Initial revision
This commit is contained in:
cvs
318
difrac/orcel2.f
Normal file
318
difrac/orcel2.f
Normal file
@@ -0,0 +1,318 @@
|
||||
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
|
||||
Reference in New Issue
Block a user