212 lines
7.9 KiB
Fortran
212 lines
7.9 KiB
Fortran
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
|