185 lines
6.3 KiB
Fortran
185 lines
6.3 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Subroutine to set a specified direct lattice row:--
|
|
C Along the Omega rotation axis (PR) or
|
|
C Along the x-ray beam (PL).
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE SETROW
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION HKL(3),DICOS(3),RM1(3,3),VEC(3)
|
|
IF (KI .EQ. 'PL') THEN
|
|
WRITE (COUT,10000)
|
|
ELSE
|
|
WRITE (COUT,11000)
|
|
ENDIF
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
WRITE (COUT,12000)
|
|
CALL FREEFM (ITR)
|
|
IH = IFREE(1)
|
|
IK = IFREE(2)
|
|
IL = IFREE(3)
|
|
HKL(1) = IH
|
|
HKL(2) = IK
|
|
HKL(3) = IL
|
|
C-----------------------------------------------------------------------
|
|
C The inverse transpose of the UB matrix of Busing and Levy (here R)
|
|
C allows Direct rather than Reciprocal rows to be set.
|
|
C-----------------------------------------------------------------------
|
|
100 CALL MATRIX (R,RM1,CRAP,CRAP,'INVERT')
|
|
CALL MATRIX (HKL,RM1,DICOS,CRAP,'VECMAT')
|
|
PHI = ATAN(DICOS(2)/DICOS(1))*DEG
|
|
IF (DICOS(1) .LT. 0) PHI = PHI + 180.0
|
|
CALL MOD360 (PHI)
|
|
CHI = ASIN(DICOS(3))*DEG
|
|
C-----------------------------------------------------------------------
|
|
C Bring the positive end of the row up (CHI = CHI + 90)
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'PR') THEN
|
|
CALL MATRIX (HKL,RM1,VEC,CRAP,'VMMULT')
|
|
PER = WAVE*SQRT(VEC(1)*VEC(1) + VEC(2)*VEC(2)+ VEC(3)*VEC(3))
|
|
WRITE (COUT,13000) PER
|
|
CALL FREEFM (ITR)
|
|
DIST = RFREE(1)
|
|
IF (DIST .NE. 0.) THEN
|
|
WRITE (COUT,14000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 110 N = 1,10
|
|
DSIN = N*WAVE/PER
|
|
IF (DSIN .LE. 0.71) THEN
|
|
VEL = DIST*TAN(ASIN(DSIN))
|
|
VEL = VEL*2
|
|
WRITE (COUT,15000) N,VEL
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
110 CONTINUE
|
|
ENDIF
|
|
THETA = 0.0
|
|
OMEGA = 0.0
|
|
CHI = CHI + 90.0
|
|
CALL MOD360(CHI)
|
|
ICC = 0
|
|
WRITE (COUT,16000) THETA,OMEGA,CHI,PHI
|
|
CALL GWRITE (ITP,' ')
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL)
|
|
IF (ICOL .NE. 0) THEN
|
|
WRITE (COUT,17000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Set up for Laue photos PL
|
|
C A direct lattice row is set along the direct beam by :--
|
|
C setting CHI = 90, PHI = PHI + 90 and OMEGA = CHI, but because of
|
|
C restrictions on the OMEGA motion, OMEGA may not be greater than OLIM.
|
|
C This means that the original CHI must be within OLIM degrees of the
|
|
C OMEGA axis
|
|
C-----------------------------------------------------------------------
|
|
CALL MOD360 (CHI)
|
|
OLIM = 47.0
|
|
IF (CHI .GE. 180-OLIM .AND. CHI .LE. 180+OLIM) THEN
|
|
WRITE (COUT,18000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') THEN
|
|
IH = -IH
|
|
IK = -IK
|
|
IL = -IL
|
|
GO TO 100
|
|
ENDIF
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
IF (CHI .GT. OLIM .AND. CHI .LT. 360-OLIM) THEN
|
|
WRITE (COUT,19000)
|
|
CALL GWRITE (ITP,' ')
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
OMEGA = CHI
|
|
CHI = 90.0
|
|
PHI = PHI + 90.0
|
|
CALL MOD360 (PHI)
|
|
THETA = 0.0
|
|
WRITE (COUT,20000) IH,IK,IL,THETA,OMEGA,CHI,PHI
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Find the azimuths of given reciprocal vectors
|
|
C-----------------------------------------------------------------------
|
|
ICC = 0
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL)
|
|
IF (ICOL .EQ. 0) THEN
|
|
WRITE (COUT,17000)
|
|
CALL GWRITE (ITP,' ')
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Direction cosines of the line along the vertical
|
|
C-----------------------------------------------------------------------
|
|
XU = COS((PHI)/DEG)
|
|
YU = SIN((PHI)/DEG)
|
|
ZU = 0.
|
|
C-----------------------------------------------------------------------
|
|
C Direction cosines of the line along the diffraction vector
|
|
C-----------------------------------------------------------------------
|
|
XD = COS((90.0 - OMEGA)/DEG)*COS((90.0 + PHI)/DEG)
|
|
YD = COS((90.0 - OMEGA)/DEG)*SIN((90.0 + PHI)/DEG)
|
|
ZD = SIN((90.0 - OMEGA)/DEG)
|
|
WRITE (COUT,21000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
WRITE (COUT,22000)
|
|
CALL GWRITE (ITP,' ')
|
|
120 WRITE (COUT,23000)
|
|
CALL FREEFM (ITR)
|
|
IH = IFREE(1)
|
|
IK = IFREE(2)
|
|
IL = IFREE(3)
|
|
HKL(1) = IH
|
|
HKL(2) = IK
|
|
HKL(3) = IL
|
|
CALL MATRIX (R,HKL,DICOS,CRAP,'MATVEC')
|
|
SU = XU*DICOS(1) + YU*DICOS(2) + ZU*DICOS(3)
|
|
SD = XD*DICOS(1) + YD*DICOS(2) + ZD*DICOS(3)
|
|
SN = SQRT(SU*SU + SD*SD)
|
|
ANG = ACOS(SU/SN)*DEG
|
|
IF (SD .LT. 0) ANG = -ANG
|
|
WRITE (COUT,24000) ANG
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') GO TO 120
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (' Set for a Laue Pattern along a given row (Y) ? ',$)
|
|
11000 FORMAT (' Set a Direct Lattice Row upwards along the Omega',
|
|
$ ' Rotation Axis',/,
|
|
$ ' Confirm (Y) ',$)
|
|
12000 FORMAT (' Type the indices of the row ',$)
|
|
13000 FORMAT (' The Periodicity for a Primitive Lattice is ',F10.3,
|
|
$ ' Angstroms',/,
|
|
$ ' Type the Crystal-to-Film Distance in mms ',$)
|
|
14000 FORMAT (' Separation in mm between the + and - nth levels')
|
|
15000 FORMAT (5X,I2,F10.1)
|
|
16000 FORMAT (' Setting angles ',4F10.3)
|
|
17000 FORMAT (' Setting Collisions. The row cannot be set')
|
|
18000 FORMAT (' hkl CANNOT be set, but -h-k-l can. OK (Y) ? ',$)
|
|
19000 FORMAT (' The setting is NOT feasible')
|
|
20000 FORMAT (' Setting angles for row',3I4,4F10.3,/,
|
|
$ ' Set it (Y) ? ',$)
|
|
21000 FORMAT (' Are you interested in the azimuth for given reciprocal',
|
|
$ ' vectors. (Y) ? ',$)
|
|
22000 FORMAT (' Origin of azimuths UP, + toward diffraction vector.')
|
|
23000 FORMAT (' Type the h k l ',$)
|
|
24000 FORMAT (20X,'Azimuth ',F10.1,' degrees. More vectors (Y) ? ',$)
|
|
END
|