PSI sics-cvs-psi_pre-ansto

difrac/rcpcor.f

@@ -0,0 +1,125 @@
+C-----------------------------------------------------------------------
+C  This subroutine calculates the reciprocal coordinates of a reflection
+C  Called by 3 commands :--
+C  AH - to convert Euler angles to h,k,l
+C  MR - to convert direct beam Euler angles to h,k,l
+C  FI - to convert face indexing Euler angles to h,k,l
+C-----------------------------------------------------------------------
+      SUBROUTINE RCPCOR
+      INCLUDE 'COMDIF'
+      DIMENSION RM1(3,3),XA(3),HA(3)
+      CHARACTER STRING*80
+      IF (KI .EQ. 'AH') THEN
+        WRITE (COUT,10000)
+        CALL GWRITE (ITP,' ')
+      ENDIF
+      CALL MATRIX (R,RM1,RJUNK,RJUNK,'INVERT')
+  100 IF (KI .EQ. 'MR') THEN
+        CALL ANGET (THETAS,OMEGS,CHIS,PHIS)
+        OMEGS = OMEGS - 90.0 + 0.5*THETAS
+      ELSE IF (KI .EQ. 'FI') THEN
+        THETAS = THETA
+        OMEGS  = OMEGA
+        CHIS   = CHI
+        PHIS   = PHI
+      ELSE
+        WRITE (COUT,11000)
+        CALL FREEFM (ITR)
+        IF (RFREE(1) .EQ. 0) THEN
+          KI = ' '
+          RETURN 
+        ENDIF
+        THETAS = RFREE(1)
+        OMEGS  = RFREE(2)
+        CHIS   = RFREE(3)
+        PHIS   = RFREE(4)
+      ENDIF
+      CO = COS(OMEGS/DEG)
+      SO = SIN(OMEGS/DEG)
+      CC = COS(CHIS/DEG)
+      SC = SIN(CHIS/DEG)
+      CP = COS(PHIS/DEG)
+      SP = SIN(PHIS/DEG)
+      ESS = 2.0*SIN(THETAS/(2.0*DEG))
+      XA(1) = ESS*(CO*CC*CP - SO*SP)
+      XA(2) = ESS*(CO*CC*SP + SO*CP)
+      XA(3) = ESS*CO*SC
+      CALL MATRIX (RM1,XA,HA,RJUNK,'MVMULT')
+      WRITE (COUT,12000) HA
+      CALL GWRITE (ITP,' ')
+      IF (KI .EQ. 'MR') KI = ' '
+      IF (KI .EQ. 'MR' .OR. KI .EQ. 'FI') RETURN
+      GO TO 100
+10000 FORMAT (' Calculate Reciprocal Coordinates ')
+11000 FORMAT (' Type the reflection angles (End) ',$)
+12000 FORMAT (5X,' Reciprocal Coordinates (h,k,l)',3F10.3)
+      END
+C-----------------------------------------------------------------------
+C  Index faces for ABSORP when they are set so that the face normal is 
+C  in the equator plane and normal to the microscope viewing direction
+C  at the Kappa angles -45, 78, kappa (-60 start), phi (0 start)
+C-----------------------------------------------------------------------
+      SUBROUTINE FACEIN
+      CHARACTER STRING*80 
+      INCLUDE 'COMDIF'
+      DATA ISENSE/-1/
+      NATT = 0
+      ICOL = 0
+C-----------------------------------------------------------------------
+C  Set the microscope to the initial viewing position and print message
+C  The viewing position Kappa angles are -45, 78, -60, 0  
+C  The Euler equivalent is used below.
+C-----------------------------------------------------------------------
+      THETA = -90.0
+      OMEGA = 102.63
+      CHI   = -45.0
+      PHI   = -20.37
+      CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
+      WRITE (COUT,10000) 
+      CALL GWRITE (ITP,' ')
+C-----------------------------------------------------------------------
+C  Get the adjusted angles and transform them
+C-----------------------------------------------------------------------
+  100 WRITE (COUT,11000)
+      CALL ALFNUM (STRING)
+      ANS = STRING(1:1)
+C      write (cout,99990)
+C99990 format (' Type omk, kap, phk for face ',$)
+C      call freefm (itr)
+C      omk = rfree(1)
+C      if (omk .eq. 0) omk = 78.0
+C      rka = rfree(2)
+C      phk = rfree(3)
+C      call eulkap (1,omega,chi,phi,omk,rka,phk,isttus)
+C99991 format (i3,7f8.2)
+      CALL ANGET (THETA,OMEGA,CHI,PHI)
+      CALL EULKAP (0,OMEGA,CHI,PHI,OMK,RKA,PHK,ISTTUS)
+C      i = 2
+C      write (COUT,99991) i,theta,omega,chi,phi,omk,rka,phk
+C      call gwrite (itp, ' ')
+C      OMK = OMK - 135.0
+      IRL = 1
+      IF (ANS .EQ. 'L') IRL = 0
+      OMK = OMK - IRL*180.0
+      CALL EULKAP (1,OMEGA,CHI,PHI,OMK,RKA,PHK,ISTTUS)
+      THETA = 20.0
+C      i = 3
+C      write (COUT,99991) i,theta,omega,chi,phi,omk,rka,phk
+C      call gwrite (itp, ' ')
+      CALL RCPCOR
+      WRITE (COUT,12000)
+      CALL YESNO ('Y',ANS)
+      IF (ANS .EQ. 'Y') GO TO 100
+      KI = ' '
+      RETURN
+10000 FORMAT (/20X,'  CAD-4 Face Indexing'/
+     $        '   Adjust Kappa and Phi with the pocket terminal,',
+     $        ' so that the face-normal is'/
+     $        ' a. Horizontal,'/
+     $        ' b. Normal to the view direction, pointing right',
+     $           ' or left.')
+11000 FORMAT (' When the face is set correctly, type R or L to',
+     $        ' indicate whether'/
+     $        ' the normal is pointing to the Right or Left (R) ',$)
+12000 FORMAT (/' Index another face (Y) ? ',$)
+      END