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