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