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 (DEFAULTS 20, 10)'/ 0059.000
3' BONDS '/ 0060.000
4' ANGLES '/' TORSION_ANGLES '/ 0061.000
5' ASYMMETRIC'/' PLANES'/' LOCAL_GEOMETRY '/ 0062.000
6' NON-BONDED_DISTANCES '/' CONTACTS '/ 0063.000
7' CORRELATIONS GIVEN'/' PRINT '/' PAGE_LENGTH (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