C (C) COPYRIGHT 1985 UNIVERSITY OF GLASGOW 0001.000 C GEOMETRY PROGRAM GEOM MARCH 1986 0002.000 C GX PACKAGE APRIL 1985 PAUL R. MALLINSON 0003.000 C 0004.000 PROGRAM GEOMPRM 0005.000 CHARACTER FSPEC(80), COMPID(72),LINE(148) 0006.000 CHARACTER*8 ATM(200), FTYPE(13),TAG,STRING 0007.000 CHARACTER*80 CBUF 0008.000 INTEGER CN(200),CONTNT(13),FIRSTC(20),FWIDTH(20) 0009.000 LOGICAL FIRST,SPPOS 0010.000 DIMENSION OM(3,3),RCP(3) 0011.000 COMMON IPRIN,LPP,ICORR,IRAD,IC(3),FIRSTC,FWIDTH,TITLE(20),X(3), 0012.000 1 S(9),P(3,3),DUM(270) 0013.000 COMMON/MODELC/COMPID,ATM,FTYPE 0014.000 COMMON/MODEL/N,NR,NLATT,NTYPE, NJD(200),XR(3,200), 0015.000 1 CN,SOF(200),UIJ(6,200),CIG(3,200),ESOF(200),SIGUIJ(6,200), 0016.000 2 WAVEL,U,V,W,COSALP,COSBET,COSGAM,ECELL(6),R(24,3,4), 0017.000 3 T(3,4),ICENT,SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 0018.000 COMMON /LIMITS/MAXYZ,MAXUIJ,MAXBON 0019.000 COMMON/ESDS/ XIG(6,200) 0020.000 COMMON/CHARA/LINE,FSPEC 0021.000 COMMON/CONSTR/NCON,ICON(99,2),EFACT(99,2) 0022.000 COMMON/OSLO/SPPOS 0023.000 EQUIVALENCE (CBUF,LINE(7)) 0024.000 DATA INTRAL,INTRAA/2*0/,IPUBS/0/,FIRST/.TRUE./,DMAX/0.0/,AMAX/0.0/0025.000 DATA INTERL,MPLANE,NDIANG/0,0,0/,BLANK/' '/,ILOC/0/,ISTOP/0/ 0026.000 DATA DMIN/0.01/ 0027.000 100 FORMAT ('0BOND DISTANCES ARE SUMS OF COVALENT RADII') 0028.000 101 FORMAT (20A4) 0029.000 102 FORMAT (80A1) 0030.000 104 FORMAT(1X,A7, F8.5,2F9.5,3F8.5,3F8.4,3F8.5) 0031.000 109 FORMAT (' ',72A1) 0032.000 209 FORMAT (' ',20A4) 0033.000 110 FORMAT('0 A =',F8.4,'(',F7.4,') B =',F8.4,'(',F7.4,') C ='0034.000 1,F8.4,'(',F7.4,')'/' ALPHA =',F8.3,'(',F6.3,') BETA =',F8.3,'(', 0035.000 2F6.3,') GAMMA =',F8.3,'(',F6.3,')') 0036.000 111 FORMAT ('0BONDS FROM',F6.2,' A TO',F6.2,' A') 0037.000 112 FORMAT( ' FRACTIONAL COORDINATES STANDARD DEVIA0038.000 1TIONS ORTHOGONAL COORDINATES (A) STANDARD DEVIATIONS') 0039.000 113 FORMAT( ' ATOM X Y Z SIGX SIGY 0040.000 1 SIGZ X Y Z SIGX SIGY SIGZ') 0041.000 114 FORMAT ('0CELL COSINES WILL BE USED AS CORRELATION COEFFICIENTS0042.000 1') 0043.000 115 FORMAT ('0****** CORRELATION MATRIX AND COORDINATES FROM ITS FI0044.000 1LE WILL BE USED FOR'/' INTERATOMIC DISTANCES AND BOND ANGLES *****0045.000 2*') 0046.000 116 FORMAT ('0ASYMMETRIC FLAG IS SET - SYMMETRY OPERATIONS WILL BE'0047.000 1/' APPLIED ONLY FOR NON-BONDED DISTANCES AND CONTACTS') 0048.000 425 FORMAT (1X,A8,' <<<<<<< COMMAND NOT RECOGNISED') 0049.000 504 FORMAT ('1') 0050.000 1041 FORMAT (1H+,105X,2F10.3) 0051.000 20000 FORMAT (' GEOM COMPLETED') 0052.000 69827 FORMAT('0ORTHOGONALISATION MATRIX FOR CARTESIAN SYSTEM DEFINED BY 0053.000 1A AND B*'/3(3F12.5/)) 0054.000 69828 FORMAT (' CELL VOLUME =',F9.2,'(',F5.2,') A**3'/) 0055.000 1222 FORMAT(1H+,107X,'COVALENT & CONTACT RADII') 0056.000 1592 FORMAT(' PLEASE TYPE COMMANDS (1ST 3 LETTERS) FROM THE LIST, TE0057.000 1RMINATED BY A BLANK LINE:'/' TITLE '/' ATOMS <SIGMA(XYZ) LI0058.000 2MIT> <SIGMA(UIJ) LIMIT> (DEFAULTS 20, 10)'/ 0059.000 3' BONDS <SIGMA(BOND LENGTH) LIMIT (DEFAULT 20)> <DMAX> <DMIN>'/ 0060.000 4' ANGLES <DMAX> <DMIN>'/' TORSION_ANGLES <DMAX> <DMIN>'/ 0061.000 5' ASYMMETRIC'/' PLANES'/' LOCAL_GEOMETRY <DMAX> <DMIN>'/ 0062.000 6' NON-BONDED_DISTANCES <DMAX> <DMIN>'/' CONTACTS <DMAX> <DMIN>'/ 0063.000 7' CORRELATIONS GIVEN'/' PRINT <NO. OF COPIES>'/' PAGE_LENGTH <NO. 0064.000 8OF LINES> (DEFAULT 35) S (FOR SINGLE COLUMN)'/' EXIT') 0065.000 1594 FORMAT ('0N.B. COVALENT & VAN DER WAALS RADII ARE USED UNLESS D0066.000 1MAX IS GIVEN') 0067.000 MAXYZ=20 0068.000 MAXUIJ=10 0069.000 MAXBON=20 0070.000 IRAD=1 0071.000 ICORR=0 0072.000 LPP=35 0073.000 STRING=' ' 0074.000 SPPOS=.FALSE. 0075.000 IPRIN=6 0076.000 NCOPS=1 0077.000 DO 2 I=1,145 0078.000 2 LINE(I)=' ' 0079.000 DO 1 I=1,3 0080.000 1 IC(I)=I 0081.000 DO 1593 I=1,20 0082.000 1593 TITLE(I)=BLANK 0083.000 C * * * * GOULD-S.E.L. ONLY * * * * * 0084.000 C CALL X:GDSPCE(15,NGET,,) 0085.000 C CALL X:GDSPCE(15,NGET,,) 0086.000 C CALL X:GDSPCE(1,NGET,,) 0087.000 C * * * * END GOULD-S.E.L. CODE * * * * 0088.000 CALL MDLIN(16) 0089.000 C THE FOLLOWING ALLOWS THE INTERATOMIC DISTANCE ROUTINE 0090.000 C TO WORK WITH ORTHOGONAL COORDINATES IN THE MODEL FILE 0091.000 IF (U.EQ.1.0.AND.V.EQ.1.0.AND.W.EQ.1.0) THEN 0092.000 U=10. 0093.000 V=10. 0094.000 W=10. 0095.000 DO 3 I=1,N 0096.000 DO 3 J=1,3 0097.000 3 XR(J,I)=XR(J,I)*0.1 0098.000 ENDIF 0099.000 501 WRITE (6,1592) 0100.000 WRITE (6,1594) 0101.000 411 READ (1,102,END=412) (LINE(I),I=2,73) 0102.000 CALL PARSE(LINE,NFIELD,FIRSTC,FWIDTH) 0103.000 IF (NFIELD.EQ.0) GO TO 412 0104.000 IF (FWIDTH(1).GT.3) FWIDTH(1)=3 0105.000 CALL AFORMT(LINE,FIRSTC(1),FWIDTH(1),TAG) 0106.000 IF (TAG.NE.'TIT') GO TO 410 0107.000 READ (CBUF,101) TITLE 0108.000 GO TO 411 0109.000 410 IF (TAG.NE.'BON') GO TO 413 0110.000 INTRAL=1 0111.000 IF(NFIELD.GT.1)CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),MAXBON) 0112.000 IF (NFIELD.GT.2) THEN 0113.000 CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMAX) 0114.000 IF (NFIELD.GT.3) CALL FFORMT(LINE,FIRSTC(4),FWIDTH(4),DMIN) 0115.000 IF (DMAX.GT.DMIN) THEN 0116.000 IRAD=0 0117.000 ELSE 0118.000 WRITE (6,999) 0119.000 999 FORMAT (' DMAX MUST BE GREATER THAN DMIN. PLEASE REPEAT') 0120.000 ENDIF 0121.000 ENDIF 0122.000 GO TO 411 0123.000 413 IF (TAG.NE.'ANG') GO TO 414 0124.000 INTRAA=1 0125.000 IF (NFIELD.GT.1) THEN 0126.000 CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),DMAX) 0127.000 IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMIN) 0128.000 IF (DMAX.GT.DMIN) THEN 0129.000 IRAD=0 0130.000 ELSE 0131.000 WRITE (6,999) 0132.000 ENDIF 0133.000 ENDIF 0134.000 GO TO 411 0135.000 414 IF (TAG.NE.'LOC') GO TO 415 0136.000 ILOC=1 0137.000 IF (NFIELD.GT.1) THEN 0138.000 CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),DMAX) 0139.000 IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMIN) 0140.000 IF (DMAX.GT.DMIN) THEN 0141.000 IRAD=0 0142.000 ELSE 0143.000 WRITE (6,999) 0144.000 ENDIF 0145.000 ENDIF 0146.000 GO TO 411 0147.000 415 IF (TAG.NE.'CON') GO TO 416 0148.000 INTERL=-1 0149.000 IF (NFIELD.GT.1) THEN 0150.000 CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),AMAX) 0151.000 IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMAX) 0152.000 IF (AMAX.GT.DMAX) THEN 0153.000 IRAD=0 0154.000 ELSE 0155.000 WRITE (6,999) 0156.000 ENDIF 0157.000 ENDIF 0158.000 GO TO 411 0159.000 416 IF (TAG.NE.'PLA') GO TO 417 0160.000 MPLANE=1 0161.000 GO TO 411 0162.000 417 IF (TAG.NE.'TOR') GO TO 418 0163.000 NDIANG=1 0164.000 IF (NFIELD.GT.1) THEN 0165.000 CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),DMAX) 0166.000 IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMIN) 0167.000 IF (DMAX.GT.DMIN) THEN 0168.000 IRAD=0 0169.000 ELSE 0170.000 WRITE (6,999) 0171.000 ENDIF 0172.000 ENDIF 0173.000 GO TO 411 0174.000 418 IF (TAG.NE.'PAG') GO TO 420 0175.000 IF (NFIELD.GT.1) CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),LPP) 0176.000 IF (NFIELD.GT.2) CALL AFORMT(LINE,FIRSTC(3),FWIDTH(3),STRING) 0177.000 GO TO 411 0178.000 420 IF (TAG.NE.'COR') GO TO 421 0179.000 ICORR=1 0180.000 GO TO 411 0181.000 421 IF (TAG.NE.'NON') GO TO 423 0182.000 INTERL=-2 0183.000 IF (NFIELD.GT.1) THEN 0184.000 CALL FFORMT(LINE,FIRSTC(2),FWIDTH(2),AMAX) 0185.000 IF (NFIELD.GT.2) CALL FFORMT(LINE,FIRSTC(3),FWIDTH(3),DMAX) 0186.000 IF (AMAX.GT.DMAX) THEN 0187.000 IRAD=0 0188.000 ELSE 0189.000 WRITE (6,999) 0190.000 ENDIF 0191.000 ENDIF 0192.000 GO TO 411 0193.000 423 IF (TAG.NE.'ATO') GO TO 424 0194.000 IF(NFIELD.GT.1)CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),MAXYZ) 0195.000 IF(NFIELD.GT.2)CALL IFORMT(LINE,FIRSTC(3),FWIDTH(3),MAXUIJ) 0196.000 IPUBS=1 0197.000 GO TO 411 0198.000 424 IF (TAG.NE.'PRI') GO TO 427 0199.000 IPRIN=3 0200.000 IF (NFIELD.GT.1) CALL IFORMT(LINE,FIRSTC(2),FWIDTH(2),NCOPS) 0201.000 GO TO 411 0202.000 427 IF (TAG.NE.'ASY') GO TO 428 0203.000 SPPOS=.TRUE. 0204.000 GO TO 411 0205.000 428 IF (TAG.EQ.'EXI') THEN 0206.000 ISTOP=1 0207.000 ELSE 0208.000 WRITE (6,425) TAG 0209.000 GO TO 411 0210.000 ENDIF 0211.000 412 WRITE (IPRIN,109) COMPID 0212.000 ICALC=NDIANG+INTRAL+INTRAA+MPLANE+ILOC+IABS(INTERL) 0213.000 IF (.NOT.FIRST) GO TO 502 0214.000 WRITE(IPRIN,209) TITLE 0215.000 SINALP=SQRT(1.-COSALP*COSALP) 0216.000 SINBET=SQRT(1.-COSBET*COSBET) 0217.000 SINGAM=SQRT(1.-COSGAM*COSGAM) 0218.000 WRITE (IPRIN,110) U,ECELL(1),V,ECELL(2),W,ECELL(3),ACOS(COSALP)* 0219.000 157.29578,ECELL(4)*57.29578/SINALP,ACOS(COSBET)*57.29578,ECELL(5)* 0220.000 257.29578/SINBET,ACOS(COSGAM)*57.29578,ECELL(6)*57.29578/SINGAM 0221.000 Q=(COSALP-COSBET*COSGAM)/SINGAM 0222.000 PZ=SINBET*SINBET-Q*Q 0223.000 PZ=SQRT(PZ) 0224.000 C FORM ORTHOGONALISATION MATRIX 0225.000 OM(1,1)=U 0226.000 OM(1,2)=V*COSGAM 0227.000 OM(1,3)=W*COSBET 0228.000 OM(2,1)=0. 0229.000 OM(2,2)=V*SINGAM 0230.000 OM(2,3)=W*Q 0231.000 OM(3,1)=0. 0232.000 OM(3,2)=0. 0233.000 OM(3,3)=W*PZ 0234.000 IF (ICALC.NE.0) WRITE (IPRIN,69827) ((OM(I,J),J=1,3),I=1,3) 0235.000 VOL=U*V*W*SQRT(1.-COSALP**2-COSBET**2-COSGAM**2+ 0236.000 12.*COSALP*COSBET*COSGAM) 0237.000 PZ=(U*V*W/VOL)**2 0238.000 EVOL=VOL*SQRT((ECELL(1)/U)**2+(ECELL(2)/V)**2+(ECELL(3)/W)**2+ 0239.000 1(PZ*(-COSALP +COSBET*COSGAM)*ECELL(4))**2+(PZ*(-COSBET +0240.000 2COSALP*COSGAM)*ECELL(5))**2+(PZ*(-COSGAM +COSALP*COSBET)* 0241.000 3ECELL(6))**2) 0242.000 WRITE (IPRIN,69828) VOL,EVOL 0243.000 REWIND 16 0244.000 IREM=0 0245.000 701 READ (16,102,END=700) (LINE(I),I=2,73) 0246.000 CALL PARSE(LINE,NFIELDS,FIRSTC,FWIDTH) 0247.000 IF (NFIELDS.EQ.0) GO TO 701 0248.000 CALL AFORMT(LINE,FIRSTC(1),3,TAG) 0249.000 IF (TAG.NE.'REM') GO TO 701 0250.000 IREM=IREM+1 0251.000 WRITE (IPRIN,109) (LINE(I),I=2,73) 0252.000 GO TO 701 0253.000 700 RCP(1)=V*W*SINALP/VOL 0254.000 RCP(2)=U*W*SINBET/VOL 0255.000 RCP(3)=U*V*SINGAM/VOL 0256.000 IF (IPRIN.NE.6.AND.ICALC.NE.0) WRITE(IPRIN,112) 0257.000 IF ((IRAD.EQ.1.OR.DMAX.EQ.0.).AND.IPRIN.NE.6.AND.ICALC.NE.0) 0258.000 1 WRITE (IPRIN,1222) 0259.000 IF (IPRIN.NE.6.AND.ICALC.NE.0) WRITE(IPRIN,113) 0260.000 DO 130 I=1,N 0261.000 C FORM VARIANCE MATRIX S 0262.000 DO 600 J=1,3 0263.000 600 S(J)=CIG(J,I)**2 0264.000 S(4)=-COSGAM*CIG(1,I)*CIG(2,I) 0265.000 S(5)=-COSBET*CIG(1,I)*CIG(3,I) 0266.000 S(6)=-COSALP*CIG(2,I)*CIG(3,I) 0267.000 CALL TRANM(S,OM,P) 0268.000 DO 601 J=1,3 0269.000 601 XIG(J,I)=P(J,J) 0270.000 XIG(4,I)=P(1,2) 0271.000 XIG(5,I)=P(1,3) 0272.000 XIG(6,I)=P(2,3) 0273.000 DO 500 J=1,3 0274.000 500 S(J)=SQRT(XIG(J,I)) 0275.000 CALL MV(OM,XR(1,I),X) 0276.000 IF (IPRIN.NE.6.AND.ICALC.NE.0) WRITE(IPRIN,104)ATM(I), 0277.000 1 (XR(J,I),J=1,3),(CIG(J,I),J=1,3),X,(S(J),J=1,3) 0278.000 IF ((IRAD.EQ.1.OR.DMAX.EQ.0.).AND.IPRIN.NE.6.AND.ICALC.NE.0) 0279.000 1 WRITE (IPRIN,1041) SFAC(13,NJD(I)),SFAC(14,NJD(I)) 0280.000 130 CONTINUE 0281.000 502 IF (IRAD.EQ.0.AND.DMAX.GT.0.) THEN 0282.000 IF (ICALC.NE.0) WRITE (IPRIN,111) DMIN,DMAX 0283.000 ELSE 0284.000 IF (ICALC.NE.0) WRITE (IPRIN,100) 0285.000 ENDIF 0286.000 IF (ICORR.EQ.0) THEN 0287.000 IF (ICALC.NE.0) WRITE (IPRIN,114) 0288.000 ELSE 0289.000 IF (ICALC.NE.0) WRITE (IPRIN,115) 0290.000 ENDIF 0291.000 IF (ICALC.NE.0.AND.SPPOS) WRITE (IPRIN,116) 0292.000 IF (IPUBS.EQ.1) CALL PUBS(RCP) 0293.000 IF(NDIANG.EQ.1) THEN 0294.000 CALL JANE(AMAX,DMAX,DMIN,OM,RCP,3) 0295.000 CALL TORSN 0296.000 ENDIF 0297.000 IF (ICORR.EQ.1) CALL ORFFEB 0298.000 IF (INTRAL.EQ.1) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,1) 0299.000 IF (INTRAA.EQ.1) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,2) 0300.000 ITABL=NDIANG+INTRAL+INTRAA+IPUBS 0301.000 IF (ITABL.NE.0) THEN 0302.000 ENDFILE 2 0303.000 REWIND 2 0304.000 ENDIF 0305.000 IF (IPRIN.NE.6) THEN 0306.000 IF ((FIRST.OR.ITABL.NE.0).AND. 0307.000 1 (.NOT.(ICALC.NE.0.AND.ITABL.EQ.0))) THEN 0308.000 DO 426 I=1,NCOPS 0309.000 426 CALL PRNTAB(STRING) 0310.000 ENDIF 0311.000 ENDIF 0312.000 IF(MPLANE.EQ.1) CALL MEANP(OM) 0313.000 IF (ILOC.EQ.1) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,0) 0314.000 IF(INTERL.LT.0) CALL JANE(AMAX,DMAX,DMIN,OM,RCP,INTERL) 0315.000 IF (IPRIN.NE.6) WRITE (IPRIN,504) 0316.000 IF (ISTOP.EQ.1) GO TO 503 0317.000 FIRST=.FALSE. 0318.000 IRAD=1 0319.000 ILOC=0 0320.000 INTRAL=0 0321.000 INTRAA=0 0322.000 IPUBS=0 0323.000 DMAX=0. 0324.000 DMIN=0.01 0325.000 INTERL=0 0326.000 MPLANE=0 0327.000 NDIANG=0 0328.000 MAXYZ=20 0329.000 MAXUIJ=10 0330.000 MAXBON=20 0331.000 ICORR=0 0332.000 LPP=35 0333.000 STRING=' ' 0334.000 SPPOS=.FALSE. 0335.000 IPRIN=6 0336.000 NCOPS=1 0337.000 GO TO 501 0338.000 503 WRITE (IPRIN,20000) 0339.000 STOP 0340.000 END 0341.000 SUBROUTINE PRECIS(ESD, IESD, FSPEC) 0342.000 CHARACTER FSPEC(80),BUF(80) 0343.000 CHARACTER*80 CBUF 0344.000 COMMON /LIMITS/MAXYZ,MAXUIJ,MAXBON 0345.000 EQUIVALENCE (CBUF,BUF) 0346.000 IESD =INT(ESD *1.E3)+1 0347.000 IF (IESD .LT.MAXBON) GO TO 3 0348.000 IESD =INT(ESD *1.E2)+1 0349.000 WRITE (CBUF,12) 0350.000 12 FORMAT ('(1X,16A1,F7.2,13A1)') 0351.000 GO TO 2 0352.000 3 WRITE (CBUF,13) 0353.000 13 FORMAT('(1X,16A1,F8.3,13A1)') 0354.000 2 DO 10 I=1,80 0355.000 10 FSPEC(I)=BUF(I) 0356.000 IF (ESD .LE.0.) IESD =-1 0357.000 RETURN 0358.000 END 0359.000 SUBROUTINE PRNTAB(STRING) 0360.000 CHARACTER*4 LINEL(13),LINER(13) 0361.000 CHARACTER*8 STRING 0362.000 INTEGER TYPE 0363.000 COMMON IPRIN,LPP 0364.000 101 READ (2,1,END=100,ERR=100) LINEL 0365.000 1 FORMAT (26A4) 0366.000 IF (LINEL(1).EQ.'BOND') THEN 0367.000 TYPE=1 0368.000 ELSE IF (LINEL(1).EQ.'ANGL'.OR.LINEL(1).EQ.'TORS') THEN 0369.000 TYPE=2 0370.000 ELSE IF (LINEL(1).EQ.'COOR') THEN 0371.000 TYPE=3 0372.000 ELSE IF (LINEL(1).EQ.'TEMP') THEN 0373.000 TYPE=4 0374.000 ELSE 0375.000 REWIND 2 0376.000 RETURN 0377.000 ENDIF 0378.000 IF (TYPE.EQ.3) THEN 0379.000 WRITE (IPRIN,16) 0380.000 16 FORMAT('1',10(/' '),55X,'TABLE'/'0',30X,'FRACTIONAL ATOMIC COORDIN0381.000 1ATES AND ISOTROPIC TEMPERATURE FACTORS'/31X,'(ANGSTROM SQUARED), W0382.000 2ITH STANDARD DEVIATIONS IN THE LEAST'/31X,'SIGNIFICANT DIGITS IN P0383.000 3ARENTHESES. ', 'FOR ANISOTROPIC ATOMS, THE'/31X,'EQUIVALENT IS0384.000 4OTROPIC TEMPERATURE FACTORS ARE SHOWN.') 0385.000 ELSE IF (TYPE.EQ.4) THEN 0386.000 WRITE (IPRIN,21) 0387.000 21 FORMAT ('1',10(/' '),55X,'TABLE'/'0',25X,'VIBRATION PARAMETERS 0388.000 1(ANGSTROM SQUARED) IN THE EXPRESSION:'/'0',25X,'-2(PI SQUARED)(U110389.000 2((H.A*)SQUARED) + U22((K.B*)SQUARED) +'/26X,'U33((L.C*)SQUARED) + 0390.000 32.U12.H.K.A*.B* + 2.U13.H.L.A*.C* +'/26X,'2.U23.K.L.B*.C*)') 0391.000 ENDIF 0392.000 WRITE (IPRIN,5) 0393.000 5 FORMAT ('1',10(/' ')) 0394.000 LINES=0 0395.000 IF (TYPE.EQ.3) THEN 0396.000 WRITE (IPRIN,19) 0397.000 19 FORMAT (46X,'X/A',12X,'Y/B',12X,'Z/C',12X,'U') 0398.000 LINES=LINES+1 0399.000 ELSE IF (TYPE.EQ.4) THEN 0400.000 WRITE (IPRIN,20) 0401.000 20 FORMAT (39X,'U11',7X,'U22',7X,'U33',7X,'U12',7X,'U13',7X,'U23')0402.000 LINES=LINES+1 0403.000 ENDIF 0404.000 107 READ (2,1,END=100,ERR=100) LINEL,LINER 0405.000 IF (LINEL(1).EQ.'END') GO TO 101 0406.000 IF (TYPE.GT.2) GO TO 110 0407.000 READ (2,1,END=108,ERR=108) LINER 0408.000 IF (LINER(1).NE.'END') GO TO 109 0409.000 108 GO TO (102,103),TYPE 0410.000 102 WRITE (IPRIN,3) LINEL 0411.000 3 FORMAT (16X,13A4,13A4) 0412.000 GO TO 101 0413.000 103 IF (STRING.EQ.' ') THEN 0414.000 WRITE (IPRIN,4) LINEL 0415.000 ELSE 0416.000 WRITE (IPRIN,3) LINEL 0417.000 ENDIF 0418.000 4 FORMAT (10X,13A4,13A4) 0419.000 GO TO 101 0420.000 109 GO TO (104,105),TYPE 0421.000 104 IF (STRING.EQ.' ') THEN 0422.000 WRITE (IPRIN,3) LINEL,LINER 0423.000 ELSE 0424.000 WRITE (IPRIN,8) LINEL,LINER 0425.000 8 FORMAT (16X,13A4/16X,13A4) 0426.000 LINES=LINES+1 0427.000 ENDIF 0428.000 GO TO 106 0429.000 105 IF (STRING.EQ.' ') THEN 0430.000 WRITE (IPRIN,4) LINEL,LINER 0431.000 ELSE 0432.000 WRITE (IPRIN,8) LINEL,LINER 0433.000 LINES=LINES+1 0434.000 ENDIF 0435.000 GO TO 106 0436.000 110 GO TO (111,112),TYPE-2 0437.000 111 WRITE (IPRIN,6) LINEL,(LINER(I),I=1,5) 0438.000 6 FORMAT (30X,18A4) 0439.000 GO TO 106 0440.000 112 WRITE (IPRIN,7) LINEL,(LINER(I),I=1,5) 0441.000 7 FORMAT (25X,18A4) 0442.000 106 LINES=LINES+1 0443.000 IF (LINES.GE.LPP) THEN 0444.000 WRITE (IPRIN,5) 0445.000 LINES=0 0446.000 IF (TYPE.EQ.3) THEN 0447.000 WRITE (IPRIN,19) 0448.000 LINES=LINES+1 0449.000 ELSE IF (TYPE.EQ.4) THEN 0450.000 WRITE (IPRIN,20) 0451.000 LINES=LINES+1 0452.000 ENDIF 0453.000 ENDIF 0454.000 GO TO 107 0455.000 100 REWIND 2 0456.000 RETURN 0457.000 END 0458.000 SUBROUTINE TORSN 0459.000 CHARACTER COMPID(72),IBRAK1(13),IBRAK2(8),IBRAK3(8),IBRAK4(8) 0460.000 CHARACTER IBRAK5(8) 0461.000 CHARACTER*8 ATM(200),SYMBOL,FTYPE(13) 0462.000 INTEGER CN(200),CONTNT(13),SYMC,SYMA 0463.000 COMMON IPRIN,LPP,ICORR,IRAD,IDUM(3), 0464.000 1 LTRANC(3),LTRANA(3),D(3),E(3),F(3), 0465.000 2G(3),P(3),Q(3) 0466.000 C SIG CONTAINS SIGMA**2 0467.000 COMMON/ESDS/ SIG(6,200) 0468.000 COMMON/MODELC/COMPID,ATM,FTYPE 0469.000 COMMON/MODEL/N,NR,NLATT,NTYPE,NFTYPE(200),XR(3,200), 0470.000 1 CN,SOF(200),UIJ(6,200),CIG(3,200),ESOF(200),SIGUIJ(6,200), 0471.000 2 WAVEL,U,V,W,COSALP,COSBET,COSGAM,ECELL(6),R(24,3,4), 0472.000 3 T(3,4),ICENT,SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 0473.000 COMMON/ORFFE/SAVE(3500,3,2),IADC(3500,2),NANGLE(200), 0474.000 C * * * * GOULD S.E.L. ONLY * * * * * 0475.000 C EXTENDED BLOCK/ORFFE/SAVE(3500,3,2),IADC(3500,2),NANGLE(200), 0476.000 C * * * * END GOULD S.E.L. CODE * * * * * 0477.000 1IDONE(500,4),NADC,DUMMY(31284) 0478.000 C 31284=MATRX+60-30201 0479.000 505 FORMAT (1X,32A1,F7.1,13A1) 0480.000 506 FORMAT ('END OF TABLE') 0481.000 507 FORMAT ('TORSION ANGLES') 0482.000 C IADC HOLDS THE DESIGNATOR CODES OF THE ATOMS SUBTENDING 0483.000 C AN ANGLE. 0484.000 C NANGLE(I) IS THE RUNNING TOTAL OF ANGLES UP TO AND INCLUDING 0485.000 C THOSE OF APEX ATOM I. 0486.000 DPR=57.29578 0487.000 K1=1 0488.000 NDONE=0 0489.000 WRITE (2,507) 0490.000 DO 1 I=1,N 0491.000 IF (I.GT.1) K1=NANGLE(I-1)+1 0492.000 K2=NANGLE(I) 0493.000 IF (K2.LT.K1) GO TO 1 0494.000 C LOOP THROUGH ANGLES ADDED BY THIS ATOM 0495.000 DO 2 K=K1,K2 0496.000 L=1 0497.000 40 IF (L.GT.NADC) GO TO 2 0498.000 IF (L.GE.K1.AND.L.LE.K2) GO TO 41 0499.000 J1=1 0500.000 42 DO 3 J2=1,2 0501.000 IF (IADC(K,J1).NE.IADC(L,J2)) GO TO 3 0502.000 N1=3-J1 0503.000 IF (IADC(K,J1).GT.0.AND.IADC(K,N1).GT.0) GO TO 7 0504.000 3 CONTINUE 0505.000 IF (J1.EQ.2) GO TO 41 0506.000 43 J1=2 0507.000 GO TO 42 0508.000 41 L=L+1 0509.000 GO TO 40 0510.000 7 IB=I 0511.000 DO 5 M=1,N 0512.000 IF (NANGLE(M).GE.L) GO TO 6 0513.000 5 CONTINUE 0514.000 6 ID=M 0515.000 IBDC=IB*531441+265387 0516.000 IDDC=ID*531441+265387 0517.000 IF (NDONE.EQ.0) GO TO 501 0518.000 C TRAP ANGLES ALREADY DONE 0519.000 DO 500 M=1,NDONE 0520.000 IF (IADC(K,N1).EQ.IDONE(M,4).AND.IBDC.EQ.IDONE(M,3).AND. 0521.000 1IADC(K,J1).EQ.IDONE(M,2).AND.IDDC.EQ.IDONE(M,1)) GO TO 502 0522.000 IF (IADC(K,N1).EQ.IDONE(M,1).AND.IBDC.EQ.IDONE(M,2).AND. 0523.000 1IADC(K,J1).EQ.IDONE(M,3).AND.IDDC.EQ.IDONE(M,4)) GO TO 502 0524.000 500 CONTINUE 0525.000 501 CALL DCODE(IADC(K,N1),IA,SYMA,ISTARA,NPA,LTRANA) 0526.000 CALL DCODE(IADC(K,J1),IC,SYMC,ISTARC,NPC,LTRANC) 0527.000 DO 4 M=1,3 0528.000 D(M)=-SAVE(K,M,N1) 0529.000 E(M)=-SAVE(K,M,J1) 0530.000 F(M)=-E(M) 0531.000 4 G(M)=SAVE(L,M,J2) 0532.000 DO 35 II=1,3 0533.000 J=II+1 0534.000 IF (J-3) 36,36,37 0535.000 37 J=J-3 0536.000 36 KK=J+1 0537.000 IF (KK-3) 38,38,39 0538.000 39 KK=KK-3 0539.000 38 P(II)=D(J)*E(KK)-D(KK)*E(J) 0540.000 35 Q(II)=F(J)*G(KK)-F(KK)*G(J) 0541.000 PNORM=FNORM(P(1),P(2),P(3)) 0542.000 QNORM=FNORM(Q(1),Q(2),Q(3)) 0543.000 PDOTQ=P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3) 0544.000 COSPQ=PDOTQ/(PNORM*QNORM) 0545.000 IF (ABS(COSPQ).GT.1.) COSPQ=SIGN(1.0,COSPQ) ANGPQ=ACOS(COSPQ)*DPR 0546.000 ASIGN=P(1)*(Q(2)*E(3)-Q(3)*E(2))+P(2)*(E(1)*Q(3)-Q(1)*E(3)) 1+P(3)*(Q(1)*E(2)-Q(2)*E(1)) 0548.000 IF (ASIGN.LT.0) ANGPQ=-ANGPQ C TORSION ANGLE ERROR. SEE HELV. CHIM. ACT. 44, 2027 (1961) & 0550.000 C ACTA CRYST. A28, 213 (1972). 0551.000 R12=FNORM(SAVE(K,1,N1),SAVE(K,2,N1),SAVE(K,3,N1)) 0552.000 R23=FNORM(SAVE(K,1,J1),SAVE(K,2,J1),SAVE(K,3,J1)) 0553.000 R34=FNORM(SAVE(L,1,J2),SAVE(L,2,J2),SAVE(L,3,J2)) 0554.000 DO 50 II=1,3 0555.000 D(II)=SAVE(K,II,N1)/R12 0556.000 E(II)=SAVE(K,II,J1)/R23 0557.000 50 F(II)=SAVE(L,II,J2)/R34 0558.000 CPHI1=D(1)*E(1)+D(2)*E(2)+D(3)*E(3) 0559.000 CPHI2=E(1)*F(1)+E(2)*F(2)+E(3)*F(3) 0560.000 C2PHI1=CPHI1*CPHI1 0561.000 C2PHI2=CPHI2*CPHI2 0562.000 S2PHI1=1.-C2PHI1 0563.000 S2PHI2=1.-C2PHI2 0564.000 SPHI1=SQRT(S2PHI1) 0565.000 SPHI2=SQRT(S2PHI2) 0566.000 T2PHI1=0. IF (S2PHI1.NE.0.) T2PHI1=C2PHI1/S2PHI1 CTPHI1=SQRT(T2PHI1) 0568.000 T2PHI2=0. IF (S2PHI2.NE.0.) T2PHI2=C2PHI2/S2PHI2 CTPHI2=SQRT(T2PHI2) 0570.000 S1=(SIG(1,IA)+SIG(2,IA)+SIG(3,IA))/3. 0571.000 S2=(SIG(1,IB)+SIG(2,IB)+SIG(3,IB))/3. 0572.000 S3=(SIG(1,IC)+SIG(2,IC)+SIG(3,IC))/3. 0573.000 S4=(SIG(1,ID)+SIG(2,ID)+SIG(3,ID))/3. 0574.000 SIGW=S1/(R12*R12*S2PHI1)+(S2/(R23*R23))*(((R23-R12*CPHI1) 0575.000 1/(R12*SPHI1))**2-2.*((R23-R12*CPHI1)/(R12*SPHI1))*CTPHI2*COSPQ 0576.000 2+T2PHI2)+(S3/(R23*R23))*(((R23-R34*CPHI2)/(R34*SPHI2))**2-2. 0577.000 3*((R23-R34*CPHI2)/(R34*SPHI2))*CTPHI1*COSPQ+T2PHI1) 0578.000 4+S4/(R34*R34*S2PHI2) 0579.000 IF (SIGW.GT.0.) THEN SIGW=SQRT(SIGW)*DPR 0580.000 ELSE SIGW=0. ENDIF JSIG=INT(SIGW*10.)+1 0581.000 IF (SIGW.EQ.0) JSIG=-1 0582.000 CALL TABLE (0,JSIG,-1,0,IBRAK1,13) 0583.000 SYMBOL=ATM(IA) 0584.000 CALL CTABLE(SYMBOL,1,IBRAK2,8) 0585.000 SYMBOL=ATM(IB) 0586.000 CALL CTABLE(SYMBOL,1,IBRAK3,8) 0587.000 SYMBOL=ATM(IC) 0588.000 CALL CTABLE(SYMBOL,1,IBRAK4,8) 0589.000 SYMBOL=ATM(ID) 0590.000 CALL CTABLE(SYMBOL,0,IBRAK5,8) 0591.000 WRITE (2,505) IBRAK2,IBRAK3,IBRAK4,IBRAK5,ANGPQ,IBRAK1 0592.000 IF (IPRIN.EQ.6) 0593.000 1 WRITE (IPRIN,505) IBRAK2,IBRAK3,IBRAK4,IBRAK5,ANGPQ,IBRAK1 0594.000 NDONE=NDONE+1 0595.000 IF (NDONE.GT.500) NDONE=1 0596.000 IDONE(NDONE,1)=IADC(K,N1) 0597.000 IDONE(NDONE,2)=IBDC 0598.000 IDONE(NDONE,3)=IADC(K,J1) 0599.000 IDONE(NDONE,4)=IDDC 0600.000 502 IF (J1.EQ.1) GO TO 43 0601.000 L=NANGLE(ID)+1 0602.000 GO TO 40 0603.000 2 CONTINUE 0604.000 1 CONTINUE 0605.000 WRITE (2,506) 0606.000 RETURN 0607.000 END 0608.000 SUBROUTINE DCODE(N,I,NS,IS,NP,LTRAN) 0609.000 C * * * * GOULD-S.E.L. ONLY * * * * 0610.000 C EXTENDED DUMMY N 0611.000 C * * * * END GOULD-S.E.L. CODE * * * * * 0612.000 DIMENSION LTRAN(3) 0613.000 I1=N/729 0614.000 IR=N-729*I1 0615.000 N1=IR/5 0616.000 IS=IR-5*N1 0617.000 NS=N1/5 0618.000 NP=N1-5*NS 0619.000 I=I1/729 0620.000 IR=I1-729*I 0621.000 L1=IR/9 0622.000 LTRAN(1)=IR-9*L1-4 0623.000 L2=L1/9 0624.000 LTRAN(2)=L1-9*L2-4 0625.000 LTRAN(3)=L2-4 0626.000 RETURN 0627.000 END 0628.000 FUNCTION FNORM(X,Y,Z) 0629.000 C * * * * GOULD-S.E.L. ONLY * * * * 0630.000 C EXTENDED DUMMY X,Y,Z 0631.000 C * * * * END GOULD-S.E.L. * * * * * 0632.000 FNORM=SQRT(X*X+Y*Y+Z*Z) 0633.000 RETURN 0634.000 END 0635.000 SUBROUTINE MEANP(OM) 0636.000 CHARACTER IC(148),COMPID(72),TAG,FSPEC(80) 0637.000 CHARACTER*8 AMIN(20),ATM(200),FTYPE(13) 0638.000 DIMENSION OM(3,3) 0639.000 INTEGER CN(200),CONTNT(13) 0640.000 COMMON IPRIN,LPP,ICORR,IRAD,ICCC(3),ICH(20),IW(20),W(200),V(3,3), 0641.000 1MIN(20),A(3,3),VJ(3,20),SUMWX(3),XI(3),X(3) 0642.000 COMMON/ESDS/ SIG(6,200) 0643.000 COMMON/CHARA/IC,FSPEC 0644.000 COMMON/MODELC/COMPID,ATM,FTYPE 0645.000 COMMON/MODEL/N,NR,NLATT,NTYPE,NFTYPE(200),XR(3,200), 0646.000 1 CN,SOF(200),UIJ(6,200),CIG(3,200),ESOF(200),SIGUIJ(6,200), 0647.000 2 WAVEL,U,VV,WW,COSALP,COSBET,COSGAM,ECELL(6),R(24,3,4), 0648.000 3 T(3,4),ICENT,SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 0649.000 C 0650.000 C 0651.000 82 FORMAT ('1 MEAN PLANES') 0652.000 88 FORMAT (144A1) 0653.000 91 FORMAT('0SIGMA DELTA SQUARED =',F10.6/'0CHI SQUARED =',F15.4, 0654.000 1' NUMBER OF DEGREES OF FREEDOM =',I4///) 0655.000 92 FORMAT(14H EIGEN VALUE =,F10.4) 0656.000 87 FORMAT ('0PLANE NO.',I4) 0657.000 93 FORMAT(23H ATOMS OUT OF THE PLANE/19X,5H ATOM,11X,2HXI,8X,2HYI,8X,0658.000 12HZI,8X,2H W,4X,'ESD(ZI)') 0659.000 94 FORMAT(20X,A8,3F10.4,F10.1,F10.4) 0660.000 95 FORMAT(' ATOMS IN THE PLANE'/19X,5H ATOM,11X,2HXI,8X,2HYI,8X, 0661.000 12HZI,8X,2H W,4X,'ESD(ZI)') 0662.000 96 FORMAT(6H M(I)=,3F10.5, 49H (COMPONENTS OF UNIT VECTOR NORMAL T0663.000 1O BEST PLANE)/3H D=,F10.5,23X,46H (PERPENDICULAR DISTANCE FROM PLA0664.000 2NE TO ORIGIN)//'0COORDINATES W.R.T. INERTIAL AXES (ZI IS DELTA)'/)0665.000 500 FORMAT(' ANGLE BETWEEN NORMALS OR LINES', I3,4H AND,I3, 4H 0666.000 1IS ,F6.2,9H DEGREES ) 0667.000 99 FORMAT ('0TENSOR OF INERTIA'/3(3F15.3/)) 0668.000 1002 FORMAT ('0ATOM SYMBOL ',A8,' INCONSISTENT'/'1') 0669.000 1254 FORMAT(' PLUS THE CENTRO-SYMMETRICALLY-RELATED ATOMS') 0670.000 WRITE(IPRIN,82) 0671.000 NJ=0 0672.000 3 NA=0 0673.000 NORG=0 0674.000 DO 14 J=1,N 0675.000 14 W(J)=1.0 0676.000 WRITE (6,603) 0677.000 603 FORMAT (' TYPE ATOM SYMBOLS TO DEFINE PLANE (BLANK LINE TO EXIT0678.000 1,'/' = TO CONTINUE SYMBOLS ON NEXT LINE)') 0679.000 READ(1,88,END=4)(IC(K),K=2,73) 0680.000 DO 26 K=74,145 0681.000 26 IC(K)=' ' 0682.000 CALL PARSE(IC,NIN,ICH,IW) 0683.000 IF (NIN.EQ.0) GO TO 4 0684.000 J=ICH(NIN) 0685.000 IF (IC(J).NE.'=') GO TO 20 0686.000 IC(J)=' ' 0687.000 READ (1,88,END=4) (IC(K),K=74,145) 0688.000 CALL PARSE(IC,NIN,ICH,IW) 0689.000 20 DO 101 I=1,NIN 0690.000 101 CALL AFORMT(IC,ICH(I),IW(I),AMIN(I)) 0691.000 DO 1001 I=1,NIN 0692.000 DO 100 J=1,N 0693.000 IF (AMIN(I).NE.ATM(J)) GO TO 100 0694.000 MIN(I)=J 0695.000 GO TO 1001 0696.000 100 CONTINUE 0697.000 WRITE (6,1002) AMIN(I) 0698.000 GO TO 3 0699.000 1001 CONTINUE 0700.000 IF (NIN.EQ.2) THEN 0701.000 NJ=NJ+1 0702.000 MATMJ=MIN(1) 0703.000 CALL MV(OM,XR(1,MATMJ),X) 0704.000 DO 200 I=1,3 0705.000 200 VJ(ICCC(I),NJ)=X(I) 0706.000 MATMJ=MIN(2) 0707.000 CALL MV(OM,XR(1,MATMJ),X) 0708.000 DO 201 I=1,3 0709.000 201 VJ(ICCC(I),NJ)=VJ(ICCC(I),NJ)-X(I) 0710.000 DIST=SQRT(VJ(1,NJ)**2+VJ(2,NJ)**2+VJ(3,NJ)**2) 0711.000 DO 202 I=1,3 0712.000 202 VJ(I,NJ)=VJ(I,NJ)/DIST 0713.000 WRITE (IPRIN,203) NJ,ATM(MIN(1)),ATM(MIN(2)),DIST, 0714.000 1 (VJ(I,NJ),I=1,3) 0715.000 203 FORMAT ('0LINE NO.',I4,' BETWEEN ATOMS ',A8,' AND ',A8/ 0716.000 1 '0INTERATOMIC DISTANCE =',F9.4,' ANGSTROMS'/ 0717.000 2 '0DIRECTION COSINES ARE',3F10.5) 0718.000 ELSE 0719.000 WRITE (6,600) 0720.000 600 FORMAT (' UNIT WEIGHTS? (N)') 0721.000 READ (1,88) TAG 0722.000 IF (TAG.EQ.'Y') NA=1 0723.000 WRITE (6,601) 0724.000 601 FORMAT (' PLANE THROUGH CENTRE OF SYMMETRY AT ORIGIN? (N)') 0725.000 READ (1,88) TAG 0726.000 IF (TAG.EQ.'Y') NORG=1 0727.000 IF(NA) 16,16,5 0728.000 16 DO 1401 J=1,N 0729.000 W(J) = 0.0 0730.000 DO 1400 K = 1,3 0731.000 1400 W(J)=W(J)+SIG(K,J) 0732.000 IF (W(J).EQ.0.) GO TO 1401 0733.000 W(J)=3./W(J) 0734.000 1401 CONTINUE 0735.000 5 SUMD2=0.0 0736.000 CHISQ=0. 0737.000 SUMW=0. 0738.000 DO 6 I=1,3 0739.000 SUMWX(I)=0.0 0740.000 DO 6 J=1,3 0741.000 6 A(I,J)=0.0 0742.000 NJ=NJ+1 0743.000 WRITE (IPRIN,87) NJ 0744.000 DO 7 J=1,NIN 0745.000 MATMJ=MIN(J) 0746.000 SUMW=SUMW+W(MATMJ) 0747.000 CALL MV(OM,XR(1,MATMJ),X) 0748.000 DO 7 I=1,3 0749.000 7 SUMWX(I)=SUMWX(I)+W(MATMJ)*X(I) 0750.000 DO 120 I=1,3 0751.000 SUMWX(I)=SUMWX(I)/SUMW 0752.000 IF (NORG.EQ.1) SUMWX(I)=0. 0753.000 120 CONTINUE 0754.000 DO 109 J=1,NIN 0755.000 MATMJ=MIN(J) 0756.000 CALL MV(OM,XR(1,MATMJ),X) 0757.000 DO 109 I=1,3 0758.000 DO 109 K=1,3 0759.000 109 A(I,K)=A(I,K)+W(MATMJ)*(X(I)-SUMWX(I))*(X(K)-SUMWX(K)) 0760.000 WRITE (IPRIN,99) ((A(I,J),J=1,3),I=1,3) 0761.000 CALL ARRAY1(2,3,3,A,A) 0762.000 CALL EIGEN(A,V,3,0) 0763.000 CALL ARRAY1(1,3,3,A,A) 0764.000 DET=V(1,1)*V(2,2)*V(3,3)+V(2,1)*V(3,2)*V(1,3)+V(3,1)*V(2,3)*V(1,2)0765.000 1-V(1,3)*V(2,2)*V(3,1)-V(1,2)*V(2,1)*V(3,3)-V(1,1)*V(3,2)*V(2,3) 0766.000 IF (DET.GE.0.) GO TO 801 0767.000 V(1,3)=-V(1,3) 0768.000 V(2,3)=-V(2,3) 0769.000 V(3,3)=-V(3,3) 0770.000 801 WRITE (IPRIN,92) A(3,3) 0771.000 D=V(1,3)*SUMWX(1)+V(2,3)*SUMWX(2)+V(3,3)*SUMWX(3) 0772.000 DO 30 M=1,3 0773.000 30 VJ(ICCC(M),NJ)=V(M,3) 0774.000 WRITE (IPRIN,96) (VJ(M,NJ),M=1,3),D 0775.000 WRITE(IPRIN,95) 0776.000 DO 9 I=1,NIN 0777.000 K=MIN(I) 0778.000 CALL MV(OM,XR(1,K),X) 0779.000 DO 11 J=1,3 0780.000 11 XI(J)=X(J) -SUMWX(J) 0781.000 DELTA=SQRT(SIG(1,K)*VJ(1,NJ)**2 +SIG(2,K)*VJ(2,NJ)**2 + 0782.000 1SIG(3,K)*VJ(3,NJ)**2) 0783.000 CALL MTV(V,XI) 0784.000 IF(DELTA.GT.0.) CHISQ=CHISQ+(XI(3) /DELTA)**2 0785.000 SUMD2=SUMD2+(XI(3))**2 0786.000 9 WRITE (IPRIN,94) ATM(K),XI,W(K),DELTA 0787.000 IF (NORG.EQ.1) WRITE (IPRIN,1254) 0788.000 NDF=NIN-3 0789.000 IF (NORG.EQ.1) NDF=2*NIN-3 0790.000 WRITE (IPRIN,91) SUMD2,CHISQ,NDF 0791.000 WRITE(IPRIN,93) 0792.000 DO 10 K = 1,N 0793.000 DO 9876 J = 1,NIN 0794.000 IF (K-MIN(J)) 9876,10,9876 0795.000 9876 CONTINUE 0796.000 CALL MV(OM,XR(1,K),X) 0797.000 DO 12 J=1,3 0798.000 12 XI(J)=X(J) -SUMWX(J) 0799.000 DELTA=SQRT(SIG(1,K)*VJ(1,NJ)**2 +SIG(2,K)*VJ(2,NJ)**2 + 0800.000 1SIG(3,K)*VJ(3,NJ)**2) 0801.000 CALL MTV(V,XI) 0802.000 WRITE (IPRIN,94) ATM(K),XI,W(K),DELTA 0803.000 10 CONTINUE 0804.000 ENDIF 0805.000 GO TO 3 0806.000 4 NB=1 0807.000 IF (NJ-1) 44,44,45 0808.000 45 NC=NB+1 0809.000 DO 40 K=NC,NJ 0810.000 COSAN =VJ(1,NB)*VJ(1,K)+VJ(2,NB)*VJ(2,K)+VJ(3,NB)*VJ(3,K) 0811.000 ANG=ACOS(COSAN) 0812.000 ANG=ANG*57.29578 0813.000 40 WRITE(IPRIN,500)NB,K,ANG 0814.000 NB=NB+1 0815.000 IF(NB-NJ)45,43,43 0816.000 43 CONTINUE 0817.000 44 CONTINUE 0818.000 RETURN 0819.000 END 0820.000 SUBROUTINE TRANM(B,L,V) 0821.000 C FORM MATRIX V=LBL(TRANSPOSED). B IS FIRST RE-ARRANGED AS A 0822.000 C SYMMETRIC MATRIX GIVEN THE UPPER TRIANGLE IN THE FIRST TWO COLUMNS0823.000 REAL L(3,3),LT(3,3) 0824.000 DIMENSION B(3,3),V(3,3),W(3,3) 0825.000 B(1,3)=B(2,2) 0826.000 B(2,3)=B(3,2) 0827.000 B(3,3)=B(3,1) 0828.000 B(2,2)=B(2,1) 0829.000 B(2,1)=B(1,2) 0830.000 B(3,1)=B(1,3) 0831.000 CALL MMULT(B,L,W) 0832.000 DO 1 I=1,3 0833.000 DO 1 J=1,3 0834.000 1 LT(I,J)=L(J,I) 0835.000 CALL MMULT(LT,W,V) 0836.000 RETURN 0837.000 END 0838.000 SUBROUTINE MMULT(B,A,W) 0839.000 C FORM MATRIX W=AB 0840.000 DIMENSION A(3,3),B(3,3),W(3,3) 0841.000 DO 1 I=1,3 0842.000 DO 1 J=1,3 0843.000 W(I,J)=0. 0844.000 DO 1 K=1,3 0845.000 1 W(I,J)=W(I,J)+A(I,K)*B(K,J) 0846.000 RETURN 0847.000 END 0848.000 SUBROUTINE MTV(M,V) 0849.000 C TRANSFORM VECTOR V BY MATRIX M(TRANSPOSED) 0850.000 REAL W(3),V(3),M(3,3) 0851.000 DO 1 I=1,3 0852.000 W(I)=0. 0853.000 DO 1 J=1,3 0854.000 1 W(I)=W(I)+M(J,I)*V(J) 0855.000 DO 2 I=1,3 0856.000 2 V(I)=W(I) 0857.000 RETURN 0858.000 END 0859.000 SUBROUTINE CTABLE(IN1, NBLNK,IBRAK,IFW) 0860.000 C SET UP ATOM SYMBOL FOR PRINTING. 0861.000 CHARACTER*8 IN1,FIELD 0862.000 CHARACTER IOUT(20),IBRAK(IFW),IBLNK, LABEL(8),MINUS 0863.000 EQUIVALENCE (FIELD,LABEL) 0864.000 DATA IBLNK, MINUS/' ','-'/ 0865.000 DO 1 I=1,IFW 0866.000 1 IBRAK(I)=IBLNK 0867.000 I2=0 0868.000 FIELD=IN1 0869.000 DO 50 I=1,8 0870.000 IF (LABEL(I).EQ.IBLNK) GO TO 50 0871.000 I2=I2+1 0872.000 IBRAK(I2)=LABEL(I) 0873.000 50 CONTINUE 0874.000 C INSERT HYPHEN IF NOT LAST ATOM SYMBOL 0875.000 IF (NBLNK.EQ.0) RETURN 0876.000 I=IFW-I2 0877.000 IF (I.LE.0) RETURN 0878.000 I=I/2+MOD(I,2) 0879.000 IBRAK(I2+I)=MINUS 0880.000 RETURN 0881.000 END 0882.000 SUBROUTINE TABLE (IN1,IN2,MODE,NBLNK,IBRAK,IFW) 0883.000 C SET UP PARAMETER VALUE FOR PRINTING. 0884.000 CHARACTER*20 FIELD 0885.000 CHARACTER IOUT(20),IBLNK,IBRAK(IFW),LBRAK,NBRAK,MINUS,IZERO 0886.000 EQUIVALENCE (FIELD,IOUT) 0887.000 DATA IBLNK,LBRAK,NBRAK,MINUS,IZERO/' ','(',')','-','0'/ 0888.000 DO 1 I=1,IFW 0889.000 1 IBRAK(I)=IBLNK 0890.000 I2=0 0891.000 IF (MODE.LT.0) GO TO 15 0892.000 WRITE (FIELD,200) IN1 0893.000 200 FORMAT (I7) 0894.000 I2=7 0895.000 DO 8 I=1,I2 0896.000 C IF MODE=2,INSERT LEADING ZEROS IN PARAMETER VALUE 0897.000 IF (MODE-1) 23,23,24 0898.000 24 IF (I-NBLNK) 23,23,37 0899.000 37 IF (IOUT(I).EQ.MINUS) GO TO 34 0900.000 IF (IOUT(I).EQ.IBLNK) GO TO 33 0901.000 23 IBRAK(I)=IOUT(I) 0902.000 GO TO 8 0903.000 34 IBRAK(NBLNK)=MINUS 0904.000 33 IBRAK(I)=IZERO 0905.000 8 CONTINUE 0906.000 C SET UP ESD IN BRACKETS (SKIP IF ESD IS -VE) 0907.000 15 IF (IN2.LT.0) RETURN 0908.000 N=0 0909.000 WRITE (FIELD,201) IN2 0910.000 201 FORMAT (I5) 0911.000 DO 2 I=1,5 0912.000 IF (IOUT(I).EQ.IBLNK) N=N+1 0913.000 2 CONTINUE 0914.000 I1=5-N 0915.000 DO 4 I=1,I1 0916.000 J=N+I 0917.000 K=I+I2+1 0918.000 4 IBRAK(K) =IOUT(J) 0919.000 IBRAK(I2+1)=LBRAK 0920.000 J=I1+2+I2 0921.000 IBRAK(J)=NBRAK 0922.000 RETURN 0923.000 END 0924.000 FUNCTION NINT(A) 0925.000 IF (A) 3,4,4 0926.000 3 NINT=A-0.5 0927.000 RETURN 0928.000 4 NINT=A+0.5 0929.000 RETURN 0930.000 END 0931.000 SUBROUTINE JANE(CMAX,BMAX,BMIN,U,RCP,INTERL) 0932.000 C INTERATOMIC DISTANCE, ANGLE PROGRAM 0933.000 C P.R.MALLINSON MAY 1973 FROM AN ALGORITHM BY J.S.ROLLETT 0934.000 C PROGRAM JANE - JUXTAPOSITION, ANGLES 0935.000 C ROUTINE OF GEOM JULY 1976 P.R.M. 0936.000 CHARACTER COMPID(72) 0937.000 CHARACTER*8 ATOM(200),FTYPE(13) 0938.000 INTEGER S,COUNT(3),CN(200),CONTNT(13),DONE 0939.000 DIMENSION RCP(3), U(3,3),POINT(3) 0940.000 COMMON IPRIN,LPP,ICORR,IRAD,IC(3), XJ(3),I,J,S,D(3), 0941.000 1 DONE, JATOM(15),XOUT(3), DMAX2,COUNT,INT,IS,ND 0942.000 COMMON/MODELC/COMPID,ATOM,FTYPE 0943.000 COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200), 0944.000 1 CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200), 0945.000 2 WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT, 0946.000 3 SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 0947.000 16 FORMAT ('1EQUIVALENT POSITIONS'/) 0948.000 18 FORMAT ('0LATTICE POINTS'/) 0949.000 20 FORMAT ( I2,3F12.4) 0950.000 104 FORMAT ('0CENTROSYMMETRIC') 0951.000 105 FORMAT ('0NON-CENTROSYMMETRIC') 0952.000 C N = NO. OF ATOMS, M = NO. OF SYMMETRY OPERATIONS 0953.000 C NT = NO. OF LATTICE POINTS, ICENT = 0/1 CENTRO/NON-CENTRO 0954.000 DMAX=CMAX 0955.000 AMAX=BMAX 0956.000 AMIN=BMIN 0957.000 IF (AMAX.GT.DMAX.OR.INTERL.GE.0) DMAX=AMAX 0958.000 DMAX2=DMAX*DMAX 0959.000 IF (INTERL.LT.1) THEN 0960.000 WRITE (IPRIN,16) 0961.000 CALL SYMPRT(IPRIN) 0962.000 WRITE (IPRIN,18) 0963.000 DO 1 K=1,NT 0964.000 DO 2 L=1,3 0965.000 2 POINT(IC(L))=T(L,K) 0966.000 WRITE (IPRIN,20) (K,(POINT(L),L=1,3)) 0967.000 1 CONTINUE 0968.000 IF (ICENT.EQ.0) WRITE (IPRIN,104) 0969.000 IF (ICENT.NE.0) WRITE (IPRIN,105) 0970.000 ENDIF 0971.000 CALL SYMM( DMAX,AMAX,AMIN, U, RCP,INTERL) 0972.000 RETURN 0973.000 END 0974.000 SUBROUTINE SYMM( DMAX,AMAX,AMIN, U, RCP,INTERL) 0975.000 C TO GENERATE THE EQUIVALENT POSITIONS 0976.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) CHARACTER FSPEC(80), COMPID(72),STAR(2),LBUF(148) 0977.000 CHARACTER IBRAK1(13),IBRAK2(8), IBRAK3(8),IBRAK4(8) 0978.000 CHARACTER*8 ATOM(200),FTYPE(13),SYMBOL,HEAD(2) 0979.000 INTEGER S,CN(200),CONTNT(13),DONE 0980.000 DIMENSION RCP(3), CP(3),U(3,3) 0981.000 LOGICAL SPPOS 0982.000 DIMENSION SAVE(3500,3,2),IADC(3500,2),NANGLE(200) 0983.000 DIMENSION IDONE(500,4),LTR(3),P1(3),P2(3),P3(3),PAR1(3),PAR3(3)0984.000 COMMON IPRIN,LPP,ICORR,IRAD,IC(3), XJ(3),I,J,S,D(3), 0985.000 1 DONE, JATOM(15),XOUT(3), DMAX2,KOUNT(3),IT,IS, ND, 0986.000 2DKEEP(15),EKEEP(15),XKEEP(3,15),DFKEEP(3,15) 0987.000 COMMON/CHARA/LBUF,FSPEC 0988.000 COMMON/MODELC/COMPID,ATOM,FTYPE 0989.000 COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200), 0990.000 1 CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200), 0991.000 2 WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT, 0992.000 3 SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 0993.000 COMMON/ESDS/XIG(6,200) 0994.000 COMMON/OSLO/SPPOS 0995.000 COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 0996.000 C * * * * GOULD S.E.L. ONLY * * * * * 0997.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 0998.000 C * * * * END GOULD S.E.L. CODE * * * * * 0999.000 COMMON/OUT/IN(231) 1000.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCLE,SAVEA,SAVEP,C,VARA,VARP 1001.000 2,E,E1,LZ,NQZ,MQZ 1002.000 EQUIVALENCE (SAVE,PM(1)),(IADC,PM(21001)), 1003.000 1(NANGLE,PM(28001)),(IDONE,PM(28201)),(NADC,PM(30201)),(LTR,XOUT) 1004.000 DATA STAR/' ','*'/,HEAD/'BONDS','ANGLES'/ 1005.000 100 FORMAT ('0BOND DISTANCES ARE SUMS OF COVALENT RADII') 1006.000 102 FORMAT ('0',28X,'BOND ANGLES E.S.D.') 1007.000 103 FORMAT (' ',2(A8, '- '),A8, F8.2,F9.2) 1008.000 201 FORMAT('0****',A8,2X,'BOND LENGTHS',2X, 1009.000 1 'E.S.D. NS NP TA TB TC',9X,'X2',8X,'Y2',8X,'Z2') 1010.000 203 FORMAT('0THE COVALENT AND VAN DER WAALS RADII WILL BE USED TO DEFI1011.000 1NE THE BOND AND CONTACT DISTANCES') 1012.000 204 FORMAT (' ',A8, '- ',A8,F7.4,F7.4,I4,A1,I4,I5,2I3,3X,3F10.5) 1013.000 205 FORMAT('0ONLY DISTANCES INVOLVING A SYMMETRY TRANSFORMATION AND GR1014.000 1EATER THAN THE SUM OF'/' COVALENT RADII (OR DMIN) APPEAR BELOW') 1015.000 210 FORMAT('0CONTACTS FROM',F6.2,' A TO',F6.2,' A') 1016.000 211 FORMAT ('0BONDS FROM',F6.2,' A TO',F6.2,' A') 1017.000 212 FORMAT ('0CONTACTS FROM SUM OF COVALENT RADII TO',F6.2,' A') 1018.000 DO 1 L=1,3 1019.000 1 D(L)=1./RCP(L) 1020.000 IF (INTERL.LT.0) THEN 1021.000 NOPT=0 1022.000 SPPOS=.FALSE. 1023.000 ELSE 1024.000 NOPT=1 1025.000 ENDIF 1026.000 IF(INTERL.EQ.-1) WRITE (IPRIN,205) 1027.000 IF (IRAD.EQ.1.AND.INTERL.LT.1) WRITE(IPRIN,203) 1028.000 IF (IRAD.EQ.0.AND.INTERL.LT.0) THEN 1029.000 IF (AMAX.GT.0.) THEN 1030.000 WRITE (IPRIN,210) AMAX,DMAX 1031.000 ELSE 1032.000 WRITE (IPRIN,212) DMAX 1033.000 ENDIF 1034.000 ENDIF 1035.000 IF (IRAD.EQ.0.AND.INTERL.EQ.0) THEN 1036.000 IF (AMAX.GT.0.) THEN 1037.000 WRITE (IPRIN,211) AMIN,AMAX 1038.000 ELSE 1039.000 WRITE (IPRIN,100) 1040.000 ENDIF 1041.000 ENDIF 1042.000 C CHANGE AXES SO THAT D(100).GE.D(010).GE.D(001) 1043.000 DO 2 K=1,2 1044.000 K1=K+1 1045.000 DO 2 L=K1,3 1046.000 IF (D(K)-D(L)) 3,2,2 1047.000 3 DO 4 K2=1,N 1048.000 4 CALL ROTAT(X(K,K2),X(L,K2)) 1049.000 DO 5 K2=1,M 1050.000 C INTERCHANGE COLS OF ROTATION MATRIX 1051.000 DO 28 K3=1,3 1052.000 28 CALL ROTAT (R(K2,K3,K),R(K2,K3,L)) 1053.000 C INTERCHANGE ROWS OF ROTATION MATRIX AND TRANSLATION VECTOR 1054.000 DO 5 K3=1,4 1055.000 5 CALL ROTAT(R(K2,K,K3),R(K2,L,K3)) 1056.000 DO 27 K2=1,NT 1057.000 27 CALL ROTAT(T(K,K2),T(L,K2)) 1058.000 CALL ROTA2(IC(K),IC(L)) 1059.000 CALL ROTAT(D(K),D(L)) 1060.000 CALL ROTAT(RCP(K),RCP(L)) 1061.000 C INTERCHANGE ROWS AND COLS OF ORTHOGONALISATION MATRIX 1062.000 DO 41 K3=1,3 1063.000 41 CALL ROTAT(U(K,K3),U(L,K3)) 1064.000 DO 42 K3=1,3 1065.000 42 CALL ROTAT(U(K3,K),U(K3,L)) 1066.000 2 CONTINUE 1067.000 C ATOM1 LOOP 1068.000 IF (INTERL.EQ.1.OR.INTERL.EQ.2) WRITE (2,302) HEAD(INTERL) 1069.000 302 FORMAT (A8) 1070.000 NADC=0 1071.000 DO 11 I=1,N 1072.000 IF (NOPT) 50,50,13 1073.000 50 K=I 1074.000 GO TO 14 1075.000 13 K=1 1076.000 14 ND=0 1077.000 DONE=0 1078.000 C ATOM2 LOOP 1079.000 DO 10 J=K,N 1080.000 IF (IRAD.EQ.0.AND.AMAX.GT.0.) GO TO 200 1081.000 AMIN=0.01 1082.000 AMAX=SFAC(13,NFTYPE(I))+SFAC(13,NFTYPE(J)) 1083.000 IF (INTERL.LT.0) THEN 1084.000 IF (IRAD.EQ.0) GO TO 200 1085.000 DMAX=SFAC(14,NFTYPE(I))+SFAC(14,NFTYPE(J)) 1086.000 ELSE 1087.000 DMAX=AMAX 1088.000 ENDIF 1089.000 DMAX2=DMAX*DMAX 1090.000 C EQUIV POSN LOOP 1091.000 200 DO 9 S=1,M 1092.000 IF (SPPOS.AND.S.GT.1) GO TO 9 1093.000 IS=1 1094.000 DO 8 L=1,3 1095.000 8 CP(L)=X(1,J)*R(S,L,1)+X(2,J)*R(S,L,2)+X(3,J)*R(S,L,3)+R(S,L,4) 1096.000 C LATTICE POINT LOOP 1097.000 21 DO 17 IT=1,NT 1098.000 IF (J-I) 7,6,7 1099.000 6 IF (S-1) 7,19,7 1100.000 19 IF (IT-1) 7,26,7 1101.000 26 IF (IS-1) 17,17,7 1102.000 7 DO 20 L=1,3 1103.000 20 XJ(L)=CP(L)+T(L,IT) 1104.000 CALL TRSLN(DMAX,AMAX,AMIN,U,INTERL) 1105.000 IF (ND.EQ.15) THEN 1106.000 WRITE (IPRIN,104) 1107.000 104 FORMAT (' TABLE OVERFLOW. SOME BONDS HAVE BEEN SKIPPED') 1108.000 GO TO 105 1109.000 ENDIF 1110.000 17 CONTINUE 1111.000 C INVERSION IF CENTROSYMMETRIC 1112.000 IF (ICENT.GT.0.OR.SPPOS) GO TO 9 1113.000 IF (IS-1) 22,22,9 1114.000 22 DO 24 L=1,3 1115.000 24 CP(L)=-CP(L) 1116.000 IS=2 1117.000 GO TO 21 1118.000 9 CONTINUE 1119.000 10 CONTINUE 1120.000 IF (ND.EQ.0) GO TO 12 1121.000 105 IF (INTERL.LT.1.) WRITE (IPRIN,201) ATOM(I) 1122.000 DO 202 K=1,ND 1123.000 IF (INTERL.EQ.1.AND.JATOM(K)/531441.GE.I) THEN 1124.000 CALL PRECIS(EKEEP(K),IERR,FSPEC) 1125.000 CALL TABLE(0,IERR,-1,0,IBRAK1,13) 1126.000 SYMBOL=ATOM(I) 1127.000 CALL CTABLE(SYMBOL, 1,IBRAK2,8) 1128.000 SYMBOL=ATOM(JATOM(K)/531441) 1129.000 CALL CTABLE(SYMBOL, 0,IBRAK3,8) 1130.000 WRITE (2,FSPEC) IBRAK2,IBRAK3,DKEEP(K),IBRAK1 1131.000 IF (IPRIN.EQ.6) 1132.000 1 WRITE (IPRIN,FSPEC) IBRAK2,IBRAK3,DKEEP(K),IBRAK1 1133.000 ELSE IF (INTERL.LT.1) THEN 1134.000 CALL DCODE(JATOM(K),L,S,IS,IT,LTR) 1135.000 WRITE(IPRIN,204) ATOM(I),ATOM(L), DKEEP(K),EKEEP(K), 1136.000 1 S, STAR(IS),IT,LTR,(XKEEP(J,K),J=1,3) 1137.000 ENDIF 1138.000 202 CONTINUE 1139.000 IF (ND.EQ.1.AND.INTERL.EQ.3) THEN 1140.000 IF (NADC.EQ.3500) THEN 1141.000 WRITE (IPRIN,408) 1142.000 DO 721 J=I,N 1143.000 721 NANGLE(J)=NADC 1144.000 RETURN 1145.000 ENDIF 1146.000 NADC=NADC+1 1147.000 IADC(NADC,1)=JATOM(1) 1148.000 IADC(NADC,2)=0 1149.000 DO 722 J=1,3 1150.000 722 SAVE(NADC,J,1)=DFKEEP(J,1) 1151.000 ENDIF 1152.000 IF (INTERL.NE.1.AND.ND.GT.1) THEN 1153.000 IF (INTERL.LT.1) WRITE (IPRIN,102) 1154.000 DO 16 K=1,ND-1 1155.000 DO 16 L=K+1,ND 1156.000 IF (INTERL.EQ.3) THEN 1157.000 IF (NADC.EQ.3500) THEN 1158.000 WRITE (IPRIN,408) 1159.000 408 FORMAT (' TABLE OVERFLOW. SOME ANGLES HAVE BEEN SKIPPED') 1160.000 NANGLE(I)=NADC 1161.000 IF (I.LT.N) THEN 1162.000 DO 710 J=I+1,N 1163.000 710 NANGLE(J)=0 1164.000 ENDIF 1165.000 RETURN 1166.000 ENDIF 1167.000 NADC=NADC+1 1168.000 IADC(NADC,1)=JATOM(K) 1169.000 IADC(NADC,2)=JATOM(L) 1170.000 DO 702 J=1,3 1171.000 P1(J)=DFKEEP(J,K)/DKEEP(K) 1172.000 P2(J)=DFKEEP(J,L)/DKEEP(L) 1173.000 SAVE(NADC,J,1)=DFKEEP(J,K) 1174.000 702 SAVE(NADC,J,2)=DFKEEP(J,L) 1175.000 COSANG=P1(1)*P2(1)+P1(2)*P2(2)+P1(3)*P2(3) 1176.000 IF (ABS(COSANG).GT.0.999999) NADC=NADC-1 1177.000 ELSE 1178.000 IF (ICORR.EQ.0) THEN 1179.000 DO 711 J=1,3 1180.000 P1(J)=DFKEEP(J,K)/DKEEP(K) 1181.000 711 P2(J)=DFKEEP(J,L)/DKEEP(L) 1182.000 COSANG=P1(1)*P2(1)+P1(2)*P2(2)+P1(3)*P2(3) 1183.000 IF (ABS(COSANG).GT.1.0) COSANG=SIGN(1.0,COSANG) F=ACOS(COSANG)*57.29578 1184.000 IF (F.LT.0.0001) GO TO 16 1185.000 C BOND ANGLE ERROR. SEE ACTA CRYST. 13, 683 (1960). 1186.000 DO 712 J=1,3 1187.000 P1(J)=XKEEP(IC(J),K) 1188.000 712 P3(J)=XKEEP(IC(J),L) 1189.000 CALL MV(U,X(1,I),XOUT) 1190.000 CALL MV(U,P1,PAR1) 1191.000 CALL MV(U,P3,PAR3) 1192.000 DO 713 J=1,3 1193.000 P1(IC(J))=PAR1(J) 1194.000 P3(IC(J))=PAR3(J) 1195.000 713 CP(IC(J))=XOUT(J) 1196.000 DCS1=DKEEP(K)/DKEEP(L)*COSANG 1197.000 DCS2=DKEEP(L)/DKEEP(K)*COSANG 1198.000 DO 900 J=1,3 1199.000 PAR1(J)=(CP(J)-P1(J))-DCS1*(CP(J)-P3(J)) 1200.000 900 PAR3(J)=(CP(J)-P3(J))-DCS2*(CP(J)-P1(J)) 1201.000 DO 901 J=1,3 1202.000 P1(J)=PAR1(J)*PAR1(J) 1203.000 P2(J)=PAR1(J)+PAR3(J) 1204.000 901 P3(J)=PAR3(J)*PAR3(J) 1205.000 JK=JATOM(K)/531441 1206.000 JL=JATOM(L)/531441 1207.000 E1=0. 1208.000 DO 902 J=1,3 1209.000 902 E1=E1+P3(J)*XIG(J,JK)+P2(J)*P2(J)*XIG(J,I)+P1(J)*XIG(J,JL) 1210.000 SIN2A=1.-COSANG*COSANG 1211.000 IF (SIN2A.LE.0.00001) THEN E1=0. ELSE E1=SQRT(E1/(DKEEP(K)*DKEEP(K)*DKEEP(L)*DKEEP(L)*SIN2A)) 1212.000 1 *57.29577 1213.000 ENDIF ELSE 1214.000 CALL DCODE(JATOM(K),IN(2),S,IS,IT,LTR) 1215.000 DO 700 J=1,3 1216.000 700 LTRAN(J,1)=LTR(J) 1217.000 IN(1)=2 1218.000 C 100C+S FOR ATOM K 1219.000 IN(3)=100+(IS-1)*M+S+(IT-1)*(2-ICENT)*M 1220.000 CALL DCODE(JATOM(L),IN(6),S,IS,IT,LTR) 1221.000 DO 701 J=1,3 1222.000 701 LTRAN(J,2)=LTR(J) 1223.000 C 100C+S FOR ATOM L 1224.000 IN(7)=200+(IS-1)*M+S+(IT-1)*(2-ICENT)*M 1225.000 IN(4)=I 1226.000 C 100C+S FOR APEX ATOM 1227.000 IN(5)=0 1228.000 CALL SUB19 1229.000 IF (F.LT.0.0001) GO TO 16 1230.000 ENDIF 1231.000 IF (INTERL.EQ.2) THEN 1232.000 J=INT(E1*10.)+1 1233.000 IF (E1.EQ.0.) J=-1 1234.000 CALL TABLE(0,J,-1,0,IBRAK1,13) 1235.000 SYMBOL=ATOM(JATOM(K)/531441) 1236.000 CALL CTABLE(SYMBOL, 1,IBRAK2,8) 1237.000 SYMBOL=ATOM(I) 1238.000 CALL CTABLE(SYMBOL, 1,IBRAK3,8) 1239.000 SYMBOL=ATOM(JATOM(L)/531441) 1240.000 CALL CTABLE(SYMBOL, 0,IBRAK4,8) 1241.000 WRITE (2,300) IBRAK2,IBRAK3,IBRAK4,F,IBRAK1 1242.000 300 FORMAT (1X,24A1,F10.1,13A1) 1243.000 IF (IPRIN.EQ.6) 1244.000 1 WRITE (IPRIN,300) IBRAK2,IBRAK3,IBRAK4,F,IBRAK1 1245.000 ELSE 1246.000 WRITE (IPRIN,103) ATOM(JATOM(K)/531441),ATOM(I), 1247.000 1ATOM(JATOM(L)/531441),F,E1 1248.000 ENDIF 1249.000 ENDIF 1250.000 16 CONTINUE 1251.000 ENDIF 1252.000 12 NANGLE(I)=NADC 1253.000 11 CONTINUE 1254.000 IF (INTERL.EQ.1.OR.INTERL.EQ.2) WRITE (2,301) 1255.000 301 FORMAT ('END OF TABLE') 1256.000 RETURN 1257.000 END 1258.000 SUBROUTINE TRSLN(DMAX,AMAX,AMIN,U,INTERL) 1259.000 C TO APPLY THE LATTICE TRANSLATIONS 1260.000 CHARACTER COMPID(72) 1261.000 CHARACTER*8 ATOM(200),FTYPE(13) 1262.000 INTEGER S,COUNT(3),CN(200),CONTNT(13),DONE 1263.000 DIMENSION U(3,3) 1264.000 COMMON IPRIN,LPP,ICORR,IRAD,IC(3), XJ(3),I,J,S,D(3), 1265.000 1 DONE, JATOM(15),XOUT(3), DMAX2,COUNT,INT,IS,ND 1266.000 COMMON/MODELC/COMPID,ATOM,FTYPE 1267.000 COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),X(3,200), 1268.000 1 CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200), 1269.000 2 WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT, 1270.000 3 SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 1271.000 K=1 1272.000 DO 2 L=1,3 1273.000 2 COUNT(L)=0 1274.000 GO TO 4 1275.000 3 XJ(K)=XJ(K)-1. 1276.000 COUNT(K)=COUNT(K)-1 1277.000 4 IF ((X(K,I)-XJ(K))*D(K)-DMAX) 3,3,7 1278.000 6 W=(X(K,I)-XJ(K))*D(K) 1279.000 IF (W+DMAX) 7,14,14 1280.000 14 IF (W-DMAX) 11,11,7 1281.000 7 XJ(K)=XJ(K)+1. 1282.000 COUNT(K)=COUNT(K)+1 1283.000 IF ((X(K,I)-XJ(K))*D(K)+DMAX) 9,6,6 1284.000 9 K=K-1 1285.000 IF (K) 15,15,7 1286.000 15 RETURN 1287.000 11 K=K+1 1288.000 IF (K-3) 4,4,13 1289.000 13 CALL DISTN(AMAX,AMIN,U,INTERL) 1290.000 IF (ND.EQ.15) RETURN 1291.000 K=K-1 1292.000 GO TO 7 1293.000 END 1294.000 SUBROUTINE DISTN(AMAX,AMIN,U,INTERL ) 1295.000 C TO CALCULATE AND PRINT AN INTERATOMIC DISTANCE 1296.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) CHARACTER STAR(2), COMPID(72) 1297.000 CHARACTER*8 ATOM(200),FTYPE(13) 1298.000 INTEGER S,COUNT(3),DONE, CN(200),CONTNT(13) 1299.000 DIMENSION DELX1(3),DELX2(3),SIG(3),DIR(3), U(3,3) 1300.000 COMMON IPRIN,LPP,ICORR,IRAD,IC(3), XJ(3),I,J,S,D(3), 1301.000 1 DONE, JATOM(15),XOUT(3), DMAX2,COUNT,INT,IS, ND, 1302.000 2DKEEP(15),EKEEP(15),XKEEP(3,15),DFKEEP(3,15) 1303.000 COMMON/ESDS/XIG(6,200) 1304.000 COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1305.000 C * * * * GOULD S.E.L. ONLY * * * * * 1306.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1307.000 C * * * * END GOULD S.E.L. CODE * * * * * 1308.000 COMMON/OUT/IN(231) 1309.000 COMMON/W/DIST,FX,NP,NM,NS,NQ,INSAVE,ITDIST,SCLE,SAVEA,SAVEP,C, 1310.000 2VARA,VARP,E,E1,LZ,NQZ,MQZ 1311.000 COMMON/MODELC/COMPID,ATOM,FTYPE 1312.000 COMMON/MODEL/N,M,NT,NTYPE,NFTYPE(200),XI(3,200), 1313.000 1 CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200), 1314.000 2 WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT, 1315.000 3 SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 1316.000 100 FORMAT (' ',A8, '- ',A8,F7.4,F7.4,I4,A1,I4,I5,2I3,3X,3F10.5) 1317.000 101 FORMAT ('0********DISTANCES FROM ',A8,' (',F8.5,2F10.5,')'/ 1318.000 129X,'E.S.D. NS NP TA TB TC',9X,'X2',8X,'Y2',8X,'Z2') 1319.000 DATA STAR/' ','*'/ 1320.000 DO 1 L=1,3 1321.000 1 DELX1(L)=XI(L,I)-XJ(L) 1322.000 CALL MV(U,DELX1,DELX2) 1323.000 DIST=DELX2(1)*DELX2(1)+DELX2(2)*DELX2(2)+DELX2(3)*DELX2(3) 1324.000 IF (DIST-DMAX2) 4,4,5 1325.000 4 LTRAN(IC(1),1)=COUNT(1) 1326.000 LTRAN(IC(2),1)=COUNT(2) 1327.000 LTRAN(IC(3),1)=COUNT(3) 1328.000 XOUT(IC(1))=XJ(1) 1329.000 XOUT(IC(2))=XJ(2) 1330.000 XOUT(IC(3))=XJ(3) 1331.000 IF (ICORR.EQ.0.OR.INTERL.EQ.3) THEN 1332.000 IF (INTERL.LT.2) THEN 1333.000 DO 706 L=1,3 1334.000 706 DIR(IC(L))=DELX2(L) 1335.000 DO 705 L=1,3 1336.000 705 SIG(L)=(XIG(L,I)+XIG(L,J))*DIR(L)*DIR(L) 1337.000 IF (DIST.GE.0.0001) 1 E1=SQRT((SIG(1)+SIG(2)+SIG(3)+2.*DIR(1)*DIR(2)*XIG(4,I) 1338.000 2 +2.*DIR(1)*DIR(2)*XIG(4,J)+2.*DIR(1)*DIR(3)*XIG(5,I) 1339.000 3 +2.*DIR(1)*DIR(3)*XIG(5,J)+2.*DIR(2)*DIR(3)*XIG(6,I) 1340.000 4 +2.*DIR(2)*DIR(3)*XIG(6,J))/DIST) 1341.000 ENDIF 1342.000 DIST=SQRT(DIST) 1343.000 ELSE 1344.000 IN(1)=1 1345.000 IN(2)=I 1346.000 IN(3)=0 1347.000 IN(4)=J 1348.000 IN(5)=100+(IS-1)*M+S+(INT-1)*(2-ICENT)*M 1349.000 CALL SUB19 1350.000 ENDIF 1351.000 IF (DIST.GT.AMAX) GO TO 7 1352.000 IF (INTERL.LT.0.OR.DIST.LT.AMIN) RETURN 1353.000 ND=ND+1 1354.000 EKEEP(ND)=E1 1355.000 DKEEP(ND)=DIST 1356.000 DO 11 L=1,3 1357.000 DFKEEP(IC(L),ND)=DELX2(L) 1358.000 11 XKEEP(L,ND)=XOUT(L) 1359.000 C FORM ATOM DESIGNATOR CODE, A 3-DIGIT NUMBER TO BASE 729, 1360.000 C ALLOWING REPRESENTATION OF ALL LATTICE TRANSLATIONS UP TO 1361.000 C + OR - 4 UNIT CELLS FOR ALL ATOMS IN ALL EQUIVALENT POSITIONS, 1362.000 C SINCE 729=(4-(-4)+1)**3. 1ST DIGIT IS ATOM SEQUENCE NUMBER, 1363.000 C 2ND IS PACKED LATTICE TRANSLATIONS, 3RD IS PACKED EQUIVALENT 1364.000 C POSITION NUMBER,LATTICE POINT NUMBER AND INVERSION INDICATOR. 1365.000 JATOM(ND)=J*531441+((LTRAN(3,1)+4)*81+(LTRAN(2,1)+4)*9+LTRAN(1,1) 1366.000 1+4)*729+S*25+INT*5+IS 1367.000 RETURN 1368.000 7 IF (INTERL+1) 99,2,5 1369.000 2 IF(S.EQ.1.AND.IS.EQ.1.AND.INT.EQ.1.AND.LTRAN(1,1).EQ.0.AND. 1370.000 1LTRAN(2,1).EQ.0.AND.LTRAN(3,1).EQ.0) RETURN 1371.000 99 IF (DONE.EQ.0) THEN 1372.000 DELX1(IC(1))=XI(1,I) 1373.000 DELX1(IC(2))=XI(2,I) 1374.000 DELX1(IC(3))=XI(3,I) 1375.000 WRITE (IPRIN,101) ATOM(I),DELX1 1376.000 DONE=1 1377.000 ENDIF 1378.000 WRITE (IPRIN,100) ATOM(I),ATOM(J),DIST,E1,S,STAR(IS),INT, 1379.000 1(LTRAN(L,1),L=1,3),XOUT 1380.000 5 RETURN 1381.000 END 1382.000 SUBROUTINE SYMPRT(LFC) 1383.000 CHARACTER LINE(66),COMPID(72) 1384.000 CHARACTER*8 LABEL(200),FTYPE(13) 1385.000 INTEGER CN(200),CONTNT(13),START 1386.000 DIMENSION RR(3,4),RRR(3,4) 1387.000 COMMON IPRIN,LPP,ICORR,IRAD,ISWAP(3) 1388.000 COMMON/MODELC/COMPID,LABEL,FTYPE 1389.000 COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200), 1390.000 1 CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200), 1391.000 2 WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT, 1392.000 3 SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT 1393.000 DO 10 I=1,NR 1394.000 DO 1 K=1,3 1395.000 DO 1 J=1,4 1396.000 1 RRR(ISWAP(K),J)=R(I,K,J) 1397.000 DO 2 K=1,3 1398.000 RR(K,4)=RRR(K,4) 1399.000 DO 2 J=1,3 1400.000 2 RR(J,ISWAP(K))=RRR(J,K) 1401.000 START=1 1402.000 DO 11 J=1,3 1403.000 CALL CRDOUT(LINE,START,RR(J,1),RR(J,2),RR(J,3),RR(J,4)) 1404.000 IF (J.EQ.3) GO TO 11 1405.000 LINE(START)=',' 1406.000 START=START+1 1407.000 11 CONTINUE 1408.000 START=START-1 1409.000 10 WRITE (LFC,100) I,(LINE(J),J=1,START) 1410.000 100 FORMAT (I3,2X, 66A1) 1411.000 RETURN 1412.000 END 1413.000 SUBROUTINE ROTAT(X,Y) 1414.000 Z=Y 1415.000 Y=X 1416.000 X=Z 1417.000 RETURN 1418.000 END 1419.000 SUBROUTINE ROTA2(I,J) 1420.000 K=J 1421.000 J=I 1422.000 I=K 1423.000 RETURN 1424.000 END 1425.000 SUBROUTINE PUBS(RCP) 1426.000 C LISTING OF ATOMIC PARAMETERS FOR PUBLICATION. 1427.000 CHARACTER COMPID(72),FSPEC(80),LBUF(148),IBRAK1(10),IBRAK2(7) 1428.000 CHARACTER IBRAK3(7),IBRAK4(7),IBRAK5(4),IBRAK6(4),IBRAK7(4) 1429.000 CHARACTER*8 SYM(200),LABEL,FTYPE(13) 1430.000 CHARACTER*80 CBUF 1431.000 INTEGER SIGU(6),CN(200),CONTNT(13) 1432.000 DIMENSION RCP(3),RAX(3) 1433.000 COMMON IPRIN,LPP,ICORR,IRAD,ISWAP(3),ISIG(3),U(6),SIGU 1434.000 COMMON/CHARA/LBUF,FSPEC 1435.000 COMMON/MODELC/COMPID,SYM,FTYPE 1436.000 COMMON/MODEL/NA,NR,NT,NTYPE,NFTYPE(200),X(3,200), 1437.000 1 CN,SOF(200),BETA(6,200),SIGX(3,200),ESOF(200),SIGB(6,200), 1438.000 2 WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT, 1439.000 3 SFAC(14,13),CONTNT,SCALE,EXTNCT(6) 1440.000 EQUIVALENCE (CBUF,FSPEC) 1441.000 5 FORMAT ( '(1X,10A1,F8.5,7A1,2(F8.5,7A1),1X,F6.3,4A1)') 1442.000 6 FORMAT ( '( 1X,10A1,F6.4,4A1,5(F6.4,4A1))') 1443.000 7 FORMAT ('COORDINATES & UISO/UEQ') 1444.000 17 FORMAT ('END OF TABLE') 1445.000 18 FORMAT ('TEMPERATURE FACTORS') 1446.000 WRITE (2,7) 1447.000 DO 6004 II=1,NA 1448.000 WRITE (CBUF,5) 1449.000 IE1=4 1450.000 DO 1124 I=1,3 1451.000 IF (SIGX(I,II).LE.0.000001) GO TO 1124 1452.000 CALL SETPRE(SIGX(I,II),IE1,FSPEC,0) 1453.000 GO TO 14 1454.000 1124 CONTINUE 1455.000 14 DO 6003 I=1,3 1456.000 ISIG(I)=NINT(SIGX(I,II)*10**IE1) 1457.000 IF (SIGX(I,II).GT.0.000001) GO TO 6003 1458.000 ISIG(I)=-1 1459.000 6003 CONTINUE 1460.000 LABEL=SYM(II) 1461.000 CALL CTABLE(LABEL, 0,IBRAK1,10) 1462.000 CALL TABLE(0, ISIG(1),-1,0, IBRAK2,7) 1463.000 CALL TABLE(0, ISIG(2),-1,0, IBRAK3,7) 1464.000 CALL TABLE(0, ISIG(3),-1,0, IBRAK4,7) 1465.000 U(ISWAP(1))=X(1,II) 1466.000 U(ISWAP(2))=X(2,II) 1467.000 U(ISWAP(3))=X(3,II) 1468.000 IE1=3 1469.000 IF (BETA(2,II).GT.0.000001) THEN 1470.000 RAX(ISWAP(1))=RCP(1) 1471.000 RAX(ISWAP(2))=RCP(2) 1472.000 RAX(ISWAP(3))=RCP(3) 1473.000 U(4)=0. 1474.000 DO 1 I=1,3 1475.000 1 U(4)=U(4)+BETA(I,II)*RAX(I)*RAX(I)*CELL(I)*CELL(I) 1476.000 DO 2 I=1,2 1477.000 DO 2 J=I+1,3 1478.000 2 U(4)=U(4)+BETA(I+J+1,II)*RAX(I)*RAX(J)*CELL(I)*CELL(J)* 1479.000 1 CELL(6-MOD(I+J,3)) 1480.000 U(4)=U(4)/3. 1481.000 UU=0. 1482.000 ELSE 1483.000 U(4)=BETA(1,II) 1484.000 UU=SIGB(1,II) 1485.000 ENDIF 1486.000 IF (UU.GT.0.000001) THEN 1487.000 CALL SETPRE(UU,IE1,FSPEC,2) 1488.000 SIGU(1)=NINT(UU*10**IE1) 1489.000 ELSE 1490.000 SIGU(1)=-1 1491.000 ENDIF 1492.000 CALL TABLE(0,SIGU(1),-1,0,IBRAK5,4) 1493.000 WRITE (2,FSPEC)IBRAK1,U(1),IBRAK2,U(2),IBRAK3,U(3),IBRAK4, 1494.000 1 U(4),(IBRAK5(I),I=1,4) 1495.000 IF (IPRIN.EQ.6) WRITE (IPRIN,FSPEC)IBRAK1,U(1),IBRAK2,U(2), 1496.000 1 IBRAK3,U(3),IBRAK4,U(4),(IBRAK5(I),I=1,4) 1497.000 6004 CONTINUE 1498.000 WRITE (2,17) 1499.000 WRITE (2,18) 1500.000 DO 6005 II=1,NA 1501.000 IF (BETA(2,II).LE.0.000001) GO TO 6005 1502.000 WRITE (CBUF,6) 1503.000 IE1=3 1504.000 DO 1125 I=1,6 1505.000 IF (SIGB(I,II).LE.0.000001) GO TO 1125 1506.000 CALL SETPRE(SIGB(I,II),IE1,FSPEC,1) 1507.000 GO TO 111 1508.000 1125 CONTINUE 1509.000 111 LABEL=SYM(II) 1510.000 CALL CTABLE(LABEL, 0,IBRAK1,10) 1511.000 DO 6006 I=1,6 1512.000 SIGU(I)=NINT(SIGB(I,II)*10**IE1) 1513.000 UU=BETA(I,II) 1514.000 IF (SIGB(I,II).GT.0.000001) GO TO 6006 1515.000 SIGU(I)=-1 1516.000 6006 U(I)= UU 1517.000 CALL TABLE(0, SIGU(1),-1,0,IBRAK2,4) 1518.000 CALL TABLE(0, SIGU(2),-1,0,IBRAK3,4) 1519.000 CALL TABLE(0, SIGU(3),-1,0,IBRAK4,4) 1520.000 CALL TABLE(0, SIGU(4),-1,0,IBRAK5,4) 1521.000 CALL TABLE(0, SIGU(5),-1,0,IBRAK6,4) 1522.000 CALL TABLE(0, SIGU(6),-1,0,IBRAK7,4) 1523.000 WRITE (2,FSPEC)IBRAK1,U(1),(IBRAK2(I),I=1,4),U(2),(IBRAK3(I), 1524.000 1I=1,4),U(3),(IBRAK4(I),I=1,4),U(4),IBRAK5,U(5),IBRAK6,U(6),IBRAK7 1525.000 IF (IPRIN.EQ.6) WRITE (IPRIN,FSPEC) 1526.000 1 IBRAK1,U(1),(IBRAK2(I),I=1,4),U(2),(IBRAK3(I), 1527.000 2I=1,4),U(3),(IBRAK4(I),I=1,4),U(4),IBRAK5,U(5),IBRAK6,U(6),IBRAK7 1528.000 6005 CONTINUE 1529.000 WRITE (2,17) 1530.000 RETURN 1531.000 END 1532.000 SUBROUTINE SETPRE(ESD,IEXP,FSPEC,MODE) 1533.000 COMMON /LIMITS/MAXYZ,MAXUIJ,MAXBON 1534.000 CHARACTER FSPEC(80),BUF(80) 1535.000 CHARACTER*80 CBUF 1536.000 EQUIVALENCE (CBUF,BUF) 1537.000 MAXESD=MAXYZ 1538.000 IF (MODE.GT.0) MAXESD=MAXUIJ 1539.000 DO 1 I=1,5 1540.000 IEXP=6-I 1541.000 IF (NINT(ESD*10**IEXP).LT.MAXESD) GO TO 2 1542.000 1 CONTINUE 1543.000 2 GO TO (4,3,5),MODE+1 1544.000 4 WRITE (CBUF,10) IEXP+3,IEXP,IEXP,6-IEXP 1545.000 10 FORMAT ('(1X,10A1,F',I1,'.',I1,',7A1,2(F8.',I1,',7A1),',I1, 1546.000 1 'X,') 1547.000 J=33 1548.000 GO TO 6 1549.000 3 IF (IEXP.GT.4) IEXP=4 1550.000 WRITE (CBUF,11) IEXP+2,IEXP,IEXP 1551.000 11 FORMAT ('(1X,10A1,F',I1,'.',I1,',4A1,5(F6.',I1,',4A1))') 1552.000 J=80 1553.000 6 DO 7 I=1,J 1554.000 7 FSPEC(I)=BUF(I) 1555.000 RETURN 1556.000 5 WRITE (CBUF,12) IEXP+3, IEXP 1557.000 12 FORMAT ('F',I1,'.',I1,',4A1)') 1558.000 DO 8 I=34,80 1559.000 8 FSPEC(I)=BUF(I-33) 1560.000 RETURN 1561.000 END 1562.000 FUNCTION ACOS(X) 1563.000 IF (ABS(X).GT.1.0) THEN 1564.000 X=SIGN(1.0,X) 1565.000 ENDIF 1566.000 IF (X.EQ.0.0) THEN 1567.000 ACOS=1.5707964 1568.000 ELSE IF (X.LT.0.0) THEN 1569.000 ACOS=3.141593+ATAN(SQRT(1.0-X*X)/X) 1570.000 ELSE 1571.000 ACOS=ATAN(SQRT(1.0-X*X)/X) 1572.000 ENDIF 1573.000 RETURN 1574.000 END 1575.000 SUBROUTINE ORFFEB 1576.000 C LZ=MONITOR OUTPUT, MQZ=BINARY INPUT FROM RBLS 1577.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1578.000 C * * * * GOULD S.E.L. ONLY * * * * * 1579.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1580.000 C * * * * END GOULD S.E.L. CODE * * * * * 1581.000 COMMON/NAT/JTF(200),NADDRX(200),NADDRB(200) 1582.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1583.000 COMMON/NV/DP(MMP),DFDP(MMP) 1584.000 COMMON/OUT/IN(231) 1585.000 COMMON/MET/AA(3,3),BB(3,3) 1586.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1587.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11588.000 20),ROW(6),A(6) 1589.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1590.000 2,E,E1,LZ,NQZ,MQZ 1591.000 COMMON/E/NG 1592.000 COMMON/G1/NJE 1593.000 COMMON/CONSTR/NCON,ICON(99,2),EFACT(99,2) 1594.000 IC(1)=1 1595.000 IC(2)=0 1596.000 IC(3)=1 1597.000 IC(5)=0 1598.000 IC(6)=0 1599.000 IC(7)=0 1600.000 IC(8)=0 1601.000 IC(9)=0 1602.000 IC(10)=0 1603.000 NF=0 1604.000 IDR=0 1605.000 LZ=6 1606.000 MQZ=20 1607.000 REWIND MQZ 1608.000 READ (MQZ) (TITLE(I), I=1,10) 1609.000 READ (MQZ) IC(4), NT 1610.000 READ(MQZ)NA,NCON 1611.000 READ(MQZ)(JTF(I),I=1,NA) 1612.000 IF (NCON.GT.0) READ(MQZ)((EFACT(I,K),K=1,2),I=1,NCON) 1613.000 READ(MQZ)ITF,NQ,IC(2) 1614.000 NP=IC(2) 1615.000 READ (MQZ) (KI1(I),I=1,NP) 1616.000 READ (MQZ) (P(I),I=1,NP) 1617.000 IC(10)=NQ+5 1618.000 IC(8)=NQ+1 1619.000 IF(ITF-1)01301,01301,01401 1620.000 1301 IC(7)=5 1621.000 IC(9)=5 1622.000 GO TO 01501 1623.000 1401 IC(7)=10 1624.000 IC(9)=10 1625.000 1501 KB=IC(10) 1626.000 KX=IC(8) 1627.000 DO 1801 I=1,NA 1628.000 NADDRX(I)=KX 1629.000 NADDRB(I)=KB 1630.000 IF(JTF(I)-1)1811,1811,1812 1631.000 1811 KX=KX+5 1632.000 KB=KB+5 1633.000 GO TO 1801 1634.000 1812 KX=KX+10 1635.000 KB=KB+10 1636.000 1801 CONTINUE 1637.000 READ (MQZ) IC(5) 1638.000 N=IC(5) 1639.000 NM=(N*(N+1))/2 1640.000 READ (MQZ) (PM(K),K=1,NM) 1641.000 NJE = 0 1642.000 DO 02104 I=1,NP 1643.000 IPOINT=KI1(I)/100 1644.000 IF (IPOINT.GT.0) THEN 1645.000 K=0 1646.000 DO 2 J=1,NP 1647.000 IF (KI1(J).EQ.1) THEN 1648.000 K=K+1 1649.000 IF (K.EQ.IPOINT) GO TO 3 1650.000 ENDIF 1651.000 2 CONTINUE 1652.000 3 ICON(MOD(KI1(I),100),1)=I 1653.000 ICON(MOD(KI1(I),100),2)=J 1654.000 KI1(I)=0 1655.000 ENDIF 1656.000 IF (KI1(I).EQ.0) GO TO 2104 1657.000 NJE=NJE+1 1658.000 2104 CONTINUE 1659.000 READ (MQZ) (AS(I),I=1,3),(CAS(I),I=1,3) 1660.000 IF(IDR)02203,02203,02204 1661.000 02203 DO 02206 I=1,3 1662.000 A(I)=AS(I) 1663.000 02206 A(I+3)=CAS(I) 1664.000 GOTO 02207 1665.000 02204 CALL CONVCC(AS,CAS,A) 1666.000 2207 IF(IC(3)-1)03401,02401,02701 1667.000 02401 DO 02402 I=1,21 1668.000 02402 AM(I)=0.0 1669.000 READ (MQZ) AM(1),AM(7),AM(12),AM(16),AM(19),AM(21) 1670.000 DO 02602 I=1,21 1671.000 02602 AM(I)=AM(I)*AM(I) 1672.000 2701 K=1 1673.000 L=6 1674.000 DO 03303 I=1,6 1675.000 DA(I)=(0.01)*SQRT (AM(K)) 1676.000 K=K+L 1677.000 03303 L=L-1 1678.000 03401 NS=IC(4) 1679.000 IF(NS)03701,03701,03601 1680.000 03601 READ (MQZ) ((TS(I,J),(TIS(K,I,J),K=1,3),I=1,3),J=1,NS) 1681.000 DO03630 J=1,NS 1682.000 DO03630 I=1,3 1683.000 NULPE=1 1684.000 DO03629 K=1,3 1685.000 IF(ABS (TIS(K,I,J))-1.0)03612,03612,03613 1686.000 03613 IF(TIS(K,I,J))03614,03614,03615 1687.000 03614 IS(1,I,J)=-K 1688.000 IS(2,I,J)=-K 1689.000 GOTO03630 1690.000 03615 IS(1,I,J)=K 1691.000 IS(2,I,J)=K 1692.000 GOTO03630 1693.000 03612 IF(TIS(K,I,J))03609,03629,03611 1694.000 03609 IS(NULPE,I,J)=-K 1695.000 NULPE=NULPE+1 1696.000 GOTO03629 1697.000 03611 IS(NULPE,I,J)=K 1698.000 NULPE=NULPE+1 1699.000 03629 CONTINUE 1700.000 GOTO(03620,03621,03630,03620),NULPE 1701.000 3620 WRITE (LZ,03622) 1702.000 03622 FORMAT(23H ERROR IN SYMMETRY CARD) 1703.000 STOP 1704.000 03621 IS(2,I,J)=0 1705.000 03630 CONTINUE 1706.000 IF(NT)03701,03701,03751 1707.000 03751 READ (MQZ) ((ANT(IL,I),IL=1,3),I=1,NT) 1708.000 NST=0 1709.000 DO03780 INT=1,NT 1710.000 NST=NST+NS 1711.000 DO03780 INS=1,NS 1712.000 INST=NST+INS 1713.000 DO03770 IL=1,3 1714.000 TS(IL,INST)=AMOD((TS(IL,INS)+ANT(IL,INT)),1.0) 1715.000 DO03770 IIS=1,2 1716.000 03770 IS(IIS,IL,INST)=IS(IIS,IL,INS) 1717.000 3780 CONTINUE 1718.000 NS=NS*(NT+1) 1719.000 IC(4)=NS 1720.000 03701 IF(IC(1))03801,04001,03801 1721.000 03801 K=1 1722.000 L=N 1723.000 DO 03903 I=1,N 1724.000 DP(I)=(0.01)*SQRT (PM(K)) 1725.000 K=K+L 1726.000 03903 L=L-1 1727.000 4001 RETURN 1728.000 END 1729.000 FUNCTION ARCCOS(X) 1730.000 C ARC COS IN DEGREES 1731.000 ARCCOS=57.2957795*ACOS(X) 1732.000 RETURN 1733.000 END 1734.000 SUBROUTINEATOM(I,Y) 1735.000 CATOM 1471 WRB ATOM COORDINATE SUBROUTINE 1736.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1737.000 C * * * * GOULD S.E.L. ONLY * * * * * 1738.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1739.000 C * * * * END GOULD S.E.L. CODE * * * * * 1740.000 COMMON/E/NG 1741.000 COMMON/OUT/IN(231) 1742.000 COMMON/NAT/JTF(200),NADDRX(200),NADDRB(200) 1743.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1744.000 COMMON/NV/DP(MMP),DFDP(MMP) 1745.000 COMMON/MET/AA(3,3),BB(3,3) 1746.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1747.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11748.000 20),ROW(6),A(6) 1749.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1750.000 2,E,E1,LZ,NQZ,MQZ 1751.000 DIMENSIONI(2),X(3),Y(3) 1752.000 IF(I(1))109,109,117 1753.000 109 X(1)=0.0 1754.000 X(2)=0.0 1755.000 X(3)=0.0 1756.000 GOTO125 1757.000 117 I1=I(1) 1758.000 K=NADDRX(I1) 1759.000 1176 IF(K+2-IC(2))119,119,503 1760.000 503 NG=5 1761.000 GOTO325 1762.000 119 DO123J=1,3 1763.000 X(J)=P(K) 1764.000 123 K=K+1 1765.000 125 KC=I(2)/100 1766.000 KS=I(2)-100*KC 1767.000 IF(KS-IC(4))203,203,403 1768.000 403 NG=1 1769.000 GOTO325 1770.000 203 IF(KS)403,205,213 1771.000 205 Y(1)=X(1) 1772.000 Y(2)=X(2) 1773.000 Y(3)=X(3) 1774.000 GOTO311 1775.000 213 DO215J=1,3 1776.000 215 Y(J)=TS(J,KS) 1777.000 DO309K=1,3 1778.000 DO307J=1,2 1779.000 L=IS(J,K,KS) 1780.000 IF(L)225,307,305 1781.000 225 L=-L 1782.000 Y(K)=Y(K)-X(L) 1783.000 GOTO307 1784.000 305 Y(K)=Y(K)+X(L) 1785.000 307 CONTINUE 1786.000 309 CONTINUE 1787.000 311 IF (KC.EQ.0) RETURN 1788.000 Y(1)=Y(1)+LTRAN(1,KC) 1789.000 Y(2)=Y(2)+LTRAN(2,KC) 1790.000 Y(3)=Y(3)+LTRAN(3,KC) 1791.000 325 RETURN 1792.000 END 1793.000 SUBROUTINE CONVCC(AX,CO,AST) 1794.000 DIMENSION AX(3),AST(6),CO(3) ,ZIN(3),SIS(3) 1795.000 DO 1 I=1,3 1796.000 1 ZIN(I)=SQRT (1.0-CO(I)**2) 1797.000 AST(4)=(CO(2)*CO(3)-CO(1))/(ZIN(2)*ZIN(3)) 1798.000 AST(5)=(CO(1)*CO(3)-CO(2))/(ZIN(1)*ZIN(3)) 1799.000 AST(6)=(CO(1)*CO(2)-CO(3))/(ZIN(1)*ZIN(2)) 1800.000 DO 2 I=1,3 1801.000 2 SIS(I)=SQRT (1.0-AST(I+3)**2) 1802.000 AST(1)=1.0/(AX(1)*SIS(2)*ZIN(3)) 1803.000 AST(2)=1.0/(AX(2)*SIS(1)*ZIN(3)) 1804.000 AST(3)=1.0/(AX(3)*SIS(1)*ZIN(2)) 1805.000 RETURN 1806.000 END 1807.000 FUNCTIONCOSVV(X,Y) 1808.000 CCOSVV 1471 WRB COSINE OF ANGLE BETWEEN VECTORS X AND Y 1809.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1810.000 C * * * * GOULD S.E.L. ONLY * * * * * 1811.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1812.000 C * * * * END GOULD S.E.L. CODE * * * * * 1813.000 COMMON/E/NG 1814.000 COMMON/OUT/IN(231) 1815.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1816.000 COMMON/NV/DP(MMP),DFDP(MMP) 1817.000 COMMON/MET/AA(3,3),BB(3,3) 1818.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1819.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11820.000 20),ROW(6),A(6) 1821.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1822.000 2,E,E1,LZ,NQZ,MQZ 1823.000 DIMENSIONX(3),Y(3) 1824.000 D=SQRT (VMV(X,AA,X)*VMV(Y,AA,Y)) 1825.000 IF(D)111,111,115 1826.000 111 NG=9 1827.000 GOTO117 1828.000 115 COSVV=VMV(X,AA,Y)/D 1829.000 117 RETURN 1830.000 END 1831.000 SUBROUTINEDIFV(X,Y,Z) 1832.000 CDIFV 1471 WRB VECTOR - VECTOR 1833.000 C Z(3)=X(3)-Y(3) 1834.000 DIMENSIONX(3),Y(3),Z(3) 1835.000 DO111I=1,3 1836.000 111 Z(I)=X(I)-Y(I) 1837.000 RETURN 1838.000 END 1839.000 FUNCTIONFUNA(I) 1840.000 CFUNA 1471 WRB ANGLE SUBROUTINE USED BY FUN2, FUN5, FUN6 1841.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1842.000 C * * * * GOULD S.E.L. ONLY * * * * * 1843.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1844.000 C * * * * END GOULD S.E.L. CODE * * * * * 1845.000 COMMON/E/NG 1846.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1847.000 COMMON/NV/DP(MMP),DFDP(MMP) 1848.000 COMMON/MET/AA(3,3),BB(3,3) 1849.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1850.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11851.000 20),ROW(6),A(6) 1852.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1853.000 2,E,E1,LZ,NQZ,MQZ 1854.000 DIMENSIONI(6),X1(3),X2(3),X3(3),V1(3),V2(3) 1855.000 CALLSTOAA 1856.000 CALLATOM(I(1),X1) 1857.000 CALLATOM(I(3),X2) 1858.000 CALLATOM(I(5),X3) 1859.000 IF(NG)123,117,123 1860.000 117 CALLDIFV(X1,X2,V1) 1861.000 CALLDIFV(X3,X2,V2) 1862.000 FUNA=ARCCOS(COSVV(V1,V2)) 1863.000 123 RETURN 1864.000 END 1865.000 FUNCTIONFUND(I) 1866.000 CFUND 1471 WRB DISTANCE SUBROUTINE USED BY FUN1 AND FUN4 1867.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1868.000 C * * * * GOULD S.E.L. ONLY * * * * * 1869.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1870.000 C * * * * END GOULD S.E.L. CODE * * * * * 1871.000 COMMON/E/NG 1872.000 COMMON/OUT/IN(231) 1873.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1874.000 COMMON/NV/DP(MMP),DFDP(MMP) 1875.000 COMMON/MET/AA(3,3),BB(3,3) 1876.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1877.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11878.000 20),ROW(6),A(6) 1879.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1880.000 2,E,E1,LZ,NQZ,MQZ 1881.000 DIMENSIONI(4),X1(3),X2(3),V(3) 1882.000 CALLSTOAA 1883.000 CALLATOM(I(1),X1) 1884.000 CALLATOM(I(3),X2) 1885.000 CALLDIFV(X2,X1,V) 1886.000 FUND=SQRT (VMV(V,AA,V)) 1887.000 RETURN 1888.000 END 1889.000 SUBROUTINE FUNI(I) 1890.000 C SELECTS THE FUN SUBROUTINE TO BE ENTERED 1891.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1892.000 C * * * * GOULD S.E.L. ONLY * * * * * 1893.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1894.000 C * * * * END GOULD S.E.L. CODE * * * * * 1895.000 COMMON/E/NG 1896.000 COMMON/OUT/IN(231) 1897.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1898.000 COMMON/NV/DP(MMP),DFDP(MMP) 1899.000 COMMON/MET/AA(3,3),BB(3,3) 1900.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1901.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11902.000 20),ROW(6),A(6) 1903.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1904.000 2,E,E1,LZ,NQZ,MQZ 1905.000 COMMON/CONSTR/NCON,ICON(99,2),EFACT(99,2) 1906.000 CALL SETA(A) 1907.000 IF (NCON.GT.0) THEN 1908.000 DO 1 J=1,NCON 1909.000 1 P(ICON(J,1))=P(ICON(J,2))*EFACT(J,1)+EFACT(J,2) 1910.000 ENDIF 1911.000 IF(I)6,6,5 1912.000 5 IF(I-2) 8,8,6 1913.000 6 NG=11 1914.000 GO TO 160 1915.000 8 GO TO (10,20),I 1916.000 10 CALL FUN1 1917.000 GO TO 160 1918.000 20 CALL FUN2 1919.000 GO TO 160 1920.000 160 RETURN 1921.000 END 1922.000 SUBROUTINEFUN1 1923.000 CFUN1 1471 WRB COMPUTE INTERATOMIC DISTANCE 1924.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1925.000 C * * * * GOULD S.E.L. ONLY * * * * * 1926.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1927.000 C * * * * END GOULD S.E.L. * * * * * 1928.000 COMMON/E/NG 1929.000 COMMON/OUT/IN(231) 1930.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1931.000 COMMON/NV/DP(MMP),DFDP(MMP) 1932.000 COMMON/MET/AA(3,3),BB(3,3) 1933.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1934.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11935.000 20),ROW(6),A(6) 1936.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1937.000 2,E,E1,LZ,NQZ,MQZ 1938.000 FX=FUND(IN(2)) 1939.000 RETURN 1940.000 END 1941.000 SUBROUTINEFUN2 1942.000 CFUN2 1471 WRB BOND ANGLE SUBROUTINE 1943.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 1944.000 C * * * * GOULD S.E.L. ONLY * * * * 1945.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 1946.000 C * * * * END GOULD S.E.L. * * * * * 1947.000 COMMON/E/NG 1948.000 COMMON/OUT/IN(231) 1949.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 1950.000 COMMON/NV/DP(MMP),DFDP(MMP) 1951.000 COMMON/MET/AA(3,3),BB(3,3) 1952.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 1953.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(11954.000 20),ROW(6),A(6) 1955.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP1956.000 2,E,E1,LZ,NQZ,MQZ 1957.000 FX=FUNA(IN(2)) 1958.000 RETURN 1959.000 END 1960.000 SUBROUTINEMV(X,Y,Z) 1961.000 CMV 1471 WRB MATRIX * VECTOR 1962.000 C Z(3)=X(3,3)*Y(3) 1963.000 DIMENSIONX(3,3),Y(3),Z(3) 1964.000 DO113I=1,3 1965.000 Z(I)=0.0 1966.000 DO113J=1,3 1967.000 113 Z(I)=Z(I)+X(I,J)*Y(J) 1968.000 RETURN 1969.000 END 1970.000 SUBROUTINENORM(X,Y,Z) 1971.000 CNORM 1471 WRB STORE A VECTOR Z NORMAL TO VECTORS X AND Y 1972.000 COMMON/MET/AA(3,3),BB(3,3) 1973.000 DIMENSIONX(3),Y(3),Z(3),X1(6),Y1(6),Z1(3) 1974.000 DO115I=1,3 1975.000 X1(I)=X(I) 1976.000 X1(I+3)=X(I) 1977.000 Y1(I)=Y(I) 1978.000 115 Y1(I+3)=Y(I) 1979.000 DO119I=1,3 1980.000 119 Z1(I)=X1(I+1)*Y1(I+2)-X1(I+2)*Y1(I+1) 1981.000 CALLMV(BB,Z1,Z) 1982.000 RETURN 1983.000 END 1984.000 SUBROUTINE PREI(I) 1985.000 C SELECTS THE PRE SUBROUTINE TO BE ENTERED 1986.000 4 IF(I)160,160,6 1987.000 6 IF(I-15)8,8,160 1988.000 8 GO TO (10,20),I 1989.000 10 CALL PRE1 1990.000 GO TO 160 1991.000 20 CALL PRE2 1992.000 GO TO 160 1993.000 160 RETURN 1994.000 END 1995.000 SUBROUTINEPRE1 1996.000 COMMON/OUT/IN(231) 1997.000 CALLSETKX(IN(2)) 1998.000 CALLSETKX(IN(4)) 1999.000 RETURN 2000.000 END 2001.000 SUBROUTINEPRE2 2002.000 CPRE2 1471 WRB PRELIMINARY SUBROUTINE 2 2003.000 COMMON/OUT/IN(231) 2004.000 DO 107 I=2,6,2 2005.000 107 CALLSETKX(IN(I)) 2006.000 RETURN 2007.000 END 2008.000 SUBROUTINE SETKX(I) 2009.000 CSETKX SET KEY WORDS FOR ATOM COORDINATES 2010.000 C I=IN(K), THE INSTRUCTION INTEGER SPECIFYING THE ATOM NUMBER 2011.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 2012.000 C * * * * GOULD S.E.L. ONLY * * * * * 2013.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 2014.000 C * * * * END GOULD S.E.L. * * * * * 2015.000 COMMON/NAT/JTF(200),NADDRX(200),NADDRB(200) 2016.000 COMMON/E/NG 2017.000 COMMON/OUT/IN(231) 2018.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 2019.000 COMMON/NV/DP(MMP),DFDP(MMP) 2020.000 COMMON/MET/AA(3,3),BB(3,3) 2021.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 2022.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12023.000 20),ROW(6),A(6) 2024.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP2025.000 2,E,E1,LZ,NQZ,MQZ 2026.000 IF(I)119,119,111 2027.000 111 J=NADDRX(I) 2028.000 KI2(J)=1 2029.000 KI2(J+1)=1 2030.000 KI2(J+2)=1 2031.000 119 RETURN 2032.000 END 2033.000 SUBROUTINESTOAA 2034.000 CSTOAA 1471 WRB STORE METRIC TENSOR 2035.000 COMMON/MET/AA(3,3),BB(3,3) 2036.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12037.000 20),ROW(6),A(6) 2038.000 AA(1,1)=A(1)*A(1) 2039.000 AA(2,2)=A(2)*A(2) 2040.000 AA(3,3)=A(3)*A(3) 2041.000 AA(1,2)=A(1)*A(2)*A(6) 2042.000 AA(1,3)=A(1)*A(3)*A(5) 2043.000 AA(3,1)=AA(1,3) 2044.000 AA(2,1)=AA(1,2) 2045.000 AA(2,3)=A(2)*A(3)*A(4) 2046.000 AA(3,2)=AA(2,3) 2047.000 RETURN 2048.000 END 2049.000 SUBROUTINE SUB13 2050.000 CSUB13 ERROR CALCULATION AND OUTPUT 2051.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 2052.000 C * * * * GOULD S.E.L. ONLY * * * * * 2053.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 2054.000 C * * * * END GOULD S.E.L. * * * * * 2055.000 COMMON/E/NG 2056.000 COMMON/OUT/IN(231) 2057.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 2058.000 COMMON/NV/DP(MMP),DFDP(MMP) 2059.000 COMMON/MET/AA(3,3),BB(3,3) 2060.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 2061.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12062.000 20),ROW(6),A(6) 2063.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP2064.000 2,E,E1,LZ,NQZ,MQZ 2065.000 COMMON/G1/NJE 2066.000 109 FORMAT (1H ,51X,3H***,I3) 2067.000 619 FORMAT (1H ,48X,F9.4,6X,3H***,I3) 2068.000 IF(NG)107,113,107 2069.000 107 WRITE (LZ,109)NG 2070.000 GO TO 723 2071.000 113 VARA=0.0 2072.000 VARP=0.0 2073.000 IF(IC(3))119,313,119 2074.000 119 DO 211 I=1,6 2075.000 IF(DA(I))201,123,201 2076.000 123 DFDA(I)=0.0 2077.000 GO TO 211 2078.000 201 SAVEA=A(I) 2079.000 A(I)=A(I)+DA(I) 2080.000 CALL FUNI(IN(1)) 2081.000 A(I)=SAVEA 2082.000 DFDA(I)=(FX-F)/DA(I) 2083.000 211 CONTINUE 2084.000 K=1 2085.000 L=6 2086.000 DO 311 I=1,6 2087.000 IF(DFDA(I))225,221,225 2088.000 221 K=K+L 2089.000 GO TO 311 2090.000 225 C=1.0 2091.000 DO 309 J=I,6 2092.000 IF(DFDA(J))305,307,305 2093.000 305 VARA=VARA+C*DFDA(I)*DFDA(J)*AM(K) 2094.000 307 K=K+1 2095.000 309 C=2.0 2096.000 311 L=L-1 2097.000 313 IF(IC(1))315,615,315 2098.000 315 NP=IC(2) 2099.000 DO 319 I=1,NP 2100.000 319 KI2(I)=0 2101.000 CALL PREI(IN(1)) 2102.000 J=0 2103.000 N=IC(5) 2104.000 DO 513 I=1,NJE 2105.000 403 J=J+1 2106.000 IF(KI1(J))407,403,407 2107.000 407 IF(KI2(J))413,409,413 2108.000 409 DFDP(I)=0.0 2109.000 GO TO 513 2110.000 413 IF(DP(I))501,409,501 2111.000 501 SAVEP=P(J) 2112.000 P(J)=P(J)+DP(I) 2113.000 CALL FUNI(IN(1)) 2114.000 P(J)=SAVEP 2115.000 DFDP(I)=(FX-F)/DP(I) 2116.000 L=I 2117.000 513 CONTINUE 2118.000 KK=1 2119.000 KKD=N 2120.000 DO 613 I=1,L 2121.000 IF(DFDP(I))523,612,523 2122.000 523 K=KK 2123.000 C=1.0 2124.000 DO 611 J=I,L 2125.000 IF(DFDP(J))607,609,607 2126.000 607 VARP=VARP+C*DFDP(I)*DFDP(J)*PM(K) 2127.000 609 K=K+1 2128.000 611 C=2.0 2129.000 612 KK=KK+KKD 2130.000 613 KKD=KKD-1 2131.000 615 IF(NG)617,623,617 2132.000 617 WRITE (LZ,619)F,NG 2133.000 GO TO 723 2134.000 623 E1=SQRT (VARP) 2135.000 E=SQRT (VARP+VARA) 2136.000 723 RETURN 2137.000 END 2138.000 SUBROUTINESUB19 2139.000 CSUB19 1471 WRB FUNCTION AND ERROR CALCULATION 2140.000 PARAMETER (MMP=850,MATRX=MMP*(MMP+1)/2) COMMON/ORFFE/PM(MATRX),LTRAN(3,20) 2141.000 C * * * * GOULD S.E.L. ONLY * * * * * 2142.000 C EXTENDED BLOCK/ORFFE/PM(MATRX),LTRAN(3,20) 2143.000 C * * * * END GOULD S.E.L. * * * * * 2144.000 COMMON/E/NG 2145.000 COMMON/OUT/IN(231) 2146.000 COMMON/NP/KI1(2000),KI2(2000),P(2000) 2147.000 COMMON/NV/DP(MMP),DFDP(MMP) 2148.000 COMMON/MET/AA(3,3),BB(3,3) 2149.000 COMMON/NS/TIS(3,3,48),IS(2,3,48),TS(3,48) 2150.000 COMMON/R/IC(10),AM(21),DA(6),DFDA(6),ANT(3,4),AS(3),CAS(3),TITLE(12151.000 20),ROW(6),A(6) 2152.000 COMMON/W/F,FX,NP,NM,NS,NQ,INSAVE,ITF,SCALE,SAVEA,SAVEP,C,VARA,VARP2153.000 2,E,E1,LZ,NQZ,MQZ 2154.000 NG=0 2155.000 IF(IN(1))117,117,109 2156.000 109 IF(IN(1)-20)111,111,117 2157.000 111 CALL FUNI(IN(1)) 2158.000 F=FX 2159.000 CALLSUB13 2160.000 117 RETURN 2161.000 END 2162.000 FUNCTIONVMV(W,X,Y) 2163.000 CVMV 1471 WRB TRANSPOSED VECTOR * MATRIX * VECTOR 2164.000 C VMV=W(3)*X(3,3)*Y(3) 2165.000 DIMENSIONW(3),X(3,3),Y(3),Z(3) 2166.000 CALLMV(X,Y,Z) 2167.000 VMV=VV(W,Z) 2168.000 RETURN 2169.000 END 2170.000 FUNCTIONVV(X,Y) 2171.000 CVV 1471 WRB TRANSPOSED VECTOR * VECTOR 2172.000 C VV=X(3)*Y(3) 2173.000 DIMENSIONX(3),Y(3) 2174.000 VV=0.0 2175.000 DO111I=1,3 2176.000 111 VV=VV+X(I)*Y(I) 2177.000 RETURN 2178.000 END 2179.000 SUBROUTINE SETA(A) 2180.000 RETURN 2181.000 END 2182.000