Initial revision
This commit is contained in:
cvs
211
difrac/ormat3.f
Normal file
211
difrac/ormat3.f
Normal file
@@ -0,0 +1,211 @@
|
||||
C-----------------------------------------------------------------------
|
||||
C Subroutine to calculate the orientation matrix from three
|
||||
C non-collinear reflections forming a right-handed system.
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE ORMAT3
|
||||
INCLUDE 'COMDIF'
|
||||
DIMENSION TH(3),OM(3),CH(3),PH(3),THE(3,3),HM(3,3),HMI(3,3),
|
||||
$ ANGS(3)
|
||||
CHARACTER INTFLT*3
|
||||
IF (KI .EQ. 'M3') THEN
|
||||
WRITE (COUT,10000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
KI = ' '
|
||||
ENDIF
|
||||
ENDIF
|
||||
DO 90 I = 1,3
|
||||
DO 90 J = 1,3
|
||||
ROLD(I,J) = R(I,J)/WAVE
|
||||
90 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C Part 1: Read in wavelength and data for the 3 reflections and then
|
||||
C form the H matrix. Used by M3 and RS and OP (LISTER)
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'M3' .OR. KI .EQ. 'RS' .OR. KI .EQ. 'OP') THEN
|
||||
IF (KI .NE. 'OP') THEN
|
||||
WRITE (COUT,11000) WAVE
|
||||
CALL FREEFM (ITR)
|
||||
WAV = RFREE(1)
|
||||
IF (WAV .NE. 0) WAVE = WAV
|
||||
ENDIF
|
||||
ANS = 'N'
|
||||
IF (KI .EQ. 'M3') THEN
|
||||
WRITE (COUT,12000)
|
||||
CALL YESNO ('N',ANS)
|
||||
IF (KI .EQ. 'M3' .AND. ANS .EQ. 'N') THEN
|
||||
WRITE (COUT, 12100)
|
||||
CALL GWRITE (ITP, ' ')
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
DO 100 J = 1,3
|
||||
HM(1,J) = IHK(J)
|
||||
HM(2,J) = NREFB(J)
|
||||
HM(3,J) = ILA(J)
|
||||
TH(J) = BCOUNT(J)
|
||||
OM(J) = BBGR1(J)
|
||||
CALL MOD360 (OM(J))
|
||||
CH(J) = BBGR2(J)
|
||||
CALL MOD360 (CH(J))
|
||||
PH(J) = BTIME(J)
|
||||
IF (KI .EQ. 'M3') THEN
|
||||
WRITE (COUT,12200) IHK(J),NREFB(J),ILA(J),BCOUNT(J),
|
||||
$ BBGR1(J),BBGR2(J),BTIME(J)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
WRITE (COUT,13000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
DO 110 J = 1,3
|
||||
WRITE (COUT,14000)
|
||||
CALL FREEFM (ITR)
|
||||
HM(1,J) = RFREE(1)
|
||||
HM(2,J) = RFREE(2)
|
||||
HM(3,J) = RFREE(3)
|
||||
TH(J) = RFREE(4)
|
||||
OM(J) = RFREE(5)
|
||||
CH(J) = RFREE(6)
|
||||
PH(J) = RFREE(7)
|
||||
TH(J) = TH(J)
|
||||
OM(J) = OM(J)
|
||||
CALL MOD360 (OM(J))
|
||||
CH(J) = CH(J)
|
||||
CALL MOD360 (CH(J))
|
||||
110 CONTINUE
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Calculate the elements of the THETA matrix
|
||||
C-----------------------------------------------------------------------
|
||||
DO 120 J = 1,3
|
||||
SLTEMP = 2.0*SIN((0.5*TH(J))/DEG)/WAVE
|
||||
THE(1,J) = (COS(OM(J)/DEG)*COS(CH(J)/DEG)*COS(PH(J)/DEG) -
|
||||
$ SIN(OM(J)/DEG)*SIN(PH(J)/DEG))*SLTEMP
|
||||
THE(2,J) = (COS(OM(J)/DEG)*COS(CH(J)/DEG)*SIN(PH(J)/DEG) +
|
||||
$ SIN(OM(J)/DEG)*COS(PH(J)/DEG))*SLTEMP
|
||||
THE(3,J) = (COS(OM(J)/DEG)*SIN(CH(J)/DEG))*SLTEMP
|
||||
120 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C Invert the H matrix and form the R matrix
|
||||
C-----------------------------------------------------------------------
|
||||
CALL MATRIX (HM,HMI,HMI,HMI,'INVERT')
|
||||
CALL MATRIX (THE,HMI,R,R,'MATMUL')
|
||||
C-----------------------------------------------------------------------
|
||||
C Evaluate the determinant to decide if right or left handed
|
||||
C-----------------------------------------------------------------------
|
||||
DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) -
|
||||
$ R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) +
|
||||
$ R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1))
|
||||
IF (NRC*DET .EQ. 0) THEN
|
||||
WRITE (LPT,15000)
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
IF (NRC*DET .GT. 0) THEN
|
||||
WRITE (LPT,16000) KI,((R(I,J),J = 1,3),I = 1,3)
|
||||
ELSE
|
||||
WRITE (LPT,17000) KI,((R(I,J),J = 1,3),I = 1,3)
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF (KI .EQ. 'OM') THEN
|
||||
DO 130 I = 1,3
|
||||
DO 130 J = 1,3
|
||||
R(I,J) = R(I,J)/WAVE
|
||||
130 CONTINUE
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Get the real and reciprocal cell parameters
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .NE. 'RA') THEN
|
||||
CALL GETPAR
|
||||
WRITE (LPT,18000) APS,CANGS
|
||||
WRITE (LPT,19000) AP,CANG
|
||||
C-----------------------------------------------------------------------
|
||||
C Calculate SANG, CANG, SANGS and CANGS for COMMON and put R right
|
||||
C-----------------------------------------------------------------------
|
||||
DO 160 I = 1,3
|
||||
SANG(I) = SIN(CANG(I)/DEG)
|
||||
CANG(I) = COS(CANG(I)/DEG)
|
||||
SANGS(I) = SIN(CANGS(I)/DEG)
|
||||
CANGS(I) = COS(CANGS(I)/DEG)
|
||||
DO 160 J = 1,3
|
||||
R(I,J) = R(I,J)*WAVE
|
||||
160 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C Calculate the symmetry matrix SINABS, unless called from LISTER (OP)
|
||||
C or M3 when it will be done only if the new matrix is retained.
|
||||
C-----------------------------------------------------------------------
|
||||
ISYS = 1
|
||||
IF (KI .NE. 'OP' .AND. KI .NE. 'M3') CALL SINMAT
|
||||
IF (KI .NE. 'M3') KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C RA calculates angles for given h,k,l values RA
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'RA') THEN
|
||||
DPSI = 0.0
|
||||
200 WRITE (COUT,20000)
|
||||
CALL FREEFM (ITR)
|
||||
IH = IFREE(1)
|
||||
IK = IFREE(2)
|
||||
IL = IFREE(3)
|
||||
RH = RFREE(1)
|
||||
RK = RFREE(2)
|
||||
RL = RFREE(3)
|
||||
INTFLT = 'INT'
|
||||
IF (ABS(RH - IH) .GT. 0.0001 .OR.
|
||||
$ ABS(RK - IK) .GT. 0.0001 .OR.
|
||||
$ ABS(RL - IL) .GT. 0.0001) INTFLT = 'FLT'
|
||||
IF (INTFLT .EQ. 'INT' .AND.
|
||||
$ IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
PSI = RFREE(4)
|
||||
C-----------------------------------------------------------------------
|
||||
C Give a value to DPSI for ANGCAL calculation to proceed for PSI .NE. 0
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ABS(PSI) .GT. 0.0001) DPSI = 10.0
|
||||
ISTAN = 0
|
||||
IPRVAL = 1
|
||||
CALL ANGCAL
|
||||
IF (IROT .NE. 0) THEN
|
||||
IF (INTFLT .EQ. 'INT') THEN
|
||||
WRITE (COUT,22000) IH,IK,IL,PSI
|
||||
ELSE
|
||||
WRITE (COUT,22100) RH,RK,RL,PSI
|
||||
ENDIF
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (IVALID .EQ. 0 .AND. IROT .EQ. 0) THEN
|
||||
IF (INTFLT .EQ. 'INT') THEN
|
||||
WRITE (COUT,23000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI
|
||||
ELSE
|
||||
WRITE (COUT,23100) RH,RK,RL,THETA,OMEGA,CHI,PHI,PSI
|
||||
ENDIF
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
GO TO 200
|
||||
ENDIF
|
||||
10000 FORMAT (' Orientation Matrix from 3 Reflections (Y) ? ',$)
|
||||
11000 FORMAT (' Type the Wavelength (',F7.5,') ',$)
|
||||
12000 FORMAT (' Are the angles to be typed (N) ? ',$)
|
||||
12100 FORMAT (' The three reflections being used are')
|
||||
12200 FORMAT (3I4,4F8.3)
|
||||
13000 FORMAT (' Type h,k,l,2Theta,Omega,Chi,Phi ')
|
||||
14000 FORMAT (' > ',$)
|
||||
15000 FORMAT (' The determinant of the matrix is 0.')
|
||||
16000 FORMAT (/' RIGHT-handed Orientation Matrix from ',A2/(3F12.8))
|
||||
17000 FORMAT (/' LEFT-handed Orientation Matrix from ',A2/(3F12.8))
|
||||
18000 FORMAT (/' a* ',F8.5,' b* ',F8.5,' c* ',F8.5,
|
||||
$ ' Alf* ',F7.3,' Bet* ',F7.3,' Gam* ',F7.3)
|
||||
19000 FORMAT (' a ',F8.5,' b ',F8.5,' c ',F8.5,
|
||||
$ ' Alf ',F7.3,' Bet ',F7.3,' Gam ',F7.3/)
|
||||
20000 FORMAT (' Type h,k,l,Psi (End) '$)
|
||||
22000 FORMAT (3I4,' Psi ',F7.3,' Rotation not possible')
|
||||
22100 FORMAT (3F8.3,' Psi ',F7.3,' Rotation not possible')
|
||||
23000 FORMAT (3I4,5F8.3)
|
||||
23100 FORMAT (8F8.3)
|
||||
END
|
||||
Reference in New Issue
Block a user