319 lines
12 KiB
Fortran
319 lines
12 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Subroutine to calculate the orientation matrix from the cell
|
|
C parameters and two non-collinear reflections.
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE ORCEL2
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION JH(2),JK(2),JL(2),OM(2),CH(2),PH(2),ANG(3),T(3,3),
|
|
$ XP(2),YP(2),ZP(2),SC(3,3),SPH(3,3),SCT(3,3),RO(3,3)
|
|
EQUIVALENCE(NREFB(7),ANG(1))
|
|
IF (KI .EQ. 'OC') THEN
|
|
ANG(1) = CANG(1)
|
|
ANG(2) = CANG(2)
|
|
ANG(3) = CANG(3)
|
|
GO TO 130
|
|
ENDIF
|
|
IF (KI .NE. 'RO' .AND. KI .NE. 'O4') THEN
|
|
WRITE (COUT,10000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
DO 90 I = 1,3
|
|
DO 90 J = 1,3
|
|
ROLD(I,J) = R(I,J)/WAVE
|
|
90 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Read Wavelength, Cell parameters and data for the 2 reflections
|
|
C-----------------------------------------------------------------------
|
|
95 WRITE (COUT,13000) WAVE
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .NE. 0.) WAVE = RFREE(1)
|
|
WRITE (COUT,15000)
|
|
CALL FREEFM (ITR)
|
|
AP(1) = RFREE(1)
|
|
AP(2) = RFREE(2)
|
|
AP(3) = RFREE(3)
|
|
ANG(1) = RFREE(4)
|
|
ANG(2) = RFREE(5)
|
|
ANG(3) = RFREE(6)
|
|
WRITE (COUT,16000) WAVE,AP,ANG
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') GO TO 95
|
|
WRITE (COUT,17000)
|
|
CALL YESNO ('N',ANS)
|
|
C-----------------------------------------------------------------------
|
|
C Typed input. Test it for h=k=l=0; collinear h,k,ls; collinear angles
|
|
C-----------------------------------------------------------------------
|
|
IF (ANS .EQ. 'Y') THEN
|
|
96 WRITE (COUT,22000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 100 J = 1,2
|
|
97 WRITE (COUT,26000) J
|
|
CALL FREEFM (ITR)
|
|
IHK(J) = IFREE(1)
|
|
NREFB(J) = IFREE(2)
|
|
ILA(J) = IFREE(3)
|
|
IF (IFREE(1) .EQ. 0 .AND.
|
|
$ IFREE(2) .EQ. 0 .AND.
|
|
$ IFREE(3) .EQ. 0) THEN
|
|
WRITE (COUT,16100)
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 97
|
|
ENDIF
|
|
BBGR1(J) = RFREE(4)
|
|
BBGR2(J) = RFREE(5)
|
|
BTIME(J) = RFREE(6)
|
|
100 CONTINUE
|
|
TOP = IHK(1)*IHK(2) + NREFB(1)*NREFB(2) + ILA(1)*ILA(2)
|
|
BOT = IHK(1)*IHK(1) + NREFB(1)*NREFB(1) + ILA(1)*ILA(1) +
|
|
$ IHK(2)*IHK(2) + NREFB(2)*NREFB(2) + ILA(2)*ILA(2)
|
|
TOP = ABS(TOP/SQRT(BOT))
|
|
IF (TOP .GT. 0.999) THEN
|
|
WRITE (COUT,16200)
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 96
|
|
ENDIF
|
|
DO 105 I = 1,2
|
|
OM(I) = BBGR1(I) - DOMEGA
|
|
CALL MOD360 (OM(I))
|
|
CH(I) = BBGR2(I) - DCHI
|
|
CALL MOD360 (CH(I))
|
|
PH(I) = BTIME(I)
|
|
XP(I) = COS(CH(I)/DEG)*COS(PH(I)/DEG)*COS(OM(I)/DEG) -
|
|
$ SIN(OM(I)/DEG)*SIN(PH(I)/DEG)
|
|
YP(I) = COS(OM(I)/DEG)*COS(CH(I)/DEG)*SIN(PH(I)/DEG) +
|
|
$ SIN(OM(I)/DEG)*COS(PH(I)/DEG)
|
|
ZP(I) = NRC*COS(OM(I)/DEG)*SIN(CH(I)/DEG)
|
|
105 CONTINUE
|
|
TOP = XP(1)*XP(2) + YP(1)*YP(2) + ZP(1)*ZP(2)
|
|
IF (TOP .GT. 0.999) THEN
|
|
WRITE (COUT,16210)
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 96
|
|
ENDIF
|
|
WRITE (COUT,16300) (IHK(J),NREFB(J),ILA(J),
|
|
$ BBGR1(J),BBGR2(J),BTIME(J),J = 1,2)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') GO TO 96
|
|
ELSE
|
|
WRITE (COUT,19000)
|
|
$ IHK(1), NREFB(1), ILA(1), BBGR1(1), BBGR2(1), BTIME(1),
|
|
$ IHK(2), NREFB(2), ILA(2), BBGR1(2), BBGR2(2), BTIME(2)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') THEN
|
|
WRITE (COUT,20000)
|
|
CALL FREEFM (ITR)
|
|
IHK(1) = IFREE(1)
|
|
NREFB(1) = IFREE(2)
|
|
ILA(1) = IFREE(3)
|
|
IHK(2) = IFREE(4)
|
|
NREFB(2) = IFREE(5)
|
|
ILA(2) = IFREE(6)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
DO 110 I = 1,3
|
|
CANG(I) = COS(ANG(I)/DEG)
|
|
SANG(I) = SIN(ANG(I)/DEG)
|
|
110 CONTINUE
|
|
130 DO 140 J = 1,2
|
|
JH(J) = IHK(J)
|
|
JK(J) = NREFB(J)
|
|
JL(J) = ILA(J)
|
|
OM(J) = BBGR1(J) - DOMEGA
|
|
CALL MOD360 (OM(J))
|
|
CH(J) = BBGR2(J) - DCHI
|
|
CALL MOD360 (CH(J))
|
|
PH(J) = BTIME(J)
|
|
140 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Calculate reciprocal cell dimensions
|
|
C-----------------------------------------------------------------------
|
|
CANGS(1) = ((CANG(2)*CANG(3)) - CANG(1))/(SANG(2)*SANG(3))
|
|
CANGS(2) = ((CANG(1)*CANG(3)) - CANG(2))/(SANG(1)*SANG(3))
|
|
CANGS(3) = ((CANG(1)*CANG(2)) - CANG(3))/(SANG(1)*SANG(2))
|
|
DO 150 I = 1,3
|
|
SANGS(I) = SQRT(1.0-CANGS(I)**2)
|
|
150 CONTINUE
|
|
APS(1) = 1.0/(AP(1)*SANGS(2)*SANG(3))
|
|
APS(2) = 1.0/(AP(2)*SANGS(1)*SANG(3))
|
|
APS(3) = 1.0/(AP(3)*SANGS(1)*SANG(2))
|
|
C-----------------------------------------------------------------------
|
|
C T-matrix
|
|
C-----------------------------------------------------------------------
|
|
T(1,1) = APS(1)
|
|
T(1,2) = APS(2)*CANGS(3)
|
|
T(1,3) = APS(3)*CANGS(2)
|
|
T(2,1) = 0.0
|
|
T(2,2) = APS(2)*SANGS(3)
|
|
T(2,3) = -APS(3)*SANGS(2)*CANG(1)
|
|
T(3,3) = 1.0/AP(3)
|
|
T(3,1) = 0.0
|
|
T(3,2) = 0.0
|
|
C-----------------------------------------------------------------------
|
|
C Form X,Y,Z for H1C and H2C vectors
|
|
C-----------------------------------------------------------------------
|
|
DO 160 I = 1,2
|
|
XP(I) = T(1,1)*JH(I) + T(1,2)*JK(I) + T(1,3)*JL(I)
|
|
YP(I) = T(2,2)*JK(I) + T(2,3)*JL(I)
|
|
ZP(I) = T(3,3)*JL(I)
|
|
160 CONTINUE
|
|
MARK = 0
|
|
C-----------------------------------------------------------------------
|
|
C Call ORCELS to form the SC matrix
|
|
C-----------------------------------------------------------------------
|
|
CALL ORCELS (XP,YP,ZP,SC,MARK)
|
|
IF (MARK .NE. 0) RETURN
|
|
C-----------------------------------------------------------------------
|
|
C Form X,Y,Z, for U1PHI and U2PHI vectors
|
|
C-----------------------------------------------------------------------
|
|
DO 170 I = 1,2
|
|
XP(I) = COS(CH(I)/DEG)*COS(PH(I)/DEG)*COS(OM(I)/DEG) -
|
|
$ SIN(OM(I)/DEG)*SIN(PH(I)/DEG)
|
|
YP(I) = COS(OM(I)/DEG)*COS(CH(I)/DEG)*SIN(PH(I)/DEG) +
|
|
$ SIN(OM(I)/DEG)*COS(PH(I)/DEG)
|
|
ZP(I) = NRC*COS(OM(I)/DEG)*SIN(CH(I)/DEG)
|
|
170 CONTINUE
|
|
MARK = 0
|
|
C-----------------------------------------------------------------------
|
|
C Call ORCELS to form the SPH matrix
|
|
C-----------------------------------------------------------------------
|
|
CALL ORCELS (XP,YP,ZP,SPH,MARK)
|
|
IF (MARK .NE. 0) RETURN
|
|
DO 180 I = 1,3
|
|
DO 180 J = 1,3
|
|
SCT(J,I) = SC(I,J)
|
|
180 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Form the RO and R matrices
|
|
C-----------------------------------------------------------------------
|
|
CALL MATRIX (SPH,SCT,RO,RO,'MATMUL')
|
|
CALL MATRIX (RO,T,R,R,'MATMUL')
|
|
C-----------------------------------------------------------------------
|
|
C The R matrix is truly right handed, change for NRC diffractometer
|
|
C-----------------------------------------------------------------------
|
|
DO 190 J = 1,3
|
|
R(3,J) = NRC*R(3,J)
|
|
190 CONTINUE
|
|
IF (KI .EQ. 'M2') THEN
|
|
WRITE (COUT,24000)
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (COUT,25000) ((R(I,J),J = 1,3),I = 1,3)
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,24000)
|
|
WRITE (LPT,25000) ((R(I,J),J = 1,3),I = 1,3)
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Store R matrix times Wavelength
|
|
C-----------------------------------------------------------------------
|
|
DO 200 I = 1,3
|
|
DO 200 J = 1,3
|
|
R(I,J) = R(I,J)*WAVE
|
|
200 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Calculate symmetry matrix SINABS. Done for M2 in BASINP only if the
|
|
C new matrix is retained.
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .NE. 'M2') THEN
|
|
ISYS = 1
|
|
CALL SINMAT
|
|
ENDIF
|
|
RETURN
|
|
10000 FORMAT (' Orientation Matrix from Cell + 2 Non-Collinear',
|
|
$ ' Reflections (Y) ',$)
|
|
13000 FORMAT (' Type the wavelength (',F7.5,') ',$)
|
|
15000 FORMAT (' Type a,b,c,alpha,beta,gamma ',$)
|
|
16000 FORMAT (' The input values are :-- Wavelength',F8.5/
|
|
$ ' Cell Parameters',3F9.4,3F9.3/
|
|
$ ' Is this correct (Y) ? ',$)
|
|
16100 FORMAT (' The reflection 0,0,0 is invalid. Try again.')
|
|
16200 FORMAT (' The reflection indices typed are collinear. Try again.')
|
|
16210 FORMAT (' The reflection angles typed are collinear. Try again.')
|
|
16300 FORMAT (' The input values are :--',2(/3I4,3F9.3)/
|
|
$ ' Is this correct (Y) ? ',$)
|
|
17000 FORMAT (' Are angles to be typed (N) ? ',$)
|
|
19000 FORMAT (' The two reflections being used are ',2(/3I4,3F8.3)/
|
|
$ ' Do you wish to edit the reflection indices (Y) ? ')
|
|
20000 FORMAT (' Type the new h1,k1,l1 and h2,k2,l2 ',$)
|
|
22000 FORMAT (' Type h,k,l, Omega, Chi, Phi for 2 non-collinear',
|
|
$ ' reflections')
|
|
24000 FORMAT (/' Orientation Matrix from M2')
|
|
25000 FORMAT (3F12.8)
|
|
26000 FORMAT (' Reflection,',I2,' > ',$)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Subroutine to calculate the S matrices for ORCEL2
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE ORCELS (XP,YP,ZP,SC,MARK)
|
|
COMMON /IODEVS/ ITP,ITR,LPT,LPTX,NB,NBLOCK,ISD,IID,
|
|
$ IBYLEN,IPR,NPR,IIP
|
|
CHARACTER*132 COUT(20)
|
|
COMMON /IOUASC/ COUT
|
|
DIMENSION XP(3),YP(3),ZP(3),SC(3,3),AL(4),AM(4),AN(4)
|
|
MARK = 0
|
|
DEN = SQRT(XP(1)*XP(1) + YP(1)*YP(1) + ZP(1)*ZP(1))
|
|
AL(1) = XP(1)/DEN
|
|
AM(1) = YP(1)/DEN
|
|
AN(1) = ZP(1)/DEN
|
|
DEN = SQRT(XP(2)*XP(2) + YP(2)*YP(2) + ZP(2)*ZP(2))
|
|
AL(4) = XP(2)/DEN
|
|
AM(4) = YP(2)/DEN
|
|
AN(4) = ZP(2)/DEN
|
|
BL = AM(1)*AN(4) - AM(4)*AN(1)
|
|
BM = AL(4)*AN(1) - AL(1)*AN(4)
|
|
BN = AL(1)*AM(4) - AL(4)*AM(1)
|
|
DEN = SQRT(BL*BL + BM*BM + BN*BN)
|
|
AL(3) = -BL/DEN
|
|
AM(3) = -BM/DEN
|
|
AN(3) = -BN/DEN
|
|
DEN = AL(1)*AM(3) - AM(1)*AL(3)
|
|
DIS = ABS(DEN)
|
|
AL(2) = 1.0
|
|
AM(2) = 0.0
|
|
AN(2) = 0.0
|
|
IF (DIS .GT. 0.0) THEN
|
|
ALN = (AM(1)*AN(3) - AM(3)*AN(1))/DEN
|
|
AMN = (AL(3)*AN(1) - AL(1)*AN(3))/DEN
|
|
SUM = SQRT(1.0 + ALN*ALN + AMN*AMN)
|
|
AN(2) = 1.0/SUM
|
|
AL(2) = AN(2)*ALN
|
|
AM(2) = AN(2)*AMN
|
|
ELSE
|
|
DEN = AL(1)*AN(3) - AL(3)*AN(1)
|
|
DIS = ABS(DEN)
|
|
IF (DIS .GT. 0.0) THEN
|
|
ALM = (AN(1)*AM(3) - AM(1)*AN(3))/DEN
|
|
ANM = (AL(3)*AM(1) - AL(1)*AM(3))/DEN
|
|
SUM = SQRT(1.0 + ALM*ALM + ANM*ANM)
|
|
AM(2) = 1.0/SUM
|
|
AL(2) = AM(2)*ALM
|
|
AN(2) = AM(2)*ANM
|
|
ENDIF
|
|
ENDIF
|
|
DO 100 I = 1,3
|
|
SC(1,I) = AL(I)
|
|
SC(2,I) = AM(I)
|
|
SC(3,I) = AN(I)
|
|
100 CONTINUE
|
|
DET = SC(1,1)*(SC(2,2)*SC(3,3) - SC(2,3)*SC(3,2)) -
|
|
$ SC(1,2)*(SC(2,1)*SC(3,3) - SC(2,3)*SC(3,1)) +
|
|
$ SC(1,3)*(SC(2,1)*SC(3,2) - SC(2,2)*SC(3,1))
|
|
C-----------------------------------------------------------------------
|
|
C To ensure both matrices are right handed
|
|
C-----------------------------------------------------------------------
|
|
IF (DET .EQ. 0) THEN
|
|
MARK = 1
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
IF (DET .LT. 0.0) THEN
|
|
DO 110 I = 1,3
|
|
SC(I,2) = -SC(I,2)
|
|
110 CONTINUE
|
|
ENDIF
|
|
RETURN
|
|
10000 FORMAT (' Determinant = 0')
|
|
END
|