linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial revision

Browse Source
This commit is contained in:
cvs
2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

184
difrac/setrow.f Normal file
View File

@@ -0,0 +1,184 @@
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