C *(INPUT,OUTPUT,PUNCH,TAPE1,TAPE44,TAPE5=INPUT,TAPE6=OUTPUT) C *** FORTRAN DECK IS BCD/IBM-026-KEYPUNCH, NOT EBCDIC/IBM-029-KEYPUNCH C ***** OAK RIDGE THERMAL ELLIPSOID PLOT PROGRAM ***** C ***** ORTEP-II / IBM-360 / FEB 1971 / INSTRUCTIONS IN ORNL-3794 ** C ***** OPTIONAL OVERLAP FEATURE ADDED TO ORTEP IN FEBRUARY 1971 *** C ***** CUBANE EXAMPLE CARDS ILLUSTRATE USE OF OVERLAP FEATURE ***** C ***** IN BRIEF, INSTRUCTION 511 MAY BE USED JUST BEFORE EACH C ***** DRAWING TO STORE THE PROJECTED ATOMS, TYPE 2 TRAILER CARDS C ***** WITH INSTR 511 CAUSES PROJECTED BONDS ALSO TO BE STORED C ***** MAXIMUM NUMBER OF STORED BONDS IS 599. IN GENERAL, JUST USE C ***** THE SAME TYPE 2 TRAILER CARDS USED BY THE 802/812 INSTR. *** C ***** COLS 10-18 ON 511 INST CARD SPECIFIES OVERLAP MARGIN(OVMRGN) C ***** 0 OVMRGN = MAX(0.025 OR SQRT(SCAL1)*0.030) C ***** 1 OR -1 OVMRGN = 0.0 C ***** .GT.0,.LT.1 OVMRGN = ACTUAL VALUE GIVEN (INCHES) ***** C ***** ALL OVERLAP INFORMATION IS DESTROYED BY INSTR. 501-510 C ***** IF THE COMPUTER MEMORY AVAILABLE IS EXCEEDED BY THIS FEATURE C ***** SUBROUTINES LAP500, LAP700, LAP800, LAPDRW, LAPAB AND LAPCON C ***** MAY BE REMOVED AND REPLACED BY THE FOLLOWING 4 DUMMIES C SUBROUTINE LAP500(NTYPE) C RETURN C END C SUBROUTINE LAP700(NA,ICQ) C RETURN C END C SUBROUTINE LAP800(NA1,NA2,ICQ) C RETURN C END C SUBROUTINE LAPDRW(Y,NPEN,NCQ) C RETURN C C Modified for SUN 1991,08.02 ny C SUBROUTINE ORTEPMAIN(fname) CHARACTER*6 CHEM CHARACTER*4 TITLE,TITLE2 CHARACTER*255 MYTITLE DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT character*255 fname LTNO=0 IFLG=0 C **************************************ny ipos_null = index(fname,"\0") open (10,file=fname(1:ipos_null-1)) C **************************************** 2 CALL PRIME C ***** READ JOB TITLE CARD ***** READ (IN,4) (TITLE(I),I=1,18) 4 FORMAT(18A4) MYTITLE = TITLE(1) DO ITITLENUM = 2,18 MYTITLE = MYTITLE // TITLE(ITITLENUM) END DO WRITE (NOUT,6)(TITLE(I),I=1,18) 5 FORMAT(1H010X,18A4) 6 FORMAT(1H110X,18A4) CALL PRELIM WRITE (NOUT,6)(TITLE(I),I=1,18) ISAVE=0 GO TO 507 7 ISAVE=0 C ***** ZERO AIN ARRAY ***** 8 DO 10 J=1,140 10 AIN(J)=0. 11 FORMAT(1H04X,17H((((( INSTRUCTIONI5,6H )))))) 12 FORMAT(I3,I6,7F9.0) 13 FORMAT(I3,I6,7E15.8) 14 FORMAT(1H 9X,7E15.7) C ***** READ NEW INSTRUCTION CARD ***** NCD=0 N1=-6 16 N1=N1+7 N2=N1+6 IF(ISAVE)22,18,18 18 READ (IN,12)IC,NF,(AIN(I),I=N1,N2) IF(ISAVE)24,24,20 20 WRITE (NSR)IC,NF,(AIN(I),I=N1,N2) GO TO 24 22 READ (NSR)IC,NF,(AIN(I),I=N1,N2) IF(IC)7,24,24 24 IF(N1-1)26,26,30 26 WRITE (NOUT,11)NF NF1=NF IF(NF1)28,8,30 28 IF(NF1+2)2,2,3000 30 WRITE (NOUT,14)(AIN(I),I=N1,N2) 32 IC=IC+1 GO TO (90,16,38,50),IC 33 FORMAT(I3,6X,5I3,8F6.0) 34 FORMAT(6I3,8E12.5) 35 FORMAT(1H 11X,5I3,8F11.5) C ***** READ FORMAT 2 TRAILER CARDS ***** 38 NCD=NCD+1 IF(ISAVE)44,40,40 40 READ (IN,33)IC,(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8) IF(ISAVE)46,46,42 42 WRITE (NSR)IC,(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8) GO TO 46 44 READ (NSR)IC,(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8) 46 WRITE (NOUT,35)(KD(I,NCD),I=1,5),(CD(I,NCD),I=1,8) GO TO 32 C ***** READ FORMAT 3 TRAILER CARD ***** 50 IF(ISAVE)52,54,54 52 READ (NSR)(TITLE2(I),I=1,18) GO TO 55 54 READ (IN ,4)(TITLE2(I),I=1,18) 55 WRITE (NOUT,5)(TITLE2(I),I=1,18) IF(ISAVE)90,90,56 56 WRITE (NSR)(TITLE2(I),I=1,18) C ***** EXECUTE INSTRUCTION ***** 90 NJ=NF1/100 NJ2=NF1-NJ*100 NJ3=MOD(NJ2,10) IF(NJ-12)98,92,92 92 IF(NJ.EQ.13) GO TO 93 CALL SPARE(NF1) GO TO 91 C C ***** CALL HGSP ***** C ***** SET ATTENSION LEVEL ***** 93 CONTINUE 91 IF(NG) 94,8,94 94 CALL ERPNT(0.,NF1) GO TO 8 C ******BRANCH TABLE FOR FUNCTION TYPES****** 98 GO TO(100,200,300,400,500,600,700,800,900,1000,1100),NJ C *******STRUCTURE ANALYSIS FUNCTIONS******* 100 GO TO (101,101,104,104,101,101,94),NJ2 101 CALL SEARC GO TO 8 C ***** ANISOTROPIC TEMP FACTOR OUTPUT ***** 104 DO 164 I=1,NATOM IF(MOD(I,14)-1)134,114,134 114 WRITE (NOUT,6)(TITLE(J),J=1,18) WRITE (NOUT,129) 129 FORMAT(1H010X,4HATOM3X,16HRMS DISPLACEMENT3X,31HROW VECTORS, BASED 1 ON REFERENCE17X,29HPROBABILITY COVARIANCE MATRIX) 134 T1=55501.+FLOAT(I)*100000. CALL PAXES(T1,-3) IF(NG)144,154,144 144 CALL ERPNT(T1,104) 149 FORMAT(1H010X,A6,F10.6,6X,3F12.7,10X,3F12.7) 154 WRITE (NOUT,149)CHEM(I),RMS(1),(PAC(J,1),J=1,3),(Q(J,1) 1,J=1,3) 164 WRITE (NOUT,159)(RMS(K),(PAC(J,K),J=1,3),(Q(J,K),J=1,3) 1,K=2,3) 159 FORMAT(1H 16X,F10.6,6X,3F12.7,10X,3F12.7) GO TO 8 C *******PLOTTER INITIALIZE,FRAME ADVANCE,TERMINATE FUNCTIONS******* 200 CALL F200 GO TO 8 300 GO TO (301,302,303,94),NJ2 C *******PLOT DIMENSIONS******* 301 IF(AIN(1))321,321,311 311 XLNG(1)=AIN(1) 321 IF(AIN(2))341,341,331 331 XLNG(2)=AIN(2) 341 IF(AIN(3))361,351,351 351 VIEW=AIN(3) 361 IF(AIN(4))381,381,371 371 BRDR=AIN(4) 381 WRITE (NOUT,389)XLNG(1),XLNG(2),BRDR C 389 FORMAT(1H010X,11HPLOT LIMITSF6.2,3H BYF6.2,15H IN. INCLUDINGF6.2, C 112H IN. MARGIN) 389 FORMAT(1H010X,11HPLOT LIMITSF6.2,3H BYF6.2,15H MM. INCLUDINGF6.2, 112H MM. MARGIN) 391 WRITE (NOUT,399)VIEW C 399 FORMAT(1H 10X,13HVIEW DISTANCEF7.3,7H INCHES) 399 FORMAT(1H 10X,13HVIEW DISTANCEF7.3,7H MM. ) C--------------------------------------------------------------------* C ( CALL GRAPHIC OR PLOT SUBROUTINE & OPEN CHECK ) * C--------------------------------------------------------------------* STMLTX=AIN(5) IF(STMLTX.LE.1.0) STMLTX=1.0 GDXLNG=XLNG(1)*STMLTX GDYLNG=XLNG(2) IF ( IFLG.NE.0 ) GOTO 2000 CYAMAZAKI READ(11,5000) IGP IGP=0 5000 FORMAT(I1) IF(IGP.EQ.1) GO TO 4000 CALL GINIT( GDXLNG , GDYLNG , IDEV ) C TITLE(CARD NO.1) DRAW CALL DRAWTITLE(MYTITLE) IFLG = 1 GO TO 2000 4000 CALL PINIT( GDXLNG,GDYLNG) IFLG = 1 2000 CONTINUE GO TO 8 C *******LEGEND ROTATION******* 302 THETA=AIN(1) T1=THETA*.01745329252E0 COSTH=COS(T1) SINTH=SIN(T1) DO 312 J=1,9 312 SYMB(J,1)=0. SYMB(1,1)=COSTH SYMB(2,2)=COSTH SYMB(3,3)=1. SYMB(2,1)=SINTH SYMB(1,2)=-SINTH WRITE (NOUT,319)THETA 319 FORMAT(1H010X,44HREGULAR TITLE AND SYMBOL ROTATION IN DEGREESF8.2) GO TO 8 C ***** RETRACE DISPLACEMENT ***** 303 DISP=AIN(1) WRITE (NOUT,313)DISP C NY SET PEN SIZE TO 'DISP' SIZE CALL SETPENSIZE(DISP) DISP = 0.0 313 FORMAT(1H010X,11HPEN SIZE = F7.0,8H POINTS ) C 313 FORMAT(1H010X,22HRETRACE DISPLACEMENT =F7.4,5H INCH) C 313 FORMAT(1H010X,22HRETRACE DISPLACEMENT =F7.4,5H MM. ) GO TO 8 C *******ATOM LIST FUNCTIONS******* 400 GO TO (401,401,401,401,401,401,490, 94, 94,410, 1 401,401,401,401,401,401, 94),NJ2 401 CALL F400 GO TO 490 410 LATM=0 DO 420 I=1,500 DO 420 J=1,4 420 ATOMS(J,I)=0. 490 IF(LATM)8,8,491 491 WRITE (NOUT,499)(ATOMS(1,I),I=1,LATM) 499 FORMAT(1H010X,23HCONTENTS OF ATOMS ARRAY/(15X,10F10.0)) GO TO 8 C *******CARTESIAN COORDINATE SYSTEM FUNCTIONS******* 500 CALL F500 WRITE (NOUT,503)(ORGN(J),J=1,3) 503 FORMAT(1H0,10X, 44HORIGIN FOR PROJECTION AXIS IN CRYSTAL COORD. 1,3F15.6) IF(NJ3-3)507,539,601 507 WRITE (NOUT,529) WRITE (NOUT,519)((REFV(J,I),I=1,3),(AAREV(J,I),I=1,3),J 1=1,3) GO TO 8 509 FORMAT(1H010X, 49HORTHONORMAL WORKING VECTORS BASED ON CRYSTAL AXE 1S18X,33HPOST-FACTOR TRANSFORMATION MATRIX/16X,8HX VECTOR8X,8HY VEC 2TOR8X,8HZ VECTOR) 519 FORMAT(1H 10X,3E16.7,8X,3E16.7) 529 FORMAT(1H010X,51HORTHONORMAL REFERENCE VECTORS BASED ON CRYSTAL AX 1ES16X,33HPOST-FACTOR TRANSFORMATION MATRIX/16X,8HX VECTOR8X,8HY VE 2CTOR8X,8HZ VECTOR) 539 WRITE (NOUT,509) WRITE (NOUT,519)((WRKV(J,I),I=1,3),(AAWRK(J,I),I=1,3),J 1=1,3) GO TO 8 C *******PLOT CENTERING FUNCTIONS******* 600 CALL F600 601 WRITE (NOUT,609)XO(1),XO(2),SCAL1,SCAL2 C 609 FORMAT(1H010X,31HORIGIN POINT IN PLOTTER COORD.(F6.2,2H ,F6.2,8H ) C 1 IN. / 11X,15HOVERALL SCALE =F6.3,32H INCH/ANGSTROM ELLIPSOID SCA 609 FORMAT(1H010X,31HORIGIN POINT IN PLOTTER COORD.(F6.2,2H ,F6.2,8H ) 1 MM. / 11X,15HOVERALL SCALE =F6.3,32H MM./ANGSTROM ELLIPSOID SCA 2LE =F6.3) GO TO 391 C *******ELLIPSOID AND SYMBOL PLOT FUNCTIONS******* C ********FILL OUT DETAILS FOR SPECIAL MODELS******** 700 GO TO (701,702,704,705,709,94),NJ3 701 AIN(3)=8. GO TO 703 702 AIN(3)=0. 703 AIN(1)=4. AIN(2)=0. AIN(4)=0. GO TO 709 704 AIN(1)=3. AIN(2)=-5. GO TO 706 705 AIN(1)=1. AIN(2)=0. 706 AIN(3)=1. AIN(4)=5. 709 CALL F700 GO TO 8 C *******BOND FUNCTIONS******* 800 CALL F800 GO TO 8 C *******TITLE FUNCTIONS******* 900 CALL F900 GO TO 8 C *******CELL OUTLINE FUNCTIONS******* 1000 CALL F1000 GO TO 8 C *******SAVE SEQUENCE FUNCTIONS******* 1100 IF(NJ2-2)1101,1102,1103 1101 ISAVE=1 GO TO 1104 1102 ISAVE=0 J=-1 END FILE NSR GO TO 1104 1103 ISAVE=-1 1104 REWIND NSR GO TO 8 C ***** TERMINATE PLOTTER TAPE IF NECESSARY ***** 3000 IF(LTNO)3010,3010,3005 C3005 AIN(1)=-.000001 C AIN(2)= 0.0 C NJ2=2 C CALL F200 C3005 CALL PLOTE ******************************************** C-----------------------------------------------------------------* C CALL GRAPHIC AND PLOTTER END * C-----------------------------------------------------------------* 3005 CALL VSTERM(0,0) IF(IGP.EQ.1) GO TO 3006 CALL TINPUT(IDUMMY) 3006 CALL GPSLTM C3010 CALL EXIT 3010 CONTINUE C **************************************** close(10) close(NOUT) C **************************************** RETURN END FUNCTION ARCCOS(X) C ARCCOS(X) IN DEGREES IF(1.0-ABS(X))1,2,2 1 X=DSIGN(DBLE(1.0),DBLE(X)) 2 IF(X)3,4,5 3 ARCCOS=180.0+ATAN(SQRT(1.0-X*X)/X)*57.29577951E0 GO TO 6 4 ARCCOS=90.0 GO TO 6 5 ARCCOS=ATAN (SQRT(1.0-X*X)/X)*57.29577951E0 6 RETURN END SUBROUTINE ATOM(QA,Z) C ATOM COORDINATE SUBROUTINE DIMENSION X(3),Z(3) INTEGER*4 KSYM CHARACTER*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT K=QA/100000.0 IF(K)109,109,117 109 X(1)=0.0 X(2)=0.0 X(3)=0.0 GO TO 125 117 IF(K-NATOM)119,119,503 503 NG=5 GO TO 325 119 DO 123 J=1,3 123 X(J)=P(J,K) 125 TA=ABS(QA) KSYM=AMOD(TA,100000.0) KT=KSYM/100 KS=KSYM-100*KT IF(KS-NSYM)203,203,403 403 NG=4 GO TO 325 203 IF(KS)403,205,213 205 Z(1)=X(1) Z(2)=X(2) Z(3)=X(3) GO TO 311 213 DO 223 K=1,3 Z(K)=TS(K,KS) DO 223 J=1,3 223 Z(K)=Z(K)+FS(J,K,KS)*X(J) 311 IF(KT)403,325,313 313 IF(KT-555)317,315,317 315 KSYM=KS GO TO 325 317 K1=KT/100 K=KT-100*K1 K2=K/10 K3=K-10*K2 Z(1)=Z(1)+FLOAT(K1-5) Z(2)=Z(2)+FLOAT(K2-5) Z(3)=Z(3)+FLOAT(K3-5) 325 RETURN END SUBROUTINE AXEQB(A1,X,B1,JJJ) C ***** SOLUTION OF MATRIX EQUATION AX=B FOR X ***** C ***** USES METHOD OF TRIANGULAR ELIMINATION ***** C ***** B AND X HAVE DIMENSIONS (3,JJJ),A IS ALWAYS (3,3) C ***** TO INVERT A MAKE B 3 BY 3 IDENITY MATRIX ***** DIMENSION A1(3,3),A(3,3),B(3,3),B1(3,3),X(3,3) NV=JJJ C ***** TRANSFER DATA ***** DO 2 I=1,3 DO 2 J=1,3 IF(NV-J)2,1,1 1 B(I,J)=B1(I,J) 2 A(I,J)=A1(I,J) C ***** TRIANGULARIZE MATRIX A ***** DO 17 I=1,2 S=0.0 DO 4 J=I,3 R=ABS(A(J,I)) IF(R-S)4,3,3 3 S=R L=J 4 CONTINUE IF(L-I)5,10,5 5 DO 6 J=I,3 S=A(I,J) A(I,J)=A(L,J) 6 A(L,J)=S DO 8 J=1,NV S=B(I,J) B(I,J)=B(L,J) 8 B(L,J)=S 10 TEM=A(I,I) IF(TEM)11,17,11 11 IPO=I+1 DO 16 J=IPO,3 IF(A(J,I))12,16,12 12 S=A(J,I)/TEM A(J,I)=0.0 DO 13 K=IPO,3 13 A(J,K)=A(J,K)-A(I,K)*S DO 15 K=1,NV 15 B(J,K)=B(J,K)-B(I,K)*S 16 CONTINUE 17 CONTINUE C ***** MODIFY SINGULAR MATRIX ***** DO 20 I=1,3 IF(A(I,I))20,19,20 19 A(I,I)=AMAX1(1.E-25,AMAX1(A(1,1),A(2,2),A(3,3))*1.E-15) 20 CONTINUE DO 24 K=1,NV DO 24 I=1,3 N=4-I M=N+1 TEM=B(N,K) IF(3-M)23,21,21 21 DO 22 J=M,3 22 TEM=TEM-A(N,J)*B(J,K) 23 B(N,K)=TEM/A(N,N) 24 X(N,K)=B(N,K) RETURN END SUBROUTINE AXES(U,V,X,ITYPE) C ***** STORE THREE ORTHOGONAL VECTORS EACH 1 ANGSTROM LONG ***** C ***** ITYPE .GT.0 FOR CARTESIAN,.LE.0 FOR TRICLINIC ***** C *****IABS(ITYPE)=1 W(1)=U,W(2)=(UXV),W(3)=UX(UXV) ***** C *****IABS(ITYPE)=2 W(1)=U,W(2)=(UXV)XU,W(3)=(UXV) ***** C ***** ITYPE=0 W(1)=A,W(2)=(AXB)XA,W(3)=(AXB), ABC=CELL VECTORS *** DIMENSION U(3),V(3),W(3,3),X(3,3) IT=ITYPE IF(IT)115,105,115 105 U(1)=1. U(2)=0. U(3)=0. V(1)=0. V(2)=1. V(3)=0. 115 DO 125 J=1,3 125 W(J,1)=U(J) IF(IABS(IT)-1)145,135,145 135 CALL NORM(U,V,W(1,2),IT) CALL NORM(U,W(1,2),W(1,3),IT) GO TO 155 145 CALL NORM(U,V,W(1,3),IT) CALL NORM(W(1,3),U,W(1,2),IT) 155 DO 195 I=1,3 IF(IT)165,165,175 165 IC=-1 GO TO 195 175 IC=1 195 CALL UNIT(W(1,I),X(1,I),IC) RETURN END SUBROUTINE DIFV(X,Y,Z) C VECTOR - VECTOR C Z(3)=X(3)-Y(3) DIMENSION X(3),Y(3),Z(3) DO 111 I=1,3 111 Z(I)=X(I)-Y(I) RETURN END SUBROUTINE BOND(Z1,Z2,NB,NA1,NA2) DIMENSION B(3,3),E(3,3),S(3,3),U(3,3),VUE(3) DIMENSION V7(3),W(13,2),X(3),Z(3) CHARACTER*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT INTEGER*4 L C ***** OBTAIN POSITIONAL PARAMETERS ***** NG1=0 DO 105 J=1,26 105 W(J,1)=0. W(1,1)=Z1 W(1,2)=Z2 DO 135 I=1,2 CALL XYZ(W(1,I),W(4,I),2) IF(NG)125,110,125 110 DO 115 J=1,3 115 W(J+6,I)=XT(J) K=W(1,I)/100000. L=W(1,I)-FLOAT(K)*100000. CALL PLTXY(W(4,I),W(2,I)) IF(EDGE-BRDR*.25)120,128,128 120 NG=10 125 NG1=1 WRITE (NOUT,136)CHEM(K),K,L,(W(J,I),J=2,9) CALL ERPNT(W(1,I),800) GO TO 135 128 IF(NJ2-10)130,135,135 130 WRITE (NOUT,136)CHEM(K),K,L,(W(J,I),J=2,9) 135 CONTINUE 136 FORMAT(1H 10X,A6,3H (I3,1H,I5,4H) 2F8.2,5X,3F8.3,13X,3F8.4) IF(NG1)999,140,999 140 CALL DIFV(W(7,1),W(7,2),V7) DIST=SQRT(VMV(V7,AA,V7)) IF(MOD(NJ2,10)-3)143,142,142 142 HGT=SCL*.12 IF(LTNO.LT.0) GO TO 2140 CALL SYMBOL(W(2,1),W(3,1),HGT,MOD(IFIX(W(1,1)/100000.),10),0.,-1) 1 CALL SYMBOL(W(2,2),W(3,2),HGT,MOD(IFIX(W(1,2)/100000.),10),0.,-2) 1 GO TO 570 C ***** HGSP ***** 2140 CONTINUE GO TO 570 143 KODE=KD(5,NB) IF(KODE)145,144,146 144 NBND=0 GO TO 148 145 KODE=-KODE 146 NBND=128/2**KODE C ***** FIND UPPERMOST ATOM PUT IN POSITION ONE ***** 148 IF(VIEW)152,150,152 150 W(12,1)=1. W(12,2)=1. IF(W(6,1)-W(6,2))165,175,175 C *****VECTOR FROM ATOM TO VIEWPOINT ***** 152 DO 160 I=1,2 DO 155 J=10,12 155 W(J,I)=-W(J-6,I) W(12,I)=W(12,I)+VIEW C ***** DISTANCE SQUARED TO VIEWPOINT ***** 160 W(13,I)=VV(W(10,I),W(10,I)) IF(W(13,2)-W(13,1))165,175,175 C ***** SWITCH ATOMS ***** 165 DO 170 J=1,13 T1=W(J,1) W(J,1)=W(J,2) 170 W(J,2)=T1 C ***** FORM IDEMFACTOR MATRIX ***** 175 DO 180 J=1,3 E(J,J)=1. E(J+1,1)=0. 180 E(J+5,1)=0. C ***** FORM VECTOR SET RADIAL TO BOND ***** CALL DIFV(W(4,2),W(4,1),DA(1,3)) CALL UNIT(DA(1,3),V3,1) C ***** UNIT VECTOR FROM BOND MIDPOINT TO REFERENCE VIEWPOINT ***** DO 183 I=1,3 V2(I)=0.0 DO 181 J=1,3 181 V2(I)=V2(I)+AAREV(J,3)*WRKV(J,I) IF(VIEW)183,183,182 182 V2(I)=V2(I)*VIEW-0.5*(W(I+3,1)+W(I+3,2)) 183 CONTINUE CALL UNIT(V2,V2,1) T6=ABS(VV(V3,V2)) IF(.9994-T6)185,185,187 C ***** ALTERNATE CALC IF BOND IS ALONG REFERENCE VIEW DIRECTION *** 185 DO 186 J=1,3 186 V2(J)=W(J+9,1)+W(J+9,2) CALL UNIT(V2,V2,1) T6=ABS(VV(V3,V2)) IF(.9994-T6)390,390,187 187 CALL AXES(V3,V2,B,1) 188 T1=CD(3,NB)/SCAL2 DO 190 J=1,3 DA(J,1)=-B(J,2)*T1 190 DA(J,2)=-B(J,3)*T1 IF(NBND)500,500,195 195 CALL RADIAL(3) C ***** DERIVE QUADRICS FOR EACH ATOM ***** DO 380 II=1,2 CALL PAXES(W(1,II),2) IF(NG)205,210,205 205 CALL ERPNT(W(1,II),800) GO TO 999 C ***** DOES BOND GO TO ELLIPSOID OR TO ENVELOPE ***** 210 T1=3-II*2 DO 212 J=1,3 V3(J)=V3(J)*T1 212 VUE(J)=0. IF(KD(5,NB))260,260,215 215 IF(VMV(V3,Q,W(10,II)))220,260,260 220 IBND=0 IF(VIEW)240,240,225 C ***** DERIVE TANGENT CONE DIRECTLY WITHOUT ROTATING COORDINATES ** 225 T2=-(SCAL2*RMS(1)*RMS(2)*RMS(3))**2 DO 230 J=1,3 V1(J)=-W(J+9,II)/SCAL1 VUE(J)=V1(J)/SCAL2 C ***** INVERT ELLIPSOID MATRIX ***** DO 230 K=J,3 T1=0.0 DO 228 I=1,3 228 T1=T1+PAC(J,I)*PAC(K,I)*RMS(I)**2 U(J,K)=T1 230 U(K,J)=T1 C ***** ADD POLARIZED COFACTOR MATRIX TO ELLIPSOID MATRIX ***** DO 235 J=1,3 J1=MOD(J,3)+1 VJ1=V1(J1) J2=MOD(J+1,3)+1 VJ2=V1(J2) DO 235 K=J,3 K2=MOD(K+1,3)+1 K1=MOD(K,3)+1 S(J,K)=T2*Q(J,K)+(VJ2*(U(J1,K1)*V1(K2)-U(J1,K2)*V1(K1)) 1 + VJ1*(U(J2,K2)*V1(K1)-U(J2,K1)*V1(K2))) 235 S(K,J)=S(J,K) T5=0.0 GO TO 300 C ***** DERIVE TANGENT CYLINDER WITH AXIS ALONG Z ***** 240 T1=-1.0/Q(3,3) DO 250 J=1,2 DO 245 K=1,2 245 S(K,J)=Q(K,J)+Q(K,3)*Q(J,3)*T1 S(3,J)=0.0 250 S(J,3)=0.0 S(3,3)=0.0 GO TO 270 C ***** TRANSFER ELLIPSOID ***** 260 DO 265 J=1,9 265 S(J,1)=Q(J,1) IBND=II 270 T5=1. C ***** CHECK FOR BOND TAPER ***** 300 IF(II-2)305,310,310 305 RADIUS=1.+T6*TAPER GO TO 320 310 RADIUS=1.-T6*TAPER 320 CALL MV(S,V3,V4) T2=VV(V3,V4) C ***** COMPUTE BOND INTERSECTION ***** KL=5-II-II KSTP=4 IF(NJ2-21)324,322,322 322 KSTP=32 324 DO 335 K=1,65,KSTP DO 325 J=1,3 V6(J)=D(J,K)*RADIUS 325 V5(J)=V6(J)+VUE(J) T3=VV(V5,V4) T4=T3*T3-T2*(VMV(V5,S,V5)-T5) IF(T4)345,330,330 330 T4=SQRT(T4) T1=(T4-T3)/T2 T3=(-T4-T3)/T2 L=K+KL-1 DO 335 J=1,3 D(J,L)=(V6(J)+T1*V3(J))*SCL 335 D(J,L+1)=(-V6(J)-T3*V3(J))*SCL IF(IBND+21-NJ2)360,338,360 338 IF(KD(5,NB))360,360,340 C ***** FOR OVERLAP, MAKE BOND QUADRANGLE TANGENT TO ENVELOPING CONE 340 T3=VV(VUE,V4) T4=T3**2-T2*(VMV(VUE,S,VUE)-T5) IF(T4)345,350,350 345 NG=13 CALL ERPNT(W(1,II),800) GO TO 999 350 T1=(SQRT(T4)-T3)/T2 DO 355 J=1,3 T4=(T1*V3(J)*SCL-0.5*(D(J,KL)+D(J,KL+64)))*1.001 D(J,KL)=D(J,KL)+T4 355 D(J,KL+64)=D(J,KL+64)+T4 360 CALL PROJ(D(1,KL),DP(1,II),W(4,II),XO,VIEW,1,65,KSTP) IF(IBND-1)370,365,370 365 CALL PROJ(D(1,KL+5),DP(1,II+68),W(4,II),XO,VIEW,1,61,KSTP) GO TO 380 C ***** RETRACE TOP HALF ***** 370 DO 375 K=4,64,4 L=K+II M=L+64 N=66-L DP(1,M)=DP(1,N) 375 DP(2,M)=DP(2,N) 380 CONTINUE C ***** CHECK FOR OVERLAP OR HIDDEN BOND ***** DO 395 K=1,65,32 T1=0. T2=0. DO 385 J=1,2 T1=T1+(DP(J,K)-W(J+1,1))**2 385 T2=T2+(DP(J,K+1)-W(J+1,1))**2 IF(T2-T1)390,390,395 395 CONTINUE GO TO 396 390 NG=14 CALL ERPNT(W(1,2),800) GO TO 999 C ***** CALL OVERLAP ROUTINE ***** 396 ICQ=0 CALL LAP800(NA1,NA2,ICQ) IF(NJ2-21)400,999,999 400 IF(ICQ)390,405,405 C ***** DRAW BOND OUTLINE ***** C INCREMENTS ARE RELATED TO THE NUMBER OF LINES BETWEEN 2 BOND LINES 405 CALL DRAW(DP(1,1),0.,0.,3) DO 415 K=5,129,16 415 CALL DRAW(DP(1,K),0.,0.,2) DO 420 K=2,66,16 420 CALL DRAW(DP(1,K),0.,0.,2) CALL DRAW(DP(1,65),0.,0.,2) C ***** DRAW BOND DETAIL ***** 425 K=65 430 K=K-NBND IF(K-1)500,500,435 435 CALL DRAW(DP(1,K),0.,0.,3) CALL DRAW(DP(1,K+1),0.,0.,2) K=K-NBND IF(K-1)500,500,440 440 CALL DRAW(DP(1,K+1),0.,0.,3) CALL DRAW(DP(1,K),0.,0.,2) GO TO 430 500 HGT=CD(4,NB) OFF=CD(5,NB) IF(HGT)570,570,510 C ***** PERSPECTIVE BOND LABEL ROUTINE ***** C ***** BASE DECISIONS ON REFERENCE SYSTEM ***** 510 K=0 CALL DIFV(W(7,2),W(7,1),V7) CALL VM(V7,AAREV,V1) CALL AXES(V1,E(1,3),U,1) DO 535 I=1,3 T1=1. IF(I-2)515,515,520 515 IF(VV(U(1,I),SYMB(1,I)))525,530,530 520 IF(MOD(K,2))530,525,530 525 T1=-1. K=K+1 530 DO 535 J=1,3 U(J,I)=U(J,I)*T1 535 VT(J,I)=B(J,I)*T1 DO 540 J=1,3 540 VT(J,4)=.5*(W(J+3,1)+W(J+3,2)) C ***** CHECK FOR EXCESS FORESHORTENING ***** IF(FORE-ABS(U(3,1)))545,550,550 545 CALL NORM(U(1,2),SYMB(1,3),VT(1,1),1) VT(1,3)=SYMB(1,3) VT(2,3)=SYMB(2,3) VT(3,3)=SYMB(3,3) HGT=CD(6,NB) OFF=CD(7,NB) IF(HGT)550,999,550 550 T1=CD(8,NB) C Z(1)=VT(1,4)-HGT*(11.+3.*T1)/7. Z(1)=VT(1,4)-HGT*(12.5+3.5*T1)/7. Z(2)=VT(2,4)+OFF-HGT*.5 Z(3)=VT(3,4) XO(3)=Z(3) ITILT=1 I9=T1+2. T9=10.**I9 DISTR=AINT((DIST*T9)+0.5)/T9 +.0001 CALL NUMBER(Z(1),Z(2),HGT,DISTR,0.,I9) 570 ITILT=0 IF(NJ2-10)580,999,999 580 WRITE (NOUT,571)DIST 571 FORMAT(1H 59X,10HDISTANCE =F8.3/1H ) 999 RETURN END SUBROUTINE DRAW(W,DX,DY,NPEN) DIMENSION W(3),X(3),Y(3),Z(3) CHARACTER*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT Y(1)=W(1)+DX Y(2)=W(2)+DY IF(ITILT)115,140,115 C ***** ROTATE FOR PERSPECTIVE TITLE ***** 115 Y(3)=XO(3) DO 120 I=1,3 120 Z(I)=Y(I)-VT(I,4) DO 130 I=1,3 130 X(I)=VT(I,1)*Z(1)+VT(I,2)*Z(2)+VT(I,3)*Z(3)+VT(I,4) CALL PLTXY(X,Y) C ***** CHECK BOUNDRY ***** 140 DO 160 J=1,2 IF(Y(J)-XLNG(J)+.1)150,150,145 145 Y(J)=XLNG(J)-.1 150 IF(Y(J)-.1)155,160,160 155 Y(J)=.1 160 CONTINUE C ***** CHECK FOR OVERLAP ***** NCQ=0 CALL LAPDRW(Y,NPEN,NCQ) IF(NCQ)165,165,170 C ***** CALL PLOTTING ROUTINE IF NO OVERLAPPING ELEMENTS ARE STORED 165 CALL SCRIBE(Y,NPEN,LTNO) 170 RETURN END SUBROUTINE EIGEN (W,VALU,VECT) C ***** EIGENVALUES AND EIGENVECTORS OF 3X3 MATRIX ***** REAL*8 W1,W2,W3 DIMENSION W(3,3),VALU(3),VECT(3,3),A(3,3),B(3,3),V(3),U(3) COMMON NG C ***** STATEMENT FUNCTION ***** PHIF(Z)=((B2-Z)*Z+B1)*Z+B0 C ***** START OF PROGRAM ***** ERRND=5.E-7 SIGMA=0. DO 115 J=1,3 DO 115 I=1,3 TEM=W(I,J) A(I,J)=TEM 115 SIGMA=SIGMA+TEM*TEM C ***** CHECK FOR NULL MATRIX ***** IF(SIGMA)230,230,120 120 SIGMA=SQRT(SIGMA) C ***** FORM CHARACTERISTIC EQUATION ***** B2=A(1,1)+A(2,2)+A(3,3) B1=-A(1,1)*A(2,2)-A(1,1)*A(3,3)-A(2,2)*A(3,3)+A(1,3)*A(3,1) 1+A(2,3)*A(3,2)+A(1,2)*A(2,1) B0=A(1,1)*A(2,2)*A(3,3)+A(1,2)*A(2,3)*A(3,1)+A(1,3)*A(3,2)*A(2,1)- 1A(1,3)*A(3,1)*A(2,2)-A(1,1)*A(2,3)*A(3,2)-A(1,2)*A(2,1)*A(3,3) C ***** FIRST ROOT BY BISECTION ***** X=0. Y=SIGMA TEM=PHIF(SIGMA) VNEW=0.0 IF(B0)135,250,145 135 IF(TEM)140,140,165 140 Y=-Y GO TO 165 145 Y=0. X=SIGMA IF(TEM)165,165,150 150 X=-X C ***** NOW PHIF(X).LT.0.AND.PHIF(Y).GT.0. ***** 165 VNEW=(X+Y)*.5 DO 225 I=1,40 175 IF(PHIF(VNEW))180,250,185 180 X=VNEW GO TO 200 185 Y=VNEW 200 VOLD=VNEW VNEW=(X+Y)*.5 TEM=ABS(VOLD-VNEW) IF(TEM-ERRND)250,250,205 205 IF(VOLD)210,225,210 210 IF (ABS(TEM/VOLD)-ERRND)250,250,225 225 CONTINUE C ***** DID NOT CONVERGE, SET ERROR INDICATOR ***** 230 NG=6 GO TO 400 C ***** STORE FIRST ROOT ***** 250 U(3)=VNEW C ***** DEFLATE ***** C1=B2-VNEW C0=B1+C1*VNEW C ***** SOLVE QUADRATIC ***** TEM=C1*C1+4.*C0 IF(TEM)255,265,260 C ***** IGNORE IMAGINARY COMPONENT OF COMPLEX ROOT ***** 255 TEM=0. GO TO 265 260 TEM=SQRT(TEM) 265 U(1)=.5*(C1-TEM) U(2)=.5*(C1+TEM) C ***** SORT ROOTS ***** DO 275 J=1,2 IF(U(J)-U(3))275,275,270 270 TEM=U(J) U(J)=U(3) U(3)=TEM 275 CONTINUE LLL=-2 DO 375 III=1,2 C ***** CHECK FOR MULTIPLE ROOTS ***** TEM=ERRND*100. NG=0 L=1 DO 305 I=1,2 IF(U(I+1)-U(I)-TEM)300,300,290 290 IF(U(I))295,305,295 295 IF(ABS((U(I+1)-U(I))/U(I))-TEM)300,300,305 300 L=L-1 NG=NG-2*I 305 CONTINUE IF(LLL-L)308,400,400 308 LLL=L C ***** EIGENVECTOR ROUTINE ***** DO 375 II=1,3 T1=U(II) IF(L)315,310,322 C ***** TWO VECTORS NULL FOR DOUBLE ROOT ***** 310 IF(NG+5-II)315,322,315 C ***** ALL VECTORS NULL FOR TRIPLE ROOT ***** 315 DO 320 J=1,3 320 VECT(J,II)=0.0 GO TO 375 322 DO 325 J=1,3 325 A(J,J)=W(J,J)-T1 SMAX=0.0 DO 355 I=1,3 I1=1 IF(I-2)335,335,340 335 I1=I+1 340 B(I,1)=A(I,2)*A(I1,3)-A(I,3)*A(I1,2) B(I,2)=A(I,3)*A(I1,1)-A(I,1)*A(I1,3) B(I,3)=A(I,1)*A(I1,2)-A(I,2)*A(I1,1) TEM=B(I,1)**2+B(I,2)**2+B(I,3)**2 IF(TEM-SMAX)355,355,350 350 SMAX=TEM IMAX=I 355 CONTINUE IF(SMAX)353,353,360 353 NG=7 GO TO 375 360 SMAX=SQRT(SMAX) DO 365 J=1,3 365 V(J)=B(IMAX,J)/SMAX C ***** REFINE EIGENVECTOR ***** CALL AXEQB(A,V,V,1) W1=V(1) W2=V(2) W3=V(3) TEM=DMAX1(DABS(W1),DABS(W2),DABS(W3)) DO 370 J=1,3 370 V(J)=V(J)/TEM CALL UNIT(V,VECT(1,II),1) C ***** REFINE EIGENVALUE ***** T1=VMV(VECT(1,II),W,VECT(1,II)) U(II)=T1 375 VALU(II)=T1 400 RETURN END SUBROUTINE ERPNT(T1,N) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT WRITE (NOUT,115)NG,T1,N 115 FORMAT(1H 10X,10HFAULT NG =I3,F10.0,I6/1H ) NG=0 RETURN END SUBROUTINE F200 character*6 CHEM CHARACTER*4 TITLE,TITLE2 C DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT NULL=2 NJQ=NJ2+1 GO TO (300,210,220,230,240,300),NJQ C ***** INITIATE CALCOMP PLOTTER ( 201 INSTRUCTION) ***** 210 LTNO=44 C CALL PLOTS('PLOTER',0.0) ********************************* GO TO 300 C ***** SET ABSOLUTEORIGIN OF PLOTTER **** 220 CALL PLOT(AIN(1),AIN(2),-3) GO TO 300 230 CONTINUE 240 CONTINUE 300 RETURN END SUBROUTINE F400 C ***** ATOM LIST FUNCTIONS ***** character*6 CHEM CHARACTER*4 TITLE,TITLE2 INTEGER*4 IL2,IL3,IL4,IL5,I104,I103,I102 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT I104=10000 I103=1000 I102=100 NG=0 IF(LATM)402,402,400 400 DO 401 I=1,LATM 401 CALL ATOM(ATOMS(1,I),ATOMS(2,I)) 402 IF(MOD(NJ2,10)-1)499,404,403 403 CALL SEARC GO TO 499 C ***** STORES (401) OR REMOVES (411) RUNS OF ATOMS ***** C ***** RUN HIERARCHY = ATOM NO./SYM/ A/B/C TRANS. ***** 404 II=1 C ***** FIND RUNS IN AIN ARRAY ***** 405 T1=AIN(II) IF(T1)410,410,420 410 II=II+1 IF(140-II)499,405,405 420 JJ=II C ***** SET INITIAL RUN VALUES ***** M1=T1/100000. M2=AMOD(T1,100.) M5=AMOD(T1/100.,1000.) IF(M5)422,422,423 422 M5=555 423 M3=M5/100 M4=MOD(M5/10,10) M5=MOD(M5,10) 425 JJ=JJ+1 IF(140-JJ)435,430,430 430 T2=-AIN(JJ) IF(T2)435,425,440 435 II=JJ-1 C ***** SET TERMINAL VALUES FOR DEGENERATE RUN ***** N1=M1 N2=M2 N3=M3 N4=M4 N5=M5 GO TO 450 440 II=JJ C ***** SET TERMINAL RUN VALUES ***** N1=T2/100000. N2=AMOD(T2,100.) N5=AMOD(T2/100.,1000.) IF(N5)445,445,446 445 N5=555 446 N3=N5/100 N4=MOD(N5/10,10) N5=MOD(N5,10) C ***** LOOP THROUGH ALL RUNS ***** 450 DO 490 L5=M5,N5 DO 490 L4=M4,N4 DO 490 L3=M3,N3 DO 490 L2=M2,N2 DO 490 L1=M1,N1 IL2=L2 IL3=L3 IL4=L4 IL5=L5 V1(1)=FLOAT(L1)*100000.+FLOAT(IL3*I104+IL4*I103+IL5*I102+IL2) CALL ATOM(V1(1),V1(2)) IF(NG)455,458,455 455 CALL ERPNT(V1(1),401) GO TO 490 458 CALL STOR 490 CONTINUE GO TO 410 499 RETURN END SUBROUTINE F500 DIMENSION RM(3,3),V(3,4) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT NG=0 IF(NJ2-11)500,600,610 500 IF(NJ2-1)610,501,510 501 T1=AIN(1) CALL ATOM(T1,ORGN) IF(NG)502,504,502 502 CALL ERPNT(T1,501) CALL MYEXIT 504 DO 506 K=1,4 T1=AIN(K+1) CALL ATOM(T1,V(1,K)) IF(NG)502,506,502 506 CONTINUE DO 507 J=1,3 V1(J)=V(J,2)-V(J,1) 507 V2(J)=V(J,4)-V(J,3) IND=-1 IF(AIN(7))509,509,508 508 IND=-2 509 CALL AXES(V1,V2,REFV,IND) GO TO 562 510 IF(NJ2-4)515,511,599 C ***** SHIFT ORIGIN FOR PROJECTION AXIS (IN MMETER) ***** 511 DO 513 J=1,3 DO 512 K=1,3 512 ORGN(J)=ORGN(J)+REFV(J,K)*AIN(K)/SCAL1 513 XO(J)=XO(J)+AIN(J) GO TO 570 C ***** FORM ROTATION MATRIX ***** 515 DO 552 L=1,139,2 I=AIN(L) IF(I) 532,552,516 516 X=AIN(L+1)*.01745329252E0 T1=COS(X) T2=SIN(X) I3=MOD(I+2,3)+1 I1=MOD(I3,3)+1 I2=MOD(I1,3)+1 RM(I1,I1)=T1 RM(I1,I2)=T2 RM(I1,I3)=0.0 RM(I2,I1)=-T2 RM(I2,I2)=T1 RM(I2,I3)=0.0 RM(I3,I1)=0.0 RM(I3,I2)=0.0 RM(I3,I3)=1.0 CALL MM(REFV,RM,V) IF(NJ2-3)518,525,599 518 DO 522 J=1,9 522 REFV(J,1)=V(J,1) GO TO 552 525 DO 528 J=1,9 528 WRKV(J,1)=V(J,1) GO TO 552 532 IF(NJ2-3)535,552,599 535 I=MOD(-I,3) DO 542 J=1,I DO 542 K=1,3 T1=REFV(K,3) REFV(K,3)=REFV(K,2) REFV(K,2)=REFV(K,1) 542 REFV(K,1)=T1 552 CONTINUE IF(NJ2-3)562,582,599 562 CALL MM(AA,REFV,AAREV) 570 DO 572 J=1,9 WRKV(J,1)=REFV(J,1) 572 AAWRK(J,1)=AAREV(J,1) GO TO 599 582 CALL MM(AA,WRKV,AAWRK) 599 CONTINUE C ***** ELIMINATE ALL PREVIOUSLY STORED OVERLAP INFORMATION **** C ***** (ALL INSTRUCTIONS FROM 501 THROUGH 510 DO THIS ***** CALL LAP500(0) GO TO 610 C ***** STORE NEW OVERLAP INFORMATION (INSTRUCTION 511) ***** 600 CALL LAP500(1) 610 RETURN END SUBROUTINE F600 C ***** SCALING AND CENTERING FUNCTIONS ***** DIMENSION MAX(3),SCAL(4),X(3),XMAX(3),XMIN(3),Z(2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT C ***** DEL = 1. FOR INCRUMENTING FUNCTIONS ***** C ***** DEL = 0. FOR REGULAR FUNCTIONS ***** DEL=FLOAT(MOD(NJ2/10,2)) NJ2=MOD(NJ2,10) C ***** EXPLICIT ORIGIN AND SCALE ***** IF(AIN(1))602,604,602 602 XO(1)=AIN(1)+XO(1)*DEL 604 IF(AIN(2))606,608,606 606 XO(2)=AIN(2)+XO(2)*DEL 608 IF(AIN(3))612,612,609 609 IF(DEL)611,611,610 610 SCAL1=SCAL1*AIN(3) GO TO 612 611 SCAL1=AIN(3) 612 IF(AIN(4))616,616,614 C ***** SET ELLIPSOID SCALE FACTOR ***** 614 SCAL2=AIN(4) C ***** AUTOMATIC ORIGIN AND/OR SCALE ***** 616 IF(NJ2-2)790,622,620 620 XO(1)=XLNG(1)*.5 XO(2)=XLNG(2)*.5 622 IF(NJ2-3)625,640,625 625 SCAL1=1. 630 IF(LATM-1)635,635,640 635 NG=12 CALL ERPNT(0.,602) CALL MYEXIT 640 DO 650 J=1,3 XMAX(J)=-1.E5 650 XMIN(J)=1.E5 C ***** FIT BOX AROUND SET OF ATOMS ***** DO 670 I=1,LATM CALL XYZ(ATOMS(1,I),ATOMS(2,I),3) IF(NG)652,653,652 652 CALL ERPNT(ATOMS(1,I),600) GO TO 670 653 DO 668 J=1,3 T1=ATOMS(J+1,I) IF(XMAX(J)-T1)655,660,660 655 XMAX(J)=T1 MAX(J)=I 660 IF(T1-XMIN(J))665,668,668 665 XMIN(J)=T1 668 CONTINUE 670 CONTINUE C ***** KM=TOP ATOM ***** KM=MAX(3) SMULT=1. DO 780 M=1,5 IF(M-2)740,675,678 C ***** CHECK VIEW DISTANCE ***** 675 IF(VIEW)785,785,680 678 IF(NJ2-3)680,785,680 680 T1=ATOMS(4,KM)*SMULT IF(VIEW*.5-T1)685,690,690 C ***** INCREASE VIEW DISTANCE ***** 685 VIEW=2.*T1 C ***** FIND PERSPECTIVE PROJECTION LIMITS ***** 690 DO 700 J=1,2 XMAX(J)=-1.E5 700 XMIN(J)=1.E5 DO 725 I=1,LATM DO 705 J=1,3 705 X(J)=ATOMS(J+1,I)*SMULT T2=VIEW/(VIEW-X(3)) DO 725 J=1,2 T1=X(J)*T2 IF(XMAX(J)-T1)710,715,715 710 XMAX(J)=T1 715 IF(T1-XMIN(J))720,725,725 720 XMIN(J)=T1 725 CONTINUE C ***** REFINE PARAMETERS ***** 740 IF(NJ2 -3)745,742,755 742 SMUL2=1. GO TO 765 C ***** AUTOMATIC SCALE ONLY ***** 745 DO 750 J=1,2 T2=XO(J) SCAL(J)=(BRDR-T2)/XMIN(J) 750 SCAL(J+2)=(XLNG(J)-BRDR-T2)/XMAX(J) SMUL2=AMIN1(SCAL(1),SCAL(2),SCAL(3),SCAL(4)) GO TO 780 C ***** AUTOMATIC SCALE AND POSITION ***** 755 DO 760 J=1,2 760 SCAL(J)=(XLNG(J)-BRDR*2.)/(XMAX(J)-XMIN(J)) SMUL2=AMIN1(SCAL(1),SCAL(2)) C ***** AUTOMATIC POSITION ***** 765 DO 770 J=1,2 770 XO(J)=.5*(XLNG(J)-SMUL2*(XMAX(J)+XMIN(J))) 780 SMULT=SMULT*SMUL2 VIEW=VIEW*SMUL2 785 SCAL1=SCAL1*SMULT 790 SCL=SCAL1*SCAL2 C ***** ELIMINATE ALL PREVIOUSLY STORED OVERLAP INFORMATION ***** CALL LAP500(0) RETURN END SUBROUTINE F700 C ***** SUBROUTINE TO DRAW ELLIPSOIDS ***** DIMENSION EYE(3),VIEWV(3),X(3),Z(3) character*6 CHEM INTEGER*4 L1 CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT C ***** SET ELLIPSOID GRAPHIC DETAILS ***** ITILT=0 NG=0 NFIRST=1 NPLANE=AIN(1) IF(NPLANE-1)720,715,720 715 NFIRST=4 NPLANE=4 720 NSOLID=AIN(2) NDOT=64/2**( IABS(NSOLID)) LINES=AIN(3) NDASH=AIN(4) CHSYM=AIN(5) C DH=AIN(6)-CHSYM*17./7. DH=AIN(6)-CHSYM*18.5/7. DV=AIN(7)-CHSYM*.5 C ***** ESTABLISH REFERENCE POINT OF VIEW ***** T1=1.E6 IF(VIEW)740,740,735 735 T1=VIEW/SCAL1 740 DO 741 J=1,3 741 EYE(J)=REFV(J,3)*T1+ORGN(J) LNS=-1 C ***** LOOP THROUGH ATOM LIST ***** DO 1105 ITOM=1,LATM T1=ATOMS(1,ITOM) IF(AIN(10))744,744,742 742 T2=AINT(T1/100000.) IF(T2-AIN(10))1105,743,743 743 IF(AIN(11)-T2)1105,744,744 744 CALL XYZ(T1,X,2) IF(NG)758,746,758 746 CALL PLTXY(X,Z) K=T1/100000. L1=T1-FLOAT(K)*100000. IF(NJ2-10)747,754,754 747 LNS=MOD(LNS+1,18) IF(LNS)749,748,749 748 WRITE (NOUT,751)(TITLE(I),I=1,18) WRITE (NOUT,752) 749 WRITE(NOUT,750) CHEM(K),K,L1,Z(1),Z(2),(X(I),I=1,3),(XT( 1I),I=1,3) 750 FORMAT(1H 10X,A6,3H (I3,1H,I5,4H) 2F8.2,3X,3F8.3,11X,3F8.4) 751 FORMAT(1H110X,18A4) 752 FORMAT(1H010X,18HSYMBOL ATOM CODE7X,16HPLOTTER X,Y(MM.) 3X,21HCA 1RTESIAN X,Y,Z (MM.)15X,20HCRYSTAL SYSTEM X,Y,Z/1H 19X,45H(DIRECTIO 2N COSINES(I,J),I=1,3),RMSD(J)),J=1,312X,42HFOR PRINCIPAL AXES BASE 3D ON WORKING SYSTEM/1H ) 754 IF(EDGE-BRDR*.75)755,760,760 755 NG=10 758 CALL ERPNT(T1,700) GO TO 1105 C ***** CALL OVERLAP ROUTINE ***** 760 ICQ=0 CALL LAP700(ITOM,ICQ) IF(ICQ)762,764,764 C ***** OMIT HIDDEN ATOM ***** 762 NG=14 GO TO 758 764 IF(CHSYM)775,775,765 C ***** PLOT CHEMICAL SYMBOLS ***** 765 T4=1. IF(VIEW)767,767,766 766 T4=VIEW/(VIEW-X(3)) 767 T3=CHSYM*T4 T4=DISP*T4*.5 V1(1)=X(1)+DH*SYMB(1,1)+DV*SYMB(1,2) V1(2)=X(2)+DH*SYMB(2,1)+DV*SYMB(2,2) V1(3)=X(3) CALL PLTXY(V1,V3) IF(EDGE-CHSYM)775,768,768 768 V2(3)=0. DO 770 I=1,3,2 V2(1)=V3(1)+FLOAT(I-2)*T4 DO 770 J=1,3,2 V2(2)=V3(2)+FLOAT(J-2)*T4 CALL SYMBOL(V2(1),V2(2),T3,CHEM(K),THETA,6) IF(T4)775,775,770 770 CONTINUE 775 IF(NPLANE)1105,1105,780 C ***** ELLIPSOID PRINC VECTORS TOWARD VIEWER ***** 780 CALL PAXES(T1,2) IF(NG)758,783,758 783 CALL DIFV(EYE,XT,VIEWV) CALL UNIT(VIEWV,VIEWV,-1) CALL VM(VIEWV,AA,V2) DO 795 I=1,3 IF(VV(V2,PAT(1,I)))785,795,795 785 DO 790 J=1,3 PAC(J,I)=-PAC(J,I) 790 PAT(J,I)=-PAT(J,I) 795 CONTINUE DO 800 J=1,3 PAC(J,4)=PAC(J,1) 800 PAC(J,5)=PAC(J,2) IF(NJ2-10)802,803,803 801 FORMAT(1H 13X,3(3X,3F8.4,F8.5)/1H ) 802 WRITE (NOUT,801) ((PAC(J,K),J=1,3),RMS(K) ,K=1,3) C ***** V4 = VECTOR NORMAL TO POLAR PLANE ***** 803 CALL VM(VIEWV,AAWRK,V6) CALL UNIT(V6,V6,1) CALL MV(Q,V6,V4) CALL UNIT(V4,V4,1) C ***** SET PLOTTING RESOLUTION FOR ELLIPSOID ***** T3=RMS(3)*SCL NRESOL=1 NBIS=5 DO 805 J=1,3 IF(T3-RES(J))804,810,810 804 NBIS=NBIS-1 805 NRESOL=NRESOL*2 810 NRES1=NRESOL+1 C ***** LOOP THROUGH PRINC AND POLAR PLANES ***** DO 1100 II=NFIRST,NPLANE II0=MOD(II+2,3)+1 II1=MOD(II,3)+1 II2=MOD(II+1,3)+1 C ***** GENERATE CONJUGATE DIAMETERS ***** IF(.99938- ABS(VV(V4,PAC(1,II2))))820,820,830 820 T1=RMS(II0)*SCL T2=RMS(II1)*SCL DO 825 J=1,3 DA(J,1)=PAC(J,II0)*T1 825 DA(J,2)=PAC(J,II1)*T2 GO TO 850 830 CALL NORM(PAC(1,II0),PAC(1,II1),V1,1) CALL NORM(V1,V4,V2,1) CALL UNIT(V2,V2,1) CALL MV(Q,V2,V3) IF(II-4)835,840,840 835 CALL NORM(V3,V1,V5,1) GO TO 843 840 CALL NORM(V3,V4,V5,1) 843 CALL UNIT(V5,V5,1) T1=SCL/SQRT(VMV(V2,Q,V2)) T2=SCL/SQRT(VMV(V5,Q,V5)) DO 845 J=1,3 DA(J,1)=V2(J)*T1 845 DA(J,2)=V5(J)*T2 C ***** GENERATE ELLIPSE ***** 850 CALL RADIAL(NBIS) IF(II-4)900,851,851 851 IF(NSOLID)859,859,852 C ***** PLOT DOTTED BOUNDARY ELLIPSE ***** 852 IF(NDOT-NRESOL)853,855,855 853 CALL RADIAL(NSOLID-1) 855 CALL PROJ(D,DP,X,XO,VIEW,1,129,NDOT) DO 857 J=1,129,NDOT CALL DRAW(DP(1,J),DISP,DISP,3) DO 856 I=1,3,2 T1=FLOAT(I-2)*DISP DO 856 K=1,3,2 T2=FLOAT(K-2)*DISP CALL DRAW(DP(1,J),T1,T2,2) IF(DISP)857,857,856 856 CONTINUE 857 CONTINUE GO TO 1100 C ***** PLOT SOLID BOUNDARY ELLIPSE ***** 859 CALL PROJ(D,DP,X,XO,VIEW,1,129,NRESOL) C C CNY CNY CALL MYARC(Z(1),Z(2),DP,DA(1,1)) C CALL DRAW(DP,0.,0.,3) DO 860 J=NRES1,129,NRESOL 860 CALL DRAW(DP(1,J),0.,0.,2) C C IF(DISP)1100,1100,865 C ***** BOUNDARY ANNULUS AS A LINEAR FUNCTION OF HEIGHT ***** 865 CALL DIFV(XT,ORGN,V1) T5=VV(V1,AAREV(1,3))*SCAL1 NCYCLE=.5+(AIN(8)+T5*AIN(9))/DISP IF(NCYCLE)1100,1100,870 870 T3=(2.*DISP)/(T1+T2) C ***** INCREASE ANNULAR THICKNESS ***** DO 875 I=1,NCYCLE T4=T3*FLOAT(I) DO 875 J=1,129,NRESOL 875 CALL DRAW(DP(1,J),D(1,J)*T4,D(2,J)*T4,2) GO TO 1100 900 CALL PROJ(D,DP,X,XO,VIEW,1,65,NRESOL) C ***** PLOT HALF AN ELLIPSE ***** CALL DRAW(DP,0.,0.,3) DO 905 J=NRES1,65,NRESOL 905 CALL DRAW(DP(1,J),0.,0.,2) IF(DISP)930,930,910 C ***** ACCENTUATE FRONT HALF ***** 910 DO 925 I=1,3,2 T2=FLOAT(I-2)*DISP DO 915 J=1,65,NRESOL K=66-J 915 CALL DRAW(DP(1,K),DISP,T2,2) DO 925 K=1,65,NRESOL 925 CALL DRAW(DP(1,K),-DISP,-T2,2) 930 IF(NSOLID)940,967,935 935 L=NDOT IF(NDOT-NRESOL)938,945,940 938 CALL RADIAL(NSOLID-1) GO TO 945 940 L=NRESOL 945 CALL PROJ(D(1,65),DP(1,65),X,XO,VIEW,1,65,L) IF(NSOLID)960,967,950 C ***** DOTTED LINE ON REVERSE SIDE ***** 950 DO 958 J=65,129,NDOT CALL DRAW(DP(1,J),DISP,DISP,3) DO 955 I=1,3,2 T1=FLOAT(I-2)*DISP DO 955 K=1,3,2 T2=FLOAT(K-2)*DISP CALL DRAW(DP(1,J),T1,T2,2) IF(DISP)958,958,955 955 CONTINUE 958 CONTINUE GO TO 967 C ***** SINGLE LINE ON REVERSE SIDE ***** 960 DO 965 J=65,129,NRESOL 965 CALL DRAW(DP(1,J),0.,0.,2) C ***** DETAIL INTERIOR FEATURES ***** 967 T2=NDASH*2 DO 975 J=1,3 T1=PAC(J,II0)*RMS(II0)*SCL DA(J,1)=T1 DA(J,2)=PAC(J,II1)*RMS(II1)*SCL DA(J,3)=0. IF(NDASH)975,975,970 970 V1(J)=-T1 V2(J)=T1/T2 975 CONTINUE IF(NDASH)987,987,980 C ***** DASHED LINE FOR REVERSE AXIS ***** 980 DO 985 J=1,NDASH DO 985 K=1,2 L=4-K CALL PROJ(V1,DP,X,XO,VIEW,1,1,1) CALL DRAW(DP,0.,0.,L) DO 985 I=1,3 985 V1(I)=V1(I)+V2(I) C ***** SOLID LINE FOR FORWARD AXIS ***** 987 IF(LINES)1100,1100,988 988 CALL PROJ(DA,DP,X,XO,VIEW,1,3,1) T1=DISP*.5 DO 990 I=1,3,2 T2=FLOAT(2-I)*T1 CALL DRAW(DP,T1,T2,3) CALL DRAW(DP(1,3),T1,T2,2) IF(DISP)1000,1000,989 989 CALL DRAW(DP(1,3),-T1,T2,2) 990 CALL DRAW(DP,-T1,T2,2) C ***** SHADE QUADRANT BETWEEN TWO PRINCIPAL AXES ***** 1000 L=LINES-1 IF(L)1100,1100,1005 1005 T2=LINES DO 1025 I=1,L T1=FLOAT(I)/T2 T3=SQRT(1.-T1*T1) IF(MOD(I,2))1010,1015,1010 1010 M=I*2 N=M-1 GO TO 1020 1015 N=I*2 M=N-1 1020 DO 1025 J=1,3 T4=DA(J,1)*T1 D(J,M)=T4 1025 D(J,N)=DA(J,2)*T3+T4 L=L*2 CALL PROJ(D,DP,X,XO,VIEW,1,L,1) DO 1030 I=2,L,2 CALL DRAW(DP(1,I-1),0.,0.,3) 1030 CALL DRAW(DP(1,I),0.,0.,2) 1100 CONTINUE 1105 CONTINUE C ***** ELIMINATE LOCAL OVERLAP INFORMATION BEFORE RETURNING ***** CALL LAP500(-1) RETURN END SUBROUTINE F800 C ***** SUBROUTINE FINDS ATOM PAIRS FOR BONDS ***** DIMENSION IA(3),W1(6) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT LNS=-4 IF(MOD(NJ2,10)-2)805,848,848 C ***** EXPLICIT DESCRIPTION ***** 805 II=0 IF(NCD)810,810,815 810 NG=11 CALL ERPNT(0.,NJ*100+NJ2) GO TO 980 815 II=II+1 IF(140-II)980,980,820 820 T1=AIN(II) IF(T1)815,815,825 825 II=II+1 T2=AIN(II) IF(T2)815,815,830 830 IF(NJ2-10)832,838,838 832 LNS=MOD(LNS+4,56) IF(LNS)838,834,838 834 WRITE (NOUT,835)(TITLE(I),I=1,18) 835 FORMAT(1H110X,18A4) WRITE (NOUT,837) 837 FORMAT(1H010X,18HSYMBOL ATOM CODE6X,16HPLOTTER X,Y(MM.) 6X,21HCA 1RTESIAN X,Y,Z (MM.)17X,20HCRYSTAL SYSTEM X,Y,Z/1H ) C ***** CHECK IF BOND ATOMS ARE IN ATOMS LIST (FOR OVERLAP CALC) *** 838 NA1=0 NA2=0 IF(LATM-2)845,839,839 839 N2=2 DO 844 K=1,LATM T3=ATOMS(1,K) IF(T3-T1)841,840,841 840 NA1=K GO TO 843 841 IF(T3-T2)844,842,844 842 NA2=K 843 N2=N2-1 IF(N2)845,845,844 844 CONTINUE 845 IF(NA2-NA1)846,847,847 846 NA3=NA1 NA1=NA2 NA2=NA3 T3=T1 T1=T2 T2=T3 847 CALL BOND(T1,T2,1,NA1,NA2) GO TO 815 C ***** IMPLICIT DESCRIPTION ***** 848 IF(LATM-2)810,850,850 850 SCAL3=SCAL1 SCAL1=1. DO 855 I=1,LATM 855 CALL XYZ(ATOMS(1,I),ATOMS(2,I),2) SCAL1=SCAL3 IF(NCD)810,810,860 860 WRITE (NOUT,861) 861 FORMAT(1H010X,20HBOND SELECTION CODES//11X,94H(SEQUENCE(A))(SEQUEN 1CE(B)) (BOND) (DISTANCES)( BOND )(PERSP.--LABELS)(NORMAL--LABELS)( 2DIGITS) /11X,93H( MIN MAX )( MIN MAX ) (TYPE) (MIN MAX)(RADI 3US)(HEIGHT OFFSET)(HEIGHT OFFSET)(NUMBER)) DMAX=0. DO 870 I=1,NCD IF(DMAX-CD(2,I))865,870,870 865 DMAX=CD(2,I) 870 WRITE (NOUT,871)(KD(J,I),J=1,5),(CD(J,I),J=1,8) 871 FORMAT(1H 10XI6,I5,I8,I5,I8,2F6.2,5F8.3,F7.0) DMAX=DMAX*DMAX C ***** LOOP THROUGH ATOMS ARRAY ***** DO 977 M=1,LATM NA1=M T1=ATOMS(1,M) IA(1)=T1/100000. IA(3)=IA(1) W1(1)=ATOMS(2,M) W1(2)=ATOMS(3,M) W1(3)=ATOMS(4,M) L=M+1 IF(LATM-L)977,872,872 872 DO 975 N=L,LATM NA2=N DIST=(ATOMS(2,N)-W1(1))**2 IF(DMAX-DIST)975,873,873 873 DIST=DIST+(ATOMS(3,N)-W1(2))**2 IF(DMAX-DIST)975,874,874 874 DIST=DIST+(ATOMS(4,N)-W1(3))**2 IF(DMAX-DIST)975,875,875 875 DIST=SQRT(DIST) T2=ATOMS(1,N) IA(2)=T2/100000. C ***** SELECT BONDS ACCORDING TO CODES ***** DO 950 J=1,NCD JB=J IF(DIST-CD(1,J)) 950,880,880 880 IF(CD(2,J)-DIST) 950,881,881 881 DO 885 K=1,2 IF(IA(K)-KD(1,J)) 885,882,882 882 IF(KD(2,J)-IA(K)) 885,883,883 883 IF(IA(K+1)-KD(3,J))885,884,884 884 IF(KD(4,J)-IA(K+1))885,890,890 885 CONTINUE GO TO 950 C ***** CHECK FOR POLYHEDRA CODE ***** 890 IF(CD(4,J))900,955,955 900 W1(4)=ATOMS(2,N) W1(5)=ATOMS(3,N) W1(6)=ATOMS(4,N) KM1=ABS(CD(4,J)) KM2=ABS(CD(5,J)) DSQ1=(CD(6,J))**2 DSQ2=(CD(7,J))**2 C ***** SEARCH FOR POLYHEDRA CENTER ***** DO 935 IM=1,LATM K3=ATOMS(1,IM)/100000. IF(K3-KM1)935,905,905 905 IF(KM2-K3)935,910,910 C ***** CHECK POLYHEDRA DISTANCE RANGE ***** 910 DO 930 J1=1,4,3 DSQ=(ATOMS(2,IM)-W1(J1))**2 IF(DSQ2-DSQ)935,915,915 915 DSQ=DSQ+(ATOMS(3,IM)-W1(J1+1))**2 IF(DSQ2-DSQ)935,920,920 920 DSQ=DSQ+(ATOMS(4,IM)-W1(J1+2))**2 IF(DSQ2-DSQ)935,925,925 925 IF(DSQ-DSQ1)935,930,930 930 CONTINUE GO TO 955 935 CONTINUE C ***** END OF POLYHEDRA CHECK ***** 950 CONTINUE GO TO 975 C ***** PREPARE TO DRAW BOND ***** 955 IF(NJ2-10)960,970,970 960 LNS=MOD(LNS+4,56) IF(LNS)965,965,970 965 WRITE (NOUT,835)(TITLE(I),I=1,18) WRITE (NOUT,837) 970 CALL BOND(T1,T2,JB,NA1,NA2) 975 CONTINUE 977 CONTINUE C ***** ELIMINATE LOCAL OVERLAP INFORMATION BEFORE RETURNING ***** 980 IF(NJ2-21)985,990,990 985 CALL LAP500(-1) 990 RETURN END SUBROUTINE F900 DIMENSION X(3),XW(3,5),Y(3),Z(3) character*6 CHEM CHARACTER*4 TITLE,TITLE2 INTEGER*2 SMALL(4) DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT C DATA SMALL/ZA3E1,ZA3E2,ZA3E3,ZA3EF/ C ***** LABELING FUNCTION SUBROUTINE ***** ITILT=0 NJ3=MOD(NJ2,10) TH=THETA SINTH=SYMB(2,1) COSTH=SYMB(1,1) ILAST=1 IF(AIN(2)-11100.)910,910,905 905 ILAST=2 910 DO 925 II=1,ILAST C ***** OBTAIN WORKING CARTESIAN COORDINATES ***** CALL XYZ(AIN(II),XW(1,II),2) IF(NG)915,925,915 925 CALL XYZ(AIN(II),XW(1,II+3),3) GO TO 926 912 NG=15 915 CALL ERPNT(AIN(II),NJ*100+NJ2) GO TO 1199 926 II=1 C ***** FIND MEAN REFERENCE POINT ***** DO 930 J=1,3 T2=XW(J,ILAST) T1=XW(J,1) XW(J,3)=T2-T1 930 X(J)=(T2+T1)*.5 C ***** PERSPECTIVE SCALING FACTOR ***** SCAL=1. IF(VIEW)940,940,935 935 SCAL=VIEW/(VIEW-X(3)) 940 HGT=SCAL*AIN(5) NSL=NJ2-20 IF(NSL) 942,942,941 941 GO TO(965,965,965,915,915,915,965),NSL 942 IF(NJ2-3)960,950,945 945 IF(NJ2-6)950,950,960 C ***** PROJECTED VECTOR BASELINE ***** 950 CALL PLTXY(XW(1,4),V1) CALL PLTXY(XW(1,5),V2) T1=V2(1)-V1(1) T2=V2(2)-V1(2) T3=SQRT(T1*T1+T2*T2) IF(T3)912,912,955 955 COSTH=T1/T3 SINTH=T2/T3 TH=ARCCOS(COSTH) IF(SINTH)958,960,960 958 TH=-TH 960 IF(NJ2-13)965,985,985 C ***** FIND CENTER OF PROJECTED LABEL ***** 965 Y(1)=SCAL*(X(1)+AIN(6)*COSTH-AIN(7)*SINTH)+XO(1) Y(2)=SCAL*(X(2)+AIN(6)*SINTH+AIN(7)*COSTH)+XO(2) Y(3)=0. C ***** CHECK FOR LEGEND RESET ***** DO 980 J=1,2 T1=AIN(J+2) IF(T1)975,980,970 970 Y(J)=T1 GO TO 980 975 Y(J)=XLNG(J)+T1 980 CONTINUE C ***** SET PARAMETERS FOR INDIVIDUAL FUNCTIONS ***** 985 GO TO(990,995,995,1000,1000,1000,915,1105,1105,915,915,915,1005,10 105,1005,1005,915,915,915,915,990,990,990,915,915,915,990),NJ2 C 990 T6=17. 990 T6=19.5 L=AIN(1)/100000. ILAST=1 DXW=0. DYW=0. GO TO 1030 C 995 T6=215. 995 T6=250.5 ILAST=18 C T1=HGT*24./7. T1=HGT*4. DXW=COSTH*T1 DYW=SINTH*T1 GO TO 1030 C1000 T6=10+3*(NJ3-4) 1000 FNJ3=NJ3 T6=9.0+3.5*(FNJ3-4.) DIST=SQRT(VV(XW(1,3),XW(1,3)))/SCAL1 GO TO 1030 C ***** TRUE PERSPECTIVE LABELS ***** 1005 CALL UNIT(XW(1,3),VT(1,1),1) IF(ABS(VT(3,1))-.9994)1010,912,912 C ***** FORM PERSPECTIVE ROTATION MATRIX ***** 1010 CALL NORM(AID(1,3),VT(1,1),VT(1,2),1) CALL UNIT(VT(1,2),VT(1,2),1) CALL NORM(VT(1,1),VT(1,2),VT(1,3),1) DO 1015 J=1,3 1015 VT(J,4)=X(J) ITILT=1 HGT=AIN(5) TH=0. Y(3)=X(3) Y(2)=X(2)+AIN(7)-HGT*.5 IF(NJ2-13)1030,1025,1020 C ***** PERSPECTIVE BOND LABELS ***** 1020 Y(1)=X(1)+AIN(6)-HGT*FLOAT(22+3*(6-NJ3))/7. DIST=SQRT(VV(XW(1,3),XW(1,3)))/SCAL1 GO TO 1050 C ***** PERSPECTIVE TITLES ***** C1025 Y(1)=X(1)+AIN(6)-HGT*215./7. 1025 Y(1)=X(1)+AIN(6)-HGT*250.5/7. ILAST=18 C DXW=HGT*24./7. DXW=HGT*4. DYW=0. GO TO 1050 1030 DH=HGT*T6/7. DV=HGT*.5 Y(1)=Y(1)-DH*COSTH+DV*SINTH Y(2)=Y(2)-DH*SINTH-DV*COSTH Y(3)=0. C ***** PLOT VARIOUS LABELS ***** 1050 Z(3)=Y(3) XO(3)=Y(3) GO TO(1060,1060,1060,1090,1090,1090,1060,1105,1105),NJ3 1060 DO 1085 I=1,ILAST DO 1075 J=1,3,2 Z(1)=Y(1)+FLOAT(J-2)*DISP*.5 DO 1075 K=1,3,2 Z(2)=Y(2)+FLOAT(K-2)*DISP*.5 IF(NSL)1064,1064,1063 1063 GO TO(1066,1067,1071,915,915,915,1069),NSL 1066 CALL CHARAC(Z(1),Z(2),HGT,SMALL(1),TH,-1) GO TO 1070 1067 CALL CHARAC(Z(1),Z(2),HGT,SMALL(2),TH,-1) GO TO 1070 1071 CALL CHARAC(Z(1),Z(2),HGT,SMALL(3),TH,-1) GO TO 1070 1069 CALL CHARAC(Z(1),Z(2),HGT,SMALL(4),TH,-1) GO TO 1070 1064 IF(NJ3-2)1065,1068,1068 C ***** PLOT CHEMICAL SYMBOL ***** 1065 CALL SYMBOL(Z(1),Z(2),HGT,CHEM(L),TH,6) GO TO 1070 C ***** PLOT TITLES ***** 1068 CALL SYMBOL(Z(1),Z(2),HGT,TITLE2(I),TH,4) 1070 IF(DISP)1080,1080,1075 1075 CONTINUE 1080 Y(1)=Y(1)+DXW 1085 Y(2)=Y(2)+DYW GO TO 1199 C ***** PLOT BOND DISTANCE LABELS ***** 1090 I9=NJ3-3 T9=10.**I9 DISTR=AINT((DIST*T9)+0.5)/T9 +.0001 CALL NUMBER(Y(1),Y(2),HGT,DISTR,TH,I9) GO TO 1199 C ***** PLOT CENTERED SYMBOLS ***** 1105 CALL SYMBOL(Y(1),Y(2),HGT, IFIX(AIN(8)),TH,7-NJ3) 1199 ITILT=0 RETURN END SUBROUTINE F1000 character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT JPEN=AIN(1) CALL NEWPEN(JPEN) RETURN END SUBROUTINE JOBNUM(H1) C ***** DUMMY FOR ORNL LOCAL SUBROUTINE CALLED BY F200 FOR CRT IDENT C ***** JOBNUM OBTAINS USERS JOB NUMBER (4 BCD CHARACTERS) ***** CWEOR RETURN END SUBROUTINE LAPAB(IQ,IA,ICQ,ITY) C ***** SUBROUTINE CHECKS FOR OVERLAP BETWEEN ATOMS AND BONDS ***** C ***** CALLED BY SUBROUTINES LAP700 AND LAP800 ***** DIMENSION BF(4),CON(3,3),QF(5),QUA(3,4) COMMON/OLAP/CONIC(7,1000),COVER(6,40),KC(40),KQ(60),NCONIC,NCOVER, 1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,60),QUAR(9,1200),SEGM(100,2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT TID=QUAR(9,IQ) NA1=TID/1000. NA2=AMOD(TID,1000.) C ***** ITY.GT.0, CHECK FOR ATOMS OVER A BOND **** C ***** ITY.LT.0, CHECK FOR BONDS OVER AN ATOM ***** ICQ=0 IF(ITY)210,200,205 200 RETURN 205 CALL LAPCON(CONIC(1,IA),CON,V1,0.0) IF(ITY-2)220,240,240 210 IF(ITY+2)220,220,215 215 CALL LAPCON(CONIC(1,IA),CON,V1,OVMRGN) C ***** SET UP LINEAR FORMS FOR EDGES OF QUADRANGLE ***** 220 DO 235 L=1,4 K=2*L K1=MOD(K,8)+2 QUA(1,L)=QUAR(K,IQ)-QUAR(K1,IQ) QUA(2,L)=QUAR(K1-1,IQ)-QUAR(K-1,IQ) QUA(3,L)=QUAR(K-1,IQ)*QUAR(K1,IQ)-QUAR(K,IQ)*QUAR(K1-1,IQ) T1=SQRT(QUA(1,L)**2+QUA(2,L)**2) IF(T1)225,225,230 225 ITY=0 ICQ=0 RETURN C ***** TRANSFORM COEFFICIENTS FOR EDGES TO NORMAL FORM ***** 230 DO 235 J=1,3 235 QUA(J,L)=QUA(J,L)/T1 C ***** EVALUATE 4 QUADRATIC AND 4 BILINEAR FORMS ***** 240 V2(3)=1.0 V3(3)=1.0 T2=3.0 DO 265 L=1,4 L1=(MOD(L,4)+1)*2 V2(1)=QUAR(2*L-1,IQ) V2(2)=QUAR(2*L,IQ) V3(1)=QUAR(L1-1,IQ) V3(2)=QUAR(L1,IQ) QF(L)=0.0 BF(L)=0.0 DO 250 K=1,3 T1=CON(3,K) DO 245 J=1,2 245 T1=T1+V2(J)*CON(J,K) QF(L)=QF(L)+T1*V2(K) 250 BF(L)=BF(L)+T1*V3(K) IF(QF(L))260,255,265 255 T2=T2-0.8 GO TO 265 260 T2=T2-1.0 265 CONTINUE QF(5)=QF(1) C ***** CHECK FOR 4 POINTS OF QUADRANGLE INSIDE OR ON ELLIPSE ***** IF(T2)270,275,275 270 ITYPE=-1 GO TO 330 C ***** CHECK FOR 1 TO 3 POINTS OF QUADRANGLE INSIDE THE ELLIPSE *** 275 IF(T2-2.2)280,285,285 280 ITYPE=0 IF(NA2-IA)340,375,335 C ***** CHECK FOR QUADRANGLE-ELLIPSE INTERSECTION ***** 285 DO 305 K=1,4 C ***** EVALUATE DISCRIMINANT ***** T1=BF(K)**2-QF(K)*QF(K+1) IF(T1)305,305,290 290 T1=SQRT(T1) C ***** IS INTERSECTION WITHIN BOUNDS OF QUADRANGLE ***** T3=QF(K)-BF(K) T4=T3+QF(K+1)-BF(K) IF(ABS(T4)-1.E-5)305,305,295 295 T5=(T3-T1)/T4 IF(T5)305,280,300 300 IF(1.0-T5)305,305,280 305 CONTINUE C ***** NO VALID INTERSECTION FOUND ***** C ***** CHECK FOR CENTER OF ELLIPSE WITHIN THE QUADRANGLE **** T3=3.0 DO 320 K=1,4 T1=QUA(3,K) DO 310 J=1,2 310 T1=T1+V1(J)*QUA(J,K) IF(T1)315,320,320 315 T3=T3-1.0 320 CONTINUE IF(T3)325,370,370 325 ITYPE=1 C ***** CHECK OVER/UNDER AMBIGUITY ***** 330 IF(NA2-IA)375,375,335 335 IF(IA-NA1)375,375,340 340 CALL DIFV(ATOMS(2,NA2),ATOMS(2,NA1),V2) CALL DIFV(ATOMS(2,IA),ATOMS(2,NA1),V3) CALL UNIT(V2,V2,1) CALL UNIT(V3,V3,1) CALL NORM(V2,V3,V4,1) IF(VV(V4,V4)-1.E-5)345,345,350 C ***** CENTER OF ATOM IQ IS ON THE BOND LINE ***** 345 IF(ITY)370,370,385 C ***** CENTER OF ATOM IQ IS NOT ON THE BOND LINE ***** 350 CALL NORM(V4,V2,V5,1) T1=-V5(3) IF(VIEW)365,365,355 355 T1=V5(3)*(ATOMS(4,IA)-VIEW) DO 360 J=1,2 360 T1=T1+V5(J)*ATOMS(J+1,IA) 365 IF(T1*FLOAT(ITY))375,375,370 C ***** NO INTERFERENCE FOUND ***** 370 ICQ=0 RETURN C ***** ITYPE=1 ENCLOSED ELLIPSE / ITYPE=-1 ENCLOSED QUADRANGLE **** 375 IF(ITYPE*ITY)380,385,385 C ***** HIDDEN ATOM OR HIDDEN BOND ***** 380 ICQ=-1 RETURN 385 ICQ=1 IF(ITY)410,390,390 C ***** STORE INTERFERING ELLIPSE ***** 390 IF(NCOVER-40)400,395,395 395 NG=17 CALL ERPNT(ATOMS(1,IA),800) NCOVER=NCOVER-1 400 NCOVER=NCOVER+1 IJ=1 DO 405 I=1,3 DO 405 J=I,3 COVER(IJ,NCOVER)=CON(I,J) 405 IJ=IJ+1 KC(NCOVER)=IA RETURN C ***** STORE INTERFERING QUADRANGLE ***** 410 IF(NQOVER-60)420,415,415 415 NG=18 CALL ERPNT(TID,700) NQOVER=NQOVER-1 420 NQOVER=NQOVER+1 DO 425 K=1,4 DO 425 J=1,3 425 QOVER(J,K,NQOVER)=QUA(J,K) KQ(NQOVER)=IQ RETURN END SUBROUTINE LAPCON(CON1,CON,Y,OVMR) C ***** TRANSFORM CONIC TO PLOTTER HOMOGENEOUS COORDINATE SYSTEM *** C ***** CALLED BY SUBROUTINES LAP700 AND LAPAB ***** DIMENSION CON1(7),CON(3,3),Y(3) Y(1)=(CON1(1)+CON1(2))*0.5 Y(2)=(CON1(3)+CON1(4))*0.5 Y(3)=1.0 CON(1,1)=CON1(5) CON(1,2)=CON1(6) CON(2,1)=CON1(6) CON(2,2)=CON1(7) T1=(CON1(2)-CON1(1)+CON1(4)-CON1(3))*0.25 CON(3,3)=-((T1-OVMR)/T1)**2 DO 205 K=1,2 CON(K,3)=0.0 DO 200 J=1,2 200 CON(K,3)=CON(K,3)-Y(J)*CON(J,K) CON(3,K)=CON(K,3) 205 CON(3,3)=CON(3,3)-CON(3,K)*Y(K) RETURN END SUBROUTINE LAPDRW(Y,NPEN,NCQ) C ***** SUBROUTINE ELIMINATES HIDDEN LINES AND DRAWS VISIBLE LINES * DIMENSION CB(40),CQ(100,2),QL(4,60,2),SEG(2),Y(3),YN(3),YO(3),Z(3) COMMON/OLAP/CONIC(7,1000),COVER(6,40),KC(40),KQ(60),NCONIC,NCOVER, 1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,60),QUAR(9,1200),SEGM(100,2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT NCQ=NCOVER+NQOVER IF(NCQ)200,200,205 200 RETURN C ***** CHECK ALL OVERLAPPING ATOMS AND BONDS ***** 205 NPM3=NPEN-3 IF(NPM3) 210,230,230 C ***** SAVE INFORMATION FROM LAST POINT IF PEN IS DOWN ***** 210 YO(1)=YN(1) YO(2)=YN(2) YO(3)=1.0 NPO=NPN DO 215 K=1,NCQ 215 CQ(K,1)=CQ(K,2) IF(NQOVER)230,230,220 220 DO 225 K=1,NQOVER DO 225 J=1,4 225 QL(J,K,1)=QL(J,K,2) C ***** EVALUATE CONIC QUADRATIC FORMS AT NEW POINT YN ***** 230 YN(1)=Y(1) YN(2)=Y(2) YN(3)=1.0 NPN=NPEN IF(NCOVER)250,250,235 235 DO 245 K=1,NCOVER Z(1)=YN(1)*COVER(1,K)+YN(2)*COVER(2,K)+COVER(3,K) Z(2)=YN(1)*COVER(2,K)+YN(2)*COVER(4,K)+COVER(5,K) Z(3)=YN(1)*COVER(3,K)+YN(2)*COVER(5,K)+COVER(6,K) CQ(K,2)=Z(1)*YN(1)+Z(2)*YN(2)+Z(3) C ***** EVALUATE CONIC BILINEAR FORM IF PEN IS DOWN ***** IF(NPM3)240,245,245 240 CB(K)= Z(1)*YO(1)+Z(2)*YO(2)+Z(3) 245 CONTINUE C ***** EVALUATE LINEAR FORMS AND SIGNATURE FOR QUADRANGLE ***** 250 IF(NQOVER)275,275,255 255 KCQ=NCOVER DO 270 K=1,NQOVER T2=3.0 DO 265 J=1,4 T1=YN(1)*QOVER(1,J,K)+YN(2)*QOVER(2,J,K)+QOVER(3,J,K) IF(T1)260,265,265 260 T2=T2-1.0 265 QL(J,K,2)=T1 KCQ=KCQ+1 C ***** T2=-1 INSIDE, =0 ACROSS ANY EDGE, =1 ACROSS ANY VERTEX ***** 270 CQ(KCQ,2)=T2 C ***** IF PEN IS UP, OMIT ALL SUBSEQUENT CHECKING ***** 275 IF(NPM3)285,280,280 280 NPN=3 CALL SCRIBE(YN,NPN,LTNO) RETURN C ***** CHECK FOR HIDDEN SEGMENT ***** 285 DO 295 K=1,NCQ IF(CQ(K,1))290,295,295 290 IF(CQ(K,2))280,295,295 295 CONTINUE C ***** FIND ENTRY AND EXIT POINTS ON EACH CONIC ***** NINT=0 IF(NCOVER)330,330,300 300 DO 325 K=1,NCOVER C ***** EVALUATE DISCRIMINANT ***** T1=CB(K)**2-CQ(K,1)*CQ(K,2) IF(T1)325,325,305 305 T1=SQRT(T1) C ***** SOLVE QUADRATIC EQATION ***** T2=CQ(K,1)-CB(K) T3=T2+CQ(K,2)-CB(K) IF(ABS(T3)-1.E-5)325,325,310 310 T4=(T2-T1)/T3 T5=(T2+T1)/T3 C ***** VALID INTERSECTION IF T4.LT.1 AND T5.GT.0 ***** IF(T4-1.0)315,325,325 315 IF(T5)325,325,320 C ***** SAVE VALID CONIC INTERSECTIONS ***** 320 NINT=NINT+1 SEGM(NINT,1)=T4 SEGM(NINT,2)=T5 325 CONTINUE 330 IF(NQOVER)425,425,335 C ***** FIND ENTRY AND EXIT POINTS FOR EACH QUADRANGLE ***** 335 DO 420 K=1,NQOVER I12=0 KCQ=NCOVER+K C ***** CHECK FOR SINGLE INSIDE POINT ***** SEG(1)=CQ(KCQ,1) IF(SEG(1))345,340,340 340 SEG(1)=1.0-CQ(KCQ,2) IF(SEG(1)-1.0)350,350,345 C ***** INSIDE POINT FOUND, ONLY ONE INTERSECTION POSSIBLE ***** 345 I12=1 C ***** FIND WHICH EDGES ARE CROSSED BY THE SEGMENT ***** 350 DO 410 J=1,4 T1=QL(J,K,1) T2=QL(J,K,2) T3=T1-T2 IF(T1*T2)355,355,410 C ***** CHECK FOR SEGMENT ON AN EDGE ***** 355 IF(ABS(T3)-1.E-5)420,420,360 C ***** CALCULATE COORDINATES OF INTERSECTION ***** 360 T4=(T1*YN(1)-T2*YO(1))/T3 T5=(T1*YN(2)-T2*YO(2))/T3 J1=2*(MOD(J,4)+1) IQ=KQ(K) C ***** IS INTERSECTION WITHIN LIMITS OF QUADRANGLE ***** T6=(T4-QUAR(2*J-1,IQ))*(QUAR(J1-1,IQ)-T4)+(T5-QUAR(2*J,IQ))* 1 (QUAR(J1,IQ)-T5) IF(ABS(T6)-1.E-4)370,370,365 365 IF(T6)410,370,370 C ***** CALCULATE FRACTION PARAMETER AND STORE IT ***** 370 T1=T1/T3 IF(I12-1)375,380,395 C ***** STORE FIRST INTERSECTION ***** 375 I12=1 GO TO 390 C ***** STORE SECOND INTERSECTION **** 380 I12=2 IF(T1-SEG(1))385,405,405 385 SEG(2)=SEG(1) 390 SEG(1)= T1 GO TO 410 C ***** MORE THAN TWO INTERSECTIONS (I.E.,QUADRANGLE DIAGONAL) ***** 395 IF(T1-SEG(1))390,410,400 400 IF(T1-SEG(2))410,410,405 405 SEG(2)=T1 410 CONTINUE IF(I12-1)420,420,415 C ***** STORE FRACTION PARAMETERS ***** 415 NINT=NINT+1 SEGM(NINT,1)=SEG(1) SEGM(NINT,2)=SEG(2) 420 CONTINUE C ***** END OF ENTRY-AND-EXIT-POINT CALCULATIONS ***** 425 IF(NINT-1)430,490,435 C ***** NO INTERFERENCE FOUND, DRAW ENTIRE SEGMENT ***** 430 CALL SCRIBE(YN,2,LTNO) RETURN C **** SORT SEGMENT INTERSECTION LIST ***** C ***** SORTING PROCEDURE BY SHELL,D.L. COMM. ACM 2,30-32 (1959) *** 435 M=NINT 440 M=M/2 IF(M)490,490,445 445 K=NINT-M J=1 450 I=J 455 IM=I+M IF(SEGM(I,1))460,470,470 460 IF(SEGM(IM,1))465,465,485 465 IF(SEGM(I,2)-SEGM(IM,2))485,485,475 470 IF(SEGM(I,1)-SEGM(IM,1))485,485,475 475 DO 480 L=1,2 T1=SEGM(I,L) SEGM(I,L)=SEGM(IM,L) 480 SEGM(IM,L)=T1 I=I-M IF(I)485,485,455 485 J=J+1 IF(J-K)450,450,440 C ***** FIND STARTING POINT P0 AND END POINT P1 ***** 490 P0=0.0 K=0 495 K=K+1 IF(K-NINT)500,500,515 500 P1=SEGM(K,1) IF(P1)510,505,505 505 IF(P1-P0)510,510,520 510 P0=AMAX1(P0,SEGM(K,2)) IF(P0-1.0)495,530,525 515 P1=1.0 C ***** DRAW SEGMENT FROM P0 TO P1 ***** 520 IF(P0)535,535,530 525 P0=1.0 530 Z(1)=YO(1)*(1.-P0)+YN(1)*P0 Z(2)=YO(2)*(1.-P0)+YN(2)*P0 NPN=3 CALL SCRIBE(Z,NPN,LTNO) IF(P0-1.0)535,540,540 535 Z(1)=YO(1)*(1.-P1)+YN(1)*P1 Z(2)=YO(2)*(1.-P1)+YN(2)*P1 NPN=2 CALL SCRIBE(Z,NPN,LTNO) IF(P1-1.0)510,540,540 540 RETURN END CDECK TEP2CRT SUBROUTINE LAP500(NTYPE) C ***** STORE PROJECTED ATOM CONICS AND BOND QUADRANGLES ***** DIMENSION QC(3,3),QD(3,3),VD1(3),VD2(3) C ***** DOUBLE PRECISION FOR VERY SMALL ATOMS AND SHORT WORDLENGTH * C ***** IN GENERAL, DOUBLE PRECISION IS NOT REQUIRED ***** REAL*8 QC,QD,VD1,VD2,TD1,TD2,TD3 C ***** JUST REMOVE THE PRECEEDING REAL*8 CARD TO MAKE SINGLE PREC COMMON/OLAP/CONIC(7,1000),COVER(6,40),KC(40),KQ(60),NCONIC,NCOVER, 1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,60),QUAR(9,1200),SEGM(100,2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT C ***** ELIMINATE ALL PREVIOUSLY STORED LOCAL OVERLAP INFORMATION ** NCOVER=0 NQOVER=0 IF(NTYPE)420,195,195 C ***** ELIMINATE ALL PREVIOUSLY STORED GLOBAL OVERLAP INFORMATION * 195 NCONIC=0 NQUAD=0 IF(NTYPE)420,420,200 C ***** CONSTANT FOR OVERLAP MARGIN (WHITE MARGIN AT OVERLAP) ***** 200 IF(AIN(1))205,215,210 C ***** NEGATIVE NUMBER OR POSITIVE INTEGER GIVES OVMRGN=0.0 ***** 205 OVMRGN=0.0 GO TO 220 C ***** SET OVERLAP MARGIN WIDTH DIRECTLY IN INCHES ***** C* ***** SET OVERLAP MARGIN WIDTH DIRECTLY IN MM ***** C*210 OVMRGN=AIN(1)-AINT(AIN(1)) 210 OVMRGN=AIN(1)-10.0*AINT(AIN(1)*0.1) GO TO 220 C ***** DEFAULT OPTION, OVERLAP MARGIN WIDTH AS A FUNCTION OF SCAL1 C* CONVERT DEFAULT VALUE IN INCHES TO MM, 0.030*SQRT(INCH/MM) C 215 OVMRGN=AMAX1(SQRT(SCAL1)*0.030,0.025) 215 OVMRGN=AMAX1(SQRT(SCAL1)*0.151,0.6250) 220 WRITE (NOUT,2) OVMRGN C 2 FORMAT(1H0,10X,17HOVERLAP MARGIN IS, F6.3,5H INCH) 2 FORMAT(1H0,10X,17HOVERLAP MARGIN IS, F6.3,5H MM. ) 225 IF(LATM)230,230,235 230 NG=12 CALL ERPNT(0.,510+NJ2) GO TO 420 C ***** SORT ATOMS LIST BY -VIEWDISTANCE OR BY Z PARAMETER 235 IF(VIEW)250,250,240 C ***** CALCULATE VIEWDISTANCES**2 *(-1) IF VIEW.GT.ZERO ***** 240 DO 245 I=1,LATM CALL XYZ(ATOMS(1,I),V3,2) V3(3)=V3(3)-VIEW 245 ATOMS(4,I)=-VV(V3,V3) GO TO 260 C ***** STORE CARTESIAN COORDINATES IF VIEW.EQ.ZERO ***** 250 DO 255 I=1,LATM 255 CALL XYZ(ATOMS(1,I),ATOMS(2,I),2) C ***** SORTING PROCEDURE BY SHELL, COMM ACM 2,30 (1959) ***** 260 M=LATM 265 M=M/2 IF(M)300,300,270 270 K=LATM-M J=1 275 I=J 280 IM=I+M IF(ATOMS(4,I)-ATOMS(4,IM))295,295,285 285 DO 290 L=1,4,3 T1=ATOMS(L,I) ATOMS(L,I)=ATOMS(L,IM) 290 ATOMS(L,IM)=T1 I=I-M IF(I)295,295,280 295 J=J+1 IF(J-K)275,275,265 C ***** LOOP THROUGH ALL ATOMS IN SORTED ATOMS LIST ***** 300 DO 405 IA=1,LATM CALL XYZ(ATOMS(1,IA),ATOMS(2,IA),2) CALL PAXES(ATOMS(1,IA),2) DO 305 J=1,3 V1(J)=ATOMS(J+1,IA) VD1(J)=V1(J) DO 305 K=1,3 305 QD(J,K)=Q(J,K) IF(VIEW)340,340,310 C ***** CALCULATE ENVELOPING CONE WITH ORIGIN AT VIEWPOINT ***** 310 V1(3)=V1(3)-VIEW VD1(3)=V1(3) C ***** FORM COFACTOR MATRIX ***** DO 315 J=1,3 J1=MOD(J,3)+1 J2=MOD(J+1,3)+1 DO 315 K=J,3 K1=MOD(K,3)+1 K2=MOD(K+1,3)+1 QC(J,K)= QD(J1,K1)*QD(J2,K2)-QD(J1,K2)*QD(J2,K1) 315 QC(K,J)=QC(J,K) C ***** FORM POLARIZED COFACTOR MATRIX AND ADD TO ELLIPSOID MATRIX * TD2=-SCL**2 C ***** TD1 IS AN ARBITRARY SCALING FACTOR ***** TD1=VMV(V1,Q,V1) DO 325 J=1,3 J1=MOD(J,3)+1 J2=MOD(J+1,3)+1 DO 320 K=J,3 K1=MOD(K,3)+1 K2=MOD(K+1,3)+1 QD(J,K)=((VD1(J2)*(QC(J1,K1)*VD1(K2)-QC(J1,K2)*VD1(K1)) 1 +VD1(J1)*(VD1(K1)*QC(J2,K2)-VD1(K2)*QC(J2,K1)))+TD2*QD(J,K))/TD1 320 QD(K,J)=QD(J,K) C ***** PROJECTED ELLIPSE IN HOMOGENEOUS COORD OF WORKING SYSTEM *** QD(J,3)=-QD(J,3)*VIEW 325 QD(3,J)=-QD(3,J)*VIEW C ***** PROJECT CENTER OF ATOM ONTO PROJECTION PLANE ***** TD1=-VIEW/VD1(3) VD2(1)=VD1(1)*TD1 VD2(2)=VD1(2)*TD1 C ***** TRANSFORM TO NEW ORIGIN TO IMPROVE CONDITION OF MATRIX Q *** DO 330 J=1,3 DO 330 K=1,2 330 QD(J,3)=QD(J,3)+QD(J,K)*VD2(K) DO 335 J=1,3 DO 335 K=1,2 335 QD(3,J)=QD(3,J)+VD2(K)*QD(K,J) V6(1)=XO(1)+VD2(1) V6(2)=XO(2)+VD2(2) GO TO 355 C ***** CALCULATE ENVELOPING CYLINDER ALONG Z OF WORKING SYSTEM **** 340 DO 345 J=1,2 DO 345 K=1,2 345 QD(J,K)=QD(J,K)-QD(J,3)*QD(K,3)/QD(3,3) DO 350 J=1,2 QD(J,3)=0.0 QD(3,J)=0.0 350 V6(J)=XO(J)+ATOMS(J+1,IA) C ***** PROJECTED ELLIPSE IN HOMOGENEOUS COORD ABOUT CENTER OF ATOM QD(3,3)=-SCL**2 C ***** FIT RECTANGLE AROUND ELLIPSE ALLOWING OVERLAP MARGIN ***** C ***** FORM MATRIX OF COFACTORS ***** 355 DO 360 J=1,3 J1=MOD(J,3)+1 J2=MOD(J+1,3)+1 DO 360 K=J,3 K1=MOD(K,3)+1 K2=MOD(K+1,3)+1 360 QC(J,K)= QD(J1,K1)*QD(J2,K2)-QD(J1,K2)*QD(J2,K1) C ***** RESCALE MATRIX OF COFACTORS SO THAT QC(3,3)=1.0 ***** DO 365 J=1,3 DO 365 K=J,3 QC(J,K)= QC(J,K)/QC(3,3) 365 QC(K,J)=QC(J,K) TD2=QD(3,3) NDG=0 DO 385 J=1,2 C ***** SOLVE QUADRATIC EQUATION ***** T1 =QC(3,J)**2-QC(J,J) IF(T1)370,370,375 C ***** ROUNDOFF PROBLEMS, RESET LIMITS IN X OR Y ***** 370 NDG=1 V5(J)=0.001+OVMRGN GO TO 380 375 V5(J)= SQRT(T1)+OVMRGN V6(J)=V6(J)+QC(3,J) TD2=TD2+QD(3,J)*QC(3,J) 380 CONIC(2*J-1,IA)=V6(J)-V5(J) 385 CONIC(2*J,IA)=V6(J)+V5(J) IF(NDG)390,390,395 390 IF(TD2)400,395,395 C ***** ELLIPSE IMAGINARY DUE TO ROUNDOFF, RESET TO REAL VALUE ***** 395 CONIC(5,IA)=1.0/((CONIC(2,IA)-CONIC(1,IA))*0.5)**2 CONIC(6,IA)=0.0 CONIC(7,IA)=1.0/((CONIC(4,IA)-CONIC(3,IA))*0.5)**2 GO TO 405 C ***** STORE NORMALIZED QUADRATIC COEFFICIENTS FOR ELLIPSE ***** C ***** SCALED BY OVERLAP MARGIN PARAMETER ***** 400 TD3= -(1.0-2.0*OVMRGN/(V5(1)+V5(2)))**2 /TD2 CONIC(5,IA)=QD(1,1)*TD3 CONIC(6,IA)=QD(1,2)*TD3 CONIC(7,IA)=QD(2,2)*TD3 405 CONTINUE NCONIC=LATM C ***** PRINT OUT SORTED ATOMS ARRAY ***** WRITE (NOUT,4)(ATOMS(1,J),J=1,LATM) 4 FORMAT(1H0,10X,30HCONTENTS OF SORTED ATOMS ARRAY/(15X,10F10.0)) C ***** STORE BOND QUADRANGLES IF SEARCH CODES ARE GIVEN ***** IF(NCD)420,420,410 C ***** GENERATE PSEUDO-INSTRUCTION 822 TO CALCULATE BONDS ***** 410 NJ2=22 CALL F800 IF(NQUAD)420,420,415 C ***** PRINT OUT NUMBER OF BOND QUADRANGLES STORED ***** C ***** PRINT OUT QUADRANGLE IDENTIFICATION ARRAY ***** 415 WRITE (NOUT,6)NQUAD,(QUAR(9,J),J=1,NQUAD) 6 FORMAT(1H0,10X,27HBOND OVERLAP ARRAY CONTAINS,I4,24H BONDS (MAXIMU CM IS 1199)/11X,66HATOM-PAIR NUMBERS IN ARRAY REFER TO SEQUENCE IN CSORTED ATOMS ARRAY/(15X,10F10.0)) 420 RETURN END SUBROUTINE LAP700(NA,ICQ) DIMENSION DETER(2),QA(3,3,2),QC(3,3,2),V12(3,2),YMIN(2),YMAX(2) DIMENSION OVMR(2) C ***** IN GENERAL, DOUBLE PRECISION IS NOT REQUIRED ***** C ***** BUT IN CASE OF TROUBLE, ACTIVATE THE CD COMMENT CARDS ***** REAL*8 AOV3,AOV3SQ,BOV3,DETER,PI,PHI,POV3,POV3CU,QA,QC,QOV2,QOV2SQ REAL*8 ROOT,TD COMMON/OLAP/CONIC(7,1000),COVER(6,40),KC(40),KQ(60),NCONIC,NCOVER, 1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,60),QUAR(9,1200),SEGM(100,2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT CD PI=3.1415926535897932 PI=3.141593 ICQ=0 NCOVER=0 NQOVER=0 OVMR(1)=OVMRGN OVMR(2)=0.0 IF(NCONIC-NA)200,200,205 200 RETURN C ***** ROUGH CHECK FOR OVERLAPPING ATOMS ***** 205 DO 210 J=1,2 YMIN(J)=CONIC(2*J-1,NA) 210 YMAX(J)=CONIC(2*J,NA) L=0 DO 420 IA=NA,NCONIC IF(IA-NA)230,230,215 215 DO 225 J=1,2 IF(YMAX(J)-CONIC(2*J-1,IA))420,420,220 220 IF(YMIN(J)-CONIC(2*J,IA))225,420,420 225 CONTINUE C ***** EXACT CHECK FOR OVERLAPPING ATOMS ***** 230 IF(L-1)235,235,240 235 L=L+1 240 CALL LAPCON(CONIC(1,IA),DA,V12(1,L),OVMR(L)) DO 245 J=1,3 DO 245 K=1,3 245 QA(J,K,L)=DA(J,K) C ***** CALCULATE COFACTORS AND DETERMINANTS ***** DETER(L)=0.0 DO 250 J=1,3 J1=MOD(J+3,3)+1 J2=MOD(J+1,3)+1 DO 250 K=1,3 K1=MOD(K+3,3)+1 K2=MOD(K+1,3)+1 TD=QA(J1,K1,L)*QA(J2,K2,L)-QA(J1,K2,L)*QA(J2,K1,L) DETER(L)=DETER(L)+TD*QA(J,K,L) 250 QC(J,K,L)=TD C ***** DETER(L) IS THE DETERMINANT TIMES 3 ***** IF(L-1)420,420,255 C ***** FORM CHARACTERISTIC EQUATION AND EXAMINE ITS ROOTS ***** 255 AOV3=0.0 BOV3=0.0 DO 260 J=1,3 DO 260 K=1,3 AOV3=AOV3+QC(J,K,2)*QA(J,K,1) 260 BOV3=BOV3+QC(J,K,1)*QA(J,K,2) AOV3=AOV3/ DETER(2) AOV3SQ=AOV3**2 BOV3=BOV3/ DETER(2) POV3=BOV3-AOV3SQ CD QOV2=AOV3*(AOV3SQ-BOV3*1.5D0)+DETER(1)/(DETER(2)*2.0D0) QOV2=AOV3*(AOV3SQ-BOV3*1.5 )+DETER(1)/(DETER(2)*2.0 ) C ***** CHECK DISCRIMINANT OF CHARACTERISTIC CUBIC EQUATION ***** ITYPE=0 POV3CU=POV3**3 QOV2SQ=QOV2**2 IF(POV3CU+QOV2SQ)270,310,265 265 IF(POV3CU*1.00001 +QOV2SQ)310,310,400 270 IF(POV3CU+1.00001 *QOV2SQ)275,310,310 C ***** THREE REAL ROOTS, ALL DIFFERENT ***** 275 ITYPE=1 C ***** NO INTERSECTION IF A/3 AND B/3 INVARIANTS ARE NEGATIVE ***** IF(AOV3)280,285,285 280 IF(BOV3)420,285,285 C ***** CALCULATE ONE ROOT OF CHARACTERISTIC CUBIC EQUATION ***** 285 IF(QOV2)295,290,295 CD290 PHI=PI/2.0D0 290 PHI=PI/2.0 GO TO 305 295 PHI=DATAN(-DSQRT(-POV3CU-QOV2SQ)/QOV2) C 295 PHI= ATAN(- SQRT(-POV3CU-QOV2SQ)/QOV2) IF(PHI)300,305,305 300 PHI=PHI+PI 305 ROOT=2.0D0*DSQRT(-POV3)*DCOS(PHI/3.0D0)-AOV3 C 305 ROOT=2.0 * SQRT(-POV3)* COS(PHI/3.0 )-AOV3 GO TO 325 C ***** THREE REAL ROOTS, AT LEAST TWO ARE EQUAL ***** 310 ITYPE=2 C ***** CHECK SIGNS OF INVARIANTS A/3 AND B/3 ***** IF(AOV3)315,320,320 315 IF(BOV3)420,320,320 C ***** CALCULATE REPEATED ROOT OF CUBIC EQUATION ***** 320 ROOT=DSIGN(DSQRT(-POV3),QOV2)-AOV3 C ***** FORM DEGENERATE CONIC (LINE PAIR WHICH MAY BE COINCIDENT) ** 325 DO 330 J=1,3 DO 330 K=1,3 330 DA(J,K)=QA(J,K,1)+ROOT*QA(J,K,2) C ***** EXAMINE INVARIANTS OF THE DEGENERATE CONIC ***** T6=DA(1,1)*DA(2,2) T7=DA(1,2)**2 C ***** NEGATIVE DENOTES REAL INTERSECTING LINE PAIR ***** C ***** POSITIVE DENOTES IMAGINARY LINES INTERSECTING AT REAL POINT IF(T6-T7)335,345,340 335 IF(T6*1.0001 -T7)400,345,345 340 IF(T6-1.0001 *T7)345,345,365 345 T8=DA(3,3)*(DA(1,1)+DA(2,2)) T9=DA(1,3)**2+DA(2,3)**2 C ***** NEGATIVE DENOTES REAL PARALLEL LINE PAIR ***** C ***** POSITIVE DENOTES IMAGINARY PARALLELS ***** C ***** ZERO DENOTES ONE REAL LINE (COINCIDENT PARALLELS) ***** IF(T8-T9)350,360,355 350 IF(T8*1.0001 -T9)400,360,360 355 IF(T8-1.0001 *T9)360,360,365 C ***** COINCIDENT LINE PAIR FOUND FOR THE REPEATED ROOT ***** 360 ITYPE=3 C ***** COMPARE AREAS OF CONICS ***** 365 KA=1 KB=2 IF(QC(3,3,KA)-QC(3,3,KB))370,375,375 370 KA=2 KB=1 C ***** SEE IF ONE CONIC IS INSIDE THE OTHER CONIC ***** 375 T1=0.0 DO 385 J=1,3 T2=QA(J,3,KB) DO 380 K=1,2 380 T2=T2+QA(J,K,KB)*V12(K,KA) 385 T1=T1+V12(J,KA)*T2 C ***** DISCARD IF KA IS OUTSIDE KB ***** IF(T1)390,390,420 390 IF(KA-1)395,395,400 C ***** THE OVERLAPPING ATOM HIDES THE ORIGINAL ATOM ***** 395 ICQ=-1 RETURN C ***** STORE OVERLAPPING ATOM ***** 400 ICQ=ICQ+1 IF(NCOVER-20)410,405,405 405 NG=17 CALL ERPNT(ATOMS(1,IA),700) NCOVER=NCOVER-1 410 NCOVER=NCOVER+1 IJ=1 DO 415 I=1,3 DO 415 J=I,3 COVER(IJ,NCOVER)=QA(I,J,2) 415 IJ=IJ+1 KC(NCOVER)=IA 420 CONTINUE C ***** SECOND PART OF SUBROUTINE CHECKS FOR BONDS OVER THE ATOM *** 425 IF(NQUAD)470,470,430 430 ITY=0 C ***** ROUGH CHECK FOR OVERLAPPING BONDS ***** DO 465 IQ=1,NQUAD TID=QUAR(9,IQ) NA1=TID/1000. NA2=AMOD(TID,1000.) IF(NA-NA2)435,435,465 435 DO 445 J=1,2 IF(YMAX(J)-AMIN1(QUAR(J,IQ),QUAR(J+2,IQ),QUAR(J+4,IQ),QUAR(J+6,IQ) 1 ))465,465,440 440 IF(YMIN(J)-AMAX1(QUAR(J,IQ),QUAR(J+2,IQ),QUAR(J+4,IQ),QUAR(J+6,IQ) 1 ))445,465,465 445 CONTINUE C ***** EXACT CHECK FOR OVERLAPPING BONDS ***** 450 ITY=ITY-1 IQQ=0 CALL LAPAB(IQ,NA,IQQ,ITY) IF(IQQ)455,460,460 455 ICQ=-1 RETURN 460 ICQ=ICQ+1 IF(NQOVER-30)465,470,470 465 CONTINUE 470 RETURN END SUBROUTINE LAP800(NA1,NA2,ICQ) C ***** SUBROUTINE CHECKS FOR ATOMS AND BONDS OVERLAPPING A BOND *** DIMENSION FL(4,4),Y1(2),Y2(2),YMAX(2),YMIN(2),QUA(3,4) DIMENSION VUE(3) COMMON/OLAP/CONIC(7,1000),COVER(6,40),KC(40),KQ(60),NCONIC,NCOVER, 1 NQOVER,NQUAD,OVMRGN,QOVER(3,4,60),QUAR(9,1200),SEGM(100,2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT IQ=0 ICQ=0 IF(NA1*NA2)245,245,195 195 TID1=FLOAT(NA1)*1000.+FLOAT(NA2) IF(NCONIC)245,245,200 200 IF(NJ2-21)250,205,205 C ***** PART 1, CALLED FROM BOND, STORES BOND OUTLINE INFORMATION ** 205 IF(NQUAD-1199)215,210,210 210 NG=16 CALL ERPNT(ATOMS(1,NA1),822) GO TO 245 215 NQUAD=NQUAD+1 C ***** CALCULATE OVERLAP MARGIN FOR BOND QUADRANGLE ***** T1=0.0 T2=0.0 DO 220 J=1,2 Y1(J)=DP(J,1)-DP(J,65) Y2(J)=DP(J,2)-DP(J,66) T1=T1+Y1(J)**2 220 T2=T2+Y2(J)**2 IF(T1*T2)225,225,230 225 T1=0.0 T2=0.0 GO TO 235 230 T1=OVMRGN/SQRT(T1) T2=OVMRGN/SQRT(T2) C ***** STORE BOND QUADRANGLE ***** 235 DO 240 J=1,2 Y1(J)=Y1(J)*T1 Y2(J)=Y2(J)*T2 QUAR(J,NQUAD)=DP(J,1)+Y1(J) QUAR(J+2 ,NQUAD)=DP(J,2)+Y2(J) QUAR(J+4,NQUAD)=DP(J,66)-Y2(J) 240 QUAR(J+6,NQUAD)=DP(J,65)-Y1(J) QUAR(9,NQUAD)=TID1 245 RETURN C ***** PART 2, CALLED FROM BOND, OVERLAP CHECK FOR BOND NA1-NA2 *** 250 NCOVER=0 NQOVER=0 TOL=1.E-5 IF(NCONIC-NA1)245,245,255 C ***** SAVE QUADRANGLE TEMPORARILY ***** 255 IQ=NQUAD+1 DO 260 J=1,2 QUAR(J,IQ)=DP(J,1) QUAR(J+2,IQ)=DP(J,2) QUAR(J+4,IQ)=DP(J,66) 260 QUAR(J+6,IQ)=DP(J,65) QUAR(9,IQ)=TID1 C ***** FIT RECTANGLE AROUND QUADRANGLE ***** 265 DO 270 J=1,2 YMIN(J)=AMIN1(DP(J,1),DP(J,2),DP(J,66),DP(J,65)) 270 YMAX(J)=AMAX1(DP(J,1),DP(J,2),DP(J,66),DP(J,65)) C ***** ROUGH CHECK FOR ATOM-OVER-BOND OVERLAP ***** NA1P1=NA1+1 ITY=0 DO 305 IA=NA1P1,NCONIC DO 285 J=1,2 IF(IA-NA2)275,305,275 275 IF(YMAX(J)-CONIC(2*J-1,IA))305,305,280 280 IF(YMIN(J)-CONIC(2*J,IA))285,305,305 285 CONTINUE C ***** CHECK FOR TRUE ATOM-OVER-BOND OVERLAP ***** ITY=ITY+1 CALL LAPAB(IQ,IA,IQQ,ITY) IF(IQQ)290,305,300 C ***** HIDDEN BOND ***** 290 ICQ=-1 295 RETURN 300 ICQ=ICQ+1 IF(NCOVER-20)305,310,310 305 CONTINUE 310 IF(NQUAD)500,500,315 C ***** ROUGH CHECK FOR BOND-OVER-BOND OVERLAP ***** 315 CALL DIFV(ATOMS(2,NA2),ATOMS(2,NA1),V1) CALL UNIT(V1,V1,1) VUE(1)= ATOMS(2,NA1) VUE(2)= ATOMS(3,NA1) VUE(3)= ATOMS(4,NA1)-VIEW DO 495 IB=1,NQUAD TID2=QUAR(9,IB) IF(TID1-TID2)320,495,320 320 NB2=AMOD(TID2,1000.) NB1=TID2/1000. IF(NA1-NB2)325,495,495 325 DO 335 J=1,2 IF(YMAX(J)-AMIN1(QUAR(J,IB),QUAR(J+2,IB),QUAR(J+4,IB),QUAR(J+6,IB) 1 ))495,495,330 330 IF(YMIN(J)-AMAX1(QUAR(J,IB),QUAR(J+2,IB),QUAR(J+4,IB),QUAR(J+6,IB) 1 ))335,495,495 335 CONTINUE C ***** SET UP LINEAR FORMS FOR EDGES OF QUADRANGLE ***** DO 345 L=1,4 K=2*L K1=MOD(K,8)+2 QUA(1,L)=QUAR(K,IB)-QUAR(K1,IB) QUA(2,L)=QUAR(K1-1,IB)-QUAR(K-1,IB) QUA(3,L)=QUAR(K-1,IB)*QUAR(K1,IB)-QUAR(K,IB)*QUAR(K1-1,IB) C ***** NORMALIZE LINE EQUATION COEFFICIENTS ***** T1=SQRT(QUA(1,L)**2+QUA(2,L)**2) IF(T1)495,495,340 340 DO 345 J=1,3 345 QUA(J,L)=QUA(J,L)/T1 C ***** EVALUATE LINEAR FORMS AND SIGNATURES FOR QUADRANGLE ***** T3=3.0 DO 365 K=1,4 T2=3.0 J=K*2 DO 355 L=1,4 T1=QUAR(J-1,IQ)*QUA(1,L)+QUAR(J,IQ)*QUA(2,L)+QUA(3,L) IF(T1)350,355,355 350 T2=T2-1.0 355 FL(L,K)=T1 IF(T2)360,365,365 360 T3=T3-1.0 365 CONTINUE C ***** CHECK FOR 4 POINTS INSIDE QUADRANGLE ***** IF(T3)370,375,375 370 ITYPE=-1 GO TO 415 C ***** CHECK FOR 1 TO 3 POINTS INSIDE QUADRANGLE **** 375 IF(T3-3.0)380,385,385 380 ITYPE=0 GO TO 415 C ***** DETERMINE WHICH EDGES ARE CROSSED BY THE 4 LINE SEGMENTS *** 385 DO 405 L=1,4 L1=MOD(L,4)+1 C ***** LINE SEGMENT L FROM POINT Y1 TO POINT Y2 ***** Y1(1)=QUAR(L*2-1,IQ) Y1(2)=QUAR(L*2,IQ) Y2(1)=QUAR(L1*2-1,IQ) Y2(2)=QUAR(L1*2,IQ) DO 405 K=1,4 T1=FL(K,L) T2=FL(K,L1) T3=T1-T2 C ***** T1 AND T2 MUST HAVE OPPOSITE SIGNS FOR INTERSECTION TO OCCUR IF(T1*T2)390,390,405 C ***** COMPONENT OF SEGMENT L PERPENDICULAR TO EDGE K OF IB IS T3 390 IF(ABS(T3)-1.E-5)405,405,395 C ***** CALCULATE COORDINATES OF INTERSECTION ***** 395 T4=(T1*Y2(1)-T2*Y1(1))/T3 T5=(T1*Y2(2)-T2*Y1(2))/T3 K0=2*K K1=2*(MOD(K,4)+1) C ***** IS INTERSECTION WITHIN QUADRANGLE IQ ***** T6=(T4-QUAR(K0-1,IB))*(QUAR(K1-1,IB)-T4)+(T5-QUAR(K0,IB))* 1 (QUAR(K1,IB)-T5) IF(ABS(T6)-1.E-4)410,410,400 400 IF(T6)405,410,410 405 CONTINUE GO TO 495 410 ITYPE=1 C ***** CHECK OVER/UNDER AMBIGUITY ***** 415 IF((NA1-NB1)*(NA2-NB2)*(NA2-NB1))425,420,425 C ***** BONDS SHARE AN ATOM ***** 420 IF(NA1+NA2-NB1-NB2)465,495,495 425 CALL DIFV(ATOMS(2,NB2),ATOMS(2,NB1),V2) CALL DIFV(ATOMS(2,NB1),ATOMS(2,NA1),V4) CALL UNIT(V2,V2,1) CALL UNIT(V4,V4,1) CALL NORM(V1,V2,V3,1) IF(VV(V3,V3)-TOL)430,430,435 C ***** PARALLEL BONDS, RECALCULATE V3 ***** 430 CALL NORM(V1,V4,V5,1) CALL NORM(V5,V1,V3,1) C ***** CHECK FOR COLLINEAR BONDS ***** IF(VV(V3,V3)-TOL)465,465,450 435 IF(VV(V3,V4)+TOL)440,450,450 440 DO 445 J=1,3 445 V3(J)=-V3(J) C ***** V3 IS NORMAL TO BONDS IQ AND IB GOING FROM IQ TOWARD IB *** 450 IF(VIEW)455,455,460 455 IF(V3(3))495,495,465 460 IF(VV(VUE,V3))465,495,495 C ***** OVERLAPPING BOND FOUND ***** 465 ICQ=ICQ+1 IF(ITYPE)470,475,475 C ***** HIDDEN BOND ***** 470 ICQ=-1 RETURN C ***** STORE INTERFERING QUADRANGLE ***** 475 IF(NQOVER-60)485,480,480 480 NG=17 CALL ERPNT(TID2,800) RETURN 485 NQOVER=NQOVER+1 DO 490 K=1,4 DO 490 J=1,3 490 QOVER(J,K,NQOVER)=QUA(J,K) KQ(NQOVER)=IB 495 CONTINUE 500 RETURN END SUBROUTINE MV(X,Y,Z) C MATRIX * VECTOR C Z(3)=X(3,3)*Y(3) DIMENSION X(3,3),Y(3),Z(3) DO 113 I=1,3 Z(I)=0.0 DO 113 J=1,3 113 Z(I)=Z(I)+X(I,J)*Y(J) RETURN END SUBROUTINE MM(X,Y,Z) C MULTIPLY TWO MATRICES C Z(3,3)=X(3,3)*Y(3,3) DIMENSION X(3,3),Y(3,3),Z(3,3) DO 117 I=1,3 DO 117 K=1,3 Z(I,K)=0.0 DO 117 J=1,3 117 Z(I,K)=Z(I,K)+X(I,J)*Y(J,K) RETURN END SUBROUTINE NORM(X,Y,Z,ITYPE) C ***** VECTOR PRODUCT Z=X*Y ***** C ***** ITYPE .GT.0 FOR CARTESIAN,.LE.0 FOR TRICLINIC ***** DIMENSION X(3),Y(3),Z(3),Z1(3) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT DO 125 I=1,3 I1=MOD(I+3,3)+1 I2=MOD(I+1,3)+1 T1=X(I1)*Y(I2)-X(I2)*Y(I1) IF(ITYPE)115,115,105 105 Z(I)=T1 GO TO 125 115 Z1(I)=T1 125 CONTINUE IF(ITYPE)135,135,300 135 CALL MV(BB,Z1,Z) 300 RETURN END SUBROUTINE PAXES(ACODE,ITYPE) C ***** ITYPE .LT.0 FOR COVARIANCE MATRIX IN Q ***** C ***** ITYPE .GT.0 FOR ELLIPSOID QUADRATIC FORM IN Q ***** C ***** XABSF(ITYPE)=1 BASED ON TRICLINIC COORDINATE SYSTEM ***** C ***** =2 OR 3 FOR WORKING OR REFERENCE CARTESIAN SYSTEMS ***** C ***** CONTRAVARIANT EIGENVECTORS FOR Q IN COLUMNS OF PAC ***** C ***** CHECK ATOM CODE ***** DIMENSION W(3,3),X(3) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT IT=IABS(ITYPE)-1 KS=AMOD(ACODE,100.) IF(NSYM-KS)105,115,115 105 NG=4 GO TO 300 115 II=ACODE/100000. IF(NATOM-II)125,130,130 125 NG=5 GO TO 300 130 IF(II)125,125,135 C ***** CRYSTALLOGRAPHIC SYMMETRY ROTATION ***** 135 CALL TMM(PA(1,1,II),FS(1,1,KS),PAT) IF(IT-1)160,145,155 C ***** TRANSFORM TO CARTESIAN SYSTEMS ***** 145 CALL TMM(PAT,AAWRK,PAC) GO TO 175 155 CALL TMM(PAT,AAREV,PAC) GO TO 175 160 IF(ITYPE)162,155,170 C ***** TRANSFORM TO TRICLINIC SYSTEM ***** 162 DO 165 J=1,9 165 PAC(J,1)=PAT(J,1) GO TO 175 170 CALL MM(AA,PAT,PAC) C ***** FORM DIAGONAL MATRIX OR ITS INVERSE ***** 175 DO 205 J=1,3 T1=EV(J,II) IF(ITYPE)195,195,185 185 X(J)=1./(T1*T1) GO TO 205 195 X(J)=T1*T1 205 RMS(J)=T1 C ***** FORM QUADRATIC FORM ***** DO 245 I=1,3 DO 245 J=I,3 T1=0.0 DO 225 K=1,3 225 T1=T1+PAC(I,K)*PAC(J,K)*X(K) Q(J,I)=T1 245 Q(I,J)=T1 300 RETURN END SUBROUTINE PLTXY(X,Y) C ***** PLOT COORD. AND CLOSEST EDGE AFTER PROJECTION ***** DIMENSION X(3),Y(2) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT T4=1. T1=1. IF(VIEW)125,125,110 110 T4=VIEW-X(3) IF(T4)115,115,120 115 Y(1)=-99. Y(2)=-99. GO TO 130 120 T1=VIEW/T4 125 Y(1)=X(1)*T1+XO(1) Y(2)=X(2)*T1+XO(2) T1=XLNG(1)-ABS(Y(1)*2.-XLNG(1)) T2=XLNG(2)-ABS(Y(2)*2.-XLNG(2)) EDGE=AMIN1(T1,T2)*.5 IF(T4-VIEW*.5)130,300,300 130 EDGE=-99. 300 RETURN END SUBROUTINE PRELIM C ***** DATA INPUT ROUTINE ***** DIMENSION B(9) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT C ***** CELL DIMENSIONS ***** 106 FORMAT(6F9.6) READ (IN,106)(A(I),I=1,6) T1=ABS(A(4))-1. DO 125 J=1,3 IF(T1)115,110,110 C ***** CELL ANGLES IN DEGREES ***** 110 A(J+6)=A(J+3) A(J+3)=COS(A(J+6)*.01745329252E0) GO TO 120 C ***** COSINES OF CELL ANGLES ***** 115 A(J+6)=ARCCOS(A(J+3)) C ***** STORE IDEMFACTOR MATRIX ***** 120 AID(J,J)=1. AID(J+1,1)=0. AID(J+5,1)=0. C ***** STORE METRIC TENSOR ***** 125 AA(J,J)=A(J)**2 AA(1,2)=A(1)*A(2)*A(6) AA(1,3)=A(1)*A(3)*A(5) AA(2,3)=A(2)*A(3)*A(4) AA(2,1)=AA(1,2) AA(3,1)=AA(1,3) AA(3,2)=AA(2,3) C ***** INVERT METRIC TENSOR ***** CALL AXEQB(AA,BB,AID,3) C ***** CALCULATE RECIPROCAL CELL PARAMETERS ***** DO 128 J=1,3 128 B(J)=SQRT(BB(J,J)) B(6)=BB(1,2)/(B(1)*B(2)) B(5)=BB(1,3)/(B(1)*B(3)) B(4)=BB(2,3)/(B(2)*B(3)) DO 130 J=1,3 130 B(J+6)=ARCCOS(B(J+3)) C ***** WAS INPUT FOR REAL OR RECIPROCAL CELL ***** IF(A(1)-1.)135,150,150 135 DO 140 J=1,9 T1=AA(J,1) AA(J,1)=BB(J,1) BB(J,1)=T1 T1=A(J) A(J)=B(J) 140 B(J)=T1 C ***** WRITE OUT CELL PARAMETERS ***** 143 FORMAT(1H010X,22HDIRECT CELL PARAMETERS/1H 15X,1HA14X,1HB14X,1HC14 1X,5HALPHA10X,4HBETA11X,5HGAMMA) 145 FORMAT(1H 10X,F9.6,2F15.6,3F15.3/1H 48X,6HCOSINEF12.8,2F15.8) 147 FORMAT(1H010X,26HRECIPROCAL CELL PARAMETERS/1H 15X,2HA*13X,2HB*13X 1,2HC*13X,6HALPHA*9X,5HBETA*10X,6HGAMMA*) 150 WRITE (NOUT,143) WRITE (NOUT,145)(A(I),I=1,3),(A(I),I=7,9),(A(I),I=4,6) WRITE (NOUT,147) WRITE (NOUT,145)(B(I),I=1,3),(B(I),I=7,9),(B(I),I=4,6) C ***** STORE STANDARD VECTORS ***** CALL AXES(AID,AID(1,2),REFV,0) CALL MM(AA,REFV,AAREV) DO 160 I=1,3 DO 160 J=1,3 AAWRK(J,I)=AAREV(J,I) Q(J,I)=REFV(I,J) 160 WRKV(J,I)=REFV(J,I) C ***** READ AND WRITE SYMMETRY TRANSFORMATIONS ***** 171 FORMAT(1H010X,24HSYMMETRY TRANSFORMATIONS/1H 14X,3HNO.12X,13HTRANS 1FORMED X18X,13HTRANSFORMED Y18X,13HTRANSFORMED Z) 173 FORMAT((I1,F14.10,3F3.0,2(F15.10,3F3.0))) 175 FORMAT((1H 13X,I2,3(F13.6,F4.0,2H XF4.0,2H YF4.0,2H Z))) 177 FORMAT(1H110X,18A4) WRITE (NOUT,171) LINES=14 DO 190 I=1,48 LINES=MOD(LINES+1,56) READ (IN,173)IS,(TS(J,I),(FS(K,J,I),K=1,3),J=1,3) IF(LINES)185,180,185 180 WRITE (NOUT,177)(TITLE(J),J=1,18) WRITE (NOUT,171) 185 WRITE (NOUT,175)I,(TS(J,I),(FS(K,J,I),K=1,3),J=1,3) C ***** NON-CRYSTALLOGRAPHIC HELIX-SYMMETRY INPUT ***** IF(FS(3,3,I)-5.)188,186,186 186 T1=FS(1,3,I)/FS(3,3,I) TS(3,I)=TS(3,I)+T1 T1=AMOD(T1*FS(2,3,I),1.)*6.28318531E0 T2=COS(T1) T1=SIN(T1) DO 187 J=1,9 187 VT(J,1)=AID(J,1) VT(1,1)=T2 VT(2,2)=T2 VT(2,1)=-T1 VT(1,2)=T1 CALL MM(VT,Q,PAC) CALL MM(AAREV,PAC,FS(1,1,I)) 188 IF(IS)195,190,195 190 CONTINUE NG=1 CALL ERPNT(0.,0) I=48 195 NSYM=I C ***** POSITIONAL AND THERMAL PARAMETERS ***** 207 FORMAT(11H0 NO. ATOM 8X,1HX10X,1HY10X,1HZ13X,3HB118X,3HB228X,3HB33 18X,3HB128X,3HB138X,10HB23 TYPE) 209 FORMAT(1H I3,1X,A6,3F11.6,5X,6F11.6,F5.0) 210 FORMAT(1H I3,1X,A6,3F11.6,5X,2F11.6,4F11.0,F5.0) 211 FORMAT(A6,3X,5F9.6,F9.0) 213 FORMAT(I1,F8.6,5F9.6,7X,F2.0) LINES=LINES+2 IF(LINES-56)220,215,215 215 LINES=-1 GO TO 225 220 WRITE (NOUT,207) 225 CONTINUE C AWTI=' U' C IF(AWTI.EQ.TITLE(18)) GO TO 1000 DO 245 I=1,200 LINES=MOD(LINES+1,56) READ (IN,211) CHEM(I),V1(1),V1(2),(P(J,I),J=1,3),T1 K=1.+T1 READ (IN,213) IS,(PA(J,1,I),J=1,7) IF(LINES) 230,230,232 230 WRITE (NOUT,177)(TITLE(J),J=1,18) WRITE (NOUT,207) 232 IF(PA(3,1,I)-10000.)235,234,234 234 WRITE (NOUT,210)I,CHEM(I),(P(J,I),J=1,3),(PA(J,1,I),J=1 1,7) GO TO 238 235 WRITE (NOUT,209)I,CHEM(I),(P(J,I),J=1,3),(PA(J,1,I),J=1 1,7) 238 GO TO (244,239,241,242,244),K C ***** TYPE 1 POSITIONAL PARAMETERS (ANGSTROMS) ***** 239 DO 240 J=1,3 240 P(J,I)=P(J,I)/A(J) GO TO 244 C ***** TYPE 2 POSITIONAL PARAMETERS, STANDARD CARTESIAN ***** 241 V1(1)=P(1,I) V1(2)=P(2,I) GO TO 243 C ***** TYPE 3 POSITIONAL PARAMETERS ***** C ***** CYLINDRICAL COORDINATES REFERRED TO STANDARD CARTESIAN ***** 242 T2=P(2,I)*.01745329252E0 V1(1)=V1(1)+P(1,I)*COS(T2) V1(2)=V1(2)+P(1,I)*SIN(T2) 243 V1(3)=P(3,I) CALL VM(V1,Q,P(1,I)) 244 IF(IS)246,245,246 245 CONTINUE NG=2 CALL ERPNT(0.,0) I=100 246 NATOM=I GO TO 1400 C **** UNICS(3) DATA **** 1000 CONTINUE READ(IN,1010) NANA,NISA 1010 FORMAT(2I5) IF(NANA.LE.0) GO TO 1100 DO 1050 I=1,NANA READ(IN,1020) CHEM(I),(P(J,I),J=1,3) READ(IN,1030) (PA(J,1,I),J=1,6) PA(7,1,I)=0. 1020 FORMAT(A8,2X,3F10.5) 1030 FORMAT(10X,6F10.5) WRITE(NOUT,209) I,CHEM(I),(P(J,I),J=1,3),(PA(J,1,I),J=1,7) 1050 CONTINUE 1100 CONTINUE IF(NISA.LE.0) GO TO 1300 DO 1200 I=1,NISA L9=I+NANA DO 1110 J=2,7 1110 PA(J,1,L9)=0. READ(IN,1120) CHEM(L9),(P(J,L9),J=1,3),PA(1,1,L9) 1120 FORMAT(A8,2X,3F10.5,F8.2) WRITE(NOUT,209) L9,CHEM(L9),(P(J,L9),J=1,3),(PA(J,1,L9),J=1,7) 1200 CONTINUE 1300 CONTINUE C **** CONVERT TEMP FACTOR COEF TO STANDARD TYPE ZERO **** NATOM=NANA+NISA 1400 NG1=0 DO 450 I=1,NATOM T1=PA(1,1,I) K=1.+PA(7,1,I) IF(T1)250,250,255 250 T1=.1 GO TO 405 255 T6=.0506605918E0 GO TO(270,260,265,265,270,260,400,405,270,260,270,450),K C ***** TYPE 1 ***** 260 DO 262 J=4,6 262 PA(J,1,I)=PA(J,1,I)*.5 GO TO 270 C ***** TYPES 2 AND 3 (BASE 2 SYSTEMS) ***** 265 T6=.351152464E0 IF(K-4)270,260,270 C ***** TYPES 0 THROUGH 5 ***** 270 IF(PA(2,1,I))400,400,272 272 DO 300 J=1,3 DO 300 L=J,3 T2=T6 IF(K-5)285,275,275 275 IF(K-6)280,280,281 C ***** TYPES 4 AND 5 ***** 280 T2=B(J)*B(L)*T2*.25 GO TO 285 C ***** TYPES 8 AND 9 (U(I,J) TENSOR SYSTEMS) ***** 281 T2=B(J)*B(L) IF(K-11)285,282,282 C ***** TYPE 10, (CARTESIAN TENSOR SYSTEM) ***** 282 T2=1.0 285 IF(J-L)290,287,290 287 VT(J,J)=T2*PA(J,1,I) GO TO 300 290 M=J+L+1 VT(J,L)=T2*PA(M,1,I) VT(L,J)=VT(J,L) 300 CONTINUE C ***** FIND PRINCIPAL AXES ***** IF(K-11)310,305,305 305 CALL MM(VT,Q,PAC) CALL MM(REFV,PAC,VT) 310 CALL MM(VT,AA,DA) CALL EIGEN(DA,RMS,PAT) C ***** ARE EIGENVALUES POSITIVE ***** IF(RMS(1))325,325,320 320 IF(NG)350,360,330 325 NG=3 330 NG1=1 CALL ERPNT(FLOAT(I)*100000.+55501.,0) C ***** 3 EQUAL EIGENVALUES, USE REFERENCE VECTORS ***** 340 T3=DSIGN(DBLE(SQRT(ABS(RMS(1)+RMS(2)+RMS(3))/3.)),DBLE(RMS(1))) DO 345 J=1,3 DO 342 K=1,3 342 PA(J,K,I)=REFV(J,K) 345 EV(J,I)=T3 GO TO 450 350 IF(NG+6)340,340,352 C ***** TWO EQUAL EIGENVALUES ***** 352 N=NG+5 CALL UNIT(PAT(1,N),V1,-1) DO 354 K=1,3 IF(ABS(VMV(V1,AA,REFV(1,K)))-.58)356,354,354 354 CONTINUE 356 CALL MM(AA,DA,VT) CALL AXES(V1,REFV(1,K),DA,-1) DO 359 K=1,3 L=MOD(N+K-2,3)+1 DO 358 J=1,3 358 PA(J,L,I)=DA(J,K) 359 EV(L,I)=DSIGN(DBLE(SQRT(ABS(VMV(DA(1,K),VT,DA(1,K))))),DBLE(RMS(L) C)) GO TO 450 C ***** MAKE EIGENVECTORS 1 ANGSTROM LONG ***** 360 CALL AXES(PAT(1,1),PAT(1,3),PA(1,1,I),-1) 370 NG=0 C ***** SQRT EIGENVALUE = RMS DISPLACEMENT ***** DO 375 J=1,3 T2=RMS(J) 375 EV(J,I)=DSIGN(DBLE(SQRT(ABS(T2))),DBLE(T2)) GO TO 450 C ***** TYPE 6 (ISOTROPIC TEMP FACTOR) ***** 400 T1=SQRT(T1*.012665148E0) C ***** TYPE 7 (DUMMY SPHERE) ***** 405 DO 410 J=1,3 410 EV(J,I)=T1 IF(PA(3,1,I))430,430,415 C ***** DEFINED VECTORS FOR SPHERE ***** 415 DO 425 J=1,4 T2=PA(J+2,1,I) CALL ATOM(T2,VT(1,J)) IF(NG)420,425,420 420 CALL ERPNT(T2,0) GO TO 430 425 CONTINUE CALL DIFV(VT(1,2),VT(1,1),V1) CALL DIFV(VT(1,4),VT(1,3),V2) CALL AXES(V1,V2,PA(1,1,I),-1) GO TO 450 C ***** REFERENCE VECTORS FOR SPHERE ***** 430 DO 435 J=1,9 435 PA(J,1,I)=REFV(J,1) 450 NG=0 C ***** WRITE OUT RMS VALUES ***** LINES=LINES+2 IF(LINES-56)458,458,455 455 LINES=-1 GO TO 460 458 WRITE (NOUT,461) 460 DO 465 I=1,NATOM LINES=MOD(LINES+1,56) IF(LINES)465,462,465 461 FORMAT(10H0NO. ATOM 8X,1HX10X,1HY10X,1HZ13X,7HRMSD 1 4X,7HRMSD 2 4 1X,7HRMSD 3 ) 462 WRITE (NOUT,177)(TITLE(J),J=1,18) WRITE (NOUT,461) 463 FORMAT(1H I3,1X,A6,3F11.6) 465 WRITE (NOUT,209)I,CHEM(I),(P(J,I),J=1,3),(EV(J,I),J=1,3 1) IF(NG1)999,999,470 470 CALL MYEXIT 999 RETURN END SUBROUTINE PRIME C ****GENERAL INITIALIZATION OF PRIME PARAMETERS**** character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT C BRDR=0.5 BRDR=1.25 C ****CALCULATE CONSTANTS**** DO 2999 I=1,5 2999 CONT(I)=SQRT(1./(2.*(1.+COS(3.141592654E0/2.**I)))) C DISP=.005 DISP=.10 FORE=.866 IN=10 ITILT=0 LATM=0 NCD=0 NG=0 NOUT=12 NSR=1 C RES(1)=1.25 C RES(2)=.5 C RES(3)=.2 RES(1)=32.0 RES(2)=12.5 RES(3)=5.000 SCAL1=1.0 SCAL2=1.54 SCL=1.54 DO 3000 I=1,3 SYMB(I,I)=1. SYMB(I+1,1)=0. 3000 SYMB(I+5,1)=0. TAPER=.375 THETA=0.0 VIEW=0.0 C XLNG(1)=30.0 C XLNG(2)=11.0 C XO(1)=15.0 C XO(2)=5.5 XLNG(1)=750. XLNG(2)=265. XO(1)=375. XO(2)=132.5 DO 3001 J=1,3 3001 ORGN(J) = 0.0 C ***** INITIATE OVERLAP ROUTINES ***** CALL LAP500(0) RETURN END SUBROUTINE PROJ(D,DP,X,XO,VIEW,I1,I2,I3) C ***** 3D CARTESIAN TO 2D PLOTTER COORDINATES ***** DIMENSION D(3,129),DP(2,129),X(3),XO(3) T3=VIEW-X(3) DO 145 I=I1,I2,I3 T1=D(1,I)+X(1) T2=D(2,I)+X(2) IF(VIEW)135,135,120 120 T4=VIEW/(T3-D(3,I)) T1=T1*T4 T2=T2*T4 135 DP(1,I)=T1+XO(1) 145 DP(2,I)=T2+XO(2) RETURN END SUBROUTINE RADIAL(ND) C ***** GENERATE ELLIPSE FROM TWO CONJUGATE VECTORS ***** C ***** ORTHONORMAL VECTORS PRODUCE 8-128 SPOKED CIRCLE ***** C ***** ND DENOTES NUMBER OF SUBDIVISIONS (1 TO 5) ***** character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT DO 115 J=1,3 T1=DA(J,1) D(J,1)=T1 D(J,129)=T1 D(J,65)=-T1 T1=DA(J,2) D(J,33)=T1 115 D(J,97)=-T1 DO 135 K=1,ND T1=CONT(K) KDEL=2**(6-K) KDEL1=KDEL+1 KDEL2=KDEL/2 DO 135 L=KDEL1,65,KDEL J=L-KDEL M=L-KDEL2 DO 135 N=1,3 T2=(D(N,L)+D(N,J))*T1 D(N,M)=T2 135 D(N,M+64)=-T2 RETURN END SUBROUTINE SEARC DIMENSION NW(6),DX(3),S(2,200),U(3),V(3),W(2,4),WW(2,3),X(4),Y(3) DIMENSION Z(3) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT EQUIVALENCE(NW(1),LL),(NW(2),LU),(NW(3),ML) EQUIVALENCE(NW(4),MU),(NW(5),NL),(NW(6),NU) C ***** OBTAIN PROBLEM PARAMETERS ***** WRITE (NOUT,20) 20 FORMAT(1H0 9X,82H FROM ATOMS TO ATOMS WITH RADIUS OR 1, IF A BOX, WITH SEMIDIMENSIONS /11X,46HCODE (MIN MAX) (MIN 2 MAX) 7X,1HA8X,1HB8X,1HC) IF(AIN(1)-10000.)100,100,101 100 ITOM1=AIN(1) SYITOM=55501. GO TO 103 101 ITOM1=AIN(1)/100000. SYITOM=AMOD(AIN(1),100000.) 102 IF(ABS(AIN(2))-10000.)103,103,104 103 ITOM2 = ABS(AIN(2)) SYITO2=SYITOM GO TO 105 104 ITOM2=ABS(AIN(2))/100000. SYITO2=DMOD(DBLE(ABS(AIN(2))),DBLE(100000.)) 105 ITAR1=AIN(3) IF(ITAR1)108,108,110 108 ITAR1=1 110 ITAR2=AIN(4) DMAX=AIN(5) IF(DMAX)115,115,120 115 DMAX=4. AIN(5)=DMAX 120 DMX=DMAX*DMAX TEM=.01 KFUN=NJ*100+MOD(NJ2,10) K=NJ*100+NJ2 I0=SYITOM I02=SYITO2 LATOM=LATM 121 FORMAT(1H010X,2I3,I5,I4,I5,2I4,18X,3F9.3/1H ) WRITE (NOUT,121)K,ITOM1,I0,ITOM2,I02, 1ITAR1,ITAR2,(AIN(J),J=5,7) 124 FORMAT(1H 15X,2I5,I8,I5,2F9.3) IF(NCD)130,130,125 125 WRITE (NOUT,124) ((KD(J,I),J=1,4),(CD(J,I),J=1,2) ,I=1, 1NCD) 130 DO 135 J=1,4 W(1,J)=99. 135 W(2,J)=-99. DO 155 I=ITAR1,ITAR2 T1=FLOAT(I)*100000. CALL ATOM(T1,X) IF(NG)140,145,140 140 CALL ERPNT(T1,KFUN) GO TO 600 145 X(4)=X(1)-X(2) DO 155 J=1,4 TEM=X(J) IF(W(2,J)-TEM)148,150,150 148 W(2,J)=TEM 150 IF(TEM-W(1,J))152,155,155 152 W(1,J)=TEM 155 CONTINUE KFUN2=MOD(KFUN,10) GO TO (165,165,160,156,165,165),KFUN2 C ***** FIND PARALLELEPIPED WHICH ENCLOSES TRICLINIC BOX ***** 156 DO 158 J=1,3 158 DX(J)=AIN(J+4) GO TO 170 C ***** FIND PARALLELEPIPED WHICH ENCLOSES RECTANGULAR BOX ***** 160 DO 162 J=1,3 DX(J)=0. DO 162 I=1,3 162 DX(J)=DX(J)+ABS(REFV(J,I)*AIN(I+4)) GO TO 170 C ***** FIND PARALLELEPIPED WHICH ENCLOSES DMAX SPHERE ***** 165 T1=1.-A(4)*A(4)-A(5)*A(5)-A(6)*A(6)+2.*A(4)*A(5)*A(6) DO 168 J=1,3 168 DX(J)=SQRT((1.-A(J+3)**2)/T1)*DMAX/A(J) C ***** START SEARCH AROUND REFERENCE ATOMS ***** 170 LIST=0 LAST=0 M1=ITOM1 N1=ITOM2 IF(KFUN2-5)186,172,172 C ***** CONVOLUTE AND REITERATIVE CONVOLUTE INSTRUCTIONS ***** 172 IF(LATM)174,174,176 C ***** FAULT, NO ENTRIES IN ATOMS LIST ***** 174 NG=12 CALL ERPNT(0.,KFUN) GO TO 600 C ***** CHECK FOR REFERENCE ATOMS IN ATOMS LIST ***** 176 IF(LATM-LAST)600,600,177 177 LIST=LAST LAST=LATM 178 LIST=LIST+1 IF(LAST-LIST)505,180,180 180 T1=ATOMS(1,LIST) ITOM=T1/100000. IF(ITOM-ITOM1)178,184,182 182 IF(ITOM2-ITOM)178,184,184 184 SYITOM=AMOD(T1,100000.) SYITO2=SYITOM M1=ITOM N1=ITOM C ***** SET INITIAL RUN PARAMETERS ***** 186 M2=AMOD(SYITOM,100.) M5=AMOD(SYITOM/100.,1000.) M3=M5/100 M4=MOD(M5/10,10) M5=MOD(M5,10) C ***** SET TERMINAL RUN PARAMETERS ***** N2=AMOD(SYITO2,100.) N5=AMOD(SYITO2/100.,1000.) N3=N5/100 N4=MOD(N5/10,10) N5=MOD(N5,10) C ***** START SEARCH AROUND REFERENCE ATOMS ***** DO 500 L5=M5,N5 DO 500 L4=M4,N4 DO 500 L3=M3,N3 DO 500 L2=M2,N2 DO 500 ITOM=M1,N1 T1=FLOAT(ITOM)*100000.+FLOAT(L3*10000+L4*1000+L5*100+L2) CALL ATOM(T1,Y) IF(NG)188,190,188 188 CALL ERPNT(T1,KFUN) GO TO 500 C ***** K=SYMMETRY EQUIVALENT POSITION ***** 190 NUM=0 DO 400 K=1,NSYM C ***** SUBTRACT SYMMETRY TRANSLATION FROM REFERENCE ATOM ***** DO 192 J=1,3 192 U(J)=Y(J)-TS(J,K) C ***** DETERMINE LIMITING CELLS TO BE SEARCHED ***** C ***** FIRST,MOVE THE BOX THROUGH THE SYMMETRY OPERATION ***** DO 200 J=1,3 DO 200 L=1,2 WW(L,J)=0.0 DO 200 I=1,3 TEM=FS(I,J,K) IF(TEM)194,200,196 194 N=MOD(L,2)+1 GO TO 198 196 N=L 198 WW(L,J)=WW(L,J)+W(N,I)*TEM 200 CONTINUE C ***** CHECK FOR MIXED INDEX TRANSFORMATION ***** DO 215 J=1,2 TEM=FS(1,J,K) IF(TEM+FS(2,J,K))215,201,215 201 IF(TEM)203,215,207 203 WW(1,J)=W(2,4)*TEM WW(2,J)=W(1,4)*TEM GO TO 215 207 WW(1,J)=W(1,4)*TEM WW(2,J)=W(2,4)*TEM 215 CONTINUE C ***** MOVE 4 CELLS AWAY THEN MOVE BACK UNTIL PARALLELEPIPED AROUND C REF ATOM AND BOX AROUND TRANSFORMED ASYM UNIT INTERSECT ***** N=0 DO 235 J=1,3 DO 225 I=1,2 N=N+1 TT=(U(J)-WW(I,J))*FLOAT(I*2-3)-DX(J) TEM=5.0 221 TEM=TEM-1.0 IF(TEM+TT)225,225,221 225 NW(N)=TEM*FLOAT(I*2-3)+5. C ***** IF NO POSSIBILITY OF A HIT, GO TO NEXT SYMMETRY OPER ***** IF(NW(N)-NW(N-1))400,235,235 235 CONTINUE LL=NW(1) LU=NW(2) ML=NW(3) MU=NW(4) NL=NW(5) NU=NW(6) C ***** L CELL TRANSLATIONS IN X ***** DO 395 L=LL,LU V(1)=U(1)+FLOAT(L-5) C ***** M CELL TRANSLATIONS IN Y ***** DO 395 M=ML,MU V(2)=U(2)+FLOAT(M-5) C ***** N CELL TRANSLATIONS IN Z ***** DO 395 NN=NL,NU V(3)=U(3)+FLOAT(NN-5) C ***** I = TARGET ATOM ***** DO 395 I=ITAR1,ITAR2 DO 250 J=1,3 TEM=0.0 DO 245 II=1,3 245 TEM=TEM+FS(II,J,K)*P(II,I) C ***** SEE IF WITHIN PARALLELEPIPED***** TEM=TEM-V(J) IF(DX(J)-ABS(TEM))395,250,250 250 X(J)=TEM GO TO (255,255,252,277,255,255),KFUN2 C ***** SEE IF WITHIN MODEL BOX ***** 252 CALL VM(X,AAREV,V1(2)) DO 253 J=2,4 IF(AIN(J+3)-ABS(V1(J)))395,253,253 253 CONTINUE GO TO 277 C ***** SEE IF WITHIN SPHERE ***** 255 DSQ=VMV(X,AA,X) IF(DMX-DSQ)395,256,256 256 IF(DSQ-.0001)258,260,260 258 IF(KFUN-402)395,260,260 260 TEM=SQRT(DSQ) IF(AIN(8))265,265,261 C *****SELECT ONLY FIRST ASYMMETRIC UNIT ENCOUNTERED ***** 261 IF(LATM)265,265,262 262 ZMIN=FLOAT(I)*100000. ZMAX=ZMIN+100000. DO 264 J=1,LATM ZSTO=ATOMS(1,J) IF(ZSTO-ZMIN)264,263,263 263 IF(ZMAX-ZSTO)264,264,395 264 CONTINUE C ***** SELECT VECTORS ACCORDING TO CODES IF ANY ***** 265 IF(NCD)277,277,268 268 DO 275 J=1,NCD 269 IF(ITOM-KD(1,J))275,270,270 270 IF(KD(2,J)-ITOM)275,271,271 271 IF(I-KD(3,J)) 275,272,272 272 IF(KD(4,J)-I) 275,273,273 273 IF(TEM-CD(1,J)) 275,274,274 274 IF(CD(2,J)-TEM) 275,277,277 275 CONTINUE GO TO 395 277 V1(1) = 100000.*FLOAT(I)+FLOAT((1110-L*100-M*10-NN)*100+K) IF(KFUN-402)278,325,325 C ***** DETERMINE CORRECT POSITION IN SORTED VECTOR TABLE ***** 278 IF(NUM)317,317,279 279 II=0 280 II=II+1 IF(II.GT.NUM) GO TO 316 TT=S(2,II)-TEM IF(ABS(TT)-0.0001)297,297,281 281 IF(TT)315,297,283 C ***** MOVE LONGER VECTORS TOWARD END OF TABLE ***** 283 IF(200-NUM)287,287,289 287 NUM=199 289 IJ=NUM DO 295 J=II,NUM S(1,IJ+1)=S(1,IJ) S(2,IJ+1)=S(2,IJ) 295 IJ=IJ-1 GO TO 319 C ***** CHECK FOR DUPLICATE VECTORS IF DISTANCES ARE EQUAL ***** 297 CALL ATOM(S(1,II),Z) DO 305 J=1,3 IF(ABS(X(J)+Y(J)-Z(J))-0.0001)305,305,315 305 CONTINUE GO TO 395 315 CONTINUE GO TO 280 316 CONTINUE IF(200-NUM)320,320,317 C ***** STORE THE RESULT IN VECTOR TABLE ***** 317 II=NUM+1 319 NUM=NUM+1 S(1,II)=V1(1) S(2,II)=TEM 320 IF(KFUN-106)395,325,325 C ***** STORE RESULT IN ATOMS TABLE ***** 325 DO 330 J=1,3 330 V1(J+1)=X(J)+Y(J) CALL STOR 395 CONTINUE 400 CONTINUE C ***** PRINT OUT DISTANCES ***** 421 FORMAT(1H010X,20HVECTORS FROM ATOM (I3,1H,I5,1H)6X,8HTO ATOMSI4, 18H THROUGHI4) I0 = AMOD(T1,100000.) WRITE (NOUT,421)ITOM,I0,ITAR1,ITAR2 IF(NUM)500,500,423 423 DO 435 I=1,NUM T2=S(1,I) I1=T2/100000. I2=T2-FLOAT(I1)*100000. CALL ATOM(T2,Z) IF(I-1)432,432,434 427 FORMAT((1H 13X,2(A6,1X),39X,1H(I3,1H,I5,1H)3F7.4,7X,3HD =F6.3)) 429 FORMAT((1H 13X,2(A6,1X),2(3H (I3,1H,I5,1H)3F7.4,3X),4X,3HD =F6.3) C) 432 WRITE (NOUT,429)CHEM(ITOM),CHEM(I1),ITOM,I0,(Y(J),J=1,3 1),I1,I2,(Z(J),J=1,3),S(2,I) GO TO 435 434 WRITE (NOUT,427)CHEM(ITOM),CHEM(I1),I1,I2,(Z(J),J=1,3), 1S(2,I) 435 CONTINUE C ***** CALCULATE ANGLES ABOUT REF ATOM IF CODE IS 102 ***** 437 IF(KFUN-102)500,451,500 441 FORMAT(1H010X,18HANGLES AROUND ATOMI5) 451 WRITE (NOUT,441)ITOM L=NUM-1 IF(L)500,500,457 457 DO 465 I=1,L T2=S(1,I) T3=S(2,I) I1=T2/100000. I2=T2-FLOAT(I1)*100000. CALL ATOM(T2,X) CALL DIFV(X,Y,U) CALL MV(AA,U,V2) M=I+1 DO 465 J=M,NUM T4=S(1,J) J1=T4/100000. J2=T4-FLOAT(J1)*100000. CALL ATOM(T4,Z) CALL DIFV(Z,Y,V) F=ARCCOS(VV(V,V2)/(T3*S(2,J))) CALL DIFV(X,Z,V3) F1=SQRT(VMV(V3,AA,V3)) 460 FORMAT((1H 13X,3(A6,1X),7X,3(2H (I3,1H,I5,1H)),12X,3HD =F6.3,7X,3H CA =F6.2)) 465 WRITE (NOUT,460)CHEM(I1),CHEM(ITOM),CHEM(J1),I1,I2,ITOM 1,I0,J1,J2,F1,F 495 CONTINUE 500 CONTINUE IF(LAST-LIST)505,505,178 505 IF(KFUN2-6)600,176,600 600 IF(KFUN-106)610,605,610 605 LATM=LATOM 610 RETURN END SUBROUTINE SPARE(INST) C ***** INSTRUCTION 1201 PRODUCES PUNCHED CARDS WITH POSIT.+THERMAL C ***** PARAMETERS FOR ATOMS PLACED IN THE ATOMS LIST BY THE 400 C ***** SERIES INSTRUCTIONS character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT character*6 CHM C ***** FIRST FIELD ON INSTRUCTION CARD = NO. OF POSITION PARAMETER C ***** CARDS TO BE READ BY THIS SUBROUTINE (STANDARD ORFLS FORMAT) C ***** THE SEQUENCE OF THESE CARDS NEED NOT BE IDENTICAL WITH C ***** THE ORIGINAL INPUT ATOM DECK SEQUENCE IF(INST-1201)100,105,100 100 NG = 9 RETURN 105 IF(AIN(1))100,100,115 115 LAST = AIN(1) DO 150 L=1,LAST READ (IN,116) CHM,V2(1),V2(2),(V1(J),J=1,4) 116 FORMAT(A6,3X,6F9.6) WRITE (NOUT,117) CHM,V2(1),V2(2),(V1(J),J=1,4) 117 FORMAT(1H0,24X,25HOLD POSITION PARAMETERS ,A6,4X,6F10.6) C ***** FIND ATOM NUMBER ***** DO 125 IA=1,NATOM DO 120 J=1,3 IF(ABS(V1(J)-P(J,IA))-0.001)120,120,125 120 CONTINUE IX = IA GO TO 130 125 CONTINUE GO TO 150 C ***** SEARCH ATOMS LIST FOR ENTRIES WITH ATOM NUMBER IX ***** 130 IF(LATM)150,150,131 131 DO 145 IB=1,LATM T1 = ATOMS(1,IB) IF(IX-INT(T1/100000.))145,135,145 135 CALL ATOM(T1,V1) WRITE (NOUT,136) T1,CHM,V2(1),V2(2),(V1(J),J=1,4) 136 FORMAT(1H0,9X,F10.0,5X,25HNEW POSITION PARAMETERS ,A6,4X,6F10.6) I1 = T1 C PUNCH 137, CHM,V2(1),V2(2),(V1(J),J=1,4),I1 137 FORMAT(A6,3X,6F9.6,9X,I8) CALL PAXES(T1,-1) DO 140 I=1,3 DO 140 J=1,3 140 Q(J,I) = Q(J,I) /.0506605918E0 WRITE (NOUT,141) Q(1,1),Q(2,2),Q(3,3),Q(1,2),Q(1,3),Q(2,3) 141 FORMAT(1H ,24X,25HNEW THERMAL PARAMETERS ,6F10.6) C PUNCH 142, Q(1,1),Q(2,2),Q(3,3),Q(1,2),Q(1,3),Q(2,3),I1 142 FORMAT(6F9.6,18X,I8) 145 CONTINUE 150 CONTINUE 300 RETURN END SUBROUTINE STOR C ***** STORE IN OR REMOVE FROM ATOMS ARRAY ***** character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT IF(LATM)481,481,450 450 IF(1000-LATM)455,455,460 455 IF(NJ2-10)490,490,460 460 L=LATM C ***** CHECK FOR POSITIONAL DUPLICATION ***** DO 480 K=1,L DO 465 J=2,4 IF(ABS(V1(J)-ATOMS(J,K))-0.001)465,465,480 465 CONTINUE IF(NJ2-10)490,490,470 C ***** ATOM REMOVAL BY TABLE PUSHDOWN ***** 470 LATM=LATM-1 DO 475 I=K,LATM DO 475 J=1,4 475 ATOMS(J,I)=ATOMS(J,I+1) GO TO 490 480 CONTINUE 481 IF(NJ2-10)482,490,490 C ***** STORE ATOM ***** 482 IF(999-LATM)490,483,485 483 NG=16 CALL ERPNT (V1(1),400) 485 LATM=LATM+1 DO 486 J=1,4 486 ATOMS(J,LATM)=V1(J) 490 RETURN END SUBROUTINE TMM(X,Y,Z) C ***** TRANSPOSE(TRANSPOSE(X)*Y)=Z ***** C ***** X,Y,Z ARE 3X3 MATRICES ***** DIMENSION X(3,3),Y(3,3),Z(3,3) DO 115 I=1,3 DO 115 K=1,3 115 Z(K,I)=X(1,I)*Y(1,K)+X(2,I)*Y(2,K)+X(3,I)*Y(3,K) RETURN END SUBROUTINE UNIT(X,Z,ITYPE) DIMENSION X(3),Y(3),Z(3) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT Y(1)=X(1) Y(2)=X(2) Y(3)=X(3) IF(ITYPE)125,125,105 105 T1=SQRT(Y(1)*Y(1)+Y(2)*Y(2)+Y(3)*Y(3)) GO TO 145 125 T1=SQRT(Y(1)*(Y(1)*AA(1,1)+Y(2)*(AA(1,2)+AA(2,1))+Y(3)*(AA(1,3)+A 1A(3,1)))+Y(2)*(Y(2)*AA(2,2)+Y(3)*(AA(2,3)+AA(3,2)))+Y(3)*Y(3)*AA(3 2,3)) 145 IF(T1)155,155,175 155 NG=5 GO TO 300 175 Z(1)=Y(1)/T1 Z(2)=Y(2)/T1 Z(3)=Y(3)/T1 300 RETURN END SUBROUTINE VM(X,Y,Z) C TRANSPOSED VECTOR TIMES MATRIX C Z(3)=X(3)*Y(3,3) DIMENSION X(3),Y(3,3),Z(3) DO 115 J=1,3 Z(J)=0.0 DO 115 I=1,3 115 Z(J)=Z(J)+X(I)*Y(I,J) RETURN END FUNCTION VMV(X1,Q,X2) C TRANSPOSED VECTOR * MATRIX * VECTOR C VMV=X1(3)*Q(3,3)*X2(3) TO EVALUATE QUADRATIC OR BILINEAR FORM DIMENSION X1(3),Q(3,3),X2(3) T1=0. DO 10 J=1,3 10 T1=T1+X1(J)*(X2(1)*Q(J,1)+X2(2)*Q(J,2)+X2(3)*Q(J,3)) VMV=T1 RETURN END FUNCTION VV(X,Y) C TRANSPOSED VECTOR * VECTOR C VV=X(3)*Y(3) DIMENSION X(3),Y(3) VV=X(1)*Y(1)+X(2)*Y(2)+X(3)*Y(3) RETURN END SUBROUTINE XYZ(QA,X,ITYPE) C ***** ITYPE .GT.0 CART. COORD. FROM ATOM CODE WORD ***** C ***** XABSF(ITYPE) .LE.2 FOR WORKING SYSTEM ***** C ***** XABSF(ITYPE) .GT.2 FOR REFERENCE SYSTEM ***** C ***** ITYPE .LE.0 USES TRICLINIC COORD. XT ***** DIMENSION X(3) character*6 CHEM CHARACTER*4 TITLE,TITLE2 DIMENSION A(9),AA(3,3),AAREV(3,3),AAWRK(3,3),AID(3,3),AIN(140) DIMENSION ATOMS(4,1000),BB(3,3),CD(8,20),CHEM(200),CONT(5),D(3,130 1 ),DA(3,3),DP(2,130),EV(3,200),FS(3,3,48),KD(5,20),ORGN(3) DIMENSION P(3,200),PA(3,3,200),PAC(3,5),PAT(3,3),Q(3,3),REFV(3,3) DIMENSION RES(4),RMS(5),SYMB(3,3),TITLE(18),TITLE2(18),TS(3,48) DIMENSION VT(3,4),V1(4),V2(3),V3(3),V4(3),V5(3),V6(3),WRKV(3,3) DIMENSION XLNG(3),XO(3),XT(3) COMMON NG,A,AA,AAREV,AAWRK,AID,AIN,ATOMS,BB,BRDR,CD,CHEM,CONT,D COMMON DA,DP,DISP,EDGE,EV,FORE,FS,IN,ITILT,KD,LATM,LTNO,NATOM,NCD COMMON NJ,NJ2,NOUT,NSR,NSYM,ORGN,P,PA,PAC,PAT,Q,REFV,RES,RMS,SCAL1 COMMON SCAL2,SCL,SYMB,TAPER,THETA,TITLE,TITLE2,TS,VIEW,VT,V1,V2 COMMON V3,V4,V5,V6,WRKV,XLNG,XO,XT IT=IABS(ITYPE)-2 NG1=NG NG=0 IF(ITYPE)10,10,5 5 CALL ATOM(QA,XT) IF(NG)30,10,30 10 T1=0. DO 15 J=1,3 T2=XT(J)-ORGN(J) V1(J)=T2 15 T1=T1+ABS(T2) IF(T1-.0001)20,20,40 20 NG=NG1 30 DO 35 J=1,3 35 X(J)=0. GO TO 300 40 IF(IT)45,45,60 C ***** RELATIVE TO WORKING SYSTEM ***** 45 DO 55 I=1,3 T1=0. DO 50 J=1,3 50 T1=T1+V1(J)*AAWRK(J,I) 55 X(I)=T1*SCAL1 GO TO 300 C ***** RELATIVE TO REFERENCE SYSTEM ***** 60 DO 70 I=1,3 T1=0. DO 65 J=1,3 65 T1=T1+V1(J)*AAREV(J,I) 70 X(I)=T1*SCAL1 300 RETURN END SUBROUTINE MYEXIT STOP END SUBROUTINE SCRIBE(Y,NPEN,LTNO) SAVE DIMENSION Y(2),YO(2) C ***** SUBROUTINE WHICH LINKS WITH THE PLOTTER-SPECIFIC SUBROUTINES C COMMON /GSCOM/ IGDS1,IGDS2,I8811,IKEY1,IKEY2,IKEY,IGSP0 IF(NPEN-3)210,205,205 C ***** KEEP TRACK OF COORDINATES FOR LAST PEN-UP LOCATION ***** 205 YO(1)=Y(1) YO(2)=Y(2) NPO=0 RETURN 210 IF (LTNO) 245,245,215 C 210 IF (LTNO) 230,245,215 C ***** CALL MECHANICAL PLOTTER PLOTTING SUBROUTINE ***** 215 IF(NPO)225,220,225 220 CALL PLOT(YO(1),YO(2),3) 225 CALL PLOT(Y(1),Y(2),2) C GO TO 245 C ***** CALL HGSP SUBROUTINE ***** C 230 IF(NPO)240,235,240 C 235 CONTINUE C 240 CONTINUE 245 NPO=1 RETURN END