PROGRAM PLATON C ******************************************************************** C * THIS PROGRAM MAY BE USED FREE OF CHARGE ONLY FOR USE WITHIN THE * C * ACADEMIC COMMUNITY AND NOT FOR PROFIT WITHOUT EXPLICIT PERMISSION* C * IT IS TO BE UNDERSTOOD THAT THE AUTHOR OR HIS UNIVERSITY CANNOT * C * BE HELD RESPONSIBLE FOR ANY PROBLEMS CAUSED BY ERRORS IN THE CODE* C ******************************************************************** C * * C * ******************************* * C * * P L A T O N - 2 0 0 6 * * C * ******************************* * C * * C * (C) 1980-2006 A.L.SPEK * C * * C * UTRECHT UNIVERSITY * C * BIJVOET CENTER FOR BIOMOLECULAR RESEARCH * C * SECTIE KRISTAL- EN STRUCTUURCHEMIE * C * PADUALAAN 8, 3584 CH UTRECHT, * C * THE NETHERLANDS * C * * C * PRELIMINARY VERSION (CDC) ............. 1980 * C * MICROVAX-II IMPLEMENTATION ............. 1986 * C * CONVEX/UNIX ,, ............. 1989 * C * SILICON-GRAPHICS ,, ............. 1990 * C * DEC/ULTRIX ,, ............. 1991 * C * LINUX ,, ............. 1993 * C * DEC/OSF/1 ,, ............. 1993 * C * SUN-SOLARIS ,, ............. 1998 * C * * C ******************************************************************** C * THE PROGRAM -PLATON- HAS BEEN DESIGNED FOR AUTOMATED GENERATION * C * AND ANALYSIS OF STEREO-CHEMICAL AND MOLECULAR GEOMETRY DATA, * C * STARTING FROM A LIST OF ATOMIC COORDINATES. IN THE CASE OF * C * FRACTIONAL COORDINATES, CELL DIMENSIONS AND SYMMETRY SHOULD BE * C * SPECIFIED AS WELL. IN GENERAL ONLY GLOBAL INSTRUCTIONS WILL BE * C * NECESSARY TO OBTAIN THE REQUIRED DATA OF THE MOLECULAR GEOMETRY * C * FROM A STANDARD (FREE FORMATTED) INPUTFILE. * C * IN THE -INTRA- MODE THE PROGRAM GENERATES, ON THE BASIS OF AN * C * INTERNAL COVALENT-RADII LIST, ALL BOND DISTANCES, BOND ANGLES, * C * TORSION ANGLES, LEAST-SQUARES PLANES, RINGS+ PUCKERING ANALYSIS. * C * IN THE -INTER- MODE A LIST IS GENERATED OF ALL SHORT VAN DER * C * WAALS CONTACTS. HYDROGEN BONDS ARE EXPLICITLY LISTED AND ANALYZED* C * IN THE -COORDN- MODE A LIST IS GENERATED OF THE BONDS AND * C * ANGLES WITHIN A SPECIFIED RADIUS FROM A GIVEN ATOM. * C * IN ADDITION, THE THERMAL MOTION IS ANALYSED WHEN ANISOTROPIC * C * THERMAL PARAMETERS HAVE BEEN PROVIDED. * C * ALL CALCULATED VALUES ARE ACCOMPAGNIED BY STANDARD DEVIATIONS * C * CALCULATED FROM THE STANDARD DEVIATIONS IN THE PARAMETERS, * C * WHEN SUPPLIED. * C * IN ADDITION THE PROGRAM GENERATES ON UNIT LU2 A LIST OF DATA * C * THAT MAY BE LISTED IN A NEAT FORM WITH THE PROGRAM OMEGA OR USED * C * OTHERWISE (AS AN ALTERNATIVE FOR THE BUILD-IN TABLE FEATURE). * C * OPTIONALLY GRAPHICS FILES SHOWING THE STRUCTURE AS PROJECTIONS * C * ON THE VARIOUS LEAST-SQUARES PLANES, NEWMAN PROJECTIONS ETC. * C * AN EASY TO USE THERMAL MOTION ELLIPSOID PLOT OPTION IS AVAILABLE.* C * * C * P O T E N T I A L M A C H I N E D E P E N D E N C I E S * C * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C * * C * - 32 BIT-WORDS MINIMUM ASSUMED (IN VIEW OF PACKING) * C * * C ******************************************************************** C * * C * L I M I T A T I O N S (LOWER BOUND) * C * --------------------- (MIN)* C * * C * THE MAXIMUM NUMBER OF ATOMS IN THE UNIQUE MOLECULE = NP1 250 * C * MAXIMUM NUMBER OF LEAST SQUARES PLANES = NP2 50 * C * MAXIMUM NUMBER OF CONNECTIONS IN ARRAY CON = NP4 8 * C * MAXIMUM BOND OVERFLOW = NP6 50 * C * MAXIMUM NUMBER OF ATOMS IN LEAST SQUARES PLANE = NP7 50 * C * MAXIMUM NUMBER OF RESIDUES = 63 * C * MAXIMUM NUMBER OF MOLECULES IN MOLECULE LIST = NP11-1 64 * C * MAXIMUM NUMBER WITHIN AN ATOM LABEL = 999 * C * DEFAULT NUMBER OF DIFFERENT ATOM KINDS = NP10 16 * C * MAXIMUM ARRAY SIZE FOR SCRATCH AND VOID CALCULATION= NPVD 200000 * C * * C * * WARNING * ONLY NP1 MAY BE MODIFIED SAFELY IN RANGE 250 - 5000 * C * NPVD SHOULD BE AS LARGE AS POSSIBLE * C ******************************************************************** C * * C * U N I X - I M P L E M E N T A T I O N * C * ************************************** * C * * C * Compile/Link: f77 -o platon platon.f xdrvr.c -lX11 * C * Run: platon sucrose * C * * C ******************************************************************** C * S U M M A R Y O F P L A T O N I N S T R U C T I O N S * C *--------------------------------------------------------------- * C * KEYWORD I SUB-KEYWORD(S) I COMMENT * C *-----------I-----------------I--------------------------------- * C *ENTRY I (nr)/(refcode) |DIR AND POSITION FDAT-FILE (ENTRY) * C *-----------I-----------------I--------------------------------- * C *NOMOVE I (OFF) INO MOVE-AROUND OF INPUT ATOMS * C *INORG I IINORGANIC MODE * C *ORGA I IORGANIC MODE * C *ROUND I ON/OFF/(range) IROUND OPTION ON/OFF (DEF = ON, 1) * C *PARENTHESESI ON/OFF ILABEL PARENTHESES ON/OFF (DEF = ON) * C *ORMA I ICAD4-ORIENTATION MATRIX(11,12,..,33)* C *INCLUDE I EL1 EL2 (Me) IINCLUDE SPECIFIED ELEMENTS ONLY * C *EXCLUDE I EL1 EL2 (Me) IEXCLUDE SPECIFIED ELEMENTS * C *SET VDWR I EL1 rad EL2 rad ISET NON-DEFAULT VDWAALS RADII * C *COLOR TYPE I EL1 col1 etc. ICHANGE DEFAULT COLORS * C *-----------I-----------------I------------------------------------* C *DOAC IEL1 EL2 .... IDON./ACCEPT. ATOMS(DEF:N,O,CL,S,F,BR* C *-----------I-----------------I------------------------------------* C *HBOND I(NORM) P1 P2 P3 IH-BOND PARAMETERS (DEF 0.5,-.12,100)* C *-----------I-----------------I------------------------------------* C *LINE IAT1 AT2 IEXPLICIT LINE SPECIFICATION * C *-----------I-----------------I------------------------------------* C *LSPL IAT1 AT2..DIST AT3IEXPLICIT L.S.-PLANE SPECIFICATION * C *-----------I-----------------I------------------------------------* C *RING IAT1 AT2 .... IEXPLICIT RING SPECIFICATION (MAX 30)* C *-----------I-----------------I------------------------------------* C *FIT IA11 A21 A1N A2N..IFIT MOL1 (A11,A12,....,A1N) TO * C * I I MOL2 (A21,A22,....,A2N) * C *FIT IA1A A1B ISIMILARLY NUMBERED RESIDUE FIT * C *-----------I-----------------I------------------------------------* C *SAVE I IUSED IN CONJ. WITH ENDS ON TAPE1 * C *-----------I-----------------I------------------------------------* C *ASYM I(AVF)(ZONEX) IASYM * C * I(LIST 0/1/2/3) I * C * I(THM thm)(VIEW) I * C * I(EXPECT) (EXPAND)I * C * I(VIEW/VALID) I * C *-----------I-----------------I------------------------------------* C *LEPAGE I(MANG) (MaxDot) IDO LEPAGE ANALYSIS (METRIC ANGLE) * C * | (TwoAxCrit) I * C *-----------I-----------------I------------------------------------* C *EXPT I IGIVE # OF EXPECTED REFL FOR RESOLN * C *-----------I-----------------I------------------------------------* C *CALC ADDSYMI (EL/EQUAL/SAVE) ICHECK FOR HIGHER SYMMETRY * C * I (ang d1 d2) ICHANGE DEFAULT CRITERIA * C * I (SHELX) (NOSF) IPREPARE NEW FILE FOR SUSPECT ENTRY * C * I (PLOT) IPLOT NEW AVERAGED STRUCTURE * C *-----------I-----------------I------------------------------------* C *CALC NONSYMI (symmol-tol) ILOOK FOR NON-CRYST. SYMMETRY * C *-----------I-----------------I------------------------------------* C *CALC NEWSYMI (ang-metric) ICHECK FOR (HIGHER) SPACE GROUP SYMM * C *-----------I-----------------I------------------------------------* C *CALC INTRA I - ICALCULATE INTRA MOLECULAR GEO- * C * I I METRY USING STANDARD ATOM RADII * C * I I D(A-B).LE.R(A)+R(B)+TOLA( =0.4) * C * IEL1 P1 EL2 P2 .. IUSE SPECIFIED ELEMENTAL RADII * C * ITOLA P1 IUSE SPECIFIED TOLERANCE VALUE * C * ITOLEA P1 IADDITIONAL EARTH-ALK. TOLERANCE * C * ITOLM P1 IADDITIONAL TOLERANCE FOR METAL-METAL* C * IEWLSPL IESD-WEIGHT LS-PLANES * C * IUWLSPL IUNIT-WEIGHT LS-PLANES * C * IAWLSPL IATOMIC-WEIGHT WEIGHTED LS-PLANES * C * INOTMA IDO NOT ANALYSE THERMAL MOTION * C * INOBOND IDO NOT PRINT BOND DISTANCES * C * INOANG IDO NOT PRINT BOND ANGLES * C * INOTOR IDO NOT PRINT TORSION ANGLES * C * INOLSP IDO NOT PRINT L.S-PLANES * C * INORING IDO NOT SEARCH FOR RINGS * C * INOSTD IDO NOT CALCULATE ST.DEV. IN PAR. * C * INOMOVE IDO NOT MOVE PRIMARY ATOMS * C * INOSYMM IDO NOT APPLY ANY SYMMETRY * C * INOBPA INO CALCULATION OF BOND/PLANE ANGLES * C * ITOLP P1 IMAX OUT OF PLANE DEV. FOR LSP(.1) * C * IMAXDEV IMAX LIST DIST FROM PLANE (Def 1.5) * C * IMAXRING P1 IMAXIMUM RING-SIZE (default 24) * C *-----------I-----------------I------------------------------------* C *CALC GEOM I(OMEGA/ IBONDS,ANGLE AND TORSION ANGLES (DEF)* C * I MOGLI/EUCLID/ I(AND GENERATE SPECIFIED FILE) * C * I SHELXL/CSD/ I * C * I PDB) I * C * I (NOMOVE) I DO NOT MOVE INPUT ATOMS * C * I (EXPAND) I OUTPUT SYMMETRY EXPANDED MOLECULES * C * I (BOND) (ANGLE) I * C * I (TORSION) I * C *-----------I-----------------I------------------------------------* C *CALC TMA I (RMAX) ITHERMAL MOTION ANALYSIS * C * I (HINCL) I INCLUDE ANISOTROPIC H-ATOMS * C * I I (def Rmax=0.25) * C * I (Atmin) I (def Min numb at=6) * C * I (Cartesian) ILIST CARTESIAN UIJ AS WELL * C *-----------I-----------------I------------------------------------* C *CALC INTER I - ICALCULATE INTERMOLECULAR GEOMETRY * C * I(NOMOVE) I WITH VAN DER WAALS RADII + TOLR=0.2* C * ITOLR P1 IUSE SPECIFIED TOLERANCE VALUE * C * IEL1 P1 EL2 P2 .. I MODIFY LISTED CONTACT RADII * C *-----------I-----------------I------------------------------------* C *CALC HBONDSI P1 P2 P3 IHBOND - ANALYSIS * C * I (NONA) I No Network Analysis * C * I (DISORDER) I INCLUDE MINOR DISORDER * C *-----------I-----------------I------------------------------------* C *CALC COORDNI (P1) ICOORDN RADII NON C,H-ATOMS(DEF=3.6) * C * IEL1 P1 EL2 P2 .. ICALCULATE COORDN SPHERE GEOMETRY * C * I I FOR THE SPECIFIED ELEMENTS ONLY. * C * I (NOANG) I SUPPRESS ANGLE CALCULATION * C * I (FIVE (TBA)) I ANALYSE FIVE COORDINATION * C * I (EUCLID) I(OUTPUT ON SPECIFIED FILE TYPE) * C *-----------I-----------------I------------------------------------* C *CALC COORDNI atom-name p1 I COORDINATION SPHERE FOR SPEC. ATOM * C * I (NOANG) I * C *-----------I-----------------I------------------------------------* C *CALC METAL I (p1) IMETAL..METAL DISTANCES (DEF. 10 A ) * C *-----------I-----------------I------------------------------------* C *CALC RDF I (p1) I CALC RADIAL DISTRIBUTION FUNCTION * C *-----------I-----------------I------------------------------------* C *CALC DIST I EL (p1) I EL-EL DISTANCE SCAN * C *-----------I-----------------I------------------------------------* C *CALC SOLV I (PROBE rad) I DETERMINE SOLVENT ACCESSIBLE AREAS * C * I (PSTEP n/GRID x)I GRID = rad / n or as given * C * I (LIST/LISTxyz) I LIST MAP ON LISTING FILE * C * I (SAR) I WRITE FILE WITH SOLVENT GRID POINTS* C *CALC VOID I (PROBE rad) I SEARCH FOR VOIDS IN THE STRUCTURE * C * I (PSTEP n) I GRID = rad / n * C * I (LIST/LISTxyz) I LIST MAP ON DISPLAY * C *-----------I-----------------I------------------------------------* C *CALC SQUEEZE (NCYC) (FCAL) I (HANDLE DISORDERED SOLVENT REGION) * C *-----------I-----------------I------------------------------------* C *CALC FCF I (GENERATE) I CALCULATE STRUCTURE FACTORS * C *CALC DELABSI(NOTHCO)(NOCHECK)I EMPIRICAL ABSORPTION CORRECTION * C * I I NOTHCORRECTION;DIRECTION COS CHECK * C *-----------I-----------------I------------------------------------* C *ABSG I mu,(ng1,ng2,ng3)I GAUSSIAN INTEGRATION ABS CORRECTION* C * I (NOCHECK)(LIST) I * C *ABST I mu I MEULENAAR & TOMPA ABS. CORR. * C * I (NOCHECK)(LIST) I * C *ABSP I I PSI-SCAN ABS CORRECTION * C * I (NOCHECK)(LIST) I * C *ABSS I mu*r I SPHERICAL ABSORPTION CORRECTION * C * I (NOCHECK)(LIST) I * C *-----------I-----------------I------------------------------------* C *MULABS I mu radius I MULTISCAN ABSORPTION CORRECTION * C * I (NOCHECK)(LIST) I * C *-----------I-----------------I------------------------------------* C *CALC I (ALL) IDEFAULT CALCULATION OF ALL GEOMETRY * C *-----------I-----------------I------------------------------------* C *LIST/INFO I CELL I LIST CELL DIMENSIONS ON DISPLAY * C *LIST/INFO I SYMM I LIST CURRENT SYMMETRY * C *LIST/INFO I ATOM (type)(res)I LIST CURRENT ATOM-TABLE (SELECT) * C *LIST/INFO I BOND (type)(res)I LIST CURRENT BOND-TABLE (SELECT) * C *LIST/INFO I UIJ I LIST UIJ * C *LIST/INFO I RADII I LIST COVALENT & V.D.WAALS RADII * C *LIST/INFO I IPR (IVL1(IVL2))I LIST INTEGER PARAMETER VALUE * C *LIST/INFO I PAR (IVL1(IVL2))I LIST REAL PARAMETER VALUE * C *LIST/INFO I FLAG I LIST INTERNAL FLAG VALUES * C *-----------I-----------------I------------------------------------* C *DIST I AT1 AT2 IINTERACTIVE DISTANCE CALCULATION * C *ANGL I AT1 AT2 AT3(AT4)I ,, ANGLE ,, * C *TORS I AT1 AT2 AT3 AT4 I ,, TORSION ,, * C *LSPL I AT1 AT2 ..... I ,, LEAST-SQUARES PL ,, * C *LSPL I AT1 AT2 .. WITH IINTERACTIVE ANGLE BETWEEN PLANES * C * I AT11 AT12 .. I * C * I (DIST AT3 ..) I (TO PLANE DISTANCE) * C *FIT IA11 A21 A1N A2N..IFIT MOL1 (A11,A12,....,A1N) TO * C * I I MOL2 (A21,A22,....,A2N) * C *GEOM I AT1 I ,, BONDS,ANGLES FOR AT1 * C *-----------I-----------------I------------------------------------* C *PLOT I LSPL IPLOT SPECIFIED PLANE(S) * C * I PLAN I AUTOM. PLANE(S) * C * I RING I RING(S) * C * I RESD I RESIDUE(S) * C * I ALONG IPLOT WITH PLANE NORMAL UPWARDS(Y) * C * I PERP IPLOT DOWN PLANE NORMAL * C * I (DISPLAY/META) IPLOT MEDIUM (DEFAULT DISPLAY) * C *-----------I-----------------I------------------------------------* C *PLOT I NEWMAN (AT1 AT2)INEWMAN PLOT(S) (FOR SPECIFIED BOND) * C * I (DISPLAY/META) IPLOT MEDIUM (DEFAULT DISPLAY) * C * I (COLOR) I * C *-----------I-----------------I------------------------------------* C *PLOT I ADP IPLOT ANISOTR. DISPLACEMENT ELLIPSOID* C * I (DISPLAY/META) I PLOT MEDIUM (DEFAULT DISPLAY) * C * I (COLOR) ICOLOR O,N AND HALOGENS * C * I (OCTANT/HETERO/ IELLIPSOID TYPE * C * I ENVELOPE) I * C * I (LABELS/NOLABEL)ILABEL PLOT * C * I (HATOM/NOHATOM) IH-ATOM (IN/EX)CLUDE * C * I (PARENT/NOPAREN)ILabels with or without parentheses * C * I (MARGIN marg) IOVERLAP MARGIN * C * I (RESIDUE resnr) IResidue number to be plotted (0=all)* C *-----------I-----------------I------------------------------------* C *PLOT I POLY IPOLYEDER PLOT (IMPLEM IN PROGRESS) * C *-----------I-----------------I------------------------------------* C *RADII BONDSI (LIST/TO MET/ IRESET (LIST)DEFAULT BOND PARAMETERS * C * I TO H/NORMAL/ALL)IFOR ADP PLOT * C * I(bond-type (rad))I -5 <= bondtype <= 5 and radius(Ang)* C *-----------I-----------------I------------------------------------* C *ELLIPSOID |(C/H/Other) IPLOT TYPES OF ELLIPSOID SHAPES * C * I type (lines) Itype 0/1 * C *-----------I-----------------I------------------------------------* C *JOIN I At1 At2 ((L)DASH) ADD (DASHED) BOND FOR PLOTTING * C *DETACH I At1 At2 IDELETE BOND FROM PLOT LIST * C *DEFINE I At1 TO At2 ..ATnIADD BOND TO CG * C * I (DASH) I (Optionally dashed) * C *-----------I-----------------I------------------------------------* C *BOX I (ON/OFF) IOUTLINE BOX WITH TEXT ON/OFF * C * I (RATIO ratio) I HOR/VERT RATIO ADP PLOT * C *-----------I-----------------I------------------------------------* C *VIEW I IDEFAULT 0,0,0 * C *VIEW I (UNIT) (XR P1) IROTATE ABOUT X,Y,Z BY P1,P2,P3 ETC. * C *VIEW I MIN ICALCULATE MINIMUM OVERLAP ORTEP * C *VIEW I INVERT IINVERT VIEW-MATRIX * C *-----------I-----------------I------------------------------------* C *HELP IMANUAL (PRINT) IGIVES (ON LINE/PRINTED) MANUAL * C * ISPGR ILISTS KNOWN SPACE GROUPS * C *-----------I-----------------I------------------------------------* C *END I INORMAL END OF PROGRAM * C *STOP/QUIT I IFORCED END OF PROGRAM * C *EXIT I IFORCED END OF PROGRAM * C *-----------I-----------------I------------------------------------* C *MENU I(ON/OFF) IMOUSE/MENU ON/OFF * C *-----------I-----------------I------------------------------------* C *SET IPAR/IPR nr val ISET PARAMETERS * C *SET IPROB (10<-->90) ISET PROBABILITY LEVEL (DEF=50) * C *SET IPRINTER LEVEL levISET PRINT LEVEL * C *SET ILABEL SIZE (size)ISET SIZE OF LABELS * C *SET IWINDOW fraction IMANIPULATE X-WINDOW-size * C *-----------I-----------------I------------------------------------* C *TABLE I(SU/AC/JA/IC) IGENERATE PUBLICATION/SUPPL.MAT.TABL.* C * I(NOHATOM) I * C * I(NORESIDUE) I DO-NOT SPLIT IN RESIDUES * C *TABLE I(CIF/CSD) (LOCAL)I GENERATE CIF-FILE FOR ACC-PUBL. * C *-----------I-----------------I------------------------------------* C *CONTOUR I ICONTOUR PLOTS (IMPL. IN PROGRESS) * C * I(FO/DIFF/SQUEEZE)ITYPE OF MAP (DEFAULT FO) * C ******************************************************************** C * * C * S T A N D A R D I N P U T O N F I L E * C * -------------------------------------------------------------- * C * * C * TITL < TEXT > * C * CELL * C * CESD * C * SPGR * C * ATOM * C * UIJ * C * SUIJ * C * OR FOR ISOTROPIC TEMPERATURE FACTOR * C * U 0) IF (IGBL(1) .EQ. -1) THEN CALL PLA000 (0) C * MANAGE DATA FILE LU1 ELSE IF (IGBL(1) .EQ. 0) THEN CALL PLA000 (1) C * RESTART FOR NEW DATASET ELSE IF (IGBL(1) .EQ. 1) THEN CALL PLA001 C * READ DATA AND INSTRUCTIONS ELSE IF (IGBL(1) .EQ. 2) THEN CALL PLA002 C * ERROR HANDLING (AND SUMMARY) ELSE IF (IGBL(1) .EQ. 3) THEN CALL PLA003 ENDIF GOTO 10 ENDIF C * CLOSE & TERMINATE PLATON RUN CALL PLA004 (0) END SUBROUTINE PLA000 (MODE) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 DID*9, TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /CGGT/ IGGT CHARACTER FNLU12*80, FNLU13*80, FNLU14*80, FNLU17*80, 1 FNLU21*80, IGGT*80 LOGICAL EXST12, EXST13, EXST21 COMMON /PATHS/ PLAPATH, BROWSER, CGETENV CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255 COMMON /TODAY/ DATIJD CHARACTER DATIJD*25 COMMON /VALDOC/ NDOC(999) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 INTEGER FINDEXE LOGICAL OPEND, EXST C * MODE = -1 - GLOBAL INIT & ESCAPE C * MODE = 0 - INIT & FILE-OPEN C * MODE = 1 - MANAGE DATA FILE ON LU1 C * GLOBAL INIT & ESCAPES FOR (S, HELENA, SHX86, STIDY) IF (MODE .LT. 0) THEN CALL GEN097 (IGBL, 1, NP38, 0) C * SET VERSION DATE IGBL(9) = 270106 C * CHECK For PLATON IGBL(80) = FINDEXE ('PLAEXE', PLAPATH, 'platon') C * CHECK FOR POVRAY IGBL(79) = FINDEXE ('POVEXE', CGETENV, 'povray') C * CHECK FOR RASMOL IGBL(78) = FINDEXE ('RASEXE', CGETENV, 'rasmol') C * CHECK FOR RASTER IGBL(77) = FINDEXE ('R3DEXE', CGETENV, 'render') C * CHECK FOR CONQUEST IGBL(76) = FINDEXE ('QUESTEXE', CGETENV, 'cqbatch') C * CHECK FOR FIREFOX/MOZILLA/NETSCAPE HELP IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'firefox') IF (IGBL(47) .EQ. 0) THEN IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'mozilla') IF (IGBL(47) .EQ. 0) THEN IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'netscape') ENDIF ENDIF C * CHECK FOR check.def (CIF-Validation) CALL GETENV ('CHECKDEF', CGETENV) IF (CGETENV(1:1) .EQ. ' ') CGETENV = 'check.def' INQUIRE (FILE = CGETENV, EXIST = EXST) IF (EXST) THEN OPEN (UNIT = LU19, FILE = CGETENV, FORM = 'FORMATTED', 1 STATUS = 'OLD') READ (LU19, 99998, END = 10) IDM IF (IDM(1:10) .EQ. '#*********') IGBL(19) = 1 10 CALL GEN108 (LU19, 0) ENDIF OPEN (UNIT = LU20, STATUS = 'SCRATCH', FORM = 'FORMATTED', 1 ERR = 150) C * MACHINE SPECIFIC ROUTINE TO GET DATA AND TIME CALL FDATE (DATIJD) PROGNM = 'PLATON-'//DATIJD(5:24) C * MACHINE DEPENDENT ROUTINE TO GET CPUTIME TIMEZ = CPUTIM() C * INITIALIZE GLOBAL PARAMETERS CALL GEN097 (NDOC, 1, 999, 0) ISAVEMOD = 0 XSH0 = 0.0 YSH0 = 0.0 GL(1) = 19.5 VERT = GL(1) GL(2) = 4.0 / 3.0 HORS = VERT * GL(2) IWIN = 0 GL(6) = 8 * ATAN2 (1.0, 1.0) GL(5) = 360.0 / GL(6) GL(7) = GL(6)**2 / 2.0 GL(8) = 4.0 * GL(7) GL(25) = 1.0 GL(26) = 0.4 GL(27) = 0.5 GL(28) = 0.0 GL(29) = 0.0 GL(30) = 0.0 IGBL(25) = 1 IGBL(33) = 1 IGBL(35) = 1 IGBL(56) = 1 IGBL(70) = 1 IGBL(62) = 4 IGBL(64) = 4 IGBL(63) = 4 IGBL(82) = 1 IGBL(83) = 1 IGBL(89) = 5 IGBL(86) = NPVD - 6 IGBL(102) = 56 IGBL(103) = 1 CALL GEN038 (DID, 1, 9) CALL GEN038 (LINE, 1, 80) CALL GEN038 (IDM, 1, 80) CALL GEN038 (ICL, 1, 80) LRT = 0 C * RUN OVER SWITCHES AND ARGUMENTS CALL PLA005 (-1, LINE, ICL, LRT) CALL PLA261 (LINE) IGBL(1) = 4 C * ESCAPE TO SYSTEM-S '-s' IF (IGBL(3) .EQ. 14) THEN CALL PLA017 CALL S C * ESCAPE TO HELENA '-k' ELSE IF (IGBL(3) .EQ. 15) THEN CALL PLA017 CALL PLA240 C * ESCAPE TO EXPLICIT SHX86-MODE '-X' ELSE IF (IGBL(3) .EQ. 32) THEN TREF = 100 CALL PLA155 (TREF) C * ESCAPE TO 'NATIVE' STIDY MODE (-Y) ELSE IF (IGBL(3) .EQ. 39) THEN CALL GEN038 (JID, 1, 80) CALL PLA301 ELSE IGBL(1) = -1 ENDIF ELSE IF (MODE .EQ. 0) THEN C * INIT & FILE OPEN C * EXTRACT FILENAME ARGUMENT FROM COMMAND LINE CALL PLA261 (LINE) CALL PLA017 IGBL(1) = 0 CALL GEN038 (IGGT, 1, 80) OPEN (UNIT = LU3, STATUS = 'SCRATCH', FORM = 'FORMATTED') OPEN (UNIT = LU23, FILE = NAME(1)(1:KNM(1))//'.def', 1 STATUS = 'UNKNOWN') READ (LU23, 99998, END = 60) ICL(1:80) IGBL(21) = 1 60 CALL GEN108 (LU23, 0) OPEN (UNIT = LU24, STATUS = 'SCRATCH') IF (EXTENS(1:3) .NE. 'dge') THEN OPEN (UNIT = LU25, FILE = NAME(2)(1:KNM(2))//'.dge', 1 STATUS = 'UNKNOWN') ELSE IGBL(4) = -1 ENDIF OPEN (UNIT = LU26, FILE = NAME(1)(1:KNM(1))//'.new', 1 STATUS = 'UNKNOWN') OPEN (UNIT = LU27, FILE = NAME(1)(1:KNM(1))//'.pjn', 1 STATUS = 'UNKNOWN') IF (IGBL(3) .EQ. 8 .OR. 1 IGBL(3) .EQ. 12 .OR. 2 IGBL(3) .EQ. 13 .OR. 3 IGBL(3) .EQ. 26) THEN CALL PLUTON (-1) IGBL(1) = 4 ELSE OPEN (UNIT = LU11, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', 1 ERR = 150) C * REDIRECT CONSOLE-OUTPUT for -u & -V (-W) validation modes IF (IGBL(3) .EQ. 1 .OR. IGBL(3) .EQ. 33 .OR. 1 IGBL(3) .EQ. 34) LU6 = LU20 OPEN (UNIT = LU4, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', 1 ERR = 150) OPEN (UNIT = LU8, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', 1 ERR = 150) OPEN (UNIT = LU9, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', 1 ERR = 150) C * CHECK FOR RECORD LENGTH (I.E. WORD OR BYTE-COUNT) NSIZE = 1 DO 80 I = 1, 2 NRZ = 14 * NSIZE OPEN (UNIT = LU29, STATUS = 'SCRATCH', 1 FORM = 'UNFORMATTED', ACCESS = 'DIRECT', RECL = NRZ) WRITE (LU29, REC = 1, ERR = 70) (FN(II), II = 1, 14) GOTO 90 70 NSIZE = 4 CLOSE (UNIT = LU29, STATUS = 'DELETE') 80 CONTINUE STOP 'CANNOT FIGURE OUT DIRECT ACCESS RECORD LENGTH' 90 NRZ = 11 * NSIZE OPEN (UNIT = LU30, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', 1 ACCESS = 'DIRECT', RECL = NRZ) FNLU12 = NAME(1)(1:KNM(1)) //'.pub' FNLU13 = NAME(1)(1:KNM(1)) //'.sup' FNLU14 = NAME(1)(1:KNM(1)) //'.sum' FNLU21 = NAME(1)(1:KNM(1)) //'.bin' FNLU17 = NAME(4)(1:KNM(4)) //'.hkp' OPEN (UNIT = LU14, FILE = FNLU14, STATUS = 'UNKNOWN') IF (IGBL(7) .EQ. 0) THEN OPEN (UNIT = LU7, FILE = NAME(1)(1:KNM(1)) //'.lis', 1 STATUS = 'UNKNOWN') IGBL(7) = 1 ENDIF INQUIRE (FILE = FNLU12, EXIST = EXST12) OPEN (UNIT = LU12, FILE = FNLU12, STATUS = 'UNKNOWN') CALL GEN108 (LU12, 0) IF (EXST12) THEN READ (LU12, 99998, END = 100) ICL(1:80) IGBL(12) = 1 ENDIF 100 INQUIRE (FILE = FNLU13, EXIST = EXST13) OPEN (UNIT = LU13, FILE = FNLU13, STATUS = 'UNKNOWN') IF (EXST13) THEN READ (LU13, 99998, END = 110) ICL(1:80) IGBL(13) = 1 ENDIF 110 IF (IGBL(12) .NE. 0 .OR. IGBL(13) .NE. 0) WRITE (LU6, 99999) OPEN (UNIT = LU15, FILE = NAME(1)(1:KNM(1)) //'.sar', 1 STATUS = 'UNKNOWN', FORM = 'UNFORMATTED') OPEN (UNIT = LU17, FILE = FNLU17, STATUS = 'UNKNOWN') CALL GEN108 (LU17, 0) INQUIRE (FILE = FNLU21, EXIST = EXST21) OPEN (UNIT = LU21, FILE = FNLU21, STATUS = 'UNKNOWN', 1 FORM = 'UNFORMATTED') IF (EXST21) THEN READ (LU21, END = 120) IGBL(16) = 1 ENDIF 120 IPR(437) = 0 C * FIND REFLECTIONS (fcf or hkl STYLE) CALL PLA286 ENDIF ELSE IF (MODE .GT. 0) THEN C * TARGET DEPENDENCY KNMXT = KNM(3) + KXT + 1 FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT) INQUIRE (FILE = FNLU1, OPENED = OPEND) IF (OPEND) THEN INQUIRE (FILE = FNLU1, NUMBER = IUNIT) LU1 = IUNIT ELSE INQUIRE (UNIT = LU1, OPENED = OPEND) IF (OPEND) CLOSE (LU1) OPEN (UNIT = LU1, FILE = FNLU1, FORM = 'FORMATTED', 1 STATUS = 'OLD', ERR = 130) ENDIF WRITE (LU6, 99997) FNLU1(1:KNMXT) IGBL(39) = 1 GOTO 140 130 WRITE (LU6, 99996) FNLU1(1:KNMXT) IF (IGBL(3) .EQ. 30) GOTO 150 IGBL(8) = 1 IGBL(39) = 0 LU1 = LU3 140 CALL GEN108 (LU3, 0) CALL GEN108 (LU4, 0) CALL GEN108 (LU8, 0) CALL GEN108 (LU12, 0) CALL GEN108 (LU13, 0) CALL GEN108 (LU14, 0) CALL GEN108 (LU15, 0) CALL GEN108 (LU17, 0) IF (IGBL(90) .EQ. 2) THEN ICL = 'ENTRY '//JID(1:9) IPR(220) = 2 IPR(221) = 0 IGBL(8) = -4 CALL PLA011 ELSE IF (IGBL(90) .EQ. 1) THEN IGBL(8) = 3 IPR(220) = 1 IPR(221) = 0 FN(1) = 1 CALL PLA011 ENDIF IGBL(1) = 1 ENDIF RETURN 150 STOP ' STOP OPEN ERROR' 99999 FORMAT (/, '!! ''.sup'' and/or ''.pub'' files EXIST and may be', 1 ' DESTROYED in the', /, '!! following calculations. ', 2 'QUIT and RENAME files NOW to avoid this to happen.', /) 99998 FORMAT (A) 99997 FORMAT (':: Data from: ', A) 99996 FORMAT ('!! File ', A, ' NOT Available, Interactive Input ', 1 'Assumed', /) END SUBROUTINE PLA001 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP31=30,NP35=110,NP36=1000,NP38=125,NP39=30, 3 NP41=200,NP47=9,NCS=50) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /PAGEIN/ INDEXP(25), INDP COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31), 1 MNH(NP35) COMMON /ALIASES/ ALAB(NP36), BLAB(NP36) CHARACTER ALAB*7, BLAB*7 COMMON /BONDTYPE/ BNDTP(11) CHARACTER BNDTP*5 COMMON /LITREF/ LREF CHARACTER LREF(25)*80 CALL GEN097 (MNH, 1, NP35, 0) MNH(6) = 2 MNH(7) = 2 IGBL(23) = 1 IGBL(71) = 0 ILAT0 = ' ' ILAT1 = 'P' LAUE = ' ' KRAD = '??' INDP = 0 PAGET = 'GENERAL' RP(1) = 1.0 CALL GEN097 (MLTI, 1, 64, 1) IGBL(8) = IABS(IGBL(8)) IF (IGBL(53) .EQ. 0) THEN DO 10 I = 1, 11 CALL GEN038 (BNDTP(I), 1, 5) 10 CONTINUE ENDIF CALL GEN038 (JID, 1, 80) CALL GEN038 (IGGT, 1, 80) DO 15 I = 1, 25 CALL GEN038 (LREF(I), 1, 80) 15 CONTINUE DO 20 I = 1, 5 RLWS(I) = ' ?' 20 CONTINUE DO 30 I = 1, 4 CALL GEN038 (SPGRNM(I), 1, 26) 30 CONTINUE CALL GEN038 (ZSPG , 1, 7) DO 40 I = 1, NP36 CALL GEN038 (ALAB(I), 1, 7) CALL GEN038 (BLAB(I), 1, 7) 40 CONTINUE CALL GEN048 (0, I, 0, I) CALL GEN097 (IPPR, 1, 129 * 3, 0) IPPR(1, 1) = 1000 IPPR(1, 2) = 0 IPPR(1, 3) = 1 DO 80 I = 1, NP10 IENLB(I) = 0 DO 60 J = 1, 4 RADR(I, J) = -1 60 CONTINUE IACL(I) = 1 DO 70 J = 1, 2 LMT(I, J) = ' ' IENS(I) = I 70 CONTINUE 80 CONTINUE CALL GEN074 (XJX, 0.0, 1, 12) CALL GEN021 (TM1, 1) CALL GEN021 (TM2, 1) CALL GEN021 (RMAT, 1) CALL GEN074 (PAR, 0.0, 1, NP13) CALL GEN097 (IPR, 1, NP12, 0) CALL GEN074 (PAR, 1.0, 101, 103) CALL GEN074 (PAR, 90.0, 104, 106) CALL GEN074 (SHFT, 0.0, 1, 3) PAR(98) = 1.0 DO 100 I = 1, 20 CCIF(I) = ' ?' NCIF(I) = 2 100 CONTINUE NEWLAT(1) = 1 CALL SGSM (IDM, 0, XJX, 0, 1, IERR) IPR(48) = 1 IPR(146) = 10 IAN = 0 ICLR = 4 IPR(34) = 1 IPR(35) = 2 IPR(36) = 3 IPR(28) = 5 IPR(40) = 1 IPR(41) = 0 IPR(45) = 5 IGBL(5) = LU1 IPR(65) = 1 IPR(66) = 7 IPR(82) = 5 IPR(68) = 2 IPR(95) = 0 IPR(96) = NP6 IPR(110) = 1 IPR(119) = 1 IPR(125) = 1 IPR(129) = NP29 IPR(142) = 25 IPR(143) = 2 IPR(144) = 3 IPR(154) = 0 IPR(159) = 6 IGBL(75) = 1 IPR(458) = 1 IPR(163) = 4 IPR(21) = 7 IPR(175) = 1 IPR(176) = 1 IPR(177) = 0 IPR(178) = 0 IPR(179) = 1 IPR(180) = 4 IPR(181) = 1 IPR(183) = 6 IPR(212) = 1 IPR(214) = 6 IPR(216) = 6 IPR(217) = 6 IPR(218) = 18 IPR(219) = 24 IPR(579) = IPR(219) IPR(211) = 0 IPR(324) = 1 C * SET BEL SIGNAL (CTRL-G = ASCII 7) IPR(223) = 7 IPR(331) = 1 IPR(346) = 1 IPR(366) = 25 IPR(460) = 3 IPR(551) = 3 IPR(507) = 3 IPR(467) = 3 IPR(484) = -1 IPR(222) = 100 IPR(243) = 60 IPR(260) = 1 IPR(274) = 2 IPR(300) = 1 IPR(302) = 25 IPR(350) = 0 IPR(353) = 1 IPR(354) = -1 IPR(356) = -1 IPR(355) = 0 IPR(357) = 1 IPR(358) = 1 IPR(363) = 1 IPR(368) = 0 IPR(392) = 3 IPR(394) = 3 IPR(398) = 1 IPR(419) = 5 IPR(480) = 11 IPR(482) = 4 IPR(487) = 10 IPR(492) = 6 IPR(505) = 1 IPR(514) = 9 IPR(523) = 6 IPR(524) = 3 IPR(550) = 50 IPR(567) = 25 IPR(569) = 1 IPR(577) = 5 IPR(578) = 5 IPR(582) = 250 IF (IGBL(47) .GT. 0) THEN IPR(590) = 1 ELSE IPR(590) = 0 ENDIF PAR(2) = 0.4 PAR(3) = 0.2 PAR(5) = 0.35 PAR(6) = 0.40 PAR(7) = 3.6 PAR(8) = 0.5 PAR(9) = -0.12 PAR(10) = 100.0 PAR(11) = 1.0 PAR(12) = 0.0001 PAR(15) = 160.0 PAR(76) = 1.5 PAR(18) = 0.01 PAR(24) = 1.0 PAR(25) = 0.4 PAR(26) = 0.70 PAR(27) = - PAR(2) PAR(28) = 0.25 PAR(31) = 150.0 PAR(33) = 100.0 PAR(30) = 0.05 PAR(32) = 1.0 PAR(34) = 0.25 PAR(36) = 6.0 PAR(37) = GL(1) PAR(38) = GL(1) PAR(39) = 1.0 PAR(40) = 0.25 PAR(41) = 0.75 PAR(42) = 100.0 PAR(43) = 1.0 PAR(44) = 0.075 PAR(48) = 0.375 PAR(49) = 0.1 PAR(50) = (4.0 - IGBL(46)) / 3.0 PAR(51) = 1.25 PAR(52) = 0.5 PAR(53) = 0.2 PAR(54) = 1.E-5 PAR(62) = 60.0 PAR(63) = 0.002 PAR(22) = 0.3 PAR(29) = 1.0 PAR(69) = 4.0 PAR(70) = 0.3 PAR(71) = 0.05 PAR(72) = 0.25 PAR(73) = 0.1 PAR(74) = 1.0 PAR(75) = 0.8 PAR(80) = 0.2 C * ADDSYM ORGANIC PARAMETERS PAR(401) = 0.25 PAR(402) = 0.45 PAR(403) = 0.45 C * ADDSYM INORGANIC DEFAULTS PAR(404) = 0.25 PAR(405) = 0.25 PAR(406) = 0.25 PAR(410) = 0.00000001 C * BEAM-STOP THETA-MIN PAR(419) = 2.5 C * NEWSYM/LAUE R_MAX PAR(429) = 5.0 C * SPGR/LAUE RMAX PAR(430) = 10.0 C * DELABS DIRECTION COSINE TEST PARAMETERS PAR(77) = 0.03 PAR(78) = 0.5 PAR(84) = 1.20 PAR(85) = 4 PAR(86) = 0.03 PAR(87) = 2 PAR(88) = 0.02 PAR(89) = 5 PAR(90) = 0.05 PAR(91) = 2 PAR(92) = 0.02 PAR(93) = 0.001 PAR(95) = 5.0 PAR(96) = 10.0 PAR(94) = 10.0 PAR(97) = 25.0 PAR(141) = 5.0 PAR(165) = 90.0 PAR(249) = 20.0 PAR(250) = 0.2 PAR(199) = -1.0 PAR(251) = -0.25 PAR(253) = -0.25 PAR(213) = 0.5 PAR(214) = 109.0 PAR(215) = 20.0 PAR(216) = 1.62 PAR(217) = 0.2 PAR(218) = 90.0 PAR(219) = 20.0 PAR(220) = 1.97 PAR(221) = 0.4 PAR(231) = 1.0 PAR(235) = 1.0 PAR(239) = 1.0 PAR(240) = 1.0 PAR(247) = 0.05 PAR(248) = 0.6 PAR(383) = 0.2 PAR(263) = 3.0 PAR(264) = 30.0 PAR(265) = 0.1 PAR(266) = 0.2 PAR(286) = 0.15 PAR(287) = 1.0 / 1.54184 PAR(288) = 2.0 PAR(268) = 0.5 PAR(269) = 0.5 PAR(270) = 0.2 PAR(271) = 0.3 PAR(273) = 10.0 PAR(272) = PAR(273) * 4.0 / 3.0 PAR(279) = 1.5 PAR(280) = 0.1 PAR(281) = 0.2 PAR(282) = 1.0 PAR(283) = 0.05 PAR(284) = 1.E5 PAR(285) = 0.0 PAR(290) = 0.2 PAR(292) = 500.0 PAR(294) = 1.19 PAR(295) = 1.50 PAR(296) = 1.083 PAR(297) = 1.009 PAR(298) = 0.983 PAR(325) = 1.0 PAR(326) = 0.5E-15 PAR(328) = 25.0 PAR(331) = 0.015 PAR(349) = 0.25 PAR(350) = 0.55 PAR(371) = 0.1 PAR(372) = 1.0 PAR(381) = 1.0 PAR(382) = 0.5 PAR(384) = 1.45 PAR(411) = 0.02 PAR(412) = 100.0 PAR(413) = 8.0 PAR(414) = 0.10 PAR(415) = 0.3 PAR(416) = 0.01 PAR(417) = 5.0 PAR(418) = 0.0 PAR(420) = 0.10 PAR(422) = 3.5 PAR(423) = 2.0 PAR(424) = 1.5 PAR(427) = 1.0 PAR(431) = 5.0 PAR(439) = 0.4 PAR(440) = 1000.0 PAR(441) = 0.4 PAR(447) = 4.0 PAR(448) = 30.0 PAR(449) = 0.4 PAR(450) = 5.0 PAR(451) = 5.0 PAR(452) = 0.25 PAR(454) = 0.04 DO 110 I = 262, 272 IPR(I) = -999999 110 CONTINUE IPR(267) = - IPR(267) IPR(269) = - IPR(269) IPR(271) = - IPR(271) IPR(310) = -999999 PAR(17) = -999999.0 PAR(158) = 999999.0 PAR(167) = -999999.0 PAR(168) = -999999.0 PAR(170) = -999999.0 PAR(173) = -999999.0 PAR(174) = -999999.0 PAR(175) = -999999.0 PAR(176) = 999999.0 PAR(177) = -999999.0 PAR(178) = -999999.0 PAR(179) = -999999.0 PAR(197) = -999999.0 PAR(198) = -999999.0 PAR(299) = -999999.0 PAR(300) = -999999.0 PAR(302) = -999999.0 PAR(303) = -999999.0 PAR(304) = -999999.0 PAR(305) = -999999.0 PAR(306) = 999999.0 PAR(307) = 999999.0 PAR(309) = -999999.0 PAR(310) = -999999.0 PAR(229) = 999999.0 PAR(312) = -999999.0 PAR(313) = -999999.0 PAR(314) = -999999.0 PAR(433) = 999999.0 PAR(434) = 999999.0 IGBL(1) = 2 RETURN END SUBROUTINE PLA002 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP24=176,NP25=99,NP29=63,NP31=30,NP35=110, 3 NP37=175,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9,NXT1=100, 4 NXT2=200,NXT3=100,NXT4=200,NCS=50) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /GGT/ MEDIUM COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4), 1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /DSPGR/ TYPE, NLAUE CHARACTER TYPE(NCS)*16, NLAUE(13)*5 COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5 COMMON // JNSC(2, NP23), VOID(NPVD) CHARACTER N213*3, NI13*3, NI14*4 COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 CHARACTER ICH*1, EXTENS1*9 COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1) CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /LABMOD/ LMOD COMMON /STID/ ISETS(73, 230) COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31), 1 MNH(NP35) DIMENSION SAV(16) J0 = 0 J1 = 0 10 IPR(205) = 0 IF (IGBL(90) .NE. 0) THEN FN(1) = IGBL(54) IGBL(90) = 0 IPR(220) = 1 IPR(221) = 1 CALL PLA011 IF (ICL(1:4) .EQ. 'END ') THEN GOTO 1090 ELSE GOTO 10 ENDIF ENDIF IF (IPR(121) .GT. 0) GOTO 820 IPR(473) = 2 C * GET NEXT INPUT-LINE AND CARD TYPE (IN IS) CALL PLA006 (0, IS) IF (IPR(2) .NE. 0) GOTO 1250 C * IS = -1: E_O_F 20 IF (IS .LT. 0) THEN GOTO 1080 C * IS = 0: FORMAT/READ - ERROR ELSE IF (IS .EQ. 0) THEN IPR(2) = 61 GOTO 1120 C * IS = 1: POTENTIAL ATOM LINE ELSE IF (IS .EQ. 1) THEN IF (IGBL(5) .EQ. 5) GOTO 10 IPR(473) = 1 IF (IPR(30) .EQ. 0) GOTO 620 C * UNKNOWN CARD ERROR IPR(2) = 7 GOTO 1120 C * IS = 2: TITL CARD ELSE IF (IS .EQ. 2) THEN I0 = 1 I1 = 0 CALL GEN039 (0, ICL, 5, 80, I0, I1) IF (I1 .GE. I0) THEN JID = ICL(I0:I1) IF (I1 - I0 + 1 .GT. 32) I1 = I0 + 31 I2 = INDEX (ICL(I0:I1), ' ') IF (I2 .NE. 0) I1 = I0 + I2 - 2 DATANM = ICL(I0:I1) ELSE DATANM = 'X' ENDIF CALL GEN020 (-1, DATANM, 1, 32) IF (IGBL(8) .EQ. 3) WRITE (LU20, 99957) DATANM WRITE (LU6, 99995) JID(1:39) IF (IGBL(100) .EQ. 0 .AND. IABS(IGBL(8)) .EQ. 3) THEN IPR(220) = 1 IPR(221) = 0 CALL PLA011 ENDIF IF (IGBL(100) .GT. 0) THEN IGBL(54) = IGBL(54) + 1 ELSE IGBL(54) = 1 ENDIF C * IS = 3: MESSAGE (ECHO) ELSE IF (IS .EQ. 3) THEN WRITE (LU6, 99988) ICL(5:80) C * IS = 4: REMARK (SKIP) ELSE IF (IS .EQ. 4) THEN C * IS = 5: ANGSTROM COORDINATE SCALE ELSE IF (IS .EQ. 5) THEN IF (IPR(221) .EQ. 1) THEN CALL PLA080 PAR(11) = FN(1) ENDIF C * IS = 6: ROUND ON/OFF OPTION ELSE IF (IS .EQ. 6) THEN IF (IPR(221) .EQ. 1) THEN IPR(68) = MAX (MIN (NINT(FN(1)), 10), 0) ELSE IPR(68) = 1 ENDIF IF (IPR(220) .GT. 1) THEN IF (IFL(2)(1:3) .EQ. 'OFF') THEN IPR(68) = 0 ENDIF ENDIF IF (IPR(68) .GT. 0) THEN CALL GEN040 (IPR(68), NQ1, IP) WRITE (LU6, 99990) IPR(68) * 10 - 1 ENDIF GOTO 1070 C * IS = 7: FIT MOL1 ON MOL2 (OR INVERTED MOL2) ELSE IF (IS .EQ. 7) THEN IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN IGBL(45) = IGBL(45) + 1 WRITE (LU3, 99984) ICL(1:80) WRITE (LU6, 99973) ICL(1:70) ENDIF IF (IPR(220) .EQ. 1 .AND. IPR(221) .EQ. 0) THEN IPR(1) = 7 IPR(81) = -1 GOTO 1190 ELSE IF (IPR(30) .EQ. 0) THEN IF (IPR(221) .EQ. 2) THEN FN1 = FN(1) FN2 = FN(2) IPR(221) = 0 CALL PLA069 CALL PLA073 (-1) FN(1) = FN1 FN(2) = FN2 IPR(221) = 2 IPR(220) = - IPR(220) GOTO 570 ELSE IF (IPR(220) .EQ. 3) THEN IPR220 = IPR(220) IPR(220) = 1 CALL PLA069 CALL PLA073 (-1) IPR(220) = - IPR220 GOTO 570 ENDIF NTYP = 0 GOTO 530 ELSE IPR(220) = - IPR(220) GOTO 570 ENDIF ENDIF C * IS = 8: EXPLICIT PLANE SPECIFICATION ELSE IF (IS .EQ. 8) THEN NTYP = 4 GOTO 530 C * IS = 9: EXPLICIT RING SPECIFICATION ELSE IF (IS .EQ. 9) THEN NTYP = 2 GOTO 530 C * IS = 10: NOMOVE (OFF) ELSE IF (IS .EQ. 10) THEN IF (IPR(30) .EQ. 0) THEN IF (IPR(220) .GT. 1 .AND. IFL(2)(1:3) .EQ. 'OFF') THEN IGBL(30) = 0 ELSE IGBL(30) = 1 ENDIF ENDIF C * IS = 11: PSIDIR ELSE IF (IS .EQ. 11) THEN IPR(78) = 5 CALL PLA190 IF (IPR(2) .EQ. 0) IPR(2) = -9 GOTO 1250 C * IS = 12: DONOR/ACCEPTOR TYPES ELSE IF (IS .EQ. 12) THEN IPR(480) = 0 DO 30 I = 1, IPR(220) CALL PLA037 (I, N, 2) IF (N .GT. 0) THEN IF (IPR(480) .LE. NP10) THEN IPR(480) = IPR(480) + 1 IDOAC(IPR(480)) = IEN(N) ELSE WRITE (LU6, 99979) NP10 ENDIF ENDIF 30 CONTINUE GOTO 1070 C * IS = 13: SPECIAL LINE MANAGEMENT ELSE IF (IS .EQ. 13) THEN IF (IPR(30) .EQ. 0) THEN IF (IPR(220) .EQ. 3 .AND. IPR(407) .LT. 10) THEN DO 40 I = 2, 3 CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) GOTO 10 SLN(IPR(407) + 1, I - 1) = XNQNR 40 CONTINUE IPR(407) = IPR(407) + 1 WRITE (LU6, 99987) ENDIF ELSE ENDIF C * IS = 14: ENDS ELSE IF (IS .EQ. 14) THEN IPR(3) = 1 IGBL(8) = - IABS(IGBL(8)) IGBL(5) = LU3 CALL GEN108 (LU3, 0) C * IS = 15: PLOT ELSE IF (IS .EQ. 15) THEN GOTO 780 C * IS = 16: YES ELSE IF (IS .EQ. 16) THEN GOTO 1130 C * IS = 18: CALC ELSE IF (IS .EQ. 18) THEN GOTO 800 C * IS = 19: END ELSE IF (IS .EQ. 19) THEN GOTO 1090 C * IS = 20: INCLUDE NAMED ELEMENTS IN CALCULATIONS ELSE IF (IS .EQ. 20) THEN IPR(70) = 1 GOTO 580 C * IS = 21: EXCLUDE NAMED ELEMENTS FROM CALCULATIONS ELSE IF (IS .EQ. 21) THEN IPR(70) = 0 GOTO 580 C * IS = 22: STOP ELSE IF (IS .EQ. 22) THEN GOTO 1100 C * IS = 23: HELP (SPGR) ELSE IF (IS .EQ. 23) THEN IF (IPR(220) .GT. 1) THEN N213 = IFL(2)(1:3) C * LIST KNOWN SPACE GROUP NAMES IF (N213 .EQ. 'SPG') THEN CALL SGSM (ICL, 0, XJX, LU6, 14, IERR) GOTO 10 ENDIF ENDIF CALL PLA109 (1) GOTO 1240 C * IS = 24: SAVE INSTRUCTION OPTION ON ELSE IF (IS .EQ. 24) THEN IGBL(45) = 1 ISAVEMOD = 1 CALL GEN108 (LU3, 0) C * IS = 25: UIJ ELSE IF (IS .EQ. 25) THEN GOTO 650 C * IS = 26: SUIJ ELSE IF (IS .EQ. 26) THEN GOTO 650 C * IS = 27: U ELSE IF (IS .EQ. 27) THEN GOTO 700 C * IS = 28: ATOM ELSE IF (IS .EQ. 28) THEN GOTO 620 C * IS = 29: LIST/INFO ELSE IF (IS .EQ. 29) THEN C * LIST OPTION(S) ON DISPLAY (ATOMS/BONDS/SYMM/PAR/IPR/IGBL/RADII/CELL) IF (IGBL(8) .EQ. 2 .AND. IGBL(5) .NE. LU5) GOTO 10 IPR(84) = 3 IPR(1) = 4 IWIN = IGBL(25) * IGBL(32) IF (IPR(220) .GT. 1) THEN N213 = IFL(2)(1:3) C * LIST IPR/PAR/IGBL/GL IF (IPR(220) .GE. 2) THEN IF (N213 .EQ. 'IPR' .OR. N213 .EQ. 'PAR' .OR. 1 N213 .EQ. 'IGB' .OR. N213 .EQ. 'GL ') THEN CALL PLA206 (-1, N213) C * LIST FLAGS ELSE IF (N213 .EQ. 'FLA') THEN NAT = IPR(39) + IPR(64) WRITE (PRBUF, 99965) IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.6 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) VRT = VRT - 0.2 ELSE WRITE (LU6, '(/, A, /)') PRBUF(1:80) ENDIF DO 50 I = 1, NAT CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CALL GEN048 (-3, IFG(I), 1, IF1) CALL GEN048 (-1, IFG(I), 4, IF2) CALL GEN048 (-1, IFG(I), 5, IF3) CALL GEN048 (-1, IFG(I), 6, IF4) CALL GEN048 (-1, IFG(I), 7, IF5) CALL GEN048 (-1, IFG(I), 8, IF6) CALL GEN048 (-6, IFG(I), 9, IF7) CALL GEN048 (-4, IFG(I), 15, IF8) CALL GEN048 (-1, IFG(I), 19, IF9) CALL GEN048 (-1, IFG(I), 20, IF10) CALL GEN048 (-1, IFG(I), 21, IF11) CALL GEN048 (-1, IFG(I), 22, IF12) CALL GEN048 (-1, IFG(I), 23, IF13) CALL GEN048 (-4, IFG(I), 24, IF14) CALL GEN048 (-1, IFG(I), 30, IF15) CALL GEN048 (-7, JFG(I), 1, IF16) CALL GEN048 (-1 , JFG(I), 10, IF17) CALL GEN048 (-1 , JFG(I), 11, IF18) CALL GEN048 (-1 , JFG(I), 12, IF19) CALL GEN048 (-10, JFG(I), 14, IF20) CALL GEN048 (-3, JFG(I), 24, IF21) WRITE (PRBUF, 99966) I, NQ1, IF1, IF2, IF3, IF4, IF5, 1 IF6, IF7, IF8, IF9, IF10, IF11, IF12, IF13, IF14, 2 IF15, IF16, IF17, IF18, IF19, IF20, IF21 IF (IWIN .EQ. 1) THEN IF (VRT - 0.4 .LT. 0) THEN CALL PLA013 (1, 1) ICH = IGGT(1:1) CALL GGIP (HORS, VERT, 0.0, 1) IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 10 VRT = VERT ENDIF VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, '(A)') PRBUF(1:80) ENDIF 50 CONTINUE IF (IWIN .EQ. 1) CALL PLA297 (1) C * LIST/INFO SYMM ELSE IF (N213 .EQ. 'SYM') THEN CALL PLA299 C * LIST/INFO CELL ELSE IF (N213 .EQ. 'CEL') THEN WRITE (BCD, 99991) (PAR(J), J = 101, 106), CHAR(0) IF (IWIN .EQ. 1) THEN IF (ABS(IGBL(23)) .GE. 10 .AND. ABS(IGBL(23)) .LE. 12) 1 IGBL(23) = - IABS(IGBL(23)) CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 66.0, 111) ELSE WRITE (LU6, 99946) BCD(1:65) ENDIF C * LIST/INFO RADII ELSE IF (N213 .EQ. 'RAD') THEN WRITE (PRBUF, 99955) IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 2.0 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF WRITE (PRBUF, 99954) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF WRITE (PRBUF, 99953) PAR(2) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99946) PRBUF(1:75) ENDIF WRITE (PRBUF, 99952) PAR(5) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF WRITE (PRBUF, 99951) IGBL(97) * PAR(26) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF WRITE (PRBUF, 99950) PAR(3) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF WRITE (PRBUF, 99949) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) ELSE WRITE (LU6, 99946) PRBUF(1:75) ENDIF DO 60 I = 1, IAN WRITE (PRBUF, 99996) LMT(I, 1), RADR(I, 3), RADR(I, 4), 1 RADR(I, 2) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF 60 CONTINUE IF (IWIN .EQ. 1) CALL PLA297 (1) C * LIST/INFO U1, U2, U3, U(eq) and U3/U1 VALUES ELSE IF (N213 .EQ. 'UIJ') THEN IF (IPR(30) .NE. 0) THEN WRITE (PRBUF, 99980) IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.6 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) VRT = VRT - 0.2 ELSE WRITE (LU6, 99984) PRBUF(1:75) ENDIF NAT = IPR(39) DO 90 I = 1, NAT DO 70 J = 1, 12 FN(J) = VOID(IPR(297) + (I - 1) * 21 + J) 70 CONTINUE CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) CALL GEN048 (-1, IFG(I), 4, IVAL) IF (IVAL .EQ. 1) THEN JMAX = 5 FN(4) = 0.0 DO 80 J = 1, 3 FN(J) = FN(J + 9)**2 FN(4) = FN(4) + FN(J) / 3.0 80 CONTINUE FN(5) = FN(3) / FN(1) ELSE CALL GEN048 (-1, IFG(I), 7, IVAL) IF (IVAL .EQ. 1) GOTO 90 JMAX = 1 FN(1) = FN(10)**2 ENDIF WRITE (PRBUF, 99981) NQ1, (FN(J), J = 1, JMAX) IF (IWIN .EQ. 1) THEN IF (VRT - 0.4 .LT. 0.0) THEN CALL PLA013 (1, 1) ICH = IGGT(1:1) CALL GGIP (HORS, VERT, 0.0, 1) IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 10 VRT = VERT ENDIF VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99984) PRBUF(1:80) ENDIF 90 CONTINUE IF (IWIN .EQ. 1) CALL PLA297 (1) ENDIF C * LIST ARU ELSE IF (N213 .EQ. 'ARU') THEN CALL PLA043 (0, -2, LU6, 1) IF (IWIN .EQ. 1) CALL PLA297 (1) C * LIST/INFO ATOMS AND BONDS ELSE IF (IPR(39) .GT. 0) THEN IF (N213 .EQ. 'ATO') IPR(84) = 1 IF (N213 .EQ. 'BON') IPR(84) = 2 GOTO 760 ELSE WRITE (LU6, 99992) ENDIF GOTO 10 ENDIF ENDIF GOTO 760 C * IS = 30: CELL CONSTANTS ELSE IF (IS .EQ. 30) THEN IF (IPR(221) .EQ. 1) THEN FN(2) = FN(1) FN(3) = FN(1) IPR(221) = 3 ENDIF IF (IPR(221) .EQ. 3) THEN CALL GEN074 (FN, 90.0, 4, 6) IPR(221) = 6 ENDIF IF (IPR(221) .LT. 6 .OR. 1 (IPR(221) .GT. 7 .AND. IPR(221) .NE. 12)) GOTO 1060 IF (IPR(221) .EQ. 7) THEN PAR(16) = FN(1) PAR(17) = FN(1) K = 1 ELSE K = 0 ENDIF DO 100 I = 1, 12 IF (I .LE. 3 .AND. ABS(FN(K + I)) .LT. 2.0) THEN IF (IGBL(5) .EQ. LU1) THEN IPR(470) = 1 ENDIF GOTO 1060 ENDIF PAR(100 + I) = FN(K + I) 100 CONTINUE IF (K .EQ. 0) GOTO 10 CALL PLA293 (FN(1), 0) C * IS = 31: CELL STANDARD DEVIATION ELSE IF (IS .EQ. 31) THEN DO 110 I = 1, 6 PAR(106 + I) = FN(I) 110 CONTINUE C * IS = 32: SYMM (LATT/SPGR/HALL etc.) ELSE IF (IS .EQ. 32) THEN IF (IPR(220) .EQ. 1 .AND. 1 (IPR(221) .EQ. 9 .OR. IPR(221) .EQ. 12)) THEN C * SYMM MATRIX R11,R12,..,R33, (T1,T2,T3) INPUT IF (IPR(93) .EQ. 0) THEN ITRS = 15 CALL SGSM (ICL, 0, FN, LU6, ITRS, IERR) CALL SGSM (ICL, 0, XJS, LU6, 18, IERR) IPR(48) = NINT(XJS(9)) IF (IGBL(8) .EQ. 3) THEN IF (CCIF(7)(1:1) .EQ. ' ' .AND. CCIF(16)(1:1) .EQ. '?') 1 THEN WRITE (LU20, 99947) '_121', 1.0, 1.0, ICL(1:7) ICL = 'SPGR P1' WRITE (LU6, 99958) IS = 32 GOTO 20 ENDIF ENDIF ELSE C * NO TRANS ALLOWED WITH SYMM MATRIX INPUT IPR(2) = 27 GOTO 1120 ENDIF ELSE IF (IGBL(8) .EQ. 2) THEN IF (IPR(141) .EQ. 0 .AND. IFL(1)(1:4) .EQ. 'SYMM') THEN IDM = 'LATT 1' CALL SGSM (IDM, 0, XJX, 0, 0, IERR) IPR(141) = 1 ENDIF ENDIF IF (IPR(93) .EQ. 1 .OR. IPR(139) .EQ. 1) THEN ITRS = 16 ELSE ITRS = 0 ENDIF CALL SGSM (ICL, 0, XJX, LU6, ITRS, IERR) IF (IERR .NE. 0) THEN IF (IERR .EQ. 7) THEN WRITE (LU20, 99947) '_126', 1.0, 1.0, 1 ICL(6:12), ICL(13:19) GOTO 10 ELSE IF (IERR .EQ. 5) THEN CALL GEN047 (ICL, 6, 16) WRITE (LU20, 99947) '_129', 1.0, 1.0, ICL(6:12) GOTO 10 ELSE IF (IERR .EQ. 12) THEN GOTO 10 ELSE IPR(470) = 1 GOTO 1060 ENDIF ENDIF CALL SGSM (ICL, 0, XJS, LU6, 18, IERR) IPR(48) = NINT(XJS(9)) IF (IPR(48) .EQ. 0) THEN IF (IGBL(8) .EQ. 3) 1 WRITE (LU20, 99947) '_121', 1.0, 1.0, ICL(1:7) ENDIF ENDIF IPR(141) = 1 IF (IPR(48) .EQ. 0 .AND. IGBL(8) .NE. 4) THEN IF (IGBL(5) .EQ. LU1) THEN IPR(470) = 1 ENDIF GOTO 1060 ENDIF IF (IPR(39) .EQ. 0) THEN CALL SGSM (ICL, 0, XJS, LU6, 18, IERR) SPGRNM(1) = ICL(1:26) SPGRNM(3) = ICL(44:60) SPGRNM(4) = ICL(15:26) IF (ICL(73:73) .NE. ' ') ZSPG = ICL(73:79) KRSYST = ICL(27:38) LAUEGR = ICL(39:43) CHSG = ICL(72:72) CALL GEN020 (-1, SPGRNM(1), 16, 24) IPR(202) = NINT(XJS(1)) IPR(241) = NINT(XJS(7)) IPR(242) = NINT(XJS(8)) IPR(255) = NINT(XJS(4)) IPR(256) = NINT(XJS(6)) IPR(257) = NINT(XJS(5)) IPR(258) = NINT(XJS(3)) IPR(259) = NINT(XJS(2)) IF (IGBL(8) .EQ. 3) THEN IF (CCIF(7)(1:1) .EQ. ' ') THEN CCIF(7) = SPGRNM(4)(1:11) ELSE CCIF(8) = SPGRNM(4)(1:11) ENDIF ENDIF ENDIF C * IS = 33: SPGR ELSE IF (IS .EQ. 33) THEN IF (IPR(220) .EQ. 1 .AND. IPR(221) .LE. 2) THEN IF (IGBL(15) .GE. 0) THEN IF (IPR(221) .GT. 0) IPR(365) = NINT(FN(1)) IF (IPR(221) .GT. 1) PAR(141) = FN(2) CALL PLA080 IGBL(31) = 5 CALL PLA021 CALL PLA042 (0) CALL PLA160 (1, TM1) GOTO 1250 ELSE IPR(2) = 55 GOTO 1120 ENDIF ENDIF IS = 32 GOTO 20 C * IS = 34: LATT ELSE IF (IS .EQ. 34) THEN IS = 32 GOTO 20 C * IS = 35: DIST ELSE IF (IS .EQ. 35) THEN GOTO 570 C * IS = 36: ANGLE ELSE IF (IS .EQ. 36) THEN GOTO 570 C * IS = 37: TORSION ELSE IF (IS .EQ. 37) THEN GOTO 570 C * IS = 38: CHANGE H-BOND PARAMETERS FROM DEFAULTS ELSE IF (IS .EQ. 38) THEN IF (IPR(220) .GT. 1 .AND. IFL(2)(1:4) .EQ. 'NORM') IPR(87) = 1 DO 120 K = 1, IPR(221) PAR(7 + K) = FN(K) 120 CONTINUE GOTO 1070 C * IS = 39: BIJ ELSE IF (IS .EQ. 39) THEN GOTO 630 C * IS = 40: SBIJ ELSE IF (IS .EQ. 40) THEN GOTO 630 C * IS = 41: B ELSE IF (IS .EQ. 41) THEN GOTO 690 C * IS = 42: TRNS/TRMX ELSE IF (IS .EQ. 42) THEN CALL GEN074 (SHFT, 0.0, 1, 3) IF (IPR(221) .EQ. 1) THEN IF (ABS(FN(1)) .GT. 1000.0) THEN ITRNS = INT (FN(1)) ELSE ITRNS = NINT(FN(1) * 1000.0) ENDIF IF (IABS(ITRNS) / 1000 .GT. IPR(48)) THEN IPR(2) = 15 GOTO 1120 ENDIF IF (ITRNS .LE. 0) THEN IPR(95) = ITRNS ELSE IF (ITRNS .GT. 0) THEN IPR(165) = ITRNS ENDIF GOTO 10 ELSE IF (IPR(221) .EQ. 3) THEN CALL GEN074 (FN, 0.0, 1, 9) FN(1) = 1.0 FN(5) = 1.0 FN(9) = 1.0 IPR(139) = 1 DO 130 I = 1, 3 SHFT(I) = - FN(I) 130 CONTINUE ELSE IF (IPR(221) .EQ. 9) THEN ELSE IF (IPR(221) .EQ. 10 .AND. IPR(220) .EQ. 2) THEN ILAT0 = IFL(2)(1:1) IF (IFL(2)(2:2) .NE. ' ') ILAT1 = IFL(2)(2:2) CALL GEN020 (-1, ILAT0, 1, 1) IFN10 = NINT(FN(10)) IF (IFN10 .GT. 0 .AND. IFN10 .LT. 14) THEN LAUE = NLAUE(NINT(FN(10))) ELSE LAUE = ' ' ENDIF ELSE IF (IPR(221) .EQ. 12) THEN IPR(139) = 1 DO 140 I = 1, 3 SHFT(I) = - FN(9 + I) 140 CONTINUE ELSE IPR(2) = 63 GOTO 1120 ENDIF IF (IPR(39) .GT. 0) THEN C * INSTRUCTION NOT ALLOWED IPR(2) = 11 GOTO 1120 ENDIF K = 0 DO 160 I = 1, 3 XJX(9 + I) = - SHFT(I) DO 150 J = 1, 3 K = K + 1 TM1(I, J) = FN(K) XJX(K) = FN(K) PAR(230 + K) = FN(K) 150 CONTINUE 160 CONTINUE CALL GEN003 (TM1, DUMV, DET, 0) IF (ABS(ABS(DET) - 1.0) .GT. 0.001) THEN WRITE (LU6, 99985) DET PAR(32) = DET ENDIF CALL GEN005 (DUMV, TM2) IPR(93) = 1 WRITE (LU6, 99972) 1 ((TM2(I, J), J = 1, 3), -SHFT(I), I = 1, 3) C * IS = 43: FVAR CARD (SHELX) ELSE IF (IS .EQ. 43) THEN IGBL(8) = 2 IF (IPR(109) + IPR(221) .GT. NP25) THEN IPR(2) = 30 GOTO 1120 ENDIF DO 170 I = 1, IPR(221) IF (IPR(109) + I .EQ. 1) THEN RP(1) = FN(1) ELSE RP(IPR(109) + I) = MOD(FN(I) + 5.0, 10.0) - 5.0 ENDIF 170 CONTINUE IF (IPR(109) .EQ. 0) THEN PAR(74) = RP(1) RP(1) = 1.0 ENDIF IPR(109) = IPR(109) + IPR(221) C * IS = 44: PARENTHESES ON/OFF OPTION ELSE IF (IS .EQ. 44) THEN IPR(119) = 1 IF (IPR(220) .GT. 1) THEN IF (IFL(2)(2:2) .EQ. 'F') IPR(119) = 0 ENDIF GOTO 1070 C * IS = 45: QUIT ELSE IF (IS .EQ. 45) THEN GOTO 1100 C * IS = 46: SET OPTION(S) ELSE IF (IS .EQ. 46) THEN C * SET - OPTION(S) N213 = IFL(2)(1:3) C * (RE)SET VAN DER WAALS RADII IF (N213 .EQ. 'VDW') THEN IF (IPR(220) .GT. 2 .AND. IPR(221) .EQ. IPR(220) - 2) THEN DO 180 I = 3, IPR(220) CALL PLA037 (I, NID, 2) IF (NID .GT. 0) RADR(NID, 4) = FN(I - 2) 180 CONTINUE ENDIF IF (IGBL(5) .EQ. LU5) CALL PLA280 ('LIST RADII') C * SET RANGE (FOR POLY) ELSE IF (N213 .EQ. 'RAN') THEN IF (IPR(221) .EQ. 6) THEN IPR(354) = 0 DO 190 I = 1, 6 PAR(200 + I) = FN(I) 190 CONTINUE C * SET OMIT RANGE (POLY) ELSE IF (N213 .EQ. 'OMI') THEN ELSE IF (IPR(221) .EQ. 6) THEN IPR(356) = 0 DO 195 I = 1, 6 PAR(206 + I) = FN(I) 195 CONTINUE ENDIF C * SET TETR (POLY) ELSE IF (N213 .EQ. 'TET') THEN DO 200 I = 1, 4 IF (FN(I) .NE. 0.0) PAR(213 + I) = FN(I) 200 CONTINUE C * SET OCTA (POLY) ELSE IF (N213 .EQ. 'OCT') THEN DO 210 I = 1, 4 IF (FN(I) .NE. 0.0) PAR(217 + I) = FN(I) 210 CONTINUE C * SET LABEL SIZE ELSE IF (N213 .EQ. 'LAB') THEN IF (IPR(220) .EQ. 3 .AND. IFL(3)(1:1) .EQ. 'S') THEN WRITE (LU6, 99994) PAR(349) IF (IPR(221) .EQ. 1) THEN PAR(349) = FN(1) WRITE (LU6, 99993) PAR(349) ENDIF ENDIF C * SET PRINTER LEVEL (0,1,2,3,4) ELSE IF (N213 .EQ. 'PRI') THEN IF (IPR(220) .EQ. 3) THEN IF (IFL(3)(1 : 1) .EQ. 'L') THEN IF (IPR(221) .GT. 0) THEN IGBL(64) = NINT(FN(1)) IGBL(63) = IGBL(64) ENDIF ENDIF ENDIF C * SET REVERSE ELSE IF (N213 .EQ. 'REV') THEN IGBL(68) = MOD (IGBL(68) + 1, 2) CALL GGIP (-999.0, FLOAT(IGBL(68)), IGBL(62) * 0.25, 9) C * SET IPR/PAR/IGBL/GL ELSE IF (IPR(221) .EQ. 2 .AND. IPR(220) .EQ. 2) THEN CALL PLA206 (1, N213) C * SET PROBABILITY (10 <--> 90 PERCENT) ELSE IF (IPR(221) .EQ. 1 .AND. IPR(220) .EQ. 2) THEN IF (N213 .EQ. 'PRO') THEN IPR(45) = MAX (1, MIN (9, NINT(FN(1) / 10))) IPR(201) = 0 C * SET WINDOW FRACTION ELSE IF (N213 .EQ. 'WIN') THEN CALL GGIP (-999.0, FLOAT(IGBL(68)), FN(1) * 1000.0, 9) IGBL(62) = MIN (MAX (1, NINT(FN(1) / 0.25)), 4) ENDIF ELSE IF (IPR(220) .EQ. 3) THEN C * SET BEEP ON/OFF IF (N213 .EQ. 'BEE') THEN MEDIUM = 0 C * SET DISPLAY TYPE ELSE IF (N213 .EQ. 'DIS') THEN MEDIUM = 1 C * SET META TYPE ELSE IF (N213 .EQ. 'MET') THEN MEDIUM = 2 ENDIF IF (IPR(220) .GT. 2) CALL GGIP (-999.0, 0.0, 0.0, 6) ENDIF GOTO 1070 C * IS = 47: AFIX CARD (SHELX) ELSE IF (IS .EQ. 47) THEN IGBL(8) = 2 C * IS = 48: SFAC CARD (SHELX) OR IS = 172: SCAT ELSE IF (IS .EQ. 48 .OR. IS .EQ. 172) THEN IF (IS .EQ. 48) IGBL(8) = 2 IF (IPR(141) .EQ. 0 .AND. IGBL(8) .EQ. 2) THEN IDM = 'LATT 1' CALL SGSM (IDM, 0, XJX, 0, 0, IERR) IPR(141) = 1 ENDIF N = IPR(220) M = IPR(221) IF (N .GT. 1) THEN DO 240 I = 2, N N12 = 0 CALL GEN105 (1, IFL(I)(1:1), N) IF (N .GT. 0) N12 = (N - ICHAR('A') + 1) * 100 CALL GEN105 (1, IFL(I)(2:2), N) IF (N .GT. 0) N12 = N12 + N - ICHAR('A') + 1 IF (N12 .EQ. 815) IPR(435) = 1 DO 220 J = 1, NP9 IF (IEL(J) .EQ. N12) GOTO 230 220 CONTINUE IPR(2) = 41 GOTO 1120 230 IAN = IAN + 1 IEN(IAN) = J RADR(IAN, 3) = REL(J) RADR(IAN, 4) = ABS(VDWR(J)) IF (IFL(I)(2:2) .EQ. ' ') THEN LMT(IAN, 1) = ' '//IFL(I)(1:1) ELSE LMT(IAN, 1) = IFL(I)(1:2) CALL GEN020 (-1, LMT(IAN, 1), 2, 2) ENDIF LMT(IAN, 2) = JTP(IABS(IATPR(J))) IF (J .EQ. 3) THEN IACL(IAN) = 2 ELSE IF (J .EQ. 4) THEN IACL(IAN) = 4 ELSE IF (IATPR(J) .EQ. -7) THEN IACL(IAN) = 3 ELSE IF (J .GT. 2) THEN IF (ICLR .LT. 8) ICLR = ICLR + 1 IACL(IAN) = ICLR ENDIF 240 CONTINUE IF (N .EQ. 2 .AND. M .GT. 0 .AND. FN(1) .EQ. 0.0) 1 IPR(493) = 5 ENDIF C * IS = 49: UNIT CARD (SHELX) ELSE IF (IS .EQ. 49) THEN IGBL(8) = 2 DO 250 I = 1, IPR(221) CONT(I, 3) = FN(I) * PAR(32) 250 CONTINUE C * IS = 50: WGHT CARD (SHELX) ELSE IF (IS .EQ. 50) THEN IGBL(8) = 2 PAR(227) = FN(1) PAR(228) = FN(2) C * IS = 51: VIEW CARD(S) ELSE IF (IS .EQ. 51) THEN C * VIEW MIN IF (IFL(2)(1:3) .EQ. 'MIN') THEN IPR(201) = 0 IGBL(67) = 0 ELSE C * VIEW (XR xr YR yr ZR zr) N = 1 IF (IPR(220) .EQ. 1) THEN CALL PLA226 (0, 0.0) ELSE CALL GEN021 (RMAT, IGBL(87)) DO 260 L = 1, 3 CALL GEN051 (0, RMAT, - GL(27 + L) / GL(5), L) 260 CONTINUE DO 270 I = 2, IPR(220) NI13 = IFL(I)(1:3) IF (NI13 .EQ. 'UNI') THEN CALL PLA226 (0, 0.0) ELSE IF (NI13 .EQ. 'INV') THEN CALL PLA226 (-4, 0.0) ELSE IF (NI13(1:2) .EQ. 'XR') THEN CALL PLA226 (-1, - FN(N) / GL(5)) N = N + 1 ELSE IF (NI13(1:2) .EQ. 'YR') THEN CALL PLA226 (-2, - FN(N) / GL(5)) N = N + 1 ELSE IF (NI13(1:2) .EQ. 'ZR') THEN CALL PLA226 (-3, - FN(N) / GL(5)) N = N + 1 ENDIF 270 CONTINUE ENDIF ENDIF GOTO 1070 C * IS = 52: BOX ON/OFF (1/0) ELSE IF (IS .EQ. 52) THEN IF (IPR(220) .GT. 1) THEN DO 280 I = 2, IPR(220) N213 = IFL(I)(1:3) C * BOX OFF IF (N213 .EQ. 'OFF') THEN IGBL(103) = 0 C * BOX ON ELSE IF (N213 .EQ. 'ON ') THEN IGBL(103) = 1 C * BOX RATIO ELSE IF (N213 .EQ. 'RAT') THEN PAR(50) = FN(1) ENDIF 280 CONTINUE ENDIF GOTO 1070 C * IS = 53: EXIT ELSE IF (IS .EQ. 53) THEN GOTO 1100 C * IS = 54: BOND CARD (SHELX) ELSE IF (IS .EQ. 54) THEN IGBL(8) = 2 C * IS = 55: ZERR (SHELXTL/SHELXL) ELSE IF (IS .EQ. 55) THEN DO 290 I = 2, 7 PAR(105 + I) = FN(I) 290 CONTINUE IGBL(8) = 2 C * IS = 56: GEOM ELSE IF (IS .EQ. 56) THEN GOTO 570 C * IS = 57: L.S. CARD (SHELX) ELSE IF (IS .EQ. 57) THEN IGBL(8) = 2 C * IS = 58: FMAP CARD (SHELX) ELSE IF (IS .EQ. 58) THEN IGBL(8) = 2 C * IS = 59: INFO ELSE IF (IS .EQ. 59) THEN IS = 29 GOTO 20 C * IS = 60: TABLE OPTION ELSE IF (IS .EQ. 60) THEN IF (IPR(30) .NE. 0) THEN IPR(2) = 31 GOTO 1120 ENDIF IPR(430) = 1 IF (IPR(72) .EQ. 0) WRITE (LU6, 99962) IPR(454) = 1 IPR(240) = 1 IPR(119) = 0 IF (IPR(220) .GT. 1) THEN DO 300 I = 2, IPR(220) NI13 = IFL(I)(1:3) C * NO-HATOM IF (NI13 .EQ. 'NHA') THEN IPR(454) = 0 C * RESIDUE SORT/LISTING (NORES) ELSE IF (NI13 .EQ. 'NOR') THEN IPR(240) = 0 ELSE IF (NI13 .EQ. 'SU ') THEN C * SU (FULL SUPPLEMENTARY MATERIAL) IPR(431) = 0 ELSE IF (NI13 .EQ. 'AC ') THEN C * AC (ACTA CRYST) IPR(430) = 2 IPR(431) = 1 ELSE IF (NI13 .EQ. 'ACC' .OR. NI13 .EQ. 'CIF' 1 .OR. NI13 .EQ. 'CSD') THEN C * ACC (ACTA CRYST C - CIF) - NOPARENTHESES IF (EXTENS(1:3) .EQ. 'acc') THEN WRITE (LU6, 99997) GOTO 10 ENDIF IPR(430) = 1 IF (NI13 .EQ. 'CSD') THEN IPR(431) = -2 IGBL(31) = 9 CALL PLA021 ELSE IPR(431) = -1 IGBL(31) = 8 CALL PLA021 ENDIF ELSE IF (NI13 .EQ. 'JA ') THEN C * JA (JACS) IPR(430) = 2 IPR(431) = 2 ELSE IF (NI13 .EQ. 'IC ') THEN C * IC (INORG CHEM) IPR(430) = 2 IPR(431) = 3 C * LOCAL ELSE IF (NI13 .EQ. 'LOC') THEN IPR(399) = 1 ENDIF 300 CONTINUE ENDIF IF (IPR(30) .EQ. 0) THEN IPR(220) = 2 IFL(2) = 'OMEGA' GOTO 800 ELSE C * EXECUTE TABLE OPTIONS IF (IPR(430) .GT. 0) THEN IGBL(92) = MAX (IGBL(92), IPR(430)) IGBL(93) = MAX (IGBL(93), IPR(431)) IPR(31) = -1 IPR(17) = -1 IPR(90) = 1 IGBL(63) = 0 CALL PLA069 CALL PLA172 IPR(1) = 1 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF GOTO 1200 ENDIF C * IS = 61: RADII BONDS ((LIST/NORMAL/TO H/TO MET/ALL) (#lines (radius)) ELSE IF (IS .EQ. 61) THEN DO 310 I = 2, IPR(220) J1 = 0 NI13 = IFL(I)(1:3) C * RADII BONDS TO H IF (NI13 .EQ. 'H ') THEN J0 = 3 J1 = 3 C * RADII BONDS TO METAL ELSE IF (NI13 .EQ. 'MET') THEN J0 = 5 J1 = 5 C * NORMAL ELSE IF (NI13 .EQ. 'NOR') THEN J0 = 1 J1 = 1 ELSE IF (NI13 .EQ. 'ALL') THEN J0 = 1 J1 = 5 ELSE GOTO 310 ENDIF GOTO 320 310 CONTINUE 320 IF (J1 .GT. 0) THEN DO 330 J = J0, J1, 2 IF (IPR(221) .GT. 0) THEN IF (ABS(FN(1)) .GT. 5.0) FN(1) = SIGN(5.0, FN(1)) PAR(84 + J) = FN(1) ENDIF IF (IPR(221) .GT. 1) PAR(85 + J) = FN(2) 330 CONTINUE ENDIF WRITE (PRBUF, 99977) IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 3.0 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2, 1.0, VRT) ELSE WRITE (LU6, '(/, '':: '', A, /)') PRBUF(1:75) ENDIF WRITE (PRBUF, 99976) 1 NINT(PAR(85)), 2**NINT(ABS(PAR(85)) - 1) + 1, PAR(86) IF (IWIN .EQ. 1) THEN VRT = VRT - 1.5 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, '(/, '':: '', A, /)') PRBUF(1:75) ENDIF WRITE (PRBUF, 99975) 1 NINT(PAR(87)), 2**NINT(ABS(PAR(87)) - 1) + 1, PAR(88) IF (IWIN .EQ. 1) THEN VRT = VRT - 1.5 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF IF (IPR(155) .GT. 0) THEN WRITE (PRBUF, 99974) 1 NINT(PAR(89)), 2**NINT(ABS(PAR(89)) - 1) + 1, PAR(90) IF (IWIN .EQ. 1) THEN VRT = VRT - 1.5 CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99945) PRBUF(1:75) ENDIF ENDIF IF (IWIN .EQ. 1) CALL PLA297 (1) GOTO 1070 C * IS = 62: BLOC CARD (SHELX) ELSE IF (IS .EQ. 62) THEN IGBL(8) = 2 C * IS = 63: MENU (ON/OFF) ELSE IF (IS .EQ. 63) THEN IF (IPR(220) .EQ. 2 .AND. IFL(2)(1:3) .EQ. 'OFF') THEN IGBL(25) = 0 ELSE IGBL(25) = 1 IF (IGBL(23) .LT. 10 .OR. IGBL(23) .GT. 12) 1 CALL PLA280 ('PLOT') ENDIF C * IS = 64: OMIT CARD ELSE IF (IS .EQ. 64) THEN N = IPR(220) IF (N .GT. 1) THEN IF (IPR(30) .EQ. 0) THEN IF (IPR(37) .EQ. 0) THEN IPR(2) = 42 GOTO 1120 ENDIF IGBL(52) = MAX (IGBL(52), IPR(23)) CALL PLA287 (0, 1, 0) ENDIF DO 340 I = 2, N CALL PLA046 (2, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NR) IF (NR .GT. 0) THEN CALL GEN048 (1, IFG(NR), 30, 1) ELSE CALL PLA015 (0, 28) ENDIF 340 CONTINUE ELSE IF (IPR(221) .EQ. 2) THEN PAR(165) = FN(2) / 2.0 IGBL(8) = 2 ENDIF ENDIF C * IS = 65: GRID CARD (SHELX) ELSE IF (IS .EQ. 65) THEN IGBL(8) = 2 C * IS = 66: DFIX CARD (SHELX) ELSE IF (IS .EQ. 66) THEN IGBL(8) = 2 C * IS = 67: JOIN ATOMS ELSE IF (IS .EQ. 67) THEN MODE = 2 GOTO 1050 C * IS = 68: DETACH ATOMS ELSE IF (IS .EQ. 68) THEN MODE = -2 GOTO 1050 C * IS = 69: DEFINE SUBSTITUTE BOND ELSE IF (IS .EQ. 69) THEN MODE = -2 GOTO 1050 C * IS = 70: HKLF - LINE ELSE IF (IS .EQ. 70) THEN CALL PLA080 IF (IPR(221) .GE. 11) THEN DO 350 K = 1, 9 I = ((K - 1) / 3) + 1 J = MOD (K - 1, 3) + 1 DUMV(I, J) = FN(K + 2) 350 CONTINUE ELSE CALL GEN021 (DUMV, 1) ENDIF CALL GEN004 (TM1, DUMV, DUMV) K = 0 DO 370 I = 1, 3 DO 360 J = 1, 3 K = K + 1 PAR(230 + K) = DUMV(I, J) 360 CONTINUE 370 CONTINUE WRITE (LU6, 99960) (PAR(230 + I), I = 1, 9) CALL GEN003 (DUMV, QQ, DET, 0) PAR(240) = DET IF (ABS(ABS(DET) - 1.0) .GT. 0.001) WRITE (LU6, 99944) DET IF (DET .LT. 0.0) THEN IPR(2) = 40 GOTO 1120 ENDIF CALL GEN001 (1, QQ, AA, RAA) CALL GEN026 (-1, RAA, PAR(241), GL(5)) CALL GEN003 (RAA, RBB, DET, 0) IF (DET .LE. 0.0) STOP 'CANNOT INVERT METRICAL MATRIX' CALL GEN026 (-1, RBB, PAR(135), GL(5)) WRITE (LU6, 99959) (PAR(100 + I), I = 1, 6), 1 (PAR(240 + I), I = 1, 6) CALL GEN025 (RBB, PAR(391), 1) C * IS = 71: RADN LINE ELSE IF (IS .EQ. 71) THEN CALL PLA293 (FN(1), 0) C * IS = 72: TRMX ELSE IF (IS .EQ. 72) THEN IS = 42 GOTO 20 C * IS = 73: PART - SHELXL STYLE ELSE IF (IS .EQ. 73) THEN C * IS = 74: INORG (FORCE INORGANIC MODE) ELSE IF (IS .EQ. 74) THEN IGBL(97) = 0 C * IS = 75: ORGA (FORCE ORGANIC MODE) ELSE IF (IS .EQ. 75) THEN IGBL(97) = 1 C * IS = 78: ENTRY (CSD-FDAT-FILE ENTRY) ELSE IF (IS .EQ. 78) THEN CALL PLA011 IF (ICL(1:4) .EQ. 'END ') GOTO 1090 C * IS = 79: ELLIPSOID PARAMETERS ELSE IF (IS .EQ. 79) THEN IF (IPR(220) .GT. 1) THEN N213 = IFL(2)(1:3) IF (N213 .EQ. 'C ') THEN N = 175 ELSE IF (N213 .EQ. 'H ') THEN N = 177 ELSE IF (N213 .EQ. 'OTH') THEN N = 179 ENDIF IF (IPR(221) .GT. 1) THEN IPR(N) = MAX (0, MIN (1, NINT(ABS(FN(1))))) IPR(N + 1) = NINT(ABS(FN(2))) ENDIF ENDIF WRITE (LU6, 99964) (IPR(174 + I), I = 1, 6) C * IS = 80: ORMA - CAD4 ORIENTATION MATRIX (Reciprocal Axes) ELSE IF (IS .EQ. 80) THEN IF (IPR(221) .EQ. 9) THEN DO 380 I = 1, 9 PAR(180 + I) = FN(I) J = MOD (I - 1, 3) + 1 K = ((I - 1) / 3) + 1 DAM(J, K) = FN(I) 380 CONTINUE CALL GEN003 (DAM, DUMV, DET, 0) IF (DET .LE. 0.0) STOP 'CANNOT INVERT ORMA' WRITE (LU6, 99963) 1.0 / DET IPR(16) = 1 ELSE GOTO 1060 ENDIF C * IS = 81: EXTI CARD (SHELXL) ELSE IF (IS .EQ. 81) THEN PAR(229) = FN(1) C * IS = 82: SETUP (EXOR.BIN) ELSE IF (IS .EQ. 82) THEN CALL PLA150 (0) GOTO 1130 C * IS = 83: EXOR ELSE IF (IS .EQ. 83) THEN CALL PLA150 (1) GOTO 1130 C * IS = 84: ABSG(AUSS) ELSE IF (IS .EQ. 84) THEN PAR(162) = FN(1) IF (IPR(221) .EQ. 4) THEN IPR(421) = NINT(FN(2)) IPR(422) = NINT(FN(3)) IPR(423) = NINT(FN(4)) ENDIF IF (IGBL(37) .EQ. 0) THEN IPR(2) = 56 GOTO 1250 ENDIF PAGET = 'ABSGAUSS' IPR(78) = 2 GOTO 730 C * IS = 85: FACE CARD ELSE IF (IS .EQ. 85) THEN IF (FN(4) .LE. 0) THEN IPR(2) = 34 GOTO 1130 ENDIF IF (IPR(367) .GT. 0) THEN DO 400 I = 1, IPR(367) DO 390 J = 1, 3 IF (ABS(PMILL(I, J) - FN(J)) .GT. 0.001) GOTO 400 390 CONTINUE GOTO 410 400 CONTINUE ENDIF IPR(367) = IPR(367) + 1 NFACES = IPR(367) 410 DO 420 J = 1, 4 PMILL(IPR(367), J) = FN(J) 420 CONTINUE PMILL(IPR(367), 5) = FN(4) C * IS = 86: ABST (de MEULENAER-TOMPA) ELSE IF (IS .EQ. 86) THEN PAR(162) = FN(1) IF (IGBL(37) .EQ. 0) THEN IPR(2) = 56 GOTO 1250 ENDIF PAGET = 'ABSTOMPA' IPR(78) = 3 GOTO 730 C * IS = 87: ABSXTAL ELSE IF (IS .EQ. 87) THEN PAR(162) = FN(1) IPR(78) = 1 GOTO 730 C * IS = 88: LEPAGE METRICAL SYMMETRY ANALYSIS ELSE IF (IS .EQ. 88) THEN IGBL(23) = 20 IPR(2) = -1 IPR(94) = 2 IF (FN(1) .NE. 0.0) PAR(441) = FN(1) IF (FN(2) .NE. 0.0) IPR(94) = MAX (2, MIN (10, NINT(FN(2)))) IF (FN(3) .NE. 0.0) PAR(439) = FN(3) CALL PLA080 CALL SGSM (ICL, 0, XJX, LU7, 18, IERR) CALL PLA164 (0, 0, ICL(13:13), TM1, PAR(439)) CALL GEN038 (ICL, 1, 80) GOTO 1240 C * IS = 89: ASYM ELSE IF (IS .EQ. 89) THEN CALL PLA140 IF (IPR(2) .EQ. 0) IPR(2) = -14 GOTO 1250 C * IS = 90: ABSPSI ELSE IF (IS .EQ. 90) THEN IF (IGBL(37) .EQ. 0) THEN IPR(2) = 56 GOTO 1250 ENDIF PAGET = 'ABSPSI' IPR(78) = 4 GOTO 730 C * IS = 91: ABSSPHERE ELSE IF (IS .EQ. 91) THEN IPR(78) = -1 GOTO 730 C * IS = 92: CONTOUR-PLOTS ELSE IF (IS .EQ. 92) THEN CALL PLA250 IF (IPR(2) .NE. 0) GOTO 1250 IF (IGGT(1:4) .EQ. 'EXIT') GOTO 1250 IF (IGBL(3) .GE. 19 .AND. IGBL(3) .LE. 22) THEN GOTO 1250 ELSE CALL PLA280 ('RESTART') ENDIF C * IS = 93: RESTART ELSE IF (IS .EQ. 93) THEN CALL GEN108 (LU1, 0) CALL GEN108 (LU2, 0) CALL GEN108 (LU20, 0) IF (IABS(IGBL(8)) .EQ. 3) IGBL(8) = 3 WRITE (LU6, 99961) GOTO 1230 C * IS = 94: VALIDATION CHECK MODE (FOR ACTA CRYST ETC) ELSE IF (IS .EQ. 94) THEN IF (IGBL(30) .EQ. 1) THEN IPR(119) = 0 IGBL(36) = 1 LINE = NAME(1)(1:KNM(1))//'.chk' IF (IGBL(10) .EQ. 0) THEN OPEN (UNIT = LU10, FILE = LINE, STATUS = 'UNKNOWN') IGBL(10) = 1 ENDIF WRITE (LU6, 1 '(/, '' >> CIF-Validation-Check Result on '', A)') LINE IGBL(64) = 0 IGBL(63) = IGBL(64) GOTO 800 ELSE CALL PLA015 (0, 47) IGBL(3) = 0 GOTO 10 ENDIF C * IS = 95: EXPT - CALCULATE EXPECTED NUMBER OF REFLECTIONS ELSE IF (IS .EQ. 95) THEN CALL PLA086 (LU6) CALL PLA086 (LU7) GOTO 1250 C * IS = 96: PLUTON ELSE IF (IS .EQ. 96) THEN GOTO 770 C * IS = 99: TWIN ELSE IF (IS .EQ. 99) THEN DO 430 I = 1, 9 PAR(331 + I) = FN(I) 430 CONTINUE IF (IPR(221) .EQ. 0) THEN PAR(332) = -1.0 PAR(336) = -1.0 PAR(340) = -1.0 ENDIF IPR(193) = IPR(193) + 1 C * IS = 103: RESI ELSE IF (IS .EQ. 103) THEN IPR(538) = NINT(FN(1)) C * IS = 112: CRYSTAL SIZE ELSE IF (IS .EQ. 112) THEN IF (IPR(221) .EQ. 3) THEN CALL GEN034 (FN, 1, 3) DO 440 I = 1, 3 PAR(301 + I) = FN(I) 440 CONTINUE ENDIF C * IS = 132: TEMP (SHELX ==> DEG. C) ([C]/K) ELSE IF (IS .EQ. 132) THEN IF (IFL(2)(1:1) .EQ. 'K') THEN IPR(261) = NINT(FN(1)) ELSE IPR(261) = NINT(FN(1)) + 273 ENDIF IPR(310) = IPR(261) C * IS = 142: BASF ELSE IF (IS .EQ. 142) THEN IF (IPR(221) .GT. 0) THEN DO 450 I = 1, IPR(221) BASF(I) = FN(I) 450 CONTINUE IPR(513) = IPR(221) PAR(341) = FN(1) IPR(193) = IPR(193) + 1 ENDIF C * IS = 146: HALL ELSE IF (IS .EQ. 146) THEN IS = 32 GOTO 20 C * IS = 148: MULABS ELSE IF (IS .EQ. 148) THEN IF (IPR(220) .GT. 1) THEN DO 460 I = 2, IPR(220) IF (IFL(I)(1:5) .EQ. 'LIST') IGBL(57) = 1 IF (IFL(I)(1:7) .EQ. 'NOCHECK') IPR(363) = 0 460 CONTINUE ENDIF IF (IGBL(37) .EQ. 0) THEN IPR(2) = 56 GOTO 1250 ENDIF IPR(78) = -2 CALL PLA080 CALL PLA042 (1) PAGET = 'MULABS' CALL PLA187 IF (IPR(2) .EQ. 0) IPR(2) = -4 GOTO 1250 C * IS = 149: HKLF-TRANS ELSE IF (IS .EQ. 149) THEN CALL PLA042 (1) CALL PLA201 IF (IPR(2) .EQ. 0) IPR(2) = -15 GOTO 1250 C * IS = 150: XTAL-HABIT PLOT ELSE IF (IS .EQ. 150) THEN IPR(78) = 0 CALL PLA190 GOTO 1260 C * IS = 151: HINCLUDE (ORTEP) ELSE IF (IS .EQ. 151) THEN DO 470 I = 2, IPR(220) CALL PLA046 (3, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, N1) CALL GEN048 (1, JFG(N1), 12, 1) 470 CONTINUE GOTO 1070 C * IS = 152: HEXCLUDE (ORTEP) ELSE IF (IS .EQ. 152) THEN DO 480 I = 2, IPR(220) CALL PLA046 (3, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, N1) CALL GEN048 (1, JFG(N1), 12, 0) 480 CONTINUE GOTO 1070 C * IS = 153: FILE ELSE IF (IS .EQ. 153) THEN CALL PLA004 (1) GOTO 1210 C * IS = 154: RENAME (RES) ELSE IF (IS .EQ. 154) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN IGBL(3) = 12 IGBL(105) = 1 GOTO 770 ENDIF C * IS = 155: SYSTEM S ELSE IF (IS .EQ. 155) THEN IGBL(3) = 14 CLOSE (LU1) CLOSE (LU2) CLOSE (LU3) CLOSE (LU4) CLOSE (LU8) CLOSE (LU9) CLOSE (LU16) CALL S GOTO 1260 C * IS = 156: DELAUNEY REDUCTION ELSE IF (IS .EQ. 156) THEN IF (IPR(221) .GT. 0) THEN PAR(382) = FN(1) IF (IPR(221) .EQ. 2) PAR(381) = FN(2) ENDIF CALL PLA080 CALL SGSM (ICL, 0, XJX, LU7, 18, IERR) CALL PLA178 (ICL(13:13), LU7) GOTO 1240 C * IS = 157: EXPAND TO P1 ELSE IF (IS .EQ. 157) THEN CALL PLA208 GOTO 1250 C * IS = 158: ARU ELSE IF (IS .EQ. 158) THEN CALL PLA295 C * IS = 159: ANALYSIS OF VARIANCE ELSE IF (IS .EQ. 159) THEN CALL PLA119 (0) GOTO 1250 C * IS = 160: FCF2HKL ELSE IF (IS .EQ. 160) THEN CALL PLA292 (LU6, LU16, LU17, IGBL(29), IPR(384)) IF (IPR(2) .EQ. 0) IPR(2) = -16 GOTO 1260 C * IS = 161: PORTRAIT ELSE IF (IS .EQ. 161) THEN IGBL(46) = MOD(IGBL(46) + 1, 2) PAR(50) = (4.0 - IGBL(46)) / 3.0 NN = 4 - IGBL(46) * 8 CALL GGIP (-999.0, 0.0, 0.0, NN) C * IS = 162: SIMULATED POWDER-PATTERN ELSE IF (IS .EQ. 162) THEN CALL PLA144 GOTO 1240 C * IS = 163: FSUM ELSE IF (IS .EQ. 163) THEN C * IS = 164: SCAL ELSE IF (IS .EQ. 164) THEN IS = 1 GOTO 20 C * IS = 165 ELSE IF (IS .EQ. 165) THEN IS = 1 GOTO 20 C * IS = 166: ROTMAT ELSE IF (IS .EQ. 166) THEN CALL PLA119 (1) GOTO 1250 C * IS = 167: CAVITY ELSE IF (IS .EQ. 167) THEN CALL PLA207 CALL PLA280 ('RESTART') C * IS = 168: SHXABS ELSE IF (IS .EQ. 168) THEN CALL PLA183 GOTO 1250 C * IS = 169: DELETE ATOM (ORTEP/SOLV) ELSE IF (IS .EQ. 169) THEN N = IPR(220) IF (N .GT. 1) THEN DO 490 I = 2, N CALL PLA046 (2, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NR) IF (NR .GT. 0) THEN CALL GEN048 (1, JFG(NR), 27, 1) ELSE CALL PLA015 (0, 28) ENDIF 490 CONTINUE ENDIF C * IS = 170: COLOR TYPE INSTRUCTION ELSE IF (IS .EQ. 170) THEN N = IPR(220) IF (MOD (N, 2) .EQ. 0 .AND. N .GE. 4) THEN DO 520 I = 3, N, 2 NQ1 = IFL(I)(1:2) NQ2 = IFL(I + 1)(1:3) IF (NQ1(2:2) .EQ. ' ') THEN NQ1 = ' '//IFL(I)(1:1) ELSE CALL GEN020 (-1, NQ1, 2, 2) ENDIF DO 510 J = 1, IAN IF (NQ1(1:2) .EQ. LMT(J, 1)) THEN DO 500 K = 1, NP10 + 1 IF (NQ2(1:3) .EQ. COLR(K)(1:3)) THEN IACL(J) = K GOTO 520 ENDIF 500 CONTINUE ENDIF 510 CONTINUE 520 CONTINUE ENDIF C * IS = 171: RESET ELSE IF (IS .EQ. 171) THEN CALL PLA281 (0) GOTO 1090 C * IS = 173: STIDY (Structure Tidy - Parthe & Gelato) ELSE IF (IS .EQ. 173) THEN IGBL(30) = 1 NAT = IPR(37) EXTENS1 = EXTENS EXTENS = 'sty' KXT = 3 CALL PLA069 OPEN (UNIT = LU64, FILE = NAME(1)(1:KNM(1))//'.'//EXTENS(1:KXT), 1 STATUS = 'UNKNOWN') WRITE (LU64, 99971) SPGRNM(4)(1:16), JID(1:40) WRITE (LU64, 99970) (PAR(I), I = 101, 106) IF (IPR(202) .NE. 0) THEN IW = ISETS (1, IPR(202)) IF (IW .LT. 0 .OR. IW .EQ. 15) WRITE (LU64, 99941) ENDIF DO 525 I = 1, NAT CALL GEN048 (-7, JFG(I), 1, IPOP) IDIS = IPPR (IPOP + 1, 1) CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, 0, 0, 0, 0) IF (IDIS .LT. 1000) THEN WRITE (LU64, 99969) NQ1, (XXO(I, J), J = 1, 3), 1 IDIS / 1000.0 ELSE WRITE (LU64, 99969) NQ1, (XXO(I, J), J = 1, 3) ENDIF 525 CONTINUE WRITE (LU64, 99968) CLOSE (LU64) CALL PLA301 WRITE (LU6, 99967) NAME(1)(1:KNM(1))//'.'//EXTENS(1:KXT) EXTENS = EXTENS1 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 C * BIJVOET PAIR ANALYSIS ELSE IF (IS .EQ. 174) THEN CALL PLA119 (-1) GOTO 1250 ENDIF C * CATCH OTHERS GOTO 10 C * TEST FOR TOO MANY SPECIFIED ATOMS 530 IF (IPR(220) .GT. NP1 + 1) THEN IPR(2) = 8 GOTO 1120 ENDIF IF (IPR(30) .EQ. 0) THEN IF (IPR(145) .LT. NP2) THEN IPR(145) = IPR(145) + 1 XLS(1, IPR(145)) = NTYP DO 540 K = 2, 9 XLS(K, IPR(145)) = -1 540 CONTINUE IPR(146) = 1 DO 560 I = 2, IPR(220) CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN IF (IFL(I)(1:3) .EQ. 'DIS') THEN IPR(220) = - IPR(220) GOTO 570 ELSE IF (IFL(I)(1:4) .EQ. 'WITH') THEN IPR(220) = - IPR(220) GOTO 570 ELSE NQ1 = IFL(I) GOTO 1110 ENDIF ENDIF IPR(146) = IPR(146) + 1 IF (IPR(146) .GT. 9) THEN IPR(145) = IPR(145) + 1 IPR(146) = 2 DO 550 K = 1, 9 XLS(K, IPR(145)) = -1 550 CONTINUE ENDIF XLS(IPR(146), IPR(145)) = XNQNR 560 CONTINUE WRITE (LU6, 99987) ENDIF GOTO 10 ENDIF IPR(220) = - IPR(220) C * SINGLE DISTANCE, ANGLE OR TORSION ANGLE CALCULATION (+GEOM) 570 IF (IPR(220) .EQ. 1 .OR. IPR(220) .GT. 5) GOTO 1060 IPR(1) = 7 IPR(81) = IPR(220) GOTO 760 C * INCLUDE/EXCLUDE NAMED ELEMENTS FROM CALCULATIONS 580 IF (IPR(30) .EQ. 1) THEN C * INSTRUCTION NOT ALLOWED IPR(2) = 11 GOTO 1120 ELSE IPR(4) = 0 I = 1 590 I = I + 1 IF (I .GT. IPR(220)) GOTO 1070 IF (IFL(I)(1:3) .EQ. 'MET') THEN DO 600 J = 1, IAN IF (IATPR(IEN(J)) .GT. 0) THEN IPR(220) = IPR(220) + 1 N = IEL(IEN(J)) N1 = N / 100 IFL(IPR(220))(1:3) = CHAR(ICHAR('A') - 1 + N1)//' ' N1 = MOD(N, 100) IF (N1 .GT. 0) THEN IFL(IPR(220))(2:2) = CHAR(ICHAR('A') - 1 + N1) ENDIF ENDIF 600 CONTINUE GOTO 590 ENDIF CALL PLA037 (I, N, 2) IF (N .GT. 0) THEN IF (IPR(4) .LE. NP10) THEN IPR(4) = IPR(4) + 1 C * SCRATCH USE OF ARRAY RADI FOR INCLUDE OPTION RADR(IPR(4), 2) = N ELSE WRITE (LU6, 99978) NP10 ENDIF ELSE IPR(2) = 16 IPR(4) = 0 IAN = IAN - 1 GOTO 1120 ENDIF GOTO 590 ENDIF 610 IPR(471) = IPR(471) + 1 IF (IGBL(5) .NE. LU5) GOTO 10 C * UNKNOWN CARD ERROR IPR(2) = 7 GOTO 1120 C * ATOMIC COORDS IN FREE-FORMAT INPUT 620 IF (IPR(220) .LT. IPR(473) .OR. IPR(221) .LT. 3) GOTO 610 IF (IGBL(8) .EQ. 2 .AND. IGBL(95) .EQ. 1) THEN IF (IFL(1)(1:1) .EQ. 'Q' .AND. FN(7) .LT. GL(26)) GOTO 10 ENDIF CALL PLA079 (XNQNR) C * CHECK FOR ERROR RETURN IF (IPR(2) .EQ. 0) THEN GOTO 10 ELSE GOTO 1120 ENDIF C * BIJ & SBIJ DATA C * (BETA-VALUES ARE TRANSFORMED TO U-VALUES AFTER TRANSFORMATION) 630 DO 640 I = 1, 6 FN(I) = FN(I) / GL(7) 640 CONTINUE IF (IS .EQ. 40) GOTO 670 GOTO 660 C * UIJ DATA & SUIJ DATA 650 FN(1) = FN(1) * PAR(135)**2 FN(2) = FN(2) * PAR(136)**2 FN(3) = FN(3) * PAR(137)**2 FN(4) = FN(4) * PAR(136) * PAR(137) FN(5) = FN(5) * PAR(135) * PAR(137) FN(6) = FN(6) * PAR(135) * PAR(136) IF (IS .EQ. 26) GOTO 670 660 IF (IGBL(8) .EQ. 3) THEN IF (IFL(2)(1:1) .EQ. '?') GOTO 10 IF (IPR(221) .NE. 12 .OR. 1 (FN(2) .EQ. 0.0 .AND. FN(3) .EQ. 0.0 .AND. FN(4) .EQ. 0 2 .AND. FN(5) .EQ. 0 .AND. FN(6) .EQ. 0)) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99942) '_217', 1.0, 1.0, IFL(2) ELSE IPR(2) = 50 GOTO 1120 ENDIF ENDIF ENDIF CALL GEN025 (DUMV, FN, -1) CALL GEN001 (1, TM2, DUMV, UIJ) CALL GEN025 (UIJ, FN, 1) ICT = 2 IPR(32) = 2 GOTO 680 C * SUIJ DATA 670 ICT = 3 680 FN(1) = FN(1) / PAR(113)**2 FN(2) = FN(2) / PAR(114)**2 FN(3) = FN(3) / PAR(115)**2 FN(4) = FN(4) / (PAR(114) * PAR(115)) FN(5) = FN(5) / (PAR(113) * PAR(115)) FN(6) = FN(6) / (PAR(113) * PAR(114)) GOTO 710 C * B DATA (SHOULD INCLUDE ATOM LABEL) 690 IF (IPR(220) .EQ. 1) THEN IS = 1 GOTO 20 ENDIF FN(1) = FN(1) / GL(8) FN(2) = FN(2) / GL(8) C * U DATA (SHOULD INCLUDE ATOM LABEL) 700 IF (IPR(220) .EQ. 1) THEN IS = 1 GOTO 20 ENDIF ICT = 4 710 IF (IPR(30) .EQ. 1 .OR. IPR(107) .EQ. 1) GOTO 610 NQ2 = IFL(2) IF (IGBL(8) .EQ. 1) THEN IF (NQ4 .NE. NQ2) THEN C * LABEL INCONSISTENT IPR(2) = 4 GOTO 1120 ENDIF XNQNR2 = XNQNR ELSE MODE = 0 CALL PLA046 (-2, NQ2, IENM, LBB, LBC, LBD, 1 XNQNR2, YNQNR2, IDUM2) ENDIF IPR(32) = MAX (IPR(32), 1) WRITE (LU4) ICT, XNQNR2, (FN(K), K = 1, 8) IF (IGBL(8) .EQ. 3) THEN IF (IS .EQ. 25) THEN IS = 26 DO 720 I = 1, 6 FN(I) = FN(I + 6) 720 CONTINUE GOTO 650 ENDIF ENDIF GOTO 10 730 IF (IPR(220) .GT. 1) THEN DO 740 I = 2, IPR(220) IF (IFL(I)(1:5) .EQ. 'LIST') IGBL(57) = 1 IF (IFL(I)(1:7) .EQ. 'NOCHECK') IPR(363) = 0 740 CONTINUE ENDIF CALL PLA190 IF (IPR(2) .EQ. 0) THEN IF (IPR(78) .EQ. -1) THEN IPR(2) = -5 ELSE IF (IPR(78) .EQ. 1) THEN IPR(2) = -1 ELSE IF (IPR(78) .EQ. 2) THEN IPR(2) = -8 ELSE IF (IPR(78) .EQ. 3) THEN IPR(2) = -7 ELSE IF (IPR(78) .EQ. 4) THEN IPR(2) = -6 ENDIF ENDIF GOTO 1250 C * ASYM (IUCR-CHECK) 750 IF (IABS(IGBL(8)) .EQ. 3 .AND. IGBL(94) .EQ. 0) THEN IF (IPR(493) .EQ. 0) 1 WRITE (LU20, 99943) '_092', PAR(17), PAR(17) IPR(121) = IPR(121) - 1 IFL(1) = 'ASYM' IFL(2) = 'EXPECT' IPR(220) = 2 IF (PAR(168) .GT. 0.0) 1 PAR(287) = SIN (PAR(168) / GL(5)) / PAR(17) ELSE IPR(121) = IPR(121) - 2 GOTO 1090 ENDIF CALL PLA140 IPR(559) = IPR(377) IPR(560) = IPR(379) IPR(561) = IPR(305) IPR(562) = IPR(306) IPR(563) = IPR(307) IF ((IGBL(29) .GT. 0 .AND. IGBL(29) .LT. 20) .OR. 1 IGBL(29) .EQ. 21) THEN IFL(1) = 'ASYM' IFL(2) = 'AVF' IFL(3) = 'VALID' IPR(200) = 0 IPR(220) = 3 IPR(221) = 0 IGBL63 = IGBL(63) IGBL(63) = 0 CALL PLA140 IGBL(18) = 0 IGBL(63) = IGBL63 ENDIF IF (IABS(IGBL(8)) .EQ. 3) CALL PLA231 (20) IPR(2) = -1 GOTO 1250 760 IF (IPR(30) .EQ. 0) THEN IGBL(52) = MAX (IGBL(52), IPR(23)) IPR(205) = 0 ENDIF GOTO 1190 C * PLUTON/PLOT - TEST FOR 'PLUTON' OR 'PLUTON/RENAME' SHORTCUT 770 IF (IFL(2)(1:3) .EQ. 'NAT') IGBL(3) = 8 IF (IGBL(3) .EQ. 8 .OR. IGBL(3) .EQ. 12) GOTO 1180 IFL(2) = IFL(1) IPR(220) = 2 C * PLOT INSTRUCTION CARD 780 IPR(1) = 5 IPR(56) = 0 IPR(112) = 0 IPR(205) = 0 N = 1 K0 = 0 IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN IGBL(45) = IGBL(45) + 1 WRITE (LU3, 99984) ICL(1:80) WRITE (LU6, 99973) ICL(1:70) ENDIF IF ((IPR(14) .EQ. 0 .OR. IPR(14) .EQ. 4) .AND. 1 IPR(220) .EQ. 1) THEN IPR(220) = 2 IFL(2) = 'ADP' IF (IPR(346) .EQ. 1) THEN IFL(3) = 'COLOR' IPR(220) = 3 ENDIF ENDIF IF (IPR(220) .GT. 1) THEN DO 790 I = 2, IPR(220) NI14 = IFL(I)(1:4) IF (NI14 .EQ. 'RING') THEN IPR(55) = 2 IPR(14) = -1 ELSE IF (NI14 .EQ. 'PLAN') THEN IPR(55) = 1 IPR(14) = -1 ELSE IF (NI14 .EQ. 'RESD') THEN IF (IPR(14) .GT. 0) THEN K0 = K0 + 1 IF (K0 .LE. IPR(221)) IPR(140) = NINT(FN(K0)) ELSE IPR(55) = 3 IPR(14) = -1 ENDIF ELSE IF (NI14 .EQ. 'LSPL') THEN IPR(55) = 4 IPR(14) = -1 C * DISPLAY ON ELSE IF (NI14 .EQ. 'DISP') THEN CALL GGIP (-999.0, 0.0, 0.0, -3) CALL GGIP (-999.0, 0.0, 0.0, 2) C * META ON ELSE IF (NI14 .EQ. 'META') THEN CALL GGIP (-999.0, 0.0, 0.0, -2) ELSE IF (NI14 .EQ. 'NEWM') THEN IPR(55) = -1 IPR(14) = -1 IPR(169) = 0 IF (IPR(30) .NE. 0) CALL GEN108 (LU8, 0) IPR(162) = 0 ELSE IF (NI14 .EQ. 'PERP') THEN IPR(56) = 0 ELSE IF (NI14 .EQ. 'ALON') THEN IPR(56) = 1 ELSE IF (NI14 .EQ. 'ADP ' .OR. NI14 .EQ. 'TME ') THEN IPR(14) = 4 ELSE IF (NI14 .EQ. 'POLY') THEN IPR(14) = 5 ELSE IF (NI14 .EQ. 'PLUT') THEN IPR(14) = 6 ELSE IF (NI14 .EQ. 'HATO') THEN IPR(212) = 1 ELSE IF (NI14 .EQ. 'NOHA') THEN IPR(212) = 0 ELSE IF (NI14 .EQ. 'LABE') THEN IGBL(75) = 1 ELSE IF (NI14 .EQ. 'NOLA') THEN IGBL(75) = 0 ELSE IF (NI14 .EQ. 'ENVE') THEN IPR(211) = 1 ELSE IF (NI14 .EQ. 'HETE') THEN IPR(211) = 0 ELSE IF (NI14 .EQ. 'OCTA') THEN IPR(211) = 2 ELSE IF (NI14 .EQ. 'PARE') THEN IPR(350) = 1 ELSE IF (NI14 .EQ. 'NOPA') THEN IPR(350) = 0 ELSE IF (NI14 .EQ. 'MARG') THEN IF (K0 .LT. IPR(221)) THEN K0 = K0 + 1 PAR(44) = FN(K0) ENDIF ELSE IF (NI14 .EQ. 'TAPE') THEN IF (K0 .LT. IPR(221)) THEN K0 = K0 + 1 PAR(48) = FN(K0) ENDIF ELSE IF (NI14 .EQ. 'NET ') THEN IPR(112) = 1 ELSE IF (NI14 .EQ. 'MONO') THEN IPR(116) = 0 ELSE IF (NI14 .EQ. 'STER') THEN IPR(116) = 1 ELSE IF (NI14 .EQ. 'COLO') THEN IPR(346) = 1 ELSE CALL PLA037 (I, L, 2) IF (IPR(2) .EQ. 0) THEN IF (L .LT. 0) IPR(162) = IPR(162) * (NP1 + 1) + IABS(L) ELSE IPR(2) = 0 WRITE (LU6, 99986) IFL(I) ENDIF ENDIF 790 CONTINUE IF (IPR(30) .EQ. 0) THEN IPR(220) = 2 IF (IPR(14) .LT. 0) THEN WRITE (LU6, 99983) ELSE WRITE (LU6, 99982) ENDIF GOTO 810 ELSE IF (IPR(14) .GT. 0) GOTO 1130 IF (IPR(136) .NE. 1) THEN IPR(2) = 12 GOTO 1120 ENDIF ENDIF IF (IPR(86) .EQ. 0) GOTO 10 ELSE IF (IPR(14) .EQ. 0) GOTO 1060 ENDIF GOTO 1130 C * CALC CONTROL CARD FOR PLA069. THE SUB-KEYWORDS ARE: C * INTRA, INTER, COORDN, METAL, GEOM, HBOND, TMA, VOID, LIST, ADDSYM 800 IPR(14) = 0 IPR(31) = 0 IPR(67) = 0 IPR(189) = 0 IPR(197) = 0 IPR(200) = 0 IPR(205) = 0 IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN IGBL(45) = IGBL(45) + 1 WRITE (LU3, 99984) ICL(1:80) WRITE (LU6, 99973) ICL(1:70) ENDIF 810 IPR(136) = 0 C * HANDLE CALC ( = CALC ALL) CASE IF (IPR(220) .EQ. 1) THEN IF (IGBL(36) .EQ. 0) IGBL(36) = -1 IGBL(22) = 0 IPR(121) = 8 IPR(495) = 1 IPR(123) = 1 IF (IPR(221) .GT. 0) THEN IPR(221) = 0 IPR(2) = 7 GOTO 1120 ENDIF ELSE IPR(121) = 0 ENDIF 820 IF (IPR(30) .EQ. 0) THEN IPR(1) = 2 ELSE IPR(1) = 6 ENDIF IPR(57) = 0 N = 0 IGBL(52) = MAX (IGBL(52), IPR(23)) PAR(262) = PAR(7) IF (IPR(14) .NE. 0) THEN IPR(121) = 1 L = 2 GOTO 920 ENDIF L = 1 C * HANDLE CALC (ALL) CASE C * (= ADDSYM, INTRA, INTER, COORDN, METAL, SOLV, (ASYM)) IF (IPR(220) .EQ. 1) THEN IF (IPR(121) .EQ. 8) THEN GOTO 860 ELSE IF (IPR(121) .EQ. 7) THEN GOTO 920 ELSE IF (IPR(121) .EQ. 6) THEN GOTO 980 ELSE IF (IPR(121) .EQ. 5) THEN GOTO 1020 ELSE IF (IPR(121) .EQ. 4) THEN GOTO 1010 ELSE IF (IPR(121) .EQ. 3) THEN GOTO 940 ELSE IF (IPR(121) .EQ. 2) THEN GOTO 750 ELSE IF (IPR(121) .EQ. 1) THEN GOTO 1090 ENDIF ENDIF IF (IPR(221) .GT. 0) PAR(262) = 0.0 IPR(121) = 1 830 L = L + 1 IF (L .GT. IPR(220)) GOTO 1040 DO 850 N0 = NP24 + 1, NP22 NQ1 = IFL(L) IF (NQ1(1:4) .EQ. ISWS(N0)) THEN ISS = N0 - NP24 + 1 C * ISS = 2: GEOM IF (ISS .EQ. 2) THEN GOTO 900 C * ISS = 3: TMA, ATOMIC DISPLACEMENT MOTION CALCULATION ELSE IF (ISS .EQ. 3) THEN IF (IPR(30) .NE. 0) THEN IPR(2) = 29 GOTO 1120 ENDIF IPR(5) = 1 IF (IPR(221) .GT. 0) THEN PAR(34) = FN(1) IF (IPR(221) .GT. 1) IPR(21) = NINT(FN(2)) ENDIF IF (IPR(220) .GT. 2 .AND. IFL(3)(1:3) .EQ. 'CAR') 1 IPR(347) = 1 GOTO 920 C * ISS = 4: INTRA ELSE IF (ISS .EQ. 4) THEN GOTO 920 C * ISS = 5: INTER ELSE IF (ISS .EQ. 5) THEN GOTO 980 C * ISS = 6: NOTM(A) ELSE IF (ISS .EQ. 6) THEN IPR(5) = 0 C * ISS = 7: NOAN(G) ELSE IF (ISS .EQ. 7) THEN IPR(7) = 0 C * ISS = 8: NOTO(R) ELSE IF (ISS .EQ. 8) THEN IPR(8) = 0 C * ISS = 9: NOLS(PL) ELSE IF (ISS .EQ. 9) THEN IPR(9) = 0 C * ISS = 10: NOST(D) ELSE IF (ISS .EQ. 10) THEN IPR(72) = 0 C * ISS = 11: NORI(NG) ELSE IF (ISS .EQ. 11) THEN IPR(10) = 0 C * ISS = 12: NOBOND ELSE IF (ISS .EQ. 12) THEN C * NOBO(ND)/NODI(ST) IPR(6) = 0 C * ISS = 13: NOMO(VE) OPTION ELSE IF (ISS .EQ. 13) THEN IF (IPR(30) .EQ. 1) THEN C * INSTRUCTION NOT ALLOWED IPR(2) = 11 GOTO 1120 ELSE IGBL(30) = 1 ENDIF C * ISS = 14: NOSY(MM) OPTION ELSE IF (ISS .EQ. 14) THEN IGBL(52) = 1 C * ISS = 15: NOBP(A) ELSE IF (ISS .EQ. 15) THEN IPR(40) = 0 C * ISS = 16: EWLS ELSE IF (ISS .EQ. 16) THEN C * (E)WLSPL - CALCULATE ESD-WEIGHTED PLANES IPR(41) = 2 C * ISS = 17: TOLA ELSE IF (ISS .EQ. 17) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(2) = FN(N) C * ISS = 18: ELSE IF (ISS .EQ. 18) THEN GOTO 1020 C * ISS = 19: COORDINATION ELSE IF (ISS .EQ. 19) THEN GOTO 1010 C * ISS = 20: AWLSPL - CALCULATE (ATOM-WEIGHT) WEIGHTED L.S.-PLANES ELSE IF (ISS .EQ. 20) THEN IPR(41) = 1 C * ISS = 21: HBONDS ELSE IF (ISS .EQ. 21) THEN IPR(31) = -1 DO 840 K = 1, IPR(221) PAR(7 + K) = FN(K) 840 CONTINUE IPR(121) = 0 IF (IPR(77) .EQ. 1) THEN IPR(2) = 11 GOTO 1120 ENDIF IPR(77) = 1 C * ISS = 22: UWLSPL - LSPL - BASED ON UNIT WEIGHTS ELSE IF (ISS .EQ. 22) THEN IPR(41) = 0 C * ISS = 23: OUTPUT SHELX(L) INPUT-FILE (CALC SHELX(L) INSTRUCTION) ELSE IF (ISS .EQ. 23) THEN IF (EXTENS(1:3) .NE. 'res') THEN IGBL(31) = -2 ELSE WRITE (LU6, 99998) IPR(121) = 0 GOTO 10 ENDIF C * SET ROUND OFF IPR(68) = 0 WRITE (LU6, 99989) GOTO 870 C * ISS = 24: OUTPUT OMEGA INPUT-FILE (CALC OMEGA INSTRUCTION) ELSE IF (ISS .EQ. 24) THEN IF (IPR(438) .EQ. 0) IGBL(31) = 1 IF (IPR(220) .LT. 4) THEN IPR(6) = 1 IPR(7) = 1 IPR(8) = 1 ENDIF GOTO 870 C * ISS = 25: OUTPUT PS300-DGE FILE ELSE IF (ISS .EQ. 25) THEN IGBL(31) = 2 IPR(6) = 1 GOTO 870 C * ISS = 26: OUTPUT EUCLID-SPF - FILE (CALC EUCLID INSTRUCTION) ELSE IF (ISS .EQ. 26) THEN IGBL(31) = 3 C * SET ROUND OFF IPR(68) = 0 WRITE (LU6, 99989) GOTO 870 C * ISS = 27: FIVE COORDINATION ELSE IF (ISS .EQ. 27) THEN IPR(122) = 5 IF (N .LT. IPR(221)) THEN N = N + 1 PAR(35) = FN(N) ELSE PAR(35) = 0.0 ENDIF C * ISS = 28: CALC ALL ELSE IF (ISS .EQ. 28) THEN IPR(121) = 7 IPR(220) = 1 GOTO 820 C * ISS = 29: TOLP ELSE IF (ISS .EQ. 29) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(49) = FN(N) C * ISS = 30: TOLR ELSE IF (ISS .EQ. 30) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(3) = FN(N) C * ISS = 31: NOTHCOR (DELABS) ELSE IF (ISS .EQ. 31) THEN IPR(398) = 0 C * ISS = 32: VOID ELSE IF (ISS .EQ. 32) THEN GOTO 950 C * ISS = 33: PROBE RADIUS ELSE IF (ISS .EQ. 33) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(84) = FN(N) C * ISS = 34: PSTEP ELSE IF (ISS .EQ. 34) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 IPR(214) = NINT(FN(N)) C * ISS = 35: LIST ELSE IF (ISS .EQ. 35) THEN IPR(197) = 1 IF (NQ1(5:7) .NE. ' ') THEN IPR(185) = ICHAR(NQ1(5:5)) - ICHAR('W') IPR(186) = ICHAR(NQ1(6:6)) - ICHAR('W') IPR(187) = ICHAR(NQ1(7:7)) - ICHAR('W') ENDIF C * ISS = 36: SUBKEYWORD EXPAND ELSE IF (ISS .EQ. 36) THEN IPR(67) = 1 C * ISS = 37: CALC DIST ELSE IF (ISS .EQ. 37) THEN IPR(57) = -2 PAR(262) = 3.0 IPR(7) = 0 GOTO 1030 C * ISS = 38: TOLEA ELSE IF (ISS .EQ. 38) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(26) = FN(N) C * ISS = 39: MISS ELSE IF (ISS .EQ. 39) THEN GOTO 860 C * ISS = 40: SOLV ELSE IF (ISS .EQ. 40) THEN GOTO 940 C * ISS = 41: TOLM ELSE IF (ISS .EQ. 41) THEN N = N + 1 IF (N .GT. IPR(121)) GOTO 1060 PAR(27) = FN(N) C * ISS = 42: NODI ELSE IF (ISS .EQ. 42) THEN C * NOBO(ND)/NODI(ST) IPR(6) = 0 C * ISS = 43: BOND ELSE IF (ISS .EQ. 43) THEN IPR(6) = 1 C * ISS = 44: ANGLE ELSE IF (ISS .EQ. 44) THEN IPR(7) = 1 C * ISS = 45: TORS(ION) ELSE IF (ISS .EQ. 45) THEN IPR(8) = 1 C * ISS = 46: CSD-QUE ELSE IF (ISS .EQ. 46) THEN IGBL(31) = 4 GOTO 870 C * ISS = 47: SQUEEZE ELSE IF (ISS .EQ. 47) THEN IPR(210) = 1 IPR(326) = 1 IF (IPR(221) .EQ. 1) IPR(142) = NINT(FN(1)) IGBL(31) = 10 CALL PLA021 IPR(200) = 2 GOTO 960 C * ISS = 48: SAR ELSE IF (ISS .EQ. 48) THEN IPR(326) = 1 C * ISS = 49: CALC FCF ELSE IF (ISS .EQ. 49) THEN IPR(210) = - 1 IF (L .EQ. IPR(220)) GOTO 900 C * ISS = 50: DIFA ELSE IF (ISS .EQ. 50) THEN GOTO 890 C * ISS = 51: CALC NEWSYM ELSE IF (ISS .EQ. 51) THEN IPR(210) = - 3 IF (FN(1) .NE. 0.0) PAR(383) = FN(1) IGBL(31) = 5 CALL PLA021 GOTO 900 C * ISS = 52: NOCHECK (DELABS) ELSE IF (ISS .EQ. 52) THEN IPR(363) = 0 C * ISS = 53: OUTPUT PDB-FORMATTED FILE ELSE IF (ISS .EQ. 53) THEN IGBL(31) = 7 GOTO 870 C * ISS = 54: HINCL (TMA) ELSE IF (ISS .EQ. 54) THEN IPR(497) = 1 C * ISS = 55: NONSYM ELSE IF (ISS .EQ. 55) THEN IPR(495) = 3 IF (IPR(221) .GT. 0) PAR(73) = FN(1) IF (IPR(221) .GT. 1) PAR(75) = FN(2) CALL PLA015 (0, 39) GOTO 910 C * ISS = 56: NONA OPTION (HBONDS) ELSE IF (ISS .EQ. 56) THEN IPR(300) = 0 C * ISS = 57: MAXDEV ELSE IF (ISS .EQ. 57) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(76) = FN(N) C * ISS = 58: WLSP ELSE IF (ISS .EQ. 58) THEN C * (E)WLSPL - CALCULATE ESD-WEIGHTED PLANES IPR(41) = 2 C * ISS = 59: FCAL (SQUEEZE OPTION) ELSE IF (ISS .EQ. 59) THEN IPR(132) = 1 C * ISS = 60: ADDSYM ELSE IF (ISS .EQ. 60) THEN GOTO 860 C * ISS = 61: DELABS ELSE IF (ISS .EQ. 61) THEN GOTO 890 C * ISS = 62: NOSORT ATOMS OPTION ELSE IF (ISS .EQ. 62) THEN IGBL(33) = 0 C * ISS = 63: DISORDER (MINOR) INCLUDED ELSE IF (ISS .EQ. 63) THEN IPR(303) = 1 C * ISS = 64: GENERATE (HKL) ELSE IF (ISS .EQ. 64) THEN IPR(408) = 1 IF (IPR(210) .EQ. -1) GOTO 900 GOTO 880 C * ISS = 65: EXPE ELSE IF (ISS .EQ. 65) THEN IPR(408) = 2 GOTO 880 C * ISS = 66: MAXRING ELSE IF (ISS .EQ. 66) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 IPR(579) = NINT(FN(N)) C * ISS = 67: MOLSYM ELSE IF (ISS .EQ. 67) THEN IPR(495) = 2 IF (IPR(221) .GT. 0) PAR(73) = FN(1) IF (IPR(221) .GT. 1) PAR(75) = FN(2) GOTO 910 C * ISS = 68: RENUM KEYWORD ELSE IF (ISS .EQ. 68) THEN IPR(501) = 1 C * ISS = 69: SOLV PLOT ELSE IF (ISS .EQ. 69) THEN IPR(326) = 2 C * ISS = 70: CALC RDF ELSE IF (ISS .EQ. 70) THEN PAR(262) = PAR(450) IF (IPR(221) .GT. 0) THEN PAR(262) = FN(1) IF (IPR(221) .GT. 1) PAR(451) = FN(2) ENDIF GOTO 1015 C * ISS = 71: SOLV GRID ELSE IF (ISS .EQ. 71) THEN N = N + 1 IF (N .GT. IPR(221)) GOTO 1060 PAR(80) = FN(N) IPR(214) = 0 C * ISS = 72: SOLV F3D ELSE IF (ISS .EQ. 72) THEN IPR(326) = 3 C * ISS = 73: NOSF ELSE IF (ISS .EQ. 73) THEN IPR(595) = 1 ELSE GOTO 850 ENDIF GOTO 830 ENDIF 850 CONTINUE IF (IPR(210) .EQ. 0) THEN C * IF NOT A SUB-KEYWORD THEN ASSUME ELEMENT SYMBOL FOLLOWED BY RADIUS C * NOTE: INDIVIDUAL ATOM - RADIUS INTERPRETED IN PLA069 FOR IPR(17)=1 IF (IPR(31) .EQ. 1) THEN IF (IPR(221) .GT. 0) THEN N = N + 1 PAR(68) = FN(N) ELSE PAR(68) = PAR(7) ENDIF ENDIF CALL PLA037 (L, NID, 3) IF (IPR(31) .EQ. 0) IPR(156) = 1 IF (L .GT. 2) THEN IF (NID .GT. 0) THEN IF (IPR(31) .LT. 1) N = N + 1 IF (IPR(57) .LT. 0) THEN IPR(57) = - NID IF (N .EQ. IPR(221)) PAR(262) = FN(N) ELSE IF (N .GT. IPR(221)) THEN FNN = PAR(7) ELSE FNN = FN(N) ENDIF RADR(NID, 1) = FNN ENDIF ELSE IF (NID .EQ. 0 .AND. IPR(30) .NE. 0) THEN IF (IPR(31) .EQ. 1) THEN GOTO 10 ELSE IPR(2) = 18 GOTO 1120 ENDIF ENDIF ELSE IPR(2) = 18 GOTO 1120 ENDIF ENDIF GOTO 830 C * ADDSYM 860 IPR(121) = IPR(121) - 1 IPR(30) = 0 IF (IPR(37) .EQ. 0) GOTO 1120 IPR(205) = 1 CALL PLA089 C * ERROR TEST IF (IPR(2) .NE. 0) GOTO 1120 IF (IGBL(3) .EQ. 4) THEN IPR(1) = 3 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF GOTO 10 870 IF (IPR(438) .EQ. 0) THEN CALL PLA021 ENDIF GOTO 910 880 CALL PLA293 (PAR(17), 0) PAR(165) = ASIN (MIN(1.0, PAR(287) * PAR(17))) * GL(5) GOTO 830 C * CALC DELABS 890 IPR(210) = - 2 IF (IGBL(37) .EQ. 0) THEN IPR(2) = 56 GOTO 1120 ENDIF C * SHORT GEOMETRY CALCULATION (GEOM) 900 IF (IPR(220) .EQ. 2 .OR. 1 (IPR(220) .EQ. 3 .AND. IFL(3)(1:3) .EQ. 'NOM')) THEN IPR(6) = 1 CALL PLA015 (0, 39) IF (IPR(210) .NE. -2) THEN IPR(7) = 1 IPR(8) = 1 ENDIF ENDIF 910 IF (IPR(30) .NE. 0) THEN IPR(2) = 31 GOTO 1120 ENDIF IPR(31) = 0 IPR(121) = 0 GOTO 830 C * CALC INTRA (UNIQUE MOLECULE CALCULATION) 920 IPR(31) = 0 IPR(430) = -1 IF (IPR(30) .NE. 0) THEN IPR(2) = 31 GOTO 1120 ENDIF DO 930 K = 5, 11 IPR(K) = 1 930 CONTINUE IPR(495) = 1 IPR(121) = IPR(121) - 1 C * SET FOR CALC INTRA AS LAST INSTRUCTION IF (IPR(121) .EQ. 0) IPR(136) = 1 CALL PLA015 (0, 39) GOTO 830 C * SOLV 940 IPR(200) = 2 GOTO 960 C * VOID 950 IPR(200) = 1 960 IF (IPR(23) .EQ. 1) THEN IPR(2) = 33 GOTO 1120 ENDIF DO 970 K = 5, 10 IPR(K) = 0 970 CONTINUE GOTO 1000 C * CALC INTER 980 IPR(200) = 0 IPR(104) = 0 DO 990 K = 5, 10 IPR(K) = 0 990 CONTINUE IF (IPR(77) .EQ. 1) THEN IPR(2) = 11 GOTO 1120 ENDIF IPR(77) = 1 1000 IPR(31) = -1 IPR(90) = 1 IPR(121) = IPR(121) - 1 GOTO 830 C * CALC METAL 1010 IF (IPR(155) .GT. 0) THEN IPR(57) = 1 PAR(262) = 5.0 IPR(170) = 0 IPR(5) = 0 IPR(6) = 1 IPR(7) = 0 IPR(8) = 0 IPR(9) = 0 IPR(10) = 0 CALL PLA015 (0, 39) GOTO 1030 ELSE IPR(121) = IPR(121) - 1 GOTO 10 ENDIF C * CALC RDF 1015 IPR(57) = 2 IPR(170) = 0 CALL PLA065 (0, 0) CALL PLA015 (0, 39) GOTO 1030 C * CALC COORDN 1020 IPR(5) = 0 IPR(6) = 1 IPR(7) = 16 IPR(8) = 0 IPR(9) = 0 IPR(10) = 0 IPR(1) = 6 IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0) 1 CALL PLA096 (0, ' ', -1.0, PAR(454)) IF (IPR(30) .EQ. 0) THEN DO 1025 I = 1, 16 SAV(I) = FN(I) 1025 CONTINUE CALL PLA069 DO 1026 I = 1, 16 FN(I) = SAV(I) 1026 CONTINUE ENDIF 1030 IPR(31) = 1 IF (IPR(221) .EQ. 1) THEN IF ((IPR(220) .EQ. 3 .AND. IFL(3)(1:3) .EQ. 'NOA') .OR. 1 IPR(220) .EQ. 2) THEN IF (IPR(57) .EQ. 1) IPR(170) = 1 PAR(262) = FN(1) ENDIF ENDIF IPR(121) = IPR(121) - 1 IPR(122) = 0 CALL PLA015 (0, 39) GOTO 830 C * CALC CARD HANDLING 1040 IF (IPR(39) .GT. 0) THEN GOTO 1130 ELSE C * MESSAGES WRITE (LU6, 99992) GOTO 1090 ENDIF 1050 IF (IPR(30) .EQ. 0) THEN CALL PLA280 (ICL) IGBL(52) = MAX (IGBL(52), IPR(23)) CALL PLA069 CALL PLA073 (1) IF (IPR(85) .EQ. 0) THEN IPR(5) = 0 CALL PLA029 ENDIF GOTO 10 ENDIF CALL PLA288 (MODE) GOTO 10 C * NOT ENOUGH DATA ON CARD 1060 IPR(2) = 5 GOTO 1120 C * SAVE THIS INSTRUCTION 1070 IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN WRITE (LU3, 99984) ICL(1:80) IGBL(45) = IGBL(45) + 1 WRITE (LU6, 99973) ICL(1:70) ENDIF GOTO 10 C * HANDLE END-OF-FILE 1080 IF (IGBL(5) .EQ. LU5) THEN GOTO 1090 ELSE IF (IGBL(5) .EQ. LU3) THEN IGBL(5) = LU5 C * OPEN MAIN X-WINDOW IGBL(23) = 10 IGBL(24) = 1 GOTO 10 ELSE IF (IPR(37) .EQ. 0 .AND. IPR(367) .EQ. 0 .AND. 1 PAR(101) .EQ. 0.0) GOTO 1120 IF (IPR(3) .EQ. 1) THEN IPR(3) = -1 GOTO 1120 ELSE IGBL(5) = LU3 ENDIF ENDIF CALL GEN108 (LU3, 0) GOTO 10 C * HANDLE END-CARD 1090 IF (IGBL(5) .EQ. LU5) THEN IF (IABS(IGBL(45)) .GT. 1) THEN C * WRITE END CARD TO SAVE-FILE WRITE (LU3, 99984) ICL(1:80) WRITE (LU6, 99973) ICL(1:70) IGBL(45) = -1 CALL GEN108 (LU3, 0) ENDIF GOTO 1120 ENDIF C * TREAT END-CARD AS END-OF-FILE FOR SHELX-INPUT ON LU1 C * BUT IGNORE WHEN Q-PEAKS ARE REQUESTED IF (IGBL(5) .EQ. LU1 .AND. IABS(IGBL(8)) .EQ. 2) THEN IF (IGBL(95) .EQ. 0) THEN IGBL(5) = LU3 CALL GEN108 (LU3, 0) ENDIF GOTO 10 ENDIF IF (IPR(3) .EQ. 0) GOTO 1120 IPR(2) = 0 IGBL(5) = LU1 IGBL(8) = IABS(IGBL(8)) C * GIVE SUMMARY IPR(1) = 3 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 C * STOP/QUIT/EXIT - NO FULL END PROCESSING 1100 WRITE (LU6, 99999) IGBL(49), NAME(1)(1 : KNM(1)) GOTO 1260 C * UNSUITABLE ATOM LABEL ERROR 1110 IPR(2) = 3 C * ERROR HANDLING 1120 IPR(1) = 1 IPR(121) = 0 1130 IF (IPR(1) .EQ. 2) THEN CALL PLA069 C * ERROR TEST IF (IPR(2) .NE. 0) GOTO 1250 C * PRINT COORDINATES CALL PLA073 (1) IF (IPR(2) .NE. 0) GOTO 1250 C * CHECK BONDS ETC IN CIF IF (IABS(IGBL(8)) .EQ. 3) CALL PLA296 GOTO 1140 ELSE IF (IPR(1) .EQ. 5) THEN GOTO 1170 ELSE IF (IPR(1) .EQ. 6) THEN GOTO 1140 ELSE IF (IPR(1) .EQ. 7) THEN GOTO 1190 ELSE IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF C * CALC INTRA MODE 1140 IF (IPR(31) .EQ. 0) THEN IF (IPR(495) .LE. 1) THEN C * HANDLE DISPLACEMENT PARAMETERS CALL PLA029 IF (IGBL(3) .EQ. 23 .OR. IGBL(3) .EQ. 24 .OR. 1 IGBL(3) .EQ. 27) THEN IPR(1) = 3 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ELSE IF (IGBL(3) .EQ. 25) THEN CALL PLA292 (LU6, LU16, LU17, IGBL(29), IPR(384)) GOTO 1260 ELSE IF (IPR(504) .EQ. 1) THEN CALL PLUTON (1) GOTO 1220 ENDIF C * OUTPUT CONNECTION TABLES IPR(18) = -2 CALL PLA073 (0) IF (IPR(2) .NE. 0) GOTO 1250 IF (IGBL(3) .EQ. 11) THEN IPR(1) = 3 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF IF (IPR(14) .NE. 6) THEN C * LIST INTRA GEOMETRY CALL PLA076 C * GENERATE RINGS AND PLANES CALL PLA077 IF (IPR(2) .NE. 0) GOTO 1250 C * LIST LEAST-SQUARES PLANES CALL PLA074 C * RING PUCKERING ANALYSIS CALL PLA075 C * FCF/DELABS/NEWSYM IF (IPR(210) .LT. 0) THEN IF (IPR(493) .EQ. 0) THEN IF (IPR(210) .EQ. -3) THEN IPR(493) = 2 ELSE IPR(2) = 47 GOTO 1250 ENDIF ENDIF IF (IPR(498) .GT. 0) THEN IPR(2) = 45 GOTO 1250 ENDIF IF (IPR(210) .EQ. -3) THEN CALL PLA160 (2, TM1) ELSE CALL PLA179 ENDIF IPR(1) = 1 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF ENDIF ENDIF ENDIF C * CALC INTER, VOID, SQUEEZE, NEWSYM AND COORDINATION MODE ELSE IPR(17) = IPR(31) IPR(189) = IPR(200) CALL PLA069 IF (IPR(2) .NE. 0) GOTO 1250 IF (IPR(57) .EQ. 2) THEN CALL PLA065 (-1, 0) GOTO 1240 ENDIF IF (IGBL(3) .EQ. 9) THEN IPR(1) = 3 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF IF (IGBL(3) .EQ. 5 .AND. IPR(210) .EQ. 0) THEN IF (IGBL(31) .NE. 0) THEN CLOSE (LU2, ERR = 1160) 1160 IGBL(31) = 0 ENDIF IPR(1) = 3 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF IF (IGBL(3) .EQ. 36) THEN IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF IF (IPR(210) .EQ. 1) THEN IF (IPR(498) .EQ. 0) THEN CALL PLA029 CALL PLA129 IPR(1) = 1 ELSE IPR(2) = 45 ENDIF IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF GOTO 1200 ENDIF C * EXECUTE PLOT OPTION 1170 IF (IPR(14) .LT. 0) THEN C * NEWMAN, RING, PLAN, LSPL, RESD PLOT CALL GEN108 (LU8, 0) CALL PLA101 ELSE IF (IPR(14) .EQ. 4) THEN C * DISPLACEMENT MOTION ELLIPSOID-PLOT IF (IPR(85) .EQ. 0) THEN IPR(5) = 0 CALL PLA029 ENDIF IF (IPR(140) .GT. IPR(75)) THEN IPR(2) = 13 GOTO 1250 ENDIF IF (IPR(460) .LT. 3) THEN IGBL(23) = 9 LMOD = 1 IFL(1) = 'LSPL' CALL PLA015 (476, 1) IPR(453) = 0 IPR(448) = 0 ENDIF IF (IPR(341) .EQ. 5) THEN IGBL(23) = 9 ENDIF IF (IPR(551) .LT. 3) THEN IGBL(23) = 9 LMOD = 1 IFL(1) = 'LSPL' IPR(551) = 1 CALL PLA015 (552, 1) IPR(453) = 0 IPR(448) = 0 ENDIF CALL PLA106 IF (IPR(2) .NE. 0) GOTO 1250 ELSE IF (IPR(14) .EQ. 5) THEN MNH(6) = 1 CALL PLA103 ELSE IF (IPR(14) .EQ. 6) THEN IF (IPR(85) .EQ. 0) THEN IPR(5) = 0 CALL PLA029 ENDIF GOTO 1180 ENDIF IF (IPR(430) .GT. 0) THEN IGBL(92) = MAX (IGBL(92), IPR(430)) IGBL(93) = MAX (IGBL(93), IPR(431)) IPR(31) = -1 IPR(17) = -1 IPR(90) = 1 IGBL(63) = 0 CALL PLA069 CALL PLA172 IPR(1) = 1 IF (IPR(2) .EQ. 0) IPR(2) = -1 GOTO 1250 ENDIF GOTO 1200 C * CALLS TO PLUTON 1180 IF (IGBL(3) .NE. 8 .AND. IGBL(3) .NE. 12 .AND. 1 IGBL(3) .NE. 13 .AND. IGBL(3) .NE. 26) THEN CALL PLUTON (1) GOTO 1220 ELSE C * EXPLICIT PLUTON/RENAME/HFIX/ANIS CALL PLUTON (-1) GOTO 1260 ENDIF C * EXECUTE LIST ON DISPLAY OPTIONS 1190 IF (IPR(30) .EQ. 0) THEN CALL PLA069 IF (IPR(2) .NE. 0) GOTO 1250 IF (IPR(205) .NE. 0) GOTO 1240 CALL PLA073 (-1) IF (IPR(2) .NE. 0) GOTO 1250 ENDIF IPR(18) = IPR(84) IF (IPR(1) .EQ. 4) THEN CALL PLA073 (-1) IF (IPR(2) .NE. 0) THEN GOTO 1250 ENDIF ELSE IF (IPR(1) .EQ. 7) THEN C * INTERACTIVE DIST, ANGLE, TORSION AND LSPL CALCULATION CALL PLA035 (1) ENDIF IF (IGBL(3) .EQ. 41) THEN IPR(2) = -1 GOTO 1250 ELSE GOTO 1240 ENDIF 1200 TIMT = TIMEA TIMEA = CPUTIM() WRITE (LU6, 99948) TIMEA - TIMT, TIMEA - TIMEZ GOTO 1240 1210 IGBL(1) = -1 RETURN 1220 IGBL(1) = 0 RETURN 1230 IGBL(1) = 1 RETURN 1240 IGBL(1) = 2 RETURN 1250 IGBL(1) = 3 RETURN 1260 IGBL(1) = 4 RETURN 99999 FORMAT (':: Escape EXIT from PLATON - ', I4, ' Pages', 1 ' on FILES ', A, '.lis', /) 99998 FORMAT ('!! Error: Input and Output have the same .res') 99997 FORMAT ('!! Error: Input and Output have the same .acc') 99996 FORMAT (A, 1X, 4(4X, F10.2)) 99995 FORMAT (':: Data Set ', A, /) 99994 FORMAT (/, ':: Old/Current Label Size =', F5.2) 99993 FORMAT ( ':: New Label Size =', F5.2, /) 99992 FORMAT (':: No ATOMS supplied as yet') 99991 FORMAT ('CELL ', 3F10.4, 3F10.2, A) 99990 FORMAT (':: Rounding Range 1 :', I3) 99989 FORMAT (':: Rounding set to OFF') 99988 FORMAT ('** ', A) 99987 FORMAT (':: LSPL/RING/FIT/LINE calculation will be included in ', 1 'next CALC GEOM/INTRA run', /) 99986 FORMAT (':: Unrecognised keyword or label (ignored): ', A, /) 99985 FORMAT (':: Transformation on input data with Det =', F5.2, /) 99984 FORMAT (A) 99983 FORMAT (':: AUTO EXEC: Calc Intra',/) 99982 FORMAT (':: Automatic join instruction',/) 99981 FORMAT (A, 1X, 3F8.4, 3X, F8.4, F10.2) 99980 FORMAT ('Atom', 8X , 'U1', 6X, 'U2', 6X, 'U3', 8X, 'U(eq)', 1 5X, 'U3/U1') 99979 FORMAT (':: No more than', I3, ' Atom Types allowed', 1 ' on DOAC card', /) 99978 FORMAT (':: No more than', I3, ' Atom Types allowed', 1 ' on (IN/EX)CLUDE card', /) 99977 FORMAT (':: Bond Type/code = #Lines Bond Radius (Ang)') 99976 FORMAT (':: Normal ', I5, I9, 9X, F6.2) 99975 FORMAT (':: To H ', I5, I9, 9X, F6.2) 99974 FORMAT (':: To Metal ', I5, I9, 9X, F6.2) 99973 FORMAT (':: Saved: ', A) 99972 FORMAT (':: Transformation for x,y,z coordinates', /, 1 ':: (', 3F8.4, ') (x) ', F10.4, /, 1 ':: (', 3F8.4, ') (y) +', F10.4, /, 1 ':: (', 3F8.4, ') (z) ', F10.4, /) 99971 FORMAT (2A) 99970 FORMAT (6F10.4) 99969 FORMAT (A, 4F10.5) 99968 FORMAT ('END', /, 'END') 99967 FORMAT (//, 'Generated INPUT for Structure Tidy on: ', A, /) 99966 FORMAT (I4, 1X, A, I4, 5I2, 2I3, 5I2, I3, I2, I3, 3I2, I5, I2) 99965 FORMAT ('Atom Label DFN A S P H C R T M P D A A H O P', 1 ' U L N') 99964 FORMAT (/, ':: AtomType EllipsoidType NumberOfShadeLines', //, 1 ':: C ', I10, 10X, I10, /, 2 ':: H ', I10, 10X, I10, /, 3 ':: Other ', I10, 10X, I10, //, 4 'Note: Ellipsoid types: 0 = Principle Ellipsoids, ', 5 ' 1 = Envelope Type', /) 99963 FORMAT (/, ':: Volume From ORMA =', F10.1, ', Please Check') 99962 FORMAT (/, 'W: No SU''s on parameters supplied on input', /) 99961 FORMAT ('>> RESTART <<') 99960 FORMAT (':: SHELXL HKLF Matrix:', 9F6.2, /) 99959 FORMAT (':: Coord. Cell:', 3F10.3, 3F10.2, /, 1 ':: Refln. Cell:', 3F10.3, 3F10.2, /) 99958 FORMAT (':: SPGR P1 Substituted', /) 99957 FORMAT ('data_', A) 99955 FORMAT ('INTRA BONDS for Dist(I-J) < RC(I) + RC(J)', 1 ' + TOLA + (TOLEA/TOLCUO)') 99954 FORMAT ('INTER CONTACTS for Dist(I-J) < RW(I) + RW(J) + TOLR') 99953 FORMAT ('TOLA [=PAR(2)] = ', F5.2, 1 ' Ang., current INTRA tolerance') 99952 FORMAT ('TOLCUO [=PAR(5)] = ', F5.2, 1 ' Ang., add for (Cu...O,N) Contacts') 99951 FORMAT ('TOLEA [=PAR(26)] = ', F5.2, 1 ' Ang., add for (Earth)Alkali- non-metal contacts') 99950 FORMAT ('TOLR [=PAR(3)] = ', F5.2, 1 ' Ang., current INTER tolerance') 99949 FORMAT ('Element Covalent(RC) van der Waals(RW) Current') 99948 FORMAT (/, ':: CPU-time:', F8.1, ' (Total:', F8.1, ')') 99947 FORMAT (A, 2F10.0, 2A) 99946 FORMAT (/, ':: ', A) 99945 FORMAT (':: ', A) 99944 FORMAT (/, ':: Det TM = ', F10.2) 99943 FORMAT (A, 2F10.4) 99942 FORMAT (A, 2F10.0, A) 99941 FORMAT ('N') END SUBROUTINE PLA003 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 IGBL(1) = 4 IF (IGBL(63) .GT. 0) THEN LU = LU7 ELSE LU = LU6 ENDIF IR = IPR(2) 10 IF (IR .GT. 0) THEN C * 1: ATTEMPT TO EXCEED MAX ATOM LIMIT IF (IR .EQ. 1) THEN WRITE (LU, 99984) NP1 GOTO 30 C * 2: LABEL PREOCCURRED ELSE IF (IR .EQ. 2) THEN WRITE (LU, 99977) NQ1 C * 3: UNSUITABLE ATOM LABEL ELSE IF (IR .EQ. 3) THEN WRITE (LU, 99978) NQ1 WRITE (LU20, 99854) '_071', 1.0, 1.0, NQ1, NQ1 IF (IGBL(3) .EQ. 1) THEN GOTO 90 ELSE GOTO 30 ENDIF C * 4: LABEL INCONSISTENT ELSE IF (IR .EQ. 4) THEN WRITE (LU, 99983) IFL(2), NQ4 C * 5: NOT ENOUGH DATA ON CARD ELSE IF (IR .EQ. 5) THEN IF (LU .EQ. LU6) THEN WRITE (LU, 99982) ICL(1:76) CALL PLA015 (0, 49) IF (IPR(470) .EQ. 1) WRITE (LU, 99961) ENDIF C * 6: INVALID ELEMENT SYMBOL ELSE IF (IR .EQ. 6) THEN WRITE (LU, 99981) NQ1(1:3) C * 7: UNKNOWN CARD ERROR ELSE IF (IR .EQ. 7) THEN IF (LU .EQ. LU6) WRITE (LU, 99992) ICL(1:30) C * 8: TOO MANY ATOMS SPECIFIED ELSE IF (IR .EQ. 8) THEN WRITE (LU, 99976) NP1 C * 9: FVAR ERROR (SHELX INPUT STYLE) ELSE IF (IR .EQ. 9) THEN WRITE (LU, 99975) GOTO 30 C * 10: POPULATION PARAMETER OVERFLOW ELSE IF (IR .EQ. 10) THEN WRITE (LU, 99974) GOTO 30 C * 11: INSTRUCTION NOT ALLOWED ELSE IF (IR .EQ. 11) THEN WRITE (LU, 99972) IFL(1) C * 12: PLOT INSTRUCTION NOT ALLOWED HERE ELSE IF (IR .EQ. 12) THEN IF (LU .EQ. LU6) WRITE (LU, 99970) C * 13: SPECIFIED RESIDUE NUMBER NOT PRESENT ELSE IF (IR .EQ. 13) THEN IF (LU .EQ. LU6) WRITE (LU, 99960) IPR(140) C * 14: ELSE IF (IR .EQ. 14) THEN C * 15: TRNS (FIX) INSTRUCTION N.O.K. ELSE IF (IR .EQ. 15) THEN IF (LU .EQ. LU6) WRITE (LU, 99957) C * 16: INVALID ELEMENT SYMBOL ELSE IF (IR .EQ. 16) THEN WRITE (LU, 99981) NQ3(1:3) C * 17: TRANSLATION CODE OUT-OF-RANGE ELSE IF (IR .EQ. 17) THEN WRITE (LU, 99947) (ITR(I), I = 1, 3), NQ1 GOTO 30 C * 18: INVALID SUB-KEYWORD or ATOM NAME/TYPE ELSE IF (IR .EQ. 18) THEN IF (LU .EQ. LU6) WRITE (LU, 99949) C * 19: VOID ARRAY OVERFLOW ELSE IF (IR .EQ. 19) THEN IF (LU .EQ. LU6) WRITE (LU, 99946) NPVD C * 20: ELSE IF (IR .EQ. 20) THEN C * 21: ELSE IF (IR .EQ. 21) THEN C * 22: NOT ENOUGH OVERLAP MEMORY ELSE IF (IR .EQ. 22) THEN IF (LU .EQ. LU6) WRITE (LU, 99943) C * 23: TOO MANY AXES (ADDSYM) CONDITION ELSE IF (IR .EQ. 23) THEN WRITE (LU, 99942) PAR(43) C * 24: TOO MANY SOLVENT AREAS ELSE IF (IR .EQ. 24) THEN WRITE (LU, 99940) C * 25: LMX/PLA091 ERROR ELSE IF (IR .EQ. 25) THEN WRITE (LU, 99939) GOTO 30 C * 26: OVERFLOW IN VOID-ROUTINE (NP1) ELSE IF (IR .EQ. 26) THEN WRITE (LU, 99938) C * 27: SYMM/TRNS ERROR ELSE IF (IR .EQ. 27) THEN WRITE (LU, 99937) C * 28: ARU-OUT OFF RANGE ELSE IF (IR .EQ. 28) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99854) '_804', 1, 1 IF (IGBL(36) .NE. 0) CALL PLA230 (0) GOTO 80 ELSE WRITE (LU, 99935) ENDIF C * 29: TMA-CALCULATION OUT-OF-SEQUENCE ELSE IF (IR .EQ. 29) THEN WRITE (LU, 99934) C * 30: TOO MANY FVAR-PARAMETERS ELSE IF (IR .EQ. 30) THEN WRITE (LU, 99932) GOTO 30 C * 31: ELSE IF (IR .EQ. 31) THEN WRITE (LU, 99931) C * 32: NON-RECOVERABLE PROBLEM ELSE IF (IR .EQ. 32) THEN WRITE (LU, 99929) IPR(323) IF (LU .NE. LU6) WRITE (LU6, 99929) IPR(323) GOTO 80 C * 33: CALC SOLV/VOID NOT ALLOWED IN ANGSTROM MODE ELSE IF (IR .EQ. 33) THEN WRITE (LU, 99928) C * 34: FACE DIST .LT. 0 ELSE IF (IR .EQ. 34) THEN WRITE (LU, 99923) C * 35: NO MU-PROVIDED FOR ABSGAUSS or ABSTOMPA ELSE IF (IR .EQ. 35) THEN WRITE (LU, 99921) GOTO 30 C * 36: UNKNOWN ELEMENT TYPE ON SFAC LINE ELSE IF (IR .EQ. 36) THEN WRITE (LU, 99920) GOTO 30 C * 37: NO VALID DIRCOS ELSE IF (IR .EQ. 37) THEN WRITE (LU, 99916) GOTO 30 C * 38: NO VALID PSI-SCAN DATA ELSE IF (IR .EQ. 38) THEN WRITE (LU, 99915) GOTO 30 C * 39: No Refl Supplied ELSE IF (IR .EQ. 39) THEN WRITE (LU, 99914) GOTO 30 C * 40: NO TRMX WITH NEG DET ON HKLF ELSE IF (IR .EQ. 40) THEN WRITE (LU, 99913) GOTO 30 C * 41: UNKNOWN ELEMENT ON SFAC ELSE IF (IR .EQ. 41) THEN WRITE (LU, 99912) GOTO 30 C * 42: NO VALID ATOMS ELSE IF (IR .EQ. 42) THEN WRITE (LU, 99911) GOTO 30 C * 43: NO .hkl or .fcf ELSE IF (IR .EQ. 43) THEN WRITE (LU, 99910) NAME(4)(1:KNM(4)), NAME(7)(1:KNM(7)) GOTO 30 C * 44: NO .hkl file given ELSE IF (IR .EQ. 44) THEN WRITE (LU, 99909) NAME(4)(1:KNM(4)) GOTO 30 C * 45: SOMETHING WRONG WITH U/UIJ ELSE IF (IR .EQ. 45) THEN WRITE (LU, 99907) IPR(498) GOTO 30 C * 46: NO-SFAC PROBLEM ELSE IF (IR .EQ. 46) THEN WRITE (LU, 99906) NQ1 GOTO 30 C * 47: NO LAMBDA GIVEN ELSE IF (IR .EQ. 47) THEN WRITE (LU, 99904) MAX (0.0, PAR(17)) C * 48: VOID TOO-LARGE ELSE IF (IR .EQ. 48) THEN WRITE (LU, 99901) C * 49: SCRATCH OVERRUN IN EXOR/FMAP ELSE IF (IR .EQ. 49) THEN WRITE (LU, 99900) NP1 GOTO 30 C * 50: INCOMPLETE UIJ(SUIJ) DATA ON CIF ELSE IF (IR .EQ. 50) THEN WRITE (6, 99898) IFL(2) WRITE (LU20, 99851) '_806', 1, 1 GOTO 20 C * 51: INCOMPLETE ATOM DATA ON CIF ELSE IF (IR .EQ. 51) THEN WRITE (6, 99896) IFL(2) WRITE (LU20, 99851) '_805', 1, 1 GOTO 20 C * 52: ELSE IF (IR .EQ. 52) THEN WRITE (LU, 99895) GOTO 30 C * 53: ELSE IF (IR .EQ. 53) THEN WRITE (LU, 99894) GOTO 30 C * 54: SYMM-LABEL PACK PROBLEM ELSE IF (IR .EQ. 54) THEN WRITE (LU, 99892) C * 55: NO REFLECTION DATA PROBLEM ELSE IF (IR .EQ. 55) THEN WRITE (LU, 99891) C * 56: NO DIR-COS ELSE IF (IR .EQ. 56) THEN WRITE (6, 99888) GOTO 20 C * 57: LABEL ALIAS OVERFLOW ELSE IF (IR .EQ. 57) THEN WRITE (LU, 99885) IF (IGBL(61) .EQ. 0 .AND. IPR(30) .EQ. 0) THEN IGBL(61) = 1 CALL PLA281 (1) CALL GEN108 (LU20, 0) IPR(2) = 0 GOTO 80 ENDIF WRITE (LU20, 99854) '_071', 1.0, 1.0, NQ1, NQ1 C * 58: CELL PROBLEM ELSE IF (IR .EQ. 58) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99854) '_801', 1.0, 1.0 GOTO 90 ELSE WRITE (6, 99848) ENDIF GOTO 80 C * 59: CIF-LINE TOO LONG ELSE IF (IR .EQ. 59) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99854) '_802', 1.0, 1.0 GOTO 90 ELSE WRITE (6, 99847) ENDIF GOTO 80 C * 60: CIF-LOOP PROBLEM ELSE IF (IR .EQ. 60) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99854) '_803', 1.0, 1.0 GOTO 90 ELSE WRITE (6, 99846) ENDIF GOTO 80 C * 61: READ/FORMAT ERROR ELSE IF (IR .EQ. 61) THEN WRITE (6, 99853) GOTO 20 C * 62: NSP-Problem ELSE IF (IR .EQ. 62) THEN WRITE (LU6, 99852) GOTO 30 C * 63: TRNS/TRMX PROBLEM ELSE IF (IR .EQ. 63) THEN WRITE (LU6, 99850) GOTO 20 C * 64: DATA FORMAT NOT RECOGNISED ELSE IF (IR .EQ. 64) THEN WRITE (LU, 99849) ENDIF C * NON-FATAL ERROR IF (LU .EQ. LU7) GOTO 50 IPR(2) = 0 CALL GEN038 (IGGT, 1, 80) IGBL(23) = 10 IGBL(24) = 1 IF (LU .EQ. LU6) WRITE (LU, 99980) CHAR(IPR(223)) GOTO 40 C * FATAL ERROR (EXECUTE EXIT STATEMENT) 20 FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT) KNMXT = KNM(3) + KXT + 1 WRITE (6, 99897) FNLU1(1:KNMXT) STOP C * FATAL ERROR (EXECUTE END STATEMENT) 30 IF (LU .EQ. LU7) GOTO 50 IPR(2) = 0 WRITE (LU, 99979) IF (IGBL(54) .LT. IGBL(100)) THEN IGBL(54) = IGBL(54) + 1 FN(1) = IGBL(54) IPR(220) = 1 IPR(221) = 1 CALL PLA011 IGBL(5) = LU5 IGBL(1) = 1 IPR(121) = 0 GOTO 80 ENDIF ENDIF 40 IF (IR .NE. 0) THEN IF (LU .EQ. LU7 .OR. IGBL(63) .EQ. 0) THEN IUCR = IABS(IGBL(8) * IGBL(19) * IPR(30)) IF (IUCR .EQ. 3 .OR. IUCR .EQ. 4) THEN IF (IGBL(36) .NE. 0) CALL PLA230 (0) ENDIF ENDIF PAGET = 'SUMMARY ' IF (LU .EQ. LU7 .AND. IGBL(63) .GT. 3 .AND. 1 IGBL(7) .EQ. 1) THEN IF (IR .LE. 0 .AND. IPR(3) .LE. 0) THEN IF (IABS(IGBL(8)) .EQ. 3) CALL PLA173 (0, LU, 1, 1) CALL PLA269 (0) WRITE (LU, 99962) ENDIF ENDIF IF (IPR(3) .GE. 0 .AND. IPR(37) .GT. 0) THEN IF (LU .EQ. LU7) THEN CALL PLA269 (0) CALL PLA269 (-999) ENDIF WRITE (LU, 99991) IF (IPR(23) .EQ. 0) THEN IF (PAR(17) .LT. 0.001) WRITE (LU, 99999) IF (PAR(107) .LT. 0.00001) WRITE (LU, 99998) IF (IGBL(30) .EQ. 1) WRITE (LU, 99997) IF (IGBL(52) .EQ. 1) WRITE (LU, 99996) ENDIF IF (IPR(129) .LT. 10) WRITE (LU, 99948) IF (IPR(209) .NE. 0) WRITE (LU, 99951) IF (IPR(118) .NE. 0) WRITE (LU, 99925) IF (IPR(459) .NE. 0) WRITE (LU, 99903) IF (IPR(72) .EQ. 0) WRITE (LU, 99956) IF (IPR(130) .EQ. 1) WRITE (LU, 99995) IF (IPR(124) .NE. 0) WRITE (LU, 99886) IF (IGBL(8) .EQ. 2) WRITE (LU, 99973) IF (IPR(23) .EQ. 0 .AND. IPR(202) .EQ. 0) WRITE (LU, 99950) IF (PAR(42) .LT. 100.0) WRITE (LU, 99927) IF (IPR(44) .EQ. 1) WRITE (LU, 99988) IF (IPR(215) .GT. 0) WRITE (LU, 99952) IF (IPR(23) .EQ. 0 .AND. IPR(484) .EQ. 0) WRITE (LU, 99933) WRITE (LU, 99890) IF (IPR(153) .GT. 0) WRITE (LU, 99959) IPR(153) IF (IPR(161) .GT. 0) WRITE (LU, 99889) IPR(161) IF (IPR(160) .GT. 0) 1 WRITE (LU, 99958) IPR(160), PAR(199), PAR(200) IF (IPR(403) .GT. 0) THEN WRITE (LU, 99924) IPR(403), PAR(251), PAR(252) ENDIF IF (IPR(404) .GT. 0) THEN WRITE (LU, 99918) IPR(404), PAR(253), PAR(254) ENDIF IF (IABS(IGBL(8)) .NE. 4) THEN IF (IPR(489) + IPR(490) .GT. 0) THEN WRITE (LU, 99930) IPR(489) + IPR(490) ENDIF ENDIF IF (IPR(50) .GT. 0) WRITE (LU, 99966) IPR(50) IF (IPR(204) .GT. 0) WRITE (LU, 99965) IPR(204) IF (IPR(498) .GT. 0) WRITE (LU, 99907) IPR(498) IF (PAR(387) .LT. 1.0) WRITE (LU, 99887) PAR(387) IF (IPR(93) .EQ. 1) 1 WRITE (LU, 99990) ((TM1(I, J), J = 1, 3), I = 1, 3) IF (IPR(139) .EQ. 1) WRITE (LU, 99968) (SHFT(I), I = 1, 3) IF (IPR(100) .GT. 0) WRITE (LU, 99989) IPR(100) IF (IPR(101) .GT. 0) WRITE (LU, 99987) IPR(101) IF (IPR(171) .GT. 0) THEN IF (IABS(IGBL(8)) .NE. 4) 1 WRITE (LU, 99963) PAR(30), IPR(171) ENDIF IF (IPR(172) .GT. 0) THEN IF (IABS(IGBL(8)) .NE. 4) 1 WRITE (LU, 99754) PAR(30), IPR(172) ENDIF IF (IPR(102) .GT. 0) WRITE (LU, 99986) IPR(102) IF (IPR(103) .GT. 0) WRITE (LU, 99985) IPR(103) IF (IPR(401) .GT. 0) WRITE (LU, 99922) IPR(401) IF (IPR(402) .GT. 0) WRITE (LU, 99919) IPR(402) IF (IPR(471) .NE. 0) WRITE (LU, 99993) IPR(471), IPR(472) IF (IGBL(71) .NE. 0) WRITE (LU, 99994) IGBL(71) IF (IPR(135) .GT. 0) WRITE (LU, 99971) IPR(135) IF (IPR(138) .GT. 0) WRITE (LU, 99969) IPR(138) IF (PAR(150) .GT. 0) WRITE (LU, 99941) PAR(150) IF (PAR(149) .GT. 0) WRITE (LU, 99926) NINT(PAR(149)) IF (IPR(126) .GT. 0) WRITE (LU, 99899) IPR(126) IF (IPR(429) .GT. 0) WRITE (LU, 99893) IPR(429) IF (IPR(405) .GT. 0) WRITE (LU, 99917) IPR(405) IF (IPR(149) .GT. 0) WRITE (LU, 99967) IPR(149) IF (IPR(494) .GT. 0) WRITE (LU, 99902) IPR(494) WRITE (LU, 99953) ENDIF IF (IGBL(63) .GT. 0 .AND. IGBL(7) .EQ. 1) THEN FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT) KNMXT = KNM(3) + KXT + 1 IF (FNLU1(1:5) .NE. 'zz123' .AND. IGBL(8) .NE. 0) 1 WRITE (LU, 99905) FNLU1(1:KNMXT), DTYPE(IABS(IGBL(8))) NPAGE = IGBL(49) IF (IPR(2) .LT. 0) THEN IGBL(67) = 0 IF (IGBL(70) .EQ. 1) THEN WRITE (LU, 99955) NPAGE, NAME(1)(1 : KNM(1)), 1 NAME(1)(1 : KNM(1)) ELSE WRITE (LU, 99855) NPAGE, NAME(1)(1 : KNM(1)) ENDIF ELSE WRITE (LU, 99954) NPAGE, NAME(1)(1 : KNM(1)), 1 NAME(1)(1 : KNM(1)) ENDIF ENDIF IGBL(8) = IABS(IGBL(8)) ENDIF 50 IF (LU .EQ. LU7) THEN LU = LU6 GOTO 10 ENDIF IF (IPR(1) .EQ. 1 .OR. 1 IPR(1) .EQ. 2 .OR. 2 IPR(1) .EQ. 4 .OR. 3 IPR(1) .EQ. 5 .OR. 4 IPR(1) .EQ. 6 .OR. 5 IPR(1) .EQ. 7) THEN IF (IR .EQ. 0) IGBL(1) = 1 ELSE IF (IPR(1) .EQ. 3 .AND. IGBL(8) .NE. 2) THEN READ (LU1, 99964, END = 70, ERR = 70) ICL(1:80) BACKSPACE LU1 IGBL(1) = 1 ENDIF C * ERROR RECOVERY FOR AUTO SEQUENCE 70 IF (IPR(3) .EQ. 1) THEN IGBL(5) = LU1 IGBL(1) = 1 ENDIF 80 GOTO 100 90 IF (IGBL(36) .NE. 0) CALL PLA230 (0) 100 IF (IGBL(3) .EQ. 36) IGBL(1) = 4 RETURN 99999 FORMAT ('W: No wavelength given.') 99998 FORMAT ('W: No Cell estimated standard deviation (CESD) given.') 99997 FORMAT ('W: NOMOVE option used.', /, 1 ':: >>> WARNING: ''CONNECTED INPUT SET'' is assumed ''TRUE'' ', 2 /, ':: >>> Network Analysis may be INCORRECT when FALSE') 99996 FORMAT ('W: NOSYMM option used. (No Symmetry applied)') 99995 FORMAT ('E: Maximum residue number exceeded.') 99994 FORMAT ('N: Number of modified (= # ) ATOM labels ', 1 33('.'), I5) 99993 FORMAT ('N: Number of Ignored Lines on INPUT ', 38('.'), 1 I5, /, 10X, 'of which blank in column 1 ', 37('.'), I5) 99992 FORMAT (':: ** Instruction N.O.K. ** :', A, /, 1 ':: Check also for mistyped ATOM labels and ATOM types') 99991 FORMAT (/, 'Summary and Remarks : N = NOTE, W = WARNING, E ', 1 '= ERROR', /, 80('='), /) 99990 FORMAT ('N: Input Data following TRNS ', 1 '[e.g. (CELL/CESD)/SPGR/COORDS/' 1 ,'UIJ)] have been', /, 4X, 'transformed according to the ', 2 'specified Cell Transformation Matrix: ', 3(/, 20X, 3F10.5)) 99989 FORMAT ('N: Number of deleted ATOMS from input stream ', 1 29('.'), I5) 99988 FORMAT ('N: DISORDERED structure - ATOMS with Pop. .LT.', 1 ' 1.0 are not moved or as a group.') 99987 FORMAT ('N: Number of detected and excluded disorder', 1 ' operations ',14('.'), I5) 99986 FORMAT ('W: Number of valency check faults for H & C ', 1 30('.'), I5) 99985 FORMAT ('W: Number of unusual bond angle faults ', 35('.'), I5) 99984 FORMAT (/, ':: FATAL attempt to EXCEED the max.ATOMS limit:', I5) 99983 FORMAT (':: U/UIJ/SUIJ/B/BIJ/SBIJ/ label: ', A, /, 4X, 1 'inconsistent with ATOM label: ', A, /) 99982 FORMAT (':: Error - Not Enough Data Items on Input Line:', 1 /, 3X, A) 99981 FORMAT (':: Error - Invalid Element Symbol: ', A) 99980 FORMAT (':: Last Line(s) Ignored', A, /) 99979 FORMAT (':: END Statement Executed for this Entry') 99978 FORMAT (//, ':: Unsuitable Keyword/ATOM label : ', A, //, 1 3X, 'Legal are: C, H999, O(3), FE(77)', /) 99977 FORMAT (//, ':: Label ', A, ' pre-occurred '/) 99976 FORMAT (':: Too many ATOMS specified, Max.Nr:', I5) 99975 FORMAT (':: FVAR - error') 99974 FORMAT (':: Population parameter OVERFLOW') 99973 FORMAT ('N: SHELX-style data input.') 99972 FORMAT (':: Instruction ', A, ' NOT allowed at this point') 99971 FORMAT ('W: Number of unusual anisotropic displacement ', 1 'parameters ', 17('.'), I5) 99970 FORMAT (':: * The PLOT instructions should be given after the', 1 ' execution of ', /, 4X, 'the -CALC INTRA- instruction') 99969 FORMAT ('W:', I5, ' Times MOL-list overflow. Results ????') 99968 FORMAT ('N: INPUT data (COORDINATES) have been transformed', 1 /, 5X, 'according to additive coordinate shift vector: ', /, 2 16X, 3F10.5) 99967 FORMAT ('W: array OVERFLOW in INTER-mode (Results INCOMPLETE)', 1 ' Code nnmmkk =', I8) 99966 FORMAT ('N: Number of positions fixed with TRNS by user ', 1 27('.'), I5) 99965 FORMAT ('N: Number of moved primary input atoms: ',34('.'), I5) 99964 FORMAT (A) 99963 FORMAT ('N: Number of Unspecified Non-H Displacement ', 1 'Parameters set to U =', F5.2, 1X, 3('.'), I5) 99754 FORMAT ('N: Number of Unspecified H Displacement ', 1 'Parameters set to U =', F5.2, 1X, 3('.'), I5) 99962 FORMAT (//, 58X, 11('='), /, 57('*'), ' N O T I C E ', 50('*'), 1 /, 58X, 11('='), //, '- PLATON Reference : Spek, A.L. (2003),', 2 ' J.Appl.Cryst. 36, 7-13', //, '- Output Values (Esd) may have', 3 ' been set to 99, 999 or 9999 to Avoid Format Overflow', //, 4 '- Derived Parameter SU''s (= Esd''s) may be Incorrect in', 5 ' Cases where Covariances in the Atom Parameters should have', 6 ' been taken', /, ' into Account (e.g. Those Involving Atoms', 7 ' That were Refined with Constraints)', //, '- ROUNDING, in', 8 ' particular of the Input Coordinate Data, may give deviating', 9 ' values for derived geometry parameters.', /, ' However,', * ' differences should be within the associated esd-range.', //, 1 '- PLATON is NOT a Finished Program. The Implementation of', 2 ' Additional Options is Planned. Some of the More Advanced', /, 3 2X, 'Features are Experimental and may Contain Loose Ends.',//, 4 '- The Communication of Glitches Encountered will be', 5 ' Appreciated: E-mail: a.l.spek@chem.uu.nl', //, 6 '- Recent versions of PLATON may be obtained by', 7 ' Anonymous FTP from xraysoft.chem.uu.nl', //, '- More INFO', 8 ' can be found on http://www.cryst.chem.uu.nl/platon/', //) 99961 FORMAT (':: Following data will be skipped until End-Of-', 1 'Section') 99960 FORMAT (':: Specified RESIDUE number:', I3, ' NOT present') 99959 FORMAT ('W: Structure contains', I3,' isolated H-atom(s).') 99958 FORMAT ('W: Structure contains', I3, ' Intra/Inter contacts', 1 ' < Sum(vdWrad) ', F5.2, ' A (max ', F5.2,')') 99957 FORMAT (':: TRNS (FIX) instruction N.O.K.') 99956 FORMAT ('N: No S.U.''s (esd) on observed/calculated parameters.') 99955 FORMAT (':: NORMAL END of PLATON :', I6, ' Pages on:', /, 1 ':: ', A, '.lis (ASCII, 132 Characters Wide)', /, 2 ':: ', A, '.lps (PostScript Version of .lis)', /) 99954 FORMAT (':: ABNORMAL END of PLATON :', I6, ' Pages on:', /, 1 A, '.lis ASCII)', /, A, '.lps (PostScript)', /) 99953 FORMAT (/, 80('='), /) 99952 FORMAT ('W: Unit cell contains non-integral number of atoms', 1 ' (please check).') 99951 FORMAT ('N: ADDSYM finds additional (pseudo)symmetry in the', 1 ' structure (please check!)') 99950 FORMAT ('N: No Explicit space group name specified') 99949 FORMAT (':: Subkeyword NOT Acceptable') 99948 FORMAT ('N: Maximum Residue Number Reduced', 1 ' (Round ARU to 0.1 units)') 99947 FORMAT ('E: Translation code [', 3I3, '] out-of-range -4:4', 1 ' for ', A) 99946 FORMAT (':: Void-array overflow, Raise NPVD to value > ', I7) 99943 FORMAT (':: Not enough storage available to handle OVERLAP') 99942 FORMAT (':: Too many axes found. Rerun with obl. ang. <', F4.1) 99941 FORMAT ('N: Total Potential Solvent Accessible Void Vol ', 1 18('.'), F8.1, ' Ang^3') 99940 FORMAT (':: Too many independent solvent areas') 99939 FORMAT (':: STOP LMX/PLA091') 99938 FORMAT (':: Overflow in VOID/SOLV routine (NP1)') 99937 FORMAT (':: No SYMM matrix allowed with TRNS option') 99935 FORMAT (':: ARU-code not representable (out-of-range)') 99934 FORMAT (':: CALC TMA not allowed after previous CALC INTRA') 99933 FORMAT ('N: No-Hydrogen atoms in this structure') 99932 FORMAT ('E: Too many FVAR - parameters (increase NP25)') 99931 FORMAT (':: No CALC INTRA or GEOM after previous (implicit) ', 1 ' CALC INTRA allowed') 99930 FORMAT ('N: Number of Isotropic Non-H Atoms ', 39('.'), I5) 99929 FORMAT ('E: Non-Recoverable problem in routine PLA', I3.3) 99928 FORMAT (':: CALC SOLV/VOID incompatible with ANGSTROM mode') 99927 FORMAT ('N: Maximum allowed number of residues reduced') 99926 FORMAT ('N: Electron Count / Cell =', I7, 1 ' - To be included in D(calc), F000 & Mol.Wght.') 99925 FORMAT ('W: Look carefully at the approximate inversion', 1 ' symmetry reported by ADDSYM') 99924 FORMAT ('W: Structure contains', I3, ' Intra H..H contacts', 1 ' < Sum(vdW-rad) ', F5.2, ' A (max ', F5.2,')') 99923 FORMAT ('W: Negative Distance Detected (i.e. Origin Outside ', 1 'Xtal)') 99922 FORMAT ('W: Number of Carbon Atoms with missing H-atoms ', 1 27('.'), I5) 99921 FORMAT ('E: No Mu-value provided') 99920 FORMAT ('E: Unknown Element Type on SFAC line, Fatal') 99919 FORMAT ('W: Number of (Carbon) Atoms with no sp(x) ', 1 'assignment ', 21('.'), I5) 99918 FORMAT ('W: Structure contains', I3, ' Inter H..H contacts', 1 ' < Sum(vdW-rad) ', F5.2, ' A (max ', F5.2,')') 99917 FORMAT ('N: Number of Non-HBonded D-H atoms ', 39('.'), I5) 99916 FORMAT ('W: No Valid Direction Cosine or Psi-values Found', /) 99915 FORMAT ('W: No Valid Psi-scans Found') 99914 FORMAT ('W: No Reflections Supplied !', /) 99913 FORMAT ('E: I Can''t accept transformations on hkl with a', 1 ' NEGATIVE Det. ') 99912 FORMAT ('E: Unknown ELEMENT Type on SFAC') 99911 FORMAT ('E: No Valid Atoms found on Input File') 99910 FORMAT ('E: No ', A,'.hkl or ', A,'.fcf Reflection file present') 99909 FORMAT ('E: No ', A,'.hkl Reflection file present', /) 99907 FORMAT ('E: Something wrong with', I5, 1 ' input U/Uij(s) (incomplete?)', /) 99906 FORMAT ('E: SFAC data incomplete or missing on shelx.res/ins file' 1 , ' for: ', A, /) 99905 FORMAT (':: Input Data from File ', A, ' - Data Type ', A, /) 99904 FORMAT (':: No proper wavelength (Ag,Mo,Cu) recognised (', 1 F8.5, ')') 99903 FORMAT ('W: Look carefully at the (approximate) Translation', 1 ' symmetry reported by ADDSYM') 99902 FORMAT ('W: Number of out of range ARU-coding problems =', I5, /, 1 ' Analysis of Inter Contacts may be incomplete') 99901 FORMAT ('E: Void TOO LARGE to be Interesting; Search Aborted', /, 1 '(at own risk: SET IPR 491 1000000 before SQUEEZE)') 99900 FORMAT (/, 'E: Scratch Array Overrun in PLA152 (Fatal)', /, 1 ' Use larger program version i.e. NP1 ', 2 '> ', I9, /) 99899 FORMAT (/, 'W: # MAXPATH EXCEEDED IN R/S-Assignment Routine =', 1 I3) 99898 FORMAT (/, 'E: Insufficient Data on UIJ/SUIJ - CIF-Input for ', 1 A, /) 99897 FORMAT (':: EXIT Statement Executed for: ', A) 99896 FORMAT (/, 'E: Insufficient Data on ATOM - CIF-Input for ', 1 A, /) 99895 FORMAT (/, 'E: Symmetry Problem in PLA081', /) 99894 FORMAT (/ ) 99893 FORMAT ('N: Number of Unrecognized Keywords ', 39('.'), I5) 99892 FORMAT ('E: SYMM-LABEL PACK PROBLEM') 99891 FORMAT ('E: No Reflection Data Available') 99890 FORMAT (80('-')) 99889 FORMAT ('W: Structure contains', I3,' isolated O-atom(s).') 99888 FORMAT ('E: No Direction Cosines or Psi found on Reflection Data') 99887 FORMAT ('W: Low density (check!) of ', 38('.'), F8.3, ' gcm-3') 99886 FORMAT ('W: Coordinates do not form a Connected Set') 99885 FORMAT ('E: Label Alias Overflow: TRY: SET IGBL(61) 1') 99855 FORMAT (':: NORMAL END of PLATON :', I6, ' Pages on FILE ', 1 A, '.lis', /) 99854 FORMAT (A, 2F10.0, 2A) 99853 FORMAT (//, 'E: READ ERROR - FATAL', /) 99852 FORMAT ('E: NSP-Problem in PLA029: Nr species too large') 99851 FORMAT (A, 2I10) 99850 FORMAT ('W: Incorrect Number of Numerical Arguments on TRNS/TRMX') 99849 FORMAT ('E: Check data type (cif,res,fdat,spf,res) of the input') 99848 FORMAT (/, ':: CELL PROBLEM') 99847 FORMAT (/, 'CIF-LINE LONGER THAN 2048 CHARACTERS') 99846 FORMAT (/, 'CIF-LOOP PROBLEM') END SUBROUTINE PLA004 (MODE) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /PATHS/ PLAPATH, BROWSER, CGETENV CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255 EXTERNAL SYSTEM IF (IGBL(36) * IGBL(66) * IGBL(32) .NE. 0) CALL PLA298 (0) C * OUTPUT-FILE TYPE C * 1 - OMEGA, 2 - MOGLI, 3 - EUCLID, 4 - CSD, 7 - PDB C * 10 - SQUEEZE C * -2 - SHELXL 10 IF (IGBL(3) .EQ. 1 .OR. IGBL(22) .NE. 0) 1 CLOSE (LU2, STATUS = 'DELETE', ERR = 20) 20 LU = LU6 IEND = 1 IF (IGBL(63) .GT. 0) IEND = 2 DO 30 I = 1, IEND IF (I .EQ. 2) LU = LU7 IF (IGBL(31) .EQ. 1) THEN IF (IPR(430) .EQ. 0) THEN WRITE (LU, 99997) NAME(5)(1:KNM(5)) ELSE ENDIF ELSE IF (IGBL(31) .EQ. 2) THEN WRITE (LU, 99996) NAME(2)(1:KNM(2)), NAME(2)(1:KNM(2)) ELSE IF (IGBL(31) .EQ. 3) THEN WRITE (LU, 99995) NAME(3)(1:KNM(3)) ELSE IF (IGBL(31) .EQ. -2) THEN WRITE (LU, 99988) NAME(7)(1:KNM(7)) ELSE IF (IGBL(31) .EQ. 4) THEN WRITE (LU, 99994) NAME(6)(1:KNM(6)) ELSE IF (IGBL(31) .EQ. 5) THEN WRITE (LU, 99985) NAME(8)(1:KNM(8)) ELSE IF (IGBL(31) .EQ. 6) THEN WRITE (LU, 99988) NAME(7)(1:KNM(7)) ELSE IF (IGBL(31) .EQ. 7) THEN WRITE (LU, 99977) NAME(3)(1:KNM(3)) ELSE IF (IGBL(31) .EQ. 8) THEN WRITE (LU, 99990) NAME(1)(1:KNM(1)) ELSE IF (IGBL(31) .EQ. 9) THEN WRITE (LU, 99991) NAME(1)(1:KNM(1)) ELSE IF (IGBL(31) .EQ. 10) THEN WRITE (LU, 99976) NAME(1)(1:KNM(1)), 1 NAME(1)(1:KNM(1)) ENDIF 30 CONTINUE IF (MODE .EQ. 0) THEN C * STOP AND CLOSE GRAPHICS (IF ANY) XGGIP = -999.0 PCAL = 0.0 PLOTS = 0.0 CALL GGIP (XGGIP, PCAL, PLOTS, -5) C * CLOSE 'ALERT' FILE CLOSE (LU20, STATUS = 'DELETE', ERR = 10) ENDIF CLOSE (UNIT = LU29, STATUS = 'DELETE') IF (IGBL(92) .GT. 0) THEN IF (IGBL(93) .GE. 0 .AND. IGBL(31) .NE. 8) 1 WRITE (LU6, 99992) NAME(1)(1:KNM(1)) IF (IGBL(92) .EQ. 2) THEN WRITE (LU6, 99993) NAME(1)(1:KNM(1)) ELSE IF (IGBL(12) .EQ. 0) CLOSE (LU12, STATUS = 'DELETE') ENDIF IF (IPR(431) .EQ. -1 .OR. IPR(431) .EQ. -2) THEN IF (IGBL(13) .EQ. 0) CLOSE (LU13, STATUS = 'DELETE') ENDIF ELSE IF (IGBL(12) .EQ. 0) CLOSE (LU12, STATUS = 'DELETE', ERR = 40) 40 IF (IGBL(13) .EQ. 0) CLOSE (LU13, STATUS = 'DELETE', ERR = 50) ENDIF 50 CLOSE (LU14, STATUS = 'DELETE', ERR = 60) 60 IF (IGBL(36) .GT. 0) THEN LU6 = 6 CALL PLA230 (1) WRITE (LU6, 99971) NAME(1)(1:KNM(1)) ENDIF IF (IGBL(22) .LT. 0) THEN LU6 = 6 WRITE (LU6, 99962) NAME(1)(1:KNM(1)) ENDIF IF (IGBL(16) .EQ. 0) CLOSE (LU21, STATUS = 'DELETE', ERR = 70) 70 IF (IPR(326) .EQ. 1 .AND. IPR(198) .GT. 0 .AND. 1 IPR(189) .EQ. 2 .AND. IPR(210) .NE. 1) THEN WRITE (LU6, 99989) NAME(1)(1:KNM(1)) ELSE CLOSE (LU15, STATUS = 'DELETE', ERR = 80) ENDIF 80 IF (IGBL(18) .EQ. 1 .AND. IPR(408) .LT. 1 1 .AND. IGBL(3) .NE. 34 .AND. IGBL(3) .NE. 1) THEN WRITE (LU6, 99966) NAME(1)(1:KNM(1)), IPR(378) ELSE IF (IGBL(18) .EQ. 2) THEN WRITE (LU6, 99965) NAME(1)(1:KNM(1)) ENDIF IF (IPR(210) .EQ. 1) THEN WRITE (LU6, 99998) NAME(1)(1:KNM(1)) ELSE IF (IPR(210) .EQ. -1) THEN WRITE (LU6, 99987) NAME(4)(1:KNM(4)) ELSE IF (IPR(210) .EQ. -2) THEN WRITE (LU6, 99986) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -4) THEN WRITE (LU6, 99972) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -5) THEN WRITE (LU6, 99979) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -6 .AND. IPR(432) .GT. 0) THEN WRITE (LU6, 99980) NAME(4)(1:KNM(4)) ELSE IF (IPR(2) .EQ. -7 .AND. IPR(432) .GT. 0) THEN WRITE (LU6, 99982) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -8 .AND. IPR(432) .GT. 0) THEN WRITE (LU6, 99983) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -9) THEN WRITE (LU6, 99978) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -10) THEN WRITE (LU6, 99963) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -11) THEN WRITE (LU6, 99964) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -12) THEN WRITE (LU6, 99960) NAME(1)(1:KNM(1))//'.rp1' ELSE IF (IPR(2) .EQ. -13 .AND. IPR(525) .EQ. 0) THEN WRITE (LU6, 99984) NAME(1)(1:KNM(1)) ELSE IF (((IPR(2) .EQ. -14 .AND. IPR(408) .NE. 2) .OR. 1 IGBL(17) .EQ. 1) .AND. IGBL(22) .EQ. 0) THEN WRITE (LU6, 99981) NAME(1)(1:KNM(1)), IPR(377) ELSE IF (IPR(2) .EQ. -15) THEN WRITE (LU6, 99970) NAME(1)(1:KNM(1)) ELSE IF (IPR(2) .EQ. -16 .AND. IPR(384) .GT. 0) THEN WRITE (LU6, 99967) NAME(1)(1:KNM(1)) ELSE CLOSE (LU17, STATUS = 'DELETE', ERR = 90) ENDIF 90 CLOSE (LU1) IF (IGBL(21) .EQ. 0) CLOSE (LU23, STATUS = 'DELETE', ERR = 100) CLOSE (LU24, STATUS = 'DELETE') 100 IF (IGBL(4) .EQ. 0) THEN CLOSE (LU25, STATUS = 'DELETE', ERR = 110) ELSE WRITE (LU6, 99974) NAME(2)(1:KNM(2)) ENDIF 110 IF (IGBL(20) .EQ. 0) THEN IF (IGBL(26) .EQ. 0) THEN CLOSE (LU26, STATUS = 'DELETE', ERR = 120) ELSE CALL PLUT29 (-1, ICL, NQ1, 0) WRITE (LU6, 99975) NAME(1)(1:KNM(1)) ENDIF ENDIF 120 IF (IGBL(98) .NE. 0) WRITE (LU6, 99999) NAME(1)(1:KNM(1)) IF (IGBL(11) .NE. 0) WRITE (LU6, 99969) NAME(1)(1:KNM(1)) IF (IPR(123) .EQ. 0 .AND. ((IGBL(7) .EQ. 1 .AND. IGBL(3) .EQ. 8) 1 .OR. IGBL(63) .EQ. 0 .OR. IGBL(23) .EQ. 17 .OR. 2 IGBL(23) .EQ. 18 .OR. IGBL(23) .EQ. 19)) THEN CLOSE (LU7, STATUS = 'DELETE', ERR = 150) ELSE IF (IGBL(70) .EQ. 1 .AND. MODE .EQ. 0) THEN IF (IGBL(7) .EQ. 1) THEN CALL GEN108 (LU7, 0) CLOSE (LU1) READ (LU7, 99961, END = 140) PRBUF CALL GEN108 (LU7, 0) FNLU1 = NAME(1)(1:KNM(1)) //'.lps' OPEN (UNIT = LU1, FILE = FNLU1, STATUS = 'UNKNOWN') CALL GEN089 (LU7, LU1, IGBL(49), IGBL(102)) GOTO 150 140 CLOSE (LU7, STATUS = 'DELETE') ENDIF ENDIF 150 IF (IGBL(27) .EQ. 1) THEN WRITE (LU6, 99973) NAME(1)(1:KNM(1)) ELSE CLOSE (LU27, STATUS = 'DELETE', ERR = 160) ENDIF 160 IF (IPR(516) .EQ. 1) THEN CLOSE (LU17) OPEN (LU61, FILE = NAME(1)(1:KNM(1))//'.hkp', 1 STATUS = 'UNKNOWN') OPEN (LU62, FILE = NAME(1)(1:KNM(1))//'_trm.fcf', 1 STATUS = 'UNKNOWN') 170 READ (LU61, 99961, END = 180) LINE WRITE (LU62, 99961) LINE GOTO 170 180 CLOSE (LU61, STATUS = 'DELETE') CLOSE (LU62) CALL SYSTEM 1 (PLAPATH(1:IGBL(80))//' -T '//NAME(1)(1:KNM(1))//'_trm.fcf') ENDIF IF (IPR(580) .LT. 0) THEN IF (IPR(580) .EQ. -1) THEN WRITE (LU6, 99959) NAME(1)(1:KNM(1)) ELSE WRITE (LU6, 99958) NAME(1)(1:KNM(1)) ENDIF ENDIF IF (MODE .NE. 0) THEN CLOSE (LU7, STATUS = 'DELETE') LU1 = 1 LINE = ICL(5:80) IGBL(7) = 0 IGBL(8) = 0 ELSE STOP ENDIF RETURN 99999 FORMAT (/, 1 ':: POV-Ray File on :', A, '.pov') 99998 FORMAT (':: SQUEEZE out on :', A, '.hkp') 99997 FORMAT (':: OMEGA File on :', A, '.ome') 99996 FORMAT (':: MOGLI Files on :', A, '.dge') 99995 FORMAT (':: SPF File on :', A, '.eld') 99994 FORMAT (':: CSD-QUE on :', A, '.que') 99993 FORMAT (':: PUBL. Tables on :', A, '.pub') 99992 FORMAT (':: SUPP. Mat. on :', A, '.sup') 99991 FORMAT (':: CIF/CSD-File on :', A, '.csd') 99990 FORMAT (':: CIF/ACC-File on :', A, '.acc') 99989 FORMAT (':: SAR-File on :', A, '.sar') 99988 FORMAT (':: SHELXL Style Output on :', A, '.res') 99987 FORMAT (':: FCF-CIF hkl on :', A, '.hkp') 99986 FORMAT (':: DELABS hkl on :', A, '.hkp') 99985 FORMAT (':: SPGR.PAR on :', A, '.par') 99984 FORMAT (':: HKLF3.HKL on :', A, '.hkp') 99983 FORMAT (':: ABSGAUSS hkl on :', A, '.hkp') 99982 FORMAT (':: ABSTOMPA hkl on :', A, '.hkp') 99981 FORMAT (':: ASYM hkl on :', A, '.hkp (# refl. =', I7, ')') 99980 FORMAT (':: ABSPSI hkl on :', A, '.hkp') 99979 FORMAT (':: ABSSPHER hkl on :', A, '.hkp') 99978 FORMAT (':: PSIDIR hkl on :', A, '.hkp') 99977 FORMAT (':: PDB-FILE out on :', A, '.pdb') 99976 FORMAT (':: SQUEEZE xyz on :', A, '.sqz', /, 1 ':: SQUEEZE CIF on :', A, '.sqf') 99975 FORMAT (/, ':: Modified SHELX-File on ', A, '.new') 99974 FORMAT (/, 1 ':: MOGLI File on :', A, '.dge') 99973 FORMAT (/, 1 ':: Journal File on :', A, '.pjn', //, 2 ':: Normal End of PLATON/PLUTON RUN.') 99972 FORMAT (':: MULABS hkl on :', A, '.hkp') 99971 FORMAT (':: CHECK out on :', A, '.chk') 99970 FORMAT (':: HKLTRANS hkl on :', A, '.hkp') 99969 FORMAT (':: RASMOL(pdb) on :', A, '.ras') 99967 FORMAT (':: HKLF4.HKL on :', A, '.hkp') 99966 FORMAT (':: ASYM -hkl on :', A, '.hks (# refl. =', I7, ')') 99965 FORMAT (':: POWDER cpi on :', A, '.cpi') 99964 FORMAT (':: HKLF5.HKL on :', A, '.hkp') 99963 FORMAT (':: SHXABS hkl on :', A, '.hkp') 99962 FORMAT (':: FCF-CHK out on :', A, '.fck') 99961 FORMAT (A) 99960 FORMAT (':: Expanded coordinate set (shelx-style) on :', A) 99959 FORMAT (':: Fourier3D on :', A, '.fou') 99958 FORMAT (':: Solv3D on :', A, '.slv') END SUBROUTINE PLA005 (MODE, LINE, ICL, LRT) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER IDM*(80), LINE*(*), ICL*(*) C * MODE = -1 C * MODE = 0 - PLATON C * MODE = 1 - PLUTON C * GET ARGUMENTS & FLAGS IF (MODE .LT. 0) THEN J0 = 0 C * FIRST CHECK FOR PROGRAM NAME ALIASES DO 10 J = J0, IARGC() CALL GETARG (J, IDM) IF (LRT .EQ. 0) THEN LRT = 1 IF (INDEX (IDM, 'platon') .NE. 0) THEN GOTO 10 ELSE IF (INDEX (IDM, 'pluton') .NE. 0) THEN IDM = '-p' ELSE IF (INDEX (IDM, 'cifchk') .NE. 0) THEN IDM = '-u' ELSE IF (INDEX (IDM, 's ') .NE. 0) THEN IDM = '-s' ELSE IF (INDEX (IDM, 'helena ') .NE. 0) THEN IDM = '-k' c SIMULATE -Y option when called as 'stidy' IDM = '-Y' ENDIF ENDIF C * ADP-ORTEP MODE IF (IDM(1:2) .EQ. '-a') THEN IGBL(3) = 3 C * CALC GEOM CSD ELSE IF (IDM(1:2) .EQ. '-b') THEN IGBL(3) = 11 C * CALC MODE ELSE IF (IDM(1:2) .EQ. '-c') THEN IGBL(3) = 2 C * DELABS - MODE ELSE IF (IDM(1:2) .EQ. '-d') THEN IGBL(3) = 6 C * MULABS - MODE ELSE IF (IDM(1:2) .EQ. '-e') THEN IGBL(3) = 18 C * HFIX ELSE IF (IDM(1:2) .EQ. '-f') THEN IGBL(3) = 13 C * CALC GEOM SHELX ELSE IF (IDM(1:2) .EQ. '-g') THEN IGBL(3) = 24 IGBL(25) = 0 C * HKL CALC ELSE IF (IDM(1:2) .EQ. '-h') THEN IGBL(3) = 10 C * PATTERSON PLOT ELSE IF (IDM(1:2) .EQ. '-i') THEN IGBL(3) = 22 C * CALC GEOM EUCLID ELSE IF (IDM(1:2) .EQ. '-j') THEN IGBL(3) = 23 IGBL(25) = 0 C * HELENA - MODE ELSE IF (IDM(1:2) .EQ. '-k') THEN IGBL(3) = 15 NAME(1) = 'helena' NAME(2) = 'shelx' NAME(5) = 'abspsi' KNM(1) = 6 KNM(2) = 5 KNM(5) = 6 EXTENS = 'cad' KXT = 3 C * ASYM AVF VIEW ELSE IF (IDM(1:2) .EQ. '-l') THEN IGBL(3) = 17 C * ADDSYM - MODE ELSE IF (IDM(1:2) .EQ. '-m') THEN IGBL(3) = 4 C * ADDSYM SHELX - MODE ELSE IF (IDM(1:2) .EQ. '-n') THEN IGBL(3) = 16 C * MENU OFF ELSE IF (IDM(1:2) .EQ. '-o') THEN IGBL(25) = 0 C * PLUTON MODE ELSE IF (IDM(1:2) .EQ. '-p') THEN IGBL(3) = 8 C * SQUEEZE - MODE ELSE IF (IDM(1:2) .EQ. '-q') THEN IGBL(3) = 5 C * RENAME MODE ELSE IF (IDM(1:2) .EQ. '-r') THEN IGBL(3) = 12 C * S - MODE ELSE IF (IDM(1:2) .EQ. '-s') THEN IGBL(3) = 14 NAME(1) = 's' KNM(1) = 1 GOTO 20 C * TABLE - MODE ELSE IF (IDM(1:2) .EQ. '-t') THEN IGBL(3) = 7 C * IUCR MODE ELSE IF (IDM(1:2) .EQ. '-u') THEN IPR(119) = 0 IGBL(3) = 1 IGBL(70) = 0 C * SOLV MODE ELSE IF (IDM(1:2) .EQ. '-v') THEN IGBL(3) = 9 C * DIFFERENCE MAP ELSE IF (IDM(1:2) .EQ. '-w') THEN IGBL(3) = 19 C * FO MAP ELSE IF (IDM(1:2) .EQ. '-x') THEN IGBL(3) = 20 C * SQUEEZE MAP ELSE IF (IDM(1:2) .EQ. '-y') THEN IGBL(3) = 21 C * WRITE IDENT ELSE IF (IDM(1:2) .EQ. '-z') THEN WRITE (LU6, '(''PLATON-Version='', I10)') IGBL(9) STOP C * PLUTON ANIS ELSE IF (IDM(1:2) .EQ. '-A') THEN IGBL(3) = 26 C * TABL ACC ELSE IF (IDM(1:2) .EQ. '-C') THEN IGBL(3) = 35 C * AUTOMOLFIT ELSE IF (IDM(1:2) .EQ. '-I') THEN IGBL(3) = 41 IGBL(25) = 0 IGBL(32) = 0 C * SILENT S NQA - MODE ELSE IF (IDM(1:2) .EQ. '-F') THEN IGBL(50) = 2 IGBL(3) = 14 NAME(1) = 's' KNM(1) = 1 GOTO 20 C * CALC KPI ELSE IF (IDM(1:2) .EQ. '-K') THEN IGBL(3) = 36 IGBL(25) = 0 C * TWINROTMAT (INTERACTIVE) ELSE IF (IDM(1:2) .EQ. '-L') THEN IGBL(3) = 40 C * TWINROTMAT (FILTER MODE) ELSE IF (IDM(1:2) .EQ. '-M') THEN IGBL(3) = 37 IGBL(25) = 0 C * ADDSYM EQUAL SHELX - MODE ELSE IF (IDM(1:2) .EQ. '-N') THEN IGBL(3) = 38 C * PLOT ADP PS ELSE IF (IDM(1:2) .EQ. '-O') THEN IGBL(25) = 0 IGBL(3) = 28 C * HKL2POWDER IOBS ELSE IF (IDM(1:2) .EQ. '-P') THEN IGBL(3) = 29 C * POWDER ICALC (POSTSCRIPT + CPI) ELSE IF (IDM(1:2) .EQ. '-Q') THEN IGBL(3) = 31 C * RENUM ==> SHELX ELSE IF (IDM(1:2) .EQ. '-R') THEN IGBL(3) = 27 C * CIF2RES & FCF2HKL ELSE IF (IDM(1:2) .EQ. '-S') THEN IGBL(3) = 25 C * TWINROTMAT (RL-PLOT) ELSE IF (IDM(1:2) .EQ. '-T') THEN IGBL(3) = 30 C * IUCR MODE (without VALIDATION DOC) ELSE IF (IDM(1:2) .EQ. '-U') THEN IGBL(3) = 1 IGBL(83) = 0 IGBL(70) = 0 C * FCF-VALIDATION (LAUE) ELSE IF (IDM(1:2) .EQ. '-V') THEN IGBL(3) = 33 C * FCF-VALIDATION (BIJVOET) ELSE IF (IDM(1:2) .EQ. '-W') THEN IGBL(3) = 34 IGBL(70) = 0 C * SHX86 ELSE IF (IDM(1:2) .EQ. '-X') THEN IGBL(3) = 32 C * STIDY ELSE IF (IDM(1:2) .EQ. '-Y') THEN IGBL(3) = 39 C * CATCH OTHER ELSE IF (IDM(1:1) .EQ. '-') THEN IGBL(8) = 1 LINE = 'zz12345.zzz' LRT = 2 ELSE LINE = IDM LRT = 2 ENDIF 10 CONTINUE ELSE IF (IGBL(3) .NE. 0) CALL GEN038 (ICL, 1, 80) IF (IGBL(3) .EQ. 1) THEN IF (IGBL(19) .NE. 0) THEN IF (IABS(IGBL(8)) .EQ. 3 .OR. IABS(IGBL(8)) .EQ. 4) THEN ICL = 'VALID' IGBL(45) = 1 CALL GEN108 (LU3, 0) ELSE WRITE (6, 1 '('' ==== >>> Cannot do -u !!! - CIF not Recognized'', /)') CALL PLA004 (0) ENDIF ELSE WRITE (6, 1 '('' ==== >>> Cannot do -u !!! - no check.def found'', /)') ENDIF ELSE IF (IGBL(3) .EQ. 2) THEN ICL = 'CALC' IGBL(45) = 1 CALL GEN108 (LU3, 0) ELSE IF (IGBL(3) .EQ. 3 .OR. IGBL(3) .EQ. 28) THEN ICL = 'PLOT ADP COLOR' IGBL(45) = 1 IPR(308) = 2 CALL GEN108 (LU3, 0) ELSE IF (IGBL(3) .EQ. 4) THEN ICL = 'CALC ADDSYM' ELSE IF (IGBL(3) .EQ. 5) THEN ICL = 'CALC SQUEEZE' ELSE IF (IGBL(3) .EQ. 6) THEN ICL = 'CALC DELABS' ELSE IF (IGBL(3) .EQ. 7) THEN ICL = 'TABLE' ELSE IF (IGBL(3) .EQ. 9) THEN ICL = 'CALC SOLV' ELSE IF (IGBL(3) .EQ. 10) THEN ICL = 'ASYM GENERATE' ELSE IF (IGBL(3) .EQ. 11) THEN ICL = 'CALC GEOM CSD' ELSE IF (IGBL(3) .EQ. 16) THEN ICL = 'CALC ADDSYM SHELX' ELSE IF (IGBL(3) .EQ. 17) THEN ICL = 'ASYM AVF VIEW' ELSE IF (IGBL(3) .EQ. 18) THEN ICL = 'MULABS' ELSE IF (IGBL(3) .EQ. 19) THEN PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 ICL = 'CONTOUR DI TN' ELSE IF (IGBL(3) .EQ. 20) THEN PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 ICL = 'CONTOUR FO TN' ELSE IF (IGBL(3) .EQ. 21) THEN PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 ICL = 'CONTOUR SQ TN' ELSE IF (IGBL(3) .EQ. 22) THEN PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 ICL = 'CONTOUR PT TN' ELSE IF (IGBL(3) .EQ. 23) THEN IGBL(70) = 0 ICL = 'CALC GEOM EUCLID' ELSE IF (IGBL(3) .EQ. 24) THEN IGBL(70) = 0 ICL = 'CALC GEOM SHELX' ELSE IF (IGBL(3) .EQ. 25) THEN ICL = 'CALC GEOM SHELX' ELSE IF (IGBL(3) .EQ. 27) THEN IGBL(70) = 0 ICL = 'CALC GEOM RENUM SHELX' ELSE IF (IGBL(3) .EQ. 29) THEN ICL = 'POWDER IOBS' ELSE IF (IGBL(3) .EQ. 30) THEN IF (IGBL(29) .LE. 0) THEN ICL = 'CALC FCF' IPR(516) = 1 ELSE ICL = 'ROTMAT' ENDIF ELSE IF (IGBL(3) .EQ. 31) THEN ICL = 'POWDER' ELSE IF (IGBL(3) .EQ. 33) THEN ICL = 'ASYM AVF VALID' ELSE IF (IGBL(3) .EQ. 34) THEN ICL = 'ASYM VALID' ELSE IF (IGBL(3) .EQ. 35) THEN ICL = 'TABL ACC' ELSE IF (IGBL(3) .EQ. 36) THEN ICL = 'CALC VOID' ELSE IF (IGBL(3) .EQ. 37 .OR. IGBL(3) .EQ. 40) THEN ICL = 'ROTMAT' ELSE IF (IGBL(3) .EQ. 38) THEN ICL = 'CALC ADDSYM EQUAL SHELX' ELSE IF (IGBL(3) .EQ. 41) THEN ICL = 'FIT' ELSE IF (MODE .EQ. 0) THEN IF (IGBL(72) .EQ. 0) THEN WRITE (LU6, 99999) WRITE (LU6, 99998) IGBL(9) IGBL(72) = 1 ENDIF IF (IPR(39) .EQ. 0) THEN IF (IABS(IGBL(8)) .EQ. 3) THEN ICL = 'END' GOTO 20 ELSE WRITE (LU6, 99997) ENDIF ENDIF ENDIF LRT = 2 ENDIF ENDIF 20 RETURN 99999 FORMAT ('::', 29X, 1 'S.e.l.e.c.t.e.d I.n.s.t.r.u.c.t.i.o.n.s', /, 2 '::', 1X, 24('*'), 2X, 3 'CALC for an exhaustive geometry calculation', /, 4 '::', 1X, '* PLATON *', 2X, 5 'PLOT ADP for default labeled ORTEP-look-alike', /, 6 '::', 1X, '* ====== *', 2X, 7 'TABL CIF for an Acta Cryst C CIF-file', /, 8 '::', 1X, '* A Multipurpose *', 2X, 9 'LEPAGE to check for higher metrical symmetry', /, * '::', 1X, '* Crystallographic *', 2X, 1 'CALC ADDSYM for a check for MISsed SYMmetry') 99998 FORMAT ('::', 1X, '* Tool *', 2X, 1 'CALC NONSYM for a non-cryst. symm. check', /, 2 '::', 1X, '* -- *', 2X, 3 'CALC SOLV to search for missed solvent areas', /, 4 '::', 1X, '*(C) 1980-2006 A.L.Spek*', 2X, 5 'CALC SQUEEZE to handle disordered solvents', /, 6 '::', 1X, '* -- *', 2X, 7 'PLOT NEWMAN for NEWMAN-Projection Plots', /, 6 '::', 1X, '* version : ', I6, ' *', 2X, 7 'LIST RADII for current radii list', /, 8 '::', 1X, 24('*'), 2X, 9 'HELP for Available Instruction Information', /, * '::', 1X, 26X, 'PLUTON to enter the PLUTON sub-program') 99997 FORMAT (/, ':: Warning: no ATOMS given yet') END SUBROUTINE PLA006 (MODE, IS) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP24=176,NP37=175,NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45), 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, TKST*10, 2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12, 3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26, 4 CHSG*6 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /CGGT/ IGGT CHARACTER IGGT*80, ICH*1 COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1) CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10 10 J = 0 ICONT = 0 A = 0.0 IF (IGBL(8) .EQ. 3) THEN KL = 0 KN = 0 LRETN = 0 CALL PLA007 (MODE, LRETN, KL, KN) ENDIF 20 KN = 0 KL = 0 IS = -1 CALL GEN074 (FN, 0.0, 1, NP17) DO 30 I = 1, NP17 CALL GEN038 (IFL(I), 1, 7) 30 CONTINUE IF (IGGT(1:1) .EQ. ' ') THEN IF (IGBL(23) .GT. 0 .AND. IGBL(23) .NE. 10 .AND. 1 IGBL(23) .NE. 11 .AND. IGBL(23) .NE. 12 .AND. 2 IGBL(5) * IGBL(24) * IGBL(25) .EQ. LU5) 3 CALL PLA280 ('PLOT') ENDIF IF (IGGT(1:1) .NE. ' ') THEN ICL = IGGT IF (IGBL(74) .EQ. 1) WRITE (LU6, 99999) IGBL(23), ICL(1:60) CALL GEN038 (IGGT, 1, 80) GOTO 60 ENDIF 40 IF (IGBL(5) .EQ. LU5) THEN LRT = 1 CALL PLA005 (MODE, LINE, ICL, LRT) IF (LRT .EQ. 1) THEN GOTO 60 ELSE IF (LRT .EQ. 2) THEN GOTO 50 ENDIF ENDIF 50 IF (IGBL(5) .NE. LU1 .OR. IGBL(8) .NE. 4) THEN CALL PLA019 (0, IER) IF (IER .NE. 0) GOTO 290 IF (MODE .EQ. 1 .AND. IGBL(5) .EQ. LU1) THEN CALL GEN038 (NQ1, 1, 7) CALL PLUT29 (1, ICL, NQ1, 0) ENDIF ENDIF C * CHECK/FIND-OUT DATA TYPE (= IGBL(8)) 60 IF (IGBL(8) .EQ. 0) THEN DO 70 I = 1, 80 IF (ICL(I:I) .EQ. CHAR(13)) GOTO 50 IF (ICL(I:I) .NE. CHAR(32)) THEN C * TEST FOR CIF STRUCTURE (IGBL(8) = 3) LRETN = -1 CALL PLA007 (MODE, LRETN, KL, KN) IF (LRETN .EQ. -2) GOTO 290 C * TEST FOR FDAT-STRUCTURE (IGBL(8) = 4) IF (IGBL(8) .EQ. 0) THEN CALL PLA008 (MODE, LRETN, KL, KN) IF (LRETN .EQ. -2) GOTO 50 C * CHECK FOR PDB-FILE-STRUCTURE (IGBL(8) = 5) IF (IGBL(8) .EQ. 0) THEN CALL PLA009 (MODE, LRETN, KL, KN) C * CHECK FOR CHEM-3D - FORMAT TRIGGERED BY NUMBER IN FIRST THREE POSITIO IF (IGBL(8) .EQ. 0) THEN CALL PLA010 (MODE, LRETN) C * ASSUME SPF = 1 (OR RES = 2) IF (IGBL(8) .EQ. 0) THEN IF (ICL(1:3) .EQ. 'REM') GOTO 50 IF (ICL(1:4) .EQ. 'TITL') THEN IGBL(8) = 1 ELSE IPR(2) = 64 GOTO 310 ENDIF ENDIF ENDIF ENDIF ENDIF GOTO 60 ENDIF 70 CONTINUE GOTO 50 C * RESTRICTED CIF - FORMAT (COMPATIBLE WITH SHELXL) ELSE IF (IGBL(8) .EQ. 3) THEN LRETN = 1 CALL PLA007 (MODE, LRETN, KL, KN) IF (LRETN .EQ. 1) THEN GOTO 20 ELSE IF (LRETN .EQ. 2) THEN GOTO 240 ELSE IF (LRETN .EQ. 3) THEN GOTO 240 ELSE IF (LRETN .EQ. 4) THEN GOTO 290 ELSE IF (LRETN .EQ. 5) THEN GOTO 260 ENDIF C * FDAT - FILE STRUCTURE ELSE IF (IGBL(8) .EQ. 4) THEN LRETN = 1 CALL PLA008 (MODE, LRETN, KL, KN) IF (LRETN .EQ. 1) THEN GOTO 240 ELSE IF (LRETN .EQ. 2) THEN GOTO 270 ELSE IF (LRETN .EQ. 3) THEN GOTO 290 ENDIF C * PDB-FILE STRUCTURE ELSE IF (IGBL(8) .EQ. 5) THEN LRETN = 1 CALL PLA009 (MODE, LRETN, KL, KN) IF (LRETN .EQ. 1) THEN GOTO 240 ELSE IF (LRETN .EQ. 4) THEN GOTO 290 ELSE IF (LRETN .EQ. 6) THEN GOTO 255 ENDIF C * CHEM-3D FORMAT ELSE IF (IGBL(8) .EQ. 6) THEN LRETN = 1 CALL PLA010 (MODE, LRETN) IF (LRETN .EQ. 1) THEN GOTO 240 ELSE IF (LRETN .EQ. 4) THEN GOTO 290 ELSE IF (LRETN .EQ. 6) THEN GOTO 255 ENDIF C * SPF or RES & Instructions ELSE CALL GEN020 (1, ICL, 1, 4) N = INDEX (ICL(1:80), CHAR(13)) IF (N .NE. 0) ICL(N:N) = CHAR(32) IF (ICL(1:4) .EQ. 'TITL' .OR. ICL(1:3) .EQ. 'REM' .OR. 1 ICL(1:4) .EQ. 'MESS' .OR. ICL(1:4) .EQ. 'FILE') THEN I80 = 4 ELSE IF (ICL(1:4) .EQ. 'ENTR') THEN I80 = 5 ELSE I80 = 80 ENDIF CALL GEN020 (1, ICL, 1, I80) IF (IPR(470) .EQ. 1) THEN IF (IGBL(5) .EQ. LU1) THEN IF (ICL(1:3) .NE. 'END') THEN IPR(471) = IPR(471) + 1 GOTO 20 ENDIF ENDIF IPR(470) = 0 ENDIF ICH = ICL(1:1) IF (KL .EQ. 0 .AND. KN .EQ. 0 .AND. 1 (ICH .EQ. ' ' .OR. ICH .EQ. '#' .OR. ICH .EQ. '+')) THEN IF (MODE .EQ. 0) THEN IF (IGBL(5) .EQ. LU5) THEN GOTO 300 ELSE IPR(472) = IPR(472) + 1 IPR(471) = IPR(471) + 1 ENDIF GOTO 20 ENDIF ENDIF IF (IGBL(5) .EQ. LU2 .AND. MODE .NE. 0) 1 WRITE (LU6, 99997) ICL(1:80) IF (IGBL(5) .EQ. LU3) WRITE (LU6, 99998) ICL(1:80) IMAX = 80 DO 80 I = 1, IMAX IF (ICL(I:I) .EQ. '!') THEN IMAX = I - 1 GOTO 90 ELSE IF (ICL(I:I) .EQ. '=') THEN IMAX = I - 1 ICONT = 1 GOTO 90 ENDIF 80 CONTINUE ICONT = 0 90 NCHAR = 7 I = 0 100 A = 0.0 IP = 0 NP = 0 L = 0 S = 1.0 110 I = I + 1 IF (I .LE. IMAX) THEN ICH = ICL(I:I) IF (ICH .EQ. CHAR(9)) THEN ICH = CHAR(32) ICL(I:I) = ICH ENDIF IF (L .EQ. 0 .AND. ICH .EQ. ' ') GOTO 110 L = L + 1 DO 120 J = 1, 10 IF (ICH .EQ. CHAR(ICHAR('0') + J - 1)) THEN IF (IGBL(5) .NE. LU5 .AND. KL .EQ. 0) GOTO 20 NP = NP + IP A = 10.0 * A + J - 1 GOTO 110 ENDIF 120 CONTINUE IF (ICH .EQ. '.') THEN IP = 1 ELSE IF (ICH .EQ. '+') THEN IF (L .GT. 1) GOTO 140 S = 1.0 ELSE IF (ICH .EQ. '-') THEN IF (L .GT. 1) GOTO 140 S = -1.0 ELSE IF (ICH .EQ. ']') THEN GOTO 140 ELSE IF (L .GT. 1) GOTO 140 GOTO 150 ENDIF GOTO 110 ENDIF IF (L .LE. 0) GOTO 240 C * END OF NUMERIC FIELD 140 IF (KN .LT. NP17) THEN KN = KN + 1 FN(KN) = S * A / 10.0**NP ENDIF IF (ICH .EQ. '+' .OR. ICH .EQ. '-') I = I - 1 GOTO 100 C * START NEW LITERAL FIELD 150 IF (KL .LT. NP17) KL = KL + 1 IF (KL .GT. 1 .AND. IS .LT. 0) THEN IF (MODE .EQ. 0) THEN CALL GEN102 (IS, IFL(1), ISWS, NP24) ELSE CALL GEN102 (IS, IFL(1), CRD, NP37) ENDIF C * DO NOT INTERPRETE TITL, REM AND MESS LINES IF (IS .GT. 1 .AND. IS .LT. 5) GOTO 300 ENDIF 160 IFL(KL)(L:L) = ICH L = L + 1 IGGTN = (KL - 1) * 7 + L IF (IGGTN .LE. 80) IGGT(IGGTN:IGGTN) = ICH IF (IGGTN .EQ. 2) CALL GEN038 (IGGT, 3, 80) 170 I = I + 1 IF (I .GT. IMAX) GOTO 190 ICH = ICL(I:I) IF (ICH .EQ. ' ' .OR. ICH .EQ. ',') GOTO 190 IF (ICH .EQ. '[' .AND. L .GT. 3) GOTO 190 IF (ICH .EQ. '.') GOTO 180 IF (ICH .EQ. '+' .OR. ICH .EQ. '-') THEN IF (IGBL(8) .NE. 2 .OR. I .GT. 4) GOTO 180 ENDIF IF (L .GT. NCHAR) THEN GOTO 170 ELSE GOTO 160 ENDIF 180 I = I - 1 190 GOTO 100 ENDIF 240 IF (IS .LT. 0) THEN IF (IFL(1)(1:4) .EQ. 'TEXT') THEN CALL PLA115 (1, 1, 0.0, 0.0, 0) CALL PLA013 (0, 1) GOTO 10 ENDIF IF (MODE .EQ. 0) THEN CALL GEN102 (IS, IFL(1), ISWS, NP24) ELSE CALL GEN102 (IS, IFL(1), CRD, NP37) ENDIF ENDIF IF (ICONT .EQ. 1) THEN IF (IS .LT. 2 .OR. IS .GT. 4) GOTO 40 ENDIF IENDS = 0 IF (MODE .EQ. 0) THEN IF (IS .EQ. 14) IENDS = 1 ELSE IF (IS .EQ. 140) IENDS = 1 ENDIF IF (IENDS .EQ. 1) THEN CALL PLA019 (0, IER) IF (IER .GE. 0) THEN BACKSPACE IGBL(5) ELSE IS = -1 ENDIF ENDIF GOTO 300 255 IS = 0 GOTO 280 260 IS = -2 GOTO 280 270 IS = -1 280 IPR(3) = 1 290 IGBL(8) = - IABS(IGBL(8)) 300 IPR(220) = KL IPR(221) = KN IF (MODE .EQ. 1) THEN IF (IS .EQ. 93) THEN IS = 65 ELSE IF (IS .EQ. 71) THEN IS = 26 ELSE IF (IS .EQ. 64) THEN IS = 40 ELSE IF (IS .EQ. 32) THEN IS = 31 ELSE IF (IS .EQ. 156) THEN IS = 13 ENDIF ENDIF 310 RETURN 99999 FORMAT (':: GGIP(', I3, '): ', A) 99998 FORMAT (':: SEx:', A) 99997 FORMAT (':: Def:', A) END SUBROUTINE PLA007 (MODE, LRETN, KL, KN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP34=509,NP38=125,NP39=30,NP41=200,NP45=2048, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /CGGT/ IGGT CHARACTER IGGT*80, ICH*1, ICHU*1 COMMON /NNLP/ NLP(50) COMMON /CIF/ CIFDIR CHARACTER CIFDIR(NP34)*36 COMMON /WORDC/ NWRD CHARACTER NWRD*80, KEYWRD*36, QT*1, UCIFD*36 DIMENSION FA(2) COMMON /CIFCOM/ ISEMC, ILOOP, NL, KW, NW, JKEY, CELL(12) COMMON /LITREF/ LREF CHARACTER LREF(25)*80 IF (LRETN .GT. 0) THEN ICH = ICL(1:1) IF (ICH .EQ. ';') THEN ISEMC = MOD (ISEMC + 1, 2) IF (ISEMC .EQ. 1) THEN LINE = ICL(2:80) GOTO 170 ELSE ICL = ''''//LINE(1:78)//'''' ENDIF ENDIF IF (ISEMC .EQ. 1) THEN LINE = ICL(1:80) GOTO 170 ENDIF I = 1 IF (ICH .EQ. CHAR(13)) THEN GOTO 170 ELSE IF (ICH .EQ. '#') THEN GOTO 170 ELSE IF (ICH .EQ. CHAR(32)) THEN DO 10 I = 2, 80 IF (ICL(I : I) .NE. CHAR(32)) GOTO 20 10 CONTINUE GOTO 170 ENDIF 20 IF (ICL(I : I + 4) .EQ. 'data_') THEN N = INDEX (ICL(1:80), 'CSD_CIF') IF (N .EQ. 0) THEN N = I + 5 ELSE IF (ICL(N+8:N+11) .EQ. 'MIF_') THEN N = N + 12 ELSE N = N + 8 ENDIF IGBL(94) = 1 ENDIF IF (IPR(39) .EQ. 0) THEN JID = ICL(N:79 + N) N = INDEX (JID, CHAR(13)) IF (N .NE. 0) JID(N:N) = CHAR(32) ENDIF LRETN = 0 CALL PLA118 (0, LRETN, CELL, FA) IPR(499) = IPR(499) + 1 IF (IPR(499) .GT. 1) THEN IF (IPR(39) .EQ. 0) THEN IF (IGBL(50) .EQ. 0) WRITE (LU6, 99999) JID GOTO 170 ENDIF BACKSPACE IGBL(5) IFL(1) = 'ENDS' ICL = 'ENDS' KL = 1 KN = 0 IGBL(8) = - IABS(IGBL(8)) GOTO 200 ENDIF ICL = 'TITL '//JID(1:75) IFL(1) = 'TITL' IF (IGBL(3) .NE. 14) CALL GEN108 (LU11, 0) WRITE (LU20, 99987) LINE(I:80) KL = 1 GOTO 200 ELSE IF (ICL(I : I + 4) .EQ. 'loop_') THEN DO 30 J = I + 5, 80 IF (ICL(J:J) .NE. CHAR(32)) THEN IGGT(1:80) = ICL(J:80) GOTO 40 ENDIF 30 CONTINUE 40 ILOOP = 1 IPR(301) = 0 KL = 0 KN = 0 GOTO 170 ELSE IF (ICL(I : I + 4) .EQ. 'stop_') THEN GOTO 170 ENDIF KW = 0 NW = 0 NL = 0 CALL GEN038 (KEYWRD, 1, 36) 50 IESC = 0 IF (ICL(81:81) .EQ. CHAR(13)) ICL(81:81) = CHAR(32) IF (ICL(81:90) .EQ. ' ') THEN IMX = 80 ELSE IMX = NP45 - 1 WRITE (LU6, 99988) ICL(1:15) IPR(544) = IPR(544) + 1 IF (IPR(544) .EQ. 1) WRITE (LU20, 99997) '_802', 1, 1 ENDIF DO 130 I = 1, IMX + 1 ICH = ICL(I : I) IF (ICH .EQ. '#') GOTO 140 IF (ICH .LT. CHAR(32)) ICH = CHAR(32) ICHU = ICH CALL GEN020 (1, ICHU, 1, 1) IF (KW .EQ. 0) THEN IF (NW .EQ. 0) THEN IF (ICH .EQ. '_') THEN KW = 1 KEYWRD(1:1) = ICH IF (ILOOP .EQ. 0) IPR(301) = 1 ELSE IF (ICH .NE. CHAR(32)) THEN IF (ICH .NE. '''' .AND. ICH .NE. '"') THEN CALL GEN038 (NWRD, 3, 80) NW = 2 NWRD(2:2) = ICHU QT = CHAR(32) ELSE NW = 1 QT = ICH ENDIF IF (ICH .EQ. CHAR(92)) THEN IESC = 1 ENDIF IF (IESC .EQ. 1) THEN IESC = 0 ENDIF ENDIF ELSE NW = NW + 1 IF (NW .GT. 1 .AND. NW .LE. 80) THEN NWRD(NW:NW) = ICHU ELSE IF (NW .EQ. 81) THEN WRITE (6, 99986) ICL(1:80), ICL(81:160) ENDIF IF ((ICH .EQ. '''' .OR. ICH .EQ. '"') .AND. IESC .EQ. 1) 1 THEN IESC = 0 ELSE IF (ICH .EQ. CHAR(92)) THEN IESC = 1 ELSE IF (ICH .EQ. QT) THEN IF (QT .EQ. ' ' .OR. QT .EQ. '"') NWRD(NW:NW) = '''' ILOOP = 0 CALL GEN042 (NWRD, FA, INUM) IF (NL .LT. IPR(301)) THEN NL = NL + 1 NLPNL = NLP(NL) IF (NLPNL .EQ. 370) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(9) = NWRD(2 : NW - 1) NCIF(9) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(9), 1, 9) ELSE IF (NLPNL .EQ. 451) THEN RLWS(1) = ''''//NWRD(2:79) IF (RLWS(1)(70:70) .EQ. '3') THEN ISTP = 0 ELSE IF (RLWS(1)(71:71) .EQ. '3') THEN ISTP = 1 ELSE ISTP = -1 ENDIF IF (ISTP .GE. 0) THEN CALL GEN020 (-1, RLWS(1), 2, 13) IF (RLWS(1)(18:19) .EQ. 'FO') RLWS(1)(19:19) = 'o' IF (RLWS(1)(17:18) .EQ. 'FO') 1 RLWS(1)(12:25) = CHAR(92)//'s^2^(Fo^2^)+(' CALL GEN020 (-1, RLWS(1), 47 + ISTP, 51 + ISTP) CALL GEN020 (-1, RLWS(1), 57 + ISTP, 57 + ISTP) CALL GEN020 (-1, RLWS(1), 64 + ISTP, 64 + ISTP) IF (RLWS(1)(37:45) .EQ. '+0.0000P]') 1 RLWS(1)(37:45) = '] ' ENDIF J = INDEX (RLWS(1), 'P)') IF (J .NE. 0) THEN IF (RLWS(1)(J - 8:J - 7) .EQ. '+(') THEN READ (RLWS(1)(J - 6: J - 1), 99990) PAR(227) J = INDEX (RLWS(1), 'P]') IF (J .NE. 0) THEN IF (RLWS(1)(J - 9:J - 8) .EQ. '2^') THEN READ (RLWS(1)(J - 7: J - 1), 99989) 1 PAR(228) ELSE IF (RLWS(1)(J-10:J-9) .EQ. '2^') THEN READ (RLWS(1)(J - 8: J - 1), 99989) 1 PAR(228) ENDIF ENDIF ENDIF IF (PAR(227) .EQ. 0.1 .AND. PAR(228) .EQ. 0.0) 1 WRITE (LU20, 99997) '_085', 1, 1 ENDIF ELSE IF (NLPNL .EQ. 163 .OR. NLPNL .EQ. 481) THEN J = INDEX (NWRD, 'NEUTRON') IF (J .NE. 0) IPR(493) = 5 J = INDEX (NWRD, 'SYNCHROTRON') IF (J .NE. 0) IPR(493) = 4 ELSE IF (NLPNL .EQ. 353) THEN RLWS(2) = ''''//NWRD(2:79) ELSE IF (NLPNL .EQ. 412 .OR. NLPNL .EQ. 443) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(1) = NWRD(2:NW-1) NCIF(1) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(1), 1, 17) ELSE IF (NLPNL .EQ. 369) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(2) = NWRD(2:NW-1) NCIF(2) = NW - 2 ENDIF IF (CCIF(2)(1:4) .EQ. 'FSQD') THEN CCIF(2) = 'Fsqd' IPR(309) = 2 ELSE IPR(309) = 1 ENDIF C * GET ABSORPTION CORRECTION TYPE ELSE IF (NLPNL .EQ. 232) THEN RLWS(3) = ''''//NWRD(2:79) IPR(485) = -2 IF (INUM .LT. 0) THEN IPR(485) = -1 ELSE IF (NWRD(2:3) .EQ. 'NO') THEN IPR(485) = 0 ELSE IF (NWRD(2:3) .EQ. 'AN') THEN IPR(485) = 1 ELSE IF (NWRD(2:3) .EQ. 'IN' .OR. 1 NWRD(2:3) .EQ. 'GA') THEN IPR(485) = 2 ELSE IF (NWRD(2:3) .EQ. 'NU') THEN IPR(485) = 3 ELSE IF (NWRD(2:3) .EQ. 'EM' .OR. 1 NWRD(2:3) .EQ. 'PS') THEN IPR(485) = 4 ELSE IF (NWRD(2:3) .EQ. 'MU') THEN IPR(485) = 5 ELSE IF (NWRD(2:3) .EQ. 'RE') THEN IPR(485) = 6 ELSE IF (NWRD(2:3) .EQ. 'SP') THEN IPR(485) = 7 ELSE IF (NWRD(2:3) .EQ. 'CY') THEN IPR(485) = 8 ENDIF ELSE IF (NLPNL .EQ. 358) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(3) = NWRD(2:NW-1) NCIF(3) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(3), 1, 17) ELSE IF (NLPNL .EQ. 354) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(4) = NWRD(2:NW-1) NCIF(4) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(4), 1, 17) ELSE IF (NLPNL .EQ. 48) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(10) = NWRD(2:NW-1) NCIF(10) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(10), 1, 17) ELSE IF (NLPNL .EQ. 49) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(11) = NWRD(2:NW-1) NCIF(11) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(11), 1, 17) ELSE IF (NLPNL .EQ. 50) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(12) = NWRD(2:NW-1) NCIF(12) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(12), 1, 17) ELSE IF (NLPNL .EQ. 239) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(5) = NWRD(2:NW-1) NCIF(5) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(5), 1, 17) ELSE IF (NLPNL .EQ. 234) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(14) = NWRD(2:NW-1) NCIF(14) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(14), 1, 17) ELSE IF (NLPNL .EQ. 232) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(15) = NWRD(2:NW-1) NCIF(15) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(15), 1, 17) ELSE IF (NLPNL .EQ. 478) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(17) = NWRD(2:NW-1) NCIF(17) = NW - 2 ENDIF ELSE IF (NLPNL .EQ. 357) THEN IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(13) = NWRD(2:NW-1) NCIF(13) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(13), 1, 17) ELSE IF (NLPNL .EQ. 308) THEN LREF(1) = NWRD(2:NW-1) ELSE IF (NLPNL .EQ. 321) THEN LREF(2)(1:NW) = NWRD(2: NW - 1)//', ' ELSE IF (NLPNL .EQ. 320) THEN LREF(2)(7:NW + 6) = NWRD(2:NW-1)//', ' ELSE IF (NLPNL .EQ. 309) THEN LREF(2)(12:NW + 11) = NWRD(2:NW-1) ELSE IF (NLPNL .EQ. 323) THEN IF (IPR(565) .LT. 23) THEN IPR(565) = IPR(565) + 1 LREF(2 + IPR(565)) = NWRD(2:NW-1) ENDIF ELSE IF (NLPNL .EQ. 419 .OR. NLPNL .EQ. 490) THEN IF (IPR(319) .EQ. 0) THEN IPR(319) = 1 CALL SGSM (IDM, 0, FN, 0, 1, IERR) IPR(48) = 1 ENDIF DO 60 J = I + 1, 80 IF (ICL(J:J) .NE. ' ') THEN IGGT(1:80) = ICL(J:80) GOTO 70 ENDIF 60 CONTINUE 70 IFL(1) = 'SYMM ' ICL = 'SYMM '//NWRD(2:NW-1) KL = 1 KN = 0 IF (MODE .EQ. 0 .AND. IGBL(3) .NE. 14) 1 WRITE (LU11) ICL(1:80), 2 (IFL(J), J = 1, 4), (FN(J), J = 1, 6) ELSE IF (NLPNL .EQ. 164) THEN KL = 1 KN = 1 IFL(1) = 'RADN' FN(1) = FA(1) GOTO 200 ELSE IF (NLPNL .EQ. 245) THEN FN(1) = FA(1) ELSE IF (NLPNL .EQ. 246) THEN FN(2) = FA(1) ELSE IF (NLPNL .EQ. 247) THEN FN(3) = FA(1) ELSE IF (NLPNL .EQ. 248) THEN IF (FA(1) .GT. 0.0) THEN FN(4) = FA(1) KL = 1 KN = 4 IFL(1) = 'FACE' GOTO 200 ENDIF ELSE IF (NLPNL .EQ. 507) THEN PAR(437) = PAR(437) + FA(1) ELSE IF (NLPNL .EQ. 508) THEN PAR(438) = PAR(438) + FA(1) ELSE IF (NLPNL .EQ. 1) THEN KL = 2 KN = 0 IFL(1) = 'UIJ' IFL(2) = NWRD(2:NW-1) IF (INUM .NE. 0) THEN WRITE (LU20, 99991) '_799', 1.0, 1.0, IFL(2) ENDIF ELSE IF (NLPNL .EQ. 3) THEN IF (INUM .EQ. 0) GOTO 200 FN(1) = FA(1) FN(7) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 4) THEN IF (INUM .EQ. 0) GOTO 200 FN(6) = FA(1) FN(12) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 5) THEN IF (INUM .EQ. 0) GOTO 200 FN(5) = FA(1) FN(11) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 6) THEN IF (INUM .EQ. 0) GOTO 200 FN(2) = FA(1) FN(8) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 7) THEN IF (INUM .EQ. 0) GOTO 200 FN(4) = FA(1) FN(10) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 8) THEN IF (INUM .EQ. 0) GOTO 200 FN(3) = FA(1) FN(9) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 452) THEN FN(1) = FA(1) / GL(8) FN(7) = FA(2) / GL(8) KN = KN + 2 ELSE IF (NLPNL .EQ. 453) THEN FN(6) = FA(1) / GL(8) FN(12) = FA(2) / GL(8) KN = KN + 2 ELSE IF (NLPNL .EQ. 454) THEN FN(5) = FA(1) / GL(8) FN(11) = FA(2) / GL(8) KN = KN + 2 ELSE IF (NLPNL .EQ. 455) THEN FN(2) = FA(1) / GL(8) FN(8) = FA(2) / GL(8) KN = KN + 2 ELSE IF (NLPNL .EQ. 456) THEN FN(4) = FA(1) / GL(8) FN(10) = FA(2) / GL(8) KN = KN + 2 ELSE IF (NLPNL .EQ. 457) THEN FN(3) = FA(1) / GL(8) FN(9) = FA(2) / GL(8) KN = KN + 2 ELSE IF (NLPNL .EQ. 22) THEN KN = 4 IFL(1) = 'ATOM' IFL(2) = NWRD(2:NW-1) IF (INUM .NE. 0) THEN WRITE (LU20, 99991) '_798', 1.0, 1.0, IFL(2) ENDIF FN(4) = 1.0 KL = KL + 2 ELSE IF (NLPNL .EQ. 35) THEN IFL(3) = NWRD(2:NW-1) KL = KL + 1 ELSE IF (NLPNL .EQ. 19) THEN IF (INUM .EQ. 0) GOTO 200 FN(1) = FA(1) FN(5) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 20) THEN IF (INUM .EQ. 0) GOTO 200 FN(2) = FA(1) FN(6) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 21) THEN IF (INUM .EQ. 0) GOTO 200 FN(3) = FA(1) FN(7) = FA(2) KN = KN + 2 ELSE IF (NLPNL .EQ. 11) THEN IF (INDEX(NWRD(2:2), 'C') .NE. 0) FN(21) = 1.0 ELSE IF (NLPNL .EQ. 31) THEN IF (INDEX(NWRD(2:NW-1), 'R') .NE. 0) FN(22) = 1.0 IF (INDEX(NWRD(2:NW-1), 'G') .NE. 0) FN(22) = 2.0 IF (INDEX(NWRD(2:NW-1), 'PR') .NE. 0) FN(22) = 3.0 IF (INDEX(NWRD(2:NW-1), 'S') .NE. 0) FN(22) = 4.0 ELSE IF (NLPNL .EQ. 33) THEN ELSE IF (NLPNL .EQ. 30) THEN IF (INUM .EQ. 0) THEN KN = KN - 2 GOTO 200 ELSE IF (INUM .LT. 0) THEN FA(1) = 1.0 FA(2) = 0.0 ENDIF IF (FA(1) .LT. 0.0001) THEN WRITE (LU20, 99991) '_074', 0.5, 0.5, IFL(2) GOTO 170 ENDIF FN(4) = FA(1) FN(8) = FA(2) ELSE IF (NLPNL .EQ. 36) THEN IF (INUM .EQ. 0) THEN KN = KN - 2 GOTO 200 ENDIF FN(9) = FA(1) FN(10) = FA(2) ELSE IF (NLPNL .EQ. 423) THEN IF (INUM .EQ. 0) THEN KN = KN - 2 GOTO 200 ENDIF FN(9) = FA(1) / GL(8) FN(10) = FA(2) / GL(8) C * BOND ELSE IF (NLPNL .EQ. 265) THEN LINE = 'BOND ' IFL(1) = NWRD(2:NW - 1) FN(3) = 1.555 FN(4) = 1.555 ELSE IF (NLPNL .EQ. 266) THEN IFL(2) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 267) THEN FN(1) = FA(1) FN(2) = FA(2) ELSE IF (NLPNL .EQ. 269) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(3) = FA(1) ELSE IF (NLPNL .EQ. 270) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(4) = FA(1) C * CONTACT ELSE IF (NLPNL .EQ. 271) THEN LINE = 'CONTACT ' IFL(1) = NWRD(2:NW - 1) FN(3) = 1.555 FN(4) = 1.555 ELSE IF (NLPNL .EQ. 272) THEN IFL(2) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 273) THEN FN(1) = FA(1) FN(2) = FA(2) ELSE IF (NLPNL .EQ. 275) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(3) = FA(1) ELSE IF (NLPNL .EQ. 276) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(4) = FA(1) C * ANGLE ELSE IF (NLPNL .EQ. 258) THEN LINE = 'ANGLE ' IFL(1) = NWRD(2:NW - 1) FN(3) = 1.555 FN(4) = 1.555 FN(5) = 1.555 ELSE IF (NLPNL .EQ. 259) THEN IFL(2) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 260) THEN IFL(3) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 257) THEN FN(1) = FA(1) FN(2) = FA(2) ELSE IF (NLPNL .EQ. 262) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(3) = FA(1) ELSE IF (NLPNL .EQ. 263) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(4) = FA(1) ELSE IF (NLPNL .EQ. 264) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(5) = FA(1) C * TORSION ELSE IF (NLPNL .EQ. 279) THEN LINE = 'TORSION ' IFL(1) = NWRD(2:NW - 1) FN(3) = 1.555 FN(4) = 1.555 FN(5) = 1.555 FN(6) = 1.555 ELSE IF (NLPNL .EQ. 280) THEN IFL(2) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 281) THEN IFL(3) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 282) THEN IFL(4) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 278) THEN FN(1) = FA(1) FN(2) = FA(2) ELSE IF (NLPNL .EQ. 284) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(3) = FA(1) ELSE IF (NLPNL .EQ. 285) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(4) = FA(1) ELSE IF (NLPNL .EQ. 286) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(5) = FA(1) ELSE IF (NLPNL .EQ. 287) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(6) = FA(1) C * H-BOND ELSE IF (NLPNL .EQ. 426) THEN LINE = 'HBOND ' IFL(1) = NWRD(2:NW - 1) FN(9) = 1.555 FN(10) = 1.555 FN(11) = 1.555 ELSE IF (NLPNL .EQ. 427) THEN IFL(2) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 428) THEN IFL(3) = NWRD(2:NW - 1) ELSE IF (NLPNL .EQ. 429) THEN FN(1) = FA(1) FN(2) = FA(2) ELSE IF (NLPNL .EQ. 430) THEN FN(3) = FA(1) FN(4) = FA(2) ELSE IF (NLPNL .EQ. 431) THEN FN(5) = FA(1) FN(6) = FA(2) ELSE IF (NLPNL .EQ. 432) THEN FN(7) = FA(1) FN(8) = FA(2) ELSE IF (NLPNL .EQ. 466) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(9) = FA(1) ELSE IF (NLPNL .EQ. 467) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(10) = FA(1) ELSE IF (NLPNL .EQ. 433) THEN IF (INUM .LE. 0) FA(1) = 1.555 FN(11) = FA(1) C * SUM & MOIETY FORMULA ELSE IF (NLPNL .EQ. 107) THEN N = 1 80 N = N + 1 IF (NWRD(N:N) .EQ. ' ') GOTO 80 RLWS(4) = NWRD(N:79) ELSE IF (NLPNL .EQ. 109) THEN N = 1 90 N = N + 1 IF (NWRD(N:N) .EQ. ' ') GOTO 90 RLWS(5) = NWRD(N:79) IFL(1) = 'FSUM' ICL = RLWS(5) GOTO 200 C * HALL SPACEGROUP ELSE IF (NLPNL .EQ. 421 .OR. NLPNL .EQ. 486) THEN IF (IPR(319) .EQ. 0) IPR(318) = 1 IF (NW .GT. 2) THEN IF (NW .GT. 19) NW = 19 CCIF(16) = NWRD(2:NW-1) NCIF(16) = NW - 2 ENDIF CALL GEN020 (-1, CCIF(16), 3, 17) IF (NWRD(2:2) .NE. '?' .AND. NWRD(2:2) .NE. ' ') 1 THEN IFL(1) = 'HALL' ICL = 'HALL '//NWRD(2:NW-1) KL = 2 KN = 0 GOTO 200 ENDIF C * H-M SPACEGROUP ELSE IF (NLPNL .EQ. 422 .OR. NLPNL .EQ. 487 .OR. 1 NLPNL .EQ. 488) THEN IF (IPR(319) .EQ. 0) IPR(318) = 1 IF (NW .GT. 19) NW = 19 NB = 2 NE = NW - 1 CALL GEN039 (0, NWRD, 2, NW -1, NB, NE) CCIF(6) = NWRD(NB:NE) NCIF(6) = NE - NB + 1 CALL GEN020 (-1, CCIF(6), 2, 17) IF (NWRD(NB:NB) .NE. '?' .AND. 1 NWRD(NB:NB) .NE. ' ') THEN IFL(1) = 'SPGR' ICL = 'SPGR '//NWRD(NB:NE) JID(11:11 + NE - NB) = NWRD(NB:NE) CALL GEN020 (-1, JID, 12, 23) KL = 2 KN = 0 GOTO 200 ELSE C * NO H-M SPACEGROUP SPECIFIED WRITE (LU20, 99997) '_122', 1, 1 ENDIF C * A-AXIS ELSE IF (NLPNL .EQ. 78) THEN CALL PLA118 (1, LRETN, CELL, FA) GOTO 180 C * B-AXIS ELSE IF (NLPNL .EQ. 79) THEN CALL PLA118 (2, LRETN, CELL, FA) GOTO 180 C * C-AXIS ELSE IF (NLPNL .EQ. 80) THEN CALL PLA118 (3, LRETN, CELL, FA) GOTO 180 C * ALPHA ELSE IF (NLPNL .EQ. 74) THEN CALL PLA118 (4, LRETN, CELL, FA) GOTO 180 C * BETA ELSE IF (NLPNL .EQ. 75) THEN CALL PLA118 (5, LRETN, CELL, FA) GOTO 180 C * GAMMA ELSE IF (NLPNL .EQ. 76) THEN CALL PLA118 (6, LRETN, CELL, FA) GOTO 180 C * VOLUME ELSE IF (NLPNL .EQ. 93) THEN PAR(164) = FA(1) PAR(327) = MAX (0.0, FA(2)) IF (FA(2) .LE. 0.0 .AND. IGBL(94) .EQ. 0) THEN WRITE (LU20, 99997) '_151', 1, 1 ELSE CALL GEN041 (PAR(164), PAR(327), IPR(313), 2, 1 IPR(314), IPR(68)) ENDIF GOTO 170 ELSE IF (INUM .EQ. 1) THEN IF (NLPNL .EQ. 164) THEN KL = 1 KN = 1 IFL(1) = 'RADN' FN(1) = FA(1) GOTO 200 C * REPORTED Z ELSE IF (NLPNL .EQ. 77) THEN IPR(276) = NINT(FA(1)) C * CELL_MEASUREMENT_TEMPERATURE ELSE IF (NLPNL .EQ. 88) THEN IPR(261) = NINT(FA(1)) IF (NINT(FA(1)) .EQ. 293) 1 WRITE (LU20, 99997) '_199', 1, IPR(261) KL = 1 KN = 1 IFL(1) = 'TEMP' IFL(2) = 'K' FN(1) = FA(1) GOTO 200 C * CELL_AMBIENT_TEMPERATURE ELSE IF (NLPNL .EQ. 133) THEN IPR(310) = NINT(FA(1)) IF (IPR(310) .EQ. 293) 1 WRITE (LU20, 99997) '_200', 1, IPR(310) C * MOL-WEIGHT ELSE IF (NLPNL .EQ. 110) THEN PAR(308) = FA(1) C * REPORTED F000 ELSE IF (NLPNL .EQ. 240) THEN PAR(324) = FA(1) C * HMIN... LMAX, THETA-MIN THETA-MAX ELSE IF (NLPNL .EQ. 198) THEN IPR(268) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 199) THEN IPR(267) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 200) THEN IPR(270) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 201) THEN IPR(269) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 202) THEN IPR(272) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 203) THEN IPR(271) = NINT(FA(1)) C * REFLECTION -THETA-MIN ELSE IF (NLPNL .EQ. 207) THEN PAR(167) = FA(1) C * REFLECTION -THETA-MAx ELSE IF (NLPNL .EQ. 206) THEN PAR(168) = FA(1) C * REFLECTION - THETA FULL ELSE IF (NLPNL .EQ. 444) THEN PAR(312) = FA(1) C * MEAS FRACTION THETA-MAX ELSE IF (NLPNL .EQ. 458) THEN PAR(313) = FA(1) C * MEAS FRACTION THETA-FULL ELSE IF (NLPNL .EQ. 459) THEN PAR(314) = FA(1) C * DENSITY(diffrn) ELSE IF (NLPNL .EQ. 235) THEN PAR(267) = FA(1) C * DENSITY(meas) ELSE IF (NLPNL .EQ. 236) THEN PAR(158) = FA(1) C * NR REFL & PARAMETERS ELSE IF (NLPNL .EQ. 204) THEN IPR(262) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 410) THEN IPR(263) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 411) THEN IPR(264) = NINT(FA(1)) ELSE IF (NLPNL .EQ. 442) THEN IPR(264) = NINT(FA(1)) C * NUMBER OF UNIQUE REFLECTIONS ELSE IF (NLPNL .EQ. 361) THEN IPR(265) = NINT(FA(1)) C * NUMBER OF L.S.-PARAMETERS ELSE IF (NLPNL .EQ. 360) THEN IPR(266) = NINT(FA(1)) C * R-all ELSE IF (NLPNL .EQ. 363) THEN IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01 PAR(309) = FA(1) C * R-obs/gt ELSE IF (NLPNL .EQ. 364 .OR. NLPNL .EQ. 445) THEN IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01 PAR(173) = FA(1) WRITE (JID(24:31), '(''R ='',F5.2)') FA(1) C * wR-All/Ref ELSE IF (NLPNL .EQ. 371 .OR. NLPNL .EQ. 446) THEN IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01 PAR(174) = FA(1) C * wR-obs/gt ELSE IF (NLPNL .EQ. 372 .OR. NLPNL .EQ. 460) THEN IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01 PAR(310) = FA(1) C * S(all/ref/obs) ELSE IF (NLPNL .EQ. 355 .OR. NLPNL .EQ. 447 .OR. 1 NLPNL .EQ. 356) THEN PAR(299) = FA(1) C * S(Restrained-obs) ELSE IF (NLPNL .EQ. 365) THEN PAR(300) = FA(1) C * DIFF-DENS-MAX ELSE IF (NLPNL .EQ. 347) THEN PAR(177) = FA(1) C * DIFF-DENS-MIN ELSE IF (NLPNL .EQ. 348) THEN PAR(176) = FA(1) C * DIFF-DENS-RMS ELSE IF (NLPNL .EQ. 462) THEN PAR(175) = FA(1) C * R(int) ELSE IF (NLPNL .EQ. 196) THEN PAR(197) = FA(1) WRITE (LU20, 99996) '_020', PAR(197), PAR(197) C * R(sig) ELSE IF (NLPNL .EQ. 197) THEN PAR(198) = FA(1) C * SHIFT/ESD(SU)-MAX ELSE IF (NLPNL .EQ. 367 .OR. NLPNL .EQ. 448) THEN PAR(178) = FA(1) C * SHIFT/ESD(SU)-MEAN ELSE IF (NLPNL .EQ. 368 .OR. NLPNL .EQ. 461) THEN PAR(179) = FA(1) C * FLACK PARAMETER ELSE IF (NLPNL .EQ. 350) THEN CALL GEN041 (FA(1), FA(2), IPR(279), 3, 1 IPR(280), IPR(68)) PAR(433) = FA(1) PAR(434) = FA(2) IF (FA(2) .LE. 0.0) THEN WRITE (LU20, 99996) '_036', 1.0, 1.0 ELSE WRITE (LU20, 99996) '_032', FA(2), FA(2) ENDIF IF (FA(1) .LT. 99999.0) THEN WRITE (LU20, 99996) '_033', ABS(FA(1)), FA(1) ENDIF IF (FA(1) .EQ. 0.0 .AND. FA(2) .GT. 0.0) 1 WRITE (LU20, 99996) '_850', 1.0, FA(2) C * EXTINCTION PARAMETER ELSE IF (NLPNL .EQ. 352) THEN RATIO = 0.0 IF (FA(2) .GT. 0.0) THEN IF (FA(1) .LT. 0.1 * FA(2)) THEN RATIO1 = 10.0 ELSE RATIO = FA(1) / FA(2) RATIO1 = 1.0 / RATIO ENDIF WRITE (LU20, 99996) '_031', RATIO1, RATIO ENDIF CALL GEN041 (FA(1), FA(2), IPR(277), -8, 1 IPR(278), IPR(68)) PAR(229) = FA(1) C * # LS-Restraints ELSE IF (NLPNL .EQ. 362) THEN IPR(273) = NINT(FA(1)) C * DATA RELATED TO ABSORPTION ELSE IF (NLPNL .EQ. 229) THEN PAR(301) = FA(1) C * XTAL-SIZE-MAX ELSE IF (NLPNL .EQ. 251) THEN PAR(302) = FA(1) C * XTAL-SIZE-MID ELSE IF (NLPNL .EQ. 252) THEN PAR(303) = FA(1) C * XTAL-SIZE-MIN ELSE IF (NLPNL .EQ. 253) THEN PAR(304) = FA(1) C * XTAL-RADIUS ELSE IF (NLPNL .EQ. 254) THEN PAR(305) = FA(1) ELSE IF (NLPNL .EQ. 230) THEN PAR(306) = FA(1) ELSE IF (NLPNL .EQ. 231) THEN PAR(307) = FA(1) ENDIF ENDIF IF (NL .EQ. IPR(301)) THEN IF (KL .GT. 0) GOTO 200 IF (MODE .EQ. 0 .AND. IGBL(3) .NE. 14) THEN IF (LINE(1:4) .EQ. 'BOND' .OR. 1 LINE(1:5) .EQ. 'ANGLE' .OR. 2 LINE(1:5) .EQ. 'TORSI' .OR. 3 LINE(1:7) .EQ. 'CONTACT') THEN WRITE (LU11) LINE, (IFL(N), N = 1, 4), 1 (FN(N), N = 1, 6) ELSE IF (LINE(1:5) .EQ. 'HBOND') THEN IF (IFL(1)(1:1) .NE. '?') THEN CALL PLA046 (1, IFL(1), IENM1, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN WRITE (LU20, 99995) '_715', 1, 1, IFL(1) ELSE VDWR1 = VDWR(IEN(IENM1)) CALL PLA046 (1, IFL(2), IENM2, LBB, LBC, 1 LBD, XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN WRITE (LU20, 99995) '_716', 1, 1, IFL(2) ELSE VDWR2 = VDWR(IEN(IENM2)) CALL PLA046 (1, IFL(3), IENM3, LBB, LBC, 1 LBD, XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN WRITE (LU20, 99995) '_717', 1, 1, IFL(3) ELSE IENM0 = IEN(IENM3) VDWR3 = VDWR(IENM0) IF (FN(1) .GT. 0.0) THEN LINE = 'D-H' WRITE (LU11) LINE, (IFL(N), N = 1, 4), 1 (FN(N), N = 1, 2), FN(9), FN(10), 2 0.0, 0.0 ENDIF IF (FN(3) .GT. 0.0) THEN DELTA = FN(3) - VDWR2 - VDWR3 IF (DELTA .GT. -0.2) THEN NQ2 = IFL(2) CALL PLA268 (NQ2) IF (IFL(3)(1:2) .NE. 'CG') 1 WRITE (LU20, 99985) 2 '_480', DELTA, FN(3), NQ2, IFL(3) ENDIF LINE = 'H..A' WRITE (LU11) LINE, (IFL(N), N = 2, 5), 1 (FN(N), N = 3, 4), FN(10), FN(11), 2 0.0, 0.0 ENDIF IF (FN(5) .GT. 0.0) THEN DELTA = FN(5) - VDWR1 - VDWR3 IF (DELTA .GT. 0.0) THEN WRITE (LU20, 99985) 1 '_481', DELTA, FN(5), IFL(1), IFL(3) ENDIF LINE = 'D..A' WRITE (LU11) LINE, IFL(1), 1 (IFL(N), N = 3, 5) 2 ,(FN(N), N = 5, 6), FN(9), FN(11), 3 0.0, 0.0 ENDIF IF (FN(7) .GT. 0.0) THEN DELTA = 180.0 - FN(7) IF (DELTA .GT. 60.0) THEN WRITE (LU20, 99985) 1 '_482', DELTA, FN(7), IFL(1), IFL(3) ENDIF LINE = 'D-H..A' WRITE (LU11) LINE, (IFL(N), N = 1, 4), 1 (FN(N), N = 7, 8), FN(9), FN(10), 2 FN(11), 0.0 ENDIF ENDIF ENDIF LINE(1:1) = CHAR(32) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF C * NOTE GENERATION BY SHELXL IF (JKEY .EQ. 72) THEN IPR(400) = 1 ENDIF CALL GEN038 (NWRD, 1, 80) NW = 0 ELSE IESC = 0 ENDIF ENDIF ELSE C * CONTINUE/FINISH BUILDING KEYWORD IF (ICH .EQ. CHAR(32)) THEN IPR(301) = IPR(301) + ILOOP IF (IPR(301) .GT. 0) THEN IF (IPR(301) .LE. 50) THEN NLP(IPR(301)) = 0 ELSE IPR(2) = 60 GOTO 210 ENDIF ENDIF C * CHECK FOR OFFICIAL KEYWORDS DO 100 J = 1, NP34 IF (KEYWRD .EQ. CIFDIR(J)) THEN IF (IPR(301) .GT. 0) THEN IF (IPR(301) .LE. 50) THEN NLP(IPR(301)) = J ELSE IPR(2) = 60 GOTO 210 ENDIF ENDIF JKEY = J GOTO 120 ENDIF 100 CONTINUE C * CHECK FOR UPPER/LOWER CASE VARIANTS CALL GEN020 (-1, KEYWRD, 1, 36) DO 110 J = 1, NP34 UCIFD = CIFDIR(J) CALL GEN020 (-1, UCIFD, 1, 36) IF (KEYWRD .EQ. UCIFD) THEN IF (IPR(301) .GT. 0) THEN IF (IPR(301) .LE. 50) THEN NLP(IPR(301)) = J ELSE IPR(2) = 60 GOTO 210 ENDIF ENDIF GOTO 120 ENDIF 110 CONTINUE J = 0 IPR(429) = IPR(429) + 1 WRITE (LU6, 99998) KEYWRD 120 CALL GEN038 (KEYWRD, 1, 36) KW = 0 IF (J .NE. 385) THEN GOTO 130 ELSE IF (IGBL(3) .EQ. 14) THEN LRETN = 5 GOTO 170 ELSE GOTO 210 ENDIF ENDIF ELSE IF (KW .LT. 36) THEN KW = KW + 1 KEYWRD(KW:KW) = ICH ENDIF ENDIF ENDIF 130 CONTINUE C * HANDLE INCOMPLETE LOOP (CONTINUE ON NEW LINE) 140 IF (KW .EQ. 0 .AND. NL .LT. IPR(301) .AND. NL .GT. 0) THEN CALL PLA019 (0, IER) IF (IER .LT. 0) GOTO 210 IF (ICL(1:1) .EQ. ';') THEN C * HANDLE ; PROBLEM IN LOOP 150 CALL PLA019 (0, IER) IF (IER .LT. 0) GOTO 210 IF (ICL(1:1) .NE. ';') GOTO 150 ICL(1:9) = ' '' ? '' # ' ENDIF NW = 0 GOTO 50 ENDIF ELSE IF (LRETN .EQ. 0) THEN NWRD(1:1) = '''' ISEMC = 0 ILOOP = 0 NL = 0 JKEY = 0 LRETN = 1 C * LOOK FOR CIF-STYLE (TRIGGERED BY data_) ELSE IF (LRETN .EQ. -1) THEN N = INDEX (ICL, 'data_') IF (N .GT. 0) THEN IGBL(8) = 3 IF (ICL(N + 5:N + 11) .EQ. 'CSD_CIF') IGBL(104) = 1 IPR(220) = 1 IPR(221) = 0 CALL PLA011 IGBL(30) = 1 WRITE (LU6, 99994) ENDIF ENDIF 170 RETURN 180 IF (LRETN .EQ. 2) THEN DO 190 N = 1, 12 FN(N) = CELL(N) 190 CONTINUE KL = 1 KN = 6 IFL(1) = 'CELL' ENDIF RETURN 200 LRETN = 3 RETURN 210 LRETN = 4 RETURN 99999 FORMAT ('W: CIF Data_Record with no Data: Skipped', //, 1 ':: New Data Set ', A, /) 99998 FORMAT ('W: Keyword ', A, ' Not in PLATON/CIFDIR') 99997 FORMAT (A, 2I10) 99996 FORMAT (A, 2F10.3) 99995 FORMAT (A, 2I10, A) 99994 FORMAT (/, ':: Restricted CIF-File Format assumed', 1 ' (Automatic NOMOVE effective) ', /) 99991 FORMAT (A, 2F10.1, A) 99990 FORMAT (F6.4) 99989 FORMAT (F7.4) 99988 FORMAT (':: Record Longer than 80 Bytes found,', 1 ' 2048 Bytes Assumed: ', A, ' ...') 99987 FORMAT (A) 99986 FORMAT (':: ERROR in RECORD:', /, A, /, A, /, '... etc ...', /) 99985 FORMAT (A, 2F10.2, 2A) END SUBROUTINE PLA008 (MODE, LRETN, KL, KN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /CSD/ MODEF, IDC(11), IFLG(19), ICEL(6), IPRX(6), 1 XCRD(4, 3), ISIG(6), CESD(6), IXJX(60), IFDAT(16) COMMON /CCSD/ RCODE, SPGP, CNAME(4), MFDAT, ITXT(30), TFDAT(16) CHARACTER RCODE*8, SPGP*8, CNAME*5, MFDAT*1, ITXT*80, TFDAT*2 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45), 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, TKST*10, 2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12, 3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26, 4 CHSG*6 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 C * ROUTINE HANDLES CSD-FDAT INPUT SCALE = 0.0 IF (LRETN .GT. 0) THEN GOTO 40 10 WRITE (LU6, 99997) RCODE MODEF = 0 20 IF (IGBL(58) .NE. 0) THEN IGBL(54) = IGBL(54) - 1 FN(1) = IGBL(54) CALL PLA011 GOTO 30 ENDIF IGBL(54) = IGBL(54) + 1 30 READ (IGBL(5), 99996, END = 160) ICL(1:80) IF (ICL(1:1) .NE. '#') GOTO 30 BACKSPACE IGBL(5) 40 IF (MODEF .EQ. 0) THEN 50 READ (IGBL(5), 99996, END = 160) ICL(1:80) IF (ICL(1:1) .NE. '#') GOTO 50 READ (ICL, 99989, ERR = 30) MFDAT, RCODE, IDC, IFLG IF (IFLG(1) .EQ. 0 .OR. IDC(6) .EQ. 0 .OR. 1 IDC(8) .EQ. 0) THEN WRITE (LU6, 99997) RCODE GOTO 20 ENDIF READ (IGBL(5), 99996, END = 170) ICL(1:80) READ (ICL, 99988, ERR = 30) ICEL, IPRX, ISIG, 1 SPGP, NTOL PAR(2) = MAX (0.4, NTOL / 100.0) IF (ICEL(1) .EQ. 0) GOTO 20 NWTXT = (IDC(2) + IDC(3) + IDC(4) + IDC(5) + 79) / 80 IF (NWTXT .GT. 0) THEN READ (IGBL(5), 99996, ERR = 30) (ITXT(I), I = 1, NWTXT) WRITE (LU6, 99995) (ITXT(I)(1:77), I = 1, NWTXT) ENDIF IFL(1)(1:4) = 'TITL' KL = 1 KN = 0 IF (IDC(2) .NE. 0) THEN WRITE (ICL, 99998) RCODE, SPGP, ITXT(1)(1:IDC(2)) ELSE WRITE (ICL, 99998) RCODE, SPGP ENDIF MODEF = 1 ELSE IF (MODEF .EQ. 1) THEN DO 60 II = 1, 6 FN(II) = ICEL(II) / 10.0**IPRX(II) 60 CONTINUE IFL(1)(1:4) = 'CELL' KL = 1 KN = 6 MODEF = 2 ELSE IF (MODEF .EQ. 2) THEN DO 70 II = 1, 6 FN(II) = ISIG(II) / 10.0**IPRX(II) 70 CONTINUE IFL(1)(1:4) = 'CESD' KL = 1 KN = 6 MODEF = 3 ELSE IF (MODEF .EQ. 3) THEN IFL(1)(1:4) = 'SPGR' IFL(2) = SPGP(1:7) KL = 2 KN = 0 ICL = 'SPGR '//SPGP CALL GEN038 (ICL, 14, 80) CCIF(6) = SPGP NB = 1 NE = 17 CALL GEN039 (1, CCIF(6), 1, 17, NB, NE) NCIF(6) = NE - NB + 1 MODEF = 4 IF (IFL(2)(1:1) .EQ. ' ') GOTO 40 ELSE IF (MODEF .EQ. 4) THEN IF (IFLG(4) .EQ. 1) THEN ICL = 'LATT P C' ELSE ICL = 'LATT P A' ENDIF CALL SGSM (ICL, 0, XJX, LU6, 0, IERR) IF (IDC(6) .GT. 0) THEN NS = IDC(6) N = -4 80 READ (IGBL(5), 99996) ICL(1:80) READ (ICL(1:75), 99993, ERR = 30) (IXJX(I), I = 1, 60) NB = 0 N = N + 5 NE = MIN (N + 4, IDC(6)) DO 110 I = N, NE DO 100 J = 1, 3 DO 90 K = 1, 3 XJX(K + (J - 1) * 3) = IXJX(NB + K) - 1 90 CONTINUE XJX(9 + J) = MOD(IXJX(NB + 4) + 12, 12) / 12.0 NB = NB + 4 100 CONTINUE WRITE (ICL, 99994) (XJX(L), L = 1, 12) CALL SGSM (ICL, 0, XJX, LU6, 15, IERR) IF (IERR .NE. 0) THEN WRITE (LU6, 99997) RCODE MODEF = 0 GOTO 20 ENDIF 110 CONTINUE NS = NS - 5 IF (NS .GT. 0) GOTO 80 ENDIF CALL SGSM (ICL, 0, XJX, LU6, 18, IERR) IF (IERR .NE. 0) THEN WRITE (LU6, 99997) RCODE MODEF = 0 GOTO 20 ENDIF IPR(48) = NINT(XJX(9)) IF (IDC(7) .GT. 0) READ (IGBL(5), 99992, END = 170) 1 (TFDAT(K), IFDAT(K), K = 1, IDC(7)) NAT = IDC(8) + IDC(9) NATA = 0 120 IF (NAT .GT. 0) THEN NATE = MIN (NAT, 5 - IFLG(3)) READ (IGBL(5), 99996, END = 170) ICL(1:80) IF (IFLG(3) .EQ. 1) THEN READ (ICL, 99991, ERR = 10) 1 (CNAME(I), (XCRD(I, K), K = 1, 3), I = 1, NATE) SCALE = 0.0001 ELSE IF (IFLG(3) .EQ. 2) THEN READ (ICL, 99990, ERR = 10) 1 (CNAME(I), (XCRD(I, K), K = 1, 3), I = 1, NATE) SCALE = 0.00001 ELSE WRITE (LU6, 99997) RCODE MODEF = 0 GOTO 20 ENDIF DO 140 I = 1, NATE IF (NATA .LT. IDC(8)) THEN NATA = NATA + 1 IFL(1) = 'ATOM' IFL(2) = CNAME(I) DO 130 J = 1, 3 FN(J) = XCRD(I, J) * SCALE 130 CONTINUE KL = 2 IPR(221) = 3 IF (MODE .EQ. 0) THEN CALL PLA079 (XNQNR) ELSE CALL PLUT03 (IER) ENDIF ENDIF 140 CONTINUE NAT = NAT - NATE GOTO 120 ENDIF IFL(1) = 'ENDS' ICL = 'ENDS' MODEF = 0 KL = 1 IGBL(8) = - IABS(IGBL(8)) KN = 0 ENDIF LRETN = 1 C * CHECK FOR FDAT-STRUCTURE (TRIGGERED BY # ON FIRST LINE POSITION 1) C * (AND REFCODE IN COLUMN 2:7) ELSE IF (LRETN .EQ. -1) THEN IF (ICL(1:1) .EQ. '#') THEN N = 0 NN = 0 NC = 0 NN1 = 0 NC1 = 0 DO 150 J = 2, 80 CALL GEN105 (3, ICL(J:J), N) IF (N .GT. 0) THEN IF (J .GT. 7) THEN NN1 = NN1 + 1 ELSE NN = NN + 1 ENDIF ELSE CALL GEN105 (1, ICL(J:J), N) IF (N .GT. 0) THEN IF (J .GT. 7) THEN NC1 = NC1 + 1 ELSE NC = NC + 1 ENDIF ENDIF ENDIF 150 CONTINUE IF (NN + NC .NE. 6 .OR. NC1 .NE. 0 .OR. NN1 .LT. 10) THEN LRETN = -2 GOTO 180 ENDIF IGBL(8) = 4 IGBL(30) = 1 IGBL(70) = 0 MODEF = 0 WRITE (LU6, 99999) IPR(220) = 1 IPR(221) = 0 IF (IGBL(25) .NE. 0) THEN CALL PLA011 ELSE CALL GEN108 (LU1, 0) ENDIF GOTO 180 ENDIF ENDIF GOTO 180 160 LRETN = 2 GOTO 180 170 LRETN = 3 180 RETURN 99999 FORMAT (/, ':: FDAT Type File Format Assumed', /) 99998 FORMAT ('TITL ', A, 2X, A, 2X, A) 99997 FORMAT ('W: Entry = ', A, ' Skipped: Incomplete or Erroneous') 99996 FORMAT (A) 99995 FORMAT (':: ', A) 99994 FORMAT ('SYMM ', 9F5.0, 3F8.5) 99993 FORMAT (15(3I1, I2)) 99992 FORMAT (16(A,I3)) 99991 FORMAT (4(A5, 3F5.0)) 99990 FORMAT (3(A5, 3F7.0, 1X)) 99989 FORMAT (2A, 14X, 11I3, 19I1) 99988 FORMAT (6I6, 6I1, 6I2, 9X, A, 3X, I2) END SUBROUTINE PLA009 (MODE, LRETN, KL, KN) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45), 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, TKST*10, 2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12, 3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26, 4 CHSG*6 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 IF (LRETN .EQ. 1) THEN NATC = 0 NATO = 0 NATN = 0 NATS = 0 NATH = 0 NAT = 0 NAT2 = 0 NCRY = 0 XADD = 25.0 ADD = 0.0 10 READ (IGBL(5), 99997, ERR = 50, END = 40) ICL(1:80) CALL GEN020 (1, ICL, 1, 80) IF (ICL(1:4) .EQ. 'ATOM' .OR. ICL(1:4) .EQ. 'HETA') THEN READ (ICL, 99998) NQ1, (FN(L), L = 1, 3) FN(1) = FN(1) + ADD NB = 1 NE = 2 N1 = 0 N2 = 0 IF (ICHAR(NQ1(1:1)) .GT. 64 .AND. ICHAR(NQ1(1:1)) .LT. 91) 1 N1 = 1 IF (ICHAR(NQ1(2:2)) .GT. 64 .AND. ICHAR(NQ1(2:2)) .LT. 91) 1 N2 = 1 IF (N1 .EQ. 1 .AND. N2 .EQ. 0) THEN NE = 1 ELSE IF (N1 .EQ. 0 .AND. N2 .EQ. 1) THEN NB = 2 ELSE IF (N1 .EQ. 1 .AND. N2 .EQ. 1) THEN NAT2 = NAT2 + 1 N = NAT2 GOTO 15 ELSE WRITE (LU6, '(''Atom '', A, '' - Skipped'')') GOTO 30 ENDIF IF (NQ1(NB:NE) .EQ. 'C') THEN NATC = NATC + 1 N = NATC ELSE IF (NQ1(NB:NE) .EQ. 'O') THEN NATO = NATO + 1 N = NATO ELSE IF (NQ1(NB:NE) .EQ. 'N') THEN NATN = NATN + 1 N = NATN ELSE IF (NQ1(2:2) .EQ. 'S') THEN NATS = NATS + 1 N = NATS ELSE IF (NQ1(2:2) .EQ. 'H') THEN NATH = NATH + 1 N = NATH ELSE NAT = NAT + 1 N = NAT ENDIF 15 N = MOD (N, 1000) CALL GEN040 (N, NQ2, IP) IFL(1) = NQ1(NB:NE)//NQ2(1:IP) KL = 1 IPR(473) = 1 IPR(220) = KL IPR(221) = 3 IF (MODE .EQ. 0) THEN CALL PLA079 (XNQNR) IF (XNQNR .EQ. 0.0) THEN IGBL(54) = IGBL(54) + 1 GOTO 40 ENDIF ELSE CALL PLUT03 (IER) ENDIF C * ANISOU ELSE IF (ICL(1:6) .EQ. 'ANISOU') THEN READ (ICL(29:70), 99996) 1 FN(1), FN(2), FN(3), FN(6), FN(5), FN(4) DO 20 I = 1, 6 FN(I) = FN(I) / 10000.0 20 CONTINUE FN(7) = 0.0 FN(8) = 0.0 IPR(32) = MAX (IPR(32), 1) WRITE (LU4) 2, XNQNR, (FN(K), K = 1, 8) GOTO 10 ELSE IF (ICL(1:3) .EQ. 'ADD') THEN XADD = FN(1) ELSE IF (ICL(1:5) .EQ. 'CRYST') THEN NCRY = NCRY + 1 IF (NCRY .EQ. 2) ADD = XADD ELSE IF (ICL(1:3) .EQ. 'END') THEN IFL(1) = 'ENDS' ICL = 'ENDS' KL = 1 IGBL(8) = - IABS(IGBL(8)) KN = 0 GOTO 30 ELSE IF (ICL(1:5) .EQ. 'CONECT') THEN ELSE IF (ICL(1:5) .EQ. 'MASTER') THEN ENDIF GOTO 10 ELSE IF (LRETN .EQ. -1) THEN C * CHECK FOR PDB-FILE-STRUCTURE (TRIGGERED BY KEYWORD HEADER ON LINE 1) IF (ICL(1:6) .EQ. 'HEADER' .OR. 1 ICL(1:6) .EQ. 'REMARK' .OR. 2 ICL(1:6) .EQ. 'COMPND') THEN IGBL(8) = 5 IF (ICL(63:66) .NE. ' ') THEN JID(1:72) = ICL(63:66) ELSE JID(1:72) = ICL(8:50) ENDIF WRITE (LU6, 99999) IPR(220) = 1 IPR(221) = 0 IF (IGBL(25) .NE. 0) THEN CALL PLA011 ELSE CALL GEN108 (LU1, 0) ENDIF GOTO 30 ENDIF IF (ICL(1:5) .EQ. 'CRYST') THEN IGBL(8) = 5 WRITE (LU6, 99999) GOTO 30 ENDIF ENDIF 30 RETURN 40 LRETN = 4 RETURN 50 LRETN = 6 RETURN 99999 FORMAT (/, ':: PDB Type File Format Assumed (HEADER/CRYST)', /) 99998 FORMAT (12X, A, 11X, 3F8.0) 99997 FORMAT (A) 99996 FORMAT (6F7.0) END SUBROUTINE PLA010 (MODE, LRETN) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45), 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, TKST*10, 2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12, 3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26, 4 CHSG*6 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 C * CHEM3D IF (LRETN .EQ. 1) THEN 10 READ (IGBL(5), 99997, ERR = 50, END = 40) ICL(1:80) READ (ICL, 99996, ERR = 50) NQ1(1:6), FN(1), FN(2), FN(3) IFL(1) = ' ' K = 0 DO 20 I = 1, 6 IF (NQ1(I:I) .NE. CHAR(32)) THEN K = K + 1 IFL(1)(K:K) = NQ1(I:I) ENDIF 20 CONTINUE IPR(473) = 1 IPR(220) = 1 IPR(221) = 3 IF (MODE .EQ. 0) THEN CALL PLA079 (XNQNR) ELSE CALL PLUT03 (IER) ENDIF GOTO 10 ELSE IF (LRETN .EQ. -1) THEN C * CHECK FOR CHEM-3D - FORMAT TRIGGERED BY NUMBER IN FIRST THREE POSITIO READ (ICL(1:3), 99998, ERR = 30) NRAT IF (NRAT .NE. 0) THEN IGBL(8) = 6 WRITE (LU6, 99999) GOTO 30 ENDIF ENDIF 30 RETURN 40 LRETN = 4 RETURN 50 LRETN = 6 RETURN 99999 FORMAT (/, ':: CHEM3D Type File Format Assumed', /) 99998 FORMAT (I3) 99997 FORMAT (A) 99996 FORMAT (2X, A, 3F12.0) END SUBROUTINE PLA011 PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /CSD/ MODEF, IDC(11), IFLG(19), ICEL(6), IPRX(6), 1 XCRD(4, 3), ISIG(6), CESD(6), IXJX(60), IFDAT(16) COMMON /CCSD/ RCODE, SPGP, CNAME(4), MFDAT, ITXT(30), TFDAT(16) CHARACTER RCODE*8, SPGP*8, CNAME*5, MFDAT*1, ITXT*80, TFDAT*2 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /MENTRY/ XENTRY(100) CHARACTER CYN*1, REFCOD*8, LIN*14, PRBUF*80, CDATA*8 PRBUF = ' ' IF (LU1 .EQ. LU5) THEN WRITE (LU6, 99999) GOTO 80 ENDIF IF (IPR(220) .GT. 1) THEN IF (IABS(IGBL(8)) .EQ. 4) CALL GEN020 (1, IFL(2), 1, 7) REFCOD = IFL(2) NENTRY = 0 ELSE REFCOD = ' ' IF (IPR(221) .GT. 0) THEN NENTRY = NINT(FN(1)) IF (IGBL(100) .NE. 0) GOTO 60 ELSE NENTRY = 0 IF (IGBL(100) .NE. 0) IPR(462) = 1 ENDIF ENDIF IF (NENTRY .EQ. 0 .OR. IGBL(100) .EQ. 0) THEN IF (IGBL(8) .NE. 0 .AND. IABS(IGBL(8)) .LE. 5) THEN NCARD = 0 NDATA = 0 IGBL(100) = 0 IGBL(86) = NPVD - 6 ILST = 1 XH = 0.0 XV = VERT IF (IGBL(25) * IGBL(32) .EQ. 1) 1 CALL GGIP (HORS, VERT, 0.0, 1) CALL GEN108 (LU1, 0) 10 READ (LU1, 99994, END = 40) ICL(1:80) NCARD = NCARD + 1 NCRD = 1 C * SPF - SEQUENCE IF ((IGBL(8) .EQ. 1 .OR. IGBL(8) .EQ. 2) .AND. 1 ICL(1:4) .EQ. 'TITL') THEN ELSE IF (IABS(IGBL(8)) .EQ. 5 .AND. 1 ICL(1:6) .EQ. 'HEADER') THEN C * CIF - SEQUENCE ELSE IF (ABS(IGBL(8)) .EQ. 3) THEN NPD = INDEX (ICL(1:80), '#') IF (NPD .EQ. 0) NPD = 80 NPC = INDEX (ICL(1:NPD), '_publ_requested_category') IF (NPC .NE. 0) THEN IF (INDEX (ICL(NPC + 24: NPD), 'I') .NE. 0) THEN IGBL(99) = 1 ELSE IF (INDEX (ICL(NPC + 24: NPD), 'M') .NE. 0) THEN IGBL(99) = 2 ELSE IF (INDEX (ICL(NPC + 24: NPD), 'O') .NE. 0) THEN IGBL(99) = 3 ENDIF ELSE IF (INDEX(ICL(1:40), 'data_') .NE. 0 .AND. 1 INDEX(ICL(1:40), '_data_') .EQ. 0) THEN N = INDEX(ICL(1:40), 'data') CDATA = ICL(N + 5:N + 12) IF (CDATA(1:7) .EQ. 'CSD_CIF') THEN IF (ICL(N + 13:N + 16) .EQ. 'MIF_') THEN CDATA = ICL(N + 17:N + 24) ELSE CDATA = ICL(N + 13:N + 20) ENDIF ENDIF NDATA = NCARD - 1 ELSE IF (INDEX(ICL(1:80), '_cell_length_a') .NE. 0) THEN GOTO 20 ENDIF GOTO 10 C * FDAT - SEQUENCE ELSE IF (IABS(IGBL(8)) .EQ. 4 .AND. ICL(1:1) .EQ. '#') THEN READ (ICL, 99993, ERR = 10) MFDAT, RCODE, IDC, IFLG IF (IFLG(1) .EQ. 0 .OR. IDC(6) .EQ. 0 .OR. 1 IDC(8) .EQ. 0) THEN WRITE (LU6, 99992) RCODE GOTO 10 ENDIF READ (LU1, 99994, END = 40) ICL(1:80) NCARD = NCARD + 1 NCRD = 2 READ (ICL, 99991, ERR = 10) ICEL, IPRX, ISIG, SPGP IF (ICEL(1) .EQ. 0) THEN WRITE (LU6, 99992) RCODE GOTO 10 ENDIF ELSE GOTO 10 ENDIF 20 IF (IGBL(86) .GT. 1) THEN IGBL(100) = IGBL(100) + 1 IF (MOD (IGBL(100), 1000) .EQ. 0) THEN IF (IGBL(25) * IGBL(32) .EQ. 1) THEN CALL GGIP20 (0.0, PRBUF, 80, 0.35, 0, 2, 0.5, 0.5) WRITE (PRBUF, 99995) IGBL(100) CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 0.5, 0.5) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF ENDIF IGBL(86) = IGBL(86) - 1 IF (ABS(IGBL(8)) .EQ. 3) THEN VOID(NPVD - 6 - IGBL(100)) = NDATA IF (IGBL(100) .LE. 100) XENTRY(IGBL(100)) = NDATA ELSE VOID(NPVD - 6 - IGBL(100)) = NCARD - NCRD IF (IGBL(100) .LE. 100) XENTRY(IGBL(100)) = NCARD - NCRD ENDIF IF (IPR(220) .EQ. 1 .AND. IPR(221) .EQ. 0) THEN IF (ILST * IPR(462) .EQ. 1) THEN IF (ILST .EQ. 1) THEN IF (IABS(IGBL(8)) .EQ. 5) THEN IF (ICL(63:66) .NE. ' ') THEN WRITE (LIN, 99997) IGBL(100), ICL(63:70) ELSE WRITE (LIN, 99997) IGBL(100), ICL(11:18) ENDIF ELSE IF (IABS(IGBL(8)) .EQ. 4) THEN WRITE (LIN, 99997) IGBL(100), RCODE ELSE IF (IABS(IGBL(8)) .EQ. 3) THEN WRITE (LIN, 99997) IGBL(100), CDATA ELSE IF (IGBL(8) .EQ. 1 .OR. IGBL(8) .EQ. 2) THEN WRITE (LIN, 99997) IGBL(100), ICL(6:13) ENDIF XV = XV - 0.45 CALL GGIP20 (0.0, LIN, 14, 0.34, 1, 2, XH, XV) ENDIF IF (MOD(IGBL(100), 43) .EQ. 0) THEN XH = XH + 4.3 XV = VERT IF (XH + 4.3 .GE. HORS) THEN IF (IGBL(25) * IGBL(32) .EQ. 1) THEN 30 CALL PLA013 (3, 1) IF (IGGT(1:4) .EQ. 'PLOT') THEN GOTO 30 ELSE IF (IGGT(1:4) .EQ. 'EXIT') THEN CALL GEN038 (IGGT, 1, 80) GOTO 80 ELSE IF (IGGT(1:1) .EQ. 'N') THEN CALL GEN038 (IGGT, 1, 80) GOTO 80 ENDIF CALL GEN072 (IGGT, IFL, FN, IPR(220), 1 IPR(221), 0, LU6, 1, 1, 80, 7, NP17) CALL GEN038 (IGGT, 1, 80) IF (IPR(221) .GT. 0) THEN NENTRY = NINT(FN(1)) GOTO 60 ENDIF ELSE CALL PLA285 (1, LU6, 'Continue Listing (Y/N[Y])') READ (LU5, '(A)') CYN ENDIF CALL GEN020 (1, CYN, 1, 1) IF (CYN .EQ. 'N') THEN ILST = 0 ELSE CALL GGIP (HORS, VERT, 0.0, 1) XH = 0.0 XV = VERT ENDIF ENDIF ENDIF ENDIF ELSE IF (IABS(IGBL(8)) .EQ. 5) THEN IF (RCODE .EQ. REFCOD) THEN NENTRY = IGBL(100) IPR(221) = 1 ENDIF ELSEIF (IABS(IGBL(8)) .EQ. 4) THEN IF (RCODE .EQ. REFCOD) THEN NENTRY = IGBL(100) IPR(221) = 1 ENDIF ELSE IF (IABS(IGBL(8)) .EQ. 3) THEN IF (ICL(6:13) .EQ. REFCOD) THEN NENTRY = IGBL(100) IPR(221) = 1 ENDIF ELSE IF (IGBL(8) .EQ. 1) THEN IF (ICL(6:13) .EQ. REFCOD) THEN NENTRY = IGBL(100) IPR(221) = 1 ENDIF ENDIF ENDIF ENDIF GOTO 10 40 IF (IABS(IGBL(8)) .EQ. 4) ICL = 'END ' IF (IPR(462) .EQ. 1) THEN 50 CALL PLA013 (3, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 50 CALL GEN072 (IGGT, IFL, FN, IPR(220), IPR(221), 0, LU6, 1, 1 1, 80, 7, NP17) CYN = IGGT(1:1) CALL GEN038 (IGGT, 1, 80) IF (IPR(221) .GT. 0) NENTRY = NINT(FN(1)) ENDIF IPR(462) = 0 IF (ICL(1:1) .EQ. ';') CALL GEN038 (ICL, 1, 80) CALL GEN108 (LU1, 0) ENDIF ENDIF 60 IF (NENTRY .GT. 0) THEN TIMEZ = CPUTIM() IF (IABS(IGBL(8)) .LE. 5) THEN IF (NENTRY .LE. IGBL(100)) THEN IGBL(54) = NENTRY - 1 IF (NENTRY .LE. 100) THEN NCARD = NINT(XENTRY(NENTRY)) ELSE NCARD = NINT(VOID(NPVD - 6 - NENTRY)) ENDIF CALL GEN108 (LU1, 0) IF (NCARD .GT. 0) THEN DO 70 I = 1, NCARD READ (LU1, 99994) ICL(1:1) 70 CONTINUE ENDIF ICL = 'END' IPR(3) = 1 ELSE WRITE (LU6, 99998) REFCOD, NENTRY, IGBL(100) CALL PLA015 (427, 50) ENDIF ENDIF ELSE IF (IPR(220) .GT. 1) THEN WRITE (LU6, 99998) REFCOD, NENTRY, IGBL(100) CALL PLA015 (427, 50) ENDIF ENDIF 80 RETURN 99999 FORMAT (':: No Entries on File (Instruction Ignored)') 99998 FORMAT (/, ':: Entry not found (', A, 2I10,')') 99997 FORMAT (I5, 1X, A) 99995 FORMAT ('Count Number of Entries on Input:', I6) 99994 FORMAT (A) 99993 FORMAT (2A, 14X, 11I3, 19I1) 99992 FORMAT ('W: FDAT-Entry = ', A, ' Incomplete/skipped') 99991 FORMAT (6I6, 6I1, 6I2, 9X, A, 3X, I2) END SUBROUTINE PLA012 PARAMETER (NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,NP31=30, 1 NP35=110,NP38=125,NP39=30,NP40=380) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31), 1 MNH(NP35) COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /XMENU/ MENX, CMEN CHARACTER MENX(NP31)*11, CMEN(NP40)*11 YGGIP = 0.0 ZGGIP = 0.0 CALL GGIP (-999.0, YGGIP, ZGGIP, 8) MNH(12) = NINT(ZGGIP) CALL PLA293 (PAR(17), 0) IF (MNH(12) .EQ. 1) THEN CMEN(24)(1:3) = 'EPS' CMEN(44)(1:3) = 'EPS' CMEN(104)(1:3) = 'EPS' CMEN(148)(5:7) = 'EPS' ELSE IF (MNH(12) .EQ. 2) THEN CMEN(24)(1:3) = 'HGL' CMEN(44)(1:3) = 'HGL' CMEN(104)(1:3) = 'HGL' CMEN(148)(5:7) = 'HGL' ELSE IF (MNH(12) .EQ. 3) THEN CMEN(24)(1:3) = 'TEK' CMEN(44)(1:3) = 'TEK' CMEN(104)(1:3) = 'TEK' CMEN(148)(5:7) = 'TEK' ENDIF MODE = IGBL(23) IF (MODE .EQ. 15) THEN MNH(27) = MAX (1, IPR(424) + 1) MNH(28) = MAX (1, IPR(425) + 1) MNH(29) = IPR(426) + 1 MNH(47) = IPR(446) + 1 ELSE IF (MODE .EQ. 17) THEN MNH(40) = IABS(IGBL(23)) - 16 ELSE IF (MODE .EQ. 21) THEN MNH(45) = 3 - NINT(LOG(PAR(371)) / LOG(10.0)) IF (PAR(372) .GE. 1.0) THEN MNH(46) = NINT (LOG(PAR(372)) / LOG(2.0)) + 1 ENDIF ELSE MNH(1) = IPR(140) + 1 IF (IPR(478) .EQ. 0) THEN MNH(2) = 1 ELSE IF (IPR(478) .EQ. -1) THEN MNH(2) = 2 ELSE MNH(2) = 3 ENDIF IF (IPR(477) .EQ. 0) THEN MNH(3) = 1 ELSE IF (IPR(477) .EQ. -1) THEN MNH(3) = 2 ELSE MNH(3) = 3 ENDIF MNH(5) = NINT(PAR(349) / 0.05) - 4 MNH(8) = IPR(139) + 1 IF (IPR(111) .NE. 0) 1 MNH(9) = INT(4 - (LOG(FLOAT(IPR(111))) / LOG(2.0))) MNH(10) = NINT (PAR(36) / 0.05) + 1 MNH(11) = MAX (0, IABS(IGBL(23)) - 1) MNH(13) = NINT (PAR(284) / 0.5) + 1 MNH(14) = NINT ((PAR(350) - 0.20) / 0.05) MNH(15) = IPR(232) + 1 MNH(17) = NINT (PAR(273) / 5.0) MNH(18) = NINT (PAR(278) * 10.0) IF (IPR(419) .EQ. 0) IPR(419) = 5 MNH(19) = NINT (LOG(IPR(419) / 2.5) / LOG(2.0)) MNH(20) = NINT (PAR(279) + 1.5) MNH(21) = IGBL(63) + 1 MNH(22) = NINT ((PAR(325) - 1.0) / 0.25) + 1 MNH(23) = IPR(346) + 1 MNH(24) = 6 - NINT(PAR(351) * 10.0) MNH(25) = INT((SIN (PAR(166) / GL(5)) * 20.0 / PAR(17)) - 0.1) MNH(25) = MAX (1, MIN (MNH(25) - 8, 7)) MNH(26) = MIN (4, IPR(68) + 1) MNH(28) = NINT (PAR(86) * 100.0) MNH(29) = NINT (PAR(90) * 100.0) MNH(30) = NINT (PAR(88) * 100.0) MNH(31) = IPR(94) - 1 MNH(32) = NINT (PAR(441) * 10.0) + 1 IF (MNH(28) .EQ. MNH(29) .AND. MNH(29) .EQ. MNH(30)) THEN MNH(27) = MNH(28) ELSE MNH(27) = 0 ENDIF IF (PAR(44) .GT. 0.0) THEN MNH(33) = MIN (NINT(LOG(PAR(44) * 2.0) / LOG(2.0) + 4), 6) ELSE MNH(33) = 1 ENDIF MNH(34) = NINT(PAR(48) / 0.125) + 1 IF (IPR(341) .GT. 1 .AND. IPR(341) .LT. 5) THEN MNH(35) = IPR(341) - 1 ELSE MNH(35) = 0 ENDIF MNH(36) = IPR(311) MNH(37) = IPR(33) + 1 MNH(38) = IPR(177) + 1 MNH(39) = IPR(460) MNH(40) = IABS(IGBL(23)) - 16 IF (IPR(389) .EQ. 1) THEN MNH(41) = 1 ELSE IF (IPR(389) .EQ. -1) THEN MNH(41) = 2 ELSE MNH(41) = 0 ENDIF MNH(42) = NINT(PAR(58) / 0.05) + 1 IF (PAR(439) .GT. 0.0) THEN MNH(43) = NINT(LOG(PAR(439) / 0.125) / LOG(2.0)) + 1 ENDIF MNH(44) = IPR(117) IF (IABS(IGBL(23)) .EQ. 1) THEN MNH(48) = 1 ELSE MNH(48) = MAX (0, IABS(IGBL(23)) - 6) ENDIF ENDIF MNH(49) = IPR(493) MNH(50) = IPR(500) MNH(51) = IPR(461) + 1 MNH(52) = IPR(41) + 1 MNH(53) = IPR(148) + 1 MNH(54) = IGBL(62) IF (IPR(182) .EQ. 0) THEN MNH(55) = IPR(515) + 1 ELSE MNH(55) = IPR(505) ENDIF MNH(56) = IPR(507) IF (IPR(132) .GE. 0) MNH(57) = IPR(132) + 1 MNH(58) = NINT (PAR(85)) MNH(59) = NINT (PAR(89)) MNH(60) = MIN (NINT(PAR(48) / 10.0) + 1, 7) MNH(61) = NINT (PAR(411) * 100.0) MNH(62) = (IPR(514) + 1) / 2 MNH(63) = MIN (NINT(PAR(412) * 5.0), 4) MNH(64) = MIN (4, MAX (1, NINT(PAR(2) / 0.2) + 1)) MNH(65) = MIN (4, MAX (1, NINT(PAR(27) / 0.2) + 3)) MNH(66) = IGBL(88) + 1 MNH(67) = IPR(531) + 1 MNH(68) = IPR(533) MNH(69) = IPR(534) MNH(70) = MIN (5, 1 + MAX (0, NINT(GL(25) / 0.25))) MNH(71) = MIN (4, MAX (1, NINT (PAR(7)) - 2)) MNH(72) = MAX (1, IPR(536)) MNH(73) = MIN (8, MAX (1, NINT ((PAR(13) - 0.4) * 2.0))) MNH(75) = IPR(551) IF (PAR(440) .NE. 0.0) THEN MNH(74) = NINT(LOG(PAR(440)) / LOG(10.0)) ENDIF MNH(76) = IGBL(101) + 1 MNH(77) = NINT (PAR(249) / 10.0) + 1 MNH(78) = NINT (PAR(43) / 0.2) MNH(79) = NINT ((PAR(407) + 0.05) / 0.1) MNH(80) = NINT ((PAR(408) + 0.05) / 0.1) MNH(81) = NINT ((PAR(409) + 0.05) / 0.1) IF (MODE .EQ. 25) THEN MNH(82) = NINT (LOG(PAR(413)) / LOG(2.0) - 0.01) + 1 MNH(83) = NINT (PAR(414) / 0.05) MNH(84) = NINT (FLOAT(IPR(550)) / 25) MNH(85) = NINT (PAR(415) / 0.1) MNH(94) = IPR(567) / 5 ENDIF MNH(86) = MAX (0, IGBL(23) - 9) MNH(87) = MIN (4, MAX (1, NINT(GL(26) / 0.20))) MNH(88) = MIN (5, 1 + MAX (0, NINT(GL(27) / 0.25))) MNH(89) = IPR(206) + 1 IF (IPR(332) .EQ. 1) THEN MNH(90) = 1 ELSE IF (IPR(352) .EQ. 1) THEN MNH(90) = 2 ELSE MNH(90) = 0 ENDIF IF (MODE .EQ. 7) THEN IF (ABS(PAR(18)) .GT. 1.0) THEN MNH(91) = 2 ELSE MNH(91) = 1 ENDIF ENDIF MNH(92) = NINT (PAR(449) / 0.1) MNH(93) = NINT (PAR(420) / 0.05) MNH(95) = MIN (5, NINT (PAR(262) / 2.5)) MNH(96) = MIN (6, NINT (PAR(451) / 2.5)) MNH(97) = MIN (6, (IPR(577) + 1) / 2) MNH(98) = MIN (6, (IPR(578) + 1) / 2) MNH(99) = IGBL(123) + 1 IF (PAR(453) .LE. 0.54) THEN MNH(100) = 1 ELSE IF (PAR(453) .LE. 0.60) THEN MNH(100) = 2 ELSE IF (PAR(453) .LE. 0.65) THEN MNH(100) = 3 ELSE MNH(100) = 4 ENDIF MNH(101) = IPR(394) MNH(102) = IGBL(124) + 1 MNH(103) = IPR(354) + 1 IF (MODE .EQ. 29) THEN IF (PAR(452) .LT. 0.01) THEN MNH(100) = 1 ELSE MNH(100) = NINT(LOG(PAR(452) / 0.25) / LOG(2.0)) + 2 ENDIF ENDIF MENS(12, 24) = INT(MENS(12, 24) / 100) * 100 + IPR(530) + 1 IF (MODE .EQ. 1 .OR. MODE .EQ. 8 .OR. MODE .EQ. 9) THEN MENS(17, MODE) = INT(MENS(17, MODE) / 100) * 100 + IPR(75) + 1 MNH(4) = IPR(45) ELSE IF (MODE .EQ. 2 .OR. MODE .EQ. 3 .OR. MODE .EQ. 5 .OR. 1 MODE .EQ. 6) THEN MENS(14, MODE) = INT(MENS(14, MODE) / 100) * 100 + IPR(75) + 1 ELSE IF (MODE .EQ. 24) THEN MENS(10, MODE) = INT(MENS(10, MODE) / 100) * 100 + IPR(75) + 1 ELSE IF (MODE .EQ. 26) THEN MENS(21, MODE) = INT(MENS(21, MODE) / 100) * 100 + IAN + 1 ELSE IF (MODE .EQ. 10) THEN IF (IPR(44) .EQ. 0) IGBL(59) = 1 ENDIF IF (IPR(116) .EQ. 0) THEN MENS(2, 2) = 4 MENS(2, 1) = 2 ELSE MENS(2, 2) = 1 MENS(2, 1) = 1 ENDIF IF (MODE .EQ. 0) THEN BCD(1:12) = ' '//CHAR(0) ELSE BCD(1:12) = MENX(IABS(MODE))//CHAR(0) ENDIF COLR = 5.0 + IGBL(68) CALL GGIP (-999.0, COLR, 1.0, 10) DO 5 I = 1, 25 BCD(1:12) = ' '//CHAR(0) CALL GGIP (-999.0, 0.0, 1.0, 10 + I) 5 CONTINUE IF (IPR(37) .NE. 0 .OR. IPR(367) .NE. 0 .OR. 1 PAR(101) .GT. 1.0 .OR. MODE .EQ. 15 .OR. 2 MODE .EQ. 17 .OR. MODE .EQ. 18 .OR. MODE .EQ. 19) THEN DO 10 I = 1, 25 IF (MODE .NE. 0) THEN J = MENA(I, IABS(MODE)) IF (J .GT. 0) THEN JJ = J / 1000 J = MOD(J, 1000) IF (JJ .GT. 0) THEN K = I IF (IABS(IPR(J)) .EQ. JJ) K = K + 25 ELSE KK = 0 IF (IPR(J) .NE. 0) KK = 25 K = KK + I ENDIF ELSE IF (J .LT. 0) THEN K = MAX (MIN (IABS(IGBL(IABS(J))), 1), 0) * 25 + I ELSE K = I ENDIF BCD(1:12) = CMEN(MOD(MENU(K, IABS(MODE)), 500))//CHAR(0) IF (MENU(K, IABS(MODE)) .GT. 500) THEN COLR = 2.0 ELSE COLR = 1.0 ENDIF MNS1 = MENS(I, IABS(MODE)) / 100 MNS2 = MOD(MENS(I, IABS(MODE)), 100) IF (MNS1 .GT. 0) THEN XMNS = MNH(MNS1) * 100 + MNS2 ELSE XMNS = MNS2 ENDIF IF (IABS(MODE) .EQ. 16) THEN IF (IPR(78) .NE. -2) THEN IF (I .LT. 5) THEN BCD(1:12) = ' '//CHAR(0) ENDIF ENDIF ENDIF CALL GGIP (-999.0, COLR, XMNS, 10 + I) ENDIF 10 CONTINUE ENDIF IF (IPR(182) .EQ. 0) THEN BCD = SBCD ELSE BCD = 'Click on Unique Atoms to be Omitted'//CHAR(0) ENDIF CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68) * IGBL(82)), 70.0, 110) RETURN END SUBROUTINE PLA013 (MSBCD, MUPCASE) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /GGT/ MEDIUM COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /CTRLC/ CC COMMON /KEYS/ STRING CHARACTER STRING*100 COMMON /NKEYS/ NCNT COMMON /LABMOD/ LMOD LOGICAL CC MMODE = 0 LRET = 0 IF (IGBL(25) .EQ. 1) THEN IF (MSBCD .EQ. 1) THEN SBCD = 'Continue (Y/N[Y])'//CHAR(0) ELSE IF (MSBCD .EQ. 2) THEN SBCD = 'Hit RETURN to Continue'//CHAR(0) ELSE IF (MSBCD .EQ. 3) THEN SBCD = 'Enter # of ENTRY or Continue (Y/N[Y])'//CHAR(0) ELSE IF (MSBCD .EQ. 4) THEN SBCD = '[NEXT]'//CHAR(0) ELSE IF (MSBCD .EQ. 5) THEN SBCD = '[CALC]'//CHAR(0) ENDIF IF (IPR(308) .EQ. 1 .AND. IPR(332) .EQ. 0 .AND. 1 IPR(335) .EQ. 0 .AND. IPR(351) .EQ. 0 .AND. 2 IPR(352) .EQ. 0 .AND. IGBL(3) .NE. 12 .AND. 3 IGBL(3) .NE. 13 .AND. IGBL(3) .NE. 26) THEN SBCD = '[END]'//CHAR(0) ELSE IF (IPR(308) .EQ. 2) THEN SBCD = '[EXIT]'//CHAR(0) ENDIF ENDIF ZZ = 0.0 LRET = 3 IF (CC) THEN ZZ = 1.0 IVENT = 5 ELSE IF (IPR(460) .EQ. 3 .AND. IPR(551) .EQ. 3) THEN LMOD = 0 CALL PLA015 (-1, 0) ENDIF 10 X = 0.0 Y = 0.0 Z = 0.0 IF (IGBL(25) * IGBL(32) .EQ. 1) THEN MMODE = IGBL(23) CALL PLA012 IF (IGBL(48) .EQ. 0) THEN IVENT = 5 CALL GGIP (X, Y, Z, IVENT) ELSE X = 1 IF (IGBL(3) .EQ. 12) THEN Y = 9 ELSE IF (IGBL(3) .EQ. 13) THEN Y = 15 ELSE IF (IGBL(3) .EQ. 26) THEN Y = 16 ENDIF Z = 1 IVENT = 2 IGBL(48) = 0 ENDIF ELSE IVENT = -1 ENDIF LRET = 1 IF (IVENT .GE. 0) THEN IF (IGBL(81) .EQ. 0) THEN MEDIUM = 2 IGGT(16:22) = 'OFF ' CALL GGIP (-999.0, 0.0, 0.0, 6) ENDIF IF (IVENT .EQ. 0) IVENT = 2 IF (IVENT .EQ. 5) THEN 20 IF (BCD(1:1) .EQ. CHAR(13)) THEN IF (NCNT .EQ. 0) THEN IF (IPR(335) .NE. 0) THEN STRING = 'RENAME' NCNT = 6 ELSE IF (IPR(332) .NE. 0) THEN STRING = 'HFIX' NCNT = 4 ELSE IF (IPR(352) .NE. 0) THEN STRING = 'ANIS' NCNT = 4 ELSE IF (IPR(308) .EQ. 1) THEN STRING = 'END ' NCNT = 4 ELSE IF (IPR(308) .EQ. 2) THEN STRING = 'EXIT' NCNT = 4 ELSE IF (IPR(209) .GT. 0) THEN STRING = 'CALC GEOM EUCLID' NCNT = 16 ELSE STRING(1:1) = '!' NCNT = 1 ENDIF ENDIF IGBL(5) = LU5 IF (IPR(308) .EQ. 2) THEN CALL GEN020 (1, STRING, 1, 4) IF (STRING(1:3) .EQ. 'END') THEN STRING(1:4) = 'EXIT' NCNT = 4 ENDIF IF (STRING(1:4) .EQ. 'EXIT') LRET = 7 ENDIF CALL PLA280 (STRING(1:NCNT)) NCNT = 0 IGBL(24) = 1 IF (STRING(1:1) .NE. '!') THEN IF (MMODE .EQ. 10 .OR. MMODE .EQ. 11 .OR. 1 MMODE .EQ. 12) LRET = 2 ELSE IF (MMODE .EQ. 1) LRET = 3 ENDIF ELSE IF (BCD(1:1) .EQ. CHAR(8) .OR. 1 BCD(1:1) .EQ. CHAR(127)) THEN IF (NCNT .GT. 0) THEN NCNT = NCNT - 1 IF (NCNT .EQ. 0) THEN BCD = CHAR(0) ELSE BCD = STRING(1:NCNT)//CHAR(0) ENDIF SBCD = BCD ENDIF LRET = -1 ELSE IF (BCD(1:1) .EQ. CHAR(12)) THEN IF (MMODE .EQ. 1) THEN CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 3 .OR. MMODE .EQ. 22 1 .OR. MMODE .EQ. 15 .OR. MMODE .EQ. 17) LRET = 2 BCD(1:1) = CHAR(13) GOTO 20 ENDIF ELSE IF (BCD(1:1) .EQ. CHAR(0)) THEN LRET = -1 ELSE IF (NCNT .LT. 80) THEN NCNT = NCNT + 1 IF (NCNT .GE. 75) 1 WRITE (LU6, '(''Position'', I3, A)') NCNT, CHAR(7) STRING(NCNT:NCNT) = BCD(1:1) BCD = STRING(1:NCNT)//CHAR(0) SBCD = BCD ENDIF LRET = -1 ENDIF ELSE IF (IVENT .EQ. 4) THEN CALL PLA280 ('EXIT') IF (IGBL(3) .EQ. 4) IGBL(3) = 0 IF (IGBL(45) .EQ. 0 .OR. IGBL(3) .EQ. 3) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. 1 MMODE .EQ. 9) LRET = 7 ELSE IGBL(45) = 0 CALL PLA280 ('REM') IGBL(23) = 10 CALL GEN108 (LU3, 0) WRITE (LU3, 99998) ENDFILE LU3 ENDIF IF (MMODE .EQ. 22) LRET = 1 IF (MMODE .EQ. 10 .OR. MMODE .EQ. 11 .OR. 1 MMODE .EQ. 14) LRET = 2 ELSE IF (IVENT .EQ. 3) THEN IF (NINT(Z) .EQ. 3) CALL PLA300 (3, 0, 0) LRET = -1 ELSE IF (IVENT .EQ. 2) THEN IF (NINT(Z) .EQ. 3) THEN CALL PLA300 (2, 1, NINT(Y)) LRET = -1 ELSE IGBL(5) = LU5 CALL PLA016 (NINT(Y), NINT(X)) ENDIF ELSE IF (IVENT .EQ. 1) THEN CALL PLA020 (X, Y, Z) ENDIF ELSE IF (IVENT .EQ. -1) THEN IGBL(25) = 0 IF (IGBL(3) .EQ. 28) THEN CALL PLA280 ('END') LRET = 7 ENDIF ENDIF IF (LRET .EQ. -1) GOTO 10 ENDIF SBCD = CHAR(0) XGGIP = 0.0 YGGIP = 0.0 CALL GGIP (XGGIP, YGGIP, ZZ, -1) IF (IGBL(74) .EQ. 1) WRITE (LU6, 99999) LRET, IGGT(1:65) IF (MUPCASE .GT. 0) CALL GEN020 (1, IGGT, 1, MUPCASE) RETURN 99999 FORMAT ('>> LRET =', I2, ', >>', A) 99998 FORMAT (80X, /) END SUBROUTINE PLA014 (MODE, NTYP, X, Y, ITEM, IASU) PARAMETER (NP0=6,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP23=18000,NP38=125,NP39=30) COMMON // YXMOL(2, NP23), RA(NPVD) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /TPOS/ XTK(250, 3), NTK(25), KMX, IMIN IBEG = 0 IEND = 0 IF (NTYP .EQ. 1) THEN X1 = X + PAR(61) Y1 = - Y - PAR(62) ELSE X1 = X Y1 = PAR(38) - Y ENDIF ITEM = 0 DELMIN = 1000.0 IMIN = 0 IASU = 0 IF (IABS(MODE) .LE. 2) THEN IB = IPR(158) IF (MODE .GT. 0) THEN IB = IB + IPR(69) * NP0 IBEG = IPR(69) + 1 IF (IPR(341) .EQ. 2) THEN IEND = IPR(62) ELSE IEND = IPR(37) ENDIF ELSE IF (MODE .EQ. -1) THEN IB = IB + IPR(62) * NP0 IBEG = IPR(62) + 1 IEND = IPR(62) + IPR(37) ELSE IF (MODE .EQ. -2) THEN IB = IB + (IPR(62) + IPR(37)) * NP0 IBEG = IPR(62) + IPR(37) + 1 IEND = IPR(62) + IPR(37) + IPR(42) ENDIF DO 10 I = IBEG, IEND IB = IB + NP0 DEL = (RA(IB - 3) - X1)**2 1 + (RA(IB - 2) - Y1)**2 IF (DEL .LT. DELMIN - 0.001) THEN IASU = NINT (RA(IB - 5)) IMIN = I DELMIN = DEL ENDIF 10 CONTINUE ELSE IF (MODE .EQ. 3) THEN DO 20 I = 1, IPR(447) DIST = SQRT ((XTK(I, 1) - X1)**2 + 1 (XTK(I, 2) - Y1)**2) IF (DIST .LT. DELMIN) THEN DELMIN = DIST IMIN = I ENDIF 20 CONTINUE ENDIF IF (DELMIN .LT. PAR(24) / 4) THEN ITEM = IMIN IF (MODE .EQ. 1) THEN IB = IPR(158) + (IMIN - 1) * NP0 CALL PLUT31 (IB, 2.0) IF (IASU .NE. 0) THEN ITEM = IASU / 1000 IASU = MOD (IASU, 1000) ENDIF ENDIF ENDIF RETURN END SUBROUTINE PLA015 (NR, IVAL) PARAMETER (NP10=16,NP12=600,NP13=500,NP17=99,NP37=175,NP38=125, 1 NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1) CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10 COMMON /NOTE/ TXT COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 CHARACTER TXT*79 IF (IGBL(50) .EQ. 2) GOTO 10 MODE = IABS(IGBL(23)) IF (IPR(427) .NE. 0) THEN IF (IGBL(23) .GT. 0) THEN CALL GEN038 (TXT, 1, 79) BCD = TXT//CHAR(0) CALL GGIP (-999.0, 0.0, 80.0, 111) ENDIF IPR(427) = 0 ENDIF IF (NR .EQ. 0) THEN C * ONE LINE NOTIFICATION MESSAGES IF (IVAL .EQ. 1) THEN TXT = 'No Classic Hydrogen Bonds Found' ELSE IF (IVAL .EQ. 2) THEN TXT = 1 'Classic Hydrogen Bonds Found (See Listing for Details)' ELSE IF (IVAL .EQ. 3) THEN TXT = 'No Solvent Accessible Void Found' ELSE IF (IVAL .EQ. 4) THEN TXT = 1 'Solvent Accessible Void Found (See Listing for Details)' ELSE IF (IVAL .EQ. 5) THEN TXT = 'No Obvious Additional Symmetry' ELSE IF (IVAL .EQ. 6) THEN TXT = 1 'Additional (Pseudo)Symmetry Found (See Listing for details)' ELSE IF (IVAL .EQ. 7) THEN TXT = 'No Proper Reflection Data Available !' ELSE IF (IVAL .EQ. 8) THEN TXT = 'Label Conflict, No Substitution !' ELSE IF (IVAL .EQ. 9) THEN TXT = 'Requested Program not Accessible !' ELSE IF (IVAL .EQ. 10) THEN TXT = 'Instruction Ignored' ELSE IF (IVAL .EQ. 11) THEN TXT = 'DIRDIF PATTY for HEAVY ATOM STRUCTURES ONLY !' ELSE IF (IVAL .EQ. 12) THEN TXT = 'No Model-data found for DIRDIF/ORIENT-run' ELSE IF (IVAL .EQ. 13) THEN TXT = 1 'Problem in DIRDIF (See tm/sg/dirdif/*.lis1 for details)' ELSE IF (IVAL .EQ. 14) THEN TXT = 'DIRDIF not Available (or accessible) !' ELSE IF (IVAL .EQ. 15) THEN TXT = ' ' ELSE IF (IVAL .EQ. 16) THEN TXT = 'SIR nor Available (or accessible) !' ELSE IF (IVAL .EQ. 17) THEN TXT = 'SHELXS not Available (or accessible) !' ELSE IF (IVAL .EQ. 18) THEN TXT = 'No (more) NEWMAN, RING or PLANE data (Rewind)? ' ELSE IF (IVAL .EQ. 19) THEN TXT = 'No Crystal Description Available !' ELSE IF (IVAL .EQ. 20) THEN TXT = 'No Cell data yet !' ELSE IF (IVAL .EQ. 21) THEN TXT = 'Automatic Invert to enantiomeric space group' ELSE IF (IVAL .EQ. 22) THEN TXT = 'Spacegroup not acceptable, try again' ELSE IF (IVAL .EQ. 23) THEN TXT = 'SPGR # Out of Range [0:NP42], try again' ELSE IF (IVAL .EQ. 24) THEN TXT = 'TRMX nor acceptable, try again' ELSE IF (IVAL .EQ. 25) THEN TXT = 1 'SPGR-Routine cannot identify appropriate space group' ELSE IF (IVAL .EQ. 26) THEN TXT = 'Formula Requires more Element-number pairs - retry' ELSE IF (IVAL .EQ. 27) THEN TXT = 'No Quest for Polymeric structures' ELSE IF (IVAL .EQ. 28) THEN TXT = 'Unsuitable Instruction. Ignored' ELSE IF (IVAL .EQ. 29) THEN TXT = 'SHELXL97 not Available (or accessible) !' ELSE IF (IVAL .EQ. 30) THEN TXT = 'HFIX-Instruction Valid for RES-files ONLY' ELSE IF (IVAL .EQ. 31) THEN TXT = 'AutoMolFit not possible for this residue pair' ELSE IF (IVAL .EQ. 32) THEN TXT = 1 'Unresolved problem in SIR97 (see tm/sg/sir for details)' ELSE IF (IVAL .EQ. 33) THEN TXT = 'Missing Element(s) in Formula (Enter New Formula)' ELSE IF (IVAL .EQ. 34) THEN TXT = 'No Coordinate Data found in Current Input File' ELSE IF (IVAL .EQ. 35) THEN TXT = 'No Direction Cosines found' ELSE IF (IVAL .EQ. 36) THEN TXT = 'An Editor will be invoked prior to the SHELX launch' ELSE IF (IVAL .EQ. 37) THEN TXT = 'Twin[Matrix NOT Acceptable (Determinant = 0)' ELSE IF (IVAL .EQ. 38) THEN TXT = 'SHELXL-Problem, No Suitable Res-file ' ELSE IF (IVAL .EQ. 39) THEN TXT = 'Result of Calculation on .lis & .lps Files' ELSE IF (IVAL .EQ. 40) THEN TXT = 'RENAME-function valid for RES-files Only !!' ELSE IF (IVAL .EQ. 41) THEN TXT = ' ' ELSE IF (IVAL .EQ. 42) THEN TXT = 'Incorrect Plane Definition. Try Again.' ELSE IF (IVAL .EQ. 43) THEN TXT = 1 'No TLS-Analysis for Polymeric or Disordered Structures' ELSE IF (IVAL .EQ. 44) THEN TXT = 'ANIS-Instruction Valid for RES-files ONLY' ELSE IF (IVAL .EQ. 45) THEN TXT = 'Click on ARU-Code to ADD ARU to ORTEP PLOT' ELSE IF (IVAL .EQ. 46) THEN TXT = 'No Mu-value given !!' ELSE IF (IVAL .EQ. 47) THEN TXT = 'Validation requires NOMOVE mode !!' ELSE IF (IVAL .EQ. 48) THEN TXT = 'Problem/Error in JOIN Instruction !!' ELSE IF (IVAL .EQ. 49) THEN TXT = 'Error - Not Enough Data Items on Input Line !!' ELSE IF (IVAL .EQ. 50) THEN TXT = 'Error: Requested Data Entry not Found. Try Again.' ELSE IF (IVAL .EQ. 51) THEN TXT = 1 'No Matching Reflection Data Set Found on Reflection FCF' ELSE IF (IVAL .EQ. 52) THEN TXT = 'No CAVITY''S Found in this Structure' ELSE IF (IVAL .EQ. 53) THEN TXT = 'Label Conflict, Special Substitution !' ELSE IF (IVAL .EQ. 54) THEN TXT = 'SIR2002 nor Available (or accessible) !' ELSE IF (IVAL .EQ. 55) THEN TXT = 'SHELXD nor Available (or accessible) !' ELSE IF (IVAL .EQ. 56) THEN TXT = 'Insufficient Space for Coordinate Expansion' ELSE IF (IVAL .EQ. 57) THEN TXT = 'Requested SIR version not found !' ENDIF ELSE IF (NR .GT. 0) THEN IF (IPR(341) .EQ. 1) CALL PLUT24 (-3, IDUM, IDUM) IPRNR = IPR(NR) IPR(329) = 0 IPR(332) = 0 IPR(334) = 0 IPR(338) = 0 IPR(341) = 0 IPR(343) = 0 IPR(344) = 0 IPR(348) = 0 IPR(352) = 0 IPR(448) = 0 IPR(440) = 0 IF (IPRNR .EQ. 0 .OR. IPRNR .NE. IVAL) THEN IPR(NR) = IVAL ELSE IPR(NR) = 0 ENDIF IF (IPR(311) .EQ. 1) THEN TXT = 'Click on 2 ATOMS to JOIN' ELSE IF (IPR(311) .EQ. 2) THEN TXT = 'Click on 2 ATOMS to JOIN DASH' ELSE IF (IPR(311) .EQ. 3) THEN TXT = 'Click on 2 ATOMS to DETACH ' ELSE IF (IPR(312) .EQ. 1) THEN TXT = 'Click on at least 5 Atom Pairs to FIT' ELSE IF (IPR(348) .EQ. 1) THEN TXT = 'Click on Atom to SELECT Pattern' ELSE IF (IPR(327) .EQ. 1) THEN IF (MODE .EQ. 1) THEN TXT = 'Click on LABEL [Lower Left Corner] to be DELETED' ENDIF ELSE IF (IPR(328) .EQ. 1) THEN IF (MODE .EQ. 1) THEN TXT = 'Click on (RED) LABEL to INCLUDE LABEL again' ENDIF ELSE IF (IPR(349) .EQ. 1) THEN IF (MODE .EQ. 1) THEN TXT = 'Click on LABEL [Lower Left Corner] to REPOSITION' ELSE TXT = 'Click on LABEL [Center] to REPOSITION' ENDIF ELSE IF (IPR(335) .EQ. 1) THEN TXT = 'Click on ATOM to be RENAMED (or RETURN for ATOM loop)' ELSE IF (IPR(351) .EQ. 1) THEN TXT = 'Click on ATOM to be DELETED [or enter instruction]' ELSE IF (IPR(448) .EQ. 1) THEN TXT = 'Click on TEXT [Lower Left Corner] to REPOSITION' ELSE IF (IPR(344) .EQ. 1) THEN TXT = 'Click on Text [Lower Left Corner] to be DELETED' ELSE IF (IPR(343) .EQ. 1) THEN TXT = 'Click on ATOM as ZOOM CENTRE' ELSE IF (IPR(341) .EQ. 1) THEN TXT = 'Click on Atom for GEOM Calculation' ELSE IF (IPR(341) .EQ. 2) THEN TXT = 'Click on 2 ATOMS for DISTANCE' ELSE IF (IPR(341) .EQ. 3) THEN TXT = 'Click on 3 ATOMS for ANGLE' ELSE IF (IPR(341) .EQ. 4) THEN TXT = 'Click on 4 ATOMS for TORSION ANGLE' ELSE IF (IPR(341) .EQ. 5) THEN TXT = 'Click on 2 ATOMS for LINE 1 and 2 ATOMS FOR LINE 2' ELSE IF (IPR(329) .EQ. 1) THEN TXT = 'Click on 2 ATOMS for VIEW LINE' ELSE IF (IPR(329) .EQ. 2) THEN TXT = 'Click on 3 ATOMS for VIEW PERP' ELSE IF (IPR(329) .EQ. 3) THEN TXT = 'Click on 3 ATOMS for VIEW BISECT' ELSE IF (IPR(476) .NE. 0) THEN TXT = 'Click on Atoms Defining Plane (or Dist/End)' ELSE IF (IPR(552) .NE. 0) THEN TXT = 'Click on Atoms Defining Planes (or With/End)' ELSE IF (IPR(508) .EQ. 1) THEN TXT = 'Click on FROM Atom Followed by TO Atoms and END' ELSE IF (IPR(508) .EQ. 2) THEN TXT = 'Click on Atoms Defining Cg Terminated with END' ELSE IF (IPR(338) .EQ. 1) THEN TXT = 'Click on ATOM to Select Color' ELSE IF (IPR(334) .EQ. 1) THEN WRITE (TXT, '(A, ''['', F4.2, '']'')') 1 'Click on TEXT [Lower Left Corner] to Change Size', 2 PAR(350) ELSE IF (IPR(352) .EQ. 1) THEN TXT = 'Click on ATOM for ANIS [or EXIT] ' ELSE IF (IPR(332) .EQ. 1) THEN TXT = 1 'Click on ATOM for HFIX (or RETURN for loop over ATOMs)' ELSE IF (IPR(440) .EQ. 1) THEN TXT = 'Click on ATOM for ''CALC COORDINATION atom''' ELSE IF (IPR(213) .EQ. 1) THEN TXT = 'Click on ARU-Label for ARU to be Excluded' ELSE IF (IPR(536) .GT. 0) THEN TXT = 'Click on ATOM to change Atom-Type-Color to '// 1 COLR(IPR(536)) ENDIF IF (IGBL(45) .NE. 0 .AND. IGBL(3) .NE. 1) THEN IF (IPR(20) .EQ. 0) THEN IF (IGBL(3) .EQ. 3) THEN BCD = 'Click EXIT to Terminate ORTEP/ADP'//CHAR(0) ELSE BCD = 1'SAVE-mode Loop (Click on PREV, NEXT or EXIT to escape)'//CHAR(0) ENDIF ELSE BCD = 'Click on END to return to System-S'//CHAR(0) ENDIF CALL GGIP (-999.0, 3.0, 80.0, 112) ENDIF ENDIF IF (IGBL(23) .GT. 0) THEN BCD = TXT//CHAR(0) CALL GGIP (-999.0, 2.0, 80.0, 111) ENDIF IF (NR .NE. 0) IPR(427) = 1 IGBL(23) = IABS (IGBL(23)) 10 RETURN END SUBROUTINE PLA016 (MENUV, MENUH) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP31=30,NP35=110,NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 DID*9, TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31), 1 MNH(NP35) COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /GGT/ MEDIUM COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /KEYS/ STRING CHARACTER STRING*100 COMMON /NKEYS/ NCNT CHARACTER BWC*5, COLOR*5 COMMON /LABMOD/ LMOD DX = 0.0 LRET = 1 IGBL(24) = 1 IF (IGBL(35) .EQ. 1) THEN IF (IPR(504) .EQ. 0) CALL PLA280 ('PLOT') ELSE CALL GEN038 (IGGT, 1, 80) ENDIF IF (IPR(346) .GT. 0) THEN COLOR = 'COLOR' ELSE COLOR = ' ' ENDIF IF (IPR(345) .GT. 0) THEN BWC = 'BWC' ELSE BWC = ' ' ENDIF MMODE = IGBL(23) IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9 .OR. MMODE .EQ. 16) THEN PAR(389) = 0.0 IPR(478) = 0 ANGC = 2.0 ** (MENUH - 5) ENDIF IF (MMODE .EQ. 2 .OR. MMODE .EQ. 3) THEN ANGC = 2.0 ** (MENUH - 5) DX = (MENUH - 1) * 0.25 ENDIF C * MENU BOX # 0 & EXPOSE EVENT IF (MENUV .EQ. 0) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN IPR(201) = 1 LRET = 3 ELSE IF (MMODE .EQ. 10) THEN LRET = 1 ELSE IF (MMODE .EQ. 12) THEN CALL PLA280 ('REF') ELSE IF (MMODE .EQ. 22) THEN LRET = 2 ENDIF C * MENU BOX # 1 ELSE IF (MENUV .EQ. 1) THEN IF (MMODE .EQ. 1) THEN IF (MENUH .EQ. 1) THEN IGBL(23) = 1 ELSE IGBL(23) = MENUH + 6 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 2) THEN IGBL(23) = MENUH + 1 LRET = -1 ELSE IF (MMODE .EQ. 3) THEN IGBL(23) = MENUH + 1 LRET = -1 ELSE IF (MMODE .EQ. 4) THEN IGBL(23) = MENUH + 1 LRET = -1 ELSE IF (MMODE .EQ. 5) THEN IGBL(23) = MENUH + 1 LRET = -1 ELSE IF (MMODE .EQ. 6) THEN IGBL(23) = MENUH + 1 LRET = -1 ELSE IF (MMODE .EQ. 7) THEN IGBL(23) = MENUH + 1 LRET = -1 ELSE IF (MMODE .EQ. 8) THEN IF (MENUH .EQ. 1) THEN IGBL(23) = 1 ELSE IGBL(23) = MENUH + 6 ENDIF IPR(453) = 0 IPR(448) = 0 LRET = -1 ELSE IF (MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN IGBL(23) = 1 ELSE IGBL(23) = MENUH + 6 ENDIF IPR(453) = 0 IPR(448) = 0 LRET = -1 ELSE IF (MMODE .EQ. 10) THEN IGBL(23) = MENUH + 9 LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IGBL(23) = MENUH + 9 LRET = -1 ELSE IF (MMODE .EQ. 12) THEN IGBL(23) = MENUH + 9 LRET = -1 ELSE IF (MMODE .EQ. 15) THEN ELSE IF (MMODE .EQ. 16) THEN STRING(1:6) = 'L0MAX ' NCNT = 6 SBCD = STRING(1:NCNT)//CHAR(0) CALL PLA015 (539, 1) IPR(441) = 0 IPR(442) = 0 IPR(443) = 0 IPR(444) = 0 IPR(451) = 0 IPR(540) = 0 IPR(541) = 0 IPR(542) = 0 LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IGBL(23) = 16 + MENUH LRET = -1 ELSE IF (MMODE .EQ. 18) THEN IGBL(23) = 16 + MENUH LRET = -1 ELSE IF (MMODE .EQ. 19) THEN IGBL(23) = 16 + MENUH LRET = -1 ELSE IF (MMODE .EQ. 20) THEN IPR(94) = MENUH + 1 CALL PLA280 ('RESTART') ELSE IF (MMODE .EQ. 21) THEN IF (MENUH .EQ. 4) THEN WL = PAR(16) ELSE IF (MENUH .EQ. 3) THEN WL = 1.54178 ELSE IF (MENUH .EQ. 2) THEN WL = 0.71073 ELSE IF (MENUH .EQ. 1) THEN WL = 0.56086 ENDIF CALL PLA293 (WL, 0) IPR(500) = 0 LRET = 4 ELSE IF (MMODE .EQ. 22) THEN IGBL(23) = 23 LRET = -1 ELSE IF (MMODE .EQ. 23) THEN IGBL(23) = 22 LRET = -1 ELSE IF (MMODE .EQ. 25) THEN IPR(550) = MENUH * 25 PAR(413) = 32.0 CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN PAR(249) = (MENUH - 1) * 10.0 CALL PLA280 ('CALC ADDSYM') ELSE IF (MMODE .EQ. 28) THEN IPR(581) = MOD (IPR(581) + 1, 2) LRET = 2 ELSE IF (MMODE .EQ. 29) THEN IF (MENUH .EQ. 1) THEN PAR(452) = 0.0 ELSE PAR(452) = 0.25 * 2 ** (MENUH - 2) ENDIF CALL PLA280 ('SIGMA') ELSE LRET = -1 ENDIF C * MENU BOX # 2 ELSE IF (MENUV .EQ. 2) THEN IF (MMODE .EQ. 1) THEN IPR(116) = MOD(IPR(116) + 1, 2) IF (IPR(116) .EQ. 1) THEN IPR(479) = 2 IF (IGBL(75) .EQ. 1) IPR(201) = 0 IF (MENUH .EQ. 1) THEN IPR(144) = 3 ELSE IPR(144) = 4 ENDIF ELSE IPR(479) = 2 PAR(389) = 0.0 IPR(201) = 0 ENDIF LRET = 2 ELSE IF (MMODE .EQ. 2) THEN IF (IPR(116) .EQ. 0) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('STEREO RG') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('STEREO RB') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('STEREO') ELSE CALL PLA280 ('STEREO S') ENDIF ELSE CALL PLA280 ('MONO') ENDIF ELSE IF (MMODE .EQ. 3) THEN IPR(173) = MOD(IPR(173) + 1, 2) CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 4) THEN CALL PLA015 (348, 1) IF (IPR(348) .EQ. 1) IPR(345) = 1 IPR(461) = MENUH - 1 LRET = -1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW UNIT') ELSE IF (MMODE .EQ. 6) THEN CALL PLA015 (341, 2) LRET = -1 ELSE IF (MMODE .EQ. 7) THEN CALL PLA280 ('MENU OFF') ELSE IF (MMODE .EQ. 8) THEN IPR(173) = MOD(IPR(173) + 1, 2) LRET = 4 ELSE IF (MMODE .EQ. 9) THEN IGBL(69) = MOD(IGBL(69) + 1, 2) YGGIP = - 100 * (IGBL(69) + 1) CALL GGIP (0.0, YGGIP, 0.0, 0) ELSE IF (MMODE .EQ. 10) THEN IF (IPR(30) .EQ. 0) IGBL(30) = MOD(IGBL(30) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IPR(29) = MOD(IPR(29) + 1, 2) IF (IPR(29) .EQ. 0) THEN IPR(579) = IPR(219) ELSE IPR(579) = IPR(216) ENDIF LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(394) = 1 LRET = 3 ELSE IF (MMODE .EQ. 16) THEN STRING(1:6) = 'L1MAX ' NCNT = 6 SBCD = STRING(1:NCNT)//CHAR(0) CALL PLA015 (540, 1) IPR(441) = 0 IPR(442) = 0 IPR(443) = 0 IPR(444) = 0 IPR(451) = 0 IPR(539) = 0 IPR(541) = 0 IPR(542) = 0 LRET = -1 ELSE IF (MMODE .EQ. 17 .OR. MMODE .EQ. 18) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('LOG') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('RELINK BACK') ELSE CALL PLA280 ('RELINK FORWARD') ENDIF ELSE IF (MMODE .EQ. 20) THEN PAR(441) = (MENUH - 1) * 0.1 CALL PLA280 ('RESTART') ELSE IF (MMODE .EQ. 19) THEN IGBL(44) = MOD(IGBL(44) + 1, 2) IF (IGBL(44) .EQ. 1) CALL PLA015 (0, 36) LRET = -1 ELSE IF (MMODE .EQ. 21) THEN CALL PLA015 (549, 1) IF (IPR(549) .EQ. 1) THEN STRING = 'RADN ' NCNT = 5 SBCD = STRING(1:NCNT)//CHAR(0) ELSE STRING = ' ' NCNT = 0 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('FO') M = MIN (NINT (PAR(412) * 5.0), 4) IF (MENUH .NE. M) THEN IF (MENUH .LT. 4) THEN PAR(412) = MENUH * 0.2 ELSE PAR(412) = 99.0 ENDIF IPR(414) = 1 LRET = 3 ELSE IF (IPR(414) .NE. 1) THEN IPR(414) = 1 ELSE LRET = -1 ENDIF ENDIF ELSE IF (MMODE .EQ. 23) THEN CALL PLA280 ('PT') M = MIN (NINT (PAR(412) * 5.0), 4) IF (MENUH .NE. M) THEN IF (MENUH .LT. 4) THEN PAR(412) = MENUH * 0.2 ELSE PAR(412) = 99.0 ENDIF IPR(414) = 5 LRET = 3 ELSE IF (IPR(414) .NE. 5) THEN IPR(414) = 5 ELSE LRET = -1 ENDIF ENDIF ELSE IF (MMODE .EQ. 24) THEN IF (IPR(533) .EQ. MENUH) THEN IPR(116) = MOD(IPR(116) + 1, 2) IPR(533) = 1 ELSE IF (MENUH .EQ. 2 .AND. IPR(116) .EQ. 0) IPR(116) = 1 IPR(533) = MENUH ENDIF ELSE IF (MMODE .EQ. 25) THEN PAR(413) = 2 ** (MENUH - 1) CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN PAR(43) = MENUH * 0.2 CALL PLA280 ('CALC ADDSYM') ELSE IF (MMODE .EQ. 28) THEN PAR(450) = MENUH * 2.5 CALL PLA280 ('CALC RDF') ELSE IF (MMODE .EQ. 30) THEN IPR(346) = MOD(IPR(346) + 1, 2) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 3 ELSE IF (MENUV .EQ. 3) THEN IF (MMODE .EQ. 1) THEN IPR(212) = MOD(IPR(212) + 1, 2) IPR(201) = 0 LRET = 4 ELSE IF (MMODE .EQ. 2) THEN IF (IPR(212) .EQ. 1) THEN CALL PLA280 ('EXCLUDE H') IPR(212) = 0 ELSE CALL PLA280 ('INCLUDE H') IPR(212) = 1 ENDIF ELSE IF (MMODE .EQ. 3) THEN IPR(173) = 1 IPR(344) = 0 IPR(453) = MOD(IPR(453) + 1, 2) IF (IPR(453) .EQ. 1) THEN CALL PLA280 ('TEXT') IPR(448) = 0 ELSE IPR(448) = 1 ENDIF ELSE IF (MMODE .EQ. 4) THEN CALL PLA015 (338, 1) IF (IPR(338) .EQ. 1) THEN IPR(346) = 1 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW MIN') ELSE IF (MMODE .EQ. 6) THEN CALL PLA015 (341, 3) LRET = -1 ELSE IF (MMODE .EQ. 7) THEN PAR(48) = (MENUH - 1) * 10.0 ELSE IF (MMODE .EQ. 8) THEN IPR(173) = 1 IPR(453) = MOD(IPR(453) + 1, 2) LRET = 5 ELSE IF (MMODE .EQ. 9) THEN IF (IPR(44) .NE. 0) THEN IF (MENUH - 1 .NE. IGBL(88)) THEN IF (IGBL(59) .EQ. 1) THEN IGBL(88) = MENUH - 1 ELSE IGBL(59) = MOD(IGBL(59) + 1, 2) ENDIF ELSE IGBL(59) = MOD(IGBL(59) + 1, 2) IGBL(88) = MENUH - 1 ENDIF ENDIF IPR(201) = 0 LRET = 4 ELSE IF (MMODE .EQ. 10) THEN IF (IPR(44) .NE. 0) THEN IF (MENUH - 1 .NE. IGBL(88)) THEN IF (IGBL(59) .EQ. 1) THEN IGBL(88) = MENUH - 1 ELSE IGBL(59) = MOD(IGBL(59) + 1, 2) ENDIF ELSE IGBL(59) = MOD(IGBL(59) + 1, 2) IGBL(88) = MENUH - 1 ENDIF ENDIF LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IPR(592) = MOD(IPR(592) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(394) = 2 LRET = 3 ELSE IF (MMODE .EQ. 15) THEN IPR(446) = MENUH - 1 IF (IPR(446) .EQ. 0) IPR(428) = 1 ELSE IF (MMODE .EQ. 16) THEN STRING(1:5) = 'TMIN ' NCNT = 5 SBCD = STRING(1:NCNT)//CHAR(0) CALL PLA015 (541, 1) IPR(441) = 0 IPR(442) = 0 IPR(443) = 0 IPR(444) = 0 IPR(451) = 0 IPR(540) = 0 IPR(541) = 0 IPR(542) = 0 LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('DELABS') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('MULABS') ENDIF ELSE IF (MMODE .EQ. 18) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('TREE') ELSE CALL PLA280 ('LIST') ENDIF ELSE IF (MMODE .EQ. 19) THEN CALL PLA280 ('EDITRES') ELSE IF (MMODE .EQ. 20) THEN PAR(439) = 0.125 * 2 ** (MENUH - 1) ELSE IF (MMODE .EQ. 21) THEN PAR(372) = 2 ** (MENUH - 1) LRET = 3 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('FS') M = MIN (NINT (PAR(412) * 5.0), 4) IF (MENUH .NE. M) THEN IF (MENUH .LT. 4) THEN PAR(412) = MENUH * 0.2 ELSE PAR(412) = 99.0 ENDIF IPR(414) = 2 LRET = 3 ELSE IF (IPR(414) .NE. 2) THEN IPR(414) = 2 ELSE LRET = -1 ENDIF ENDIF ELSE IF (MMODE .EQ. 24) THEN IPR(534) = MENUH ELSE IF (MMODE .EQ. 25) THEN IPR(567) = MENUH * 5 CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN PAR(404 - IGBL(97) * 3) = MENUH * 0.1 - 0.05 CALL PLA280 ('CALC ADDSYM') ELSE IF (MMODE .EQ. 28) THEN PAR(451) = MENUH * 2.5 CALL PLA280 ('CALC RDF') ELSE IF (MMODE .EQ. 30) THEN IPR(355) = MOD(IPR(355) + 1, 2) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 4 ELSE IF (MENUV .EQ. 4) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (351, 1) IPR(349) = 0 LRET = -1 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN PAR351 = (6 - MENUH) * 0.1 IF (IABS(IPR(4)) .NE. 1 .OR. PAR(351) .NE. PAR351) THEN PAR(351) = PAR351 IPR(4) = 0 CALL PLA280 ('SOLID '//BWC//COLOR) ELSE CALL PLA280 ('STICK '//COLOR) ENDIF ELSE IF (MMODE .EQ. 3) THEN CALL PLA015 (448, 1) IF (IPR(448) .EQ. 1) IPR(453) = 0 LRET = -1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW XO') ELSE IF (MMODE .EQ. 6) THEN CALL PLA015 (341, 4) LRET = -1 ELSE IF (MMODE .EQ. 7) THEN IF (IPR(30) .EQ. 0) THEN IGBL(97) = MOD(IGBL(97) + 1, 2) ENDIF LRET = -1 ELSE IF (MMODE .EQ. 8) THEN CALL PLA015 (448, 1) IF (IPR(448) .EQ. 1) IPR(453) = 0 LRET = -1 ELSE IF (MMODE .EQ. 9) THEN IF (IPR(431) .EQ. -2) THEN IGBL(104) = MOD(IGBL(104) + 1, 2) ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 10) THEN IF (IPR(30) .EQ. 0) THEN IGBL(97) = MOD(IGBL(97) + 1, 2) ENDIF LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IGBL(56) = MOD(IGBL(56) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(394) = 3 LRET = 3 ELSE IF (MMODE .EQ. 16) THEN STRING(1:5) = 'TMAX ' NCNT = 5 SBCD = STRING(1:NCNT)//CHAR(0) CALL PLA015 (542, 1) IPR(441) = 0 IPR(442) = 0 IPR(443) = 0 IPR(444) = 0 IPR(451) = 0 IPR(539) = 0 IPR(540) = 0 IPR(541) = 0 LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('ABSTOMPA') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('ABSPSI') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('ABSNONE') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('REMOVE') ELSE IF (MMODE .EQ. 20) THEN IPR(514) = 2 * MENUH - 1 CALL PLA280 ('RESTART') ELSE IF (MMODE .EQ. 21) THEN IPR(500) = MENUH LRET = 3 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('DI') M = MIN (NINT (PAR(412) * 5.0), 4) IF (MENUH .NE. M) THEN IF (MENUH .LT. 4) THEN PAR(412) = MENUH * 0.2 ELSE PAR(412) = 99.0 ENDIF IPR(414) = 3 LRET = 3 ELSE IF (IPR(414) .NE. 3) THEN IPR(414) = 3 ELSE LRET = -1 ENDIF ENDIF ELSE IF (MMODE .EQ. 24) THEN IPR(526) = 1 ELSE IF (MMODE .EQ. 25) THEN PAR(414) = MENUH * 0.05 CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN PAR(405 - IGBL(97) * 3) = MENUH * 0.1 -0.05 CALL PLA280 ('CALC ADDSYM') ELSE LRET = -1 ENDIF C * MENU BOX # 5 ELSE IF (MENUV .EQ. 5) THEN IF (MMODE .EQ. 1) THEN IPR(45) = MENUH IPR(201) = 0 LRET = 2 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN IF (IABS(IPR(4)) .NE. 2) THEN CALL PLA280 ('ROD '//BWC//COLOR) ELSE CALL PLA280 ('STICK '//COLOR) ENDIF ELSE IF (MMODE .EQ. 3 .OR. MMODE .EQ. 8) THEN PAR(350) = 0.20 + 0.05 * MENUH LRET = -1 ELSE IF (MMODE .EQ. 4) THEN LRET = -1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW YO') ELSE IF (MMODE .EQ. 6) THEN CALL PLA015 (341, 1) LRET = -1 ELSE IF (MMODE .EQ. 7) THEN IGBL(105) = MOD(IGBL(105) + 1, 2) ELSE IF (MMODE .EQ. 9) THEN IGBL(105) = MOD(IGBL(105) + 1, 2) IPR(201) = 0 LRET = 2 ELSE IF (MMODE .EQ. 10) THEN IPR(68) = MENUH - 1 LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IF (IPR(30) .EQ. 0) THEN IPR(501) = MOD (IPR(501) + 1, 2) IPR(119) = 0 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 15) THEN IPR(320) = MOD (IPR(320) + 1, 2) ELSE IF (MMODE .EQ. 16) THEN CALL PLA015 (441, 1) IPR(442) = 0 IPR(443) = 0 IPR(444) = 0 IPR(451) = 0 IPR(539) = 0 IPR(540) = 0 IPR(541) = 0 IPR(542) = 0 IF (IPR(441) .EQ. 1) THEN STRING = 'MU' NCNT = 3 SBCD = STRING(1:NCNT)//CHAR(0) ELSE NCNT = 0 STRING = ' ' ENDIF LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('TRMX') ELSE CALL PLA280 ('SPGR') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('XTAL') ELSE IF (MMODE .EQ. 20) THEN IPR(117) = MENUH ELSE IF (MMODE .EQ. 21) THEN PAR(411) = MENUH / 100.0 LRET = 3 ELSE IF (MMODE .EQ. 22) THEN IF (IGBL(29) .LT. 0) THEN CALL PLA280 ('SQ') M = MIN (NINT (PAR(412) * 5.0), 4) IF (MENUH .NE. M) THEN IF (MENUH .LT. 4) THEN PAR(412) = MENUH * 0.2 ELSE PAR(412) = 99.0 ENDIF IPR(414) = 4 LRET = 3 ELSE IF (IPR(414) .NE. 4) THEN IPR(414) = 4 ELSE LRET = -1 ENDIF ENDIF ELSE CALL PLA015 (427, 7) LRET = -1 ENDIF ELSE IF (MMODE .EQ. 24) THEN IPR(526) = 2 ELSE IF (MMODE .EQ. 25) THEN IPR(469) = MOD(IPR(469) + 1, 2) CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN PAR(406 - IGBL(97) * 3) = MENUH * 0.1 - 0.05 CALL PLA280 ('CALC ADDSYM') ELSE LRET = -1 ENDIF C * MENU BOX # 6 ELSE IF (MENUV .EQ. 6) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (440, 1) IPR(351) = 0 IPR(349) = 0 IPR(327) = 0 IPR(328) = 0 LRET = -1 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN IF (IABS(IPR(4)) .NE. 3) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('CPK '//BWC//COLOR) ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('CPK STICK '//BWC//COLOR) ENDIF ELSE CALL PLA280 ('STICK '//COLOR) ENDIF ELSE IF (MMODE .EQ. 3) THEN CALL PLA015 (344, 1) LRET = -1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW ZO') ELSE IF (MMODE .EQ. 6) THEN IPR(90) = 256 CALL PLUT12 ELSE IF (MMODE .EQ. 7) THEN IPR(14) = MOD (IPR(14) + 1, 2) ELSE IF (MMODE .EQ. 8) THEN IPR(453) = 0 CALL PLA015 (344, 1) LRET = -1 ELSE IF (MMODE .EQ. 9) THEN IPR(506) = MOD(IPR(506) + 1, 2) IPR(201) = 0 LRET = 2 ELSE IF (MMODE .EQ. 10) THEN IF (IGBL(71) .EQ. 0) IPR(119) = MOD (IPR(119) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IPR(502) = MOD (IPR(502) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(406) = MOD (IPR(406) + 1, 2) IPR(389) = 0 LRET = 4 ELSE IF (MMODE .EQ. 15) THEN IPR(428) = MOD (IPR(428) + 1, 2) IF (IPR(428) .EQ. 0) IPR(446) = 1 ELSE IF (MMODE .EQ. 16) THEN CALL PLA015 (442, 1) IPR(441) = 0 IPR(443) = 0 IPR(444) = 0 IPR(451) = 0 IPR(539) = 0 IPR(540) = 0 IPR(541) = 0 IPR(542) = 0 IF (IPR(442) .EQ. 1) THEN STRING = 'RADIUS' NCNT = 7 SBCD = STRING(1:NCNT)//CHAR(0) ELSE STRING = ' ' NCNT = 0 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('FORMULA') ELSE CALL PLA280 ('Z') ENDIF ELSE IF (MMODE .EQ. 18) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('CELL') ELSE CALL PLA280 ('HELENA') ENDIF ELSE IF (MMODE .EQ. 19) THEN CALL PLA280 ('TWIN') ELSE IF (MMODE .EQ. 20) THEN PAR(440) = 10 ** MENUH ELSE IF (MMODE .EQ. 21) THEN IF (MENUH .LT. 3) THEN PAR(371) = 10 ** (3 - MENUH) ELSE PAR(371) = 1.0 / 10 ** (MENUH - 3) ENDIF LRET = 3 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('PLAN') IPR(416) = 0 IPR(420) = 0 ELSE IF (MMODE .EQ. 24) THEN IPR(526) = 3 ELSE IF (MMODE .EQ. 25) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 26) THEN IPR(568) = MOD (IPR(568) + 1, 2) LRET = -1 ELSE LRET = -1 ENDIF C * MENU BOX # 7 ELSE IF (MENUV .EQ. 7) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (341, MENUH + 1) LRET = -1 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN IF (IABS(IPR(4)) .NE. 4) THEN CALL PLA280 ('STRAW '//BWC//COLOR) ELSE CALL PLA280 ('STICK '//COLOR) ENDIF ELSE IF (MMODE .EQ. 3 .OR. MMODE .EQ. 8) THEN CALL PLA015 (334, 1) LRET = -1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW AFACE') ELSE IF (MMODE .EQ. 6) THEN IPR(90) = 16 CALL PLUT12 ELSE IF (MMODE .EQ. 7) THEN IF (IPR(17) .EQ. 0) IGBL(30) = MOD(IGBL(30) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 9) THEN IGBL(55) = MOD (IGBL(55) + 1, 2) ELSE IF (MMODE .EQ. 10) THEN IGBL(55) = MOD (IGBL(55) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IPR(497) = MOD(IPR(497) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(387) = MOD (IPR(387) + 1, 2) IPR(389) = 0 LRET = 4 ELSE IF (MMODE .EQ. 15) THEN IF (IPR(370) .EQ. 0) IPR(424) = MENUH - 1 ELSE IF (MMODE .EQ. 16) THEN CALL PLA015 (443, 1) IPR(441) = 0 IPR(442) = 0 IPR(444) = 0 IPR(451) = 0 IF (IPR(443) .EQ. 1) THEN STRING = 'MUR' NCNT = 4 SBCD = STRING(1:NCNT)//CHAR(0) ELSE STRING = ' ' NCNT = 0 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('SHELXS97 TREF') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('SHELXS97 PATT') ELSE CALL PLA280 ('SHELXD') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('PLATON CSD') ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('PLAN') IPR(416) = 1 IPR(420) = 0 ELSE IF (MMODE .EQ. 25) THEN IF (IPR(543) .EQ. 1) THEN IPR(543) = 0 ELSE IPR(543) = 1 CALL PLA280 ('TWIN') IPR(576) = 0 ENDIF ELSE LRET = -1 ENDIF C * MENU BOX # 8 ELSE IF (MENUV .EQ. 8) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (311, MENUH) LRET = -1 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN IF (IABS(IPR(4)) .NE. 0) THEN CALL PLA280 ('STICK '//COLOR) ELSE CALL PLA280 ('STRAW '//BWC//COLOR) ENDIF ELSE IF (MMODE .EQ. 3) THEN CALL PLA015 (351, 1) IF (IPR(335) .EQ. 1) CALL PLA015 (335, 1) IF (IPR(349) .EQ. 1) CALL PLA015 (349, 1) IF (IGBL(75) .EQ. 0) THEN CALL PLA280 ('LABEL ON') ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW BFACE') ELSE IF (MMODE .EQ. 6) THEN IPR(90) = 32 CALL PLUT12 ELSE IF (MMODE .EQ. 7) THEN IPR(231) = MOD (IPR(231) + 1, 2) ELSE IF (MMODE .EQ. 8) THEN PAR(7) = 2.0 + MENUH LRET = -1 ELSE IF (MMODE .EQ. 9) THEN IF (IPR(75) .GT. 1) THEN CALL PLA015 (312, 1) IFL(1) = 'FIT' IPR(33) = MENUH - 1 IF (IPR(312) .EQ. 0) THEN IPR(81) = - LMOD - 1 CALL PLA035 (1) LMOD = 0 IGBL(23) = IABS(IGBL(23)) ENDIF ENDIF LRET = -1 ELSE IF (MMODE .EQ. 10) THEN IPR(324) = MOD (IPR(324) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IGBL(61) = MOD (IGBL(61) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(388) = MOD (IPR(388) + 1, 2) IPR(389) = 0 LRET = 4 ELSE IF (MMODE .EQ. 15) THEN IF (IPR(370) .EQ. 0) IPR(425) = MENUH -1 ELSE IF (MMODE .EQ. 16) THEN CALL PLA015 (444, 1) IPR(441) = 0 IPR(442) = 0 IPR(443) = 0 IPR(451) = 0 IF (IPR(444) .EQ. 1) THEN STRING = 'GRID' NCNT = 5 SBCD = STRING(1:NCNT)//CHAR(0) ELSE STRING = ' ' NCNT = 0 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('DIRDIF PATTY') ELSE CALL PLA280 ('DIRDIF ORIENT') ENDIF ELSE IF (MMODE .EQ. 18) THEN VAL = 1.0 IF (MENUH .EQ. 1) THEN VAL = 0.54 ELSE IF (MENUH .EQ. 2) THEN VAL = 0.60 ELSE IF (MENUH .EQ. 3) THEN VAL = 0.65 ENDIF WRITE (IGGT, '(''STLM'', F10.2, 5X)') VAL PAR(453) = VAL ELSE IF (MMODE .EQ. 19) THEN IGBL(91) = MOD(IGBL(91) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('PLAN') IPR(416) = 2 IPR(420) = 0 ELSE IF (MMODE .EQ. 23) THEN IPR(577) = (MENUH * 2) - 1 LRET = -1 ELSE IF (MMODE .EQ. 25) THEN IF (IPR(543) .EQ. 2) THEN IPR(543) = 0 ELSE IPR(543) = 2 CALL PLA280 ('TWIN') IPR(576) = 0 ENDIF ELSE LRET = -1 ENDIF C * MENU BOX # 9 ELSE IF (MENUV .EQ. 9) THEN IF (MMODE .EQ. 1) THEN IF (MENUH .EQ. 1) THEN LMOD = 1 IFL(1) = 'DEFINE' IPR(507) = 1 CALL PLA015 (508, 1) LRET = -1 ELSE IF (MENUH .EQ. 3) THEN IF (IPR(508) .EQ. 1) THEN IPR(507) = 3 IPR(508) = 0 WRITE (IGGT, 99995) (IFL(I), I = 1, LMOD) IGBL(23) = IABS(IGBL(23)) LRET = 7 ENDIF ENDIF ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN 10 IPR(345) = MOD(IPR(345) + 1, 2) IF (IPR(345) .EQ. 1) THEN IF (MENUH .EQ. 1) THEN IPR(478) = 0 ELSE IF (MENUH .EQ. 2) THEN IPR(478) = -1 ELSE IPR(478) = 1 ENDIF ELSE IF (MENUH * IPR(478) .EQ. -2 .OR. 1 MENUH * IPR(478) .EQ. 3 .OR. 2 (MENUH .EQ. 1 .AND. IPR(478) .EQ. 0)) THEN IPR(478) = 0 ELSE IPR(478) = 0 GOTO 10 ENDIF ENDIF IF (IGBL(35) .EQ. 1) THEN CALL PLA280 ('PLOT') ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 3) THEN IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1) IF (IPR(349) .EQ. 1) CALL PLA015 (349, 1) IF (IGBL(3) .NE. 0) THEN CALL PLA015 (335, 1) IF (IGBL(75) .EQ. 0) THEN CALL PLA280 ('LABEL ON') ELSE LRET = -1 ENDIF ELSE CALL PLA015 (427, 40) LRET = -1 ENDIF ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW CFACE') ELSE IF (MMODE .EQ. 6) THEN IPR(90) = 512 CALL PLUT12 ELSE IF (MMODE .EQ. 8) THEN IGBL(52) = MOD (IGBL(52) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 9) THEN IF (IPR(75) .GT. 1) THEN IPR(33) = MENUH - 1 CALL PLA280 ('FIT 1 2') ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 10) THEN IPR(87) = MOD(IPR(87) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IF (IPR(30) .EQ. 0) IPR(181) = MOD(IPR(181) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 15) THEN IF (IPR(370) .EQ. 0) IPR(426) = MENUH - 1 ELSE IF (MMODE .EQ. 16) THEN CALL PLA015 (451, 1) IPR(441) = 0 IPR(442) = 0 IPR(443) = 0 IPR(444) = 0 IF (IPR(451) .EQ. 1) THEN STRING = 'FACE' NCNT = 5 SBCD = STRING(1:NCNT)//CHAR(0) ELSE STRING = ' ' NCNT = 0 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('SHELXS86') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('SIR97') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('SIR2002') ENDIF ELSE IF (MMODE .EQ. 18) THEN IGBL(97) = MOD(IGBL(97) + 1, 2) ELSE IF (MMODE .EQ. 19) THEN IGBL(51) = MOD(IGBL(51) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('PLAN') IPR(416) = 3 IPR(420) = 0 ELSE IF (MMODE .EQ. 23) THEN IPR(578) = (MENUH * 2) - 1 LRET = -1 ELSE IF (MMODE .EQ. 24) THEN IPR(537) = MOD(IPR(537) + 1, 2) ELSE IF (MMODE .EQ. 25) THEN IF (IPR(543) .EQ. 3) THEN IPR(543) = 0 ELSE IPR(543) = 3 CALL PLA280 ('TWIN') IPR(576) = 0 ENDIF ELSE IF (MMODE .EQ. 26) THEN IPR(503) = MOD(IPR(503) + 1, 2) LRET = -1 ELSE LRET = -1 ENDIF C * MENU BOX # 10 ELSE IF (MENUV .EQ. 10) THEN IF (MMODE .EQ. 1) THEN IF (MENUH .EQ. 1) THEN CALL PLA226 (0, 0.0) ELSE IF (MENUH .EQ. 2) THEN IGBL(67) = 0 IPR(201) = 0 ELSE IF (MENUH .EQ. 3) THEN CALL PLA226 (2, 90.0) ELSE IF (MENUH .EQ. 4) THEN CALL PLA226 (1, -90.0) ELSE IF (MENUH .EQ. 5) THEN CALL PLA226 (3, 90.0) ENDIF MNH(6) = MENUH LRET = 4 ELSE IF (MMODE .EQ. 2) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('VIEW UNIT') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('VIEW MIN') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('VIEW XO') ELSE IF (MENUH .EQ. 4) THEN CALL PLA280 ('VIEW YO') ELSE IF (MENUH .EQ. 5) THEN CALL PLA280 ('VIEW ZO') ENDIF MNH(6) = MENUH ELSE IF (MMODE .EQ. 3) THEN CALL PLA015 (349, 1) IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1) IF (IPR(335) .EQ. 1) CALL PLA015 (335, 1) IF (IGBL(75) .EQ. 0) THEN CALL PLA280 ('LABEL ON') ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 4) THEN IPR(345) = 0 IPR(139) = MENUH - 1 ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('VIEW INVERT') ELSE IF (MMODE .EQ. 6) THEN CALL PLA280 ('LIST CELL') ELSE IF (MMODE .EQ. 7) THEN CALL PLA280 ('HELP') ELSE IF (MMODE .EQ. 8) THEN CALL PLA226 (-4, 0.0) ELSE IF (MMODE .EQ. 9) THEN IPR(41) = MENUH - 1 LRET = -1 ELSE IF (MMODE .EQ. 10) THEN IF (IPR(30) .EQ. 0) IGBL(52) = MOD (IGBL(52) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IPR(41) = MENUH - 1 LRET = -1 ELSE IF (MMODE .EQ. 14) THEN PAR(165) = ASIN((0.45 + MENUH * 0.05) * PAR(17)) * GL(5) LRET = 3 ELSE IF (MMODE .EQ. 16) THEN STRING(1:5) = 'DELF ' NCNT = 5 SBCD = STRING(1:NCNT)//CHAR(0) LRET = -1 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('EXOR') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('EXORS') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('EXORD') ELSE IF (MENUH .EQ. 4) THEN CALL PLA280 ('EXORC') ENDIF ELSE IF (MMODE .EQ. 18) THEN IGBL(40) = MOD(IGBL(40) + 1, 2) ELSE IF (MMODE .EQ. 19) THEN IGBL(96) = MOD(IGBL(96) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 22) THEN CALL PLA280 ('PLAN') IPR(416) = 4 IPR(420) = MENUH MNH(16) = MENUH IF (MENUH .EQ. 1) THEN PAR(272) = PAR(101) PAR(273) = PAR(102) ELSE IF (MENUH .EQ. 2) THEN PAR(272) = PAR(101) PAR(273) = PAR(103) ELSE PAR(272) = PAR(102) PAR(273) = PAR(103) ENDIF IF (PAR(272) .LT. PAR(273)) THEN PAR(276) = 90.0 CALL GEN018 (PAR(272), PAR(273)) ELSE PAR(276) = 0 ENDIF IF (PAR(273) * PAR(50) .LT. PAR(272)) THEN PAR(273) = PAR(272) / PAR(50) ENDIF PAR(273) = PAR(273) + 3.0 PAR(272) = PAR(273) * PAR(50) ELSE IF (MMODE .EQ. 23) THEN CALL PLA280 ('F3D') ELSE IF (MMODE .EQ. 24) THEN IPR(140) = MENUH - 1 ELSE IF (MMODE .EQ. 25) THEN IF (IPR(543) .EQ. 4) THEN IPR(543) = 0 ELSE IPR(543) = 4 CALL PLA280 ('TWIN') IPR(576) = 0 ENDIF ELSE IF (MMODE .EQ. 26) THEN IGBL(106) = MOD(IGBL(106) + 1, 2) ELSE IF (MMODE .EQ. 30) THEN IF (MENUH .EQ. 1) THEN CALL PLA226 (0, 0.0) ELSE IF (MENUH .EQ. 2) THEN CALL PLA226 (2, 90.0 / GL(5)) ELSE IF (MENUH .EQ. 3) THEN CALL PLA226 (1, -90.0 / GL(5)) ELSE IF (MENUH .EQ. 4) THEN CALL PLA226 (3, 90.0 / GL(5)) ENDIF MNH(6) = MENUH LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 11 ELSE IF (MENUV .EQ. 11) THEN IF (MMODE .EQ. 1) THEN IPR(346) = MOD(IPR(346) + 1, 2) IF (IPR(116) .EQ. 0) THEN LRET = 3 ELSE IPR(116) = 0 IPR(479) = 2 PAR(389) = 0.0 IPR(201) = 0 LRET = 2 ENDIF ELSE IF (MMODE .EQ. 2) THEN CALL PLA015 (341, 1) LRET = -1 ELSE IF (MMODE .EQ. 3) THEN IF (MENUH - 1 .NE. IGBL(88)) THEN IF (IGBL(59) .EQ. 1) THEN IGBL(88) = MENUH - 1 ELSE IGBL(59) = MOD(IGBL(59) + 1, 2) ENDIF ELSE IGBL(59) = MOD(IGBL(59) + 1, 2) IGBL(88) = MENUH - 1 ENDIF ELSE IF (MMODE .EQ. 4) THEN IF (MENUH .GT. 1) THEN PAR(44) = 0.5 * 2.0 ** (MENUH - 4) ELSE PAR(44) = 0.0 ENDIF ELSE IF (MMODE .EQ. 5) THEN IFL(1) = 'VIEW ' IFL(2) = 'LINE ' CALL PLA015 (329, 1) LRET = -1 ELSE IF (MMODE .EQ. 6) THEN CALL PLA299 CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 7) THEN IGBL(35) = MOD(IGBL(35) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 8) THEN CALL PLA015 (536, MENUH) LRET = -1 ELSE IF (MMODE .EQ. 9) THEN CALL PLA015 (341, 5) LRET = -1 ELSE IF (MMODE .EQ. 10) THEN IPR(110) = MOD(IPR(110) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IPR(154) = MOD(IPR(154) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN PAR(284) = (MENUH - 1) * 0.5 LRET = 3 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 1') ELSE IF (MMODE .EQ. 16) THEN IGBL(57) = MOD(IGBL(57) + 1, 2) ELSE IF (MMODE .EQ. 17) THEN WRITE(IGGT(1:14), '(''SHELXL ISO'', I3, 1X)') MENUH - 1 ELSE IF (MMODE .EQ. 18) THEN IGBL(41) = MOD(IGBL(41) + 1, 2) ELSE IF (MMODE .EQ. 19) THEN IGBL(125) = MOD(IGBL(125) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 22) THEN PAR(279) = - 1.5 + MENUH LRET = 2 ELSE IF (MMODE .EQ. 24) THEN IPR(535) = MOD(IPR(535) + 1, 2) ELSE IF (MMODE .EQ. 25) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) CALL PLA280 ('TWIN') ELSE IF (MMODE .EQ. 30) THEN IPR(353) = MOD(IPR(353) + 1, 2) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 12 ELSE IF (MENUV .EQ. 12) THEN IF (MMODE .EQ. 1) THEN IF (MENUH .EQ. IPR(232) + 1) 1 IGBL(75) = MOD(IGBL(75) + 1, 2) IF (MENUH .EQ. 2) THEN IPR(232) = 1 IPR(201) = 0 ELSE IPR(232) = 0 ENDIF IF (IGBL(75) .EQ. 1) WRITE (LU6, 99999) IF (IGBL(35) .EQ. 1) THEN LRET = 2 ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 2) THEN PAR(349) = 0.20 + 0.05 * MENUH ELSE IF (MMODE .EQ. 3) THEN CALL PLA015 (343, 1) LRET = -1 ELSE IF (MMODE .EQ. 4) THEN PAR(36) = (MENUH - 1) * 0.05 ELSE IF (MMODE .EQ. 5) THEN IFL(1) = 'VIEW ' IFL(2) = 'PERP ' CALL PLA015 (329, 2) LRET = -1 ELSE IF (MMODE .EQ. 6) THEN IPR(90) = 4 IPR(220) = 2 CALL PLUT12 ELSE IF (MMODE .EQ. 7) THEN PAR(58) = (MENUH - 1) * 0.05 ELSE IF (MMODE .EQ. 8) THEN IPR(108) = 1 IPR(148) = MENUH - 1 LRET = 2 ELSE IF (MMODE .EQ. 9) THEN CALL PLA280 ('RADII BONDS') ELSE IF (MMODE .EQ. 10) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('LIST ARU') LRET = 2 ELSE WRITE (BCD, 99997) (PAR(J), J = 113, 115), 1 (ACOS(PAR(J)) * GL(5), J = 116, 118), PAR(17), CHAR(0) CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111) LRET = -1 ENDIF ELSE IF (MMODE .EQ. 12) THEN IPR(594) = MOD (IPR(594) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 2') ELSE IF (MMODE .EQ. 11 .OR. MMODE .EQ. 16) THEN IPR(445) = MOD (IPR(445) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 17) THEN WRITE (IGGT(1:16), '(''SHELXL ANISO'', I3, 1X)') MENUH - 1 ELSE IF (MMODE .EQ. 18) THEN IGBL(34) = MOD(IGBL(34) + 1, 2) ELSE IF (MMODE .EQ. 22) THEN PAR(273) = MENUH * 5.0 PAR(272) = 4.0 * PAR(273) / 3.0 CALL PLA280 ('SCAL') ELSE IF (MMODE .EQ. 24) THEN IPR(531) = MENUH - 1 ELSE IF (MMODE .EQ. 25) THEN PAR(449) = MENUH * 0.1 CALL PLA280 ('RESOLUTION') ELSE IF (MMODE .EQ. 30) THEN IPR(358) = MOD (IPR(358) + 1, 2) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 13 ELSE IF (MENUV .EQ. 13) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (349, 1) IPR(327) = 0 IPR(328) = 0 IPR(351) = 0 LRET = -1 ELSE IF (MMODE .EQ. 2) THEN IF (IPR(46) .EQ. 0) THEN CALL PLA280 ('UNIT ON') ELSE CALL PLA280 ('UNIT OFF') ENDIF ELSE IF (MMODE .EQ. 3) THEN IPR(130) = 0 PAR(13) = 0.4 + MENUH * 0.5 CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 4) THEN IPR(111) = 2 ** (4 - MENUH) PAR(5) = 1.0 / (3.33333 ** MENUH) ELSE IF (MMODE .EQ. 5) THEN IFL(1) = 'VIEW ' IFL(2) = 'BISECT ' CALL PLA015 (329, 3) LRET = -1 ELSE IF (MMODE .EQ. 6) THEN IPR(90) = 8 CALL PLUT12 ELSE IF (MMODE .EQ. 7) THEN IGBL(123) = MENUH - 1 ELSE IF (MMODE .EQ. 8) THEN IPR(177) = MENUH - 1 IPR(211) = 0 LRET = 3 ELSE IF (MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN WRITE (BCD, 99998) PAR(17), (PAR(J), J = 101, 106), 1 PAR(98), CHAR(0) CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111) LRET = -1 ELSE CALL PLA299 CALL GEN038 (ICL, 1, 80) LRET = 4 ENDIF ELSE IF (MMODE .EQ. 10) THEN IF (MENUH .EQ. 1) THEN IF (PAR(98) .EQ. 1.0) CALL PLA080 WRITE (BCD, 99998) PAR(17), (PAR(J), J = 101, 106), 1 PAR(98), CHAR(0) CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111) LRET = -1 ELSE CALL PLA280 ('LIST SYMM') LRET = 2 ENDIF ELSE IF (MMODE .EQ. 12) THEN IGBL(109) = MOD (IGBL(109) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(369) = MOD (IPR(369) + 1, 2) IPR(389) = 0 LRET = 4 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 3') ELSE IF (MMODE .EQ. 11 .OR. MMODE .EQ. 16) THEN IPR(363) = MOD (IPR(363) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 17) THEN CALL PLA280 ('TWINMAT') ELSE IF (MMODE .EQ. 22) THEN IF (MENUH .GT. 3) THEN DELTA = (MENUH - 3) * 0.5 ELSE DELTA = (MENUH - 4) * 0.5 ENDIF PAR(274) = PAR(274) + DELTA * COS(PAR(276) / GL(5)) PAR(275) = PAR(275) + DELTA * SIN(PAR(276) / GL(5)) CALL PLA280 ('SCAL') ELSE IF (MMODE .EQ. 24) THEN IPR(527) = MOD (IPR(527) + 1, 2) ELSE IF (MMODE .EQ. 30) THEN IPR(357) = MOD (IPR(357) + 1, 2) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 14 ELSE IF (MENUV .EQ. 14) THEN IF (MMODE .EQ. 1) THEN PAR(349) = 0.20 + MENUH * 0.05 IPR(201) = 0 LRET = 3 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 3 .OR. MMODE .EQ. 5 1 .OR. MMODE .EQ. 6) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('ARU RESTORE') ELSE WRITE (IGGT(1:14), '(''ARU NONE '', I5)') MENUH - 1 ENDIF IPR(140) = MENUH - 1 ELSE IF (MMODE .EQ. 4) THEN IF (IPR(63) .EQ. 0) THEN CALL PLA280 ('LABEL ARU') ELSE CALL PLA280 ('UNLABEL ARU') ENDIF ELSE IF (MMODE .EQ. 7) THEN IF (MENUH .EQ. 1) THEN PAR(18) = SIGN(1.0, PAR(18)) ELSE PAR(18) = SIGN(1.333, PAR(18)) ENDIF ELSE IF (MMODE .EQ. 8) THEN IPR(211) = 1 LRET = 3 ELSE IF (MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('LIST ATOMS') ELSE CALL PLA280 ('LIST UIJ') ENDIF ELSE IF (MMODE .EQ. 10) THEN IF (IPR(30) .EQ. 0) CALL PLA069 IPR(220) = 2 IPR(221) = 0 IPR(18) = 1 CALL PLA073 (1) ELSE IF (MMODE .EQ. 11) THEN IF (IPR(30) .EQ. 0) IGBL(33) = MOD(IGBL(33) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 12) THEN IGBL(57) = MOD(IGBL(57) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 4') ELSE IF (MMODE .EQ. 16) THEN IPR(331) = MOD (IPR(331) + 1, 2) ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('HDIF') ELSE CALL PLA280 ('HFIX') IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1) ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('RPLUTO') ELSE IF (MMODE .EQ. 22) THEN IF (MENUH .GT. 3) THEN DELTA = (MENUH - 3) * 0.5 ELSE DELTA = (MENUH - 4) * 0.5 ENDIF PAR(275) = PAR(275) + DELTA * COS(PAR(276) / GL(5)) PAR(274) = PAR(274) - DELTA * SIN(PAR(276) / GL(5)) CALL PLA280 ('SCAL') ELSE IF (MMODE .EQ. 24) THEN IPR(528) = MOD (IPR(528) + 1, 2) ELSE IF (MMODE .EQ. 25) THEN ELSE LRET = -1 ENDIF C * MENU BOX # 15 ELSE IF (MENUV .EQ. 15) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (327, 1) IPR(440) = 0 IPR(349) = 0 IPR(328) = 0 LRET = -1 ELSE IF (MMODE .EQ. 2) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('JOIN RADII INTER HBONDS') ELSE CALL PLA280 ('JOIN RADII INTER XBONDS') ENDIF ELSE IF (MMODE .EQ. 3) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN IF (MENUH .EQ. 1) THEN IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1) IF (IPR(335) .EQ. 1) CALL PLA015 (335, 1) CALL PLA015 (332, 1) IF (IGBL(75) .EQ. 0) THEN CALL PLA280 ('LABEL ON') ELSE LRET = -1 ENDIF ELSE CALL PLA015 (352, 1) IF (IGBL(3) .EQ. 26) LRET = -1 ENDIF ELSE IF (MENUH .EQ. 1) THEN CALL PLA015 (427, 30) ELSE CALL PLA015 (427, 44) ENDIF LRET = -1 ENDIF ELSE IF (MMODE .EQ. 4) THEN IF (IPR(339) .EQ. 0) THEN CALL PLA280 ('LABEL UNIT') IPR(46) = 1 ELSE CALL PLA280 ('UNLABEL UNIT') ENDIF ELSE IF (MMODE .EQ. 5) THEN CALL PLA280 ('PLOT CAL MOGLI') ELSE IF (MMODE .EQ. 7) THEN IGBL(101) = MENUH - 1 CALL PLA280 ('PLOT POV') IPR (340) = 1 IGBL(98) = 0 ELSE IF (MMODE .EQ. 8) THEN IPR(177) = MENUH - 1 IPR(211) = 2 LRET = 3 ELSE IF (MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('LIST FLAGS') ELSE CALL PLA280 ('LIST RADII') ENDIF ELSE IF (MMODE .EQ. 10) THEN IF (IPR(30) .EQ. 0) CALL PLA069 IPR(220) = 2 IPR(221) = 0 IPR(18) = 2 CALL PLA073 (1) ELSE IF (MMODE .EQ. 11) THEN IGBL(121) = MOD (IGBL(121) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 12) THEN IGBL(74) = MOD (IGBL(74) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 14) THEN IPR(468) = MOD (IPR(468) + 1, 2) LRET = 3 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 5') ELSE IF (MMODE .EQ. 16) THEN IPR(388) = MOD (IPR(388) + 1, 2) ELSE IF (MMODE .EQ. 17) THEN WRITE (IGGT(1:16), '(''SHELXL HATOM'', I3, 1X)') MENUH - 1 ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('CONTOUR PT') ELSE IF (MMODE .EQ. 19) THEN IGBL(74) = MOD (IGBL(74) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 22) THEN IF (MENUH .GT. 3) THEN ZROT = (MENUH - 3) * 30.0 ELSE ZROT = (MENUH - 4) * 30.0 ENDIF WRITE (IGGT, '(''ZROT '', F10.2)') ZROT ELSE IF (MMODE .EQ. 24) THEN IPR(529) = MOD (IPR(529) + 1, 2) LRET = 4 ELSE IF (MMODE .EQ. 25) THEN IPR(394) = MENUH CALL PLA280 ('ZONE') ELSE IF (MMODE .EQ. 29) THEN IPR(593) = MOD (IPR(593) + 1, 2) CALL PLA280 ('SLOPE') ELSE LRET = -1 ENDIF C * MENU BOX # 16 ELSE IF (MENUV .EQ. 16) THEN IF (MMODE .EQ. 1) THEN CALL PLA015 (328, 1) IGBL(75) = 1 IPR(440) = 0 IPR(349) = 0 IPR(327) = 0 ELSE IF (MMODE .EQ. 2) THEN MNH(7) = MENUH IF (MENUH .EQ. 1) THEN CALL PLA280 ('ARU NONE 1555') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('ARU UNIQUE') ELSE WRITE (IGGT(1:46), '(''PACK RANGE'', 6F6.2)') 1 0.45 - DX, 0.55 + DX, 0.45 - DX, 0.55 + DX, 2 0.45 - DX, 0.55 + DX ENDIF ELSE IF (MMODE .EQ. 3) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('VIEW UNIT') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('VIEW MIN') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('VIEW XO') ELSE IF (MENUH .EQ. 4) THEN CALL PLA280 ('VIEW YO') ELSE IF (MENUH .EQ. 5) THEN CALL PLA280 ('VIEW ZO') ENDIF MNH(6) = MENUH ELSE IF (MMODE .EQ. 4) THEN IF (IPR(452) .EQ. 0) THEN CALL PLA280 ('LABEL ATOM') ELSE CALL PLA280 ('UNLABEL ATOM') ENDIF ELSE IF (MMODE .EQ. 7) THEN IPR(71) = MOD (IPR(71) + 1, 2) ELSE IF (MMODE .EQ. 8) THEN IF (IGBL(71) .EQ. 0) THEN IPR(350) = MOD (IPR(350) + 1, 2) IPR(201) = 0 LRET = 4 ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 9) THEN LRET = 1 CALL PLA280 ('LIST ARU') ELSE IF (MMODE .EQ. 10) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('LIST FLAGS') ELSE CALL PLA280 ('LIST RADII') ENDIF LRET = 2 ELSE IF (MMODE .EQ. 12) THEN IGBL(62) = MENUH WRITE (IGGT, '(''SET WINDOW'', F8.2)') IGBL(62) / 4.0 LRET = 2 ELSE IF (MMODE .EQ. 14) THEN IPR(132) = MENUH - 1 LRET = 3 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 6') ELSE IF (MMODE .EQ. 16) THEN IGBL(75) = MOD (IGBL(75) + 1, 2) ELSE IF (MMODE .EQ. 17) THEN WRITE (IGGT(1:17), '(''SHELXL WEIGHT'', I3, 1X)') 1 MENUH - 1 ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('CONTOUR DF') ELSE IF (MMODE .EQ. 22) THEN CALL PLA015 (458, 1) LRET = 2 ELSE IF (MMODE .EQ. 24) THEN IPR(532) = MOD (IPR(532) + 1, 2) ELSE IF (MMODE .EQ. 25) THEN IF (MENUH .EQ. 1) THEN IPR(389) = 1 ELSE IPR(389) = -1 ENDIF CALL PLA280 ('NEXT') ELSE IF (MMODE .EQ. 30) THEN IF (MENUH .GT. 1) THEN IPR(354) = MENUH - 1 ELSE IPR(354) = -1 ENDIF LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 17 ELSE IF (MENUV .EQ. 17) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN IPR(140) = MENUH - 1 IPR(201) = 0 LRET = 4 ELSE IF (MMODE .GE. 2 .AND. MMODE .LE. 6) THEN IF (IGBL(75) .EQ. 1) THEN IF (MENUH .NE. IPR(232) + 1) IGBL(75) = 0 ENDIF IF (MENUH .EQ. 2) THEN IPR(232) = 1 ELSE IPR(232) = 0 ENDIF IF (IGBL(75) .EQ. 0) THEN CALL PLA280 ('LABEL ON') ELSE CALL PLA280 ('LABEL OFF') ENDIF ELSE IF (MMODE .EQ. 7) THEN CALL PLA280 ('PORTRAIT') ELSE IF (MMODE .EQ. 11) THEN PAR(7) = 2.0 + MENUH LRET = -1 ELSE IF (MMODE .EQ. 12) THEN CALL PLA280 ('PORTRAIT') LRET = 2 ELSE IF (MMODE .EQ. 13) THEN CALL PLA280 ('CANDP') ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 7') ELSE IF (MMODE .EQ. 16) THEN PAR(325) = 1.0 + (MENUH - 1) * 0.25 ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('PLUTON') ELSE CALL PLA280 ('RENAME') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('CONTOUR FO') ELSE IF (MMODE .EQ. 22) THEN IF (MENUH .EQ. IPR(232) + 1) 1 IGBL(75) = MOD(IGBL(75) + 1, 2) IF (MENUH .EQ. 2) THEN IPR(232) = 1 IPR(201) = 0 ELSE IPR(232) = 0 ENDIF LRET = 2 ELSE IF (MMODE .EQ. 24) THEN IF (MENUH .EQ. IPR(232) + 1) 1 IGBL(75) = MOD(IGBL(75) + 1, 2) IF (MENUH .EQ. 2) THEN IPR(232) = 1 ELSE IPR(232) = 0 ENDIF ELSE IF (MMODE .EQ. 25) THEN IPR(575) = MOD (IPR(575) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 30) THEN IPR(356) = MOD (IPR(356) + 1, 2) ELSE LRET = -1 ENDIF C * MENU BOX # 18 ELSE IF (MENUV .EQ. 18) THEN IF (MMODE .EQ. 1) THEN IPR(479) = 2 PAR(389) = ANGC IPR(201) = 0 LRET = 6 ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 3) THEN WRITE (IGGT(1:20), '(''CROTY COLOR'', F8.2)') ANGC ELSE IF (MMODE .EQ. 4) THEN IF (MENUH .EQ. 1) THEN IFL(1) = 'DEFINE' IFL(2) = 'CG' LMOD = 2 IPR(507) = 1 CALL PLA015 (508, 2) LRET = -1 ELSE IF (MENUH .EQ. 2) THEN IF (IPR(508) .EQ. 2) THEN IPR(507) = 2 IPR(508) = 0 WRITE (IGGT, 99995) (IFL(I), I = 1, LMOD) IGBL(23) = IABS(IGBL(23)) ENDIF ENDIF ELSE IF (MMODE .EQ. 6) THEN CALL PLA280 ('ENTRY') ELSE IF (MMODE .EQ. 7) THEN WRITE (IGGT, '(''SET REVERSE'')') ELSE IF (MMODE .EQ. 8) THEN PAR(85) = MENUH LRET = 4 ELSE IF (MMODE .EQ. 9) THEN WRITE (IGGT, '(''SET REVERSE'')') ELSE IF (MMODE .EQ. 10) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN GL(26) = MENUH * 0.20 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 12) THEN IGBL(64) = MENUH - 1 IGBL(63) = IGBL(64) LRET = -1 ELSE IF (MMODE .EQ. 13) THEN IGBL(23) = 1 CALL PLA280 ('PLOT ADP COLOR') ELSE IF (MMODE .EQ. 14) THEN IF (MENUH .EQ. 1) THEN IPR(389) = 1 ELSE IPR(389) = -1 ENDIF LRET = 4 ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 8') ELSE IF (MMODE .EQ. 16) THEN WRITE (IGGT(1:20), '(''CROTY '', F8.2)') ANGC ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('PLATON') ELSE CALL PLA280 ('PLATON ADP') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('CONTOUR SQ') ELSE IF (MMODE .EQ. 19) THEN WRITE (IGGT, '(''SET REVERSE'')') ELSE IF (MMODE .EQ. 22) THEN PAR(278) = 0.1 * MENUH LRET = 2 ELSE IF (MMODE .EQ. 23) THEN PAR(278) = 0.1 * MENUH LRET = 2 ELSE IF (MMODE .EQ. 24) THEN PAR(349) = 0.20 + MENUH * 0.05 ELSE IF (MMODE .EQ. 25) THEN IPR(571) = MOD (IPR(571) + 1, 2) LRET = -1 ELSE LRET = -1 ENDIF C * MENU BOX # 19 ELSE IF (MENUV .EQ. 19) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN IPR(479) = 3 IF (MENUH .GT. 5) THEN PAR(389) = 2 ** (MENUH - 6) ELSE PAR(389) = - 2 ** (5 - MENUH) ENDIF IPR(201) = 0 LRET = 2 ELSE IF (MMODE .EQ. 7) THEN IGBL(69) = MOD(IGBL(69) + 1, 2) YGGIP = - 100 * (IGBL(69) + 1) CALL GGIP (0.0, YGGIP, 0.0, 0) ELSE IF (MMODE .EQ. 8) THEN PAR(89) = MENUH LRET = 4 ELSE IF (MMODE .EQ. 10) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN GL(27) = (MENUH - 1) * 0.25 ENDIF LRET = -1 ELSE IF (MMODE .EQ. 12) THEN IGBL(70) = MOD(IGBL(70) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 13) THEN IPR(55) = -1 CALL PLA280 ('YES') ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('RR 9') ELSE IF (MMODE .EQ. 16) THEN IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:9), 99996) 'Z', IANG ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('INVERT') ELSE CALL PLA280 ('HFREE') ENDIF ELSE IF (MMODE .EQ. 19) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('ANIS') ELSE IF (MENUH .EQ. 2) THEN ENDIF ELSE IF (MMODE .EQ. 22) THEN IPR(419) = NINT(2.5 * 2 ** MENUH) LRET = 2 ELSE IF (MMODE .EQ. 24) THEN IPR(479) = 3 IF (MENUH .GT. 5) THEN PAR(389) = 2 ** (MENUH - 6) ELSE PAR(389) = - 2 ** (5 - MENUH) ENDIF LRET = 3 ELSE IF (MMODE .EQ. 25) THEN IPR(572) = MOD (IPR(572) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 26) THEN IPR(566) = MOD (IPR(566) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 30) THEN IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:9), 99996) 'Z', IANG ELSE IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:18), '(''VIEW CUR ZROT'', I5)') IANG ENDIF C * MENU BOX # 20 ELSE IF (MENUV .EQ. 20) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN IPR(479) = 2 IF (MENUH .GT. 5) THEN PAR(389) = 2 ** (MENUH - 6) ELSE PAR(389) = - 2 ** (5 - MENUH) ENDIF IPR(201) = 0 LRET = 2 ELSE IF (MMODE .EQ. 7) THEN GL(25) = (MENUH - 1) * 0.25 CALL PLA280 ('RESET') ELSE IF (MMODE .EQ. 8) THEN PAR(86) = MENUH * 0.01 PAR(88) = MENUH * 0.01 PAR(90) = MENUH * 0.01 LRET = 4 ELSE IF (MMODE .EQ. 10) THEN IF (MENUH .EQ. 1) THEN IGBL(95) = MOD (IGBL(95) + 1, 2) ELSE IF (MENUH .EQ. 2) THEN IGBL(95) = 1 ENDIF CALL PLA280 ('RESTART') LRET = 2 ELSE IF (MMODE .EQ. 12) THEN MNH(12) = MENUH IF (MENUH .EQ. 1) THEN CALL PLA280 ('SET META PS') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('SET META HPGL') ELSE IF (MENUH .EQ. 3) THEN CALL PLA280 ('SET META TEK4014') ENDIF LRET = 2 ELSE IF (MMODE .EQ. 11) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN GL(25) = (MENUH - 1) * 0.25 CALL PLA280 ('RESTART') LRET = 2 ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 13) THEN IPR(55) = 2 CALL PLA280 ('YES') ELSE IF (MMODE .EQ. 16) THEN IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:9), 99996) 'Y', IANG ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('ASYM') ELSE CALL PLA280 ('ASYM VIEW') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('BROWSE PS') ELSE IF (MMODE .EQ. 19) THEN LRET = -1 ELSE IF (MMODE .EQ. 22) THEN STRING(1:3) = 'CL ' NCNT = 3 SBCD = STRING(1:NCNT)//CHAR(0) LRET = -1 ELSE IF (MMODE .EQ. 24) THEN IPR(479) = 2 IF (MENUH .GT. 5) THEN PAR(389) = 2 ** (MENUH - 6) ELSE PAR(389) = - 2 ** (5 - MENUH) ENDIF LRET = 3 ELSE IF (MMODE .EQ. 25) THEN IPR(573) = MOD (IPR(573) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 26) THEN CALL PLA280 ('CALC ADDSYM EQUAL') ELSE IF (MMODE .EQ. 30) THEN IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:9), 99996) 'Y', IANG ELSE IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:18), '(''VIEW CUR YROT'', I5)') IANG ENDIF C * MENU BOX # 21 ELSE IF (MENUV .EQ. 21) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN IPR(479) = 1 IF (MENUH .GT. 5) THEN PAR(389) = 2 ** (MENUH - 6) ELSE PAR(389) = - 2 ** (5 - MENUH) ENDIF IPR(201) = 0 LRET = 2 ELSE IF (MMODE .EQ. 7) THEN IPR(166) = MOD(IPR(166) + 1, 2) IPR(130) = 0 CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 8) THEN PAR(86) = MENUH * 0.01 LRET = 4 ELSE IF (MMODE .EQ. 10) THEN CALL PLA280 ('HELP') LRET = 2 ELSE IF (MMODE .EQ. 12) THEN IGBL(35) = MOD(IGBL(35) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 13) THEN IPR(55) = 1 CALL PLA280 ('YES') ELSE IF (MMODE .EQ. 16) THEN IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:9), 99996) 'X', IANG ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('SQUEEZE') ELSE CALL PLA280 ('FCF') ENDIF ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('LASER') ELSE IF (MMODE .EQ. 19) THEN IGBL(124) = MENUH - 1 ELSE IF (MMODE .EQ. 22) THEN IF (IPR(182) .EQ. 0) THEN CALL PLA280 ('OMIT') IPR(515) = MENUH - 1 ELSE IPR(505) = MENUH IF (MENUH .EQ. 1) THEN CALL PLA280 ('XROT 10') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('YROT 10') ELSE CALL PLA280 ('ZROT 10') ENDIF ENDIF ELSE IF (MMODE .EQ. 21) THEN IPR(569) = MOD (IPR(569) + 1, 2) IPR(570) = 0 LRET = 3 ELSE IF (MMODE .EQ. 24) THEN IPR(479) = 1 IF (MENUH .GT. 5) THEN PAR(389) = 2 ** (MENUH - 6) ELSE PAR(389) = - 2 ** (5 - MENUH) ENDIF LRET = 3 ELSE IF (MMODE .EQ. 25) THEN IPR(574) = MOD (IPR(574) + 1, 2) LRET = -1 ELSE IF (MMODE .EQ. 26) THEN IF (MENUH .EQ. 1) THEN NQ1 = ' ' ELSE NQ1 = LMT(MENUH - 1, 1) ENDIF CALL PLA280 ('CALC ADDSYM '//NQ1) ELSE IF (MMODE .EQ. 30) THEN IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:9), 99996) 'X', IANG ELSE IF (MENUH .GT. 5) THEN IANG = 2 ** (MENUH - 6) ELSE IANG = - 2 ** (5 - MENUH) ENDIF WRITE (IGGT(1:18), '(''VIEW CUR XROT'', I5)') IANG ENDIF C * MENU BOX # 22 ELSE IF (MENUV .EQ. 22) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN IGBL(58) = 0 REWIND LU2 IF (MENUH .EQ. 1) THEN IGBL(54) = MAX (1, IGBL(54) - 1) IF (IGBL(54) .GT. 1) IGBL(58) = 1 WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54) ELSE IF (IGBL(54) .LT. IGBL(100)) THEN IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100))) WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54) ELSE IGBL(45) = 0 CALL PLA280 ('REM') IGBL(23) = 10 CALL GEN108 (LU3, 0) WRITE (LU3, '(80X, /)') ENDFILE LU3 ENDIF ENDIF ELSE IF (MMODE .EQ. 3) THEN CALL PLA015 (213, 1) IF (IPR(213) .EQ. 1) THEN IF (IPR(63) .EQ. 0) THEN CALL PLA280 ('LABEL ARU') ELSE LRET = -1 ENDIF ELSE CALL PLA280 ('UNLABEL ARU') ENDIF IF (IGBL(35) .EQ. 0) LRET = -1 ELSE IF (MMODE .EQ. 2 .OR. 1 (MMODE .GE. 4 .AND. MMODE .LE. 6)) THEN 20 IPR(346) = MOD(IPR(346) + 1, 2) IF (IPR(346) .EQ. 1) THEN IF (MENUH .EQ. 1) THEN IPR(477) = 0 ELSE IF (MENUH .EQ. 2) THEN IPR(477) = -1 ELSE IPR(477) = 1 ENDIF ELSE IF (MENUH * IPR(477) .EQ. -2 .OR. 1 MENUH * IPR(477) .EQ. 3 .OR. 2 (MENUH .EQ. 1 .AND. IPR(477) .EQ. 0)) THEN IPR(477) = 0 ELSE GOTO 20 ENDIF ENDIF IF (IGBL(35) .EQ. 1) THEN CALL PLA280 ('PLOT') ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 7) THEN IPR(73) = MOD(IPR(73) + 1, 2) ELSE IF (MMODE .EQ. 8) THEN PAR(90) = MENUH * 0.01 LRET = 4 ELSE IF (MMODE .EQ. 10) THEN IGBL(58) = 0 IF (MENUH .EQ. 1) THEN IGBL(54) = MAX (1, IGBL(54) - 1) IF (IGBL(54) .GT. 1) IGBL(58) = 1 ELSE IF (MENUH .EQ. 2) THEN IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100))) ENDIF IPR(220) = 0 IPR(221) = 1 FN(1) = IGBL(54) CALL PLA011 IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0 CALL PLA280 ('END') LRET = 3 ELSE IF (MMODE .EQ. 11) THEN IF (IPR(30) .EQ. 0) PAR(27) = (MENUH - 3) * 0.2 LRET = -1 ELSE IF (MMODE .EQ. 12) THEN IGBL(69) = MOD(IGBL(69) + 1, 2) YGGIP = - 100 * (IGBL(69) + 1) CALL GGIP (0.0, YGGIP, 0.0, 0) ELSE IF (MMODE .EQ. 13) THEN IPR(346) = MOD(IPR(346) + 1, 2) CALL PLA280 ('REF') ELSE IF (MMODE .EQ. 16) THEN CALL PLA280 ('NEXT') ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('PLATON ADDSYM') ELSE CALL PLA280 ('PLATON SOLV') ENDIF ELSE IF (MMODE .EQ. 18) THEN IF (IGBL(43) .EQ. 1) IGBL(42) = 1 IGBL(42) = MOD(IGBL(42) + 1, 2) IGBL(43) = 0 CALL PLA280 ('BROWSE LPS') ELSE IF (MMODE .EQ. 19) THEN CALL PLA280 ('CGLS') ELSE IF (MMODE .EQ. 21) THEN IPR(570) = MOD (IPR(570) + 1, 2) IPR(569) = 0 LRET = 3 ELSE IF (MMODE .EQ. 22) THEN IF (IPR(415) .GT. 0) THEN IPR(182) = MOD(IPR(182) + 1, 2) IF (IGBL(25) * IGBL(32) .EQ. 1) THEN IF (IPR(182) .NE. 0) THEN BCD = 'Click on Unique Atoms to be Omitted'//CHAR(0) CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68) * IGBL(82)), 1 30.0, 110) CALL GGIP (0.0, 0.0, 0.0, 6) LRET = -1 ELSE LRET = 2 ENDIF ENDIF ELSE LRET = -1 ENDIF ELSE IF (MMODE .EQ. 24) THEN IPR(346) = MOD(IPR(346) + 1, 2) ELSE IF (MMODE .EQ. 25) THEN PAR(415) = MENUH * 0.1 CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN CALL PLA280 ('CALC ADDSYM EXACT') ELSE LRET = -1 ENDIF C * MENU BOX # 23 ELSE IF (MENUV .EQ. 23) THEN IF (MMODE .EQ. 1) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) LRET = 3 ELSE IF (MMODE .EQ. 2 .OR. 1 (MMODE .GT. 4 .AND. MMODE .LE. 6)) THEN IF (IGBL(103) .EQ. 1) THEN CALL PLA280 ('BOX OFF') ELSE CALL PLA280 ('BOX ON') ENDIF ELSE IF (MMODE .EQ. 3) THEN CALL GEN038 (IGGT, 1, 80) IPR(141) = MOD(IPR(141) + 1, 2) IF (IPR(141) .EQ. 1) THEN CALL PLA280 ( 1 'OMIT OUTSIDE -0.1 1.1 -0.1 1.1 -0.1 1.1') ELSE CALL PLA280 ('OMIT OUTSIDE 0') ENDIF ELSE IF (MMODE .EQ. 4) THEN IF (MENUH .EQ. 1) THEN LMOD = 1 IFL(1) = 'DEFINE' IPR(507) = 1 CALL PLA015 (508, 1) LRET = -1 ELSE IF (MENUH .EQ. 3) THEN IF (IPR(508) .NE. 0) THEN IPR(507) = 3 IPR(508) = 0 WRITE (IGGT, 99995) (IFL(I), I = 1, LMOD) IGBL(23) = IABS(IGBL(23)) ENDIF ENDIF ELSE IF (MMODE .EQ. 7) THEN IGBL(58) = 0 IF (MENUH .EQ. 1) THEN IGBL(54) = MAX (1, IGBL(54)) IF (IGBL(54) .GT. 1) IGBL(58) = 1 ELSE IGBL(54) = IGBL(54) + 1 IF (IGBL(54) .LT. IGBL(100)) THEN IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100))) ENDIF ENDIF WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54) IGBL(67) = 0 LRET = 3 ELSE IF (MMODE .EQ. 8) THEN PAR(88) = MENUH * 0.01 LRET = 4 ELSE IF (MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN LMOD = 1 IFL(1) = 'LSPL' IPR(551) = 1 CALL PLA015 (552, 1) IPR(453) = 0 IPR(448) = 0 IPR(460) = 3 IPR(476) = 0 LRET = -1 ELSE IF (MENUH .EQ. 2) THEN IF (IPR(552) .NE. 0 .AND. LMOD .GT. 3) THEN LMOD = LMOD + 1 IPR(551) = 2 IFL(LMOD) = 'WITH' ENDIF LRET = -1 ELSE IF (MENUH .EQ. 3) THEN IF (IPR(552) .NE. 0) THEN IPR(551) = 3 CALL PLA015 (552, 1) IPR(81) = - LMOD CALL PLA035 (1) LMOD = 0 IGBL(23) = IABS(IGBL(23)) ELSE IGBL(23) = 10 IF (IABS(IGBL(45)) .NE. 0) THEN CALL PLA280 ('END') ELSE CALL PLA280 ('REM') ENDIF ENDIF ENDIF ELSE IF (MMODE .EQ. 10) THEN IGBL(45) = MOD(IGBL(45) + 1, 2) ISAVEMOD = 1 CALL GEN108 (LU3, 0) LRET = -1 ELSE IF (MMODE .EQ. 11) THEN IF (IPR(30) .EQ. 0) PAR(2) = (MENUH - 1) * 0.2 LRET = -1 ELSE IF (MMODE .EQ. 12) THEN CALL PLA280 ('SET REVERSE') LRET = 2 ELSE IF (MMODE .EQ. 13) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) CALL PLA280 ('REF') ELSE IF (MMODE .EQ. 14) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) IPR(389) = 0 LRET = 4 ELSE IF (MMODE .EQ. 16) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) ELSE IF (MMODE .EQ. 17) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('VALID') ELSE CALL PLA280 ('REPORT') ENDIF ELSE IF (MMODE .EQ. 18) THEN IF (IGBL(42) .EQ. 1) IGBL(43) = 1 IGBL(43) = MOD(IGBL(43) + 1, 2) IGBL(42) = 0 CALL PLA280 ('BROWSE LIS') ELSE IF (MMODE .EQ. 19) THEN CALL PLA280 ('SHELXL') ELSE IF (MMODE .EQ. 21) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) ELSE IF (MMODE .EQ. 22) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) LRET = 2 ELSE IF (MMODE .EQ. 24) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) ELSE IF (MMODE .EQ. 25) THEN PAR(420) = MENUH * 0.05 CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 26) THEN CALL PLA280 ('CALC ADDSYM PLOT') ELSE IF (MMODE .EQ. 28) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) ELSE IF (MMODE .EQ. 30) THEN IGBL(103) = MOD(IGBL(103) + 1, 2) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 24 ELSE IF (MENUV .EQ. 24) THEN IF (MMODE .EQ. 1) THEN IPR(346) = MENUH - 1 CALL PLA015 (0, 0) MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) LRET = 3 ELSE IF (MMODE .EQ. 3) THEN IPR(105) = MOD(IPR(105) + 1, 2) IPR(130) = 0 CALL PLA280 ('PLOT') ELSE IF (MMODE .EQ. 2 .OR. (MMODE .GE. 5 1 .AND. MMODE .LE. 6)) THEN IF (MENUH .EQ. 1) THEN CALL PLA015 (0, 0) MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) CALL PLA280 ('PLOT') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('PLOT POV') IPR (340) = 1 IGBL(98) = 0 ELSE IF (MENUH .EQ. 3) THEN IPR (340) = 1 CALL PLA280 ('PLOT PDB') ENDIF ELSE IF (MMODE .EQ. 4) THEN CALL PLA015 (311, MENUH) LRET = -1 ELSE IF (MMODE .EQ. 7) THEN CALL PLA015 (462, 1) IF (IPR(462) .EQ. 1) THEN CALL PLA280 ('ENTRY') ELSE WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54) ENDIF ELSE IF (MMODE .EQ. 8) THEN PAR(48) = (MENUH - 1) * 0.125 LRET = 4 ELSE IF (MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN LMOD = 1 IFL(1) = 'LSPL' IPR(460) = 1 CALL PLA015 (476, 1) IPR(453) = 0 IPR(448) = 0 IPR(551) = 3 IPR(552) = 0 LRET = -1 ELSE IF (MENUH .EQ. 2) THEN IF (IPR(476) .NE. 0 .AND. LMOD .GT. 3) THEN LMOD = LMOD + 1 IPR(460) = 2 IFL(LMOD) = 'DIST' ENDIF LRET = -1 ELSE IF (MENUH .EQ. 3) THEN IF (IPR(476) .NE. 0) THEN IPR(460) = 3 CALL PLA015 (476, 1) IPR(81) = - LMOD CALL PLA035 (1) LMOD = 0 IGBL(23) = IABS(IGBL(23)) ELSE IGBL(23) = 10 IF (IABS(IGBL(45)) .NE. 0) THEN CALL PLA280 ('END') ELSE CALL PLA280 ('REM') ENDIF ENDIF ENDIF ELSE IF (MMODE .EQ. 13) THEN IPR(346) = MENUH - 1 CALL PLA015 (0, 0) MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) CALL PLA280 ('REF') ELSE IF (MMODE .EQ. 10) THEN CALL PLA015 (462, 1) IF (IPR(462) .EQ. 1) THEN CALL PLA280 ('ENTRY') ELSE WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54) ENDIF LRET = 2 ELSE IF (MMODE .EQ. 12) THEN IGBL(47) = - IGBL(47) IPR(590) = MOD (IPR(590) + 1, 2) CALL PLA280 ('REM') IGBL(23) = 10 LRET = 2 ELSE IF (MMODE .EQ. 16) THEN CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 17) THEN CALL PLA280 ('RENUM') ELSE IF (MMODE .EQ. 18) THEN CALL PLA280 ('PRUNE') ELSE IF (MMODE .EQ. 19) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('LRES') ELSE CALL PLA280 ('SHXLPS') ENDIF ELSE IF (MMODE .EQ. 20) THEN CALL PLA280 ('NEXT') ELSE IF (MMODE .EQ. 21) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) ELSE IF (MMODE .EQ. 22) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('UP') ELSE CALL PLA280 ('DOWN') ENDIF ELSE IF (MMODE .EQ. 24) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) ELSE IF (MMODE .EQ. 25) THEN CALL PLA280 ('HKLF') ELSE IF (MMODE .EQ. 26) THEN CALL PLA280 ('CALC ADDSYM SHELX') ELSE IF (MMODE .EQ. 28) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) ELSE IF (MMODE .EQ. 29) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) ELSE IF (MMODE .EQ. 30) THEN IPR(346) = MENUH - 1 CALL PLA015 (0, 0) MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) LRET = 3 ELSE LRET = -1 ENDIF C * MENU BOX # 25 ELSE IF (MENUV .EQ. 25) THEN IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN IF (MENUH .EQ. 1) THEN LRET = 1 CALL PLA280 ('PLUTON') IPR(327) = 0 IPR(328) = 0 IPR(349) = 0 IPR(440) = 0 ELSE IF (MENUH .EQ. 2) THEN LRET = 1 IF (IABS(IGBL(45)) .NE. 0) THEN IF (IPR(308) .EQ. 2) THEN CALL PLA280 ('EXIT') LRET = 7 ELSE CALL PLA280 ('END') ENDIF IPR(351) = 0 ELSE CALL PLA280 ('REM') ENDIF ENDIF ELSE IF (MMODE .GE. 2 .AND. MMODE .LE. 7) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('RESET') ELSE IF (MENUH .EQ. 2) THEN IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0 CALL PLA280 ('END') IGBL(67) = 0 LRET = 3 ENDIF ELSE IF (MMODE .GE. 10 .AND. MMODE .LE. 12) THEN IF (MENUH .EQ. 1) THEN CALL PLA281 (0) LRET = 2 ELSE IF (MENUH .EQ. 2) THEN IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0 CALL PLA280 ('END') LRET = 3 ENDIF ELSE IF (MMODE .EQ. 13) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('PLUTON') ELSE IF (MENUH .EQ. 2) THEN CALL PLA280 ('NO') ENDIF ELSE IF (MMODE .EQ. 14) THEN IF (MENUH .EQ. 1) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) IPR(389) = 0 ELSE CALL PLA280 ('END') LRET = 2 ENDIF ELSE IF (MMODE .EQ. 15) THEN CALL PLA280 ('CALC') ELSE IF (MMODE .EQ. 16) THEN IF (MENUH .EQ. 1) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) CALL PLA280 ('PLOT') ELSE CALL PLA280 ('END') ENDIF ELSE IF (MMODE .GE. 17 .AND. MMODE .LE. 19) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('SKIP') ELSE CALL PLA280 ('!') ENDIF ELSE IF (MMODE .EQ. 20) THEN CALL PLA280 ('END') ELSE IF (MMODE .EQ. 21) THEN IGBL(23) = 10 CALL PLA281 (0) LRET = 2 ELSE IF (MMODE .EQ. 22) THEN IF (MENUH .EQ. 1) THEN MEDIUM = 2 IGGT(16:22) = 'ON ' CALL GGIP (-999.0, 0.0, 0.0, 6) CALL PLA280 ('EPS') LRET = 2 ELSE CALL PLA280 ('QUIT') ENDIF ELSE IF (MMODE .EQ. 24) THEN LRET = 2 ELSE IF (MMODE .EQ. 25) THEN CALL PLA280 ('END') ELSE IF (MMODE .EQ. 26) THEN CALL PLA280 ('END') ELSE IF (MMODE .EQ. 27) THEN IF (MENUH .EQ. 1) THEN CALL PLA280 ('SKIP') ELSE CALL PLA280 ('!') ENDIF ELSE IF (MMODE .EQ. 28) THEN CALL PLA280 ('END') ELSE IF (MMODE .EQ. 29) THEN CALL PLA280 ('END') ELSE IF (MMODE .EQ. 30) THEN CALL PLA280 ('END') ELSE LRET = -1 ENDIF ENDIF RETURN 99999 FORMAT ('>> Labels may be moved by ''clicking'' on them', 1 ' (When in LabPosOn-Mode)', //) 99998 FORMAT ('CELL', F9.5, 3F9.4, 3F8.2, F12.2, A) 99997 FORMAT ('RCELL ', 3F10.6, 3F9.2, F10.5, A) 99996 FORMAT (A, 'ROT', I5) 99995 FORMAT (10(A, 1X)) END SUBROUTINE PLA017 PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /GGT/ MEDIUM COMMON /CGGT/ IGGT CHARACTER IGGT*80 IF ((IGBL(3) .NE. 1 .AND. IGBL(3) .NE. 33 .AND. IGBL(3) .NE. 34) 1 .AND. (IGBL(50) .GT. -1 .AND. IGBL(50) .LT. 2)) THEN IGGT(2:80) = NAME(1)(1:79) PAR1 = -999.0 PAR2 = FLOAT(-KNM(1)) CALL GGIP (PAR1, PAR2, 0.0, 5) IF (IGBL(3) .EQ. 28) THEN MEDIUM = 1 IGGT(16:22) = 'OFF ' CALL GGIP (-999.0, 0.0, 0.0, 6) ENDIF YGGIP = 0.0 ZGGIP = 0.0 CALL GGIP (-999.0, YGGIP, ZGGIP, 8) IGBL(32) = NINT(YGGIP) ENDIF RETURN END SUBROUTINE PLA018 (MODE, X, Y, NQ) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31, NP25=99, NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) CHARACTER NQ*7, NQ1*7 DELMIN = 100000.0 IMIN = 1 NQ = '*******' NAT = IPR(39) + IPR(64) DO 10 I = 1, NAT II = IATC(I) IF (II .EQ. 0) GOTO 10 CALL GEN048 (-1, JFG(II), 27, ISKP) IF (ISKP .EQ. 0) THEN CALL PLA047 (XLAB(IATC(I)), NQ1, IDUM, JDUM, 1, IGBL(55), 1 0, 0) IF (NQ1(1:2) .NE. 'Cg' .OR. IPR(506) .EQ. 1) THEN DEL = (XXO(I, 1) - X) ** 2 + (XXO(I, 2) - Y) ** 2 IF (DEL .LT. DELMIN) THEN DELMIN = DEL IMIN = I ENDIF ENDIF ENDIF 10 CONTINUE IF (DELMIN .LT. 0.5) THEN IF (MODE .LE. 0) THEN IMN = IATC(IMIN) CALL PLA047 (XLAB(IMN), NQ, IDUM, JDUM, 1, IGBL(55), 0, 0) IF (MODE .EQ. -1 ) THEN IF (IMN .LE. IPR(37)) THEN CALL GEN048 (1, IFG(IMN), 30, 1) ELSE CALL PLA015 (427, 28) GOTO 20 ENDIF ENDIF DSH = 0.15 XX = XXO(IMIN, 1) YY = XXO(IMIN, 2) CALL GGIP (0.0, 2.0, 0.0, 0) CALL GGIP (XX, YY + DSH, 0.0, 3) CALL GGIP (XX + DSH, YY, 0.0, 2) CALL GGIP (XX, YY - DSH, 0.0, 2) CALL GGIP (XX - DSH, YY, 0.0, 2) CALL GGIP (XX, YY + DSH, 0.0, 2) CALL GGIP (0.0, 0.0, 0.0, 6) ELSE IMIN = IATC(IMIN) CALL GEN048 (1, JFG(IMIN), 27, 1) IPR(201) = 0 ENDIF ENDIF 20 RETURN END SUBROUTINE PLA019 (MODE, IER) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP38=125,NP39=30,NP45=2048,NP46=15) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER DIRC*7 CHARACTER OPTS*10 COMMON /CMEN/ OPTS(NP46, 7) COMMON /IMEN/ IOPT(NP46, 7) COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 LU = 0 IF (MODE .EQ. 0) THEN LU = IGBL(5) IF (LU .EQ. LU5) THEN IF (IGBL(3) .EQ. 0 .AND. IGBL(25) * IGBL(32) .EQ. 1) THEN IF (IABS(IGBL(23)) .GE. 10 .AND. 1 IABS(IGBL(23)) .LE. 12) THEN IF (IGBL(23) .LT. 0) GOTO 50 WRITE (LU6, 99996) C * OPEN MAIN X-WINDOW, GET INPUT FROM MENU/KEYPRESS IGBL(72) = 1 10 BCD(1:12) = 'P.L.A.T.O.N'//CHAR(0) VERT = GL(1) HORS = VERT * GL(2) CALL GGIP (HORS, VERT, 0.0, 1) SIZ = HORS / 63.0 LINE = 'P L A T O N' CALL GGIP20 (0.0, LINE, 11, 2.0, 4, 15, 3.7, VERT - 2.4) CALL GGIP20 (0.0, LINE, 11, 2.0, 2, 15, 3.5, VERT - 2.5) LINE = 'A Multipurpose Crystallographic Tool' CALL GGIP20 (0.0, LINE, 36, 0.6, 1, 3, 3.9, VERT - 3.5) CALL GEN040 (IGBL(9), NQ1, IP) MW = NPVD / 1000000 CALL GEN040 (MW, NQ2, IP) LINE = 1 '(C) 1980-2006 A.L.Spek - '//NQ2(1:IP)//'M-Version: '//NQ1 CALL GGIP20 (0.0, LINE, 50, 0.4, 3, 2, 5.0, VERT - 4.5) IF (IPR(37) .NE. 0 .OR. IPR(367) .NE. 0 .OR. 1 PAR(101) .GT. 1.0) THEN FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT) KNMXT = KNM(3) + KXT + 1 NKNMXT = MIN (KNMXT, 25) WRITE (LINE, 99999) DTYPE(IABS(IGBL(8))), 1 FNLU1(1:NKNMXT), IGBL(54), MAX (1, IGBL(100)), 2 JID(1:8) CALL GGIP20 (0.0, LINE, 80, SIZ, 3, 2, 1 0.1, VERT - 17.5) NKNM16 = MIN (KNM16, 25) IF (IGBL(15) .GE. 0) THEN IF (IGBL(37) .EQ. 1) THEN DIRC = 'DIR-COS' ELSE IF (IGBL(37) .EQ. 2) THEN DIRC = 'ABS-PSI' ELSE DIRC = 'NO-DIRC' ENDIF CALL GGIP (0.0, 3.0, 0.0, 0) WRITE (LINE, 99998) RDTYPE, FNLU16(1:NKNM16), DIRC, 1 DID KNMXT = KNM16 + 60 ELSE CALL GGIP (0.0, 4.0, 0.0, 0) WRITE (LINE, 99997) FNLU16(1:NKNM16) KNMXT = KNM16 + 30 ENDIF CALL GGIP20 (0.0, LINE, KNMXT, SIZ, -1, 2, 0.1, 1 VERT - 18.2) IF (IGBL(19) .EQ. 0 .AND. IABS(IGBL(8)) .EQ. 3) THEN LINE = 'No check.def file found for CIF-Validation' CALL GGIP20 (0.0, LINE, 42, SIZ, 4, 2, 0.1, 1 VERT - 18.6) ENDIF CALL GGIP (0.0, 1.0, 0.0, 0) CALL GGIP (0.0, -2.0, 0.0, 0) XB = 0.0 YB = VERT - 5.0 CALL GGIP (XB, YB, 0.0, 3) XB = HORS CALL GGIP (XB, YB, 0.0, 2) XB = HORS YB = 0.0 CALL GGIP (XB, YB, 0.0, 3) XB = HORS YB = VERT CALL GGIP (XB, YB, 0.0, 2) LINE(1:41) = 1 ' GRAPHICS GEOM-CALC VOIDS TWIN SYMMETRY ' LINE(42:73) = ' ABSORPTION REPORT MISC-TOOLS' CALL GGIP20 (0.0, LINE, 73, SIZ, 5 + IGBL(68), 2, 0.1, 1 VERT - 5.6) DO 30 I = 1, NP46 DO 20 J = 1, 7 IF ((IGBL(15) .LT. 0 .AND. IOPT(I, J) .GT. 1) .OR. 1 (IOPT(I, J) .EQ. 5 .AND. IGBL(29) .NE. 1)) THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE IF (IGBL(15) .GE. 0 .AND. IGBL(29) .EQ. 0 1 .AND. IOPT(I, J) .EQ. 3) THEN ELSE IF (IOPT(I, J) .EQ. -2 .AND. (IPR(30) .NE. 0 1 .OR. IPR(37) .EQ. 0)) 1 THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE IF (IOPT(I, J) .EQ. -3 .AND. IPR(17) .NE. 0) 1 THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE IF (IOPT(I, J) .EQ. -4 .AND. IPR(30) .NE. 0 1 .AND. IPR(136) .EQ. 0) THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE IF (IOPT(I, J) .EQ. -5 .AND. IPR(37) .EQ. 0) 1 THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE IF (IOPT(I, J) .EQ. -9) THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE CALL GGIP (0.0, 1.0, 0.0, 0) ENDIF IF (IOPT(I, J) .EQ. -1) THEN IF (IPR(30) .NE. 0 .OR. IGBL(19) .EQ. 0 .OR. 1 IABS(IGBL(8)) .LT. 3 .OR. 2 IABS(IGBL(8)) .GT. 4) THEN CALL GGIP (0.0, 4.0, 0.0, 0) ELSE CALL GGIP (0.0, 1.0, 0.0, 0) ENDIF ENDIF IF (IGBL(76) .EQ. 0) THEN IF ((I .EQ. 11 .AND. J .EQ. 6) .OR. 1 (I .EQ. 12 .AND. J .EQ. 6)) 2 CALL GGIP (0.0, 4.0, 0.0, 0) ENDIF IF (IPR(75) .EQ. 1) THEN IF (J .EQ. 1 .AND. I .EQ. 9) 1 CALL GGIP (0.0, 4.0, 0.0, 0) ENDIF YVERT = VERT - I * 11.0 / NP46 - 5.6 XHORS = 9 * SIZ * (J - 1) + 0.1 CALL GGIP20 (0.0, OPTS(I, J), 10, SIZ, -1, 2, 1 XHORS, YVERT) 20 CONTINUE 30 CONTINUE CALL GGIP (0.0, -2.0, 0.0, 0) CALL GGIP (0.0, 1.0, 0.0, 0) XB = 0.0 YB = VERT - 5.8 CALL GGIP (XB, YB, 0.0, 3) XB = HORS CALL GGIP (XB, YB, 0.0, 2) XB = 0.0 YB = VERT - 16.8 CALL GGIP (XB, YB, 0.0, 3) XB = HORS CALL GGIP (XB, YB, 0.0, 2) XB = 0.0 XBS = HORS / 7.0 DO 40 I = 1, 7 XB = XB + XBS YB = VERT - 16.8 CALL GGIP (XB, YB, 0.0, 3) YB = VERT - 5.0 CALL GGIP (XB, YB, 0.0, 2) 40 CONTINUE CALL GGIP (0.0, -1.0, 0.0, 0) ELSE LINE(1:26) = 'NO PROPER INPUT FILE FOUND' CALL GGIP20 (0.0, LINE, 26, 0.7, 2, 3, 4.8, VERT - 7.0) LINE(1:33) = 'NO ATOM DATA, FACES OR CELL FOUND' CALL GGIP20 (0.0, LINE, 33, 0.7, 2, 3, 2.7, VERT - 8.5) LINE(1:34) = 'TO PROCEED' CALL GGIP20 (0.0, LINE, 34, 0.7, 1, 3, 2.7, VERT - 11.) LINE(1:35) = 'Enter ''FILE filename'' via Keyboard' CALL GGIP20 (0.0, LINE, 35, 0.5, 1, 2, 2.7, 1 VERT - 12.5) LINE(1:26) = 'or Enter Data via Keyboard' CALL GGIP20 (0.0, LINE, 26, 0.5, 1, 2, 2.7, 1 VERT - 14.0) LINE(1:25) = 'or Click on HELP for INFO' CALL GGIP20 (0.0, LINE, 25, 0.5, 1, 2, 2.7, 1 VERT - 15.5) ENDIF IF (IGBL(47) .GT. 0) THEN LINE = 'Browser STARTUP' CALL GGIP20 (0.0, LINE, 15, 0.7, 0, 3, HORS - 9.8, 0.3) LINE = 'Browser -' CALL GGIP20 (0.0, LINE, 9, 0.7, 1, 3, HORS - 9.8, 0.3) LINE = 'HELP' CALL GGIP20 (0.0, LINE, 4, 1.0, 1, 4, HORS - 3.5, 0.3) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF 50 CALL PLA013 (0, 1) IF (LRET .EQ. 1) THEN GOTO 10 ELSE IF (LRET .EQ. 2 .OR. LRET .EQ. 3) THEN GOTO 60 ELSE IF (LRET .EQ. 4) THEN GOTO 70 ENDIF 60 ICL = IGGT 70 CALL GEN038 (IGGT, 1, 80) GOTO 100 ENDIF ELSE IF (IGBL(50) .EQ. 0) THEN CALL PLA285 (0, LU6, '>>') ELSE ICL = 'END' CALL GEN038 (IGGT, 1, 80) GOTO 100 ENDIF ENDIF ENDIF ELSE IF (MODE .EQ. 1) THEN LU = LU5 C * CHECK FOR CONTINUE CALL PLA285 (1, LU6, ' ..... more (Y/N[Y])?') ENDIF C * ACTUAL FILE READ IF (MODE .EQ. 1) THEN READ (LU, 99995, END = 110, ERR = 110) ICL(1:80) IF (ICL(1:1) .EQ. 'N' .OR. ICL(1:1) .EQ. 'n') GOTO 120 ELSE READ (LU, 99995, END = 110, ERR = 110) ICL ENDIF 100 IER = 0 RETURN C * READ FAILURE 110 IER = -1 RETURN 120 IER = 1 RETURN 99999 FORMAT ('Xtal Data (', A, ' ) ', A, '- Set', I5, '(', I5, '): ', 1 A) 99998 FORMAT ('Refl Data (', A, ') ', A, ' [ ', A, ']', ' :', A) 99997 FORMAT ('No Refl_Data on ', A, ' or .hkl') 99996 FORMAT (/, ':: PLATON may be run without opening-window ', 1 'with ''platon -o xxxx.yyy'' ', /) 99995 FORMAT (A) END SUBROUTINE PLA020 (X, Y, Z) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP37=175,NP38=125,NP39=30, 3 NP41=200,NP45=2048,NP46=15,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON // YXMOL(2, NP23), VOID(NPVD) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1) CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /TPOS/ XTK(250, 3), NTK(25), KMX, IMIN COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /KEYS/ STRING CHARACTER STRING*100 COMMON /NKEYS/ NCNT CHARACTER NTYP*4, TADD*7 COMMON /IMEN/ IOPT(NP46, 7) CHARACTER OPTS*10 COMMON /CMEN/ OPTS(NP46, 7) COMMON /IITEM/ ITEM COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /SIAT/ IAT, IATK COMMON /LABMOD/ LMOD YY = VERT - Y SIZ = HORS / 63.0 MMODE = IGBL(23) JATK = 0 IASU = 0 LRET = 1 IF (IPR(344) .EQ. 1) THEN IF (IPR(447) .GT. 0) THEN IF (MMODE .EQ. 3) THEN CALL PLA115 (3, 1, X, Y, 0) ELSE IF (MMODE .EQ. 8) THEN CALL PLA115 (3, 0, X, Y, 0) ENDIF GOTO 10 ENDIF ELSE IF (IPR(334) .EQ. 1) THEN IF (IPR(447) .GT. 0) THEN IF (MMODE .EQ. 3) THEN CALL PLA115 (4, 1, X, Y, 0) ELSE CALL PLA115 (4, 0, X, Y, 0) ENDIF ENDIF GOTO 10 ELSE IF (IPR(343) .EQ. 1) THEN CALL PLA014 (1, 1, X, Y, ITEM, IASU) IPR(342) = ITEM ELSE IF (IPR(329) .GT. 0) THEN CALL PLA014 (1, 1, X, Y, ITEM, IASU) IF (ITEM .EQ. 0) GOTO 10 LMOD = LMOD + 1 CALL PLUT25 (1, ITEM, IDUM) IFL(LMOD + 2) = NQ1 IF (IPR(329) .EQ. 1) THEN IF (LMOD .LT. 2) GOTO 10 ELSE IF (LMOD .LT. 3) GOTO 10 ENDIF IPR(220) = LMOD + 2 CALL PLUT06 IPR(329) = 0 LMOD = 0 GOTO 100 ELSE IF (IPR(182) .EQ. 1) THEN CALL PLA018 (-1, X, YY, NQ1) GOTO 10 ELSE IF (IPR(415) .GT. 0) THEN CALL PLA018 (0, X, YY, NQ1) CALL PLA280 (NQ1) GOTO 100 ELSE IF (IPR(312) .GT. 0) THEN CALL PLA018 (0, X, YY, NQ1) IF (NQ1(1:1) .NE. '*') THEN LMOD = LMOD + 1 IF (MOD(LMOD, 2) .EQ. 1) THEN XHORS = HORS - 4.0 YHORS = VERT - 0.5 - (LMOD + 1) * 0.25 ELSE XHORS = HORS - 2.0 YHORS = VERT - 0.5 - LMOD * 0.25 ENDIF CALL GGIP20 (0.0, NQ1, 6, 0.3, 5 + IGBL(68), 1, 1 XHORS, YHORS) IFL(LMOD + 1) = NQ1 WRITE (LU6,'(I5, 1X, A)') LMOD, NQ1 ENDIF GOTO 10 ELSE IF (IPR(536) .GT. 0) THEN CALL PLA018 (0, X, YY, NQ1) CALL PLA046 (3, NQ1, IENM, LBB, LBC, LBD, XNQNR, YNQNR, N1) CALL PLA280 ('COLOR TYPE '//LMT(IENM, 1)//' '//COLR(IPR(536))) IPR(536) = 0 GOTO 100 ELSE IF (IPR(341) .GT. 0) THEN IF (IABS(MMODE) .EQ. 1 .OR. IABS(MMODE) .EQ. 8 .OR. 1 IABS(MMODE) .EQ. 9) THEN CALL PLA018 (0, X, YY, NQ1) LMOD = LMOD + 1 IFL(LMOD + 1) = NQ1 WRITE (SBCD, 99999) (IFL(I), I = 1, LMOD + 1) IF (LMOD .GE. MIN(4,IPR(341))) THEN IPR(81) = LMOD + 1 CALL PLA035 (1) LMOD = 0 IGBL(23) = IABS(IGBL(23)) ENDIF GOTO 10 ELSE CALL PLA014 (1, 1, X, Y, ITEM, IASU) IF (ITEM .EQ. 0) GOTO 10 IF (IPR(341) .EQ. 1) THEN IFL(1) = 'GEOM' ELSE IF (IPR(341) .EQ. 2) THEN IFL(1) = 'DIST ' IF (IASU .GT. 1) THEN IF (LMOD .EQ. 0) THEN GOTO 10 ELSE IF (LMOD .EQ. 1) THEN FN(1) = - IASU IPR(221) = 1 ENDIF ENDIF ELSE IF (IPR(341) .EQ. 3) THEN IFL(1) = 'ANGLE' ELSE IF (IPR(341) .EQ. 4) THEN IFL(1) = 'TORSION' ENDIF LMOD = LMOD + 1 CALL PLUT25 (1, ITEM, IDUM) IFL(LMOD + 1) = NQ1 WRITE (SBCD, 99999) (IFL(I), I = 1, LMOD + 1), CHAR(0) IF (LMOD .LT. IPR(341)) GOTO 10 IPR(220) = LMOD + 1 IPR(163) = 0 CALL PLUT24 (LMOD, IPR(38), IDUM) LMOD = 0 IF (IPR(130) .EQ. 0) GOTO 100 ENDIF ELSE IF ((IPR(476) .NE. 0 .OR. IPR(552) .NE. 0) 1 .AND. MMODE .EQ. 9) THEN CALL PLA018 (0, X, YY, NQ1) LMOD = LMOD + 1 IFL(LMOD) = NQ1 GOTO 10 ELSE IF (IPR(508) .NE. 0 .AND. MMODE .EQ. 1) THEN CALL PLA018 (0, X, YY, NQ1) LMOD = LMOD + 1 IFL(LMOD) = NQ1 IF (LMOD .EQ. 2) THEN LMOD = LMOD + 1 IFL(LMOD) = 'TO' IPR(507) = 2 ENDIF GOTO 10 ELSE IF (IPR(508) .NE. 0 .AND. MMODE .EQ. 4) THEN CALL PLA014 (1, 1, X, Y, ITEM, IASU) IF (ITEM .EQ. 0) THEN LMOD = 0 GOTO 10 ENDIF CALL PLUT25 (1, ITEM, IDUM) LMOD = LMOD + 1 IFL(LMOD) = NQ1 IF (LMOD .EQ. 2) THEN LMOD = LMOD + 1 IFL(LMOD) = 'TO' IPR(507) = 2 ENDIF GOTO 10 ELSE IF (IPR(311) .NE. 0) THEN IF (IABS(MMODE) .EQ. 1 .OR. IABS(MMODE) .EQ. 8) THEN LMOD = LMOD + 1 IF (LMOD .EQ. 1) THEN CALL PLA018 (0, X, YY, NQ1) GOTO 10 ELSE CALL PLA018 (0, X, YY, NQ2) IF (IPR(311) .EQ. 1) THEN CALL PLA280 ('JOIN '//NQ1//NQ2) ELSE IF (IPR(311) .EQ. 2) THEN CALL PLA280 ('JOIN DASH '//NQ1//NQ2) ELSE CALL PLA280 ('DETACH '//NQ1//NQ2) ENDIF GOTO 100 ENDIF ELSE IF (MMODE .EQ. 4) THEN CALL PLA014 (1, 1, X, Y, ITEM, IASU) IF (ITEM .EQ. 0) THEN LMOD = 0 GOTO 10 ENDIF LMOD = LMOD + 1 CALL PLUT25 (LMOD, ITEM, IDUM) IF (LMOD .EQ. 1) THEN IAT = ITEM IATK = IDUM ELSE JAT = ITEM JATK = IDUM ENDIF IF (LMOD .LT. 2) GOTO 10 IF (IPR(221) .EQ. 0) THEN CALL PLUT22 (IAT, JAT, DIST) IF (DIST .GT. RADR(IATK, 3) + RADR(JATK, 3) + 0.8) THEN TADD = ' 0.05 2' ELSE TADD = ' ' ENDIF ENDIF IF (IPR(311) .EQ. 1) THEN CALL PLA280 ('JOIN '//NQ1//NQ2//TADD) ELSE IF (IPR(311) .EQ. 2) THEN CALL PLA280 ('JOIN DASH '//NQ1//NQ2//TADD) ELSE CALL PLA280 ('DETACH '//NQ1//NQ2) ENDIF GOTO 100 ENDIF ELSE IF (IPR(439) .EQ. 1) THEN WRITE (IGGT, '(''CPS'', 2F10.3)') X, PAR(38) - Y GOTO 100 ENDIF IF (MMODE .EQ. 1) THEN IPR(478) = 0 IF (IPR(351) .EQ. 1) THEN CALL PLA018 (1, X, YY, NQ1) ELSE IF (IPR(440) .EQ. 1) THEN CALL PLA018 (0, X, YY, NQ1) CALL GEN020 (1, NQ1, 1, 7) IF (NQ1(2:2) .EQ. ' ') THEN NQ1(2:3) = '()' ELSE DO 30 III = ICHAR('A'), ICHAR('Z') IF (NQ1(2:2) .EQ. CHAR(III)) THEN IF (NQ1(3:3) .EQ. ' ') THEN NQ1(3:4) = '()' ENDIF ENDIF 30 CONTINUE ENDIF CALL PLA280 ('CALC COORDN '//NQ1) ELSE IF (IPR(440) .EQ. -1) THEN IF (X .LT. PAR(37) / 2) THEN IMIN = 0 DISM = 1000.0 DO 40 III = 1, 100 DIS = ABS(YY - YMOL(1, III)) IF (DIS .LT. DISM) THEN IMIN = III DISM = DIS ENDIF 40 CONTINUE IF (IMIN .NE. 0) THEN FN(1) = YMOL(2, IMIN) IPR(221) = 1 CALL PLA295 ENDIF ENDIF ELSE IF (IPR(349) .NE. 0 .OR. IPR(327) .NE. 0 1 .OR. IPR(328) .NE. 0) THEN IF (LMOD .EQ. 0) THEN DELMIN = 1000.0 IMIN = 1 DO 50 I = 1, IPR(39) + IPR(64) III = I * (NP4 + 15) DEL = (VOID(III - 2) - X)**2 + (VOID(III - 1) - YY)**2 IF (IPR(328) .EQ. 1) THEN IVAL = 1 ELSE CALL GEN048 (-1, JFG(I), 11, IVAL) ENDIF IF (IVAL .EQ. 1 .AND. DEL .LT. DELMIN) THEN CALL GEN048 (-1, IFG(I), 7, IHAT) IF (IHAT .NE. 1 .OR. IPR(212) * IPR(232) .NE. 0) 1 THEN IMIN = I DELMIN = DEL ENDIF ENDIF 50 CONTINUE CALL PLA047 (XLAB(IMIN), NQ1, IDUM, JDUM, 1 IPR(350) * 2 - 1, IGBL(55), 0, 0) LMOD = 1 X = VOID (IMIN * (NP4 + 15) - 2) YY = VOID (IMIN * (NP4 + 15) - 1) ELSE LMOD = 0 VOID (IMIN * (NP4 + 15) - 2) = X VOID (IMIN * (NP4 + 15) - 1) = YY ENDIF IF (IPR(328) .EQ. 1) THEN CALL GEN048 (1, JFG(IMIN), 11, 1) LMOD = 0 ENDIF YGGIP = FLOAT(1 - LMOD) CALL GGIP20 (0.0, NQ1, 6, PAR(349), NINT(YGGIP), 1, X, YY) IF (IPR(327) .EQ. 1) THEN CALL GEN048 (1, JFG(IMIN), 11, 0) LMOD = 0 ENDIF GOTO 10 ELSE GOTO 10 ENDIF ELSE IF (MMODE .EQ. 2) THEN GOTO 10 ELSE IF (MMODE .EQ. 3) THEN IF (IPR(349) .EQ. 1) THEN IF (LMOD .EQ. 0) THEN CALL PLA014 (-1, 1, X, Y, ITEM, IASU) NRCOL = 0 CALL PLUT14 (-1, ITEM, IASU, NRCOL, XL, YL, ZL, RL) IF (ITEM .NE. 0) THEN CALL GGIP (0.0, 0.0, 0.0, 0) CALL PLUT25 (1, ITEM - IPR(62), IATK) CALL PLUT04 (1, ITEM - IPR(62)) IPR(117) = 0 CALL GGIP (0.0, 1.0, 0.0, 0) LMOD = 1 ENDIF ELSE XL = X + PAR(61) YL = - Y - PAR(62) NRCOL = 0 CALL PLUT14 (1, ITEM, IASU, NRCOL, XL, YL, ZL, RL) CALL PLUT15 (4, ITEM - IPR(62), 37, 15) LMOD = 0 CALL PLUT04 (1, ITEM - IPR(62)) IPR(117) = 0 ENDIF GOTO 10 ELSE IF (IPR(213) .EQ. 1) THEN CALL PLA014 (-2, 1, X, Y, ITEM, IASU) ITEM = ITEM - IPR(62) - IPR(37) IF (ITEM .GT. 0) THEN CALL PLUT17 (FLOAT(ITEM), 1005, M, LU6) ELSE GOTO 10 ENDIF ELSE IF (IPR(332) .EQ. 1 .OR. IPR(335) .EQ. 1 .OR. 1 IPR(351) .EQ. 1 .OR. IPR(352) .EQ. 1) THEN CALL PLA014 (1, 1, X, Y, ITEM, IASU) IF (ITEM .NE. 0) THEN CALL PLUT25 (1, ITEM, IATK) IF (IPR(351) .EQ. 1) THEN WRITE (IGGT(1:), '(''DELETE '', A)') NQ1 ELSE IF (IPR(352) .EQ. 1) THEN WRITE (IGGT(1:), '(''ANIS '', A)') NQ1 CALL PLUT15 (1, ITEM, 41, 1) ELSE IF (IPR(332) .EQ. 1) THEN IF (IGBL(25) .EQ. 0) THEN WRITE (LU6, '(''HFIX '', A, 1X, $)') NQ1 READ (LU5, '(A)') NQ2 WRITE (IGGT(1:), '(''HFIX '', A, A)') NQ1, NQ2 ELSE IF (NCNT .EQ. 0) THEN STRING(1:4) = 'HFIX' NCNT = 4 ENDIF CALL GEN039 (1, NQ1, 1, 7, NB, NE) STRING(NCNT + 1:) = ' '//NQ1(1:NE)//' ' NCNT = NCNT + NE + 2 SBCD = STRING(1:NCNT)//CHAR(0) CALL GEN038 (IGGT, 1, 80) CALL PLA280 (STRING(1:NCNT)) NCNT = 0 GOTO 100 ENDIF ELSE IF (IPR(335) .EQ. 1) THEN IF (IGBL(25) .EQ. 0) THEN READ (LU5, '(A)') NQ2 WRITE (IGGT(1:), '(''REN '', A, A)') NQ1, NQ2 ELSE IF (NCNT .EQ. 0) THEN STRING(1:6) = 'RENAME' NCNT = 6 CALL GEN039 (1, NQ1, 1, 7, NB, NE) STRING(NCNT + 1:) = ' '//NQ1(1:NE)//' ' NCNT = NCNT + NE + 2 ENDIF CALL GGIP( 0.0, 1.0, 0.0, 0) SBCD = STRING(1:NCNT)//CHAR(0) CALL GEN038 (IGGT, 1, 80) CALL PLA280 (STRING(1:NCNT)) NCNT = 0 GOTO 100 ENDIF ELSE GOTO 10 ENDIF ELSE GOTO 10 ENDIF ELSE CALL PLA115 (5, 1, X, Y, LMOD) GOTO 10 ENDIF ELSE IF (MMODE .EQ. 4) THEN CALL PLA014 (1, 1, X, Y, ITEM, IASU) IF (ITEM .NE. 0) THEN CALL PLUT25 (1, ITEM, IATK) NET = IEL(IEN(IATK)) N1 = NET / 100 N2 = NET - N1 * 100 NTYP = ' '//CHAR(ICHAR('A') + N1 - 1)//' ' IF (N2 .NE. 0) NTYP(3:3) = CHAR(ICHAR('a') + N2 - 1) IF (IPR(348) .EQ. 1) THEN IF (IPR(461) .EQ. 0) THEN IF (IPR(478) .EQ. 0) THEN IPR(340) = IPR(340) + 1 IF (IPR(340) .GT. 17) IPR(340) = 1 CALL PLA280 ('BWC TYPE'//NTYP//BWCT(IPR(340))) ENDIF ELSE IPR(139) = IPR(139) + 1 IF (IPR(139) .GT. 17) IPR(139) = 1 CALL PLA280 ('PLOT') ENDIF ELSE IF (IPR(338) .EQ. 1) THEN IPR(337) = IPR(337) + 1 IF (IPR(337) .GT. 9) IPR(337) = 1 CALL PLA280 ('COLOR TYPE'//NTYP//COLR(IPR(337))) ENDIF ELSE GOTO 10 ENDIF ELSE IF (MMODE .EQ. 5) THEN GOTO 10 ELSE IF (MMODE .EQ. 6) THEN GOTO 10 ELSE IF (MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN CALL PLA115 (5, 0, X, Y, LMOD) GOTO 10 ELSE IF (MMODE .EQ. 22) THEN GOTO 10 ELSE IF (MMODE .EQ. 19) THEN GOTO 10 ELSE IF (MMODE .EQ. 7 .OR. MMODE .EQ. 10 .OR. 1 MMODE .EQ. 11 .OR. MMODE .EQ. 12) THEN IF (IPR(462) .EQ. 0) THEN IF (IPR(37) .NE. 0 .OR. IPR(367) .NE. 0 .OR. 1 PAR(101) .GT. 1.0) THEN NH = INT(7.0 * X / HORS) + 1 IF (NH .LT. 1 .OR. NH .GT. 7) GOTO 10 NV = INT((Y - 4.8) * NP46 / 11.0) IF (NV .LT. 0 .OR. NV .GT. NP46) THEN NH = 7 NV = NP46 + 1 ENDIF ELSE NH = 7 NV = NP46 + 1 ENDIF IF (NH .EQ. 7 .AND. (NV .EQ. NP46 + 1)) THEN CALL PLA300 (1, 0, 0) GOTO 10 ELSE IF (NINT(Z) .EQ. 3) THEN CALL PLA300 (1, NH, NV) GOTO 10 ENDIF IF (NV .GT. 0 .AND. NV .LE. NP46) THEN IF ((IOPT(NV, NH) .GT. 1 .AND. IGBL(15) .LT. 0) .OR. 1 (IOPT(NV, NH) .EQ. 3 .AND. IGBL(15) .EQ. 0 .AND. 2 IGBL(29) .EQ. 0)) THEN CALL PLA015 (427, 7) GOTO 10 ENDIF ELSE GOTO 10 ENDIF YVERT = VERT - NV * 11.0 / NP46 - 5.6 XHORS = 9 * SIZ * (NH - 1) + 0.1 CALL GGIP20 (0.0, OPTS(NV, NH), 10, SIZ, 2, 2, XHORS, YVERT) IF (NH .EQ. 1) THEN IF (NV .EQ. 1) THEN IGBL(23) = 1 IGBL(24) = 1 IPR(68) = 0 CALL PLA280 ('PLUTON') ELSE IF (NV .EQ. 2) THEN IGBL(23) = 1 CALL PLA280 ('PLOT ADP COLOR') ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('PLOT NEWMAN COLOR') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('PLOT RING COLOR') IGBL(23) = 13 ELSE IF (NV .EQ. 5) THEN CALL PLA280 ('PLOT PLAN COLOR') IGBL(23) = 13 ELSE IF (NV .EQ. 6) THEN IGBL(23) = 30 CALL PLA280 ('PLOT POLY') ELSE IF (NV .EQ. 7) THEN IGBL(23) = 9 PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 CALL PLA280 ('CONTOUR DI TN') ELSE IF (NV .EQ. 8) THEN IGBL(23) = 9 PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 CALL PLA280 ('CONTOUR FO TN') ELSE IF (NV .EQ. 9) THEN CALL PLA280 ('FIT') ELSE IF (NV .EQ. 10) THEN CALL PLA280 ('POWDER IOBS') ELSE IF (NV .EQ. 11) THEN CALL PLA280 ('POWDER') ELSE IF (NV .EQ. 12) THEN CALL PLA280 ('CALC RDF') ELSE IF (NV .EQ. 15) THEN IGBL(3) = 8 IGBL(23) = 2 IGBL(24) = 1 IGBL(75) = 0 CALL PLA280 ('PLUTON NATIVE') LRET = 3 ENDIF C * GEOM TOOLS ELSE IF (NH .EQ. 2) THEN IF (NV .EQ. 1) THEN CALL PLA280 ('CALC') ELSE IF (NV .EQ. 2) THEN CALL PLA280 ('CALC INTRA') ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('CALC INTER') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('CALC COORDN') ELSE IF (NV .EQ. 5) THEN CALL PLA280 ('CALC METAL') ELSE IF (NV .EQ. 6) THEN CALL PLA280 ('CALC GEOM') ELSE IF (NV .EQ. 7) THEN CALL PLA280 ('CALC HBONDS') ELSE IF (NV .EQ. 8) THEN CALL PLA280 ('CALC TMA') ELSE IF (NV .EQ. 9) THEN IPR(460) = 1 CALL PLA280 ('PLOT ADP COLOR') ELSE IF (NV .EQ. 10) THEN IPR(551) = 1 CALL PLA280 ('PLOT ADP COLOR') ELSE IF (NV .EQ. 11) THEN IPR(341) = 5 CALL PLA280 ('PLOT ADP COLOR') ELSE IF (NV .EQ. 12) THEN IPR(551) = 1 CALL PLA280 ('PLOT ADP COLOR') ELSE IF (NV .EQ. 13) THEN CALL PLA280 ('PLOT RING COLOR') IGBL(23) = 13 ELSE IF (NV .EQ. 14) THEN IGBL(121) = 1 CALL PLA280 ('CALC COORDN NOANG 4.0') ELSE IF (NV .EQ. 15) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN IGBL(3) = 13 CALL PLA280 ('PLUTON') ELSE CALL PLA015 (427, 30) GOTO 10 ENDIF ENDIF ELSE IF (NH .EQ. 3) THEN IF (NV .EQ. 1) THEN CALL PLA280 ('CALC SOLV') ELSE IF (NV .EQ. 2) THEN CALL PLA280 ('CALC VOID') ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('CALC SQUEEZE') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('CALC FCF') ELSE IF (NV .EQ. 5) THEN IGBL(23) = 9 PAR(274) = 0.0 PAR(275) = 0.0 PAR(276) = 0.0 CALL PLA280 ('CONTOUR SQ TN') ELSE IF (NV .EQ. 6) THEN CALL PLA280 ('CALC SOLV GRID 0.35 F3D') ELSE IF (NV .EQ. 7) THEN CALL PLA280 ('CALC SOLV PLOT') ELSE IF (NV .EQ. 8) THEN CALL PLA280 ('CAVITY') ELSE IF (NV .EQ. 9) THEN ELSE IF (NV .EQ. 10) THEN ELSE IF (NV .EQ. 11) THEN ELSE IF (NV .EQ. 14) THEN CALL PLA280 ('LEPAGE 0.0 6') ELSE IF (NV .EQ. 15) THEN IF (IGBL(29) .LE. 0) THEN CALL PLA280 ('CALC FCF') IPR(516) = 1 ELSE CALL PLA280 ('ROTMAT') ENDIF ENDIF ELSE IF (NH .EQ. 4) THEN IF (NV .EQ. 1) THEN CALL PLA280 ('CALC ADDSYM') ELSE IF (NV .EQ. 2) THEN CALL PLA280 ('CALC ADDSYM EQUAL') ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('CALC ADDSYM EXACT') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('CALC ADDSYM PLOT') ELSE IF (NV .EQ. 5) THEN CALL PLA280 ('CALC ADDSYM SHELX NOSF') ELSE IF (NV .EQ. 6) THEN CALL PLA280 ('CALC NEWSYM') ELSE IF (NV .EQ. 7) THEN CALL PLA280 ('CALC NONSYM') ELSE IF (NV .EQ. 8) THEN CALL PLA280 ('LEPAGE') ELSE IF (NV .EQ. 9) THEN CALL PLA280 ('DELRED') ELSE IF (NV .EQ. 10) THEN CALL PLA280 ('CALC MOLSYM') ELSE IF (NV .EQ. 12) THEN CALL PLA280 ('ASYM') ELSE IF (NV .EQ. 13) THEN CALL PLA280 ('ASYM AVF') ELSE IF (NV .EQ. 14) THEN CALL PLA280 ('SPGR') ELSE IF (NV .EQ. 15) THEN CALL PLA280 ('STIDY') ENDIF ELSE IF (NH .EQ. 5) THEN IF (NV .EQ. 1) THEN CALL PLA280 ('CALC DELABS') ELSE IF (NV .EQ. 2) THEN CALL PLA280 ('ABSP') ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('ABST') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('ABSG') ELSE IF (NV .EQ. 5) THEN CALL PLA280 ('ABSX') ELSE IF (NV .EQ. 6) THEN CALL PLA280 ('ABSS') ELSE IF (NV .EQ. 7) THEN CALL PLA280 ('MULABS') IGBL(23) = 16 ELSE IF (NV .EQ. 8) THEN CALL PLA280 ('SHXABS') ELSE IF (NV .EQ. 9) THEN ELSE IF (NV .EQ. 10) THEN ELSE IF (NV .EQ. 11) THEN ELSE IF (NV .EQ. 15) THEN CALL PLA280 ('XTAL') ENDIF ELSE IF (NH .EQ. 6) THEN IF (NV .EQ. 1) THEN IF (IABS(IGBL(8)) .LT. 3 .OR. IABS(IGBL(8)) .GT. 4 1 .OR. IPR(30) .NE. 0) GOTO 10 IGBL(66) = 1 IGBL(19) = IABS(IGBL(19)) IGBL(3) = 1 LU6 = LU20 CALL PLA280 ('VALI') ELSE IF (NV .EQ. 2) THEN CALL PLA280 ('ASYM AVF VIEW') IGBL(23) = 14 ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('ASYM AVF VALID') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('TABLE') ELSE IF (NV .EQ. 5) THEN IF (IGBL(29) .EQ. 1) THEN CALL PLA280 ('VARIANCE') ELSE GOTO 10 ENDIF ELSE IF (NV .EQ. 6) THEN CALL PLA280 ('BIJVOET') ELSE IF (NV .EQ. 7) THEN CALL PLA280 ('ASYM EXPECT') ELSE IF (NV .EQ. 8) THEN ELSE IF (NV .EQ. 9) THEN ELSE IF (NV .EQ. 10) THEN CALL PLA280 ('EXPT') ELSE IF (NV .EQ. 11) THEN CALL PLA294 (1) CALL PLA280 ('RESTART') GOTO 10 ELSE IF (NV .EQ. 12) THEN CALL PLA280 ('CALC GEOM CSD') ELSE IF (NV .EQ. 13) THEN ELSE IF (NV .EQ. 14) THEN ELSE IF (NV .EQ. 15) THEN CALL PLA280 ('TABL ACC LOCAL') ENDIF ELSE IF (NH .EQ. 7) THEN IF (NV .EQ. 1) THEN CALL PLA280 ('SETUP PATT') ELSE IF (NV .EQ. 2) THEN CALL PLA280 ('FCF2HKL') ELSE IF (NV .EQ. 3) THEN CALL PLA280 ('EXP1') ELSE IF (NV .EQ. 4) THEN CALL PLA280 ('CALC FCF GENER') ELSE IF (NV .EQ. 5) THEN CALL PLA280 ('ASYM GENERATE') ELSE IF (NV .EQ. 6) THEN CALL PLA280 ('HKLTRANS') ELSE IF (NV .EQ. 7) THEN CALL PLA280 ('EXOR') ELSE IF (NV .EQ. 8) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN IGBL(3) = 26 CALL PLA280 ('PLUTON') ENDIF ELSE IF (NV .EQ. 9) THEN IF (IABS(IGBL(8)) .EQ. 2) THEN IGBL(3) = 12 IGBL(105) = 1 CALL PLA280 ('PLUTON') ELSE CALL PLA015 (427, 40) ENDIF ELSE IF (NV .EQ. 10) THEN CALL PLA280 ('CALC PDB EXPAND') ELSE IF (NV .EQ. 11) THEN CALL PLA280 ('CALC EUCLID') ELSE IF (NV .EQ. 12) THEN CALL PLA280 ('CALC SHELX NOSF') ELSE IF (NV .EQ. 13) THEN CALL PLA280 ('TABL ACC') ELSE IF (NV .EQ. 14) THEN IGBL(3) = 27 CALL PLA280 ('CALC GEOM RENUM SHELX') ELSE IF (NV .EQ. 15) THEN CALL PLA280 ('SYST') ENDIF ENDIF IF (IGGT(1:1) .EQ. ' ') GOTO 10 LRET = 2 GOTO 100 ELSE IF (IPR(462) .EQ. 1) THEN NH = INT (6 * X / (GL(1) * GL(2))) NV = INT (43 * Y / GL(1)) + 1 WRITE (IGGT, '(I6.6)') 1 INT((IGBL(100) - 1) / 258) * 258 + NH * 43 + NV ENDIF ELSE IF (MMODE .EQ. 17) THEN IF (IGBL(28) .GT. 0) THEN NV = NINT((Y - GL(1) + PAR(360) + PAR(361) / 2.0) 1 / PAR(361)) IF (NV .LE. 0) THEN CALL PLA280 ('PLOT') ELSE IF (IGBL(28) .EQ. 1) THEN IF (NV .LT. 10) THEN WRITE (IGGT, 99998) NV ELSE WRITE (IGGT, 99997) NV ENDIF ELSE IF (IGBL(28) .EQ. 2) THEN NV = - NV IF (NV .LT. 10) THEN WRITE (IGGT, 99997) NV ELSE WRITE (IGGT, 99996) NV ENDIF ENDIF ENDIF ELSE CALL PLA280 ('PLOT') ENDIF ELSE IF (MMODE .EQ. 18) THEN IF (IGBL(28) .EQ. 1) THEN NV = MIN (17, MAX (0, INT(Y - 1.5))) IF (NV .LT. 10) THEN WRITE (IGGT, 99998) NV ELSE WRITE (IGGT, 99997) NV ENDIF ELSE CALL PLA280 ('PLOT') ENDIF ENDIF 100 RETURN 10 LRET = -1 RETURN 99999 FORMAT (6(A, 1X)) 99998 FORMAT (I1) 99997 FORMAT (I2) 99996 FORMAT (I3) END SUBROUTINE PLA021 PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER FNLU2*80, FILEN*80 LOGICAL OPEND MODE = IGBL(31) C * FILE OPEN IF (MODE .EQ. IPR(437)) THEN WRITE (LU2, 99999) ELSE IPR(437) = MODE IF (MODE .LT. 0) THEN IF (MODE .EQ. -1) THEN FNLU2 = NAME(4)(1:KNM(4))//'.res' ELSE FNLU2 = NAME(7)(1:KNM(7))//'.res' ENDIF OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 3) THEN FNLU2 = NAME(3)(1:KNM(3))//'.eld' IGBL(2) = IGBL(2) + 1 INQUIRE (LU2, OPENED = OPEND) C * WORK-AROUND FOR SALFORD-COMPILER FILEN = ' ' INQUIRE (UNIT = LU2, NAME = FILEN) IF (OPEND .AND. FILEN(1:1) .NE. ' ') THEN WRITE (LU2, 99999) ELSE OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ENDIF ELSE IF (MODE .EQ. 1) THEN FNLU2 = NAME(5)(1:KNM(5))//'.ome' OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') IPR(438) = 1 ELSE IF (MODE .EQ. 2) THEN FNLU2 = NAME(2)(1:KNM(2))//'.dge' OPEN(UNIT = LU2, FILE = FNLU2, STATUS='UNKNOWN') ELSE IF (MODE .EQ. 4) THEN FNLU2 = NAME(6)(1:KNM(6))//'.que' OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 5) THEN FNLU2 = NAME(8)(1:KNM(8))//'.par' OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 6) THEN FNLU2 = NAME(7)(1:KNM(7))//'.res' OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 7) THEN FNLU2 = NAME(3)(1:KNM(3))//'.pdb' OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 8) THEN FNLU2 = NAME(1)(1:KNM(1))//'.acc' IPR(438) = 1 OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 9) THEN FNLU2 = NAME(1)(1:KNM(1))//'.csd' IPR(438) = 1 OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ELSE IF (MODE .EQ. 10) THEN FNLU2 = NAME(1)(1:KNM(1))//'.sqz' OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN') ENDIF IF (IGBL(2) .LE. 1) CALL GEN108 (LU2, 0) ENDIF RETURN 99999 FORMAT ('ENDS') END SUBROUTINE PLA022 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP20=20, 2 NP22=256,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION DHX(3, 37) COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8) COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 DIMENSION RH(3, 3, NP20), HH(4, NP20), AANG(NP20), PH(3, NP20), 1 PERPAX(NP20), HX(4, 37), SHRT(4, 4), ROW(3), IROW0(3), 2 TTRANS(3, 3), TTRM1(3, 3), BTRANS(3, 3), BTRM1(3, 3), DEL(3), 3 TRANSL(3), RATOM(3), ATOM2(3, 2), ROTAX(3, 4), GLIDE(3), 4 ORIG(3), IROW(3), GLITOT(2), GLIDO(3, 2), XMIS(3, 3, 15), 5 XMIS4(3, 15), XMIS5(3, 15), NMIS(15), TR1(3, 3), ORGM(3) DIMENSION IMPROP(64) CHARACTER LATT*1, CENT*1, STAR*2, TEXT1*1, TEXT2*7, FSYM*2 COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /CTRNS/ TRTYP CHARACTER TRTYP(8)*5 DIMENSION DUMMY(3, 3) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 DIMENSION GLY(3), NA(3) CHARACTER XSUB*1, ZSPG0*7 NSYMT = IPR(48) OPEN (LU61, FILE = 'symmscr', STATUS = 'UNKNOWN') DO 5 I = 1, NSYMT ISYM = I CALL SGSM (ICL, ISYM, XJX, 0, 2, IERR) WRITE (LU61, 99922) ICL(1:50) 5 CONTINUE WRITE (LU61, 99921) LOOPR = 0 LU = 0 C * ADDSYM TEST SUBROUTINE -- NOTE: SUBROUTINE SCRATCHES ARRAY CON( ) IF (IPR(23) .EQ. 1 .OR. IPR(241) .EQ. 0) GOTO 1160 PAGET = 'ADDSYM' 10 LOOPR = LOOPR + 1 JERR = 0 IPR(206) = 0 IF (IGBL(3) .EQ. 1) THEN IPR(207) = 0 ELSE IPR(207) = 1 ENDIF IPR(504) = 0 INVST = 0 IN1 = 0 NORGM = 0 NCHIR = 0 IPR(595) = 0 DO 20 I = 1, 3 PAR(406 + I) = PAR(403 + I - IGBL(97) * 3) 20 CONTINUE IF (IPR(220) .GT. 2) THEN DO 30 I = 3, IPR(220) IF (IFL(I)(1:2) .EQ. 'EQ') THEN IPR(207) = 0 ELSE IF (IFL(I)(1:2) .EQ. 'PL') THEN IPR(504) = 1 ELSE IF (IFL(I)(1:2) .EQ. 'SH') THEN IPR(504) = 2 ELSE IF (IFL(I)(1:2) .EQ. 'EX') THEN PAR(249) = 0.00 IF (IPR(221) .EQ. 0) THEN FN(1) = 0.30 IF (LOOPR .LT. 3) THEN FN(2) = 0.25 FN(3) = 0.25 FN(4) = 0.25 ELSE FN(2) = 0.1 FN(3) = 0.1 FN(4) = 0.1 ENDIF ENDIF ELSE IF (IFL(I)(1:4) .EQ. 'NOSF') THEN IPR(595) = 1 ELSE IF (IFL(I)(1:3) .EQ. 'ELD') THEN IGBL(65) = 1 ELSE CALL PLA037 (I, N, 2) IF (N .GT. 0) IPR(206) = N ENDIF 30 CONTINUE ENDIF IF (FN(1) .GT. 0.0) PAR(43) = FN(1) IF (FN(2) .GT. 0.0) PAR(407) = FN(2) IF (FN(3) .GT. 0.0) PAR(408) = FN(3) IF (FN(4) .GT. 0.0) PAR(409) = FN(4) IWIN = 0 IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(504) .EQ. 0 .AND. 1 IPR(121) .EQ. 0) IWIN = 1 IF (IGBL(3) .EQ. 1) IPR(503) = 1 IGBL(23) = 26 IPR(209) = 0 N = 0 CALL GEN101 (2, N, DHX) XSUB = CHAR(32) NLCP = 1 NLCLP = 0 NLTX = 1 40 NLCLP = NLCLP + 1 IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.5 WRITE (PRBUF, 99940) JID(1:20) CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT) ENDIF CALL PLA087 (NLTX) NRXX = 0 NSGTR = 0 NEWLT = 0 IF (IPR(100) .GT. 0) WRITE (LU6, 99960) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-2) WRITE (LU7, 99999) ENDIF IF (IPR(206) .EQ. 0) THEN IF (IPR(207) .NE. 0) THEN WRITE (PRBUF, 99993) NINT(PAR(249)) ELSE WRITE (PRBUF, 99992) NINT(PAR(249)) ENDIF ELSE CALL GEN020 (-1, NQ3, 2, 2) WRITE (PRBUF, 99994) NQ3, NINT(PAR(249)) ENDIF WRITE (LU6, 99979) WRITE (LU6, 99990) PRBUF IF (IPR(206) .EQ. 0 .AND. IPR(207) .NE. 0) WRITE (LU6, 99983) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99990) PRBUF ENDIF IF (IWIN .EQ. 1) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT) ENDIF NEWS = 0 IBV = IPR(256) NSYM = NSYMT / IBV DO 50 I = 1, NSYM CALL SGSM (ICL, I, XJX, LU6, 6, IERR) IMPROP(I) = NINT(GEN119(XJX)) 50 CONTINUE NATOMS = 0 NSKIP = 0 NINC = 0 DO 110 I = 1, IPR(37) CALL GEN048 (-2, IFG(I), 28, JCAI) IF (JCAI .GT. 0) THEN JR(I) = JCAI - 2 NCHIR = NCHIR + 1 ELSE JR(I) = 0 ENDIF CALL GEN048 (-4, IFG(I), 15, NO1) IF (IEN(NO1 + 1) .NE. 1) THEN CALL GEN048 (-7, JFG(I), 1, IDSO) IF (IPPR(IDSO + 1, 1) .EQ. 1000) THEN IF (IPR(206) .NE. 0 .AND. NO1 + 1 .NE. IPR(206)) GOTO 110 DO 60 L = 1, 3 XJX(L) = XXO(I, L) XJX(L + 3) = 0.0 60 CONTINUE NINC = NINC + 1 CALL GEN048 (-1, IFG(I), 19, IMET) IF (NLCLP .EQ. 1) THEN NATOMB = NATOMS ELSE NATOMB = 0 ENDIF DO 100 J = 1, NSYM CALL SGSM (ICL, J, XJX, LU6, 3, IERR) CALL GEN002 (1, TRNSM1, XJX(7), V2, XLNG) DO 70 K = 1, 3 CON(NATOMS + 1, K) = MOD (V2(K) + 10.0, 1.0) 70 CONTINUE IF (NATOMS .GT. NATOMB) THEN DO 90 L = NATOMB + 1, NATOMS DO 80 M = 1, 3 XDUM = MOD (CON(NATOMS + 1, M) - CON(L, M), 1.0) IF (ABS(ABS(XDUM) - 0.5) .LT. 0.49) GOTO 90 80 CONTINUE GOTO 100 90 CONTINUE ENDIF IF (NATOMS .LT. NP1) THEN NATOMS = NATOMS + 1 CON(NATOMS, 8) = XLAB(I) JCA(NATOMS) = IMET IFNT(NATOMS) = JR(I) * IMPROP(J) CON(NATOMS, 4) = (IEN(NO1 + 1) - 1) * IPR(207) + 1 ELSE WRITE (LU6, 99969) NP1 GOTO 1160 ENDIF 100 CONTINUE ELSE NSKIP = NSKIP + 1 IF (NSKIP .EQ. 1) THEN IF (IGBL(63) .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99962) ENDIF ENDIF CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0) IF (IGBL(63) .GT. 0) THEN IF (MOD (NSKIP, 8) .NE. 0) THEN WRITE (LU7, '(3X, A, $)') NQ1 ELSE WRITE (LU7, 99925) NQ1 CALL PLA269 (1) ENDIF ENDIF ENDIF ENDIF 110 CONTINUE NCHIRF = NCHIR IF (NATOMS .EQ. 0) THEN WRITE (LU6, 99968) ELSE IF (NSKIP .GT. 0) THEN WRITE (LU6, 99975) NSKIP IF (IGBL(63) .GT. 0) THEN CALL PLA269 (1) WRITE (LU7, 99975) NSKIP ENDIF ENDIF IF (PAR(386) .NE. 0.0) THEN YUNK = PAR(98) / PAR(386) ELSE YUNK = 0.0 ENDIF WRITE (PRBUF, 99936) PAR(387), YUNK WRITE (LU6, 99997) NINC, NATOMS WRITE (LU6, 99990) PRBUF(1:80) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99997) NINC, NATOMS WRITE (LU7, 99990) PRBUF(1:80) ENDIF IF (IWIN .EQ. 1) THEN IF (PAR(387) .LT. 1.0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT) ENDIF ENDIF NSV = 0 N2 = 0 IMETRIC = 0 IPR(118) = 0 IPR(459) = 0 NROT = 0 NNFIT = 100 NNNFIT = 100 NFT = 100 ANGMAX = SIN(PAR(43) / GL(5))**2 DO 120 I = 1, 37 CALL GEN002 (2, ADIR, DHX(1, I), HX(1, I), HX(4, I)) 120 CONTINUE DO 150 I = 1, 37 CALL GEN002 (-2, AINV, DHX(1, I), V1, XLNG) DO 140 J = 1, 37 MULT = NINT (ABS (GEN009 (DHX(1, I), DHX(1, J)))) IF (MULT .EQ. 1 .OR. MULT .EQ. 2) THEN CALL GEN008 (V1, HX(1, J), V5, -1) IF (V5(1) .LT. ANGMAX) THEN IF (N2 .GE. NP20) THEN IPR(2) = 23 GOTO 1160 ENDIF N2 = N2 + 1 DO 130 K = 1, 3 PH(K, N2) = DHX(K, I) HH(K, N2) = HX (K, J) RH(K, 3, N2) = DHX(K, J) 130 CONTINUE AANG(N2) = ASIN(SQRT(V5(1))) * GL(5) PERPAX(N2) = 2.0 HH(4, N2) = HX(4, J) ENDIF ENDIF 140 CONTINUE 150 CONTINUE N3 = N2 IF (N2 .GT. 0) THEN IF (N2 .GT. 2) THEN DO 220 I = 1, N2 - 2 DO 210 J = I + 1, N2 - 1 NMX = 2 CALL GEN008 (HH(1, I), HH(1, J), V6 , 0) DO 160 K = J + 1, N2 IF (ABS(GEN009 (V6, HH(1, K))) .LE. 0.01) 1 NMX = NMX + 1 160 CONTINUE DO 170 K = 1, N2 IF (ABS(GEN009(PH(1, K), RH(1, 3, I))) .LE. 0.01) 1 THEN IF (ABS(GEN009(PH(1, K), RH(1, 3, J))) .LE. 0.01) 1 THEN IF (NMX .GT. PERPAX(K)) PERPAX(K) = NMX GOTO 210 ENDIF ENDIF 170 CONTINUE IF (NMX .GT. 2) THEN CALL GEN002 ( 2, AINV, V6, V4, XLEN) CALL GEN002 (-2, ADIR, V6, V3, XLNG) SMR = 2.0 SMD = 2.0 DO 180 K = 1, 3 IF (ABS(V3(K)) .GT. 0.1 .AND. ABS(V3(K)) .LT. SMR) 1 SMR = ABS(V3(K)) IF (ABS(V4(K)) .GT. 0.1 .AND. ABS(V4(K)) .LT. SMD) 1 SMD = ABS(V4(K)) 180 CONTINUE DO 190 K = 1, 3 V3(K) = NINT(V3(K) / SMR) V4(K) = NINT(V4(K) / SMD) 190 CONTINUE CALL GEN002 (-2, AINV, V3, V1, XLNG) CALL GEN002 ( 2, ADIR, V4, V2, XLEN) CALL GEN008 (V1, V2, V5, -1) IF (V5(1) .LT. ANGMAX) THEN N3 = N3 + 1 DO 200 K = 1, 3 PH(K, N3) = V3(K) RH(K, 3, N3) = V4(K) HH(K, N3) = V2(K) 200 CONTINUE AANG(N3) = ASIN(SQRT(V5(1))) * GL(5) PERPAX(N3) = NMX HH(4, N3) = XLEN ENDIF ENDIF 210 CONTINUE 220 CONTINUE DO 250 I = 1, N3 - 1 AIMAX = PERPAX(I) - AANG(I) KMAX = I DO 230 J = I + 1, N3 AJMAX = PERPAX(J) - AANG(J) IF (AJMAX .GT. AIMAX) THEN AIMAX = AJMAX KMAX = J ENDIF 230 CONTINUE CALL GEN018 (PERPAX(I), PERPAX(KMAX)) DO 240 K = 1, 3 CALL GEN018 (RH(K, 3, I), RH(K, 3, KMAX)) CALL GEN018 (PH(K, I), PH(K, KMAX)) CALL GEN018 (HH(K, I), HH(K, KMAX)) 240 CONTINUE CALL GEN018 (AANG(I), AANG(KMAX)) CALL GEN018 (HH(4, I), HH(4, KMAX)) 250 CONTINUE ENDIF DO 380 IT = 1, N3 J = 0 DO 280 I = 1, 37 IF (ABS(GEN009 (DHX(1, I), PH(1, IT))) .LT. 0.01) THEN J = J + 1 DO 270 K = 1, 3 SHRT(K, J) = DHX(K, I) 270 CONTINUE IF (J .EQ. 2) GOTO 290 ENDIF 280 CONTINUE 290 DO 300 I = 1, 3 SHRT (I, 3) = SHRT (I, 1) + SHRT (I, 2) SHRT (I, 4) = SHRT (I, 1) - SHRT (I, 2) 300 CONTINUE DO 310 I = 1, 4 CALL GEN002 (2, ADIR, SHRT(1, I), V5, SHRT(4, I)) 310 CONTINUE ISWTCH = 0 DO 340 I = 1, 2 DO 330 J = 2, 4 IF (SHRT(4, J) .LT. SHRT(4, I)) THEN DO 320 K = 1, 4 CALL GEN018 (SHRT(K, I), SHRT(K, J)) 320 CONTINUE ISWTCH = 1 ENDIF 330 CONTINUE 340 CONTINUE IF (ISWTCH .EQ. 1) GOTO 290 CALL GEN002 (2, ADIR, SHRT(1, 1), SHRT(1, 3), XLEN) CALL GEN002 (2, ADIR, SHRT(1, 2), SHRT(1, 4), XLEN) IF (GEN009 (SHRT(1, 3), SHRT(1, 4)) .GT. 0.000001) THEN DO 350 NX = 1, 3 SHRT(NX, 2) = - SHRT(NX, 2) 350 CONTINUE ENDIF SGN0 = SIGN (1.0, GEN009 (RH(1, 3, IT), PH(1, IT))) CALL GEN008 (SHRT(1, 1), SHRT(1, 2), V3, 0) SGN = SIGN(1.0, GEN009 (V3, RH(1, 3, IT))) DO 370 NX = 1, 3 RH(NX, 3, IT) = SGN * RH(NX, 3, IT) PH(NX, IT) = SGN * PH(NX, IT) * SGN0 DO 360 NY = 1, 2 RH(NX, NY, IT) = SGN * SHRT(NX, NY) 360 CONTINUE 370 CONTINUE 380 CONTINUE ENDIF CALL GEN021 (RH(1, 1, N3 + 1), 1) PH(1, N3 + 1) = 0.0 PH(2, N3 + 1) = 0.0 PH(3, N3 + 1) = 1.0 DSCENT = 999.0 DLIM = PAR(407) PAR(291) = 0.0 WRITE (PRBUF, 99989) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (6) WRITE (LU7, 99990) PRBUF(1:78) WRITE (LU7, 99955) PAR(43), PAR(407), PAR(408), PAR(409) WRITE (LU7, 99979) WRITE (LU7, 99953) WRITE (LU7, 99952) WRITE (LU7, 99951) ENDIF WRITE (LU6, 99990) PRBUF(1:78) WRITE (LU6, 99955) PAR(43), PAR(407), PAR(408), PAR(409) WRITE (LU6, 99979) WRITE (LU6, 99953) WRITE (LU6, 99952) WRITE (LU6, 99951) IF (IWIN .EQ. 1) THEN WRITE (PRBUF, 99955) PAR(43), PAR(407), PAR(408), PAR(409) VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT) WRITE (PRBUF, 99953) VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT) WRITE (PRBUF, 99952) VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT) CALL GGIP (0.0, 1.0, 0.0, 0) CALL GGIP (0.0, VRT - 0.2, 0.0, 3) CALL GGIP (HORS, VRT - 0.2, 0.0, 2) VRT = VRT - 0.3 CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF DO 850 ISYM = 1, N3 + 1 DO 400 I = 1, 3 DO 390 J = 1, 3 BTRANS(I, J) = RH(I, J, ISYM) 390 CONTINUE IROW0(I) = NINT (RH(I, 3, ISYM)) 400 CONTINUE CALL GEN003 (BTRANS, BTRM1, DET, 0) IRCTR = 0 DO 410 I = 1, 3 IF (ABS (ABS (BTRM1(3, I)) - 0.5) .LT. 0.48) IRCTR = I 410 CONTINUE DO 440 I = 1, NATOMS DO 420 J = 1, 3 V1(J) = CON(I, J) 420 CONTINUE CALL GEN002 (1, BTRM1, V1, V2, XLNG) DO 430 J = 1, 3 CON(I, J + 4) = V2(J) 430 CONTINUE 440 CONTINUE IF (ISYM .LE. N3) THEN IPERP = NINT (PERPAX(ISYM)) ANG = AANG(ISYM) MULT = NINT (GEN009 (RH(1, 3, ISYM), PH(1, ISYM))) DLE = HH(4, ISYM) IF (IPERP .GE. 6) THEN ITYPB = 1 ITYPE = 4 ELSE IF (IPERP .EQ. 3) THEN ITYPB = 2 ITYPE = 2 ELSE IF (IPERP .GE. 4) THEN ITYPB = 3 ITYPE = 4 ELSE ITYPB = 4 ITYPE = 4 ENDIF ELSE ITYPB = 5 ITYPE = 5 INVST = 0 ENDIF DO 840 ITYP = ITYPB, ITYPE IF (ITYP .EQ. 1) THEN NROT = 6 ELSE IF (ITYP .EQ. 2) THEN NROT = 3 ELSE IF (ITYP .EQ. 3) THEN NROT = 4 ELSE IF (ITYP .EQ. 4) THEN NROT = 2 ENDIF DO 830 NTYP = 1, 2 ITRY = ITYP * (-1) ** NTYP JROT = 6 - NTYP DSMAX = -1.0 NCHR = 0 IF (ITRY .EQ. 5) THEN DLIM = PAR(408) ELSE IF (ITRY .EQ. -5) THEN DLIM = PAR(409) ENDIF DO 460 I = 1, 3 ROTAX(I, 4) = 0.0 TRANSL(I) = ROT(I, JROT, ITYP) DO 450 J = 1, 3 TEMP = ROT(I, J, ITYP) IF (ITRY .LT. 0) TEMP = - TEMP ROTAX(I, J) = TEMP IF (I .EQ. J) TEMP = TEMP - 1.0 ROTM1(I, J) = TEMP 450 CONTINUE 460 CONTINUE DO 480 I = 1, 3 V6(I) = 1.0 DO 470 J = 1, 3 IF (ROTM1(I, J) .NE. 0.0) GOTO 480 IF (ROTM1(J, I) .NE. 0.0) GOTO 480 470 CONTINUE V6(I) = 0.0 ROTM1(I, I) = 1.0 480 CONTINUE CALL GEN003 (ROTM1, ROTM2, DET, 0) DO 490 I = 1, 3 ROTM2(I, I) = ROTM2(I, I) * V6(I) 490 CONTINUE IAT1 = 1 CATM1 = CON(IAT1, 4) IFNT1 = IFNT(IAT1) DO 510 I = 1, 3 RATOM(I) = 0.0 DO 500 J = 1, 3 RATOM(I) = RATOM(I) + ROTAX(I, J) * CON(IAT1, J + 4) 500 CONTINUE 510 CONTINUE DO 820 IAT2 = 1, NATOMS IFNT2 = IFNT(IAT2) IF (NTYP .EQ. 1 .OR. ITRY .EQ. 5) THEN IF ((IFNT1 + IFNT2) .NE. 0) GOTO 820 ELSE IF (NTYP .EQ. 2 .OR. ITRY .EQ. -5) THEN IF ((IFNT1 - IFNT2) .NE. 0) GOTO 820 ENDIF NCHR = IABS(IFNT1) DSMAX = -1.0 IF (NINT(CON(IAT2, 4)) .EQ. NINT(CATM1)) THEN DO 520 II = 1, 3 ATOM2(II, 1) = CON(IAT2, II + 4) 520 CONTINUE IF (IRCTR .NE. 0) THEN JM = 2 DO 530 I = 1, 3 ATOM2(I, 2) = ATOM2(I, 1) + BTRM1(I, IRCTR) 530 CONTINUE ELSE JM = 1 ENDIF DO 550 J = 1, JM GLITOT(J) = 0.0 DO 540 I = 1, 3 GLIDO(I, J) = 0.0 IF (TRANSL(I) .GE. 0.1 .OR. ITRY .EQ. -5) THEN GLIDO(I, J) = ATOM2(I, J) - CON(IAT1, I + 4) GLITOT(J) = GLITOT(J) + GLIDO(I, J)**2 GLITOT(J) = GLITOT(J) - INT(GLITOT(J) + 0.1) IF (ITRY .NE. - 5) THEN XDUM = MOD (12.0 * GLIDO(I, J) / 1 TRANSL(I) + 10.0, 1.0) IF (ABS (XDUM - 0.5) .LE. 0.45) GOTO 820 ENDIF ENDIF 540 CONTINUE 550 CONTINUE JG = 1 IF (IRCTR .NE. 0) THEN IF (ABS (GLITOT(2)) .LT. ABS(GLITOT(1))) JG = 2 ENDIF DO 560 I = 1, 3 ROTAX(I, 4) = GLIDO(I, JG) * 12.0 V1(I) = RATOM(I) - ATOM2(I, JG) + GLIDO(I, JG) 560 CONTINUE CALL GEN002 (1, ROTM2, V1, ORIG, XLNG) P249 = PAR(249) NLOOP = 0 570 NFIT = 0 NNFIT = 100 DO 580 I = 1, NATOMS CON(I, 9) = 0.0 580 CONTINUE CON(IAT1, 9) = 2.0 CON(IAT2, 9) = 2.0 DO 640 IAT3 = 2, NATOMS IFNT3 = IFNT(IAT3) DO 590 K = 1, 3 V1(K) = CON(IAT3, K + 4) - ORIG(K) 590 CONTINUE DO 610 K = 1, 3 V2(K) = ROTAX(K, 4) / 12.0 + ORIG(K) DO 600 J = 1, 3 V2(K) = V2(K) + ROTAX(K, J) * V1(J) 600 CONTINUE 610 CONTINUE CALL GEN002 (1, BTRANS, V2, V3, XLNG) IIAT3 = NINT(CON(IAT3, 4)) DO 630 IAT4 = 1, NATOMS IFNT4 = IFNT(IAT4) IF (NTYP .EQ. 1 .OR. ITRY .EQ. 5) THEN IF ((IFNT3 + IFNT4) .NE. 0) GOTO 630 ELSE IF (NTYP .EQ. 2 .OR. ITRY .EQ. -5) THEN IF ((IFNT3 - IFNT4) .NE. 0) GOTO 630 ENDIF IF (NINT(CON(IAT4, 4)) .EQ. IIAT3) 1 THEN IF (ITRY .NE. -5 .OR. IAT3 .NE. IAT4) THEN DO 620 K = 1, 3 DELTA = MOD (V3(K) - CON(IAT4, K), 1.0) IF (ABS (DELTA) .GT. 0.5) 1 DELTA = DELTA - SIGN (1.0, DELTA) IF (ABS (DELTA) .GT. 0.2) GOTO 630 DEL(K) = DELTA 620 CONTINUE CALL GEN002 (2, ADIR, DEL, V4, DIS) DIS = DIS / 2 IF (DIS .LE. DLIM) THEN IF (DIS .GT. DSMAX) THEN DSMAX = DIS CALL PLA047 (CON(IAT3, 8), NQ3, IDUM, 1 JDUM, 0, IGBL(55), 0, 0) CALL PLA047 (CON(IAT4, 8), NQ4, IDUM, 1 JDUM, 0, IGBL(55), 0, 0) NQ3(6 : 6) = '-' ENDIF CON(IAT3, 9) = CON(IAT3, 9) + 1 NCHR = NCHR + IABS(IFNT3) GOTO 640 ENDIF ENDIF ENDIF 630 CONTINUE NFIT = NFIT + 1 IF (NFIT * 100.0 / NATOMS .GT. P249) GOTO 820 640 CONTINUE IF (ITRY .EQ. 5) THEN IF (IPR(257) .EQ. 1) THEN IF (NFIT .NE. 0) IPR(118) = 1 ENDIF ENDIF NQ1 = ' ' NFTX = 0 CALL GEN038 (LINE, 1, 80) DO 650 N = 1, NATOMS IF (NINT (CON(N, 9)) .LT. 1) THEN CALL PLA047 (CON(N, 8), NQ2, IDUM, JDUM, 0, 1 IGBL(55), 0, 0) IF (NQ2 .NE. NQ1) THEN NQ1 = NQ2 IF (JCA(N) .EQ. 1 .AND. ITRY .EQ. 5) THEN IF (NFTX .NE. 0) THEN WRITE (LU6, 99979) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (1) WRITE (LU7, 99979) ENDIF ENDIF GOTO 820 ENDIF NFTX = NFTX + 1 IF (NFTX .LT. 12) THEN LINE((NFTX - 1) * 5 + 1:) = NQ1 ENDIF ENDIF ENDIF 650 CONTINUE FIT = NFTX * 100.0 / NINC IF (FIT .GT. P249) GOTO 820 IF (NFTX .EQ. 0) THEN NNFIT = 100 ELSE NNFIT = INT(100.0 - FIT) ENDIF CALL GEN004 (TRNS, BTRANS, TTRANS) CALL GEN003 (TTRANS, TTRM1, DET, 0) CALL GEN004 (ROTAX , TTRM1, DUMV) CALL GEN004 (TTRANS, DUMV, ROTM1) ISTR = 1 STAR = ' *' IF (ITRY .NE. -5) THEN DO 680 I0 = 1, NSYM CALL SGSM (ICL, I0, XJX, LU6, 6, IERR) ITEL = 0 DO 670 IR = 1, 3 DO 660 IL = 1, 3 ITEL = ITEL + 1 IF (ABS (ROTM1(IR, IL) - XJX(ITEL)) 1 .GT. 0.01) GOTO 680 660 CONTINUE 670 CONTINUE ISTR = 0 STAR = ' ' IF (NFIT .GT. 0 .AND. NLCLP .EQ. 1) THEN P249 = 0.0 NLOOP = NLOOP + 1 IF (NLOOP .LT. 10) GOTO 570 ENDIF GOTO 690 680 CONTINUE IPR(209) = 1 ENDIF 690 FSYM = ' ' TEXT1 = ' ' NRT = NROT IF (ITRY .GT. 0 .AND. ITYP .NE. 4) THEN FSYM(1 : 1) = '-' IF (NRT .EQ. 4) NRT = 5 ENDIF FSYM(2 : 2) = CHAR(ICHAR('0') + NROT) IF (ITRY .EQ. -4) THEN FSYM(2 : 2) = 'm' NRT = 0 ENDIF IGLIDE = 0 DO 700 I0 = 1, 3 ORI = MOD (ORIG(I0), 1.0) IF (ORI .LT. -0.45) ORI = ORI + 1.0 IF (ORI .GT. 0.6) ORI = ORI - 1.0 ORIG(I0) = ORI GLI = MOD (GLIDO(I0, JG), 1.0) IF (GLI .LT. -0.45) GLI = GLI + 1.0 IF (GLI .GT. 0.6) GLI = GLI - 1.0 GLIDE(I0) = GLI IF (ABS(GLI) .GE. 0.05) IGLIDE = 1 700 CONTINUE CALL GEN002 (1, BTRANS, GLIDE, V1, XLNG) CALL GEN002 (1, TRNS , V1, GLIDE, XLNG) CALL GEN002 (1, TRNS , V1, GLY, XLNG) CALL GEN002 (1, BTRANS, ORIG , V1, XLNG) CALL GEN002 (1, TRNS , V1 , ORIG, XLNG) CALL GEN002 (1, TRNS , RH(1, 3, ISYM), ROW, XLNG) DO 710 I0 = 1, 3 IF (ISYM .GT. N3) THEN ORIG(I0) = MOD (1.0 + ORIG(I0), 0.5) ELSE IF (ORIG(I0) .LT. - 0.1) ORIG(I0) = ORIG(I0) + 1.0 ENDIF 710 CONTINUE IF (DSMAX .LT. 0.0001) THEN NQ3 = ' ' NQ4 = ' ' ENDIF IF (ITYP .NE. 5) THEN ISIG = 0 DO 720 I0 = 1, 3 IF (ISIG .EQ. 0 .AND. ROW(I0) .LT. -0.01) 1 ISIG = -1 IF (ISIG .EQ. 0 .AND. ROW(I0) .GT. 0.01) 1 ISIG = 1 720 CONTINUE IMULT = 0 730 IMULT = IMULT + ISIG DO 740 I0 = 1, 3 IROW(I0) = NINT(IMULT * ROW(I0)) IF (ABS(ABS(ROW(I0) * IMULT) - IABS(IROW(I0))) 1 .GT. 0.01) GOTO 730 740 CONTINUE IF (ITRY .LT. 0) THEN DO 750 I0 = 1, 3 GLIDE(I0) = ISIG * GLIDE(I0) GLY(I0) = GLIDE(I0) 750 CONTINUE ENDIF IF (IGLIDE .EQ. 1) THEN TEXT2 = 'Screw =' DO 760 I0 = 1, 3 ITR(I0) = MOD (NINT(12.0 * GLIDE(I0)) + 12, 12) GLIDE(I0) = ITR(I0) / 12.0 ISHFT = ITR(I0) * IROW(I0) ITRI0 = ITR(I0) IF (ISHFT .NE. 0) THEN IF (NROT .EQ. 3) THEN IF (ITRI0 .EQ. 2) THEN ITRI0 = 4 ELSE IF (ITRI0 .EQ. 10) THEN ITRI0 = 8 ENDIF ENDIF TEXT1 = CHAR(ICHAR('0') + ITRI0 * NROT / 12) ENDIF 760 CONTINUE IF (ITRY .EQ. - 4) THEN NRT = 0 TEXT1 = ' ' TEXT2 = 'Glide =' IF (ITR(1) .EQ. 0 .AND. ITR(2) .EQ. 0) THEN FSYM(2 : 2) = 'c' ELSE IF (ITR(1) .EQ. 0 .AND. ITR(3) .EQ. 0) THEN FSYM(2 : 2) = 'b' ELSE IF (ITR(2) .EQ. 0 .AND. ITR(3) .EQ. 0) THEN FSYM(2 : 2) = 'a' ELSE IF (MOD (ITR(1), 6) .EQ. 3 .OR. 1 MOD (ITR(2), 6) .EQ. 3) THEN FSYM(2 : 2) = 'd' ELSE FSYM(2 : 2) = 'n' ENDIF ENDIF IPRMX = 80 ELSE IPRMX = 55 ENDIF NEWS = NEWS + 1 NMIS(NEWS) = (6 - NRT) * 100 + NEWS DO 780 IR = 1, 3 DO 770 IK = 1, 3 XMIS(IR, IK, NEWS) = ROTM1(IR, IK) 770 CONTINUE XMIS4(IR, NEWS) = ORIG(IR) XMIS5(IR, NEWS) = GLY(IR) * ISIG 780 CONTINUE IF (NFTX .GT. 0) THEN WRITE (LU6, 99964) WRITE (LU6, 99954) LINE(1:75) WRITE (LU6, 99979) WRITE (LU6, 99979) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99964) WRITE (LU7, 99954) LINE(1:75) WRITE (LU7, 99979) ENDIF ENDIF IF (STAR .EQ. ' *') 1 WRITE (LU20, 99935) '_112', NNFIT, NNFIT, FSYM WRITE (PRBUF, 99995) FSYM, STAR, IROW, IROW0, DLE, 1 IPERP, MULT, ANG, NNFIT, DSMAX, ORIG NNNFIT = MIN (NNNFIT, NNFIT) CALL GEN065 (0, PRBUF, 81, 7) WRITE (LU6, 99954) PRBUF(1:80) IF (NNFIT .LT. 100 .AND. ISTR .EQ. 1) ISTR = 5 IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1 + ISTR, 1 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99954) PRBUF(1:80) ENDIF WRITE (PRBUF, 99991) TEXT1, NQ3(1:6), NQ4(1:6), 1 TEXT2, GLIDE CALL GEN065 (0, PRBUF, IPRMX + 1, 7) WRITE (LU6, 99954) PRBUF(1:IPRMX) IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN DO 790 I0 = 1, IPRMX IF (PRBUF(I0:I0) .NE. ' ') THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, IPRMX, 0.35, 1 1 + ISTR, 2, 1.0, VRT) GOTO 800 ENDIF 790 CONTINUE ENDIF 800 IF (IWIN .EQ. 1) CALL GGIP (0.0, 0.0, 0.0, 6) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99954) PRBUF(1:IPRMX) ENDIF IF (DSMAX .GT. PAR(291)) PAR(291) = DSMAX NSV = NSV + 1 KBO(NSV, 1) = NROT KBO(NSV, 2) = ISYM KBO(NSV, 3) = ISTR ELSE IF (ITRY .LT. 0) THEN DO 810 I0 = 1, 3 GLIDE(I0) = MOD (GLIDE(I0), 1.0) IF (ABS(GLIDE(I0)) .LT. 0.001) GLIDE(I0) = 0.0 IF (GLIDE(I0) .LT. -0.001) 1 GLIDE(I0) = GLIDE(I0) + 1.0 NA(I0) = MOD (NINT(GLIDE(I0) * 24), 24) NZ = NA(I0) IF (NZ .GT. 12) NZ = 24 - NZ IF (NZ .EQ. 1 .OR. NZ .EQ. 5. .OR. NZ .EQ. 7 1 .OR. NZ .EQ. 10 .OR. NZ .EQ. 11) GOTO 820 810 CONTINUE NLCP = NA(1) * 10000 + NA(2) * 100 + NA(3) IF (NLCP .EQ. 0) THEN FSYM = ' P' ELSE IF (NLCP .EQ. 1212) THEN FSYM = ' A' ELSE IF (NLCP .EQ. 120012) THEN FSYM = ' B' ELSE IF (NLCP .EQ. 121200) THEN FSYM = ' C' ELSE IF (NLCP .EQ. 121212) THEN FSYM = ' I' ELSE IF (NLCP .EQ. 120000) THEN FSYM = ' X' ELSE IF (NLCP .EQ. 1200) THEN FSYM = ' Y' ELSE IF (NLCP .EQ. 12) THEN FSYM = ' Z' ELSE FSYM = ' S' ENDIF NSGTR = 1 IF (NFTX .GT. 0) THEN WRITE (LU6, 99964) WRITE (LU6, 99954) LINE(1:75) WRITE (LU6, 99979) WRITE (LU6, 99979) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99964) WRITE (LU7, 99954) LINE(1:75) WRITE (LU7, 99979) ENDIF ENDIF WRITE (LU20, 99935) '_112', 1, 1, FSYM WRITE (PRBUF, 99988) FSYM, NLCP, NNFIT, DSMAX, 1 GLIDE CALL GEN065 (0, PRBUF, 81, 7) WRITE (LU6, 99954) PRBUF(1:80) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99954) PRBUF(1:80) ENDIF IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN VRT = VRT - 0.5 IF (NNFIT .EQ. 100) THEN NCOL = 2 ELSE NCOL = 6 ENDIF CALL GGIP20 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1 1.0, VRT) ENDIF WRITE (PRBUF, 99970) NQ3(1:6), NQ4(1:6) WRITE (LU6, 99954) PRBUF(1:80) IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1 1.0, VRT) ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99954) PRBUF(1:80) ENDIF IF (NLCLP .EQ. 1) THEN IF (NNFIT .GE. (100 - IPR(568) * 1 NINT(PAR(249)))) THEN IF (NEWLT .EQ. 0) WRITE (LU20, 99954) 1 '_110 1 1' IF (IPR(503) .EQ. 0) THEN NEWLT = NEWLT + 1 NEWLAT(NEWLT) = NLCP IPR(209) = 1 IPR(459) = 1 ELSE NNFIT = 100 ENDIF ENDIF ENDIF ENDIF GOTO 820 ELSE IF (IPR(257) .EQ. 1) INVST = 1 IF (STAR .EQ. ' *') THEN WRITE (LU20, 99935) '_111', NNFIT, NNFIT ENDIF WRITE (PRBUF, 99987) STAR, NNFIT, DSMAX, ORIG IF (DSMAX .LT. DSCENT) THEN NFT = NNFIT DSCENT = DSMAX ORGM(1) = ORIG(1) ORGM(2) = ORIG(2) ORGM(3) = ORIG(3) ENDIF CALL GEN065 (0, PRBUF, 81, 7) WRITE (LU6, 99954) PRBUF(1:80) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99954) PRBUF(1:80) ENDIF IF (NNFIT .LT. 100 .AND. ISTR .EQ. 1) ISTR = 5 IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1 + ISTR, 2, 1 1.0, VRT) ENDIF WRITE (PRBUF, 99970) NQ3(1:6), NQ4(1:6) WRITE (LU6, 99954) PRBUF(1:80) IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1 + ISTR, 2, 1 1.0, VRT) ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99954) PRBUF(1:80) ENDIF ENDIF ENDIF IF (ITYP .NE. 5 .OR. STAR .EQ. ' ') GOTO 850 ENDIF 820 CONTINUE 830 CONTINUE IF (ITRY .NE. 5) NCHIRF = MIN (NCHIRF, NCHR / NSYM) 840 CONTINUE IF (ISYM .LE. N3) THEN IMETRIC = IMETRIC + 1 WRITE (PRBUF, 99996) IROW0, DLE, IPERP, MULT, ANG CALL GEN065 (0, PRBUF, 61, 4) WRITE (LU6, 99932) PRBUF(1:61) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99932) PRBUF(1:61) ENDIF ENDIF 850 CONTINUE IF (NEWLT .GT. 0 .AND. IPR(503) .EQ. 0) THEN CALL PLA028 (NEWLT, NLTX, NEWLAT, NP47) IF (NLTX .GT. 0) THEN IF (IWIN .EQ. 1) THEN BCD = 'Implement new Sublattice ? (y/n[N])'//CHAR(0) CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 36.0, 110) CALL PLA013 (0, 1) ELSE IGGT = 'Y' ENDIF IF (IGGT(1:1) .EQ. 'Y') THEN WRITE (PRBUF, 99959) JID(1:21) WRITE (LU6, 99926) PRBUF IF (IWIN .EQ. 1) THEN VRT = VRT - 1.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 4.0, VRT) CALL PLA297 (0) ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99927) PRBUF ENDIF XSUB = 'S' GOTO 40 ELSE IPR(459) = 0 IPR(209) = 0 ENDIF ENDIF ENDIF IF (NSV .EQ. 2) THEN DO 870 I = 1, 2 IF (KBO(I, 3) .EQ. 1) THEN KBO(I, 1) = 0 GOTO 880 ENDIF 870 CONTINUE ENDIF 880 JMX = NSV - 1 890 NB = 0 DO 910 J = 1, JMX IF (KBO(J, 1) .LT. KBO(J + 1, 1)) THEN DO 900 K = 1, 3 CALL GEN014 (KBO(J, K), KBO(J + 1, K)) 900 CONTINUE NB = 1 ENDIF 910 CONTINUE IF (NB .EQ. 1) GOTO 890 ISYST = 8 MLAUE = 12 IF (NSV .EQ. 2) NSV = 1 IF (NSV .EQ. 0) THEN CALL GEN021 (PAT, 1) ISYST = 1 MLAUE = 1 ELSE NROT = KBO(1, 1) IF (NSV .EQ. 7 .AND. NROT .NE. 6) THEN I0 = 4 ELSE I0 = 0 ENDIF IF (I0 .EQ. 4 .OR. NSV .EQ. 3 .OR. NSV .EQ. 13) THEN DO 930 I = 1, 3 DO 920 J = 1, 3 PAT(I, J) = RH(J, 3, KBO(I0 + I, 2)) 920 CONTINUE 930 CONTINUE IF (NSV .EQ. 3) THEN ISYST = 3 MLAUE = 3 ELSE IF (NSV .EQ. 7) THEN ISYST = 7 MLAUE = 10 ELSE ISYST = 7 MLAUE = 11 ENDIF ELSE ISYM = KBO(1, 2) DO 940 J = 1, 3 DO 945 K = 1, 3 PAT(K, J) = RH(J, K, ISYM) 945 CONTINUE 940 CONTINUE IF (NSV .EQ. 1) THEN IF (NROT .EQ. 2) THEN ISYST = 2 MLAUE = 2 DO 950 J = 1, 3 CALL GEN018 (PAT(2, J), PAT(3, J)) 950 CONTINUE ELSE IF (NROT .EQ. 3) THEN ISYST = 5 MLAUE = 6 ELSE IF (NROT .EQ. 4) THEN ISYST = 4 MLAUE = 4 ELSE ISYST = 6 MLAUE = 8 ENDIF ELSE IF (NSV .EQ. 4) THEN IF (NROT .NE. 4) THEN ISYST = 5 MLAUE = 7 ELSE ISYST = 4 MLAUE = 5 ENDIF ELSE IF (NSV .EQ. 5) THEN ISYST = 4 MLAUE = 5 ELSE IF (NSV .EQ. 7) THEN ISYST = 6 MLAUE = 9 ENDIF ENDIF ENDIF CALL GEN010 (PAT, IDET, 0) IF(IDET .LT. 0) THEN DO 960 J = 1, 3 PAT(2, J) = - PAT(2, J) 960 CONTINUE ENDIF CALL GEN003 (PAT, ROTM1, DET, 0) IDET = NINT(DET) IF (IDET .EQ. 4) THEN LATT = 'F' ELSE IF (IDET .EQ. 3) THEN LATT = 'R' V1(1) = 2.0 V1(2) = 1.0 V1(3) = 1.0 CALL GEN094 (PAT, V1, 3, IDUM) IF (IDUM .NE. 0) THEN CALL GEN021 (DAM, 1) DAM(1, 2) = 1.0 DAM(2, 1) = -1.0 DAM(2, 2) = 0.0 CALL GEN004 (DAM, PAT, PAT) ENDIF ELSE IF (IDET .EQ. 2) THEN V1(1) = 0.0 V1(2) = 1.0 V1(3) = 1.0 N = 0 CALL GEN094 (PAT, V1, 2, IDUM) IF (IDUM .EQ. 0) THEN LATT = 'A' N = 1 ELSE CALL GEN018 (V1(1), V1(2)) CALL GEN094 (PAT, V1, 2, IDUM) IF (IDUM .EQ. 0) THEN LATT = 'B' N = 2 ELSE CALL GEN018 (V1(2), V1(3)) CALL GEN094 (PAT, V1, 2, IDUM) IF (IDUM .EQ. 0) THEN LATT = 'C' ELSE V1(3) = 1.0 CALL GEN094 (PAT, V1, 2, IDUM) IF (IDUM .EQ. 0) THEN LATT = 'I' ELSE LATT = ' ' ENDIF ENDIF ENDIF ENDIF IF (N .NE. 0) THEN DO 970 I = 1, 3 PAT(2, I) = - PAT(2, I) CALL GEN018 (PAT(N, I), PAT(3, I)) 970 CONTINUE LATT = 'C' ENDIF ELSE LATT = 'P' ENDIF IF (ISYST .EQ. 5) THEN LAT0 = 6 ELSE LAT0 = ISYST ENDIF IF (LAT0 .EQ. 2 .AND. LATT .EQ. 'I' .AND. IGBL(106) .EQ. 0) THEN LATT = 'C' CALL GEN021 (DAM, 1) DAM(1, 3) = 1.0 DAM(3, 1) = -1.0 DAM(3, 3) = 0.0 CALL GEN004 (DAM, PAT, PAT) ENDIF CALL GEN005 (TRNS, QM) CALL GEN004 (PAT, QM, ROTM2) CALL GEN005 (ROTM2, TR1) CALL GEN003 (TR1, ROTM1, DET, 0) CALL GEN038 (SPGRNM(2), 1, 11) CALL GEN074 (ORG, 0.0, 1, 3) IF (INVST .EQ. 1) CALL GEN002 (1, ROTM1, ORGM, ORG, XLNG) IF (INVST .EQ. 1 .OR. IPR(257) .EQ. 2) THEN CENT = 'C' ELSE CENT = 'A' ENDIF IF (LAT0 .EQ. 7) THEN DO 990 JN = 1, NEWS IN = NMIS(JN) / 100 IF (IN .EQ. 3) NMIS(JN) = NMIS(JN) + 300 990 CONTINUE ENDIF CALL GEN022 (NMIS, 1, NEWS) NRT1 = 0 NNRT = 0 V41 = 0.25 V42 = 0.25 V43 = 0.25 DO 1010 JN = 1, NEWS IN = MOD (NMIS(JN), 100) NRT = 6 - NMIS(JN) / 100 IF (NRT .EQ. 5) THEN NRT = 4 NNRT = 1 ENDIF CALL GEN004 (ROTM1, XMIS(1, 1, IN), XMIS(1, 1, IN)) CALL GEN004 (XMIS(1, 1, IN), TR1, XMIS(1, 1, IN)) CALL GEN002 (1, ROTM1, XMIS4(1, IN), XMIS4(1, IN), XLNG) CALL GEN002 (1, ROTM1, XMIS5(1, IN), XMIS5(1, IN), XLNG) IF (JN .EQ. 1) THEN IF (INVST .EQ. 0 .AND. IPR(257) .EQ. 1) THEN IN1 = IN ORG(1) = XMIS4(1, IN) ORG(2) = XMIS4(2, IN) ORG(3) = XMIS4(3, IN) NRT1 = NRT IF (LAT0 .EQ. 4) THEN V43 = 0.125 ELSE IF (LAT0 .EQ. 6) THEN V41 = 0.3333 V42 = 0.3333 V43 = 0.5 / NRT1 ELSE IF (LAT0 .EQ. 7) THEN V41 = 0.125 V42 = 0.125 V43 = 0.125 ENDIF ELSE IF (NRT .EQ. 3 .OR. NRT .EQ. 6) THEN ORG(1) = ORG(1) + 1 0.5 * MOD (NINT((XMIS4(1, IN) - ORG(1)) * 6), 2) ORG(2) = ORG(2) + 1 0.5 * MOD (NINT((XMIS4(2, IN) - ORG(2)) * 6), 2) ENDIF ENDIF ELSE IF (JN .EQ. 2 .AND. NNRT .EQ. 0) THEN IF (INVST .EQ. 0 .AND. IPR(257) .EQ. 1) THEN IF (NRT1 .GT. 2) THEN IF (NRT .EQ. 4) THEN IF (XMIS(1, 1, IN1) .EQ. 1) THEN ORG(1) = XMIS4(1, IN) ELSE IF (XMIS(2, 2, IN1) .EQ. 1) THEN ORG(2) = XMIS4(2, IN) ELSE IF (XMIS(3, 3, IN1) .EQ. 1) THEN ORG(3) = XMIS4(3, IN) ENDIF ELSE ORG(3) = XMIS4(3, IN) ENDIF ELSE IF (NINT(XMIS(1, 1, IN1)) .EQ. 1 .AND. 1 NINT(XMIS(2, 2, IN1)) .EQ. -1 .AND. 2 NINT(XMIS(3, 3, IN1)) .EQ. -1) THEN ORG(1) = XMIS4(1, IN) ELSE IF (NINT(XMIS(1, 1, IN1)) .EQ. -1 .AND. 1 NINT(XMIS(2, 2, IN1)) .EQ. 1 .AND. 2 NINT(XMIS(3, 3, IN1)) .EQ. -1) THEN ORG(2) = XMIS4(2, IN) ELSE IF (NINT(XMIS(1, 1, IN1)) .EQ. -1 .AND. 1 NINT(XMIS(2, 2, IN1)) .EQ. -1 .AND. 2 NINT(XMIS(3, 3, IN1)) .EQ. 1) THEN ORG(3) = XMIS4(3, IN) ENDIF ENDIF ENDIF ENDIF DO 1000 IR = 1, 3 XMIS4(IR, IN) = XMIS4(IR, IN) - ORG(IR) 1000 CONTINUE 1010 CONTINUE V4(1) = 0.0 V4(2) = 0.0 V4(3) = 0.0 NORG = 0 1020 WRITE (ICL, 99958) LATT, CENT CALL SGSM (ICL, 0, FN, LU6, 0, IERR) DO 1060 JN = 1, NEWS IN = MOD (NMIS(JN), 100) DO 1030 JJ = 1, 3 V5(JJ) = - XMIS4(JJ, IN) + V4(JJ) 1030 CONTINUE CALL GEN002 (1, XMIS(1, 1, IN), V5, V6, XLNG) KK = 0 DO 1050 II = 1, 3 FN(9 + II) = NINT (24.0 * MOD (XMIS4(II, IN) - V4(II) + 1 V6(II) + XMIS5(II, IN) + 10.0, 1.0)) / 24.0 DO 1040 JJ = 1, 3 KK = KK + 1 FN(KK) = XMIS(II, JJ, IN) 1040 CONTINUE 1050 CONTINUE CALL SGSM (ICL, 0, FN, LU6, 15, IERR) IF (IERR .NE. 0) THEN IF (LOOPR .EQ. 1) THEN JERR = 1 GOTO 1155 ELSE GOTO 1070 ENDIF ENDIF 1060 CONTINUE CALL SGSM (ICL, 0, FN, 0, 18, IERR) SPGRNM(2) = ICL(1:26) IF (SPGRNM(2)(1:4) .NE. 'C2/n') THEN IF (IBVL(LAT0)//LATT .NE. ICL(12:13)) GOTO 1070 IF (SPGRNM(2)(1:2) .NE. ' ') GOTO 1080 ENDIF 1070 IF (CENT .EQ. 'A') THEN V4(3) = V4(3) + V43 IF (V4(3) .GT. 0.99) THEN V4(3) = 0.0 V4(2) = V4(2) + V42 IF (V4(2) .GT. 0.99) THEN V4(2) = 0.0 V4(1) = V4(1) + V41 ENDIF ENDIF IF (V4(1) .LT. 1.0) GOTO 1020 ELSE NORG = NORG + 1 IF (LATT .EQ. 'P') THEN IF (NORG .EQ. 1) THEN V4(1) = 0.50 V4(2) = 0.00 V4(3) = 0.00 ELSE IF (NORG .EQ. 2) THEN V4(1) = 0.00 V4(2) = 0.50 V4(3) = 0.00 ELSE IF (NORG .EQ. 3) THEN V4(1) = 0.00 V4(2) = 0.00 V4(3) = 0.50 ENDIF NORGM = 3 ELSE IF (LATT .EQ. 'A') THEN V4(2) = 0.25 V4(3) = 0.25 NORGM = 1 ELSE IF (LATT .EQ. 'B') THEN V4(1) = 0.25 V4(3) = 0.25 NORGM = 1 ELSE IF (LATT .EQ. 'C') THEN V4(1) = 0.25 V4(2) = 0.25 NORGM = 1 ELSE IF (LATT .EQ. 'F') THEN IF (NORG .EQ. 1) THEN V4(1) = 0.00 V4(2) = 0.25 V4(3) = 0.25 ELSE IF (NORG .EQ. 2) THEN V4(1) = 0.25 V4(2) = 0.00 V4(3) = 0.25 ELSE IF (NORG .EQ. 3) THEN V4(1) = 0.25 V4(2) = 0.25 V4(3) = 0.00 ENDIF NORGM = 3 ELSE IF (LATT .EQ. 'I') THEN IF (NORG .EQ. 1) THEN V4(1) = 0.25 V4(2) = 0.25 V4(3) = 0.25 ELSE IF (NORG .EQ. 2) THEN V4(1) = 0.50 V4(2) = 0.00 V4(3) = 0.00 ELSE IF (NORG .EQ. 3) THEN V4(1) = 0.00 V4(2) = 0.50 V4(3) = 0.00 ELSE IF (NORG .EQ. 4) THEN V4(1) = 0.00 V4(2) = 0.00 V4(3) = 0.50 ELSE IF (NORG .EQ. 5) THEN V4(1) = 0.75 V4(2) = 0.25 V4(3) = 0.25 ELSE IF (NORG .EQ. 6) THEN V4(1) = 0.25 V4(2) = 0.75 V4(3) = 0.25 ELSE IF (NORG .EQ. 7) THEN V4(1) = 0.25 V4(2) = 0.25 V4(3) = 0.75 ENDIF NORGM = 7 ELSE IF (LATT .EQ. 'R') THEN IF (NORG .EQ. 1) THEN V4(1) = 0.33333 V4(2) = 0.16667 V4(3) = 0.16667 ELSE V4(1) = 0.16667 V4(2) = 0.33333 V4(3) = 0.33333 ENDIF NORGM = 2 ENDIF IF (NORG .LE. NORGM) GOTO 1020 ENDIF 1080 DO 1090 J = 1, 3 ORG(J) = ORG(J) + V4(J) V4(J) = 0.0 1090 CONTINUE IF (SPGRNM(2)(1:1) .EQ. ' ') THEN SPGRNM(2)(1:1) = '?' ELSE IF (SPGRNM(2)(12:12) .EQ. 'm') THEN IF (SPGRNM(2)(1:7) .EQ. 'Pa ') THEN SPGRNM(2)(1:11) = 'Pc C-BA' ELSE IF (SPGRNM(2)(1:7) .EQ. 'P2/a ') THEN SPGRNM(2)(1:11) = 'P2/c C-BA' ELSE IF (SPGRNM(2)(1:7) .EQ. 'P21/a ') THEN SPGRNM(2)(1:11) = 'P21/c C-BA' ELSE IF (IGBL(106) .EQ. 0) THEN IF (SPGRNM(2)(1:7) .EQ. 'Pn ') THEN SPGRNM(2)(1:11) = 'Pc A-B-' ELSE IF (SPGRNM(2)(1:7) .EQ. 'P2/n ') THEN SPGRNM(2)(1:11) = 'P2/c A-B-' ELSE IF (SPGRNM(2)(1:7) .EQ. 'P21/n ') THEN SPGRNM(2)(1:11) = 'P21/c A-B-' ENDIF ENDIF ELSE IF (SPGRNM(2)(12:12) .EQ. 'c') THEN IF (SPGRNM(2)(1:7) .EQ. 'Pb-3 ') THEN SPGRNM(2)(1:11) = 'Pa-3 BA-C' V4(2) = 0.5 ENDIF ENDIF CALL GEN020 (1, SPGRNM(2), 8, 11) DO 1100 J = 1, 8 IF (SPGRNM(2)(8:11) .EQ. TRTYP(J)(1:4)) THEN CALL GEN004 (TRDAT(1, 1, J), PAT, PAT) CALL GEN004 (PAT, QM, ROTM2) CALL GEN005 (TRDAT(1, 1, J), TR1) CALL GEN003 (TR1, TTRM1, DET, 0) CALL GEN002 (1, TTRM1, ORG, ORG, XLNG) ENDIF 1100 CONTINUE WRITE (ICL, 99939) SPGRNM(2)(1:7) CALL SGSM (ICL, NRXX, XJX, LU6, 0, IERR) CALL SGSM (ICL, 0, FN, LU6, 18, IERR) SPGRNM(2) = ICL(1:26) ISGNR = NINT(FN(1)) LAT0 = NINT(FN(2)) LATT = SPGRNM(2)(13:13) ENDIF DO 1110 J = 1, 3 ORG(J) = ORG(J) + V4(J) IF (ORG(J) .LE. - 0.5) ORG(J) = ORG(J) + 1.0 IF (ORG(J) .GT. 0.5) ORG(J) = ORG(J) - 1.0 1110 CONTINUE LU = LU6 IF (LU .GT. 0) THEN WRITE (LU6, 99974) IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN WRITE (PRBUF, 99943) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, 1 VRT) CALL GGIP (0.0, 1.0, 0.0, 0) CALL GGIP (0.0, VRT - 0.2, 0.0, 3) CALL GGIP (HORS, VRT - 0.2, 0.0, 2) VRT = VRT - 0.3 ENDIF ENDIF CALL GEN003 (ROTM2, DUMMY, DET, 0) CALL GEN005 (DUMMY, DUMMY) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (8) WRITE (LU7, 99974) ENDIF WRITE (PRBUF, 99973) (PAT(1, J), J = 1, 3), 1 (QM(1, J), J = 1, 3), (ROTM2(1, J), J = 1, 3) CALL GEN065 (LU, PRBUF, 80, 16) IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 2) WRITE (LU7, 99954) PRBUF WRITE (PRBUF, 99972) (PAT(2, J), J = 1, 3), 1 (QM(2, J), J = 1, 3), (ROTM2(2, J), J = 1, 3) CALL GEN065 (LU, PRBUF, 80, 16) IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 2) WRITE (LU7, 99954) PRBUF WRITE (PRBUF, 99971) (PAT(3, J), J = 1, 3), 1 (QM(3, J), J = 1, 3), (ROTM2(3, J), J = 1, 3), DET CALL GEN065 (LU, PRBUF, 80, 16) IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 0) WRITE (LU7, 99954) PRBUF CALL GEN004 (ROTM2, AA, DUMV) CALL GEN005 (ROTM2, ROTM1) CALL GEN004 (DUMV, ROTM1, DUMV) CALL GEN026 (-1, DUMV, PAR(143), GL(5)) CALL GEN003 (DUMV, ROTM1, DET, 0) PAR(100) = SQRT(DET) DDIS = 0.0 DANG = 0.0 IF (ISYST .EQ. 2) THEN DANG = MAX (ABS(PAR(146) - 90.0), DANG) DANG = MAX (ABS(PAR(148) - 90.0), DANG) ELSE IF (ISYST .EQ. 3) THEN DANG = MAX (ABS(PAR(146) - 90.0), DANG) DANG = MAX (ABS(PAR(147) - 90.0), DANG) DANG = MAX (ABS(PAR(148) - 90.0), DANG) ELSE IF (ISYST .EQ. 4) THEN DDIS = MAX (ABS(PAR(143) - PAR(144)), DDIS) DANG = MAX (ABS(PAR(146) - 90.0), DANG) DANG = MAX (ABS(PAR(147) - 90.0), DANG) DANG = MAX (ABS(PAR(148) - 90.0), DANG) ELSE IF (ISYST .EQ. 5 .OR. ISYST .EQ. 6) THEN DDIS = MAX (ABS(PAR(143) - PAR(144)), DDIS) DANG = MAX (ABS(PAR(148) - 120.0), DANG) ELSE IF (ISYST .EQ. 7) THEN DDIS = MAX (ABS(PAR(143) - PAR(144)), DDIS) DDIS = MAX (ABS(PAR(143) - PAR(145)), DDIS) DDIS = MAX (ABS(PAR(144) - PAR(145)), DDIS) DANG = MAX (ABS(PAR(146) - 90.0), DANG) DANG = MAX (ABS(PAR(147) - 90.0), DANG) DANG = MAX (ABS(PAR(148) - 90.0), DANG) ENDIF IF (IGBL(63) .GT. 2) THEN JMAX = 2 ELSE JMAX = 1 ENDIF DO 1120 J = 1, JMAX IF (J .EQ. 2) THEN LU = LU7 CALL PLA269 (6) ELSE LU = LU6 ENDIF WRITE (LU, 99979) WRITE (LU, 99998) WRITE (LU, 99951) WRITE (LU, 99949) SPGRNM(1)(12:13), (PAR(100 + I), I = 1, 6), 1 NINT(PAR(98)), KRSYST, LAUEGR WRITE (LU, 99948) (PAR(122 + I), I = 1, 6), NINT(PAR(99)) LAT1 = LAT0 IF (LAT1 .EQ. 5) LAT1 = 6 WRITE (LU, 99947) IBVL(LAT1), LATT, (PAR(142 + I), I = 1, 6), 1 NINT(PAR(100)), XSYST(ISYST), LGR(MLAUE) IF (J .EQ. 1) THEN IF (IWIN .EQ. 1) THEN WRITE (PRBUF, 99998) VRT = VRT - 0.8 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, 1 VRT) CALL GGIP (0.0, 1.0, 0.0, 0) CALL GGIP (0.0, VRT - 0.2, 0.0, 3) CALL GGIP (HORS, VRT - 0.2, 0.0, 2) WRITE (PRBUF, 99949) 1 SPGRNM(1)(12:13), (PAR(100 + I), I = 1, 6), 2 NINT(PAR(98)), KRSYST, LAUEGR VRT = VRT - 0.8 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) WRITE (PRBUF, 99948) 1 (PAR(122 + I), I = 1, 6), NINT(PAR(99)) VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) LAT1 = LAT0 IF (LAT1 .EQ. 5) LAT1 = 6 WRITE (PRBUF, 99947) 1 IBVL(LAT1), LATT, (PAR(142 + I), I = 1, 6), 2 NINT(PAR(100)), XSYST(ISYST), LGR(MLAUE) VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF IF (NLCLP .EQ. 1) THEN N0 = INDEX (ZSPG, ':') IF (N0 .NE. 0) THEN ZSPG0 = ZSPG(1:N0-1) ELSE ZSPG0 = ZSPG ENDIF IF (ZSPG0 .EQ. SPGRNM(2)(1:7)) THEN IF (SPGRNM(1)(1:1) .EQ. ' ') THEN NSP = 2 ELSE NSP = 1 ENDIF WRITE (LU, 99984) SPGRNM(NSP)(1:11) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.9 IF (NSGTR .EQ. 0) THEN WRITE (PRBUF, 99950) SPGRNM(NSP)(1:11) NCOL = 3 ELSE WRITE (PRBUF, 99929) SPGRNM(NSP)(1:11) NCOL = 2 ENDIF CALL GGIP20 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1.0, 1 VRT) ENDIF ELSE IF (INDEX (SPGRNM(2), '?') .NE. 0) THEN IF (LOOPR .LT. 3) THEN JERR = 1 GOTO 1155 ENDIF IF (IWIN .EQ. 1) THEN VRT = VRT - 0.9 WRITE (PRBUF, 99931) CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT) ENDIF WRITE (LU, 99930) PRBUF WRITE (LU20, 99954) '_114 1 1' ENDIF ENDIF ENDIF ENDIF IF (DDIS .GT. 0.0001) WRITE (LU, 99967) DDIS IF (DANG .GT. 0.001) WRITE (LU, 99966) DANG 1120 CONTINUE IF ((ZSPG .NE. SPGRNM(2)(1:7) .AND. 1 SPGRNM(2)(1:1) .NE. '?') .OR. NLCLP .NE. 1) THEN WRITE (LU6, 99963) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (-4) WRITE (LU7, 99963) ENDIF CALL SGSM (ICL, 0, FN, LU6, 2, IERR) IF (IGBL(63) .GT. 0) CALL SGSM (ICL, 0, FN, LU7, 2, IERR) IF (IPR(209) .EQ. 0 .AND. IPR(118) .EQ. 0 .AND. 1 IPR(459) .EQ. 0) THEN IF (IGBL(94) .EQ. 0) THEN IF (ZSPG(1:6) .NE. 'P21/n ' .AND. 1 ZSPG(1:5) .NE. 'I2/n ') THEN WRITE (LU20, 99934) '_128', 1, 1, 1 SPGRNM(2)(1:7), ZSPG ENDIF ENDIF WRITE (PRBUF, 99945) ZSPG, SPGRNM(2)(1:7) WRITE (LU6, 99961) PRBUF(1:80) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.8 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99961) PRBUF(1:80) ENDIF ENDIF ENDIF DO 1150 J = 1, JMAX IF (J .EQ. 2) THEN LU = LU7 ELSE LU = LU6 ENDIF IF (IMETRIC .GT. 0) THEN IF (J .EQ. 2) CALL PLA269 (2) WRITE (LU, 99978) ENDIF IF (IPR(209) .EQ. 0) THEN IF (IPR(118) .EQ. 0 .AND. IPR(459) .EQ. 0 1 .AND. NSGTR .EQ. 0) THEN IF (J .EQ. 1) THEN CALL PLA015 (0, 5) ELSE IF (J .EQ. 2) THEN CALL PLA269 (3) WRITE (LU, 99985) IF (IPR(207) .NE. 0) THEN CALL PLA269 (1) WRITE(LU, 99924) ENDIF ENDIF ELSE WRITE (PRBUF, 99977) IF (J .EQ. 1) THEN IF (IWIN .EQ. 1) THEN VRT = VRT - 1.0 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT) ENDIF ENDIF IF (J .EQ. 2) CALL PLA269 (1) WRITE (LU, 99932) PRBUF IF (IPR(118) .NE. 0) THEN CALL PLA269 (1) WRITE (LU, 99976) ENDIF ENDIF ELSE IF (J .EQ. 2) CALL PLA269 (12) WRITE (LU, 99965) ORG(1), ORG(2), ORG(3), 1 ((DUMMY(III, JJJ), JJJ = 1,3), -ORG(III), III = 1, 3) IF (IGBL(45) .GT. 0) IGBL(45) = - 1 NNNFIT = MIN (NNNFIT, NFT) WRITE (LU, 99986) IF (SPGRNM(1)(1:11) .NE. SPGRNM(2)(1:11) .OR. 1 XSUB .EQ. 'S') THEN IF (SPGRNM(2)(1:11) .NE. '?' .OR. NNNFIT .EQ. 100) THEN IF (J .EQ. 2) CALL PLA269 (3) WRITE (LU, 99957) JID(1:27), SPGRNM(1)(12:13), 1 IBVL(LAT0), LATT, PAR(142), NCHIR, NCHIRF, DDIS, 2 DANG, PAR(291), XSUB, NNNFIT, SPGRNM(2)(1:11), 3 CHAR(IPR(223)) ENDIF IF (SPGRNM(2)(1:11) .NE. '?') WRITE (LU20, 99934) '_113', 1 NNNFIT, NNNFIT, SPGRNM(2)(1:10) ENDIF IF (J .EQ. 1) THEN IF (IWIN .EQ. 1) THEN IF (ABS(ORG(1)) + ABS(ORG(2)) + ABS(ORG(3)) .GT. 0.001) 1 THEN WRITE (PRBUF, 99944) ORG(1), ORG(2), ORG(3) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT) ENDIF IF (SPGRNM(2)(1:11) .NE. '?') THEN VRT = VRT - 0.5 IF (NNNFIT .EQ. 100) THEN WRITE (PRBUF, 99946) SPGRNM(2)(1:11), ISGNR CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT) ELSE WRITE (PRBUF, 99942) SPGRNM(2)(1:11), ISGNR CALL GGIP20 (0.0, PRBUF, 80, 0.35, 6, 2, 1.0, VRT) WRITE (PRBUF, 99941) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 6, 2, 1.0, VRT) ENDIF ENDIF ENDIF CALL PLA015 (0, 6) ENDIF IF (ISYST .GT. IPR(259)) THEN IF (J .EQ. 2) CALL PLA269 (1) WRITE (LU, 99982) PAR(291) ELSE IF (IPR(259) .NE. 8) THEN IF (MLAUE .NE. IPR(258)) THEN IF (J .EQ. 2) CALL PLA269 (1) WRITE (LU, 99981) DSMAX ENDIF ENDIF IF (INVST .EQ. 1) THEN IPR(457) = 1 PAR(291) = MAX (PAR(291), 2.0 * MAX (0.25, DSMAX)) IF (DSMAX .GT. 0.0) THEN IF (J .EQ. 2) CALL PLA269 (1) WRITE (LU, 99980) DSMAX ENDIF ENDIF ENDIF 1150 CONTINUE 1155 IF (SPGRNM(1)(1:1) .NE. ' ') THEN IF (INDEX (SPGRNM(1)(1:11), ':') .NE. 0) THEN WRITE (ICL, '(''SPGR '', A, 64X)') SPGRNM(1)(1:11) ELSE WRITE (ICL, 99938) 1 SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11) IF (SPGRNM(1)(13:13) .NE. ' ') ICL(13:13) = '.' ENDIF CALL SGSM (ICL, NRXX, XJX, LU6, 0, IERR) ELSE REWIND LU61 WRITE (ICL, 99937) CALL SGSM (ICL, NRXX, XJX, 0, 0, IERR) DO 1156 I = 1, NSYMT READ (LU61, 99923, END = 1157) ICL IF (ICL(1:3) .EQ. 'END') GOTO 1157 CALL SGSM (ICL, NRXX, XJX, 0, 0, IERR) 1156 CONTINUE 1157 CONTINUE ENDIF IF (LOOPR .LT. 3 .AND. JERR .EQ. 1) THEN IPR(220) = IPR(220) + 1 IFL(IPR(220)) = 'EXACT' IF (LU .EQ. 0) LU = LU6 WRITE (LU, 99928) GOTO 10 ENDIF IF ((ISAVEMOD .EQ. 0 .OR. IGBL(65) .EQ. 1) .AND. 1 (IPR(209) .GT. 0 .OR. IPR(504) .GT. 0)) THEN IF (SPGRNM(2)(1:1) .EQ. '?') THEN SPGRNM(2) = SPGRNM(1) CALL GEN074 (ORG, 0.0, 1, 3) WRITE (LU6, 99956) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99956) ENDIF ENDIF CALL PLA280 ('CALC GEOM EUCLID') JID(34:40) = SPGRNM(2)(1:7) ENDIF IGBL(67) = 0 ENDIF 1160 IF (IWIN .EQ. 1) CALL PLA013 (0, 1) IF (IGGT(1:4) .EQ. 'PLOT') THEN CALL PLA280 ('CALC ADDSYM') ELSE IF (IGGT(1:1) .EQ. '!') THEN CALL PLA280 ('CALC ADDSYM') ELSE IF (IGGT(1:3) .EQ. 'END') THEN CALL PLA280 ('!') ENDIF IF (LOOPR .GT. 0) THEN IF (IPR(121) .GT. 0) IPR(220) = 1 ENDIF IGBL(23) = 10 CLOSE (LU61, STATUS = 'DELETE') RETURN 99999 FORMAT ('ADDSYM - CHECK (cf. MISSYM (C): Le Page, Y.,', 1 ' J. Appl. Cryst. (1987), 20, 264-269; J. Appl.', 2 ' Cryst. (1988), 21, 983-984)', /, 132('-')) 99998 FORMAT ('Cell Lattice', 2X, 'a', 7X, 'b', 7X, 'c', 4X, 1 'Alpha', 3X, 'Beta', 2X, 'Gamma Volume', 1X, 2 'CrystalSystem Laue') 99997 FORMAT ('- Number of Input Atoms Included in Search', I5, 1 ' (Unitcell', I5, ')') 99996 FORMAT (14X, '[', 3I2, ']', F6.2, 2I3, F6.2, 14X, ' Metric') 99995 FORMAT (2A, ' [', 3I2, '] [', 3I2, ']', F6.2, 2I3, F6.2, 1 I5, F8.3, ' through', 3F6.3) 99994 FORMAT ('ADDSYM Search on Chemical Type ', A, 'ONLY', 1 ' [Max NonFit',I3, ' Perc]') 99993 FORMAT ('ADDSYM Search on ALL NON-H Chemical Types', 1 ' [Max NonFit',I3, ' Perc]') 99992 FORMAT ('ADDSYM Search on ALL NON-H Chem. Types (Treated EQUAL)', 1 ' [Max NonFit',I3, ' Perc]') 99991 FORMAT (2X, A, 40X, 3A, 4F6.3) 99990 FORMAT ('- ', A) 99989 FORMAT ('The Structure Implies the Following Symmetry ', 1 'Elements Subject to the Criteria:') 99988 FORMAT (A, ' * ', I6, '/24 (NonSpacegroup) Translation', 1 I3, F8.3, 9X, 3F6.3) 99987 FORMAT ('-1', A, 1X, 35('='), 2X, I3, F8.3, 2X, 'at', 5X, 1 3F6.3, 1X) 99986 FORMAT (/, ':: * Symmetry Elements Preceded by an Asterisk ', 1 'are New and Indicate', /, 2 ':: Missed/Pseudosymmetry. Proposed Inversion or', 3 ' (Glide) Planes do NOT Apply', /, 4 ':: for Chiral Molecules.', /, 5 ':: Note: Glide Plane Codes are with Reference ', 6 'to the Input Cell !!') 99985 FORMAT (/, ':: *** No Obvious Extra Crystallographic Symmetry', 1 ' was Detected ***', /) 99984 FORMAT (/, ':: SpaceGroup = ', A, 1 ' - No Obvious Spacegroup Change Needed/Suggested', //, 2 ':: An Alternative Analysis for Missed Symmetry may ', 3 'be tried with ''CALC NEWSYM''.', /) 99983 FORMAT ('- The ADDSYM Search may be rerun for a choosen atom', 1 ' type', / 1 '- Use LIST RADII for an overview of the atom types', /) 99982 FORMAT (':: Change of Crystal System indicated.', 1 ' (Maxdev. = ', F6.3, ' Ang.)') 99981 FORMAT (':: Change of Laue Class without change of System', 1 ' indicated (Maxdev = ', F6.3, ' Ang)') 99980 FORMAT (':: Addition of an Inversion Center Indicated.', 1 ' (Maxdev. = ', F6.3, ' Ang.)') 99979 FORMAT (1X) 99978 FORMAT (/, ':: Lattice Features Metrical Symmetry not ', 1 'Supported by Contents.') 99977 FORMAT (':: Check for (Approximate/Pseudo) ', 1 'Inversion/Transl. Symmetry.') 99976 FORMAT (' See e.g. R.E. Marsh, Acta Cryst. (1994). C50,', 1 ' 1713-1715', /) 99975 FORMAT (/, '- Number of Excluded Disordered Input Atoms = ', I5) 99974 FORMAT (/, 9X, 'T.R.A.N.S.F.O.R.M.A.T.I.O.N M.A.T.R.I.X', 1 ' for CELL and HKL DATA', /, 9X, 62('='), 2 /, 3X, 'Reduced->Convent', 9X, 'Input->Reduced', 7X, 3 'T = Input->Convent: a'' = T a', /, 80('-')) 99973 FORMAT ('(', 3F6.2, ' ) (', 3F6.2, ' ) (', 3F6.2, ' )', 1 5X, 'Det(T)') 99972 FORMAT ('(', 3F6.2, ' ) X (', 3F6.2, ' ) = (', 3F6.2, ' )', 1 7X, '=') 99971 FORMAT ('(', 3F6.2, ' ) (', 3F6.2, ' ) (', 3F6.2, ' )', 1 F10.3) 99970 FORMAT (43X, 2A) 99969 FORMAT (':: Over', I7, 'atoms in the Primitive Cell', 1 ' (ADDSYM request aborted!)') 99968 FORMAT (':: No Fully Occ. Atoms found in list ...', 1 ' ADDSYM request aborted!') 99967 FORMAT (/, ':: Axial Lengths differ by', F6.3, ' Ang.') 99966 FORMAT (/, ':: Cell Angles differ', F5.2, ' Deg. from (90/120)') 99965 FORMAT (/, ':: Origin Shifted to:', F7.4, ',', F7.4, ',', F7.4, 1 ' after Transformation', //, 2 ':: (', 3F8.4, ') (', F8.4, ')', /, 2 ':: R/t for Coordinates (', 3F8.4, ') (', F8.4, ')', /, 2 ':: (', 3F8.4, ') (', F8.4, ')', /) 99964 FORMAT (/, ':: NonFits (i.e. Atoms with no symmetry related', 1 ' counterpart):') 99963 FORMAT (/, 10X, 'Conventional, New or Pseudo Symmetry', /, 1 80('='), /) 99962 FORMAT (/, ':: Excluded Disorder Atoms From ADDSYM Analysis:') 99961 FORMAT (/, A, /) 99960 FORMAT (/, ':: Note: Atoms deleted from input !') 99959 FORMAT ('Forced RESTART of ADDSYM to Implement TRANSLATION for ', 1 A) 99958 FORMAT ('LATT ', A, 1X, A, 72X) 99957 FORMAT (/, 'P! ', A, 1X, A, '=>', 2A, F4.1, 2I3, F6.3, F5.2, 1 F6.3, 1X, A, I4, '% ', A, /, A, //, 2 ':: An SPF-style file is written', 2 ' to be used for the cell transformation.', /) 99956 FORMAT (/, ':: Higher (pseudo)symmetry not compatible,', 1 '(current symmetry retained)') 99955 FORMAT ('Criteria:', F6.2, ' Deg (Metric),', F5.2, ' Ang (Rot.),' 1 , F5.2, ' Ang (Inv),', F5.2, ' Ang (Transl)') 99954 FORMAT (A) 99953 FORMAT ('Symm. Input Reduced (Ang)', 8X, '(Deg)', 1X, 1 '(%)', 3X, '(Ang)', 16X, 'Input Cell') 99952 FORMAT ('Elem', 1X, 'Cell_Row', 1X, 'Cell_Row', 3X, 1 'd Typ Dot Angle Fit MaxDev.', 13X, 2 'x y z') 99951 FORMAT (80('-')) 99950 FORMAT (':: SpaceGroup = ', A, 1 ' - No Obvious Spacegroup Change Needed/Suggested') 99949 FORMAT ('Input ', A, F7.3, 2F8.3, 3F7.2, I7, 1X, A, 1X, A) 99948 FORMAT ('Reduced ',' P', F7.3, 2F8.3, 3F7.2, I7) 99947 FORMAT ('Convent ', 2A, F7.3, 2F8.3, 3F7.2, I7, 1X, A, 1X, A) 99946 FORMAT ('Missed/Additional Symmetry : Suggested SPGR = ', A, 1 '(No', I4,')') 99945 FORMAT (':: Alternative Setting ', A, ' of Standard Setting ', A) 99944 FORMAT ('Origin shifted to:', F6.3, ',', F6.3, ',', F6.3, 1 ' after transformation') 99943 FORMAT (' Reduced-to-Convent', 7X, 'Input-to-Reduced', 5X, 3 'T = Input-to-Convent: a'' = T a') 99942 FORMAT ('Missed/Additional Symmetry (Ignore Nonfit):', 1 ' Suggested SPGR = ', A, '(No', I4,')') 99941 FORMAT (' *** PLEASE COMPARE with ''CALC ADDSYM EXACT'' ') 99940 FORMAT (25X, 'PLATON/ADDSYM for ', A) 99939 FORMAT ('SPGR ' , A, 68X) 99938 FORMAT ('SPGR ' , A, 63X) 99937 FORMAT ('LATT P A ', 72X) 99936 FORMAT ('Density based on Input Atom Set =', F6.3, 1 ' g.cm-3 - Vol / Non-H atom =', F5.1, ' Ang+3') 99935 FORMAT (A, 2I10, 5X, A) 99934 FORMAT (A, 2I10, 2A) 99932 FORMAT (A, /) 99931 FORMAT (':: ADDSYM Could Not (Re)Construct Proper Spacegroup') 99930 FORMAT (/, A) 99929 FORMAT (':: Spacegroup: ', A, ' Not Changed but Check ', 1 'Pseudo-Translations') 99928 FORMAT (/, 'Restart with EXACT', /) 99927 FORMAT (/, A, /) 99926 FORMAT (/, ':: ', A, /) 99925 FORMAT (3X, A) 99924 FORMAT (':: Note: Rerun in EQUAL Atom Type Mode for more Checks') 99923 FORMAT (A) 99922 FORMAT ('SYMM ', A) 99921 FORMAT ('END') END SUBROUTINE PLA024 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9,NCS=50) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /DSPGR/ TYPE, NLAUE CHARACTER TYPE(NCS)*16, NLAUE(13)*5 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER LSB*1, RSB*1, ND13*1, FORMA*136, FORMB*47, DISOR*1 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 XI = 0.0 YI = 0.0 ZI = 0.0 FORMA(1:26) = '(I4,1X, A ,F8.4,''('',I2,'')''' FORMA(27:42) = ',F9.4,''('',I2,'')''' FORMA(43:74) = FORMA(27:42)//FORMA(27:42) FORMA(75:106) = FORMA(43:74) FORMA(107:136) = FORMA(27:42)//',3F7.4,F7.2,A)' FORMB(1:27) = '(I4,1X, A ,F8.4,''('',I2,'')'',' FORMB(28:47) = '65X,F9.4,''('',I2,'')'')' DO 10 I = 1, IAN + 1 BOK(I, 1) = 0.0 BOK(I, 2) = 9999.0 BOK(I, 3) = 0.0 KBO(I, 1) = 0 10 CONTINUE PAGET = 'ADP-Anal' WAVELTH = PAR(17) IPR493 = IPR(493) IF (IPR493 .EQ. 0) THEN WAVELTH = 0.71073 IPR493 = 2 WRITE (LU6, 99958) ENDIF NAT = IPR(37) NATB = IPR(39) NRES = IPR(75) IF (IPR(67) .EQ. 0) THEN NATC = NAT ELSE NATC = NATB ENDIF IF (IGBL(31) .EQ. 0) THEN IGBL(31) = 3 CALL PLA021 ENDIF IF (IGBL(31) .LT. 0) IPR(109) = 1 IF (IGBL(31) .EQ. 7) THEN WRITE (LU2, 99963) JID(1:73), (PAR(100 + I), I = 1, 6), 1 SPGRNM(4), ((ROR(I, J), J = 1, 3), 0.0, I = 1, 3) ENDIF IF (IGBL(31) .NE. 0 .AND. IGBL(31) .NE. 2 .AND. 1 IGBL(31) .NE. 4 .AND. IGBL(31) .NE. 7) THEN WRITE (LU2, 99982) JID(1:74) IF (IGBL(31) .EQ. 3 .AND. 1 (IPR(209) .GT. 0 .OR. IPR(504) .GT. 0)) THEN WRITE (LU2, 99973) ((ROTM2(I, J), J = 1, 3), I = 1, 3), 1 (ORG(J), J = 1, 3) WRITE (LU2, 99960) MAX (0.3, PAR(291) + 0.01) ENDIF IF (IGBL(31) .EQ. -2) THEN CALL GEN066 (2, PAR(101), PAR(107), SPGRNM(1)(12:12)) ENDIF IF (IPR(23) .EQ. 0) THEN WRITE (LU2, 99974) WAVELTH, (PAR(100 + I), I = 1, 6) ENDIF IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN IF (IPR(23) .EQ. 0) THEN WRITE (LU2, 99979) (PAR(106 + I), I = 1, 6) ENDIF IF (PAR(2) .NE. 0.4) WRITE (LU2, 99951) PAR(2) ELSE IF (IGBL(31) .EQ. -2) THEN WRITE (LU2, 99971) (PAR(106 + I), I = 1, 6) ENDIF IF (IPR(438) .EQ. 1) WRITE (LU2, 99990) PAR(98), PAR(21) IF (IPR(256) .EQ. 0 .OR. IGBL(31) .LT. 0) THEN IF (IGBL(31) .LT. 0) THEN WRITE (LU2, 99975) IPR(242) ISW = 17 ELSE IF (IPR(23) .EQ. 0) THEN WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14) ENDIF ISW = 2 ENDIF IF (IPR(23) .EQ. 0) THEN DO 20 I = 2, IPR(255) CALL SGSM (ICL, I, XJX, 0, ISW, IERR) WRITE (LU2, 99977) ICL(1:60) 20 CONTINUE ENDIF ELSE IF (IGBL(31) .EQ. 3 .AND. IPR(67) .NE. 0) THEN WRITE (LU2, 99989) ELSE IF (SPGRNM(1)(1:3) .EQ. ' ' .AND. IPR(209) .EQ. 0 1 .AND. IPR(504) .EQ. 0) THEN IF (IPR(23) .EQ. 0) THEN WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14) ISW = 2 DO 30 I = 2, IPR(255) CALL SGSM (ICL, I, XJX, 0, ISW, IERR) WRITE (LU2, 99977) ICL(1:60) 30 CONTINUE ENDIF ELSE IF (SPGRNM(2)(1:1) .NE. '?' .AND. SPGRNM(2)(1:1) .NE. ' ' 1 .AND. IGBL(31) .EQ. 3) THEN J = 2 LSB = '[' RSB = ']' ELSE J = 1 LSB = ' ' RSB = ' ' ENDIF IF (INDEX(SPGRNM(J)(1:11), ':') .NE. 0) THEN WRITE (LU2, 99976) LSB, SPGRNM(J)(1:11),RSB ELSE IF (SPGRNM(J)(8:11) .EQ. ' ') THEN I = ICHAR(' ') ELSE I = ICHAR('.') ENDIF WRITE (LU2, 99976) 1 LSB, SPGRNM(J)(1:7), CHAR(I), SPGRNM(J)(8:11), RSB ENDIF ENDIF ENDIF ENDIF IF (IPR(504) .EQ. 2) THEN WRITE (LU2, 99994) (LMT(IENS(K), 1), K = 1, IAN) ENDIF IF ((IGBL(31) .EQ. 3 .OR. IGBL(3) .LT. 0) .AND. IPR(310) .GT. 0) 1 WRITE (LU2, 99998) IPR(310) - 273 ENDIF C * OUTPUT (LU2) SHELXL - SFAC, UNIT, FVAR IF (IGBL(31) .LT. 0) THEN NFVR = IPR(109) IF (IPR(595) .EQ. 0) THEN DO 40 K = 1, IAN L = IEN(IENS(K)) IF (IPR493 .LT. 5) THEN J = (L - 1) * 15 IF (IPR493 .LT. 4) THEN J0 = J + 15 - 2 * IPR493 FAC = SFAC(J0 + 1) FDC = SFAC(J0 + 2) RMU = AMR(L, IPR493) ELSE FAC = 0.0 FDC = 0.0 RMU = 0 ENDIF WRITE (LU2, 99981) LMT(IENS(K), 1), 1 (SFAC(J + I), I = 1, 9), FAC, FDC, RMU, REL(L), 2 SATWT(IENS(K)) ELSE WRITE (LU2, 99981) LMT(IENS(K), 1), 0.0, 0.0, 0.0, 0.0, 1 0.0, 0.0, 0.0, 0.0, RNSCL(L), 0.0, 0.0, 0.0, REL(L), 2 SATWT(IENS(K)) ENDIF 40 CONTINUE ELSE WRITE (LU2, 99941) (LMT(IENS(K), 1), K = 1, IAN) ENDIF WRITE (LU2, 99980) (NINT(CONT(IENS(L), 2)), L = 1, IAN) IF (IPR(310) .GT. 0) WRITE (LU2, 99998) IPR(310) - 273 WRITE (LU2, 99942) WRITE (LU2, 99999) PAR(74), (RP(L), L = 2, NFVR) ELSE IF (IGBL(31) .EQ. 3 .AND. IPR(209) .EQ. 0) THEN WRITE (LU2, 99970) ENDIF IF (IPR(32) .NE. 0 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (-2) WRITE (LU7, 99984) CHAR(ICHAR('#')) ENDIF CALL GEN074 (XPV, 0.0, 1, 4) DO 210 N = 1, NRES DO 60 I = 1, IAN + 1 BOK(I, 5) = 9999.0 BOK(I, 6) = 0.0 60 CONTINUE CALL GEN074 (DEV, 0.0, 1, 6) NDEV = 0 NADD = 0 IF (RCONT(N) .LT. IPR(487) .AND. NRES .GT. 1) NADD = 1 IF (IPR(32) .NE. 0) THEN NLN = 5 IF (NRES .GT. 1) NLN = NLN + 5 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (NLN) IF (NRES .NE. 1) WRITE (LU7, 99993) N WRITE (LU7, 99991) ENDIF ENDIF IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) WRITE (LU2, 99992) N NRAT = 0 DO 180 I = 1, NATB CALL GEN048 (-6, IFG(I), 9, IRESI) IF (N .EQ. IRESI) THEN CALL GEN048 (-1, IFG(I), 7, NHAT) IF (IGBL(31) .LT. 0) THEN IF (NHAT .EQ. 0) THEN XI = VOID((I - 1) * (NP4 + 15) + 4) YI = VOID((I - 1) * (NP4 + 15) + 5) ZI = VOID((I - 1) * (NP4 + 15) + 6) ELSE GOTO 180 ENDIF ENDIF CALL GEN048 (-4, IFG(I), 15, NIEN) NIEN = NIEN + 1 IF (IGBL(31) .EQ. 3 .AND. IPR(501) .EQ. 0) THEN IALIAS = 1 ELSE IALIAS = IGBL(55) ENDIF CALL PLA036 (-I, 1, 1, IDISD, IDUM1, IDUM2, 0, IALIAS) CALL PLA036 (-I, 1, 2, IDISD, IDUM1, IDUM2, 0, IGBL(55)) IF (NHAT .EQ. 0) THEN XPV(1 + NADD) = XPV(1 + NADD) + 1 IF (IDISD .LT. 1000) 1 XPV(3 + NADD) = XPV(3 + NADD) + IDISD / 1000.0 ENDIF CALL GEN048 (-1, IFG(I), 4, IVAL) IF (IVAL .GT. 0) THEN JM = 6 ELSE JM = 1 CALL GEN048 (-1, IFG(I), 7, IHA) IF (IHA .EQ. 0 .AND. I .LE. NAT .AND. IDISD .GT. 500) 1 IPR(489 + NADD) = IPR(489 + NADD) + 1 ENDIF DO 70 J = 1, JM CALL GEN041 (XXO(I, J), XSD(I, J), ISDV(J), 5, NDEC, 1 IPR(68)) ISDV(J) = MIN (99, ISDV(J)) IF (ISDV(J) .LE. 0) XSD(I, J) = -1.0 IF (JM .EQ. 1) THEN FORMB(15:15) = CHAR(ICHAR('0') + NDEC) FORMB(35:35) = CHAR(ICHAR('0') + NDEC) ELSE IFT = -1 + J * 16 FORMA(IFT:IFT) = CHAR(ICHAR('0') + NDEC) ENDIF 70 CONTINUE DO 80 K = 1, 4 CALL GEN041 (CON(I, K), CON(I, K + 4), IDUM, IPR(183), 1 NDEC, IPR(68)) IF (1.1 * CON(I, K + 4) .LT. 1.0 / 10 ** IPR(183)) 1 CON(I, K + 4) = -1.0 80 CONTINUE IF (IGBL(31) .EQ. 7) THEN IPDB = 1 ELSE IPDB = 0 ENDIF CALL PLA047 (XLAB(I), NQ2, IDUM, JDUM, 0, IGBL(55), IPDB, 0) IF (IGBL(31) .EQ. 7) THEN DO 90 K = 1, 3 V1(K) = CON(I, K) 90 CONTINUE CALL GEN002 (1, OR, V1, V3, XLNG) IF (NQ2(1:1) .EQ. CHAR(32)) THEN NB = 2 NE = 5 ELSE NB = 1 NE = 4 ENDIF WRITE (LU2, 99962) I, NQ2(NB:NE), 0, (V3(K), K = 1, 3), 1 1.0, 0.0, NQ2(1:2) ENDIF IF (I .LE. NATC) THEN IF (IGBL(31) .LT. 0) THEN DO 100 L = 1, IAN IF (IENS(L) .EQ. NIEN) THEN ISCFT = L GOTO 110 ENDIF 100 CONTINUE 110 POPL = 10.0 + CON(I, 4) IF (CON(I, 4) .LT. 0.99) THEN DO 111 K = 1, 3 XJX(K) = CON(I, K) 111 CONTINUE XJX(10) = 0.05 CALL SGSM (ICL, 0, XJX, LU6, 19, IERR) DO 112 K = 1, 3 CON(I, K) = XJX(6 + K) 112 CONTINUE ENDIF ELSE IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN DISOR = NAMS(1, 1)(1:1) IF (DISOR .NE. ' ') DISOR = 'X' IF (IPR(23) .EQ. 0) THEN WRITE (LU2, 99987) 1 NAMS(1, 1)(2:7), (CON(I, K), K = 1, 8) ELSE WRITE (LU2, 99955) 1 NAMS(1, 1)(2:7), DISOR, (CON(I, K), K = 1, 8) ENDIF ENDIF ENDIF IF (JM .GT. 1) THEN DO 120 K = 1, 6 DUMA(K) = XXO(I, K) 120 CONTINUE IF (I .LE. NAT) THEN DO 125 K = 1, 6 DEV(K) = DEV(K) + DUMA(K) 125 CONTINUE NDEV = NDEV + 1 ENDIF CALL GEN025 (UIJ, DUMA, -1) CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, DUMV, UEQ) NRESD = 0 SUEQ = 0.0 DO 130 J = 1, 3 IF (XSD(I, J) .GT. 0.0) THEN NRESD = NRESD + 1 SUEQ = SUEQ + XSD(I, J) ** 2 ENDIF 130 CONTINUE IF (NRESD .GT. 0) SUEQ = SQRT(SUEQ) / NRESD CALL GEN041 (UEQ, SUEQ, ISUEQ, 5, NDEC, IPR(68)) ISUEQ = MIN (99, ISUEQ) FORMA(111:111) = CHAR(ICHAR('0') + NDEC) IF (ISUEQ .LE. 0) SUEQ = -1 IF (DUMA(1) .LT. PAR(12)) THEN D13 = -1.0 NQ3 = 'N.P.D. ' ELSE D13 = DUMA(3) / DUMA(1) D21 = DUMA(2) - DUMA(1) D32 = DUMA(3) - DUMA(2) IF (D32 .LT. D21) THEN NQ3 = 'oblate ' ELSE NQ3 = 'prolate' ENDIF ENDIF DATC(I) = UEQ IF (I .LE. NAT) THEN IF (NHAT .EQ. 0) THEN BOK(1, 1) = BOK(1, 1) + UEQ BOK(1, 2) = MIN (BOK(1, 2), UEQ) BOK(1, 3) = MAX (BOK(1, 3), UEQ) KBO(1, 1) = KBO(1, 1) + 1 ENDIF BOK(NIEN + 1, 1) = BOK(NIEN + 1, 1) + UEQ BOK(NIEN + 1, 2) = MIN (BOK(NIEN + 1, 2), UEQ) BOK(NIEN + 1, 3) = MAX (BOK(NIEN + 1, 3), UEQ) KBO(NIEN + 1, 1) = KBO(NIEN + 1, 1) + 1 BOK(NIEN + 1, 5) = MIN (BOK(NIEN + 1, 5), UEQ) BOK(NIEN + 1, 6) = MAX (BOK(NIEN + 1, 6), UEQ) IF (D13 .GT. 0.0) SQD13 = SQRT(D13) ND13 = ' ' IF (D13 .LE. 0.0 .OR. SQD13 .GT. 2.0) THEN IF (D13 .GT. 9.0 .OR. D13 .LT. 0.0) THEN WRITE (LU6, 99959) 1 NAMS(1, 1), (DUMA(J), J = 1, 3), D13, NQ3 ND13 = '#' IPR(135) = IPR(135) + 1 ENDIF IF (D13 .LT. 0) THEN NCOD = 211 + NADD IF (IGBL(22) .NE. -1) WRITE (LU20, 99946) 1 NCOD, 1.0, 1.0, NAMS(1, 1)(2:8) ELSE IF (NAMS(1, 1)(1:1) .EQ. '*') THEN NCOD = 215 + NADD IF (IGBL(22) .NE. -1) WRITE (LU20, 99946) 1 NCOD, SQD13, SQD13, NAMS(1, 1)(2:8) ELSE NCOD = 213 + NADD IF (IGBL(22) .NE. -1) WRITE (LU20, 99946) 1 NCOD, SQD13, SQD13, NAMS(1, 1)(2:8), NQ3 ENDIF ENDIF ENDIF IF (IPR(32) .NE. 0) THEN NRAT = NRAT + 1 IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMA) NRAT, NAMS(1, 2), 1 (XXO(I, J), ISDV(J), J = 1, 6), UEQ, ISUEQ, 2 (DUMA(J), J = 1, 3), D13, ND13 CALL PLA067 (LU7, PRBUF, 132, 1, 9) CALL GEN025 (UIJC, DUMA, 1) IF (IPR(347) .GT. 0) THEN CALL PLA269 (1) WRITE (LU7, 99972) (DUMA(J), J = 1, 6) ENDIF ENDIF ENDIF ENDIF IF (I .LE. NATC) THEN IF (IGBL(31) .LT. 0) THEN WRITE (LU2, 99997) NQ2(1:4), ISCFT, 1 (CON(I, K), K = 1, 3), CHAR(ICHAR('=')), 2 POPL, (XXO(I, K), K = 1, 6) ELSE IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN WRITE (LU2, 99986) NAMS(1, 1)(2:7), 1 (XXO(I, K), K = 1, 6), UEQ WRITE (LU2, 99985) NAMS(1, 1)(2:7), 1 (XSD(I, K), K = 1, 6), SUEQ ENDIF ENDIF ELSE IF (JM .EQ. 1) THEN DATC(I) = XXO(I, 1) IF (I .LE. NATC) THEN IF (IGBL(31) .LT. 0) THEN WRITE (LU2, 99996) NQ2(1:4), ISCFT, 1 (CON(I, K), K = 1, 3), POPL, XXO(I, 1) ELSE IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN WRITE (LU2, 99988) NAMS(1, 1)(2:7), 1 XXO(I, 1), XSD(I, 1) ENDIF ENDIF IF (IPR(32) .NE. 0 .AND. I .LE. NAT) THEN NRAT = NRAT + 1 IF (NHAT .EQ. 0) THEN BOK(1, 1) = BOK(1, 1) + XXO(I, 1) BOK(1, 2) = MIN (BOK(1, 2), XXO(I, 1)) BOK(1, 3) = MAX (BOK(1, 3), XXO(I, 1)) KBO(1, 1) = KBO(1, 1) + 1 ENDIF BOK(NIEN + 1, 1) = BOK(NIEN + 1, 1) + XXO(I, 1) BOK(NIEN + 1, 2) = MIN (BOK(NIEN + 1, 2), XXO(I, 1)) BOK(NIEN + 1, 3) = MAX (BOK(NIEN + 1, 3), XXO(I, 1)) KBO(NIEN + 1, 1) = KBO(NIEN + 1, 1) + 1 BOK(NIEN + 1, 5) = MIN (BOK(NIEN + 1, 5), XXO(I, 1)) BOK(NIEN + 1, 6) = MAX (BOK(NIEN + 1, 6), XXO(I, 1)) IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMB) NRAT, NAMS(1, 2), 1 XXO(I, 1), ISDV(1), XXO(I, 1), ISDV(1) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF ENDIF ENDIF IF (IGBL(31) .LT. 0) THEN ISCFT = 0 DO 135 J = 1, IAN IF (IEN(IENS(J)) .EQ. 1) ISCFT = J 135 CONTINUE NCH = 0 DO 145 NLP = 1, 2 IF (NLP .EQ. 2) THEN NM = 3 IF (NCH .EQ. 0) THEN GOTO 149 ELSE IF (IEN(NIEN) .EQ. 2) THEN CALL GEN048 (-4, IFG(I), 24, IHYB) IF (NCH .EQ. 1) THEN IF (IHYB .EQ. 1) THEN NM = 163 ELSE IF (IHYB .EQ. 2) THEN NM = 43 ELSE IF (IHYB .EQ. 3) THEN NM = 13 ENDIF ELSE IF (NCH .EQ. 2) THEN IF (IHYB .EQ. 2) THEN NM = 93 ELSE IF (IHYB .EQ. 3) THEN NM = 23 ENDIF ELSE IF (NCH .EQ. 3) THEN IF (IHYB .EQ. 3) THEN NM = 137 ENDIF ENDIF ENDIF WRITE (LU2, 99961) NM ENDIF DO 140 J = 1, NATC CALL GEN048 (-1, IFG(J), 7, JHAT) IF (JHAT .NE. 0) THEN XJ = VOID((J - 1) * (NP4 + 15) + 4) YJ = VOID((J - 1) * (NP4 + 15) + 5) ZJ = VOID((J - 1) * (NP4 + 15) + 6) DIST = SQRT ((XI - XJ)**2 + (YI - YJ)**2 1 + (ZI - ZJ)**2) IF (DIST .LT. 1.2) THEN IF (NLP .EQ. 1) THEN NCH = NCH + 1 ELSE YNK = -1.2 IF (NM .EQ. 137) YNK = -1.5 CALL PLA047 (XLAB(J), NQ3, IDUM, JDUM, 0, 1 IGBL(55), IPDB, 0) WRITE (LU2, 99953) NQ3(1:4), ISCFT, 1 (CON(J, K), K = 1, 3), 10.0 + CON(J, 4), YNK ENDIF ENDIF ENDIF 140 CONTINUE 145 CONTINUE WRITE (LU2, 99961) 0 ENDIF 149 IF (JM .GT. 1) THEN J = IPR(297) + (I - 1) * 21 DO 150 K = 1, 3 V8(K) = VOID(J + K + 6) 150 CONTINUE XDUM = SQRT (GEN009 (V8, V8)) DO 160 K = 1, 3 V8(K) = V8(K) * (VOID(J + 12) - MAX(VOID(J + 10), 0.0)) 1 / XDUM 160 CONTINUE CALL GEN002 (1, ROR, V8, V6, XLNG) J = (I - 1) * (NP4 + 15) DO 170 K = 1, 3 V5(K) = VOID(J + K) - V6(K) V8(K) = VOID(J + K) + V6(K) 170 CONTINUE IF (I .LE. NATC .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99952) (V5(K), K = 1, 3), (V8(K), K = 1, 3) ENDIF ENDIF ENDIF 180 CONTINUE IF (IPR(32) .NE. 0) THEN DO 190 I = 2, IAN + 1 IF (BOK(I, 5) .GT. 0.0) THEN BOK(I, 4) = MIN (9.9999, BOK(I, 6) / BOK(I, 5)) ELSE BOK(I, 4) = 0.0 ENDIF IF (BOK(I, 5) .GT. 1000.0) BOK(I, 5) = 0.0 190 CONTINUE DO 200 I = 1, IAN J = IENS(I) IF (BOK(J + 1, 4) .GT. 1.5) THEN IF (LMT(J, 1) .EQ. ' H' .OR. LMT(J, 1) .EQ. ' D') THEN K = 2 + NADD ELSE K = NADD ENDIF IF (IGBL(22) .NE. -1) WRITE (LU20, 99945) '_22', K, 1 BOK(J + 1, 4), BOK(J + 1, 4), LMT(J, 1) ENDIF 200 CONTINUE ENDIF IF (NDEV .GT. 0) THEN DO 205 I = 1, 6 DEV(I) = DEV(I) / NDEV 205 CONTINUE CALL GEN025 (UIJ, DEV, -1) CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, DUMV, UEQ) CALL PLA269 (3) RATIO = DUMA(3) / DUMA(1) IF (IGBL(63) .GT. 2) WRITE (LU7, 99948) (DEV(K), K = 1, 6), 1 UEQ, (DUMA(K), K = 1, 3), RATIO IF (NDEV .GT. 5 .AND. IGBL(22) .NE. -1) 1 WRITE (LU20, 99947) '_250', RATIO, RATIO ENDIF 210 CONTINUE IF (IPR(32) .NE. 0) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (15) WRITE (LU7, 99983) CALL PLA269 (6) WRITE (LU7, 99968) (LMT(IENS(I), 1), I = 1, IAN) WRITE (LU7, 99967) BOK(1, 1) / MAX (1, KBO(1, 1)), 1 (BOK(IENS(I) + 1, 1) / 2 MAX (1, KBO(IENS(I) + 1, 1)), I = 1, IAN) ENDIF DO 220 I = 1, IAN + 1 IF (BOK(I, 2) .GT. 0.0) THEN BOK(I, 1) = MIN (9.9999, BOK(I, 3) / BOK(I, 2)) ELSE BOK(I, 1) = 0.0 ENDIF IF (BOK(I, 2) .GT. 1000.0) BOK(I, 2) = 0.0 220 CONTINUE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99966) BOK(1, 2), (BOK(IENS(I) + 1, 2), 1 I = 1, IAN) WRITE (LU7, 99965) BOK(1, 3), (BOK(IENS(I) + 1, 3), 1 I = 1, IAN) WRITE (LU7, 99964) BOK(1, 1), (BOK(IENS(I) + 1, 1), 1 I = 1, IAN) WRITE (LU7, 99957) KBO(1, 1), (KBO(IENS(I) + 1, 1), 1 I = 1, IAN) ENDIF ENDIF IF (IGBL(31) .EQ. -2) THEN WRITE (LU2, 99969) (PAR(230 + I), I = 1, 9) IF (IPR(209) .GT. 0) THEN DO 230 I0 = 1, 12 IF (LAUEGR .EQ. NLAUE(I0)) GOTO 240 230 CONTINUE 240 WRITE (LU2, 99954) (PAR(230 + I), I = 1, 9), 1 SPGRNM(1)(12:13), I0, SPGRNM(1)(1:7) ENDIF ENDIF IF (IGBL(31) .LT. 0) WRITE (LU2, 99995) IF (IGBL(31) .EQ. 3 .AND. IPR(504) .NE. 2) THEN WRITE (LU2, 99969) (PAR(230 + I), I = 1, 9) IF (IGBL(97) .EQ. 0) THEN WRITE (LU2, 99944) ELSE WRITE (LU2, 99943) ENDIF ENDIF IF (IPR(43) .GT. 0 .AND. IGBL(22) .NE. -1) THEN IF (XPV(3) .GT. 0.0) 1 WRITE (LU20, 99949) '_301', XPV(3) * 100 / XPV(1), 2 XPV(3) * 100 / XPV(1) IF (XPV(4) .GT. 0.0) 1 WRITE (LU20, 99949) '_302', XPV(4) * 100 / XPV(2), 2 XPV(4) * 100 / XPV(2) ENDIF IF (IPR(504) .EQ. 2) THEN WRITE (LU2, 99969) (PAR(I), I = 231, 239) IF (IPR(595) .EQ. 0) THEN WRITE (LU2, 99956) IPR(209), ' ' ELSE WRITE (LU2, 99956) IPR(209), 'NOSF' ENDIF CLOSE (LU1) CLOSE (LU2, ERR = 250) 250 CALL PLA280 ('END') KXT = 3 EXTENS = 'eld' FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT) OPEN (UNIT = LU1, FILE = FNLU1, FORM = 'FORMATTED', 1 STATUS = 'OLD') IPR(3) = 1 IGBL(8) = 1 ENDIF IF (IABS(IGBL(8)) .NE. 4 .AND. IGBL(94) .EQ. 0) THEN IF (IPR(489) + IPR(490) .GT. 0) THEN IF (IPR(489) .GT. 0 .AND. IGBL(22) .NE. -1) 1 WRITE (LU20, 99950) '_201', IPR(489), IPR(489) IF (IPR(490) .GT. 0 .AND. IGBL(22) .NE. -1) 1 WRITE (LU20, 99950) '_202', IPR(490), IPR(490) ENDIF IF (IPR(32) .EQ. 0 .AND. IGBL(22) .NE. -1) 1 WRITE (LU20, 99950) '_210', 1, 1 ENDIF RETURN 99999 FORMAT ('FVAR ', 6F10.5, ' =', 8(/, 5X, 6F10.5, '=')) 99998 FORMAT ('TEMP ', I5) 99997 FORMAT (A, I3, 3F9.5, 1X, A, /, 5X, F10.5, 6F9.4) 99996 FORMAT (A, I3, 3F9.5, F10.5, F9.4) 99995 FORMAT ('END') 99994 FORMAT ('SCAT', 16(1X, A)) 99993 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue = ', I3, 1X, 1 61('*'), /, 57X, 13('=')/) 99992 FORMAT ('RESD ', I5) 99991 FORMAT (132('-'), /, 'Atom Label', 3X, 'U11 or Uiso', 6X, 'U22', 1 10X, 'U33', 10X, 'U23', 10X, 'U13', 10X, 'U12', 8X, 'Ueq(sUeq)', 2 5X, 'U1', 5X, 'U2', 5X, 'U3', 2X, 'U3/U1', /, 132('-')) 99990 FORMAT ('VOLU ', 2F10.3) 99989 FORMAT ('SPGR P1') 99988 FORMAT ('U ', A, 2F10.5) 99987 FORMAT ('ATOM ', A, 1X, 2(3F9.6, F7.4)) 99986 FORMAT ('UIJ ', A, 1X, 7F9.5) 99985 FORMAT ('SUIJ ', A, 1X, 7F9.5) 99984 FORMAT ('(An)isotropic, Equivalent and Main Axes Displacement ', 1 'Parameters - Unusual Values Marked with a ', A, 2 ' - [Optional Coordinate Split-up]', /, 132('-')) 99983 FORMAT (/, 49X, 21('='), /, 38X, 'The Displacement Factor has ', 1 'the Form of Exp(-T)'//54X, 'where'//29X, 'T = 8*(pi**2)*Uiso*', 2 'sin(theta/lambda)**2, for Isotropic Atoms,'//2X, 'T = 2*(pi', 3 '**2)*(U11*(h*as)**2+U22*(k*bs)**2+U33*(l*cs)**2+2*U23*k*l*', 4 'bs*cs+2*U13*h*l*as*cs+2*U12*h*k*as*bs),for Anisotr. Atoms'// 5 37X, ' Ueq = 1/3 Sum(i,j) (Uij*as(i)*as(j)*a(i).a(j))',//, 34X, 6 ' U1, U2, U3 are the three Main Axes Components of Uij', //, 7 'Reference U(eq): R.X. Fischer & E. Tillmanns, ', 8 'Acta Cryst. (1988). C44, 775-776') 99982 FORMAT ('TITL ', A) 99981 FORMAT ('SFAC ', A, 7F10.5, ' =', /, 7X, 4F10.5, F10.3, 2F10.5) 99980 FORMAT ('UNIT ', 2I5, 14I4) 99979 FORMAT ('CESD', 9X, 3F10.4, 3F10.3) 99978 FORMAT ('LATT ', A, 2X, A) 99977 FORMAT ('SYMM ', A) 99976 FORMAT ('SPGR ', 5A) 99975 FORMAT ('LATT', I4) 99974 FORMAT ('CELL', F9.5, 3F10.4, 3F10.3) 99973 FORMAT ('TRNS ', 9F8.4, ' = ', /, 5X, 3F8.4) 99972 FORMAT (13X, 6(F13.4)) 99971 FORMAT ('ZERR', ' 1', 7X, 3F10.4, 3F10.3) 99970 FORMAT ('NOMOVE') 99969 FORMAT ('HKLF 4 1', 9F8.4) 99968 FORMAT (/, 'Ueq [or U(iso)] Averages per Element', /, 1 132('-'), /, 10X, 'Non-H', 16(3X, A, 2X)) 99967 FORMAT (132('-'), /, 'Average', 1X, 17F7.4) 99966 FORMAT ('Minimum', 1X, 17F7.4) 99965 FORMAT ('Maximum', 1X, 17F7.4) 99964 FORMAT ('Ratio ', 1X, 17F7.4) 99963 FORMAT ('HEADER', 1X, A, /, 'CRYST1', 3F9.3, 3F7.2, 1X, A, /, 1 'SCALE1', 4X, 3F10.7, 5X, F10.7, /, 2 'SCALE2', 4X, 3F10.7, 5X, F10.7, /, 3 'SCALE3', 4X, 3F10.7, 5X, F10.7) 99962 FORMAT ('ATOM', 2X, I5, 1X, A, 5X, I5, 4X, 3F8.3, 2F6.2, 10X, A) 99961 FORMAT ('AFIX', I5) 99960 FORMAT ('REM RESET CLOSENESS CRITERIUM', /, 1 'SET PAR 22', F10.3) 99959 FORMAT (':: ADP ', A, 3F8.3, ' - RATIO(MAX/MIN) = ', F8.1, 1X, A) 99958 FORMAT ('W: No Wavelength given, MoKa - assumed for SFAC') 99957 FORMAT ('Number', 2X, 17I7) 99956 FORMAT ('SET IPR 209', I3, /, 'CALC SHELX ', A, /, 'END') 99955 FORMAT ('ATOM ', A, 1X, A, 1X, 3F9.4, F6.3, 3F9.4, F6.2) 99954 FORMAT ('REM TRMX', 9F7.3, 1X, A, I3, /, 'REM SPGR ', A) 99953 FORMAT (A, I3, 5F9.5, F9.3) 99952 FORMAT (15X, '[', F9.4, 2F13.4, '] [', F9.4, 2F13.4,']') 99951 FORMAT ('SET PAR 2', F6.2) 99950 FORMAT (A, 2I10) 99949 FORMAT (A, 2F10.0) 99948 FORMAT (/, 'U(i,j)-Average', F11.4, 5F13.4, 6X, 4F7.4, F7.2, /) 99947 FORMAT (A, 2F10.2) 99946 FORMAT ('_', I3, 2F10.1, 2A) 99945 FORMAT (A, I1, 2F10.3, A) 99944 FORMAT ('INORGANIC') 99943 FORMAT ('ORGANIC') 99942 FORMAT ('L.S. 5', /, 'ACTA', /, 'BOND $H') 99941 FORMAT ('SFAC', 16(1X, A)) END SUBROUTINE PLA025 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /PL16/ VALI(3), VI(3,3), VT(3,3), XOCG(3), XCG(3), D(3,3), 1 H(3,3), R(3,3), UC(3,3), UI(3,3), ROL(3), SL(3,3), SO(3,3), 2 TO(3,3), TW2(3,3), TT2(3,3), SOM(3,3), TOM(3,3), W3D(3), 3 TOM2(3,3), TTOM2(3,3), TOM3(3), TL(3,3), AO(20), AN(250), 4 BN(25), AMC(3,3), ALC(3,3), ATC(3,3), ALM(3,3), ATM(3,3), 5 W1(3,3), W2(3,3), W3(3), S1(3,3), T1(3,3), T2(3,3), T3(3) CHARACTER ITLS*1 IF (IPR(32) .NE. 0 .AND. IPR(5) .NE. 0) THEN NMAX = IPR(39) NRES = IPR(75) NSYM = IPR(48) IPR72 = IPR(72) IPR(72) = 0 DO 20 I = 1, NMAX DO 10 J = 1, 3 CALL GEN018 (CON(I, J), XXO(I, J)) CON(I, J + 3) = XXO(I, J + 3) 10 CONTINUE CALL GEN048 (-4, IFG(I), 15, IVL) CON(I, 7) = SATWT(IVL + 1) CON(I, 8) = (XSD(I, 1) + XSD(I, 2) + XSD(I, 3)) / 3 IO = I CALL PLA059 (IO, IO) 20 CONTINUE IPR(72) = IPR72 DO 260 NRS = 1, NRES NATR = 0 IPR(73) = 1 IPR(74) = 1 ITLS = 'S' MULT = MLTI(NRS) DO 40 I = 1, NMAX IVL = NP1 + I CALL GEN048 (-6, IFG(I), 9, IVAL) IF (IVAL .EQ. NRS) THEN CALL GEN048 (-1, IFG(I), 4, IVAL) IF (IVAL .NE. 0) THEN IF (IPR(497) .NE. 0) THEN IVAL = 0 ELSE CALL GEN048 (-1, IFG(I), 7, IVAL) ENDIF IF (IVAL .EQ. 0) THEN IVL = I NATR = NATR + 1 CALL PLA047 (XLAB(I), NQ1, IVAL, JDUM, IPR(119), 1 IGBL(55), 0, 0) IF (IVAL .NE. 1) THEN IPR(73) = 2 IPR(74) = 0 ITLS = ' ' ENDIF ENDIF ENDIF ENDIF IATP(I) = IVL 40 CONTINUE IF (IPR(32) .NE. 0) THEN IF (NATR .LT. IPR(21)) THEN WRITE (LU6, 99992) NRS, IPR(21) ELSE IF ((NSYM / MULT) * MULT .EQ. NSYM) THEN CALL PLA054 (1) DO 50 I = 1, 3 VALI(I) = DUMA(I) XOCG(I) = DXI(I) VI(I, 3) = DUMV(I, 1) VI(I, 1) = DUMV(I, 3) VI(I, 2) = -DUMV(I, 2) VT(3, I) = DUMV(I, 1) VT(1, I) = DUMV(I, 3) VT(2, I) = -DUMV(I, 2) 50 CONTINUE DO 80 K = 1, NMAX IF (IATP(K) .LE. NP1) THEN DO 70 I = 1, 3 XXO(K, I) = 0.0 DO 60 J = 1, 3 XXO(K, I) = XXO(K, I) + (XXO(K, J + 3) 1 - XOCG(J)) * VI(J, I) 60 CONTINUE 70 CONTINUE ENDIF 80 CONTINUE DO 100 I = 1, 3 DO 90 J = 1, 3 IF (I .EQ. J) THEN D(I, I) = PAR(112 + I) ELSE D(I, J) = 0.0 ENDIF 90 CONTINUE 100 CONTINUE CALL GEN004 (VT, OR, H) CALL GEN004 (H, D, H) DO 120 N = 1, NMAX IF (IATP(N) .LE. NP1) THEN DO 110 I = 1, 6 DUMA(I) = CON(N, I) 110 CONTINUE CALL GEN025 (UC, DUMA, -1) CALL GEN001 (1, H, UC, UI) XSD(N, 1) = UI(1, 1) XSD(N, 2) = UI(1, 2) XSD(N, 3) = UI(1, 3) XSD(N, 4) = UI(2, 2) XSD(N, 5) = UI(2, 3) XSD(N, 6) = UI(3, 3) ENDIF 120 CONTINUE CALL GEN074 (BN, 0.0, 1, 20) CALL GEN074 (AN, 0.0, 1, 250) NN = 12 + IPR(74) * 8 DO 210 I = 1, NMAX IF (IATP(I) .LE. NP1) THEN DO 180 JLOOP = 1, 6 J = JLOOP CALL GEN100 (AO, J, XXO(I, 1), XXO(I, 2), XXO(I, 3)) M = NN + 1 DO 200 N = 1, NN Y = AO(N) L = M M = M + NN - N + 1 BN(N) = BN(N) + Y * XSD(I, J) AN(N) = AN(N) + Y**2 DO 190 K = N, NN AN(L) = AN(L) + Y * AO(K) L = L + 1 190 CONTINUE 200 CONTINUE 180 CONTINUE ENDIF 210 CONTINUE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-2) WRITE (LU7, 99999) IF (NRES .NE. 1) THEN CALL PLA269 (5) WRITE (LU7, 99997) NRS ENDIF ENDIF CALL GEN012 (AN, BN, NN, 0.0, PAR(410), 1.0) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99996) ENDIF NNA = 0 SUM = 0.0 SUM1 = 0.0 SUMN = 0.0 SUMN1 = 0.0 DELM = 0 DO 240 I = 1, NMAX IF (IATP(I) .LE. NP1) THEN DO 220 JLOOP = 1, 6 J = JLOOP DUMA(J) = - XSD(I, J) SUMN = SUMN + DUMA(J)**2 SUMN1 = SUMN1 + ABS(DUMA(J)) CALL GEN100 (AO, J, XXO(I, 1), XXO(I, 2), XXO(I, 3)) DO 230 K = 1, NN DUMA(J) = DUMA(J) + AO(K) * AN(K) 230 CONTINUE SUM = SUM + DUMA(J)**2 SUM1 = SUM1 + ABS(DUMA(J)) IF (ABS(DUMA(J)) .GT. DELM) DELM = ABS(DUMA(J)) 220 CONTINUE NNA = NNA + 6 IF (IGBL(63) .GT. 2) THEN CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) CALL PLA269 (1) UEQO = (XSD(I, 1) + XSD(I, 4) + XSD(I, 6)) / 3.0 UEQC = UEQO + (DUMA(1) + DUMA(4) + DUMA(6)) / 3.0 WRITE (LU7, 99995) 1 NQ1, (XSD(I, K), DUMA(K), K = 1, 6), UEQO, UEQC ENDIF ENDIF 240 CONTINUE SIG = SQRT(SUM / (NNA - IPR(73) * NN)) RIND1 = SUM1 / SUMN1 RIND = SQRT(SUM / SUMN) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (17) WRITE (LU7, 99994) RIND1, RIND, SIG, NATR, IPR(73), 1 NN, DELM, ITLS ENDIF DO 250 I = 1, NN BN(I) = BN(I) * SIG 250 CONTINUE CALL PLA043 (0, 1, LU7, 0) IF (RIND .GT. PAR(34)) THEN WRITE (LU6, 99993) NRS, PAR(34) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99993) NRS, PAR(34) ENDIF CALL PLA027 (0, W1, W2) ELSE CALL PLA026 CALL PLA027 (1, W1, W2) ENDIF ENDIF ENDIF 260 CONTINUE ENDIF RETURN 99999 FORMAT ('V.Schomaker and K.N.Trueblood Rigid Body Motion', 1 ' Analysis, TLS - Model (Acta Cryst. (1968), B24, 63-76)', 2 ' - see also Dunitz, p244', /, 132('=')) 99997 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X, 1 61('*'), /, 57X, 13('='), /) 99996 FORMAT ('Vibration Tensor in Inertial System I(1)=L,I(2)=M', 1 ', I(3)=N (Difference U(calc)-U(obs) in Parentheses)', /, 2 132('='), /, 'Label U(L,L)', 12X, 'U(L,M)', 12X, 'U(L,N)', 3 12X, 'U(M,M)', 12X, 'U(M,N)', 12X, 'U(N,N)', 9X, 4 'Ueq(obs) Ueq(cal)', /, 132('-')) 99995 FORMAT (A, 6(F9.5, '(', F7.5, ')'), F8.4, F9.4) 99994 FORMAT (// 1 'R1 = Sum(abs(U(obs)-U(calc)))/Sum(abs(U(obs))) =', F10.5,// 2 'R2 = Sqrt(Sum((U(obs)-U(calc))**2)/Sum(U(obs)**2)) =', F10.5,// 3 'S = Sqrt(Sum((U(obs)-U(calc))**2)/(6*N-NS*M)) =', F10.5,// 4 'N = Number of Atoms in Rigid Group', 16X, '=', I10 ,// 5 'NS = Symmetry Factor', 31X, '=', I10, //, 'M = Number of ', 6 'Rigid-Body Parameters', 15X, '=', I10, //, 5X, 7 'Largest abs(U(obs)-U(calc))', 19X, '=', F10.5, //, 54X, 'TL', A, 8 '-Mode') 99993 FORMAT (/, ':: No TLS-Analysis for Residue Nr:', I3, 1 ', Because R >', F6.2) 99992 FORMAT (/, ':: No TLS-Analysis for Residue Nr:', I3, 1 ', Because Number non-H atoms <', I3) END SUBROUTINE PLA026 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /PL16/ VALI(3), VI(3,3), VT(3,3), XOCG(3), XCG(3), D(3,3), 1 H(3,3), R(3,3), UC(3,3), UI(3,3), ROL(3), SL(3,3), SO(3,3), 2 TO(3,3), TW2(3,3), TT2(3,3), SOM(3,3), TOM(3,3), W3D(3), 3 TOM2(3,3), TTOM2(3,3), TOM3(3), TL(3,3), AO(20), AN(250), 4 BN(25), AMC(3,3), ALC(3,3), ATC(3,3), ALM(3,3), ATM(3,3), 5 W1(3,3), W2(3,3), W3(3), S1(3,3), T1(3,3), T2(3,3), T3(3) K = 0 DO 20 I = 1, 3 DO 10 J = I, 3 K = K + 1 W1(I, J) = AN(K) W1(J, I) = AN(K) T1(I, J) = AN(K + 6) T1(J, I) = T1(I, J) S1(I, J) = 0.0 S1(J, I) = 0.0 10 CONTINUE 20 CONTINUE BN(21) = 0.0 IF (IPR(74) .NE. 0) THEN S1(1, 1) = AN(13) S1(1, 2) = AN(14) S1(1, 3) = AN(15) S1(2, 1) = AN(16) S1(2, 2) = AN(17) S1(2, 3) = AN(18) S1(3, 1) = AN(19) S1(3, 2) = AN(20) S1(3, 3) = -AN(13) - AN(17) BN(21) = SQRT(BN(13)**2 + BN(17)**2) ENDIF CALL GEN024 (W1, W2, W3, TW2) CALL GEN024 (T1, T2, T3, TT2) CALL GEN004 (VT, OR, AMC) CALL GEN004 (W2, VT, ALC) CALL GEN004 (ALC, OR, ALC) CALL GEN002 (1, ROR, XOCG, XCG, XLNG) CALL GEN001 (1, W2, S1, SL) CALL GEN001 (1, W2, T1, TL) ROL(1) = (SL(2, 3) - SL(3, 2)) / (W3(2) + W3(3)) ROL(2) = (SL(3, 1) - SL(1, 3)) / (W3(3) + W3(1)) ROL(3) = (SL(1, 2) - SL(2, 1)) / (W3(1) + W3(2)) R(1, 1) = 0.0 R(1, 2) = ROL(3) R(1, 3) = - ROL(2) R(2, 1) = - ROL(3) R(2, 2) = 0.0 R(2, 3) = ROL(1) R(3, 1) = ROL(2) R(3, 2) = - ROL(1) R(3, 3) = 0.0 DO 80 N = 1, 3 DO 70 I = 1, 3 SO(N, I) = R(I, N) * W3(N) + SL(N, I) 70 CONTINUE 80 CONTINUE DO 110 I = 1, 3 DO 100 L = 1, 3 TO(I, L) = 0.0 DO 90 J = 1, 3 TO(I, L) = TO(I, L) + R(I, J) * R(L, J) * W3(J) 1 + R(I, J) * SL(J, L) + R(L, J) * SL(J, I) 90 CONTINUE TO(I, L) = TO(I, L) + TL(I, L) 100 CONTINUE 110 CONTINUE CALL GEN001 (1, TW2, TO, TOM) CALL GEN001 (1, TW2, SO, SOM) CALL GEN024 (TOM, TOM2, TOM3, TTOM2) CALL GEN004 (TOM2, VT, ATC) CALL GEN004 (ATC, OR, ATC) DO 130 I = 1, 3 W3D(I) = W3(I) * GL(5)**2 DO 120 J = 1, 3 AMCIJ = AMC(I, J) / PAR(100 + J) IF (ABS(AMCIJ) .GT. 1.0) AMCIJ = SIGN(1.0, AMCIJ) AMC(I, J) = ACOS(AMCIJ) * GL(5) ALCIJ = ALC(I, J) / PAR(100 + J) IF (ABS(ALCIJ) .GT. 1.0) ALCIJ = SIGN(1.0, ALCIJ) ALC(I, J) = ACOS(ALCIJ) * GL(5) ATCIJ = ATC(I, J) / PAR(100 + J) IF (ABS(ATCIJ) .GT. 1.0) ATCIJ = SIGN(1.0, ATCIJ) ATC(I, J) = ACOS(ATCIJ) * GL(5) ALM(I, J) = ACOS(W2(I, J)) * GL(5) ATM(I, J) = ACOS(TOM2(I, J)) * GL(5) 120 CONTINUE 130 CONTINUE TRSO = T3(1) + T3(2) + T3(3) TRSN = TOM3(1) + TOM3(2) + TOM3(3) DO 140 I = 1, 21 IF (ABS(BN(I)) .GT. 0.99999) BN(I) = 0.999989 140 CONTINUE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (0) WRITE (LU7, 99999) (I, (VT(I, J), J = 1, 3), VALI(I), 1 (AMC(I, J), J = 1, 3), CHAR(ICHAR('W') + I), XCG(I), 2 I = 1, 3) WRITE (LU7, 99998) (W1(1, J), BN(J), J = 1, 3), 1 (W2(1, J), J = 1, 3), W3(1), W3D(1), (W1(2, J), 2 BN(J + 2), J = 2, 3), (W2(2, J), J = 1, 3), W3(2), W3D(2), 3 W1(3, 3), BN(6), (W2(3, J), J = 1, 3), W3(3), W3D(3) WRITE (LU7, 99997) T1(1, 1), BN(7), T1(1, 2), BN(8), T1(1, 3), 1 BN(9), (T2(1, J), J = 1, 3), T3(1), T1(2,2), BN(10), T1(2, 3), 2 BN(11), (T2(2, J), J = 1, 3), T3(2), T1(3, 3), BN(12), 3 (T2(3, J), J = 1, 3), T3(3) IF (IPR(74) .NE. 0) THEN WRITE (LU7, 99996) S1(1, 1), BN(13), S1(1, 2), BN(14), 1 S1(1, 3), BN(15), S1(2, 1), BN(18), S1(2, 2), BN(17), 2 S1(2, 3), BN(18), S1(3, 1), BN(19), S1(3, 2), BN(20), 3 S1(3, 3), BN(21) WRITE (LU7, 99995) TRSO, TRSN WRITE (LU7, 99994) (I, ROL(I), (SOM(I, J), J = 1, 3), 1 (TOM(I, J), J = 1, 3), I, (TOM2(I, J), J = 1, 3), 2 TOM3(I), I = 1, 3) ENDIF WRITE (LU7, 99993) WRITE (LU7, 99992) (I, (ALM(I, J), J = 1, 3), 1 (ALC(I, J), J = 1, 3), I = 1, 3) WRITE (LU7, 99991) WRITE (LU7, 99990) (I, (ATM(I, J), J = 1, 3), 1 (ATC(I, J), J = 1, 3), I = 1, 3) ENDIF RETURN 99999 FORMAT ('Inertial Tensor I, Eigenvectors and Eigenvalues ', 1 'of I in the Cartesian XO,YO,ZO System and Angular Relation', 2 ' with X,Y,Z System', /, 132('-'), /, 15X, 'XO', 8X, 'YO', 3 8X, 'ZO', 10X, 'Value', 14X, 'X', 9X, 'Y', 9X, 'Z', 5X, 'Origin', 4 ' (Mass-Weighted)', /, 132('-'), /, 3('I(', I1, ')', 3X, 5 3F10.5, 5X, F10.2, 6X, 3F10.2, 3X, A, ' =', F9.5, /)) 99998 FORMAT ('Librational Tensor, L(rad**2)', 25X, 'Eigenvectors ', 1 'and Eigenvalues of L in the Inertial System XI,YI,ZI', /, 2 132('-'), /, 66X, 'XI', 8X, 'YI', 8X, 'ZI', 9X, 'rad**2', 4X, 3 'deg**2', /, 132('-'), /, F7.5, '(', F6.5, ')', F8.5, '(', 4 F6.5, ')', F8.5, '(', F6.5, ')', 7X, 'L(1)', 3F10.5, 5X, F10.5, 5 F10.2, /, 15X, F8.5, '(', F6.5, ')', F8.5, '(', F6.5, ')', 7X, 6 'L(2)', 3F10.5, 5X, F10.5, F10.2, /, 31X, F8.5, '(', F6.5, ')', 7 7X, 'L(3)', 3F10.5, 5X, F10.5, F10.2, /) 99997 FORMAT ('Translational Tensor, T(ang**2)', 23X, 'Eigenvectors', 1 ' and Eigenvalues of T in the Inertial System XI,YI,ZI', /, 2 132('-'), /, 66X, 'XI', 8X, 'YI', 8X, 'ZI', 9X, 'Ang^2', /, 3 132('-'), /, F7.5, '(', F6.5, ')', F8.5, '(', F6.5, ')', F8.5, 4 '(', F6.5, ')', 7X, 'T(1)', 3F10.5, 5X, F10.5, /, 15X, F8.5, 5 '(', F6.5, ')', F8.5, '(', F6.5, ')', 7X, 'T(2)', 3F10.5, 5X, 6 F10.5, /, 31X, F8.5, '(', F6.5, ')', 7X, 'T(3)', 3F10.5, F15.5/) 99996 FORMAT ('Cross Tensor, S(rad*Ang)', /, 132('-'), /, 3(F8.5, '(', 1 F6.5, ')')/3(F8.5, '(', F6.5, ')')/3(F8.5, '(', F6.5, ')')/) 99995 FORMAT ('Calculation of the Origin Shift that Symmetrizes S', 1 23X, '- Trace old-T = ', F10.5, 7X, 'Trace new-T = ', F10.5, /, 2 132('-'), /, 'Shift Origin in I', 17X, 'New S-Tensor', 17X, 3 'New T-Tensor', 8X, 'Eigenvectors and Values of New-T in ', 4 'I-System', /, 132('-')) 99994 FORMAT ('Rol(', I1, ')', F10.5, 3X, 3F10.5, 3X, 3F10.5, 1X, 1 'New T(', I1, ')', 3F9.5, 4X, F9.5) 99993 FORMAT (/20X, 'Angular Relationships (Degrees)', /, 20X, 31('=')) 99992 FORMAT ('Libration Axes', 4X, '-', 5X, 'Inertial Axes', 6X, 1 'Libration Axes - Crystal Axes', /, 73('-'), /, 20X, 'XI', 2 6X, 'YI', 6X, 'ZI', 17X, 'X', 7X, 'Y', 7X, 'Z', /, 3 3('L(', I1, ')', 10X, 3F8.2, 10X, 3F8.2, /)) 99991 FORMAT ('Translation Axes - Inertial Axes', 4X, 1 'Translation Axes - Crystal Axes', /, 73('-'), /, 20X, 2 'XI', 6X, 'YI', 6X, 'ZI', 17X, 'X', 7X, 'Y', 7X, 'Z') 99990 FORMAT ('New T(', I1, ')', 6X, 3F8.2, 10X, 3F8.2) END SUBROUTINE PLA027 (MODE, W, W2) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION W(3, 3), WO(3, 3), DY(3), Z(3), W2(3, 3), ANGL(3) CHARACTER XMRK*1 NMAX = IPR(39) IF (MODE .NE. 0) THEN TRACE = W(1, 1) + W(2, 2) + W(3, 3) DO 20 I = 1, 3 DO 10 J = 1, 3 IF (I .EQ. J) THEN TADD = TRACE ELSE TADD = 0.0 ENDIF WO(I, J) = (TADD - W(I, J)) / 2 10 CONTINUE 20 CONTINUE ELSE CALL GEN074 (ANGL, 0.0, 1, 3) CALL GEN074 (DY, 0.0, 1, 3) ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-7) WRITE (LU7, 99995) WRITE (LU7, 99994) ENDIF DELIJ = 0 NRB = 0 NATR = 0 DO 90 I = 1, NMAX CALL GEN048 (-6, IFG(I), 9, IVAL) NADD = 0 IF (RCONT(IVAL) .LT. IPR(487) .AND. IPR(75) .GT. 1) NADD = 1 CALL GEN048 (-1, IFG(I), 19, IVALI) IF (IATP(I) .LE. NP1) THEN CALL PLA047 (XLAB(I), NQ1, IDUM, IENI, IPR(119), IGBL(55), 1 0, 0) RVLI = REL(IENI) IATPRI = IATPR(IENI) NR1 = IATNR(IENI) NATR = NATR + 1 DO 80 J = I, NMAX IF (I .NE. J .AND. IATP(J) .LE. NP1) THEN CALL PLA047 (XLAB(J), NQ2, IDUM, IENJ, IPR(119), 1 IGBL(55), 0, 0) IATPRJ = IATPR(IENJ) CALL GEN048 (-1, IFG(J), 31, IVAL) IF (IATPRI * IVAL .GT. 0) GOTO 80 NR2 = IATNR(IENJ) IF (IATPRI .GT. 0 .AND. IATPRJ .GT. 0) THEN DMAX = 2.0 ELSE DMAX = RVLI + REL(IENJ) + PAR(2) ENDIF S = 0.0 DO 30 K = 1, 3 DXI(K) = XXO(I, K) - XXO(J, K) S = S + DXI(K)**2 30 CONTINUE S = SQRT(S) IF (S .GT. 0.001 .AND. S .LT. DMAX) THEN SC = 0.0 IF (MODE .NE. 0) CALL GEN002 (1, WO, DXI, DY, XLNG) DO 40 K = 1, 3 IF (MODE .NE. 0) THEN Z(K) = DXI(K) + DY(K) SC = SC + Z(K)**2 ENDIF DXI(K) = DXI(K) / S 40 CONTINUE IF (MODE .NE. 0) THEN CALL GEN002 (1, W2, DXI, ANGL, XLNG) DO 50 K = 1, 3 ANGL(K) = ACOS(ANGL(K)) * GL(5) 50 CONTINUE SC = SQRT(SC) ENDIF VI = 0.0 VJ = 0.0 DO 70 K = 1, 3 DO 60 L = 1, 3 M = K * L IF (M .EQ. 6) M = 5 IF (M .EQ. 9) M = 6 VI = VI + DXI(K) * XSD(I, M) * DXI(L) VJ = VJ + DXI(K) * XSD(J, M) * DXI(L) 60 CONTINUE 70 CONTINUE ISVI = MAX (0, MIN (999, NINT(CON(I, 8) * 10000.0))) ISVJ = MAX (0, MIN (999, NINT(CON(J, 8) * 10000.0))) DIJ = ABS(VI - VJ) XMRK = ' ' IF (ISVI .GT. 0 .AND. ISVJ .GT. 0) THEN IDIJ = MIN (999, NINT(SQRT(CON(I, 8)**2 + 1 CON(J, 8)**2) * 10000.0)) THIRSH = DIJ * 10000.0 / IDIJ IF (THIRSH .GT. PAR(431)) XMRK = '#' ELSE IDIJ = 0 ENDIF DELIJ = DELIJ + DIJ**2 NRB = NRB + 1 SDIJ = SQRT(DIJ) IF (I .LE. IPR(37)) THEN CALL GEN048 (-1, IFG(I), 6, IGEN) IF (IGEN .EQ. 1) THEN JUNK = IPR(37) ELSE JUNK = IPR(39) ENDIF IF (J .LE. JUNK .AND. NR2 .LE. NR1) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, 99993) NQ1, NQ2, S, SC, DY, VI, 1 ISVI, VJ, ISVJ, DIJ, IDIJ, XMRK, SDIJ, ANGL CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF IF (IDIJ .NE. 0) THEN IF (THIRSH .GT. PAR(431)) WRITE (LU6, 99991) 1 NQ1, NQ2, THIRSH IF (THIRSH .GT. 2.0) THEN CALL GEN048 (-1, IFG(J), 19, IVALJ) NAD = NADD + 2 * MAX (IVALI, IVALJ) WRITE (LU20, 99990) 1 '_23', NAD, THIRSH, THIRSH, NQ1, NQ2 ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF 80 CONTINUE ENDIF 90 CONTINUE IF (NRB .GT. 0) DELIJ = SQRT(DELIJ / NRB) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (5) WRITE (LU7, 99992) DELIJ, PAR(431) ENDIF IF (NATR .LE. 40) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (0) CALL PLA269 (5) WRITE (LU7, 99999) (J, J = 1, NATR) WRITE (LU7, 99998) ENDIF N0 = 0 DO 160 I = 1, NMAX IF (IATP(I) .LE. NP1) THEN CALL PLA047 (XLAB(I), NQ1, IDUM, IENI, IPR(119), 1 IGBL(55), 0, 0) RVLI = REL(IENI) N0 = N0 + 1 N = 0 DO 150 J = 1, NMAX IF (IATP(J) .LE. NP1) THEN CALL GEN048 (-4, IFG(J), 15, IVLJ) DMAX = RVLI + REL(IEN(IVLJ + 1)) + PAR(2) S = 0 V = 0 IF (I .NE. J) THEN DO 100 K = 1, 3 DXI(K) = XXO(I, K) - XXO(J, K) S = S + DXI(K)**2 100 CONTINUE S = SQRT(S) V = S IF (I .LT. J .AND. S .GT. 0.001) THEN DO 110 K = 1, 3 DXI(K) = DXI(K) / S 110 CONTINUE V = 0 DO 130 K = 1, 3 DO 120 L = 1, 3 M = K * L IF (M .EQ. 6) M = 5 IF (M .EQ. 9) M = 6 V = V + DXI(K) * XSD(I, M) * DXI(L) 1 - DXI(K) * XSD(J, M) * DXI(L) 120 CONTINUE 130 CONTINUE V = V * 1000.0 ENDIF ENDIF N = N + 1 IATC(N) = MIN (99, NINT(ABS(V))) IF (S .LT. DMAX) IATC(N) = -IATC(N) ENDIF 150 CONTINUE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99997) N0, NQ1(1:6), (IATC(K), K = 1, N) ENDIF ENDIF 160 CONTINUE IF (IGBL(63) .GT. 2) THEN CALL PLA269(8) WRITE (LU7, 99996) ENDIF ENDIF RETURN 99999 FORMAT ('Test Matrix for Rigid-Body Vibrations - /Del(A,B)/ = ', 1 '/Z(A,B)**2 - Z(B,A)**2/ Should be Near Zero (Acta Cryst A34,', 2 '1978,828)', /, 132('='), //, 'Atom-Atom ', 40I3) 99998 FORMAT (132('-')) 99997 FORMAT (I2, 1X, A, ' - ', 40I3) 99996 FORMAT (/, 'Remarks', /, 7('-'), /, '- Upper Triangle Entries ', 1 'Represent /Del(A,B)/*1000 Values'//'- Lower Triangle Entries ', 2 'Represent Distances (A-B) Angstrom'//'- Negative Entries ', 3 'Indicate Bonded Atoms') 99995 FORMAT ('Rigid-Body Model Libration Corrections for Bond', 1 ' Distances and "Hirshfeld Rigid-Bond" Test (Acta Cryst,(1976),', 2 'A32,239-244)', /, 132('=')/) 99994 FORMAT (5X, 'Bond', 11X, 'Bond Distance Components of the', 1 ' Correction Vibration Along the Interatomic Bond', 8X, 2 'Angle with Lib. Axes', //, 'Atom(I) Atom(J)', 6X, 'Obsd ', 3 ' Calcd', 4X, 'Del(L) Del(M) Del(N)', 4X, 'I to J', 6X, 4 'J to I', 5X, 'Difference', 1X, 'Sqrt(Diff) L(1) L', 5 '(2) L(3)', /, 132('-')) 99993 FORMAT (A, '- ', A, 2F10.4, 2X, 3F8.4, 1X, 3(F6.4, '(', 1 I3, ')', 1X), A, F9.4, 2X, 3F7.2) 99992 FORMAT (/, 59X , 'Sqrt(Sum(DelIJ**2)/Nrb) = ', F10.4, //, 1 30X, '# - Indicates bonds exceeding the', F4.1, 2 ' sigma test level') 99991 FORMAT (':: ', A, '-', A, 'fails Hirshfeld Rigid Bond test at', 1 F6.2, ' sigma level') 99990 FORMAT (A, I1, 2F10.3, 2A) END SUBROUTINE PLA028 (NLT, NLTX, NEWLAT, NLTMAX) COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8) DIMENSION NEWLAT(*), A(3, 20), B(3, 3), C(3, 3), NA(3) NLTX = 0 IF (NLT .LE. NLTMAX - 3) THEN CALL GEN022 (NEWLAT, 1, NLT) L = 0 NEWLAT(NLT + 1) = 240000 NEWLAT(NLT + 2) = 2400 NEWLAT(NLT + 3) = 24 DO 20 I = 1, NLT + 3 L = L + 1 NA(3) = NEWLAT(I) NA(1) = NA(3) / 10000 NA(2) = NA(3) - NA(1) * 10000 NA(3) = MOD(NA(2), 100) NA(2) = NA(2) / 100 DO 10 J = 1, 3 IF (NA(J) .GT. 12 .AND. NA(J) .LT. 24) 1 NA(J) = NA(J) - 24 A(J, L) = FLOAT(NA(J)) / 24.0 10 CONTINUE IF (NEWLAT(I) .EQ. 121200) THEN L = L + 1 A(1, L) = A(1, L - 1) A(2, L) = - A(2, L - 1) A(3, L) = 0.0 ELSE IF (NEWLAT(I) .EQ. 1212) THEN L = L + 1 A(1, L) = 0.0 A(2, L) = A(2, L - 1) A(3, L) = - A(3, L - 1) ELSE IF (NEWLAT(I) .EQ. 120012) THEN L = L + 1 A(1, L) = A(1, L - 1) A(2, L) = 0.0 A(3, L) = - A(3, L - 1) ENDIF 20 CONTINUE DO 100 I = 1, L - 2 DO 30 N = 1, 3 B(1, N) = A(N, I) 30 CONTINUE DO 90 J = I + 1, L - 1 DO 40 N = 1, 3 B(2, N) = A(N, J) 40 CONTINUE DO 80 K = J + 1, L DO 50 N = 1, 3 B(3, N) = A(N, K) 50 CONTINUE CALL GEN003 (B, C, DET, 0) IF (DET .NE. 0.0) THEN IF (NINT(1.0 / ABS(DET)) .EQ. NLT + 1) THEN DO 70 N = 1, 3 IF (N .EQ. 1 .AND. DET .LT. 0.0) THEN IS = -1 ELSE IS = 1 ENDIF DO 60 M = 1, 3 TRNSX(N, M, 128) = B(N, M) * IS 60 CONTINUE 70 CONTINUE NLTX = 128 GOTO 110 ENDIF ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE ENDIF 110 RETURN END SUBROUTINE PLA029 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /ISCR/ RIK(3, 3), UKL(3, 3), INSCR(3) CALL GEN074 (UIJC, 0.0, 1, 9) NAT = IPR(37) NATB = IPR(39) IPR(297) = NP1 * (NP4 + 15) IPR(298) = IPR(297) + NP1 * 21 CALL PLA034 (1, NATB) WRITE (LU4) 6, (FN(K), K = 1, 9) CALL GEN108 (LU4, 0) 10 READ (LU4) ICT, XNQNR, (FN(K), K = 1, 8) IF (ICT .NE. 6) THEN DO 50 I = 1, NAT IF (NINT(XLAB(I)) .EQ. NINT(XNQNR)) THEN IF (MOD(ICT, 10) .EQ. 1) THEN IF (FN(4) .GT. 0.0) THEN JM = 4 ELSE JM = 3 ENDIF DO 20 J = 1, JM CON(I, J) = FN(J) FNJP4 = FN(J + 4) IF (FNJP4 .LT. 0.0) FNJP4 = 0.0 CON(I, J + 4) = FNJP4 20 CONTINUE IF (ICT .EQ. 1) THEN XXO(I, 1) = 0.0 XSD(I, 1) = 0.0 ENDIF ELSE IF (ICT .EQ. 2) THEN DO 30 J = 1, 6 XXO(I, J) = FN(J) XSD(I, J) = 0.0 30 CONTINUE CALL GEN048 (1, IFG(I), 4, 1) ELSE IF (ICT .EQ. 3) THEN DO 40 J = 1, 6 IF (FN(J) .GT. 0.0) XSD(I, J) = FN(J) 40 CONTINUE ELSE IF (ICT .EQ. 4) THEN XXO(I, 1) = FN(1) IF (FN(2) .LE. 0.0) FN(2) = 0.0 XSD(I, 1) = FN(2) ELSE N = NINT(FN(1)) LRT = 1 GOTO 90 ENDIF GOTO 10 ENDIF 50 CONTINUE GOTO 10 ENDIF I = NAT 60 I = I + 1 IF (I .GT. NATB) GOTO 160 XLABM = - XLAB(I) CALL PLA047 (XLABM, NQ1, MNM, JDUM, IPR(119), IGBL(55), 0, 0) CALL GEN098 (MOL(MNM), PAR(42), N, MT1, MT2, MT3, MR1) FN(2) = MT1 FN(3) = MT2 FN(4) = MT3 CALL PLA046 (2, NQ1, IENM, LBB, LBC, LBD, XLMP, YNQNR, J) IF (J .LT. 0) THEN WRITE (LU6, '(//, ''Label Problem #'', I3, '' for '', A)') 1 J, NQ1 CALL PLA004 (0) GOTO 160 ENDIF DO 70 K = 1, NP4 CON(I, K) = CON(J, K) 70 CONTINUE DO 80 K = 1, 6 XXO(I, K) = XXO(J, K) XSD(I, K) = XSD(J, K) 80 CONTINUE CALL GEN048 (-1, IFG(J), 4, IVAL) CALL GEN048 ( 1, IFG(I), 4, IVAL) LRT = 2 90 DO 100 J = 1, 3 XJX(J) = CON(I, J) XJX(J + 3) = FN(J + 1) 100 CONTINUE CALL SGSM (ICL, N, XJX, LU7, 3, IERR) DO 110 J = 1, 3 CON(I, J) = XJX(J + 6) XJX(J) = CON(I, J + 4) XJX(J + 3) = 0.0 110 CONTINUE CALL SGSM (ICL, -N, XJX, LU7, 3, IERR) DO 120 J = 1, 3 CON(I, J + 4) = XJX(J + 6) 120 CONTINUE CALL GEN048 (-1, IFG(I), 4, IVAL) IF (IVAL .GT. 0) THEN IF (N .GT. 0) THEN CALL SGSM (ICL, N, XJX, LU7, 6, IERR) DO 130 K = 1, 9 K0 = MOD (K - 1, 3) + 1 K1 = ((K - 1) / 3) + 1 RIK(K0, K1) = XJX(K) 130 CONTINUE CALL GEN005 (RIK, RIK) DO 140 K = 1, 6 DUMA(K) = XXO(I, K) 140 CONTINUE CALL GEN025 (UKL, DUMA, -1) CALL GEN001 (1, RIK, UKL, UIJ) CALL GEN025 (UIJ, DUMA, 1) DO 150 K = 1, 6 XXO(I, K) = DUMA(K) 150 CONTINUE ENDIF ENDIF IF (LRT .EQ. 1) THEN GOTO 10 ELSE IF (LRT .EQ. 2) THEN GOTO 60 ENDIF 160 DO 230 I = 1, NP1 CALL GEN048 (-1, IFG(I), 7, IHAT) CALL GEN048 (-1, IFG(I), 4, IVAL) IF (I .LE. NATB) THEN IF (XXO(I, 1) .LE. 0.0 .AND. IVAL .EQ. 0) THEN IF (IHAT .EQ. 0) THEN XXO(I, 1) = PAR(30) IPR(171) = IPR(171) + 1 ELSE XXO(I, 1) = PAR(30) IPR(172) = IPR(172) + 1 ENDIF ENDIF IF (IVAL .NE. 0) THEN DO 170 K = 1, 6 DUMA(K) = XXO(I, K) 170 CONTINUE CALL GEN025 (UIJ, DUMA, -1) ELSE UIJ(1, 1) = XXO(I, 1) ENDIF ELSE IVAL = 0 IHAT = 0 UIJ(1, 1) = - 0.1 ENDIF IF (IVAL .EQ. 0) THEN T1 = UIJ(1, 1) IF (IPR(32) .EQ. 0 .OR. T1 .LE. 0 .OR. IHAT .EQ. 1) THEN IF (IHAT .EQ. 1) THEN T1 = PAR(265) ELSE T1 = PAR(266) ENDIF ELSE T1 = SQRT(T1) ENDIF DO 190 J = 1, 3 DUMA(J) = T1 DO 180 K = 1, 3 DAM(J, K) = ROR(J, K) IF (J .EQ. K) THEN UIJC(J, K) = T1 ELSE UIJC(J, K) = 0.0 ENDIF 180 CONTINUE 190 CONTINUE ELSE CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, PAT, T1) CALL GEN019 (AA, BB, PAT(1, 1), PAT(1, 3), DAM(1, 1), -1) DO 200 J = 1, 3 T2 = DUMA(J) DUMA(J) = SIGN(SQRT(ABS(T2)), T2) 200 CONTINUE ENDIF DO 210 J = 1, 9 K0 = MOD(J - 1, 3) + 1 K1 = ((J - 1) / 3) + 1 VOID(IPR(297) + I * 21 + J - 21) = DAM(K0, K1) VOID(IPR(297) + I * 21 + J - 9) = UIJC(K0, K1) 210 CONTINUE DO 220 J = 1, 3 VOID(IPR(297) + I * 21 + J - 12) = DUMA(J) 220 CONTINUE 230 CONTINUE IF (IPR(14) .EQ. 0 .OR. IPR(14) .EQ. 4 .OR. 1 IPR(14) .EQ. 6) THEN CALL PLA024 IF (IPR(504) .EQ. 0 .AND. IGBL(22) .NE. -1) THEN IF (IPR(14) .NE. 6) THEN IF (IPR(322) .EQ. 0 .AND. IPR(43) .EQ. 0) THEN CALL PLA025 ELSE CALL PLA015 (0, 43) WRITE (LU6, 99999) ENDIF ENDIF ENDIF ENDIF CALL PLA034 (-1, NATB) IPR(85) = 1 RETURN 99999 FORMAT (/, 1 ':: No TLS-Analysis for Polymeric or Disordered Structures') END SUBROUTINE PLA030 (XXO, CON, NT, IFG, JFG, IPPR, BOND) PARAMETER (NP1=7000,NP4=9,NP9=118,NP10=16,NP12=600,NP13=500, 2 NP17=99,NPVD=40000000,NP23=18000,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // JNSC(2 * NP23), VOID(NPVD) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION XXO(NP1, 6), NT(NP1), CON(NP1, NP4), 1 IFG(NP1), JFG(NP1), BOND(*), ISMLST(5), ITEMPP(NP1), 2 ITMPL(4), IPRIOR(4), NPRIOR(4), WPRIOR(4), IFTM(4), ISHLPRI(4), 3 IPADF(4), V1(3), V2(3), V3(3), V4(3), V5(3), V6(3), V7(3), 4 JR(100), JLN(100), NCN(100), IPTR(2, NP1), INB(8), INE(8), 5 INL(8), LST(8), DTC(NP10), ITC(NP10), IPPR(129, 3), IJKL(4) CHARACTER CHYB*3, NOTE1*1 NAT = IPR(39) NATO = IPR(39) NBD = IPR(131) CALL PLA034 (1, NAT) DO 20 I = 1, NAT NC = - NINT(CON(I, NP4)) IF (NC .GT. 0 .AND. NC .LT. NP4) THEN K0 = 0 DO 10 J = 1, NC K = NINT(CON(I, J)) CALL GEN048 (-7, JFG(K), 1, KP) KP = IPPR(KP + 1, 1) / IPR(582) IF (KP .GT. 0) THEN K0 = K0 + 1 CON(I, K0) = CON(I, J) ENDIF 10 CONTINUE CON(I, NP4) = - K0 ENDIF 20 CONTINUE DO 30 I = 1, NAT CALL GEN048 (-1, IFG(I), 19, IMET) CALL PLA099 (0, I, NANG, ANG1, ANG2, ANG3, NCEFF, 1 IMET, IHYB, CHYB, NATH, NOTE1) CALL GEN048 (4, IFG(I), 24, IHYB) CALL GEN048 (3, JFG(I), 24, NATH) 30 CONTINUE DO 40 I = 1, IAN DTC(I) = ATWT(IEN(I)) ITC(I) = I 40 CONTINUE CALL GEN013 (DTC, ITC, 1, IAN) DO 50 I = 1, IAN DTC(I) = ITC(I) ITC(I) = I 50 CONTINUE CALL GEN013 (DTC, ITC, 1, IAN) DO 60 I = 1, NAT CALL GEN048 (-4, IFG(I), 15, IDUM) NT(I) = ITC(IDUM + 1) 60 CONTINUE DO 80 I = 1, NBD IPQ1 = NINT(BOND(I * 3 - 2)) IPQ2 = NINT(BOND(I * 3 - 1)) CALL PLA050 (IPQ1, IPQ2, 0, 0, DIST) CALL GEN048 (-4, IFG(IPQ1), 24, IHYA) CALL GEN048 (-4, IFG(IPQ2), 24, IHYB) CALL GEN048 (-4, IFG(IPQ1), 15, NOIP) CALL GEN048 (-4, IFG(IPQ2), 15, NOIQ) NOIP = IEN(NOIP + 1) NOIQ = IEN(NOIQ + 1) IF (IHYA .EQ. 1 .AND. IHYB .EQ. 1) THEN IBNDO = 3 ELSE IF (IHYA * IHYB .EQ. 2) THEN IBNDO = 2 ELSE IF (IHYA .EQ. 2 .AND. IHYB .EQ. 2) THEN IBNDO = 2 IF (NOIP .EQ. 2 .AND. NOIQ .EQ. 2) THEN IF (DIST .GT. PAR(384)) IBNDO = 1 ENDIF ELSE IF (NOIP .EQ. 8 .AND. NOIQ .EQ. 3 .AND. 1 IHYA .EQ. 3 .AND. IHYB .EQ. 2) THEN IBNDO = 2 ELSE IBNDO = 1 ENDIF IF (IBNDO .GT. 1) THEN DO 70 J = 2, IBNDO ITMP1 = - NINT(CON(IPQ1, NP4)) + 1 ITMP2 = - NINT(CON(IPQ2, NP4)) + 1 IF (ITMP1 .LE. 4 .OR. ITMP2 .LE. 4) THEN IF (ITMP1 .LE. 4) THEN NATO = NATO + 1 NT(NATO) = NT(IPQ2) CON(NATO, 1) = IPQ1 CON(NATO, NP4) = - 1 CON(IPQ1, ITMP1) = NATO CON(IPQ1, NP4) = - ITMP1 ENDIF IF (ITMP2 .LE. 4) THEN NATO = NATO + 1 NT(NATO) = NT(IPQ1) CON(NATO, 1) = IPQ2 CON(NATO, NP4) = - 1 CON(IPQ2, ITMP2) = NATO CON(IPQ2, NP4) = - ITMP2 ENDIF ENDIF 70 CONTINUE ENDIF 80 CONTINUE DO 120 I = 1, NAT CALL GEN048 (-4, IFG(I), 24, IHYA) CALL GEN048 (-1, IFG(I), 19, IMET) NC = - NINT(CON(I, NP4)) IF (NC .EQ. 4 .AND. IMET .EQ. 0 .AND. IHYA .EQ. 3) THEN JCAI = 2 ELSE JCAI = 0 ENDIF CALL GEN048 (2, IFG(I), 28, JCAI) IF (NC .GT. 1) THEN IF (NC .LT. 0) NC = NP4 DO 110 J = 2, NC I1 = NINT(CON(I, J)) DO 90 II = J - 1, 1, -1 IF (NT(NINT(CON(I, II))) .GE. NT(I1)) GOTO 100 CON(I, II + 1) = CON(I, II) 90 CONTINUE II = 0 100 CON(I, II + 1) = I1 110 CONTINUE ENDIF 120 CONTINUE NRTM = IPR(492) NPK = (NRTM + 1) * 4 MAXPAD = NP23 * 2 / NPK DO 530 KCENT = 1, NAT CALL GEN048 (-2, IFG(KCENT), 28, JCAK) IF (JCAK .EQ. 2) THEN CALL GEN048 (2, IFG(KCENT), 28, 0) ICHIRAL = 2 DO 130 I = 1, 4 NPRIOR(I) = NINT(CON(KCENT, I)) WPRIOR(I) = NT(NINT(CON(KCENT, I))) 130 CONTINUE CALL GEN013 (WPRIOR, NPRIOR, 1, 4) ISMPNTR = 1 140 NSAME = 1 ISMLST(1) = NPRIOR(ISMPNTR) DO 150 I = 1, 4 - ISMPNTR IF (WPRIOR(ISMPNTR + I) .NE. WPRIOR(ISMPNTR)) GOTO 160 ISMLST(I + 1) = NPRIOR(ISMPNTR + I) NSAME = NSAME + 1 150 CONTINUE 160 IF (NSAME .NE. 1) THEN CALL GEN048 (-1, IFG(ISMLST(1)), 7, IDUM) IF (IDUM .EQ. 1) GOTO 530 MAXNUMPAD = 1 CALL GEN097 (JNSC, 1, 2 * NP23, 0) DO 300 ISAM = 1, NSAME IHINP = 0 ISMLST(NSAME + 1) = KCENT IPRIOR(ISAM) = 0 IATOM = ISMLST(ISAM) IPADNUM = 0 NRT = 1 JR(1) = KCENT JR(2) = IATOM 170 IF (NRT .LT. 1) GOTO 220 NRT = NRT + 1 IF (NRT .GT. NRTM) GOTO 200 IF (NRT .GT. 3) THEN DO 180 K = NRT - 3, 1, -1 IF (JR(NRT) .EQ. JR(K)) GOTO 200 180 CONTINUE ENDIF NC = - NINT(CON(JR(NRT), NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .EQ. 1) THEN CALL GEN048 (-1, IFG(I), 7, IHAT) IF (IHAT .EQ. 1) NRT = NRT -1 GOTO 200 ENDIF NCN(NRT) = NC JLN(NRT) = 0 190 IF (NRT .LE. 1) GOTO 220 JLN(NRT) = JLN(NRT) + 1 IF (JLN(NRT) .GT. NCN(NRT)) THEN IF (NRT .EQ. 2) GOTO 200 NRT = NRT - 1 GOTO 190 ENDIF JR(NRT + 1) = NINT(CON(JR(NRT), JLN(NRT))) CALL GEN048 (-1, IFG(JR(NRT + 1)), 7, IHAT) IF (IHAT .EQ. 1) THEN IF (NCN(NRT) .LE. 2) THEN GOTO 200 ELSE GOTO 190 ENDIF ENDIF IF (JR(NRT + 1) .EQ. JR(NRT - 1)) GOTO 190 GOTO 170 200 DO 210 I = 2, NRT JNSC(ISAM + IPADNUM * NPK + (I - 2) * 4) = JR(I) 210 CONTINUE IPADNUM = IPADNUM + 1 NRT = NRT - 1 JNSC(ISAM + (IPADNUM - 1) * NPK + NRTM * 4) = NRT IHINP = MAX (IHINP, NRT) IF (IPADNUM .GT. MAXNUMPAD) MAXNUMPAD = IPADNUM IF (IPADNUM .EQ. MAXPAD) THEN IPR(126) = IPR(126) + 1 WRITE (LU6, 99999) MAXPAD ISMLST(1) = -1 GOTO 520 ENDIF GOTO 190 220 DO 290 ISHL = IHINP, 1, -1 DO 280 J = 1, IPADNUM -1 I1 = JNSC(ISAM + J * NPK + (ISHL - 1) * 4) I2 = JNSC(ISAM + J * NPK + NRTM * 4) IF (I1 .GT. 0 .AND. I1 .LE. NATO) THEN I3 = NT(I1) ELSE I3 = 0 ENDIF DO 230 K = 1, IHINP ITEMPP(K) = JNSC(ISAM + J * NPK + (K - 1) * 4) 230 CONTINUE DO 250 I = J, 1, -1 I4 = JNSC(ISAM + (I - 1) * NPK + (ISHL - 1) * 4) IF (I4 .GT. 0 .AND. I4 .LE. NATO) THEN I5 = NT(I4) ELSE I5 = 0 ENDIF IF (I5 .GE. I3) GOTO 260 DO 240 K = 1, IHINP JNSC(ISAM + I * NPK + (K - 1) * 4) = 1 JNSC(ISAM + (I - 1) * NPK + (K - 1) * 4) 240 CONTINUE JNSC(ISAM + I * NPK + NRTM * 4) 1 = JNSC(ISAM + (I - 1) * NPK + NRTM * 4) 250 CONTINUE I = 0 260 JNSC(ISAM + I * NPK + (ISHL - 1) * 4) = I1 DO 270 K = 1, IHINP JNSC(ISAM + I * NPK + (K - 1) * 4) = ITEMPP(K) 270 CONTINUE JNSC(ISAM + I * NPK + NRTM * 4) = I2 280 CONTINUE 290 CONTINUE 300 CONTINUE DO 310 I = 1, NSAME IPADF(I) = 0 310 CONTINUE DO 460 IPAD = 1, MAXNUMPAD IHINP = 0 JDUM = (IPAD - 1) * NPK + NRTM * 4 DO 320 I = 1, NSAME IHINP = MAX (IHINP, JNSC(I + JDUM)) 320 CONTINUE DO 450 ISHL = 1, IHINP IHINC = 0 JDUM = (IPAD - 1) * NPK + (ISHL - 1) * 4 DO 330 I = 1, NSAME IPNTR = JNSC(I + JDUM) IF (IPNTR .GT. 0) THEN IF (NINT(CON(IPNTR, NP4)) .LT. - IHINC) THEN IHINC = - NINT(CON(IPNTR, NP4)) IF (IHINC .GT. 6) GOTO 520 ENDIF ENDIF 330 CONTINUE DO 350 I = 1, NSAME IF (IPADF(I) .EQ. 0) THEN ISHLPRI(I) = 0 IPNTR = JNSC(I + (IPAD - 1) * NPK + (ISHL - 1) * 4) IF (IPNTR .GT. 0) THEN NC = - NINT(CON(IPNTR, NP4)) IF (NC .LT. 0) NC = NP4 IJKL(I) = IPNTR DO 340 J = 1, NC ISHLPRI(I) = ISHLPRI(I) + 1 NT(NINT(CON(IPNTR, J))) * 2 (IAN + 1) ** (IHINC - J) 340 CONTINUE ENDIF ENDIF 350 CONTINUE NFOUND = 0 DO 370 I = 1, NSAME IF (IPADF(I) .EQ. 1) THEN NFOUND = NFOUND + 1 ELSE DO 360 J = 1, NSAME IF (I .NE. J) THEN IF (IJKL(I) .EQ. IJKL(J)) GOTO 530 IF (ISHLPRI(I) .EQ. ISHLPRI(J) 1 .AND. IPADF(J) .EQ. 0) GOTO 370 ENDIF 360 CONTINUE IPADF(I) = 1 NFOUND = NFOUND + 1 IFTM(I) = ISHL ENDIF 370 CONTINUE DO 420 I = 1, NSAME ILOWEST = ISHLPRI(1) + 1 IHIGHEST = 0 IHI = 1 ILO = 1 DO 380 J = 1, NSAME IF (ISHLPRI(J) .GT. IHIGHEST) THEN IHI = J IHIGHEST = ISHLPRI(J) ENDIF IF (ISHLPRI(J) .LT. ILOWEST .AND. 1 ISHLPRI(J) .NE. -1) THEN ILO = J ILOWEST = ISHLPRI(J) ENDIF 380 CONTINUE IF (IHIGHEST .NE. 0 .AND. IPADF(IHI) .EQ. 1 .AND. 1 IFTM(IHI) .EQ. ISHL) THEN DO 390 J = 1, NSAME IF (IPRIOR(J) .EQ. 0) THEN IPRIOR(J) = IHI ISHLPRI(IHI) = -1 GOTO 400 ENDIF 390 CONTINUE ENDIF 400 IF (ILOWEST .NE. 0 .AND. IPADF(ILO) .EQ. 1 .AND. 1 IFTM(ILO) .EQ. ISHL) THEN DO 410 J = NSAME, 1, -1 IF (IPRIOR(J) .EQ. 0) THEN IPRIOR(J) = ILO ISHLPRI(ILO) = - 1 GOTO 420 ENDIF 410 CONTINUE ENDIF 420 CONTINUE IF (NFOUND .EQ. NSAME) THEN DO 430 I = 1, NSAME IF (IPRIOR(I) .LT. 1 .OR. IPRIOR(I) .GT. 4) 1 GOTO 520 ITMPL(I) = ISMLST(IPRIOR(I)) 430 CONTINUE DO 440 I = 1, NSAME ISMLST(I) = ITMPL(I) 440 CONTINUE GOTO 480 ENDIF 450 CONTINUE 460 CONTINUE GOTO 530 480 DO 490 I = 1, NSAME IF (ISMLST(I) .LT. 0) GOTO 530 490 CONTINUE ENDIF DO 500 I = 1, NSAME NPRIOR(ISMPNTR + I - 1) = ISMLST(NSAME - I + 1) WPRIOR(ISMPNTR + I - 1) = NT(ISMLST(NSAME - I + 1)) 500 CONTINUE ISMPNTR = ISMPNTR + NSAME IF (ISMPNTR .LE. 4) GOTO 140 DO 510 I = 1, 3 V1(I) = XXO(NPRIOR(4), I + 3) V2(I) = XXO(NPRIOR(3), I + 3) V3(I) = XXO(NPRIOR(2), I + 3) V4(I) = XXO(NPRIOR(1), I + 3) 510 CONTINUE CALL GEN008 (V2, V3, V5, 0) D = GEN009 (V1, V5) CALL GEN008 (V1, V2, V6, 0) CALL GEN015 (V5, V6, V7) CALL GEN008 (V3, V1, V6, 0) CALL GEN015 (V6, V7, V5) IF (GEN009 (V4, V5) .LT. D) THEN ICHIRAL = 1 ELSE ICHIRAL = 3 ENDIF IF (IABS(2 - ICHIRAL) .EQ. 1) IPR(583) = IPR(583) + 1 520 CALL GEN048 (2, IFG(KCENT), 28, ICHIRAL) ENDIF 530 CONTINUE CALL GEN097 (JNSC, 1, 2 * NP23, 0) INB(1) = 1 INE(1) = NATO DO 540 I = INB(1), INE(1) JNSC ((I - 1) * 8 + 1) = NT(I) IPTR (1, I) = NT(I) IPTR (2, I) = I 540 CONTINUE CALL GEN037 (IPTR, INB(1), INE(1)) MPG = 0 550 DO 580 I = INB(1), INE(1) NC = - NINT(CON(I, NP4)) IF (NC .LT. 0 .OR. NC .GT. 6) NC = 6 IF (NC .GT. 0) THEN DO 560 J = 1, NC LST(J) = NT(NINT(CON(I, J))) 560 CONTINUE CALL GEN022 (LST, 1, NC) DO 570 K = 1, NC JNSC((I - 1) * 8 + K + 1) = LST (NC + 1 - K) 570 CONTINUE ENDIF 580 CONTINUE M = 1 MPRI = 1 590 INL(M) = INB(M) - 1 INB(M + 1) = INB(M) N = JNSC((IPTR(2, INB(M)) - 1) * 8 + M) NVB = JNSC((IPTR(2, INB(M)) - 1) * 8 + M + 1) ISORT = 0 600 INL(M) = INL(M) + 1 IF (INL(M) .LE. INE(M)) THEN IPTM = IPTR(2, INL(M)) IF (JNSC((IPTM - 1) * 8 + M) .EQ. N) THEN NVX = JNSC ((IPTM - 1) * 8 + M + 1) IPTR(1, INL(M)) = NVX IF (NVX .NE. NVB) ISORT = 1 NT(IPTM) = MPRI GOTO 600 ENDIF ENDIF INE(M + 1) = INL(M) - 1 IF (ISORT .EQ. 1) THEN CALL GEN037 (IPTR, INB(M + 1), INE(M + 1)) ELSE IF (NVB .EQ. 0) GOTO 640 ENDIF DO 630 KKK = 1, NATO III = IPTR(2, KKK) DO 610 NNN = 1, 6 IF (JNSC((III - 1) * 8 + NNN) .EQ. 0) GOTO 630 610 CONTINUE 630 CONTINUE IF (M .LT. 8) THEN M = M + 1 GOTO 590 ENDIF 640 INB(M + 1) = INL(M) IF (INB(M + 1) .LE. INE(M)) THEN N = JNSC((IPTR(2, INB(M + 1)) - 1) * 8 + M) NVB = JNSC((IPTR(2, INB(M + 1)) - 1) * 8 + M + 1) ISORT = 0 MPRI = MPRI + 1 INL(M) = INL(M) - 1 GOTO 600 ELSE M = M - 1 IF (M .EQ. 0) GOTO 650 GOTO 640 ENDIF 650 IF (MPRI .GT. MPG) THEN MPG = MPRI GOTO 550 ENDIF DO 660 K = 1, NAT IVAL = NT(K) CALL GEN048 (10, JFG(K), 14, IVAL) 660 CONTINUE CALL PLA034 (-1, NAT) RETURN 99999 FORMAT (':: MAXPATH = ', I4, ' EXCEEDED') END SUBROUTINE PLA031 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // JNSC(2, NP23), VOID(NPVD) DIMENSION XMD(9, 2), IXMD(9), ICSD(6) CHARACTER FORM*160, FORMI*79, FORMJ*68 FORMI( 1:28) = '(''Centroid '',A,'': x ,y ,z '',' FORMI(29:62) = 'F10.5,''('',I4,'')'',F10.5,''('',I4,'')'',' FORMI(63:79) = 'F10.5,''('',I4,'')'')' FORMJ( 1:17) = '(16X,''XO,YO,ZO '',' FORMJ(18:68) = FORMI(29:79) FORM( 1: 15) = '('' From: '',A ' FORM( 16: 31) = ',F8.4,''('',I3,'')''' FORM( 32: 79) = FORM(16:31)//FORM(16:31)//FORM(16:31) FORM( 80:127) = FORM(32:79) FORM(128:160) = FORM(16:31)//FORM(16:31)//')' NRAT = IPR(12) NAT = IPR(39) IPR(64) = IPR(64) + 1 KRC = NAT + IPR(64) IFG(KRC) = IFG(JR(1)) JFG(KRC) = JFG(JR(1)) NTRNS(KRC) = NTRNS(JR(1)) CALL GEN048 (-6, IFG(KRC), 9, NRES) CALL GEN040 (IPR(19) + IATP(KRC), NQ2, IP) NQ1(1:7) = 'CG ' NQ1(3:2 + IP) = NQ2(1:IP) CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) CALL GEN048 (6, IFG(KRC), 15, NIEN) XLAB(KRC) = XNQNR CALL PLA047 (XNQNR, NQ1, MN, JDUM, IPR(119), IGBL(55), 0, 0) DO 10 K = 1, 3 YUNK = SQRT(XSD(KRC, K)) CALL GEN041 (XXO(KRC, K), YUNK, ICSD(K), IPR(183), 1 NDEC, IPR(68)) NDC = K * 17 + 16 YUNK = SQRT(XSD(KRC, K + 3)) CALL GEN041 (XXO(KRC, K + 3), YUNK, ICSD(K + 3), 5, NDECJ, 1 IPR(68)) NDCJ = K * 17 + 5 FORMI(NDC:NDC) = CHAR(ICHAR('0') + NDEC) FORMJ(NDCJ:NDCJ) = CHAR(ICHAR('0') + NDECJ) ICSD(K) = MIN (99, ICSD(K)) ICSD(K + 3) = MIN (99, ICSD(K + 3)) 10 CONTINUE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, '(/)') WRITE (PRBUF, FORMI) NQ1(1:6), (XXO(KRC, K), ICSD(K), K = 1, 3) CALL PLA067 (LU7, PRBUF, 132, 1, 3) WRITE (PRBUF, FORMJ) (XXO(KRC, K), ICSD(K), K = 4, 6) CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF IF (NRAT .LE. 7) THEN NRAT = NRAT + 1 NAMS(NRAT, 1) = ' '//NQ1 NRT = NRAT + 1 NAMS(NRT, 1) = ' RING ' NM = 0 DO 120 I = 1, NAT CALL GEN048 (-1, IFG(I), 19, MET) IF (MET .EQ. 0) GOTO 120 JR(NRAT) = KRC CALL PLA050 (I, KRC, 0, 0, DCEN) IF (DCEN .GT. PAR(422)) GOTO 120 CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) CALL PLA055 CALL PLA056 (XPV(1), I, XMD(NRT, 1), XMD(NRT, 2), 1 IDUM1, 5, IDUM2) XMD(NRT, 1) = ABS(XMD(NRT, 1)) IXMD(NRT) = MIN (999, NINT(10000 * XMD(NRT, 2))) DO 20 J = 1, NRAT CALL PLA053 (I, JR(J), 0, 0, XMD(J, 1), XMD(J, 2), 1 IXMD(J), NDEC, IER) IF (IER .EQ. 0) THEN IF (XMD(J, 1) .LT. PAR(12)) GOTO 120 IFT = 4 + J * 16 FORM(IFT : IFT) = CHAR(ICHAR('0') + NDEC) ENDIF 20 CONTINUE DPERP = - XPV(4) DO 30 J = 1, 3 DPERP = DPERP + XPV(J) * XXO(I, J + 3) 30 CONTINUE DSH = SQRT (MAX(0.0, DCEN**2 - DPERP**2)) IF (DSH .GT. PAR(423) .OR. ABS(DPERP) .LT. PAR(424)) GOTO 120 IF (IGBL(63) .GT. 2) THEN NM = NM + 1 IF (NM .EQ. 1) THEN WRITE (LU7, 99998) PAR(422), PAR(424), PAR(423) WRITE (LU7, 99997) (NAMS(II, 1)(2:7), II = 1, NRT) WRITE (LU7, 99996) ENDIF WRITE (PRBUF, FORM) 1 NQ1(1:7), (XMD(J, 1), IXMD(J), J = 1, NRT) CALL PLA067 (LU7, PRBUF, 132, 1, 3) WRITE (LU7, 99999) DSH ENDIF IF (DSH .LT. PAR(70)) THEN JR(NRAT) = I DO 110 MM = 1, IPR(51) IF (MM .EQ. 1) THEN DO 40 J = 2, NRAT CALL PLA100 (JR(NRAT), JR(J - 1), -2, -1.0) 40 CONTINUE CALL PLA100 (JR(NRAT), KRC, 2, -1.0) ELSE CALL GEN098 (MOL(MM), PAR(42), IPR(54), 1 ITR(1), ITR(2), ITR(3), IR) IF (NRES .EQ. IR) THEN KAT = IPR(39) + IPR(64) + 1 IF (MN .GT. IPR(463)) THEN IPR(2) = 54 GOTO 130 ENDIF XLAB(KAT) = XLAB(KRC) + MM - 1 DO 50 J = 1, IPR(64) IF (XLAB(KAT) .EQ. XLAB(IPR(39) + J)) THEN KAT = IPR(39) + J GOTO 70 ENDIF 50 CONTINUE IPR(64) = IPR(64) + 1 CALL PLA059 (KRC, KAT) IFG(KAT) = IFG(KRC) JFG(KAT) = JFG(KRC) DO 60 J = 1, 6 VOID((KAT - 1) * (NP4 + 15) + J) = XXO(KAT, J) VOID((KAT - 1) * (NP4 + 15) + J + 6) = XSD(KAT, J) 60 CONTINUE CALL GEN048 (6, IFG(KAT), 9, IR) 70 DO 100 J = 1, NRAT KAT1 = KAT + 1 CALL PLA059 (JR(NRAT + 1 - J), KAT1) DO 80 K = 1, NAT CALL PLA050 (K, KAT1, 0, 0, DIST) IF (DIST .LT. 0.05) GOTO 90 80 CONTINUE GOTO 100 90 IF (J .EQ. 1) THEN KMETAL = K CALL PLA100 (KMETAL, KAT, 2, -1.0) ELSE CALL PLA100 (KMETAL, K, -2, -1.0) ENDIF 100 CONTINUE ENDIF ENDIF 110 CONTINUE ENDIF 120 CONTINUE ENDIF 130 RETURN 99999 FORMAT (/, 'Ring-Slippage: Distance Between Perpendicular ', 1 'Projection of Heavy Atom on Ring L.S.-Plane and Ring ', 2 'Centroid =', F6.3, ' Ang'/) 99998 FORMAT (///, 10X, 'Metal - Ring Geometry [d(Metal-Cg) .lt.', 1 F5.1, ' Ang., d(perp) .gt. ', F5.1, ' Ang., Slippage .lt. ', 2 F6.3, ' Ang.]', /, 10X, 102('='), /) 99997 FORMAT ('Distance (Ang) to:', 1X, A, 8(7X, A)) 99996 FORMAT (132('-')) END SUBROUTINE PLA032 (NRSD) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER FORM*73 SA = 0.0 ISA = 0 NDEC = 0 IF (IPR(8) .GT. 0) THEN IPR(60) = 0 NAT = IPR(37) MTL = 3 NTOR = 0 KB = 0 FORM(1 :4) = '(1X,' FORM(5:24) = '4(A),F8.2,''('',I3,'')''' FORM(25:48) = ',4X,'//FORM(5:24) FORM(49:73) = FORM(25:48)//')' DO 80 NHB = 1, 2 IHB = NHB - 1 IF (IHB .EQ. 1 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, '( )') ENDIF DO 70 JAT = 1, NAT JR(2) = JAT JATL = INT(XLAB(JAT) / IPR(463)) CALL GEN048 (-6, IFG(JAT), 9, IRESJ) IF (IRESJ .NE. NRSD) GOTO 70 CALL GEN048 (-1, IFG(JAT), 7, IHJ) NJ = - NINT(CON(JAT, NP4)) IF (NJ .LT. 0) THEN NJ = NP4 CALL GEN048 (-1, IFG(JAT), 8, IVAL) IF (IVAL .GT. 0) NJ = NJ + IPR(76) ENDIF IF (NJ .LE. 1) GOTO 70 DO 60 KJ = 1, NJ IF (KJ .LE. NP4) THEN KAT = NINT(CON(JAT, KJ)) ELSE IF (IBON(KJ - NP4, 1) .NE. JAT) GOTO 60 KAT = IBON(KJ - NP4, 2) ENDIF JR(3) = KAT KATL = INT(XLAB(KAT) / IPR(463)) IF (JATL .GT. KATL) GOTO 60 NK = - NINT(CON(KAT, NP4)) IF (NK .LT. 0) THEN NK = NP4 CALL GEN048 (-1, IFG(KAT), 8, IVAL) IF (IVAL .GT. 0) NK = NK + IPR(76) ENDIF IF (NK .LE. 1) GOTO 60 CALL GEN048 (-1, IFG(KAT), 7, IHK) IF (NJ .LE. IPR(163) .AND. NK .LE. IPR(163)) 1 CALL PLA033 (NJ, NK) DO 50 KI = 1, NJ IF (KI .LE. NP4) THEN IAT = NINT(CON(JAT, KI)) ELSE IF (IBON(KI - NP4, 1) .NE. JAT) GOTO 50 IAT = IBON(KI - NP4, 2) ENDIF JR(1) = IAT IF (IAT .EQ. KAT) GOTO 50 CALL GEN048 (-1, IFG(IAT), 7, IHI) DO 40 KK = 1, NK IF (KK .LE. NP4) THEN LAT = NINT(CON(KAT, KK)) ELSE IF (IBON(KK - NP4, 1) .NE. KAT) GOTO 40 LAT = IBON(KK - NP4, 2) ENDIF JR(4) = LAT IF (LAT .EQ. JAT) GOTO 40 IF (IAT .EQ. LAT) GOTO 40 CALL GEN048 (-1, IFG(LAT), 7, IHL) IHA = IHI + IHJ + IHK + IHL IF (IHB .EQ. 0) THEN IF (IHA .GT. 0) GOTO 40 ELSE IF (IHA .EQ. 0) GOTO 40 ENDIF KB1 = KB + 1 CALL PLA036 (IAT, KB1, 1, IDS1, MNUM1, ISP1, 1 IPR(119), IGBL(55)) IF (IDS1 .LT. 500) GOTO 50 CALL PLA036 (JAT, KB1, 2, IDS2, MNUM2, ISP2, 1 IPR(119), IGBL(55)) IF (IDS2 .LT. 500) GOTO 70 CALL PLA036 (KAT, KB1, 3, IDS3, MNUM3, ISP3, 1 IPR(119), IGBL(55)) IF (IDS3 .LT. 500) GOTO 60 CALL PLA036 (LAT, KB1, 4, IDS4, MNUM4, ISP4, 1 IPR(119), IGBL(55)) IF (IDS4 .LT. 500) GOTO 40 IVLT = 0 IF (MNUM1 .GT. 1) THEN IVLT = IVLT + 1 ENDIF IF (MNUM2 .GT. 1) THEN IVLT = IVLT + 1 ENDIF IF (MNUM3 .GT. 1) THEN IVLT = IVLT + 1 ENDIF IF (MNUM4 .GT. 1) THEN IVLT = IVLT + 1 ENDIF ITEST = (4 - ISP1 - ISP2 - ISP3 - ISP4) / 2 IF (IVLT .GT. ITEST) GOTO 40 CALL PLA050 (IAT, JAT, KAT, 0, A) IF (A .GT. PAR(15)) GOTO 40 CALL PLA050 (JAT, KAT, LAT, 0, A) IF (A .GT. PAR(15)) GOTO 40 CALL PLA053 (IAT, JAT, KAT, LAT, A, SA, ISA, 1 NDEC, IER) IF (IER .NE. 0) GOTO 40 KB = KB + 1 NTOR = NTOR + 1 DBUF(KB) = A IDBUF(KB) = ISA IFT = -11 + KB * 24 FORM(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IF (IPR(438) .EQ. 1 .AND. IHA .EQ. 0) THEN IPR(253) = IPR(253) + 1 WRITE (LU2, 99998) 1 (NAMS(KB, M)(2:8), M = 1, 4), A, SA ENDIF CALL GEN048 (-3, JFG(KAT), 24, KMET) CALL GEN048 (-4, IFG(KAT), 24, KHYB) NCK = NINT(CON(KAT, NP4)) CALL GEN048 (-3, JFG(JAT), 24, JMET) CALL GEN048 (-4, IFG(JAT), 24, JHYB) NCJ = NINT(CON(JAT, NP4)) IF (NCK .EQ. -4) THEN IF (KMET .EQ. 3 .AND. JHYB .EQ. 2) THEN IF (180.0 - ABS(A) .LT. 0.15) THEN WRITE (LU20, 99999) 1 '_380', 1.0, 1.0, NAMS(KB, 3)(2:8) ENDIF ENDIF ENDIF IF (NCJ .EQ. -4) THEN IF (JMET .EQ. 3 .AND. KHYB .EQ. 2) THEN IF (180.0 - ABS(A) .LT. 0.15) THEN WRITE (LU20, 99999) 1 '_380', 1.0, 1.0, NAMS(KB, 2)(2:8) ENDIF ENDIF ENDIF IF (NTOR .EQ. 1) THEN IF (IPR(134) .EQ. 1) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99996) NRSD ENDIF IPR(134) = 0 ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99997) '>', PAR(15) ENDIF ENDIF IF (KB .LT. MTL) GOTO 40 IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORM) ((NAMS(L, M)(2:8), M = 1, 4), 1 DBUF(L), IDBUF(L), L = 1, MTL) CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF KB = 0 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE IF (KB .GT. 0) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORM) ((NAMS(L, M)(2:8), M = 1, 4), 1 DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF KB = 0 ENDIF 80 CONTINUE IF (IPR(60) .NE. 0) CALL PLA033 (0, 0) ENDIF RETURN 99999 FORMAT (A, 2F10.2, A) 99998 FORMAT ('TORS ', 4(A, 2X), 2F7.2) 99997 FORMAT (/, 'Torsion/Dihedral Angles (Deg.) - Klyne & Prelog', 1 ' Convention (Dunitz, p241) - (Excl. Minor Disorder & Embedded', 2 ' Bond Angl. ', A, F5.0, ' Deg.)', /, 132('=')) 99996 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X, 1 61('*'), /, 57X, 13('=')) END SUBROUTINE PLA033 (NJ, NK) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 NTYP = -1 IF (NJ .NE. 0) THEN IPR(60) = IPR(60) + 1 J = JR(2) K = JR(3) CALL PLA227 (K, J, RMAT(1, 3)) DEN = SQRT(RMAT(1, 3)**2 + RMAT(2, 3)**2) IF (DEN .LT. PAR(12)) THEN RMAT(1, 2) = 0.0 RMAT(2, 2) = 1.0 ELSE RMAT(1, 2) = RMAT(2, 3) / DEN RMAT(2, 2) = -RMAT(1, 3) / DEN ENDIF RMAT(3, 2) = 0.0 CALL GEN008 (RMAT(1, 2), RMAT(1, 3), RMAT(1, 1), 1) CALL GEN005 (RMAT, RMAT) JJ = 0 DO 30 I = 1, NJ I1 = NINT(CON(J, I)) IF (I1 .NE. K) THEN JJ = JJ + 1 IATC(JJ) = I1 + NP1 ENDIF 30 CONTINUE DO 40 I = 1, NK I1 = NINT(CON(K, I)) IF (I1 .NE. J) THEN JJ = JJ + 1 IATC(JJ) = I1 ENDIF 40 CONTINUE CALL PLA044 (RMAT, J, XR0, YR0, ZR0, 0.0, 0.0, 0.0, 1.0, 0.0) DO 50 I = 1, JJ DATC(I) = 90.0 L = MOD(IATC(I), NP1) CALL PLA044 (RMAT, L, XR, YR, ZR, XR0, YR0, ZR0, 1.0, 0.0) IF (ABS(XR) .GT. 0.00001) THEN DATC(I) = ATAN2(YR, XR) * GL(5) IF (DATC(I) .LT. 0.0) DATC(I) = DATC(I) + 360.0 ENDIF 50 CONTINUE CALL GEN013 (DATC, IATC, 1, JJ) ISH = (IPR(60) - 1) * 60 IATP(1 + ISH) = JJ IATP(2 + ISH) = J IATP(3 + ISH) = K DO 60 I = 1, JJ IATP(I + 3 + ISH) = IATC(I) IATP(I + 20 + ISH) = NINT(100.0 * (DATC(I) - DATC(1))) IATP(I + 38 + ISH) = NINT(100.0 * (DATC(I) - DATC(1))) 60 CONTINUE DO 80 I = 2, JJ DO 70 J = 1, 6 DELX = PAR(24) * ABS(COS(IATP(I + 38 + ISH) / GL(5)) 1 -COS(IATP(I + 37 + ISH) / GL(5))) DELY = PAR(24) * ABS(SIN(IATP(I + 38 + ISH) / GL(5)) 1 -SIN(IATP(I + 37 + ISH) / GL(5))) IF (4.5 * DELX .GT. 6.0 * PAR(25) .OR. 1 4.5 * DELY .GT. PAR(25)) GOTO 80 IATP(I + 38 + ISH) = IATP(I + 38 + ISH) + 1 IATP(I + 37 + ISH) = IATP(I + 37 + ISH) - 1 70 CONTINUE 80 CONTINUE IATP(JJ + 4 + ISH) = IATC(1) IATP(JJ + 21 + ISH) = IATP(21 + ISH) + 36000 IF (IPR(60) .NE. 4) GOTO 100 ENDIF WRITE (LU8) NTYP, IPR(60), JR, RMAT WRITE (LU8) (IATP(L4), L4 = 1, 240) IPR(60) = 0 100 RETURN END SUBROUTINE PLA034 (MODE, NAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP19=31,NPVD=40000000,NP23=18000,NP25=99,NP29=63, 2 NP41=200,NP47=9) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON // JNSC(2, NP23), VOID(NPVD) K = 0 IF (MODE .EQ. 1) THEN DO 30 I = 1, NAT DO 10 J = 1, 6 VOID(K + J) = XXO(I, J) VOID(K + J + 6) = XSD(I, J) 10 CONTINUE DO 20 J = 1, NP4 VOID(K + J + 12) = CON(I, J) 20 CONTINUE K = K + NP4 + 15 30 CONTINUE ELSE IF (MODE .EQ. -1) THEN DO 60 I = 1, NAT DO 40 J = 1, 6 XXO(I, J) = VOID(K + J) XSD(I, J) = VOID(K + J + 6) 40 CONTINUE DO 50 J = 1, NP4 CON(I, J) = VOID(K + J + 12) 50 CONTINUE K = K + NP4 + 15 60 CONTINUE ENDIF RETURN END SUBROUTINE PLA035 (MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 DIMENSION ISPV(8) CHARACTER INQ1*1, FORMA*48, FORMB*48, FORMT*48, FORMC*35, 1 FORMD*34, FORME*40, FORML*58, FORM*87, FORMH*36 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 IWIN = IGBL(25) * IGBL(32) FORM(1:28) = '(''P ='',F8.4,''('',I4,''), Q ='',' FORM(29:61) = 'F8.4,''('',I4,''), R ='',F8.4,''('',I4,' FORM(62:86) = '''), S ='',F8.4,''('',I4,'')'')' FORMB( 1:11) = '( ''DIST '',1' FORMB(12:48) = '( A ,''.. ''), A ,'' ='',F9.4,''('',I3,'')'')' FORMA( 1:48) = '(''ANGLE '',2'//FORMB(12:48) FORMT( 1:48) = '( ''TORS '',3'//FORMB(12:48) FORMC( 1:35) = '(1X,A,'' -- '',A,11X,F8.4,''('',I3,'')'')' FORMD( 1:34) = '(1X,2(A,'' -- ''),A,F8.2,''('',I3,'')'')' FORME( 1:40) = '(A,1X,A,'' : '',F10.0,''('',I2,'') '',6F8.4)' FORML( 1:30) = '( ''ANGLE '',A,''- '',A,''with '',A,' FORML(31:58) = '''- '',A,'' ='',F9.3,''('',I3,'')'')' FORMH( 1:36) = '(''Dihedral Angle ='',F7.0,''('',I2,'')'')' ANG = 0.0 SANG = 0.0 D = 0.0 SD = 0.0 ISANG = 0 ISD = 0 PAGET = 'SelGeom' NAT = IPR(39) NMAX = NAT + IPR(64) N = IPR(81) IPR(97) = IPR(97) + 1 IF (IPR(97) .EQ. 1 .AND. IGBL(63) .GT. 1 .AND. MODE .EQ. 1) THEN CALL PLA269 (-3) WRITE (LU7, 99997) ENDIF IF (N .LT. 0) THEN IPR(12) = 0 N = - N NANAL = 0 IF (IFL(1) .EQ. 'FIT') THEN 5 IF (N .EQ. 1) THEN IF (IPR(221) .EQ. 0) THEN FN(1) = 2 FN(2) = 1 IPR(221) = 2 ENDIF IF (IPR(221) .EQ. 2) THEN NRES1 = NINT(FN(1)) NRES2 = NINT(FN(2)) N2 = 0 DO 30 I = 1, NAT CALL GEN048 (-1, IFG(I), 7, IHAT) IF (IHAT .EQ. 0) THEN CALL GEN048 (-6, IFG(I), 9, NRESI) IF (NRESI .EQ. NRES1) THEN CALL GEN048 (-10, JFG(I), 14, LBN1) IF (I .LT. NAT) THEN DO 10 J = 1, NAT IF (J .NE. I) THEN CALL GEN048 (-10, JFG(J), 14, LBN2) IF (LBN1 .EQ. LBN2) THEN CALL GEN048 (-6, IFG(J), 9, NRESJ) IF (NRESI .EQ. NRESJ) GOTO 30 ENDIF ENDIF 10 CONTINUE ENDIF DO 20 J = 1, NAT CALL GEN048 (-1, IFG(J), 7, IHAT) IF (IHAT .EQ. 0) THEN CALL GEN048 (-6, IFG(J), 9, NRESJ) IF (NRESJ .EQ. NRES2) THEN CALL GEN048 (-10, JFG(J), 14, LBN2) IF (LBN1 .EQ. LBN2) THEN N2 = N2 + 2 JR(N2 - 1) = I JR(N2) = J GOTO 30 ENDIF ENDIF ENDIF 20 CONTINUE ENDIF ENDIF 30 CONTINUE IF (N2 .GE. IPR(28) * 2) THEN IPR(12) = N2 WRITE (LU6, 99994) NRES1, NRES2, N2 / 2 ELSE N = -3 GOTO 5 ENDIF ELSE GOTO 280 ENDIF ELSE IF (ABS(N) .EQ. 3) THEN NANAL = 1 IF (N .EQ. 3) THEN CALL PLA046 (4, IFL(2), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, N1) IF (N1 .LT. 0) THEN IF (N1 .EQ. -4) THEN GOTO 280 ELSE GOTO 270 ENDIF ENDIF CALL GEN048 (-6, IFG(N1), 9, NRES1) CALL PLA046 (4, IFL(3), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, N2) IF (N2 .LT. 0) THEN IF (N2 .EQ. -4) THEN GOTO 280 ELSE GOTO 270 ENDIF ENDIF CALL GEN048 (-6, IFG(N2), 9, NRES2) ENDIF N1 = -1 N2 = 0 DO 40 I = 1, NAT CALL GEN048 (-1, IFG(I), 7, IHAT) IF (IHAT .EQ. 0) THEN CALL GEN048 (-6, IFG(I), 9, NRES) IF (NRES .EQ. NRES1) THEN N1 = N1 + 2 JR(N1) = I ELSE IF (NRES .EQ. NRES2) THEN N2 = N2 + 2 JR(N2) = I ENDIF ENDIF 40 CONTINUE DO 50 K = 1, N2 - 1, 2 JCA(JR(K)) = JR(K + 1) 50 CONTINUE IPR(12) = N2 WRITE (LU6, 99994) NRES1, NRES2, N2 / 2 IF (N2 .NE. N1 + 1) THEN WRITE (LU6, 99993) GOTO 260 ENDIF ELSE DO 60 I = 2, N CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN IF (NIEN .EQ. -4) THEN GOTO 280 ELSE GOTO 270 ENDIF ENDIF IPR(12) = IPR(12) + 1 JR(IPR(12)) = NIEN 60 CONTINUE ENDIF IF (IPR(12) .GE. IPR(28) * 2) THEN VARDIST = 999.0 CALL PLA085 (1, VARDIST) IF (NANAL .NE. 0) CALL PLA084 (NRES1, NRES2) ELSE CALL PLA015 (0, 31) WRITE (LU6, 99998) ENDIF ELSE LOOP = 1 NW = 0 DO 70 I = 2, N IF (IFL(I) .EQ. 'WITH') THEN NW = I LOOP = 2 ENDIF 70 CONTINUE DO 160 ILP = 1, LOOP IF (LOOP .EQ. 1) THEN IBEG = 2 IEND = N ELSE IF (ILP .EQ. 1) THEN IBEG = 2 IEND = NW - 1 ELSE IBEG = NW + 1 IEND = N ENDIF ENDIF C * LEAST-SQUARES PLANE REQUESTED DO 80 I = 1, NMAX IATP(I) = I + 2 * NP1 80 CONTINUE IMODE = 0 NDIST = 0 DO 90 I = IBEG, IEND IF (IFL(I) .EQ. 'DIST') THEN IMODE = 1 ELSE CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN IF (NIEN .EQ. -4) THEN GOTO 280 ELSE GOTO 270 ENDIF ENDIF IPR(12) = IPR(12) + 1 - IMODE NDIST = NDIST + 1 IATP(NIEN) = NIEN + IMODE * NP1 ENDIF 90 CONTINUE CALL GEN022 (IATP, 1, NMAX) IF (IEND - IBEG .GT. 1) THEN CALL PLA055 DO 100 I = 1, 4 XLS(I, ILP) = XPV(I) XLS(I + 4, ILP) = XSPV(I) 100 CONTINUE IFT = -10 DO 110 I = 5, 8 CALL GEN041 (XPV(I), XSPV(I), ISPV(I), 4, NDEC, IPR(68)) IFT = IFT + 21 FORM(IFT : IFT) = CHAR(ICHAR('0') + NDEC) 110 CONTINUE ELSE CALL PLA227 (IATP(1), IATP(2), VECN) CALL PLA053 (IATP(1),IATP(2), 0, 0, D, SD, IDUM1, 1 IDUM2, IER) ENDIF IF (IWIN .EQ. 1) THEN IF (ILP .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.7 WRITE (PRBUF, 99990) CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) VRT = VRT - 0.7 WRITE (PRBUF, 99989) CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) WRITE (LU6, 99986) WRITE (LU6, 99990) WRITE (LU6, 99989) ELSE VRT = VRT - 1.0 WRITE (LU6, 99987) ENDIF IF (IEND - IBEG .GT. 1) THEN WRITE (PRBUF, FORM) (XPV(I), ISPV(I), I = 5, 8) VRT = VRT - 0.6 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) WRITE (PRBUF, 99991) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) ELSE IF (IEND - IBEG .EQ. 1) THEN CALL GGIP20 (0.0, ' Bond', 6, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) ENDIF VRT = VRT - 0.2 ENDIF IF (IEND - IBEG .GT. 1) THEN WRITE (LU6, FORM) (XPV(I), ISPV(I), I = 5, 8) WRITE (LU6, 99987) WRITE (LU6, 99991) IF (IGBL(63) .GT. 1) THEN CALL PLA269 (8) WRITE (LU7, 99986) WRITE (LU7, 99990) WRITE (LU7, 99989) WRITE (LU7, FORM) (XPV(I), ISPV(I), I = 5, 8) WRITE (LU7, 99987) WRITE (LU7, 99991) ENDIF ENDIF CALL GEN003 (OR, UIJ, DET, 0) IF (DET .LE. 0.0) STOP 'CANNOT INVERT OR' IF (IEND - IBEG .GT. 1) THEN DO 130 I = 1, NDIST IF (I .GT. IPR(12)) THEN INQ1 = ' ' ELSE INQ1 = '*' ENDIF IATPI = MOD(IATP(I), NP1) CALL PLA047 (XLAB(IATPI), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CALL PLA056 (XPV(1), IATPI, DIS, SDIS, ISDIS, 5, NDEC) ISDIS = MIN (99, ISDIS) FORME(19:19) = CHAR(ICHAR('0') + NDEC) DO 120 J = 1, 3 V2(J) = XXO(IATPI, J + 3) 120 CONTINUE CALL GEN002 (1, UIJ, V2, V1, YUNK) WRITE (PRBUF, FORME) INQ1, NQ1, DIS, ISDIS, 1 (V1(J), J = 1, 3), (V2(J), J = 1, 3) CALL GEN065 (LU6, PRBUF, 80, 1) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.45 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 1) THEN CALL PLA269 (1) WRITE (LU7, 99999) PRBUF ENDIF 130 CONTINUE ELSE IF (IEND - IBEG .EQ. 1) THEN DO 150 I = 1, 2 CALL PLA047 (XLAB(IATP(I)), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) DO 140 J = 1, 3 V2(J) = XXO(IATP(I), J + 3) 140 CONTINUE CALL GEN002 (1, UIJ, V2, V1, YUNK) WRITE (PRBUF, 99985) NQ1, 1 (V1(J), J = 1, 3), (V2(J), J = 1, 3) CALL GEN065 (LU6, PRBUF, 80, 1) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.45 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF IF (IGBL(63) .GT. 1) THEN CALL PLA269 (1) WRITE (LU7, 99999) PRBUF ENDIF 150 CONTINUE ENDIF 160 CONTINUE IF (LOOP .EQ. 2) THEN IF (IEND - IBEG .GT. 1) THEN ANG = GL(5) * ACOS(MIN(ABS(XLS(1, 1) * XLS(1, 2) + 1 XLS(2, 1) * XLS(2, 2) + XLS(3, 1) * XLS(3, 2)), 1.0)) SANG = 0 DO 170 I = 5, 7 SANG = SANG + XLS(I, 1)**2 + XLS(I, 2)**2 170 CONTINUE SANG = GL(5) * SQRT(SANG) FORMH(3:10) = 'Dihedral' ELSE IF (IEND - IBEG .EQ. 1) THEN ANG = 90.0 - ACOS(MIN(ABS(XLS(1, 1) * VECN(1) + 1 XLS(2, 1) * VECN(2) + XLS(3, 1) * VECN(3)), 1.0)) * 2 GL(5) SANG = 0.0 DO 180 L = 1, 3 SANG = SANG + XLS(L + 4, 1)**2 + (VECN(L) * SD / D)**2 180 CONTINUE SANG = GL(5) * SQRT(SANG) FORMH(3:10) = 'LsplBond' ENDIF IF (IEND - IBEG .GT. 0) THEN CALL GEN041 (ANG, SANG, ISANG, 2, NDEC, IPR(68)) ISANG = MIN (99, ISANG) FORMH(24:24) = CHAR(ICHAR('0') + NDEC) WRITE (PRBUF, FORMH) ANG, ISANG CALL GEN065 (LU6, PRBUF, 80, 1) IF (IWIN .EQ. 1) THEN VRT = VRT - 1.00 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF ENDIF ENDIF IF (IPR(41) .EQ. 0) THEN PRBUF = 'UNIT WEIGHTS' ELSE IF (IPR(41) .EQ. 1) THEN PRBUF = 'ATWT WEIGHTS' ELSE PRBUF = 'ESD/SU WEIGHTS' ENDIF WRITE (LU6, 99988) PRBUF IF (IGBL(63) .GT. 1) THEN CALL PLA269 (2) WRITE (LU7, 99988) PRBUF ENDIF IF (IWIN .EQ. 1) THEN VRT = VRT - 1.0 CALL GGIP20 (0.0, PRBUF, 30, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) CALL PLA297 (0) ENDIF ENDIF C * DISTANCES & ANGLES ELSE DO 220 I = 2, N NQ2 = IFL(I) DO 200 J = 1, 2 CALL PLA046 (4, NQ2, IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN IF (NIEN .EQ. -4) THEN DO 190 L = 1, 6 IF (NQ2(7-L:7-L) .NE. ' ') THEN NQ2(8-L:8-L) = NQ2(7-L:7-L) NQ2(7-L:7-L) = '_' GOTO 200 ENDIF 190 CONTINUE ENDIF GOTO 270 ENDIF CALL PLA047 (XNQNR, NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) NAMS(I, 1) = ' '//NQ1 GOTO 210 200 CONTINUE GOTO 280 210 JATC(I) = NIEN 220 CONTINUE IF (N .EQ. 2) THEN I = JATC(2) NC = - NINT(CON(I, NP4)) IF (NC .LT. 0) NC = NP4 DO 240 J = 1, NC J0 = NINT(CON(I, J)) CALL PLA053 (I, J0, 0, 0, D, SD, ISD, NDEC, IER) IF (IER .EQ. 0) THEN FORMC(23:23) = CHAR(ICHAR('0') + NDEC) ISD = MIN (999, ISD) CALL PLA047 (XLAB(J0), NQ2, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) IF (MODE .EQ. 0) CALL PLA269 (1) WRITE (PRBUF, FORMC) NQ2, NQ1, D, ISD IF (MODE .EQ. 1) CALL GEN065 (LU6, PRBUF, 80, 1) IF (IGBL(63) .GT. 1) CALL GEN065 (LU7, PRBUF, 80, 1) DO 230 K = J + 1, NC IF (K .LE. NC) THEN K0 = NINT(CON(I, K)) CALL PLA053 (K0, I, J0, 0, ANG, SANG, ISANG, NDEC, 1 IER) IF (IER .EQ. 0) THEN FORMD(22:22) = CHAR(ICHAR('0') + NDEC) ISANG = MIN (999, ISANG) CALL PLA047 (XLAB(K0), NQ3, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) IF (MODE .EQ. 0) CALL PLA269 (1) WRITE (PRBUF, FORMD) NQ2, NQ1, NQ3, ANG, ISANG IF (MODE .EQ. 1) CALL GEN065 (LU6, PRBUF, 80, 1) IF (IGBL(63) .GT. 1) 1 CALL GEN065 (LU7, PRBUF, 80, 1) ENDIF ENDIF 230 CONTINUE ENDIF 240 CONTINUE ELSE IF (N .EQ. 3) THEN CALL PLA053 (JATC(2), JATC(3), 0, 0, D, SD, ISD, NDEC, IER) IF (IER .EQ. 0) THEN ISD = MIN (99, ISD) FORMB(36:36) = CHAR(ICHAR('0') + NDEC) WRITE (PRBUF, FORMB) (NAMS(I, 1)(2:8), I = 2, 3), D, ISD CALL GEN065 (LU6, PRBUF, 80, 1) IF (IGBL(63) .GT. 1) CALL PLA067 (LU7, PRBUF, 80, 1, 1) ELSE WRITE (LU6, 99995) ENDIF ELSE IF (N .EQ. 4) THEN CALL PLA053 (JATC(2), JATC(3), JATC(4), 0, ANG, SANG, 1 ISANG, NDEC, IER) IF (IER .EQ. 0) THEN ISANG = MIN (999, ISANG) FORMA(36:36) = CHAR(ICHAR('0') + NDEC) WRITE (PRBUF, FORMA) (NAMS(I, 1)(2:8), I = 2, 4), 1 ANG, ISANG CALL GEN065 (LU6, PRBUF, 80, 1) IF (IGBL(63) .GT. 1) CALL PLA067 (LU7, PRBUF, 80, 1, 1) ELSE WRITE (LU6, 99995) ENDIF ELSE IF (N .EQ. 5) THEN IF (IFL(1)(1:3) .EQ. 'ANG' .OR. IPR(341) .EQ. 5) THEN NEX = NMAX + 1 DO 250 I = 4, 6 XXO(NEX, I) = XXO(JATC(5), I) + XXO(JATC(2), I) 1 - XXO(JATC(4), I) XSD(NEX, I) = XSD(JATC(5), I) 250 CONTINUE CALL PLA053 (JATC(3), JATC(2), NEX, 0, ANG, SANG, 1 ISANG, NDEC, IER) IF (IER .EQ. 0) THEN ISANG = MIN (999, ISANG) FORML(46:46) = CHAR(ICHAR('0') + NDEC) WRITE (PRBUF, FORML) (NAMS(I, 1)(2:8), I = 2, 5), 1 ANG, ISANG CALL GEN065 (LU6, PRBUF, 80, 1) IF (IGBL(63) .GT. 1) CALL PLA067 (LU7, PRBUF, 80, 1, 1) ENDIF ELSE CALL PLA053 (JATC(2), JATC(3), JATC(4), JATC(5), 1 ANG, SANG, ISANG, NDEC, IER) IF (IER .EQ. 0) THEN ISANG = MIN (999, ISANG) FORMT(36:36) = CHAR(ICHAR('0') + NDEC) CALL PLA050 (JATC(2), JATC(3), JATC(4), 0, ANG1) CALL PLA050 (JATC(3), JATC(4), JATC(5), 0, ANG2) CALL PLA050 (JATC(2), JATC(3), 0, 0, DIS1) CALL PLA050 (JATC(3), JATC(4), 0, 0, DIS2) CALL PLA050 (JATC(4), JATC(5), 0, 0, DIS3) WRITE (PRBUF, FORMT) (NAMS(I, 1)(2:8), I = 2, 5), 1 ANG, ISANG CALL GEN065 (LU6, PRBUF, 80, 1) WRITE (LU6, 99996) ANG1, ANG2, DIS1, DIS2, DIS3 IF (IGBL(63) .GT. 1) THEN CALL PLA067 (LU7, PRBUF, 80, 1, 1) CALL PLA269 (2) WRITE (LU7, 99996) ANG1, ANG2, DIS1, DIS2, DIS3 ENDIF ENDIF ENDIF ELSE GOTO 280 ENDIF ENDIF 260 IF (MODE .EQ. 1) THEN IF (IFL(1)(1:3) .EQ. 'DIS' .OR. IFL(1)(1:3) .EQ. 'ANG' 1 .OR. IFL(1)(1:3) .EQ. 'TOR' .OR. IPR(341) .NE. 0) THEN IF (IPR(2) .NE. 0) THEN PRBUF = 'Label Error : '//IFL(I) IPR(2) = 0 WRITE (LU6, 99999) PRBUF(1:50) ENDIF IF (IGBL(25) * IGBL(32) .EQ. 1) THEN IGBL(23) = - IABS(IGBL(23)) SBCD = PRBUF(1:60)//CHAR(0) ENDIF ENDIF ENDIF RETURN 270 IPR(2) = 3 GOTO 260 280 IPR(2) = 7 GOTO 260 99999 FORMAT (A) 99998 FORMAT (/, ':: Not Enough Atoms to Fit on', /) 99997 FORMAT ('Selected Geometrical Data', /, 132('=')/) 99996 FORMAT ('ANGLE', 6X, F9.2, F10.2, /, 'BOND', 2X, 3(F10.4)) 99995 FORMAT (':: Input Error, Try again') 99994 FORMAT (/, ':: Fit for RESD =', I3, 1 ' and RESD =', I3, ' [N(fit) =', I3, ']') 99993 FORMAT (/, ':: Residues contain unequal number of atoms, nofit') 99991 FORMAT (2X, 'Atom', 12X, 'Distance', 8X, 'x', 7X, 1 'y', 7X, 'z', 6X, 'X', 7X, 'Y', 7X, 'Z') 99990 FORMAT ('The equation of the plane is of the form:', 1 ' P * x + Q * y + R * z - S = 0') 99989 FORMAT ('where P, Q, R, S are constants and x, y, z', 1 ' are fractional coordinates.') 99988 FORMAT (/, A) 99987 FORMAT (1X) 99986 FORMAT (//) 99985 FORMAT (2X, A, 20X, 6F8.4) END SUBROUTINE PLA036 (IAT, KB, NA, IDS, MNUM, ISPOS, IPAR, IALIAS) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP19=31,NP22=256,NP25=99,NP29=63,NP41=200,NP47=9) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 CHARACTER NQ*7 I = IABS(IAT) IF (IAT .GT. 0) THEN XLABI = XLAB(I) ELSE XLABI = - XLAB(I) ENDIF CALL GEN048 (-1, IFG(I), 6, ISPOS) CALL GEN048 (-7, JFG(I), 1, IDS) IDS = IPPR(IDS + 1, 1) IF (IDS .EQ. 1000) THEN NAMDIS = ICHAR(' ') ELSE IF (IDS .GT. 500) THEN NAMDIS = ICHAR('>') ELSE IF (IDS .EQ. 500) THEN NAMDIS = ICHAR('*') ELSE NAMDIS = ICHAR('<') ENDIF CALL PLA047 (XLABI, NQ, MNUM, JDUM, IPAR, IALIAS, 0, 1 - IALIAS) NAMS(KB, NA) = CHAR(NAMDIS)//NQ RETURN END SUBROUTINE PLA037 (K, N, M) PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP17=99, 1 NP22=256,NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) NQ3 = IFL(K) IF (NQ3(3:3) .EQ. ' ') THEN DO 20 I = 1, 26 IF (NQ3(1:1) .EQ. CHAR(ICHAR('A') + I - 1)) THEN N = I * 100 IF (NQ3(2:2) .EQ. ' ') GOTO 30 DO 10 J = 1, 26 IF (NQ3(2:2) .EQ. CHAR(ICHAR('A') + J - 1)) THEN N = N + J GOTO 30 ENDIF 10 CONTINUE GOTO 50 ENDIF 20 CONTINUE 30 DO 40 J = 1, IAN IF (N .EQ. IEL(IEN(J))) THEN N = J GOTO 70 ENDIF 40 CONTINUE ENDIF 50 N = 0 CALL PLA046 (M, NQ3, IENM, LBB, LBC, LBD, 1 XNQNR, YNQNR, NIEN) IF (NIEN .LT. 0) THEN IPR(2) = 3 ELSE N = - NIEN ENDIF 70 RETURN END SUBROUTINE PLA038 (IAT, JAT, IFIN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /PL38/ IENI, KI, IMET, JMET, LABI, NC, IATNRI, IXX, NAT C * SUBROUTINE GENERATES SEQUENCE OF UNIQUE BONDS (IAT, JAT) C * INITIALIZED BY IFIN = -3, -2, -1 ; END SIGNAL WITH IFIN = 1 ON RETURN IF (IFIN .EQ. 0) THEN GOTO 40 ELSE IF (IFIN .EQ. -3) THEN NAT = IPR(39) IXX = 0 ELSE IF (IFIN .EQ. -2) THEN NAT = IPR(39) IXX = 1 ELSE NAT = IPR(37) IXX = 0 ENDIF IFIN = 0 IAT = 0 IMET = 0 JMET = 0 IENI = 0 10 IAT = IAT + 1 IF (IAT .GT. NAT) THEN IFIN = 1 GOTO 90 ENDIF CALL GEN048 (-1, IFG(IAT), 7, IHA) IF (IHA .EQ. 1) GOTO 10 CALL GEN048 (-1, IFG(IAT), 19, IMET) CALL PLA047 (XLAB(IAT), NQ1, IDUM, IENI, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) IF (IXX .EQ. 0) THEN IATNRI = IATNR(IENI) LABI = NINT(XLAB(IAT)) / IPR(463) ENDIF NC = - NINT(CON(IAT, NP4)) IF (NC .EQ. 0) THEN GOTO 10 ELSE IF (NC .LT. 0) THEN NC = NP4 CALL GEN048 (-1, IFG(IAT), 8, IVAL) IF (IVAL .GT. 0) NC = NC + IPR(76) ENDIF KI = 0 40 KI = KI + 1 IF (KI .GT. NC) GOTO 10 IF (KI .LE. NP4) THEN JAT = NINT(CON(IAT, KI)) ELSE IF (IBON(KI - NP4, 1) .EQ. IAT) THEN JAT = IBON(KI - NP4, 2) ELSE GOTO 40 ENDIF ENDIF IF (IPR(133) .GE. 0) THEN CALL GEN048 (-1, IFG(JAT), 7, IHA) IF (IHA .NE. IPR(133)) GOTO 40 ENDIF CALL PLA047 (XLAB(JAT), NQ2, IDUM, IENJ, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) CALL GEN048 (-1, IFG(JAT), 19, JMET) IF (IMET .EQ. 1 .AND. IENJ .EQ. 2 .OR. 1 JMET .EQ. 1 .AND. IENI .EQ. 2) THEN NDIST = 0 IF (IENJ .EQ. 2) THEN NCJ = - NINT(CON(JAT, NP4)) DO 50 KJ = 1, NCJ KAT = NINT(CON(JAT, KJ)) CALL GEN048 (-4, IFG(KAT), 15, NEL) NEL = IEN(NEL + 1) IF (NEL .EQ. 3) THEN CALL PLA050 (IAT, KAT, 0, 0, DIST) IF (IENI .GT. 0) THEN IF (DIST .LT. REL(IENI) + 1.10) NDIST = NDIST + 1 ENDIF ENDIF 50 CONTINUE IF (NDIST .GE. 2) GOTO 40 ELSE NCI = - NINT(CON(IAT, NP4)) DO 60 K = 1, NCI KAT = NINT(CON(IAT, K)) CALL GEN048 (-4, IFG(KAT), 15, NEL) NEL = IEN(NEL + 1) IF (NEL .EQ. 3) THEN CALL PLA050 (JAT, KAT, 0, 0, DIST) IF (DIST .LT. REL(IENJ) + 1.20) NDIST = NDIST + 1 ENDIF 60 CONTINUE IF (NDIST .GE. 2) GOTO 40 ENDIF ENDIF IF (IXX .EQ. 0) THEN JUNK = IATNRI - IATNR(IENJ) IF (JUNK .LT. 0) THEN GOTO 40 ELSE IF (JUNK .EQ. 0) THEN LABJ = NINT(XLAB(JAT)) / IPR(463) IF (LABI .GT. LABJ) GOTO 40 ENDIF ENDIF 90 RETURN END SUBROUTINE PLA039 (IAT, JAT, KAT, NRSD, A, SA, ISA, ND, KB, IFIN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /PL39/ NAT, NC, KI, KJ, IHI, IHJ, IHK IF (IFIN .EQ. 0) THEN GOTO 50 ELSE IF (IFIN .EQ. -1) THEN NAT = IPR(37) ENDIF IFIN = 0 JAT = 0 10 JAT = JAT + 1 IF (JAT .GT. NAT) THEN IFIN = 1 GOTO 250 ENDIF CALL GEN048 (-1, IFG(JAT), 7, IHJ) IF (IHJ .EQ. 1) GOTO 10 CALL GEN048 (-6, IFG(JAT), 9, IRESJ) IF (IRESJ .NE. NRSD) GOTO 10 NC = - NINT(CON(JAT, NP4)) IF (NC .LT. 0) THEN NC = NP4 CALL GEN048 (-1, IFG(JAT), 8, IVAL) IF (IVAL .GT. 0) NC = NC + IPR(76) ENDIF IF (NC .LE. 1) GOTO 10 KI = 0 40 KI = KI + 1 IF (KI .GE. NC) GOTO 10 IF (KI .LE. NP4) THEN IAT = NINT(CON(JAT, KI)) ELSE IF (IBON(KI - NP4, 1) .NE. JAT) GOTO 40 IAT = IBON(KI - NP4, 2) ENDIF KJ = KI CALL GEN048 (-1, IFG(IAT), 7, IHI) 50 KJ = KJ + 1 IF (KJ .GT. NC) GOTO 40 IF (KJ .LE. NP4) THEN KAT = NINT(CON(JAT, KJ)) ELSE IF (IBON(KJ - NP4, 1) .NE. JAT) GOTO 50 KAT = IBON(KJ - NP4, 2) ENDIF CALL GEN048 (-1, IFG(KAT), 7, IHK) IHA = IHI + IHJ + IHK IF (IPR(133) .EQ. 0) THEN IF (IHA .GT. 0) GOTO 50 ELSE IF (IHA .EQ. 0) GOTO 50 ENDIF KB1 = KB + 1 CALL PLA036 (IAT, KB1, 1, IDS1, MNUM1, ISP1, IPR(119), IGBL(55)) CALL PLA036 (JAT, KB1, 2, IDS2, MNUM2, ISP2, IPR(119), IGBL(55)) CALL PLA036 (KAT, KB1, 3, IDS3, MNUM3, ISP3, IPR(119), IGBL(55)) IF (IDS1 .LT. 1000 .AND. IDS3 .LT. 1000) THEN IF (IDS1 .NE. IDS3) GOTO 50 IF (IDS2 .LT. 1000) THEN IF (IDS1 .NE. IDS2 .OR. IDS2 .NE. IDS3) GOTO 50 ENDIF ENDIF CALL PLA053 (IAT, JAT, KAT, 0, A, SA, ISA, ND, IER) IF (IER .NE. 0) GOTO 50 IF (ISP2 .EQ. 1 .AND. MNUM3 .GT. 1) THEN CALL PLA050 (IAT, JAT, KAT, 0, A1) IF (ABS(A1) .GT. 179.9) THEN A = 180.0 SA = 0.0 ENDIF ENDIF 250 RETURN END SUBROUTINE PLA040 (MODE, MD1, MD2, MD3, MD4) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /PL40/ LHNT(4, 3, 5), NETH(64, 3), MXL DIMENSION KVEC(4) IF (IPR(17) .LT. 0) THEN NRX = 0 ELSE NRX = IPR(75) ENDIF IF (MODE .LT. 0) THEN MXL = 0 ELSE IF (MODE .EQ. 0) THEN IF (MXL .GT. 0) THEN IPRINT = 0 N = -1 10 N = N + 1 IF (N .GT. NRX) GOTO 70 DO 60 L = 1, MXL IF (NETH(L, 1) .EQ. N) THEN IF (IGBL(63) .GT. 2) CALL PLA269 (2) IF (NETH(L, 2) .EQ. 1) THEN WRITE (LU6, 99995) NETH(L, 1), 1 (LHNT(1, J, L), J = 1, 3) IF (IGBL(63) .GT. 2) THEN IPRINT = IPRINT + 1 IF (IPRINT .EQ. 1) THEN IF (IPR(51) .GT. 1) THEN WRITE (LU7, 99990) CALL PLA269 (2) ENDIF CALL PLA269 (2) WRITE (LU7, 99991) ENDIF WRITE (LU7, 99999) NETH(L, 1), 1 (LHNT(1, J, L), J = 1, 3) CALL PLA269 (1) ENDIF ELSE IF (NETH(L, 2) .EQ. 2) THEN LHNT(3, 1, L) = LHNT(1, 2, L) * LHNT(2, 3, L) 1 - LHNT(1, 3, L) * LHNT(2, 2, L) LHNT(3, 2, L) = LHNT(1, 3, L) * LHNT(2, 1, L) 1 - LHNT(1, 1, L) * LHNT(2, 3, L) LHNT(3, 3, L) = LHNT(1, 1, L) * LHNT(2, 2, L) 1 - LHNT(1, 2, L) * LHNT(2, 1, L) DO 40 I = 1, 3 IVL = LHNT(3, I, L) IF (IVL .NE. 0) THEN DO 20 J = 1, 3 IVL1 = LHNT(3, J, L) / IVL IF (IVL1 * IVL .NE. LHNT(3, J, L)) GOTO 40 20 CONTINUE DO 30 J = 1, 3 LHNT(3, J, L) = LHNT(3, J, L) / IVL 30 CONTINUE GOTO 50 ENDIF 40 CONTINUE 50 WRITE (LU6, 99994) NETH(L, 1), 1 (I, (LHNT(I, J, L), J = 1, 3), I = 1, 2), 2 (LHNT(3, J, L), J = 1, 3) IF (IGBL(63) .GT. 2) THEN IPRINT = IPRINT + 1 IF (IPRINT .EQ. 1) THEN IF (IPR(51) .GT. 1) THEN WRITE (LU7, 99990) CALL PLA269 (2) ENDIF CALL PLA269 (2) WRITE (LU7, 99991) ENDIF WRITE (LU7, 99998) NETH(L, 1), 1 (I, (LHNT(I, J, L), J = 1, 3), I = 1, 2), 2 (LHNT(3, J, L), J = 1, 3) CALL PLA269 (1) ENDIF ELSE IF (NETH(L, 2) .EQ. 3) THEN WRITE (LU6, 99993) NETH(L, 1), NETH(L, 3), 1 (I, (LHNT(I, J, L), J = 1, 3), I = 1, 3) IF (IGBL(63) .GT. 2) THEN IPRINT = IPRINT + 1 IF (IPRINT .EQ. 1) THEN IF (IPR(51) .GT. 1) THEN WRITE (LU7, 99990) CALL PLA269 (2) ENDIF CALL PLA269 (2) WRITE (LU7, 99991) ENDIF WRITE (LU7, 99997) NETH(L, 1), NETH(L, 3), 1 (I, (LHNT(I, J, L), J = 1, 3), I = 1, 3) CALL PLA269 (1) ENDIF ENDIF IF (IPR(17) .EQ. 0) THEN IPR(322) = MXL ELSE IF (IPR(17) .LT. 0) THEN ENDIF NETH(L, 2) = 0 NETH(L, 3) = 0 ENDIF 60 CONTINUE GOTO 10 70 CONTINUE ENDIF ELSE IF (MXL .GT. 0) THEN DO 80 L = 1, MXL IF (NETH(L, 1) .EQ. MD4) GOTO 90 80 CONTINUE ENDIF IF (MXL .LT. 5) THEN MXL = MXL + 1 ELSE WRITE (LU6, 99996) GOTO 260 ENDIF NETH(MXL, 1) = MD4 NETH(MXL, 2) = 0 NETH(MXL, 3) = 99999 L = MXL 90 K1 = MD1 K2 = MD2 K3 = MD3 IF (K1 .EQ. 0) THEN GOTO 120 ELSE IF (K1 .GT. 0) THEN GOTO 130 ENDIF K1 = - K1 100 K2 = - K2 110 K3 = - K3 GOTO 130 120 IF (K2 .LT. 0) THEN GOTO 100 ELSE IF (K2 .GT. 0) THEN GOTO 130 ENDIF IF (K3 .LT. 0) GOTO 110 130 LHNT(NETH(L, 2) + 1, 1, L) = K1 LHNT(NETH(L, 2) + 1, 2, L) = K2 LHNT(NETH(L, 2) + 1, 3, L) = K3 NDIM = NETH(L, 2) IF (NDIM .EQ. 2) THEN DO 150 I = 1, 3 IF (LHNT(1, I, L) .EQ. 1) THEN N = LHNT(2, I, L) IF (N .NE. 0) THEN DO 140 J = 1, 3 LHNT(2, J, L) = LHNT(2, J, L) - N * LHNT(1, J, L) 140 CONTINUE GOTO 160 ENDIF ENDIF 150 CONTINUE 160 CONTINUE ENDIF IF (NETH(L, 2) .EQ. 1) THEN IF ((LHNT(1, 1, L) * LHNT(2, 2, L) - 1 LHNT(2, 1, L) * LHNT(1, 2, L) .EQ. 0) .AND. 2 (LHNT(1, 1, L) * LHNT(2, 3, L) - 3 LHNT(2, 1, L) * LHNT(1, 3, L) .EQ. 0) .AND. 4 (LHNT(1, 2, L) * LHNT(2, 3, L) - 5 LHNT(2, 2, L) * LHNT(1, 3, L) .EQ. 0)) THEN IF ((IABS(LHNT(2, 1, L)) + IABS(LHNT(2, 2, L)) + 1 IABS(LHNT(2, 3, L))) .LT. 2 (IABS(LHNT(1, 1, L)) + IABS(LHNT(1, 2, L)) + 3 IABS(LHNT(1, 3, L)))) THEN DO 170 K = 1, 3 LHNT(1, K, L) = LHNT(2, K, L) 170 CONTINUE ENDIF GOTO 260 ENDIF ELSE IF (NETH(L, 2) .EQ. 2) THEN CALL PLA058 (1, 2, 3, L, IDET) NETH(L, 3) = IDET IF (NETH(L, 3) .EQ. 0) GOTO 260 ELSE IF (NETH(L, 2) .EQ. 3) THEN IF (NETH(L, 3) .GT. 1) THEN CALL PLA058 (1, 2, 4, L, IDET) IF (IDET .GT. 0 .AND. IDET .LT. NETH(L, 3)) THEN NETH(L, 3) = IDET DO 180 K = 1, 3 LHNT(3, K, L) = LHNT(4, K, L) 180 CONTINUE GOTO 260 ENDIF CALL PLA058 (1, 3, 4, L, IDET) IF (IDET .GT. 0 .AND. IDET .LT. NETH(L, 3)) THEN NETH(L, 3) = IDET DO 190 K = 1, 3 LHNT(2, K, L) = LHNT(4, K, L) 190 CONTINUE GOTO 260 ENDIF CALL PLA058 (2, 3, 4, L, IDET) IF (IDET .GT. 0 .AND. IDET .LT. NETH(L, 3)) THEN NETH(L, 3) = IDET DO 200 K = 1, 3 LHNT(1, K, L) = LHNT(4, K, L) 200 CONTINUE GOTO 260 ENDIF ENDIF GOTO 260 ENDIF NETH(L, 2) = NETH(L, 2) + 1 NRDIM = NETH(L, 2) IF (NRDIM .GT. 1) THEN 210 DO 230 K = 1, NRDIM KVEC(K) = 0 DO 220 I = 1, 3 KVEC(K) = KVEC(K) + 10**(3 - I) * LHNT(K, I, L) 220 CONTINUE N = IABS(KVEC(K)) IF (N .EQ. 1 .OR. N .EQ. 10 .OR. N .EQ. 100) THEN IF (KVEC(K) .LT. 0) THEN LHNT(K, 1, L) = IABS(LHNT(K, 1, L)) LHNT(K, 2, L) = IABS(LHNT(K, 2, L)) LHNT(K, 3, L) = IABS(LHNT(K, 3, L)) GOTO 210 ENDIF ENDIF 230 CONTINUE DO 250 I = 1, NRDIM N = KVEC(I) IF (N .EQ. 1) THEN K = 3 ELSE IF (N .EQ. 10) THEN K = 2 ELSE IF (N .EQ. 100) THEN K = 1 ELSE GOTO 250 ENDIF DO 240 J = 1, NRDIM IF (J .NE. I) THEN IF (LHNT(J, K, L) .NE. 0) THEN LHNT(J, K, L) = 0 GOTO 210 ENDIF ENDIF 240 CONTINUE 250 CONTINUE ENDIF ENDIF 260 RETURN 99999 FORMAT (/,':: Resd #', I2, 1 ' - Infinite One-Dimensional Chain :: Base Vector: [', 2 3I3, ']') 99998 FORMAT (/,':: Resd #', I2, 1 ' - Infinite Two-Dimensional Network :: Base Vectors', 1 ':', 2(' #', I1, ' = [', 3I3, '], '), ' - Plane: (', 3I3, ')') 99997 FORMAT (/,':: Resd #', I2, 1 ' - Infinite Three-Dimensional Framework :: Det =', 2 I2, ', Base Vectors: ', 3(' #', I1, ' =[', 3I3, '], ')) 99996 FORMAT (/, ':: Maximum number of Polymeric Residues Exceeded') 99995 FORMAT (/, ':: Resd #', I2, ' - Infinite One-Dimensional Chain', 1 /, ':: Base Vector: ', 3I3) 99994 FORMAT (/, ':: Resd #', I2, 1 ' - Infinite Two-Dimensional Network', /, 2 ':: Base Vectors: ', 2(I5, ' : [', 3I3, '], '), 3 ' Plane: (', 3I3, ')') 99993 FORMAT (/, ':: Resd #', I2, 1 ' - Infinite Three-Dimensional Framework : Det =', 2 I2, /, ':: Base Vectors: ', 3(I5, ' : ', 3I3, ' , ')) 99991 FORMAT (/, ':: Analysis of Polymeric Structure(s)') 99990 FORMAT (/, ':: Starred ARUs belong (chemically) to the ', 1 'previous ARU') END SUBROUTINE PLA041 (MODE, I, J, IVAL) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) IF (MODE .LT. 0) THEN NC = - NINT(CON(I, NP4)) IF (NC .EQ. 0) THEN GOTO 30 ELSE IF (NC .GT. 0) THEN GOTO 10 ENDIF NC = NP4 CALL GEN048 (-1, IFG(I), 8, IVL) IF (IVL .GT. 0) NC = NC + IPR(76) 10 DO 20 L = 1, NC IF (L .GT. NP4) THEN IF (IBON(L - NP4, 1) .NE. I) GOTO 20 IF (IBON(L - NP4, 2) .EQ. IVAL) GOTO 40 ELSE IF (NINT(CON(I, L)) .EQ. IVAL) GOTO 40 ENDIF 20 CONTINUE 30 J = 0 GOTO 60 40 J = L ELSE IF (MODE .EQ. 0) THEN DO 50 K = I, J CON(K, NP4) = IVAL 50 CONTINUE ELSE J = 0 IPR(147) = IPR(147) + 1 IF (CON(I, NP4) .GT. 0) THEN CALL GEN048 (1, IFG(I), 8, 1) IF (IPR(76) .NE. IPR(96)) THEN IPR(76) = IPR(76) + 1 IBON(IPR(76), 1) = I IBON(IPR(76), 2) = IVAL J = NP4 + IPR(76) ENDIF ELSE CON(I, NP4) = CON(I, NP4) - 1 J = - NINT(CON(I, NP4)) CON(I, J) = IVAL ENDIF ENDIF 60 RETURN END SUBROUTINE PLA042 (MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER FCELA*120, FCELB*89, FCELC*89, FCELV*94 COMMON /TODAY/ DATIJD CHARACTER DATIJD*25 FCELA( 1: 38) = '( ''a ='',F9.4,''('',I3,'') Angstrom'',16X,' FCELA( 39: 75) = '''alpha ='',F9.3,''('',I3,'') Degree'',13X,' FCELA( 76:106) = '''a ='',F9.3,5X,''alpha ='',F8.2,' FCELA(107:120) = ''' V ='',F8.1)' FCELB( 1: 28) = '( ''b ='',F9.4,''('',I3,'')'',26X,' FCELB( 29: 58) = ''' beta ='',F9.3,''('',I3,'')'',20X,' FCELB( 59: 89) = '''b ='',F9.3,5X,''beta ='',F8.2)' FCELC( 1: 28) = '( ''c ='',F9.4,''('',I3,'')'',26X,' FCELC( 29: 58) = '''gamma ='',F9.3,''('',I3,'')'',20X,' FCELC( 59: 89) = '''c ='',F9.3,5X,''gamma ='',F8.2)' FCELV( 1: 40) = '( ''V ='',F9.2,''('',I3,'') Cubic-Angstrom'',' FCELV( 41: 63) = '9X,''d(100) ='',F12.4,3X,' FCELV( 64: 94) = '''Angstrom'',24X,''Niggli Values'')' IF (MODE .NE. 2) THEN IF (SPGRNM(1)(12:12) .EQ. 'a') THEN IF (ABS(PAR(101) - PAR(123)) .GT. 0.01 .OR. 1 ABS(PAR(102) - PAR(124)) .GT. 0.01 .OR. 2 ABS(PAR(103) - PAR(125)) .GT. 0.01 .OR. 3 ABS(PAR(104) - PAR(126)) .GT. 0.1 .OR. 4 ABS(PAR(105) - PAR(127)) .GT. 0.1 .OR. 5 ABS(PAR(106) - PAR(128)) .GT. 0.1) 6 WRITE (LU20, 99992) '_155 1 1' ENDIF ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-5) WRITE (LU7, 99999) IGBL(9), JID(1:71), DATIJD(5:24) ENDIF IF (IPR(23) .NE. 0) THEN WRITE (LU6, 99995) PAR(11) ELSE IF (SPGRNM(1)(8:11) .EQ. ' ') THEN II = ICHAR(' ') ELSE II = ICHAR('.') ENDIF WRITE (LU6, 99998) JID(1:70), (PAR(100 + I), I = 1, 6), PAR(98), 1 SPGRNM(1)(1:7), CHAR(II), SPGRNM(1)(8:11), CHSG IPR(83) = 34 IF (IGBL(63) .GT. 2) THEN WRITE (LU7, 99993) SPGRNM(1)(13:13), MAX (0, IPR(310)) FCELA(12 : 12) = CHAR(ICHAR('0') + IPR(287)) FCELA(52 : 52) = CHAR(ICHAR('0') + IPR(290)) WRITE (PRBUF, FCELA) PAR(101), IPR(281), PAR(104), IPR(284), 1 PAR(123), PAR(126), PAR(99) CALL GEN065 (LU7, PRBUF, 132, 3) FCELB(12 : 12) = CHAR(ICHAR('0') + IPR(288)) FCELB(42 : 42) = CHAR(ICHAR('0') + IPR(291)) WRITE (PRBUF, FCELB) PAR(102), IPR(282), PAR(105), IPR(285), 1 PAR(124), PAR(127) CALL GEN065 (LU7, PRBUF, 132, 3) FCELC(12 : 12) = CHAR(ICHAR('0') + IPR(289)) FCELC(42 : 42) = CHAR(ICHAR('0') + IPR(292)) WRITE (PRBUF, FCELC) PAR(103), IPR(283), PAR(106), IPR(286), 1 PAR(125), PAR(128) CALL GEN065 (LU7, PRBUF, 132, 3) WRITE (LU7, 99991) FCELV(12 : 12) = CHAR(ICHAR('0') + IPR(294)) WRITE (PRBUF, FCELV) PAR(98), IPR(293), 1.0 / PAR(113) CALL GEN065 (LU7, PRBUF, 132, 3) WAVL = MAX (0.0, PAR(17)) WRITE (LU7, 99990) 1.0 / PAR(114), (PAR(150 + J), J = 1, 3), 1 KRAD, WAVL, 1.0 / PAR(115), (PAR(150 + J), J = 4, 6) CALL PLA269 (1) WRITE (LU7, 99997) WRITE (LU7, 99994) WRITE (PRBUF, 99989) (OR(1, J), J = 1, 3), 1 (ROR(1, K), K = 1, 3) CALL GEN065 (LU7, PRBUF, 132, 2) WRITE (PRBUF, 99988) (OR(2, J), J = 1, 3), 1 (ROR(2, K), K = 1, 3) CALL GEN065 (LU7, PRBUF, 132, 2) WRITE (PRBUF, 99987) (OR(3, J), J = 1, 3), 1 (ROR(3, K), K = 1, 3) CALL GEN065 (LU7, PRBUF, 132, 2) IF (MODE .GT. 0) THEN WRITE (LU7, 99996) IF (SPGRNM(1)(1:1) .NE. ' ') THEN NRXX = 0 IF (INDEX (SPGRNM(1)(1:11), ':') .NE. 0) THEN WRITE (ICL, '(''SPGR '', A, 64X)') SPGRNM(1)(1:11) ELSE WRITE (ICL, '(''SPGR '' , A, 63X)') 1 SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11) IF (SPGRNM(1)(13:13) .NE. ' ') ICL(13:13) = '.' ENDIF CALL SGSM (ICL, NRXX, XJX, LU6, 0, IERR) ENDIF CALL SGSM (ICL, 0, XJX, LU7, 2, IERR) ENDIF ENDIF IPPR(1, 3) = IPR(48) ENDIF RETURN 99999 FORMAT ('PLATON(V-', I6, ')-Run for: ', A, 9X, 'TIME: ', A, /, 1 132('='), /, 110X, '(C) 1980-2006 A.L.Spek') 99998 FORMAT (/, ':: TITL ', A, /, 1 ':: CELL ', 3F10.4, 3F10.3, F10.1, /, 2 ':: SPGR ', 3A, 2X, A) 99997 FORMAT (48X, 26('=')/, 47('='), ' Orthogonalization Matrices ', 1 57('='), /, 48X, 26('=')) 99996 FORMAT (/, 50X, 20('='), /, 49('='), ' Space Group Symmetry ', 1 61('='), /, 50X, 20('='), //, '(See e.g. G. Burns & A.M. ', 2 'Glazer, Space Groups for Solid State Scientists, ', 3 'Academic Press, 1990 or Int. Tables A)', /) 99995 FORMAT (':: Angstrom Coordinate Data Scale = ', F10.4, /) 99994 FORMAT (/, '(See e.g. J.D.Dunitz, Xray Analysis and Structure', 1 ' Determination of Organic Molecules, Cornell Univ. Press,', 2 ' 1979, P236)', /) 99993 FORMAT (55X, 12('='), /, 54('='), ' Crystal Data ', 64('='), /, 1 55X, 12('=') / 24X, 'Input Cell', 2X, '(Lattice Type: ', A1,')', 2 3X, '- Temp =', I4, 'K', 13X, 'Reduced Cell', 5X, 3 '(Acta Cryst.(1976),A32,297-298)', /, 81('-'), 3X, 48('-')) 99992 FORMAT (A) 99991 FORMAT (1X) 99990 FORMAT (42X, 'd(010) =', F12.4, 26X, 3F10.3, /, 1 'Lambda(', A, ') =', F10.5, ' Angstrom', 9X, 2 'd(001) =', F12.4, 26X, 3F10.3, /) 99989 FORMAT ('(XO) (', 3F10.5, ' ) (X) , (X) (', 3F10.5, 1 ' ) (XO)', 5X, ' Orthogonal Axes AO, BO and CO') 99988 FORMAT ('(YO) = (', 3F10.5, ' )*(Y) , (Y) = (', 3F10.5, 1 ' )*(YO)', 13X, 'are defined as:') 99987 FORMAT ('(ZO) (', 3F10.5, ' ) (Z) , (Z) (', 3F10.5, 1 ' ) (ZO)', 5X, 'AO // A, CO // C*, BO // CO X AO') END SUBROUTINE PLA043 (MODE, ITYPE, LU, NWIN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 CHARACTER ILTR*3, FORMA*53 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 FORMA(1:40) = '( A, ''['',F9.2,'' ] = '',A,'' = [ '',5I3,' FORMA(41:53) = ''' ] '',3F11.3)' IHOR = -1 IF (IWIN .EQ. 1) THEN IF (NWIN .EQ. 1) CALL GGIP (HORS, VERT, 0.0, 1) IF (ITYPE .NE. 0) VRT = VERT - 0.6 ENDIF IF (ITYPE .EQ. 0) THEN FORMA(14:14) = '7' FORMA(16:16) = '0' ELSE IF (PAR(42) .LT. 100.0) FORMA(16:16) = '1' ENDIF IF (MODE .GE. 0) THEN NMOL = IPR(13) IF (NMOL .GT. 1) THEN NPRNT = 0 DO 30 I = 1, NMOL IF (ITYPE .EQ. 0) THEN IF (MP(I) .EQ. 0) GOTO 30 ENDIF ML = MOL(I) IF (ML .NE. 0) THEN XML = ML / PAR(42) IF (I .GT. 1 .AND. ITYPE .LE. 0) THEN XML = INT(XML) DO 10 J = 1, I - 1 IF (MP(J) .EQ. 1) THEN YML = INT (MOL(J) / PAR(42)) IF (XML .EQ. YML) GOTO 30 ENDIF 10 CONTINUE ENDIF CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRS0) IF (IRS0 .GT. 0)THEN IF (MOL1 .GT. IPR(48)) THEN IF (I .EQ. (IPR(13) - IPR(101) + 1) .AND. 1 IGBL(63) .GT. 2) THEN IF (LU .EQ. LU7) CALL PLA269 (4) WRITE (LU, 99996) ENDIF MOL1 = MOL1 - IPR(48) ILTR = '* =' XML = XML - IPR(48) * 1000 ENDIF IF (I .GT. 1) THEN IF (IPR(17) .EQ. 0 .OR. ITYPE .LT. 0) THEN IF (I .LE. 27) THEN ILTR = CHAR(ICHAR('a') + I - 2)//' =' ELSE ILTR = '* =' ENDIF ELSE ILTR = ' ' ENDIF XJX(4) = MOL2 XJX(5) = MOL3 XJX(6) = MOL4 CALL SGSM (ICL, MOL1, XJX, 0, 20, IERR) DO 20 K = 1, 3 XJX(K) = XXO(NP1 + 1 - IRS0, K) 20 CONTINUE CALL SGSM (ICL, MOL1, XJX, LU, 3, IERR) IF (IGBL(63) .GT. 2) THEN IF (NPRNT .EQ. 0 .AND. LU .GT. 0) THEN IF (ITYPE .EQ. 1) THEN IF (LU .EQ. LU7) CALL PLA269 (7) WRITE (LU, 99998) ELSE IF (ITYPE .EQ. 0) THEN IF (LU .EQ. LU7) CALL PLA269 (3) WRITE (LU, 99997) ENDIF NPRNT = 1 ENDIF ENDIF IF (IGBL(63) .GT. 2 .OR. LU .NE. LU7) THEN CALL GEN020 (-1, ICL, 1, 33) WRITE (PRBUF, FORMA) ILTR, XML, ICL(1:33), 1 MOL1, MOL2, MOL3, MOL4, IRS0, (XJX(K), K = 7, 9) CALL GEN065 (0, PRBUF, 132, 7) IF (LU .EQ. LU7) CALL PLA269 (1) IF (ITYPE .EQ. 1) THEN WRITE (LU, 99995) PRBUF ELSE IF (LU .GT. 0) THEN WRITE (LU, 99995) PRBUF(1:50) IF (IWIN .EQ. 1 .AND. ITYPE .NE. 0) THEN VRT = VRT - 0.45 CALL GGIP20 (0.0, PRBUF, 50, 0.30, 1 5 + IGBL(68), 2, 1.0, VRT) ENDIF ELSE IF (IWIN .EQ. 1) THEN IHOR = MOD(IHOR + 1, 3) IF (IHOR .EQ. 0) VRT = VRT - 0.45 HOR = IHOR * HORS / 3 - 0.5 CALL GGIP20 (0.0, PRBUF, 50, 0.28, 1, 2, 1 HOR, VRT) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF 30 CONTINUE IF (ITYPE .EQ. 1 .AND. IGBL(63) .GT. 2) THEN IF (LU .EQ. LU7) CALL PLA269 (7) WRITE (LU, 99999) ENDIF IF (MODE .NE. 0) CALL PLA040 (0, 0, 0, 0, 0) ENDIF ENDIF RETURN 99999 FORMAT (/, 'Note: Symmetry Operations Refer to the Coordinates ', 1 'listed in the Fractional Coordinate Table given above', 2 //, 65X, 'SYM', 9X, '- Number of the Symmetry Operator.', 3 /, 'X(J) = X(sym) + TX , Y(J) = Y(sym) + TY , ', 4 'Z(J) = Z(sym) + TZ,', 4X, 'Ires', 8X, '- Residue Number.', /, 5 65X, 'TX, TY, TZ - Unit Cell Translations.') 99998 FORMAT (/, 42X, 'Asymmetric Residue Unit (= ARU) Code List', /, 1 42X, 41('='), //, 5X, 'ARU-CODE', 6X, 'Symmetry-Code', 26X, 2 'sym TX TY TZ', ' Ires', 5X, 'x(cen)', 5X, 'y(cen)', 5X, 3 'z(cen)', /, 132('-')) 99997 FORMAT (/, 'Translation of ARU-code to Equivalent Position ', 1 'Code', /, 51('=')) 99996 FORMAT (/, 37X, 'Detected and Excluded Disorder Asymmetric ', 1 'Residue Units', /, 37X, 55('='), /) 99995 FORMAT (A) END SUBROUTINE PLA044 (R, IAT, XR, YR, ZR, SX, SY, SZ, SC, SXY) DIMENSION R(3, 3) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) IF (IAT .LT. 0) THEN N = - IAT XOR = XLS(1, N) * XLS(4, N) YOR = XLS(2, N) * XLS(4, N) ZOR = XLS(3, N) * XLS(4, N) ELSE XOR = XXO(IAT, 4) YOR = XXO(IAT, 5) ZOR = XXO(IAT, 6) ENDIF XR = SC * (R(1, 1) * XOR + R(1, 2) * YOR + R(1,3) * ZOR -SX) + SXY YR = SC * (R(2, 1) * XOR + R(2, 2) * YOR + R(2,3) * ZOR -SY) + SXY ZR = SC * (R(3, 1) * XOR + R(3, 2) * YOR + R(3,3) * ZOR -SZ) + SXY RETURN END SUBROUTINE PLA045 (NTYP) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 IF (IPR(52) .LT. NP2) THEN NMAX = IPR(39) IPR52 = IPR(52) CALL PLA054 (0) DO 10 I = 1, 4 XLS(I, IPR52 + 1) = XPV(I) 10 CONTINUE IF (NTYP .EQ. 1) THEN IF (IPR52 .GT. 0) THEN DO 30 J = 1, IPR52 DMIN = 0 DO 20 K = 1, 4 DMIN = DMIN + ABS(XLS(K, IPR52 + 1) - XLS(K, J)) 20 CONTINUE IF (DMIN .LT. 0.00001) GOTO 50 30 CONTINUE ENDIF ENDIF CALL GEN022 (IATP, 1, NMAX) IPR(52) = IPR(52) + 1 IF (NTYP .EQ. 3) THEN CALL GEN004 (ROR, DUMV, ORRES) CALL GEN003 (ORRES, RMAT, DET, 0) ENDIF CALL GEN005 (DUMV, RMAT) DO 40 K = 1, 3 TEMP = RMAT(1, K) RMAT(1, K) = - RMAT(3, K) RMAT(3, K) = TEMP 40 CONTINUE IF (NTYP .EQ. 2) THEN IPR(69) = IPR(69) + 1 IF (IPR(12) .GT. 4 .AND. IPR(12) .LT. 8) THEN IYUNK = 2 * (IPR(12) - 5) IPR(496) = IPR(496) + 10 ** IYUNK ENDIF ENDIF WRITE (LU8) NTYP, IPR(12), JR, RMAT WRITE (LU8) (IATP(L4), L4 = 1, IPR(39)) ENDIF 50 RETURN END SUBROUTINE PLA046 (MODUS, NQ, IENM, LBB, LBC, LBD, XNQNR, YNQNR, 1 NIEN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP36=1000,NP38=125,NP39=30,NP41=200,NP45=2048, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 CHARACTER NQ*7, ICH*1, NQJ*2 COMMON /ALIASES/ ALAB(NP36), BLAB(NP36) CHARACTER ALAB*7, BLAB*7 III = 0 NAT = 0 MODE = MODUS MODX = 0 IF (MODUS .GT. 98) THEN MODE = MODUS - 100 MODX = 1 ENDIF IF (MODE .NE. -1) THEN IF (MODE .EQ. -2) THEN N = 0 MODE = 2 ELSE N = INDEX (NQ, '_') IF (N .LT. 5) THEN M = INDEX (NQ(N +1: 7), '_') N = N + M ENDIF IF (N .LT. 7) THEN IF (N .NE. 0) THEN ICH = NQ(N+1:N+1) DO 10 I = 1, 10 IF (ICH .EQ. CHAR(ICHAR('0') + I - 1)) THEN N = 0 GOTO 20 ENDIF 10 CONTINUE NQJ = NQ(N:N+1) NQ(N:) = ' ' ENDIF ELSE NIEN = -15 GOTO 140 ENDIF ENDIF 20 IF (IGBL(71) .GT. 0) THEN DO 30 I = 1, IGBL(71) IF (NQ .EQ. ALAB(I)) THEN IF (N .EQ. 0) THEN NQ = BLAB(I) ELSE M = INDEX (BLAB(I), ' ') NQ = BLAB(I)(1:M-1)//NQJ ENDIF GOTO 50 ENDIF 30 CONTINUE ENDIF IF (N .NE. 0) NQ(N:) = NQJ ENDIF IF (MODX .EQ. 1 .AND. IABS(IGBL(8)) .EQ. 3) THEN KL = IPR(220) IF (KL .EQ. 3) THEN IF (IFL(3)(2:2) .EQ. ' ') THEN N = 1 ELSE N = 2 ENDIF IF (NQ(1:N) .NE. IFL(3)(1:N)) GOTO 40 IF (N .EQ. 1) THEN IF (ICHAR(NQ(2:2)) .GE. 65 .AND. ICHAR(NQ(2:2)) .LE. 90) 1 GOTO 40 ENDIF ENDIF IF (NQ(1:2) .EQ. 'HO' .AND. IPR(435) .EQ. 0) THEN GOTO 40 ELSE IF (NQ(1:2) .EQ. 'HN') THEN GOTO 40 ELSE IF (NQ(2:2) .EQ. '0') THEN GOTO 40 ELSE IF (NQ(2:3) .EQ. '00') THEN GOTO 40 ENDIF GOTO 50 40 IF (KL .EQ. 3) THEN IF (IFL(3)(1:2) .NE. 'HO') THEN NIEN = -8 GOTO 140 ELSE IPR(435) = 1 ENDIF ENDIF ENDIF 50 LBA = 0 LBC = 0 NR = 0 NCH = 0 ITEL = 0 NIEN = 0 XNQNR = 0.0 YNQNR = 0.0 IF (MODE .EQ. 8) THEN LBB = -1 LBD = 27 ELSE LBB = 0 LBD = 0 ENDIF LEV = 1 NB = 1 NE = 7 CALL GEN039 (1, NQ, 1, 7, NB, NE) DO 80 I = 1, NE ICH = NQ(I : I) IF (ICH .EQ. '*') THEN NIEN = -14 GOTO 140 ELSE IF (ICH .EQ. CHAR(92)) THEN NIEN = -10 GOTO 140 ELSE IF (ICH .EQ. '(') THEN LBB = 0 LEV = 2 ELSE IF (ICH .EQ. ')') THEN LEV = 4 ELSE IF (ICH .EQ. '_') THEN IF (MODE .NE. 0) THEN LEV = 4 ELSE NIEN = -11 GOTO 140 ENDIF ELSE IF (ICH .EQ. '''') THEN IF (LBC .EQ. 0) THEN LBC = 1 LEV = 3 ELSE NIEN = -9 GOTO 140 ENDIF ELSE IF (ICH .EQ. '"') THEN IF (LBC .EQ. 0) THEN LBC = 2 LEV = 3 ELSE NIEN = -9 GOTO 140 ENDIF ELSE IF (ICH .EQ. '#') THEN IF (MODE .GT. 0) THEN LBC = 3 LEV = 3 ELSE GOTO 90 ENDIF ELSE DO 60 J = 1, 26 IF (ICH .EQ. CHAR(ICHAR('A') + J - 1) .OR. 1 ICH .EQ. CHAR(ICHAR('a') + J - 1)) THEN IF (LEV .EQ. 1) THEN NR = NR + 1 IF (NR .EQ. 1) THEN NQJ = ' '//CHAR(ICHAR('A') + J - 1) LBA = J * 100 ELSE IF (NR .EQ. 2) THEN NQJ(1:1) = NQJ(2:2) NQJ(2:2) = CHAR(ICHAR('a') + J - 1) LBA = LBA + J ELSE LBA = -1 GOTO 90 ENDIF GOTO 80 ELSE IF (LEV .EQ. 2) THEN IF (NCH .EQ. 0 .AND. LBC .EQ. 0 .AND. 1 IGBL(61) .EQ. 0) THEN NCH = NCH + 1 LBC = 3 + J LEV = 3 ELSE NIEN = -8 GOTO 140 ENDIF ELSE IF (LEV .EQ. 3) THEN NIEN = -8 GOTO 140 ELSE IF (MODE .LE. 0) THEN GOTO 90 ELSE LBD = J GOTO 80 ENDIF ENDIF ENDIF 60 CONTINUE DO 70 J = 1, 10 IF (ICH .EQ. CHAR(ICHAR('0') + J - 1)) THEN IF (LEV .LE. 2) THEN IF (MODE .EQ. 8 .AND. LBB .EQ. -1) LBB = 0 LBB = LBB * 10 + J - 1 IF (LBB .EQ. 0) THEN NIEN = -13 NQ(I:) = ' ' GOTO 140 ENDIF ITEL = ITEL + 1 LEV = 2 GOTO 80 ELSE NIEN = -8 GOTO 140 ENDIF ENDIF 70 CONTINUE ENDIF 80 CONTINUE 90 ITEL = ITEL + NR IF (LBC .GT. 0) ITEL = ITEL + 1 IENM = 0 IF (IAN .GT. 0) THEN DO 100 I = 1, IAN IF (LBA .EQ. IEL(IEN(I))) THEN IENM = I GOTO 120 ENDIF 100 CONTINUE ENDIF DO 110 III = 1, NP9 IF (LBA .EQ. IEL(III)) GOTO 120 110 CONTINUE III = 0 120 IF (MODE .EQ. 8) THEN IF (IENM .GT. 0) GOTO 140 IF (III .GE. NP9 - 3 .AND. III .LE. NP9) IENM = III ELSE IF (MODE .LT. 8) THEN IF (IENM .EQ. 0) THEN IF (IABS(IGBL(8)) .NE. 2 .OR. NQJ .EQ. 'Cg' .OR. 1 NQJ .EQ. ' Q') THEN IF (III .GT. 0) THEN IAN = IAN + 1 IF (IAN .GT. NP10) THEN NIEN = -2 GOTO 140 ENDIF IEN(IAN) = III JJ = IABS(IATPR(III)) LMT(IAN, 2) = JTP(JJ) LMT(IAN, 1) = NQJ RADR(IAN, 3) = REL(III) RADR(IAN, 4) = ABS(VDWR(III)) IF (III .EQ. 3) THEN IACL(IAN) = 2 ELSE IF (III .EQ. 4) THEN IACL(IAN) = 4 ELSE IF (IATPR(III) .EQ. -7) THEN IACL(IAN) = 3 ELSE IF (III .GT. 2) THEN IF (ICLR .LT. 8) ICLR = ICLR + 1 IACL(IAN) = ICLR ENDIF IENM = IAN ENDIF ELSE NIEN = -3 GOTO 140 ENDIF ENDIF IF (IENM .LE. 0) THEN NIEN = -5 GOTO 140 ENDIF IF (MODE .LT. 0 .OR. (MODE .EQ. 0 .AND. ITEL .GT. 4)) THEN LBC = 3 ITEL = 3 IF (MOD(LBA, 100) .NE. 0) ITEL = ITEL + 1 IF (IGBL(71) .GE. NP36) THEN NIEN = -7 ELSE IGBL(71) = IGBL(71) + 1 ENDIF IENLB(IENM) = IENLB(IENM) + 1 LBB = IENLB(IENM) IF (LBB .GT. 10) ITEL = ITEL + 1 IF (LBB .GT. 99 .AND. IGBL(61) .EQ. 0) THEN NIEN = -12 GOTO 140 ENDIF IF (ITEL .GT. 4) IPR(119) = 0 ENDIF YNQNR = (120 - IATNR(IEN(IENM))) * 40000 + LBB * 40 + LBC IF (IGBL(61) .EQ. 0) THEN IF (LBC .GT. 0) LBC = LBC + 10 IF (LBB .GE. 10 ** (3 - NR) .AND. LBC .EQ. 0) THEN LBB1 = LBB / 10 LBC = LBB - LBB1 * 10 + 1 LBB = LBB1 ENDIF NQX = LBB * 40 + LBC ELSE NQX = LBB * 4 + LBC ENDIF IF (LBD .GE. 128) THEN NIEN = -6 GOTO 140 ENDIF XNQNR = FLOAT(IENM * 512000 + NQX * 128 + LBD) IF (MODE .GT. 1) THEN IF (MODE .EQ. 2) THEN NAT = IPR(37) ELSE IF (MODE .EQ. 3) THEN NAT = IPR(39) ELSE IF (MODE .EQ. 4) THEN NAT = IPR(39) + IPR(64) ENDIF DO 130 I = 1, NAT IF (NINT(XNQNR) .EQ. NINT(XLAB(I))) THEN NIEN = I GOTO 140 ENDIF 130 CONTINUE NIEN = - 4 ELSE NIEN = IENM - 1 ENDIF C * PLUTON PACK MODE ELSE IF (MODE .EQ. 9 .OR. MODE .EQ. 10) THEN IF (IENM .EQ. 0) THEN IF (III .EQ. 0) THEN NIEN = -1 GOTO 140 ELSE IAN = IAN + 1 IF (IAN .GT. NP10) THEN NIEN = -2 GOTO 140 ENDIF RADR(IAN, 3) = REL(III) RADR(IAN, 4) = ABS(VDWR(III)) IEN(IAN) = III IENM = IAN ENDIF ENDIF IF (ITEL .GT. 4 .OR. MODE .EQ. 10) THEN LBC = 3 IENLB(IENM) = IENLB(IENM) + 1 LBB = IENLB(IENM) ENDIF NQX = LBB * 32 + LBC XNQNR = (IENM - 1) * 32000 + NQX YNQNR = (120 - IATNR(IEN(IENM))) * 32000 + NQX ENDIF 140 RETURN END SUBROUTINE PLA047 (XL, NQ, MN, IENR, IPAR, IALIAS, IPDB, IMU) PARAMETER (NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,NP36=1000, 1 NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /ALIASES/ ALAB(NP36), BLAB(NP36) CHARACTER ALAB*7, BLAB*7 DIMENSION NUM(3) CHARACTER NQ*(*), NQ1*9, NQ2*9, NQ3*9 K = 0 JPAR = IPAR IF (IGBL(71) .GT. 0 .AND. IALIAS .EQ. 0 .AND. JPAR .EQ. 1) 1 JPAR = 0 NQ = ' ' NQ3 = ' ' IENR = 0 MN = 0 JX3 = NINT(ABS(XL)) IF (JX3 .GT. 0) THEN JX1 = JX3 / 512000 JX3 = MOD(JX3, 512000) JX2 = JX3 / 128 JX3 = MOD(JX3, 128) IF (IGBL(61) .EQ. 0) THEN JX4 = MOD(JX2, 40) JX2 = JX2 / 40 IF (JX4 .GT. 0 .AND. JX4 .LT. 11) THEN JX2 = JX2 * 10 + JX4 - 1 JX4 = 0 ELSE JX4 = JX4 - 10 ENDIF ELSE JX4 = MOD(JX2, 4) JX2 = JX2 / 4 ENDIF MN = JX3 + 1 IF (JX2 .EQ. 0) JPAR = MIN (JPAR, 0) IF (XL .LT. 0) JX3 = 0 IENR = IEN(JX1) JX1 = IEL(IENR) J1 = JX1 / 100 J2 = MOD(JX1, 100) K = 1 IF (IPDB .EQ. 1 .AND. J2 .EQ. 0) K = 2 NQ3(K : K) = CHAR(ICHAR('A') + J1 - 1) K = K + 1 IF (J2 .GT. 0) THEN IF (IPDB .LE. 0) THEN NQ3(K : K) = CHAR(ICHAR('a') + J2 - 1) ELSE NQ3(K : K) = CHAR(ICHAR('A') + J2 - 1) ENDIF K = K + 1 ENDIF IF (JPAR .GT. 0) THEN NQ3(K : K) = '(' K = K + 1 ENDIF J2 = JX2 / 10 NUM(3) = MOD(JX2, 10) NUM(1) = J2 / 10 NUM(2) = MOD(J2, 10) J2 = 0 DO 10 J = 1, 3 IF (NUM(J) .GT. 0 .OR. J2 .GT. 0) THEN NQ3(K : K) = CHAR(ICHAR('0') + NUM(J)) K = K + 1 J2 = J2 + 1 ENDIF 10 CONTINUE IF (JX4 .GT. 0) THEN IF (JX4 .EQ. 1) THEN NQ3(K : K) = '''' ELSE IF (JX4 .EQ. 2) THEN NQ3(K : K) = '"' ELSE IF (JX4 .EQ. 3) THEN NQ3(K : K) = '#' ELSE IF (JX4 .GT. 3) THEN NQ3(K : K) = CHAR(ICHAR('A') + JX4 - 4) ENDIF K = K + 1 ENDIF IF (JPAR .GT. 0) THEN NQ3(K : K) = ')' K = K + 1 ENDIF IF (JX3 .GT. 0) THEN IF (JPAR .EQ. 0) THEN NQ3(K : K) = '_' K = K + 1 ENDIF IF (JX3 .LT. 27) THEN NQ3(K : K) = CHAR(ICHAR('a') + JX3 - 1) ELSE NQ3(K : K) = '*' ENDIF K = K + 1 ENDIF NQ3(K : K) = ' ' ENDIF IF (K .GT. 1 .AND. IGBL(71) .GT. 0 .AND. IALIAS .EQ. 0) THEN NQ1 = NQ3(1 : K) K0 = K IF (JX3 .GT. 0) THEN K0 = K0 - 1 NQ3(K0:K0) = ' ' IF (JPAR .EQ. 0) K0 = K0 - 1 NQ3(K0:K0) = ' ' ENDIF DO 20 I = 1, IGBL(71) IF (IPR(501) .EQ. 0) THEN N = INDEX (BLAB(I), '#') ELSE N = INDEX (BLAB(I), ' ') ENDIF IF (N .GT. 0) THEN IF (NQ3(1:N) .EQ. BLAB(I)(1:N)) THEN M = INDEX (ALAB(I), ' ') - 1 IF (IMU .EQ. 0) THEN IF (INDEX (ALAB(I), '_') .NE. 0) GOTO 30 ENDIF IF (M .LT. 1 .OR. M .GT. (7 + K0 - K)) GOTO 30 NQ2 = ALAB(I)(1:M)//NQ1(K0:K) CALL GEN020 (2, NQ3, 1, 2) IF (NQ2(1:2) .EQ. NQ3(1:2)) NQ2(1:2) = BLAB(I)(1:2) NQ3 = NQ2(1:7) GOTO 40 ENDIF ENDIF 20 CONTINUE 30 NQ3 = NQ1 ENDIF 40 NQ = NQ3(1:7) RETURN END SUBROUTINE PLA048 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 DIMENSION B(3, 3), C(3, 3), XXX(12), ICSD(6), UVIJ(3) CHARACTER FORMI*119, FORMJ*116, FORMK*75 FORMI( 1:31) = '(A ,F10.6,''('',I4,'')'',' FORMI(32:68) = 'F10.6,''('',I4,'')'',F10.6,''('',I4,'')'',7X,' FORMI(69:119) = FORMI(15:64)//')' FORMJ(1:30) = '(A,''-'',A,''['',I2,''] -> '',A,''['',' FORMJ(31:69) = 'F9.2,'']'',F7.3,''('',I3,'') '',3F7.4, F9.4,' FORMJ(70:95) = 'F7.3,F7.2,F8.2,''('',I3,'')'',' FORMJ(96:116) = 'F8.4,''('',I3,'')'',F7.0)' FORMK(1:33) = '(A,''['',I2,''] -> '',A,''['',F9.2,'']'',' FORMK(34:75) = 'F7.4,''('',I3,'') '',3F7.4,F10.4,3F8.2,3F8.3)' DMIN = 0.0 ANG2M = 0.0 NTMP = 0 NPRT = 0 NSYM = IPR(48) NRING = IPR(64) NMAX = IPR(39) IRMST = 0 ISANG1 = 0 ISDIST1 = 0 ISDIST3 = 0 NDEC0 = 0 NDEC1 = 0 NDEC3 = 0 SANG1 = 0 SDIST1 = 0 SDIST3 = 0 DIST4 = 0.0 DO 210 MODE = 1, 5 CALL PLA068 (0, 0.0) IF (MODE .EQ. 1) THEN DMAX = PAR(36) DMIN = 2.5 ELSE IF (MODE .EQ. 2) THEN DMAX = PAR(69) DMIN = 2.0 ANG2M = 45.0 ELSE IF (MODE .EQ. 3) THEN DMAX = 3.0 DMIN = 1.5 ELSE IF (MODE .EQ. 4) THEN DMAX = PAR(263) DMIN = 2.0 ANG3M = PAR(264) ELSE IF (MODE .EQ. 5) THEN DMAX = PAR(447) DMIN = 2.5 ANG3M = PAR(448) ENDIF DO 10 I = 1, 3 V3(I) = DMAX * PAR(112 + I) 10 CONTINUE IF (MODE .GT. 2) THEN NBEG = 1 NEND = IPR(37) NTMP = 0 NPRT = 0 ELSE NBEG = NMAX + 1 NEND = NMAX + NRING ENDIF NR = 0 DO 200 N = NBEG, NEND NEWTMP = NMAX + NRING CALL GEN048 (-1, IFG(N), 19, MET) CALL GEN048 (-1, IFG(N), 7, NHAT) IF (MODE .EQ. 3) THEN IF (MET .EQ. 0) GOTO 200 NTMP = 0 ELSE IF (MODE .EQ. 4) THEN IF (NHAT .EQ. 0) GOTO 200 NTMP = 0 ELSE IF (MODE .EQ. 5) THEN IF (NINT(CON(N, NP4)) .NE. -1 .OR. 1 MET .NE. 0 .OR. NHAT .NE. 0) GOTO 200 NTMP = 0 ENDIF CALL GEN048 (-6, IFG(N), 9, IRES) CALL PLA047 (XLAB(N), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) IF (MODE .EQ. 2) THEN JBEG = 1 JEND = IPR(37) ELSE JBEG = NMAX + 1 JEND = NMAX + NRING ENDIF DO 140 J = JBEG, JEND IF (MODE .EQ. 2) THEN CALL GEN048 (-1, IFG(J), 19, MET) IF (MET .EQ. 0) GOTO 140 ENDIF CALL GEN048 (-6, IFG(J), 9, JRES) DO 130 NSM = 1, NSYM IF (J .EQ. N .AND. NSM .EQ. 1) GOTO 130 DO 20 K0 = 1, 3 XXX(K0) = XXO(J, K0) XXX(K0 + 3) = 0.0 V4(K0) = 0.0 20 CONTINUE NS = NSM CALL SGSM (LINE, NS, XXX, 6, 3, IERR) IF (MODE .EQ. 3 .AND. NSM .EQ. 1) THEN K = 3 GOTO 60 ELSE K = 1 ENDIF 30 IF ((XXO(N, K) - XXX(6 + K)) .GT. V3(K)) GOTO 50 XXX(6 + K) = XXX(6 + K) - 1.0 V4(K) = V4(K) - 1.0 GOTO 30 40 K = K - 1 50 XXX(6 + K) = XXX(6 + K) + 1.0 V4(K) = V4(K) + 1.0 IF ((XXO(N, K) - XXX(6 + K)) .GE. V3(K)) GOTO 50 IF ((XXX(6 + K) - XXO(N, K)) .LE. V3(K)) GOTO 60 K = K - 1 IF (K .GT. 0) THEN GOTO 50 ELSE GOTO 130 ENDIF 60 K = K + 1 IF (K .GT. 3) THEN DO 70 L = 1, 3 V5(L) = XXX(6 + L) - XXO(N, L) 70 CONTINUE CALL GEN002 (1, OR, V5, V6, DUM) CALL GEN002 (2, OR, V5, DXI, DIST1) IF (IATP(N) .LE. 0) THEN WRITE (LU6, 99993) IATP(N) GOTO 240 ENDIF IF (DIST1 .LT. DMAX .AND. DIST1 .GT. DMIN) THEN NEWTMP = NEWTMP + 1 IF (NEWTMP .EQ. 0) GOTO 40 IPR(54) = NS DO 80 III = 1, 3 ITR(III) = NINT(V4(III)) 80 CONTINUE CALL PLA059 (J, NEWTMP) IFG(NEWTMP) = IFG(J) JFG(NEWTMP) = JFG(J) IF (MODE .LT. 3) THEN NPL = IPR(19) + IATP(N) IF (NPL .GT. NP2) THEN WRITE (LU6, 99993) IATP(N) GOTO 240 ENDIF DIST3 = ABS(XLS(1, NPL) * XXO(NEWTMP, 4) 1 + XLS(2, NPL) * XXO(NEWTMP, 5) 2 + XLS(3, NPL) * XXO(NEWTMP, 6) 3 - XLS(4, NPL)) ENDIF IF (MODE .EQ. 3) THEN IF (IATP(J) .GT. 0) THEN NPL = IPR(19) + IATP(J) IF (NPL .GT. NP2) THEN WRITE (LU6, 99993) IATP(J) GOTO 240 ENDIF DIST3 = ABS(XLS(1, NPL) * XXO(N, 4) 1 + XLS(2, NPL) * XXO(N, 5) 2 + XLS(3, NPL) * XXO(N, 6) 3 - XLS(4, NPL)) IF (ABS(DIST3) .LT. DMIN) THEN NEWTMP = NEWTMP -1 GOTO 140 ENDIF ENDIF ENDIF ARUJ = NS * 1000.0 + V4(1) * 100 + V4(2) * 10 + V4(3) 1 + 555 + JRES / PAR(42) CALL PLA047 (XLAB(J), NQ2, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) XLAB(NEWTMP) = XLAB(J) IF (MODE .LT. 3) THEN NPL = IPR(19) + IATP(N) V8(1) = XLS(1, NPL) V8(2) = XLS(2, NPL) V8(3) = XLS(3, NPL) ANG2 = GEN027 (V8, DXI, GL(5)) IF (ANG2 .GT. 90.0) ANG2 = 180.0 - ANG2 ENDIF IF (MODE .EQ. 1 .OR. MODE .EQ. 4 1 .OR. MODE .EQ. 5) THEN IF (IATP(J) .LE. 0 .OR. IATP(J) .GT. NP2) THEN WRITE (LU6, 99993) IATP(J) GOTO 240 ENDIF NPL = IPR(19) + IATP(J) V5(1) = XLS(1, NPL) V5(2) = XLS(2, NPL) V5(3) = XLS(3, NPL) V1(4) = XLS(4, NPL) CALL SGSM (LINE, NS, XJS, 6, 6, IERR) K0 = 0 DO 100 I1 = 1, 3 V2(I1) = V4(I1) + XJS(I1 + 9) DO 90 J1 = 1, 3 K0 = K0 + 1 UIJ(I1, J1) = XJS(K0) 90 CONTINUE 100 CONTINUE CALL GEN005 (OR, B) CALL GEN004 (UIJ, B, C) CALL GEN005 (ROR, B) CALL GEN004 (B, C, UIJ) CALL GEN002 (1, UIJ, V5, V1, DUM) CALL GEN002 (-1, OR, V1, V6, DUM) V1(4) = V1(4) + GEN009(V6, V2) ANG3 = GEN027 (V1, DXI, GL(5)) IF (ANG3 .GT. 90.0) ANG3 = 180.0 - ANG3 DIST2 = ABS(XXO(N, 4) * V1(1) + XXO(N, 5) * V1(2) 1 + XXO(N, 6) * V1(3) - V1(4)) ANG1 = GEN027 (V8, V1, GL(5)) IF (ANG1 .GT. 90.0) ANG1 = 180.0 - ANG1 IF (MODE .EQ. 1) THEN IF (ANG2 .LT. PAR(62)) THEN NR = NR + 1 IF (NR .EQ. 1) THEN CALL PLA269 (-14) WRITE (LU7, 99999) PAR(36), PAR(62) CALL GEN074 (DUMA, 99999.0, 1, 6) DUMA(4) = 0.0 ENDIF CALL PLA053 (N, NEWTMP, 0, 0, DIST1, SDIST1, 1 ISDIST1, NDEC1, IER) IF (IER .NE. 0) DIST1 = 0.0 FORMK(37:37) = CHAR(ICHAR('0') + NDEC1) IF (ANG1 .LT. 0.05) THEN DIST4 = DIST1 * SIN (ANG2 / GL(5)) WRITE (PRBUF, FORMK) NQ1, IRES, NQ2, ARUJ, 1 DIST1, ISDIST1, (V1(L), L = 1, 4), ANG1, 2 ANG2, ANG3, DIST2, DIST3, DIST4 ELSE WRITE (PRBUF, FORMK) NQ1, IRES, NQ2, ARUJ, 1 DIST1, ISDIST1, (V1(L), L = 1, 4), ANG1, 2 ANG2, ANG3, DIST2, DIST3 ENDIF CALL PLA067 (LU7, PRBUF, 132, 1, 3) CALL PLA068 (1, ARUJ) DUMA(1) = MIN (DUMA(1), DIST1) DUMA(2) = MIN (DUMA(2), ANG1) DUMA(3) = MIN (DUMA(3), ANG2) DUMA(4) = MAX (DUMA(4), ANG3) DUMA(5) = MIN (DUMA(5), DIST2) DUMA(6) = MIN (DUMA(6), DIST3) ENDIF ELSE IF (ANG3 .LT. ANG3M) THEN IF (NINT(CON(N, NP4)) .EQ. -1) THEN I = NINT(CON(N, 1)) CALL PLA047 (XLAB(I), NQ3, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) CALL PLA227 (I, N, UVIJ) ANG4 = GEN027 (V1, UVIJ, GL(5)) IF (ANG4 .GT. 90.0) ANG4 = 180.0 - ANG4 ANG4 = 90.0 - ANG4 IF (MODE .EQ. 4) ANG4 = NINT(ANG4) CALL PLA053 (I, N, NEWTMP, 0, ANG1, SANG1, 1 ISANG1, NDEC0, IER) IF (IER .NE. 0) ANG1 = 0 IF (ISANG1 .EQ. 0) THEN NDEC0 = 0 ANG1 = NINT (ANG1) ENDIF FORMJ(83:83) = CHAR(ICHAR('0') + NDEC0) CALL PLA053 (N, NEWTMP, 0, 0, DIST1, SDIST1, 1 ISDIST1, NDEC1, IER) IF (IER .NE. 0) DIST1 = 0.0 FORMJ(43:43) = CHAR(ICHAR('0') + NDEC1) CALL PLA053 (I, NEWTMP, 0, 0, DIST3, SDIST3, 1 ISDIST3, NDEC3, IER) IF (IER .NE. 0) DIST3 = 0.0 FORMJ(99:99) = CHAR(ICHAR('0') + NDEC3) NR = NR + 1 IF (NR .EQ. 1) THEN CALL PLA269 (-6) IF (MODE .EQ. 4) THEN WRITE (LU7, 99992) DMAX, ANG3M ELSE WRITE (LU7, 99987) DMAX, ANG3M ENDIF CALL GEN074 (DUMA, 99999.0, 1, 5) DUMA(4) = 0.0 DUMA(6) = 0.0 ENDIF IF (MODE .EQ. 5) THEN FORMJ(112:115) = 'F7.2' WRITE (PRBUF, FORMJ) NQ3, NQ1, IRES, NQ2, 1 ARUJ, DIST1, ISDIST1, (V1(L), L = 1, 4), 2 DIST2, ANG3, ANG1, ISANG1, DIST3, ISDIST3, 3 ANG4 ELSE FORMJ(112:115) = 'I7 ' WRITE (PRBUF, FORMJ) NQ3, NQ1, IRES, NQ2, 1 ARUJ, DIST1, ISDIST1, (V1(L), L = 1, 4), 2 DIST2, ANG3, ANG1, ISANG1, DIST3, ISDIST3, 3 NINT(ANG4) ENDIF CALL PLA067 (LU7, PRBUF, 132, 1, 3) CALL PLA068 (1, ARUJ) DUMA(1) = MIN (DUMA(1), DIST1) DUMA(2) = MIN (DUMA(2), DIST2) DUMA(5) = MIN (DUMA(5), DIST3) DUMA(3) = MIN (DUMA(3), ANG3) DUMA(4) = MAX (DUMA(4), ANG1) DUMA(6) = MAX (DUMA(6), ANG4) ENDIF ENDIF ENDIF ELSE IF (MODE .EQ. 2) THEN IF (ANG2 .LT. ANG2M) THEN NR = NR + 1 IF (NR .EQ. 1) THEN CALL PLA269 (8) WRITE (LU7, 99997) DMAX ENDIF CALL PLA269 (1) WRITE (LU7, 99996) NQ1, IRES, NQ2, ARUJ, DIST1, 1 DIST3, ANG2 CALL PLA068 (1, ARUJ) ENDIF ELSE IF (MODE .EQ. 3) THEN IF (NTMP .LT. NP4 - 1) THEN NTMP = NTMP + 1 IATC(NTMP) = NEWTMP ELSE IRMST = IRMST + 1 ENDIF ENDIF ENDIF GOTO 40 ENDIF GOTO 30 130 CONTINUE 140 CONTINUE IF (MODE .EQ. 3) THEN IF (NTMP .GT. 0) THEN DO 150 I = 1, NP4 DATC(I) = CON(N, I) 150 CONTINUE NC = - NINT (CON(N, NP4)) IF (NC .LT. 0) THEN NC = NP4 CALL GEN048 (-1, IFG(N), 8, IVAL) IF (IVAL .GT. 0) NC = NC + IPR(76) ENDIF DO 160 I = 1, NTMP CON(N, I) = IATC(I) 160 CONTINUE NTMPC = NTMP DO 180 I = 1, NC IF (I .LE. NP4) THEN K = NINT(DATC(I)) ELSE IF (IBON(I - NP4, 1) .NE. N) GOTO 180 K = IBON(I - NP4, 2) ENDIF DO 170 L = 1, NTMPC CALL PLA050 (IATC(L), K, 0, 0, DIST2) IF (DIST2 .LT. 1.5) GOTO 180 170 CONTINUE IF (NTMP .LT. NP4 - 1) THEN NTMP = NTMP + 1 CON(N, NTMP) = K ELSE IRMST = IRMST + 1 ENDIF 180 CONTINUE CON(N, NP4) = - NTMP IF (NPRT .EQ. 0) THEN CALL PLA269 (0) NPRT = 1 CALL PLA269 (3) WRITE (LU7, 99995) ENDIF IPR(81) = 2 IFL(2) = NQ1 CALL PLA035 (0) DO 190 I = 1, NP4 CON(N, I) = DATC(I) 190 CONTINUE ENDIF ENDIF 200 CONTINUE IF (MODE .EQ. 1 .AND. NR .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99989) (DUMA(L), L = 1, 6) ELSE IF ((MODE .EQ. 4 .OR. MODE .EQ. 5) .AND. NR .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99990) (DUMA(L), L = 1, 6) ENDIF CALL PLA068 (-1, 0.0) 210 CONTINUE CALL PLA269 (5) WRITE (LU7, 99988) DO 230 I = NMAX + 1, NMAX + NRING CALL PLA269 (1) DO 220 K = 1, 3 YUNK = SQRT(XSD(I, K)) CALL GEN041 (XXO(I, K), YUNK, ICSD(K), IPR(183), 1 NDEC, IPR(68)) NDC = K * 17 + 2 YUNK = SQRT(XSD(I, K + 3)) CALL GEN041 (XXO(I, K + 3), YUNK, ICSD(K + 3), 5, NDECJ, 1 IPR(68)) NDCJ = K * 17 + 56 FORMI(NDC:NDC) = CHAR(ICHAR('0') + NDEC) FORMI(NDCJ:NDCJ) = CHAR(ICHAR('0') + NDECJ) ICSD(K) = MIN (99, ICSD(K)) ICSD(K + 3) = MIN (99, ICSD(K + 3)) 220 CONTINUE CALL PLA047 (XLAB(I), NQ2, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) WRITE (PRBUF, FORMI) NQ2(1:6), (XXO(I, K), ICSD(K), K = 1, 6) CALL PLA067 (LU7, PRBUF, 132, 1, 3) 230 CONTINUE IF (IRMST .GT. 0) THEN WRITE (LU6, 99994) WRITE (LU7, 99994) ENDIF 240 RETURN 99999 FORMAT ('Analysis of Short Ring-Interactions with ', 1 'Cg-Cg Distances < ', F5.1, ' Angstrom and Beta <', F5.1, 2 ' Deg.', /, 132('='), /, 3 '- Cg(I) = Plane number I (= ring number in () above)', /, 4 '- Alpha = Dihedral Angle between Planes I and J (Deg)', /, 5 '- Beta = Angle Cg(I)-->Cg(J) or Cg(I)-->Me vector and', 6 ' normal to plane I (Deg)', /, 7 '- Gamma = Angle Cg(I)-->Cg(J) vector and normal to', 8 ' plane J (Deg)', /, 9 '- Cg-Cg = Distance between ring Centroids (Ang.)', /, * '- CgI_Perp = Perpendicular distance of Cg(I) on', 1 ' ring J (Ang.)', /, 2 '- CgJ_Perp = Perpendicular distance of Cg(J) on', 3 ' ring I (Ang.)', /, 4 '- Slippage = Distance between Cg(I) and Perpendicular', 5 ' Projection of Cg(J) on Ring I (Ang).', /, 6 '- P,Q,R,S = J-Plane Parameters for Carth. Coord.', 7 ' (Xo, Yo, Zo)', //, 'Cg(I) Res(I)', 3X, 8 'Cg(J) [', 3X, 'ARU(J)] ', 6X, 'Cg-Cg', 3X, 9 'Transformed J-Plane P, Q, R, S', 3X, 'Alpha', 4X, * 'Beta', 3X, 'Gamma', 1X, 'CgI_Perp CgJ_Perp Slippage', /) 99997 FORMAT (//, 'Ring-Metal Interactions with Cg-Me < ', F5.1, 1 ' Ang.', /, 132('='), //, 2 'Cg(I) Res(I)', 3X, 'Me(J) [', 3X, 'ARU(J)] Cg(I)-Me(J)', 3 ' MeJ_Perp Beta', /) 99996 FORMAT (A, '[', I2, '] -> ', A, ' [', F9.2, '] ', 2F10.3, F9.2) 99995 FORMAT ('Geometry around Metals Involving Ring centroids', /, 1 132('='), /) 99994 FORMAT (/, 'W: Ring-Metal Search Truncated', /) 99993 FORMAT (/, 'W: Problem - Ring-(Ring/Metal) search aborted', I5,/) 99992 FORMAT (/, 'Analysis of X-H...Cg(Pi-Ring) Interactions', 1 ' (H..Cg <', F4.1, ' Ang. - Gamma < ', F5.1, ' Deg)', /, 2 132('='), //, ' X--H(I) Res(I)', 3X, 3 'Cg(J) [', 3X, 'ARU(J)]', 7X, 'H..Cg', 2X, 4 'Transformed J-Plane P, Q, R, S H-Perp Gamma', 6X, 5 'X-H..Cg', 8X, 'X..Cg X-H,Pi', /) 99990 FORMAT (46X, 7('-'), 33X, 46('-'), /, 36X, 'Min or Max', 1 F7.3, 32X, F7.3, F7.2, 5X, F8.2, 5X, F8.3, F7.2) 99989 FORMAT (38X, 7('-'), 33X, 40('-'), /, 28X, 'Min or Max', 1 F7.3, 33X, F8.2, F8.2, F8.2, F8.3, F8.3) 99988 FORMAT (/, 'The Cg(I) refer to the Ring Centre-of-Gravity ', 1 'numbers given in () in the Ring-Analysis above', //, 2 'Cg(I)', 11X, 'x', 15X, 'y', 15X, 'z', 20X, 3 'Xo', 14X, 'Yo', 14x, 'Zo', /) 99987 FORMAT (/, 'Analysis of Y-X...Cg(Pi-Ring) Interactions', 1 ' (X..Cg <', F4.1, ' Ang. - Gamma < ', F5.1, ' Deg)', /, 2 132('='), //, ' Y--X(I) Res(I)', 3X, 3 'Cg(J) [', 3X, 'ARU(J)]', 7X, 'X..Cg', 2X, 4 'Transformed J-Plane P, Q, R, S X-Perp Gamma', 6X, 5 'Y-X..Cg', 8X, 'Y..Cg Y-X,Pi', /) END SUBROUTINE PLA049 (IFUN, D) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /DERIV/ NDIR, VIJ(3), VJK(3) DIMENSION DSV(8), VIJK(3), VIJKD(3) KM = 1 DSV(1) = D DSV(2) = XPV(1) IF (IFUN .EQ. 2) THEN CALL GEN008 (VIJ, VJK, VIJK, 0) ELSE IF (IFUN .EQ. 4) THEN DO 10 I = 1, 8 DSV(I) = XPV(I) 10 CONTINUE KM = 4 ENDIF DO 50 I = 1, NDIR ITP = IDIR(I) DO 40 J = 1, 3 ITEK = 1 SINC = SQRT(XSD(ITP, J + 3)) XXO(ITP, J + 3) = XXO(ITP, J + 3) + SINC IF (IFUN .EQ. 1) THEN CALL PLA050 (IDIR(1), IDIR(2), 0, 0, XPV(1)) ELSE IF (IFUN .EQ. 2) THEN CALL PLA050 (IDIR(1), IDIR(2), IDIR(3), 0, XPV(1)) CALL GEN008 (VIJ, VJK, VIJKD, 0) IF (GEN009 (VIJK, VIJKD) .LT. 0.0) XPV(1) = 360.0 - XPV(1) ELSE IF (IFUN .EQ. 3) THEN CALL PLA050 (IDIR(1), IDIR(2), IDIR(3), IDIR(4), XPV(1)) IF ((DSV(1) - XPV(1)) .GT. 180.0) THEN XPV(1) = XPV(1) + 360.0 ELSE IF ((DSV(1) - XPV(1)) .LT. -180.0) THEN XPV(1) = XPV(1) - 360.0 ENDIF ELSE IF (IFUN .EQ. 4) THEN CALL PLA054 (0) ITEK = NINT(GEN009(XPV, DSV)) ENDIF XXO(ITP, J + 3) = XXO(ITP, J + 3) - SINC DO 30 K = 1, KM XDIR(I, J, K) = ITEK * XPV(K) - DSV(K) 30 CONTINUE 40 CONTINUE 50 CONTINUE D = DSV(1) XPV(1) = DSV(2) IF (IFUN .EQ. 4) THEN DO 60 I = 1, 8 XPV(I) = DSV(I) 60 CONTINUE ENDIF RETURN END SUBROUTINE PLA050 (I, J, K, L, D) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /DERIV/ NDIR, VIJ(3), VJK(3) DIMENSION VKL(3), R(3), S(3), T(3) IF (I .LE. 0 .OR. J .LE. 0) GOTO 40 IF (I .GT. NP1 .OR. J .GT. NP1) GOTO 40 IF (K .EQ. 0) THEN D = 0 DO 10 KK = 1, 3 DK = XXO(I, KK + 3) - XXO(J, KK + 3) D = D + DK**2 10 CONTINUE D = SQRT(D) ELSE IF (K .GT. 0 .AND. L .EQ. 0) THEN IF (K .GT. NP1) GOTO 40 DAK = 0 DBK = 0 DAB = 0 DO 20 KK = 1, 3 VIJ(KK) = XXO(I, KK + 3) - XXO(J, KK + 3) VJK(KK) = XXO(K, KK + 3) - XXO(J, KK + 3) DAK = DAK + VIJ(KK)**2 DBK = DBK + VJK(KK)**2 DAB = DAB + VIJ(KK)*VJK(KK) 20 CONTINUE IF (DAK .LE. 0.0 .OR. DBK .LE. 0.0) THEN D = 0 ELSE C = DAB / SQRT(DAK * DBK) C = MAX (-1.0, MIN (1.0, C)) D = ACOS(C) * GL(5) ENDIF ELSE IF (L .GT. 0) THEN IF (L .GT. NP1) GOTO 40 DO 30 N = 1, 3 VIJ(N) = XXO(J, N + 3) - XXO(I, N + 3) VJK(N) = XXO(K, N + 3) - XXO(J, N + 3) VKL(N) = XXO(L, N + 3) - XXO(K, N + 3) 30 CONTINUE CALL GEN008 (VIJ, VJK, R, 1) CALL GEN008 (VJK, VKL, S, 1) CALL GEN008 (R, S, T, 1) D = MAX (-1.0, MIN (1.0, GEN009(R, S))) D = ACOS(D) * GL(5) IF (GEN009 (VJK, T) .LT. 0.0) D = - D ELSE GOTO 40 ENDIF RETURN 40 WRITE (LU6, 99999) I, J, K, L WRITE (LU7, 99999) I, J, K, L RETURN 99999 FORMAT (/, 'F: Invalid arg(s) in call to PLA050 ', 4I10, /) END SUBROUTINE PLA051 (IAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /DERIV/ NDIR, VIJ(3), VJK(3) NDIR = NDIR + 1 IDIR(NDIR) = IAT DO 20 I = 1, 3 DO 10 J = 1, 4 XDIR(NDIR, I, J) = 0.0 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE PLA052 (IFUN, SD) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /DERIV/ NDIR, VIJ(3), VJK(3) DIMENSION SD(*) IF (IFUN .EQ. 4) THEN KM = 4 ELSE KM = 1 ENDIF DO 10 K = 1, KM SD(K) = 0 10 CONTINUE DO 40 I = 1, NDIR DO 30 J = 1, 3 DO 20 K = 1, KM SD(K) = SD(K) + XDIR(I, J, K)**2 20 CONTINUE 30 CONTINUE 40 CONTINUE DO 50 K = 1, KM SD(K) = SQRT(SD(K)) 50 CONTINUE RETURN END SUBROUTINE PLA053 (I0, J0, K0, L0, D, SD, ISD, NDEC, IER) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /DERIV/ NDIR, VIJ(3), VJK(3) DIMENSION SDD(2) I = I0 J = J0 K = K0 L = L0 IHAT = 0 JHAT = 0 KHAT = 0 LHAT = 0 IER = 0 NOESD = 1 NESD = 0 SD = 0.0 CALL PLA050 (I, J, K, L, D) CALL GEN048 (-1, JFG(I), 10, IVAL) IF (IVAL .EQ. 0) NOESD = 0 IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(I), 30, IVAL) IF (IVAL .EQ. 1) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(I), 31, IVAL) NESD = NESD + IVAL ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(J), 10, IVAL) IF (IVAL .EQ. 0) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(J), 30, IVAL) IF (IVAL .EQ. 1) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(J), 31, IVAL) NESD = NESD + IVAL ENDIF CALL GEN048 (-1, IFG(I), 7, IHAT) CALL GEN048 (-1, IFG(J), 7, JHAT) IF (K .EQ. 0) THEN MODE = 1 NDCD = 4 IF (NESD .EQ. 2) NOESD = 0 ELSE IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(K), 10, IVAL) IF (IVAL .EQ. 0) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(K), 30, IVAL) IF (IVAL .EQ. 1) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(K), 31, IVAL) NESD = NESD + IVAL ENDIF NDCD = 2 IF (L .EQ. 0) THEN MODE = 2 IF (NESD .EQ. 3) NOESD = 0 IF (D .LT. 1.0) IER = - 1 CALL GEN048 (-1, IFG(I), 5, IVAL) CALL GEN048 (-1, IFG(J), 6, JVAL) CALL GEN048 (-1, IFG(K), 5, KVAL) IF (ABS (180.0 - D) .LT. 0.05) THEN IF (JVAL .EQ. 1 .AND. IVAL + KVAL .EQ. 1) NOESD = 0 ELSE IF (ABS(120.0 - D) .LT. 0.05 .OR. 1 ABS(60.0 - D) .LT. 0.05) THEN CALL GEN048 (-1, IFG(J), 6, IVAL) IF (JVAL .EQ. 1 .AND. IVAL + KVAL .EQ. 1) THEN IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) NOESD = 0 ENDIF ENDIF CALL GEN048 (-1, IFG(K), 7, KHAT) ELSE IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(L), 10, IVAL) IF (IVAL .EQ. 0) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(L), 30, IVAL) IF (IVAL .EQ. 1) NOESD = 0 ENDIF IF (NOESD .EQ. 1) THEN CALL GEN048 (-1, JFG(L), 31, IVAL) NESD = NESD + IVAL ENDIF MODE = 3 IF (NESD .EQ. 4) NOESD = 0 CALL PLA050 (I, J, 0, 0, D1) IF (D1 .LT. 0.1) IER = - 1 CALL PLA050 (K, L, 0, 0, D1) IF (D1 .LT. 0.1) IER = - 1 CALL PLA050 (I, K, 0, 0, D1) IF (D1 .LT. 0.1) IER = - 1 CALL PLA050 (J, L, 0, 0, D1) IF (D1 .LT. 0.1) IER = - 1 CALL GEN048 (-1, IFG(L), 7, LHAT) ENDIF ENDIF IF (NOESD .NE. 0) THEN NDIR = 0 CALL PLA051 (I) CALL PLA051 (J) IF (K .GT. 0) CALL PLA051 (K) IF (L .GT. 0) CALL PLA051 (L) CALL PLA049 (MODE, D) CALL PLA052 (MODE, SDD) IF (K .EQ. 0) THEN SD = SQRT(SDD(1)**2 + (PAR(13) * D)**2) ELSE SD = SQRT(SDD(1)**2 + PAR(14)**2) ENDIF ENDIF CALL GEN041 (D, SD, ISD, NDCD, NDEC, IPR(68)) IF (IPR(68) .EQ. 0) THEN IPR68 = 10 ELSE IPR68 = IPR(68) ENDIF IF (ISD .GT. IPR68 * 10 - 1) THEN ISD = -1 NDEC = 0 SD = -1.0 ENDIF IF (ISD .EQ. 0) THEN NHAT = IHAT + JHAT + KHAT + LHAT IF (NHAT .NE. 0) THEN IF (MODE .EQ. 1) THEN NDEC = 2 D = NINT (D * 100.0) / 100.0 ELSE NDEC = 0 D = NINT (D) ENDIF ENDIF ENDIF RETURN END SUBROUTINE PLA054 (MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION DUMW(3, 3), EV(3, 3), EW(3) NMAX = IPR(39) WHT = 1.0 IF (MODE .EQ. 1) THEN IWHT = 1 ELSE IWHT = IPR(41) ENDIF CALL GEN074 (DXI, 0.0, 1, 3) KP = 0 WM = 0 DO 30 N = 1, NMAX I = IATP(N) IF (I .LE. NP1) THEN IF (IWHT .EQ. 1) THEN CALL GEN048 (-4, IFG(I), 15, IVL) WHT = SATWT(IVL + 1) ELSE IF (IWHT .EQ. 2) THEN WHT = 3.0 / (XSD(I, 4) + XSD(I, 5) + XSD(I, 6)) ENDIF KP = KP + 1 WM = WM + WHT DO 20 J = 1, 3 DXI(J) = DXI(J) + WHT * XXO(I, J + 3) 20 CONTINUE ENDIF 30 CONTINUE DO 50 I = 1, 3 DXI(I) = DXI(I) / WM DO 40 J = 1, 3 DUMW(I, J) = 0.0 40 CONTINUE 50 CONTINUE DO 60 N = 1, NMAX I = IATP(N) IF (I .LE. NP1) THEN IF (IWHT .EQ. 1) THEN CALL GEN048 (-4, IFG(I), 15, IVL) WHT = SATWT(IVL + 1) ELSE IF (IWHT .EQ. 2) THEN WHT = 3.0 / (XSD(I, 4) + XSD(I, 5) + XSD(I, 6)) ENDIF XX = XXO(I, 4) - DXI(1) YY = XXO(I, 5) - DXI(2) ZZ = XXO(I, 6) - DXI(3) XSQ = XX**2 YSQ = YY**2 ZSQ = ZZ**2 DUMW(1, 1) = DUMW(1, 1) + WHT * (YSQ + ZSQ) DUMW(1, 2) = DUMW(1, 2) - WHT * XX * YY DUMW(1, 3) = DUMW(1, 3) - WHT * XX * ZZ DUMW(2, 2) = DUMW(2, 2) + WHT * (ZSQ + XSQ) DUMW(2, 3) = DUMW(2, 3) - WHT * YY * ZZ DUMW(3, 3) = DUMW(3, 3) + WHT * (XSQ + YSQ) ENDIF 60 CONTINUE CALL GEN024 (DUMW, EV, EW, DUMV) DO 70 I = 1, 3 XPV(I) = DUMV(I, 1) DUMA(I) = EW(I) 70 CONTINUE XPV(4) = GEN009(XPV, DXI) XPV(8) = XPV(4) RETURN END SUBROUTINE PLA055 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /DERIV/ NDIR, VIJ(3), VJK(3) NMAX = IPR(39) CALL PLA054 (0) CALL GEN002 (-1, OR, XPV(1), XPV(5), XLNG) CALL GEN074 (XSPV, 0.0, 1, 8) IF (IPR(72) .GT. 0) THEN NDIR = 0 N = 0 DO 20 I = 1, NMAX IATPI = IATP(I) IF (IATPI .LE. NP1) THEN N = N + 1 IF (N .GT. NP7) GOTO 60 CALL PLA051 (IATPI) ENDIF 20 CONTINUE D = 0.0 CALL PLA049 (4, D) CALL PLA052 (4, XSPV) DO 40 J = 1, 3 XSPV(4 + J) = 0.0 DO 30 K = 1, 3 XSPV(4 + J) = XSPV(4 + J) + (XSPV(K) * OR(K, J))**2 30 CONTINUE 40 CONTINUE DO 50 K = 5, 7 XSPV(K) = SQRT(XSPV(K)) 50 CONTINUE XSPV(8) = XSPV(4) ENDIF 60 RETURN END SUBROUTINE PLA056 (PV, IAT, D, SD, ISD, NDECD, NDEC) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) DIMENSION PV(*) NDEC = NDECD D = - PV(4) DO 10 I = 1, 3 D = D + PV(I) * XXO(IAT, I + 3) 10 CONTINUE SD = 0 ISD = 0 IF (IPR(72) .NE. 0) THEN DO 30 I = 1, 3 XXO(IAT, I + 3) = XXO(IAT, I + 3) + PAR(12) DAC = - PV(4) DO 20 J = 1, 3 DAC = DAC + PV(J) * XXO(IAT, J + 3) 20 CONTINUE XXO(IAT, I + 3) = XXO(IAT, I + 3) - PAR(12) DIR = (DAC - D) / PAR(12) SD = SD + XSD(IAT, I + 3) * DIR**2 30 CONTINUE SD = SQRT(SD) CALL GEN041 (D, SD, ISD, NDECD, NDEC, IPR(68)) ENDIF RETURN END SUBROUTINE PLA057 (IAT, JAT, KAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) CHARACTER MARK*2, IMRK1*5, FORMI*98, FORMJ*24, FORMK*6, CXMOL2*9 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 PAGET = 'INTER' ANGLE = 0.0 DIJ = 0.0 SDIJ = 0.0 NDEC1 = 0 NDEC2 = 0 ISDIJ = 0 NATHX = 0 NATHY = 0 C * SETUP PRINT FORMATS FORMI( 1: 32) = '( A,1X,''.... '',A,''['',A ,'']'',' FORMI(33: 65) = 'F8.3,''('',I3,'')'',A,F5.2,F6.2,1X,A,' FORMI(66: 98) = '1X,2(3F7.4,2X),A,F7.2,''('',I3,'')'')' FORMJ( 1: 24) = '(112X,A,F7.2,''('',I3,'')'')' FORMK( 1: 6 ) = '(F9.2)' IF (PAR(42) .LT. 100.0) FORMK(5:5) = '1' IF (IPR(90) .EQ. 1) THEN IF (IPR(15) .LE. 0) THEN IF (IPR(15) .EQ. 0 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (-6) IF (LMT(IENS(IAN), 1) .EQ. 'Cg') THEN IAN0 = IAN - 1 ELSE IAN0 = IAN ENDIF WRITE (LU7, 99997) PAR(1), PAR(33), 1 (LMT(IENS(K), 1), K = 1, IAN0) WRITE (LU7, 99996) (RADR(IENS(K), 2), K = 1, IAN0) IF (IGBL(63) .GT. 3) THEN CALL PLA269 (6) WRITE (LU7, 99998) ENDIF ENDIF CALL PLA066 (0, 0, 0, 0, 0.0, 0.0, 0.0, 0.0, 0.0) IF (IPR(2) .NE. 0) STOP '302' PAR(67) = 1555.0 + IPR(61) / PAR(42) IF (IPR(75) .NE. 1 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (6) WRITE (LU7, 99999) PAR(67) ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99995) PAR(67) ENDIF IPR(15) = 1 ENDIF CALL PLA036 (IAT, 1, 1, IPOPI, IDUM1, IDUM2, IPR(119), IGBL(55)) IDSORD = 0 IF (IPR(67) .NE. 0) IPOPI = 1000 IF (IPOPI .LT. 1000) THEN IDSORD = IDSORD + 10 X1 = - XLAB(IAT) ELSE X1 = XLAB(IAT) ENDIF X3 = 0.0 NC = - NINT(CON(IAT, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .GT. 0) THEN INCX = NINT(CON(IAT, 1)) IF (INCX .GT. 0 .AND. INCX .LE. NP1) THEN X3 = XLAB(INCX) CALL GEN048 (-3, JFG(INCX), 24, NATHX) ELSE WRITE (LU6, '(''PLA057 INCX = '', I10)') INCX ENDIF ENDIF CALL PLA036 ( KAT, 1, 4, IPOPK, MN, IDUM2, IPR(119), IGBL(55)) CALL PLA036 (-KAT, 1, 2, IPOPK, MN, IDUM2, IPR(119), IGBL(55)) IF (IPOPK .LT. 1000) THEN IDSORD = IDSORD + 1 X2 = - XLAB(KAT) ELSE X2 = XLAB(KAT) ENDIF X4 = 0.0 NC = - NINT(CON(JAT, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .GT. 0) THEN JNCX = NINT(CON(JAT, 1)) IF (JNCX .GT. 0 .AND. JNCX .LE. NP1) THEN X4 = XLAB(JNCX) CALL GEN048 (-3, JFG(JNCX), 24, NATHY) ELSE WRITE(LU6, '(''PLA057 JNCX = '', I10)') JNCX ENDIF ENDIF MOL2 = MOL(MN) IARU = NINT(PAR(42)) IF (MOL2 .EQ. 1555 * IARU) MOL2 = MOL2 + IPR(62) XMOL2 = MOL2 / PAR(42) CALL PLA053 (IAT, KAT, 0, 0, DIJ, SDIJ, ISDIJ, NDEC1, IER) ISDIJ = MIN (999, ISDIJ) MARK = ' ' DMX0 = PAR(23) - PAR(1) DELT = DIJ - DMX0 DIJ29 = DIJ IF (DELT .LT. 0) THEN DIJ29 = DIJ29 + 100.0 MARK = ' <' IF (DELT + PAR(1) .LT. 0.0) THEN CALL GEN048 (-1, IFG(IAT), 7, IHA) CALL GEN048 (-1, IFG(KAT), 7, KATHA) CALL GEN048 (-1, IFG(IAT), 20, IDOH) CALL GEN048 (-1, IFG(KAT), 20, KDOH) CALL GEN048 (-1, IFG(IAT), 23, IDOA) CALL GEN048 (-1, IFG(KAT), 23, KDOA) IF (DELT .LT. PAR(199) .AND. IAT .LT. KAT) THEN IF ((IDOH .EQ. 1 .OR. KDOA .EQ. 1) .AND. 1 (IDOA .EQ. 1 .OR. KDOH .EQ. 1)) THEN IPR(160) = IPR(160) + 1 ENDIF PAR(200) = MIN (DELT, PAR(200)) ENDIF IF (DELT .LT. PAR(251 + 2 * IPR(20)) 1 .AND. IAT .LE. JAT) THEN IF (IHA .EQ. 1 .AND. KATHA .EQ. 1 .AND. 1 (IPOPI .EQ. 1000 .OR. IPOPK .EQ. 1000)) THEN IPR(403 + IPR(20)) = IPR(403 + IPR(20)) + 1 PAR(252 + 2 * IPR(20)) = 1 MIN (DELT, PAR(252 + 2 * IPR(20))) IPR20 = IPR(20) IKDOH = IDOH + KDOH IF (IKDOH .EQ. 0) THEN IF (NATHX .EQ. 3 .OR. NATHY .EQ. 3) IPR20 = IPR20 + 2 ELSE IF (IKDOH .EQ. 1) THEN IPR20 = IPR(20) + 4 ELSE IF (IKDOH .EQ. 2) THEN IPR20 = IPR(20) + 6 ENDIF WRITE (LU20, 99993) '_41', 1 IPR20, - DELT, DIJ, NAMS(1, 1)(2:8), NAMS(1, 2)(2:8) ENDIF ENDIF DIJ29 = DIJ29 + 100.0 MARK = '<<' IF (IPOPI .GE. 500 .AND. IPOPK .GE. 500) THEN IF (IHA .NE. 1 .AND. KATHA .NE. 1 .AND. IPR(20) .EQ. 1) 1 THEN IF (IPR(88) .LT. NP2) THEN IPR(88) = IPR(88) + 1 XLS(1, IPR(88)) = XLAB(IAT) XLS(2, IPR(88)) = PAR(67) XLS(3, IPR(88)) = -XLAB(KAT) XLS(4, IPR(88)) = XMOL2 XLS(5, IPR(88)) = IPR(61) XLS(6, IPR(88)) = DIJ XLS(7, IPR(88)) = DELT XLS(8, IPR(88)) = IDSORD ELSE IPR(149) = IPR(149) + 100 ENDIF ENDIF ENDIF ENDIF ENDIF IF (IPR(20) .EQ. 1) THEN CALL PLA066 (1, MOL2, NATHX, NATHY, X1, X2, X3, X4, DIJ29) IF (IPR(2) .NE. 0) STOP '303' ENDIF IF (IPR(20) .EQ. 0) THEN IMRK1 = 'Intra' ELSE IMRK1 = ' ' ENDIF ANGL = -1.0 SA = 0.0 IANGL = 0 NC = - NINT(CON(IAT, NP4)) N = 0 NLINE = 0 10 N = N + 1 IF (N .GT. NC) THEN IF (NLINE .NE. 0) GOTO 20 ELSE K = NINT(CON(IAT, N)) IF (K .GT. IPR(37)) GOTO 10 CALL PLA053 (K, IAT, KAT, 0, ANGLE, SA, IANGL, NDEC2, IER) IF (IER .NE. 0) GOTO 10 IF (ANGLE .LT. PAR(33)) GOTO 10 CALL PLA036 (K, 1, 3, IDUM1, IDUM2, IDUM3, IPR(119), IGBL(55)) ANGL = ANGLE IANGL = MIN (999, IANGL) ENDIF IF (NLINE .EQ. 0) THEN WRITE (CXMOL2, FORMK) XMOL2 IF (INT(XMOL2) .EQ. 1555) CXMOL2 = ' ' FORMI(36 : 36) = CHAR(ICHAR('0') + NDEC1) IF (ANGL .LT. 0) THEN WRITE (PRBUF, FORMI) (NAMS(1, L), L = 1, 2), 1 CXMOL2, DIJ, ISDIJ, MARK, DMX0, DELT, IMRK1, 2 (XXO(IAT, L), L = 1, 3), (XXO(KAT, L), L = 1, 3) ELSE FORMI(86 : 86) = CHAR(ICHAR('0') + NDEC2) WRITE (PRBUF, FORMI) (NAMS(1, L), L = 1, 2), 1 CXMOL2, DIJ, ISDIJ, MARK, DMX0, DELT, IMRK1, 2 (XXO(IAT, L), L = 1, 3), (XXO(KAT, L), L = 1, 3), 3 NAMS(1, 3), ANGL, IANGL ENDIF IF (MN .LT. 28) THEN IF (IPR(438) * IGBL(97) .EQ. 1) THEN IPR(254) = IPR(254) + 1 WRITE (LU2, 99994) NAMS(1, 1)(2:8), NAMS(1, 4)(2:8), 1 DIJ, SDIJ ENDIF ENDIF ELSE FORMJ(12 : 12) = CHAR(ICHAR('0') + NDEC2) WRITE (PRBUF, FORMJ) NAMS(1, 3), ANGL, IANGL ENDIF IF (IGBL(63) .GT. 2) CALL PLA067 (LU7, PRBUF, 132, 1, 11) NLINE = NLINE + 1 GOTO 10 ENDIF 20 RETURN 99999 FORMAT (/, 57X, 13('='), /, 56('*'), ' ARU =', F8.2, 1X, 1 61('*'), /, 57X, 13('='), /) 99998 FORMAT (/, 'Default Contact Radii are those given by A.Bondi', 1 ', J.Phys.Chem. (1964),68,441. (or Coval. Rad. + 0.8 Ang.', 2 ' when not given)', //, '* WARNING * : no Far-Reaching', 3 ' Conclusions should be drawn based on the Default Radii', 4 ' Assigned to Metals', //, 'Short "INTRA" Distances between', 5 ' two Atoms that are Separated by less than 4 Bonds are NOT', 6 ' Listed (Except for Potential D/A Contacts)', /) 99997 FORMAT ('Analysis of Short Intra- and Inter-molecular Contacts', 1 ' , d(I-J) < R(I) + R(J) + Tolr, With Tolr =', F5.1, 2 ' Ang. (X - I...J) >', F5.0, ' Deg.', /, 132('-'), /, 3 'Contact Radii :', 16(3X, A)) 99996 FORMAT ('(Angstrom)', 5X, 16F5.2) 99995 FORMAT (132('-')/, 'At(I)[', F7.2, '] At(J) [ ARU(J) ]', 1 7X, 'D(I-J) Sumrad Del Type X(I) Y(I) Z(I)', 5X, 2 'X(J) Y(J) Z(J) X', 9X, 'X - I...J', /, 132('-')) 99994 FORMAT ('NONB ', 2(A, 2X), 2F8.4) 99993 FORMAT (A, I1, 2F10.2, 2A) END SUBROUTINE PLA058 (I, J, K, L, IDET) COMMON /PL40/ LHNT(4, 3, 5), NETH(64, 3), MXL IDET = LHNT(I, 1, L) * (LHNT(J, 2, L) * LHNT(K, 3, L) 1 - LHNT(K, 2, L) * LHNT(J, 3, L)) + LHNT(I, 2, L) 2 * (LHNT(J, 3, L) * LHNT(K, 1, L) - LHNT(J, 1, L) 3 * LHNT(K, 3, L)) + LHNT(I, 3, L) * (LHNT(J, 1, L) 4 * LHNT(K, 2, L) - LHNT(J, 2, L) * LHNT(K, 1, L)) IDET = ABS(IDET) RETURN END SUBROUTINE PLA059 (JAT, KAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 IF (JAT .GT. NP1 .OR. JAT .LE. 0) THEN WRITE (LU6, 99999) JAT, KAT STOP 'Report problem to Author' ENDIF IF (JAT .NE. KAT) THEN DO 10 I = 1, 3 XJX(I + 3) = 0.0 XJX(I) = XXO(JAT, I) 10 CONTINUE CALL SGSM (ICL, IPR(54), XJX, LU7, 3, IERR) DO 20 I = 4, 6 XJS(I) = XJX(I + 3) + ITR(I - 3) XJS(IPR(30 + I)) = XJS(I) 20 CONTINUE IF (IPR(189) .EQ. 0) THEN DO 30 I = 1, 3 XJX(I) = XSD(JAT, I) 30 CONTINUE NSMM = -IPR(54) CALL SGSM (ICL, NSMM, XJX, LU7, 3, IERR) ENDIF ENDIF DO 50 N = 1, 3 J = 4 - N JP3 = J + 3 IF (JAT .NE. KAT) THEN XXO(KAT, J) = XJS(J + 3) XSD(KAT, J) = XJX(J + 6) ENDIF XXO(KAT, JP3) = 0.0 XSD(KAT, JP3) = 0.0 DO 40 L = J, 3 ORJK = OR(J, L) XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * ORJK IF (IPR(189) .EQ. 0) THEN IF (IPR(72) .NE. 0) THEN XSD(KAT, JP3) = XSD(KAT, JP3) + XSD(KAT, L) * ORJK**2 ENDIF ENDIF 40 CONTINUE 50 CONTINUE RETURN 99999 FORMAT (/, 'Problem in PLA059; JAT & KAT =', 2I12, /) END SUBROUTINE PLA065 (MODE, IAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /PL65/ NBOND, NPNT, NPNTM COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 IF (MODE .EQ. 0) THEN NBOND = 0 NPNT = NINT (PAR(262) * 100.0) NPNTM = 2 * NPNT CALL GEN074 (DATC, 0.0, NPNT + 1, NPNTM) ELSE IF (MODE .GT. 0) THEN NC = IPR(79) IF (NC .GT. 0) THEN CALL PLA047 (XLAB(IAT), NQ3, MNX, IENI, 0, IGBL(55), 0, 1 1 - IGBL(55)) CALL GEN048 (-7, JFG(IAT), 1, IPP) MULTI = IPR(48) / IPPR(IPP + 1, 3) CALL PLA036 (IAT, 1, 1, IDUM1, MNI, IDUM3, IPR(119), 1 IGBL(55)) NCI = 0 NDB = 0 DO 30 J = 1, NC KAT = IATC(J) MKAT = MOD (KAT, NP1) IDUB = 0 IF (J .GT. 1) THEN DO 20 K = 2, J IF (MKAT .EQ. MOD(IATC(K - 1), NP1)) THEN IDUB = 2 NDB = NDB + 1 ENDIF 20 CONTINUE ENDIF CALL GEN048 (-1, IFG(MKAT), 7, IHA) PADD = (IDUB + IHA + 1) * PAR(23) IF (KAT .LE. NP1) THEN CALL PLA041 (-1, IAT, JJ, KAT) IF (JJ .GT. 0) THEN NCI = NCI + 1 PADD = 0 ENDIF ENDIF DATC(J) = PADD + DATC(J) 30 CONTINUE CALL GEN013 (DATC, IATC, 1, NC) NC = NC - NDB DO 40 J = 1, NC KAT = IATC(J) IPR(20) = 0 IF (KAT .GT. NP1) THEN KAT = KAT - NP1 IATC(J) = KAT IPR(20) = 1 ENDIF CALL GEN048 (-6, IFG(KAT), 9, IRESJ) CALL PLA036 (KAT, 1, 2, IDUM1, MNJ, IDUM3, IPR(119), 1 IGBL(55)) XLABX = - XLAB(KAT) CALL PLA047 (XLABX, NQ4, MNY, IENK, IPR(119), IGBL(55), 0, 1 1 - IGBL(55)) CALL PLA046 (2, NQ4, IDUM, LBB, LBC, LBD, XLMP, YNQNR, KATP) CALL PLA047 (XLAB(KAT), NQ3, MNY, IENK, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) CALL PLA053 (IAT, KAT, 0, 0, DIJ, SDIJ, ISDIJ, NDEC, IER) NBOND = NBOND + 1 NI = IATNR(IENI) NK = IATNR(IENK) NIJ = INT(DIJ * 100.0) + NPNT + 1 DATC(NIJ) = DATC(NIJ) + FLOAT(NI * NK) / FLOAT(MULTI) 40 CONTINUE ENDIF ELSE 50 CALL GEN074 (DATC, 0.0, 1, NPNT) DO 70 I = 1, NPNT IF (IPR(581) .EQ. 0) THEN A = DATC(I + NPNT) ELSE A = DATC(I + NPNT) / I ENDIF IF (A .GT. 0.0) THEN DATC(I) = DATC(I) + A J = 0 60 J = J + 1 FACT = A * EXP (- (J / PAR(451)) ** 2) IF (I + J .LE. NPNT) DATC(I + J) = DATC(I + J) + FACT IF (I - J .GT. 0) DATC(I - J) = DATC(I - J) + FACT IF (J .LT. 200) GOTO 60 ENDIF 70 CONTINUE AMX = 0.0 DO 80 I = 1, NPNT AMX = MAX (AMX, DATC(I)) 80 CONTINUE 90 IGBL(23) = 28 BCD(1:30) = 'Simulated Radial Distribution'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, BCD, 29, 1.0, 4, 8, 0.6, VERT - 1.6) CALL GGIP20 (0.0, BCD, 29, 1.0, 2, 8, 0.5, VERT - 1.7) CALL PLA117 (HORS, VERT, -1) VRT = VERT - 3.0 CALL PLA283 (0, 1, N, IDM) WRITE (LINE, 99989) IDM(N:80) CALL GGIP20 (0.0, LINE, 60, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99999) SPGRNM(1)(1:7) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 17, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99998) PAR(101) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99997) PAR(102) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99996) PAR(103) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99995) PAR(104) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99994) PAR(105) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99993) PAR(106) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) WRITE (LINE, 99990) PAR(98) VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT) XSTEP = (HORS - 2.0) / NPNT SCF = (VERT - 4.0) / AMX CALL GGIP (1.0, 2.0, 0.0, 3) XP = 1.0 DO 100 I = 1, NPNT XP = XP + XSTEP YP = 2.0 + SCF * DATC(I) CALL GGIP (XP, YP, 0.0, 2) 100 CONTINUE CALL GGIP (0.0, 0.0, 0.0, 3) XP = 1.0 N = 0 NM = NPNT / 50 XST = XSTEP * 50 110 CALL GGIP (XP, 1.0, 0.0, 3) CALL GGIP (XP, 1.4, 0.0, 2) IF (N .LT. 20) THEN WRITE (NQ1, 99992) N * 0.5 ELSE WRITE (NQ1, 99991) N * 0.5 ENDIF CALL GGIP20 (0.0, NQ1, 4, 0.2, 2, 2, XP + 0.1, 1.2) XP = XP + XST N = N + 1 IF (N .LE. NM) GOTO 110 CALL GGIP20 (0.0, 'Angstrom', 8, 0.3, 2,2, HORS - 2.4, 0.2) CALL PLA013 (0, 1) CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) IF (IFL(1)(1:4) .EQ. 'EXIT') THEN GOTO 120 ELSE IF (IFL(1)(1:4) .EQ. 'CALC') THEN GOTO 120 ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN IGGT = ' ' IGBL(23) = 10 GOTO 120 ELSE IF (LRET .EQ. 2) THEN GOTO 50 ELSE GOTO 90 ENDIF ENDIF 120 RETURN 99999 FORMAT ('SpGroup ', A) 99998 FORMAT ('a ', F8.2) 99997 FORMAT ('b ', F8.2) 99996 FORMAT ('c ', F8.2) 99995 FORMAT ('alpha', F8.2) 99994 FORMAT ('beta ', F8.2) 99993 FORMAT ('gamma', F8.2) 99992 FORMAT (F3.1) 99991 FORMAT (F4.1) 99990 FORMAT ('Volume', F7.1) 99989 FORMAT ('Formula ', A) END SUBROUTINE PLA066 (MODE, MOLX, NATHX, NATHY, X1, X2, X3, X4, DIST) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) CHARACTER MARK*2, IDS1*1, IDS2*1, FORMI*81 DIMENSION ZMOLX(6), AMOLX(51) FORMI( 1:43) = '(I4,'' ['',F9.2,'']'',I8,F11.4,F7.2,4X,I1,1X,A,' FORMI(44:81) = '''-'',2A,''... '',2A,''-'',A,I2,3X,A,6F10.2)' IF (PAR(42) .LT. 100.0) THEN FORMI(13:13) = '1' FORMI(80:80) = '1' ENDIF N = IPR(49) IF (MODE .EQ. 0) THEN IPR(49) = 0 ELSE IF (MODE .LT. 0) THEN IF (N .GT. 0 .AND. IPR(149) .LE. 0) THEN NSMOL = IPR(51) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (8) WRITE (LU7, 99999) PAR(3), IPR(104) ENDIF NI = 0 DO 150 K = 1, NSMOL ML = MOL(K) CALL GEN098 (ML, PAR(42), M1, M2, M3, M4, NRES) IF (NRES .EQ. 0) THEN NRES = IPR(104) ML = ML + NRES ENDIF IF (NRES .EQ. IPR(104)) THEN RMOL = ML / PAR(42) DO 30 I = 1, N MARK = ' ' DIJ = MOD(BOK(I, 1), 100.0) ISML = INT(BOK(I, 1) / 100.0) IF (ISML .GT. 0) MARK = ' <' IF (ISML .GT. 1) MARK = '<<' CALL GEN098 (KBO(I, 1), PAR(42), M1, M2, M3, M4, MRES) VMOL = KBO(I, 1) / PAR(42) CALL PLA081 (18, RMOL, VMOL, XMOLX) IF (IPR(2) .NE. 0) GOTO 100 ZMOLX(1) = XMOLX IF (BOK(I, 2) .LT. 0) THEN IDS1 = '*' ELSE IDS1 = ' ' ENDIF XLABN1 = - ABS(BOK(I, 2)) IF (BOK(I, 3) .LT. 0) THEN IDS2 = '*' ELSE IDS2 = ' ' ENDIF NQ3 = ' ' NQ4 = ' ' XLABN2 = - ABS(BOK(I, 3)) XLABN3 = - ABS(BOK(I, 4)) XLABN4 = - ABS(BOK(I, 5)) CALL PLA047 (XLABN1, NQ1, IDUM, IENI, IPR(119), 1 IGBL(55), 0, 0) CALL PLA047 (XLABN2, NQ2, IDUM, IENJ, IPR(119), 1 IGBL(55), 0, 0) IF (XLABN3 .NE. 0.0) 1 CALL PLA047 (XLABN3, NQ3, IDUM, IENK, IPR(119), 1 IGBL(55), 0, 0) IF (XLABN4 .NE. 0.0) 1 CALL PLA047 (XLABN4, NQ4, IDUM, IENL, IPR(119), 1 IGBL(55), 0, 0) SUMRAD = ABS(VDWR(IENI)) + ABS(VDWR(IENJ)) DEL = DIJ - SUMRAD NSML = 1 IF (NSMOL .GT. 1) THEN DO 120 L = 2, NSMOL ML = MOL(L) CALL GEN098 (ML, PAR(42), L1, L2, L3, L4, MLRES) IF (IPR(2) .NE. 0) GOTO 100 IF (MLRES .EQ. MRES .AND. NSML .LT. 6) THEN YMOLX = ML / PAR(42) CALL PLA081 (19, XMOLX, YMOLX, ZMOLX(NSML + 1)) IF (IPR(2) .EQ. 52) GOTO 100 IF (IPR(2) .EQ. 28) THEN IPR(2) = 0 ELSE NSML = NSML + 1 ENDIF ENDIF 120 CONTINUE ENDIF IF (NSML .GT. 1) THEN DO 180 I1 = 1, NSML K1 = NSML + 1 DO 190 J1 = I1 + 1, NSML K1 = K1 - 1 IF (ZMOLX(K1) .LT. ZMOLX(K1 - 1)) 1 CALL GEN018 (ZMOLX(K1), ZMOLX(K1 - 1)) 190 CONTINUE 180 CONTINUE ENDIF AMOLX(NI + 1) = ZMOLX(1) IF (NI .GT. 0) THEN DO 200 I1 = 1, NI IF (AMOLX(I1) .EQ. ZMOLX(1)) GOTO 30 200 CONTINUE ENDIF IF (NI .LT. 50) NI = NI + 1 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, FORMI) NI, XMOLX, KBO(I, 2), DIJ, DEL, 1 KBO(I, 3), NQ3, IDS1, NQ1, IDS2, NQ2, NQ4, 2 KBO(I, 4), MARK, (ZMOLX(L), L = 1, NSML) ENDIF 30 CONTINUE ENDIF 150 CONTINUE IPR(49) = 0 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99997) PAR(3) ENDIF ENDIF ELSE IF (N .GT. 0) THEN DO 60 I = 1, N IF (KBO(I, 1) .EQ. MOLX) THEN KBO(I, 2) = KBO(I, 2) + 1 IF (MOD(DIST, 100.0) .GT. MOD(BOK(I, 1), 100.0)) THEN GOTO 100 ELSE GOTO 90 ENDIF ENDIF 60 CONTINUE ENDIF I = N + 1 IF (I .GT. NP8) THEN IPR(149) = IPR(149) + 1 GOTO 100 ENDIF KBO(I, 1) = MOLX KBO(I, 2) = 1 IPR(49) = IPR(49) + 1 90 BOK(I, 1) = DIST BOK(I, 2) = X1 BOK(I, 3) = X2 BOK(I, 4) = X3 BOK(I, 5) = X4 KBO(I, 3) = NATHX KBO(I, 4) = NATHY ENDIF 100 RETURN 99999 FORMAT (//, 'Summary of Shortest Inter Contacts with d(I-J) < ', 1 ' R(I) + R(J) + ', F4.1, ' of Residue #', I3, 2 ' to Neighbouring ARU''S', /, 132('='), //, 2X, 3 'Nr', 7X, 'ARU', 4X, 'Nr.Cont.', 3X, 'd(min)', 4X, 'Del', 4 2X, 'XHn X - At(I)', 7X, 'At(J) - Y YHn Note', 2X, 5 'Partaking ARU''s in Close Contact Resd.', /, 132('-')) 99997 FORMAT (/, 'Symbols :: < denotes contacts less than the sum of ', 1 'the van der Waals Radii and << contacts less than this sum ', 2 'minus', F4.1, ' Angstrom.',/, 3 11X, 'Nr.Cont. = Number of short contacts from current ARU to', 4 ' surrounding ARU''s (from list above).') END SUBROUTINE PLA067 (LU, PRBUF, JBUFL, NLINE, JSUBST) CHARACTER PRBUF*(*) IF (NLINE .GT. 0) CALL PLA269 (NLINE) CALL GEN065 (LU, PRBUF, JBUFL, JSUBST) RETURN END SUBROUTINE PLA068 (MODE, ARU) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 IF (MODE .EQ. 0) THEN IPR(25) = 0 ELSE IF (MODE .GT. 0) THEN IF (IPR(13) + IPR(25) + 2 .LT. NP11) THEN NEWARU = NINT(ARU * PAR(42)) IF (IPR(25) .GT. 0) THEN DO 10 I = 1, IPR(25) IF (NEWARU .EQ. MOL(IPR(13) + I)) GOTO 100 10 CONTINUE ENDIF IPR(25) = IPR(25) + 1 MOL(IPR(25) + IPR(13)) = NEWARU ENDIF ELSE IF (MODE .LT. 0) THEN IF (IPR(25) .GT. 0) THEN CALL PLA269 (1) WRITE (LU7, 99998) DO 20 I = 1, IPR(25) ML = MOL(IPR(13) + I) CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRS0) XJX(4) = MOL2 XJX(5) = MOL3 XJX(6) = MOL4 CALL SGSM (ICL, MOL1, XJX, 0, 20, IERR) ML = INT(ML / PAR(42)) CALL PLA269 (1) WRITE (LU7, 99999) ML, ICL(1:30) 20 CONTINUE ENDIF ENDIF 100 RETURN 99999 FORMAT ('[', I6, '] = ', A) 99998 FORMAT (1X) END SUBROUTINE PLA069 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 IF (IPR(71) .GT. 0) THEN IPR(2) = 10 ELSE NNAT = 0 IWIN = 0 CALL PLA293 (PAR(17), LU20) CALL PLA089 IF (IPR(2) .EQ. 0) THEN NSYM = IPR(48) NAT = IPR(37) IF (IPR(17) .EQ. 0) THEN PAGET = 'INTRA' NNAT = 1 CALL GEN074 (RCG, 0.0, 1, NP29 * 4) ENDIF C * BRANCH FOR INTRA, INTER/VOID OR COORDINATION CALCULATIONS 10 IAT = 0 IATNF = 0 IATHF = 0 IF (IPR(17) .EQ. 0) THEN MNAT = NNAT INXT = 0 DO 30 N = MNAT, NAT CALL GEN048 (-4, IFG(N), 15, IVAL) IATPRP = IATPR(IEN(IVAL + 1)) CALL GEN048 (-3, IFG(N), 1, IVAL) IF (IVAL .GT. 3) THEN CALL GEN048 (-1, IFG(N), 7, IHAT) IF (IHAT .EQ. 1) THEN CALL GEN048 (3, IFG(N), 1, 3) DO 20 JJ = 1, 3 RCG(JJ, IPR(75)) = RCG(JJ, IPR(75)) + XXO(N, JJ) 20 CONTINUE RCG(4, IPR(75)) = RCG(4, IPR(75)) + 1 GOTO 30 ELSE IF (IATPRP .LT. 0) THEN CALL GEN048 (-1, JFG(N), 9, NCONS) IF (NCONS .EQ. 1) THEN IAT = N GOTO 130 ELSE IF (IATNF .EQ. 0) IATNF = N ENDIF ELSE CALL GEN048 (-1, JFG(N), 9, NCONS) IF (NCONS .EQ. 1) THEN IF (IATHF .LE. 0) IATHF = N ELSE IF (IATHF .EQ. 0) IATHF = - N ENDIF ENDIF ELSE IF (IVAL .EQ. 3) THEN IF (N .EQ. NNAT) NNAT = NNAT + 1 ELSE IF (INXT .LE. 0) THEN IF (IATPRP .LT. 0) THEN INXT = N ELSE IF (INXT .EQ. 0) INXT = - N ENDIF CALL GEN048 (-7, JFG(N), 1, IPP) IPR(184) = IPPR(IPP + 1, 1) ENDIF ENDIF 30 CONTINUE IF (IAT .EQ. 0) THEN IF (IATHF .GT. 0) THEN IAT = IATHF GOTO 130 ELSE IF (IATHF .LT. 0) THEN IF (IATNF .NE. 0) THEN IAT = IATNF ELSE IAT = - IATHF ENDIF IPR(124) = 1 GOTO 130 ELSE IF (IATNF .NE. 0) THEN IAT = IATNF IPR(124) = 1 GOTO 130 ENDIF ENDIF JJ = IPR(75) IF (JJ .GT. 0) THEN ICG = IPR(39) + IPR(24) + 1 KAT1 = ICG + 1 ICG1 = KAT1 + 1 DO 40 J = 1, 3 IF (RCG(4, JJ) .NE. 0.0) 1 RCG(J, JJ) = RCG(J, JJ) / RCG(4, JJ) XXO(ICG, J) = RCG(J, JJ) XXO(KAT1, J) = PAR(63 + J) XSD(ICG, J) = 0.0 XSD(KAT1, J) = 0.0 40 CONTINUE IATP(ICG) = 1555 IF (IGBL(30) .EQ. 0) THEN DUM5 = 99999.0 CALL PLA059 (KAT1, KAT1) DO 80 J = 1, NSYM IPR(54) = J DO 50 L = 1, 3 ITR(L) = 0 50 CONTINUE CALL PLA059 (ICG, ICG1) DO 60 L = 1, 3 DUM1 = MOD(XXO(ICG1, L), 1.0) IF (DUM1 .LT. 0.0) DUM1 = DUM1 + 1.0 ITR(L) = NINT(DUM1 - XXO(ICG1, L)) XXO(ICG1, L) = DUM1 60 CONTINUE CALL PLA059 (ICG1, ICG1) CALL PLA050 (ICG1, KAT1, 0, 0, DUM4) IF (DUM4 .LT. DUM5) THEN DUM5 = DUM4 FN(1) = J DO 70 L = 1, 3 FN(L + 1) = ITR(L) 70 CONTINUE ENDIF 80 CONTINUE YM1 = FN(1) * 1000 + FN(2) * 100.0 + FN(3) * 10.0 + 1 FN(4) + 555 + JJ / PAR(42) CALL PLA081 (1, YM1, 0.0, YMM1) DO 100 I = 1, ICG CALL GEN048 (-6, IFG(I), 9, JJRES) IF (JJ .EQ. JJRES) THEN ITRNS = NINT(FN(1) * 1000 + 555) DO 90 L = 1, 3 XXO(KAT1, L) = XXO(I, L) XSD(KAT1, L) = XSD(I, L) ITR(L) = NINT(FN(L + 1)) IF (IABS(ITR(L)) .GT. 4) THEN CALL PLA047 (XLAB(KAT1), NQ1, IDUM, JDUM, 0, 1 IGBL(55), 0, 0) IPR(2) = 17 GOTO 200 ENDIF ITRNS = ITRNS + ITR(L) * 10**(3 - L) 90 CONTINUE IF (ITRNS .NE. 1555) THEN IF (I .LT. ICG) WRITE (LU4) 5, XLAB(I), 1 (FN(L), L = 1, 8) IPR(54) = NINT(FN(1)) CALL PLA059 (KAT1, I) ENDIF YM2 = IATP(I) CALL PLA081 (2, YM1, YM2, YM3) IATP(I) = NINT(YM3) CALL GEN048 (1, IFG(I), 2, 1) ENDIF 100 CONTINUE L2 = IPR(13) DO 110 L = 1, L2 ML = MOL(L) CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, 1 JJRES) IF (JJ .EQ. JJRES) THEN IF (MOL1 .GT. IPR(48)) THEN MOL0 = NINT(IPR(48) * 1000.0 * PAR(42)) ELSE MOL0 = 0 ENDIF ML = ML - MOL0 YM3 = ML / PAR(42) CALL PLA081 (3, YM1, YM3, YM2) CALL PLA081 (4, YM2, YMM1, YM3) MOL(L) = NINT(YM3 * PAR(42)) + MOL0 ENDIF 110 CONTINUE ENDIF ENDIF IF (INXT .EQ. 0) THEN CALL PLA094 (IPR(110)) DO 120 I = 1, IPR(13) MOLS(I) = MOL(I) 120 CONTINUE IPR(53) = IPR(13) GOTO 200 ELSE IAT = IABS(INXT) IPR(75) = IPR(75) + 1 IF (IPR(75) .GT. IPR(129)) THEN IPR(75) = IPR(129) IPR(130) = 1 ENDIF CALL GEN048 (6, IFG(IAT), 9, IPR(75)) CALL PLA078 (IAT) IF (IPR(2) .NE. 0) THEN CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) GOTO 200 ELSE IPR(166) = IABS(IATP(IAT)) GOTO 130 ENDIF ENDIF ENDIF 130 CALL GEN048 (1, IFG(IAT), 3, 1) CALL GEN048 (1, JFG(IAT), 9, 1) GOTO 160 ELSE IF (IPR(17) .LT. 0) THEN IPR(13) = IPR(51) IF (IPR(189) .NE. 0) THEN CALL PLA125 GOTO 200 ENDIF ELSE IF (IPR(17) .GT. 0) THEN IF (IPR(168) .GT. 0) THEN IAT = IPR(168) GOTO 160 ELSE IPR(13) = IPR(51) GOTO 150 ENDIF ENDIF 150 IAT = IAT + 1 IF (IAT .GT. NAT) GOTO 190 160 CALL GEN048 (-4, IFG(IAT), 15, IPR(58)) IPR(509) = IEN(IPR(58) + 1) CALL GEN048 (-7, JFG(IAT), 1, IPP) IPR(128) = IPPR(IPP + 1, 1) * IPPR(IPP + 1, 3) / NSYM IPR(127) = IPPR(IPP + 1, 1) IF (IPR(127) .LT. 1000) THEN IPR(98) = 1 - IPR(502) * IABS(IPR(17)) ELSE IPR(98) = 0 ENDIF CALL GEN048 (-6, IFG(IAT), 9, IPR(61)) PAR(19) = RADR(IPR(58) + 1, 2) + PAR(1) IF (IPR(17) .EQ. 0) THEN IATPRI = IATPR(IPR(509)) IF (IPR(509) .EQ. 10 .OR. IPR(509) .EQ. 11 .OR. 1 IPR(509) .EQ. 30 .OR. IPR(509) .EQ. 59 .OR. 2 IPR(509) .EQ. 94 .OR. IPR(509) .EQ. 103) THEN IPR(157) = IPR(509) ELSE IF (IATPRI .EQ. 5 .OR. IATPRI .EQ. 6) THEN IPR(157) = 1 ELSE IF (IPR(325) .EQ. 0 .AND. IATPRI .LT. 0) THEN IF (IPR(509) .GE. 3 .AND. IPR(509) .LE. 5) THEN IPR(157) = - IPR(509) ELSE IPR(157) = -1 ENDIF ELSE IF (IPR(325) .EQ. -1 .AND. IATPRI .EQ. -1) THEN IF (IPR(509) .EQ. 3 .OR. IPR(509) .EQ. 4) THEN IPR(157) = - IPR(509) ELSE IPR(157) = -1 ENDIF ELSE IPR(157) = 0 ENDIF IPR(191) = ISIGN(1, IATPRI) ELSE IF (IPR(17) .LT. 0) THEN IF (IPR(104) .NE. IPR(61)) GOTO 150 ELSE IF (IPR(17) .GT. 0) THEN IF (IPR(168) .EQ. 0) THEN IF (RADR(IPR(58) + 1, 2) .LT. 0.001) GOTO 150 ELSE IF (IPR(168) .EQ. IAT) THEN PAR(19) = PAR(68) ELSE GOTO 150 ENDIF IPR(13) = IPR(51) IPR(24) = 0 IPR(79) = 0 ENDIF CALL PLA070 (IAT, KAT) IF (IPR(2) .NE. 0) GOTO 200 IF (IPR(17) .EQ. 0) THEN IF (IPR(203) .EQ. 0) THEN DO 180 JJ = 1, 3 RCG(JJ, IPR(75)) = RCG(JJ, IPR(75)) + XXO(IAT, JJ) 180 CONTINUE RCG(4, IPR(75)) = RCG(4, IPR(75)) + 1 ENDIF GOTO 10 ELSE IF (IPR(17) .GT. 0) THEN IF (IPR(138) .EQ. 0) THEN IF (IPR(57) .NE. 2) THEN CALL PLA072 (IAT) ELSE CALL PLA065 (1, IAT) ENDIF ELSE WRITE (LU6, 99999) NP11 IPR(138) = 0 IF (IPR(168) .EQ. 0) THEN RADR(IPR(58) + 1, 2) = RADR(IPR(58) + 1, 2) - 1.0 ELSE PAR(68) = PAR(68) - 1.0 ENDIF IAT = IAT - 1 ENDIF IF (IPR(168) .GT. 0) GOTO 190 ENDIF GOTO 150 190 IF (IPR(17) .LT. 0) THEN IF (IPR(90) .EQ. 1) THEN CALL PLA066 (-1, 0, 0, 0, 0.0, 0.0, 0.0, 0.0, 0.0) IF (IPR(2) .NE. 0) GOTO 200 ENDIF IPR(104) = IPR(104) + 1 IF (IPR(104) .LE. IPR(75)) THEN IAT = 0 IPR(15) = - IABS(IPR(15)) GOTO 150 ENDIF IF (IPR(90) .GT. 0) CALL PLA043 (0, 1, LU7, 0) IF (IPR(149) .EQ. 0) THEN CALL PLA091 (1) IF (IPR(2) .NE. 0) GOTO 200 ENDIF CALL PLA090 IF (IPR(149) .EQ. 0 .AND. IPR(300) .GT. 0) THEN CALL PLA091 (0) IF (IPR(2) .NE. 0) GOTO 200 CALL PLA092 ENDIF ENDIF ENDIF ENDIF 200 IF (IWIN .EQ. 1) THEN IF (IPR(168) .EQ. 0 .AND. IPR(326) .LT. 2) CALL PLA297 (0) IF (IPR(189) .NE. 0 .AND. IPR(121) .EQ. 0 1 .AND. IPR(326) .NE. 1) CALL PLA280 ('RESTART') ENDIF IF (IPR(17) .EQ. 0 .AND. IPR(37) .GT. 100) IGBL(75) = 0 RETURN 99999 FORMAT (/, ':: ARU-LIST Overflow (', I3, '), Radius Reduced', /) END SUBROUTINE PLA070 (IAT, KAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) CHARACTER CSCRAT*1 P23K = 0.0 NSYM = IPR(48) NAT = IPR(37) DO 10 K = 1, 3 INDX = IPR(33 + K) DXI(INDX) = XXO(IAT, K) DUMA(INDX + 3) = PAR(112 + K) 10 CONTINUE IPR(203) = 0 20 KAX = -1 IPR(80) = 0 30 IF (KAX .EQ. 0) THEN GOTO 50 ELSE IF (KAX .GT. 0) THEN GOTO 110 ENDIF IPR(54) = 0 40 IPR(54) = IPR(54) + 1 KAX = -1 IF (IPR(54) .GT. NSYM) THEN IF (IPR(17) .EQ. 0) THEN IF (IPR(80) .NE. 0) GOTO 20 CALL GEN048 (3, IFG(IAT), 1, 3) ENDIF GOTO 230 ENDIF JAT = 0 50 JAT = JAT + 1 IF (JAT .GT. NAT) GOTO 40 IF (IPR(189) .NE. 0) THEN CALL GEN048 (-1, JFG(JAT), 27, IOMT) IF (IOMT .NE. 0) GOTO 50 ENDIF CALL GEN048 (-10, IFG(JAT), 9, IHLP) IPR(59) = IHLP / 64 IPR(62) = MOD(IHLP, 64) PAR(23) = PAR(19) ADDEA = 0.0 IPR(510) = IEN(IPR(59) + 1) IF (IPR(17) .GT. 0) THEN IF (IPR(57) .NE. 0) THEN IF (RADR(IPR(59) + 1, 2) .LT. 0.001) GOTO 50 ENDIF GOTO 60 ELSE IF (IPR(17) .EQ. 0) THEN IATPRJ = IATPR(IPR(510)) IF (IPR(510) .EQ. 10 .OR. IPR(510) .EQ. 11 .OR. 1 IPR(510) .EQ. 30 .OR. IPR(510) .EQ. 59 .OR. 2 IPR(510) .EQ. 94 .OR. IPR(510) .EQ. 103) THEN IPR(158) = IPR(510) ELSE IF (IATPRJ .EQ. 5 .OR. IATPRJ .EQ. 6) THEN IPR(158) = 1 ELSE IF (IPR(325) .EQ. 0 .AND. IATPRJ .LT. 0) THEN IF (IPR(510) .GE. 3 .AND. IPR(510) .LE. 5) THEN IPR(158) = - IPR(510) ELSE IPR(158) = -1 ENDIF ELSE IF (IPR(325) .EQ. -1 .AND. IATPRJ .EQ. -1) THEN IF (IPR(510) .EQ. 3 .OR. IPR(510) .EQ. 4) THEN IPR(158) = - IPR(510) ELSE IPR(158) = -1 ENDIF ELSE IPR(158) = 0 ENDIF IPR(192) = ISIGN(1, IATPRJ) IF (IPR(156) .EQ. 0) THEN ITST = IPR(157) * IPR(158) IF (ITST .EQ. -30 .OR. ITST .EQ. -40 .OR. 1 ITST .EQ. -50 .OR. ITST .EQ. -120) THEN ADDEA = PAR(5) ELSE IF (ITST .EQ. -177 .OR. ITST .EQ. -236) THEN ADDEA = PAR(6) ELSE IF (ITST .EQ. -1 .OR. ITST .EQ. -3 .OR. 1 ITST .EQ. -4) THEN ADDEA = IGBL(97) * PAR(26) ENDIF IF (IPR(191) + IPR(192) .EQ. 2) ADDEA = PAR(27) ENDIF IF (IPR(62) .NE. 0) THEN IF (IPR(62) .NE. IPR(61)) GOTO 50 ENDIF IF (IPR(509) .EQ. 3 .AND. IPR(510) .EQ. 1) 1 PAR(23) = PAR(23) - 0.15 ENDIF PAR(23) = PAR(23) + RADR(IPR(59) + 1, 2) + ADDEA IF (IPR(509) .EQ. 10 .AND. IPR(510) .EQ. 10) PAR(23) = 2.0 60 P23K = PAR(23)**2 DO 70 I = 1, 3 DUMA(I) = DUMA(I + 3) * PAR(23) ITR(I) = 0 70 CONTINUE IF (IPR(27) .EQ. 1) THEN IPR(26) = 1555 KAT = JAT KAX = 0 GOTO 180 ENDIF DO 80 I = 1, 3 XJS(I + 3) = 0.0 XJS(I) = XXO(JAT, I) 80 CONTINUE CALL SGSM (CSCRAT, IPR(54), XJS, LU7, 3, IERR) DO 90 I = 1, 3 XJS(IPR(33 + I)) = XJS(I + 6) 90 CONTINUE KAX = 1 100 IF (DXI(KAX) - XJS(KAX) .GT. DUMA(KAX)) GOTO 120 XJS(KAX) = XJS(KAX) - 1.0 GOTO 100 110 KAX = KAX - 1 120 XJS(KAX) = XJS(KAX) + 1.0 IF (DXI(KAX) - XJS(KAX) .GE. DUMA(KAX)) GOTO 120 IF (XJS(KAX) - DXI(KAX) .LE. DUMA(KAX)) GOTO 130 KAX = KAX - 1 IF (KAX .GT. 0) THEN GOTO 120 ELSE GOTO 50 ENDIF 130 KAX = KAX + 1 IF (KAX .LT. 4) GOTO 100 NPOW = 1000 IPR(26) = IPR(54) * NPOW + 555 DO 140 J = 1, 3 NPOW = NPOW / 10 TEMP = XJS(IPR(33 + J)) ITR(J) = ITR(J) + NINT(TEMP - XJS(J + 6)) XJS(J + 6) = TEMP IF (IABS(ITR(J)) .GT. 4) THEN IPR(494) = IPR(494) + 1 GOTO 30 ENDIF IPR(26) = IPR(26) + ITR(J) * NPOW 140 CONTINUE KAT = IPR(39) + IPR(24) + 1 IF (KAT .GT. NP1 - IPR(75)) THEN IPR(2) = 1 GOTO 230 ENDIF IF (IPR(189) .EQ. 0) THEN DO 150 I = 1, 3 XJX(I) = XSD(JAT, I) 150 CONTINUE NSMM = - IPR(54) CALL SGSM (CSCRAT, NSMM, XJX, LU7, 3, IERR) ENDIF DO 170 N = 1, 3 J = 4 - N JP3 = J + 3 IF (JAT .NE. KAT) THEN XXO(KAT, J) = XJS(J + 6) XSD(KAT, J) = XJX(J + 6) ENDIF XXO(KAT, JP3) = 0 XSD(KAT, JP3) = 0 DO 160 L = J, 3 ORJK = OR(J, L) XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * ORJK IF (IPR(189) .EQ. 0) THEN IF (IPR(72) .NE. 0) THEN XSD(KAT, JP3) = XSD(KAT, JP3) 1 + XSD(KAT, L) * ORJK**2 ENDIF ENDIF 160 CONTINUE 170 CONTINUE 180 DIJK = (XXO(IAT, 4) - XXO(KAT, 4))**2 + 1 (XXO(IAT, 5) - XXO(KAT, 5))**2 + 2 (XXO(IAT, 6) - XXO(KAT, 6))**2 IF (DIJK .LE. P23K) THEN DIJ = SQRT(DIJK) IF (IPR(189) .EQ. 0) THEN IF (IPR(26) .EQ. 1555 .AND. IAT .EQ. JAT) GOTO 30 CALL GEN048 (-1, IFG(JAT), 23, IVAL) CALL GEN048 (-1, JFG(JAT), 28, IVAL1) IPR(63) = IVAL + IVAL1 * IGBL(56) CALL GEN048 (-7, JFG(JAT), 1, JPP) IPR(120) = IPPR(JPP + 1, 1) IF (IPR(120) .LT. 1000) THEN IPR(99) = 1 - IPR(502) * IABS(IPR(17)) ELSE IPR(99) = 0 ENDIF IF (IPR(98) + IPR(99) .EQ. 2) THEN IF (IPR(17) .EQ. 0) THEN IF (IPR(189) .EQ. 0) THEN CALL GEN048 (6, IFG(JAT), 9, IPR(75)) CALL GEN048 (-1, IFG(JAT), 1, IBT1) CALL GEN048 (-1, IFG(JAT), 2, IBT2) IF (IBT2 .EQ. 0 .AND. IBT1 .EQ. 0) THEN IF (IPR(127) .NE. IPR(120)) THEN CALL GEN048 (3, IFG(JAT), 1, 6) ENDIF ELSE IF (IPR(26) .EQ. 1555) THEN CALL GEN048 (1, JFG(JAT), 9, 1) IF (IBT1 .EQ. 0) CALL GEN048 (1, IFG(JAT), 3, 1) ENDIF ENDIF ENDIF IF (IPR(127) .NE. IPR(120)) THEN IF (IPR(127) .LT. 500 .AND. IPR(120) .LT. 500) THEN IF (IABS(2 * IPR(127) - IPR(120)) .GT. 1 .AND. 1 IABS(2 * IPR(120) - IPR(127)) .GT. 1) GOTO 30 ELSE IF (IPR(127) + IPR(120) .GE. 999) THEN GOTO 30 ENDIF ENDIF IF (IPR(154) .EQ. 0) THEN IF (IPR(128) .EQ. 500 .AND. IPR(54) .GT. 1) GOTO 30 ENDIF ENDIF IF (IPR(17) .NE. 0) THEN IPR(20) = 1 IARU = NINT(PAR(42)) IF (IPR(61) .EQ. IPR(62)) THEN IF (IPR(26) .NE. 1555) THEN CALL GEN048 (-1, IFG(JAT), 6, JSP) IF (JSP .EQ. 1) THEN IF (IPR(17) .LT. 0) THEN DO 190 L = 1, IPR(37) CALL PLA050 (L, KAT, 0, 0, DST) IF (DST .LT. 0.001) GOTO 30 190 CONTINUE ENDIF ENDIF ENDIF NITJ = IPR(26) * IARU IF (NITJ .NE. 1555 * IARU) NITJ = NITJ + IPR(62) N51 = IPR(51) DO 200 L = 1, N51 MOLL = MOL(L) IF (L + IPR(101) .GT. N51) 1 MOLL = MOLL - NSYM * 1000 * IARU IF (MOLL .EQ. NITJ) GOTO 210 200 CONTINUE GOTO 220 210 IF (L + IPR(101) .GT. N51) GOTO 30 IPR(20) = 0 ENDIF ENDIF 220 IF (IPR(17) .LT. 0) THEN PAR26 = REL(IPR(509)) + REL(IPR(510)) IF (IPR(510) .EQ. 3 .AND. IPR(509) .EQ. 1) THEN PAR26 = PAR26 + 0.25 ELSE PAR26 = PAR26 + PAR(2) ENDIF ELSE PAR26 = PAR(18) ENDIF IF (IPR(27) .NE. 0 .OR. DIJ .GT. PAR26) THEN CALL PLA071 (IAT, JAT, KAT, DIJ) ENDIF IF (IPR(2) .NE. 0) GOTO 230 ELSE IF (DIJ .GT. PAR(23) - PAR(20)) THEN IPR(199) = -1 GOTO 30 ELSE IPR(199) = 1 GOTO 230 ENDIF ENDIF ENDIF IF (IPR(17) .GT. 0) THEN IF (IPR(203) .GT. 0) GOTO 230 ELSE IF (IPR(17) .EQ. 0) THEN ENDIF GOTO 30 230 RETURN END SUBROUTINE PLA071 (IAT, JAT, KAT, DIJ) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) IDS = 0 IAUX = 0 NAT = IPR(39) IARU = NINT(PAR(42)) IF (IPR(17) .EQ. 0) THEN IF (IPR(509) .EQ. 1 .OR. IPR(510) .EQ. 1) THEN IF (DIJ .GT. 2.0) GOTO 140 ENDIF CALL GEN048 (-1, IFG(JAT), 7, JHAT) IF (JHAT .EQ. 1) THEN IF (IPR(509) .EQ. 2) THEN CALL GEN048 (-6, IFG(JAT), 9, IYK) IF (IYK .EQ. 0) THEN CALL GEN048 (-1, JFG(JAT), 10, IESD) IPR(474) = IPR(474) + IESD ENDIF ENDIF ENDIF CALL GEN048 (6, IFG(JAT), 9, IPR(75)) CALL GEN048 (-1, IFG(JAT), 1, IBT1) CALL GEN048 (-1, IFG(JAT), 2, IBT2) IF (IBT2 .EQ. 1 .AND. IPR(26) .EQ. 1555) THEN CALL GEN048 (1, JFG(JAT), 9, 1) ENDIF IF (IBT1 .EQ. 0) CALL GEN048 (1, IFG(JAT), 3, 1) CALL GEN048 (-1, IFG(JAT), 3, IBT3) IF (IBT2 .EQ. 0) THEN IF (IPR(99) .NE. 0) THEN IF (IPR(26) .NE. IPR(166)) THEN IF (IBT1 .EQ. 0) CALL GEN048 (1, IFG(JAT), 3, 0) GOTO 140 ENDIF ENDIF CALL GEN048 (1, IFG(JAT), 2, 1) CALL GEN048 (1, JFG(JAT), 9, 1) IF (IPR(157) .GE. 0 .AND. IPR(158) .LT. 0) IPR(203) = 1 IF (IATP(JAT) .LE. 0) IATP(JAT) = 1555 IF (IPR(26) .NE. 1555) THEN DO 60 L = 1, 6 XXO(JAT, L) = XXO(KAT, L) XSD(JAT, L) = XSD(KAT, L) 60 CONTINUE FN(1) = IPR(54) ITRNS = IPR(54) * 1000 + 555 DO 70 L = 2, 4 FN(L) = ITR(L - 1) ITRNS = ITRNS + ITR(L - 1) * 10**(4 - L) 70 CONTINUE IATP(JAT) = ITRNS WRITE (LU4) 5, XLAB(JAT), (FN(L), L = 1, 8) ENDIF KAT = JAT IPR(80) = 1 GOTO 140 ELSE ENDIF ELSE IF (IPR(17) .LT. 0) THEN N51 = IPR(51) N511 = N51 - IPR(101) MOL511 = (IPR(48) * 1000 + IPR(26)) * IARU + IPR(62) DO 50 K = 1, N51 IF (K .GT. N511) THEN IF (MOL(K) .EQ. MOL511) GOTO 140 ENDIF MOLK = MOL(K) / IARU IRES = MOL(K) - MOLK * IARU IF (MOLK .EQ. IPR(26)) THEN IF (IRES .EQ. 0 .OR. IPR(62) .EQ. IRES) THEN DO 40 N = 1, NAT CALL PLA050 (N, KAT, 0, 0, D) IF (D .LT. PAR(18)) THEN KAT = N IF (IPR(61) .NE. IPR(62)) THEN GOTO 130 ELSE CALL GEN048 (-1, IFG(IAT), 23, IDAC) CALL GEN048 (-1, IFG(KAT), 23, KATDAC) NCI = - NINT(CON(IAT, NP4)) IF (NCI .LT. 0) NCI = NP4 NCJ = - NINT(CON(KAT, NP4)) IF (NCJ .LT. 0) NCJ = NP4 DO 30 MI = 1, NCI LI = NINT(CON(IAT, MI)) IF (LI .LE. NP1) THEN IF (LI .EQ. KAT) GOTO 140 CALL GEN048 (-4, IFG(LI), 15, NOLI) IF (MOD(IATPR(IEN(NOLI + 1)), 7) .LT. 5) THEN DO 20 MJ = 1, NCJ LJ = NINT(CON(KAT, MJ)) IF (LJ .LE. NP1) THEN IF (LI .EQ. LJ) THEN CALL GEN048 (-1, IFG(LI), 19, LIMET) IF (LIMET .EQ. 0) GOTO 140 GOTO 130 ELSE NCK = - NINT(CON(LJ, NP4)) IF (NCK .LT. 0) NCK = NP4 DO 10 MK = 1, NCK LK = NINT(CON(LJ, MK)) IF (LK .EQ. LI) THEN CALL GEN048 (-1, IFG(LK), 19, LKMET) IF (LKMET .EQ. 0 .AND. (IDAC .EQ. 0 1 .OR. KATDAC .EQ. 0)) GOTO 140 GOTO 130 ENDIF 10 CONTINUE ENDIF ENDIF 20 CONTINUE ENDIF ENDIF 30 CONTINUE GOTO 130 ENDIF ENDIF 40 CONTINUE GOTO 140 ENDIF ENDIF 50 CONTINUE ENDIF IF (IPR(17) .GE. 0) THEN NTOT = IPR(39) + IPR(24) DO 90 I = 1, NTOT CALL PLA050 (I, KAT, 0, 0, D) IF (D .LT. PAR(18)) THEN KAT = I IF (IPR(17) .GT. 0) THEN NCX = IPR(79) KATX = KAT + IPR(20) * NP1 DO 80 L = 1, NCX IF (KATX .EQ. IATC(L)) GOTO 140 80 CONTINUE ENDIF GOTO 130 ENDIF 90 CONTINUE IF (IPR(17) .EQ. 0) THEN IF (IPR(98) + IPR(99) .GT. 0) THEN IF (DIJ + 2 * PAR(2) .LE. PAR(23)) 1 IDS = IPR(154) * IPR(48) * 1000 * IARU ENDIF GOTO 100 ENDIF ENDIF IPR(24) = IPR(24) + 1 IAUX = 1 IFG(KAT) = IFG(JAT) JFG(KAT) = JFG(JAT) CALL GEN048 (1, IFG(KAT), 5, 1) 100 NMOL = IPR(13) IF (IPR(26) .NE. 1555) THEN IF (IPR(62) .EQ. 0) IPR(62) = IPR(61) MOL(NMOL + 1) = IPR(26) * IARU + IPR(62) + IDS IF (NMOL .GT. 1) THEN DO 110 MM = 2, NMOL IF (MOL(MM) .EQ. MOL(NMOL + 1)) GOTO 120 IF (MOL(MM) - IPR(48) * 1000 * IARU .EQ. 1 MOL(NMOL + 1)) THEN IPR(24) = IPR(24) - IAUX GOTO 140 ENDIF IF (MOL(MM) + IDS .EQ. MOL(NMOL + 1)) THEN MOL(MM) = MOL(NMOL + 1) GOTO 120 ENDIF 110 CONTINUE ENDIF IF (IPR(13) + 3 .LT. NP11) THEN IPR(13) = IPR(13) + 1 MM = IPR(13) MLTI(IPR(62)) = MLTI(IPR(62)) + 1 ELSE IPR(138) = IPR(138) + 1 IPR(24) = IPR(24) - IAUX GOTO 140 ENDIF 120 IF (IPR(17) .NE. 0) THEN IF (MM .GT. IPR(463) - 1) THEN IPR(2) = 54 GOTO 140 ENDIF XLAB(KAT) = XLAB(JAT) + MM - 1 ENDIF ENDIF 130 IF (IPR(17) .EQ. 0) THEN IF (KAT .LE. IPR(37)) THEN CALL GEN048 (-1, IFG(IAT), 23, IDOA) CALL GEN048 (-1, IFG(KAT), 7, IHA) IF (IDOA .EQ. 1 .AND. IHA .EQ. 1) THEN CALL GEN048 (1, IFG(IAT), 21, 1) CALL GEN048 (1, IFG(KAT), 20, 1) ENDIF ENDIF ELSE IF (IPR(17) .LT. 0) THEN CALL PLA057 (IAT, JAT, KAT) CALL GEN048 (-1, IFG(IAT), 7, IHA) IF (IHA .EQ. 1 .AND. IPR(63) .EQ. 1) THEN IF (KAT .LE. NAT) THEN IPR(24) = IPR(24) - IAUX IAUX = 0 ENDIF IF (DIJ .GT. (PAR(23) - PAR(1) + PAR(9))) THEN IPR(24) = IPR(24) - IAUX GOTO 140 ENDIF KAT = KAT + NP1 CALL PLA041 (1, IAT, IVAL, KAT) ELSE IPR(24) = IPR(24) - IAUX ENDIF ELSE IPR(79) = IPR(79) + 1 IATC(IPR(79)) = KAT + IPR(20) * NP1 DATC(IPR(79)) = DIJ IF (IPR(79) .GE. NP1) THEN CALL GEN013 (DATC, IATC, 1, IPR(79)) IPR(79) = NP1 - 5 PAR(23) = DATC(IPR(79)) ENDIF ENDIF 140 RETURN END SUBROUTINE PLA072 (IAT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) CHARACTER IMRK0*4, IMRK1*5, IMRK2*4, FORMA*71, FORMB*133, POLY*4, 1 FORMC*96, FORMD*76, FORME*156, FORMK*6, CXMOL*9 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGGT/ IGGT CHARACTER IGGT*80 CHARACTER NQ5*7 DIMENSION YP(3, 12) IPR(440) = - IABS(IPR(440)) DO 1 I = 1, 100 YMOL(1, I) = -1000.0 1 CONTINUE 5 IMRK2 = ' ' ANGLE = 0.0 SANGL = 0.0 DIJ = 0.0 SDIJ = 0.0 SOME = 0.0 ISANGL = 0 NDEC = 0 NDEC1 = 0 NDEC2 = 0 ISANG = 0 INUM = 0 IDIS = 0 ISDIJ = 0 PSCL = 0.0 J2 = 0 FORMA( 1: 31) = '(I2,F8.4,''('',I2,'')'', A,A,''['',A,' FORMA(32: 71) = '''='',A ,''] '',A,2F7.2,1X,3F9.5,2X,3F8.4)' FORMB( 1: 4) = '( ' FORMB( 5: 33) = ' A , '', '', A ,F7.2,''('',I3,'')''' FORMB(34: 66) = ',4X,'//FORMB(5:33) FORMB(67:133) = FORMB(34:66)//FORMB(34:66)//')' FORMC( 1: 45) = '(F4.1,'' Angstrom Coordination Sphere Around ''' FORMC(46: 78) = ',''Atom I = '',A,''[ARU ='',F8.2,'']'',' FORMC(79: 96) = '7X,3F9.5,2X,3F8.4)' FORMD( 1: 39) = '(A,'' , '',A,F8.2,''('',I3,'')'',5X,F8.4,''('',' FORMD(40: 76) = 'I3,'')'',3X,4(F8.2,''('',I3,'')''),2(2X,A))' FORME( 1: 29) = '(''Dist. '',A,'' - Polyh_C.G.:'',' FORME(30: 57) = 'F6.3,''('',I3,'') Ang, C.G.:'',' FORME(58: 73) = 'F9.5,''('',I2,'')'',' FORME(74:108) = FORME(58:73)//FORME(58:73)//'5X,' FORME(109:124)= 'F9.4,''('',I2,'')'',' FORME(125:156)= FORME(109:124)//FORME(109:123)//')' FORMK(1:6) = '(F9.2)' IF (PAR(42) .LT. 100.0) THEN FORMK(5:5) = '1' FORMC(73:73) = '1' ENDIF CALL PLA047 (XLAB(IAT), NQ3, MNX, IENI, 0, IGBL(55), 0, 1 1 - IGBL(55)) NC = IPR(79) IF (NC .EQ. 0) THEN IF (IPR(57) .EQ. 1) WRITE (LU6, 99996) PAR(262), NQ3 GOTO 280 ENDIF CALL GEN048 (-1, IFG(IAT), 23, IDOA) NMAX = IPR(39) KPC = NMAX + IPR(24) + 1 IF (KPC + NC .GT. NP1 - IPR(75)) THEN IPR(2) = 1 GOTO 280 ENDIF IF (IPR(15) .EQ. 0) THEN IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN IF (IPR(57) .EQ. 0) THEN PAGET = 'COORDN' CALL PLA269 (0) WRITE (LU7, 99990) ELSE IF (IPR(57) .LT. 0) THEN PAGET = 'DSCAN' CALL PLA269 (0) WRITE (LU7, 99986) LMT(- IPR(57), 1) ELSE PAGET = 'METAL' CALL PLA269 (0) WRITE (LU7, 99989) ENDIF WRITE (LU7, 99988) ENDIF IPR(15) = 1 ENDIF VDWI = ABS(VDWR(IENI)) CALL GEN048 (-6, IFG(IAT), 9, IRESI) CALL PLA036 (IAT, 1, 1, IDUM1, MNI, IDUM3, IPR(119), IGBL(55)) NCI = 0 NDB = 0 DO 20 J = 1, NC KAT = IATC(J) MKAT = MOD (KAT, NP1) IDUB = 0 IF (J .GT. 1) THEN DO 10 K = 2, J IF (MKAT .EQ. MOD(IATC(K - 1), NP1)) THEN IDUB = 2 NDB = NDB + 1 ENDIF 10 CONTINUE ENDIF CALL GEN048 (-1, IFG(MKAT), 7, IHA) PADD = (IDUB + IHA + 1) * PAR(23) IF (KAT .LE. NP1) THEN CALL PLA041 (-1, IAT, JJ, KAT) IF (JJ .GT. 0) THEN NCI = NCI + 1 PADD = 0 ENDIF ENDIF DATC(J) = PADD + DATC(J) 20 CONTINUE CALL GEN013 (DATC, IATC, 1, NC) NC = NC - NDB XMOL1 = (1555 * PAR(42) + IRESI) / PAR(42) IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA269 (-4) IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0) 1 CALL PLA096 (0, NAMS(1, 1)(2:8), 0.0, PAR(454)) WRITE (PRBUF, FORMC) PAR(23), NAMS(1, 1)(2:8), XMOL1, 1 (XXO(IAT, L), L = 1, 6) CALL PLA067 (LU7, PRBUF, 132, 1, 10) WRITE (LU7, 99981) WRITE (LU7, 99987) ENDIF IF (IPR(168) .NE. 0 .OR. IPR(170) .NE. 0) THEN WRITE (PRBUF, 99980) PAR(23), NAMS(1, 1)(2:8) WRITE (LU6, 99977) PRBUF(1:46) IWIN = 0 IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(121) .EQ. 0) THEN IWIN = 1 CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.6 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT) VRT = VRT - 0.1 PXOR = 0.80 * HORS PYOR = 0.72 * VERT PSCL = 0.22 * HORS / PAR(23) ENDIF ENDIF IF (IGBL(31) .EQ. 3) THEN WRITE (LU2, 99993) WRITE (LU2, 99995) NQ3(1:6) WRITE (LU2, 99994) NQ3(1:6), 1 (XXO(IAT, L), L = 4, 6), (XSD(IAT, L), L = 4, 6) ENDIF DMAX = 0 DO 60 J = 1, NC ICOL = 1 KAT = IATC(J) IPR(20) = 0 IF (KAT .GT. NP1) THEN KAT = KAT - NP1 IATC(J) = KAT IPR(20) = 1 ENDIF CALL GEN048 (-6, IFG(KAT), 9, IRESJ) CALL PLA036 (KAT, 1, 2, IDUM1, MNJ, IDUM3, IPR(119), IGBL(55)) IF (MNJ .GT. 1) THEN MOLMNJ = MOL(MNJ) ELSE MOLMNJ = NINT(1555 * PAR(42) + IRESJ) ENDIF XMOL = MOLMNJ / PAR(42) IF (ABS(XMOL1 - XMOL) .LT. 0.005) IPR(20) = 0 CALL GEN048 (-1, IFG(KAT), 23, KDOA) XLABX = - XLAB(KAT) CALL PLA047 (XLABX, NQ4, MNY, IENK, IPR(119), IGBL(55), 0, 1 1 - IGBL(55)) NQ5 = NQ4 CALL PLA046 (2, NQ4, IDUM, LBB, LBC, LBD, XLMP, YNQNR, KATP) CALL PLA047 (XLAB(KAT), NQ3, MNY, IENK, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) VDWIK = ABS(VDWR(IENK)) + VDWI CALL PLA053 (IAT, KAT, 0, 0, DIJ, SDIJ, ISDIJ, NDEC, IER) IF (IER .NE. 0) GOTO 60 IF (DIJ .LT. DMAX .AND. IGBL(63) .GT. 2 1 .AND. IENI .NE. 2) THEN CALL PLA269 (1) WRITE (LU7, 99999) ENDIF IF (J .GT. NCI) THEN DELTA = DIJ - VDWIK IF (DELTA .GT. 0.0) THEN IMRK0 = ' .. ' ICOL = 3 ELSE IF (DELTA .LT. - 0.2) THEN IMRK0 = ' << ' ICOL = 2 ELSE IMRK0 = ' .< ' ICOL = 6 ENDIF IF (IPR(20) .NE. 0 .AND. IAT .LE. KATP) THEN CALL GEN048 (-1, IFG(IAT), 19, IMET) CALL GEN048 (-1, IFG(KAT), 19, KMET) CALL GEN048 (-7, JFG(KAT), 1, KPP) IF (IRESI .NE. IRESJ .OR. IPR(322) .EQ. 0) THEN IF (IDOA + KDOA .EQ. 2) THEN CALL GEN048 (-1, IFG(IAT), 21, IDO) CALL GEN048 (-1, IFG(KAT), 21, KDO) IF (IMET + KMET .EQ. 0) THEN IF (IATPR(IENI) .NE. -7 .AND. 1 IATPR(IENK) .NE. -7 .AND. DIJ .LT. 2.9) THEN IF (IDO + KDO .EQ. 0) THEN WRITE (LU20, 99978) '_430', 1 - DELTA, DIJ, NAMS(1, 1)(2:8), NQ5(1:7) ENDIF ELSE IF (IATPR(IENI) .EQ. -7) THEN IF (KDO .EQ. 0) THEN DIJT = 10.0 IF (IENI .EQ. 38 .AND. IENK .EQ. 38) DIJT = 2.6 IF (IENI .EQ. 5 .AND. IENK .EQ. 5) DIJT = 3.15 IF (DIJ .LT. DIJT) THEN WRITE (LU20, 99978) '_431', 1 - DELTA, DIJ, NAMS(1, 1)(2:8), NQ5(1:7) ENDIF ENDIF ENDIF ENDIF ELSE CALL GEN048 (-1, IFG(IAT), 7, IHAT) CALL GEN048 (-1, IFG(KAT), 7, KHAT) IF (IHAT + KHAT + IMET + KMET .EQ. 0) THEN IF (IPR(127) .GT. 150 .OR. IPR(120) .GT. 150) THEN N = 432 ELSE N = 433 ENDIF WRITE (LU20, 99984) '_', N, 1 - DELTA, DIJ, NAMS(1, 1)(2:8), NQ5(1:7) ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IMRK0 = ' -- ' ENDIF DMAX = DIJ ISDIJ = MIN (99, ISDIJ) FORMA(8 : 8) = CHAR(ICHAR('0') + NDEC) CALL PLA050 (IAT, KAT, 0, 0, DIJN) DO 30 JJ = 4, 6 XXO(KPC, JJ) = (XXO(KAT, JJ) - XXO(IAT, JJ)) / DIJN XSD(KPC, JJ) = XSD(IAT, JJ) 30 CONTINUE DO 40 JJ = 4, 6 XXO(KPC + J, JJ) = XXO(IAT, JJ) + XXO(KPC, JJ) XSD(KPC + J, JJ) = XSD(IAT, JJ) 40 CONTINUE XLAB(KPC + J) = XLAB(KAT) JATC(J) = IATC(J) IF (ABS(XXO(KPC, 6)) .LT. 0.999) THEN XMU = 90.0 - GL(5) * ACOS(XXO(KPC, 6)) PHI = GL(5) * ATAN2(XXO(KPC, 5), XXO(KPC, 4)) ELSE XMU = SIGN(90.0, XXO(KPC, 6)) PHI = 0.0 ENDIF IF (IPR(20) .EQ. 0) THEN IMRK1 = 'Intra' ELSE IMRK1 = ' ' ENDIF CALL GEN098 (MOLMNJ, PAR(42), MOL0, MOL1, MOL2, MOL3, IDUM) XJX(4) = MOL1 XJX(5) = MOL2 XJX(6) = MOL3 CALL SGSM (IDM, MOL0, XJX, 0, 20, IERR) CALL GEN020 (-1, IDM, 1, 20) IF (IDM(1 : 6) .EQ. 'x,y,z ') IDM(1:5) = ' ' WRITE (CXMOL, FORMK) XMOL IF (XMOL .EQ. XMOL1) CXMOL = ' ' IF (INT(XMOL) .EQ. 1555) CXMOL(1:7) = ' ' IF (IMRK2 .NE. IMRK0) THEN VRT = VRT - 0.2 IMRK2 = IMRK0 ENDIF JPR = MIN (J, 99) IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0) 1 CALL PLA096 (1, NAMS(1, 2)(2:8), DIJ, PAR(454)) WRITE (PRBUF, FORMA) JPR, DIJ, ISDIJ, IMRK0, NAMS(1, 2), 1 IDM(1:20), CXMOL, IMRK1, PHI, XMU, (XXO(KAT, L), L = 1, 6) IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA067 (LU7, PRBUF, 132, 1, 3) IF (J .EQ. NCI .AND. NCI .GT. 0 .AND. NC .GT. NCI) THEN CALL PLA269 (1) WRITE (LU7, 99999) ENDIF ENDIF IF (IPR(168) .NE. 0 .OR. IPR(170) .NE. 0) THEN CALL PLA067 (LU6, PRBUF, 58, 1, 3) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.5 YMOL(1, JPR) = VRT + 0.175 YMOL(2, JPR) = XMOL IF (ICOL .EQ. 2) THEN NRLN = 2 + KDOA ELSE NRLN = 2 ENDIF LINE = PRBUF(1:26)//' '//PRBUF(49:57)//' = '//PRBUF(28:47) CALL GGIP20 (0.0, LINE, 59, 0.35, ICOL, NRLN, 0.1, VRT) DO 50 L = 1, 3 V1(L) = (XXO(KAT, L + 3) - XXO(IAT, L + 3)) * PSCL 50 CONTINUE CALL GEN002 (-1, RMAT, V1, V2, YUNK) IF (ICOL .NE. 3) THEN CALL GGIP20 (0.0, PRBUF, 2, 0.4, ICOL, NRLN, 1 PXOR + V2(1) - 0.4, PYOR + V2(2) - 0.20) IF (V2(3) .GE. 0) THEN ICOL0 = 3 ELSE ICOL0 = 4 ENDIF CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0) CALL GGIP (PXOR, PYOR, 0.0, 3) QXOR = PXOR + V2(1) * 0.9 QYOR = PYOR + V2(2) * 0.9 CALL GGIP (QXOR, QYOR, 0.0, 2) ENDIF ENDIF ENDIF IF (IGBL(31) .EQ. 3) WRITE (LU2, 99994) NQ3(1:6), 1 (XXO(KAT, L), L = 4, 6), (XSD(KAT, L), L = 4, 6) 60 CONTINUE IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0) 1 CALL PLA096 (-1, ' ', 0.0, PAR(454)) IF (IGBL(31) .EQ. 3) WRITE (LU2, 99993) IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN IF (NCI .GE. 4 .AND. NCI .LE. 12) THEN DO 80 J = 1, NCI DO 70 K = 1, 3 YP(K, J) = XXO(IATC(J), K + 3) - XXO(IAT, K + 3) 70 CONTINUE 80 CONTINUE CALL PLA278 (NCI, YP, LU7) ENDIF ENDIF IF (IPR(7) .EQ. 0) GOTO 280 IF (IPR(122) .LT. 0) IPR(122) = 0 IF (IPR(122) .EQ. 0 .AND. NCI .EQ. 5 .AND. IPR(7) .GT. 0) 1 IPR(122) = -5 IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA269 (3) WRITE (LU7, 99998) NAMS(1, 1)(1:7) ENDIF KB = 0 NN = NC - 1 DO 100 J1 = 1, NN JB1 = JATC(J1) CALL GEN048 (-1, IFG(JB1), 7, IVL) IF (IVL .EQ. 0 .OR. IPR(521) .NE. 0) THEN MM = MAX (J1, IABS(IPR(122))) + 1 DO 90 J2 = MM, NC JB2 = JATC(J2) CALL GEN048 (-1, IFG(JB2), 7, IVL) IF (IVL .EQ. 0 .OR. IPR(521) .NE. 0) THEN CALL PLA053 (JB1, IAT, JB2, 0, ANGLE, SANGL, ISANGL, 1 NDEC, IER) IF (IER .NE. 0) GOTO 90 KB = KB + 1 CALL PLA036 (JB1, KB, 2, IDUM1, IDUM2, IDUM3, IPR(119), 1 IGBL(55)) CALL PLA036 (JB2, KB, 3, IDUM1, IDUM2, IDUM3, IPR(119), 1 IGBL(55)) DBUF(KB) = ANGLE IDBUF(KB) = MIN (999, ISANGL) IFT = -11 + KB * 33 FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IF (KB .GE. 4) THEN IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN WRITE (PRBUF, FORMB) ((NAMS(L, M), 1 M = 2, 3), DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF KB = 0 ENDIF ENDIF 90 CONTINUE ENDIF 100 CONTINUE IF (KB .GT. 0 .AND. IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 2, 3), 1 DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF NC = MIN (NC, IABS(IPR(122))) IF (NC .EQ. 0 .OR. NC .LT. IABS(IPR(122))) GOTO 280 DO 110 I = 1, NMAX IATP(I) = I + 2 * NP1 110 CONTINUE DO 120 I = 1, 5 IATP(JATC(I)) = JATC(I) 120 CONTINUE IATP(IAT) = IAT + NP1 NANG = 0 ANG1 = 0.0 ANG2 = 0.0 DO 130 JJ = 1, 6 XXO(KPC, JJ) = 0.0 XSD(KPC, JJ) = 0.0 130 CONTINUE DO 150 II = 1, NC IP = IATC(II) DO 140 JJ = 1, 3 XXO(KPC, JJ) = XXO(KPC, JJ) + XXO(IP, JJ) XXO(KPC, JJ + 3) = XXO(KPC, JJ + 3) + XXO(IP, JJ + 3) XSD(KPC, JJ) = XSD(KPC, JJ) + XSD(IP, JJ) XSD(KPC, JJ + 3) = XSD(KPC, JJ + 3) + XSD(IP, JJ + 3) 140 CONTINUE DATC(II) = 0.0 IF (IPR(125) .EQ. 1 .AND. IABS(IPR(122)) .GT. 0) 1 IATC(II) = KPC + II 150 CONTINUE DO 160 JJ = 1, 3 XXO(KPC, JJ) = XXO(KPC, JJ) / NC XXO(KPC, JJ + 3) = XXO(KPC, JJ + 3) / NC XSD(KPC, JJ) = XSD(KPC, JJ) / (NC**2) XSD(KPC, JJ + 3) = XSD(KPC, JJ + 3) / (NC**2) 160 CONTINUE CALL PLA269 (2) IF (IPR(125) .EQ. 0) THEN POLY = 'Real' ELSE POLY = 'Unit' ENDIF CALL PLA053 (IAT, KPC, 0, 0, DBUF(1), SDIJ, IDIS, INUM, IER) IF (IER .EQ. 0) THEN IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA269 (3) IDBUF(1) = MIN (999, IDIS) FORME(33:33) = CHAR(ICHAR('0') + INUM) IFT0 = 45 DO 170 JJ = 1, 6 IF (JJ .EQ. 4) IFT0 = 48 XSIG = SQRT(XSD(KPC, JJ)) CALL GEN041 (XXO(KPC, JJ), XSIG, IDBUF(JJ + 1), IPR(183), 1 NDEC, IPR(68)) XSD(KPC, JJ) = XSIG ** 2 DBUF(JJ + 1) = XXO(KPC, JJ) IDBUF(JJ + 1) = MIN (99, IDBUF(JJ + 1)) IFT = IFT0 + JJ * 16 FORME(IFT:IFT) = CHAR(ICHAR('0') + NDEC) 170 CONTINUE WRITE (LU7, '(1X)') WRITE (PRBUF, FORME) NAMS(1, 1)(2:7), 1 (DBUF(JJ), IDBUF(JJ), JJ = 1, 7) CALL PLA067 (LU7, PRBUF, 132, 1, 3) WRITE (LU7, 99985) NAMS(1, 1)(1:7), POLY ENDIF ENDIF NN = NC - 1 DO 230 J1 = 1, NN JB1 = IATC(J1) IF (JB1 .GT. KPC) THEN IB1 = JATC(JB1 - KPC) ELSE IB1 = JB1 ENDIF MM = J1 + 1 DO 220 J2 = MM, NC JB2 = IATC(J2) IF (JB2 .GT. KPC) THEN IB2 = JATC(JB2 - KPC) ELSE IB2 = JB2 ENDIF IF (NC .EQ. IABS(IPR(122))) THEN ANG = 0.0 JX = 0 JY = 0 DO 190 J3 = 1, NC IF (J3 .NE. J1 .AND. J3 .NE. J2) THEN JB3 = IATC(J3) DO 180 J4 = 1, NC IF (J4 .NE. J1 .AND. J4 .NE. J2 .AND. J4 .NE. J3) THEN JB4 = IATC(J4) CALL PLA050 (JB3, JB1, JB2, JB4, OME) IF (ABS(OME) .GT. ANG) THEN JX = JB3 JY = JB4 ANG = ABS(OME) ENDIF ENDIF 180 CONTINUE ENDIF 190 CONTINUE IF (JX .EQ. 0 .OR. JY .EQ. 0) THEN WRITE (LU6, 99982) GOTO 280 ENDIF DO 200 II = 1, NC JZ = IATC(II) IF (JZ .NE. JB1 .AND. JZ .NE. JB2 .AND. 1 JZ .NE. JX .AND. JZ .NE. JY) GOTO 210 200 CONTINUE 210 CALL PLA053 (JX, JB1, JB2, JY, DBUF(3), SOME, IDUM1, 1 IDUM2, IER) IF (IER .NE. 0) GOTO 220 IDBUF(3) = MIN (999, NINT(SOME * 100.0)) CALL PLA053 (JX, JB1, JB2, JZ, DBUF(4), SOME, IDUM1, 1 IDUM2, IER) IF (IER .NE. 0) GOTO 220 IDBUF(4) = MIN (999, NINT(SOME * 100.0)) CALL PLA053 (JZ, JB1, JB2, JY, DBUF(5), SOME, IDUM1, 1 IDUM2, IER) IF (IER .NE. 0) GOTO 220 IDBUF(5) = MIN (999, NINT(SOME * 100.0)) DBUF(6) = 180.0 - ABS(DBUF(4) + DBUF(5)) IDBUF(6) = (IDBUF(4) + IDBUF(5))/2 IF (DBUF(6) .GT. 0) THEN NANG = NANG + 1 KBO(NANG, 1) = JB1 KBO(NANG, 2) = JB2 BOK(NANG, 1) = DBUF(6) DATC(J1) = DATC(J1) + 1 DATC(J2) = DATC(J2) + 1 ENDIF ENDIF CALL PLA053 (IB1, IAT, IB2, 0, DBUF(1), SANGL, ISANG, 1 NDEC1, IER) IF (IER .NE. 0) GOTO 220 CALL PLA053 (IB1, IB2, 0, 0, DBUF(2), SDIJ, IDIS, 1 NDEC2, IER) IF (IER .NE. 0) GOTO 220 IDBUF(1) = MIN (999, ISANG) IDBUF(2) = MIN (999, IDIS) FORMD(15 : 15) = CHAR(ICHAR('0') + NDEC1) FORMD(34 : 34) = CHAR(ICHAR('0') + NDEC2) CALL PLA036 (IB1, 1, 1, IDIS1, IDUM1, IDUM2, IPR(119), 1 IGBL(55)) CALL PLA036 (IB2, 1, 2, IDIS2, IDUM1, IDUM2, IPR(119), 1 IGBL(55)) CALL PLA047 (XLAB(JX), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) CALL PLA047 (XLAB(JY), NQ3, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) IF (DBUF(1) .GT. ANG1) THEN ANG2 = ANG1 ANG1 = DBUF(1) ELSE IF (DBUF(1) .GT. ANG2) THEN ANG2 = DBUF(1) ENDIF IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN WRITE (PRBUF, FORMD) (NAMS(1, M)(1:7), M = 1, 2), 1 (DBUF(L), IDBUF(L), L = 1, 6), NQ2, NQ3 CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF 220 CONTINUE 230 CONTINUE IF (IPR(122) .NE. 0) THEN IF (NC .EQ. 5) THEN IF (PAR(35) .GT. 0.0) THEN TBA = PAR(35) ELSE IF (IENI .EQ. 103) THEN TBA = 158 ELSE TBA = PAR(31) ENDIF PHC = COS(TBA / (2 * GL(5))) PHS = SIN(TBA / (2 * GL(5))) SPA1 = 180.0 - GL(5) * ATAN((1.0 + PHC) * SQRT(2.0) / PHS) SPA2 = 180.0 - 2.0 * GL(5) * ATAN(SQRT(2.0 / (1.0 + PHC))) TPA1 = 180.0 - 2.0 * GL(5) * ATAN(2.0 / SQRT(6.0)) TPA2 = 180.0 - 2.0 * GL(5) * ATAN(2.0) DTP = 4.0 * ABS(TPA1 - SPA1) + 2.0 * ABS(TPA1 - SPA2) + 1 2.0 * ABS(TPA2 - SPA2) + TPA2 IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA269 (4) WRITE (LU7, 99979) ANG1, ANG2, (ANG1 - ANG2) / 60.0 CALL PLA269 (8) WRITE (LU7, 99983) TBA, TPA1, TPA2, SPA1, SPA2, DTP ENDIF CALL GEN013 (DATC, IATC, 1, NC) CALL GEN013 (DATC, JATC, 1, NC) STP1 = 0.0 SSP1 = 0.0 SSP2 = 0.0 SSP3 = 0.0 DO 250 II = 1, NANG JB1 = KBO(II, 1) JB2 = KBO(II, 2) ANG = BOK(II, 1) DO 240 JJ = 1, NC IF (IATC(JJ) .EQ. JB1) J1 = JJ IF (IATC(JJ) .EQ. JB2) J2 = JJ 240 CONTINUE IF (J1 .GT. J2) THEN J0 = J1 J1 = J2 J2 = J0 ENDIF IF (J1 .GT. 2) THEN TP1 = TPA2 ELSE TP1 = TPA1 ENDIF STP1 = STP1 + ABS(TP1 - ANG) SP1 = SPA1 SP2 = SPA1 SP3 = SPA1 IF (J1 .EQ. 4 .AND. J2 .EQ. 5) SP1 = 0.0 IF (J1 .EQ. 3 .AND. J2 .EQ. 5) SP2 = 0.0 IF (J1 .EQ. 3 .AND. J2 .EQ. 4) SP3 = 0.0 IF (J1 .EQ. 3 .OR. J2 .EQ. 3) SP1 = SPA2 IF (J1 .EQ. 4 .OR. J2 .EQ. 4) SP2 = SPA2 IF (J1 .EQ. 5 .OR. J2 .EQ. 5) SP3 = SPA2 SSP1 = SSP1 + ABS(SP1 - ANG) SSP2 = SSP2 + ABS(SP2 - ANG) SSP3 = SSP3 + ABS(SP3 - ANG) 250 CONTINUE QSP1 = DTP - SSP1 QSP2 = DTP - SSP2 QSP3 = DTP - SSP3 CALL PLA047 (XLAB(IATC(3)), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CALL PLA047 (XLAB(IATC(4)), NQ2, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CALL PLA047 (XLAB(IATC(5)), NQ3, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CALL PLA050 (IATC(4), IAT, IATC(5), 0, TH11) CALL PLA050 (IATC(3), IAT, IATC(5), 0, TH21) CALL PLA050 (IATC(3), IAT, IATC(4), 0, TH31) CALL PLA050 (IATC(1), IAT, IATC(2), 0, TH00) CALL PLA050 (IATC(1), IATC(4), IATC(5), IATC(2), OME) DLP1 = 180.0 - ABS(OME) CALL PLA050 (IATC(1), IATC(3), IATC(5), IATC(2), OME) DLP2 = 180.0 - ABS(OME) CALL PLA050 (IATC(1), IATC(3), IATC(4), IATC(2), OME) DLP3 = 180.0 - ABS(OME) CALL PLA269 (6) BDIF = STP1 - QSP1 IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN WRITE (LU7, 99991) DTP, NQ1, STP1, SSP1, QSP1, DLP1, TH11, 2 TH00, NQ2, STP1, SSP2, QSP2, DLP2, TH21, TH00, NQ3, STP1, 3 SSP3, QSP3, DLP3, TH31, TH00 ENDIF IF (STP1 - QSP2 .LT. BDIF) THEN NQ1 = NQ2 QSP1 = QSP2 BDIF = STP1 - QSP1 ENDIF IF (STP1 - QSP3 .LT. BDIF) THEN NQ1 = NQ3 QSP1 = QSP3 BDIF = STP1 - QSP3 ENDIF BAVER = (STP1 + QSP1) / 2.0 PSTP1 = BAVER * 100.0 / DTP DO 260 JATCI = 1, 5 CALL PLA047 (XLAB(JATC(JATCI)), NQ2, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) IF (NQ2(1:6) .EQ. NQ1(1:6)) THEN IATP(JATC(JATCI)) = JATC(JATCI) + NP1 ENDIF 260 CONTINUE IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA269 (7) WRITE (LU7, 99992) PSTP1, '>', '>', NQ1(1:6), 1 BAVER, BDIF ENDIF ENDIF IF (PSTP1 .GT. 50) THEN IPR(12) = 4 CALL GEN022 (IATP, 1, NMAX) CALL PLA055 SGN = 1 DO 270 I = 1, 6 IATPI = MOD(IATP(I), NP1) CALL PLA036 (IATPI, I, 1, IDUM1, IDUM2, IDUM3, IPR(119), 1 IGBL(55)) CALL PLA056 (XPV(1), IATPI, DEV(I), SDV(I), IDUM1, 1 5, IDUM2) ISDV(I) = MIN (999, NINT(SDV(I) * 10000.0)) 270 CONTINUE IF (DEV(4) .LT. 0.0) SGN = -1.0 IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN CALL PLA269 (3) WRITE (LU7, 99997) (NAMS(I, 1)(2:8), I = 1, 4), 1 (NAMS(I, 1)(2:8), DEV(I) * SGN, ISDV(I), I = 1, 6) ENDIF ENDIF ENDIF 280 IF (IWIN .EQ. 1) THEN IF (IABS(IGBL(23)) .EQ. 1) THEN CALL PLA015 (0, 45) ENDIF CALL PLA297 (2) IF (IGGT(1:4) .EQ. 'CALC') GOTO 5 ENDIF IPR(440) = IABS(IPR(440)) RETURN 99999 FORMAT (1X) 99998 FORMAT (/, 'Angles (Degrees) At1...V...At2 with Vertex V = ', 1 A, /, 132('-')) 99997 FORMAT (/, '>> Distance to SP square base plane defined by:', 1 4(1X, A), /, 1X, 6(1X, A, F8.4, '(', I3, '),'), 'Ang.') 99996 FORMAT (':: No Metal-Metal Distances within ', F5.1, 1 ' Ang. for ', A) 99995 FORMAT ('TITL ', A, ' - COORDINATION') 99994 FORMAT ('ATOM ', A, 6F8.4) 99993 FORMAT ('ENDS') 99992 FORMAT (/, 'Trigonal Bipyramid (TP) to Square Pyramid (SP)', 1 ' ::: Perc. Along Berry Pseudorotation Coordinate:', F6.1, 3X, 2 '::: D3h ---', A, ' C2v ---', A, ' C4v', //, 'NOTE: This', 3 ' Analysis Depends on the Value of the Trans Basal Angle that', 4 ' is used (Default Value = 150 Deg.).', /, 6X, 'The Pivot Atom', 5 ' that Best Describes a Berry Pseudo Rotation is: ', A, /, 5X, 6 ' The Percentage has been Calculated for the Average value,', 7 F7.1, ' Deg., of the Second and Fourth Table Entry.', /, 5X, 8 ' The Difference,', F7.1, ' Deg., Between the Second and', 9 ' Fourth Table Entry (for pivot) should be Zero for a True', * ' Berry Rotation.') 99991 FORMAT (/, 'Pivot(3)', 4X, 'Sum(/Del:C - Del:TP/)', 8X, 'Sum(', 1 '/Del:C - Del:SP/)', 8X, F5.1, ' - Sum(/Del:C - Del:SP/)', 5X, 2 'Del(24) Th(24) Th(15)', /, 132('-'), 3(/, 1X, A, 8X, 3 3(F8.1, ' Deg.', 16X), 3F9.2)) 99990 FORMAT ('Analysis of the Coordination Geometry') 99989 FORMAT ('Analysis of Metal-Metal Geometry') 99988 FORMAT (132('-'), //, 'Distances are calculated from atom I', 1 ' of Unique Molecule Coordinate List to atom J in Asymmetric', 2 ' Residue Unit: ARU.', //, 'Phi = Azimuth angle(counter', 3 ' clockwise from XO in XO,YO-Plane), Mu = Angle between D and', 4 ' XO,YO-plane.', //, '''To-Code'' : ''--'' = Bonded atoms, ', 5 ' ''<<'' = .LT. sum vdW-radii - 0.2, ''.<'' = .LT. sum vdW', 6 '-radii, ''..'' = .GT. sum vdW-radii.', //, 7 '>>>> NOTICE >>>> : The Symmetry Code', 8 ' Character Added to the Atom Label Applies to the Current', 9 ' Coordination Sphere Only.', /, * '>>>>>>>>>>>>>>>> : Symmetry operations refer to the', 1 ' coordinates listed in the fractional coordinate table', 2 ' given above', //, 19X, 'The List May be', * ' Limited to the Shortest Distances.') 99987 FORMAT (1X, 'Nr d(I,J) To Atom J Symm_Oper. on Atom', 3 ' J', 4X, 'ARU(J) Type', 5X, 'Phi', 5X, 'Mu', 9X, 'X', 8X, 4 'Y', 8X, 'Z', 8X, 'XO', 6X, 'YO', 6X, 'ZO', /, 132('-')) 99986 FORMAT ('Distance Scan for Element ', A) 99985 FORMAT (/, 'Real Angles I - ', A, ' - J', 8X, 'Real Edge I - J', 1 5X, A4, ' Polyhedron Dihedral Angles', 5X, 'Norm. IJK:IJL', 2X, 2 'K', 8X, 'L', /, 132('-')) 99984 FORMAT (A, I3, 2F10.2, 2A) 99983 FORMAT (//, 'Analysis of Five-Coordination (See R.R. Holmes in ', 1 'Progress in Inorg. Chem. Vol. 32 (1984),119-235 and References', 2 ' Therein)', /, 132('-'), /, 'Idealized Dihedral Angles for', 3 ' Trans Basal Angle :', F6.1, /8X, 'Del(13) & Del(23) Trigonal', 4 ' Bipyramid (TP):', 2F6.1, /, 12X, 'Del(12) & Del(13) Square', 5 ' Pyramid (SP):', 2F6.1, /, 'Distance Between TP and SP Along', 6 ' Berry Coordinate:', F6.1) 99982 FORMAT (/, ':: Coordination Analysis Aborted !', //) 99981 FORMAT (132('-')) 99980 FORMAT (F5.1, ' Ang. Coordination Sphere Around ', A, 1 2X, 'Green = Above, Blue = Below Plane') 99979 FORMAT (/, 'Tau-Descriptor for 5-Coordination (A.W.Addison,T.N.', 1 'Rao,J.Reedijk,J.van Rijn,G.C.Verschoor, J.Chem.Soc.Dalton ', 2 'Trans.(1984),1349-1356)', /, 132('-'), /, 3 'Tau = (Beta - Alpha) / 60 = (', F6.2, '-', F6.2, ') / 60 =', 4 F5.2, ' : (Extreme forms: Tau = 0.00 for SP and 1.00 for TP)') 99978 FORMAT (A, 2F10.2, 2A) 99977 FORMAT (/, A, /) END SUBROUTINE PLA073 (NSMPR) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9,NMA=550) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /FORMT/ FORM CHARACTER ICH*1, JCH*1, CHYB*3, FORM*109, FORMA*82, NRND*4, 1 KTYPE*3, ISORD*4, IRS0*1, NOTE*1, NOTE1*1, IYSP1*1, 2 SPSITE*6, MOVE*8, VLAG*4 DIMENSION PERC(NP10) COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 CHARACTER CN3*1, CN31*1 IWIN = IGBL(25) * IGBL(32) FORMA( 1:40) = '(12X,''Calculated Density ='',F8.4,''('',I2,' FORMA(41:82) = ''') g cm-3 [= Mg m-3]'',24X,''** WARNING **'')' JBN = 0 IATCAR = 0 NC2 = 0 KL = IPR(220) KN = IPR(221) NATX = IPR(37) NAT = IPR(39) NRES = IPR(75) NSYM = IPR(48) LTYPE = 0 IRS0 = ' ' LRES = 0 NHAT = 0 NCEFF = 0 IF (IPR(18) .GT. 0) THEN IF (IWIN .EQ. 1) CALL GGIP (HORS, VERT, 0.0, 1) IF (IPR(18) .EQ. 1) NAT = NAT + IPR(64) IF (KN .GT. 0) LRES = NINT(FN(1)) IF (KL .GT. 2) CALL PLA037 (3, LTYPE, 2) NDLPM = 1 ELSE NDLPM = 2 PAGET = 'GEOMETRY' ENDIF C * LIST ATOMS IF (IABS(IPR(18)) .EQ. 1) THEN IF (IPR(18) .GT. 0) THEN WRITE (PRBUF, 99979) IF (IWIN .EQ. 1) THEN VRT = VERT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1 1.0, VRT) VRT = VRT - 0.2 ELSE WRITE (LU6, 99969) PRBUF(1:80) ENDIF GOTO 70 ENDIF IF (IPR(113) .NE. 0) GOTO 690 IPR(113) = 1 IF (IGBL(63) .GT. 1) THEN IF (IPR(23) .EQ. 0) THEN CALL PLA269 (0) ELSE CALL PLA269 (3) WRITE (LU7, 99957) PAR(11) ENDIF ENDIF IF (IPR(72) .EQ. 0 .OR. IPR(68) .EQ. 0) THEN NRND = ' Not' ELSE CALL GEN040 (IPR(68) * 10 - 1, NQ1, IP) NRND = '1:'//NQ1(1:2) ENDIF C * GET SHELDRICK TYPE ROUNDED ATOM WEIGHTS DO 10 I = 1, IAN K = IENS(I) L = IEN(K) IF (IPR(181) .EQ. 1) THEN IF (L .EQ. 1) THEN YUNK = 1000.0 ELSE YUNK = 100.0 ENDIF SATWT(K) = NINT(ATWT(L) * YUNK) / YUNK ELSE SATWT(K) = ATWT(L) ENDIF 10 CONTINUE DO 30 I = 1, IAN J = IEN(IENS(I)) IF (IPR(493) .NE. 5) THEN J = (J - 1) * 15 FN(I) = 0.0 DO 20 K = 1, 9, 2 FN(I) = FN(I) + SFAC(J + K) 20 CONTINUE ELSE FN(I) = RNSCL(J) ENDIF IPR(22) = MAX (IPR(22), IATNR(IEN(IENS(I)))) 30 CONTINUE IF (IGBL(63) .GT. 3) THEN CALL PLA269 (15) WRITE (LU7, 99974) NRND WRITE (LU7, 99991) (LMT(IENS(I), 1), I = 1, IAN) WRITE (LU7, 99994) (RADR(IENS(I), 2), I = 1, IAN) WRITE (LU7, 99992) (IATNR(IEN(IENS(I))), I = 1, IAN) WRITE (LU7, 99993) (SATWT(IENS(I)), I = 1, IAN) IF (IPR(493) .NE. 5) THEN WRITE (LU7, 99954) (FN(I), I = 1, IAN) ELSE WRITE (LU7, 99940) (FN(I), I = 1, IAN) ENDIF ENDIF IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 4) THEN DO 50 K = 1, 2 DO 40 I = 1, IAN J = IEN(IENS(I)) * 15 + K - 2 * IPR(493) FN(I) = SFAC(J) 40 CONTINUE IF (IGBL(63) .GT. 3) THEN CALL PLA269 (1) IF (K .EQ. 1) WRITE (LU7, 99953) (FN(I), I = 1, IAN) IF (K .EQ. 2) WRITE (LU7, 99952) (FN(I), I = 1, IAN) ENDIF 50 CONTINUE ENDIF IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 5) THEN DO 60 I = 1, IAN J = IEN(IENS(I)) IF (SATWT(IENS(I)) .GT. 0.1) THEN IF (IPR(493) .LT. 4) THEN YUNK = AMR(J, IPR(493)) ELSE YUNK = AMR(J, 1) * (PAR(17) / 0.56086)**3 ENDIF FN(I) = YUNK / (SATWT(IENS(I)) * 1.66054) ELSE FN(I) = 0.0 ENDIF 60 CONTINUE IF (IGBL(63) .GT. 3) THEN CALL PLA269 (6) WRITE (LU7, 99998) KRAD, (FN(I), I = 1, IAN) WRITE (LU7, 99990) (LMT(IENS(I), 2), I = 1, IAN) ENDIF ENDIF IF (IGBL(63) .GT. 3) THEN IF (IGBL(30) .EQ. 1) THEN NQ1 = 'NOMOVE' ELSE NQ1 = ' ' ENDIF WRITE (LU7, 99995) NQ1 ENDIF IF (IPR(23) .EQ. 0) THEN FORM(1:8) = '(A,1X,A,' FORM(9:47) = 'F11.0,A,I2,A,F11.0,A,I2,A,F11.0,A,I2,A,' FORM(48:88) = 'F8.0,A,I2,A,F8.0,A,I2,A,F8.0,A,I2,A,A,I3,' FORM(89:109) = '2F6.3,A,I3,A,A,1X,A3)' ELSE FORM(1:37) = '(I4,1X,A,42X,F9.0,A,I2,A,F9.0,A,I2,A,' FORM(38:56) = 'F9.0,A,I2,A,35X,A3)' ENDIF 70 IF (NRES .EQ. 0) THEN NRES0 = 0 ELSE NRES0 = 1 ENDIF C * LOOP OVER RESIDUES DO 120 N = NRES0, NRES IF (IPR(18) .GT. 0) THEN IF (NRES .GT. 1) WRITE (LU6, 99982) N ELSE IF (IGBL(63) .GT. 2) THEN IF (NRES .GT. 1) THEN CALL PLA269 (5) WRITE (LU7, 99981) N ENDIF CALL PLA269 (3) WRITE (LU7, 99971) ENDIF ENDIF NHAT = 0 NDIS = 0 DO 110 NDLP = 1, NDLPM NRAT = 0 DO 100 I = 1, NAT CALL GEN048 (-6, IFG(I), 9, IRESI) IF (N .EQ. IRESI) THEN CALL PLA036 (I, 1, 1, IDIS1, IDUM, ISP1, IPR(119), 1 IGBL(55)) CALL GEN048 (-1, IFG(I), 23, IDA0) CALL GEN048 (-1, IFG(I), 20, IDH0) CALL GEN048 (-1, IFG(I), 19, IMET) CALL GEN048 (-1, IFG(I), 7, IHAT) VLAG = '- ' IF (IABS(IGBL(8)) .EQ. 3) THEN VLAG = 'd ' CALL GEN048 (-1, JFG(I), 29, IVLAG) IF (IVLAG .EQ. 1) VLAG(1:1) = 'c' CALL GEN048 (-1, JFG(I), 30, IVLAG) IF (IVLAG .EQ. 1) VLAG(2:2) = 'R' CALL GEN048 (-1, JFG(I), 31, IVLAG) IF (IVLAG .EQ. 1) VLAG(2:2) = 'G' ENDIF IF (IPR(18) .LT. 0) THEN DO 80 J = 1, 3 XSIGMA = SQRT(XSD(I, J)) IF (IHAT .EQ. 1) THEN NDEF = 5 ELSE IF (INT(XSIGMA * 100000.0) .EQ. 0 .AND. 1 INT(XSIGMA * 1000000.0) .GT. 0) THEN NDEF = 6 ELSE NDEF = 5 ENDIF CALL GEN041 (XXO(I, J), XSIGMA, IXSD(J), 1 NDEF, NDEC, IPR(68)) XSD(I, J) = XSIGMA ** 2 IF (IPR(23) .EQ. 0) THEN NDC = J * 13 FORM(NDC:NDC) = CHAR(ICHAR('0') + NDEC) ENDIF IXSD(J) = MIN (99, IXSD(J)) XSIGMA = SQRT(ABS(XSD(I, J + 3))) NDEF = 4 YUNK = XXO(I, J + 3) IYUNK = IXSD(J + 3) CALL GEN041 (YUNK, XSIGMA, IYUNK, NDEF, NDEC, 1 IPR(68)) IF (IPR(23) .EQ. 0) THEN NDC = J * 12 + 39 ELSE NDC = J * 12 + 5 ENDIF FORM(NDC:NDC) = CHAR(ICHAR('0') + NDEC) IXSD(J + 3) = MIN (99, IYUNK) 80 CONTINUE ENDIF CALL GEN048 (-4, IFG(I), 15, NO1) NO1 = NO1 + 1 IF (IEN(NO1) .EQ. 5 .OR. IEN(NO1) .EQ. 6 .OR. 1 IEN(NO1) .EQ. 8) THEN IF (NINT(CON(I, NP4)) .LT. -3) THEN IDA0 = 0 CALL GEN048 (1, IFG(I), 23, IDA0) ENDIF ENDIF IAH0 = 0 IF (IHAT .EQ. 1) THEN IF (NINT(CON(I, NP4)) .EQ. -1) THEN J = NINT(CON(I, 1)) CALL GEN048 (-4, IFG(J), 15, NO2) IF (IEN(NO2 + 1) .EQ. 20) THEN IAH0 = 1 CALL GEN048 (1, JFG(I), 28, 1) ENDIF ENDIF ENDIF IF (NDLP .EQ. 1) THEN IF (IPR(18) .LT. 0) THEN IF (IEN(NO1) .EQ. 1) THEN IF (NHAT .EQ. 0) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99966) ENDIF NHAT = 1 ENDIF ELSE IF (NHAT .EQ. 1) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99966) ENDIF NHAT = 0 ENDIF ENDIF ENDIF ENDIF IF (ISP1 .EQ. 1) THEN IYSP1 = 'S' XJX(1) = XXO(I, 1) XJX(2) = XXO(I, 2) XJX(3) = XXO(I, 3) XJX(10) = 0.0 CALL SGSM (LINE, 0, XJX, LU6, 19, IERR) SPSITE = ' '//LINE(1:5) ELSE IYSP1 = ' ' SPSITE = ' ' ENDIF KTYPE = ' - ' IF (IAH0 .EQ. 1) KTYPE = 'A-H' IF (IDA0 .EQ. 1) KTYPE = 'D/A' IF (IDH0 .EQ. 1) KTYPE = 'D-H' IF (IMET .EQ. 1) KTYPE = 'Met' CALL GEN048 (-7, JFG(I), 1, IPP) IPP = IPP + 1 PPAR = IPPR(IPP, 1) / 1000.0 SPAR = IPPR(IPP, 2) / 1000.0 CALL GEN041 (PPAR, SPAR, IPPAR, 3, NDEC, IPR(68)) IF (IPR(23) .EQ. 0) FORM(93:93) = 1 CHAR(ICHAR('0') + NDEC) MULT = NSYM / IPPR(IPP, 3) SOF = PPAR / MULT ATTRS = NTRNS(I) / 1000.0 IF (IPR(18) .GT. 0) THEN IF (LTYPE .EQ. 0 .AND. LRES .EQ. 0 .OR. 1 LTYPE .EQ. 0 .AND. LRES .EQ. N .OR. 2 LTYPE .EQ. NO1 .AND. LRES .EQ. 0 .OR. 3 LTYPE .EQ. NO1 .AND. LRES .EQ. N) THEN IF (IPR(23) .EQ. 0) THEN WRITE (PRBUF, 99978) I, NAMS(1, 1), 1 (XXO(I, K), K = 1, 3), 2 RADR(NO1, 2), IYSP1, MULT, PPAR, ATTRS, KTYPE ELSE WRITE (PRBUF, 99934) I, NAMS(1, 1), 1 (XXO(I, K), K = 1, 3), 2 RADR(NO1, 2), IYSP1, MULT, PPAR, ATTRS, KTYPE ENDIF K = INDEX (PRBUF, ' 1.000 ') IF (K .GT. 0) PRBUF(K:K+5) = ' - ' K = INDEX (PRBUF, ' 1.555 ') IF (K .GT. 0) PRBUF(K:K+5) = ' - ' IF (IWIN .EQ. 1) THEN IF (VRT - 0.4 .LT. 0) THEN CALL PLA013 (1, 1) ICH = IGGT(1:1) CALL GGIP (HORS, VERT, 0.0, 1) IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 700 VRT = VERT ENDIF VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99948) PRBUF(1:80) ENDIF ENDIF ELSE IF (PPAR .LT. 0.5) THEN IF (NDLP .EQ. 1) GOTO 100 NDIS = NDIS + 1 IF (NDIS .LT. 2) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99999) '<' ENDIF ENDIF GOTO 90 ENDIF IF (NDLP .EQ. 2) GOTO 100 90 NRAT = NRAT + 1 MOVE = ' - ' IF (NINT(ATTRS * 1000.0) .NE. 1555) 1 WRITE (MOVE, '(F8.3)') ATTRS IF (IPR(23) .EQ. 0) THEN IF (IATP(I) .NE. 1555 .AND. I .LE. NATX) THEN IPR(204) = IPR(204) + 1 ENDIF WRITE (PRBUF, FORM) VLAG, NAMS(1, 1), (XXO(I, K), 1 '(', IXSD(K), ')', K = 1, 6), SPSITE, MULT, SOF, 2 PPAR, '(', IPPAR, ')', MOVE, KTYPE ELSE WRITE (PRBUF, FORM) NRAT, NAMS(1, 1), (XXO(I, K), 1 '(', IXSD(K), ')', K = 4, 6), KTYPE ENDIF IF (IGBL(63) .GT. 2) 1 CALL PLA067 (LU7, PRBUF, 132, 1, 7) ENDIF ENDIF 100 CONTINUE 110 CONTINUE 120 CONTINUE IF (IPR(18) .LE. 0) THEN IF (IPR(23) .EQ. 0 .AND. IPR(13) .GT. 1) THEN CALL PLA269 (0) CALL PLA043 (NSMPR, 1, LU7, 0) ENDIF IPR(488) = 3 IF (IGBL(63) .GT. 2) THEN IF (IPR(44) .EQ. 1) THEN CALL PLA269 (3) WRITE (LU7, 99973) ISORD = 'Diso' ELSE ISORD = ' O' ENDIF IF (IGBL(71) .NE. 0) THEN CALL PLA269 (3) WRITE (LU7, 99972) ENDIF NWL = 25 + NRES - IPR(23) * 10 CALL PLA269 (NWL) WRITE (LU7, 99986) ISORD, (LMT(IENS(K), 1), K = 1, IAN) WRITE (LU7, 99985) ENDIF PAR(163) = 0 PAR(157) = 0 DO 130 J = 1, NP10 CONT(J, 2) = 0.0 130 CONTINUE DO 410 IRES = 1, NRES MULT = MLTI(IRES) IF (MULT .LE. 0) MULT = 1 NN = NP1 + 1 - IRES DO 140 J = 1, 5 XXO(NN, J) = 0.0 XSD(NN, J) = 0.0 140 CONTINUE XXO(NN, 6) = 1.0 DO 150 J = 1, NP10 CONT(J, 1) = 0.0 150 CONTINUE SUMWT = 0.0 DO 190 J = 1, NAT CALL GEN048 (-6, IFG(J), 9, IRESJ) IF (IRESJ .EQ. IRES) THEN IF (J .GT. NATX) THEN KMX = J - 1 DO 170 K = 1, KMX DO 160 L = 1, 3 DIF = ABS(XXO(J, L) - XXO(K, L)) IF (ABS(MOD(DIF, 1.0)) .GT. 0.0001) GOTO 170 160 CONTINUE GOTO 190 170 CONTINUE ENDIF CALL GEN048 (-7, JFG(J), 1, NPP) NPP = NPP + 1 PPM = MULT * IPPR(NPP, 3) * IPPR(NPP, 1) / 1 (NSYM * 1000.0) CALL GEN048 (-4, IFG(J), 15, NO1) NO1 = NO1 + 1 WT = SATWT(NO1) IF (NINT(WT) .EQ. 0) WT = 1.0 SUMWT = SUMWT + WT DO 180 L = 1, 3 XXO(NN, L) = XXO(NN, L) + XXO(J, L) * WT 180 CONTINUE IF (J .LE. NATX) THEN CONT(NO1, 1) = CONT(NO1, 1) + PPM XXO(NN, 4) = XXO(NN, 4) + WT * PPM XXO(NN, 5) = MAX(XXO(NN, 5), IPPR(NPP, 1) / 1000.0) XXO(NN, 6) = MIN(XXO(NN, 6), IPPR(NPP, 1) / 1000.0) ENDIF ENDIF 190 CONTINUE IF (XXO(NN, 5) .NE. XXO(NN, 6)) XXO(NN, 5) = 1.000 IF (SUMWT .EQ. 0.0) THEN IPR(2) = 32 IPR(323) = 8 GOTO 690 ENDIF DOM = 1 DO 200 J = 1, 3 XJX(J) = XXO(NN, J) / SUMWT XXO(NN, J) = XJX(J) 200 CONTINUE SPSITE = ' ' IF (IPR(101) .GT. 0) THEN NMOL = IPR(13) DO 220 K = 2, NMOL ML = MOL(K) XML = ML / PAR(42) CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRES0) IF (IRES0 .EQ. IRES) THEN IF (MOL1 .GT. IPR(48)) THEN MOL1 = MOL1 - IPR(48) XML = XML - IPR(48) * 1000 XJX(4) = MOL2 XJX(5) = MOL3 XJX(6) = MOL4 CALL SGSM (ICL, MOL1, XJX, LU6, 3, IERR) DO 210 J = 1, 3 XXO(NN, J) = XXO(NN, J) + XJX(J + 6) 210 CONTINUE DOM = DOM + 1 ENDIF ENDIF 220 CONTINUE DO 230 K = 1, 3 XXO(NN, K) = XXO(NN, K) / DOM 230 CONTINUE ENDIF DO 240 K = 1, 3 XJX(K) = XXO(NN, K) 240 CONTINUE XJX(10) = 0.0 CALL SGSM (LINE, 0, XJX, LU6, 19, IERR) SPSITE = ' '//LINE(1:5) PAR(163) = PAR(163) + XXO(NN, 4) * NSYM / MULT RCONT(IRES) = 0.0 IF (IPR(322) .GT. 0) THEN MM0 = IPR(255) * IPR(257) DO 250 I = 1, IAN C1 = CONT(I, 1) * MM0 IC1 = NINT(C1) IF (ABS(C1 - IC1) .GT. 0.01) GOTO 270 IATC(I) = IC1 250 CONTINUE MULT = MULT * MM0 IATC(IAN + 1) = MULT CALL GEN107 (IATC, IAN + 1, IGGD) MULT = MULT / IGGD XXO(NN, 4) = XXO(NN, 4) * MM0 / IGGD DO 260 I = 1, IAN CONT(I, 1) = CONT(I, 1) * MM0 / IGGD 260 CONTINUE ENDIF 270 DO 280 I = 2, 6 IF (I .NE. 5) THEN DO 271 L = 1, IAN IF (ABS(MOD(CONT(L, 1) / XXO(NN, 5), 1.0) - 1.0 / 1 FLOAT(I)) .LT. 0.001) THEN IF (MOD(NSYM, I) .EQ. 0) THEN DO 275 L9 = 1, IAN CONT(L9, 1) = CONT(L9, 1) * FLOAT(I) 275 CONTINUE MULT = MULT * I XXO(NN, 4) = XXO(NN, 4) * FLOAT(I) ENDIF GOTO 290 ENDIF 271 CONTINUE ENDIF 280 CONTINUE 290 NSP = IPR(488) NONINT = 0 IF (NSP .GT. 3) THEN DO 310 K = 4, NSP DO 300 L = 1, IAN IF (ABS(CONT(L, K) - CONT(L, 1)) .GT. 0.03) GOTO 310 300 CONTINUE NSP = K GOTO 320 310 CONTINUE ENDIF NSP = NSP + 1 IPR(488) = NSP IF (NSP .GT. 99) THEN IPR(2) = 62 GOTO 710 ENDIF CONT(NP10 + 1, NSP) = 0.0 320 IZET = NSYM / MULT IF (IZET * MULT .NE. NSYM) THEN DO 330 L = 1, IAN CONT(L, 1) = CONT(L, 1) * NSYM / MULT 330 CONTINUE XXO(NN, 4) = XXO(NN, 4) * NSYM / MULT IZET = 1 DO 340 L = 1, IAN IF (ABS(NINT (CONT(L, 1) / 2.0) - CONT(L, 1) / 2.0) 1 .GT. 0.01) GOTO 360 340 CONTINUE DO 350 L = 1, IAN CONT(L, 1) = CONT(L, 1) / 2.0 350 CONTINUE XXO(NN, 4) = XXO(NN, 4) / 2.0 IZET = 2 ENDIF 360 DO 370 L = 1, IAN CONT(L, 2) = CONT(L, 2) + CONT(L, 1) * IZET CONT(L, 1) = CONT(L, 1) / XXO(NN, 5) NCNT = NINT (CONT(L, 1)) IF (ABS(CONT(L, 1) - NCNT) .GE. 0.1) NONINT = 1 CONT(L, NSP) = CONT(L, 1) IF (IEN(L) .NE. 1) RCONT(IRES) = RCONT(IRES) + CONT(L, 1) 370 CONTINUE CONT(NP10 + 1, NSP) = CONT(NP10 + 1, NSP) 1 + IZET * XXO(NN, 5) CALL PLA283 (1, 1, N, IDM) IF (N .GT. 0 .AND. N .LT. 81) 1 WRITE (LU6, 99963) IRES, XXO(NN, 5), IZET, IDM(N:80) INSIDE = 1 DO 390 K = 1, 3 IF (XXO(NN, K) .GT. 1.1 .OR. XXO(NN, K) .LT. -0.1) THEN INSIDE = 0 ENDIF 390 CONTINUE IF (INSIDE .EQ. 0) THEN IF (N .GT. 0 .AND. N .LT. 81 .AND. IGBL(94) .EQ. 0) 1 WRITE (LU20, 99946) 1, IRES, IDM(N:80) ENDIF IF (NONINT .GT. 0) THEN WRITE (PRBUF, 99984) IRES, SPSITE, (XXO(NN, K), K = 1, 5), 1 IZET, (CONT(IENS(L), 1), L = 1, IAN) ELSE IF (IRES .EQ. 1 .AND. NRES .EQ. 1) IPR(260) = IZET WRITE (PRBUF, 99970) IRES, SPSITE, (XXO(NN, K), K = 1, 5), 1 IZET, (NINT(CONT(IENS(L), 1)), L = 1, IAN) DO 400 K = 51, 128 IF (PRBUF(K : K + 4) .EQ. ' 0') PRBUF(K+4:K+4) = '-' 400 CONTINUE ENDIF IF (IGBL(63) .GT. 2) CALL GEN065 (LU7, PRBUF, 130, 7) 410 CONTINUE NCMX = 1 IF (NRES .GT. 1) THEN DO 415 K = 1, NRES IF (RCONT(K) .GT. RCONT(NCMX)) NCMX = K 415 CONTINUE ENDIF IF (RCONT(NCMX) .LT. 15) IPR(487) = 0 DO 430 K = 1, 32 KZ = 33 - K DO 420 L = 4, IPR(488) LZ = NINT(CONT(NP10 + 1, L)) IF (ABS(CONT(NP10 + 1, L) - LZ) .LT. 0.00001) THEN IF (MOD(LZ, KZ) .NE. 0) GOTO 430 ENDIF 420 CONTINUE GOTO 440 430 CONTINUE KZ = NSYM 440 IF (KZ * 2 .EQ. NSYM) THEN DO 450 L = 1, IAN LZ = NINT(CONT(L, 2)) IF (MOD (LZ, 2) .NE. 0) GOTO 460 450 CONTINUE IF (MOD (NINT(CONT(NP10 + 1, 4)), NSYM) .EQ. 0) KZ = KZ * 2 ENDIF 460 MZ = 1 IF ((KZ / 2) * 2 .EQ. KZ) THEN DO 465 L = 1, IAN 461 LZ = NINT(CONT(L, 2) * MZ) IF (ABS(CONT(L, 2) * MZ - LZ) .LT. 0.001) THEN IF ((LZ / KZ) * KZ .NE. LZ) THEN IF (MZ .EQ. 1) THEN MZ = 2 GOTO 461 ELSE GOTO 466 ENDIF ENDIF ENDIF 465 CONTINUE KZ = KZ / MZ ENDIF 466 IPR(260) = KZ PAR(162) = 0.0 IPR(215) = 0 F000A = 0.0 F000B = 0.0 NHEAVY = 0 DO 480 L = 1, IAN IENL = IEN(L) NHEAVY = MAX (NHEAVY, IATNR(IENL)) J = (IENL - 1) * 15 YMR = 0.0 FDELA = 0.0 FDELB = 0.0 IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 5) THEN IF (IPR(493) .LT. 4) THEN YMR = AMR(IENL, IPR(493)) FDELA = SFAC(J + 16 - 2 * IPR(493)) FDELB = SFAC(J + 17 - 2 * IPR(493)) ELSE YMR = AMR(IENL, 1) * (PAR(17) / 0.56086)**3 ENDIF ENDIF DO 470 K = 1, 9, 2 F000A = F000A + CONT(L, 2) * SFAC(J + K) 470 CONTINUE F000A = F000A + CONT(L, 2) * FDELA F000B = F000B + CONT(L, 2) * FDELB IF (IPR(493) .NE. 5) THEN PAR(157) = PAR(157) + CONT(L, 2) * IATNR(IENL) ELSE PAR(157) = PAR(157) + CONT(L, 2) * RNSCL(IENL) ENDIF PERC(L) = CONT(L, 2) * SATWT(L) * 100.0 / PAR(163) PAR(162) = PAR(162) + CONT(L, 2) * YMR * 0.1 NCNT = NINT(CONT(L, 2)) CONT(L, 3) = CONT(L, 2) - NCNT IF (ABS(CONT(L, 3)) .GT. NCNT * PAR(331)) 1 IPR(215) = IPR(215) + 1 480 CONTINUE PAR(426) = SQRT(F000A**2 + F000B**2) PAR(160) = PAR(163) / (PAR(98) * 0.60221) DXREP = IPR(276) * PAR(308) / (PAR(98) * 0.60221) IF (PAR(267) .GT. 0.0 .AND. IGBL(94) .EQ. 0) THEN XDIF = 100 * ABS (PAR(267) - DXREP) / PAR(267) IF (XDIF .GT. 0.5) 1 WRITE (LU20, 99936) '_046', XDIF, DXREP ENDIF PAR(162) = PAR(162) / PAR(98) SIGD = (PAR(160) / PAR(98)) * PAR(21) CALL GEN041 (PAR(160), SIGD, IPR(295), 4, IPR(296), IPR(68)) FORMA(32:32) = CHAR(ICHAR('0') + IPR(296)) PAR(142) = FLOAT(IPR(260)) / NSYM CALL PLA283 (0, 1, N, IDM) IF (IGBL(94) .EQ. 0) THEN IF (INDEX (RLWS(4), '?') .EQ. 0) THEN N3 = 0 DO 500 N2 = N, 80 ICH = IDM(N2:N2) 490 N3 = N3 + 1 CN3 = RLWS(4)(N3:N3) IF (CN3 .EQ. '+' .OR. CN3 .EQ. '-') GOTO 490 CN31 = RLWS(4)(N3+1:N3+1) IF (ICH .NE. CN3) THEN CALL GEN105 (3, CN3, J) IF (CN3 .EQ. CHAR(32)) THEN GOTO 490 ELSE IF (ICH .EQ. CHAR(32) .AND. 1 CN3//CN31 .EQ. '1 ') THEN GOTO 490 ELSE IF (J .GE. 0 .AND. (CN31 .EQ. '+' .OR. 1 CN31 .EQ. '-')) THEN N3 = N3 + 1 GOTO 490 ELSE CALL GEN020 (1, ICH, 1, 1) IF (ICH .NE. CN3) THEN WRITE (LU20, 99943) '_042', 1.0, 1.0 GOTO 510 ELSE CALL GEN020 (-1, RLWS(4), N3, N3) ENDIF ENDIF ENDIF 500 CONTINUE ELSE WRITE (LU20, 99943) '_048', 1.0, 1.0 ENDIF ENDIF 510 XDIF = 100 * ABS (PAR(163) - PAR(308) * IPR(276)) / PAR(163) IF (XDIF .GT. 0.1 .AND. IGBL(94) .EQ. 0) 1 WRITE (LU20, 99937) '_043', XDIF, PAR(308) XDIF = 100.0 * ABS (PAR(160) - PAR(267)) / PAR(160) IF (XDIF .GT. 0.5 .AND. IGBL(94) .EQ. 0) 1 WRITE (LU20, 99939) '_044', XDIF, PAR(267) IF (PAR(160) .LT. 1.0) 1 WRITE (LU20, 99939) '_049', 0.5, PAR(160) IF (IPR(260) .NE. IPR(276)) THEN IF (IPR(276) .NE. 0) THEN RATIO = FLOAT(IPR(260)) / FLOAT(IPR(276)) ELSE RATIO = 0.0 ENDIF IF (IGBL(94) .EQ. 0) 1 WRITE (LU20, 99937) '_045', 1.0, RATIO ENDIF CALL PLA283 (2, IPR(260), N1, ICL) IF (IGBL(94) .EQ. 0) THEN IF (INDEX (RLWS(5), '?') .EQ. 0) THEN N3 = 0 DO 530 N2 = N1, 80 ICH = ICL(N2:N2) 520 N3 = N3 + 1 JCH = RLWS(5)(N3:N3) IF (ICH .NE. JCH) THEN IF (ICH .EQ. ' ' .AND. 1 RLWS(5)(N3:N3+1) .EQ. '1 ') GOTO 520 CALL GEN020 (1, ICH, 1, 1) IF (ICH .NE. JCH) THEN WRITE (LU20, 99943) '_041', 1.0, 1.0 GOTO 540 ELSE CALL GEN020 (-1, RLWS(5), N3, N3) ENDIF ENDIF 530 CONTINUE ELSE WRITE (LU20, 99943) '_047', 1.0, 1.0 ENDIF ENDIF 540 WRITE (LU6, 99951) IDM(N:80), ICL(N1:80), 1 PAR(163) / IPR(260), IPR(260), IPR(48), PAR(142) IF (ABS(IGBL(8)) .EQ. 4) WRITE (LU6, 99947) 1 JID(1:27), PAR(98), PAR(142), PAR(160), IDM(N:80) IF (IPR(23) .EQ. 0) THEN IF (IGBL(63) .GT. 2) THEN WRITE (LU7, 99989) 1 PAR(163), (NINT(CONT(IENS(L), 2)), L = 1, IAN) IF (IPR(215) .GT. 0) THEN WRITE (LU7, 99965) (CONT(IENS(L), 3), L = 1, IAN) ENDIF WRITE (LU7, 99988) (PERC(IENS(L)), L = 1, IAN) WRITE (LU7, 99956) IDM(N:80), ICL(N1:80), 1 PAR(163) / IPR(260), IPR(260), IPR(48), IPR(260), 2 IPR(48), PAR(142) WRITE (LU7, 99966) WRITE (PRBUF, FORMA) PAR(160), IPR(295) CALL GEN065 (LU7, PRBUF, 130, 1) WRITE (LU7, 99987) PAR(157), PAR(426) ENDIF IF (IGBL(71) .GT. 0) 1 WRITE (LU20, 99944) '_720', 1, IGBL(71) IF (IPR(474) .GT. 0 .AND. NHEAVY .GT. 18 .AND. 1 IGBL(94) .EQ. 0) WRITE (LU20, 99944) '_164', 1, IPR(474) IF (IPR(164) .GT. 0) THEN WRITE (LU20, 99944) '_165', 1, IPR(164) ENDIF IF (KRAD(1:2) .NE. '??') THEN IF (IGBL(63) .GT. 2) THEN WRITE (LU7, 99955) KRAD, PAR(162) * 10.0, PAR(162) WRITE (LU6, 99997) KRAD, PAR(162) * 10.0, PAR(162) ENDIF IF (IABS(IGBL(8)) .EQ. 3) THEN IF (IPR(124) .NE. 0 .AND. IGBL(97) .EQ. 1) 1 WRITE (LU20, 99933) 1, 1 CALL PLA231 (50) CALL PLA231 (80) ENDIF ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99949) ENDIF ENDIF IPR(483) = 0 IPR(484) = 0 DO 550 L = 1, IAN IF (IEN(L) .EQ. 1) THEN IF (CONT(L, 2) .GT. 0) IPR(484) = 1 ELSE IF (IEN(L) .EQ. 2) THEN IF (CONT(L, 2) .GT. 0) IPR(483) = 1 ENDIF 550 CONTINUE CALL PLA231 (70) IF (PAR(433) .EQ. 999999.0 .AND. IPR(22) .GT. 14 .AND. 1 IPR(257) .EQ. 1 .AND. IGBL(94) .EQ. 0 .AND. 2 IABS(IGBL(8)) .NE. 4) 3 WRITE (LU20, 99944) '_034', 1, 1 IF (IPR(257) .NE. 2 .AND. IGBL(94) .EQ. 0 1 .AND. IPR(583) .GT. 0) THEN N = INDEX (CCIF(17), '?') IF (N .NE. 0 .AND. IABS(IGBL(8)) .EQ. 3 .AND. 1 CHSG(1:1) .EQ. 'C') WRITE (LU20, 99944) '_035', 1, 1 ENDIF IF (IPR(484) .EQ. 0 .AND. IPR(483) .GT. 0) THEN WRITE (LU20, 99944) '_040', 1, 1 ENDIF IF (IPR(495) .NE. 0 .AND. IPR(200) .EQ. 0) THEN IF (IPR(322) .EQ. 0 .AND. IGBL(3) .NE. 28) THEN IF (IGBL(3) .NE. 1 .AND. IPR(39) .LT. NMA) THEN IF (IPR(23) .EQ. 0) CALL PLA211 (LU6, LU7, JID) ELSE WRITE (LU6, '(''Too Many Atoms for MOLSYM'')') ENDIF IF (IPR(495) .EQ. 1 .OR. IPR(495) .EQ. 3) CALL PLA082 ENDIF ENDIF ENDIF ELSE IF (IPR(147) .NE. 0) THEN IF (IGBL(31) .EQ. 4) THEN CALL GEN108 (LU2, 0) WRITE (LU2, 99959) ENDIF VRT = 0.0 DO 680 N = 1, NRES NRS = N NADD = 0 IF (RCONT(NRS) .LT. IPR(487)) NADD = 1 IF (IGBL(31) .EQ. 4) THEN CALL GEN040 (NRS, NQ1, IP) WRITE (LU2, 99962) NQ1(1:IP) JBN = NP1 ENDIF IF (IPR(18) .LT. 0) THEN IF (IGBL(63) .GT. 2) THEN IF (NRS .EQ. 1) THEN CALL PLA269 (-11) WRITE (LU7, 99983) ENDIF IF (NRES .GT. 1) THEN CALL PLA269 (-5) WRITE (LU7, 99981) NRS ENDIF CALL PLA269 (3) WRITE (LU7, 99977) ENDIF ELSE IF (NRES .GT. 1 .AND. IWIN .EQ. 0) 1 WRITE (LU6, 99982) N IF (IWIN .EQ. 0) 1 WRITE (LU6, '(//, A, /, 80(''-''))') PRBUF(1:80) ENDIF NDIS = 0 DO 660 NDLP = 1, NDLPM NRAT = 0 NHRAT = 0 DO 650 I = 1, NAT IAT = I UEQAVR = 0.0 NUEQ = 0 NROX = 0 CALL GEN048 (-6, IFG(IAT), 9, IRESI) IF (NRS .NE. IRESI) GOTO 650 CALL GEN048 (-1, IFG(I), 7, IHAT) CALL PLA036 (IAT, 1, 2, IDS1, IDUM1, IDUM2, IPR(119), 1 IGBL(55)) IF (IDS1 .GE. 500) THEN IF (NDLP .EQ. 2) GOTO 650 ELSE IF (NDLP .EQ. 1) GOTO 650 NDIS = NDIS + 1 IF (NDIS .EQ. 1 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99999) '<' ENDIF ENDIF CALL GEN048 (-4, IFG(IAT), 15, NO1) NO1 = NO1 + 1 IATAK = IATPR(IEN(NO1)) IF (IATAK .EQ. 5 .OR. IATAK .EQ. 6) THEN IATALK = 1 ELSE IATALK = 0 ENDIF IF (IGBL(31) .EQ. 4) THEN IF (IEN(NO1) .EQ. 2) THEN IATCAR = 1 ELSE IATCAR = 0 ENDIF IF (NDLP .EQ. 1 .AND. IEN(NO1) .NE. 1) THEN NHRAT = NHRAT + 1 JNSC(1, IAT) = NHRAT ENDIF ENDIF CALL GEN048 (-1, IFG(IAT), 19, IMET) IATMET = IMET IF (IPR(18) .LT. 0) THEN IF (IEN(NO1) .EQ. 1) THEN IF (NHAT .EQ. 0) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99966) ENDIF NHAT = 1 ENDIF ELSE IF (NHAT .EQ. 1) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99966) ENDIF NHAT = 0 ENDIF ENDIF ENDIF NOTE = ' ' NOTE1 = ' ' KMT = 0 DMX = 0.0 DMN = 999.0 DMNNH = 0.0 NRAT = NRAT + 1 NBNDS = 0 NC = - NINT(CON(IAT, NP4)) IF (NC .LT. 0) THEN NC = NP4 CALL GEN048 (-1, IFG(IAT), 8, IVAL) IF (IVAL .GT. 0) NC = NC + IPR(76) ENDIF PNC = 0 NRMET = 0 DO 570 J = 1, NP4 IF (J .GT. NC) THEN NAMS(J, 1) = ' -------' ELSE IF (J .LE. NP4) THEN KAT = NINT(CON(IAT, J)) ELSE IF (IBON(J - NP4, 1) .NE. IAT) GOTO 570 KAT = IBON(J - NP4, 2) ENDIF KAT = MOD(KAT, NP1) CALL GEN048 (-1, IFG(KAT), 7, JHAT) CALL GEN048 (-4, IFG(KAT), 15, NO3) NO3 = NO3 + 1 IF (IEN(NO3) .EQ. 3) NROX = NROX + 1 IF (JHAT .EQ. 0 .AND. IPR(18) .EQ. -2 1 .AND. KAT .LE. NATX) THEN NUEQ = NUEQ + 1 UEQAVR = UEQAVR + DATC(KAT) ENDIF CALL GEN048 (-1, IFG(KAT), 19, KATMET) NRMET = NRMET + KATMET CALL GEN048 (-4, IFG(KAT), 15, NOK) NOK = NOK + 1 IF (IGBL(31) .EQ. 4) THEN IF (JHAT .EQ. 0 .AND. NDLP .EQ. 1) THEN IF (IEN(NOK) .EQ. 2) THEN KATCAR = 1 ELSE KATCAR = 0 ENDIF IF ((IATMET .NE. 1 .OR. KATCAR .NE. 1) .AND. 1 (KATMET .NE. 1 .OR. IATCAR .NE. 1)) THEN CALL PLA036 (KAT, 1, 2, IDS2, IDUM1, IDUM2, 1 IPR(119), IGBL(55)) IF (IDS2 .GT. 500) THEN NBNDS = NBNDS + 1 IF (KAT .GT. IAT) THEN JBN = JBN + 1 JNSC(1, JBN) = IAT JNSC(2, JBN) = KAT ENDIF ENDIF ENDIF ENDIF ENDIF CALL PLA036 (KAT, J, 1, IDS2, MNUM, ISPOS, 1 IPR(119), IGBL(55)) CALL GEN048 (-1, IFG(KAT), 19, KMET) KMT = KMT + 1 PNC = PNC + MIN (1.0, FLOAT(IDS2) / FLOAT(IDS1)) IF (IPR(18) .LT. 0) THEN CALL PLA050 (IAT, KAT, 0, 0, DIST) DMX = MAX (DMX, DIST) DMN = MIN (DMN, DIST) IF (JHAT .EQ. 0) THEN DMNNH = DMNNH + DIST ENDIF IF (KMET .EQ. 1) IMET = IMET + 1 ENDIF ENDIF 570 CONTINUE IF (IPR(18) .GT. 0) THEN WRITE (PRBUF, 99976) IF (IWIN .EQ. 1 .AND. VRT .EQ. 0.0) THEN VRT = VERT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.3, 5 + IGBL(68), 2, 1 1.0, VRT) VRT = VRT - 0.2 ENDIF IF (LTYPE .EQ. 0 .AND. LRES .EQ. 0 .OR. 1 LTYPE .EQ. 0 .AND. LRES .EQ. NRS .OR. 2 LTYPE .EQ. NO1 .AND. LRES .EQ. 0 .OR. 3 LTYPE .EQ. NO1 .AND. LRES .EQ. NRS) THEN WRITE (PRBUF, 99975) NRAT, NAMS(1, 2), 1 (NAMS(L, 1)(1:8), L = 1, 8) IF (IWIN .EQ. 1) THEN IF (VRT - 0.4 .LT. 0.0) THEN CALL PLA013 (1, 1) ICH = IGGT(1:1) CALL GGIP (HORS, VERT, 0.0, 1) IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 700 VRT = VERT ENDIF VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ELSE WRITE (LU6, 99948) PRBUF(1:80) ENDIF ENDIF GOTO 610 ENDIF INC = NINT(PNC) IF (IATMET .EQ. 1) THEN IF (IGBL(97) .NE. 0 .AND. IATALK .EQ. 0) THEN IF (NAMS(1, 2)(2:3) .NE. 'Cg') THEN IF (INC .EQ. 0) THEN WRITE (LU20, 99938) '_307', 1.0, 1.0, NAMS(1, 2) ELSE IF (INC .EQ. 1 .AND. IAT .LE. NATX) THEN WRITE (LU20, 99938) '_308', 1.0, 1.0, NAMS(1, 2) ENDIF ENDIF ENDIF ENDIF IF (IEN(NO1) .EQ. 1) THEN IF (INC .NE. 1 .AND. IMET .EQ. 0) NOTE = 'V' IF (INC .EQ. 0 .AND. IAT .LE. NATX) THEN IPR(153) = IPR(153) + 1 WRITE (LU20, 99938) '_305', 1.0, 1.0, NAMS(1, 2) ENDIF ENDIF IF (IEN(NO1) .EQ. 2 .AND. KMT .LE. 1 .AND. 1 (INC .EQ. 0 .OR. INC .GT. 4)) NOTE = 'V' IF (NC .EQ. 0) DMN = 0.0 IF (IEN(NO1) .EQ. 3 .AND. IAT .LE. NATX) THEN IF (INC .EQ. 0) THEN NOTE = 'V' IPR(161) = IPR(161) + 1 IF (IDS1 .EQ. 1000) THEN WRITE (LU20, 99938) '_306', 1.0, 1.0, NAMS(1, 2) ELSE WRITE (LU20, 99938) '_311', 1.0, 1.0, NAMS(1, 2) ENDIF ELSE IF (INC .EQ. 1 .AND. PNC .LT. 1.3) THEN KAT = NINT(CON(IAT, 1)) CALL GEN048 (-4, IFG(KAT), 15, NO2) IF (IEN(NO2 + 1) .EQ. 2) THEN CALL PLA050 (IAT, KAT, 0, 0, DIST) IF (DIST .GT. 1.3) THEN CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) WRITE (LU20, 99938) '_309', 1.0, 1.0, ' '//NQ1 ENDIF ENDIF ELSE IF (INC .EQ. 2) THEN KAT = NINT(CON(IAT, 1)) LAT = NINT(CON(IAT, 2)) CALL GEN048 (-1, IFG(KAT), 19, METK) CALL GEN048 (-1, IFG(LAT), 19, METL) CALL GEN048 (-4, IFG(KAT), 15, NO2) IF (IEN(NO2 + 1) .EQ. 2) THEN CALL PLA050 (IAT, KAT, 0, 0, DIST) IF (DIST .LT. 1.25) THEN CALL GEN048 (-4, IFG(LAT), 15, NO2) IF (IEN(NO2 + 1) .EQ. 1) THEN CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) WRITE (LU20, 99938) 1 '_312', 1.25 - DIST, 1.0, ' '//NQ1 ENDIF ENDIF ENDIF CALL PLA050 (KAT, IAT, LAT, 0, ANG3) IF (ANG3 .GT. 120) THEN IF (METK .EQ. 0 .AND. METL .EQ. 0) THEN CALL GEN048 (-4, IFG(KAT), 15, NOK) CALL GEN048 (-4, IFG(LAT), 15, NOL) IF (IEN(NOK + 1) .EQ. 85 .AND. 1 IEN(NOL + 1) .EQ. 85) THEN WRITE (LU20, 99938) 1 '_396', ANG3 - 150.0, ANG3, NAMS(1, 2) ELSE WRITE (LU20, 99938) 1 '_395', ANG3 - 120.0, ANG3, NAMS(1, 2) ENDIF ENDIF ENDIF ELSE IF (INC .EQ. 3) THEN DISTM = 0.0 DO 575 LL = 1, 3 KAT = NINT(CON(IAT, LL)) CALL PLA050 (IAT, KAT, 0, 0, DIST) DISTM = MAX (DISTM, DIST) 575 CONTINUE IF (DISTM .LT. 1.6) THEN CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) WRITE (LU20, 99932) 1, 1, NQ1 ENDIF ENDIF ENDIF CALL PLA099 (1, IAT, NANG, ANG1, ANG2, ANG3, NCEFF, 1 IMET, IHYB, CHYB, NATH, NOTE1) CALL GEN048 ( 4, IFG(IAT), 24, IHYB) CALL GEN048 ( 3, JFG(IAT), 24, NATH) CALL GEN048 (-10, JFG(IAT), 14, LNR) IF (IPR(324) .EQ. 1) THEN IRS0 = ' ' IF (IHYB .EQ. 3) THEN CALL GEN048 (-2, IFG(IAT), 28, JCAI) IF (JCAI .EQ. 1) THEN IRS0 = 'S' ELSE IF (JCAI .EQ. 2) THEN IRS0 = '?' ELSE IF (JCAI .EQ. 3) THEN IRS0 = 'R' ENDIF ENDIF ENDIF VLAG = '- ' IF (IABS(IGBL(8)) .EQ. 3) THEN VLAG = 'd ' CALL GEN048 (-1, JFG(IAT), 29, IVLAG) IF (IVLAG .EQ. 1) VLAG(1:1) = 'c' CALL GEN048 (-1, JFG(IAT), 30, IVLAG) IF (IVLAG .EQ. 1) VLAG(2:2) = 'R' CALL GEN048 (-1, JFG(IAT), 31, IVLAG) IF (IVLAG .EQ. 1) VLAG(2:2) = 'G' ENDIF IF (IGBL(31) .EQ. 4 .AND. IEN(NO1) .NE. 1) THEN IF (NDLP .EQ. 1) THEN CALL GEN040 (NHRAT, NQ1, IP) JX1 = IEL(IEN(NO1)) J1 = JX1 / 100 J2 = MOD(JX1, 100) NQ1(5 : 5) = CHAR(ICHAR('A') + J1 - 1) IF ( J2 .NE. 0) THEN NQ1(6 : 6) = CHAR(ICHAR('A') + J2 - 1) ELSE NQ1(6 : 6) = ' ' ENDIF WRITE (LU2, 99961) NQ1(1:IP), NQ1(5:6), NBNDS ENDIF ENDIF IF (IAT .LE. NATX) THEN IF (IEN(NO1) .EQ. 4) THEN IF (NRMET .GT. 0 .AND. NCEFF .EQ. 3 .AND. 1 DMN .GT. 1.45 .AND. ANG3 .LT. 114.0) THEN WRITE (LU20, 99942) 1 '_32', 4 + NADD, 1.0, 1.0, NAMS(1, 2) NOTE = '?' ENDIF IF (IHYB .EQ. 0 .AND. NRMET. EQ. 0 .AND. 1 NCEFF .EQ. 3 .AND. DMN .LT. 1.1 .AND. 2 DMNNH .GT. 2.8 .AND. ANG3 .EQ. 120.0) THEN WRITE (LU20, 99942) 1 '_31', 8 + NADD, 1.0, 1.0, NAMS(1, 2) ENDIF ELSE IF (IEN(NO1) .EQ. 2) THEN IF (NCEFF .EQ. 3 .AND. NRMET .EQ. 0) THEN IF (DMN .GT. 1.45 .AND. ANG3 .LT. 112.0) THEN WRITE (LU20, 99942) 1 '_32', 6 + NADD, 1.0, 1.0, NAMS(1, 2) NOTE = '?' ENDIF ENDIF ELSE IF (IEN(NO1) .EQ. 8) THEN IF (NCEFF .EQ. 3 .AND. NRMET .GT. 0) THEN IF (ANG3 .LT. 115.0) THEN WRITE (LU20, 99942) 1 '_32', 8, 1.0, 1.0, NAMS(1, 2) ENDIF ENDIF ENDIF ENDIF IF (NAMS(1, 2)(1:1) .EQ. CHAR(32)) THEN DO 580 LL = 1, NP4 IF (NAMS(LL, 1)(1:1) .NE. CHAR(32)) GOTO 590 580 CONTINUE GOTO 600 ENDIF 590 NOTE = ' ' NOTE1 = ' ' 600 IF (NOTE .EQ. 'V') IPR(102) = IPR(102) + 1 IF (NOTE1 .EQ. 'A') IPR(103) = IPR(103) + 1 IF (IPR(483) .GT. 0 .AND. IPR(484) .GT. 0) THEN NADD1 = NADD IF (IEN(NO1) .NE. 2) THEN IF (NADD1 .EQ. 0) THEN NADD1 = 2 ELSE IF (NADD1 .EQ. 1) THEN NADD1 = 3 ENDIF ENDIF IF ((NOTE1 .EQ. '?' .OR. NOTE1 .EQ. 'A') .AND. 1 IAT .LT. NATX) WRITE (LU20, 99935) 2 '_32', NADD1, 1.0, 1.0, NAMS(1, 2) ENDIF IF (NOTE .NE. ' ' .OR. NOTE1 .NE. ' ') THEN WRITE (LU6, 99996) NAMS(1, 2), 1 (NAMS(LL, 1), LL = 1, 7), NOTE, NOTE1 ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99980) VLAG, NAMS(1, 2), 1 (NAMS(LL, 1), LL = 1, NP4), NANG, NINT(ANG1), 2 NINT(ANG2), ANG3, DMN, DMX, NCEFF, LNR, CHYB, IRS0, 3 NOTE, NOTE1 ENDIF IF (IRS0 .NE. ' ') 1 WRITE (LU6, 99950) NAMS(1, 2), NRS, LNR, IRS0 IF (IPR(18) .EQ. -2 .AND. IAT .LE. NATX 1 .AND. IHAT .EQ. 0) THEN IF (NUEQ .GT. 1) THEN UEQAVR = UEQAVR / NUEQ DUEQ = DATC(IAT) - UEQAVR NADD2 = 0 NQ4 = NAMS(1, 2)(2 : 8) IF (RCONT(NRS) .LT. IPR(487) .AND. NRES .GT. 1) 1 NADD2 = 2 IF (DUEQ .GT. 0.005) THEN WRITE (LU20, 99945) 241 + NADD2, DUEQ, DUEQ, NQ4 ELSE IF (DUEQ .LT. -0.005) THEN IF (NO1 .NE. 5 .OR. NROX .NE. 4 .OR. 1 DATC(IAT) .LT. 0.025) THEN WRITE (LU20, 99945) 242 + NADD2, - DUEQ, 1 - DUEQ, NQ4 ENDIF ENDIF ENDIF ENDIF 610 NC1 = NP4 620 NC1 = NC1 + 1 IF (NC1 .GT. NC) GOTO 650 NCL = 0 DO 630 NC0 = NC1, NC NC2 = NC0 IF (IBON(NC0 - NP4, 1) .EQ. IAT) THEN NCK = MOD(IBON(NC0 - NP4, 2), NP1) NCL = NCL + 1 CALL PLA036 (NCK, NCL, 1, IDIS, MNUM, ISPOS, 1 IPR(119), IGBL(55)) IF (NCL .EQ. NP4) GOTO 640 ENDIF 630 CONTINUE 640 IF (NCL .GT. 0) THEN IF (IPR(18) .GT. 0) THEN WRITE (LU6, 99968) (NAMS(LL, 1)(2:7), LL = 1, NCL) ELSE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99967) (NAMS(LL, 1), LL = 1, NCL) ENDIF ENDIF ENDIF NC1 = NC2 GOTO 620 650 CONTINUE 660 CONTINUE IF (IGBL(31) .EQ. 4) THEN DO 670 K = NP1 + 1, JBN WRITE (LU2, 99960) JNSC(1, JNSC(1, K)), 1 JNSC(1, JNSC(2, K)) 670 CONTINUE WRITE (LU2, 99958) ENDIF 680 CONTINUE IF (IGBL(31) .EQ. 4) THEN IF (IPR(322) .EQ. 0) THEN CALL PLA294 (0) ELSE CALL PLA015 (0, 27) ENDIF ENDIF C * PRINT SYMMETRY CODES CALL PLA043 (NSMPR, 1, LU7, 0) ENDIF ENDIF 690 IF (IWIN .EQ. 1 .AND. IPR(18) .GT. 0) CALL PLA297 (0) 700 IPR(18) = 0 710 RETURN 99999 FORMAT (/, 'Disordered Atoms with S.O.F ', A, ' 0.5', /) 99998 FORMAT ('Mu/Rho(', A, '):', 16F7.2) 99997 FORMAT (':: mu(', A, ') =', F12.2, ' cm-1 = ', F7.3, 1 ' mm-1') 99996 FORMAT ('N: ', A, ' : ', 7(A), 1X, 2A) 99995 FORMAT (132('-'), /, 'Sources - Cov. Radii : Manual Cambridge', 1 ' Cryst. Data Base', /, 8X, '- Atomic Wt. : IUPAC 1993', 2 93X, A, /, 8X, 3 '- mu/rho : International Tables C, table 4.2.4.2,', 4 ' p193-199') 99994 FORMAT ('Cov.Rad(Ang):', 16F7.2) 99993 FORMAT ('Atom Weight :', 2F7.3, 14F7.2) 99992 FORMAT ('Atom Number :', 16I7) 99991 FORMAT ('Atom Types : ', 16(4X, A, 1X)) 99990 FORMAT ('Elem. Type : ', 16(4X, A, 1X)) 99989 FORMAT (30X, 102('-'), /, 9X, 'Unit Cell Weight =', F12.2, 1 11X, 2I6, 14I5) 99988 FORMAT (/, 1X, 'Calculated Analysis (Percent) =', 1 11X, F13.1, F6.1, 14F5.1) 99987 FORMAT (75X, 'Please Check the Derived Crystal Data.', /, 1 24X, 'F(000) = ', F11.1, ' [', F11.2, ']', 17X, 2 'They may be Incorrect for Disordered,', /, 75X, 3 'Incomplete or Polymeric Structures.') 99986 FORMAT (/, A4, 'rdered Structure', 34X, 'Unit Cell Contents', 1 ' (Based on Contents of Atom List, that may be Incomplete)', /, 2 132('='), /, 'Resd Site X(cen) Y(cen) Z(cen) Mol.Wt S.O.F', 3 ' Z', 5X, A, 4X, A, 14(3X, A)) 99985 FORMAT (132('=')) 99984 FORMAT (I3, A, 3F7.3, F9.2, F6.3, I4, 1X, 2F6.1, 14F5.1) 99983 FORMAT ('Analysis of Bond Distance and Angle Values', 1 ' - Identification of Chiral Center(s) and Their (R/S)-', 2 'Configuration (Cahn-Ingold-Prelog)', /, 132('='), /, 3 4X, 'The Following Tests are done. Faults are Marked ', 4 'Under Note', /, 4X, '-- V : Valency Check Fault for H, C ', /, 5 4X, '-- S : Bond Too Short ', /, 4X, '-- A : Unusual Bond Angle', 6 ' Values (PLEASE CHECK)', /, 132('='), /, 7 ' *** PLEASE NOTE: R/S ASSIGNMENTS ARE TENTATIVE ***', 8 ' (CIP Special rules NOT Implemented)', /, 9 ' *** See Angew.Chem.Intern. Ed. Eng.,(1966),5,385 & ', * '(1982),21,567 for Authoritative Details for Special Cases', /) 99982 FORMAT (/, 34X, 'Residue =', I4, /) 99981 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X, 1 61('*'), /, 57X, 13('='), /) 99980 FORMAT (A, A, '-', 9(A), I2, 2I4, F6.1, 2F6.3, I3, I4, 1X, 1 A3, 2X, A, 2X, 2A) 99979 FORMAT ('Atom Label', 5X, 'Fractional Coordinates', 3X, 1 'Radius Sp SSN Ppar Move Type') 99978 FORMAT (I4, 1X, A, F8.5, 2F9.5, F7.2, 2X, A, I4, F7.3, F8.3, 1 2X, A3) 99977 FORMAT (87X, '=A.N.G.L.E.S= =B.O.N.D.S=', /, 'Flag Label -', 1 ' Connected to (May be Incomplete for Polymeric Structures)', 2 12X, 'nra min max Aver min', 3X, 3 'max nrb tnr Hyb RS Note', /, 132('-')) 99976 FORMAT ('Atom Label - Bonded to ') 99975 FORMAT (I4, 1X, A, ' : ', 9(A)) 99974 FORMAT ('(', A, '-Rule Rounded) Coordinates of Unique', 1 ' Residue(s) Identified. Standard Deviations in the Last ', 2 'Digit are in Parentheses.', /, 132('-'), /, 3 10X, 'Site = Site Symmetry; SSN = Site Symmetry Number; ', 4 'SSOF = SHELX Site Occupation Factor (= S.O.F / SSN).', 5 /, '******* Move = Transformation on Input Data', 6 ': N.IJK (N = SymOp, IJK = Translation) i.e. 1.555 = nomove', /, 7 'SYMBOLS: Type = D/A = Potential Donor or Acceptor atom,', 8 ' D-H = H on Donor atom, MET = Metal.', /, 9 '******* El Type = AK = Alkali Metal, AE = Alkaline Earth,', * ' HL = Halogen, AN = Actinide, LN = Lanthanide,', 1 ' TR = Transition Element.', /, 2 10X, 'ARU = Asymmetric Residue Unit encoded as sklm.nn,', 3 ' with s = symmetry op, klm = translation, nn = residue #.', /, 4 10X, 'RESIDUE = collection of ARU''s constituting an isolated', 5 ' unit (= molecule, ion).', /, 6 10X, 'FLAGS : d = determined, c = calculated, R = riding ', 7 'G = group', /, 132('-')) 99973 FORMAT (/, 'NOTE: Atoms preceded by > * or < indicate ', 1 'disordered positions (SOF : < 50%, 50%, > 50%)', /) 99972 FORMAT (/, 'NOTE: A # in the Atom Label Indicates a Label that', 1 ' was Modified to Conform with the Label Convention (A4)', /) 99971 FORMAT (132('-'), /, 'Flags Label', 9X, 1 'Fractional Coordinates (x,y,z)', 10X, 2 'Orthogonal Coordinates (XO,YO,ZO)', 3X, 'Site SSN*SSOF =', 4X, 3 'S.O.F', 3X, 'Move Type', /, 132('-')) 99970 FORMAT (I3, A, 3F7.3, F9.2, F6.3, I4, 1X, 2I6, 14I5) 99969 FORMAT (/, A, /) 99968 FORMAT (15X, 9(A, 1X)) 99967 FORMAT (13X, 9(A)) 99966 FORMAT (1X) 99965 FORMAT (37X, 'Add Non-Int. ', 2F6.2, 14F5.2) 99963 FORMAT (':: Resd', I3, ', SOF', F6.3, ', Z', I3, ', ', A) 99962 FORMAT ('T', A, ' *CONNSER') 99961 FORMAT ('AT', A, 2X, A, I5) 99960 FORMAT ('BO', 2I6, ' 99') 99959 FORMAT ('SAVE 3') 99958 FORMAT ('END') 99957 FORMAT ('Angstrom coordinates. - Input data multiplied by:', 1 F15.5, //) 99956 FORMAT (/, 16X, 'Moiety_Formula = ', A, //, 1 19X, 'Sum_Formula = ', A, //, 2 16X, 'Formula_Weight =', F12.2, //, 3 21X, 'Formula_Z =', I12, //, 4 18X, 'SpaceGroup_Z =', I12, 5 ' ===> Z'' =', I3, ' /', I3, ' =', F8.3) 99955 FORMAT (22X, 'mu(', A, ') =', F12.2, ' cm-1 =', F8.3, ' mm-1') 99954 FORMAT ('Scat.Fact.f0:', 16F7.3) 99953 FORMAT ('Scat.Fact.f'':', 16F7.3) 99952 FORMAT ('Scat.Fact.f":', 16F7.3) 99951 FORMAT (':: Moiety_Formula = ', A, /, 1 ':: Sum_Formula = ', A, /, 2 ':: Formula_Weight = ', F11.2, /, 3 ':: Formula_Z = ', I11, /, 4 ':: SpaceGroup_Z = ', I11, /, 5 ':: Formula_Z'' = ', F11.3) 99950 FORMAT ('::', A, ' RES =', I5, ' LNR =', I5, ' Chiral: ', A) 99949 FORMAT (/, 1 'Note on F000: The first number is a pure electron count, the ', 2 'second number between [] is calculated from f,f'' & f"') 99948 FORMAT (A) 99947 FORMAT (A, ' ;V', F8.1, ' Z''', F7.3, ' Dx', F6.3, ' ', A) 99946 FORMAT ('_790', 2I10, 15X, '=', /, 14X, A) 99945 FORMAT ('_', I3, 2F10.3, A) 99944 FORMAT (A, 2I10) 99943 FORMAT (A, 2F10.0) 99942 FORMAT (A, I1, 2F10.1, A) 99940 FORMAT ('NScat.Length:', 16F7.3) 99939 FORMAT (A, 2F10.4) 99938 FORMAT (A, 2F10.1, A) 99937 FORMAT (A, 2F10.2) 99936 FORMAT (A, 2F10.3) 99935 FORMAT (A, I1, 2F10.1, A) 99934 FORMAT (I4, 1X, A, F8.4, 2F9.4, F7.2, 2X, A, I4, F7.3, F8.3, 1 2X, A3) 99933 FORMAT ('_780', 2I10) 99932 FORMAT ('_313', 2I10, A) END SUBROUTINE PLA074 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER IE3*4, ISRT*4, IPROB*4, FORMA*73, FORMB*73, 1 FORMC*73, FORMD*157, FORME*218, FORMF*188, CPLM*1, CDUM*1 DIMENSION ISPV(8), IPLA(7, 2) IDUM1 = 0 IDUM2 = 0 IRES1 = 0 FORMA(1:9) = '( A ,' FORMA(10:41) = 'F8.4,''('',I4,'')'',F8.4,''('',I4,'')'',' FORMA(42:73) = FORMA(10:41) FORMB(1:9) = '( ''A'',I3,' FORMB(10:73) = FORMA(10:73) FORMC(1:29) = '(60X, ' FORMC(30:73) = FORMC(8:29)//FORMC(8:29) FORMD(74:94) = '1X,A,F6.3,''('',I2,'')'',' FORMD(95:136) = FORMD(74:94)//FORMD(74:94) FORMD(137:157) = '1X,A,F6.3,''('',I2,'')'')' FORME(1:32) = '(I2,'','',I2,''= '',F5.2,''('',I3,'')'',' FORME(33:63) = 'I4,'','',I2,''= '',F5.2,''('',I3,'')'',' FORME(64:156) = FORME(33:63)//FORME(33:63)//FORME(33:63) FORME(157:187) = FORME(33:63) FORME(188:218) = 'I4,'','',I2,''= '',F5.2,''('',I3,'')'')' FORMF(1:18) = '( 3A,I2,''M = '',' FORMF(19:52) = 'F6.2,''('',I2,''),'',F6.2,''('',I2,''),'',' FORMF(53:154) = FORMF(19:52)//FORMF(19:52)//FORMF(19:52) FORMF(155:188) = 'F6.2,''('',I2,''),'',F6.2,''('',I2,''),'')' IF (IPR(147) .GT. 0) THEN CALL GEN108 (LU8, 0) SD = 0.0 NMAX = IPR(39) NLSPL = 0 10 READ (LU8) MARK, IPR(12), JR, RMAT IF (MARK .NE. -100) THEN IF (MARK .LT. 0) THEN READ (LU8) GOTO 10 ENDIF READ (LU8) (IATP(L4), L4 = 1, NMAX) NLSPL = NLSPL + 1 IF (NLSPL .EQ. 1) THEN IF (IPR(41) .EQ. 0) THEN IE3 = 'UNIT' ELSE IF (IPR(41) .EQ. 1) THEN IE3 = 'ATWT' ELSE IE3 = 'ESD ' ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (- 15 - IPR(155) * 2) WRITE (LU7, 99998) IPR(579), PAR(49), PAR(76), IE3 IF (IPR(155) .GT. 0) 1 WRITE (LU7, 99995) IPR(217), IPR(159) WRITE (LU7, 99997) ENDIF ENDIF IF (NLSPL .GT. NP2) GOTO 170 CALL PLA055 DO 20 I = 1, 4 K = I + 4 XLS(I, NLSPL) = XPV(I) XLS(K, NLSPL) = XSPV(I) IFT = -3 + 16 * I CALL GEN041 (XPV(I), XSPV(I), ISPV(I), 4, NDEC, IPR(68)) FORMA(IFT : IFT) = CHAR(ICHAR('0') + NDEC) CALL GEN041 (XPV(K), XSPV(K), ISPV(K), 4, NDEC, IPR(68)) FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC) 20 CONTINUE CPLM = '#' IF (MARK .EQ. 1) THEN ISRT = 'Plan' ELSE IF (MARK .EQ. 2) THEN ISRT = 'Ring' ELSE IF (MARK .EQ. 3) THEN ISRT = 'Resd' ELSE IF (MARK .EQ. 4) THEN ISRT = 'Lspl' IPR(19) = IPR(19) + 1 ELSE IF (MARK .EQ. 5) THEN ISRT = 'Crdn' ENDIF DO 30 I = 1, 8 ISPV(I) = MIN (99, ISPV(I)) 30 CONTINUE SGREF = 0 SDK = 0 NATP = IPR(12) DO 50 J = 1, NATP IP = IATP(J) SGREF = SGREF + XSD(IP, 4) + XSD(IP, 5) + XSD(IP, 6) D = - XPV(4) DO 40 I = 1, 3 D = D + XPV(I) * XXO(IP, I + 3) 40 CONTINUE SDK = SDK + D**2 50 CONTINUE SIGPL = 0 IF (NATP .GT. 3) SIGPL = SQRT(SDK / (NATP - 3)) SGREF = SQRT(SGREF / (NATP * 3)) CHIK = 0.0 IF (SGREF .GT. PAR(12)) CHIK = MIN (999999.9, SDK / SGREF**2) IDOF = NATP - 3 IF (IPR(72) .NE. 0) THEN CALL GEN093 (IDOF, CHIK, IPROB) ELSE IPROB = ' ' ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99999) NLSPL, SGREF, SIGPL, CHIK, IPROB ENDIF MLL = 0 ISX = 0 DO 80 II = 1, NMAX IATPI = MOD(IATP(II), NP1) CALL GEN048 (-1, IFG(IATPI), 7, IVAL) IF (IVAL .EQ. 1 .AND. II .GT. NATP) GOTO 70 CALL GEN048 (-6, IFG(IATPI), 9, IRESII) IF (II .EQ. 1) THEN IRES1 = IRESII ELSE IF (II .GT. NATP) THEN IF (IRES1 .NE. IRESII .AND. II .GT. 8) GOTO 70 ENDIF CALL PLA056 (XLS(1, NLSPL), IATPI, DEVMLL, SDVMLL, 1 ISDVML, 3, NDEC) IF (ABS(DEVMLL) .GT. PAR(76) .AND. II .GT. NATP) GOTO 70 CALL PLA047 (XLAB(IATPI), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) MLL = MLL + 1 IF (II .GT. NATP) CPLM = ' ' NAMS(MLL, 1) = CPLM//NQ1 DEV(MLL) = DEVMLL SDV(MLL) = SDVMLL ISDV(MLL) = MIN (99, ISDVML) IFT = 61 + MLL * 21 FORMD(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IF (II .NE. NMAX) THEN IF (MLL .LT. 4) GOTO 80 ENDIF 60 IF (ISX .EQ. 4) THEN FORMD(1 : 73) = FORMB IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMD) IPR(12), 1 (XPV(I + ISX), ISPV(I + ISX), I = 1, 4), 2 (NAMS(LL, 1)(1:7), DEV(LL), ISDV(LL), LL = 1, MLL) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF ISX = ISX + 4 ELSE IF (ISX .GT. 4) THEN IF (MLL .EQ. 0) GOTO 80 FORMD(1 : 73) = FORMC IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMD) (NAMS(LL, 1)(1:7), 1 DEV(LL), ISDV(LL), LL = 1, MLL) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF ELSE FORMD(1 : 73) = FORMA IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMD) ISRT, 1 (XPV(I + ISX), ISPV(I + ISX), I = 1, 4), 2 (NAMS(LL, 1)(1:7), DEV(LL), ISDV(LL), LL = 1, MLL) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF NAMS(1, 1) = ' ' ISX = ISX + 4 ENDIF MLL = 0 GOTO 80 70 IF (II .EQ. NMAX) GOTO 60 80 CONTINUE GOTO 10 ENDIF IF (NLSPL .GT. 1 .AND. IGBL(63) .GT. 0) THEN KB = 0 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99996) ENDIF DO 110 I = 1, NLSPL - 1 DO 100 J = I + 1, NLSPL KB = KB + 1 DBUF(KB) = GL(5) * ACOS(MIN(ABS(XLS(1, I) * XLS(1, J) + 1 XLS(2, I) * XLS(2, J) + XLS(3, I) * XLS(3, J)), 1.0)) A = 0 DO 90 K = 5, 7 A = A + XLS(K, I)**2 + XLS(K, J)**2 90 CONTINUE A = GL(5) * SQRT(A) CALL GEN041 (DBUF(KB), A, ISIGA, 2, NDEC, IPR(68)) IDBUF(KB) = MIN (99, ISIGA) IPLA(KB, 1) = I IPLA(KB, 2) = J IFT = - 11 + KB * 31 FORME(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IF (KB .GE. 7) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORME) ((IPLA(L, M), M = 1, 2), 1 DBUF(L), IDBUF(L), L = 1, 7) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF KB = 0 ENDIF 100 CONTINUE 110 CONTINUE IF (KB .GT. 0 .AND. IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORME) ((IPLA(L, M), M = 1, 2), DBUF(L), 1 IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF ENDIF IF (NLSPL .GT. 0 .AND. IGBL(63) .GT. 0) THEN IF (IPR(40) .GT. 0) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (7) WRITE (LU7, 99994) '>', (I, I = 1, 10) ENDIF KB = 0 IPR(133) = - IPR(368) IFIN = -3 N = 0 NEXB = IPR(407) + 6 NQ1(1:6) = 'Axes O' NQ2(1:6) = '--->a ' 120 IF (N .GE. 6) THEN N = N + 1 IF (N .GT. NEXB) THEN CALL PLA038 (I, J, IFIN) IF (IFIN .EQ. 1) GOTO 170 CDUM = '-' ELSE I = NINT(SLN(N - 6, 1)) J = NINT(SLN(N - 6, 2)) CALL PLA047 (XLAB(I), NQ1, IDUM1, IDUM2, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CALL PLA047 (XLAB(J), NQ2, IDUM1, IDUM2, IPR(119), 1 IGBL(55), 0, 1 - IGBL(55)) CDUM = '.' ENDIF CALL PLA227 (I, J, VECN) CALL PLA053 (I, J, 0, 0, D, SD, IDUM1, IDUM2, IER) IF (IER .NE. 0) GOTO 120 ELSE N = N + 1 IF (N .LT. 4) THEN NQ2(5:5) = CHAR(ICHAR('a') - 1 + N) D = PAR(100 + N) SD = 0.0 DO 130 K = 1, 3 VECN(K) = OR(K, N) / D 130 CONTINUE ELSE NQ2(5:6) = CHAR(ICHAR('a') - 4 + N)//'*' D = PAR(109 + N) SD = 0.0 DO 140 K = 1, 3 VECN(K) = ROR(N - 3, K) / D 140 CONTINUE ENDIF CDUM = ' ' ENDIF IF (D .NE. 0.0) THEN DO 160 K = 1, NLSPL KB = KB + 1 DBUF(KB) = 90.0 - ACOS(MIN(ABS(XLS(1, K) * VECN(1) + 1 XLS(2, K) * VECN(2) + XLS(3, K) * VECN(3)), 1.0)) * 2 GL(5) A = 0 DO 150 L = 1, 3 A = A + XLS(L + 4, K)**2 + (VECN(L) * SD / D)**2 150 CONTINUE A = GL(5) * SQRT(A) CALL GEN041 (DBUF(KB), A, ISIGA, 2, NDEC, IPR(68)) IDBUF(KB) = MIN (99, ISIGA) IFT = 5 + KB * 17 FORMF(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IF (KB .GE. 10) THEN K0 = K / 10 - 1 IF (IGBL(63) .GT. 2) THEN IF (K0 .EQ. 0) THEN NQ1(7:7) = CDUM NQ2(7:7) = ' ' CPLM = '/' ENDIF WRITE (PRBUF, FORMF) NQ1, NQ2, CPLM, K0, 1 (DBUF(L), IDBUF(L), L = 1, 10) CALL PLA067 (LU7, PRBUF, 132, 1, 1) NQ1 = ' ' NQ2 = ' ' CPLM = ' ' ENDIF KB = 0 ENDIF 160 CONTINUE ENDIF IF (KB .GT. 0) THEN K0 = NLSPL / 10 IF (IGBL(63) .GT. 2) THEN IF (K0 .EQ. 0) THEN NQ1(7:7) = CDUM NQ2(7:7) = ' ' CPLM = '/' ENDIF WRITE (PRBUF, FORMF) NQ1, NQ2, CPLM, K0, 1 (DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 1) NQ1 = ' ' NQ2 = ' ' CPLM = ' ' ENDIF KB = 0 ENDIF GOTO 120 ENDIF ENDIF ENDIF 170 RETURN 99999 FORMAT (132('-'), /, 'Nr', I3, 8X, 'P', 13X, 'Q', 13X, 'R', 13X, 1 'S', 5X, 'Sigref', F7.3, 5X, 'Sigpln', F7.3, 5X, 'Chisq ', F9.1, 2 4X, 'Pl.Hyp.', 4X, A4, /, 132('-')) 99998 FORMAT ('Automatic Search for Rings (3 to', I3, '-Membered) and', 1 ' Planes Determined by 4 or More Connected Atoms (with', 2 ' Deviation <', F5.2, ' Ang.)', /, 132('-'), //, 3 'Least-Squares Planes - P*X+Q*Y+R*Z=S ::', 2X, 'First Line', 4 ' Orthogonal(XO,YO,ZO), Second Line Fractional(X,Y,Z)', /, 5 36('='), 7X, 'Ring/Plan/Resd/Lspl N Indicates that the Ring/', 6 'Plane/Residue Involves N Atoms', /, 43X, 'Sigref - R.M.S-Error', 7 ' of the Contributing Atoms', /, ' The Deviation D of an Atom', 8 ' with', 10X, 'Sigpln - Sqrt(Sum(j=1:N)(D(j)**2/(N-3))',/, 43X, 9 'Chisq - Chi-Squared = Sum(j=1:N)(D(j)**2)/Sigref**2', /, * ' Fractional Coordinates X,Y,Z may be', 6X, 'Pl.Hyp. - Result', 1 ' of the Chi.Sq. Test for Planarity (See Stout & Jensen, p424)', 2 //, 2X, 'Calculated via Substitution in', 3 /43X, 4 '**** - Atoms Deviating by More Than ', F3.1, ' Angstrom and', 5 ' Hydrogen Atoms are NOT Listed', /, 2X, 'D = P*X + Q*Y + R*Z', 6 ' - S (2nd Line)', 7X, 'Note - Weights : ', A4) 99997 FORMAT (48X, '- Deviations from planes are in Angstrom Units', /, 1 48X, '- The Plane determining Atoms have been Marked #') 99996 FORMAT (/, '(Acute) Angles (Degrees) Between Planes ', 1 '(Numbers I,J from List Above)', /, 132('-')) 99995 FORMAT (43X, '**** - Maximum Metal Containing Ring Size:', 1 I6, /, 48X, '- Maximum Number of Bonds to Ring Metal:', I3) 99994 FORMAT (//, '(Acute) Angles (Degrees) Between Axes, Lines,', 1 ' Bonds and L.S.-Plane', /, 132('-'), /, 1X, 2 'Bond / Plane NM --', A, ' M', I7, 9(I11), /, 132('-')) END SUBROUTINE PLA075 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 IF (IPR(69) .NE. 0 .AND. IPR(55) .EQ. 0) THEN CALL GEN108 (LU8, 0) NRING = 0 NHEAD = 0 10 READ (LU8) MARK, IPR(12), JR, RMAT IF (MARK .NE. -100) THEN IF (MARK .NE. 2) THEN READ (LU8) GOTO 10 ENDIF READ (LU8) (IATP(L4), L4 = 1, IPR(39)) NRING = NRING + 1 IF (IPR(12) .GT. 3) CALL PLA095 (NRING, NHEAD, 0) GOTO 10 ENDIF ENDIF CALL GEN108 (LU8, 0) IF (IPR(23) .EQ. 0 .AND. IPR(64) .GT. 0 .AND. IGBL(97) .EQ. 1 1 .AND. IGBL(63) .GT. 1) CALL PLA048 RETURN END SUBROUTINE PLA076 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // JNSC(2, NP23), VOID(NPVD) CHARACTER FORMA*126, FORMB*129 A = 0.0 D = 0.0 SA = 0.0 SD = 0.0 ISA = 0 ISD = 0 NDEC = 0 CALL GEN108 (LU8, 0) IPR(52) = 0 IF (IPR(147) .EQ. 0) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99985) '<', PAR(1) ENDIF WRITE (LU6, 99985) '<', PAR(1) GOTO 190 ENDIF NMAX = IPR(39) NRES = IPR(75) NCB = IPR(131) MBL = 4 MAL = 3 IF (IGBL(31) .EQ. 2) THEN DO 10 I = 1, NMAX CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0) WRITE (LU2, 99999) NQ1(1:4), (XXO(I, J), J = 4, 6) 10 CONTINUE WRITE (LU2, 99998) DO 20 N = 1, NCB FLI = VOID(IPR(298) + N * 3 - 2) FLJ = VOID(IPR(298) + N * 3 - 1) WRITE (LU2, 99997) NINT(FLI), NINT(FLJ) 20 CONTINUE WRITE (LU2, 99996) ENDIF CALL PLA098 (0, 0, 0, 0.0, 0.0, 0.0, 0, 0) IF (IPR(6) + IPR(7) + IPR(8) .EQ. 0) GOTO 190 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (0) WRITE (LU7, 99993) WRITE (LU7, 99989) PAR(1), IGBL(97) * PAR(26), PAR(27) IF (IPR(44) .EQ. 1) WRITE (LU7, 99984) '>', '<' NLINE = 3 + IPR(44) ENDIF IF (PAR(107) .GT. 0.0 .AND. IGBL(63) .GT. 2) THEN NLINE = NLINE + 4 WRITE (LU7, 99983) PAR(13), PAR(14) WRITE (LU7, 99981) ENDIF IF (IGBL(63) .GT. 2) CALL PLA269 (NLINE) FORMB( 1: 4) = '( ' FORMB( 5: 32) = ' A ,''- '', A ,F8.4,''('',I2,'')''' FORMB(33: 64) = ',4X,'//FORMB(5:32) FORMB(65:129) = FORMB(33:64)//FORMB(33:64)//')' FORMA( 1: 4) = '( ' FORMA( 5: 26) = ' A ,''- '', A ,''- '', A ,' FORMA(27: 41) = 'F7.2,''('',I3,'')''' FORMA(42: 83) = ', 6X,'//FORMA(5:26)//FORMA(27:41) FORMA(84:126) = FORMA(42:83)//')' DO 180 NRSD = 1, NRES NDIS = 0 KB = 0 IHB = 0 IF (NRES .GT. 1) THEN IPR(134) = 1 ELSE IPR(134) = 0 ENDIF IF (IPR(438) .EQ. 1) WRITE (LU2, 99995) NRSD IF (IPR(6) .NE. 0) THEN IPR(133) = -1 70 IPR(133) = IPR(133) + 1 IF (IPR(133) .GT. 1) GOTO 100 IFIN = -1 80 CALL PLA038 (I, J, IFIN) IF (IFIN .EQ. 1) GOTO 70 CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .NE. NRSD) GOTO 80 CALL GEN048 (-1, IFG(J), 7, IHJ) IF (IHJ .NE. IHB) THEN IHB = 1 IF (KB .GT. 0) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 1, 2), 1 DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF KB = 0 ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99992) ENDIF ENDIF CALL PLA053 (I, J, 0, 0, D, SD, ISD, NDEC, IER) IF (IER .NE. 0) GOTO 80 KB = KB + 1 NDIS = NDIS + 1 CALL PLA036 (I, KB, 1, IDS1, IDUM1, IDUM2, IPR(119), IGBL(55)) CALL PLA036 (J, KB, 2, IDS2, IDUM1, IDUM2, IPR(119), IGBL(55)) DIFF = 0.0 IDS12 = IDS1 + IDS2 CALL PLA098 (I, J, KB, D, SD, DIFF, IDS12, 1) DBUF(KB) = D IDBUF(KB) = MIN (99, ISD) IFT = -11 + 32 * KB FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IFT = -22 + 32 * KB FORMB(IFT : IFT) = '-' IF (DIFF .GT. PAR(280)) FORMB(IFT : IFT) = '>' IF (DIFF .LT. - PAR(280)) FORMB(IFT : IFT) = '<' IF (IPR(438) .EQ. 1) THEN IPR(251) = IPR(251) + 1 WRITE (LU2, 99991) 1 (NAMS(KB, M)(2:8), M = 1, 2), D, SD ENDIF IF (NDIS .EQ. 1) THEN IF (IPR(134) .EQ. 1) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99994) NRSD ENDIF IPR(134) = 0 ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99990) ENDIF ENDIF IF (KB .GE. MBL) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 1, 2), 1 DBUF(L), IDBUF(L), L = 1, MBL) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF KB = 0 ENDIF GOTO 80 100 IF (KB .GT. 0 .AND. IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 1, 2), 1 DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF ENDIF IF (IPR(7) .NE. 0) THEN NANG = 0 KB = 0 IPR(133) = -1 170 IPR(133) = IPR(133) + 1 IF (IPR(133) .GT. 1) GOTO 175 IF (IPR(133) .EQ. 1 .AND. IGBL(63) .GT. 2) THEN IF (KB .GT. 0) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMA) ((NAMS(L, M), M = 1, 3), 1 DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF KB = 0 ENDIF CALL PLA269 (1) WRITE (LU7, 99992) ENDIF IFIN = -1 160 CALL PLA039 (IAT, JAT, KAT, NRSD, A, SA, ISA, NDEC, KB, IFIN) IF (IFIN .EQ. 1) GOTO 170 NANG = NANG + 1 KB = KB + 1 DBUF(KB) = A IDBUF(KB) = MIN (999, ISA) IFT = -12 + 42 * KB FORMA(IFT : IFT) = CHAR(ICHAR('0') + NDEC) IF (IPR(438) .EQ. 1) THEN IPR(252) = IPR(252) + 1 WRITE (LU2, 99988) 1 (NAMS(KB, M)(2:8), M = 1, 3), A, SA ENDIF IF (NAMS(KB, 2)(2:2) .EQ. 'C') THEN CALL GEN048 (-3, JFG(JAT), 24, JMET) IF (JMET .EQ. 3) THEN DANG = ABS (109.5 - A) IF (DANG .GT. 0.1) THEN CALL GEN048 (-1, IFG(IAT), 7, IHAT) NDISO = 0 IF (NAMS(KB, 1)(1:1) .NE. ' ') NDISO = NDISO + 1 IF (NAMS(KB, 2)(1:1) .NE. ' ') NDISO = NDISO + 1 IF (NAMS(KB, 3)(1:1) .NE. ' ') NDISO = NDISO + 1 IF (NDISO .LT. 2) WRITE (LU20, 99982) 1 IHAT, DANG, A, NAMS(KB, 2)(2:8) ENDIF ENDIF ENDIF IF (NANG .EQ. 1) THEN IF (IPR(134) .EQ. 1) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99994) NRSD ENDIF IPR(134) = 0 ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99987) ENDIF ENDIF IF (KB .GE. MAL) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMA) ((NAMS(L, M), M = 1, 3), 1 DBUF(L), IDBUF(L), L = 1, MAL) CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF KB = 0 ENDIF GOTO 160 175 IF (KB .GT. 0) THEN IF (IGBL(63) .GT. 2) THEN WRITE (PRBUF, FORMA) ((NAMS(L, M), M = 1, 3), 1 DBUF(L), IDBUF(L), L = 1, KB) CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF KB = 0 ENDIF ENDIF CALL PLA032 (NRSD) 180 CONTINUE 190 CALL PLA098 (0, 0, 0, 0.0, 0.0, 0.0, 0, -1) RETURN 99999 FORMAT (A, 3X, 3F10.4) 99998 FORMAT ('END') 99997 FORMAT (I4, 1X, I4) 99996 FORMAT ('END', /, 'END') 99995 FORMAT ('RESD ', I5) 99994 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X, 1 61('*'), /, 57X, 13('=')) 99993 FORMAT ('Analysis of the IntraMolecular Geometry in Terms of', 1 ' Unique Molecule(s)/Ions, with Bond Criterium:', 2 ' d(i-j) < R(i) + R(j) + Tol', /, 132('-')) 99992 FORMAT (' ') 99991 FORMAT ('BOND ', 2(A, 2X), 2F8.4) 99990 FORMAT (/'Bond Lengths (Angstrom). - (Bonds are ordered on the', 1 ' first label, left to right and top to bottom) - ', 2 'su in last digit in ().', /, 132('=')) 99989 FORMAT ('-- Tol = ', F4.2, ' Ang. for Normal Bonds + ', F4.2, 1 ' for (Earth)alkali-NonMetal Contacts and adjusted by ', 2 F4.2, ' Ang. for Metal-Metal Distances') 99988 FORMAT ('ANGL ', 3(A, 2X), 2F7.2) 99987 FORMAT (/'Bond/Valence Angles (Degrees) - (Angles are ordered', 1 ' on the middle label, left to right and top to bottom) -', 2 ' su in last digit in ().', /, 132('=')) 99985 FORMAT (/, ':: Note: No Intra-Bonds with d(I-J) ', 1 A,' R(I) + R(J) + (Tol=', F5.2, ')') 99984 FORMAT ('-- Disordered Atoms are Indicated with ', A, ' or ', A, 1 ' Attached to the Atom Label, indicating Major and Minor Form', 2 ' Respectively') 99983 FORMAT ('-- The Bond Distance and Angle su''s have been', 1 ' Incremented to Include the Effect of the Unit-cell su.',/, 2 3X, '(Rel.Error in Dist.', F7.4, ' Ang. , Abs. Angle Error', 3 F6.3, ' Deg.)') 99982 FORMAT ('_39', I1, 2F10.2, A) 99981 FORMAT ('-- Bonds below with ''>'' or ''<'' Substituted for', 1 ' ''-'' have Distances that Deviate from Expected Values', 2 '(Based on the hybridisations).', /, 132('-')) END SUBROUTINE PLA077 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) NAT = IPR(37) NMAX = IPR(39) NRES = IPR(75) IPR(18) = -2 NEXB = 0 IF (IPR(407) .GT. 0) THEN DO 30 I = 1, IPR(407) NEXB = NEXB + 1 DO 20 J = 1, 2 DO 10 K = 1, NMAX IF (SLN(I, J) .EQ. XLAB(K)) THEN SLN(NEXB, J) = K GOTO 20 ENDIF 10 CONTINUE NEXB = NEXB - 1 GOTO 30 20 CONTINUE 30 CONTINUE IPR(407) = NEXB ENDIF IF (IPR(147) .NE. 0) THEN IPR(146) = 0 40 IPR(12) = 0 IPR(146) = IPR(146) + 1 IF (IPR(146) .GT. IPR(145)) GOTO 100 NTYP = NINT(XLS(1, IPR(146))) IF (NTYP .GE. 0) THEN DO 90 I = 1, NMAX IATPI = NP1 + I XLBL = XLAB(I) I1 = IPR(146) GOTO 60 50 I1 = I1 + 1 IF (XLS(1, I1) .GT. 0) GOTO 80 60 I2 = 1 70 I2 = I2 + 1 IF (I2 .GT. 9) GOTO 50 XLS12 = XLS(I2, I1) IF (XLS12 .GE. 0.0) THEN IF (ABS(XLBL - XLS12) .GT. 0.001) GOTO 70 IPR(12) = IPR(12) + 1 JR((I1 - IPR(146)) * 8 + I2 - 1) = I IATPI = I ENDIF 80 IATP(I) = IATPI 90 CONTINUE IF (IPR(12) .LT. NP7) THEN IF (NTYP .EQ. 0) THEN IF (IPR(12) .GE. 2) THEN VARDIST = 999.0 CALL PLA085 (0, VARDIST) ELSE WRITE (LU6, 99998) ENDIF ELSE IF (IPR(12) .GE. 3) THEN CALL PLA045 (NTYP) ELSE WRITE (LU6, 99998) ENDIF ENDIF ELSE WRITE (LU6, 99998) ENDIF ENDIF GOTO 40 100 IF (IPR(10) .NE. 0 .AND. IGBL(97) .NE. 0) THEN IF (NMAX .GT. 250 .OR. IPR(44) .EQ. 1) THEN IPR(579) = MIN (IPR(219), IPR(216)) WRITE (LU6, 99999) IPR(579) ENDIF DO 190 NR = 1, NRES NRING = 0 DO 180 K = 3, IPR(579) NRTM = K + 1 DO 170 J = 1, NAT CALL GEN048 (-6, IFG(J), 9, IRESJ) IF (IRESJ .NE. NR) GOTO 170 IF (IPR(44) .GT. 0) THEN CALL GEN048 (-7, JFG(J), 1, IPP) IF (IPPR(IPP + 1, 1) .LE. IPR(222)) GOTO 170 ENDIF NHAT = NINT(RCONT(IRESJ)) IF (NHAT .LT. 5 .OR. NHAT .LT. K) GOTO 170 LRT = 2 NRT = 1 JR(1) = J 110 CALL GEN048 (-1, JFG(JR(NRT)), 13, IVAL) IF (IVAL .EQ. 1) THEN IF (LRT .EQ. 1) THEN GOTO 120 ELSE IF (LRT .EQ. 2) THEN GOTO 170 ENDIF ENDIF CALL GEN048 (-1, IFG(JR(NRT)), 8, IVAL) IF (IVAL .EQ. 1) THEN IF (LRT .EQ. 1) THEN GOTO 120 ELSE IF (LRT .EQ. 2) THEN GOTO 170 ENDIF ENDIF NCN(NRT) = - NINT(CON(JR(NRT), NP4)) IF (NCN(NRT) .LT. 0) NCN(NRT) = NP4 IF (NCN(NRT) .LT. 2) THEN IF (LRT .EQ. 1) THEN GOTO 120 ELSE IF (LRT .EQ. 2) THEN GOTO 170 ENDIF ENDIF CALL GEN048 (-1, IFG(JR(NRT)), 19, IVAL) IF (IVAL .EQ. 1) THEN IF (NCN(NRT) .GT. IPR(159)) THEN IF (LRT .EQ. 1) THEN GOTO 120 ELSE IF (LRT .EQ. 2) THEN GOTO 170 ENDIF ENDIF CALL GEN048 (-4, IFG(JR(NRT)), 15, NO1) IF (IATPR(IEN(NO1 + 1)) .GT. 4) THEN IF (LRT .EQ. 1) THEN GOTO 120 ELSE IF (LRT .EQ. 2) THEN GOTO 170 ENDIF ENDIF ENDIF LRT = 1 NRT = NRT + 1 JLN(NRT) = 0 120 JLN(NRT) = JLN(NRT) + 1 IF (JLN(NRT) .GT. NCN(NRT - 1)) THEN NRT = NRT - 1 IF (NRT .GT. 1) GOTO 120 GOTO 170 ENDIF JR(NRT) = NINT(CON(JR(NRT - 1), JLN(NRT))) IF (JR(NRT) .GE. JR(1)) THEN IF (NRT .GT. 3) THEN IF (NRT .EQ. NRTM) THEN NRTM2 = 1 ELSE NRTM2 = NRT - 2 ENDIF DO 130 I = 2, NRTM2 IF (JR(NRT) .EQ. JR(I)) GOTO 120 130 CONTINUE ENDIF IF (JR(NRT) .EQ. JR(1)) THEN IF (NRT .LT. NRTM) GOTO 120 DO 140 I = 2, NRT CALL GEN048 (-1, IFG(JR(I)), 19, IVAL) IF (IVAL * (NRT - 1) .GT. IPR(217)) GOTO 120 140 CONTINUE IF (JR(2) .LE. JR(NRT - 1)) THEN DO 150 I = 1, NMAX IATP(I) = NP1 + I 150 CONTINUE IPR(12) = NRT - 1 IPOP = 1000 DO 160 I = 1, IPR(12) IF (IPR(44) .GT. 0) THEN CALL GEN048 (-7, JFG(JR(I)), 1, IPP) IPAR = IPPR(IPP + 1, 1) IF (IPAR .NE. IPOP) THEN IF (IPOP .LT. 1000 .AND. IPAR .LT. 1000 .OR. 1 IPOP .LE. IPR(222) .OR. 2 IPAR .LE. IPR(222)) THEN GOTO 120 ELSE IF (IPOP .EQ. 1000) IPOP = IPAR ENDIF ENDIF ENDIF IATP(JR(I)) = JR(I) 160 CONTINUE IF (K .GT. 3 .OR. 1 (K .EQ. 3 .AND. IPR(69) .LE. 10)) THEN CALL PLA045 (2) NRING = NRING + 1 IF (NRING .GE. IPR(302) + IPR(592) * 1000) THEN IPR(579) = K WRITE (LU6, 99999) K GOTO 190 ENDIF ELSE GOTO 180 ENDIF ENDIF IF (NRT .EQ. NRTM) NRT = NRT - 1 GOTO 120 ENDIF IF (NRT .LT. NRTM) GOTO 110 ENDIF GOTO 120 170 CONTINUE 180 CONTINUE 190 CONTINUE ELSE IF (IGBL(99) .EQ. 1) WRITE (LU6, 99997) ENDIF IF (IPR(11) .NE. 0 .AND. IGBL(97) .NE. 0) THEN DO 220 JAT = 1, NAT CALL GEN048 (-1, IFG(JAT), 19, IVAL) IF (IVAL .EQ. 1) THEN IF (NINT(CON(JAT, NP4)) .EQ. -4) THEN DO 200 I = 1, NMAX IATP(I) = NP1 + I 200 CONTINUE DO 210 I = 1, 4 IATP(I) = NINT(CON(JAT, I)) 210 CONTINUE IPR(12) = 4 CALL PLA045 (5) ENDIF ENDIF 220 CONTINUE DO 240 NRS = 1, NRES IPR(12) = 0 DO 230 I = 1, NMAX IATPI = NP1 + I CALL GEN048 (-6, IFG(I), 9, IVAL) IF (IVAL .EQ. NRS) THEN CALL GEN048 (-1, IFG(I), 7, IVAL) IF (IVAL .EQ. 0) THEN IPR(12) = IPR(12) + 1 IATPI = I ENDIF ENDIF IATP(I) = IATPI 230 CONTINUE IF (IPR(12) .GT. 5) CALL PLA045 (3) 240 CONTINUE ENDIF IF (IPR(9) .NE. 0) THEN DO 350 JAT = 1, NMAX IF (IPR(44) .GT. 0) THEN CALL GEN048 (-7, JFG(JAT), 1, IPP) IF (IPPR(IPP + 1, 1) .LT. 1000) GOTO 350 ENDIF CALL GEN048 (-1, IFG(JAT), 7, IVAL) IF (IVAL .GT. 0) GOTO 350 CALL GEN048 (-1, IFG(JAT), 5, IVAL) IF (IVAL .GT. 0) GOTO 350 CALL GEN048(-6, IFG(JAT), 9, IRESJ) NC = - NINT(CON(JAT, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .GT. 1) THEN N = NC - 1 DO 340 KI = 1, N IAT = NINT(CON(JAT, KI)) IF (IPR(44) .GT. 0) THEN CALL GEN048 (-7, JFG(IAT), 1, IPP) IF (IPPR(IPP + 1, 1) .LT. 1000) GOTO 340 ENDIF CALL GEN048 (-1, IFG(IAT), 7, IVAL) IF (IVAL .EQ. 0) THEN J1 = KI + 1 DO 330 KJ = J1, NC KAT = NINT(CON(JAT, KJ)) CALL GEN048 (-1, IFG(KAT), 7, IVAL) IF (IVAL .EQ. 0) THEN DO 250 I = 1, NMAX IATP(I) = NP1 + I 250 CONTINUE IATP(IAT) = IAT IATP(JAT) = JAT IATP(KAT) = KAT IPR(12) = 3 260 CALL PLA054 (0) I = 0 270 I = I + 1 IF (I .GT. NMAX) GOTO 320 IF (IPR(44) .GT. 0) THEN CALL GEN048 (-7, JFG(I), 1, IPP) IF (IPPR(IPP + 1, 1) .LT. 1000) GOTO 270 ENDIF IF (IATP(I) .LT. NP1) GOTO 270 CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .NE. IRESJ) GOTO 270 CALL GEN048 (-1, IFG(I), 7, IVAL) IF (IVAL .GT. 0) GOTO 270 NCI = - NINT(CON(I, NP4)) IF (NCI .LT. 0) NCI = NP4 IF (NCI .EQ. 0) GOTO 270 UITW = - XPV(4) DO 280 J = 1, 3 UITW = UITW + XPV(J) * XXO(I, J + 3) 280 CONTINUE IF (ABS(UITW) .GT. PAR(49)) GOTO 270 DO 300 J = 1, NMAX IF (IATP(J) .GT. NP1) GOTO 300 DO 290 IJ = 1, NCI IF (NINT(CON(I, IJ)) .EQ. J) GOTO 310 290 CONTINUE 300 CONTINUE GOTO 270 310 IPR(12) = IPR(12) + 1 IATP(I) = I GOTO 260 320 IF (IPR(12) .GT. 3) CALL PLA045 (1) ENDIF 330 CONTINUE ENDIF 340 CONTINUE ENDIF 350 CONTINUE ENDIF ENDIF WRITE (LU8) -100, 0, JR, RMAT IPR(86) = 1 RETURN 99999 FORMAT (/, ':: Maximum Ring-size has been Reset to:', I3, /) 99998 FORMAT ('W: User-specified Ring/Plane/Fit/Line not accepted', /) 99997 FORMAT (/, ':: Note: Ring-search Suppressed in Inorganic Mode.', 1 /) END SUBROUTINE PLA078 (I) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CALL GEN048 (-1, IFG(I), 2, IVAL) IF (IGBL(30) .EQ. 1) THEN ITRNS = 1555 ELSE IF (IVAL .EQ. 1) THEN ITRNS = IATP(I) ELSE KAT = IPR(39) + IPR(24) + 1 KAT1 = KAT + 1 IF (KAT1 .GT. NP1) THEN IPR(2) = 1 ITRNS = 1555 GOTO 40 ENDIF ITRNS = IABS(IATP(I)) IF (ITRNS .NE. 0) THEN IGBL(30) = -1 IPR(50) = IPR(50) + 1 J = ITRNS / 1000 FN(1) = J J = ITRNS - J * 1000 ITR(1) = J / 100 J = J - ITR(1) * 100 ITR(2) = J / 10 ITR(3) = J - ITR(2) * 10 DO 20 J = 1, 3 FN(J + 1) = ITR(J) - 5 20 CONTINUE ELSE FN(1) = 1.0 CALL GEN074 (FN, 0.0, 2, 4) ENDIF ITRNS = NINT(FN(1) * 1000 + 555) DO 30 L = 1, 3 XXO(KAT, L) = XXO(I, L) XSD(KAT, L) = XSD(I, L) ITR(L) = NINT(FN(L + 1)) IF (IABS(ITR(L)) .GT. 4) IPR(2) = 17 ITRNS = ITRNS + ITR(L) * 10**(3 - L) 30 CONTINUE IF (ITRNS .NE. 1555) THEN WRITE (LU4) 5, XLAB(I), (FN(L), L = 1, 8) IPR(54) = NINT(FN(1)) CALL PLA059 (KAT, I) ENDIF ENDIF 40 IATP(I) = ITRNS CALL GEN048 (1, IFG(I), 2, 1) RETURN END SUBROUTINE PLA079 (XNQNR) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP36=1000,NP38=125,NP39=30,NP41=200,NP45=2048, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /ALIASES/ ALAB(NP36), BLAB(NP36) CHARACTER ALAB*7, BLAB*7 COMMON /LMEM/ ATYC, ATYO, ATYN IENR = 0 ISU = 0 NAT = IPR(39) IF (NAT .GE. NP1) THEN IPR(2) = 1 ELSE IF (NAT .EQ. 0) THEN IGBL(59) = 0 ATYC = 0.0 ATYO = 0.0 ATYN = 0.0 ENDIF NATP1 = NAT + 1 KL = IPR(220) KN = IPR(221) MODE = 100 GL25 = MAX (0.05, GL(25)) IF (IGBL(8) .EQ. 3) THEN IF (KN .NE. 10) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99990) '_170', 1, 1, IFL(2) ELSE IPR(2) = 51 ENDIF GOTO 250 ENDIF IF (NAT .EQ. 0) THEN IF (IPR(319) .EQ. 0) THEN WRITE (LU20, 99994) '_124', 1.0, 1.0, CCIF(7)(1:7) IF (SPGRNM(1)(1:1) .EQ. ' ') THEN WRITE (LU20, 99994) '_121', 1.0, 1.0, CCIF(6) CALL SGSM (IDM, 0, XJX, 0, 1, IERR) IPR(48) = 1 ENDIF ENDIF ENDIF ENDIF NSYM = IPR(48) IPR(107) = 0 IF (NAT .EQ. 0) THEN IF (IGBL(8) .EQ. 3 .AND. PAR(101) .LT. 1.1) THEN IPR(2) = 58 GOTO 250 ENDIF IPR(463) = 128 IPR(464) = 512000 IPR(465) = 4000 IPR(466) = IPR(465) * 2 ENDIF NQ1 = IFL(IPR(473)) IF (IGBL(8) .EQ. 2) THEN IF (IPR(538) .NE. 0) THEN N = INDEX (NQ1, ' ') IF (N .NE. 0) THEN IF (IPR(538) .LT. 10) THEN WRITE (NQ1(N:N + 1), 99992) IPR(538) ELSE WRITE (NQ1(N:N + 2), 99991) IPR(538) ENDIF ENDIF IFL(IPR(473)) = NQ1 ENDIF ENDIF NQ2 = NQ1 NQ4 = NQ1 LOP = 0 10 CALL PLA046 (MODE, NQ1, IENM1, LBB, LBC, LBD, XNQNR, YNQNR, 1 NIEN) IF (NIEN .LT. 0) THEN IF (NIEN .EQ. -12) THEN NQ1 = NQ2 IPR(2) = 57 GOTO 250 ENDIF IF (IABS(IGBL(8)) .EQ. 3) THEN IF (KL .EQ. 3) THEN LOP = LOP + 1 IF (LOP .EQ. 1) THEN NQ1 = IFL(3) ELSE MODE = 100 NQ1 = IFL(2) IPR(220) = 2 KL = 2 GOTO 10 ENDIF ELSE LOP = LOP + 1 IF (ICHAR(IFL(2)(2:2)) .GE. 48 .AND. 1 ICHAR(IFL(2)(2:2)) .LE. 57 .AND. 2 LOP .LT. 3) THEN NQ1 = IFL(2)(1:1)//' ' ELSE IPR(2) = 3 GOTO 250 ENDIF ENDIF ELSE IF (IABS(IGBL(8)) .EQ. 2) THEN IF (IAN .GT. 0 .AND. NINT(FN(1)) .LE. IAN) THEN NQ1 = LMT(NINT(FN(1)), 1)//' ' ELSE IPR(2) = 46 GOTO 250 ENDIF ELSE IF (IGBL(8) .EQ. 1) THEN ELSE IPR(2) = 3 GOTO 250 ENDIF IF (NQ1(1:1) .EQ. ' ') THEN NQ1(1:1) = NQ1(2:2) NQ1(2:4) = '999' ELSE IF (NQ1(2:2) .EQ. ' ') THEN NQ1(2:4) = '999' ELSE NQ1(3:4) = '99' ENDIF MODE = 99 GOTO 10 ENDIF IF (MODE .EQ. 100) THEN DO 20 K = 1, NAT IF (NINT(CON(K, 2)) .EQ. NINT(XNQNR)) THEN WRITE (LU20, 99994) '_070', 1.0, 1.0, NQ2 MODE = 99 GOTO 10 ENDIF 20 CONTINUE ENDIF IF (IABS (IGBL(8)) .EQ. 2) THEN IPR(32) = MAX (IPR(32), 1) IF (KN .EQ. 7) KN = 6 IF (KN .NE. 6 .AND. KN .NE. 11) THEN IPR(498) = IPR(498) + 1 IF (KN .EQ. 4) FN(5) = 11.0 FN(6) = PAR(30) KN = 6 ENDIF IENR = NINT(FN(1)) DO 30 K = 2, KN YY = FN(K) IF (ABS(YY) .GT. 5.0) THEN I = NINT(ABS(YY) * 0.1) IF (I .EQ. 1) THEN RPI = 1.0 ELSE RPI = RP(I) ENDIF SJ = SIGN(0.5, YY) IF (I .NE. 1 .AND. I .GT. IPR(109)) THEN IPR(2) = 9 GOTO 250 ENDIF YY = (YY - I * SJ * 20.0) * (RPI + SJ - 0.5) ENDIF FN(K - 1) = YY 30 CONTINUE KN = KN - 1 IF (KN .EQ. 5) THEN FN(9) = FN(5) FN(10) = 0.0 KN = 10 ELSE IPR(32) = 2 DO 40 K = 1, 6 FN(15 - K) = FN(11 - K) 40 CONTINUE CALL GEN074 (FN, 0.0, 15, 20) KN = 20 ENDIF CALL GEN074 (FN, 0.0, 5, 8) IF (FN(4) .LT. 0.0001) THEN IPR(100) = IPR(100) + 1 IPR(471) = IPR(471) + 1 IPR(2) = 0 GOTO 250 ENDIF ELSE IF (KN .EQ. 5) KN = 3 KNP1 = KN + 1 DO 70 K = KNP1, 9 FN(K) = 0.0 70 CONTINUE IF (KN .EQ. 6) THEN DO 80 K = 1, 4 FN(9 - K) = FN(8 - K) 80 CONTINUE FN(4) = 0.0 ENDIF IF (IPR(23) .NE. 0) THEN ISU = 0 DO 90 K = 1, 3 FN(K) = FN(K) * PAR(11) FN(K + 4) = FN(K + 4) * PAR(11) IF (FN(K + 4) .GT. 0) ISU = 1 90 CONTINUE ENDIF ENDIF IF (IPR(23) .EQ. 0) CALL PLA080 CALL GEN002 (1, TM2, FN, XJX, XLNG) DO 100 K = 1, 3 DUMA(K) = 0.0 FNK4 = FN(K + 4) IF (FNK4 .GT. 0.0) IPR(72) = 1 IF (FNK4 .LT. 0.0) FNK4 = 0.0 FN(K + 4) = FNK4**2 100 CONTINUE DO 120 K = 1, 3 IF (IPR(23) .EQ. 0) THEN DO 110 L = 1, 3 DUMA(K) = DUMA(K) + TM2(K, L)**2 * FN(L + 4) 110 CONTINUE ELSE DUMA(K) = FN(K + 4) ENDIF 120 CONTINUE DO 130 K = 1, 3 XJX(K) = XJX(K) + SHFT(K) FN(K) = XJX(K) FN(K + 4) = SQRT(DUMA(K)) XJX(K + 3) = 0.0 CON(NATP1, K + 2) = FN(K) CON(NATP1, K + 5) = DUMA(K) CON(NAT + 2, K + 2) = 0.0 130 CONTINUE IPR94 = 0 IBORH = 0 IF (IEN(NIEN + 1) .EQ. 1 .OR. IEN(NIEN + 1) .EQ. 33 .OR. 1 IEN(NIEN + 1) .EQ. 113) THEN IPR94 = 1 IBORH = 1 ENDIF IF (IEN(NIEN + 1) .EQ. 20) IBORH = 1 MULT = IPR(23) IF (MULT .EQ. 0) THEN XJX(10) = 0.0 CALL SGSM (IDM, 0, XJX, LU6, 19, IERR) IF (IGBL(8) .EQ. 3) THEN IF (XJX(10) .NE. 1.0) THEN FN(4) = FN(4) * XJX(10) ELSE IF (IPR94 .EQ. 0 .AND. IGBL(94) .EQ. 0) THEN IF (FN(5) .LE. 0.0) WRITE (LU20, 99994) 1 '_161', 1.0, 1.0, NQ2(1:7) IF (FN(6) .LE. 0.0) WRITE (LU20, 99994) 1 '_162', 1.0, 1.0, NQ2(1:7) IF (FN(7) .LE. 0.0) WRITE (LU20, 99994) 1 '_163', 1.0, 1.0, NQ2(1:7) ENDIF ENDIF ENDIF IF (IPR94 .EQ. 0) THEN ISU = 1 IF (XJX(10) .EQ. 1.0 .AND. FN(5) .LE. 0.0 .AND. 1 FN(6) .LE. 0.0 .AND. FN(7) .LE. 0.0) ISU = 0 ELSE ISU = 0 IF (FN(5) .GT. 0.0 .OR. FN(6) .GT. 0.0 .OR. FN(7) .GT. 0) 1 ISU = 1 ENDIF IF (ABS(FN(4) / XJX(10) - 0.5) .GT. 0.4998) THEN DO 190 J = 1, NSYM JSYM = J CALL SGSM (ICL, JSYM, XJX, LU7, 3, IERR) DO 180 I = 1, NATP1 VERS = 0.0 DO 150 K = 1, 3 DUMA(K) = CON(I, K + 2) - XJX(K + 6) 140 IF (DUMA(K) .GT. 0.5) THEN XJX(K + 6) = XJX(K + 6) + 1.0 DUMA(K) = DUMA(K) - 1.0 GOTO 140 ENDIF IF (DUMA(K) .LE. - 0.5) THEN XJX(K + 6) = XJX(K + 6) - 1.0 DUMA(K) = DUMA(K) + 1.0 GOTO 140 ENDIF 150 CONTINUE VERS = SQRT(PAR(129) * DUMA(1) ** 2 1 + PAR(130) * DUMA(2) ** 2 2 + PAR(131) * DUMA(3) ** 2 3 + PAR(132) * DUMA(1) * DUMA(2) 4 + PAR(133) * DUMA(1) * DUMA(3) 5 + PAR(134) * DUMA(2) * DUMA(3)) IF (VERS .LT. GL25) THEN CALL GEN048 (-1, IFG(I), 7, IHAT) IF (IHAT .EQ. 1 .OR. IPR94 .EQ. 1) THEN IF (VERS .GT. PAR(22)) GOTO 180 ENDIF IF (NQ2(1:1) .NE. 'Q' .AND. VERS .GT. PAR(22)) 1 GOTO 180 IF (I .NE. NATP1) THEN CALL PLA047 (CON(I, 2), NQ2, IENM, JDUM, IPR(119), 1 IGBL(55), 0, 0) IPR(100) = IPR(100) + 1 WRITE (LU6, 99997) NQ1, VERS, NQ2 IF (VERS .LT. PAR(22)) THEN IF (IEN(IENM1) .EQ. JDUM) THEN DO 160 K = 1, 3 FN(K) = (CON(I, K + 2) + XJX(K + 6)) / 2.0 CON(I, K + 2) = FN(K) 160 CONTINUE FN(4) = - 1.0 WRITE (LU4) 11, CON(I, 2), (FN(K), K = 1, 8) ENDIF WRITE (LU6, 99996) NQ1, VERS, NQ2, 1 (FN(K), K = 1, 3) ENDIF WRITE (LU20, 99993) '_310', VERS, VERS, NQ1, NQ2 IPR(471) = IPR(471) + 1 IPR(107) = 1 IPR(2) = 0 GOTO 250 ELSE IF (MULT .EQ. 0 .OR. IABS(IGBL(8)) .NE. 2 .OR. 1 IABS(IGBL(8)) .NE. 3) THEN MULT = MULT + 1 DO 170 K = 1, 3 CON(NAT + 2, K + 2) = CON(NAT + 2, K + 2) 1 + XJX(K + 6) 170 CONTINUE ENDIF ENDIF ENDIF 180 CONTINUE 190 CONTINUE ELSE MULT = NINT(1.0 / XJX(10)) ENDIF ENDIF CALL PLA047 (XNQNR, NQ2, MN, JDUM, 0, IGBL(55), 0, 0) DO 200 K = 1, 7 IF (NQ2(K : K) .EQ. '#') THEN IF (IGBL(71) .EQ. 1) THEN WRITE (LU6, 99999) IPR(119) = 0 IPR(350) = 0 ENDIF ALAB(IGBL(71)) = IFL(IPR(473)) BLAB(IGBL(71)) = NQ2 M = INDEX (IFL(IPR(473)), ' ') IF (M .GT. 6) THEN WRITE (LU6, 99995) IFL(IPR(473)), NQ2 ELSE WRITE (LU6, 99998) IFL(IPR(473)), NQ2 ENDIF GOTO 210 ENDIF 200 CONTINUE 210 IF (IPR(39) .EQ. 0) IPPR(1, 3) = NSYM IPR(39) = IPR(39) + 1 IPR(37) = IPR(39) CON(IPR(39), 2) = XNQNR IF (IABS(IGBL(8)) .EQ. 2) THEN CON(IPR(39), NP4 - 1) = IENR CON(IPR(39), NP4) = FN(4) ENDIF IF (IPR(37) .EQ. 1) THEN IF (IGBL(8) .EQ. 3 .AND. IGBL(94) .EQ. 0) THEN IF (CCIF(7)(1:11) .NE. CCIF(8)(1:11) .AND. 1 IPR(319) * IPR(318) .EQ. 1) THEN IDM = CCIF(8) CALL GEN047 (IDM, 1, 20) NQ2 = IDM(1:7) IF (NQ2(1:1) .EQ. ' ') NQ2(1:1) = '?' IDM = CCIF(6) CALL GEN047 (IDM, 1, 20) WRITE (LU20, 99994) '_120', 1.0, 1.0, IDM(1:7), NQ2 ENDIF ENDIF ENDIF IFG(IPR(39)) = 0 JFG(IPR(39)) = 0 IF (IABS(IGBL(8)) .EQ. 3) THEN IF (FN(21) .NE. 0.0) THEN CALL GEN048 (1, JFG(IPR(39)), 29, 1) IF ((FN(5) .GT. 0.0 .OR. FN(6) .GT. 0.0 .OR. 1 FN(7) .GT. 0.0) .AND. FN(22) .NE. 3.0) 1 WRITE (LU20, 99994) '_166', 1.0, 1.0, IFL(IPR(473)) ENDIF IF (FN(22) .NE. 0.0) THEN IF (FN(22) .EQ. 1.0) CALL GEN048 (1, JFG(IPR(39)), 30, 1) IF (FN(22) .EQ. 2.0) CALL GEN048 (1, JFG(IPR(39)), 31, 1) IF (IPR94 .EQ. 0 .AND. FN(22) .EQ. 1.0) 1 IPR(164) = IPR(164) + 1 ENDIF ENDIF IF (MULT .GT. 1) CALL GEN048 (1, IFG(IPR(39)), 6 , 1) CALL GEN048 (4, IFG(IPR(39)), 15, NIEN) IF (IPR(165) .GT. 0) THEN ITRNS = IPR(165) IPR(165) = 0 ELSE ITRNS = IPR(95) ENDIF IATP(IPR(39)) = ITRNS CALL GEN048 (1, IFG(IPR(39)), 7, IPR94) CALL GEN048 (1, JFG(IPR(39)), 13, IBORH) IF (IATPR(IEN(NIEN + 1)) .GT. 0) THEN CALL GEN048 (1, IFG(IPR(39)), 19, 1) IPR(155) = 1 PAR(85) = 2 PAR(87) = 1 ENDIF IF (IGBL(99) .NE. 1) THEN NORGA = 0 DO 215 K = 1, NIEN + 1 IF (IEN(K) .EQ. 1) NORGA = NORGA + 1 IF (IEN(K) .EQ. 2) NORGA = NORGA + 1 215 CONTINUE IF (NORGA .EQ. 2) IGBL(97) = 1 ENDIF NPOP = IPR(65) POPPAR = FN(4) * MULT IF (IABS(IGBL(8)) .EQ. 3) THEN IF (POPPAR .GT. 1.001) 1 WRITE (LU20, 99994) '_075', 1.0, POPPAR, IFL(IPR(473)) IF (POPPAR .LT. 1.0 .AND. 1 ABS(MULT * POPPAR - 1.0) .LT. 0.01) THEN WRITE (LU20, 99993) '_076', 0.5, POPPAR, IFL(IPR(473)) ENDIF ENDIF IF (IGBL(8) .EQ. 3) THEN IF (MOD (NINT(YNQNR), 40) .EQ. 0) THEN N = IEN(IENM1) IF (N .EQ. 2) THEN IF (YNQNR .GT. ATYC) THEN ATYC = YNQNR ELSE IPR(545) = IPR(545) + 1 IF (IPR(545) .EQ. 1) THEN WRITE (LU20, 99994) '_795', 1.0, 1.0, NQ1 ENDIF ENDIF ELSE IF (N .EQ. 3) THEN IF (YNQNR .GT. ATYO) THEN ATYO = YNQNR ELSE IPR(546) = IPR(546) + 1 IF (IPR(546) .EQ. 1) THEN WRITE (LU20, 99994) '_796', 1.0, 1.0, NQ1 ENDIF ENDIF ELSE IF (N .EQ. 4) THEN IF (YNQNR .GT. ATYN) THEN ATYN = YNQNR ELSE IPR(547) = IPR(547) + 1 IF (IPR(547) .EQ. 1) THEN WRITE (LU20, 99994) '_797', 1.0, 1.0, NQ1 ENDIF ENDIF ENDIF ENDIF ENDIF FN(4) = MIN (1.0, POPPAR) FN(8) = FN(8) * MULT IF (FN(4) .LT. PAR(12)) FN(4) = 1.0 IF (FN(8) .LT. 0.0) FN(8) = 0.0 IF (FN(4) .LT. 0.5) YNQNR = YNQNR + 150 * 4000 CON(IPR(39), 1) = YNQNR INTPOP = NINT(FN(4) * 1000.0) IF (INTPOP .EQ. 500) THEN IF (FN(4) .GT. 0.5) INTPOP = 501 IF (FN(4) .LT. 0.5) INTPOP = 499 ENDIF IPPR(NPOP + 1, 1) = INTPOP IPPR(NPOP + 1, 2) = NINT(FN(8) * 1000.0) IPPR(NPOP + 1, 3) = NSYM / MULT FN(4) = FN(4) / MULT FN(8) = FN(8) / MULT IF (IPR94 .EQ. 0) PAR(386) = PAR(386) + NSYM * FN(4) PAR(388) = PAR(388) + NSYM * FN(4) * ATWT(IEN(NIEN + 1)) PAR(387) = PAR(388) / (PAR(98) * 0.60221) IF (MULT .GT. 1 .AND. INTPOP .EQ. 1000) THEN DO 220 K = 1, 3 CON(NAT + 1, K + 2) = CON(NAT + 2, K + 2) / MULT FN(K) = CON(NAT + 1, K + 2) 220 CONTINUE ENDIF MULT = NSYM / MULT IF (MOD(IPPR(NPOP + 1, 1), 1000) .NE. 0) THEN IPR(44) = 1 IF (IPR94 .EQ. 0) IPR(43) = 1 ENDIF DO 230 I = 1, NPOP IF (IPPR(I, 3) .EQ. IPPR(NPOP + 1, 3) .AND. 1 IPPR(I, 1) .EQ. IPPR(NPOP + 1, 1)) THEN IPOP = I - 1 GOTO 240 ENDIF 230 CONTINUE IPOP = NPOP IF (IPOP .GT. 127) THEN IPR(71) = IPR(71) + 1 ELSE IPR(65) = IPR(65) + 1 ENDIF 240 CALL GEN048 (7, JFG(IPR(39)), 1, IPOP) CALL GEN048 (1, JFG(IPR(39)), 10, ISU) CALL GEN048 (-1, IFG(IPR(39)), 7, JHAT) IF (JHAT .EQ. 1) IPR(564) = IPR(564) + ISU CALL GEN048 (1, JFG(IPR(39)), 11, 1) WRITE (LU4) 1, XNQNR, (FN(K), K = 1, 8) IF (IABS(IGBL(8)) .EQ. 2) THEN IF (FN(9) .LT. 0.0) THEN FN(9) = - FN(9) * PAR(61) ELSE IF (IPR94 .EQ. 0) PAR(61) = FN(9) ENDIF ENDIF IF (KN .EQ. 10) WRITE (LU4) 4, XNQNR, (FN(K), K = 9, 16) IF (KN .EQ. 20) THEN CALL GEN048 (1, IFG(IPR(39)), 4, 1) FN(9) = FN(9) * PAR(135)**2 FN(10) = FN(10) * PAR(136)**2 FN(11) = FN(11) * PAR(137)**2 FN(12) = FN(12) * PAR(136) * PAR(137) FN(13) = FN(13) * PAR(135) * PAR(137) FN(14) = FN(14) * PAR(135) * PAR(136) CALL GEN025 (DUMV, FN(9), -1) CALL GEN001 (1, TM2, DUMV, UIJ) CALL GEN025 (UIJ, FN(9), 1) FN(9) = FN(9) / PAR(113)**2 FN(10) = FN(10) / PAR(114)**2 FN(11) = FN(11) / PAR(115)**2 FN(12) = FN(12) / (PAR(114) * PAR(115)) FN(13) = FN(13) / (PAR(113) * PAR(115)) FN(14) = FN(14) / (PAR(113) * PAR(114)) IF (IABS(IGBL(8)) .EQ. 2 .AND. IPR94 .EQ. 0) THEN CALL GEN025 (UIJ, FN(9), -1) CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, DUMV, PAR(61)) ENDIF WRITE (LU4) 2, XNQNR, (FN(K), K = 9, 16) WRITE (LU4) 3, XNQNR, (FN(K), K = 15, 22) ENDIF ENDIF 250 RETURN 99999 FORMAT (//, ':: Changed not acceptable ATOM labels on', 1 ' INPUT with substituted ALIASES', /, 71('-')) 99998 FORMAT (':: ', A, ' ======> ', A) 99997 FORMAT (':: ATOM ', A, ' DELETED from INPUT STREAM, ', 1 F5.2, ' Ang. From ', A) 99996 FORMAT (':: ATOM ', A, ' at', F5.2, ' Ang. from ', A, 1 ' - New Av Pos:', 3F8.4) 99995 FORMAT (':: ', A, ' ======> ', A, 2X, 'NO BACKSUBSTITUTION') 99994 FORMAT (A, 2F10.0, 2A) 99993 FORMAT (A, 2F10.3, 2A) 99992 FORMAT ('_', I1) 99991 FORMAT ('_', I2) 99990 FORMAT (A, 2I10, 2A) END SUBROUTINE PLA080 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 DIMENSION KAX(3) IF (IPR(39) .EQ. 0) THEN IF (IPR(48) .GT. 48) THEN IPR(129) = 9 PAR(42) = 10.0 WRITE (LU6, 99999) ENDIF IF (PAR(101) .LT. 1.1) THEN IGBL(52) = 1 IPR(23) = 1 IPR(34) = 1 IPR(35) = 2 IPR(36) = 3 ELSE CALL SGSM (ICL, 0, XJX, LU7, 18, IERR) SPGRNM(1) = ICL(1:26) SPGRNM(4) = ICL(15:26) IF (IGBL(8) .EQ. 3 .AND. IPR(522) .EQ. 0) THEN IF (SPGRNM(1)(1:1) .EQ. ' ') 1 WRITE (LU20, 99998) '_123', 1, 1 ENDIF KRSYST = ICL(27:38) LAUEGR = ICL(39:43) IF (ICL(72:72) .EQ. 'C') CHSG = 'Chiral' CALL GEN020 (-1, SPGRNM(1), 16, 26) IPR(202) = NINT(XJX(1)) IPR(241) = NINT(XJX(7)) IPR(242) = NINT(XJX(8)) IPR(255) = NINT(XJX(4)) IPR(256) = NINT(XJX(6)) IPR(257) = NINT(XJX(5)) IPR(258) = NINT(XJX(3)) IPR(259) = NINT(XJX(2)) IF (ICL(12:12) .EQ. 'h') THEN PAR(261) = 120.0 ELSE PAR(261) = 90.0 ENDIF ENDIF IF (PAR(104) .EQ. 0.0) PAR(104) = 90.0 IF (PAR(105) .EQ. 0.0) PAR(105) = 90.0 IF (PAR(106) .EQ. 0.0) PAR(106) = PAR(261) PAR(13) = 0 PAR(14) = 0 IF (INDEX (KRSYST, 'Trigonal') .NE. 0) THEN IF (ABS(PAR(106) - PAR(105)) .LT. 0.5) THEN KRSYST = 'Rhombohedral' ENDIF ENDIF IF (IGBL(94) .EQ. 0 .AND. IPR(522) .EQ. 0) THEN IF (PAR(107) / PAR(101) .LT. 0.00001) WRITE (LU20, 99998) 1 '_141', 1, NINT(PAR(107) * 100000) IF (INDEX (KRSYST, 'Triclinic') .NE. 0) THEN IF (PAR(108) / PAR(102) .LT. 0.00001) 1 WRITE (LU20, 99998) '_142', 1, NINT(PAR(108) * 100000) IF (PAR(109) / PAR(103) .LT. 0.00001) 1 WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000) IF (PAR(110) .LT. 0.0005) 1 WRITE (LU20, 99998) '_144', 1, NINT(PAR(110) * 10000) IF (PAR(111) .LT. 0.0005) 1 WRITE (LU20, 99998) '_145', 1, NINT(PAR(111) * 10000) IF (PAR(112) .LT. 0.0005) 1 WRITE (LU20, 99998) '_146', 1, NINT(PAR(112) * 10000) IF (PAR(101) .GT. PAR(102) .OR. PAR(102) .GT. PAR(103)) 1 WRITE (LU20, 99998) '_156', 1, 1 ELSE IF (INDEX (KRSYST, 'Monoclinic') .NE. 0) THEN N90 = 0 IF (PAR(104) .NE. 90.0) N90 = N90 + 1 IF (PAR(105) .NE. 90.0) N90 = N90 + 1 IF (PAR(106) .NE. 90.0) N90 = N90 + 1 IF (N90 .GT. 1) WRITE (LU20, 99998) '_138', 1, 1 IF (ZSPG(2:4) .EQ. '112') THEN MSET = 3 ELSE MSET = 2 ENDIF IF (PAR(108) /PAR(102) .LT. 0.00001) 1 WRITE (LU20, 99998) '_142', 1, NINT(PAR(108) * 100000) IF (PAR(109) /PAR(103) .LT. 0.00001) 1 WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000) IF (MSET .EQ. 2) THEN IF (PAR(111) .LT. 0.0005) 1 WRITE (LU20, 99998) '_145', 1, NINT(PAR(111) * 10000) ELSE IF (MSET .EQ. 3) THEN IF (PAR(112) .LT. 0.0005) 1 WRITE (LU20, 99998) '_146', 1, NINT(PAR(111) * 10000) ENDIF IF (PAR(105) .LT. 90.0) 1 WRITE (LU20, 99997) '_157', 1.0, PAR(105) IF (PAR(104) .EQ. 90.0 .AND. PAR(105) .NE. 90.0 .AND. 1 PAR(106) .EQ. 90.0) THEN IF (PAR(110) .NE. 0.0 .OR. PAR(112) .NE. 0.0) 1 WRITE (LU20, 99998) '_147', 1, 1 ENDIF ELSE IF (INDEX (KRSYST, 'Orthorhombic') .NE. 0) THEN IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0 .OR. 1 PAR(106) .NE. 90.0) WRITE (LU20, 99998) '_137', 1, 1 IF (PAR(108) / PAR(102) .LT. 0.00001) 1 WRITE (LU20, 99998) '_142', 1, NINT(PAR(108) * 100000) IF (PAR(109) / PAR(103) .LT. 0.00001) 1 WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000) IF (PAR(110) .NE. 0.0 .OR. PAR(111) .NE. 0.0 .OR. 1 PAR(112) .NE. 0.0) WRITE (LU20, 99998) '_147', 1, 1 ELSE IF (INDEX (KRSYST, 'Tetragonal') .NE. 0) THEN IF (PAR(101) .NE. PAR(102)) 1 WRITE (LU20, 99998) '_135', 1, 1 IF (PAR(109) / PAR(103) .LT. 0.00001) 1 WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000) IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0 .OR. 1 PAR(106) .NE. 90.0) WRITE (LU20, 99998) '_136', 1, 1 IF (PAR(110) .NE. 0.0 .OR. PAR(111) .NE. 0.0 .OR. 1 PAR(112) .NE. 0.0) WRITE (LU20, 99998) '_147', 1, 1 ELSE IF (INDEX (KRSYST, 'Rhombohedral') .NE. 0) THEN IF (PAR(101) .NE. PAR(102) .OR. PAR(101) .NE. PAR(103)) 1 WRITE (LU20, 99998) '_139', 1, 1 IF (PAR(104) .NE. PAR(105) .OR. PAR(104) .NE. PAR(106)) 1 WRITE (LU20, 99998) '_140', 1, 1 IF (PAR(110) .LT. 0.0005) 1 WRITE (LU20, 99998) '_144', 1, NINT(PAR(110) * 10000) ELSE IF (INDEX (KRSYST, 'Trigonal') .NE. 0 .OR. 1 INDEX (KRSYST, 'Hexagonal') .NE. 0) THEN IF (PAR(101) .NE. PAR(102)) 1 WRITE (LU20, 99998) '_132', 1, 1 IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0) 1 WRITE (LU20, 99998) '_133', 1, 1 IF (PAR(106) .NE. 120.0) 1 WRITE (LU20, 99998) '_134', 1, 1 IF (PAR(109) / PAR(103) .LT. 0.00001) 1 WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000) ELSE IF (INDEX (KRSYST, 'Cubic') .NE. 0) THEN IF (PAR(101) .NE. PAR(102) .OR. PAR(101) .NE. PAR(103)) 1 WRITE (LU20, 99998) '_130', 1, 1 IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0 .OR. 1 PAR(106) .NE. 90.0) WRITE (LU20, 99998) '_131', 1, 1 IF (PAR(110) .NE. 0.0 .OR. PAR(111) .NE. 0.0 .OR. 1 PAR(112) .NE. 0.0) WRITE (LU20, 99998) '_147', 1, 1 ENDIF ENDIF CALL GEN026 (1, RAA, PAR(101), GL(5)) CALL GEN026 (-1, RAA, PAR(241), GL(5)) CALL GEN003 (RAA, RBB, DET, 0) IF (DET .LT. 0.0) STOP 'CANNOT INVERT METRICAL MATRIX' CALL GEN026 (-1, RBB, PAR(135), GL(5)) CALL GEN025 (RBB, PAR(391), 1) CALL GEN001 (1, TM1, RAA, AA) CALL GEN003 (AA, BB, DET, 0) IF (DET .LT. 0.0) STOP 'CANNOT INVERT METRICAL MATRIX' PAR(98) = SQRT(DET) DO 10 I = 1, 3 PAR(128 + I) = AA(I, I) PAR(112 + I) = SQRT(BB(I, I)) PAR(190 + I) = BB(I, I) 10 CONTINUE PAR(194) = BB(2, 3) PAR(195) = BB(1, 3) PAR(196) = BB(1, 2) PAR(132) = AA(1, 2) * 2.0 PAR(133) = AA(1, 3) * 2.0 PAR(134) = AA(2, 3) * 2.0 CALL GEN026 (-1, AA, PAR(101), GL(5)) CALL GEN067 (TM1, PAR(241), PAR(101), PAR(107), PAR(107)) CALL GEN066 (1, PAR(101), PAR(107), SPGRNM(1)(12:12)) DO 50 I = 1, 3 CALL GEN041 (PAR(100 + I), PAR(106 + I), IPR(280 + I), 5, 1 IPR(286 + I), IPR(68)) CALL GEN041 (PAR(103 + I), PAR(109 + I), IPR(283 + I), 4, 1 IPR(289 + I), IPR(68)) 50 CONTINUE DO 60 I = 1, 3 R = PAR(106 + I) / PAR(100 + I) IF (R .GT. PAR(13)) PAR(13) = R IF (PAR(109 + I) .GT. PAR(14)) PAR(14) = PAR(109 + I) 60 CONTINUE DO 70 I = 1, 3 V4(I) = COS(PAR(103 + I) / GL(5)) IF (ABS(V4(I)) .LT. 1E-6) V4(I) = 0.0 V3(I) = SIN(PAR(103 + I) / GL(5)) 70 CONTINUE CALL GEN068 (PAR(101), PAR(98), PAR(107), PAR(21)) CALL GEN041 (PAR(98), PAR(21), IPR(293), 2, IPR(294), IPR(68)) XDUM = 100.0 * ABS (PAR(164) - PAR(98)) / PAR(98) IF (IPR(522) .EQ. 0) THEN IF (XDUM .GT. 0.01 .AND. IGBL(94) .EQ. 0) 1 WRITE (LU20, 99997) '_150', XDUM, PAR(164) IF (PAR(327) .GT. 0.0 .AND. PAR(21) .GT. 0.0) THEN IF (PAR(21) / PAR(327) .GT. 1.1 .OR. 1 PAR(327) / PAR(21) .GT. 1.1) THEN WRITE (LU20, 99998) '_152', 1, 1 ENDIF ENDIF ENDIF PAR(116) = (V4(2) * V4(3) - V4(1)) / (V3(2) * V3(3)) PAR(117) = (V4(1) * V4(3) - V4(2)) / (V3(1) * V3(3)) PAR(118) = (V4(1) * V4(2) - V4(3)) / (V3(1) * V3(2)) DO 100 K = 16, 18 PAR(103 + K) = SQRT(1.0 - PAR(100 + K)**2) 100 CONTINUE CALL GEN044 (PAR(101), OR) CALL GEN003 (OR, ROR, DET, 0) IF (DET .LT. 0.0) STOP 'CANNOT INVERT OR MATRIX' DO 110 I = 1, 3 KAX(I) = NINT(PAR(100 + I) * 10.0) * 10 + I 110 CONTINUE CALL GEN022 (KAX, 1, 3) DO 120 I = 1, 3 K = KAX(4 - I) / 10 IPR(33 + I) = KAX(4 - I) - K * 10 120 CONTINUE IPR(185) = IPR(36) IPR(186) = IPR(35) IPR(187) = IPR(34) CALL GEN108 (LU4, 0) IF (IPR(23) .EQ. 0) THEN NEWLAT(1) = 0 CALL PLA087 (1) ENDIF IPR(522) = 1 ENDIF 99999 FORMAT (':: Maximum number of allowed residues reduced:', 1 ' Round ARU to 0.1 units!', /) 99998 FORMAT (A, 2I10) 99997 FORMAT (A, 2F10.2) RETURN END SUBROUTINE PLA081 (LOC, XM1, XM2, XM3) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 DIMENSION XJX(12) CHARACTER ICLX*1 IPR(2) = 0 ISW = 9 M1 = NINT(XM1 * PAR(42)) CALL GEN098 (M1, PAR(42), MS1, MT11, MT12, MT13, MR3) XJX(1) = MS1 XJX(2) = MT11 XJX(3) = MT12 XJX(4) = MT13 M2 = NINT(XM2 * PAR(42)) IF (M2 .NE. 0) THEN ISW = 8 CALL GEN098 (M2, PAR(42), MS2, MT21, MT22, MT23, MR3) XJX(5) = MS2 XJX(6) = MT21 XJX(7) = MT22 XJX(8) = MT23 ENDIF CALL SGSM (ICLX, 0, XJX, LU6, ISW, IERR) DO 10 I = 10, 12 IF (ABS(XJX(I)) .GT. 4.1) THEN WRITE (LU6, 99999) LOC, XM1, XM2, (XJX(I), J = 10, 12) IF (IGBL(63) .GT. 0) 1 WRITE (LU7, 99999) LOC, XM1, XM2, (XJX(I), J = 10, 12) WRITE (LU20, 99998) '_804', 1, 1 IPR(150) = 1 IPR(210) = 0 GOTO 20 ENDIF 10 CONTINUE XM3 = (((XJX(9) * 10 + XJX(10)) * 10 + XJX(11)) * 10 + XJX(12)) XM3 = NINT(XM3) + 555 + FLOAT(MR3) / PAR(42) 20 RETURN 99999 FORMAT (':: ARU-Pack Problem at Loc:', I2, 5F10.2, /, 1 ':: IPR(210) Reset to ZERO i.e. no SQUEEZE etc.') 99998 FORMAT (A, 2I10) END SUBROUTINE PLA082 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 DIMENSION DHX(3, 37), DUMVA(3, 3), DUMVB(3, 3), EWA(3), EWB(3), 1 V2A(3), V2B(3), IANG(3, 3) COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 IF (IPR(23) .EQ. 1) GOTO 230 NX = 0 NVEC = 0 NMAX = IPR(39) NRES = IPR(75) PAGET = 'NONSYM' CALL GEN101 (2, NVEC, DHX) DO 30 I = 1, NRES CALL PLA083 (I, DUMVA, EWA, V2A, WHTA, NATA, NATTA, IDETA) IF (NATA .GT. 0) THEN NX = NX + 1 IF (NX .EQ. 1) THEN IF (IGBL(63) .GT. 0) THEN CALL PLA269 (0) WRITE (LU7, 99999) WRITE (LU7, 99991) ENDIF ENDIF DO 20 J = 1, 3 DO 10 K = 1, 3 ANG = 0.0 DO 1 L = 1, 3 ANG = ANG + DUMVA(L, J) * OR(L, K) / PAR(100 + K) 1 CONTINUE IF (ANG .GT. 1.0) ANG = 1.0 IF (ANG .LT. -1.0) ANG = -1.0 IANG(J, K) = NINT(ACOS(ANG) * GL(5)) 10 CONTINUE 20 CONTINUE II = I * IDETA IF (IGBL(63) .GT. 0) THEN WRITE (LU7, 99987) II, (XXO(NMAX + I, K), K = 1, 3), 1 (DUMVA(I0, 1), I0 = 1, 3), NINT(EWA(1)), ABS(V2A(1)), 2 (IANG(1, I0), I0 = 1, 3) WRITE (LU7, 99986) (XXO(NMAX + I, K), K = 4, 6), 1 (DUMVA(I0, 2), I0 = 1, 3), NINT(EWA(2)), ABS(V2A(2)), 2 (IANG(2, I0), I0 = 1, 3) WRITE (LU7, 99985) WHTA, (DUMVA(I0, 3), I0 = 1, 3), 1 NINT(EWA(3)), ABS(V2A(3)), (IANG(3, I0), I0 = 1, 3) ENDIF ENDIF 30 CONTINUE IF (NX .GT. 1) THEN DO 50 I = 1, NMAX CALL GEN048 (-6, IFG(I), 9, IRES) DIST = 0.0 DO 40 J = 4, 6 DIST = DIST + (XXO(NMAX + IRES, J) - XXO(I, J))**2 40 CONTINUE IATC(I) = I DATC(I) = SQRT(DIST) 50 CONTINUE CALL GEN013 (DATC, IATC, 1, NMAX) IF (NRES .GT. 1) THEN DO 220 IRES = 1, NRES - 1 CALL PLA083 (IRES, DUMVA, EWA, V2A, WHTA, NATA, NATTA, 1 IDETA) IF (NATA .EQ. 0) GOTO 220 II = IRES * IDETA DO 210 JRES = IRES + 1, NRES CALL PLA083 (JRES, DUMVB, EWB, V2B, WHTB, NATB, NATTB, 1 IDETB) IF (NATB .EQ. 0) GOTO 210 JJ = JRES * IDETB IF (ABS (WHTB - WHTA) .LT. 0.1 .AND. 1 NATTA .EQ. NATTB) THEN IDETR = IDETA * IDETB CALL GEN005 (DUMVA, QM) CALL GEN004 (DUMVB, QM, UIJ) UIJSUM = (UIJ(1, 1) + UIJ(2, 2) + UIJ(3, 3)) * IDETR DO 60 K = 4, 6 V2(K - 3) = (XXO(NMAX + JRES, K) 1 + XXO(NMAX + IRES, K)) / 2.0 V3(K - 3) = XXO(NMAX + JRES, K) 1 - XXO(NMAX + IRES, K) 60 CONTINUE IF (UIJSUM .LT. 2.999) THEN CALL GEN074 (V1, 0.0, 1, 3) DO 90 I1 = 1, 3 J1 = MOD(I1, 3) + 1 DO 80 K1 = 1, 3 V4(K1) = UIJ(K1, I1) * IDETR V5(K1) = UIJ(K1, J1) * IDETR 80 CONTINUE V4(I1) = V4(I1) - 1 V5(J1) = V5(J1) - 1 CALL GEN008 (V4, V5, V6, 1) IF (GEN009 (V1, V6) .GE. 0.0) THEN CALL GEN015 (V1, V6, V1) ELSE CALL GEN016 (V1, V6, V1) ENDIF 90 CONTINUE XX = GEN017 (V1) ANGMAX = 99999.0 DO 100 I = 1, 37 CALL GEN002 (-2, ROR, DHX(1, I), V8, XLNG) CALL GEN008 (V8, V1, V5, -1) IF (V5(1) .LT. ANGMAX) THEN ANGMAX = V5(1) V6(1) = DHX(1, I) V6(2) = DHX(2, I) V6(3) = DHX(3, I) ENDIF 100 CONTINUE ANGMAX = ABS(ASIN(SQRT(ANGMAX)) * GL(5)) ANGMAX = MIN (ANGMAX, 180 - ANGMAX) WRITE (LU6, 99989) (V6(I), I = 1, 3), ANGMAX IF (IGBL(63) .GT. 0) THEN CALL PLA269 (0) CALL PLA269 (3) WRITE (LU7, 99989) (V6(I), I = 1, 3), ANGMAX ENDIF DO 110 I1 = 1, 3 PAT(I1, 3) = V1(I1) 110 CONTINUE XX = SQRT(V1(1)**2 + V1(2)**2) IF (XX .GT. 0.0001) THEN PAT(1, 1) = V1(2) / XX PAT(2, 1) = - V1(1) / XX PAT(3, 1) = 0.0 ELSE PAT(1, 1) = 0.0 PAT(2, 1) = 1.0 PAT(3, 1) = 0.0 ENDIF CALL GEN008 (PAT(1, 3), PAT(1, 1), PAT(1, 2), 1) CALL GEN005 (PAT, PAT) CALL GEN004 (PAT, UIJ, UIJC) CALL GEN005 (PAT, PAT) CALL GEN004 (UIJC, PAT, UIJC) V1(4) = (ATAN2((UIJC(2, 1) - UIJC(1, 2)) * IDETR, 1 (UIJC(1, 1) + UIJC(2, 2)) * IDETR)) * GL(5) CALL GEN002 (1, ROR, V1, V4, DUM) V4MX = MAX (ABS(V4(1)), ABS(V4(2)), ABS(V4(3))) DO 120 K = 1, 3 V4(K) = V4(K) / V4MX 120 CONTINUE IF (IDETR .GT. 0) THEN GLIDEA = GEN009 (V1, V3) WRITE (LU6, 99996) II, JJ, 1 (V4(I2), I2 = 1, 3), V1(4), GLIDEA IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99990) WRITE (LU7, 99996) II, JJ, 1 (V4(I2), I2 = 1, 3), V1(4), GLIDEA ENDIF ELSE WRITE (LU6, 99994) II, JJ, 1 (V4(I2), I2 = 1, 3), V1(4) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99990) WRITE (LU7, 99994) II, JJ, 1 (V4(I2), I2 = 1, 3), V1(4) ENDIF CALL GEN008 (V1, V3, V8, 1) CALL GEN008 (V8, V1, V5, 1) GLIDEB = GEN009 (V5, V3) CALL GEN002 (1, ROR, V5, V6, DUM) V6MX = MAX (ABS(V6(1)), ABS(V6(2)), ABS(V6(3))) DO 130 K = 1, 3 V6(K) = V6(K) / V6MX 130 CONTINUE WRITE (LU6, 99995) II, JJ, 1 (V6(I2), I2 = 1, 3), GLIDEB IF (IGBL(63) .GT. 0) THEN CALL PLA269 (1) WRITE (LU7, 99995) II, JJ, (V6(I2), I2 = 1, 3), 1 GLIDEB ENDIF ENDIF ELSE IF (IDETR .LT. 0) THEN CALL GEN002 (1, ROR, V2, V8, DUM) WRITE (LU6, 99998) II, JJ, (V8(K), K = 1, 3) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99990) WRITE (LU7, 99998) II, JJ, (V8(K), K = 1, 3) ENDIF ELSE CALL GEN002 (1, ROR, V3, V8, DUM) V8MX = MAX (ABS(V8(1)), ABS(V8(2)), ABS(V8(3))) DO 140 K = 1, 3 V8(K) = V8(K) / V8MX 140 CONTINUE WRITE (LU6, 99997) II , JJ, (V8(K), K = 1, 3) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99990) WRITE (LU7, 99997) II , JJ, (V8(K), K = 1, 3) ENDIF ENDIF ENDIF VARDIST = 0.0 NVAR = 0 IPR(12) = 0 DO 150 L = 1, NMAX IATC(L) = IABS(IATC(L)) 150 CONTINUE DO 200 L0 = 1, NMAX L = IATC(L0) IF (L .GT. 0) THEN CALL GEN048 (-6, IFG(L), 9, IRESL) IF (IRESL .EQ. IRES) THEN CALL GEN048 (-1, IFG(L), 7, IVL) IF (IVL .EQ. 0) THEN DO 160 I = 1, 3 V6(I) = XXO(L, I + 3) 1 - XXO(NMAX + IRES, I + 3) 160 CONTINUE CALL GEN002 (1, UIJ, V6, V8, DUM) DO 170 I = 1, 3 V8(I) = V8(I) + XXO(NMAX + IRES, I + 3) 170 CONTINUE CALL GEN015 (V8, V3, V8) DISTMN = 99999.0 MDIST = 0 CALL PLA047 (XLAB(L), NQ1, IDUM, IENR1, 0, 1 IGBL(55), 0, 0) CALL GEN048 (-10, JFG(L), 14, LBN1) DO 190 M0 = 1, NMAX M = IATC(M0) IF (M .GT. 0) THEN CALL GEN048 (-6, IFG(M), 9, IRESM) IF (IRESM .EQ. JRES) THEN CALL PLA047 (XLAB(M), NQ2, IDUM, IENR2, 0, 1 IGBL(55), 0, 0) IF (IENR1 .EQ. IENR2) THEN CALL GEN048 (-1, IFG(M), 7, IVL) IF (IVL .EQ. 0) THEN CALL GEN048 (-10, JFG(M), 14, LBN2) IF (LBN2 .EQ. LBN1) THEN DO 180 I = 1, 3 V6(I) = XXO(M, I + 3) 180 CONTINUE CALL GEN016 (V8, V6, V5) DIST = SQRT(GEN009 (V5, V5)) IF (DIST .LT. DISTMN) THEN DISTMN = DIST MDIST = M0 ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF 190 CONTINUE M0 = MDIST IF (M0 .EQ. 0) GOTO 200 MDIST = IATC(M0) JCA(L) = MDIST IATC(M0) = - IATC(M0) JR(IPR(12) + 1) = L JR(IPR(12) + 2) = MDIST IPR(12) = IPR(12) + 2 VARDIST = VARDIST + DISTMN**2 NVAR = NVAR + 1 IF (IGBL(63) .GT. 0) THEN CALL PLA047 (XLAB(MDIST), NQ2, IDUM, IENR2, 0, 1 IGBL(55), 0, 0) IF (NVAR .EQ. 1) THEN CALL PLA269 (5) WRITE (LU7, 99992) ENDIF CALL PLA269 (1) WRITE (LU7, 99993) 1 NQ1, (V8(J), J = 1, 3), DATC(L0), 2 NQ2, (XXO(MDIST, J + 3), J = 1, 3), 3 DATC(M0), DISTMN, LBN1 ENDIF ENDIF ENDIF ENDIF 200 CONTINUE IF (NVAR .NE. 0) THEN VARDIST = SQRT(VARDIST / NVAR) WRITE (LU6, 99988) VARDIST IF (IGBL(63) .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99988) VARDIST ENDIF ELSE VARDIST = 999.0 ENDIF C * QUATERNION-FIT IF (IGBL(63) .GT. 0 .AND. NVAR .GT. 5) THEN CALL PLA085 (0, VARDIST) WRITE (LU6, 99977) CALL PLA269 (3) WRITE (LU7, 99977) IF (VARDIST .LT. 0.5) CALL PLA084 (IRES, JRES) ENDIF ENDIF 210 CONTINUE 220 CONTINUE ENDIF ENDIF 230 RETURN 99999 FORMAT ('NONSYM Search for Additional (Non)Crystallographic', 1 ' Symmetry between Residues (Experimental)', /, 132('='), //, 2 '- Residue numbers with opposite signs indicate ', 3 'potential enantiomeric pairs', /, 4 '- Hydrogen atoms omitted from the analysis', /, 5 '- Residues with more than 6 atoms are analysed only', /) 99998 FORMAT (':: Inversion at :', 2I5, ' ', 3F7.3) 99997 FORMAT (':: Translation :', 2I5, ' ', 3F7.3) 99996 FORMAT (':: Rotation :', 2I5, ' [', 3F7.3, ']', F8.2, F8.3) 99995 FORMAT (':: GlidePlane :', 2I5, ' [', 3F7.3, ']', 8X, F8.3) 99994 FORMAT (':: Rota-Inversion:', 2I5, ' [', 3F7.3, ']', F8.2) 99993 FORMAT (A, 3F7.3, F6.2, 2X, A, 3F7.3, F6.2, F10.3, I5) 99992 FORMAT (/, 'Comparison of Orthogonal Coordinates of Transformed', 1 ' Residue #I with those of Residue #J', /, 132('='), /, 2 'Atom I', 6X, 'XI', 5X, 'YI', 5X, 'ZI', 4X, 'RI', 2X, 3 'Atom J', 6X, 'XJ', 5X, 'YJ', 5X, 'ZJ', 4X, 'RJ', 1X, 4 'Dist(Ang) Tnr', /, 85('-')) 99991 FORMAT (/, 'RES#', ' Coords Center of Gravity', 8X, 1 'Main axes (hor)', 3X, 'EigenV', 3X, 'Asym', 2 ' Angle a,b,c', /, 80('-')) 99990 FORMAT (/, 3X, 'Symm Op', 8X, 'Res#i Res#j', 6X, 'DirLatt Vector', 1 3X, 'Angle(Deg)', 1X, 'Shift(Ang)', /, 80('=')) 99989 FORMAT (/, ':: Smallest angle of [RotAx] with Plane normal (', 1 3F4.0, ') = ', F6.3, ' Deg.', /) 99988 FORMAT (/, ':: RMS-Fit = ', F10.3, ' Ang.', 1 ' (Note: Use Quaternion FIT for an accurate fit)') 99987 FORMAT (I3, F8.4, 2F9.4, 2X, 3F7.3, I8, F8.2, 3I4) 99986 FORMAT (3X, F8.4, 2F9.4, 2X, 3F7.3, I8, F8.2, 3I4) 99985 FORMAT (7X, 'Res.Mol.Wt. =', F9.2, 2X, 3F7.3, I8, F8.2, 3I4, /) 99977 FORMAT (/, ':: Warning: The Pairwise Atom Association', 1 ' is Tentative and may be Erroneous', /) END SUBROUTINE PLA083 (NR, DUMVX, EWX, V2X, WHTX, NATX, NATT, IDETX) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION DUMW(3, 3), EV(3, 3), EWX(3), DUMVX(3, 3), V2X(3) NMAX = IPR(39) CALL GEN074 (V1, 0.0, 1, 3) CALL GEN074 (DXI, 0.0, 1, 3) KP = 0 KPT = 0 WM = 0 DO 30 N = 1, NMAX CALL GEN048 (-6, IFG(N), 9, IRESN) IF (IRESN .EQ. NR) THEN CALL GEN048 (-7, JFG(N), 1, IPP) IF (IPPR(IPP + 1, 1) .LT. 1000) THEN KP = 0 GOTO 130 ENDIF KPT = KPT + 1 CALL GEN048 (-1, IFG(N), 7, IVL) IF (IVL .EQ. 0) THEN CALL GEN048 (-4, IFG(N), 15, IVL) WHT = SATWT(IVL + 1) KP = KP + 1 WM = WM + WHT DO 20 J = 1, 3 V1 (J) = V1 (J) + WHT * XXO(N, J) DXI(J) = DXI(J) + WHT * XXO(N, J + 3) 20 CONTINUE ENDIF ENDIF 30 CONTINUE IF (KP .LE. 6 .OR. WM .EQ. 0.0) THEN KP = 0 GOTO 130 ENDIF WHTX = WM DO 50 I = 1, 3 V1 (I) = V1 (I) / WM DXI(I) = DXI(I) / WM XXO(NMAX + NR, I) = V1 (I) XXO(NMAX + NR, I + 3) = DXI(I) DO 40 J = 1, 3 DUMW(I, J) = 0.0 40 CONTINUE 50 CONTINUE DO 60 N = 1, NMAX CALL GEN048 (-6, IFG(N), 9, IRESN) IF (IRESN .EQ. NR) THEN CALL GEN048 (-1, IFG(N), 7, IVL) IF (IVL .EQ. 0) THEN CALL GEN048 (-4, IFG(N), 15, IVL) WHT = SATWT(IVL + 1) XX = XXO(N, 4) - DXI(1) YY = XXO(N, 5) - DXI(2) ZZ = XXO(N, 6) - DXI(3) XSQ = XX**2 YSQ = YY**2 ZSQ = ZZ**2 DUMW(1, 1) = DUMW(1, 1) + WHT * (YSQ + ZSQ) DUMW(1, 2) = DUMW(1, 2) - WHT * XX * YY DUMW(1, 3) = DUMW(1, 3) - WHT * XX * ZZ DUMW(2, 2) = DUMW(2, 2) + WHT * (ZSQ + XSQ) DUMW(2, 3) = DUMW(2, 3) - WHT * YY * ZZ DUMW(3, 3) = DUMW(3, 3) + WHT * (XSQ + YSQ) ENDIF ENDIF 60 CONTINUE CALL GEN024 (DUMW, EV, EWX, DUMVX) CALL GEN074 (V2X, 0.0, 1, 3) DO 100 N = 1, NMAX CALL GEN048 (-6, IFG(N), 9, IRESN) IF (IRESN .EQ. NR) THEN CALL GEN048 (-1, IFG(N), 7, IVL) IF (IVL .EQ. 0) THEN CALL GEN048 (-4, IFG(N), 15, IVL) WHT = SATWT(IVL + 1) DO 70 I = 1, 3 V3(I) = XXO(N, I + 3) - DXI(I) 70 CONTINUE DO 90 J = 1, 3 DO 80 I = 1, 3 V2X(J) = V2X(J) + (WHT * DUMVX(I, J) * V3(I))**3 80 CONTINUE 90 CONTINUE ENDIF ENDIF 100 CONTINUE DO 120 J = 1, 3 IF (V2X(J) .LT. 0.0) THEN DO 110 I = 1, 3 DUMVX(I, J) = - DUMVX(I, J) 110 CONTINUE V2X(J) = - ABS(V2X(J)) ** (1.0 / 3.0) ELSE V2X(J) = V2X(J) ** (1.0 / 3.0) ENDIF 120 CONTINUE CALL GEN010 (DUMVX, IDETX, 0) 130 NATX = KP NATT = KPT RETURN END SUBROUTINE PLA084 (IRES, JRES) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER FORMA*74, FORMB*66 FORMB(1 :37) = '(A,''-'',A,5X,A,''-'',A,F10.4,''('',I3,'')'',' FORMB(38:66) = 'F10.4,''('',I3,'')'',F10.4,F10.4)' FORMA(1:32) = '(A,''-'',A,''-'',A,3X,A,''-'',A,''-'',A,' FORMA(33:64) = 'F8.2,''('',I3,'')'',F8.2,''('',I3,'')'',' FORMA(65:74) = 'F8.2,F8.2)' D1 = 0.0 D2 = 0.0 A1 = 0.0 SA1 = 0.0 SD1 = 0.0 SD2 = 0.0 ND1 = 0 ND2 = 0 ISD1 = 0 ISD2 = 0 ISA1 = 0 CALL PLA269 (0) CALL PLA269 (5) WRITE (LU7, 99999) IRES, JRES IPR(133) = 0 VDIF = 0.0 NV = 0 IFIN = -1 10 CALL PLA038 (I, J, IFIN) IF (IFIN .NE. 1) THEN CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .EQ. IRES) THEN CALL PLA053 (I, J, 0, 0, D1, SD1, ISD1, ND1, IER) IF (IER .EQ. 0) THEN IAT = JCA(I) JAT = JCA(J) CALL PLA053 (IAT, JAT, 0, 0, D2, SD2, ISD2, ND2, IER) IF (IER .EQ. 0) THEN CALL PLA047 (XLAB(I), NQ3, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) CALL PLA047 (XLAB(J), NQ4, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) CALL PLA047 (XLAB(JAT), NQ2, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) DIF = D1 - D2 DS = SQRT (SD1**2 + SD2**2) IF (DS .NE. 0) DS = DIF / DS VDIF = VDIF + DIF**2 NV = NV + 1 FORMB(25:25) = CHAR(ICHAR('0') + ND1) FORMB(42:42) = CHAR(ICHAR('0') + ND2) WRITE (PRBUF, FORMB) 1 NQ3, NQ4, NQ1, NQ2, D1, ISD1, D2, ISD2, DIF, DS CALL PLA067 (LU7, PRBUF, 132, 1, 3) DATC(NV) = ABS(DS) ENDIF ENDIF ENDIF GOTO 10 ENDIF VDIF = SQRT (VDIF / NV) CALL PLA269 (2) WRITE (LU7, 99997) VDIF IF (NV .GT. 5) THEN CALL PLA269 (0) CALL PLA282 (1, DATC(1), DATC(NV + 1), NV, LU7) ENDIF CALL PLA269 (0) CALL PLA269 (5) WRITE (LU7, 99996) IRES, JRES IPR(133) = 0 VDIS = 0.0 NV = 0 KB = 0 IFIN = -1 20 CALL PLA039 (I, J, K, IRES, A, SA, ISA, NDEC, KB, IFIN) IF (IFIN .NE. 1) THEN IAT = JCA(I) JAT = JCA(J) KAT = JCA(K) IF (IAT .NE. 0 .AND. JAT .NE. 0 .AND. KAT .NE. 0) THEN CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) CALL PLA047 (XLAB(JAT), NQ2, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) CALL PLA047 (XLAB(KAT), NQ3, IDUM, JDUM, 1 IPR(119), IGBL(55), 0, 0) CALL PLA053 (IAT, JAT, KAT, 0, A1, SA1, ISA1, ND1, IER) IF (IER .EQ. 0) THEN DIF = A - A1 DS = SQRT (SA**2 + SA1**2) IF (DS .NE. 0) DS = DIF / DS VDIS = VDIS + DIF**2 NV = NV + 1 FORMA(36:36) = CHAR(ICHAR('0') + NDEC) FORMA(52:52) = CHAR(ICHAR('0') + ND1) WRITE (PRBUF, FORMA) (NAMS(1, M)(2:8), M = 1, 3), 1 NQ1, NQ2, NQ3, A, ISA, A1, ISA1, DIF, DS CALL PLA067 (LU7, PRBUF, 132, 1, 3) DATC(NV) = ABS(DS) ENDIF ENDIF GOTO 20 ENDIF VDIS = SQRT (VDIS / NV) CALL PLA269 (2) WRITE (LU7, 99994) VDIS IF (NV .GT. 5) THEN CALL PLA269 (0) CALL PLA282 (1, DATC(1), DATC(NV + 1), NV, LU7) ENDIF RETURN 99999 FORMAT ('Comparison of the Bonds of the Fitted Residues', /, 1 46('='), //, 'Resd#',I1, 14X, 'Resd#', I1, 18X, 'Dist#1', 2 9X, 'Dist#2', 6X, 'Diff', 2X, 'Diff/Sig', /, 85('=')) 99997 FORMAT (/, ':: RMS Bond Fit = ', F10.4, ' Ang.') 99996 FORMAT ('Comparison of the Bond Angles of the Fitted Residues', /, 1 52('='), //, 'Resd#', I1, 20X, 'Resd#', I1, 25X, 2 'Ang#1', 8X, 'Ang#2', 4X, 'Diff', 1X, 'Diff/Sig', /, 3 91('=')) 99994 FORMAT (/, ':: RMS Angle Fit = ', F10.3, ' Deg.') END SUBROUTINE PLA085 (LU, VARDIST) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 DIMENSION DUMW(3), V(3) COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER INVRT*8, INCF*1 COMMON /PATHS/ PLAPATH, BROWSER, CGETENV CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255 EXTERNAL SYSTEM ISN = 0 NATC = IPR(12) / 2 NAT1 = IPR(12) - 1 NAT2 = IPR(12) CALL GEN048 (-6, IFG(JR(1)), 9, NRES1) CALL GEN048 (-6, IFG(JR(2)), 9, NRES2) IF (LU .EQ. 1) WRITE (LU6, 99999) CALL PLA269 (-3) WRITE (LU7, 99999) IF (LU .NE. 0) OPEN (UNIT = LU60, 1 FILE = NAME(1)(1:KNM(1))//'_fit.spf', STATUS = 'UNKNOWN') CALL GEN074 (DUMA, 0.0, 1, 6) DO 30 I = 1, IPR(39) DO 20 J = 1, IPR(12) IF (JR(J) .EQ. I) THEN K = MOD(J + 1, 2) * 3 DO 10 N = 1, 3 DUMA(N + K) = DUMA(N + K) + XXO(JR(J), 3 + N) / NATC 10 CONTINUE GOTO 30 ENDIF 20 CONTINUE CALL GEN048 (-6, IFG(I), 9, NRES) IF (NRES .EQ. NRES1) THEN NAT1 = NAT1 + 2 JR(NAT1) = I ELSE IF (NRES .EQ. NRES2) THEN NAT2 = NAT2 + 2 JR(NAT2) = I ENDIF 30 CONTINUE 40 IF (NAT2 .GT. NAT1 + 1) THEN NAT1 = NAT1 + 2 JR(NAT1) = 0 GOTO 40 ELSE IF (NAT2 .LT. NAT1 +1) THEN NAT2 = NAT2 + 2 JR(NAT2) = 0 GOTO 40 ENDIF ISN1 = 1 ISN7 = 7 IF (IPR(33) .NE. 0) THEN ISNS = 2 IF (IPR(33) .EQ. 2) THEN ISN1 = 2 ISN7 = 8 ENDIF ELSE ISNS = 1 ENDIF TH = 0.0 BEST = 99999.0 ISNB = 1 MBST = 0 DO 140 ISN0 = ISN1, ISN7, ISNS IF (ISN0 .EQ. ISN7) THEN ISN = ISNB M = MBST IF (ISN .EQ. -1) THEN IF (LU .EQ. 1) WRITE (LU6, 99994) NRES1, NRES2 CALL PLA269 (2) WRITE (LU7, 99994) NRES1, NRES2 CALL PLA269 (2) INVRT = '(INVERT)' ELSE INVRT = ' ' ENDIF IF (LU .NE. 0) 1 WRITE (LU60, 99991) JID(1:8), NRES1, INVRT, NRES2, NATC ELSE M = INT((ISN0 - 1) / 2) IF (MOD(ISN0, 2) .EQ. 0) THEN ISN = -1 ELSE ISN = 1 ENDIF ENDIF CALL GEN021 (DUMV, 0) CALL GEN074 (DUMW, 0.0, 1, 3) CALL GEN074 (V5, 0.0, 1, 3) CALL GEN074 (V6, 0.0, 1, 3) DO 60 I = 1, IPR(12), 2 DO 50 J = 1, 3 V1(J) = (XXO(JR(I), MOD(J + M, 3) + 4) 1 - DUMA(MOD(J + M, 3) + 1)) * ISN V2(J) = XXO(JR(I + 1), J + 3) - DUMA(J + 3) V3(J) = V1(J) + V2(J) V4(J) = - V1(J) + V2(J) 50 CONTINUE DUMV(1, 1) = DUMV(1, 1) + V3(2)**2 + V3(3)**2 DUMV(2, 2) = DUMV(2, 2) + V3(1)**2 + V3(3)**2 DUMV(3, 3) = DUMV(3, 3) + V3(1)**2 + V3(2)**2 DUMV(1, 2) = DUMV(1, 2) - V3(1) * V3(2) DUMV(1, 3) = DUMV(1, 3) - V3(1) * V3(3) DUMV(2, 3) = DUMV(2, 3) - V3(2) * V3(3) DUMW(1) = DUMW(1) - V3(3) * V4(2) + V3(2) * V4(3) DUMW(2) = DUMW(2) + V3(3) * V4(1) - V3(1) * V4(3) DUMW(3) = DUMW(3) - V3(2) * V4(1) + V3(1) * V4(2) 60 CONTINUE DUMV(2, 1) = DUMV(1, 2) DUMV(3, 1) = DUMV(1, 3) DUMV(3, 2) = DUMV(2, 3) CALL GEN003 (DUMV, RMAT, DET, 0) CALL GEN002 (1, RMAT, DUMW, V8, XLNG) THETA = 2 * ATAN(SQRT(GEN009(V8, V8))) IF (THETA .EQ. 0.0) THEN CALL PLA269 (5) IF (LU .EQ. 1) THEN WRITE (LU6, 99993) WRITE (LU6, 99998) TH, V5, V6 ENDIF WRITE (LU7, 99993) WRITE (LU7, 99998) TH, V5, V6 GOTO 160 ENDIF DO 70 I = 1, 3 V(I) = V8(I) / TAN(THETA / 2) 70 CONTINUE TH = THETA * GL(5) IF (ISN0 .EQ. ISN7) THEN STHH = SIN(THETA / 2.0) CTHH = COS(THETA / 2.0) V5(1) = STHH * V(1) V5(2) = STHH * V(2) V5(3) = STHH * V(3) VAL = SIN( -(M + 1) * 60.0 / GL(5)) / SQRT(3.0) CALL GEN074 (V6, VAL, 1, 3) VAL = COS(-(M + 1) * 60.0 / GL(5)) THH = CTHH * VAL - GEN009 (V5, V6) THH = MAX (-1.0, MIN (THH, 1.0)) TH = MOD (2.0 * ACOS(THH) * GL(5) + 360.0, 360.0) IF (TH .GT. 180.0) TH = TH - 360.0 CALL GEN008 (V5, V6, V1, 0) SHH = SQRT (1.0 - THH **2) IF (SHH .NE. 0.0) THEN DO 90 I = 1, 3 V1(I) = (V1(I) + V5(I) * VAL + CTHH * V6(I)) / SHH 90 CONTINUE ENDIF CALL GEN002 (1, ROR, V1, V2, DUM) V2MAX = MAX (ABS(V2(1)), ABS(V2(2)), ABS(V2(3))) IF (V2MAX .NE. 0) THEN DO 100 I = 1, 3 V2(I) = V2(I) / V2MAX 100 CONTINUE ENDIF IF (LU .EQ. 1) WRITE (LU6, 99998) TH, (V1(I), I = 1, 3), 1 (V2(I), I = 1, 3) CALL PLA269 (6) WRITE (LU7, 99998) TH, (V1(I), I = 1, 3), (V2(I), I = 1, 3) ENDIF THH = THETA / 2 F1 = COS(THH)**2 - SIN(THH)**2 F2 = SIN(THETA) F3 = 2 * SIN(THH)**2 RMSQ = 0.0 URMS = 0.0 SUMW = 0.0 RMSQ1 = 0.0 URMS1 = 0.0 SUMW1 = 0.0 NONHA = 0 DO 130 J = 1, NAT1, 2 I = JR(J) K = JR(J + 1) WGHT = 0.0 DO 110 N = 1, 3 IF (I .EQ. 0) THEN V1(N) = 0.0 ELSE MODNM = MOD(N + M, 3) V1(N) = (XXO(I, MODNM + 4) - DUMA(MODNM + 1)) * ISN ENDIF IF (K .EQ. 0) THEN V2(N) = 0.0 ELSE V2(N) = XXO(K, N + 3) - DUMA(N + 3) ENDIF WGHT = WGHT + V1(N)**2 110 CONTINUE F4 = F3 * GEN009 (V, V1) CALL GEN008 (V, V1, V4, 0) DO 120 N = 1, 3 V3(N) = F1 * V1(N) + F2 * V4(N) + F4 * V(N) 120 CONTINUE DIST = (V2(1) - V3(1))**2 + (V2(2) - V3(2))**2 1 + (V2(3) - V3(3))**2 IF (J .LT. IPR(12)) THEN INCF = '*' RMSQ = RMSQ + WGHT * DIST SUMW = SUMW + WGHT URMS = URMS + DIST ELSE INCF = ' ' ENDIF CALL GEN048 (-1, IFG(I), 7, IHAT) IF (IHAT .EQ. 0) THEN NONHA = NONHA + 1 RMSQ1 = RMSQ1 + WGHT * DIST SUMW1 = SUMW1 + WGHT URMS1 = URMS1 + DIST ENDIF DIST = SQRT(DIST) IF (ISN0 .EQ. ISN7) THEN IF (I .NE. 0) THEN CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) CALL PLA047 (XLAB(I), NQ3, IDUM, JDUM, IPR(119), 1, 0, 0) ELSE CALL GEN038 (NQ1, 1, 7) NQ3 = NQ1 ENDIF IF (K .NE. 0) THEN CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) ELSE CALL GEN038 (NQ2, 1, 7) ENDIF IF (JR(J) .NE. 0 .AND. LU .NE. 0) THEN WRITE (LU60, 99992) NQ1, NQ3, (V3(N), N = 1, 3) ENDIF CALL PLA269 (1) IF (LU .EQ. 1) 1 WRITE (LU6, 99996) NQ1(1:6), (V3(N), N = 1, 3), 2 NQ2(1:6), (V2(N), N = 1, 3), DIST, INCF WRITE (LU7, 99996) NQ1(1:6), (V3(N), N = 1, 3), 1 NQ2(1:6), (V2(N), N = 1, 3), DIST, INCF ENDIF 130 CONTINUE URMS = SQRT(URMS / NATC) RMSQ = SQRT(RMSQ / SUMW) URMS1 = SQRT(URMS1 / NONHA) RMSQ1 = SQRT(RMSQ1 / SUMW1) IF (ISN0 .EQ. ISN7) THEN CALL PLA269 (5) IF (LU .EQ. 1) WRITE (LU6, 99995) RMSQ, URMS, NATC, 1 RMSQ1, URMS1, NONHA WRITE (LU7, 99995) RMSQ, URMS, NATC, RMSQ1, URMS1, NONHA ELSE IF (RMSQ .LT. BEST) THEN BEST = RMSQ ISNB = ISN MBST = M ENDIF ENDIF 140 CONTINUE IF (LU .NE. 0) THEN WRITE (LU60, 99990) DO 150 I = 1, NAT2, 2 K = JR(I + 1) IF (K .NE. 0) THEN CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, IPR(119), 1, 0, 0) CALL PLA047 (XLAB(K), NQ4, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) WRITE (LU60, 99992) NQ4, NQ2, 1 (XXO(K, N) - DUMA(N), N = 4, 6) ENDIF 150 CONTINUE WRITE (LU60, 99997) CLOSE (UNIT = LU60) IF (IGBL(25) .NE. 0 .OR. IGBL(3) .EQ. 41) CALL SYSTEM 1 (PLAPATH(1:IGBL(80))//' -p '//NAME(1)(1:KNM(1))//'_fit.spf') ENDIF VARDIST = RMSQ 160 RETURN 99999 FORMAT ('Molfit with Quaternion Transformation Method', 1 ' (see: A.L. Mackay, Acta Cryst.(1984), A40, 165-166)', /, 2 132('='), /) 99998 FORMAT ('Fit Rotation angle about (Pseudo)axis [l,m,n] = ', 1 F10.2, ' Degree', /, 2 'Direction Cosines with Orthogonal Cell l,m,n = ', 2 3F10.6, /, 'Components in crystal system', 20X, 3F10.6, //, 3 'Transf. Orthogonal Coord. Mol1', 5X, 4 'Orth. Coord. Mol2 with Resp. to C.G.', 1X, 5 'Dist (A)', /, 80('-')) 99997 FORMAT ('STRAW', /, 'COLOR RESD', /, 'OVERLAP MARGIN 0.0', /, 1 'SET PAR 149 0.0', /, 'LABEL ON', /, 'PLOT') 99996 FORMAT (1X, 2(A, 1X, 3F8.3, 4X), F7.3, 1X, A) 99995 FORMAT (/, ':: Weighted and Unit Weight RMS-Fit: ', 1 2F7.3 ,' Ang, No of Fitted Atoms:', I4, /, 2 /, ':: Weighted and Unit Weight RMS-Fit: ', 3 2F7.3 ,' Ang, No of Non-H Atoms:', I4) 99994 FORMAT (':: FIT Inverted Resd', I2, ' on Resd', I2, 1 ' gives the best fit', /) 99993 FORMAT (':: Residues are IDENTICAL', /) 99992 FORMAT (A, A, 3F10.3) 99991 FORMAT ('TITL ', A, ' - FIT RESD', I3, A, ' TO RESD', I3, 1 ', N =', I3, /, 'RESD 1') 99990 FORMAT ('RESD 2') END SUBROUTINE PLA086 (LU) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CALL PLA080 CONST = 16.0 * GL(6) * PAR(98) / 3.0 IF (LU .EQ. LU7) CALL PLA269 (0) WRITE (LU, 99999) IPR(48) DO 10 I = 20, 30 STHL = SIN (I / GL(5)) / 0.71073 NREF1 = NINT (CONST * STHL ** 3) NREF2 = NREF1 / IPR(48) NREF3 = NREF2 / (3 - IPR(257)) XJ = ASIN (MIN(1.0, STHL * 1.5418)) * GL(5) WRITE (LU, 99998) I, NREF1, NREF2, NREF3, XJ , STHL 10 CONTINUE 99999 FORMAT (/, 'Expected number of reflections in sphere ', 1 '(NSYM =', I3, ')', //, 2 'THMAX(MoKa) N N/NSYM N(LAUE) ', 3 'THMAX(CuKa) SINT/LAMBDA', /, 80('='), /) 99998 FORMAT (I5, 5X, 3I10, F10.2, F12.3) RETURN END SUBROUTINE PLA087 (NLTX) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8) C * CELL REDUCTION, SEE KRIVY & GRUBER, ACTA CRYST (1976), A32, 297-298) DO 20 J = 1, 3 DO 10 K = 1, 3 TRNS(J, K) = TRNSX(J, K, IPR(241)) DUMV(J, K) = TRNSX(J, K, NLTX) 10 CONTINUE 20 CONTINUE CALL GEN004 (TRNS, DUMV, TRNS) CALL GEN001 (1, TRNS, AA, DUMV) CALL PLA088 (DUMV, TRNS, PAR(440)) CALL GEN025 (DUMV, PAR(151), 1) CALL GEN026 (-1, DUMV, PAR(123), GL(5)) CALL GEN005 (TRNS, TRNS) CALL GEN003 (TRNS, TRNSM1, DET, 0) PAR(99) = PAR(98) * DET CALL GEN044 (PAR(123), ADIR) CALL GEN003 (ADIR, AINV, DET, 0) RETURN END SUBROUTINE PLA088 (DUMV, TRNS, SCL) COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8) DIMENSION TRNS(3, 3), DUMV(3, 3) REAL KSI, ETA, ZETA C * CELL REDUCTION, SEE KRIVY & GRUBER, ACTA CRYST (1976), A32, 297-298) A = NINT(DUMV(1, 1) * SCL) B = NINT(DUMV(2, 2) * SCL) C = NINT(DUMV(3, 3) * SCL) KSI = NINT(2.0 * SCL * DUMV(2, 3)) ETA = NINT(2.0 * SCL * DUMV(1, 3)) ZETA = NINT(2.0 * SCL * DUMV(1, 2)) 10 IF ((A .GT. B) .OR. ((NINT(A) .EQ. NINT(B)) .AND. 1 (ABS(KSI) .GT. ABS(ETA)))) THEN CALL GEN018 (A, B) CALL GEN018 (KSI, ETA) ETA = - ETA KSI = - KSI CALL GEN004 (TRNSX(1, 1, 8), TRNS, TRNS) ENDIF IF ((B .GT. C) .OR. ((NINT(B) .EQ. NINT(C)) .AND. 1 (ABS(ETA) .GT. ABS(ZETA)))) THEN CALL GEN018 (B, C) CALL GEN018 (ETA, ZETA) ETA = - ETA ZETA = - ZETA CALL GEN004 (TRNSX(1, 1, 9), TRNS, TRNS) GOTO 10 ENDIF IF (KSI * ETA * ZETA .GT. 0) THEN TRNSX(1, 1, 10) = SIGN(1.0, KSI) TRNSX(2, 2, 10) = SIGN(1.0, ETA) TRNSX(3, 3, 10) = SIGN(1.0, ZETA) KSI = ABS(KSI) ETA = ABS(ETA) ZETA = ABS(ZETA) CALL GEN004 (TRNSX(1, 1, 10), TRNS, TRNS) ELSE TRNSX(1, 1, 11) = - SIGN(1.0, KSI) TRNSX(2, 2, 11) = - SIGN(1.0, ETA) TRNSX(3, 3, 11) = - SIGN(1.0, ZETA) IF (KSI * ETA * ZETA .EQ. 0.0) THEN IF (KSI .EQ. 0.0) 1 TRNSX(1, 1, 11) = TRNSX(2, 2, 11) * TRNSX(3, 3, 11) IF (ETA .EQ. 0.0) 1 TRNSX(2, 2, 11) = TRNSX(1, 1, 11) * TRNSX(3, 3, 11) IF (ZETA .EQ. 0.0) 1 TRNSX(3, 3, 11) = TRNSX(1, 1, 11) * TRNSX(2, 2, 11) ENDIF KSI = - ABS(KSI) ETA = - ABS(ETA) ZETA = - ABS(ZETA) CALL GEN004 (TRNSX(1, 1, 11), TRNS, TRNS) ENDIF IF ((ABS(KSI) .GT. B) .OR. ((KSI .EQ. B) .AND. 1 (2.0 * ETA .LT. ZETA)) .OR. ((KSI .EQ. -B) .AND. 2 (ZETA .LT. 0.0))) THEN TRNSX(3, 2, 12) = - SIGN(1.0, KSI) C = B + C - KSI * SIGN(1.0, KSI) ETA = ETA - ZETA * SIGN(1.0, KSI) KSI = KSI - 2.0 * B * SIGN(1.0, KSI) CALL GEN004 (TRNSX(1, 1, 12), TRNS, TRNS) GOTO 10 ENDIF IF ((ABS(ETA) .GT. A) .OR. ((ETA .EQ. A) .AND. 1 (2.0 * KSI .LT. ZETA)) .OR. ((ETA .EQ. -A) .AND. 2 (ZETA .LT. 0))) THEN TRNSX(3, 1, 13) = - SIGN(1.0, ETA) C = A + C - ETA * SIGN(1.0, ETA) KSI = KSI - ZETA * SIGN(1.0, ETA) ETA = ETA - 2.0 * A * SIGN(1.0, ETA) CALL GEN004 (TRNSX(1, 1, 13), TRNS, TRNS) GOTO 10 ENDIF IF ((ABS(ZETA) .GT. A) .OR. ((ZETA .EQ. A) .AND. 1 (2.0 * KSI .LT. ETA)) .OR. ((ZETA .EQ. -A) .AND. 2 (ETA .LT. 0))) THEN TRNSX(2, 1, 14) = - SIGN(1.0, ZETA) B = A + B - ZETA * SIGN(1.0, ZETA) KSI = KSI - ETA * SIGN(1.0, ZETA) ZETA = ZETA - 2.0 * A * SIGN(1.0, ZETA) CALL GEN004 (TRNSX(1, 1, 14), TRNS, TRNS) GOTO 10 ENDIF IF ((KSI + ETA + ZETA + A + B .LT. 0) .OR. 1 ((KSI + ETA + ZETA + A + B .EQ. 0) .AND. 2 (2.0 * (A + ETA) + ZETA .GT. 0.0))) THEN C = A + B + C + KSI + ETA + ZETA KSI = 2.0 * B + KSI + ZETA ETA = 2.0 * A + ETA + ZETA CALL GEN004 (TRNSX(1, 1, 15), TRNS, TRNS) GOTO 10 ENDIF DUMV(1, 1) = A / SCL DUMV(2, 2) = B / SCL DUMV(3, 3) = C / SCL DUMV(1, 2) = ZETA * 0.5 / SCL DUMV(1, 3) = ETA * 0.5 / SCL DUMV(2, 3) = KSI * 0.5 / SCL DUMV(3, 2) = DUMV(2, 3) DUMV(3, 1) = DUMV(1, 3) DUMV(2, 1) = DUMV(1, 2) RETURN END SUBROUTINE PLA089 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 IF (IPR(30) .EQ. 0) THEN KINC = IPR(4) NDOAC = IPR(480) NAT = IPR(37) IPR(4) = 0 IF (IPR(208) .EQ. 0) THEN CALL PLA042 (1) MODE = 0 DO 10 I = 1, IAN IF (IEN(I) .EQ. 2) THEN MODE = 1 GOTO 20 ENDIF 10 CONTINUE 20 CALL GEN123 (MODE, IEN, IENS, IEL, IAN) DO 50 I = 1, NAT CALL GEN048 (-4, IFG(I), 15, NO1) NO1 = NO1 + 1 IVAL = 1 IF (KINC .GT. 0) THEN DO 30 J = 1, KINC IF (NO1 .EQ. NINT(RADR(J, 2))) THEN IVAL = IPR(70) GOTO 40 ENDIF 30 CONTINUE IVAL = 1 - IPR(70) 40 CON(I, 1) = CON(I, 1) * IVAL ENDIF 50 CONTINUE IF (NAT .EQ. 0) GOTO 230 IF (IGBL(33) .NE. 0) THEN ND = 2**(INT((ALOG(FLOAT(NAT)) / ALOG(2.0)) + 1.0e-5)) - 1 60 IF (ND .GT. 0) THEN I = 1 70 J = I NIFL = IFG(I + ND) NJFL = JFG(I + ND) NIAP = IATP(I + ND) DO 80 K = 1, NP4 DBUF(K) = CON(I + ND, K) 80 CONTINUE 90 IF (DBUF(1) .LT. CON(J, 1)) THEN IFG(J + ND) = IFG(J) JFG(J + ND) = JFG(J) IATP(J + ND) = IATP(J) DO 100 K = 1, NP4 CON(J + ND, K) = CON(J, K) 100 CONTINUE J = J - ND IF (J .GT. 0) GOTO 90 ENDIF DO 110 K = 1, NP4 CON(J + ND, K) = DBUF(K) 110 CONTINUE IFG(J + ND) = NIFL JFG(J + ND) = NJFL IATP(J + ND) = NIAP I = I + 1 IF (I + ND .LE. NAT) GOTO 70 ND = (ND - 1) / 2 GOTO 60 ENDIF ENDIF K = 0 DO 130 I = 1, NAT IF (CON(I, 1) .NE. 0) THEN K = K + 1 XLAB(K) = CON(I, 2) IFG(K) = IFG(I) JFG(K) = JFG(I) IATP(K) = IATP(I) DO 120 J = 1, 3 XXO(K, J) = CON(I, J + 2) IF (IABS(IGBL(8)) .NE. 2) THEN XSD(K, J) = CON(I, J + 5) ELSE XSD(K, J) = 0.0 ENDIF 120 CONTINUE ENDIF 130 CONTINUE IPR(37) = K IPR(39) = K NAT = K IPR(208) = 1 ENDIF IF(IPR(205) .GT. 0) THEN CALL PLA022 ELSE CALL PLA041 (0, 1, NP1, 0) IPR(13) = 1 MOL(1) = NINT(1555 * PAR(42)) IPR(51) = IPR(13) IPR(75) = 0 IPR(17) = 0 DO 160 I = 1, NAT CALL GEN048 (-4, IFG(I), 15, NO1) NO1 = NO1 + 1 CALL GEN048 (3, IFG(I), 1, 0) IKAT = I CALL PLA059 (IKAT, IKAT) IVAL = 1 DO 140 J = 1, NDOAC IF (IEN(NO1) .EQ. IDOAC(J)) GOTO 150 140 CONTINUE IVAL = 0 150 CALL GEN048 (1, IFG(I), 23, IVAL) IF (IGBL(30) .EQ. 1 .OR. IATP(I) .GT. 0) CALL PLA078 (I) 160 CONTINUE ENDIF ENDIF IF (IPR(205) .EQ. 0) THEN IF (IPR(17) .LT. 0) THEN DO 170 I = 1, IAN RADR(I, 2) = RADR(I, 4) 170 CONTINUE IF (IPR(189) .EQ. 0) THEN PAR(1) = PAR(3) ELSE PAR(1) = 0.0 ENDIF ELSE IF (IPR(17) .EQ. 0) THEN DO 190 I = 1, IAN RADR(I, 2) = RADR(I, 3) 190 CONTINUE PAR(1) = PAR(2) IF (IPR(31) .NE. 0) GOTO 220 ELSE PAR(1) = 0.0 DO 200 I = 1, IAN RVAL = 0.0 IF (IPR(57) .EQ. 1) THEN IELTP = IATPR(IEN(I)) IF (IELTP .GT. 0) RVAL = PAR(262) ELSE IF (IPR(57) .EQ. 2) THEN RVAL = PAR(262) ELSE IF (IPR(57) .LT. 0) THEN IF (IPR(57) + I .EQ. 0) RVAL = PAR(262) ELSE IF (IABS(IGBL(8)) .EQ. 2 .OR. IABS(IGBL(8)) .EQ. 3) THEN ICARB = 1 ELSE ICARB = 2 ENDIF IF (IEN(I) .GT. ICARB .AND. IEN(I) .NE. 33 .AND. 1 IEN(I) .NE. 113) RVAL = PAR(262) ENDIF RADR(I, 2) = RVAL 200 CONTINUE IPR(168) = 0 IF (IPR(220) .GE. 3) THEN IF (IFL(3)(1:3) .EQ. 'NOA') THEN IPR(7) = 0 ELSE CALL PLA037 (3, NID, 3) IF (NID .LT. 0) THEN IPR(168) = - NID ELSE IF (NID .EQ. 0) THEN IPR(2) = 18 GOTO 230 ENDIF ENDIF ENDIF ENDIF DO 210 J = 1, IAN RADJ = RADR(J, 1) RADR(J, 1) = -1.0 IF (RADJ .GE. 0.0) RADR(J, 2) = RADJ 210 CONTINUE 220 IPR(15) = 0 IPR(104) = 1 IPR(24) = 0 IF (IPR(23) .EQ. 1 .OR. IGBL(52) .EQ. 1) THEN IPR(27) = 1 IGBL(30) = 1 ELSE IPR(27) = 0 ENDIF ENDIF 230 RETURN END SUBROUTINE PLA090 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 CHARACTER FORM*105, FORMA*70, FORMB*43, CXMOL3*9 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER INTRA*6, IYH*1, NYH*1 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 IGBL(23) = 10 IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(121) .EQ. 0 .AND. 1 IPR(430) .EQ. 0) THEN IWIN = 1 ELSE IWIN = 0 ENDIF FORM(1 :40) = '(I2,A,I2, A,''--'',A,''..'',A,''['',A ,'']''' FORM(41:56) = ',F7.4,''('',I2,'')''' FORM(57:105) = FORM(41:56)//FORM(41:56)//',F7.1,''('',I2,'')'')' FORMB(1:36) = '(8X,I2,A,''--'',A,''.. ?'',16X,F7.4,''('',' FORMB(37:43) = 'I2,'')'')' A1 = 0.0 A2 = 0.0 A3 = 0.0 D1 = 0.0 D2 = 0.0 D3 = 0.0 SA1 = 0.0 SA2 = 0.0 SA3 = 0.0 SD1 = 0.0 SD2 = 0.0 SD3 = 0.0 IDEC1 = 0 IDEC2 = 0 IDEC3 = 0 IDEC4 = 0 IDEC5 = 0 IDEC6 = 0 ISA1 = 0 ISA2 = 0 ISD1 = 0 ISD2 = 0 ISD3 = 0 ISA3 = 0 NHEAD = 0 ITLC = 0 KOLD = 0 IOLD = 0 IDC = 0 NTEL = 0 A0 = 0.0 SA0 = 0.0 IF (IPR(87) .NE. 0) WRITE (LU6, 99983) NAT = IPR(37) NATM = IPR(39) IPR(88) = 0 CALL GEN097 (IATP, 1, NATM, 0) CALL GEN097 (IFNT, 1, NATM, 0) CALL GEN097 (JCA, 1, NATM, 0) CALL GEN097 (MP, 1, NP11, 0) WRITE (PRBUF, 99992) WRITE (LU6, 99986) PRBUF(1:80) IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, JID, 9, 0.30, 5 + IGBL(68), 2, HORS - 3.0, 1 0.1) VRT = VERT - 0.6 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT) VRT = VRT - 0.4 ENDIF DO 80 III = 1, 2 INRM = 0 DO 70 I = 1, NAT CALL GEN048 (-1, IFG(I), 7, IHA) IF (IHA .NE. 0) THEN INRM = INRM + 1 INORM = NATM + IPR(24) + INRM IF (III .EQ. 1) THEN DO 20 J = 1, 6 XXO(INORM, J) = XXO(I, J) XSD(INORM, J) = XSD(I, J) 20 CONTINUE XLAB(INORM) = XLAB(I) IFG(INORM) = IFG(I) JFG(INORM) = JFG(I) ENDIF CALL PLA036 (I, 1, 2, IPOPI, IDUM1, IDUM2, 1 IPR(119), IGBL(55)) IF (IPOPI .GE. 500) THEN NC = - NINT(CON(I, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .NE. 0) THEN K = NINT(CON(I, 1)) IF (K .GT. NP1) GOTO 70 IF (K .LE. 0) THEN WRITE (LU6, 99989) I, K, NC CALL PLA004 (0) ENDIF CALL GEN048 (-6, IFG(K), 9, IRES) CALL GEN048 (-4, IFG(K), 19, IMET) IF (IMET .EQ. 1) GOTO 70 CALL GEN048 (-4, IFG(K), 15, IVLC) IVLC = IEN(IVLC + 1) IF (IVLC .EQ. 20) GOTO 70 CALL PLA036 (K, 1, 1, IPOPK, IDIM1, IDUM2, 1 IPR(119), IGBL(55)) IF (III .EQ. 1) THEN IF (IPR(87) .GT. 0) THEN CALL GEN048 (1, JFG(INORM), 10, 0) CALL PLA050 (K, INORM, 0, 0, D1) IF (IVLC .EQ. 2) THEN D1 = PAR(296) / D1 ELSE IF (IVLC .EQ. 4) THEN D1 = PAR(297) / D1 ELSE IF (IVLC .EQ. 3) THEN D1 = PAR(298) / D1 ELSE IF (IVLC .EQ. 20) THEN D1 = PAR(294) / D1 ELSE IF (IVLC .EQ. 85) THEN D1 = PAR(295) / D1 ENDIF DO 30 L = 4, 6 YUNK = (XXO(INORM, L) - XXO(K, L)) * D1 XXO(INORM, L) = XXO(K, L) + YUNK XSD(INORM, L) = 0.0 30 CONTINUE ENDIF IF (IVLC .EQ. 2) GOTO 70 IF (NC .LT. 2) THEN IF (IGBL(63) .GT. 2) THEN IF (NHEAD .NE. 1) THEN NHEAD = 1 CALL PLA269 (-7) WRITE (LU7, 99997) PAR(8), PAR(9), PAR(10) WRITE (LU7, 99996) ENDIF ENDIF CALL PLA053 (K, INORM, 0, 0, D1, SD1, ISD1, 1 IDEC1, IER) IF (IER .EQ. 0) THEN IF (ISD1 .EQ. 0) THEN IDEC1 = 2 D1 = NINT (D1 * 100.0) / 100.0 ENDIF ENDIF IF (IGBL(63) .GT. 2) THEN IF (NHEAD .NE. 1) THEN NHEAD = 1 CALL PLA269 (-5) WRITE (LU7, 99997) PAR(8), PAR(9), PAR(10) IF (IPR(87) .GT. 0) THEN CALL PLA269 (3) WRITE (LU7, 99988) ENDIF CALL PLA269 (2) WRITE (LU7, 99996) ENDIF ISD1 = MIN (99, ISD1) FORMB(31:31) = CHAR(ICHAR('0') + IDEC1) WRITE (PRBUF, FORMB) IRES, NAMS(1, 1)(1:7), 1 NAMS(1, 2)(2:8), D1, ISD1 CALL PLA067 (LU7, PRBUF, 132, 1, 3) WRITE (LU6, 99980) PRBUF(12:79) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF(12:90), 79, 0.35, 2, 2, 1 1.0, VRT) ENDIF CALL PLA269 (1) ENDIF IF (NAMS(1, 1)(2:2) .NE. 'B' .AND. 1 NAMS(1, 1)(2:2) .NE. 'P') THEN IF (NAMS(1, 1)(2:2) .EQ. 'O') THEN W = 2.0 ELSE W = 1.0 ENDIF WRITE (LU20, 99982) '_420', W, W, 1 (NAMS(1, KK)(1:7), KK = 1, 2) ENDIF IPR(405) = IPR(405) + 1 GOTO 70 ENDIF ELSE IF (NC .LT. 2) GOTO 70 IF (IVLC .NE. 2) GOTO 70 ENDIF IF (IPOPK .LT. 501) THEN IF (IPOPK .LT. 500) GOTO 70 IDISK = 10 ELSE IDISK = 0 ENDIF CALL PLA053 (K, INORM, 0, 0, D1, SD1, ISD1, 1 IDEC1, IER) IF (IER .NE. 0) GOTO 70 CALL GEN048 (-1, IFG(I), 20, IHB) DO 50 L = 2, NC M = NINT(CON(I, L)) M = MOD(M, NP1) CALL GEN048 (-1, IFG(M), 23, IVAL) CALL GEN048 (-1, JFG(M), 28, IVAL1) IF (IVAL .EQ. 0 .AND. IVAL1 .EQ. 0) GOTO 50 CALL PLA036 ( M, 1, 4, IPOPM, IDUM1, IDUM2, IPR(119), 1 IGBL(55)) CALL PLA036 (-M, 1, 3, IPOPM, IDUM1, IDUM2, IPR(119), 1 IGBL(55)) IF (IPOPM .LT. 501) THEN IF (IPOPM .LT. 500 .AND. IPR(303) .EQ. 0) GOTO 50 IDSORD = IDISK + 1 ELSE IDSORD = IDISK ENDIF XLABM = - XLAB(M) CALL PLA047 (XLABM, NQ3, MNM, JDUM, IPR(119), 1 IGBL(55), 0, 0) CALL PLA046 (-2, NQ3, IENM, LBB, LBC, LBD, 1 XLMP, YNQNR, NIEN) IF (NIEN .LT. 0) THEN NQ1 = NQ3 IPR(2) = 3 GOTO 130 ENDIF IF (IEL(IEN(IENM)) .EQ. 321) GOTO 50 MPRIM = NIEN CALL GEN048 (-6, IFG(M), 9, IRESM) XMOL3 = MOL(MNM) / PAR(42) IF (NINT(XMOL3) .EQ. 1555) 1 XMOL3 = XMOL3 + IRESM / PAR(42) CALL GEN048 (-4, IFG(K), 15, IVWK) CALL GEN048 (-4, IFG(I), 15, IVWI) CALL GEN048 (-4, IFG(M), 15, IVWM) CALL PLA053 (M, INORM, 0, 0, D2, SD2, ISD2, IDEC2, 1 IER) IF (IER .NE. 0) GOTO 50 IF (D2 .GT. (RADR(IVWI + 1, 2) + RADR(IVWM + 1, 2) + 1 PAR(9))) GOTO 50 CALL PLA053 (K, INORM, M, 0, A1, SA1, ISA1, IDEC4, 1 IER) IF (IER .NE. 0) GOTO 50 IF (A1 .LT. PAR(10)) GOTO 50 CALL PLA053 (K, M, 0, 0, D3, SD3, ISD3, IDEC3, IER) IF (IER .NE. 0) GOTO 50 IF (D3 .GT. (RADR(IVWK + 1, 2) + RADR(IVWM + 1, 2) + 1 PAR(8))) GOTO 50 ISD1 = MIN (99, ISD1) FORM(45:45) = CHAR(ICHAR('0') + IDEC1) ISD2 = MIN (99, ISD2) FORM(61:61) = CHAR(ICHAR('0') + IDEC2) ISD3 = MIN (99, ISD3) FORM(77:77) = CHAR(ICHAR('0') + IDEC3) ISA1 = MIN (99, ISA1) FORM(93:93) = CHAR(ICHAR('0') + IDEC4) IF (NHEAD .NE. 1) THEN NHEAD = 1 IF (IGBL(63) .GT. 2) THEN PAGET = 'H-BONDS' CALL PLA269 (-7) WRITE (LU7, 99997) PAR(8), PAR(9), PAR(10) WRITE (LU7, 99996) ENDIF ENDIF XMOL2 = (1555 * PAR(42) + IRES) / PAR(42) IF (IHB .NE. 0) THEN IPR(88) = IPR(88) + 1 IF (IPR(88) .LE. NP2) THEN XLS(1, IPR(88)) = K XLS(2, IPR(88)) = XMOL2 XLS(3, IPR(88)) = MPRIM XLS(4, IPR(88)) = XMOL3 XLS(8, IPR(88)) = IDSORD XLS(9, IPR(88)) = A1 XLS(10, IPR(88)) = I IATP(K) = IATP(K) + 1 IFNT(MPRIM) = IFNT(MPRIM) + 1 CALL GEN048 (1, IFG(MPRIM), 22, 1) ELSE IPR(149) = IPR(149) + 10000 ENDIF ELSE JCA(MPRIM) = JCA(MPRIM) + 1 ENDIF IF (IRESM .EQ. IRES .AND. MNM .LE. IPR(51)) THEN INTRA = ' Intra' ELSE INTRA = ' ' ENDIF IF (III .EQ. 2) THEN IF (IDC .EQ. 0 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (1) VRT = VRT - 0.3 WRITE (LU6, 99981) WRITE (LU7, 99981) ENDIF IDC = IDC + 1 ENDIF ITLC = ITLC + 1 MP(MNM) = 1 IF (INT(XMOL3) .EQ. 1555) THEN CXMOL3 = ' ' ELSE WRITE (CXMOL3, 99994) XMOL3 ENDIF WRITE (PRBUF, FORM) ITLC, INTRA, IRES, 1 NAMS(1, 1)(1:7), (NAMS(1, L9)(2:8), L9 = 2, 3), 2 CXMOL3, D1, ISD1, D2, ISD2, D3, ISD3, A1, ISA1 IF (IPR(438) .EQ. 1) THEN IPR(452) = IPR(452) + 1 WRITE (LU2, 99987) (NAMS(1, L9)(2:8), L9 = 1, 2), 1 NAMS(1, 4)(2:8), D1, SD1, D2, SD2, D3, SD3, 2 A1, SA1, XLAB(M) ENDIF IF (K .NE. KOLD .OR. I .NE. IOLD) THEN KOLD = K IOLD = I MPRM = M MDPRM = 0 A0 = A1 SA0 = SA1 GOTO 40 ENDIF CALL PLA053 (MPRM, INORM, M, 0, A2, SA2, ISA2, 1 IDEC5, IER) IF (IER .NE. 0) GOTO 50 FORMA(1:21) = '(A,F6.1,''('',I2,'')'',A,' ISA2 = MIN (99, ISA2) FORMA(7:7) = CHAR(ICHAR('0') + IDEC5) IF (A2 .GT. 0.1) THEN SUM = A0 + A1 + A2 SSUM = SQRT(SA0**2 + SA1**2 + SA2**2) CALL GEN041 (SUM, SSUM, ISUM, 2, IDEC7, IPR(68)) ISUM = MIN (99, ISUM) IF (MDPRM .EQ. 0) THEN FORMA(22:41) = '10X,F6.1,''('',I2,'')'')' FORMA(29:29) = CHAR(ICHAR('0') + IDEC7) WRITE (PRBUF(91:132), FORMA(1:41)) 1 CHAR(39), A2, ISA2, CHAR(39), SUM, ISUM MDPRM = M SUM4 = A1 SSUM4 = SA1**2 GOTO 40 ENDIF FORMA(22:37) = 'F6.1,''('',I2,'')'',' FORMA(38:70) = FORMA(22:37)//FORMA(22:37)//')' CALL PLA053 (MDPRM, INORM, M, 0, A3, SA3, ISA3, 1 IDEC6, IER) IF (IER .NE. 0) GOTO 50 ISA3 = MIN (99, ISA3) FORMA(25:25) = CHAR(ICHAR('0') + IDEC6) FORMA(41:41) = CHAR(ICHAR('0') + IDEC7) IF (A3 .GT. 0.1) THEN SUM4 = SUM4 + A1 + A3 SSUM4 = SQRT(SSUM4 + SA1**2 + SA3**2) CALL GEN041 (SUM4, SSUM4, ISUM4, 2, IDEC8, 1 IPR(68)) ISUM4 = MIN (99, ISUM4) FORMA(57:57) = CHAR(ICHAR('0') + IDEC8) WRITE (PRBUF(91:132), FORMA) CHAR(34), A2, ISA2, 1 CHAR(34), A3, ISA3, SUM, ISUM, SUM4, ISUM4 GOTO 40 ENDIF ENDIF ITLC = ITLC - 1 GOTO 50 40 IF (IGBL(63) .GT. 2) THEN CALL PLA067 (LU7, PRBUF, 132, 1, 3) IF (IWIN .EQ. 1) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF(12:90), 79, 0.35, 1, 2, 1 1.0, VRT) NTEL = NTEL + 1 ENDIF WRITE (LU6, 99980) PRBUF(12:90) ENDIF 50 CONTINUE ENDIF ENDIF ENDIF 70 CONTINUE 80 CONTINUE IF (IPR(88) .EQ. 0) THEN LINE = ':: No Classic Hydrogen Bonds Found' CALL PLA015 (0, 1) WRITE (LU6, 99986) LINE IF (IWIN .EQ. 1) THEN VRT = VRT - 2.5 CALL GGIP20 (0.0, LINE, 50, 0.70, 2, 2, 2.5, VRT) VRT = VRT - 1.5 ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99986) LINE ENDIF ELSE CALL PLA015 (0, 2) ENDIF IF (IPR(87) .NE. 0 .AND. INRM .NE. 0) THEN CALL PLA269 (5) WRITE (LU7, 99985) DO 100 I = 1, INRM J = NATM + IPR(24) + I CALL PLA047 (XLAB(J), NQ1, MNM, JDUM, IPR(119), IGBL(55), 1 0, 0) DO 90 K = 1, 3 V5(K) = XXO(J, K + 3) 90 CONTINUE CALL GEN002 (1, ROR, V5, V4, XLNG) CALL PLA269(1) WRITE (LU7, 99984) NQ1, (V4(K), K = 1, 3), 1 (V5(K), K = 1, 3) 100 CONTINUE ENDIF IF (IPR(300) .GT. 0 .AND. NHEAD .NE. 0) THEN IF (NTEL .GT. 0) THEN VRT = VRT - 0.4 CALL PLA043 (0, 0, 0, 0) CALL PLA043 (0, 0, LU6, 0) ENDIF CALL PLA043 (0, 0, LU7, 0) IF (IDC .GT. 0 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99995) ENDIF IF (ITLC .GT. 0 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (6) WRITE (LU7, 99993) ENDIF IF (IPR(88) .GT. 0) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (6) WRITE (LU7, 99999) ENDIF DO 120 I = 1, NAT CALL GEN048 (-1, IFG(I), 23, IDA) IF (IDA .EQ. 1) THEN CALL PLA036 (I, 1, 1, IDS1, IDUM1, IDUM2, IPR(119), 1 IGBL(55)) IF (IDS1 .GE. 500) THEN CALL GEN048 (-1, IFG(I), 21, IH) IF (IH .EQ. 1) THEN IYH = 'H' ELSE IYH = '-' ENDIF NC = - NINT(CON(I, NP4)) NCV = 0 NCVH = 0 DO 110 J = 1, NC K = NINT(CON(I, J)) IF (K .LE. NP1) THEN NCV = NCV + 1 CALL GEN048 (-1, IFG(K), 7, IHA) NCVH = NCVH + IHA ENDIF 110 CONTINUE IF (NCVH .EQ. 0) THEN NYH = ' ' ELSE WRITE (NYH, 99979) NCVH ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) NSUMH = IATP(I) + IFNT(I) + JCA(I) NSUMT = NSUMH + NCV - NCVH WRITE (LU7, 99998) I, NAMS(1, 1), NCV, NYH, IYH, 1 IATP(I), IFNT(I), JCA(I), NSUMH, NSUMT ENDIF ENDIF ENDIF 120 CONTINUE ENDIF ENDIF 130 CONTINUE RETURN 99999 FORMAT (/, 'Analysis of Potential Donor/Acceptor Atoms', 1 ' -- (Major Disorder Form Only)', /, 132('='), //, 2 'At.Nr D/A', 4X, '#Cov.Bonds', 4X, '# H', 5X, '#D-H..A', 3X, 3 '#A..H', 3X, '#A..H-C', 2X, 'Sum(A-H)', 3X, 'Sum(A-X)', /, 4 132('-')) 99998 FORMAT (I4, 2X, A, 2X, I6, 6X, A, 1X, A, 5I9) 99997 FORMAT ('Analysis of Potential Hydrogen Bonds and Schemes with ', 1 'd(D...A) < R(D)+R(A)+0', F3.2, ', d(H...A) < R(H)+R(A)', 2 F5.2, ' Ang., D-H...A >', F6.1, ' Deg', /, 3 132('='), /, 'Note: - ARU codes in [] are with reference to', 4 ' the Coordinates printed above (Possibly transformed, when', 5 ' MOVE .NE. 1.555)', /, 132('='), /) 99996 FORMAT ('Nr Typ Res Donor --- H....Acceptor [ ARU ]', 6X, 1 'D - H', 6X, 'H...A', 6X, 'D...A', 2X, 'D - H...A', 4X, 'A..H', 2 '..A*', 1X, 'A''..H..A" Sum(XY,YZ) Sum(XZ)', /, 132('-')) 99995 FORMAT (/, 'For C--H...Acceptor Interactions See: ', 1 'Th. Steiner, Cryst. Rev, (1996), 6, 1-57') 99994 FORMAT (F9.2) 99993 FORMAT (/, 'H-Bond classification [G.A.Jeffrey, H.Maluszynska &', 1 ' J.Mitra., Int.J.Biol.Macromol.(1985),7,336-348]', /, 132('-'), 3 /, '2-Centre (linear) D-H...X most prob. angle 160 deg', 4 ' - also: G.A.Jeffrey & W.Saenger, Hydrogen Bonding in ', 5 'Biological Structures', /, 6 '3-Centre (bifurcated) SUM of 3 angl. about H = 360 deg', 7 20X, 'Springer-Verlag, Berlin, 1991, pp 20.', /, 8 '4-Centre (trifurcated)') 99992 FORMAT ('Donor --- H....Acceptor [ ARU ]', 6X, 1 'D - H', 6X, 'H...A', 6X, 'D...A', 2X, 'D - H...A') 99989 FORMAT (/, 'Problem in PLA090', 3I10, /) 99988 FORMAT ('X-H Bonds normalized: G.A. Jeffrey & L. Lewis', 1 ', Carbohydr.Res. (1978), 60, 179', /, 2 22X, 'R.Taylor & O.Kennard, Acta Cryst. (1983), B39, 133)', /) 99987 FORMAT ('HBON ', 3(A, ' '), 4F8.4, ' = ', /, 1 5X, 2F10.4, 2F10.2, F12.0) 99986 FORMAT (/, A, /) 99985 FORMAT (/, 'Normalized X-H Atom Positions', /, 132('='), /, 1 'Atom', 10X, 'x', 9X, 'y', 9X, 'z', 9X, 'XO', 8X, 'YO', 2 8X, 'ZO', /, 132('-')) 99984 FORMAT (A, 6F10.4) 99983 FORMAT (/, ':: X-H Distances have been NORMALIZED', /) 99982 FORMAT (A, 2F10.0, 2A) 99981 FORMAT (1X) 99980 FORMAT (A) 99979 FORMAT (I1) END SUBROUTINE PLA091 (MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON // JNSC(2 * NP23), VOID(NPVD) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER IDS1*1, IDS2*1, FORMI*58, FORMJ*31, FORMK*16 FORMI( 1:40) = '(I4,6X,2A,''['',F9.2,''] ... '',2A,''['',F9.2,' FORMI(41:58) = ' ''] = '',F6.3,F7.2)' FORMJ( 1:31) = '(I2,I3,F9.2,'' -- '',11(F9.2,A))' FORMK( 1:16) = '(19X,11(F9.2,A))' IF (PAR(42) .LT. 100.0) THEN FORMI(18:18) = '1' FORMI(39:39) = '1' FORMJ(11:11) = '1' FORMJ(27:27) = '1' FORMK(12:12) = '1' ENDIF NR1 = 0 NS1 = 0 NT11 = 0 NT12 = 0 NT13 = 0 IAGGP = 0 IARU = NINT(PAR(42)) NTOP = IPR(299) NADD = 25 ITL = IPR(88) IF (ITL .GT. 0) THEN IF (MODE .EQ. 0) THEN ITL2 = ITL * 2 IF (ITL2 .GT. NP2) THEN WRITE (LU6, 99989) GOTO 150 ENDIF ELSE ITL2 = ITL ENDIF NRES = IPR(75) NSYM = IPR(48) IF (IGBL(63) .GT. 2) CALL PLA269 (0) IF (MODE .EQ. 0) THEN IF (IGBL(63) .GT. 3) THEN CALL PLA269 (10) WRITE (LU7, 99999) WRITE (LU7, 99990) ENDIF DO 10 I = 1, ITL IATC(I) = 1 XLS(5, I) = MOD(NINT(XLS(2, I) * IARU), IARU) MR1 = MOD(NINT(XLS(4, I) * IARU), IARU) XLS(5, ITL + I) = MR1 XLS(9, ITL + I) = XLS(9, I) CALL PLA081 (5, XLS(4, I), 0.0, XLS(2, ITL + I)) IF (IPR(2) .NE. 0) GOTO 150 CALL PLA081 (6, XLS(2, ITL + I), XLS(2, I), XLS(4, ITL + I)) IF (IPR(2) .NE. 0) GOTO 150 XLS(2, ITL + I) = (1555 * PAR(42) + MR1) / PAR(42) J = NINT(XLS(1, I)) K = NINT(XLS(3, I)) XLS(1, ITL + I) = K XLS(3, ITL + I) = J IDSORD = NINT(XLS(8, I)) IF (IDSORD .EQ. 10) THEN IDISO = 1 ELSE IF (IDSORD .EQ. 1) THEN IDISO = 10 ELSE IDISO = IDSORD ENDIF XLS(8, ITL + I) = IDISO CALL PLA093 (I, J, K, 1) ITLPI = ITL + I CALL PLA093 (ITLPI, K, J, -1) 10 CONTINUE ELSE IF (IGBL(63) .GT. 3) THEN CALL PLA269 (5) WRITE (LU7, 99992) ENDIF DO 20 I = 1, ITL IDSORD = NINT(XLS(8, I)) IF (IDSORD / 10 .EQ. 1) THEN IDS1 = '*' ELSE IDS1 = ' ' ENDIF IF (MOD(IDSORD, 10) .EQ. 1) THEN IDS2 = '*' ELSE IDS2 = ' ' ENDIF CALL PLA047 (XLS(1, I), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) CALL PLA047 (XLS(3, I), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, FORMI) I, IDS1, NQ1(1:6), XLS(2, I), IDS2, 1 NQ2(1:6), XLS(4, I), XLS(6, I), XLS(7, I) ENDIF 20 CONTINUE ENDIF ITL0 = 0 DO 40 J = 1, NSYM DO 30 I = 1, NRES IF (ITL0 .GE. NP1) GOTO 50 ITL0 = ITL0 + 1 IATP(ITL0) = (J * 1000 + 555) * IARU + I 30 CONTINUE 40 CONTINUE 50 IAGG = 0 N51 = IPR(51) L0 = 1 CALL PLA040 (-1, 0, 0, 0, 0) DO 140 I = 1, ITL0 N1 = 0 LMX = 1 DMOL = IATP(I) / PAR(42) VOID(NTOP + (I - 1) * NADD + 1) = DMOL CALL GEN098 (IATP(I), PAR(42), MS1, MT1, MT2, MT3, MR0) IF (N51 .GT. 1) THEN DO 55 K = 2, N51 ML = MOL(K) IF (MOD(ML, IARU) .EQ. MR0) THEN XMOL1 = ML / PAR(42) CALL PLA081 (7, DMOL, XMOL1, XMOL2) IF (IPR(2) .NE. 0) GOTO 150 LMX = LMX + 1 VOID(NTOP + (I - 1) * NADD + LMX) = XMOL2 IFNT(LMX) = ICHAR('*') ENDIF 55 CONTINUE ENDIF IF (L0 .LE. I) THEN CALL PLA040 (0, 0, 0, 0, 0) IAGGP = 1 L0 = L0 + 1 IF (N51 .GT. 1) THEN DO 70 K = 2, N51 ML = MOL(K) IF (MOD(ML, IARU) .EQ. MR0) THEN XMOL1 = ML / PAR(42) DMOL = VOID(NTOP + (I - 1) * NADD + 1) CALL PLA081 (7, DMOL, XMOL1, XMOL2) IF (IPR(2) .NE. 0) GOTO 150 MOL1 = INT(XMOL2 / 1000.0) ML = NINT(XMOL2 * PAR(42)) NMOL = MOL1 * 1000 * IARU + 555 * IARU + MR0 DO 60 L = L0, ITL0 IF (IATP(L) .EQ. NMOL) THEN IATP(L) = IATP(L0) IATP(L0) = ML L0 = L0 + 1 GOTO 70 ENDIF 60 CONTINUE ENDIF 70 CONTINUE ENDIF ENDIF DO 120 K = 1, ITL2 N = NINT(XLS(5, K)) IF (MR0 .EQ. N) THEN CALL PLA081 (8, DMOL, XLS(4, K), XMOL) IF (IPR(2) .NE. 0) GOTO 150 N1 = N1 + 1 DO 80 L = 1, LMX DMOLL = VOID(NTOP + (I - 1) * NADD + L) IF (NINT((DMOLL - XMOL) * PAR(42)) .EQ. 0) THEN IF (L .EQ. 1) N1 = N1 - 1 GOTO 120 ENDIF 80 CONTINUE LMX = LMX + 1 VOID(NTOP + (I - 1) * NADD + LMX) = XMOL IFNT(LMX) = ICHAR(' ') NMOL = NINT(XMOL * PAR(42)) CALL GEN098 (NMOL, PAR(42), MS2, MT21, MT22, MT23, MR2) DO 110 L = 1, ITL0 CALL GEN098 (IATP(L), PAR(42), MS1, MT11, MT12, 1 MT13, MR1) IF (MS2 .EQ. MS1 .AND. MR2 .EQ. MR1) THEN IF (L .LT. L0) THEN MD1 = MT21 - MT11 MD2 = MT22 - MT12 MD3 = MT23 - MT13 IF (IABS(MD1) + IABS(MD2) + IABS(MD3) .GT. 0) 1 THEN CALL PLA040 (1, MD1, MD2, MD3, 0) IFNT(LMX) = ICHAR('T') ENDIF ELSE IATP(L) = IATP(L0) IATP(L0) = NMOL L0 = L0 + 1 IF (N51 .GT. 1) THEN DO 100 K2 = 2, N51 ML = MOL(K2) IF (MOD(ML, IARU) .EQ. MR2) THEN XMOL1 = ML / PAR(42) CALL PLA081 (9, XMOL, XMOL1, XMOL2) IF (IPR(2) .NE. 0) GOTO 150 MOL2 = INT(XMOL2 / 1000.0) NMOL2 = (MOL2 * 1000 + 555) * IARU + MR2 DO 90 L2 = L0, ITL0 IF (IATP(L2) .EQ. NMOL2) THEN IATP(L2) = IATP(L0) IATP(L0) = NINT(XMOL2 * PAR(42)) L0 = L0 + 1 GOTO 100 ENDIF 90 CONTINUE ENDIF 100 CONTINUE ENDIF ENDIF ENDIF 110 CONTINUE ENDIF 120 CONTINUE M1 = LMX - 1 IF (M1 .GT. 0) THEN IF (IAGGP .GT. 0) THEN IAGG = IAGG + 1 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (7) IF (MODE .EQ. 0) THEN WRITE (LU7, 99998) ' Aggregate =', IAGG WRITE (LU7, 99997) ELSE WRITE (LU7, 99998) ' Cluster =', IAGG WRITE (LU7, 99995) ENDIF ENDIF IAGGP = 0 ENDIF IF (LMX .GT. 12) THEN LMZ = 12 ELSE LMZ = LMX ENDIF NTP = NTOP + (I - 1) * NADD VOID(NTP + 25) = LMX IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, FORMJ) N1, M1, VOID(NTP + 1), 1 (VOID(NTP + L), CHAR(IFNT(L)), L = 2, LMZ) ENDIF IF (LMX .GT. 12) THEN LMB = 2 130 LMB = LMB + 11 LMZ = LMB + 10 IF (LMZ .GT. LMX) LMZ = LMX IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) NTP = NTOP + (I - 1) * NADD WRITE (LU7, FORMK) 1 (VOID(NTP + L), CHAR(IFNT(L)), L = LMB, LMZ) ENDIF IF (LMZ .LT. LMX) GOTO 130 ENDIF ENDIF 140 CONTINUE CALL PLA040 (0, 0, 0, 0, 0) IF (MODE .NE. 0 .OR. IGBL(63) .LE. 2) GOTO 150 NCIR = 0 N1 = 1 N2 = 2 MCIR = IPR(66) IF (MCIR .EQ. 0) N1 = 2 MCHN = IPR(82) IF (MCHN .EQ. 0) N2 = 1 IF (N2 .GE. N1) THEN DO 595 N3 = N1, N2 IF (N3 .EQ. 1) THEN MC = MCIR NCRA = 0 ELSE MC = MCHN NCRA = NCIR + 1 ENDIF DO 590 NR = 1, NRES DO 505 I = 1, ITL0 IF (MOD(IATP(I), IARU) .EQ. NR) GOTO 506 505 CONTINUE 506 NRT = 1 L0 = ITL0 K = I 510 JR(NRT) = NTOP + (K - 1) * NADD DATC(NRT) = VOID(JR(NRT) + 1) IF (NRT .GT. 1) THEN MOL2 = NINT(DATC(NRT) * PAR(42)) CALL GEN098 (MOL2, PAR(42), NS2, NT21, NT22, NT23, NR2) IF (NS1 .EQ. NS2 .AND. NR1 .EQ. NR2) THEN ND1 = NT21 - NT11 ND2 = NT22 - NT12 ND3 = NT23 - NT13 ND123 = IABS(ND1) + IABS(ND2) + IABS(ND3) IF (N3 .EQ. 1) THEN IF (ND123 .NE. 0) GOTO 526 ELSE IF (ND123 .EQ. 0 .OR. NRT .GT. MCHN) GOTO 526 ENDIF DO 509 KK = 1, NRT JNSC(NCIR * 100 + KK) = NINT(DATC(KK) * PAR(42)) 509 CONTINUE IF (NCIR .GT. NCRA + 1) THEN DO 501 J = NCRA + 1, NCIR - 1 DO 515 K0 = 1, NRT - 1 DO 502 KK = 1, NRT - 1 KK0 = MOD(KK + K0 - 2, NRT - 1) + 1 IF (JNSC(NCIR * 100 + KK0) .NE. 1 JNSC(J * 100 + KK)) GOTO 504 502 CONTINUE NRT = NRT - 1 GOTO 530 504 DO 503 KK = 1, NRT - 1 KK0 = MOD(KK + K0 - 2, NRT - 1) + 1 IF (JNSC(NCIR * 100 + NRT - KK0) .NE. 1 JNSC(J * 100 + KK)) GOTO 515 503 CONTINUE NRT = NRT - 1 GOTO 530 515 CONTINUE 501 CONTINUE ENDIF NCIR = NCIR + 1 IF (NCIR .EQ. 1) THEN CALL PLA269 (4) WRITE (LU7, 99985) IPR(66) - 1, IPR(82) - 1 ELSE IF ((NCIR + 1) * 100 .GT. 2.0 * NP23) THEN GOTO 150 ENDIF CALL PLA269 (3 + NRT / 14) IF (ND123 .EQ. 0) THEN WRITE (LU7, 99988) NRT - 1 WRITE (LU7, 99987) (DATC(KK), KK = 1, NRT) ELSE WRITE (LU7, 99986) NRT - 1, ND1, ND2, ND3 WRITE (LU7, 99987) (DATC(KK), KK = 1, NRT) ENDIF NRT = NRT - 1 GOTO 530 ENDIF ELSE MOL1 = NINT(DATC(1) * PAR(42)) CALL GEN098 (MOL1, PAR(42), NS1, NT11, NT12, NT13, NR1) ENDIF 526 NCN(NRT) = NINT(VOID(JR(NRT) + 25)) IF (NRT .EQ. 1) THEN IF (NCN(1) .LT. 3) GOTO 590 ENDIF IF (NRT .LT. MC) THEN NRT = NRT + 1 JLN(NRT) = 1 ENDIF 530 JLN(NRT) = JLN(NRT) + 1 IF (NRT .LE. 1) GOTO 590 IF (JLN(NRT) .GT. NCN(NRT - 1)) THEN NRT = NRT - 1 IF (NRT .GT. 1) GOTO 530 GOTO 590 ENDIF XMOL = VOID(JR(NRT - 1) + JLN(NRT)) IF (NRT .GT. 2) THEN IF (XMOL .EQ. DATC(NRT - 2)) GOTO 530 ENDIF NMOL = NINT(XMOL * PAR(42)) CALL GEN098 (NMOL, PAR(42), MS2, MT21, MT22, MT23, MR2) DO 540 L = 1, ITL0 CALL GEN098 (IATP(L), PAR(42), MS1, MT11, MT12, MT13, 1 MR1) IF (MS2 .EQ. MS1 .AND. MR2 .EQ. MR1) THEN MD1 = MT21 - MT11 MD2 = MT22 - MT12 MD3 = MT23 - MT13 IF (IABS(MD1) + IABS(MD2) + IABS(MD3) .NE. 0) THEN NAD = MD1 * 100 + MD2 * 10 + MD3 L0 = L0 + 1 IF (L0 .GT. NP1) GOTO 590 IATP(L0) = IATP(L) + NAD * 100 N0 = INT(VOID(NTOP + (L - 1) * NADD + 25)) VOID(NTOP + (L0 - 1) * NADD + 25) = N0 DO 545 N = 1, N0 MOLY = NINT(VOID(NTOP + (L - 1) * NADD + N) 1 * PAR(42)) CALL GEN098 (MOLY, PAR(42), MS3, MT31, MT32, 1 MT33, MR3) MT31 = MT31 + MD1 IF (MT31 .LT. -5 .OR. MT31 .GT. 4) GOTO 530 MT32 = MT32 + MD2 IF (MT32 .LT. -5 .OR. MT32 .GT. 4) GOTO 530 MT33 = MT33 + MD3 IF (MT33 .LT. -5 .OR. MT33 .GT. 4) GOTO 530 VOID(NTOP + (L0 - 1) * NADD + N) = 1 VOID(NTOP + (L - 1) * NADD + N) + NAD 545 CONTINUE K = L0 ELSE K = L ENDIF ENDIF 540 CONTINUE GOTO 510 590 CONTINUE 595 CONTINUE ENDIF ENDIF 150 RETURN 99999 FORMAT ('Analysis of Hydrogen Bonded Molecular Aggregates', 1 ' (See also Acta Cryst. B36, 1980, 2113 - 2115)', 2 ' -- (Major Disorder Component Only)', /, 132('='), /) 99998 FORMAT (/, 57X, 14('='), /, 56('*'), A, I3, 1 1X, 60('*'), /, 57X, 14('='), /) 99997 FORMAT ('(N:M) : ARU -- Connected with N Hydrogen Bonds', 1 ' to/from M ARU(S).', 4X, 'T = Translated Molecule (Infinite', 2 ' chain etc.)', /, 132('-')) 99995 FORMAT ('(N:M) : ARU -- Connected with (N) Interactions', 1 ' to/from (M) ARU(S).', 4X, 'T = Translated Molecule (Infinite', 2 ' chain etc.)', /, 132('-')) 99992 FORMAT ('Analysis of Short Non-Hydrogen Inter-Molecular', 1 ' Contacts For Inter-Molecular Clusters and/or Networks', 2 3X,'(Minor Disorder Excluded)', /, 132('='), //, 3 'Contact-Nr Atom I[ ARU ]', 6X, 'Atom J[ ARU ]', 4X, 4 'd(I-J)', 3X, 'Del', /, 132('-')) 99990 FORMAT (/, 20X, 'Coordinates of Donor and Acceptor Atoms', 32X, 1 'Coordinates of D/A-Bonded Atom(s)', /, 20X, 39('='), 32X, 2 33('='), //, ' D/A I [ ARU ] X Y Z --', 3 ' D/A J [ ARU ] X Y Z', 3X, 4 'Atom K X Y Z I..J--K Angle', /, 132('-')) 99989 FORMAT (':: Too Many Interactions for Aggregate Analysis', /) 99988 FORMAT (/, I3, '-Membered ARU-Circuit') 99987 FORMAT (14F9.2) 99986 FORMAT (/, I3, '-Membered Infinite ARU-Chain (Translation [', 1 3I3, '])') 99985 FORMAT (/, 'Search for ARU-Circuits (Max =', I3, ') and', 1 ' Infinite ARU-Chains (Max =', I3, ')', /, 132('='), /) END SUBROUTINE PLA092 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER IDS1*1, IDS2*1, IYA*1, COPT*5 ITL = IPR(88) IF (ITL .EQ. 0) GOTO 250 MXLSP = NP2 CALL PLA040 (-1, 0, 0, 0, 0) MXRING = IPR(218) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-3) WRITE (LU7, 99998) MXRING ENDIF NETW = 0 L0 = 0 KAT = IPR(39) + IPR(24) + 1 JAT = KAT + 1 IAT = JAT + 1 I = 0 10 I = I + 1 IF (I .GT. ITL) GOTO 240 LFORW = 1 IF (L0 .LE. I) THEN L0 = 0 DO 40 J = I, ITL IF (IATC(J) .GT. 0) THEN L1 = NINT(XLS(1, J)) CALL GEN048 (-1, IFG(L1), 22, IA) IF (IA .EQ. 0) GOTO 50 IF (L0 .EQ. 0) L0 = J ENDIF 40 CONTINUE IF (L0 .EQ. 0) THEN GOTO 240 ELSE J = L0 ENDIF 50 CALL PLA040 (0, 0, 0, 0, 0) NETW = NETW + 1 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (7) WRITE (LU7, 99997) NETW WRITE (LU7, 99996) ENDIF J0 = J L0 = I XLSI3 = XLS(1, J0) XLSI4 = XLS(2, J0) JMX = 99 GOTO 90 ENDIF 70 IF (XLS(8, I) .LE. 0) THEN J0 = I LFORW = -1 XLS(8, I) = 1 XLSI3 = XLS(1, J0) XLSI4 = XLS(2, J0) JMX = 99 GOTO 90 ENDIF XLSI2 = XLS(2, I) XLSI3 = XLS(3, I) XLSI4 = XLS(4, I) M = NINT(XLS(1, I)) N = NINT(XLSI3) NH = NINT(XLS(10, I)) CALL PLA047 (XLAB(M), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 0, 0) CALL PLA047 (XLAB(N), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 0, 0) CALL PLA047 (XLAB(NH), NQ3, IDUM, JDUM, IPR(119), IGBL(55), 0, 0) CALL GEN048 (-7, JFG(M), 1, IDIS1) IPOPM = IPPR(IDIS1 + 1, 1) IF (IPOPM .LT. 1000) THEN IDS1 = '*' ELSE IDS1 = ' ' ENDIF CALL GEN048 (-7, JFG(N), 1, IDIS2) IPOPN = IPPR(IDIS2 + 1, 1) IF (IPOPN .LT. 1000) THEN IDS2 = '*' ELSE IDS2 = ' ' ENDIF MS1 = NINT(XLSI2 * PAR(42)) CALL GEN098 (MS1, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), IML) CALL PLA059 (M, KAT) CALL PLA059 (NH, IAT) MS2 = NINT(XLSI4 * PAR(42)) CALL GEN098 (MS2, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), IML) CALL PLA059 (N, JAT) CALL GEN048 (-1, IFG(M), 22, IA) IF (IA .EQ. 1) THEN IYA = 'A' ELSE IYA = ' ' ENDIF JMX = 4 90 K = 0 100 K = K + 1 IF (K .GT. ITL) GOTO 220 IF (IATC(K) .NE. 0) THEN IF (XLS(1, K) .EQ. XLSI3) THEN IHBD = 1 CALL PLA081 (10, XLS(2, K), 0.0, XLSK2) IF (IPR(2) .NE. 0) GOTO 250 CALL PLA081 (11, XLSK2, XLS(4, K), XLSK4) IF (IPR(2) .NE. 0) GOTO 250 CALL PLA081 (12, XLSI4, XLSK4, XLS4) IF (IPR(2) .NE. 0) GOTO 250 XLS2 = XLSI4 GOTO 140 ENDIF IF (K .NE. I) THEN IF (NINT(XLS(3, K)) .EQ. NINT(XLSI3)) THEN IHBD = -1 CALL PLA081 (13, XLS(4, K), 0.0, XLSK4) IF (IPR(2) .NE. 0) GOTO 250 CALL PLA081 (14, XLSK4, XLS(2, K), XLSK2) IF (IPR(2) .NE. 0) GOTO 250 CALL PLA081 (15, XLSI4, XLSK2, XLS2) IF (IPR(2) .NE. 0) GOTO 250 XLS4 = XLSI4 GOTO 140 ENDIF ENDIF ENDIF GOTO 100 140 XML = K + 0.555 L = L0 150 L = L - 1 IF (L .NE. 0) THEN IF (XLS(1, L) .NE. XLS(1, K)) GOTO 150 IF (XLS(3, L) .NE. XLS(3, K)) GOTO 150 ID1 = INT(XLS2) ID2 = INT(XLS(2, L)) IF (ID1 / 1000 .NE. ID2 / 1000) GOTO 150 IDF1 = ID1 - ID2 ID3 = INT(XLS4) ID4 = INT(XLS(4, L)) IF (ID3 / 1000 .NE. ID4 / 1000) GOTO 150 IDF2 = ID3 - ID4 IF (IDF1 .NE. IDF2) GOTO 150 XML = L + (IDF1 + 555) / 1000.0 IF (IDF1 .EQ. 0) THEN IF (LFORW .GT. 0) THEN IXPVJ = 82 ELSE IXPVJ = 32 ENDIF ELSE IXPVJ = 84 IDFX = IDF1 + 555 MD1 = IDFX / 100 IDFX = IDFX - MD1 * 100 MD1 = MD1 - 5 MD2 = IDFX / 10 MD3 = IDFX - MD2 * 10 - 5 MD2 = MD2 - 5 CALL PLA040 (1, MD1, MD2, MD3, 0) ENDIF GOTO 210 ENDIF IXPVJ = 32 IATCK = IATC(K) IATCL0 = 0 IF (IATCK .GE. 0) THEN IATCL0 = -1 IATCK = 0 ENDIF IATCTL = IATC(L0) IF (L0 .EQ. K) IATCTL = 0 IF (ITL .EQ. MXLSP) GOTO 100 ITL = ITL + 1 DO 180 J = 1, 10 XLS(J, ITL) = XLS(J, L0) 180 CONTINUE IATC(K) = IATCK IATC(ITL) = IATCTL IATC(L0) = IATCL0 XLS(1, L0) = XLS(1, K) XLS(3, L0) = XLS(3, K) XLS(2, L0) = XLS2 XLS(4, L0) = XLS4 XLS(5, L0) = 0.0 XLS(6, L0) = 0.0 XLS(7, L0) = 0.0 XLS(8, L0) = IHBD XLS(9, L0) = XLS(9, K) XLS(10, L0) = XLS(10, K) XML = L0 + 0.555 L0 = L0 + 1 IF (L0 .GT. ITL) GOTO 210 IF (IATCTL .EQ. 0) GOTO 200 IF (IATC(K) .NE. 0) GOTO 210 DO 190 J = 1, 10 XLS(J, K) = XLS(J, ITL) 190 CONTINUE IATC(K) = IATC(ITL) 200 ITL = ITL - 1 210 IF (JMX .GT. 7) GOTO 100 IF (IHBD .LT. 0) GOTO 100 JMX = JMX + 1 XLS(JMX, I) = XML IXPV(JMX) = IXPVJ GOTO 100 220 CONTINUE IF (JMX .EQ. 99) GOTO 70 YI = I + 0.555 JMX0 = JMX IF (JMX0 .GT. 7) JMX0 = 7 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99995) YI, IYA, IDS1, NQ1(1:6), XLSI2, 1 (XXO(KAT, J), J = 1, 3), IDS2, NQ2(1:6), XLS(4, I), 2 (XXO(JAT, J), J = 1, 3), 3 (XLS(J, I), CHAR(IXPV(J)), J = 5, JMX0) WRITE (LU7, 99993) NQ3, (XXO(IAT, J), J = 1, 3) ENDIF 230 CONTINUE IF (JMX0 .LT. JMX) THEN JMXB = JMX0 + 1 JMX0 = JMX IF (JMX0 .GT. JMXB + 2) JMX0 = JMXB + 2 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99994) (XLS(J, I), CHAR(IXPV(J)), J = JMXB, JMX0) ENDIF GOTO 230 ENDIF GOTO 10 240 CALL PLA040 (0, 0, 0, 0, 0) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (9) WRITE (LU7, 99999) ENDIF IPR(224) = ITL NRRING = 0 KAT = IPR(39) + IPR(24) NRTM = MXRING + 1 DO 390 J = 1, ITL JAT = NINT(XLS(1, J)) CALL GEN048 (-1, IFG(JAT), 22, IA) IF (IA .GT. 0) THEN JR(1) = J * 1000 + 555 ML = NINT(XLS(2, J) * PAR(42)) CALL GEN098 (ML, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), 1 MR1) JRAT = KAT + 1 CALL PLA059 (JAT, JRAT) NRT = 1 310 NCN(NRT) = 4 JRNRT = JR(NRT) / 1000 DO 320 I = 5, 7 IF(XLS(I, JRNRT) .NE. 0.0) NCN(NRT) = I 320 CONTINUE NRT = NRT + 1 JLN(NRT) = 4 330 JLN(NRT) = JLN(NRT) + 1 IF (JLN(NRT) .GT. NCN(NRT - 1)) THEN NRT = NRT - 1 IF (NRT .GT. 1) GOTO 330 GOTO 390 ENDIF NRTM1 = NRT - 1 NRTM2 = NRT - 2 JRNRTM1 = JR(NRTM1) / 1000 JRDIF = MOD(JR(NRTM1), 1000) IF (NRT .EQ. NRTM) NRTM2 = 1 JR(NRT) = NINT(XLS(JLN(NRT), JRNRTM1) * 1000 - 555 + JRDIF) J0 = JR(NRT) / 1000 JRDIF = MOD(JR(NRT), 1000) IF (J0 .EQ. 0) THEN WRITE (LU6, '(''>> J0=0 Problem in PLA092, Loop abort'')') GOTO 250 ENDIF ML = NINT((XLS(2, J0) - 555 + JRDIF) * PAR(42)) CALL GEN098 (ML, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), 1 MR1) JAT = NINT(XLS(1, J0)) JRAT = KAT + NRT IF (JAT .LE. 0) THEN WRITE (LU6, 99989) NRT, J0, JAT WRITE (LU7, 99989) NRT, J0, JAT GOTO 250 ENDIF CALL PLA059 (JAT, JRAT) IF (NRT .GT. 3) THEN DO 340 I = 2, NRTM2 IF (JR(NRT) .EQ. JR(I)) GOTO 330 340 CONTINUE ENDIF JRD = JR(NRT) / 1000 JRDT = JR(NRT) - JRD * 1000 IF (JRD .EQ. J) THEN IF (JRDT .EQ. 555) THEN COPT = 'Ring ' ELSE COPT = 'Chain' GOTO 355 ENDIF ELSE IF (JR(NRT) .LT. JR(1)) THEN GOTO 330 ELSE IF (JR(NRT) .GT. JR(1)) THEN GOTO 380 ENDIF ENDIF IF (NRTM1 .LT. 3) GOTO 330 355 IF (IGBL(63) .GT. 2) THEN CALL PLA269 (NRTM1 + 5) WRITE (LU7, 99992) NRTM1, COPT, JRDT ENDIF NRRING = NRRING + 1 IF (NRRING .GT. 15) THEN WRITE (LU6, 99988) GOTO 250 ENDIF WRITE (LU6, 99990) NRTM1, COPT, JRDT DO 370 K = 1, NRTM1 L = JR(K) / 1000 IDIF = JR(K) - L * 1000 M = NINT(XLS(1, L)) CALL PLA047 (XLAB(M), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) IF (IGBL(63) .GT. 2) WRITE (LU7, 99991) 1 JR(K) / 1000.0, NQ1(1:6), XLS(2, L) - 555 + IDIF, 2 (XXO(KAT + K, N), N = 1, 6), XLS(9, L) 370 CONTINUE IF (NRT .EQ. NRTM) NRT = NRT - 1 GOTO 330 380 IF (NRT .EQ. NRTM) GOTO 330 GOTO 310 ENDIF 390 CONTINUE 250 RETURN 99999 FORMAT (/, 44X, 30('-'), //, 'Hydrogen Bonds are Coded as', 1 ' N.IJK Where N = Sequence Number of Hydrogen Bond', 2 ' (NOTE: New Hbond Numbering system)', /, 3 40X, 'I - 5 = Nr of Translation Units Along A-Axis', /, 4 40X, 'J - 5 = Nr of Translation Units Along B-Axis', /, 5 40X, 'K - 5 = Nr of Translation Units Along C-Axis', //, 6 'Ring Closure Links are Indicated', 7 ' with ''R'' and Infinite Chain Links With ''T'' ') 99998 FORMAT ('Analysis of the (Cooperative) Hydrogen Bond Network', 1 ' (i.e. (In)Finite O-H...O-H...O-H.. Chains and/or Rings', 2 ' (Max =', I3, ' Membered))', /, 132('='), /) 99997 FORMAT (/, 57X, 12('='), /, 56('*'), ' NetworK =', I3, 1X, 1 62('*'), /, 57X, 12('='), /) 99996 FORMAT (2X, 'Code Acc Donor Atom', 10X, 'X', 7X, 'Y', 7X, 'Z', 1 7X, 'Acceptor Atom', 7X, 'X', 7X, 'Y', 7X, 'Z ', 2 'up to BondCode(s) of Forward Link(s)', /, 132('-')) 99995 FORMAT (F6.3, 2X, A, 2X, A, A, '[', F9.2,']', 3F8.4, 2X, A, 1 A, '[', F9.2, ']', 3F8.4, 3(F9.3, A)) 99994 FORMAT (96X, 3(F9.3, A)) 99993 FORMAT (12X, A, 10X, 3F8.4) 99992 FORMAT (/, 'Directed', I3, 1 '-Membered Cooperative O-H...O-H...O-H.. ', A, ', - Code', 2 I4, /, 90('='), /, 'BondCode', 2X, 'Donor Atom', 12X, 'X', 3 7X, 'Y', 7X, 'Z', 10X, 'XO', 7X, 'YO', 7X, 'ZO', 4X, 'D-H...A', 4 /, 90('=')) 99991 FORMAT (F7.3, 2X, A, '[', F9.2, ']', 2X, 3F8.4, 2X, 3F9.4, F9.2) 99990 FORMAT (':: Directed', I3, '-Membered O-H...O-H...O-H.. ', 1 A, ' - Code', I4) 99989 FORMAT (/, '=>> Problem with ring-search; aborted', 3I10, /) 99988 FORMAT (/, ':: Too many rings - Listing Aborted') END SUBROUTINE PLA093 (I, J, K, IDIRCT) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER DIRECT*4, IDS*1, FORMA*27, FORMB*78, FORMC*32 A3 = 0.0 SA3 = 0.0 ISA3 = 0 NDEC = 0 FORMA(1:27) = ' A,3F7.4,F8.2,''('',I3,'')'')' FORMB(1:39) = '(1X,A,''['',F9.2,''], '',3F7.4,2A,''['',F9.2,' FORMB(40:51) = '''], '',3F7.4,' FORMC(1:5) = '(89X,' IF (IDIRCT .GT. 0) THEN DIRECT = ' >> ' ELSE DIRECT = ' << ' ENDIF IDSORD = NINT(XLS(8, I)) CALL PLA047 (XLAB(J), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 0, 0) IF (IDSORD / 10 .EQ. 1) THEN IDS = '*' ELSE IDS = ' ' ENDIF NAMS(1, 1) = IDS//NQ1 CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 0, 0) IF (MOD(IDSORD, 10) .EQ. 1) THEN IDS = '*' ELSE IDS = ' ' ENDIF NAMS(1, 2) = IDS//NQ2 NMOL = NINT(XLS(4, I) * PAR(42)) CALL GEN098 (NMOL, PAR(42), MS1, MT1, MT2, MT3, MR1) DO 10 L = 1, 3 XJX(L) = XXO(K, L) 10 CONTINUE XJX(4) = MT1 XJX(5) = MT2 XJX(6) = MT3 CALL SGSM (ICL, MS1, XJX, LU7, 3, IERR) IF (IPR(39) + 2 .LE. NP1 - IPR(75)) THEN K0 = IPR(39) + 1 DO 20 L = 1, 3 XXO(K0, L) = XJX(L + 6) 20 CONTINUE IF (IPR(167) .EQ. 1) THEN WRITE (LU2, 99999) 1 NQ1(1:6), XLS(2, I), (XXO(J, L), L = 1, 3), 2 NQ2(1:6), XLS(4, I), (XXO(K0, L), L = 1, 3) ENDIF CALL PLA059 (K0, K0) NC = - NINT(CON(K, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .GT. 0) THEN DO 50 L = 1, NC M = NINT(CON(K, L)) IF (M .LE. NP1) THEN CALL PLA047 (XLAB(M), NQ3, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) CALL GEN048 (-7, JFG(M), 1, IDIS3) IPOPM = IPPR(IDIS3 + 1, 1) IF (IPOPM .LT. 1000) THEN IDS = '*' ELSE IDS = ' ' ENDIF NAMS(1, 3) = IDS//NQ3 DO 30 N = 1, 3 XJX(N) = XXO(M, N) 30 CONTINUE CALL SGSM (ICL, MS1, XJX, LU7, 3, IERR) N0 = IPR(39) + 2 DO 40 N = 1, 3 XXO(N0, N) = XJX(N + 6) 40 CONTINUE CALL PLA059 (N0, N0) CALL PLA053 (J, K0, N0, 0, A3, SA3, ISA3, NDEC, IER) IF (IER .NE. 0) GOTO 50 FORMA(15:15) = CHAR(ICHAR('0') + NDEC) IF (IGBL(63) .GT. 3) THEN IF (L .EQ. 1) THEN FORMB(52:78) = FORMA WRITE (PRBUF, FORMB) NAMS(1, 1), XLS(2, I), 1 (XXO(J, N), N = 1, 3), DIRECT, NAMS(1, 2), 2 XLS(4, I), (XXO(K0, N), N = 1, 3), NAMS(1, 3), 3 (XXO(N0, N), N = 1, 3), A3, ISA3 ELSE FORMC(6:32) = FORMA WRITE (PRBUF, FORMC) NAMS(1, 3), 1 (XXO(N0, N), N = 1, 3), A3, ISA3 ENDIF CALL PLA067 (LU7, PRBUF, 132, 1, 3) ENDIF ENDIF 50 CONTINUE ENDIF ENDIF RETURN 99999 FORMAT ('HBON ', A, '[', F8.2, ']', 3F7.4, 1 1X, A, '[', F8.2, ']', 3F7.4) END SUBROUTINE PLA094 (MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2 * NP23), VOID(NPVD) COMMON /PL40/ LHNT(4, 3, 5), NETH(64, 3), MXL DIMENSION IRCONT(63), JRCONT(63) IPR(30) = 1 IPR(18) = -1 IGBL(60) = 0 CALL PLA040 (-1, 0, 0, 0, 0) NATC = IPR(37) NSYM = IPR(48) NRES = IPR(75) IARU = NINT(PAR(42)) DO 10 I = 1, NATC IF (IATP(I) .NE. 1555) IGBL(60) = IGBL(60) + 1 10 CONTINUE IF (IPR(13) .GT. 1) THEN MMO = IPR(13) IF (MODE .LE. 0) GOTO 120 MMO = MMO + 1 20 MMO = MMO - 1 IF (MMO .GT. 1) THEN CALL GEN098 (MOL(MMO), PAR(42), IS1, IX1, IY1, IZ1, IR1) MM1 = MMO 30 MM1 = MM1 - 1 IF (MM1 .EQ. 0) GOTO 20 CALL GEN098 (MOL(MM1), PAR(42), IS2, IX2, IY2, IZ2, IR2) IF (IS1 .EQ. IS2) THEN IF (IR2 .EQ. 0) IR2 = IR1 IF (IR1 .EQ. IR2) THEN IX3 = IX2 - IX1 IY3 = IY2 - IY1 IZ3 = IZ2 - IZ1 IF (IABS(IX3) + IABS(IY3) + IABS(IZ3) .NE. 0) THEN CALL PLA040 (1, IX3, IY3, IZ3, IR2) ENDIF ENDIF ENDIF GOTO 30 ENDIF 40 CALL GEN022 (MOL, 2, IPR(13)) MMO = IPR(13) IF (IGBL(97) .NE. 0) THEN MMO = MMO + 1 50 MMO = MMO - 1 IF (MOL(MMO) / (1000 * IARU) .GT. NSYM) GOTO 50 IPR(101) = IPR(13) - MMO MM1 = MMO + 1 60 MM1 = MM1 - 1 IF (MM1 .GT. 1) THEN CALL GEN098 (MOL(MM1), PAR(42), IS1, IX1, IY1, IZ1, IR1) XM1 = MOL(MM1) / PAR(42) MM2 = MMO + 1 70 MM2 = MM2 - 1 IF (MM2 .EQ. 1) GOTO 60 CALL GEN098 (MOL(MM2), PAR(42), IS2, IX2, IY2, IZ2, IR2) XM2 = MOL(MM2) / PAR(42) IF (IR2 .NE. IR1) GOTO 70 CALL PLA081 (16, XM1, XM2, XM3) IF (IPR(2) .NE. 0) THEN IF (IPR(210) .NE. 1) THEN IPR(2) = 0 GOTO 90 ELSE WRITE (LU6, 99999) CALL PLA004 (0) ENDIF ENDIF MOLN = NINT(XM3 * PAR(42)) CALL GEN098 (MOLN, PAR(42), IS3, IX3, IY3, IZ3, IR3) IF (IS3 .EQ. 1) THEN IF (IABS(IX3) + IABS(IY3) + IABS(IZ3) .NE. 0) THEN MLTI(IR3) = -1 CALL PLA040 (1, IX3, IY3, IZ3, IR3) ENDIF GOTO 70 ENDIF DO 80 L = 1, MMO CALL GEN098 (MOL(L), PAR(42), IS4, IX4, IY4, IZ4, IR4) IF (L .EQ. 1) IR4 = IR3 IF (IR3 .EQ. IR4 .AND. IS3 .EQ. IS4) THEN IX5 = IX4 - IX3 IY5 = IY4 - IY3 IZ5 = IZ4 - IZ3 IF (IABS(IX5) + IABS(IY5) + IABS(IZ5) .NE. 0) THEN CALL PLA040 (1, IX5, IY5, IZ5, IR3) ENDIF GOTO 70 ENDIF 80 CONTINUE IF (IPR(13) + 3 .LT. NP11) THEN IPR(13) = IPR(13) + 1 MOL(IPR(13)) = MOLN IF (MLTI(IR3) .GT. 0) MLTI(IR3) = MLTI(IR3) + 1 GOTO 40 ELSE IPR(138) = IPR(138) + 1 ENDIF ENDIF ENDIF 90 DO 100 MM = 2, MMO M1 = MOD(MOL(MM), IARU) M2 = MOL(MM) / IARU MOL(MM) = M1 * 1000000 + M2 100 CONTINUE CALL GEN022 (MOL, 2, MMO) DO 110 MM = 2, MMO M1 = MOL(MM) / 1000000 M2 = MOD(MOL(MM), 1000000) MOL(MM) = M2 * IARU + M1 110 CONTINUE 120 DO 150 MM = 2, MMO CALL GEN098 (MOL(MM), PAR(42), IPR(54), ITR(1), ITR(2), 1 ITR(3), IR) IF (MM .GT. IPR(463) - 1) THEN IPR(2) = 54 GOTO 340 ENDIF MN = MM - 1 I = 0 130 I = I + 1 IF (I .LE. NATC) THEN CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .NE. IR) GOTO 130 CALL GEN048 (-7, JFG(I), 1, IPP) IPR(128) = IPPR(IPP + 1, 1) * IPPR(IPP + 1, 3) / NSYM IPR(127) = IPPR(IPP + 1, 1) IF (IPR(127) .LT. 1000) THEN IPR(98) = 1 ELSE IPR(98) = 0 ENDIF KAT = IPR(39) + 1 IF (KAT .GE. NP1) THEN IPR(2) = 1 GOTO 280 ENDIF CALL PLA059 (I, KAT) NAT = IPR(39) J = 0 140 J = J + 1 IF (J .LE. NAT) THEN CALL PLA050 (J, KAT, 0, 0, DIJ) IF (DIJ .LT. PAR(18)) GOTO 130 GOTO 140 ENDIF IPR(39) = IPR(39) + 1 IF (MN .GT. IPR(463) - 1) THEN IPR(2) = 54 GOTO 340 ENDIF XLAB(KAT) = XLAB(I) + MN IFG(KAT) = IFG(I) JFG(KAT) = JFG(I) CALL GEN048 (1, IFG(KAT), 5, 1) CON(KAT, NP4) = 0.0 IF (MODE .EQ. 1) THEN XM1 = (MOL(MM) - IR) / PAR(42) XM2 = IABS(IATP(I)) CALL PLA081 (17, XM1, XM2, XM3) IF (IPR(2) .NE. 0) GOTO 280 IATP(KAT) = INT(XM3) ENDIF GOTO 130 ENDIF 150 CONTINUE ENDIF DO 160 I = 1, NRES IRCONT(I) = (NP1 * 100 + I) * 1000 + MLTI(I) + 1 160 CONTINUE NAT = IPR(39) DO 210 I = 1, NAT CALL GEN048 (-6, IFG(I), 9, IRESI) IRCONT(IRESI) = IRCONT(IRESI) - 100000 IF (I .GT. 1) THEN N2 = I - 1 CALL GEN048 (-4, IFG(I), 15, NO1) IENI = IEN(NO1 + 1) DMX = RADR(NO1 + 1, 2) + PAR(1) IATPRI = IATPR(IENI) IPR(191) = ISIGN(1, IATPRI) NUMO = 0 NUMS = 0 IF (IENI .GE. 4 .AND. IENI .LE. 8) THEN DO 170 J = 1, NAT IF (I .NE. J) THEN CALL PLA050 (I, J, 0, 0, DIST) IF (DIST .LT. 2.1) THEN CALL GEN048 (-4, IFG(J), 15, IVAL) IVAL = IEN(IVAL + 1) IF (DIST .LT. 1.7) THEN IF (IVAL .EQ. 3) NUMO = NUMO + 1 ENDIF IF (IVAL .EQ. 6) NUMS = NUMS + 1 ENDIF ENDIF 170 CONTINUE IF (IENI .EQ. 4 .AND. NUMO .EQ. 3) NUMO = -1 IF (IENI .EQ. 5 .AND. NUMO .EQ. 4) NUMO = -1 IF (IENI .EQ. 6 .AND. NUMO .EQ. 4) NUMO = -1 IF (IENI .EQ. 8 .AND. (NUMO + NUMS) .EQ. 4) NUMO = -1 IF (NUMO .LT. 0) CALL GEN048 (1, IFG(I), 31, 1) ENDIF IF (IENI .EQ. 10 .OR. IENI .EQ. 11 .OR. 1 IENI .EQ. 30 .OR. IENI .EQ. 59 .OR. 2 IENI .EQ. 94) THEN IPR(157) = IENI ELSE IF (IATPRI .EQ. 5 .OR. IATPRI .EQ. 6) THEN IPR(157) = 1 ELSE IF (IPR(325) .EQ. 0 .AND. IATPRI .LT. 0) THEN IF (IENI .GE. 3 .AND. IENI .LE. 5) THEN IPR(157) = - IENI ELSE IPR(157) = -1 ENDIF ELSE IF (IPR(325) .EQ. -1 .AND. IATPRI .EQ. -1) THEN IF (IENI .EQ. 3 .OR. IENI .EQ. 4) THEN IPR(157) = - IENI ELSE IPR(157) = -1 ENDIF ELSE IPR(157) = 0 ENDIF CALL GEN048 (-7, JFG(I), 1, IDS1) IDS1 = IPPR(IDS1 + 1, 1) DO 200 J = 1, N2 CALL GEN048 (-6, IFG(J), 9, IRESJ) IF (IRESI .EQ. IRESJ) THEN CALL GEN048 (-4, IFG(J), 15, NO2) IENJ = IEN(NO2 + 1) IATPRJ = IATPR(IENJ) IF (IATPRJ .LE. 0 .OR. NUMO .GE. 0) THEN IF (IENJ .EQ. 10 .OR. IENJ .EQ. 11 .OR. 1 IENJ .EQ. 30 .OR. IENJ .EQ. 59 .OR. 2 IENJ .EQ. 94) THEN IPR(158) = IENJ ELSE IF (IATPRJ .EQ. 5 .OR. IATPRJ .EQ. 6) THEN IPR(158) = 1 ELSE IF (IPR(325) .EQ. 0 .AND. IATPRJ .LT. 0) THEN IF (IENJ .GE. 3 .AND. IENJ .LE. 5) THEN IPR(158) = - IENJ ELSE IPR(158) = -1 ENDIF ELSE IF (IPR(325) .EQ. -1 .AND. IATPRJ .EQ. -1) THEN IF (IENJ .EQ. 3 .OR. IENJ .EQ. 4) THEN IPR(158) = - IENJ ELSE IPR(158) = -1 ENDIF ELSE IPR(158) = 0 ENDIF IPR(192) = ISIGN(1, IATPRJ) TOLEA = 0 IF (IPR(156) .EQ. 0) THEN ITST = IPR(157) * IPR(158) IF (ITST .EQ. -30 .OR. ITST .EQ. -40 .OR. 1 ITST .EQ. -50 .OR. ITST .EQ. -120) THEN TOLEA = PAR(5) ELSE IF (ITST .EQ. -177 .OR. ITST .EQ. -236) THEN TOLEA = PAR(6) ELSE IF (ITST .EQ. -1 .OR. ITST .EQ. -3 .OR. 1 ITST .EQ. -4) THEN TOLEA = IGBL(97) * PAR(26) ENDIF IF (IPR(191) + IPR(192) .EQ. 2) TOLEA = PAR(27) ENDIF PAR(23) = DMX + RADR(NO2 + 1, 2) + TOLEA IF (IENI .EQ. 1 .OR. IENJ .EQ. 1) 1 PAR(23) = MIN (PAR(23), 2.0) IF (PLA260 (IENI, IENJ) .LT. 0.0) PAR(23) = 2.0 CALL GEN048 (-7, JFG(J), 1, IDS2) IDS2 = IPPR(IDS2 + 1, 1) IF (IDS1 .LT. 1000 .AND. IDS2 .LT. 1000) THEN IF (IDS1 .NE. IDS2) THEN IF (IABS(2 * IDS1 - IDS2) .GT. 1 .AND. 1 IABS(2 * IDS2 - IDS1) .GT. 1) GOTO 200 ENDIF IF (IPR(154) .EQ. 0) THEN MNI = NINT(MOD(XLAB(I), FLOAT(IPR(463)))) MNJ = NINT(MOD(XLAB(J), FLOAT(IPR(463)))) IF (IDS1 .EQ. 500 .AND. MNI .NE. MNJ) GOTO 200 ENDIF ENDIF CALL PLA050 (I, J, 0, 0, DSQ) IF (DSQ .LE. PAR(23) .AND. DSQ .GT. 0.1) THEN IF (IATPRJ .GT. 0) THEN IF (IENI .EQ. 4 .OR. IENI .EQ. 8 .OR. 1 IENI .EQ. 20) THEN NUMB = 0 DO 180 K = 1, NAT IF (K .NE. I .AND. K .NE. J) THEN CALL PLA050 (K, I, 0, 0, DIST) IF (IENI .EQ. 8) THEN IF (DIST .LT. 1.9) NUMB = NUMB + 1 ENDIF IF (DIST .LT. 1.7) THEN CALL PLA050 (J, I, K, 0, ANGLE) IF (ANGLE .LT. 45.0) GOTO 200 ENDIF ENDIF 180 CONTINUE IF (IENI .EQ. 8 .AND. NUMB .EQ. 4) GOTO 200 ENDIF ELSE IF (IATPRI .GT. 0) THEN IF (IENJ .EQ. 4 .OR. IENJ .EQ. 8 .OR. 1 IENJ .EQ. 20) THEN NUMB = 0 DO 190 K = 1, NAT IF (K .NE. I .AND. K .NE. J) THEN CALL PLA050 (K, J, 0, 0, DIST) IF (IENI .EQ. 8) THEN IF (DIST .LT. 1.9) NUMB = NUMB + 1 ENDIF IF (DIST .LT. 1.7) THEN CALL PLA050 (I, J, K, 0, ANGLE) IF (ANGLE .LT. 45.0) GOTO 200 ENDIF ENDIF 190 CONTINUE IF (IENJ .EQ. 8 .AND. NUMB .EQ. 4) GOTO 200 ENDIF ENDIF CALL PLA041 ( 1, I, KI, J) CALL PLA041 (-1, J, IVAL, I) IF (IVAL .LE. 0) CALL PLA041 (1, J, KJ, I) ENDIF ENDIF ENDIF 200 CONTINUE ENDIF 210 CONTINUE IF (NRES .GT. 1) THEN CALL GEN022 (IRCONT, 1, NRES) DO 220 I = 1, NRES MLTI(I) = MOD(IRCONT(I), 1000) - 1 IRCONT(I) = IRCONT(I) / 1000 J = MOD(IRCONT(I), 100) JRCONT(J) = I 220 CONTINUE NMOL = IPR(13) IF (NMOL .GT. 1) THEN DO 230 J = 2, NMOL CALL GEN098 (MOL(J), PAR(42), IS1, IX1, IY1, IZ1, IR1) MOL(J) = (IS1 * 1000 + IX1 * 100 + IY1 * 10 + IZ1 + 555) * 1 IARU + JRCONT(IR1) 230 CONTINUE ENDIF IF (MXL .GT. 0) THEN DO 240 J = 1, MXL JUNK = NETH(J, 1) NETH(J, 1) = JRCONT(JUNK) 240 CONTINUE ENDIF ENDIF I = 0 250 I = I + 1 IF (I .GT. NAT) GOTO 270 NTRNS(I) = IATP(I) IF (NRES .GT. 1) THEN CALL GEN048 (-6, IFG(I), 9, IVAL) CALL GEN048 ( 6, IFG(I), 9, JRCONT(IVAL)) ENDIF IF (IPR(72) .EQ. 1) THEN DO 260 J = 1, 3 FSDV = SQRT(XSD(I, J)) CALL GEN041 (XXO(I, J), FSDV, IDUM, IPR(183), NDEC, IPR(68)) XSD(I, J) = FSDV**2 260 CONTINUE CALL PLA059 (I, I) ENDIF GOTO 250 270 IPR(51) = IPR(13) 280 DO 300 IAT = 1, IPR(39) CALL GEN048 (-1, IFG(IAT), 23, IDAC) IF (IDAC .EQ. 1) THEN CALL GEN048 (-4, IFG(IAT), 15, NO1) IENI = IEN(NO1 + 1) IF (IENI .EQ. 4 .OR. IENI .EQ. 6) THEN NC = - NINT(CON(IAT, NP4)) IF (NC .GT. 0) THEN NRBO = 0 DO 290 JJ = 1, NC KK = NINT(CON(IAT, JJ)) CALL GEN048 (-4, IFG(KK), 15, NO2) IENK = IEN(NO2 + 1) IF (IENK .EQ. 3) NRBO = NRBO + 1 290 CONTINUE IF (NRBO .GT. 2) 1 CALL GEN048 (1, IFG(IAT), 23, 0) ENDIF ENDIF ENDIF 300 CONTINUE IPR(297) = NP1 * (NP4 + 15) IPR(298) = IPR(297) + NP1 * 21 IPR(131) = 0 IPR(133) = -1 310 IPR(133) = IPR(133) + 1 IF (IPR(133) .GT. 1) GOTO 330 IFIN = -2 320 CALL PLA038 (I, J, IFIN) IF (IFIN .EQ. 1) GOTO 310 CALL PLA100 (I, J, 2, 1.0) GOTO 320 330 IF (IPR(324) .EQ. 1 .AND. IPR(322) .EQ. 0 1 .AND. MODE .GE. 0) THEN CALL PLA030 (XXO, CON, JATC, IFG, JFG, IPPR, VOID(IPR(298) + 1)) C * GENERAL AUTO-RENUMBERING IF (IPR(501) .EQ. 1) CALL PLA228 ENDIF 340 RETURN 99999 FORMAT ('UNRESOLVABLE ARU-PROBLEM - SQUEEZE ABORTED') END SUBROUTINE PLA095 (NRING, NHEAD, MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP5=250,NP6=100,NP7=50,NP8=50, 1 NP9=118,NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31, 2 NPVD=40000000,NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125, 3 NP39=30,NP41=200,NP47=9,NPX = 2 * NP23 - 42 * NP5 - 6) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // Q(NP5), SPHI(NP5), PHI(NP5), KPHI(NP5), SSQ(NP5), 1 NPHI(NP5), ZP(NP5), TRA(NP5), DCSV(NP5), DCSB(NP5), DC2V(NP5), 2 DC2B(NP5), KZP(NP5), KTRA(NP5), STRA(NP5), KDCSV(NP5), NQ(NP5), 3 KDCSB(NP5), KDC2V(NP5), KDC2B(NP5), KQ(NP5), XYZR(NP5, 4), 4 RBO(NP5), KRBO(NP5), RANG(NP5), KRANG(NP5), HDCSV(NP5), 5 HDC2V(NP5), HDCSB(NP5), HDC2B(NP5), FCS(NP5), HFCS(NP5), 6 KFCS(NP5), FC2(NP5), HFC2(NP5), KFC2(NP5), NRANG(NP5), NTRA(NP5), 7 NRBO(NP5), XYZD(3), XYZDD(3), ISCR(NPX), VOID(NPVD) CHARACTER KDES*2, TXT1*5, TXT2*5, ACONF*1 CHARACTER FORMA*158, FORMB*158, FORMC*158, FORMD*158, FORME*158, 1 FORMF*158, FORMG*158, FORMH*158, FORMI*56, FORMK*73, FORML*37, 2 FORMP*106, FORMQ*63, FORMX*54, CHYB*3 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 IF (MODE .NE. 0) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT ENDIF NRAT = IPR(12) NMAX = IPR(39) RBOMN = 1000.0 RBOMX = 0.0 D = 0.0 SD = 0.0 SANG = 0.0 SRANG = 0.0 SRBO = 0.0 ANG = 0.0 NDEC = 0 ISANG = 0 ISD = 0 ION2 = 0 ION5 = 0 N = 0 IC2 = 0 ATERM = 0.0 BTERM = 0.0 SIGAK = 0.0 SIGBK = 0.0 FORMA(1:30) = '( ''Dev. (Ang)'',10X, ' FORMA(31:46) = 'F8.4,''('',I3,'')'',' FORMA(47:94) = FORMA(31:46)//FORMA(31:46)//FORMA(31:46) FORMA(95:158) = FORMA(47:94)//'F8.4,''('',I3,'')'')' FORMB(1:30) = '( ''Cs(I)-Asym-Par (Deg)'', ' FORMB(31:158) = FORMA(31:158) FORMC(1:30) = '( ''C2(I)-Asym-Par (Deg)'', ' FORMC(31:158) = FORMA(31:158) FORMD(1:30) = '( ''Ring Bond Angle(Deg)'', ' FORMD(31:158) = FORMA(31:158) FORME(1:30) = '( ''Tors(I-J) (Deg)'',10X, ' FORME(31:158) = FORMA(31:158) FORMF(1:30) = '( ''Cs(I-J)-Asym-Par (Deg) '',' FORMF(31:158) = FORMA(31:158) FORMG(1:30) = '( ''C2(I-J)-Asym-Par (Deg) '',' FORMG(31:158) = FORMA(31:158) FORMH(1:30) = '( ''Ring Bond Distance (Ang) '',' FORMH(31:158) = FORMA(31:158) FORMI(1:34) = '( A,'' - '',A,F10.4,''('',I3,'')'',5X,' FORMI(35:56) = 'F10.2,''('',I3,'')'',2X,A)' FORMK( 1:28) = '(''Q('',I1,'') ='',F9.4,''('',I5,' FORMK(29:58) = ''') Ang., Phi('',I1,'') ='',F8.2,' FORMK(59:73) = '''('',I5,'') Deg'')' FORML( 1:37) = FORMK(1:35)//''')' FORMP( 1:34) = '(''Puckering Amplitude (Q) ='',F8.4,' FORMP(35:63) = '''('',I5,'') Ang, Theta ='',F8.2,' FORMP(64:91) = '''('',I5,'') Deg, Phi ='',F8.2,' FORMP(92:106) = '''('',I5,'') Deg'')' FORMQ(1 :38) = '(''Angle between '',3A,'' and '',3A,'' = '',' FORMQ(39:63) = 'F10.0,''('',I3,'')'','' deg.'')' FORMX(1:38) = '(''Total Puckering Amplitude Q ='',F8.4,' FORMX(39:54) ='''('',I5,'') Ang.'')' CALL PLA055 KRC = NMAX + IPR(64) + 1 IATP(KRC) = NRING DO 10 K = 1, 3 XXO(KRC, K) = 0.0 XXO(KRC, K + 3) = 0.0 XSD(KRC, K) = 0.0 XSD(KRC, K + 3) = 0.0 XYZD(K) = 0.0 XYZDD(K) = 0.0 10 CONTINUE ISUGR = 0 IF (NRAT .EQ. 5) THEN DO 30 J = 1, NRAT CALL GEN048 (-4, IFG(JR(J)), 15, JDUM) JDUM = IEN(JDUM + 1) IF (JDUM .EQ. 2) THEN ISUGR = ISUGR + 1 ELSE IF (JDUM .EQ. 3) THEN ISUGR = ISUGR + 100 ENDIF 30 CONTINUE IF (ISUGR .EQ. 104) THEN ISUGL = 2 40 ISUGL = ISUGL - 1 IF (ISUGL .LT. 0) THEN ISUGR = 0 GOTO 70 ENDIF IC2 = 0 ION2 = 0 J2 = JR(2) NC = - NINT(CON(J2, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .LE. 3) THEN ISUGR = 0 GOTO 70 ENDIF DO 50 K = 1, NC M = NINT(CON(J2, K)) IF (M .NE. JR(1) .AND. M .NE. JR(3)) THEN CALL GEN048 (-4, IFG(M), 15, JDUM) JDUM = IEN(JDUM + 1) IF (JDUM .EQ. 3 .OR. JDUM .EQ. 4) THEN ION2 = 1 ENDIF IF (JDUM .EQ. 2) IC2 = 1 ENDIF 50 CONTINUE ION5 = 0 J5 = JR(5) NC = - NINT(CON(J5, NP4)) IF (NC .LT. 0) NC = NP4 IF (NC .LE. 3) THEN ISUGR = 0 GOTO 70 ENDIF DO 60 K = 1, NC M = NINT(CON(J5, K)) IF (M .NE. JR(1) .AND. M .NE. JR(4)) THEN CALL GEN048 (-4, IFG(M), 15, JDUM) JDUM = IEN(JDUM + 1) IF (JDUM .EQ. 3 .OR. JDUM .EQ. 4) ION5 = 1 IF (JDUM .EQ. 2) THEN ACONF = 'L' CALL PLA053 (M, JR(5), JR(1), JR(2), 1 ANG, SANG, ISANG, NDEC, IER) IF (IER .EQ. 0 .AND. ANG .GT. 0.0) ACONF = 'D' ENDIF ENDIF 60 CONTINUE IF (ION5 .EQ. 1) THEN CALL GEN014 (JR(2), JR(5)) CALL GEN014 (JR(3), JR(4)) GOTO 40 ENDIF ENDIF ENDIF 70 BAV = 0.0 BAVK = 0.0 SWT = 0.0 TAU = 0.0 TAUK = 0.0 STWT = 0.0 SMSIGJ = 0.0 NCARB = 0 NHAT = 0 DO 100 J = 1, NRAT I = JR(J) CALL GEN048 (-4, IFG(I), 15, JDUM) IF (IEN(JDUM + 1) .EQ. 2) THEN NCARB = NCARB + 1 NC = - NINT(CON(I, NP4)) IF (NC .LT. 0) NC = NP4 DO 80 K = 1, NC M = NINT(CON(I, K)) CALL GEN048 (-1, IFG(M), 7, IHAT) NHAT = NHAT + IHAT 80 CONTINUE ENDIF NRJ = NRAT + J I1 = JR(MOD(NRJ - 2, NRAT) + 1) I2 = JR(MOD(NRJ - 1, NRAT) + 1) I3 = JR(MOD(NRJ, NRAT) + 1) I4 = JR(MOD(NRJ + 1, NRAT) + 1) CALL PLA053 (I2, I3, 0, 0, RBO(J), SRBO, KRBO(J), NRBO(J), 1 IER) IF (IER .NE. 0) GOTO 290 IF (SRBO .LE. 0.0) THEN WBO = 1.0 ELSE WBO = 1.0 / SRBO**2 ENDIF RBOMX = MAX (RBOMX, RBO(J)) RBOMN = MIN (RBOMN, RBO(J)) BAV = BAV + WBO * RBO(J) BAVK = BAVK + WBO * RBO(J)**2 SWT = SWT + WBO CALL PLA053 (I1, I2, I3, 0, RANG(J), SRANG, KRANG(J), 1 NRANG(J), IER) IF (IER .NE. 0) GOTO 290 CALL PLA053 (I1, I2, I3, I4, TRA(J), STRA(J), KTRA(J), 1 NTRA(J), IER) IF (IER .NE. 0) GOTO 290 IF (STRA(J) .LE. 0) THEN WTAU = 1.0 ELSE WTAU = 1.0 / STRA(J)**2 ENDIF TAU = TAU + WTAU * ABS(TRA(J)) TAUK = TAUK + WTAU * TRA(J)**2 STWT = STWT + WTAU IP = JR(J) SIGJ = 0.0 DO 90 K = 1, 3 XYZR(J, K) = XXO(IP, K + 3) XXO(KRC, K) = XXO(KRC, K) + XXO(IP, K) XXO(KRC, K + 3) = XXO(KRC, K + 3) + XXO(IP, K + 3) XSD(KRC, K) = XSD(KRC, K) + XSD(IP, K) XSD(KRC, K + 3) = XSD(KRC, K + 3) + XSD(IP, K + 3) SIGJ = SIGJ + XSD(IP, K + 3) 90 CONTINUE XYZR(J, 4) = SIGJ / 3 SMSIGJ = SMSIGJ + SIGJ / 3 100 CONTINUE IF (NHEAD .EQ. 0 .AND. IGBL(63) .GT. 3) THEN NHEAD = 1 CALL PLA269 (-53) WRITE (LU7, 99970) NRNG = IPR(496) IF (MOD (NRNG, 100) .GT. 0) WRITE (LU7, 99969) NRNG = NRNG / 100 IF (MOD (NRNG, 100) .GT. 0) WRITE (LU7, 99968) NRNG = NRNG / 100 IF (MOD (NRNG, 100) .GT. 0) WRITE (LU7, 99967) NRNG = NRNG / 100 IF (NRNG .GT. 0) WRITE (LU7, 99966) '<', '>', '>', '>', 1 '>', '>' WRITE (LU7, 99965) WRITE (LU7, 99964) WRITE (LU7, 99982) ENDIF DO 110 K = 1, 3 XSD(KRC, K) = XSD(KRC, K) / (NRAT**2) XSD(KRC, K + 3) = XSD(KRC, K + 3)/ (NRAT**2) XXO(KRC, K) = XXO(KRC, K) / NRAT XXO(KRC, K + 3) = XXO(KRC, K + 3)/ NRAT 110 CONTINUE DO 120 K = 1, 6 VOID((KRC - 1) * (NP4 + 15) + K) = XXO(KRC, K) VOID((KRC - 1) * (NP4 + 15) + K + 6) = XSD(KRC, K) 120 CONTINUE BAV = BAV / SWT BAVK = BAVK / SWT KBAV = MIN (999, NINT(10000.0 / SQRT(SWT))) KBAVE = MIN (999, NINT(10000.0 * SQRT(ABS(BAVK 1 - BAV**2) / (NRAT - 1)))) TAU = TAU / STWT TAUK = TAUK / STWT KTAU = MIN (999, NINT(100.0 / SQRT(STWT))) KTAUE = MIN (999, NINT(100.0 * SQRT(ABS(TAUK - TAU**2) / 1 (NRAT - 1)))) SMSIGJ = SMSIGJ / (NRAT**2) DO 150 J = 1, NRAT DO 130 K = 1, 3 XYZR(J, K) = XYZR(J, K) - XXO(KRC, K + 3) 130 CONTINUE XYZR(J, 4) = XYZR(J, 4) + SMSIGJ SINF = SIN(GL(6) * (J - 1) / NRAT) COSF = COS(GL(6) * (J - 1) / NRAT) DO 140 L = 1, 3 XYZD(L) = XYZD(L) + XYZR(J, L) * SINF XYZDD(L) = XYZDD(L) + XYZR(J, L) * COSF 140 CONTINUE 150 CONTINUE CALL GEN008 (XYZD, XYZDD, XPV, 1) IE = 0 BQ = 0.0 SBQ = 0.0 DO 160 J = 1, NRAT ZP(J) = XPV(1) * XYZR(J, 1) + XPV(2) * XYZR(J, 2) 1 + XPV(3) * XYZR(J, 3) BQ = BQ + ZP(J)**2 SBQ = SBQ + ZP(J)**2 * XYZR(J, 4) 160 CONTINUE BQ = SQRT(BQ) IF (BQ .GT. 0.0) SBQ = SQRT(SBQ) / BQ DO 180 J = 1, NRAT DCSV(J) = 0.0 DC2V(J) = 0.0 DCSB(J) = 0.0 DC2B(J) = 0.0 FCS(J) = 0.0 FC2(J) = 0.0 HDCSV(J) = 0.0 HDC2V(J) = 0.0 HDCSB(J) = 0.0 HDC2B(J) = 0.0 HFCS(J) = 0.0 HFC2(J) = 0.0 NRD2 = NRAT / 2 NRD3 = (NRAT - 1) / 2 NRJ = NRAT + J DO 170 K = 1, NRD2 ITRA0 = MOD(NRJ + K - 1, NRAT) + 1 ITRA1 = MOD(NRJ + K - 2, NRAT) + 1 ITRA2 = MOD(NRJ - K - 1, NRAT) + 1 TRA0 = TRA(ITRA0) STRA0 = STRA(ITRA0)**2 TRA1 = TRA(ITRA1) STRA1 = STRA(ITRA1)**2 TRA2 = TRA(ITRA2) STRA2 = STRA(ITRA2)**2 ZP0 = ZP(ITRA0) SZP0 = SQRT(XYZR(ITRA0, 4)) ZP2 = ZP(ITRA2) SZP2 = SQRT(XYZR(ITRA2, 4)) T1P2S = (TRA1 + TRA2)**2 T1M2S = (TRA1 - TRA2)**2 T0P2S = (TRA0 + TRA2)**2 T0M2S = (TRA0 - TRA2)**2 Z0P2S = (ZP0 + ZP2)**2 Z0M2S = (ZP0 - ZP2)**2 DCSV(J) = DCSV(J) + T1P2S HDCSV(J) = HDCSV(J) + T1P2S * (STRA1 + STRA2) DC2V(J) = DC2V(J) + T1M2S HDC2V(J) = HDC2V(J) + T1M2S * (STRA1 + STRA2) IF (K .LE. NRD3) THEN FC2(J) = FC2(J) + Z0P2S HFC2(J) = HFC2(J) + Z0P2S * (SZP0 + SZP2) FCS(J) = FCS(J) + Z0M2S HFCS(J) = HFCS(J) + Z0M2S * (SZP0 + SZP2) DCSB(J) = DCSB(J) + T0P2S HDCSB(J) = HDCSB(J) + T0P2S * (STRA0 + STRA2) DC2B(J) = DC2B(J) + T0M2S HDC2B(J) = HDC2B(J) + T0M2S * (STRA0 + STRA2) ENDIF 170 CONTINUE IF (DCSV(J) .LT. 1E-5) THEN HDCSV(J) = 0 ELSE HDCSV(J) = SQRT(ABS(HDCSV(J)) / (NRD2 * DCSV(J))) ENDIF DCSV(J) = SQRT(ABS(DCSV(J)) / NRD2) IF (DC2V(J) .LT. 1E-5) THEN HDC2V(J) = 0 ELSE HDC2V(J) = SQRT(ABS(HDC2V(J)) / (NRD2 * DC2V(J))) ENDIF DC2V(J) = SQRT(ABS(DC2V(J)) / NRD2) IF (DCSB(J) .LT. 1E-5) THEN HDCSB(J) = 0 ELSE HDCSB(J) = SQRT(ABS(HDCSB(J)) / (NRD3 * DCSB(J))) ENDIF DCSB(J) = SQRT(ABS(DCSB(J)) / NRD3) IF (FCS(J) .LT. 1E-5) THEN HFCS(J) = 0.0 ELSE HFCS(J) = SQRT(ABS(HFCS(J)) / (NRD3 * FCS(J))) ENDIF FCS(J) = SQRT(ABS(FCS(J)) / NRD3) IF (FC2(J) .LT. 1E-5) THEN HFC2(J) = 0.0 ELSE HFC2(J) = SQRT(ABS(HFC2(J)) / (NRD3 * FC2(J))) ENDIF FC2(J) = SQRT(ABS(FC2(J)) / NRD3) IF (DC2B(J) .LT. 1E-5) THEN HDC2B(J) = 0.0 ELSE HDC2B(J) = SQRT(ABS(HDC2B(J)) / (NRD3 * DC2B(J))) ENDIF DC2B(J) = SQRT(ABS(DC2B(J)) / NRD3) 180 CONTINUE NSP2 = 0 NSP3 = 0 II1 = -7 190 II1 = II1 + 8 II2 = II1 + 7 IF (II2 .GT. NRAT) II2 = NRAT JJ = 0 DO 200 II = II1, II2 JJ = JJ + 1 IP = JR(II) CALL PLA047 (XLAB(IP), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 1 - IGBL(55)) NAMS(JJ, 1) = ' '//NQ1 CALL GEN048 (-4, IFG(IP), 24, IHYB) IF (IHYB .EQ. 1) THEN CHYB = 'sp' ELSE IF (IHYB .EQ. 2) THEN CHYB = 'sp2' NSP2 = NSP2 + 1 ELSE IF (IHYB .EQ. 3) THEN CHYB = 'sp3' NSP3 = NSP3 + 1 ELSE CHYB = ' ' ENDIF NAMS(JJ, 2) = CHYB 200 CONTINUE IF (II1 .NE. 1) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (5) WRITE (LU7, 99996) (NAMS(II, 1)(2:7), II = 1, JJ) WRITE (LU7, 99971) WRITE (LU7, 99962) (NAMS(II, 2)(1:3), II = 1, JJ) ENDIF ELSE IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-4) IF (ISUGR .EQ. 104) THEN CALL PLA269 (1) IF (IC2 .EQ. 1) THEN WRITE (LU7, 99991) ELSE WRITE (LU7, 99990) ENDIF ENDIF WRITE (PRBUF, 99997) NRAT, IPR(19) + NRING, 1 (NAMS(II, 1)(2:7), II = 1, JJ) WRITE (LU7, 99961) PRBUF IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 5 + IGBL(68), 2, 0.1, 1 VRT) ENDIF WRITE (LU7, 99971) WRITE (PRBUF, 99962) (NAMS(II, 2)(1:3), II = 1, JJ) WRITE (LU7, 99961) PRBUF IF (MODE .NE. 0) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF ENDIF ENDIF IF (IGBL(63) .GT. 2) THEN IFT = 18 I68 = IPR(68) DO 210 II = II1, II2 IFT = IFT + 16 SX = SQRT (XYZR(II, 4)) CALL GEN041 (ZP(II), SX, KZP(II), 4, NDEC, I68) FORMA(IFT:IFT) = CHAR(ICHAR('0') + NDEC) CALL GEN041 (DCSV(II), HDCSV(II), KDCSV(II), 2, NDEC, I68) FORMB(IFT:IFT) = CHAR(ICHAR('0') + NDEC) CALL GEN041 (DC2V(II), HDC2V(II), KDC2V(II), 2, NDEC, I68) FORMC(IFT:IFT) = CHAR(ICHAR('0') + NDEC) FORMD(IFT:IFT) = CHAR(ICHAR('0') + NRANG(II)) FORME(IFT:IFT) = CHAR(ICHAR('0') + NTRA(II)) CALL GEN041 (DCSB(II), HDCSB(II), KDCSB(II), 2, NDEC, I68) FORMF(IFT:IFT) = CHAR(ICHAR('0') + NDEC) CALL GEN041 (DC2B(II), HDC2B(II), KDC2B(II), 2, NDEC, I68) FORMG(IFT:IFT) = CHAR(ICHAR('0') + NDEC) FORMH(IFT:IFT) = CHAR(ICHAR('0') + NRBO(II)) 210 CONTINUE WRITE (PRBUF, FORMA) (ZP(II), KZP(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, FORMB) (DCSV(II), KDCSV(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, FORMC) (DC2V(II), KDC2V(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, FORMD) (RANG(II), KRANG(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (LU7, 99974) WRITE (PRBUF, FORME) (TRA(II), KTRA(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, FORMF) (DCSB(II), KDCSB(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, FORMG) (DC2B(II), KDC2B(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, FORMH) (RBO(II), KRBO(II), II = II1, II2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF ENDIF IF (II2 .LT. NRAT) GOTO 190 M = (NRAT - 1) / 2 IF (NRAT .EQ. 6 .AND. NCARB .EQ. 6) THEN IF (NSP2 .EQ. 6) THEN IF (NHAT .GT. 4) THEN NADD = 0 ELSE NADD = 3 ENDIF IF (TAU .LT. 5.0) THEN BAVDIF = BAV - 1.395 IF (BAVDIF .GT. 0.005) THEN WRITE (LU20, 99963) 330 + NADD, BAVDIF, BAV, 1 NAMS(1, 1) (2:8), NAMS(6, 1) (2:8) ELSE IF (BAVDIF .LT. -0.005) THEN WRITE (LU20, 99963) 331 + NADD, - BAVDIF, BAV, 1 NAMS(1, 1) (2:8), NAMS(6, 1) (2:8) ENDIF ENDIF IF (TAU .LT. 12.0) WRITE (LU20, 99963) 332 + NADD, 1 RBOMX - RBOMN, RBOMX - RBOMN, 2 NAMS(1, 1) (2:8), NAMS(6, 1) (2:8) ELSE IF (NSP3 .EQ. 6) THEN WRITE (LU20, 99963) 338, 60.0 - TAU, TAU, NAMS(1, 1)(2:8), 1 NAMS(6, 1)(2:8) ENDIF ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (5) WRITE (LU7, 99974) WRITE (PRBUF, 99960) BAV, KBAV, KBAVE WRITE (LU7, 99961) PRBUF IF (MODE .NE. 0) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (PRBUF, 99959) TAU, KTAU, KTAUE WRITE (LU7, 99961) PRBUF IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF WRITE (LU7, 99974) IF (NRAT .EQ. 4) THEN CALL PLA053 (JR(1), JR(2), JR(4), JR(3), TRA(5), STRA(5), 1 KTRA(5), NTRA(5), IER) IF (IER .EQ. 0) THEN FORMQ(43:43) = CHAR(ICHAR('0') + NTRA(5)) WRITE (PRBUF, FORMQ) 1 NAMS(1, 1)(2:7), NAMS(2, 1)(2:7), NAMS(4, 1)(2:7), 2 NAMS(2, 1)(2:7), NAMS(3, 1)(2:7), NAMS(4, 1)(2:7), 3 ABS(TRA(5)), KTRA(5) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF CALL PLA053 (JR(2), JR(3), JR(1), JR(4), TRA(6), STRA(6), 1 KTRA(6), NTRA(6), IER) IF (IER .EQ. 0) THEN FORMQ(43:43) = CHAR(ICHAR('0') + NTRA(6)) WRITE (PRBUF, FORMQ) 1 NAMS(1, 1)(2:7), NAMS(2, 1)(2:7), NAMS(3, 1)(2:7), 2 NAMS(1, 1)(2:7), NAMS(3, 1)(2:7), NAMS(4, 1)(2:7), 3 ABS(TRA(6)), KTRA(6) CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF WRITE (LU7, 99974) ENDIF ENDIF RMXMN = 100.0 * ABS (RBOMX - RBOMN) / BAV IF (TAU .GT. PAR(95)) THEN IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99992) ENDIF IF (NRAT / 2 .GT. M) IE = 1 IF (M .GT. 1) THEN DO 230 N = 2, M QS = 0.0 QC = 0.0 SQ = 0.0 CQ = 0.0 ATERM = 0 BTERM = 0 SIGAK = 0 SIGBK = 0 DO 220 J = 1, NRAT COSNF = COS(GL(6) * N * (J - 1) / NRAT) SINNF = SIN(GL(6) * N * (J - 1) / NRAT) QC = QC + ZP(J) * COSNF QS = QS + ZP(J) * SINNF SQ = SQ + XYZR(J, 4) * SINNF**2 CQ = CQ + XYZR(J, 4) * COSNF**2 IF (NRAT .EQ. 5) THEN ATERM = ATERM + TRA(J) * COSNF BTERM = BTERM + TRA(J) * SINNF SIGAK = SIGAK + (STRA(J) * COSNF)**2 SIGBK = SIGBK + (STRA(J) * SINNF)**2 ENDIF 220 CONTINUE QC = QC * SQRT (2.0 / NRAT) QS = -QS * SQRT (2.0 / NRAT) CQ = CQ * 2.0 / NRAT SQ = SQ * 2.0 / NRAT Q(N) = SQRT (QC**2 + QS**2) SNTH = 0.0 CSTH = 0.0 PHI(N) = 0.0 SPHI(N) = 0.0 SSQ(N) = 0.0 KQ(N) = 0 NQ(N) = 0 KPHI(N) = 0 NPHI(N) = 0 IF (Q(N) .GT. 0.0001) THEN SNTH = QS / Q(N) CSTH = QC / Q(N) IF (CSTH .GE. 0) THEN PHI(N) = ASIN(SNTH) * GL(5) IF (PHI(N) .LT. 0) PHI(N) = PHI(N) + 360.0 ELSE PHI(N) = ACOS(CSTH) * GL(5) IF (SNTH .LT. 0) PHI(N) = 360.0 - PHI(N) ENDIF SSQ(N) = SQRT(ABS(CQ * CSTH**2 + SQ * SNTH**2)) SPHI(N) = SQRT(ABS(CQ * SNTH**2 1 + SQ * CSTH**2)) * GL(5) / Q(N) ENDIF IF (IGBL(63) .GT. 2) THEN QQN = Q(N) CALL GEN041 (QQN, SSQ(N), KQ(N), 4, NQ(N), IPR(68)) CALL GEN041 (PHI(N), SPHI(N), KPHI(N), 4, NPHI(N), 1 IPR(68)) IF (N .LT. 10) THEN FORMK(8:8) = '1' FORMK(18:18) = '9' FORMK(46:46) = '1' FORMK(55:55) = '8' ELSE FORMK(8:8) = '2' FORMK(18:18) = '8' FORMK(46:46) = '2' FORMK(55:55) = '7' ENDIF FORMK(20:20) = CHAR(ICHAR('0') + NQ(N)) FORMK(57:57) = CHAR(ICHAR('0') + NPHI(N)) WRITE (PRBUF, FORMK) N, QQN , KQ(N), N, PHI(N), KPHI(N) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF ENDIF 230 CONTINUE ENDIF IF (IE .EQ. 1) THEN N2 = NRAT / 2 Q(N2) = 0.0 QN2 = 0 DO 240 J = 1, NRAT Q(N2) = (-1)**(J - 1) * ZP(J) + Q(N2) QN2 = QN2 + XYZR(J, 4) 240 CONTINUE SSQ(N2) = SQRT(ABS(QN2 / NRAT)) Q(N2) = Q(N2) * SQRT(1.0 / NRAT) IF (IGBL(63) .GT. 2) THEN QQN2 = Q(N2) CALL GEN041 (QQN2, SSQ(N2), KQ(N2), 4, NQ(N2), IPR(68)) IF (N2 .LT. 10) THEN FORML(8:8) = '1' FORML(18:18) = '9' ELSE FORML(8:8) = '2' FORML(18:18) = '8' ENDIF FORML(20:20) = CHAR(ICHAR('0') + NQ(N2)) WRITE (PRBUF, FORML) N2, QQN2, KQ(N2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF ENDIF AAZ = Q(N2) ELSE AAZ = 0 ENDIF IF (NRAT .GT. 6 .AND. IGBL(63) .GT. 2) THEN WRITE (LU7, 99974) CALL GEN041 (BQ, SBQ, KBQ, 4, NBQ, IPR(68)) FORMX(37:37) = CHAR(ICHAR('0') + NBQ) WRITE (PRBUF, FORMX) BQ, KBQ CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF IF (RMXMN .GT. PAR(328) .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (4) WRITE (LU7, 99994) RMXMN, PAR(328) IF (MODE .NE. 0) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF ENDIF IF (NRAT .EQ. 6) THEN IF (BQ .GT. PAR(12)) THEN CSTH = Q(N2) / BQ ELSE CSTH = 0.0 ENDIF IF (CSTH .GT. 1.0) CSTH = 1.0 IF (CSTH .LT. -1.0) CSTH = -1.0 TH = ACOS(CSTH) * GL(5) IF (BQ .GT. PAR(12)) THEN STH = SQRT(ABS((SSQ(2)**2 - SSQ(3)**2) 1 * CSTH**2 + SSQ(3)**2)) * GL(5) / BQ ELSE STH = 0.0 ENDIF IF (IGBL(63) .GT. 2) THEN CALL GEN041 (TH, STH, KTH, 2, NTH, IPR(68)) CALL GEN041 (BQ, SBQ, KBQ, 4, NBQ, IPR(68)) CALL PLA269 (1) WRITE (LU7, 99974) FORMP(33:33) = CHAR(ICHAR('0') + NBQ) FORMP(62:62) = CHAR(ICHAR('0') + NTH) FORMP(90:90) = CHAR(ICHAR('0') + NPHI(2)) WRITE (PRBUF, FORMP) BQ, KBQ, TH, KTH, PHI(2), KPHI(2) CALL PLA067 (LU7, PRBUF, 132, 1, 1) IF (MODE .NE. 0) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT) ENDIF IF (IGBL(63) .GT. 3) THEN CALL PLA269 (6) WRITE (LU7, 99981) ENDIF ENDIF ELSE IF (NRAT .EQ. 5) THEN ATERM = ATERM * 0.4 BTERM = -0.4 * BTERM SIGAK = 0.16 * SIGAK SIGBK = 0.16 * SIGBK TAUM = SQRT(ATERM**2 + BTERM**2) PPAR = ATAN2(BTERM, ATERM) STAUM = SQRT(SIGAK * ATERM**2 + SIGBK * BTERM**2) / TAUM SPPAR = SQRT(SIGBK * ATERM**2 + SIGAK * BTERM**2) / (TAUM**2) PPAR = PPAR * GL(5) SPPAR = SPPAR * GL(5) IPPAR = MIN (999, NINT(SPPAR * 10.0)) ITAUM = MIN (999, NINT(STAUM * 10.0)) IP = JR(1) CALL GEN048 (-4, IFG(IP), 15, NO1) IF (IEN(NO1 + 1) .EQ. 3) THEN PPAR = PPAR + 288.0 KK = 3 ELSE KK = 1 ENDIF IF (IGBL(63) .GT. 3) THEN CALL PLA269 (6) WRITE (LU7, 99980) ENDIF PPAR = MOD(PPAR + 360.0, 360.0) IF (IGBL(63) .GT. 2) THEN WRITE (LU7, 99999) WRITE (PRBUF, 99998) PPAR, IPPAR, TAUM, ITAUM, 1 NAMS(KK, 1)(2:7), NAMS(KK + 1, 1)(2:7) CALL GEN065 (LU7, PRBUF, 132, 1) WRITE (LU7, 99983) WRITE (LU7, 99989) 2.0 * PPAR CALL PLA269 (7) IF (ISUGR .EQ. 104 .AND. ION2 .EQ. 1) THEN CALL PLA269(5) WRITE (LU7, 99988) IBPAR = MOD(NINT(PPAR / 18.0), 20) IF (MOD(IBPAR, 2) .EQ. 0) THEN IBP = (IBPAR / 2) + 3 IBP1 = MOD (IBP + 4, 5) + 1 IBP2 = MOD (IBP , 5) + 1 TXT1 = '-exo ' TXT2 = '-endo' IF (MOD (IBP, 2) .EQ. 0) THEN TXT1 = '-endo' TXT2 = '-exo ' ENDIF WRITE (LU7, 99987) NAMS(IBP1, 1)(2:7), TXT1, 1 NAMS(IBP2, 1)(2:7), TXT2, ACONF ELSE IBP = (IBPAR - 1) / 2 + 3 IBP1 = MOD (IBP, 5) + 1 TXT1 = '-endo' IF (MOD (IBP, 2) .EQ. 0) TXT1 = '-exo ' WRITE (LU7, 99986) NAMS(IBP1, 1)(2:7), TXT1, ACONF ENDIF ELSE IBPAR = MOD(NINT(PHI(2) / 18.0), 20) CALL PLA269 (3) IF (MOD(IBPAR, 2) .EQ. 1) THEN IBP = (IBPAR / 2) IBP1 = MOD (IBP, 5) + 1 IBP2 = MOD (IBP + 1, 5) + 1 WRITE (LU7, 99985) NAMS(IBP1, 1)(2:7), 1 NAMS(IBP2, 1)(2:7) ELSE IBPAR = IBPAR / 2 IBP1 = MOD (IBPAR, 5) + 1 WRITE (LU7, 99984) NAMS(IBP1, 1)(2:7) ENDIF ENDIF WRITE (LU7, 99974) ENDIF ENDIF IF (IGBL(63) .GT. 2) CALL PLA218 (Q, PHI, AAZ, NRAT, LU7) ELSE IF (TAU .LT. PAR(95) .AND. 1 IGBL(63) .GT. 2) THEN CALL PLA269 (3) WRITE (LU7, 99974) WRITE (PRBUF, 99995) TAU, PAR(95) WRITE (LU7, 99961) PRBUF WRITE (LU7, 99974) IF (MODE .NE. 0) THEN VRT = VRT - 0.9 CALL GGIP20 (0.0, PRBUF, 132, 0.3, 2, 1, 0.1, VRT) ENDIF ENDIF ENDIF IF (TAU .LT. PAR(96)) CALL PLA031 IF (IPR(2) .NE. 0) IPR(2) = 0 IF (NRAT .EQ. 6 .AND. TAU .GT. PAR(97) .OR. 1 NRAT .EQ. 5 .AND. TAU .GT. PAR(94)) THEN NBND = 0 NHAT = 0 DO 280 L = 1, 2 DO 270 I = 1, NRAT J = JR(I) NC = - NINT(CON(J, NP4)) IF (NC .LT. 0) NC = NP4 CALL PLA047 (XLAB(J), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) DO 260 K = 1, NC M = NINT(CON(J, K)) N = I + NRAT - 2 IF (M .EQ. JR(MOD(I, NRAT) + 1) .OR. 1 M .EQ. JR(MOD(N, NRAT) + 1)) GOTO 260 CALL GEN048 (-1, IFG(M), 7, IHAT) IF (L + IHAT .EQ. 2) GOTO 260 NHAT = NHAT + IHAT CALL PLA047 (XLAB(M), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) CALL PLA053 (J, M, 0, 0, D, SD, ISD, NDEC, IER) IF (IER .EQ. 0) THEN FORMI(19:19) = CHAR(ICHAR('0') + NDEC) CALL PLA227 (J, M, VECN) ANG = XPV(1) * VECN(1) + XPV(2) * VECN(2) 1 + XPV(3) * VECN(3) ANG = ABS(ANG) IF (ANG .GT. 1.0) ANG = 1.0 IANG = 0 ANG = ACOS(ANG) * GL(5) A = 0 IF (D .NE. 0.0) THEN DO 250 KKK = 1, 3 A = A + XSPV(KKK)**2 + (VECN(KKK) * SD / D)**2 250 CONTINUE A = GL(5) * SQRT(A) ENDIF CALL GEN041 (ANG, A, IANG, 2, NDEC, IPR(68)) FORMI(39:39) = CHAR(ICHAR('0') + NDEC) KDES = 'Bi' IF (ANG .GT. 60) KDES = 'Eq' IF (ANG .LT. 30) KDES = 'Ax' NBND = NBND + 1 IF (IGBL(63) .GT. 2) THEN IF (NBND .EQ. 1) THEN CALL PLA269 (4) WRITE (LU7, 99972) ENDIF IF (NHAT .EQ. 1) THEN CALL PLA269 (1) WRITE (LU7, 99974) ENDIF WRITE (PRBUF, FORMI) NQ1, NQ2, D, ISD, ANG, IANG, 1 KDES CALL PLA067 (LU7, PRBUF, 132, 1, 1) ENDIF ENDIF 260 CONTINUE 270 CONTINUE 280 CONTINUE ENDIF 290 IF (MODE .NE. 0) THEN CALL GGIP (0.0, 0.0, 0.0, 3) CALL PLA013 (1, 1) ENDIF RETURN 99999 FORMAT (/, 'Pseudorotation Parameters P and Tau(M), (S.T.Rao, ', 1 'E.Westhof & M.Sundaralingam, Acta Cryst (1981), A37, 421-425)', 2 /, 132('-')) 99998 FORMAT ('P =', F6.1, '(', I3, ') Degree, Tau(M) =', F6.1, 1 '(', I3, ') Deg. for Reference Bond ', A, '--> ', A, 2 ' [add 144 Deg. to P for each shift to next Bond]') 99997 FORMAT (I3, '-Membered Ring (', I2, ')', 1 8(3X, A, ' -->')) 99996 FORMAT (132('-'), /, 5X, '(Continued)', 6X, 8(3X, A, ' -->')) 99995 FORMAT ('No C & P - Puckering Analysis since =', F5.1, 1 ' < ', F6.1, ' Deg.') 99994 FORMAT (/, ':: C & P - Puckering Analysis may be DUBIOUS since', 1' %(Bond Distance Range/Average) =', F6.1, ' > ', F5.1, ' %', /) 99992 FORMAT ('Cremer & Pople Puckering Parameters', 2X, 1 '[D. Cremer & J.A. Pople, J.Amer.Chem.Soc., 97, (1975), ', 2 '1354-1358]', /, 132('-')) 99991 FORMAT ('Hexafuranose Nomencl.', 4X, 'O5', 11X, 'C2', 11X, 1 'C3', 11X, 'C4', 11X, 'C5', 9X, 2 '(IUPAC-IUB: Eur.J.Biochem. (1983), 131, 5-7)') 99990 FORMAT ('Pentafuranose Nomencl.', 3X, 'O4', 11X, 'C1', 11X, 1 'C2', 11X, 'C3', 11X, 'C4', 9X, 2 '(IUPAC-IUB: Eur.J.Biochem. (1983), 131, 5-7)') 99989 FORMAT (/, 'Note: DELTA [Defined in Altona,C.,Geise,H.J.,', 1 'Romers,C.(1968). Tetrahedron, 24, 13-32] = 2 * P =', 2 F7.1, ' Deg.') 99988 FORMAT (/, 'Nearest Furanose Pucker Descriptor - (see W. Saenger', 1 ', Principles of Nucleic Acid Structure, 1983, pp19', 2 /, 132('-')) 99987 FORMAT ('Descriptor: T(wisted) ', 2A, ', ', 2A, 5X, 1 'Absolute Configuration: ', A) 99986 FORMAT ('Descriptor: E(nvelope) ', 2A, 5X, 1 'Absolute Configuration: ', A) 99985 FORMAT (/, 'Closest Pucker Descriptor: Twisted on ', 1 A, '-- ', A) 99984 FORMAT (/, 'Closest Pucker Descriptor: Envelope on ', A) 99983 FORMAT (84X, '[Ring-Sequence Change of Sense : P ---->>> - P]') 99982 FORMAT (//, '*** NOTE *** ', 1 '- For Ring Puckering Comparisons: Make Sure that the', 2 ' Absolute Configuration, Pivot Atom and Cyclic Sense Agree.', 3 /, 13X, '- The "RING AT1 AT2 AT3 ... ATn" Instruction Gives', 4 ' the User Explicit Choice of Pivot Atom (AT1) and Sense', 5 ' (AT2).', /, 13X, '- Use TRNS Instructions to Obtain the', 6 ' Required Absolute Configuration.',/, 13X, '- The Values of', 7 ' Theta and Phi [ = Phi(2)] Depend on the Abs. Conf. and the', 8 ' Choice of the First and Second Ring Atom.', /, 13X, 9 '- Alternatively, Appropriate Phase Shifts may be Applied', * ' to the Same Effect (see Below)', //, 13X, 'For Correct Usage', 1 ' of C&P Puckering Parameters see also: D. Cremer, ', 2 'Acta Cryst. (1984). B40, 498-500.', /) 99981 FORMAT (//, '*** NOTE *** ', 1 '- A Change of the Absolute Configuration Transforms Theta', 2 ' into 180 - Theta and Phi into 180 + Phi.', /, 13X, 3 '- A Cyclic Forward Shift of the Pivot Atom from At1 to At2', 4 ' Transforms Theta into 180 - Theta and Phi into Phi + 120.', 5 /, 13X, 6 '- A Change of the Sense Transforms Theta into 180 - Theta', 7 ' and Phi into 180 - Phi, and Vice Versa.'/) 99980 FORMAT (/, '*** NOTE *** ', 1 '- A Change of the Absolute Configuration Transforms Phi(2)', 2 ' into 180 + Phi(2).', /, 13X, 3 '- A Cyclic Forward Shift of the Pivot Atom From At1 to At2', 4 ' Transforms Phi(2) into Phi(2) + 144.', /, 13X, 5 '- A Change of the Sense Transforms Phi(2) into 180 - Phi(2).'/) 99974 FORMAT (1X) 99972 FORMAT (31X, 'Analysis of Ring Substituents', /, 31X, 1 29('='), /, 6X, 'Bond', 13X, 'Distance', 5X, 2 'Angle with C&P Plane Normal', /, 63('-')) 99971 FORMAT (132('-')) 99970 FORMAT ('Ring Puckering Analysis (Cremer & Pople) - (e.s.d.', 1 ' following Norrestam, Acta Cryst. (1981), A37, 764-765)', /, 2 132('-'), //, 19X, 'Symmetrical Forms', 70X, 'References', /, 3 19X, 17('-'), 70X, 10('-')) 99969 FORMAT ('5-Membered Rings : E : Envelope - Phi = k X 36', 24X, 1 'D. Cremer & J.A. Pople, J.Amer.Chem.Soc., 97,(1975),1354-1358', 2 /, 19X, 'T : Half Chair- Phi = k X 36 + 18 ', /) 99968 FORMAT ('6-Membered Rings : C : Chair - Th = 0.0', 37X, 1 'J.C.A. Boeyens, J.Cryst.Mol.Struct. 8,(1978),317-320', /, 19X, 2 'H : Half-Chair- Th = 50.8; Phi = k X 60 + 30', /, 19X, 3 'E : Envelope - Th = 54.7; Phi = k X 60', /, 19X, 4 'S : Screw-Boat- Th = 67.5; Phi = k X 60 + 30', /, 19X, 5 'B : Boat - Th = 90.0; Phi = k X 60', /, 19X, 6 'T : Twist-Boat- Th = 90.0; Phi = k X 60 + 30', /) 99967 FORMAT ('7-Membered Rings : C : Chair', 43X, 1 'I.K. Boessenkool et al., J.Cryst.Mol.Struct., 10,(1980),11-18', 2 /, 18X, 'TC : Twist-Chair', /, 19X, 'B : Boat', /, 18X, 3 'TB : Twist-Boat', /) 99966 FORMAT ('8-Membered Rings :CR : Crown - Q(2)=Q(3)=0, Q', 1 '(4)', 2A, '0', 28X, 'Palyulin et al., J.Mol.Struct.,70,(1981', 2 '),65-75'/19X,'B : Boat - Q(3)=Q(4)=0, Q(2)',A,' 0 Ph', 3 'i(2) = k X 90 + 45'/18X, 'BB : Boat-Boat - Q(3)=Q(4)=0, ', 4 ' Q(2)', A, ' 0 Phi(2) = k X 90 '/19X, 'C : Chair - ', 5 'Q(2)=Q(4)=0, Q(3)', A, ' 0 Phi(3) = k X 45 '/18X, 'LC : L', 6 'ong-Chair- Q(2)=Q(4)=0, Q(3)', A, ' 0 Phi(3) = k X 45', 7 ' + 22.5'/) 99965 FORMAT (/, 'Definitions (All Values Rounded on Esd)', /, 1 40('-'), /, 'Dev', 12X, '- Deviation of Atom I from ', 2 'Cremer&Pople Plane (Defined Differently from Least-Squares ', 3 'Plane)', /, 'Cs(I),C2(I) - Mirror Plane and 2-Axis Asym. ', 4 'Par. for Atom I (See Duax et al., Topics in Stereochemistry,', 5 'V-9, (1976) pp.271-383)', /, 'Cs(I-J),C2(I-J)- Asymmetry ', 6 'Parameters for Bond I-J', /, 'Tors(I-J) - Torsion Angle', 7 ' for Bond I-J', /) 99964 FORMAT (//, 1 'Descriptors for Torsion Angles', 40X, 'Descriptors for Ring ', 2 'Substituents (J.Appl.Cryst.,1983,16,431)', /, 30('-'), 40X, 3 62('-'), //, 'Torsion Angle Range', 5X, 'Full Descriptor', 5X, 4 'Short Descriptor', 10X, 'Angle Range of Subst. Full ', 5 'Descriptor', 5X, 'Short Descriptor', /, 60('-'), 10X, 60('-'), 5 /, 4X, '0 TO 30 Deg', 5X, '+ Syn-Periplanar', 7X, '+sp', 6 23X, '0 TO 30 Deg.', 12X, 'Axial', 12X, 'ax', /, 3X, 7 '30 to 90', 9X, '+ Syn-Clinal', 11X, '+sc', 22X, 8 '30 to 60', 11X, 'Bisectional', 12X, 'bi', /, 3X, 9 '90 to 150', 9X, '+ Anti-Clinal',11X, '+ac', 22X, * '60 to 90', 12X, 'Equatorial', 12X, 'eq', /, 2X, 1 '150 to 180', 9X, '+ Anti-Periplanar', 7X, '+ap', /, 4X, 2 '0 to -30', 9X, '- Syn-Periplanar', 7X, '-sp', /, 2X, 3 '-30 to -90', 9X, '- Syn-Clinal', 11X, '-sc', /, 2X, 4 '-90 to -150', 9X, '- Anti-Clinal', 11X, '-ac', /, 1X, 5 '-150 to -180', 9X, '- Anti-Periplanar', 7X, '-ap') 99963 FORMAT ('_', I3, 2F10.2, 2A) 99962 FORMAT (20X, 8(10X, A)) 99961 FORMAT (A) 99960 FORMAT ('Weighted Average Ring Bond Distance = ', F6.4, '(', 1 I3,',',I3,') Ang. - NOTE: 1st esd. Internal, 2nd esd External.') 99959 FORMAT ('Weighted Average Abs. Torsion Angl. = ', F6.2, '(', I3, 1 ',',I3,') Deg.',3X,'see: e.g. Domenicano et al., Acta Cryst.', 2 '(1975), B31, 221-234.') END SUBROUTINE PLA096 (MODE, NQ, D, CRIT) PARAMETER (NP50=100,NP51=100) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /BONDVAL/ VALENCE(1625) CHARACTER VALENCE*18 COMMON /PLC96/ NQ1, NQ2(NP50), NQ3, NQ4, VL(9), NQ5(NP51) COMMON /PL096/ DIST(NP50), NVAL(NP51), SUM, MAT, NVL, NAT CHARACTER NQ*7, NQ1*7, NQ2*7, NQ3*2, NQ4*2, NQ5*7, VL*2 IF (MODE .EQ. 0) THEN IF (D .LT. 0.0) THEN NAT = 0 SUM = 0.0 NB = 0 NE = 0 ELSE IF (NAT .LT. NP51) THEN NAT = NAT + 1 NQ1 = NQ NQ5(NAT) = NQ MAT = 0 CALL GEN105 (2, NQ(2:2), N) IF (N .LT. 0) THEN NQ3 = NQ(1:1) ELSE NQ3 = NQ(1:2) ENDIF NVL = 0 DO 20 J = 1, 1625 IF (VALENCE(J)(1:2) .EQ. NQ3) THEN IF (NVL .EQ. 0) THEN NVL = 1 VL(1) = ' '//VALENCE(J)(3:3) ELSE IF (VALENCE(J)(3:3) .NE. VL(NVL)(2:2)) THEN NVL = NVL + 1 VL(NVL) = ' '//VALENCE(J)(3:3) ENDIF ENDIF ELSE IF (VALENCE(J)(4:5) .EQ. NQ3) THEN IF (NVL .EQ. 0) THEN NVL = 1 VL(1) = VALENCE(J)(6:7) ELSE DO 10 I = 1, NVL IF (VALENCE(J)(6:7) .EQ. VL(I)) GOTO 20 10 CONTINUE NVL = NVL + 1 VL(NVL) = VALENCE(J)(6:7) ENDIF ENDIF 20 CONTINUE ENDIF ENDIF ELSE IF (MODE .EQ. 1) THEN IF (MAT .LT. NP50) THEN MAT = MAT + 1 NQ2(MAT) = NQ DIST(MAT) = D ENDIF ELSE IF (MODE .EQ. -1) THEN NP = 0 DIFM = 10.0 DO 60 K = 1, NVL READ (VL(K), 99995) IVL SUM = 0.0 DMX = 0.0 L = 0 IF (MAT .GT. 0) THEN DO 50 I = 1, MAT NTV = 0 IF (NAT .GT. 0) THEN DO 30 NT = 1, NAT CALL GEN039 (1, NQ5(NT), 1, 7, NB, NE) IF (NQ2(I)(1:NE) .EQ. NQ5(NT)(1:NE)) NTV = NVAL(NT) 30 CONTINUE ENDIF CALL GEN105 (2, NQ2(I)(2:2), N) IF (N .LT. 0) THEN NQ4 = NQ2(I)(1:1) ELSE NQ4 = NQ2(I)(1:2) ENDIF IF (NQ3 .EQ. NQ4) THEN IF (NQ3 .EQ. 'O ' .OR. 1 NQ3 .EQ. 'N ') GOTO 50 ENDIF IF (NQ3 .EQ. 'N ' .AND. NQ4 .EQ. 'C ') GOTO 50 DO 40 J = 1, 1625 IF (VL(K)(1:1) .NE. '-') THEN IF (VL(K)(2:2) .EQ. VALENCE(J)(3:3)) THEN IF (NQ3 .EQ. VALENCE(J)(1:2) .AND. 1 NQ4 .EQ. VALENCE(J)(4:5)) THEN READ (VALENCE(J), 99997) R, B BV = EXP ((R - DIST(I)) / B) IF (BV .GT. IVL * CRIT) THEN SUM = SUM + BV DIF = ABS(IVL - SUM) L = L + 1 IF (L .EQ. 1) THEN NP = NP + 1 IF (NP .EQ. 1) THEN CALL PLA269 (0) WRITE (LU7, 99998) ENDIF WRITE (LU7, 99996) VL(K) ENDIF DMX = MAX (DMX, DIST(I)) WRITE (LU7, 99999) L, NQ1, NQ2(I), DIST(I), 1 R, B, BV, SUM, DIF ENDIF GOTO 50 ENDIF ENDIF ELSE IF (VL(K) .EQ. VALENCE(J)(6:7)) THEN IF (NQ3 .EQ. VALENCE(J)(4:5) .AND. 1 NQ4 .EQ. VALENCE(J)(1:2)) THEN IF (NTV .GT. 0) THEN READ (VALENCE(J)(3:3), 99994) M IF (M .NE. NTV) GOTO 40 ENDIF READ (VALENCE(J), 99997) R, B BV = EXP ((R - DIST(I)) / B) IF (BV .GT. IABS(NTV) * CRIT) THEN SUM = SUM + BV DIF = ABS(IABS(IVL) - SUM) L = L + 1 IF (L .EQ. 1) THEN NP = NP + 1 IF (NP .EQ. 1) THEN CALL PLA269 (0) WRITE (LU7, 99998) ENDIF WRITE (LU7, 99996) VL(K), CRIT ENDIF DMX = MAX (DMX, DIST(I)) WRITE (LU7, 99999) L, NQ1, NQ2(I), DIST(I), 1 R, B, BV, SUM, DIF ENDIF GOTO 50 ENDIF ENDIF ENDIF 40 CONTINUE 50 CONTINUE IF (DIF .LT. DIFM) THEN NVAL(NAT) = IVL DIFM = DIF VSUM = SUM NSUM = L DMAX = DMX ENDIF ENDIF 60 CONTINUE IF (VSUM .GT. 0.0) THEN WRITE (LU6, 99993) NAT, NQ5(NAT), VSUM, DMAX, NSUM, 1 NVAL(NAT) CALL PLA269 (0) ENDIF ENDIF RETURN 99999 FORMAT (I2, 2X, 2A, F10.4, F7.4, F5.2, 3F6.3) 99998 FORMAT ('Bond Valence Analysis', /, 21('='), /, 1 'N.E. Brese & M. O''Keeffe', 2 ' (1991) Acta Cryst. B47, 192-197.', /, 3 'I.D. Brown (2002). The Chemical Bond in Inorganic', 4 ' Chemistry: The Bond Valence Model. ', 5 'Oxford University Press.') 99997 FORMAT (7X, F6.0, F4.0) 99996 FORMAT (/, 'Nr', 6X, 'Bond', 12X, 'Dist', 6X, 'R', 1 4X, 'B BVal Sum Diff', ' - Assume Valence = ', A, 2 ' -- Min. BondVal Contribution = ', 3 F5.2, ' * Cation Val.') 99995 FORMAT (I2) 99994 FORMAT (I1) 99993 FORMAT ('::', I5, 1X, A, F10.2, F10.4, I5, ' Valence = ', I3) END SUBROUTINE PLA098 (N1, N2, KB, DIS, SDIS, DIFF, IDS12, MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION KSM(71) CHARACTER NOTE*1, HYB1*1, HYB2*1, BNDPR*8 COMMON /BONDTYPE/ BNDTP(11) CHARACTER BNDTP*5 TDIS = 0.0 BNDPX = 0.0 IF (MODE .GT. 0) THEN CALL GEN048 (-4, IFG(N1), 24, IHYB1) CALL GEN048 (-4, IFG(N2), 24, IHYB2) CALL GEN048 (-4, IFG(N1), 15, NO1) CALL GEN048 (-4, IFG(N2), 15, NO2) IF (IHYB1 .EQ. 0) IHYB2 = 0 IF (IHYB2 .EQ. 0) IHYB1 = 0 NOA = NO1 * 10 + IHYB1 NOB = NO2 * 10 + IHYB2 IEN1 = IEN(NO1 + 1) IEN2 = IEN(NO2 + 1) IAT1 = IATNR(IEN1) IAT2 = IATNR(IEN2) IF (IAT1 .LT. IAT2) THEN CALL GEN014 (NOA, NOB) CALL GEN014 (IEN1, IEN2) CALL GEN014 (IAT1, IAT2) ENDIF IF (IAT2 .GT. 1) IPR(315) = IPR(315) + 1 IF (IDS12 .NE. 2000) GOTO 5000 IEN12 = IEN1 * 1000 + IEN2 IF (IHYB1 .LT. IHYB2) CALL GEN014 (IHYB1, IHYB2) INR = 0 IF (IEN12 .EQ. 2001) THEN TDIS = 0.96 INR = 350 ELSE IF (IEN12 .EQ. 4001) THEN TDIS = 0.87 INR = 352 ELSE IF (IEN12 .EQ. 3001) THEN NC = - NINT(CON (N2, NP4)) IF (NC .EQ. 1) THEN TDIS = 0.82 INR = 354 ENDIF ELSE IF (IEN12 .EQ. 2002) THEN IF (SDIS .GT. 0.0001) THEN IPR(317) = IPR(317) + 1 PAR(318) = PAR(318) + SDIS ENDIF IF (IPR(483) .GT. 0 .AND. IPR(484) .GT. 0) THEN IF (IHYB1 .EQ. 3) THEN IF (IHYB2 .EQ. 3) THEN TDIS = 1.54 INR = 360 ELSE IF (IHYB2 .EQ. 2) THEN TDIS = 1.52 INR = 362 ELSE IF (IHYB2 .EQ. 1) THEN TDIS = 1.46 INR = 364 ELSE TDIS = 1.50 INR = 366 ENDIF ELSE IF (IHYB1 .EQ. 2) THEN IF (IHYB2 .EQ. 2) THEN TDIS = 1.34 INR = 368 ELSE IF (IHYB2 .EQ. 1) THEN TDIS = 1.31 INR = 370 ELSE TDIS = 1.50 INR = 366 ENDIF ELSE IF (IHYB1 .EQ. 1) THEN IF (IHYB2 .EQ. 1) THEN TDIS = 1.25 INR = 372 ELSE TDIS = 1.50 INR = 366 ENDIF ELSE TDIS = 1.50 INR = 366 ENDIF ENDIF ELSE IF (IEN12 .EQ. 4004) THEN IF (DIS .GT. 1.45) THEN WRITE (LU20, 99993) 1 374, DIS - 1.45, DIS, NAMS(KB, 1)(1:7), NAMS(KB, 2)(1:7) ENDIF GOTO 145 ENDIF IF (INR .NE. 0) THEN DIFF = ABS(DIS - TDIS) IF (DIFF .GT. 0.001) THEN IF (DIS .GT. TDIS) INR = INR + 1 WRITE (LU20, 99993) 1 INR, DIFF, DIS, NAMS(KB, 1)(1:7), NAMS(KB, 2)(1:7) ENDIF ENDIF 145 NO12 = NOA * 1000 + NOB IM = IPR(47) IF (IM .GT. 0) THEN DO 150 I = 1, IM IF (NO12 .EQ. KBO(I, 1)) THEN IF (KBO(I, 2) .EQ. 0) BOK(I, 1) = 9999.0 KBO(I, 2) = KBO(I, 2) + 1 BOK(I, 3) = BOK(I, 3) + DIS IF (SDIS .GT. 0.0) THEN KBO(I, 5) = KBO(I, 5) + 1 BOK(I, 6) = BOK(I, 6) + SDIS ENDIF IF (DIS .LT. BOK(I, 1)) BOK(I, 1) = DIS IF (DIS .GT. BOK(I, 2)) BOK(I, 2) = DIS RETURN ENDIF 150 CONTINUE ENDIF IF (IPR(47) .LT. NP8) THEN IPR(47) = IPR(47) + 1 I = IPR(47) KBO(I, 1) = NO12 BOK(I, 1) = DIS BOK(I, 2) = DIS BOK(I, 3) = DIS KBO(I, 2) = 1 IF (SDIS .GT. 0.0) THEN KBO(I, 5) = 1 BOK(I, 6) = SDIS ENDIF ENDIF ELSE IF (MODE .LT. 0) THEN IF (IPR(6) .NE. 0) THEN IF (IPR(317) .GT. 0) THEN PAR(318) = PAR(318) / IPR(317) I318 = NINT(PAR(318) * 1000) IF (IPR(22) .LT. 20) THEN IBPR = 340 ELSE IF (IPR(22) .GE. 40) THEN IBPR = 342 ELSE IBPR = 341 ENDIF WRITE (LU20, 99994) IBPR, I318, I318 ENDIF IM = IPR(47) IF (IGBL(63) .GT. 2) THEN CALL PLA269 (-6) WRITE (LU7, 99999) ENDIF DO 110 I = 1, IM DO 20 J = 1, 71 KSM(J) = 0 20 CONTINUE IPR(133) = -1 30 IPR(133) = IPR(133) + 1 IF (IPR(133) .GT. 1) GOTO 60 IFIN = -1 40 CALL PLA038 (I0, J0, IFIN) IF (IFIN .EQ. 1) GOTO 30 CALL GEN048 (-4, IFG(I0), 24, IHYB1) CALL GEN048 (-4, IFG(J0), 24, IHYB2) CALL GEN048 (-4, IFG(I0), 15, NO1) CALL GEN048 (-4, IFG(J0), 15, NO2) IF (IHYB1 .EQ. 0) IHYB2 = 0 IF (IHYB2 .EQ. 0) IHYB1 = 0 NOA = NO1 * 10 + IHYB1 NOB = NO2 * 10 + IHYB2 IF (IATNR(IEN(NO1 + 1)) .LT. IATNR(IEN(NO2 + 1))) THEN CALL GEN014 (NOA, NOB) ENDIF NO12 = NOA * 1000 + NOB IF (KBO(I, 1) .NE. NO12) GOTO 40 CALL PLA050 (I0, J0, 0, 0, DIST) NDIS = MIN (71, NINT(DIST * 20 + 1)) KSM(NDIS) = KSM(NDIS) + 1 GOTO 40 60 DO 100 J = 1, 71 IDMJ = KSM(J) IF (IDMJ .LE. 0) THEN IDM(J:J) = '.' ELSE IF (IDMJ .LE. 9) THEN IDM(J:J) = CHAR(ICHAR('0') + IDMJ) ELSE IF (IDMJ .LE. 35) THEN IDM(J:J) = CHAR(ICHAR('Z') - 35 + IDMJ) ELSE IDM(J:J) = '*' ENDIF 100 CONTINUE HYB1 = ' ' HYB2 = ' ' K = KBO(I, 1) / 1000 L = KBO(I, 1) - K * 1000 IHYB1 = MOD (K, 10) IHYB2 = MOD (L, 10) K = K / 10 + 1 L = L / 10 + 1 IF (IHYB1 .NE. 0) THEN IF (IEN(K) .EQ. 2 .OR. IEN(K) .EQ. 4) 1 HYB1 = CHAR(IHYB1 + 49) IF (IEN(L) .EQ. 2 .OR. IEN(K) .EQ. 4) 1 HYB2 = CHAR(IHYB2 + 49) ENDIF SUMR = RADR(K, 2) + RADR(L, 2) IF (KBO(I, 2) .GT. 0) BOK(I, 3) = BOK(I, 3) / KBO(I, 2) IF (KBO(I, 5) .GT. 0) THEN BOK(I, 6) = BOK(I, 6) / KBO(I, 5) WRITE (BNDPR, '(F8.4)') BOK(I, 6) ELSE CALL GEN038 (BNDPR, 1, 8) ENDIF IF (BOK(I, 1) + 0.4 .LT. SUMR .AND. KBO(I, 2) .GT. 0) 1 THEN NOTE = 'S' ELSE NOTE = ' ' ENDIF IF (KBO(I, 5) .GT. 0) THEN IF (LMT(L, 1) .NE. ' H' .AND. LMT(L, 1) .NE. ' D' .AND. 1 LMT(L, 1) .NE. 'Hw') THEN BNDTP(1) = LMT(K, 1)//'-'//LMT(L, 1) BNDPX = BOK(I, 6) ENDIF ENDIF IF (IGBL(63) .GT. 2) THEN CALL PLA269 (2) WRITE (LU7, 99998) LMT(K, 1), HYB1, LMT(L, 1), HYB2, 1 KBO(I, 2), BNDPR, (BOK(I, J), J = 1, 3), SUMR, NOTE, 2 IDM(1:71) ENDIF 110 CONTINUE IF (PAR(318) .GT. 0) THEN BNDTP(1) = ' C-C' ELSE PAR(318) = BNDPX ENDIF IF (IGBL(63) .GT. 3) THEN CALL PLA269 (22) WRITE (LU7, 99997) WRITE (LU7, 99996) ENDIF ENDIF IF (IPR(315) .NE. 0) THEN RATIO = FLOAT(IPR(316)) / FLOAT(IPR(315)) IF (RATIO .LT. 1.0 .AND. IGBL(8) .EQ. 3) 1 WRITE (LU20, 99995) '_763', 1.0 - RATIO, RATIO IF (RATIO .GT. 1.0) 1 WRITE (LU20, 99995) '_764', RATIO - 1.0, RATIO ENDIF ELSE IPR(47) = 0 IPR(317) = 0 PAR(318) = 0 DO 140 I = 1, NP8 DO 120 J = 1, 5 KBO(I, J) = 0 120 CONTINUE DO 130 J = 1, 6 BOK(I, J) = 0.0 130 CONTINUE 140 CONTINUE ENDIF 5000 RETURN 99999 FORMAT ('Statistics of Bond Length per Bond Type (NOTE: ', 1 'A Indicates 10 Occurrences, B Indicates 11, Etc. and', 2 ' * more than 35)', /, 132('='), //, 'Bond Type Nr', 4X, 3 'B.P.', 2X, 'd(min)', 2X, 'd(max)', 3X, 'd(av) Sumrad Note', 4 2X, '0.0', 7X, '0.5', 7X, '1.0', 7X, '1.5', 7X, '2.0', 7X, 5 '2.5', 7X, '3.0 Angstrom', /, 58('-'), 3X, 35('I-'), 'I') 99998 FORMAT (2A, ' -- ', 2A, I4, A, 3F8.4, F7.2, 4X, A, 3X, A, /) 99997 FORMAT (//, 'Selected Bond Lengths (Angstrom) - ', 1 'see M.F.C. Ladd & R.A. Palmer, ', 2 'Structure Determination by X-Ray Crystallography (1985)', /, 3 132('='), //, 49X, 'Formal single bonds', /, 49X, 19('-'), /, 4 'C4-C4 1.54 C4-C3 1.52 C4-C2 1.46 C4-N3 1.47 C4-N2 ', 5 '1.47 C4-O2 1.43 C3-C3 1.46 C3-C2 1.45 C3-N3 1.40 ', 6 'C3-N2 1.40', /, 'C3-O2 1.36 C2-C2 1.38 C2-N3 1.33 C2-N2', 7 ' 1.33 C2-O2 1.36 N3-N3 1.45 N3-N2 1.45 N3-O2 1.36 ', 8 'N2-N2 1.45 N2-O2 1.41', //, 49X, 'Formal double bonds', /, 9 49X, 19('-'), /, 'C3-C3 1.34 C3-C2 1.31 C3-N2 1.32 C3-O1', * ' 1.22 C2-C2 1.28 C2-N2 1.32 C2-O1 1.16 N3-O1 1.24 ', 1 'N2-N2 1.25 N2-O1 1.21', /) 99996 FORMAT ('Formal triple bonds', 17X, 1 'Aromatic bonds', /, 19('-'), 17X, 14('-'), /, 'C2-C2 1.20', 2 ' C2-N1 1.16 C3-C3 1.40 C2-N2 1.34 N2-N2 1.35', //, 3 'The notation in the table indicates the connectivity of the', 4 ' atoms', //, 5 'For more detailed standard bond distance tabulations see: ', 6 'J. Chem. Soc. Perkin II, (1987), S1-S19;', /, 7 'J. Chem. Soc. Dalton Trans. (1989), S1 - S83 or ', 8 'International Tables C, (1992), 707-791.') 99995 FORMAT (A, 2F10.2) 99994 FORMAT ('_', I3, 2I10) 99993 FORMAT ('_', I3, 2F10.2, 2A) END SUBROUTINE PLA099 (MODE, IAT, NANG, ANG1, ANG2, ANG3, NCEFF, 1 IMET, IHYB, CHYB, NATH, NOTE1) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) CHARACTER CHYB*3, NOTE1*1 NMET = 0 NATX = IPR(37) NAT = IPR(39) CALL GEN048 (-4, IFG(IAT), 15, NO1) NO1 = NO1 + 1 CALL GEN048 (-7, JFG(IAT), 1, IPPI0) IPPI0 = IPPR(IPPI0 + 1, 1) NC = - NINT(CON(IAT, NP4)) IF (NC .LT. 0) THEN NC = NP4 CALL GEN048 (-1, IFG(IAT), 8, IVAL) IF (IVAL .GT. 0) NC = NC + IPR(76) ENDIF MSKP = 0 10 NANG = 0 ANG3 = 0.0 ANG2 = 0.0 EFNC = 0.0 ENCH = 0.0 DISM = 99.0 IF (NC .GT. 0) THEN ANG1 = 9999.0 NMET = 0 DO 30 J = 1, NC IF (J .LE. NP4) THEN J0 = NINT(CON(IAT, J)) ELSE IF (IBON(J - NP4, 1) .NE. IAT) GOTO 30 J0 = IBON(J - NP4, 2) ENDIF CALL GEN048 (-1, IFG(J0), 7, IHAT) IF (IHAT .EQ. 0) THEN CALL PLA050 (J0, IAT, 0, 0, DIS0) DISM = MIN (DISM, DIS0) ENDIF CALL GEN048 (-1, IFG(J0), 19, IVL1) IF (MSKP * IVL1 .EQ. 1) GOTO 30 NMET = NMET + IVL1 CALL GEN048 (-7, JFG(J0), 1, IPPJ0) IPPJ0 = IPPR(IPPJ0 + 1, 1) EFNC = EFNC + FLOAT(IPPJ0) / FLOAT(IPPI0) CALL GEN048 (-1, IFG(J0), 7, IHAT) IF (IHAT .EQ. 1) ENCH = ENCH + FLOAT(IPPJ0) / FLOAT(IPPI0) IF (J .LT. NC) THEN K1 = J + 1 DO 20 K = K1, NC IF (K .LE. NP4) THEN K0 = NINT(CON(IAT, K)) ELSE IF (IBON(K - NP4, 1) .NE. K) GOTO 20 K0 = IBON(K - NP4, 2) ENDIF CALL GEN048 (-7, JFG(K0), 1, IPPK0) IPPK0 = IPPR(IPPK0 + 1, 1) IF (IPPJ0 .GT. 0 .AND. IPPK0 .GT. 0) THEN IF (IPPJ0 .EQ. IPPK0) THEN CALL PLA050 (J0, IAT, K0, 0, ANG) IF (IEN(NO1) .EQ. 2 .AND. IVL1 .EQ. 1 .AND. 1 ANG .LE. 85) THEN MSKP = 1 GOTO 10 ENDIF NANG = NANG + 1 ANG2 = MAX (ANG2, ANG) ANG1 = MIN (ANG1, ANG) ANG3 = ANG3 + ANG ENDIF ENDIF 20 CONTINUE ENDIF 30 CONTINUE IF (NANG .GT. 0) THEN ANG3 = ANG3 / NANG ELSE ANG1 = 0.0 ENDIF ELSE ANG1 = 0.0 ENDIF IHYB = 0 CHYB = ' ' IF (MODE .EQ. 0) THEN NCEFF = NC ELSE NCEFF = NINT(EFNC) ENDIF IF (IAT .LE. NAT) THEN IF (IEN(NO1) .EQ. 2 .OR. IEN(NO1) .EQ. 85) THEN IF (ANG1 .LT. 35.0) NOTE1 = 'A' IF (NCEFF .EQ. 4) THEN IF (ABS(ANG3 - 108.0) .LT. 2.5) THEN IF (NMET .EQ. 2) THEN IHYB = 2 ELSE IHYB = 3 ENDIF ENDIF IF (ANG2 .GT. 125.0 .AND. ANG1 .GT. 61 1 .AND. IMET .EQ. 0) THEN NOTE1 = 'A' ENDIF ELSE IF (NCEFF .EQ. 3) THEN IF (ABS(ANG3 - 120.0) .LT. 2.0) THEN IHYB = 2 ENDIF ELSE IF (NCEFF .EQ. 2) THEN IF (ABS(ANG3 - 180.0) .LT. 10.0) THEN IHYB = 1 ENDIF ELSE IF (NCEFF .EQ. 1) THEN IF (MODE .EQ. 1 .AND. IAT .LE. NATX) 1 IPR(401) = IPR(401) + 1 NOTE1 = '?' ENDIF IF (IHYB .EQ. 0 .AND. IMET .EQ. 0) THEN IF (IEN(NO1) .EQ. 2) THEN IF (MODE .EQ. 1 .AND. IAT .LE. NATX) THEN IF (ABS(NCEFF - EFNC) .LT. 0.002) 1 IPR(402) = IPR(402) + 1 ENDIF NOTE1 = '?' ENDIF ENDIF ELSE IF (IEN(NO1) .EQ. 3) THEN IF (NC .EQ. 2) THEN IHYB = 3 ELSE IF (NC .EQ. 1) THEN CALL PLA050 (NINT(CON(IAT, 1)), IAT, 0, 0, DIST) IHYB = 2 ENDIF ELSE IF (IEN(NO1) .EQ. 4) THEN IF (NC .EQ. 1) THEN CALL PLA050 (NINT(CON(IAT, 1)), IAT, 0, 0, DIST) IF (DIST .LT. 1.2) IHYB = 1 ENDIF IF (NC .EQ. 3 .AND. ABS(ANG3 - 120.0) .LT. 1.5 1 .AND. DISM .LT. 1.335) IHYB = 2 IF (NC .EQ. 4 .AND. ABS(ANG3 - 109.5) .LT. 1.0) IHYB = 3 IF (NC .EQ. 3 .AND. ANG3 .LT. 112) IHYB = 3 ELSE IF (IEN(NO1) .EQ. 8) THEN IF (NC .EQ. 4 .AND. ABS(ANG3 - 109.5) .LT. 1.0) IHYB = 3 ENDIF IF (IAT .LE. NATX .OR. IPR(322) .EQ. 0) THEN IF (IHYB .EQ. 1) THEN CHYB = 'sp ' ELSE IF (IHYB .EQ. 2) THEN CHYB = 'sp2' ELSE IF (IHYB .EQ. 3) THEN CHYB = 'sp3' ENDIF ENDIF ENDIF IF (IAT .LE. NATX .AND. IHYB .EQ. 0) THEN IF (ANG1 .LT. 90.0 .AND. ANG1 .GT. 0.1) THEN IF (NO1 .EQ. 3 .AND. NC .EQ. 2) THEN NOTE1 = ' ' ELSE IF (IMET .EQ. 0 .AND. NC .LT. 6 .AND. 1 IEN(NO1) .NE. 92) THEN NOTE1 = 'A' ENDIF ENDIF ENDIF NATH = MIN (NINT(ENCH), 7) RETURN END SUBROUTINE PLA100 (IAT, JAT, MODE, DASH) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON // JNSC(2, NP23), VOID(NPVD) DASH0 = DASH NB = IPR(131) I = IAT J = JAT IF (I .GT. J) CALL GEN014 (I, J) IF (NB .GT. 0) THEN DO 10 K = 1, NB IA = NINT(VOID(IPR(298) + K * 3 - 2)) JA = NINT(VOID(IPR(298) + K * 3 - 1)) IF (I .EQ. IA .AND. J .EQ. JA) THEN IF (MODE .EQ. -2) THEN VOID(IPR(298) + K * 3 - 2) = VOID(IPR(298) + NB * 3 - 2) VOID(IPR(298) + K * 3 - 1) = VOID(IPR(298) + NB * 3 - 1) VOID(IPR(298) + K * 3) = VOID(IPR(298) + NB * 3) IPR(131) = IPR(131) - 1 GOTO 30 ELSE N = K GOTO 20 ENDIF ENDIF 10 CONTINUE ENDIF IF (MODE .EQ. -2) GOTO 30 IPR(131) = IPR(131) + 1 N = IPR(131) IPR(299) = IPR(298) + N * 3 20 XBND = 1.0 CALL GEN048 (-1, IFG(I), 19, METI) CALL GEN048 (-1, IFG(J), 19, METJ) IF (METI .EQ. 1 .OR. METJ .EQ. 1) XBND = 5.0 CALL GEN048 (-1, IFG(I), 7, IHAT) CALL GEN048 (-1, IFG(J), 7, JHAT) IF (IHAT .EQ. 1 .OR. JHAT .EQ. 1) XBND = 3.0 VOID(IPR(298) + N * 3 - 2) = I VOID(IPR(298) + N * 3 - 1) = J IF (DASH0 .LT. 2.0) THEN CALL GEN048 (-7, JFG(I), 1, IPP) CALL GEN048 (-7, JFG(J), 1, JPP) IPP = IPPR(IPP + 1, 1) / 500 JPP = IPPR(JPP + 1, 1) / 500 IF (IPP .LT. 2 .OR. JPP .LT. 2) THEN XBND = 7.0 IF (IPP * JPP .EQ. 0) DASH0 = -1.0 ENDIF ELSE DASH0 = 1.0 ENDIF IF (DASH0 .LT. -1.0) THEN DASH0 = -1.0 XBND = 7.0 ENDIF VOID(IPR(298) + N * 3) = SIGN(XBND, DASH0) 30 RETURN END SUBROUTINE PLA101 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGGT/ IGGT CHARACTER IGGT*80, TYPE*4 J1 = 0 J2 = 0 XOS = 0.0 YOS = 0.0 IENR = 0 NRING = 0 NHEAD = 0 IGBL(23) = 13 10 IOPEN = 0 NR = 0 NAT = IPR(39) 20 READ (LU8) MARK, IPR(12), JR, RMAT IF (MARK .EQ. -100) THEN CALL PLA015 (0, 18) CALL GEN108 (LU8, 0) IPR(169) = 0 GOTO 190 ENDIF NL4 = NAT IF (MARK .EQ. -1) NL4 = 240 READ (LU8) (IATP(L4), L4 = 1, NL4) IF (MARK .NE. IPR(55)) THEN IF (IPR(55) .EQ. 1) THEN IF (MARK .LT. 1 .OR. MARK .GT. 4) GOTO 20 ELSE GOTO 20 ENDIF ENDIF 30 IF (IOPEN .EQ. 0) THEN HORS = 25.0 VERT = 25.0 CALL GGIP (HORS, VERT, 0.0, 1) CALL PLA117 (HORS, VERT, -1) IOPEN = 1 IF (IPR(55) .NE. -1) 1 CALL GGIP20 (0.0, JID(75:80), 6, 0.45, 1, 2, 10.5, 24.25) ENDIF C * PLAN, RING, RESD, LSPL IF (IPR(55) .GT. 0) THEN CALL PLA102 (PMAX, SX, SY, SZ) IF (MARK .EQ. 1) THEN TYPE = 'Plan' ELSE IF (MARK .EQ. 2) THEN TYPE = 'Ring' NRING = NRING + 1 ELSE IF (MARK .EQ. 3) THEN TYPE = 'Resd' ELSE IF (MARK .EQ. 4) THEN TYPE = 'Lspl' ENDIF CALL GGIP20 (0.0, TYPE, 4, 0.45, 1, 2, 23.0, 24.0) NR = NR + 1 SXY = VERT / 2.0 SC = SXY * 0.8 / PMAX CALL GEN096 (RMAT, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM) GL(28) = IROTX GL(29) = IROTY GL(30) = IROTZ IGBL(87) = IDET IGBL(67) = 1 CALL GEN040 (IROTX, NQ1, IP) CALL GEN040 (IROTY, NQ2, IP) CALL GEN040 (IROTZ, NQ3, IP) CALL GGIP20 (0.0, NQ1, 4, 0.4, 1, 2, 23.6, 0.15) CALL GGIP20 (0.0, NQ2, 4, 0.4, 1, 2, 0.15, 24.5) CALL GGIP20 (0.0, NQ3, 4, 0.4, 1, 2, 0.15, 0.15) CALL GEN040 (IPR(140), NQ1, IP) CALL GGIP20 (0.0, NQ1, 2, 0.4, 1, 2, 22.5, 0.15) YRR = 0.4 IPR12 = IPR(12) IF (IPR12 .LE. 20) THEN DO 40 I = 1, IPR12 CALL PLA047 (XLAB(IATP(I)), NQ1, IDUM, JDUM, IPR(119), 1 IGBL(55), 0, 0) YRR = YRR + 0.5 YR = YRR XR = 1.0 CALL GGIP20 (0.0, NQ1, 5, 0.35, 1 + IPR(346), 2, XR, YR) 40 CONTINUE ENDIF IF (IPR(56) .NE. 0) THEN CALL PLA044 (RMAT, -NR, XR, YR, ZR, SX, SY, SZ, SC, SXY) YR = YR + 0.05 CALL GGIP (2.0, YR, 0.0, 3) CALL GGIP (23.0, YR, 0.0, 2) YR = YR - 0.1 CALL GGIP (23.0, YR, 0.0, 3) CALL GGIP (2.0, YR, 0.0, 2) CALL GEN040 (NR, NQ1, IP) CALL GGIP20 (0.0, NQ1, IP, 0.5, 1, 2, 23.0, 24.3) ENDIF I = 0 50 I = I + 1 IF (I .LE. NAT) THEN IF (IATC(I) .EQ. 0) GOTO 50 CALL GEN048 (-1, IFG(I), 7, IVAL) IF (IVAL .GT. 0) GOTO 50 CALL PLA044 (RMAT, I, XR, YR, ZR, SX, SY, SZ, SC, SXY) XR0 = XR YR0 = YR NQ1(1:1) = '.' DO 60 II = 1, IPR12 IF (I .EQ. IATP(II)) THEN NK0 = 1 + IPR(346) GOTO 70 ENDIF 60 CONTINUE CALL GGIP (0.0, 1.0, 0.0, 0) NK0 = 1 70 CALL GGIP20 (0.0, NQ1, 1, 0.5, NK0, 2, XR0, YR0) CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 1 0, 0) XR0 = XR + 0.5 YR0 = YR + 0.5 CALL GGIP20 (0.0, NQ1, 6, 0.4, NK0, 2, XR0, YR0) GOTO 50 ENDIF I = 0 80 I = I + 1 IF (I .GT. NAT) GOTO 180 IF (IATC(I) .EQ. 0) GOTO 80 JM = - NINT(CON(I, NP4)) IF (JM .LT. 0) JM = NP4 IF (JM .LE. 0) GOTO 80 CALL GEN048 (-1, IFG(I), 7, IHAT) CALL PLA044 (RMAT, I, XR1, YR1, ZR1, SX, SY, SZ, SC, SXY) DO 110 J = 1, JM K = NINT(CON(I, J)) IF (I .GE. K) GOTO 110 IF (IATC(K) .EQ. 0) GOTO 110 CALL GEN048 (-1, IFG(K), 7, KHAT) IF (IHAT + KHAT .GT. 0) THEN IF (IPR(346) .GT. 0) CALL GGIP (0.0, 4.0, 0.0, 0) ELSE DO 90 II = 1, IPR12 IF (I .EQ. IATP(II) .OR. K .EQ. IATP(II)) THEN IF (IPR(346) .GT. 0) CALL GGIP (0.0, 2.0, 0.0, 0) GOTO 100 ENDIF 90 CONTINUE IF (IPR(346) .GT. 0) CALL GGIP (0.0, 3.0, 0.0, 0) 100 CONTINUE ENDIF CALL PLA044 (RMAT, K, XR2, YR2, ZR2, SX, SY, SZ, SC, SXY) XR3 = XR2 - XR1 YR3 = YR2 - YR1 XYR3 = SQRT(XR3**2 + YR3**2 + PAR(12)) XR3 = 0.4 * XR3 / XYR3 YR3 = 0.4 * YR3 / XYR3 XR1 = XR1 + XR3 YR1 = YR1 + YR3 ZGGIP = 0.0 CALL GGIP (XR1, YR1, ZGGIP, 3) XR1 = XR1 - XR3 YR1 = YR1 - YR3 XR2 = XR2 - XR3 YR2 = YR2 - YR3 CALL GGIP (XR2, YR2, ZGGIP, 2) 110 CONTINUE GOTO 80 C * NEWMAN PLOT ELSE IF (IPR(55) .EQ. -1) THEN IPR(169) = IPR(169) + 1 IF (IPR(162) .GT. 0) THEN J1 = IPR(162) / (NP1 + 1) J2 = MOD(IPR(162), NP1 + 1) ENDIF IF (IOPEN .EQ. 1) THEN CALL GGIP (0.0, VERT, 0.0, 3) CALL GGIP (HORS, VERT, 0.0, 2) CALL GGIP (0.0, 0.0, 0.0, 3) CALL GGIP (HORS, 0.0, 0.0, 2) XGGIP = IGBL(103) YGGIP = VERT / 2.0 CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (HORS, YGGIP, 0.0, 2) YGGIP = VERT - 1.0 CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (HORS, YGGIP, 0.0, 2) YGGIP = VERT / 2.0 - 1.0 CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (HORS, YGGIP, 0.0, 2) YGGIP = IGBL(103) CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (HORS, YGGIP, 0.0, 2) XGGIP = HORS / 2.0 YGGIP = IGBL(103) CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (XGGIP, VERT, 0.0, 2) XGGIP = IGBL(103) CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (XGGIP, VERT, 0.0, 2) XGGIP = HORS / 2.0 + IGBL(103) CALL GGIP (XGGIP, YGGIP, 0.0, 3) CALL GGIP (XGGIP, VERT, 0.0, 2) CALL GGIP (HORS, YGGIP, 0.0, 3) CALL GGIP (HORS, VERT, 0.0, 2) IOPEN = 2 ENDIF 120 IVWP = 0 130 IVWP = IVWP + 1 IF (IVWP .GT. IPR(12)) THEN IF (IPR(162) .GT. 0) THEN GOTO 20 ELSE GOTO 180 ENDIF ENDIF ISH = (IVWP - 1) * 60 J = IATP(2 + ISH) K = IATP(3 + ISH) IF (IPR(162) .GT. 0) THEN IF ((J1 .NE. J .OR. J2 .NE. K) .AND. 1 (J1 .NE. K .OR. J2 .NE. J)) THEN GOTO 130 ELSE IPR(162) = 0 GOTO 120 ENDIF ENDIF CALL PLA047 (XLAB(J), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0) CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, 0, IGBL(55), 0, 0) IF (IVWP .EQ. 1) THEN XOR = HORS / 4.0 YOR = 3.0 * VERT / 4.0 XOS = XOR YOS = YOR ELSE IF (IVWP .EQ. 2) THEN XOR = HORS / 2.0 YOR = 0.0 XOS = XOS + XOR ELSE IF (IVWP .EQ. 3) THEN XOR = - HORS / 2.0 YOR = - VERT / 2.0 XOS = XOS + XOR YOS = YOS + YOR ELSE IF (IVWP .EQ. 4) THEN XOR = HORS / 2.0 YOR = 0.0 XOS = XOS + XOR ENDIF CALL GGIP (XOR, YOR, 0.0, -3) XR = -2.5 YR = 5.5 NK0 = 1 IF (IPR(346) .EQ. 1) NK0 = 5 CALL GGIP20 (0.0, NQ1//'-'//NQ2, 11, 0.5, NK0, 2, XR, YR) NWMNR = (IPR(169) - 1) * 4 + IVWP CALL GEN040 (NWMNR, NQ1, IP) XR = 5.9 - (IP * 0.4 * 6.0) / 7.0 CALL GGIP20 (0.0, NQ1, IP, 0.4, 1, 2, XR, YR) CALL PLA289 (0.0, 0.0, 1.0, 24) NWM = IATP(1 + ISH) IPHIP = 90 DO 170 I = 1, NWM PHI = IATP(20 + ISH + I) / (GL(5) * 100.0) PHIL = IATP(38 + ISH + I) / (GL(5) * 100.0) IPHI = NINT((IATP(21 + ISH + I) - IATP(20 + ISH + I)) 1 / 100.0) CALL GEN040 (IPHI, NQ1, IP) PHIB = PHI + IPHI / (GL(5) * 2) RADCP = PAR(24) * COS(PHI) RADSP = PAR(24) * SIN(PHI) XPL = RADCP * 3 YPL = RADSP * 3 XLB = PAR(24) * COS(PHIL) * 4 YLB = PAR(24) * SIN(PHIL) * 4 XAG = PAR(24) * COS(PHIB) * 2 YAG = PAR(24) * SIN(PHIB) * 2 IF (IP .LE. 1) THEN XAG = XAG * 1.75 YAG = YAG * 1.75 ELSE IF (IPHI .LE. 40) THEN XAG = XAG * 1.4 YAG = YAG * 1.4 ENDIF ENDIF XAG = XAG - IP * PAR(25) / 2 YAG = YAG - PAR(25) / 2 IF (IATP(I + 3 + ISH) .LE. NP1) THEN XST = RADCP YST = RADSP ELSE XST = 0.0 YST = 0.0 ENDIF L = MOD(IATP(I + 3 + ISH), NP1) CALL PLA047 (XLAB(L), NQ3, IDUM, IENR, 0, IGBL(55), 0, 0) DO 150 L0 = 1, 5 IF (NQ3(6-L0:6-L0) .NE. ' ') GOTO 160 150 CONTINUE 160 L0 = 6 - L0 IF (COS(PHIL) .LT. 0) THEN XLB = XLB + L0 * PAR(25) * COS(PHIL) * 5.0 / 6.0 IF (IGBL(103) .EQ. 1) XLB = MAX (XLB, -5.0) IF (IPHIP .LT. 25) THEN YLB = YLB - PAR(25) -0.05 ENDIF ELSE IF (IPHIP .LT. 25) THEN YLB = YLB + PAR(25) + 0.05 ENDIF ENDIF CALL GGIP (XST, YST, 0.0, 3) CALL GGIP (XPL, YPL, 0.0, 2) NK0 = 1 IF (IPR(346) .EQ. 1 .AND. IENR .NE. 1) NK0 = 2 CALL GGIP20 (0.0, NQ3, L0, PAR(25), NK0, 2, XLB, YLB) IF (IPR(346) .EQ. 1) NK0 = 3 CALL GGIP20 (0.0, NQ1, IP, 0.5, NK0, 2, XAG, YAG) IPHIP = IPHI 170 CONTINUE GOTO 130 ENDIF 180 CALL GGIP (0.0, 1.0, 0.0, 0) CALL GGIP (0.0, 0.0, 0.0, 3) 190 CALL GGIP (-XOS, - YOS, 0.0, -3) CALL PLA013 (1, 1) IF (IGBL(5) .EQ. LU5) THEN CALL GEN020 (1, IGGT, 1, 80) IF (IGGT(1:1) .EQ. ' ') WRITE (LU6, 99999) IF (IGGT(1:1) .EQ. '!' .OR. IGGT(1:1) .EQ. 'Y') GOTO 10 IF (IGGT(1:5) .EQ. 'CANDP') THEN IF (IPR(55) .EQ. 2 .AND. IPR(12) .GT. 0 .AND. IPR(12) .LT. 8) 1 CALL PLA095 (NRING, NHEAD, 1) GOTO 10 ENDIF CALL PLA006 (0, IS) IF (IFL(1)(1:3) .EQ. 'REF') THEN IOPEN = 0 IPR(169) = IPR(169) - 1 GOTO 30 ELSE IPR(201) = 0 CALL PLA280 (ICL) IGBL(23) = 10 ENDIF ELSE GOTO 10 ENDIF IPR(1) = 5 RETURN 99999 FORMAT (':: Type Y(es) to continue this plot sequence, ', 1 ' or another instruction', /) END SUBROUTINE PLA102 (PMAX, SX, SY, SZ) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) IF (IPR(56) .NE. 0) THEN DO 10 I = 1, 3 TEMP = RMAT(1, I) RMAT(1, I) = RMAT(2, I) RMAT(2, I) = RMAT(3, I) RMAT(3, I) = TEMP 10 CONTINUE ENDIF NAT = IPR(39) DO 20 I = 1, 3 PAR(54 + I) = 1.0E10 PAR(57 + I) =-1.0E10 20 CONTINUE I = 0 30 I = I + 1 IF (I .GT. NAT) GOTO 60 IATC(I) = 1 IF (IPR(140) .GT. 0) THEN CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .NE. IPR(140)) THEN IATC(I) = 0 GOTO 30 ENDIF ENDIF DO 40 K = 1, 3 V5(K) = XXO(I, K + 3) 40 CONTINUE CALL GEN002 (1, RMAT, V5, V6, XLNG) DO 50 K = 1, 3 PAR(57 + K) = MAX (PAR(57 + K), V6(K)) PAR(54 + K) = MIN (PAR(54 + K), V6(K)) 50 CONTINUE GOTO 30 60 SX = (PAR(55) + PAR(58)) * 0.5 SY = (PAR(56) + PAR(59)) * 0.5 SZ = (PAR(57) + PAR(60)) * 0.5 PMAX = MAX (PAR(58) - SX, PAR(59) - SY) IF (ABS(PMAX) .LT. 0.0001) PMAX = 1.0 RETURN END SUBROUTINE PLA103 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP26=6000,NP27=1000,NP28=3024, 3 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), 1 VOID(NPVD - 5 * NP26 - 9 * NP27 - NP28 - 1560), B(24), 1 A(NP26, 5), IP(NP27, 9), IO(NP28), CY(36), D(300, 5) COMMON /PL103/ NATP, NRCRC, NPOLY COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 LOGICAL LOG 5 IER = 0 NAT = IPR(37) NSYM = IPR(48) NRCRC = 0 NPOLY = 0 NATP = 8 NATPS = 0 PAR(224) = 1.0 DO 20 I = 1, 8 A(I, 1) = I * 10 DO 10 J = 2, 4 A(I, J) = 0.0 10 CONTINUE 20 CONTINUE A(2, 2) = 1.0 A(3, 3) = 1.0 A(4, 4) = 1.0 A(5, 2) = 1.0 A(5, 3) = 1.0 A(6, 2) = 1.0 A(6, 4) = 1.0 A(7, 3) = 1.0 A(7, 4) = 1.0 A(8, 2) = 1.0 A(8, 3) = 1.0 A(8, 4) = 1.0 C73 = MAX (PAR(216) + PAR(217), PAR(220) + PAR(221)) V2(1) = ABS (C73 / OR(1, 1)) V2(2) = ABS (C73 / (V2(1) * OR(1, 2) - OR(2, 2))) V2(3) = ABS (C73 / (V2(2) * OR(1, 3) + OR(3, 3))) IF (IPR(354) .EQ. -1) THEN IPR(354) = 0 ENDIF DO 25 I = 1, 5, 2 J = (I + 1) / 2 PAR(200 + I) = (1 - (IPR(354) + 1)) * 0.5 - V2(J) PAR(201 + I) = (1 + (IPR(354) + 1)) * 0.5 + V2(J) 25 CONTINUE C * DEFAULT OMIT OUTSIDE RANGE IF (IPR(356) .LT. 0) THEN DO 30 I = 1, 5, 2 PAR(206 + I) = -0.01 PAR(207 + I) = 1.01 30 CONTINUE IPR(356) = 0 ENDIF DO 40 I = 1, 6 IO(I) = IFIX(PAR(200 + I) - SIGN(1E-4, PAR(200 + I)) + 10.0) 40 CONTINUE WRITE (LU6, 99998) (PAR(J), J = 201, 202), (IO(J) -10, J = 1, 2), 1 (PAR(J), J = 203, 204), (IO(J) -10, J = 3, 4), 2 (PAR(J), J = 205, 206), (IO(J) -10, J = 5, 6) DO 110 INAT = 1, NAT CALL PLA047 (XLAB(INAT), NQ1, IDUM, IENR, 0, IGBL(55), 0, 0) N2 = NATP DO 100 J = 1, NSYM NATP = NATP + 1 A(NATP, 1) = (IENR * 10000 + INAT) * 10 A(NATP, 5) = REL(IENR) * PAR(213) DO 50 L = 1, 3 XJX(L) = XXO(INAT, L) XJX(L + 3) = 0.0 50 CONTINUE CALL SGSM (LINE, J, XJX, LU7, 3, IERR) DO 60 L = 2, 4 A(NATP, L) = MOD(XJX(L + 5) + 10.0, 1.0) 60 CONTINUE IF (J .GT. 1) THEN DO 70 L = N2, NATP - 1 IF (ABS(A(L, 2) - A(NATP, 2)) .LT. 0.001) THEN IF (ABS(A(L, 3) - A(NATP, 3)) .LT. 0.001) THEN IF (ABS(A(L, 4) - A(NATP, 4)) .LT. 0.001) THEN NATP = NATP - 1 GOTO 100 ENDIF ENDIF ENDIF 70 CONTINUE ENDIF DO 80 L = 2, 4 K = (L - 1) * 2 IF (A(NATP, L) .LT. PAR(199 + K) .OR. 1 A(NATP, L) .GT. PAR(200 + K)) THEN A(NATP, 1) = SIGN(A(NATP, 1), -1.0) GOTO 100 ENDIF 80 CONTINUE IF (IPR(356) .EQ. 1) THEN DO 90 L = 2, 4 K = (L + 102) * 2 IF (A(NATP, L) .LT. PAR(K - 1) .OR. 1 A(NATP, L) .GT. PAR(K)) THEN A(NATP, 1) = FLOAT(IFIX(A(NATP, 1) * 0.1) * 10 + 5) GOTO 100 ENDIF 90 CONTINUE ENDIF 100 CONTINUE 110 CONTINUE NATPS = NATP DO 170 I = 9, NATPS CY(1) = ABS(IFIX(A(I, 1) * 0.1) * 10) CY(2) = A(I, 2) CY(3) = A(I, 3) CY(4) = A(I, 4) CY(5) = A(I, 5) DO 160 J = IO(1), IO(2) DO 150 K = IO(3), IO(4) DO 140 L = IO(5), IO(6) IF (J .NE. 10 .OR. K .NE. 10 .OR. L .NE. 10) THEN NATP = NATP + 1 A(NATP, 1) = CY(1) A(NATP, 2) = CY(2) + FLOAT(J) - 10.0 A(NATP, 3) = CY(3) + FLOAT(K) - 10.0 A(NATP, 4) = CY(4) + FLOAT(L) - 10.0 A(NATP, 5) = CY(5) DO 120 M = 2, 4 M2 = (M - 1) * 2 IF (A(NATP, M) .LT. PAR(199 + M2) .OR. 1 A(NATP, M) .GT. PAR(200 + M2)) THEN NATP = NATP - 1 GOTO 140 ENDIF 120 CONTINUE IF (IPR(356) .EQ. 1) THEN DO 130 M = 2, 4 M2 = (M + 102) * 2 IF (A(NATP, M) .LT. PAR(M - 1) .OR. 1 A(NATP, M) .GT. PAR(M)) THEN A(NATP, 1) = FLOAT(IFIX(A(NATP, 1) * 0.1) 1 * 10 + 5) GOTO 140 ENDIF 130 CONTINUE ENDIF ENDIF 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE CALL GEN021 (RMAT, 1) DO 180 I = 1, 3 X = - GL(27 + I) / GL(5) CALL GEN051 (0, RMAT, X, I) 180 CONTINUE DO 190 I = 1, NATP V3(1) = A(I, 2) V3(2) = A(I, 3) V3(3) = A(I, 4) CALL GEN002 (1, OR, V3, V2, DUM) CALL GEN002 (-1, RMAT, V2, V3, DUM) A(I, 2) = V3(1) A(I, 3) = V3(2) A(I, 4) = V3(3) 190 CONTINUE DO 200 I = 9, NATP IF (A(I, 1) .GT. 0) THEN IF (MOD(IFIX(A(I, 1)), 10) .EQ. 0) THEN II = INT(A(I, 1) / 100000) IF (IATPR(II) .EQ. 5 .OR. IATPR(II) .EQ. 6) THEN NRCRC = NRCRC + 1 IO(NRCRC) = I ENDIF ENDIF ENDIF 200 CONTINUE IF (IABS(NRCRC) .GT. 0) THEN DO 220 I = 1, NRCRC - 1 K = 0 CY1 = A(IO(I), 4) DO 210 J = I + 1, NRCRC IF (CY1 .LE. A(IO(J), 4)) THEN CY1 = A(IO(J), 4) K = J ENDIF 210 CONTINUE IF (K .GT. 0) THEN CALL GEN014 (IO(I), IO(K)) ENDIF 220 CONTINUE ENDIF PAR(222) = MAX (PAR(216) + PAR(217), PAR(220) + PAR(221)) DO 390 I0 = 9, NATP IF (A(I0, 1) .GT. 0.0) THEN LOG = I0 .GT. NATPS IF (LOG .AND. IPR(354) .EQ. 0) GOTO 400 LOG = IFIX(A(I0, 1) * 0.1) .EQ. 1 IFIX(A(I0 - 1, 1) * 0.1) .OR. LOG L = 0 DO 240 J = 9, NATP IF (A(J, 1) .GT. 0.0) THEN IF (J .NE. I0) THEN D(L + 1, 1) = FLOAT(J) DEL = 0 DO 230 K = 2, 4 D(L + 1, K) = A(I0, K) - A(J, K) DEL = DEL + D(L + 1, K)**2 230 CONTINUE D(L + 1, 5) = SQRT(DEL) IF (D(L + 1, 5) .LE. PAR(222)) L = L + 1 ENDIF ENDIF 240 CONTINUE DO 270 I1 = 1, L - 1 K1 = 0 B24 = D(I1, 5) DO 250 J1 = I1 + 1, L IF (B24 .GE. D(J1, 5)) THEN B24 = D(J1, 5) K1 = J1 ENDIF 250 CONTINUE IF (K1 .GT. 0) THEN DO 260 J1 = 1, 5 CALL GEN018 (D(I1, J1), D(K1, J1)) 260 CONTINUE ENDIF 270 CONTINUE II = L DO 290 J = 1, L - 1 IF (D(J, 5) .LE. PAR(222)) THEN DO 280 K = J + 1, L IF (D(K, 5) .GT. PAR(222)) GOTO 290 II = II + 1 IF (II .GT. 300) STOP 'II' D(II, 1) = D(J, 1) D(II, 2) = D(K, 1) IF (ABS(D(J, 5) * D(K, 5)) .GE. 1E-8) THEN ARCO = (D(J, 2) * D(K, 2) + D(J, 3) * D(K, 3) 1 + D(J, 4) * D(K, 4)) / (D(J, 5) * D(K, 5)) ELSE ARCO = 1.0 ENDIF IF (ABS(ARCO) .GT. 1.0) ARCO = SIGN(1.0, ARCO) D(II, 3) = ACOS(ARCO) * GL(5) D(II, 4) = D(J, 5) D(II, 5) = D(K, 5) 280 CONTINUE ENDIF 290 CONTINUE DO 380 IG0 = 1, 2 IG1 = 9 - IG0 * 2 DO 300 J = 1, 4 IF (IG0 .EQ. 1) THEN CY(J) = PAR(217 + J) ELSE CY(J) = PAR(213 + J) ENDIF 300 CONTINUE CY(5) = 1.414 * (PAR(220) + PAR(221)) IF (NPOLY .GE. NP27) THEN WRITE (LU7, 99996) NP27 IER = 1 GOTO 410 ENDIF IG4 = 1 IP(NPOLY + 1, 1) = I0 IP(NPOLY + 1, 6) = 0 IP(NPOLY + 1, 7) = 0 X1 = 0.0 X2 = A(I0, 2) X3 = A(I0, 3) DO 330 II0 = L + 1, II IF (ABS(D(II0, 3) - CY(1)) .LE. CY(2)) THEN IF (ABS(D(II0, 4) - CY(3)) .LE. CY(4)) THEN IF (ABS(D(II0, 5) - CY(3)) .LE. CY(4)) THEN DO 320 M = 1, 2 IF (IG4 .GT. 1) THEN DO 310 K = 2, IG4 IF (NINT(D(II0, M)) .EQ. IP(NPOLY + 1, K)) 1 GOTO 320 310 CONTINUE ENDIF IG4 = IG4 + 1 IP(NPOLY + 1, IG4) = NINT(D(II0, M)) X4 = A(IP(NPOLY + 1, IG4), 2) X5 = A(IP(NPOLY + 1, IG4), 3) X1 = MAX (X1, SQRT((X2 - X4)**2 1 + (X3 - X5)**2)) 320 CONTINUE ENDIF ENDIF ENDIF 330 CONTINUE IP(NPOLY + 1, 8) = IFIX(X1 * 1000) IP(NPOLY + 1, 9) = IG1 IF (IG4 .EQ. IG1) THEN NPOLY = NPOLY + 1 IF (IG1 .EQ. 7) THEN DO 370 I = 2, 3 DO 340 JJ = 1, 3 XPV(JJ) = A(IP(NPOLY, I), JJ + 1) 340 CONTINUE CY(6) = 0.0 DO 360 J = I + 1, 9 - I DO 350 JJ = 1, 3 XPV(JJ + 3) = A(IP(NPOLY, J), JJ + 1) 350 CONTINUE CY(5) = SQRT((XPV(4) - XPV(1))**2 1 + (XPV(5) - XPV(2))**2 + (XPV(6) - XPV(3))**2) IF (CY(5) .GT. CY(6)) THEN CY(6) = CY(5) IG4 = J ENDIF 360 CONTINUE CALL GEN014 (IP(NPOLY, IG4), IP(NPOLY, 9 - I)) 370 CONTINUE ENDIF GOTO 390 ENDIF 380 CONTINUE ENDIF 390 CONTINUE 400 CALL PLA104 (IER) 410 IF (IER .NE. 0) WRITE (LU7, 99999) IER CALL PLA013 (0, 1) CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) IF (IFL(1)(1:4) .EQ. 'EXIT') THEN GOTO 420 ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN IGGT = ' ' IGBL(23) = 10 GOTO 420 ELSE IF (IFL(1)(1:2) .EQ. 'XR') THEN CALL PLA226 (-1, - FN(1) / GL(5)) GOTO 5 ELSE IF (IFL(1)(1:2) .EQ. 'YR') THEN CALL PLA226 (-2, - FN(1) / GL(5)) GOTO 5 ELSE IF (IFL(1)(1:2) .EQ. 'ZR') THEN CALL PLA226 (-3, - FN(1) / GL(5)) GOTO 5 ENDIF IF (LRET .EQ. 1) THEN GOTO 420 ELSE IF (LRET .EQ. 3) THEN GOTO 5 ENDIF 420 CALL GGIP (0.0, 0.0, 0.0, -1) RETURN 99999 FORMAT (':: Error Nr.', I3, ' in POLY') 99998 FORMAT (///, 'Range for Generating Atoms is X:', 1 F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')',/, 30X, 'Y:', 2 F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')' /, 30X, 'Z:', 3 F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')') 99996 FORMAT ('Maximum Number of Polyhedra', I5, ' has been Exceeded') END SUBROUTINE PLA104 (IER) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP23=18000,NP25=99,NP26=6000,NP27=1000,NP28=3024,NP29=63, 3 NP38=125, NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON // JNSC(2, NP23), 1 VOID(NPVD - 5 * NP26 - 9 * NP27 - NP28 - 1560), B(24), 2 A(NP26, 5), IP(NP27, 9), IO(NP28), IG1(100), IG2(100), 3 R(400, 3), IF1(6), NF(68), D(62) COMMON /ALL/ NN(12, 3), LO(12, 2), IE(12, 2) COMMON /PL103/ NATP, NRCRC, NPOLY V1(1) = 1E5 V1(2) = -1E5 V1(3) = 1E5 V1(4) = -1E5 DO 10 I = 1, NATP IF (IPR(355) .GT. 0) THEN B14 = 60.0 / (60.0 - A(I, 4)) A(I, 2) = A(I, 2) * B14 A(I, 3) = A(I, 3) * B14 ENDIF IF (A(I, 1) .GT. 0) THEN V1(1) = MIN (V1(1), A(I, 2)) V1(2) = MAX (V1(2), A(I, 2)) V1(3) = MIN (V1(3), A(I, 3)) V1(4) = MAX (V1(4), A(I, 3)) ENDIF 10 CONTINUE B14 = ABS(V1(1) - V1(2)) B15 = ABS(V1(3) - V1(4)) PAR(224) = MIN (PAR(38) * PAR(50) / B14, PAR(38) / B15) B14 = (V1(1) + V1(2)) / 2 B15 = (V1(3) + V1(4)) / 2 DO 20 I = 1, NATP A(I, 2) = A(I, 2) - B14 A(I, 3) = A(I, 3) - B15 20 CONTINUE XGGIP = PAR(38) * PAR(50) YGGIP = PAR(38) CALL GGIP (XGGIP, YGGIP, 0.0, 1) CALL GGIP (0.0, 1.0, 0.0, 0) CALL PLA117 (XGGIP, YGGIP, 0) XGGIP = XGGIP / 2.0 YGGIP = YGGIP / 2.0 CALL GGIP (XGGIP, YGGIP, 0.0, -3) DD = PAR(224) * 0.9 CALL GGIP (0.0, DD, 0.0, 7) NF(1) = 0 NF(2) = 0 D(23) = 0.0 D(24) = 0.0 C1 = 0.012 / DD IF (IPR(357) .GT. 0) THEN NF(10) = 1 DO 30 I = 1, 12 V1(1) = A(LO(I, 1), 2) V1(2) = A(LO(I, 1), 3) V1(3) = A(LO(I, 2), 2) V1(4) = A(LO(I, 2), 3) CALL GGIP (V1(1), V1(2), 0.0, 3) CALL GGIP (V1(3), V1(4), 0.0, 2) D(23) = V1(3) D(24) = V1(4) 30 CONTINUE ENDIF 40 IF (NF(1) .LT. NPOLY) THEN IF (NF(2) .GE. NRCRC .OR. (NF(2) .LT. NRCRC .AND. 1 A(IP(NF(1) + 1, 1), 4) .GT. A(IO(NF(2) + 1), 4))) THEN NF(1) = NF(1) + 1 IF (IPR(353) .EQ. 0) GOTO 40 DO 50 I = 1, 11 IE(I, 1) = -1 IE(I, 2) = -1 50 CONTINUE CALL GEN097 (IF1, 1, 6, -1) IF (IP(NF(1), 7) .LE. 0) THEN NF(12) = 9 NF(13) = 12 ELSE NF(12) = 1 NF(13) = 8 ENDIF K = 0 L = 0 DO 60 I = 1, 3 B(I) = A(IP(NF(1), 1), I + 1) 60 CONTINUE DO 100 I = NF(12), NF(13) DO 65 J = 1, 3 NF(6 + J) = IP(NF(1), NN(I, J)) 65 CONTINUE DO 70 J = 1, 3 B(4 + J) = A(NF(8), 1 + J) - A(NF(7), 1 + J) B(7 + J) = A(NF(9), 1 + J) - A(NF(7), 1 + J) B(13 + J) = B(J) - A(NF(7), 1 + J) 70 CONTINUE CALL GEN008 (B(5), B(8), B(11), 0) IF (GEN009 (B(11), B(14)) .GE. 0.0) B(13) = - B(13) IF (B(13) .GT. 0) THEN K = K + 1 IF1(K) = I DO 90 J0 = 1, 3 J1 = 1 + J0 / 3 J2 = 2 + (J0 + 1) / 3 IF (L .GT. J0 - 1) THEN DO 80 J = 1, L IF (NN(I, J1) .EQ. IE(J, 1) .AND. 1 NN(I, J2) .EQ. IE(J, 2)) GOTO 90 IF (NN(I, J2) .EQ. IE(J, 1) .AND. 1 NN(I, J1) .EQ. IE(J, 2)) GOTO 90 80 CONTINUE ENDIF L = L + 1 IE(L, 1) = NN(I, J1) IE(L, 2) = NN(I, J2) 90 CONTINUE ENDIF 100 CONTINUE DO 120 J = 1, L DO 110 K = 1, 2 IE(J, K) = IP(NF(1), IE(J, K)) 110 CONTINUE 120 CONTINUE NF(4) = 0 NF(5) = 0 IF (NF(1) .LT. 1) THEN GOTO 40 ELSE IF (NF(1) .GT. 1) THEN B(6) = FLOAT(IP(NF(1), 8)) * 1E-3 DO 130 I = 1, NF(1) - 1 B(7) = FLOAT(IP(I, 8)) * 1E-3 B(4) = A(IP(I, 1), 2) B(5) = A(IP(I, 1), 3) B(8) = SQRT((B(1) - B(4))**2 + (B(2) - B(5))**2) IF (B(8) - B(6) - B(7) .LT. 0.0) THEN NF(4) = NF(4) + 1 IG1(NF(4)) = I ENDIF 130 CONTINUE ENDIF IF (NF(2) .GT. 0) THEN DO 140 I = 1, NF(2) B(4) = A(IO(I), 2) B(5) = A(IO(I), 3) B(7) = A(IO(I), 5) B(8) = SQRT((B(1) - B(4))**2 + (B(2) - B(5))**2) IF (B(8) - B(6) - B(7) .LT. 0) THEN NF(5) = NF(5) + 1 IG2(NF(5)) = I ENDIF 140 CONTINUE ENDIF K = 17 DO 150 I = 1, 10 IF (IE(I + 1, 1) .LE. 0) GOTO 160 150 CONTINUE I = 11 160 NF(10) = 3 DO 180 J = 1, I B(9) = A(IE(J, 1), 2) B(10) = A(IE(J, 1), 3) B(11) = A(IE(J, 2), 2) B(12) = A(IE(J, 2), 3) D(13) = B(1) D(14) = B(2) D(15) = 0.5 * (B(9) + B(11)) D(16) = 0.5 * (B(10) + B(12)) D(21) = (D(13) - D(15))**2 + (D(14) - D(16))**2 DO 170 L = 1, I IF (J .NE. L) THEN D(17) = A(IE(L, 1), 2) D(18) = A(IE(L, 1), 3) D(19) = A(IE(L, 2), 2) D(20) = A(IE(L, 2), 3) D(9) = D(15) - D(13) D(10) = D(16) - D(14) D(11) = D(19) - D(17) D(12) = D(20) - D(18) DEN = D(9) * D(12) - D(10) * D(11) IF (ABS(DEN) .LE. 1E-8) THEN D(5) = 10.0 ELSE D(5) = (D(10) * (D(17) - D(13)) 1 - D(9) * (D(18) - D(14))) / DEN D(6) = (D(12) * (D(17) - D(13)) 1 -D(11) * (D(18) - D(14))) / DEN D(1) = D(17) + D(5) * D(11) D(2) = D(18) + D(5) * D(12) ENDIF IF (ABS(D(5) - 0.5) .LE. 0.5) THEN IF (D(6) .GE. 0.0) THEN D(22) = (D(13) - D(1))**2 + (D(14) - D(2))**2 IF (D(22) .GT. D(21)) GOTO 175 ENDIF ENDIF ENDIF 170 CONTINUE K = K + 1 NF(K) = J 175 CALL PLA105 180 CONTINUE IF (IPR(358) .GT. 0) THEN NF(10) = 1 DO 220 I = 1, 6 IF (IF1(I) .LE. 0) GOTO 230 NF(7) = NN(IF1(I), 1) NF(8) = NN(IF1(I), 2) NF(9) = NN(IF1(I), 3) DO 190 JX = 8, 9 IF (A(IP(NF(1), NF(7)), 4) 1 - A(IP(NF(1), NF(JX)), 4) .LE. 0) THEN CALL GEN014 (NF(7), NF(JX)) ENDIF 190 CONTINUE DO 210 J = 1, 9 DO 200 J0 = 9, 12 J1 = MOD(J0 + 1, 2) + 2 J2 = 8 + (J0 - 8) / 3 B(J0) = ((10 - J) * A(IP(NF(1), NF(7)), J1) 1 + J * A(IP(NF(1), NF(J2)), J1)) / 10.0 200 CONTINUE IF (IPR(346) .NE. 0) THEN IF (IP(NF(1), 9) .EQ. 5) THEN CALL GGIP (0.0, 2.0, 0.0, 0) ELSE CALL GGIP (0.0, 3.0, 0.0, 0) ENDIF ENDIF CALL PLA105 CALL GGIP (0.0, 1.0, 0.0, 0) 210 CONTINUE 220 CONTINUE ENDIF 230 L = 3 IP(NF(1), 2) = IE(NF(18), 1) IP(NF(1), 3) = IE(NF(18), 2) 240 DO 250 I = 19, K IF (NF(I) .GT. 0) THEN IF (IE(NF(I), 1) .EQ. IP(NF(1), L)) THEN L = L + 1 IP(NF(1), L) = IE(NF(I), 2) ELSE IF (IE(NF(I), 2) .NE. IP(NF(1), L)) GOTO 250 L = L + 1 IP(NF(1), L) = IE(NF(I), 1) ENDIF NF(I) = -1 IF (L .GT. 7) THEN IER = 2 GOTO 440 ELSE IF (L .LT. 7) THEN GOTO 240 ELSE IF (IP(NF(1), 2) .EQ. IP(NF(1), L)) IP(NF(1), L) = -1 GOTO 430 ENDIF ENDIF 250 CONTINUE IP(NF(1), L) = -1 GOTO 430 ENDIF ENDIF IF (NF(2) .LT. NRCRC) THEN NF(2) = NF(2) + 1 B(1) = A(IO(NF(2)), 2) B(2) = A(IO(NF(2)), 3) B(3) = A(IO(NF(2)), 5) NF(4) = 0 IF (IPR(353) .NE. 0 .AND. NF(1) .GT. 0) THEN DO 260 I = 1, NF(1) B(8) = FLOAT(IP(I, 8)) * 0.001 IF (SQRT((B(1) - A(IP(I, 1), 2))**2 1 + (B(2) - A(IP(I, 1), 3))**2) .LT. B(3) + B(8)) THEN NF(4) = NF(4) + 1 IG1(NF(4)) = I ENDIF 260 CONTINUE ENDIF NF(5) = 0 IF (NF(2) .GT. 1) THEN DO 270 I = 1, NF(2) - 1 B(8) = A(IO(I), 5) B(5) = A(IO(I), 2) B(6) = A(IO(I), 3) D(40) = SQRT((B(1) - B(5))**2 + (B(2) - B(6))**2) IF (D(40) - B(3) - B(8) .LT. 0.0) THEN IF (D(40) .LE. 1E-3) THEN IF (D(40) + ABS(B(3) - B(8)) .LE. 1E-3) THEN GOTO 430 ELSE GOTO 270 ENDIF ENDIF NF(5) = NF(5) + 1 IG2(NF(5)) = I ENDIF 270 CONTINUE ENDIF NF(15) = 2 R(1, 1) = B(1) R(1, 2) = B(2) + B(3) R(1, 3) = 0.0 R(2, 1) = R(1, 1) R(2, 2) = R(1, 2) R(2, 3) = 360.0 IF (IPR(353) .NE. 0 .AND. NF(4) .GT. 0) THEN B(19) = B(1) B(20) = B(2) DO 290 I = 1, NF(4) NF(16) = IP(IG1(I), 9) - 1 DO 280 J = 2, NF(16) + 1 IF (IP(IG1(I), J) .LT. 1) GOTO 290 IF (IP(IG1(I), J + 1) .LE. 0) NF(16) = J - 1 B(9) = A(IP(IG1(I), J), 2) B(10) = A(IP(IG1(I), J), 3) NF(13) = J - 1 NF(14) = MOD(NF(13), NF(16)) + 2 B(11) = A(IP(IG1(I), NF(14)), 2) B(12) = A(IP(IG1(I), NF(14)), 3) D(5) = -1.0 D(6) = -1.0 D(7) = B(9) - B(19) D(8) = B(10) - B(20) D(9) = B(11) - B(9) D(10) = B(12) - B(10) D(11) = D(9)**2 + D(10)**2 D(12) = D(7) * D(9) + D(8) * D(10) D(13) = D(12)**2 1 - D(11) * (D(7)**2 + D(8)**2 - B(3)**2) IF (D(13) .GE. 0) THEN D(14) = - D(12) / D(11) D(13) = SQRT(D(13)) / D(11) D(5) = D(14) + D(13) D(1) = B(9) + D(5) * D(9) D(2) = B(10) + D(5) * D(10) IF (D(13) .GT. 1E-4) THEN D(6) = D(14) - D(13) D(3) = B(9) + D(6) * D(9) D(4) = B(10) + D(6) * D(10) ENDIF ENDIF IF (ABS(D(5) - 0.5) .LE. 0.5) THEN NF(15) = NF(15) + 1 R(NF(15), 1) = D(1) R(NF(15), 2) = D(2) D(25) = D(1) - B(1) D(26) = D(2) - B(2) R(NF(15), 3) = ACOS((D(26) / 1 SQRT(D(25)**2 + D(26)**2))) * GL(5) IF (D(25) .LE. 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3) ENDIF IF (ABS(D(6) - 0.5) .LE. 0.5) THEN NF(15) = NF(15) + 1 R(NF(15), 1) = D(3) R(NF(15), 2) = D(4) D(25) = D(3) - B(1) D(26) = D(4) - B(2) R(NF(15), 3) = ACOS((D(26) / 1 SQRT(D(25)**2 + D(26)**2))) * GL(5) IF (D(25) .LE. 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3) ENDIF 280 CONTINUE 290 CONTINUE ENDIF IF (NF(5) .GT. 0) THEN DO 300 I = 1, NF(5) B(5) = A(IO(IG2(I)), 2) B(6) = A(IO(IG2(I)), 3) B(8) = A(IO(IG2(I)), 5) D(9) = B(5) - B(1) D(10) = B(6) - B(2) D(11) = D(9)**2 + D(10)**2 D(12) = B(1) * D(9) + B(2) * D(10) D(13) = (B(5)**2 + B(6)**2 - B(1)**2 1 - B(2)**2 + B(3)**2 - B(8)**2) / 2.0 D(14) = (D(13) - D(12)) / D(11) D(15) = SQRT(B(3)**2 * D(11) - (D(13) - D(12))**2) / D(11) D(1) = B(1) + D(14) * D(9) - D(15) * D(10) D(2) = B(2) + D(14) * D(10) + D(15) * D(9) D(3) = B(1) + D(14) * D(9) + D(15) * D(10) D(4) = B(2) + D(14) * D(10) - D(15) * D(9) NF(15) = NF(15) + 1 R(NF(15), 1) = D(1) R(NF(15), 2) = D(2) D(25) = D(1) - B(1) D(26) = D(2) - B(2) R(NF(15), 3) = ACOS((D(26) / 1 SQRT(D(25)**2 + D(26)**2))) * GL(5) IF (D(25) .LE. 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3) NF(15) = NF(15) + 1 R(NF(15), 1) = D(3) R(NF(15), 2) = D(4) D(25) = D(3) - B(1) D(26) = D(4) - B(2) R(NF(15), 3) = ACOS((D(26) / 1 SQRT(D(25)**2 + D(26)**2))) * GL(5) IF (D(25) .LE. 0.0) R(NF(15),3) = 360.0 - R(NF(15),3) 300 CONTINUE ENDIF DO 330 I2 = 1, NF(15) - 1 K2 = 0 B(13) = R(I2, 3) DO 310 J2 = I2 + 1, NF(15) IF (B(13) .GE. R(J2, 3)) THEN B(13) = R(J2, 3) K2 = J2 ENDIF 310 CONTINUE IF (K2 .GT. 0) THEN DO 320 J2 = 1, 3 CALL GEN018 (R(I2, J2), R(K2, J2)) 320 CONTINUE ENDIF 330 CONTINUE IF (IPR(346) .NE. 0) CALL GGIP (0.0, 5.0, 0.0, 0) DO 420 I = 2, NF(15) B(11) = R(I, 3) - R(I - 1, 3) B(12) = R(I, 3) - B(11) * 0.5 B(23) = B(3) * SIN(B(12) / GL(5)) + B(1) B(24) = B(3) * COS(B(12) / GL(5)) + B(2) IF (IPR(353) .NE. 0) THEN IF (NF(4) .GT. 0) THEN DO 390 J = 1, NF(4) NF(3) = IG1(J) DO 340 I0 = 3, 6 IF (IP(NF(3), I0 + 2) .LE. 0) GOTO 350 340 CONTINUE I0 = 6 350 K0 = I0 + MOD(I0, 2) - 1 DO 370 J0 = 1, K0, 2 NF(12) = MOD(J0, I0) + 2 NF(13) = MOD(J0 + 1, I0) + 2 NF(14) = MOD(J0 - 1, I0) + 2 DO 360 J1 = 13, 16 J2 = MOD(J1 + 1, 2) + 2 J3 = 13 + (J1 - 12) / 3 B(J1) = A(IP(NF(3), NF(J3)), J2) 1 - A(IP(NF(3), NF(12)), J2) 360 CONTINUE D(11) = B(23) - A(IP(NF(3), NF(12)), 2) D(12) = B(24) - A(IP(NF(3), NF(12)), 3) D(5) = (D(11) * B(14) - D(12) * B(13)) / 1 (B(15) * B(14) - B(16) * B(13)) D(6) = (D(11) * B(16) - D(12) * B(15)) / 1 (B(13) * B(16) - B(14) * B(15)) D(10) = MIN (D(5), D(6)) IF (D(10) .LE. 0.0) GOTO 380 370 CONTINUE 380 IF (IFIX(SIGN(1.0, D(10))) .GE. 0) GOTO 420 390 CONTINUE ENDIF ENDIF IF (NF(5) .GT. 0) THEN DO 400 J = 1, NF(5) IF (SQRT((B(23) - A(IO(IG2(J)), 2))**2 1 + (B(24) - A(IO(IG2(J)), 3))**2) 2 - A(IO(IG2(J)), 5) .LE. 0) GOTO 420 400 CONTINUE ENDIF CALL GGIP (R(I - 1, 1), R(I - 1, 2), 0.0, 3) NF24 = NINT(B(11) * B(3) / (3 * C1 * GL(5))) IF (NF24 .LE. 1) GOTO 420 D(30) = B(11) / FLOAT(NF24) D(31) = R(I - 1, 3) DO 410 K = 1, NF24 D(31) = D(31) + D(30) D(32) = B(3) * SIN(D(31) / GL(5)) + B(1) D(33) = B(3) * COS(D(31) / GL(5)) + B(2) CALL GGIP (D(32), D(33), 0.0, 2) 410 CONTINUE 420 CONTINUE ENDIF 430 CALL GGIP (0.0, 1.0, 0.0, 0) IF (NF(1) .LT. NPOLY .OR. NF(2) .LT. NRCRC) GOTO 40 440 RETURN END SUBROUTINE PLA105 PARAMETER (NPVD=40000000,NP23=18000,NP26 = 6000,NP27 = 1000, 4 NP28=3024) COMMON // JNSC(2, NP23), 1 VOID(NPVD - 5 * NP26 - 9 * NP27 - NP28 - 1560), B(24), 1 A(NP26, 5), IP(NP27, 9), IO(NP28), IG1(100), IG2(100), 2 R(400, 3), IF1(6), NF(68), D(62) R(1, 1) = B(9) R(1, 2) = B(10) R(1, 3) = 0.0 R(2, 1) = B(11) R(2, 2) = B(12) R(2, 3) = SQRT((B(9) - B(11))**2 + (B(10) - B(12))**2) NF(15) = 2 IF (NF(4) .GT. 0) THEN DO 5 I = 9, 12 D(I + 4) = B(I) 5 CONTINUE DO 30 I = 1, NF(4) NF(16) = IP(IG1(I), 9) - 1 DO 20 J = 2, NF(16) + 1 IF (IP(IG1(I), J) .LT. 1) GOTO 30 IF (IP(IG1(I), J + 1) .LE. 0) NF(16) = J - 1 D(17) = A(IP(IG1(I), J), 2) D(18) = A(IP(IG1(I), J), 3) NF(13) = J - 1 NF(14) = MOD(NF(13), NF(16)) + 2 D(19) = A(IP(IG1(I), NF(14)), 2) D(20) = A(IP(IG1(I), NF(14)), 3) D(9) = D(15) - D(13) D(10) = D(16) - D(14) D(11) = D(19) - D(17) D(12) = D(20) - D(18) DEN = D(9) * D(12) - D(10) * D(11) IF (ABS(DEN) .LE. 1E-8) THEN D(5) = 10.0 ELSE D(5) = (D(10) * (D(17) - D(13)) 1 - D(9) * (D(18) - D(14))) / DEN D(6) = (D(12) * (D(17) - D(13)) 1 - D(11) * (D(18) - D(14))) / DEN D(1) = D(17) + D(5) * D(11) D(2) = D(18) + D(5) * D(12) ENDIF IF (ABS(D(5) - 0.5) .LE. 0.5) THEN IF (ABS(D(6) - 0.5) .LE. 0.5) THEN B(8) = SQRT((B(9) - D(1))**2 + (B(10) - D(2))**2) IF (B(8) .GT. 1E-3) THEN DO 10 K = 1, NF(15) IF (ABS(B(8) - R(K, 3)) .LE. 1E-5) GOTO 20 10 CONTINUE NF(15) = NF(15) + 1 R(NF(15), 1) = D(1) R(NF(15), 2) = D(2) R(NF(15), 3) = B(8) ENDIF ENDIF ENDIF 20 CONTINUE 30 CONTINUE ENDIF IF (NF(5) .GT. 0) THEN DO 40 I = 1, NF(5) B(3) = A(IO(IG2(I)), 5) B(19) = A(IO(IG2(I)), 2) B(20) = A(IO(IG2(I)), 3) D(5) = -1.0 D(6) = -1.0 D(7) = B(9) - B(19) D(8) = B(10) - B(20) D(9) = B(11) - B(9) D(10) = B(12) - B(10) D(11) = D(9)**2 + D(10)**2 D(12) = D(7) * D(9) + D(8) * D(10) D(13) = D(12)**2 - D(11) * (D(7)**2 + D(8)**2 - B(3)**2) IF (D(13) .GE. 0) THEN D(14) = - D(12) / D(11) D(13) = SQRT(D(13)) / D(11) D(5) = D(14) + D(13) D(1) = B(9) + D(5) * D(9) D(2) = B(10) + D(5) * D(10) IF (D(13) .GT. 1E-4) THEN D(6) = D(14) - D(13) D(3) = B(9) + D(6) * D(9) D(4) = B(10) + D(6) * D(10) ENDIF ENDIF IF (ABS(D(5) - 0.5) .LE. 0.5) THEN NF(15) = NF(15) + 1 R(NF(15), 1) = D(1) R(NF(15), 2) = D(2) R(NF(15), 3) = SQRT((B(9) - D(1))**2 + (B(10) - D(2))**2) ENDIF IF (ABS(D(6) - 0.5) .LE. 0.5) THEN NF(15) = NF(15) + 1 R(NF(15), 1) = D(3) R(NF(15), 2) = D(4) R(NF(15), 3) = SQRT((B(9) - D(3))**2 + (B(10) - D(4))**2) ENDIF 40 CONTINUE IF (NF(15) .LE. 0) GOTO 80 ENDIF DO 70 I2 = 1, NF(15) - 1 K2 = 0 B(13) = R(I2, 3) DO 50 J2 = I2 + 1, NF(15) IF (B(13) .GE. R(J2, 3)) THEN B(13) = R(J2, 3) K2 = J2 ENDIF 50 CONTINUE IF (K2 .GT. 0) THEN DO 60 J2 = 1, 3 CALL GEN018 (R(I2, J2), R(K2, J2)) 60 CONTINUE ENDIF 70 CONTINUE 80 DO 160 I = 1, NF(15) - 1 B(9) = R(I, 1) B(10) = R(I, 2) B(11) = R(I + 1, 1) B(12) = R(I + 1, 2) B(23) = (B(9) + B(11)) * 0.5 B(24) = (B(10) + B(12)) * 0.5 IF (NF(1) .NE. 1 .AND. NF(4) .NE. 0) THEN DO 140 J = 1, NF(4) NF(3) = IG1(J) DO 90 I0 = 3, 6 IF (IP(NF(3), I0 + 2) .LE. 0) GOTO 100 90 CONTINUE I0 = 6 100 K0 = I0 + MOD(I0, 2) - 1 DO 120 J0 = 1, K0, 2 NF(12) = MOD(J0, I0) + 2 NF(13) = MOD(J0 + 1, I0) + 2 NF(14) = MOD(J0 - 1, I0) + 2 DO 110 J1 = 13, 16 J2 = MOD(J1 + 1, 2) + 2 J3 = 13 + (J1 - 12) / 3 B(J1) = A(IP(NF(3), NF(J3)), J2) 1 - A(IP(NF(3), NF(12)), J2) 110 CONTINUE D(11) = B(23) - A(IP(NF(3), NF(12)), 2) D(12) = B(24) - A(IP(NF(3), NF(12)), 3) D(5) = (D(11) * B(14) - D(12) * B(13)) / 1 (B(15) * B(14) - B(16) * B(13)) D(6) = (D(11) * B(16) - D(12) * B(15)) / 1 (B(13) * B(16) - B(14) * B(15)) D(10) = MIN (D(5), D(6)) IF (D(10) .LE. 0.0) GOTO 130 120 CONTINUE 130 IF (IFIX(SIGN(1.0, D(10))) .GE. 0) GOTO 160 140 CONTINUE ENDIF IF (NF(2) .NE. 0 .AND. NF(5) .NE. 0) THEN DO 150 J = 1, NF(5) B(8) = A(IO(IG2(J)), 5) B(19) = A(IO(IG2(J)), 2) B(20) = A(IO(IG2(J)), 3) IF (SQRT((B(23) - B(19))**2 + (B(24) - B(20))**2) 1 .LE. B(8)) GOTO 160 150 CONTINUE ENDIF IF ((D(23) - B(9))**2 + (D(24) - B(10))**2 .GT. 1E-4) THEN D(23) = B(9) D(24) = B(10) CALL GGIP (D(23), D(24), 0.0, 3) ENDIF IF (NF(10) .LE. 1) THEN CALL GGIP (B(11), B(12), 0.0, 2) ELSE D(10) = D(23) - B(12) D(11) = B(11) - D(24) D(12) = 0.012 / SQRT(D(10)**2 + D(11)**2) D(10) = D(10) * D(12) D(11) = D(11) * D(12) CALL GGIP (B(11), B(12), 0.0, 2) CALL GGIP (B(11) + D(10), B(12) + D(11), 0.0, 2) CALL GGIP (D(23) + D(10), D(24) + D(11), 0.0, 2) CALL GGIP (D(23) - D(10), D(24) - D(11), 0.0, 2) CALL GGIP (B(11) - D(10), B(12) - D(11), 0.0, 2) ENDIF D(23) = B(11) D(24) = B(12) 160 CONTINUE RETURN END SUBROUTINE PLA106 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP15=20,NP17=99,NP19=31, 2 NPVD=40000000,NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125, 3 NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /GGT/ MEDIUM DIMENSION TMAT(3, 3) COMMON /CTRLC/ CC LOGICAL CC DIMENSION DETER(2), QA(3, 3, 2), QC(3, 3, 2), V12(3, 2), YMIN(2), 1 YMAX(2), QCC(3, 3), QD(3, 3), B(3, 3), S(3, 3), Y1(2), Y2(2), 2 W(4, 2), FL(4, 4), QUA(3, 4), AAREV(3, 3) DIMENSION PROBA(9), LPOS(8, 2), POSL(6) COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 DATA LPOS / 2, 2, 2, 5, 1, 1, 1, 5, 3, 6, 4, 4, 4, 6, 3, 3 / DATA PROBA / 1 0.7644, 1.0026, 1.1932, 1.3672, 1.5382, 1.7164, 1.9144, 2 2.1544, 2.5003/ C*********************************************************************C C*********************************************************************C IWIN = IGBL(25) * IGBL(32) NCD = 0 NQD = 0 NBND = 0 IDASH = 0 ID1 = 0 DIST = 0.0 KKK = 0 NPOS = 0 PVER = 0.0 PHOR = 0.0 IPOS = 0 NB = 0 NP = 0 10 NCB = IPR(131) NATOM = IPR(39) NSUP = IPR(64) NASUP = NATOM + NSUP IPR(174) = NASUP + MAX (NASUP, NCB) IF (IPR(174) + NP15 .GT. NP1) THEN IPR(2) = 22 GOTO 1340 ENDIF IF (IGBL(23) .NE. 8 .AND. 1 IGBL(23) .NE. 9 .AND. 1 IGBL(23) .NE. 22) IGBL(23) = 1 20 IPR(477) = 0 K = 0 DO 40 I = 1, NASUP DO 30 J = 1, 3 XXO(I, J) = VOID(K + J + 3) 30 CONTINUE K = K + NP4 + 15 IATP(I) = I + NP1 CALL GEN048 (-1, IFG(I), 7, IHAT) CALL GEN048 (-1, JFG(I), 12, INH) IF (IGBL(59) .NE. 0) THEN CALL GEN048 (-7, JFG(I), 1, IPP) NPOP = IPPR(IPP + 1, 1) IF (NPOP .LT. 1000) THEN IF (IGBL(88) .EQ. 0) THEN IF (IPPR(IPP + 1, 1) .LT. 500) GOTO 40 ELSE IF (IPPR(IPP + 1, 1) .GT. 500) GOTO 40 ENDIF ENDIF ENDIF IF (IHAT .NE. 1 .OR. 1 INH .NE. 0 .OR. 2 IPR(212) .NE. 0) THEN IF (IPR(140) .GT. 0) THEN CALL GEN048 (-6, IFG(I), 9, IRES) IF (IRES .NE. IPR(140)) GOTO 40 ENDIF IPR(477) = IPR(477) + 1 IATP(I) = I ENDIF 40 CONTINUE IF (IGBL(87) .EQ. 0) IGBL(87) = 1 CALL GEN021 (RMAT, IGBL(87)) PAR(389) = 0 IPR(479) = 1 IF (IGBL(67) .EQ. 0) THEN CALL PLA054 (0) DO 50 I = 1, 3 DUMI = DUMV(I, 1) DUMV(I, 1) = -DUMV(I, 3) DUMV(I, 3) = DUMI 50 CONTINUE CALL GEN004 (DUMV, RMAT, RMAT) IGBL(67) = 1 ELSE DO 60 L = 1, 3 X = - GL(27 + L) / GL(5) LLL = L CALL GEN051 (0, RMAT, X, LLL) 60 CONTINUE ENDIF NLOOP = 2 70 IPR(478) = 0 80 IPR(478) = IPR(478) + 1 IF (CC) GOTO 1290 PAR(46) = PROBA(IPR(45)) IF (IPR(108) .NE. 0) THEN OPEN (UNIT = LU65, FILE = NAME(1)(1:KNM(1))//'.rst', 1 STATUS = 'UNKNOWN') WRITE (LU65, 99996) JID(1:50) CALL GEN005 (RMAT, TMAT) ENDIF IF (IPR(116) .EQ. 1) PAR(389) = PAR(389) -9.0 + 6.0 * IPR(478) IF (NLOOP .GE. 1) THEN DUMMY = - PAR(389) / GL(5) CALL GEN051 (0, RMAT, DUMMY, IPR(479)) ENDIF IF (LRET .NE. 6) PAR(389) = 0.0 CALL GEN003 (OR, ROR, DET, 0) CALL GEN004 (ROR, RMAT, RORO) CALL GEN004 (AA, RORO, AAREV) CALL GEN005 (RMAT, DUMV) CALL GEN096 (DUMV, IROTX, IROTY, IROTZ, IDET, V6, YANK, RORO) GL(28) = IROTX GL(29) = IROTY GL(30) = IROTZ IGBL(87) = IDET DO 90 I = 1, 3 VIEWV(I) = RORO(I, 3) 90 CONTINUE CALL GEN007 (AA, VIEWV, VIEWV, -1) PAR(37) = PAR(38) * PAR(50) CALL GEN074 (PAR, -1.E5, 58, 60) CALL GEN074 (PAR, 1.E5, 55, 57) IPR(477) = 0 IREF = IPR(297) DO 150 I = 1, NASUP IREF = IREF + 21 DO 110 J = 1, 9 CON(I, J) = VOID(IREF + J - 21) 110 CONTINUE DO 120 J = 1, 3 IF (I .GT. NATOM) THEN XSD(I, J) = VOID(IREF + J - 12) / 2.0 ELSE XSD(I, J) = VOID(IREF + J - 12) ENDIF 120 CONTINUE IF (IATP(I) .LE. NP1) THEN DO 130 J = 1, 3 V1(J) = VOID((I - 1) * (NP4 + 15) + J) 130 CONTINUE CALL GEN002 (-1, AAREV, V1, DXI, XLNG) IPR(477) = IPR(477) + 1 IATC(IPR(477)) = I DATC(IPR(477)) = DXI(3) CALL GEN048 (-1, JFG(I), 27, ISKP) IF (ISKP .EQ. 0) THEN DO 140 J = 1, 3 PAR(57 + J) = MAX (PAR(57 + J), DXI(J)) PAR(54 + J) = MIN (PAR(54 + J), DXI(J)) 140 CONTINUE ENDIF ENDIF 150 CONTINUE C * AUTOMATIC SCALE AND POSITION DETERMINATION SECTION PAR(45) = (PAR(37) - PAR(40) * 2.0) / 1 (PAR(58) - PAR(55) + 2.0 * PAR(41)) PAR(45) = MIN (PAR(45), (PAR(38) - PAR(40) * 2.0) / 1 (PAR(59) - PAR(56) + 2.0 * PAR(41))) PAR(47) = PAR(45) * PAR(46) DO 160 J = 1, 2 V2(J) = (PAR(36 + J) - PAR(45) * 1 (PAR(57 + J) + PAR(54 + J))) / 2.0 160 CONTINUE V2(3) = 0.0 CALL GEN013 (DATC, IATC, 1, IPR(477)) DO 260 IA = 1, IPR(477) NIA = NASUP + IA IIA = IATC(IA) IF (IIA .NE. 0) THEN CALL GEN048 (-1, JFG(IIA), 27, ISKP) IF (ISKP .EQ. 0) THEN DO 170 J = 1, 3 V1(J) = VOID((IIA - 1) * (NP4 + 15) + J) IF (XSD(IIA, J) .LT. 0.001) XSD(IIA,J) = 0.001 V6(J) = 1.0 / XSD(IIA, J)**2 170 CONTINUE CALL GEN002 (-1, AAREV, V1, DXI, XLNG) IF (IPR(108) .NE. 0) THEN CALL PLA047 (XLAB(IIA), NQ2, IDUM, JDUM, 0, IGBL(55), 1 1, 0) WRITE (LU65, 99998) 1 IIA, NQ2, 0, (DXI(J), J = 1, 3), 1.0, 0.0 L = 0 IANI = 1 CALL GEN048 (-1, IFG(IIA), 7, IHAT) IF (IHAT .EQ. 1) THEN CALL GEN048 (-1, IFG(IIA), 4, IANI) ENDIF DO 190 J = 1, 3 DO 180 K = 1, 3 L = L + 1 UIJC(J, K) = VOID(IPR(297) + IIA * 21 + L - 9) 1 * 10000.0 IF ((IANI .EQ. 0 .OR. NQ2(1:2) .EQ. 'CG') 1 .AND. J .EQ. K) UIJC(J, K) = 25 180 CONTINUE 190 CONTINUE CALL GEN001 (1, TMAT, UIJC, UIJC) WRITE (LU65, 99997) 1 IIA, NQ2, 0, (NINT(UIJC(J, J)), J = 1, 3), 2 NINT(UIJC(1, 2)), NINT(UIJC(1, 3)), NINT(UIJC(2, 3)) ENDIF DO 200 J = 1, 3 XXO(IA, J) = DXI(J) * PAR(45) + V2(J) 200 CONTINUE DO 210 I = 1, 9 J = MOD (I - 1, 3) + 1 K = ((I - 1) / 3) + 1 PAT(J, K) = CON(IIA, I) 210 CONTINUE CALL GEN005 (AAREV, QD) CALL GEN004 (QD, PAT, PAC) CALL GEN099 (PAC, V6, QD) DO 230 J = 1, 2 DO 220 K = 1, 2 QD(J, K) = QD(J, K) - QD(J, 3) * QD(K, 3) / QD(3, 3) 220 CONTINUE 230 CONTINUE DO 240 J = 1, 2 QD(J, 3) = 0.0 QD(3, J) = 0.0 V6(J) = XXO(IA, J) 240 CONTINUE QD(3, 3) = - PAR(47)**2 CALL GEN003 (QD, QCC, DUMMY, 1) TD2 = QD(3, 3) NDG = 0 DO 250 J = 1, 2 T1 = QCC(3, J)**2 - QCC(J, J) IF (T1 .LE. 0.0) THEN NDG = 1 V5(J) = 0.001 + PAR(44) ELSE V5(J) = SQRT(T1) + PAR(44) V6(J) = V6(J) + QCC(3, J) TD2 = TD2 + QD(3, J) * QCC(3, J) ENDIF XXO(NIA, 2 * J - 1) = V6(J) - V5(J) XXO(NIA, 2 * J) = V6(J) + V5(J) 250 CONTINUE IF (NDG .EQ. 0) THEN IF (TD2 .LT. 0.0) THEN TD3 = - (1.0 - 2.0 * PAR(44) / (V5(1) + V5(2)))**2 1 / TD2 XSD(NIA, 1) = QD(1, 1) * TD3 XSD(NIA, 2) = QD(1, 2) * TD3 XSD(NIA, 3) = QD(2, 2) * TD3 GOTO 260 ENDIF ENDIF XSD(NIA, 1) = 4.0 / (XXO(NIA, 2) - XXO(NIA, 1))**2 XSD(NIA, 2) = 0.0 XSD(NIA, 3) = 4.0 / (XXO(NIA, 4) - XXO(NIA, 3))**2 ENDIF ENDIF 260 CONTINUE K = NASUP + 1 NCD = 0 DO 270 I = 1, NCB XSD(K, 4) = VOID(IPR(298) + I * 3 - 2) XSD(K, 5) = VOID(IPR(298) + I * 3 - 1) XBND = VOID(IPR(298) + I * 3) XB = PAR(84 + NINT(ABS(XBND))) IF (XB .LT. 0) THEN XB = - XB XBND = - ABS(XBND) ENDIF XSD(K, 6) = SIGN(128 / 2**XB, XBND) XXO(K, 5) = PAR(85 + NINT(ABS(XBND))) IF (IATP(NINT(XSD(K, 4))) .LT. NP1) THEN NCD = NCD + 1 K = K + 1 ENDIF 270 CONTINUE IF (IPR(108) .NE. 0) THEN CLOSE (LU65) IF (IPR(477) .GT. 1) CALL PLA209 IPR(108) = 0 GOTO 80 ENDIF 280 CALL GEN074 (SCIR, 0.0, 1, 390) CALL GEN074 (DP, 0.0, 1, 260) C * GRAPHICS OUTPUT SECTION PVER = PAR(349) IF (IPR(478) .LE. 1 .AND. NLOOP .GE. 1) THEN BCD(1:12) = 'P.L.A.T.O.N'//CHAR(0) CALL GGIP (PAR(37), PAR(38), 0.0, 1) ENDIF IF (IWIN .EQ. 1 .AND. LRET .EQ. 6) THEN BCD = 'Click on Window to STOP Rotation'//CHAR(0) CALL GGIP (-999.0, 2.0, 33.0, 111) ENDIF IF (IPR(116) .EQ. 0) THEN CALL GGIP (0.0, 1.0, 0.0, 0) ELSE CALL GGIP (0.0, FLOAT(IPR(143 + IPR(478) - 1)), 0.0, 0) ENDIF CALL PLA117 (PAR(37), PAR(38), 1) IF (NCD .GT. 0 .OR. IPR(201) .EQ. 0) THEN NQD = 0 V8(1) = 0.0 V8(2) = 0.0 V8(3) = 1.0 IF (NCD .EQ. 0) THEN MILP = 3 ELSE MILP = 1 ENDIF IF (IGBL(75) .NE. 0 .AND. 1 IPR(201) .EQ. 0) THEN MLP = 3 ELSE MLP = 2 ENDIF DO 870 MLOOP = MILP, MLP IF (MLOOP .LT. 3) THEN MNB = NCD ELSE MNB = IPR(477) ENDIF DO 860 NBLP = 1, MNB IF (CC) GOTO 1290 NSHIFT = 1 545 IF (MLOOP .LT. 3) THEN NBND = NINT(XSD(NASUP + NBLP, 6)) IF (NBND .GT. 0) THEN IDASH = 0 ELSE IDASH = 1 NBND = IABS(NBND) ENDIF KD1 = NINT(XSD(NASUP + NBLP, 4)) KD2 = NINT(XSD(NASUP + NBLP, 5)) W(1, 1) = KD1 W(1, 2) = KD2 NA1 = 0 NA2 = 0 DO 310 K = 1, IPR(477) III = IATC(K) IF (III .EQ. 0) GOTO 310 I = 0 IF (III .EQ. KD1) THEN NA1 = K I = 1 CALL GEN048 (-1, JFG(III), 27, ISKP) IF (ISKP .EQ. 1) GOTO 860 ELSE IF (III .EQ. KD2) THEN NA2 = K I = 2 CALL GEN048 (-1, JFG(III), 27, ISKP) IF (ISKP .EQ. 1) GOTO 860 ENDIF IF (I .NE. 0) THEN DO 290 J = 2, 4 W(J, I) = XXO(K, J - 1) 290 CONTINUE IF (NA1 .GT. 0 .AND. NA2 .GT. 0) THEN IF (W(4, 1) .LT. W(4, 2)) THEN DO 300 J = 1, 4 CALL GEN018 (W(J, 1), W(J, 2)) 300 CONTINUE CALL GEN014 (NA1, NA2) ENDIF ID1 = NA1 * (NP1 + 1) + NA2 GOTO 320 ENDIF ENDIF 310 CONTINUE GOTO 860 320 DO 330 I = 1, 3 DAM(I, 3) = W(1 + I, 2) - W(1 + I, 1) 330 CONTINUE CALL GEN007 (AA, DAM(1, 3), V3, 1) IF (MLOOP .EQ. 2) DIST = SQRT(DAM(1, 3)**2 + DAM(2, 3)**2 1 + DAM(3, 3)**2) / PAR(45) CALL GEN002 (-1, RORO, AAREV(1, 3), V2, XLNG) CALL GEN007 (AA, V2, V2, 1) T6 = ABS(GEN009 (V3, V2)) IF (0.9994 .LE. T6) GOTO 860 CALL GEN019 (AA, BB, V3, V2, B, 1) TX = XXO(NASUP + NBLP, 5) / PAR(46) DO 340 J = 1, 3 T1 = - B(J, 2) * TX SCIR(J, 1) = T1 SCIR(J, 129) = T1 SCIR(J, 65) = - T1 T1 = - B(J, 3) * TX SCIR(J, 33) = T1 SCIR(J, 97) = - T1 340 CONTINUE DO 370 K = 1, 3 T1 = SQRT(1.0 / 1 (2.0 * (1.0 + COS(GL(6) / (2**(K + 1)))))) KDEL = 2**(6 - K) KDEL1 = KDEL + 1 KDEL2 = KDEL / 2 DO 360 L = KDEL1, 65, KDEL J = L - KDEL M = L - KDEL2 DO 350 N = 1, 3 T2 = (SCIR(N, L) + SCIR(N, J)) * T1 SCIR(N, M) = T2 SCIR(N, M + 64) = -T2 350 CONTINUE 360 CONTINUE 370 CONTINUE DO 520 II = 1, 2 III = NINT(W(1, II)) DO 380 I = 1, 9 J = MOD (I - 1, 3) + 1 K = ((I - 1) / 3) + 1 PAT(J, K) = CON(III, I) 380 CONTINUE CALL GEN005 (AAREV, QM) CALL GEN004 (QM, PAT, PAC) DO 390 J = 1, 3 IF (XSD(III, J) .NE. 0.0) THEN V6(J) = 1.0 / XSD(III, J)**2 ELSE V6(J) = 1.0 ENDIF 390 CONTINUE CALL GEN099 (PAC, V6, QM) T1 = 3 - II * 2 DO 400 J = 1, 3 V3(J) = V3(J) * T1 400 CONTINUE IF (GEN006 (V3, QM, V8) .LT. 0.0) THEN IBND = 0 T1 = - 1.0 / QM(3, 3) DO 420 J = 1, 2 DO 410 K = 1, 2 S(K, J) = QM(K, J) + QM(K, 3) * QM(J, 3) * T1 410 CONTINUE S(3, J) = 0.0 S(J, 3) = 0.0 420 CONTINUE S(3, 3) = 0.0 ELSE DO 440 J = 1, 3 DO 430 K = 1, 3 S(J, K) = QM(J, K) 430 CONTINUE 440 CONTINUE IBND = II ENDIF T5 = 1.0 IF (II .LT. 2) THEN RADIUS = 1.0 + T6 * PAR(48) ELSE RADIUS = 1.0 - T6 * PAR(48) ENDIF CALL GEN002 (1, S, V3, V4, XLNG) T2 = GEN009 (V3, V4) KL = 5 - 2 * II IF (MLOOP .EQ. 2) THEN KSTP = 4 ELSE KSTP = 32 ENDIF DO 470 K = 1, 65, KSTP DO 450 J = 1, 3 V6(J) = SCIR(J, K) * RADIUS V5(J) = V6(J) 450 CONTINUE T3 = GEN009 (V5, V4) T4 = T3 * T3 - T2 * (GEN006(V5, S, V5) - T5) IF (T4 .LT. 0.0000001) GOTO 860 T4 = SQRT(T4) T1 = ( T4 - T3) / T2 T3 = (-T4 - T3) / T2 L = K + KL - 1 DO 460 J = 1, 3 SCIR(J, L) = ( V6(J) + T1 * V3(J)) * PAR(47) SCIR(J, L + 1) = (-V6(J) - T3 * V3(J)) * PAR(47) 460 CONTINUE 470 CONTINUE IF (IBND + MLOOP .EQ. 2) THEN T4 = T2 * T5 IF (T4 .LT. 0.0) GOTO 860 T1 = SQRT(T4) / T2 DO 480 J = 1, 3 T4 = (T1 * V3(J) * PAR(47) - 0.5 * (SCIR(J, KL) 1 + SCIR(J, KL + 64))) * 1.001 SCIR(J, KL) = SCIR(J, KL) + T4 SCIR(J, KL + 64) = SCIR(J, KL + 64) + T4 480 CONTINUE ENDIF DO 490 I = 1, 65, KSTP DP(1, II - 1 + I) = SCIR(1, KL - 1 + I) + W(2, II) DP(2, II - 1 + I) = SCIR(2, KL - 1 + I) + W(3, II) 490 CONTINUE IF (IBND .EQ. 1) THEN DO 500 I = 68, 128, KSTP DP(1, II + I) = SCIR(1, KL - 63 + I) + W(2, II) DP(2, II + I) = SCIR(2, KL - 63 + I) + W(3, II) 500 CONTINUE GOTO 520 ENDIF DO 510 K = 4, 64, 4 L = K + II M = L + 64 N = 66 - L IF (N .LE. 0) GOTO 520 DP(1, M) = DP(1, N) DP(2, M) = DP(2, N) 510 CONTINUE 520 CONTINUE DO 540 K = 1, 65, 32 T1 = 0.0 T2 = 0.0 DO 530 J = 1, 2 T1 = T1 + (DP(J, K) - W(J + 1, 1))**2 T2 = T2 + (DP(J, K + 1) - W(J + 1, 1))**2 530 CONTINUE IF (T2 .LE. T1) GOTO 860 540 CONTINUE ELSE NTOM = NASUP + NBLP KKK = IATC(NBLP) IF (KKK .EQ. 0) GOTO 860 IF (KKK .GT. NATOM) THEN IF (IPR(506) .EQ. 0) GOTO 860 ENDIF CALL GEN048 (-4, IFG(KKK), 15, NO1) CALL GEN048 (-1, JFG(KKK), 12, INH) CALL GEN048 (-1, IFG(KKK), 7, IHAT) NO1 = NO1 + 1 IF (IHAT .NE. 1 .OR. 1 MAX (IPR(212), INH) * IPR(232) .EQ. 1) THEN NPOS = 0 CALL PLA047 (XLAB(KKK), NQ1, IDUM, JDUM, 1 IPR(350) * 2 - 1, IGBL(55), 0, 1 - IGBL(55)) CALL GEN039 (1, NQ1, 1, 6, NB, NP) NSHIFT = NSHIFT + 2 PAR71 = NSHIFT * PAR(71) XSFT = (XXO(NTOM, 2) - XXO(NTOM, 1)) / 7.0 YSFT = (XXO(NTOM, 4) - XXO(NTOM, 3)) / 7.0 PHOR = PVER * NP * 6.0 / 7.0 POSL(1) = XXO(NTOM, 1) - PHOR - PAR71 POSL(2) = XXO(NTOM, 2) + PAR71 POSL(3) = XXO(NTOM, 3) - PVER - PAR71 POSL(4) = XXO(NTOM, 4) + PAR71 POSL(5) = (POSL(1) + POSL(2)) / 2.0 POSL(6) = (POSL(3) + POSL(4)) / 2.0 IF (POSL(5) .GT. PAR(37) / 2.0) THEN IF (POSL(6) .GT. PAR(38) / 2.0) THEN IPOS = 2 ELSE IPOS = 0 ENDIF ELSE IF (POSL(6) .GT. PAR(37) / 2.0) THEN IPOS = 4 ELSE IPOS = 6 ENDIF ENDIF ELSE GOTO 860 ENDIF ENDIF IF (MLOOP .EQ. 1) THEN NQD = NQD + 1 T1 = 0.0 T2 = 0.0 DO 570 J = 1, 2 Y1(J) = DP(J, 1) - DP(J, 65) Y2(J) = DP(J, 2) - DP(J, 66) T1 = T1 + Y1(J)**2 T2 = T2 + Y2(J)**2 570 CONTINUE IF (T1 * T2 .LE. 0.0) THEN T1 = 0.0 T2 = 0.0 ELSE T1 = PAR(44) / SQRT(T1) T2 = PAR(44) / SQRT(T2) ENDIF NREF = NASUP + NQD DO 580 J = 1, 2 Y1(J) = Y1(J) * T1 Y2(J) = Y2(J) * T2 CON(NREF, J) = DP(J, 1) + Y1(J) CON(NREF, J + 2) = DP(J, 2) + Y2(J) CON(NREF, J + 4) = DP(J, 66) - Y2(J) CON(NREF, J + 6) = DP(J, 65) - Y1(J) 580 CONTINUE CON(NREF, 9) = ID1 ELSE 590 IF (MLOOP .EQ. 3) THEN 600 IPOS = MOD(IPOS, 8) + 1 NPOS = NPOS + 1 KKKA = KKK * (NP4 + 15) IF (NPOS .GT. 8) THEN IF (NSHIFT .LT. 10) GOTO 545 WRITE (LU6, 99999) NQ1 IF (IGBL(105) .EQ. 0) THEN VOID(KKKA - 2) = 0.0 VOID(KKKA - 1) = 0.0 VOID(KKKA ) = 0.0 ELSE VOID(KKKA - 2) = POSL(LPOS(8, 1)) VOID(KKKA - 1) = POSL(LPOS(8, 2)) VOID(KKKA ) = PHOR ENDIF GOTO 860 ENDIF LPOS1 = LPOS(IPOS, 1) LPOS2 = LPOS(IPOS, 2) XSHFT = 0.0 YSHFT = 0.0 LPOS12 = LPOS1 * 10 + LPOS2 IF (LPOS12 .EQ. 23) THEN XSHFT = - XSFT YSHFT = YSFT ELSE IF (LPOS12 .EQ. 24) THEN XSHFT = - XSFT YSHFT = - YSFT ELSE IF (LPOS12 .EQ. 14) THEN XSHFT = XSFT YSHFT = - YSFT ELSE IF (LPOS12 .EQ. 13) THEN XSHFT = XSFT YSHFT = YSFT ENDIF VOID(KKKA - 2) = POSL(LPOS1) + XSHFT VOID(KKKA - 1) = POSL(LPOS2) + YSHFT VOID(KKKA ) = PHOR DP(1, 1) = VOID(KKKA - 2) DP(2, 1) = VOID(KKKA - 1) DP(1, 2) = DP(1, 1) DP(2, 2) = DP(2, 1) + PVER DP(1, 65) = DP(1, 1) + PHOR DP(2, 65) = DP(2, 1) DP(1, 66) = DP(1, 65) DP(2, 66) = DP(2, 2) IF (DP(1, 1) .LT. 0.0 .OR. DP(1, 65) .GT. PAR(37) .OR. 1 DP(2, 1) .LT. 0.0 .OR. DP(2, 65) .GT. PAR(38)) 2 GOTO 600 ID1 = 0 NA1 = 0 NA2 = 0 IF (NBLP .GT. 1) THEN NBM1 = NBLP - 1 DO 610 J = 1, NBM1 JJJ = IATC(J) IF (JJJ .NE. 0) THEN CALL GEN048 (-1, JFG(JJJ), 27, ISKP) IF (ISKP .EQ. 0) THEN IF (IPR(232) .EQ. 0) THEN CALL GEN048 (-1, IFG(JJJ), 7, JHAT) ISKP = JHAT ENDIF IF (ISKP .EQ. 0) THEN KKKK = KKK * (NP4 + 15) JJJJ = JJJ * (NP4 + 15) DSX = ABS(VOID(KKKK - 2) - VOID(JJJJ - 2)) DSY = ABS(VOID(KKKK - 1) - VOID(JJJJ - 1)) IF (DSY .LT. 1.1 * PAR(349)) THEN IF (DSX .LT. MAX (PHOR, VOID(JJJJ))) 1 GOTO 600 ENDIF ENDIF ENDIF ENDIF 610 CONTINUE ENDIF IF (IGBL(74) .NE. 0) THEN CALL GGIP (DP(1, 1), DP(2, 1), 0.0, 3) CALL GGIP (DP(1, 65), DP(2, 65), 0.0, 2) CALL GGIP (DP(1, 66), DP(2, 66), 0.0, 2) CALL GGIP (DP(1, 2), DP(2, 2), 0.0, 2) CALL GGIP (DP(1, 1), DP(2, 1), 0.0, 2) CALL GGIP20 (0.0, CHAR(48 + IPOS), 1, 0.3, 2, 1, 1 DP(1,1),DP(2,1)) ENDIF ENDIF IPR(151) = 0 IPR(152) = 0 IQ = NQD + 1 IQN = IQ + NASUP DO 620 J = 1, 2 YMIN(J) = MIN(DP(J, 1), DP(J, 2), DP(J, 66), DP(J, 65)) YMAX(J) = MAX(DP(J, 1), DP(J, 2), DP(J, 66), DP(J, 65)) CON(IQN, J) = DP(J, 1) CON(IQN, J + 2) = DP(J, 2) CON(IQN, J + 4) = DP(J, 66) CON(IQN, J + 6) = DP(J, 65) 620 CONTINUE CON(IQN, 9) = ID1 CALL PLA107 (0, 0, 0, DUMP) NA1P1 = NA1 + 1 DO 640 IA = NA1P1, IPR(477) IATCIA = IATC(IA) IF (IATCIA .NE. 0) THEN IF (IA .NE. NA2 .AND. IATCIA .LE. NATOM) THEN NIA = NASUP + IA CALL GEN048 (-1, JFG(IATCIA), 27, ISKP) IF (ISKP .NE. 1) THEN DO 630 J = 1, 2 IF (YMAX(J) .LE. XXO(NIA, 2 * J - 1)) GOTO 640 IF (YMIN(J) .GE. XXO(NIA, 2 * J )) GOTO 640 630 CONTINUE CALL PLA107 (IQ, IA, 1, DUMP) IF (DUMP .GT. 0.0) THEN IF (IPR(151) .GE. NP15) GOTO 650 ELSE IF (DUMP .LT. 0.0) THEN GOTO 860 ENDIF ENDIF ENDIF ENDIF 640 CONTINUE 650 IF (NQD .GT. 0) THEN IF (MLOOP .LT. 3) THEN DO 660 III = 1, 3 V1(III) = XXO(NA2, III) - XXO(NA1, III) 660 CONTINUE CALL GEN007 (AA, V1, V1, 1) ENDIF DO 810 IB = 1, NQD NIB = NASUP + IB ID2 = NINT(CON(NIB, 9)) IF (ID1 .EQ. ID2) GOTO 810 NB2 = MOD(ID2, NP1 + 1) NB1 = ID2 / (NP1 + 1) IF (NA2 .GT. NB1) GOTO 810 DO 670 J = 1, 2 IF (YMAX(J) .LE. MIN (CON(NIB, J), CON(NIB, J + 2), 1 CON(NIB, J + 4), CON(NIB, J + 6))) GOTO 810 IF (YMIN(J) .GE. MAX (CON(NIB, J), CON(NIB, J + 2), 1 CON(NIB, J + 4), CON(NIB, J + 6))) GOTO 810 670 CONTINUE DO 690 L = 1, 4 K = 2 * L K1 = MOD(K, 8) + 2 QUA(1, L) = CON(NIB, K) - CON(NIB, K1) QUA(2, L) = CON(NIB, K1 - 1) - CON(NIB, K - 1) QUA(3, L) = CON(NIB, K - 1) * CON(NIB, K1) 1 - CON(NIB, K) * CON(NIB, K1 - 1) T1 = SQRT(QUA(1, L)**2 + QUA(2, L)**2) IF (T1 .LE. 0.0) GOTO 810 DO 680 J = 1, 3 QUA(J, L) = QUA(J, L) / T1 680 CONTINUE 690 CONTINUE T3 = 3.0 NASIQ = NASUP + IQ SCONX = 0.0 SCONY = 0.0 DO 710 K = 1, 4 T2 = 3.0 J = K * 2 XCONK = CON(NASIQ, J - 1) YCONK = CON(NASIQ, J) SCONX = SCONX + XCONK SCONY = SCONY + YCONK DO 700 L = 1, 4 T1 = XCONK * QUA(1, L) 1 + YCONK * QUA(2, L) + QUA(3, L) IF (T1 .LT. 0.0) T2 = T2 - 1.0 FL(L, K) = T1 700 CONTINUE IF (T2 .LT. 0.0) T3 = T3 - 1.0 710 CONTINUE IF (MLOOP .EQ. 3) THEN XCONK = SCONX / 4.0 YCONK = SCONY / 4.0 T2 = 3.0 DO 715 L = 1, 4 T1 = XCONK * QUA(1, L) 1 + YCONK * QUA(2, L) + QUA(3, L) IF (T1 .LT. 0.0) T2 = T2 - 1.0 715 CONTINUE IF (T2 .LT. 0.0) GOTO 590 ENDIF IF (T3 .LT. 0.0) THEN ITYPE = -1 ELSE IF (T3 .LT. 3.0) THEN ITYPE = 0 ELSE NASIQ = NASUP + IQ DO 730 L = 1, 4 L1 = MOD(L, 4) + 1 Y1(1) = CON(NASIQ, L * 2 - 1) Y1(2) = CON(NASIQ, L * 2) Y2(1) = CON(NASIQ, L1 * 2 - 1) Y2(2) = CON(NASIQ, L1 * 2) DO 720 K = 1, 4 T1 = FL(K, L) T2 = FL(K, L1) T3 = T1 - T2 IF (T1 * T2 .LE. 0.0) THEN IF (ABS(T3) .GT. PAR(54)) THEN 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) IF ((T4 - CON(NIB, K0 - 1)) * 1 (CON(NIB, K1 - 1) - T4) 2 + (T5 - CON(NIB, K0)) * 3 (CON(NIB, K1) - T5) 4 .GT. -1.E-4) GOTO 740 ENDIF ENDIF 720 CONTINUE 730 CONTINUE GOTO 810 740 ITYPE = 1 ENDIF IF (MLOOP .LT. 3) THEN IF (NA1 .EQ. NB1 .OR. 1 NA1 .EQ. NB2 .OR. 2 NA2 .EQ. NB2 .OR. 3 NA2 .EQ. NB1) THEN IF ((NA1 + NA2) .LT. (NB1 + NB2)) THEN GOTO 780 ELSE GOTO 810 ENDIF ENDIF DO 750 J = 1, 3 V2(J) = XXO(NB2, J) - XXO(NB1, J) V4(J) = XXO(NB1, J) - XXO(NA1, J) 750 CONTINUE CALL GEN007 (AA, V2, V2, 1) CALL GEN007 (AA, V4, V4, 1) CALL GEN011 (BB, V1, V2, V3, 1) IF (GEN009 (V3, V3) .LE. PAR(54)) THEN CALL GEN011 (BB, V1, V4, V5, 1) CALL GEN011 (BB, V5, V1, V3, 1) YUNK = GEN009 (V3, V3) - PAR(54) IF (YUNK .GT. 0.0) THEN GOTO 770 ELSE GOTO 780 ENDIF ENDIF IF (GEN009 (V3, V4) .LT. - PAR(54)) THEN DO 760 J = 1, 3 V3(J) = - V3(J) 760 CONTINUE ENDIF 770 IF (V3(3) .LE. 0.0) GOTO 810 ENDIF 780 IF (ITYPE .LT. 0) GOTO 860 IF (IPR(152) .GE. NP7) GOTO 820 IPR(152) = IPR(152) + 1 DO 800 K = 1, 4 DO 790 J = 1, 3 XDIR(IPR(152), J, K) = QUA(J, K) 790 CONTINUE 800 CONTINUE IDIR(IPR(152)) = IB 810 CONTINUE ENDIF 820 IF (MLOOP .LT. 3) THEN CALL PLA108 (1, 4, 129, 3) CALL PLA108 (2, 4, 66, 3) BDIR = - 0.5 DO 850 K = 1, 65, NBND BDIR = - BDIR DO 830 J = 1, 2 DP(J, 130 + NINT(1.5 - BDIR)) = DP(J, K) DP(J, 130 + NINT(1.5 + BDIR)) = DP(J, K + 1) 830 CONTINUE IF (IDASH .EQ. 1) THEN NSTEP = NINT(DIST / 0.4) * 2 + 1 ELSE NSTEP = 1 ENDIF DELX = (DP(1, 132) - DP(1, 131)) / NSTEP DELY = (DP(2, 132) - DP(2, 131)) / NSTEP DO 840 J = 1, NSTEP, 2 DP(1, 132) = DP(1, 131) + DELX DP(2, 132) = DP(2, 131) + DELY CALL PLA108 (131, 1, 132, 3) DP(1, 131) = DP(1, 131) + 2 * DELX DP(2, 131) = DP(2, 131) + 2 * DELY 840 CONTINUE 850 CONTINUE ELSE IF (IPR(151) .GT. 0 .OR. IPR(152) .GT. 0) GOTO 590 ENDIF ENDIF 860 CONTINUE 870 CONTINUE ENDIF C * LOOP THROUGH ATOM LIST TO DRAW ELLIPSOIDS DO 1280 ITOM = 1, IPR(477) IF (CC) GOTO 1290 NTOM = NASUP + ITOM KKK = IATC(ITOM) IF (KKK .EQ. 0) GOTO 1280 IF (KKK .GT. NATOM) THEN IF (IPR(506) .EQ. 0) GOTO 1280 ENDIF CALL GEN048 (-1, JFG(KKK), 27, ISKP) IF (ISKP .EQ. 1) GOTO 1280 DO 880 J = 1, 2 YMIN(J) = XXO(NTOM, 2 * J - 1) YMAX(J) = XXO(NTOM, 2 * J ) 880 CONTINUE CALL GEN048 (-4, IFG(KKK), 15, NO1) NO1 = NO1 + 1 IF (IEN(NO1) .EQ. 2) THEN NFRST = IPR(175) LINES = IPR(176) ELSE IF (IEN(NO1) .EQ. 1 .OR. IEN(NO1) .EQ. 33 .OR. 1 IEN(NO1) .EQ. 113) THEN NFRST = IPR(177) LINES = IPR(178) ELSE NFRST = IPR(179) LINES = IPR(180) ENDIF IF (IPR(211) .EQ. 1) THEN NFRST = 0 ELSE IF (IPR(211) .EQ. 2) THEN CALL GEN048 (-1, IFG(KKK), 7, IVAL) IF (IVAL .EQ. 0) THEN NFRST = 1 ELSE NFRST = IPR(177) ENDIF LINES = IPR(180) ENDIF DO 890 J = 1, 3 V1(J) = VOID((KKK -1) * (NP4 + 15) + J) DXI(J) = XXO(ITOM, J) 890 CONTINUE CALL PLA047 (XLAB(KKK), NQ1, IDUM, JDUM, IPR(350) * 2 - 1, 1 IGBL(55), 0, 1 - IGBL(55)) IF (IGBL(75) .GT. 0) THEN CALL GEN048 (-1, JFG(KKK), 11, IVAL) CALL GEN048 (-1, JFG(KKK), 12, INH) CALL GEN048 (-1, IFG(KKK), 7, IHAT) IF (IHAT .NE. 1 .OR. 1 MAX (IPR(212), INH) * IPR(232) .GT. 0) THEN IF (IPR(116) .EQ. 0) THEN IF (IPR(328) .EQ. 0) THEN COLX = FLOAT(IVAL) ELSE COLX = FLOAT (2 - IVAL) ENDIF CALL GGIP (0.0, COLX, 0.0, 0) ENDIF XLPOS = VOID(KKK * (NP4 + 15) - 2) YLPOS = VOID(KKK * (NP4 + 15) - 1) IF ((XLPOS .GT. 1.0 .OR. YLPOS .GT. 1.0) 1 .AND. COLX .NE. 0.0) CALL GGIP20 1 (0.0, NQ1, 6, PAR(349), -1, 1, XLPOS, YLPOS) IF (IPR(116) .EQ. 0) CALL GGIP (0.0, 1.0, 0.0, 0) ENDIF ENDIF IF (KKK .GT. NATOM) GOTO 1280 IF (IPR(116) .EQ. 0 .AND. IPR(346) .EQ. 1) THEN CALL GEN048 (-4, IFG(KKK), 15, NRI) CALL GGIP (0.0, FLOAT(IACL(NRI + 1)) , 0.0, 0) ENDIF IPR(151) = 0 IPR(152) = 0 IF (IPR(477) .GT. ITOM) THEN L = 0 DO 1040 IA = ITOM, IPR(477) IATCIA = IATC(IA) IF (IATCIA .EQ. 0) GOTO 1040 IF (IATCIA .GT. NATOM) GOTO 1040 CALL GEN048 (-1, JFG(IATCIA), 27, ISKP) IF (ISKP .EQ. 1) GOTO 1040 NIA = NASUP + IA IF (IA .GT. ITOM) THEN DO 900 J = 1, 2 IF (YMAX(J) .LE. XXO(NIA, 2 * J - 1)) GOTO 1040 IF (YMIN(J) .GE. XXO(NIA, 2 * J )) GOTO 1040 900 CONTINUE ENDIF IF (L .LT. 2) L = L + 1 IF (L .EQ. 2) THEN OVMR = 0.0 ELSE OVMR = PAR(44) ENDIF V12(1, L) = (XXO(NIA, 1) + XXO(NIA, 2)) * 0.5 V12(2, L) = (XXO(NIA, 3) + XXO(NIA, 4)) * 0.5 V12(3, L) = 1.0 QA(1, 1, L) = XSD(NIA, 1) QA(1, 2, L) = XSD(NIA, 2) QA(2, 1, L) = XSD(NIA, 2) QA(2, 2, L) = XSD(NIA, 3) TX = XXO(NIA, 2) - XXO(NIA, 1) + XXO(NIA, 4) - XXO(NIA, 3) QA(3, 3, L) = -(1.0 - 4.0 * OVMR / TX)**2 DO 920 K = 1, 2 QA(K, 3, L) = 0.0 DO 910 J = 1, 2 QA(K, 3, L) = QA(K, 3, L) - V12(J, L) * QA(J, K, L) 910 CONTINUE QA(3, K, L) = QA(K, 3, L) QA(3, 3, L) = QA(3, 3, L) - QA(3, K, L) * V12(K, L) 920 CONTINUE CALL GEN003 (QA(1, 1, L), QC(1, 1, L), DET, -1) DETER(L) = DET * 3.0 IF (L .LT. 2) GOTO 1040 AOV3 = 0.0 BOV3 = 0.0 DO 940 J = 1, 3 DO 930 K = 1, 3 AOV3 = AOV3 + QC(J, K, 2) * QA(J, K, 1) BOV3 = BOV3 + QC(J, K, 1) * QA(J, K, 2) 930 CONTINUE 940 CONTINUE AOV3 = AOV3 / DETER(2) AOV3SQ = AOV3**2 BOV3 = BOV3 / DETER(2) POV3 = BOV3 - AOV3SQ QOV2 = AOV3 * (AOV3SQ - BOV3 * 1.5) + DETER(1) / 1 (DETER(2) * 2.0) POV3CU = POV3**3 QOV2SQ = QOV2**2 PQTEST = POV3CU + QOV2SQ IF (PQTEST .GT. 0.0) THEN IF (PQTEST + POV3CU * 0.00001 .GT. 0.0) THEN GOTO 1010 ENDIF ELSE IF (PQTEST .LT. 0.0) THEN IF (PQTEST + QOV2SQ * 0.00001 .LT. 0.0) THEN IF (AOV3 .LT. 0.0) THEN IF (BOV3 .LT. 0.0) GOTO 1040 ENDIF IF (QOV2 .EQ. 0.0) THEN PHI = GL(6) / 4.0 ELSE PHI = ATAN(- SQRT( - PQTEST) / QOV2) IF (PHI .LT. 0.0) PHI = PHI + GL(6) / 2.0 ENDIF ROOT = 2.0 * SQRT( - POV3) * COS(PHI / 3.0) - AOV3 GOTO 950 ENDIF ENDIF IF (AOV3 .LT. 0.0 .AND. BOV3 .LT. 0.0) GOTO 1040 ROOT = SIGN(SQRT( - POV3), QOV2) - AOV3 950 DO 970 J = 1, 3 DO 960 K = 1, 3 DAM(J, K) = QA(J, K, 1) + ROOT * QA(J, K, 2) 960 CONTINUE 970 CONTINUE T6 = DAM(1, 1) * DAM(2, 2) T7 = DAM(1, 2)**2 IF (T6 .GT. 1.0001 * T7) THEN GOTO 980 ELSE IF (T6 .LT. 0.9999 * T7) THEN GOTO 1010 ELSE T8 = DAM(3, 3) * (DAM(1, 1) + DAM(2, 2)) T9 = DAM(1, 3)**2 + DAM(2, 3)**2 IF (T8 * 1.0001 .LT. T9) GOTO 1010 ENDIF 980 IF (QC(3, 3, 1) .LT. QC(3, 3, 2)) THEN KA = 2 KB = 1 ELSE KA = 1 KB = 2 ENDIF T1 = 0.0 DO 1000 J = 1, 3 T2 = QA(J, 3, KB) DO 990 K = 1, 2 T2 = T2 + QA(J, K, KB) * V12(K, KA) 990 CONTINUE T1 = T1 + V12(J, KA) * T2 1000 CONTINUE IF (T1 .GT. 0.0) GOTO 1040 IF (KA .EQ. 1) GOTO 1280 1010 IF (IPR(151) .LT. NP15) IPR(151) = IPR(151) + 1 IJ = 1 DO 1030 I = 1, 3 DO 1020 J = I, 3 XXO(IPR(174) + IPR(151), IJ) = QA(I, J, 2) IJ = IJ + 1 1020 CONTINUE 1030 CONTINUE 1040 CONTINUE IF (NQD .GT. 0) THEN CALL PLA107 (0, 0, 0, DUMP) DO 1060 IQ = 1, NQD NIQ = NASUP + IQ ID = NINT(CON(NIQ, 9)) NA1 = ID / (NP1 + 1) NA2 = MOD(ID, NP1 + 1) IF (ITOM .LE. NA2) THEN DO 1050 J = 1, 2 IF (YMAX(J) .LE. MIN (CON(NIQ, J), 1 CON(NIQ, J + 2), CON(NIQ, J + 4), 2 CON(NIQ, J + 6))) GOTO 1060 IF (YMIN(J) .GE. MAX (CON(NIQ, J), 1 CON(NIQ, J + 2), CON(NIQ, J + 4), 2 CON(NIQ, J + 6))) GOTO 1060 1050 CONTINUE CALL PLA107 (IQ, ITOM, -1, YUNK) IF (YUNK .LT. 0.0) GOTO 1280 IF (IPR(152) .GE. NP7) GOTO 1070 ENDIF 1060 CONTINUE ENDIF ENDIF 1070 DO 1080 I = 1, 9 J = MOD (I - 1, 3) + 1 K = ((I - 1) / 3) + 1 PAT(J, K) = CON(KKK, I) 1080 CONTINUE CALL GEN005 (AAREV, QM) CALL GEN004 (QM, PAT, PAC) DO 1090 J = 1, 3 T1 = XSD(KKK, J) IF (T1 .NE. 0.0) THEN V6(J) = 1.0 / (T1**2) ELSE V6(J) = 1.0 ENDIF RMS(J) = T1 1090 CONTINUE CALL GEN099 (PAC, V6, QM) CALL GEN002 (-1, AA, VIEWV, V2, XLNG) DO 1110 I = 1, 3 IF (GEN009 (V2, PAT(1, I)) .LT. 0.0) THEN DO 1100 J = 1, 3 PAC(J, I) = - PAC(J, I) PAT(J, I) = - PAT(J, I) 1100 CONTINUE ENDIF 1110 CONTINUE DO 1120 J = 1, 3 PAC(J, 4) = PAC(J, 1) PAC(J, 5) = PAC(J, 2) 1120 CONTINUE CALL GEN002 (-1, AAREV, VIEWV, V6, XLNG) CALL GEN007 (AA, V6, V6, 1) CALL GEN002 (1, QM, V6, V4, XLNG) CALL GEN007 (AA, V4, V4, 1) T3 = RMS(3) * PAR(47) NRESOL = 1 NBIS = 5 DO 1130 J = 1, 3 IF (T3 .LT. PAR(50 + J)) THEN NBIS = NBIS - 1 NRESOL = NRESOL * 2 ELSE GOTO 1140 ENDIF 1130 CONTINUE 1140 NRES1 = NRESOL + 1 NFIRST = 4 - 3 * NFRST DO 1270 II = NFIRST, 4 II0 = MOD(II + 2, 3) + 1 II1 = MOD(II, 3) + 1 II2 = MOD(II + 1, 3) + 1 IF (0.99938 .LE. ABS(GEN009(V4, PAC(1, II2)))) THEN T1 = RMS(II0) * PAR(47) T2 = RMS(II1) * PAR(47) DO 1150 J = 1, 3 DAM(J, 1) = PAC(J, II0) * T1 DAM(J, 2) = PAC(J, II1) * T2 1150 CONTINUE ELSE CALL GEN011 (BB, PAC(1, II0), PAC(1, II1), V1, 1) CALL GEN011 (BB, V1, V4, V2, 1) CALL GEN007 (AA, V2, V2, 1) CALL GEN002 (1, QM, V2, V3, XLNG) IF (II .LT. 4) THEN CALL GEN011 (BB, V3, V1, V5, 1) ELSE CALL GEN011 (BB, V3, V4, V5, 1) ENDIF CALL GEN007 (AA, V5, V5, 1) T1 = MAX (1.0E-10, GEN006 (V2, QM, V2)) T2 = MAX (1.0E-10, GEN006 (V5, QM, V5)) DO 1160 J = 1, 3 DAM(J, 1) = V2(J) * PAR(47) / SQRT(T1) DAM(J, 2) = V5(J) * PAR(47) / SQRT(T2) 1160 CONTINUE ENDIF DO 1170 J = 1, 3 T1 = DAM(J, 1) SCIR(J, 1) = T1 SCIR(J, 129) = T1 SCIR(J, 65) = -T1 T1 = DAM(J, 2) SCIR(J, 33) = T1 SCIR(J, 97) = -T1 1170 CONTINUE DO 1200 K = 1, NBIS T1 = SQRT(1.0 / (2.0 * (1.0 + COS(GL(6) / 2**(K + 1))))) KDEL = 2**(6 - K) KDEL1 = KDEL + 1 KDEL2 = KDEL / 2 DO 1190 L = KDEL1, 65, KDEL J = L - KDEL M = L - KDEL2 DO 1180 N = 1, 3 T2 = (SCIR(N, L) + SCIR(N, J)) * T1 SCIR(N, M) = T2 SCIR(N, M + 64) = - T2 1180 CONTINUE 1190 CONTINUE 1200 CONTINUE IF (II .LT. 4) THEN JEND = 65 ELSE JEND = 129 ENDIF DO 1210 J = 1, JEND, NRESOL DP(1, J) = SCIR(1, J) + DXI(1) DP(2, J) = SCIR(2, J) + DXI(2) 1210 CONTINUE CALL PLA108 (1, 1, 1, 3) CALL PLA108 (NRES1, NRESOL, JEND, 2) IF (II .LT. 4) THEN DO 1220 J = 1, 3 T1 = PAC(J, II0) * RMS(II0) * PAR(47) DAM(J, 1) = T1 DAM(J, 2) = PAC(J, II1) * RMS(II1) * PAR(47) DAM(J, 3) = 0.0 1220 CONTINUE IF (LINES .GT. 0) THEN DO 1230 I = 1, 3, 1 DP(1, I) = DAM(1, I) + DXI(1) DP(2, I) = DAM(2, I) + DXI(2) 1230 CONTINUE CALL PLA108 (1, 2, 3, 3) L = LINES - 1 IF (L .GT. 0) THEN DO 1250 I = 1, L T1 = FLOAT(I) / LINES T3 = SQRT(1.0 - T1**2) IF (MOD(I, 2) .NE. 0) THEN M = I * 2 N = M - 1 ELSE N = I * 2 M = N - 1 ENDIF DO 1240 J = 1, 3 T4 = DAM(J, 1) * T1 SCIR(J, M) = T4 SCIR(J, N) = DAM(J, 2) * T3 + T4 1240 CONTINUE 1250 CONTINUE L = L * 2 DO 1260 I = 1, L DP(1, I) = SCIR(1, I) + DXI(1) DP(2, I) = SCIR(2, I) + DXI(2) 1260 CONTINUE CALL PLA108 (1, 1, L, -3) ENDIF ENDIF ENDIF 1270 CONTINUE 1280 CONTINUE CALL PLA115 (2, 0, 0.0, 0.0, 0) IF (IGBL(75) .GT. 0) IPR(201) = 1 IF (IPR(478) .GT. 0 .AND. IPR(478) .EQ. IPR(116)) GOTO 80 IF (LRET .EQ. 6) GOTO 1310 1290 IF (IGBL(23) .EQ. 22) THEN CALL GGIP20 (0.0, 'CONTOUR-MAP', 11, 0.8, 5 + IGBL(68), 3, 1 10.0, 0.2) GOTO 1340 ENDIF NLOOP = 2 CALL PLA013 (0, 1) IF (IGBL(3) .EQ. 28) LRET = 7 IF (LRET .EQ. 1) THEN GOTO 1320 ELSE IF (LRET .EQ. 2) THEN GOTO 80 ELSE IF (LRET .EQ. 3) THEN GOTO 280 ELSE IF (LRET .EQ. 4) THEN GOTO 20 ELSE IF (LRET .EQ. 5) THEN CALL PLA115 (1, 0, 0.0, 0.0, 0) GOTO 1290 ELSE IF (LRET .EQ. 6) THEN GOTO 1310 ELSE IF (LRET .EQ. 7) THEN GOTO 1330 ELSE IF (LRET .EQ. 8) THEN GOTO 10 ENDIF 1310 IF (LRET .EQ. 6 .AND. IWIN .EQ. 1) THEN XG = 0.0 YG = 0.0 ZG = 0.0 IG = 9 CALL GGIP (XG, YG, ZG, IG) IF (IG .EQ. 1) CC = .TRUE. ENDIF IPR(201) = 0 IF (IPR(116) .EQ. 0) NLOOP = MOD(NLOOP + 1, 2) GOTO 70 1320 CALL PLA006 (0, IS) IF (IS .EQ. 1) THEN WRITE (LU6, 99995) CALL PLA015 (0, 10) GOTO 1320 ENDIF IF (IFL(1)(1:3) .EQ. 'REM') THEN IGBL(23) = 10 IPR(351) = 0 GOTO 1330 ELSE IF (IFL(1)(1:3) .EQ. 'END' .OR. 1 IFL(1)(1:4) .EQ. 'EXIT') THEN IF (IFL(1)(1:3) .EQ. 'END') REWIND LU2 IF (IGBL(3) .EQ. 3) THEN IGBL(45) = -1 ENDIF GOTO 1330 ENDIF IF (IFL(1)(1:4) .EQ. 'DIST' .OR. 1 IFL(1)(1:4) .EQ. 'ANGL' .OR. 2 IFL(1)(1:4) .EQ. 'TORS') THEN IPR(81) = IPR(220) CALL PLA035 (1) GOTO 1290 ENDIF IF (IFL(1)(1:3) .EQ. 'SET') THEN IF (IFL(2)(1:3) .EQ. 'REV') THEN IGBL(68) = MOD(IGBL(68) + 1, 2) CALL GGIP (-999.0, FLOAT(IGBL(68)), IGBL(62) * 0.25, 9) CALL GGIP (0.0, 0.0, 0.0, 6) IGGT = 'MENU ON' WRITE (LU6,*)'ENTER RETURN' READ (LU5, *) GOTO 1290 ELSE ISW = 1 ENDIF ELSE IF (IFL(1)(1:4) .EQ. 'LIST') THEN ISW = -1 IF (IFL(2)(1:3) .EQ. 'ARU') THEN ISW = 0 CALL PLA043 (0, -2, LU6, 0) CALL PLA013 (1, 1) IGBL(23) = 9 GOTO 20 ELSE IF (IFL(2)(1:3) .EQ. 'UIJ') THEN ISW = 0 IGBL(23) = 9 ELSE IF (IFL(2)(1:4) .EQ. 'ATOM') THEN ISW = 0 IGBL(23) = 9 ELSE IF (IFL(2)(1:4) .EQ. 'FLAG') THEN ISW = 0 IGBL(23) = 9 ELSE IF (IFL(2)(1:5) .EQ. 'RADII') THEN ISW = 0 IGBL(23) = 9 ENDIF ELSE IF (IFL(1)(1:4) .EQ. 'CALC') THEN ISW = 0 IF (IFL(2)(1:4) .EQ. 'COOR') THEN IF (IFL(3)(1:6) .EQ. '******') GOTO 1320 ENDIF ELSE ISW = 0 ENDIF IF (ISW .NE. 0 .AND. IPR(220) .GT. 1) THEN C * SET META TYPE IF (IFL(2)(1:3) .EQ. 'MET') THEN MEDIUM = 2 IF (IPR(220) .GT. 2) CALL GGIP (-999.0, 0.0, 0.0, 6) ELSE CALL PLA206 (ISW, IFL(2)(1:3)) ENDIF ISW = 0 GOTO 1290 ENDIF IF (IFL(1)(1:6) .EQ. 'PLUTON') THEN CALL PLA280 (IFL(1)(1:7)) ELSE CALL PLA280 (ICL) ENDIF 1330 CALL PLA034 (-1, NASUP) 1340 IF (IGBL(3) .EQ. 3) IGBL(3) = 0 RETURN 99999 FORMAT (':: Label Positioning Problem for ', A) 99998 FORMAT ('ATOM ', I5, 1X, A, 2X, I5, 4X, 3F8.3, 2F6.2) 99997 FORMAT ('ANISOU', I5, 1X, A, 2X, I5, 2X, 6I7) 99996 FORMAT ('HEADER ', A) 99995 FORMAT ('>> UNKNOWN INSTRUCTION - IGNORED', /) END SUBROUTINE PLA107 (IQ, IA, MODE, PCQ) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP15=20,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) DIMENSION BF(4), CONX(3, 3), QF(5), QUA(3, 4) ITY = 0 NATOM = IPR(39) NSUP = IPR(64) NASUP = NATOM + NSUP NIA = NASUP + IA NIQ = NASUP + IQ ID = NINT(CON(NIQ, 9)) NA1 = ID / (NP1 + 1) NA2 = MOD(ID, NP1 + 1) PCQ = 0.0 IF (MODE .NE. 0) THEN ITY = ITY + MODE IF (ITY .GT. 0) THEN OVMG = 0.0 ELSE OVMG = PAR(44) ENDIF IF (ITY .GT. -2) THEN V1(1) = (XXO(NIA, 1) + XXO(NIA, 2)) * 0.5 V1(2) = (XXO(NIA, 3) + XXO(NIA, 4)) * 0.5 V1(3) = 1.0 CONX(1, 1) = XSD(NIA, 1) CONX(1, 2) = XSD(NIA, 2) CONX(2, 1) = XSD(NIA, 2) CONX(2, 2) = XSD(NIA, 3) TX = XXO(NIA, 2) - XXO(NIA, 1) + XXO(NIA, 4) - XXO(NIA, 3) CONX(3, 3) = - (1.0 - 4.0 * OVMG / TX)**2 DO 20 K = 1, 2 CONX(K, 3) = 0.0 DO 10 J = 1, 2 CONX(K, 3) = CONX(K, 3) - V1(J) * CONX(J, K) 10 CONTINUE CONX(3, K) = CONX(K, 3) CONX(3, 3) = CONX(3, 3) - CONX(3, K) * V1(K) 20 CONTINUE ENDIF IF (ITY .LT. 2) THEN DO 40 L = 1, 4 K = 2 * L K1 = MOD(K, 8) + 2 QUA(1, L) = CON(NIQ, K) - CON(NIQ, K1) QUA(2, L) = CON(NIQ, K1 - 1) - CON(NIQ, K - 1) QUA(3, L) = CON(NIQ, K - 1) * CON(NIQ, K1) - 1 CON(NIQ, K) * CON(NIQ, K1 - 1) T1 = SQRT(QUA(1, L)**2 + QUA(2, L)**2) IF (T1 .LE. 0.0) THEN ITY = 0 GOTO 470 ENDIF DO 30 J = 1, 3 QUA(J, L) = QUA(J, L) / T1 30 CONTINUE 40 CONTINUE ENDIF V2(3) = 1.0 V3(3) = 1.0 T2 = 3.0 DO 150 L = 1, 4 L1 = (MOD(L, 4) + 1) * 2 V2(1) = CON(NIQ, 2 * L - 1) V2(2) = CON(NIQ, 2 * L) V3(1) = CON(NIQ, L1 - 1) V3(2) = CON(NIQ, L1) QF(L) = 0.0 BF(L) = 0.0 DO 120 K = 1, 3 T1 = CONX(3, K) DO 110 J = 1, 2 T1 = T1 + V2(J) * CONX(J, K) 110 CONTINUE QF(L) = QF(L) + T1 * V2(K) BF(L) = BF(L) + T1 * V3(K) 120 CONTINUE IF (QF(L) .EQ. 0.0) THEN T2 = T2 - 0.8 ELSE IF (QF(L) .LT. 0.0) THEN T2 = T2 - 1.0 ENDIF 150 CONTINUE QF(5) = QF(1) IF (T2 .LT. 0.0) THEN ITYPE = -1 ENDIF IF (T2 .GE. 2.2) THEN DO 230 K = 1, 4 T1 = BF(K)**2 - QF(K) * QF(K + 1) IF (T1 .GT. 0.0) THEN T1 = SQRT(T1) T3 = QF(K) - BF(K) T4 = T3 + QF(K + 1) - BF(K) IF (ABS(T4) .GT. PAR(54)) THEN T5 = (T3 - T1) / T4 IF (T5 .GE. 0.0 .AND. T5 .LT. 1.0) THEN ITYPE = 0 IF (NA2 .EQ. IA) THEN GOTO 390 ELSE IF (NA2 .GT. IA) THEN IF (NA1 .GE. IA) THEN GOTO 390 ELSE GOTO 300 ENDIF ELSE GOTO 300 ENDIF ENDIF ENDIF ENDIF 230 CONTINUE T3 = 3.0 DO 260 K = 1, 4 T1 = QUA(3, K) DO 240 J = 1, 2 T1 = T1 + V1(J) * QUA(J, K) 240 CONTINUE IF (T1 .LT. 0.0) T3 = T3 - 1.0 260 CONTINUE IF (T3 .GE. 0.0) GOTO 470 ITYPE = 1 IF (IA .GE. NA2 .OR. IA .LE. NA1) GOTO 390 ELSE ITYPE = 0 IF (NA2 .EQ. IA .OR. (NA2 .GT. IA .AND. NA1 .GE. IA)) GOTO 390 ENDIF 300 IF (ID .EQ. 0) GOTO 410 DO 310 III = 1, 3 V2(III) = XXO(NA2, III) - XXO(NA1, III) V3(III) = XXO(IA, III) - XXO(NA1, III) 310 CONTINUE CALL GEN007 (AA, V2, V2, 1) CALL GEN007 (AA, V3, V3, 1) CALL GEN011 (BB, V2, V3, V4, 1) IF (GEN009 (V4, V4) .LE. PAR(54)) THEN IF (ITY .GT. 0) THEN GOTO 410 ELSE GOTO 470 ENDIF ENDIF CALL GEN011 (BB, V4, V2, V5, 1) T1 = - V5(3) IF (T1 * FLOAT(ITY) .GT. 0.0) GOTO 470 390 IF (ITYPE * ITY .LT. 0) THEN PCQ = -1.0 GOTO 470 ENDIF 410 PCQ = 1.0 IF (ITY .LT. 0) THEN IF (IPR(152) .LT. NP7) THEN IPR(152) = IPR(152) + 1 DO 510 K = 1, 4 DO 500 J = 1, 3 XDIR(IPR(152), J, K) = QUA(J, K) 500 CONTINUE 510 CONTINUE IDIR(IPR(152)) = IQ ENDIF ELSE IF (IPR(151) .LT. NP15) THEN IPR(151) = IPR(151) + 1 IJ = 1 DO 460 I = 1, 3 DO 450 J = I, 3 XXO(IPR(174) + IPR(151), IJ) = CONX(I, J) IJ = IJ + 1 450 CONTINUE 460 CONTINUE ENDIF ENDIF ELSE ITY = 0 ENDIF 470 RETURN END SUBROUTINE PLA108 (IND1, IND2, IND3, NPEN) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /PL108/ SEG(2), Y(3), YN(2), YO(2), Z(3) NASUP = IPR(39) + IPR(64) NCOVR = IPR(151) NQOVR = IPR(152) NCQ = NCOVR + NQOVR NCO = IPR(174) ZGGIP = 0.0 LPEN = IABS(NPEN) DO 760 INDX = IND1, IND3, IND2 Y(1) = DP(1, INDX) Y(2) = DP(2, INDX) DO 40 J = 1, 2 Y(J) = MAX (0.0, MIN (Y(J), PAR(36 + J))) 40 CONTINUE IF (NCQ .EQ. 0) THEN CALL GGIP (Y(1), Y(2), ZGGIP, LPEN) ELSE IF (LPEN .EQ. 2) THEN YO(1) = YN(1) YO(2) = YN(2) DO 80 K = 1, NCQ XSD(NCO + K, 1) = XSD(NCO + K, 2) 80 CONTINUE IF (NQOVR .GT. 0) THEN DO 110 K = 1, NQOVR DO 100 J = 1, 4 CON(NCO + K, J) = CON(NCO + K, J + 4) 100 CONTINUE 110 CONTINUE ENDIF ENDIF YN(1) = Y(1) YN(2) = Y(2) IF (NCOVR .GT. 0) THEN KBG = NCO + 1 KEND = NCO + NCOVR DO 150 K = KBG, KEND Z(1) = YN(1) * XXO(K, 1) + YN(2) * XXO(K, 2) + XXO(K, 3) Z(2) = YN(1) * XXO(K, 2) + YN(2) * XXO(K, 4) + XXO(K, 5) Z(3) = YN(1) * XXO(K, 3) + YN(2) * XXO(K, 5) + XXO(K, 6) XSD(K, 2) = Z(1) * YN(1) + Z(2) * YN(2) + Z(3) IF (LPEN .EQ. 2) THEN XSD(K, 5) = Z(1) * YO(1) + Z(2) * YO(2) + Z(3) ENDIF 150 CONTINUE ENDIF IF (NQOVR .GT. 0) THEN KCQ = NCO + NCOVR DO 210 K = 1, NQOVR T2 = 3.0 DO 200 J = 1, 4 T1 = YN(1) * XDIR(K, 1, J) + YN(2) * XDIR(K, 2, J) 1 + XDIR(K, 3, J) IF (T1 .LT. 0) T2 = T2 - 1.0 CON(NCO + K, J + 4) = T1 200 CONTINUE KCQ = KCQ + 1 XSD(KCQ, 2) = T2 210 CONTINUE ENDIF IF (LPEN .EQ. 3) GOTO 745 DO 260 K = 1, NCQ IF (XSD(NCO + K, 1) .LT. 0.0 .AND. 1 XSD(NCO + K, 2) .LT. 0.0) GOTO 745 260 CONTINUE MINT = 0 IF (NCOVR .GT. 0) THEN DO 320 K = 1, NCOVR NCOK = NCO + K T1 = XSD(NCOK, 5)**2 - XSD(NCOK, 1) * XSD(NCOK, 2) IF (T1 .GT. 0.0) THEN T1 = SQRT(T1) T2 = XSD(NCOK, 1) - XSD(NCOK, 5) T3 = T2 + XSD(NCOK, 2) - XSD(NCOK, 5) IF (ABS(T3) .GT. PAR(54)) THEN T4 = (T2 - T1) / T3 T5 = (T2 + T1) / T3 IF (T4 .LT. 1.0 .AND. T5 .GT. 0.0) THEN MINT = MINT + 1 XSD(NCO + MINT, 3) = T4 XSD(NCO + MINT, 4) = T5 ENDIF ENDIF ENDIF 320 CONTINUE ENDIF IF (NQOVR .GT. 0) THEN DO 510 K = 1, NQOVR I12 = 0 KCQ = NCO + NCOVR + K SEG(1) = XSD(KCQ, 1) IF (SEG(1) .GE. 0.0) THEN SEG(1) = 1.0 - XSD(KCQ, 2) IF (SEG(1) .LE. 1.0) GOTO 370 ENDIF I12 = 1 370 DO 490 J = 1, 4 T1 = CON(NCO + K, J) T2 = CON(NCO + K, J + 4) T3 = T1 - T2 IF (T1 * T2 .LE. 0.0) THEN IF (ABS(T3) .LE. PAR(54)) GOTO 510 T4 = (T1 * YN(1) - T2 * YO(1)) / T3 T5 = (T1 * YN(2) - T2 * YO(2)) / T3 J1 = 2 * (MOD(J, 4) + 1) NIQ = NASUP + IDIR(K) T6 = (T4 - CON(NIQ, 2 * J - 1)) * 1 (CON(NIQ, J1 - 1) - T4) + 2 (T5 - CON(NIQ, 2 * J)) * (CON(NIQ, J1) - T5) IF (T6 .GT. -1.E-4) THEN T1 = T1 / T3 IF (I12 .LT. 1) THEN I12 = 1 SEG(1) = T1 ELSE IF (I12 .EQ. 1) THEN I12 = 2 IF (T1 .GE. SEG(1)) THEN SEG(2) = T1 ELSE SEG(2) = SEG(1) SEG(1) = T1 ENDIF ELSE IF (T1 .LT. SEG(1)) THEN SEG(1) = T1 ELSE IF (T1 .GT. SEG(1)) THEN IF (T1 .GT. SEG(2)) SEG(2) = T1 ENDIF ENDIF ENDIF ENDIF 490 CONTINUE IF (I12 .GT. 1) THEN MINT = MINT + 1 XSD(NCO + MINT, 3) = SEG(1) XSD(NCO + MINT, 4) = SEG(2) ENDIF 510 CONTINUE ENDIF IF (MINT .EQ. 0) THEN CALL GGIP (YN(1), YN(2), ZGGIP, 2) GOTO 750 ELSE M = MINT 550 M = M / 2 IF (M .EQ. 0) GOTO 650 K = MINT - M J = 1 570 I = J 580 IM = I + M IF (XSD(NCO + I, 3) .LT. 0.0) THEN IF (XSD(NCO + IM, 3) .GT. 0.0) GOTO 640 IF (XSD(NCO + I, 4) .LE. XSD(NCO + IM, 4)) GOTO 640 ELSE IF (XSD(NCO + I, 3) .LE. XSD(NCO + IM, 3)) GOTO 640 ENDIF CALL GEN018 (XSD(NCO + I, 3), XSD(NCO + IM, 3)) CALL GEN018 (XSD(NCO + I, 4), XSD(NCO + IM, 4)) I = I - M IF (I .GT. 0) GOTO 580 640 J = J + 1 IF (J .GT. K) THEN GOTO 550 ELSE GOTO 570 ENDIF ENDIF 650 P0 = 0.0 K = 0 660 K = K + 1 IF (K .GT. MINT) THEN P1 = 1.0 GOTO 710 ENDIF P1 = XSD(NCO + K, 3) IF (P1 .GE. 0.0 .AND. P1 .GT. P0) GOTO 710 690 P0 = MAX (P0, XSD(NCO + K, 4)) IF (P0 .LT. 1.0) GOTO 660 P0 = 1.0 710 IF (P0 .GT. 0.0) THEN Z(1) = YO(1) * (1.0 - P0) + YN(1) * P0 Z(2) = YO(2) * (1.0 - P0) + YN(2) * P0 CALL GGIP (Z(1), Z(2), ZGGIP, 3) IF (P0 .GE. 1.0) GOTO 750 ENDIF Z(1) = YO(1) * (1.0 - P1) + YN(1) * P1 Z(2) = YO(2) * (1.0 - P1) + YN(2) * P1 CALL GGIP (Z(1), Z(2), ZGGIP, 2) IF (P1 .LT. 1.0) GOTO 690 GOTO 750 745 CALL GGIP (YN(1), YN(2), ZGGIP, 3) ENDIF 750 IF (NPEN .GT. 0) THEN LPEN = 2 ELSE IF (LPEN .EQ. 3) THEN LPEN = 2 ELSE LPEN = 3 ENDIF ENDIF 760 CONTINUE RETURN END SUBROUTINE PLA109 (MODE) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /MAN/ MANUAL(140), PLUMAN(116) CHARACTER MANUAL*65, PLUMAN*65 DATA (MANUAL(I), I = 1, 18) / 1 'NOMOVE Keep Coords as Input', 2 'CALC (ALL) Exhaustive Derived Geometry', 3 'END Normal End-of-Program', 4 'STOP Forced End-of-Program', 5 'QUIT Forced End-of-Program', 6 'EXIT Forced End-of-Program', 7 'ROUND ON/OFF (range) Round On/Off (Def = ON, 2)', 8 'PARENTHESES ON/OFF Parenth. on/off Opt.(Def=ON)', 9 'INCLUDE el1 (el2 .. ) Include Specified Element(s)', * 'EXCLUDE el1 (el2 .. ) Exclude Specified Element(s)', 1 'INCLUDE METALS Include Metal(s) Only', 2 'EXCLUDE METALS Exclude Metal(s) Only', 3 'DOAC el1 (el2 ..) Specify DO/AC Elements', 4 'HBOND (NORM) p1 p2 p3 Modify H-Bond Criteria', 5 'GEOM at1 Calc Dist and Angles for at1', 6 'RING at1 at2 at3 (at4 ..) Explicit ring specification', 7 'LINE at1 at2 Explicit Line specification', 8 'FIT at11 at21 .. at1n at2n FIT mol1 to Mol2'/ DATA (MANUAL(I), I = 19, 36) / 1 'INORG Force Inorganic Structure Type', 2 'ORGA Force Organic Structure Type', 3 'ORMA r11 r12 r13 .. r32 r33 CAD4-Orientation Matrix', 4 'CALC INTRA Calculate Intramolecular Geom.', 5 ' el1 p1 el2 p2 .. Use Specified Elemental Radii', 6 ' (A/U/E)WLSPL Weighted Least-Squares', 7 ' TOLA p1 Use Specified Tolerance Value', 8 ' TOLEA p1 Add Tol for EAlk/Alk-Non-M', 9 ' TOLM p1 Add Tol for Metal-Metal', * ' NOTMA Do not Analyse Thermal Motion', 1 ' NOBOND Do not Print Bond Data', 2 ' NOANG Do not Print Angle Data', 3 ' NOTOR Do not Print Torson Data', 4 ' NOLSP Do not Print L.S.-planes', 5 ' NORING Do not search for rings', 6 ' MAXRING P1 Max RingSize ', 7 ' NOSTD Do not Calculate s.u.', 8 ' NOMOVE Do not Move Input Atom'/ DATA (MANUAL(I), I = 37, 54) / 1 ' NOSYMM Do not Apply any Symmetry', 2 ' TOLP p1 Max Dev. for Lspl Include', 3 ' MAXDEV p1 Max Dev. from LSPL for Listing', 4 ' NOSORT Do not SORT atoms', 5 'CALC INTER (NOMOVE) Calc. Inter-Mol. Geom with vdW.', 6 ' TOLR p1 Use Specified Tol. value p1', 7 ' el1 p1 (el2 p2 ..) Use Spec. Contact Rad (p1 = 0)', 8 'CALC HBONDS (NONA) P1 P2 P3 Calculate Hbonds [0.5,-.12,100]', 9 'LIST RADII/CELL/SYMM List Radii/Cell/Symm on Display', * 'INFO RADII/CELL/SYMM List Radii/Cell/Symm on Display', 1 'LIST ATOMS/BONDS (attyp)(res) List ATOMS/BONDS Data on Displ.', 2 'INFO ATOMS/BONDS (attyp)(res) List ATOMS/BONDS Data on Displ.', 3 'LIST UIJ List UIJ and U1, U2, U3', 4 'INFO UIJ List UIJ and U1, U2, U3', 5 'LIST IPR/PAR/IGBL (nr1 (nr2)) List Internal Parameters', 6 'INFO IPR/PAR/IGBL (nr1 (nr2)) List Internal Parameters', 7 'LIST FLAGS List Flag Array (Internal)', 8 'INFO FLAGS List Flag Array (Internal)'/ DATA (MANUAL(I), I = 55, 72) / 1 'LIST GRAPHICS Display Graphics Status', 2 'INFO GRAPHICS Display Graphics Status', 3 'CALC GEOM (OMEGA/MOGLI/CSD/ Calc Bonds,Angles,Torsion only', 4 ' EUCLID/SHELXL/PDB) Opt. Generate Specified File', 5 ' (NOMOVE) (EXPAND) Output Expanded Molecule', 6 ' (BOND) (ANGLE) (TORSION) Bonds Angles Torsion', 7 'CALC TMA (CART)(HINC) Thermal Motion Analysis only', 8 ' (Rmax) Maximum R-value (def. 0.25)', 9 ' (Atmin) Min Number of non-H atoms [6]', * 'SAVE Save instr. to be repeated', 1 'CALC ADDSYM (el/EQUAL)(SAVE) Test for Higher Symm. (for el)', 2 ' (ang d1 d2) Tolerances', 3 'CALC NONSYM Test for Non-Cryst Symmetry', 4 'CALC NEWSYM Test for additional symmetry', 5 'LEPAGE Check for Higher Metrical Symm.', 6 'EXPT Calc Expd # reflns for resoln', 7 'CALC COORDN (p1) Calc non-C,H Coordn with p1', 8 ' (FIVE (tba)) Analyse for 5-coordn. (TBA)'/ DATA (MANUAL(I), I = 73, 90) / 1 ' (el1 p1 el2 p2 ..) Coordn Calc for Specified Elem.', 2 ' (NOANG) Suppress Angle Calculation', 3 'CALC COORDN at1 p1 (NOANG) Calc Coordination for Atom_name', 4 'CALC METAL (p1) Me-Me Scan (Def. = 10 Ang.)', 5 'CALC DIST el (p1) el-el Scan (Def. = 3 Ang.)', 6 'DIST at1 at2 Calc Specified Distance', 7 'ANGL at1 at2 at3 (at4) Calc Specified Angle', 8 'TORS at1 at2 at3 at4 Calculate Spec. Torsion Angle', 9 'LSPL at1 at2 at3 (at4 ..) Explicit plane specification', * ' (DIST at3 ..) Optional Additional Dist.', 1 'PLOT (RING/PLAN/LSPL/RESD) Gives L.S.-plane plot', 2 ' (PERP/ALONG) Perpendicular/Along', 3 ' (DISPLAY/META) Plot medium (Default DISPLAY)', 4 'PLOT ADP Displacement Ellipsoid Plot', 5 ' (COLOR) Color O, N and Halogen atoms', 6 ' (ENVE/HETE/OCTA) Ellipsoid Styles', 7 ' (HATOM/NOHATOM) Hatom/NoHatom Inclusion', 8 ' (LABEL/NOLABEL) Label/Nolabel Atoms'/ DATA (MANUAL(I), I = 91, 108) / 1 ' (PAREN/NOPAREn) With/Without Parentheses', 2 ' (MARGIN marg) Overlap Margin (cm)', 3 ' (RESIDUE resd) Residue Number', 4 ' (DISPLAY/META) Plot medium (Default DISPLAY)', 5 'PLOT NEWMAN (at1 at2) NEWMAN-plot (Optional Bond)', 6 ' (DISPLAY/META)(COLR) Plot medium (Default DISPLAY)', 7 'BOX (ON/OFF) (RATIO p1) Outline and Text ON/OFF, ratio', 8 'VIEW Default 0 0 0 setting', 9 'VIEW (UNIT) XR p1 YR p2 ZR p3 Rot about XP,YP,ZP by p1,p2,p3', * 'VIEW MIN Minimum Overlap ADP Plot', 1 'VIEW INVERT Invert Image', 2 'SET PROB (10<-->90) Set Probability Level (Def=50)', 3 'SET IPR/PAR/IGBL/GL nr val Set Parameter Values', 4 'SET PRINTER LEVEL lev Set Print Level (0/1/2/3/4)', 5 'SET LABEL SIZE (size) Set Label Size (ADP)', 6 'SET WINDOW fraction Set X-Window Size', 7 'CALC SOLV Look for Solvent Acc Regions', 8 ' (LIST) Print Sections'/ DATA (MANUAL(I), I = 109, 126) / 1 'CALC VOID (PROBE r) (PSTEP n) Look for holes', 2 ' (LIST) Print Sections', 3 'CALC SQUEEZE (ncyc) Handle Solvent Area', 4 'CALC FCF Generate Fo^2/Fc^2 CIF', 5 'CALC DELABS (NOTHCOR)(NOCHECK)Empirical Absorption Correction', 6 'ABSG mu (n1 n2 n3) (NOCHECK) Gaussian Abs. Corr.', 7 'ABST mu (NOCHECK) Analytical Abs. Corr.', 8 'TABLE (SU/CIF/AC/JA/IC) Generate Publication Tables', 9 ' (NOHATOM) Exclude H-Atoms', * ' (NORESIDUE) No Residue Split-up', 1 'JOIN at1 at2 (DASH/LDASH) Add (DASHED) Bond to PLOT List', 2 'DETACH at1 at2 Delete Bond from PLOT List', 3 'DEFINE at1 TO at2 ..aTn Add BOND to Center-of-Grav.', 4 ' (DASH/LDASH) (Optionally (long)dashed)', 5 'RADII BONDS (NORMAL bt r/ Modify Normal Bond radii', 6 ' TO METAL bt r/ Modify radii to metals', 7 ' TO H bt r/ Modify radii involving H', 8 ' ALL bt r/LIST) Set ALL radii / List Radii'/ DATA (MANUAL(I), I = 127, 135) / 1 ' (-6 < bt < 6, radii in Ang', 2 'MENU (ON/OFF) X-Window Menu On/Off', 3 'ELLIPSOID (C/H/Other) Modify ellipsoid plot types', 4 ' type (lines) (type = 0/1)', 5 'CONTOUR (FO/DIFF/SQUEEZE) Contour Plot (Fo=default)', 7 ' TNCP 3 non-collinear points', 8 ' abcd ax + by + cz = d ', 9 ' BIS bisect', * ' PERP Perp. to the plane 3 points'/ DATA (PLUMAN(I), I = 1, 18) / 1 'ANGLE atom-name1 atom-name2 atom-name3', 2 'ANGSTROM (scale)', 3 'ARU (color)(aru1 (aru2) ..(resd))', 4 'ARU NONE/UNIQUE/INTER/RESTORE', 5 'ATOM atom-name x y z (pop sigx sigy sigz sigpop)', 6 'BOX (ON/OFF[ON]) (SHRINK shr) (RATIO ratio)', 7 'BWC TYPE atom-type bwc (atom-type bwc ..)', 8 'BWC (on/off)', 9 'CELL (wavelength) a b c alpha beta gamma', * 'COLOR BLACK/RED/GREEN/BLUE/YELLOW/ORANGE/VIOLET/BROWN', 1 'COLOR TYPE atom-type col (atom-type col ..)', 2 'COLOR RESD (ON/OFF)', 3 'COLOR ARU (ON/OFF)', 4 'COLOR (ON/OFF)', 5 'COORD atom-name', 6 'CPK (SHADE (a1 a2 (d))/', 7 ' COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/', 8 ' BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (STICK) (SPOT)'/ DATA (PLUMAN(I), I = 19, 37) / 1 'CROT(X/Y/Z)(M) (step (nstep)) (COLOR[off])', 2 'DEFINE Me# TO atom-name1 atom-name2 atom-name3 ...', 3 'DEFINE TO/CG atom-name1 atom-name2 atom-name3 ...', 4 'DELETE atom-type/atom-name .../aru', 5 'DETACH (atom-name/atom-type (TO) atom-name/atom-type)', 6 'DIR', 7 'DIST atom-name1 atom-name2 (aru)', 8 'END/ENDS', 9 'ENTRY (nr/refcode)', * 'EXCLUDE atom-names/atom-types/ALL/NONE/ORIG/UNIQUE/', 1 ' INTER/ZOMBIES/aru/resd', 2 'GEOM atom-name', 3 'INCLUDE atom-names/atom-types/ALL/NONE/ORIG/UNIQUE/', 4 ' INTER/ZOMBIES/aru/resd', 5 'INORG', 6 'JOIN RADII (UNIQUE (EXPAND) (NOMOVE)) (TOLE tole)', 7 ' ((TOL tol)/(n1 r1 n2 r2 ...))', 8 'JOIN RADII INTER (HBONDS/XBONDS)(EXPAND)', 9 ' (TOL tol)/(n1 r1 n2 r2 ...)'/ DATA (PLUMAN(I), I = 38, 55) / 1 'JOIN atom-name TO atom-name(s) (aru)', 2 'JOIN atom-names/atom-types', 3 'JOIN (NONE/INTRA)', 4 'LABEL atname1(aru) (atname2(aru)) (...) (attype3(aru)) (..)', 5 'LABEL (ON/OFF)/ALL/NONE/(UNITCELL) (ATOMS) (ARU) ', 6 ' ((NO)PARENTHESES) (FULL/NUM)', 7 'LATT (P/A/B/C/I/F) (C/A)', 8 'LIST (ATOMS)(BONDS)(GRAPHICS)(LINES)(MATR)(ARU)(STATUS)(TYPES)', 9 'LIST ATOM (atom-name/atom-type/INTER)/(RESD nr)', * 'LIST BOND (atom-name1 atom-name2/INTER)/(RESD nr)', 1 'LIST CELL/SYMM/FLAGS', 2 'LIST PAR (nr1 (nr2))', 3 'LIST IPR (nr1 (nr2))', 4 'MONO (PERSP d)', 5 'NOMOVE (OFF)', 6 'NOSORT', 7 'OMIT OUTSIDE (xmin xmax ymin ymax zmin zmax/atom-name rad/0)', 8 'OMIT aru ...(resd)'/ DATA (PLUMAN(I), I = 56, 73) / 1 'ORGA', 2 'OVERLAP (MARGIN mrg) (SHADOW shad)((ON/OFF)/BA/BB[ON])', 3 'PACK PLAN h k l d1 d2 RANGE xmin .. zmax (atom-name)', 4 'PACK (RANGE xmin xmax ymin ymax zmin zmax (atom-name))', 5 'PLOT (DISPLAY/META) (MOGLI) (LIST) (3/2)', 6 'PUT ARU/ATOM/atom-name/atom-type/OR/OA/OB/OC pos.', 7 '(atom-name/atom-type/OR/OA/OB/OC position .. )', 8 ' position: N, NE, E, SE, S, SW, W, NW, NUCL, AUTO', 9 'QUIT/EXIT', * 'RADII ATOMS COVALENT/CPK/AUTO/ALL r', 1 'RADII ATOMS atom-type1 r1 (atom-type2 r2 ... )', 2 'RADII ATOMS atom-name1 r1 (atom-name2 r2 ... )', 3 'RADII BONDS (DASH) ALL r n', 4 'RADII BONDS (DASH) TO atom-name/atom-type r n', 5 'RADII BONDS (DASH) atom-name1 atom-name2 r n', 6 'RADII BONDS (DASH) INTER/NORMAL r n', 7 'RADII BONDS TAPER t', 8 'RENAME (atom-name/atom-type)/(at1 at2 (at3 at4 ..))'/ DATA (PLUMAN(I), I = 74, 92) / 1 'RESET', 2 'RETRACE LABELS ((n) (d))', 3 'ROD (NUCL/SHADE (a1 a2 (d))/', 4 ' COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR/SEGMENT/', 5 ' BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)', 6 'SAVE (AUTO)', 7 'SEGMENT (plotstep (substep))', 8 'SET (IPR/PAR) nr val', 9 'SET WINDOW fraction', * 'SIZE sz (RATIO ra) (SCALE sc) (CHAR ch) (TITLE ti)', 1 'SOLID (NUCL/SHADE (a1 a2 (d))/', 2 ' COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/', 3 ' BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)', 4 'SPGR space-group-name', 5 'STEREO (SMALL) (RG/GR/RB/BR/CROSSED) (PERSP d)', 6 'STICK (COLOR)', 7 'STRAW (NUCL/SHADE (a1 a2 (d))/', 8 ' COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/', 9 'BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)'/ DATA (PLUMAN(I), I = 93, 110) / 1 'STOP', 2 'SYMM symmetry-operator', 3 'TITL text', 4 'TORSION atom-name1 atom-name2 atom-name3 atom-name4', 5 'UNITCELL (OFF/ON) (rbo nli)', 6 'UNLABEL (atom-names/atom-types/ALL/(UNITCELL) (ATOMS) (ARU)', 7 'VIEW MATRIX r11,r12, .. ,r33 (rotations)', 8 'VIEW MIN (rotations)', 9 'VIEW UNIT (rotations)', * 'VIEW XO/YO/ZO (rotations)', 1 'VIEW AFACE/BFACE/CFACE (rotations)', 2 'VIEW ALIGN atom-name1 atom-name2 (ARU) WITH XP/YP (rotations)', 3 'VIEW DIRECTION x y z (rotations)', 4 'VIEW LINE atom-name1 atom-name2 (ARU/rotations)', 5 'VIEW BISECT atom-name1 atom-name2 atom-name3 (rotations)', 6 'VIEW PERP atom-name1 atom-name2 atom-name3 (rotations)', 7 'VIEW CURRENT (rotations)', 8 'VIEW INVERT (rotations)'/ DATA (PLUMAN(I), I = 111, 116) / 1 ' rotations:', 2 ' (XROT xr)(YROT yr)(ZROT zr)(LROT lr x y z)(INVERT)', 3 ' (OROT or x y z)(PROT pr x y z)(BROT br at-name1 at-name2)', 4 'XROT xr', 5 'YROT yr', 6 'ZROT zr'/ CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT HRT = HORS / 2.0 IF (MODE .EQ. 1) THEN DO 10 I = 1, 127 WRITE (LU6, 99999) MANUAL(I) 10 CONTINUE DO 20 I = 1, 70 VRT = VRT - 0.25 CALL GGIP20 (0.0, MANUAL(I), 65, 0.2, 1, 1, 0.2, VRT) 20 CONTINUE VRT = VERT DO 30 I = 71, 135 VRT = VRT - 0.25 CALL GGIP20 (0.0, MANUAL(I), 65, 0.2, 1, 1, HRT, VRT) 30 CONTINUE CALL PLA013 (1, 1) IGGT = '!' ELSE DO 40 I = 1, 70 VRT = VRT - 0.25 CALL GGIP20 (0.0, PLUMAN(I), 65, 0.2, 1, 1, 0.2, VRT) 40 CONTINUE VRT = VERT DO 50 I = 71, 116 VRT = VRT - 0.25 CALL GGIP20 (0.0, PLUMAN(I), 65, 0.2, 1, 1, HRT, VRT) 50 CONTINUE DO 60 I = 1, 116 WRITE (LU6, 99999) PLUMAN(I) 60 CONTINUE CALL PLA013 (1, 1) IGGT = '!' ENDIF RETURN 99999 FORMAT (A) END SUBROUTINE PLA115 (MODE, NTYP, X, Y, LMOD) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /TPOS/ XTK(250, 3), NTK(25), KMX, IMIN COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 I = 0 IASU = 0 XMAX = 0.0 YMAX = 0.0 IF (NTYP .EQ. 0) THEN XMAX = PAR(37) YMAX = PAR(38) ELSE IF (NTYP .EQ. 1) THEN XMAX = - PAR(61) YMAX = - PAR(62) ENDIF 10 IF (MODE .EQ. 1) THEN IF (IWIN .EQ. 1) THEN I = IPR(447) + 1 WRITE (SBCD, '(''Give Text[size ='', F5.2, '']'', A)') 1 PAR(350), CHAR(0) CALL GEN038 (IGGT, 1, 80) CALL PLA013 (0, 0) TKST(I) = IGGT(1:10) LINE = IGGT CALL GEN038 (ICL, 1, 80) CALL GEN038 (IGGT, 1, 80) ELSE CALL PLA285 (0, LU6, 'Give Text:') READ (LU5, '(A)') LINE ENDIF IF (LINE(1:1) .EQ. '!' .OR. LINE(1:4) .EQ. 'TEXT' .OR. 1 LINE(1:4) .EQ. 'PLOT' .OR. LINE(1:3) .EQ. 'END' .OR. 2 LINE(1:3) .EQ. 'REM' .OR. LINE(1:4) .EQ. 'EXIT') THEN IPR(453) = 0 IPR(448) = 0 LINE = '!' IF (NTYP .EQ. 1) THEN IGBL(23) = 3 ELSE IGBL(23) = 8 ENDIF GOTO 60 ENDIF IF (I .EQ. 1) THEN KMX = 0 ENDIF IF (KMX .GT. 0) THEN DO 20 J = 1, KMX IF (NTK(J) .EQ. 0) THEN K = J GOTO 30 ENDIF 20 CONTINUE ENDIF KMX = KMX + 1 K = KMX 30 XTK(I, 1) = XMAX - 5.0 XTK(I, 2) = YMAX - K NTK(K) = 1 XTK(I, 3) = PAR(350) IPR(447) = I CALL GGIP20 (0.0, TKST(I), 10, XTK(I, 3), -1, 1, 1 XTK(I, 1), XTK(I, 2)) GOTO 10 ELSE IF (MODE .EQ. 2) THEN IF (IPR(173) * IPR(447) .GT. 0) THEN DO 40 I = 1, IPR(447) CALL GGIP20 (0.0, TKST(I), 10, XTK(I, 3), 1, 1, XTK(I, 1), 1 XTK(I, 2)) 40 CONTINUE ENDIF ELSE IF (MODE .EQ. 3) THEN IASU = 0 CALL PLA014 (3, NTYP, X, Y, ITEM, IASU) IF (ITEM .NE. 0) THEN CALL GGIP20 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 0, 1, 1 XTK(ITEM, 1), XTK(ITEM, 2)) CALL GGIP (0.0, 1.0, 0.0, 0) IF (IPR(447) .GT. 1) THEN DO 50 I = 1, 3 XTK(ITEM, I) = XTK(IPR(447), I) 50 CONTINUE TKST(ITEM) = TKST(IPR(447)) ENDIF IPR(447) = IPR(447) - 1 ENDIF ELSE IF (MODE .EQ. 4) THEN CALL PLA014 (3, NTYP, X, Y, ITEM, IASU) IF (ITEM .NE. 0) THEN CALL GGIP20 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 0, 1, 1 XTK(ITEM, 1), XTK(ITEM, 2)) XTK(ITEM, 3) = PAR(350) CALL GGIP20 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 1, 1, 1 XTK(ITEM, 1), XTK(ITEM, 2)) ENDIF ELSE IF (MODE .EQ. 5) THEN IF (IPR(448) .NE. 0) THEN IF (IPR(447) .GT. 0) THEN IF (LMOD .EQ. 0) THEN CALL PLA014 (3, NTYP, X, Y, IMIN, IASU) XX = XTK(IMIN, 1) YY = XTK(IMIN, 2) LMOD = 1 XN = - XTK(IMIN, 2) + YMAX N = NINT(-XTK(IMIN, 2) + YMAX) IF (ABS(XN - N) .LT. 0.05) THEN NTK(N) = 0 ENDIF ELSE XX = - (NTYP * XMAX) + X YY = YMAX - Y XTK(IMIN, 1) = XX XTK(IMIN, 2) = YY LMOD = 0 ENDIF YGGIP = FLOAT(1 - LMOD) CALL GGIP20 (0.0, TKST(IMIN), 10, XTK(IMIN, 3), 1 NINT(YGGIP), 1, XX, YY) ENDIF ENDIF ENDIF 60 RETURN END SUBROUTINE PLA117 (HORS, VERT, MODE) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /LITREF/ LREF CHARACTER LREF(25)*80 IF (IGBL(103) .NE. 0) THEN CALL GGIP (0.0, 0.0, 0.0, 3) CALL GGIP (HORS, 0.0, 0.0, 2) CALL GGIP (HORS, VERT, 0.0, 2) CALL GGIP (0.0, VERT, 0.0, 2) CALL GGIP (0.0, 0.0, 0.0, 2) P14 = 0.4 IF (MODE .GE. 0) THEN IF (IPR(116) .EQ. 0 .AND. IABS(IGBL(23)) .NE. 25) THEN IF (IGBL(30) .EQ. 1) THEN CALL GGIP20 (0.0, 'NOMOVE FORCED', 13, P14, 3, 1, 1 HORS - 31 * P14, VERT - 0.15 - P14) ELSE IF (IGBL(60) .GT. 0) THEN CALL GGIP20 (0.0, 'INPUT ATOMS MOVED', 17, P14, 2, 1, 1 HORS - 35 * P14, VERT - 0.15 - P14) ENDIF ENDIF ENDIF IF (MODE .EQ. 1 .AND. IGBL(104) .EQ. 1 .AND. 1 IPR(116) .EQ. 0) THEN VRT = VERT - 1.0 DO 10 I = 1, 2 + IPR(565) VRT = VRT - 0.4 CALL GGIP20 (0.0, LREF(I), 79, 0.25, 5, 1, 1.0, VRT) 10 CONTINUE ENDIF IROTX = NINT(GL(28)) IROTY = NINT(GL(29)) IROTZ = NINT(GL(30)) IDET = IGBL(87) IF (IDET .EQ. -1 .AND. IPR(116) .EQ. 0) 1 CALL GGIP20 (0.0, 'INVERT', 6, P14, 3, 1, 2 HORS - 16 * P14, VERT - 0.15 - P14) CALL GEN040 (IROTX, NQ1, IP) NQ1(IP + 1:IP + 2) = ' X' IP = IP + 2 CALL GGIP20 (0.0, NQ1, IP, P14, -1, 1, HORS - IP * P14, 0.15) CALL GEN040 (IROTY, NQ2, IP) NQ2(IP + 1:IP + 2) = ' Y' IP = IP + 2 CALL GGIP20 (90.0, NQ2, IP, P14, -1, 1, P14 + 0.15, VERT 1 - IP * P14) NQ3(1:1) = 'Z' CALL GGIP20 (0.0, NQ3, 1, P14, -1, 1, 0.15, 0.15) CALL GEN040 (IROTZ, NQ3, IP) CALL GGIP20 (0.0, NQ3, IP, P14, -1, 1, 0.15 + 2 * P14, 0.15) IF (MODE .EQ. 1) THEN NQ1 = 'PROBA= ' CALL GGIP20 (0.0, NQ1, 6, P14, -1, 1, HORS - 9 * P14, 1 VERT - 0.15 - P14) IPRB = IPR(45) * 10 CALL GEN040 (IPRB, NQ1, IP) CALL GGIP20 (0.0, NQ1, IP, P14, -1, 1, PAR(37) - 2 * P14, 1 PAR(38) - 0.15 - P14) ENDIF IF (IABS(IGBL(23)) .NE. 25) THEN NQ1 = 'RES= ' CALL GGIP20 (0.0, NQ1, 4, P14, -1, 1, HORS - 14 * P14, 1 0.15) CALL GEN040 (IPR(140), NQ1, IP) CALL GGIP20 (0.0, NQ1, 2, P14, -1, 1, HORS - 8 * P14, 1 0.15) ENDIF ENDIF NJID = MAX (74, NINT(HORS / 0.4) - 12) CALL GGIP20 (0.0, JID, NJID, 0.4, -1, 1, 3.0, 0.15) CALL GEN040 (IGBL(9), NQ2, IP) IF (MODE .LT. 0) THEN VR = 0.5 ELSE VR = 1.5 ENDIF CALL GGIP20 (90.0, PROGNM//' - ('//NQ2(1:IP)//')', 1 IP + 33, 0.4, -1, 1, 0.6, VR) ENDIF RETURN END SUBROUTINE PLA118 (N, LRETN, CELL, FA) COMMON /PL118/ M DIMENSION CELL(*), FA(*) IF (N .NE. 0) THEN CELL(N) = FA(1) CELL(6 + N) = FA(2) M = M + 1 IF (M .EQ. 6) LRETN = 2 ELSE M = 0 LRETN = 1 ENDIF RETURN END SUBROUTINE PLA119 (MODE) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP23=18000,NP38=125,NP39=30,MM=10) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR, 1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN, 2 BASFM(4) COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON // JNSC(2, NP23), VOID(NPVD) DIMENSION STAT(20, 9) INTEGER HMAX REWIND LU16 IWIN = IGBL(25) * IGBL(32) DO 20 I = 1, 20 DO 10 J = 1, 9 STAT(I, J) = 0.0 10 CONTINUE 20 CONTINUE SIGK = 0.0 CALL PLA080 CALL PLA042 (2) IF (IGBL(29) .LE. 0 .OR. IPR(594) .NE. 0) CALL PLA287 (1, 1, 0) IF (MODE .LE. 1) THEN IF (MODE .EQ. -1) THEN PAGET = 'BIJVOET' CALL PLA269 (0) IPR(2) = -1 ELSE IF (MODE .EQ. 1) THEN PAGET = 'TWINROTM' CALL PLA269 (0) WRITE (LU7, 99998) IGBL(23) = 25 ELSE IF (MODE .EQ. 0) THEN PAGET = 'ANALVAR' CALL PLA269 (0) IPR(2) = -1 ENDIF WRITE (LU6, 99997) PAR(227), PAR(228) WRITE (LU7, 99996) RLWS(1) ENDIF CALL PLA293 (PAR(17), 0) IPR(132) = -1 IEND = -1 STOT = 0.0 NTOT = 0 NADR = 0 FOKM = 0.0 IND1 = 1 IND2 = 2 IND3 = 3 NSYM = IPR(48) NSYMH = IPR(255) ICNTR = IPR(257) IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) THEN IHEXL = 1 ELSE IHEXL = 0 ENDIF HMAX = -999 KMAX = -999 LMAX = -999 SUMFOK = 0.0 SUMFCK = 0.0 30 CALL PLA132 (IH, IK, IL, FOK, SIG, CALI, FCK, ACALS, BCALS, 1 ACOR, IEND) IF (IEND .NE. 1) THEN IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN IF (IGBL(29) .LE. 0 .OR. IPR(594) .NE. 0) THEN ACAL = 0.0 BCAL = 0.0 CALL PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, YUNK) FCK = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2 ENDIF VOID(NADR + 1) = IH VOID(NADR + 2) = IK VOID(NADR + 3) = IL VOID(NADR + 4) = FOK VOID(NADR + 5) = FCK VOID(NADR + 6) = SIG VOID(NADR + 8) = 0.0 VOID(NADR + 9) = 0.0 VOID(NADR + 10) = 0.0 SUMFOK = SUMFOK + FOK SUMFCK = SUMFCK + FCK NADR = NADR + MM HMAX = MAX (HMAX, IABS(IH)) KMAX = MAX (KMAX, IABS(IK)) IF (IHEXL .EQ. 1) THEN HMAX = MAX (KMAX, HMAX, IABS(IH + IK)) KMAX = HMAX ENDIF LMAX = MAX (LMAX, IABS(IL)) GOTO 30 ENDIF ENDIF NREF = NADR / MM IF (NREF .EQ. 0) THEN WRITE (LU6, 99999) ELSE IF (IGBL(29) .LE. 0) THEN SCALE = SUMFCK / SUMFOK ELSE SCALE = 1.0 ENDIF NADR = 0 DO 40 I = 1, NREF IH = NINT(VOID (NADR + 1)) IK = NINT(VOID (NADR + 2)) IL = NINT(VOID (NADR + 3)) STL = SQRT(GEN095 (PAR(191), IH, IK, IL)) ST = STL * PAR(17) IF (ST .LT. 1.0) THEN TH = ASIN (ST) * GL(5) ELSE TH = 0.0 ENDIF FOK = VOID (NADR + 4) * SCALE FOKM = MAX (FOKM, FOK) FCK = VOID (NADR + 5) SIG = VOID (NADR + 6) * SCALE IF (SIG .GT. 0.0) THEN SIGK = SIG**2 IF (PAR(227) .GT. 0.0) THEN P = (MAX(FOK, 0.0) + 2.0 * FCK) / 3.0 SIGK = SIGK + (PAR(227) * P)**2 + PAR(228) * P ENDIF ENDIF IF (SIG .NE. 0.0) THEN VOID(NADR + 8) = MAX ((FOK - FCK) / SIG, 0.0) VOID(NADR + 9) = (FOK - FCK) / SQRT(SIGK) ENDIF VOID (NADR + 4) = FOK VOID (NADR + 6) = SIG VOID (NADR + 7) = TH N = MAX (1, MIN (20, INT(STL * 20 + 0.5))) STAT(N, 1) = STAT(N, 1) + ABS(FOK) STAT(N, 2) = STAT(N, 2) + ABS(FCK) STAT(N, 3) = STAT(N, 3) + 1.0 STAT(N, 4) = STAT(N, 4) + SQRT(ABS(FOK)) STAT(N, 5) = STAT(N, 5) 1 + ABS(SQRT(ABS(FOK)) - SQRT(ABS(FCK))) STAT(N, 6) = STAT(N, 6) + (FOK - FCK) ** 2 / SIGK STAT(N, 7) = STAT(N, 7) + FOK ** 2 / SIGK NADR = NADR + MM 40 CONTINUE IF (IPR(259) .EQ. 4) THEN HMAX = MAX (HMAX, KMAX) KMAX = HMAX ELSE IF (IPR(259) .EQ. 7) THEN HMAX = MAX (HMAX, KMAX, LMAX) KMAX = HMAX LMAX = HMAX ENDIF SCL = 10 ** (INT(ALOG (10000000 / FOKM) / ALOG (10.0))) IF (MODE .NE. 2) THEN WRITE (LU6, 99995) HMAX, KMAX, LMAX CALL PLA269 (2) WRITE (LU7, 99995) HMAX, KMAX, LMAX IHEAD = 0 IF (PAR(227) .GT. 0.0) WRITE (LU7, 99990) PAR(227), PAR(228) DO 50 I = 1, 20 IF (STAT(I, 3) .NE. 0.0 .AND. STAT(I, 7) .NE. 0.0 .AND. 1 STAT(I, 4) .NE. 0.0) THEN R1 = STAT(I, 5) / STAT(I, 4) R2 = SQRT(STAT(I, 6) / STAT(I, 7)) S = SQRT(STAT(I, 6) / STAT(I, 3)) STOT = STOT + STAT(I, 6) NTOT = NTOT + NINT(STAT(I, 3)) IF (IHEAD .EQ. 0) THEN WRITE (LU7, 99994) IHEAD = 1 ENDIF WRITE (LU7, 99993) I / 20.0, NINT(STAT(I, 3)), R1, R2, S ENDIF 50 CONTINUE STOT = SQRT(STOT / NTOT) WRITE (LU7, 99992) STOT C * NORMAL PROBABILITY PLOT CALL PLA269 (0) DO 60 I = 1, NREF VOID(NADR + I) = VOID(I * MM - 1) 60 CONTINUE WRITE (LU7, 99991) IF (PAR(227) .GT. 0.0) WRITE (LU7, 99990) PAR(227), PAR(228) CALL PLA282 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NREF, 1 LU7) ENDIF IF (MODE .NE. 0) THEN C * ANALYSE FOR TWINNING IF (MODE .GT. 0) THEN CALL PLA120 (MODE) C * ANALYSIS OF BIJVOET-PAIRS ELSE IF (MODE .EQ. -1) THEN CALL PLA124 ENDIF ENDIF ENDIF IGGT = ' ' RETURN 99999 FORMAT (/, ':: No Reflections found') 99998 FORMAT (/, 'TwinRotMat: Analysis of the Fo/Fc CIF for Unaccounted' 1 ,' (Non)Merohedral Twinning', /, 80('='), /) 99997 FORMAT (':: W1, W2 =', 2F10.4) 99996 FORMAT (/, A, /) 99995 FORMAT (/, ':: Hmax =', I5, ', Kmax =', I5, ', Lmax =', I5) 99994 FORMAT (/, 4X, 'STL # R1 wR2 S', /, 1 3X, 33('=')) 99993 FORMAT (F7.2, I5, 3F8.3) 99992 FORMAT (/, ':: S =', F10.3) 99991 FORMAT ('NPP for (Fobs**2 - Fcalc**2) / Sigma(Fobs**2)') 99990 FORMAT (/, ':: Sigma includes SHELXL WGHT Par.', 2F10.4, /) END SUBROUTINE PLA120 (MODE) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP23=18000,NP38=125,NP39=30,NP45=2048,MM=10) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR, 1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN, 2 BASFM(4) COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 COMMON // JNSC(2, NP23), VOID(NPVD) DIMENSION IHKL(3), ORT(3, 3), V(3), TAU(3) DIMENSION XX(12), ALPHA(4), NFRQ(4), SDAT(500), ISDAT(500) INTEGER HMAX C * ANALYSE FOR TWINNING FROM REFLECTION OVERLAP CALL GEN044 (PAR(101), OR) CALL GEN005 (OR, ORT) CALL GEN003 (ORT, ROTQ, DET, 0) IEXT = 0 IASM = 0 NSEL = 0 NVCX = 0 NADR = NREF * MM NSYMR = NSYMH * ICNTR IBRV = IPR(241) IF (IBRV .EQ. 7) THEN IBLP = 2 ELSE IBLP = 1 ENDIF LINV = 3 - ICNTR MPH = 2 * HMAX + 1 MPK = 2 * KMAX + 1 MPL = 2 * LMAX + 1 MHK = MPH * MPK MHKL = MPL * MHK MHKLH = (MHKL - 1) / 2 IADR = NPVD - MHKLH IADR1 = NPVD - MHKL DO 10 I = 1, MHKL IEXT = 0 IH = I - 1 IL = IH / MHK IH = IH - IL * MHK IL = IL - LMAX IK = IH / MPH IH = IH - IK * MPH - HMAX IK = IK - KMAX IF (IBRV .GT. 1) THEN IF (GEN049 (LAT(IBRV), IH, IK, IL) .LT. 0.0) IEXT = 1 ENDIF IF (IEXT .EQ. 0) CALL PLA139 (IH, IK, IL, IEXT, IASM) VOID(IADR1 + I) = - FLOAT (IEXT) 10 CONTINUE DO 40 K = 1, LINV DO 30 I = 1, NREF IMM = (I - 1) * MM XX(1) = VOID(IMM + 1) XX(2) = VOID(IMM + 2) XX(3) = VOID(IMM + 3) DO 20 NS = 1, NSYMR CALL SGSM (LINE, NS, XX, LU7, 5, IER) IH = NINT(XX(7)) IK = NINT(XX(8)) IL = NINT(XX(9)) IHKLP = IL * MHK + IK * MPH + IH IF (K .EQ. 1) THEN IF (VOID(IADR + IHKLP) .EQ. 0.0) VOID (IADR + IHKLP) = I ELSE IF (VOID(IADR - IHKLP) .EQ. 0.0) VOID (IADR - IHKLP) = I ENDIF 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) CALL GGIP (HORS, VERT, 0.0, 1) NLIST = 0 IF (IPR(259) .EQ. 2) THEN IPR(394) = 2 ELSE IPR(394) = 3 ENDIF CALL GEN097 (NTW, 1, 4, 0) 60 NSEL = 0 DO 70 I = 1, NREF IMM = (I - 1) * MM IF (VOID(IMM + 8) .GT. PAR(413) .AND. 1 VOID(IMM + 7) .GT. 0.0) THEN IF (NSEL .LT. 500) THEN NSEL = NSEL + 1 SDAT(NSEL) = 100000.0 - VOID(IMM + 8) ISDAT(NSEL) = I ELSE IF (PAR(413) .LT. 32.0) THEN PAR(413) = PAR(413) * 2.0 GOTO 60 ELSE GOTO 80 ENDIF ENDIF ENDIF 70 CONTINUE 80 IF (NSEL .GT. 1) CALL GEN013 (SDAT, ISDAT, 1, NSEL) NSEL = MIN (NSEL, IPR(550)) IF (NSEL .EQ. 0) THEN GOTO 340 ELSE IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN CALL GGIP20 (0.0, 'WorkinG', 7, 3.0, 2, 10, 5.0, 8.0) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF ENDIF IF (MODE .NE. 2) THEN WRITE (LU6, 99979) WRITE (LU6, 99988) CALL PLA269 (0) IF (IPR(469) .NE. 0) THEN WRITE (LU7, 99984) CALL PLA269 (2) ENDIF WRITE (LU7, 99988) CALL PLA269 (3) ENDIF NVC = 0 NX = NP23 / 2 DO 180 I = 1, NSEL IMM = (ISDAT(I) - 1) * MM THI = VOID(IMM + 7) IHI = NINT(VOID(IMM + 1)) IKI = NINT(VOID(IMM + 2)) ILI = NINT(VOID(IMM + 3)) FOKI = VOID(IMM + 4) FCKI = VOID(IMM + 5) SIGI = VOID(IMM + 6) DELS = VOID(IMM + 8) DELI = FOKI - FCKI IF (MODE .NE. 2) THEN WRITE (LU6, 99985) IHI, IKI, ILI, FOKI, FCKI, SIGI, DELS, THI CALL PLA269 (1) IF (IPR(469) .NE. 0) THEN CALL PLA269 (2) WRITE (LU7, 99978) ENDIF WRITE (LU7, 99985) IHI, IKI, ILI, FOKI, FCKI, SIGI, DELS, THI IF (IPR(469) .NE. 0) THEN CALL PLA269 (1) WRITE (LU7, 99979) ENDIF ENDIF DO 170 J = 1, NREF JMM = (J - 1) * MM THJ = VOID(JMM + 7) DTH = THI - THJ IF (ABS(DTH) .LT. PAR(414) .AND. THJ .GT. 0.0) THEN DO 90 K = 1, 3 XX(K) = VOID(JMM + K) 90 CONTINUE XX(4) = 0.0 FOKJ = VOID(JMM + 4) FCKJ = VOID(JMM + 5) SIGJ = VOID(JMM + 6) IF (FCKJ - FCKI .GT. SIGJ) THEN DELSJ = (FOKJ - FCKJ) / SIGJ DO 160 NS = 1, NSYMR CALL SGSM (LINE, NS, XX, LU7, 5, IER) DO 150 ILP = 1, IBLP IF (ILP .EQ. 1) THEN IHJ = NINT(XX(7)) IKJ = NINT(XX(8)) ILJ = NINT(XX(9)) ELSE IHJ = - NINT(XX(8)) IKJ = NINT(XX(7)) + NINT(XX(8)) ILJ = NINT(XX(9)) IF (MOD(-IHJ + IKJ + ILJ, 3) .EQ. 0) GOTO 150 ENDIF DO 140 LIV = 1, LINV IF (LIV .EQ. 2) THEN IHJ = - IHJ IKJ = - IKJ ILJ = - ILJ ENDIF IHKL(1) = IHI + IHJ IHKL(2) = IKI + IKJ IHKL(3) = ILI + ILJ IF (IHKL(1) .LT. 0) THEN IHKL(1) = - IHKL(1) IHKL(2) = - IHKL(2) IHKL(3) = - IHKL(3) ELSE IF (IHKL(1) .EQ. 0) THEN IF (IHKL(2) .LT. 0) THEN IHKL(2) = - IHKL(2) IHKL(3) = - IHKL(3) ELSE IF (IHKL(2) .EQ. 0) THEN IHKL(3) = IABS(IHKL(3)) ENDIF ENDIF CALL GEN107 (IHKL, 3, IYUNK) IHKLP = IHKL(1) 1 + 200 * (IHKL(2) + 200 * IHKL(3)) IF (IHKLP .NE. 0) THEN IF (NVC .GT. 0) THEN DO 110 N = 1, NVC ISN = 1 DO 100 K = 1, LINV IF (IHKLP .EQ. ISN * JNSC(2, NX + N)) 1 GOTO 130 ISN = -1 100 CONTINUE 110 CONTINUE ENDIF IF (NVC .LT. NX - 1) THEN NVC = NVC + 1 N = NVC JNSC(1, NVC) = 10000 JNSC(2, NVC) = NVC JNSC(1, NX + NVC) = 0 JNSC(2, NX + NVC) = IHKLP ENDIF 130 JNSC(1, N) = JNSC(1, N) - 1 DELJ = FCKJ - FCKI ALFA = MIN (DELI / DELJ, 1.0) IF (ALFA .GE. PAR(416)) THEN IF (IPR(469) .NE. 0) THEN CALL PLA269 (1) WRITE (LU7, 99986) IHJ, IKJ, ILJ, 1 FOKJ, FCKJ, SIGJ, DELSJ, THJ, DTH, ALFA, 2 IHKL(1), IHKL(2), IHKL(3) ENDIF JNSC(1, NX + N) = JNSC(1, NX + N) 1 + NINT (ALFA * 100.0) ENDIF ENDIF 140 CONTINUE 150 CONTINUE 160 CONTINUE ENDIF ENDIF 170 CONTINUE 180 CONTINUE NVCX = 0 IF (NVC .GT. 0) THEN IPR(543) = 0 CALL GEN037 (JNSC, 1, NVC) NMIN = 1 NTWIN = 0 DO 320 I = 1, NVC IF (NVCX .EQ. 4) GOTO 330 NFRQ(NVCX + 1) = 10000 - JNSC(1, I) IF (NFRQ(NVCX + 1) .GT. NMIN) THEN XHKL = JNSC(2, JNSC(2, I) + NX) CALL GEN046 (XHKL, H(1), H(2), H(3)) IHKLSUM = 0 DO 190 J = 1, 3 IHKLR(J, NVCX + 1) = NINT(H(J)) IHKLSUM = IHKLSUM + NINT(H(J)) 190 CONTINUE CALL GEN002 (2, ROTQ, H, TAU, XLNG) IF (ABS(TAU(1)) + ABS(TAU(2)) .LT. 0.0001) THEN OME = 0.0 CHI = 90.0 / GL(5) ELSE OME = ATAN2 (TAU(2), TAU(1)) CHI = ATAN2 (TAU(3), SQRT(TAU(1)**2 + TAU(2)**2)) ENDIF CALL GEN043 (3, TP, OME) CALL GEN043 (2, TG, - CHI) CALL GEN004 (TG, TP, TM) PHI = 180.0 / GL(5) CALL GEN043 (1, G, PHI) CALL GEN004 (G, TM, TPS) CALL GEN005 (TM, TM) CALL GEN004 (TM, TPS, TPQ) CALL GEN004 (TPQ, ROTQ, TPS) CALL GEN004 (ORT, TPS, TWM(1, 1, NVCX + 1)) IF (NSYMH .GT. 1 .AND. NVCX .GT. 0) THEN DO 210 J = 1, 3 DO 200 K = 1, 3 TM(J, K) = TWM(J, K, NVCX + 1) 200 CONTINUE 210 CONTINUE DO 270 J = 2, NSYMR NS = J CALL SGSM (LINE, NS, XX, LU6, 6, IER) DO 220 K = 1, 9 N = INT ((K - 1) / 3) + 1 M = MOD (K - 1 , 3) + 1 TPS(M, N) = XX(K) 220 CONTINUE CALL GEN004 (TPS, TM, TPQ) IS = 1 DO 260 LL = 1, LINV IF (LL .EQ. 2) IS = -1 DO 250 K = 1, NVCX + 1 DO 240 N = 1, 3 DO 230 M = 1, 3 IF (K .LE. NVCX) THEN IF (ABS(TWM(N, M, K) - IS * TPQ(N, M)) 1 .GT. 0.05) GOTO 250 ELSE IF (ABS(TWM(N, M, K) - IS * TPS(N, M)) 1 .GT. 0.05) GOTO 250 ENDIF 230 CONTINUE 240 CONTINUE GOTO 320 250 CONTINUE 260 CONTINUE 270 CONTINUE ENDIF NVCX = NVCX + 1 COSA = 0.0 N1 = IPR(567) N2 = 2 * N1 - 1 DO 300 K = 1, N2 V(1) = K - N1 DO 290 L = 1, N2 V(2) = L - N1 DO 280 M = 1, N2 V(3) = M - N1 CALL GEN002 (2, OR, V, T, XLNG) IF (XLNG .NE. 0) THEN SPRD = GEN009 (T, TAU) IF (SPRD .GT. COSA) THEN COSA = SPRD IHKL(1) = K - N1 IHKL(2) = L - N1 IHKL(3) = M - N1 ENDIF ENDIF 280 CONTINUE 290 CONTINUE 300 CONTINUE ALPHA(NVCX) = ACOS(MIN(1.0, COSA)) * GL(5) CALL GEN107 (IHKL, 3, IYUNK) DO 310 K = 1, 3 IHKLD(K, NVCX) = IHKL(K) 310 CONTINUE IF (MODE .NE. 2) THEN CALL PLA269 (1) WRITE (LU6, 99997) WRITE (LU7, 99997) ENDIF CALL PLA121 (NVCX) ENDIF 320 CONTINUE C * SORT TWIN LAWS 330 CALL GEN124 (MTWIN, 1, NVCX * 2) ENDIF C * SHOW RESULTS 340 IF (MODE .EQ. 1) THEN IF (IWIN .EQ. 1) THEN CALL GGIP (HORS, VERT, 0.0, 1) CALL PLA117 (HORS, VERT, -1) BCD = 'TwinRotMat'//CHAR(0) CALL GGIP20 (0.0, BCD, 10, 1.4, 4, 8, 7.0, VERT - 1.8) CALL GGIP20 (0.0, BCD, 10, 1.4, 2, 8, 6.8, VERT - 1.9) WRITE (BCD, 99996) JID(1:6) VRT = VERT - 3.0 CALL GGIP20 (0.0, BCD, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT) WRITE (BCD, 99991) PAR(17), (PAR(100 + I), I = 1, 6), 1 SPGRNM(1)(1:11) VRT = VRT - 1.0 CALL GGIP20 (0.0, BCD, 80, 0.35, 1, 2, 1.0, VRT) ENDIF ELSE WRITE (LU22, 99982) ENDIF IF (MODE .EQ. 1) NLIST = NLIST + 1 WRITE (BCD, 99990) PAR(413), PAR(414), IPR(550) IF (NLIST .EQ. 1) THEN CALL PLA269 (0) CALL PLA269 (9) WRITE (LU6, 99997) WRITE (LU7, 99997) WRITE (LU6, 99998) BCD WRITE (LU7, 99998) BCD ENDIF IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, BCD, 80, 0.35, 1, 2, 1.0, VRT) ENDIF WRITE (BCD, 99983) NREF, NSEL, IPR(567), PAR(415), PAR(420) IF (NLIST .EQ. 1) THEN WRITE (LU6, 99997) WRITE (LU7, 99997) WRITE (LU7, 99987) PAR(17) WRITE (LU6, 99998) BCD WRITE (LU7, 99998) BCD WRITE (LU6, 99997) WRITE (LU7, 99997) ENDIF IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN VRT = VRT - 0.7 CALL GGIP20 (0.0, BCD, 80, 0.35, 1, 2, 1.0, VRT) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF IF (NSEL .EQ. 0) THEN IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN CALL GGIP20 (0.0, 'No Refl Selected', 16, 1.2, 2, 10, 4.0, 1 8.0) ENDIF IF (MODE .EQ. 2) WRITE (LU22, 99981) GOTO 360 ENDIF NRTWL = 0 IF (NVCX .GT. 0) THEN IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN CALL GGIP (0.0, VRT - 0.5, 0.0, 3) CALL GGIP (HORS, VRT - 0.5, 0.0, 2) CALL GGIP (1.8, VRT - 0.5, 0.0, 3) CALL GGIP (1.8, 0.0, 0.0, 2) CALL GGIP (HORS - 4.1, VRT - 0.5, 0.0, 3) CALL GGIP (HORS - 4.1, 0.0 , 0.0, 2) ENDIF DO 350 J = 1, NVCX I = MTWIN(J * 2) IF (BASFM(I) .GT. 0.0 .AND. DRVAL(I) .LE. -0.01) THEN NCOL = 3 IPR(570 + J) = 1 ELSE NCOL = 4 ENDIF WRITE (BCD, 99999) (IHKLR(K, I), K = 1, 3), 1 (IHKLD(K, I), K = 1, 3), 2 ALPHA(I), NFRQ(I) IF (NLIST .EQ. 1) THEN CALL PLA269 (2) WRITE (LU6, 99997) WRITE (LU7, 99997) WRITE (LU6, 99998) BCD WRITE (LU7, 99998) BCD ENDIF IF (NCOL .EQ. 3) THEN IF (MODE .EQ. 2) THEN WRITE (LU22, 99997) WRITE (LU22, 99998) BCD WRITE (LU22, 99997) ENDIF WRITE (NQ1, 99989) (IHKLR(K, I), K = 1, 3) WRITE (NQ2, 99989) (IHKLD(K, I), K = 1, 3) WRITE (LU20, 99980) '_930', BASFM(I), BASFM(I), NQ1, NQ2 NRTWL = NRTWL + 1 ENDIF IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN VRT = VRT - 1.0 BCD(80:80) = CHAR(0) CALL GGIP20 (0.0, BCD, 80, 0.3, NCOL, 2, 2.0, VRT) ENDIF IF (NLIST .EQ. 1) THEN CALL PLA269 (4) WRITE (LU6, 99997) WRITE (LU7, 99997) ENDIF WRITE (BCD, 99994) (TWM(1, II, I), II = 1, 3), NTW(I) IF (NLIST .EQ. 1) THEN WRITE (LU6, 99998) BCD WRITE (LU7, 99998) BCD ENDIF IF (NCOL .EQ. 3 .AND. MODE .EQ. 2) WRITE (LU22, 99998) BCD IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN VRT = VRT - 1.0 CALL GGIP20 (0.0, BCD, 80, 0.3, NCOL, 2, 2.0, VRT) ENDIF WRITE (BCD, 99993) (TWM(2, II, I), II = 1, 3), BASFM(I) IF (NLIST .EQ. 1) THEN WRITE (LU6, 99998) BCD WRITE (LU7, 99998) BCD ENDIF IF (NCOL .EQ. 3 .AND. MODE .EQ. 2) WRITE (LU22, 99998) BCD IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, BCD, 80, 0.3, NCOL, 2, 2.0, VRT) WRITE (NQ1, 99995) J CALL GGIP20 (0.0, NQ1, 1, 1.5, 1, 2 , HORS - 2.5, VRT) ENDIF WRITE (BCD, 99992) (TWM(3, II, I), II = 1, 3), DRVAL(I) IF (NLIST .EQ. 1) THEN WRITE (LU6, 99998) BCD WRITE (LU7, 99998) BCD ENDIF IF (NCOL .EQ. 3 .AND. MODE .EQ. 2) WRITE (LU22, 99998) BCD IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN VRT = VRT - 0.6 CALL GGIP20 (0.0, BCD, 80, 0.3, NCOL, 2, 2.0, VRT) CALL GGIP (1.8, VRT - 0.4, 0.0, 3) CALL GGIP (HORS, VRT - 0.4, 0.0, 2) ENDIF 350 CONTINUE ELSE IF (MODE .EQ. 1) THEN IF (IWIN .EQ. 1) THEN CALL GGIP20 (0.0, 'No Twin Law Detected', 20, 1.2, 2, 10, 1 3.0, 8.0) ENDIF ENDIF ENDIF IF (MODE .EQ. 2) THEN IF (NRTWL .EQ. 0 .AND. MODE .EQ. 2) WRITE (LU22, 99981) WRITE (LU22, 99997) ENDIF 360 IF (MODE .NE. 2) THEN IF (IGBL(3) .NE. 37) THEN CALL PLA013 (0, 1) IF (IGGT(1:1) .EQ. '!' .OR. IGGT(1:4) .EQ. 'PLOT') GOTO 340 CALL PLA006 (0, IS) C * CALC TWIN LAWS IF (IS .EQ. 18) THEN GOTO 50 C * CALC HKLF (GENERATE HKLF 5 FILE) ELSE IF (IS .EQ. 70) THEN CALL PLA122 GOTO 370 C * END (RETURN) ELSE IF (IS .EQ. 19) THEN GOTO 370 C * LIST (IPR/PAR/IGBL/GL) ELSE IF (IS .EQ. 29) THEN CALL PLA206 (-1, IFL(2)(1:3)) GOTO 360 C * SET (IPR/PAR/IGBL/GL) ELSE IF (IS .EQ. 46) THEN CALL PLA206 (1, IFL(2)(1:3)) GOTO 360 C * EXIT ELSE IF (IS .EQ. 53) THEN GOTO 370 C * TWIN PLOT ELSE IF (IS .EQ. 99) THEN IF (IWIN .EQ. 1) THEN CALL PLA123 ENDIF GOTO 340 ELSE GOTO 360 ENDIF ELSE C * GENERATE HKLF 5 FILE IF (NVCX .GT. 0) THEN CALL PLA122 ENDIF ENDIF ENDIF 370 CONTINUE RETURN 99999 FORMAT ('2-axis (', 3I4, ' ) [',3I4, ' ]', 1 ', Angle () [] =', F6.2, ' Deg, Freq =', I6) 99998 FORMAT (A) 99997 FORMAT (1X) 99996 FORMAT ('Analysis of Fo/Fc Data for Unaccounted (Non)Merohedral', 1 ' Twinning for: ', A) 99995 FORMAT (I1) 99994 FORMAT ('(', F6.3, 2F9.3, ') (h1) (h2)', 19X, 1 'Nr Overlap =', I6) 99993 FORMAT ('(', F6.3, 2F9.3, ') * (k1) = (k2)', 25X, 1 'BASF =', F6.2) 99992 FORMAT ('(', F6.3, 2F9.3, ') (l1) = (l2)', 24X, 1 'DEL-R =', F6.3) 99991 FORMAT ('Cell:', F8.5, 3F7.3, 3F7.2, 2X, 'Spgr: ', A) 99990 FORMAT ('Criteria: DeltaI/SigmaI .GT.', F5.1, ', DeltaTheta', 1 F5.2, ' Deg., NselMin =', I4) 99989 FORMAT (2I2, I3) 99988 FORMAT (' H K L Iobs Icalc SigI', 1 ' Delt/Sig Theta', 1 ' DTheta Alpha Rot Axis', /, 89('=')) 99987 FORMAT ('Wavelength Used in this Analysis', F10.5, ' Ang.', /) 99986 FORMAT (3I3, 2F13.2, 2F9.2, 3F7.2, 3I5) 99985 FORMAT (3I3, 2F13.2, 2F9.2, F7.2) 99984 FORMAT (/, 'Alpha = (Iobs - Icalc) / (Jcalc - Icalc)', /) 99983 FORMAT ('N(refl) =', I7, ', N(selected) =', I5, ', IndMax =', 1 I3, ', CritI =', F4.1, ', CritT =', F5.2) 99982 FORMAT (/, 80('='), /, 1 'Check for Unaccounted Twinning with the TwinRotMat Algorithm.', 2 /, 80('=')) 99981 FORMAT (/, 1 'No Applicable Twin Law(s) Detected from Fo/Fc Analysis', /) 99980 FORMAT (A, 2F10.2, 2A) 99979 FORMAT (60('=')) 99978 FORMAT (/) END SUBROUTINE PLA121 (NRTWIN) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP23=18000,NP38=125,NP39=30,MM=10,NAL=100) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC COMMON // JNSC(2, NP23), VOID(NPVD) DIMENSION IHKL(3), SUMT(NAL), SUMN(NAL), SCLA(NAL), SUMFC(NAL) COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR, 1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN, 2 BASFM(4) COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 INTEGER HMAX DO 30 K = 1, NREF KMM = (K - 1) * MM DO 10 J = 1, 3 IHKL(J) = NINT(VOID(KMM + J)) H(J) = IHKL(J) 10 CONTINUE FOK = VOID(KMM + 4) FCK = VOID(KMM + 5) TH = VOID(KMM + 7) CALL GEN002 (1, TWM(1, 1, NRTWIN), H, T, XDUM) IHT = NINT(T(1)) IKT = NINT(T(2)) ILT = NINT(T(3)) FCKT = 0.0 IF (ABS(T(1) - IHT) .LT. PAR(415)) THEN IF (ABS(T(2) - IKT) .LT. PAR(415)) THEN IF (ABS(T(3) - ILT) .LT. PAR(415)) THEN IHKLTP = ILT * MHK + IKT * MPH + IHT JJJ = IADR + IHKLTP IF (JJJ .GT. NPVD) GOTO 20 J = NINT(VOID(JJJ)) IF (J .LT. 0) THEN GOTO 20 ELSE IF (J .GT. 0) THEN FCKT0 = VOID((J - 1) * MM + 5) ENDIF ST = SQRT(GEN095 (PAR(191), IHT, IKT, ILT)) * PAR(17) IF (ST .LT. 1.0) THEN THT = ASIN (ST) * GL(5) ELSE THT = 0.0 ENDIF IF (ABS(TH - THT) .LE. PAR(420)) THEN IF (ABS(IHT) .LE. HMAX .AND. ABS(IKT) .LE. KMAX .AND. 1 ABS(ILT) .LE. LMAX) THEN NTW(NRTWIN) = NTW(NRTWIN) + 1 FCKT = FCKT0 ENDIF ENDIF ENDIF ENDIF ENDIF 20 VOID (KMM + 10) = FCKT 30 CONTINUE SUMFO = 0.0 NALM = 100 STAL = 1.0 / NALM CALL GEN074 (SUMFC, 0.0, 1, NALM) DO 60 K = 1, NREF KMM = (K - 1) * MM FCKT = VOID(KMM + 10) FOK = VOID(KMM + 4) FCK = VOID(KMM + 5) SUMFO = SUMFO + FOK DO 50 I = 1, NALM ALF = (I - 1) * STAL SUMFC(I) = SUMFC(I) + (1.0 - ALF) * FCK + ALF * FCKT 50 CONTINUE 60 CONTINUE DO 70 I = 1, NALM SCLA(I) = SUMFC(I) / SUMFO SUMT(I) = 0.0 SUMN(I) = 0.0 70 CONTINUE DO 90 K = 1, NREF KMM = (K - 1) * MM FCKT = VOID(KMM + 10) FOK = VOID(KMM + 4) FCK = VOID(KMM + 5) DO 80 I = 1, NALM ALF = (I - 1) * STAL FCKS = (1.0 - ALF) * FCK + ALF * FCKT SUMT(I) = SUMT(I) + ABS(SCLA(I) * FOK - FCKS) SUMN(I) = SUMN(I) + SCLA(I) * FOK 80 CONTINUE 90 CONTINUE BASF = 0.0 RVAL = SUMT(1) / SUMN(1) DRVAL(NRTWIN) = - RVAL DO 100 I = 2, NALM YUNK = SUMT(I) /SUMN(I) IF (YUNK .LT. RVAL) THEN BASF = (I - 1) * STAL RVAL = YUNK ENDIF 100 CONTINUE DRVAL(NRTWIN) = DRVAL(NRTWIN) + RVAL BASFM(NRTWIN) = BASF MTWIN(NRTWIN * 2 - 1) = NINT (DRVAL(NRTWIN) * 1000.0) MTWIN(NRTWIN * 2 ) = NRTWIN RETURN END SUBROUTINE PLA122 PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP23=18000,NP38=125,NP39=30,MM=10) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC COMMON // JNSC(2, NP23), VOID(NPVD) DIMENSION IHKL(3) COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR, 1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN, 2 BASFM(4) COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 INTEGER HMAX, MTW(4) NTX = 0 IRT = (2 - ICNTR) * IPR(575) + 1 CALL PLA269 (0) CALL PLA269 (2) WRITE (LU7, 99999) NTWIN = 0 DO 10 K = 1, 4 IF (IPR(570 + K) .EQ. 1) THEN NTWIN = NTWIN + 1 MTW(NTWIN) = MTWIN(K * 2) ENDIF 10 CONTINUE IPR(2) = -11 DO 40 K = 1, NREF KMM = (K - 1) * MM DO 20 J = 1, 3 IHKL(J) = NINT(VOID(KMM + J)) H(J) = IHKL(J) 20 CONTINUE FOK = VOID(KMM + 4) FCK = VOID(KMM + 5) SIG = VOID(KMM + 6) TH = VOID(KMM + 7) IFOK = NINT(FOK * SCL) ISIG = NINT(SIG * SCL) NTY = 0 DO 30 NRTW = 1, NTWIN NRTWIN = MTW(NRTW) CALL GEN002 (1, TWM(1, 1, NRTWIN), H, T, XDUM) IHT = NINT(T(1)) IKT = NINT(T(2)) ILT = NINT(T(3)) FCKT = 0.0 IPRN = 0 IF (ABS(T(1) - IHT) .LT. PAR(415)) THEN IF (ABS(T(2) - IKT) .LT. PAR(415)) THEN IF (ABS(T(3) - ILT) .LT. PAR(415)) THEN IHKLTP = ILT * MHK + IKT * MPH + IHT J = NINT(VOID(IADR + IHKLTP)) IF (J .LT. 0) THEN GOTO 30 ELSE IF (J .GT. 0) THEN FCKT0 = VOID((J - 1) * MM + 5) ENDIF ST = SQRT(GEN095 (PAR(191), IHT, IKT, ILT)) * PAR(17) IF (ST .LT. 1.0) THEN THT = ASIN (ST) * GL(5) ELSE THT = 0.0 ENDIF IF (ABS(TH - THT) .LE. PAR(420)) THEN IF (ABS(IHT) .LE. HMAX .AND. ABS(IKT) .LE. KMAX .AND. 1 ABS(ILT) .LE. LMAX) THEN NTY = 1 FCKT = FCKT0 NTC = - (NRTW + 1) * IRT IF (IPR(575) .EQ. 1) THEN WRITE (LU17, 99998) -IHT, -IKT, -ILT, IFOK, ISIG, 1 NTC ENDIF WRITE (LU17, 99998) IHT, IKT, ILT, IFOK, ISIG, 1 NTC + (IRT - 1) IPRN = 1 ENDIF ENDIF ENDIF ENDIF ENDIF 30 CONTINUE IF (IPR(575) .EQ. 1) THEN WRITE (LU17, 99998) ( -NINT(H(J)), J = 1, 3), IFOK, ISIG, -2 ENDIF WRITE (LU17, 99998) (NINT(H(J)), J = 1, 3), IFOK, ISIG, 1 NTX = NTX + NTY IF (IPR(469) .NE. 0) THEN CALL PLA269 (1) IF (IPRN .NE. 0) THEN WRITE (LU7, 99997) NTX, (NINT(H(J)), J = 1, 3), 1 FOK, FCK, SIG, IHT, IKT, ILT, FCKT, 2 TH, THT, TH - THT ELSE WRITE (LU7, 99996) (NINT(H(J)), J = 1, 3), FOK, FCK, SIG ENDIF ENDIF VOID (KMM + 10) = FCKT 40 CONTINUE WRITE (LU6, 99995) (MTW(K), K = 1, NTWIN) CALL PLA269 (0) WRITE (LU7, 99995) (MTW(K), K = 1, NTWIN) IF (IRT .EQ. 1) THEN WRITE (LU6, 99994) NREF, NTX, (BASFM(MTW(I)), 1 I = 1, NTWIN) WRITE (LU7, 99994) NREF, NTX, (BASFM(MTW(I)), 1 I = 1, NTWIN) ELSE WRITE (LU6, 99994) NREF, NTX, 1 (BASFM(MTW(NTWIN + 1 - I)) / 2.0, 2 BASFM(MTW(NTWIN + 1 - I)) / 2.0, 3 I = 1, NTWIN) WRITE (LU7, 99994) NREF, NTX, 1 (BASFM(MTW(NTWIN + 1 - I)) / 2.0, 2 BASFM(MTW(NTWIN + 1 - I)) / 2.0, 3 I = 1, NTWIN) ENDIF RETURN 99999 FORMAT (3X, 'nr', 6X, 'H K L', 7X, 'FOK', 7X, 'FCK', 7X, 1 'SIG', 5X, 'HT KT LT', 6X, 'FCKT', 2 8X, 'TH', 7X, 'THT', 4X, 'DEL-TH', /, 105('=')) 99998 FORMAT (3I4, 2I8, I4) 99997 FORMAT (I5, I7, 2I4, 3F10.2, I7, 2I4, 4F10.2) 99996 FORMAT (5X, I7, 2I4, 3F10.2) 99995 FORMAT (/, ':: TwinRotMatrix #', 4I5) 99994 FORMAT (':: Total Number of Reflections in HKLF 5 file =', I6, 2 /, ':: Number of which with Twin Contribution =', I6, 3 /, ':: Estimated BASF Line =', 8F5.2) END SUBROUTINE PLA123 PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP23=18000,NP38=125,NP39=30,MM=10) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR, 1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN, 2 BASFM(4) COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 DIMENSION IMX(3), JMX(3), XYZ(3), TAU(3), ROT(3, 3), IAS(8), 1 AS(3, 8) INTEGER HMAX HH = HORS / 2.0 VH = VERT / 2.0 RD = 0.9 * VH IBRV = IPR(241) 10 NTPLT = MTWIN(IPR(543) * 2) STL = PAR(449) RADM = RD DO 20 I = 1, 3 IMX(I) = INT (2 * STL * PAR(100 + I)) JMX(I) = 2 * IMX(I) + 1 RADM = MIN (RADM, RD / IMX(I)) 20 CONTINUE RADM = RADM * 0.45 NV = NADR FCMX = 0.0 DO 60 I = 1, JMX(1) II = I - IMX(1) - 1 DO 50 J = 1, JMX(2) JJ = J - IMX(2) - 1 DO 40 K = 1, JMX(3) KK = K - IMX(3) - 1 H(1) = II H(2) = JJ H(3) = KK YUNK = 0 IF (IBRV .GT. 1) THEN IF (GEN049 (LAT(IBRV), II, JJ, KK) .LT. 0.0) YUNK = -1.0 ENDIF ITP = -1 IF (II .EQ. 0 .AND. JJ .EQ. 0 .AND. KK .EQ. 0) ITP = 0 IF (II .EQ. 1 .AND. JJ .EQ. 0 .AND. KK .EQ. 0) ITP = 1 IF (II .EQ. 0 .AND. JJ .EQ. 1 .AND. KK .EQ. 0) ITP = 2 IF (II .EQ. 0 .AND. JJ .EQ. 0 .AND. KK .EQ. 1) ITP = 3 IF (II .EQ. 1 .AND. JJ .EQ. 1 .AND. KK .EQ. 0) ITP = 4 IF (II .EQ. 1 .AND. JJ .EQ. 0 .AND. KK .EQ. 1) ITP = 5 IF (II .EQ. 0 .AND. JJ .EQ. 1 .AND. KK .EQ. 1) ITP = 6 DO 30 L = 1, 2 IF (L .EQ. 1) THEN T(1) = H(1) T(2) = H(2) T(3) = H(3) FCK = 0.0 IF (IABS(NINT(T(1))) .LE. HMAX .AND. 1 IABS(NINT(T(2))) .LE. KMAX .AND. 2 IABS(NINT(T(3))) .LE. LMAX) THEN IHKLP = NINT(T(3)) * MHK + NINT(T(2)) * MPH 1 + NINT(T(1)) N = NINT(VOID(IADR + IHKLP)) IF (N .GT. 0) FCK = VOID((N - 1) * MM + 5) ENDIF IF (FCK .GT. 0) THEN FCX = LOG(FCK) ELSE FCX = 0.0 ENDIF FCMX = MAX (FCMX, FCX) ELSE CALL GEN002 (1, TWM(1, 1, NTPLT), H, T, XDUM) ENDIF CALL GEN002 (1, ROTQ, T, XYZ, XDUM) IF (SQRT(GEN009 (XYZ, XYZ)) .LT. 2 * STL) THEN VOID(NV + 1) = L VOID(NV + 2) = H(1) VOID(NV + 3) = H(2) VOID(NV + 4) = H(3) VOID(NV + 5) = XYZ(1) VOID(NV + 6) = XYZ(2) VOID(NV + 7) = XYZ(3) VOID(NV + 8) = ITP VOID(NV + 9) = YUNK VOID(NV + 10) = FCX NV = NV + 10 ENDIF 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CALL GEN097 (IAS, 1, 8, 0) 80 DO 90 I = 1, 3 TAU(I) = OR(I, IPR(394)) 90 CONTINUE XTAU = SQRT(GEN009 (TAU, TAU)) DO 100 I = 1, 3 TAU(I) = TAU(I) / XTAU 100 CONTINUE IF (ABS(TAU(1)) + ABS(TAU(2)) .LT. 0.0001) THEN OME = 0.0 CHI = 90.0 / GL(5) ELSE OME = ATAN2 (TAU(2), TAU(1)) CHI = ATAN2 (TAU(3), SQRT(TAU(1)**2 + TAU(2)**2)) ENDIF CALL GEN043 (3, TP, OME) CALL GEN043 (2, TG, 90.0 / GL(5) - CHI) CALL GEN004 (TG, TP, ROT) IF (IPR(394) .EQ. 2 .OR. IPR(394) .EQ. 3) THEN CALL GEN043 (3, TG, 180.0 / GL(5)) ELSE CALL GEN043 (3, TG, 90.0 / GL(5)) ENDIF CALL GEN004 (TG, ROT, ROT) BCD = 'PlotTwinLat'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (90.0, BCD, 11, 1.2, 2, 8, 2.3, 2.5) CALL PLA117 (HORS, VERT, -1) VRT = VERT - 0.4 CALL GGIP20 (0.0, 'Twin Matrix', 11, 0.25, 5, 1, 2.0, VRT) VRT = VRT - 0.2 DO 110 I = 1, 3 WRITE (LINE, 99999) (TWM(I, J, NTPLT), J = 1, 3) VRT = VRT - 0.4 CALL GGIP20 (0.0, LINE, 21, 0.25, 1, 1, 0.5, VRT) 110 CONTINUE VRT = VRT - 0.7 WRITE (LINE, 99996) (IHKLD(I, NTPLT), I = 1, 3) CALL GGIP20 (0.0, LINE, 17, 0.30, 1, 1, 1.0, VRT) VRT = VRT - 0.6 WRITE (LINE, 99998) (IHKLR(I, NTPLT), I = 1, 3) CALL GGIP20 (0.0, LINE, 17, 0.30, 1, 1, 1.0, VRT) IF (IPR(394) .EQ. 1) THEN LINE = 'Zone - H =' ELSE IF (IPR(394) .EQ. 2) THEN LINE = 'Zone - K =' ELSE LINE = 'Zone - L =' ENDIF WRITE (LINE(11:13), 99997) IPR(576) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 13, 0.35, 5, 1, 1.0, VRT) WRITE (LINE, '(''Resol = '', F5.1)') PAR(449) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT) WRITE (LINE, '('' BASF ='', F6.2)') BASFM(NTPLT) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT) WRITE (LINE, '(''DRVAL ='', F6.3)') DRVAL(NTPLT) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT) VRT = VERT WRITE (LINE, '(''SpGr '', A)') SPGRNM(1)(1:7) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''a '', F7.2)') PAR(101) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''b '', F7.2)') PAR(102) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''c '', F7.2)') PAR(103) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''alpha'', F7.2)') PAR(104) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''beta '', F7.2)') PAR(105) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''gamma'', F7.2)') PAR(106) VRT = VRT - 0.6 CALL GGIP20 (0.0, LINE, 14, 0.35, 1, 1, HORS - 4.0, VRT) CALL GGIP (HH, VH, 0.0, -3) CALL PLA289 (0.0, 0.0, RD, 36) SCF = RD / (2 * STL) BAS2 = BASFM(NTPLT) BAS1 = 1.0 - BAS2 SCPR0 = IPR(576) / XTAU DO 130 N = NADR, NV, 10 SCPR = GEN009 (TAU, VOID(N + 5)) IF (ABS(SCPR0 - SCPR) .LT. 0.01) THEN IPEN = NINT (VOID(N + 1)) ITP = NINT (VOID(N + 8)) IPLT = NINT (VOID(N + 9)) DO 120 I = 1, 3 T(I) = VOID (N + I + 4) * SCF 120 CONTINUE IF (IPEN .EQ. 1) THEN NADD = 0 ELSE NADD = 4 ENDIF IF (IPR(394) .EQ. 1) THEN IF (ITP .EQ. 2) IAS(1 + NADD) = N IF (ITP .EQ. 0) IAS(2 + NADD) = N IF (ITP .EQ. 3) IAS(3 + NADD) = N IF (ITP .EQ. 6) IAS(4 + NADD) = N ELSE IF (IPR(394) .EQ. 2) THEN IF (ITP .EQ. 1) IAS(1 + NADD) = N IF (ITP .EQ. 0) IAS(2 + NADD) = N IF (ITP .EQ. 3) IAS(3 + NADD) = N IF (ITP .EQ. 5) IAS(4 + NADD) = N ELSE IF (IPR(394) .EQ. 3) THEN IF (ITP .EQ. 1) IAS(1 + NADD) = N IF (ITP .EQ. 0) IAS(2 + NADD) = N IF (ITP .EQ. 2) IAS(3 + NADD) = N IF (ITP .EQ. 4) IAS(4 + NADD) = N ENDIF CALL GEN002 (1, ROT, T, XYZ, XLNG) IF (IPLT .EQ. 0) THEN RADIUS = RADM * VOID(N + 10) / FCMX IF (IPEN .EQ. 1) THEN RADIUS = MAX (RADIUS, 0.02) NSTEP = 12 ELSE RADIUS = MAX (RADIUS * BAS2 / BAS1, 0.02) NSTEP = 3 ENDIF CALL GGIP (0.0, FLOAT(IPEN), 0.0, 0) CALL PLA289 (XYZ(1), XYZ(2), RADIUS, NSTEP) ENDIF ENDIF 130 CONTINUE IF (IPR(576) .EQ. 0) THEN DO 150 J = 1, 8 DO 140 I = 1, 3 IASJ = IAS(J) IF (IASJ .EQ. 0) IASJ = IAS(2) T(I) = VOID (IASJ + I + 4) * SCF 140 CONTINUE CALL GEN002 (1, ROT, T, AS(1, J), XLNG) 150 CONTINUE DO 160 I = 1, 2 NADD = (2 - I) * 4 CALL GGIP (0.0, FLOAT(3 - I), 0.0, 0) CALL GGIP (AS(1, 1 + NADD), AS(2, 1 + NADD), 0.0, 3) CALL GGIP (AS(1, 2 + NADD), AS(2, 2 + NADD), 0.0, 2) CALL GGIP (AS(1, 3 + NADD), AS(2, 3 + NADD), 0.0, 2) CALL GGIP (AS(1, 4 + NADD), AS(2, 4 + NADD), 0.0, 2) CALL GGIP (AS(1, 1 + NADD), AS(2, 1 + NADD), 0.0, 2) 160 CONTINUE CALL GGIP20 (0.0, 'O', 1, 0.25, 1, 2, AS(1, 2) -0.3, 1 AS(2, 2) - 0.3) IF (IPR(394) .EQ. 1) THEN CALL GGIP20 (0.0, 'K', 1, 0.25, 1, 2, AS(1, 1), 1 AS(2, 1) + 0.1) CALL GGIP20 (0.0, 'L', 1, 0.25, 1, 2, AS(1, 3) + 0.1, 1 AS(2, 3)) ELSE IF (IPR(394) .EQ. 2) THEN CALL GGIP20 (0.0, 'H', 1, 0.25, 1, 2, AS(1, 1), 1 AS(2, 1) + 0.1) CALL GGIP20 (0.0, 'L', 1, 0.25, 1, 2, AS(1, 3) + 0.1, 1 AS(2, 3)) ELSE IF (IPR(394) .EQ. 3) THEN CALL GGIP20 (0.0, 'H', 1, 0.25, 1, 2, AS(1, 1), 1 AS(2, 1) + 0.1) CALL GGIP20 (0.0, 'K', 1, 0.25, 1, 2, AS(1, 3) + 0.1, 1 AS(2, 3)) ENDIF ENDIF CALL PLA013 (0, 1) IF (IGGT(1:1) .EQ. '!') THEN GOTO 70 ELSE IF (IGGT(1:4) .EQ. 'TWIN') THEN GOTO 10 ELSE IF (IGGT(1:4) .EQ. 'NEXT') THEN IPR(576) = MAX (-IMX(IPR(394)), MIN (IMX(IPR(394)), 1 IPR(576) + IPR(389))) GOTO 80 ELSE IF (IGGT(1:4) .EQ. 'ZONE') THEN GOTO 70 ELSE IF (IGGT(1:4) .EQ. 'RESO') THEN GOTO 10 ELSE IPR(543) = 0 ENDIF RETURN 99999 FORMAT (3F7.3) 99998 FORMAT ('(', I3, 2I5, ' )') 99997 FORMAT (I3) 99996 FORMAT ('[', I3, 2I5, ' ]') END SUBROUTINE PLA124 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP23=18000, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9, 3 NPVD=40000000,MM=10) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR, 1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN, 2 BASFM(4) COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /NPPLOT/ YCC, YINT, YSLOPE CHARACTER FORM*9 INTEGER HMAX NFPK = 32000 C * Analysis of Friedel Pair Differences IF (ICNTR .EQ. 2) THEN WRITE (LU6, 99999) ELSE IF (NREF .GT. NFPK) THEN WRITE (LU6, 99981) NFPK ELSE IGBL(23) = 29 NADR = NREF * MM MPH = 2 * HMAX + 1 MPK = 2 * KMAX + 1 MPL = 2 * LMAX + 1 MHK = MPH * MPK MHKL = MPL * MHK MHKLH = (MHKL - 1) / 2 IADR = NPVD - MHKLH IADR1 = NPVD - MHKL DO 10 I = 1, MHKL VOID(IADR1 + I) = 0.0 10 CONTINUE DO 30 I = 1, NREF IMM = (I - 1) * MM XJS(1) = VOID(IMM + 1) XJS(2) = VOID(IMM + 2) XJS(3) = VOID(IMM + 3) DO 20 NS = 1, NSYMH CALL SGSM (LINE, NS, XJS, LU7, 5, IER) IH = NINT(XJS(7)) IK = NINT(XJS(8)) IL = NINT(XJS(9)) IHKLP = IL * MHK + IK * MPH + IH VOID (IADR + IHKLP) = I 20 CONTINUE 30 CONTINUE 40 NF0 = 0 NF = 0 NPLS = 0 NMIN = 0 NFR = 0 CALL GEN074 (DATC, 0.0, 1, 101) CALL PLA269 (0) DO 60 I = 1, NREF IMM = (I - 1) * MM IH = NINT(VOID(IMM + 1)) IK = NINT(VOID(IMM + 2)) IL = NINT(VOID(IMM + 3)) FOK1 = VOID(IMM + 4) FCK1 = VOID(IMM + 5) SIG1 = VOID(IMM + 6) IHKLP = IL * MHK + IK * MPH + IH N = NINT(VOID(IADR - IHKLP)) IF (N .GT. I) THEN NF0 = NF0 + 1 M = (N - 1) * MM FOK2 = VOID(M + 4) FCK2 = VOID(M + 5) SIG2 = VOID(M + 6) FOKD = FOK1 - FOK2 FCKD = FCK1 - FCK2 SIGM = SQRT(SIG1**2 + SIG2**2) NFR = NFR + 1 VOID (NADR + NFR) = (FCKD - FOKD) / SIGM DO 50 J = 1, 101 YK = (J - 51) * 0.1 DATC(J) = DATC(J) - (((YK * FCKD - FOKD) / SIGM)**2) / 2 50 CONTINUE IF (ABS(FCK1 - FCK2) .GE. PAR(452) * SIGM) THEN IF (NF .LT. NP23) THEN NF = NF + 1 SIGM = MAX (SIGM, 0.01) JNSC(1, NF) = 100000000 1 - NINT(100.0 * ABS(FCK1 - FCK2) / SIGM) JNSC(2, NF) = I * NFPK + N ENDIF ENDIF ENDIF 60 CONTINUE IF (NF .LT. 3) THEN IF (PAR(452) .GT. 0.0) THEN PAR(452) = 0.0 GOTO 40 ENDIF ENDIF C * NORMAL PROBABILITY PLOT IF (NFR .GT. 0) THEN WRITE (LU7, 99969) CALL PLA282 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NFR, 1 LU7) CALL PLA269 (0) ENDIF SUM = 0.0 SUMW = 0.0 XMAX = 0.0 YMAX = 0.0 RCT = 0.0 RCN = 0.0 DDP = -999999.0 DDM = 999999.0 IF (NF .GT. 0) THEN CALL GEN037 (JNSC, 1, NF) DO 70 N = 1, NF J = JNSC(2, N) I = J / NFPK J = MOD (J, NFPK) IMM = (I - 1) * MM JMM = (J - 1) * MM IH1 = NINT(VOID(IMM + 1)) IK1 = NINT(VOID(IMM + 2)) IL1 = NINT(VOID(IMM + 3)) FOK1 = VOID(IMM + 4) FCK1 = VOID(IMM + 5) SIG1 = VOID(IMM + 6) IH2 = NINT(VOID(JMM + 1)) IK2 = NINT(VOID(JMM + 2)) IL2 = NINT(VOID(JMM + 3)) FOK2 = VOID(JMM + 4) FCK2 = VOID(JMM + 5) SIG2 = VOID(JMM + 6) FOKD = FOK1 - FOK2 FCKD = FCK1 - FCK2 SIGM = SIG1**2 + SIG2**2 RCT = RCT + FOKD * FCKD / SIGM RCN = RCN + FCKD**2 / SIGM SIGM = SQRT(SIGM) IF (FOKD * FCKD .GT. 0.0) THEN NPLS = NPLS + 1 ELSE NMIN = NMIN + 1 ENDIF IF (ABS(FOKD) .LT. 3.0 * ABS(FCKD)) THEN XMAX = MAX (XMAX, ABS(FCKD)) YMAX = MAX (YMAX, ABS(FOKD)) ENDIF IF (FCKD .NE. 0.0) THEN RATIO = FOKD / FCKD DCDOS = (FCKD - FOKD) / SIGM DDP = MAX (DDP, DCDOS) DDM = MIN (DDM, DCDOS) IF (SIGM .GT. 0.0) THEN WGHT = ABS(FCKD) / SIGM SUM = SUM + WGHT * RATIO SUMW = SUMW + WGHT ENDIF ENDIF IF (N .EQ. 1) THEN WRITE (LU7, 99997) PAR(452) CALL PLA269 (3) WRITE (LU7, 99996) CALL PLA269 (2) ENDIF IF (N .LT. 21) THEN IF (N .EQ. 1) WRITE (LU6, 99993) WRITE (LU6, 99994) IH1, IK1, IL1, IH2, IK2, IL2, 1 FOKD, FCKD, SIGM, WGHT, RATIO, DCDOS ENDIF CALL PLA269 (1) WRITE (LU7, 99998) IH1, IK1, IL1, FOK1, FCK1, SIG1, 1 IH2, IK2, IL2, FOK2, FCK2, SIG2, 2 FOKD, FCKD, SIGM, WGHT, RATIO, DCDOS 70 CONTINUE SUM = SUM / SUMW ENDIF IF (IPR(593) .NE. 0) THEN DO 75 J = 1, 101 DATC(J) = DATC(J) / YSLOPE**2 75 CONTINUE ENDIF DATCM = DATC(1) DO 80 J = 2, 101 IF (DATC(J) .GT. DATCM) DATCM = DATC(J) 80 CONTINUE XG0 = 0.0 XG1 = 0.0 XG2 = 0.0 DO 90 J = 1, 101 YK = (J - 51) * 0.1 XG1 = XG1 + YK * EXP (DATC(J) - DATCM) XG0 = XG0 + EXP (DATC(J) - DATCM) 90 CONTINUE XG = XG1 / XG0 DO 100 J = 1, 101 YK = (J - 51) * 0.1 XG2 = XG2 + (YK - XG)**2 * EXP (DATC(J) - DATCM) 100 CONTINUE FLEQ = (1.0 - XG) / 2.0 SFLEQ = SQRT (XG2 / XG0) / 2.0 XPLLL = DATC(61) - DATCM XMNLL = DATC(41) - DATCM XTWLL = DATC(51) - DATCM XPLLL = EXP(XPLLL) XTWLL = EXP(XTWLL) XMNLL = EXP(XMNLL) XSMLL = XPLLL + XTWLL + XMNLL XPLLL = XPLLL / XSMLL XMNLL = XMNLL / XSMLL XTWLL = XTWLL / XSMLL IF (RCN .NE. 0) THEN RCO = RCT / RCN ELSE RCO = 0.0 ENDIF WRITE (LU6, 99995) SUM, NF, NF0, DDM, DDP CALL PLA269 (3) WRITE (LU7, 99995) SUM, NF, NF0, DDM, DDP C * SCATTER DISPLAY 110 IF (XMAX .NE. 0.0 .AND. YMAX .NE. 0.0) THEN SCLX = 0.90 * VERT / (2.0 * XMAX) SCLY = 0.90 * VERT / (2.0 * YMAX) XOR = VERT / 2.0 YOR = VERT / 2.0 CALL GGIP (HORS, VERT, 0.0, 1) CALL PLA117 (VERT, VERT, -1) CALL PLA269 (0) LINE = 'BIJVOET-PAIR SCATTER PLOT' VRT = VERT - 0.6 CALL GGIP20 (0.0, LINE, 25, 0.35, 5 + IGBL(68), 2, 6.0, VRT) LINE = 'DELTA Fobs**2' CALL GGIP20 (90.0, LINE, 13, 0.35, 1, 2, 0.6, VERT - 4.6) LINE = 'DELTA Fcalc**2' CALL GGIP20 (0.0, LINE, 14, 0.35, 1, 2, VERT - 4.6, 0.2) WRITE (LINE, 99984) SPGRNM(1)(1:7) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 19, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.2 IF (PAR(433) .LT. 999999.0) THEN VRT = VRT - 0.7 WRITE (LINE, 99992) PAR(433) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) ENDIF IF (PAR(434) .LT. 999999.0) THEN VRT = VRT - 0.7 WRITE (LINE, 99980) PAR(434) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) ENDIF VRT = VRT - 1.5 WRITE (LU7, 99967) WRITE (LINE, 99990) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 14, 0.45, 5 + IGBL(68), 2, 1 VERT + 0.2, VRT) VRT = VRT - 0.8 WRITE (LINE, 99987) PAR(452) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99989) NF WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99988) NF0 WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99986) NPLS WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99985) NMIN WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99991) SUM WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99970) RCO WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 1.0 WRITE (LU7, 99967) WRITE (LINE, 99966) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 5 + IGBL(68), 2, 1 VERT + 0.2, VRT) VRT = VRT - 0.9 WRITE (LINE, 99965) YCC WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99964) YINT WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99963) YSLOPE WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 1.0 WRITE (LU7, 99967) WRITE (LINE, 99974) WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 5 + IGBL(68), 2, 1 VERT + 0.2, VRT) VRT = VRT - 0.9 WRITE (LINE, 99973) NF0 WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 IF (XPLLL .GT. 0.001) THEN WRITE (FORM, '(F9.3)') XPLLL ELSE WRITE (FORM, '(E9.1)') XPLLL ENDIF WRITE (LINE, 99979) FORM WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 IF (XTWLL .GT. 0.001) THEN WRITE (FORM, '(F9.3)') XTWLL ELSE WRITE (FORM, '(E9.1)') XTWLL ENDIF WRITE (LINE, 99977) FORM WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 IF (XMNLL .GT. 0.001) THEN WRITE (FORM, '(F9.3)') XMNLL ELSE WRITE (FORM, '(E9.1)') XMNLL ENDIF WRITE (LINE, 99978) FORM WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99972) XG WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 YUNK = SQRT (XG2 / XG0) IF (YUNK .GT. 0.0001) THEN WRITE (FORM, '(F9.4)') YUNK ELSE WRITE (FORM, '(E9.1)') YUNK ENDIF WRITE (LINE, 99971) FORM WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 WRITE (LINE, 99976) FLEQ WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) VRT = VRT - 0.7 IF (SFLEQ .GT. 0.001) THEN WRITE (FORM, '(F9.3)') SFLEQ ELSE WRITE (FORM, '(E9.1)') SFLEQ ENDIF WRITE (LINE, 99975) FORM WRITE (LU7, 99968) LINE CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT) CALL GGIP (XOR, YOR, 0.0, -3) DX = 0.45 * VERT CALL GGIP (0.0, FLOAT(5 + IGBL(68)), 0.0, 0) CALL GGIP (0.0, - DX, 0.0, 3) CALL GGIP (0.0, + DX, 0.0, 2) CALL GGIP (- DX, 0.0, 0.0, 3) CALL GGIP (DX, 0.0, 0.0, 2) CALL GGIP (0.0, 0.0, 0.0, 3) DY = XMAX * RCO / YMAX IF (DY .LT. 1.0) THEN DX0 = - DX DY0 = - DX * DY ELSE DX0 = - DX / DY DY0 = - DX ENDIF CALL GGIP (0.0, 3.0, 0.0, 0) CALL GGIP (DX0, DY0, 0.0, 2) CALL GGIP (0.0, 0.0, 0.0, 3) WRITE (LINE, 99983) XMAX CALL GGIP20 (90.0, LINE, 9, 0.3, 1, 2, DX + 0.4, -1.2) WRITE (LINE, 99983) YMAX CALL GGIP20 (0.0, LINE, 9, 0.3, 1, 2, -2.8, DX - 0.3) DSH = 0.05 DO 130 N = 1, NF J = JNSC(2, N) I = J / NFPK J = MOD (J, NFPK) IMM = (I - 1) * MM JMM = (J - 1) * MM FOK1 = VOID(IMM + 4) FCK1 = VOID(IMM + 5) SIG1 = VOID(IMM + 6) FOK2 = VOID(JMM + 4) FCK2 = VOID(JMM + 5) SIG2 = VOID(JMM + 6) FOKD = SCLY * (FOK1 - FOK2) FCKD = SCLX * (FCK1 - FCK2) SIG = SCLY * SQRT(SIG1**2 + SIG2**2) IF (ABS(FOKD) .GT. 0.45 * VERT) GOTO 130 DO 120 M = 1, 3, 2 IF (FOKD * FCKD .GE. 0.0) THEN COLR = 1.0 ELSE COLR = 2.0 ENDIF CALL GGIP (0.0, COLR, 0.0, 0) X = (M - 2) * FCKD Y = (M - 2) * FOKD CALL GGIP (X, Y + DSH, 0.0, 3) CALL GGIP (X + DSH, Y, 0.0, 2) CALL GGIP (X, Y - DSH, 0.0, 2) CALL GGIP (X - DSH, Y, 0.0, 2) CALL GGIP (X, Y + DSH, 0.0, 2) IF (X .GT. 0.0) THEN CALL GGIP (X, Y + SIG, 0.0, 3) CALL GGIP (X, Y - SIG, 0.0, 2) IF (X .GT. DX / 2.0 .OR. Y .LT. -DX / 2.0) THEN IH = NINT(VOID(IMM + 1)) IK = NINT(VOID(IMM + 2)) IL = NINT(VOID(IMM + 3)) WRITE (LINE, 99982) IH, IK, IL IF (MOD(N, 2) .EQ. 1) THEN ADD = 0.1 ELSE ADD = -1.1 ENDIF CALL GGIP20 (-45.0, LINE, 9, 0.16, 5 + IGBL(68), 1 1, X + ADD , Y - ADD) ENDIF ENDIF 120 CONTINUE 130 CONTINUE ENDIF CALL PLA013 (0, 1) CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) IF (IFL(1)(1:3) .EQ. 'END') THEN GOTO 140 ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN GOTO 140 ELSE IF (IFL(1)(1:5) .EQ. 'SIGMA') THEN GOTO 40 ELSE IF (IFL(1)(1:5) .EQ. 'SLOPE') THEN GOTO 40 ELSE GOTO 110 ENDIF ENDIF 140 RETURN 99999 FORMAT (':: No Bijvoet Pair Analysis for Centrosymmetric', 1 ' Structure') 99998 FORMAT (2(3I4, 2F10.2, F8.2), 3F9.2, 2F8.2, F9.3) 99997 FORMAT ('Analyses of Bijvoet-Pair (Friedel-Pair) Differences', 1 ' for abs(Fcalcl**2 - Fcalc2**2))/Sigma .GT. ', F6.2, /, 2 101('='), /) 99996 FORMAT (' IH1 IK1 IL1 FO1**2 FC1**2 SIGMA1', 1 ' IH2 IK2 IL2 FO2**2 FC2**2 SIGMA2', 2 ' DELOBS DELCALC SIG(DEL) DLC/SIG DLO/DLC DC-DO/S', /, 3 132('=')) 99995 FORMAT (/, 'Average Weighted Ratio =', F6.2, ' for', I5, 1 ' Bijvoet Pairs (out of', I7, ')', /, 2 ' MIN, MAX = ', 2F8.3, /) 99994 FORMAT (3I4, 2X, 3I4, 5F9.2, F9.3) 99993 FORMAT (/, ' IH1 IK1 IL1 IH2 IK2 IL2 DELOBS DELCALC', 1 ' SIG(DEL) DLC/SIG DLO/DLC DC-DO/SG', /) 99992 FORMAT ('Flack Param', F10.3) 99991 FORMAT ('Aver. Ratio', F10.3) 99990 FORMAT ('Bijvoet Pairs:') 99989 FORMAT ('Selected ...', I9) 99988 FORMAT ('Out of .....', I9) 99987 FORMAT ('Sigma Crit..', F9.2) 99986 FORMAT ('Number Plus ', I9) 99985 FORMAT ('Number Minus', I9) 99984 FORMAT ('Space Group ', A) 99983 FORMAT (F9.2) 99982 FORMAT (3I3) 99981 FORMAT (':: No Bijvoet Pair Analyses: More than', I6, 1 'Reflections') 99980 FORMAT ('Flack S.U. ', F10.3) 99979 FORMAT ('P(ok).......', A) 99978 FORMAT ('P(wrong) ...', A) 99977 FORMAT ('P(rac-twin).', A) 99976 FORMAT ('FLEQ .......', F9.3) 99975 FORMAT ('FLEQ S.U. ..', A) 99974 FORMAT ('Bayesian Statistics') 99973 FORMAT ('Bijvoet Pairs', I8) 99972 FORMAT ('G ..........', F9.4) 99971 FORMAT ('G S.U. .....', A) 99970 FORMAT ('RC .........', F9.3) 99969 FORMAT (':: NPP for (delta(Fcalc**2) - delta(Fobs**2))/sigma', /, 1 ' Sigma = sqrt(sigma(Fobs1**2) + sigma(Fobs2**2))') 99968 FORMAT (A) 99967 FORMAT (/) 99966 FORMAT ('Normal Prob. Plot') 99965 FORMAT ('Corr. Coeff.', F9.3) 99964 FORMAT ('Intercept ..', F9.3) 99963 FORMAT ('Slope ......', F9.3) END SUBROUTINE PLA125 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2 * NP23), VOID(NPVD) COMMON /ISCR/ NXYZ(3), NXYZ0(3), IGR(3), JGR(3), KGR(3), MGR(3), 1 IJGR(3) DIMENSION DUMW(3, 3), EW(3), NGPV(3), NGNX(3), NJG(4, 2), 1 EV(3, 3), I123(4, 3) COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /FNAME/ KNM(8), KXT, KNM16 CHARACTER PLPATH*255 INTEGER FINDEXE EXTERNAL SYSTEM IGBL(23) = 24 NGB = 0 NGE = 0 CSLA = 0.0 REWIND LU15 NSYM = IPR(48) CALL GEN097 (I123, 1, 12, 0) I123(2, 1) = 1 I123(3, 2) = 1 I123(4, 3) = 1 NGRTR = ICHAR('>') NDOT = ICHAR('.') 10 ISAR = IPR(39) + 1 IF (ISAR .GE. NP1) THEN IF (IGBL(3) .NE. 1) IPR(2) = 25 GOTO 460 ENDIF IAT = NP1 XLAB(IAT) = IPR(464) IPR(58) = 0 IPR(61) = IPR(75) + 1 IPR(98) = 0 IPR(104) = IPR(61) IPR(127) = 0 IPR(188) = 0 IPR(190) = 0 IPR(198) = 0 IF (IPR(491) .EQ. 0) THEN IF (IGBL(3) .EQ. 0) THEN IPR(491) = 40000 ELSE IPR(491) = 5000 ENDIF ENDIF IPR(199) = 0 IF (IPR(214) .GT. 0) PAR(80) = PAR(84) / IPR(214) PAR(19) = PAR(84) IF (IPR(189) .EQ. 1) THEN PAR(20) = PAR(19) ELSE PAR(20) = 0.0 ENDIF O11 = OR(1, 1) O12 = OR(1, 2) O13 = OR(1, 3) O22 = OR(2, 2) O23 = OR(2, 3) O33 = OR(3, 3) IF (NINT(PAR(100 + IPR(187)) / PAR(80)) .GT. 130) THEN CALL GEN014 (IPR(186), IPR(187)) IF (NINT(PAR(100 + IPR(187)) / PAR(80)) .GT. 130) THEN CALL GEN014 (IPR(185), IPR(187)) ENDIF ENDIF DO 20 K = 1, 3 KK = IPR(184 + K) NGRID = NINT(PAR(100 + KK) / (PAR(80) * 12)) * 12 PAR(80 + K) = 1.0 / NGRID IPR(193 + K) = NGRID MGR(K) = IFIX(NGRID * PAR(84) * PAR(112 + KK)) + 1 20 CONTINUE DO 30 K = 1, 3 IPR(394 + IPR(184 + K)) = IPR(193 + K) 30 CONTINUE N1 = IPR(194) N2 = IPR(195) N3 = IPR(196) N23 = N2 * N3 NTGRD = N1 * N23 KGR(1) = N23 KGR(2) = N3 KGR(3) = 1 IF (IGBL(3) .EQ. 1) THEN NMXG = 2 ** 20 ELSE NMXG = 2 ** 24 ENDIF N = N1 * N2 * N3 WRITE (LU6, 99986) PAR(80), NTGRD * 100.0 / NPVD IF (NTGRD .GT. NPVD .OR. N .GT. NMXG) THEN IPR(214) = IPR(214) - 1 IF (IPR(214) .GT. 0) THEN IF (PAR(84) / IPR(214) .LT. 0.41) GOTO 10 ENDIF IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99973) '_603', 1.0, 1.0 ELSE IPR(2) = 19 ENDIF GOTO 460 ENDIF WRITE (PRBUF, 99999) PAR(80), PAR(84) C * START WINDOW FOR SOLV/VOID IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(121) .EQ. 0 .AND. 1 IGBL(3) .NE. 5) THEN IWIN = 1 CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.6 CALL GGIP20 (0.0, PRBUF, 68, 0.4, 5 + IGBL(68), 2, 1.0, VRT) IF (IPR(483) .GT. 0 .AND. IPR(484) .EQ. 0) THEN WRITE (PRBUF, 99968) WRITE (LU6, 99971) PRBUF(1:80) CALL GGIP20 (0.0, PRBUF, 60, 0.5, 2, 2, 3.0, 1.0) ENDIF CALL GGIP20 (0.0, 'WorkinG', 7, 3.0, 2, 10, 5.0, 8.0) WRITE (PRBUF, 99990) PAR(84) CALL GGIP20 (0.0, PRBUF, 68, 0.35, 1, 2, 0.5, 5.0) CALL GGIP (0.0, 0.0, 0.0, 6) VRT = VRT - 0.2 ENDIF IF (IGBL(63) .GT. 2) THEN PAGET = 'VOIDS' CALL PLA269 (0) CALL PLA269 (14) IF (LMT(IENS(IAN), 1) .EQ. 'Cg') THEN IAN0 = IAN - 1 ELSE IAN0 = IAN ENDIF WRITE (PRBUF, 99999) PAR(80), PAR(84) WRITE (LU7, 99969) PRBUF WRITE (LU6, 99975) (LMT(IENS(I), 1), I = 1, IAN0) WRITE (LU7, 99975) (LMT(IENS(I), 1), I = 1, IAN0) WRITE (LU6, 99974) (RADR(IENS(I), 4), I = 1, IAN0) WRITE (LU7, 99974) (RADR(IENS(I), 4), I = 1, IAN0) WRITE (LU7, 99989) (CHAR(IPR(184 + K) + ICHAR('W')), 1 PAR(80 + K), IPR(193 + K), 2 PAR(100 + IPR(184 + K)) / IPR(193 + K), K = 1, 3) IF (IPR(197) .EQ. 1) THEN WRITE (LU7, 99997) DO 40 K = 1, IAN JX1 = IEL(IEN(K)) J1 = JX1 / 100 J2 = MOD(JX1, 100) NQ1(1 : 1) = CHAR(ICHAR('A') + J1 - 1) IF ( J2 .NE. 0) THEN NQ1(2 : 2) = CHAR(ICHAR('a') + J2 - 1) ELSE NQ1(2 : 2) = ' ' ENDIF WRITE (LU7, 99996) K, NQ1(1:2) 40 CONTINUE ENDIF ENDIF CALL GEN074 (VOID, 0.0, 1, NTGRD) NJG(1, 1) = - 1 NJG(1, 2) = 25 L = 0 50 L = L + 1 JGR(L) = - MGR(L) - 1 60 JGR(L) = JGR(L) + 1 IF (JGR(L) .GT. MGR(L)) THEN L = L - 1 IF (L .EQ. 0) GOTO 90 GOTO 60 ENDIF IF (L .LT. 3) GOTO 50 IF (ABS(JGR(1)) .LT. 2 .AND. ABS(JGR(2)) .LT. 2 .AND. 1 ABS(JGR(3)) .LT. 2) THEN IF (ABS(JGR(1)) + ABS(JGR(2)) + ABS(JGR(3)) .EQ. 0) GOTO 60 NJG(1, 1) = NJG(1, 1) + 1 INDX = NJG(1, 1) ELSE DO 70 K = 1, 3 V6(IPR(184 + K)) = PAR(80 + K) * JGR(K) 70 CONTINUE IF (SQRT(GEN006(V6, AA, V6)) .GT. PAR(84)) GOTO 60 NJG(1, 2) = NJG(1, 2) + 1 INDX = NJG(1, 2) ENDIF INDX3 = INDX * 3 IF (INDX3 + 3 .GT. 2 * NP23) THEN WRITE (LU6, 99979) GOTO 460 ENDIF DO 80 K = 1, 3 JNSC(INDX3 + K) = JGR(K) 80 CONTINUE GOTO 60 90 NJGR = NJG(1, 2) DO 130 N = 2, 4 NJG(N, 1) = NJG(N - 1, 2) - 1 NJG(N, 2) = NJG(N - 1, 2) + 8 DO 120 I = 1, NJGR I1 = JNSC(I * 3 - 2) I2 = JNSC(I * 3 - 1) I3 = JNSC(I * 3) IF (ABS(I1) .LT. 2 .AND. ABS(I2) .LT. 2 .AND. 1 ABS(I3) .LT. 2) THEN IF (JNSC(I * 3 - 4 + N) .EQ. 1) THEN NJG(N, 1) = NJG(N, 1) + 1 INDX = NJG(N, 1) ELSE GOTO 120 ENDIF ELSE J3 = 0 I1N = I1 + I123(N, 1) I2N = I2 + I123(N, 2) I3N = I3 + I123(N, 3) DO 100 J = 1, NJGR IF (ABS(JNSC(J3 + 1) - I1N) + 1 ABS(JNSC(J3 + 2) - I2N) + 2 ABS(JNSC(J3 + 3) - I3N) .EQ. 0) GOTO 120 J3 = J3 + 3 100 CONTINUE NJG(N, 2) = NJG(N, 2) + 1 INDX = NJG(N, 2) ENDIF INDX3 = INDX * 3 IF (INDX3 + 3 .GT. 2 * NP23) THEN WRITE (LU6, 99979) GOTO 460 ENDIF DO 110 K = 1, 3 JNSC(INDX3 + K) = JNSC(I * 3 - 3 + K) 110 CONTINUE 120 CONTINUE 130 CONTINUE NHV = 0 IVOIDX = -1 140 IVOIDX = IVOIDX + 1 IF (IVOIDX .EQ. N1) THEN IF (IPR(189) .EQ. 1) THEN IF (IPR(43) .EQ. 0) THEN PERC = 100.0 * (1 - IPR(190) / FLOAT(NTGRD)) WRITE (PRBUF, 99992) IPR(198), PERC ELSE WRITE (PRBUF, 99976) ENDIF IF (IWIN .EQ. 1) THEN VRT = VRT - 0.8 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF WRITE (LU6, 99993) PRBUF(1:80) IF (IGBL(63) .GT. 1) THEN CALL PLA269 (5) WRITE (LU7, 99993) PRBUF(1:80) WRITE (LU7, 99985) ENDIF ENDIF NGPV(1) = -1000 NGPV(2) = -1000 NGPV(3) = -1000 ISLA = ISAR IPR(530) = 0 DO 270 N = 1, NTGRD IF (NINT(VOID(N)) .EQ. NGRTR) THEN NGRD = N IF (IPR(189) .EQ. 2) THEN NGB = NTGRD NGE = NTGRD ISLA = ISLA + 1 IPR(530) = IPR(530) + 1 IF (ISLA .GT. NP1 - IPR(75)) THEN IF (IGBL(3) .NE. 1) IPR(2) = 25 GOTO 460 ENDIF IF (ISLA - ISAR .GT. 26) THEN IF (ISLA - ISAR .GT. NP41) THEN WRITE (LU6, '(''Too Many Voids'')') WRITE (LU20, 99973) '_604', 1, 1 GOTO 460 ENDIF CSLA = ICHAR('Z') ELSE CSLA = ICHAR('A') + IPR(530) - 1 ENDIF IATC(ISLA) = 0 JATC(ISLA) = 0 DO 150 K = 1, 3 XXO(ISLA, K) = 0.0 NXYZ0(K) = 0 150 CONTINUE DO 160 K = 1, 9 SXYZ(K, IPR(530)) = 0.0 160 CONTINUE VOID(NGRD) = CSLA ENDIF 170 NGRD0 = NGRD - 1 IGR(1) = NGRD0 / N23 IGR(3) = NGRD0 - IGR(1) * N23 IGR(2) = IGR(3) / N3 IGR(3) = IGR(3) - IGR(2) * N3 CALL PLA126 (ISLA, NXYZ0, IGR, 2) DO 180 L = 1, 3 NGNX(L) = NXYZ0(L) + IGR(L) 180 CONTINUE NJI = 1 IF (NGPV(3) + 1 .EQ. NGNX(3)) THEN IF (NGPV(2) .EQ. NGNX(2)) THEN IF (NGPV(1) .EQ. NGNX(1)) NJI = 4 ENDIF ELSE IF (NGPV(2) + 1 .EQ. NGNX(2)) THEN IF (NGPV(1) .EQ. NGNX(1)) THEN IF (NGPV(3) .EQ. NGNX(3)) NJI = 3 ENDIF ELSE IF (NGPV(1) + 1 .EQ. NGNX(1)) THEN IF (NGPV(2) .EQ. NGNX(2)) THEN IF (NGPV(3) .EQ. NGNX(3)) NJI = 2 ENDIF ENDIF IF (NJI .EQ. 1) THEN NJ3 = - 3 NJB = 1 NJE = NJGR ELSE NJ3 = NJG(NJI - 1, 2) * 3 - 3 NJB = NJG(NJI - 1, 2) + 1 NJE = NJG(NJI , 2) ENDIF DO 190 L = 1, 3 NGPV(L) = NGNX(L) 190 CONTINUE DO 250 NJ = NJB, NJE NJ3 = NJ3 + 3 M = 1 DO 220 L = 1, 3 I193L = IPR(193 + L) NXYZ(L) = NXYZ0(L) IJGRL = IGR(L) + JNSC(NJ3 + L) 200 IF (IJGRL .LT. 0) THEN IJGRL = IJGRL + I193L NXYZ(L) = NXYZ(L) - I193L GOTO 200 ELSE 210 IF (IJGRL .GE. I193L) THEN IJGRL = IJGRL - I193L NXYZ(L) = NXYZ(L) + I193L GOTO 210 ENDIF ENDIF M = M + IJGRL * KGR(L) IJGR(L) = IJGRL 220 CONTINUE IVOIDM = NINT(VOID(M)) IF (IVOIDM .LT. NGRTR) THEN IF (IVOIDM .NE. NDOT) THEN IF (IPR(189) .EQ. 1) THEN VOID(M) = NDOT ELSE VOID(M) = CSLA ENDIF CALL PLA126 (ISLA, NXYZ, IJGR, 1) ENDIF ELSE IF (IVOIDM .EQ. NGRTR) THEN IF (IPR(189) .EQ. 2) THEN IF (NGE + 2 .GT. NPVD) THEN IF (NGB .GT. NTGRD) THEN I = NTGRD J = NGB 230 I = I + 2 VOID(I - 1) = VOID(J + 1) VOID(I) = VOID(J + 2) J = J + 2 IF (J .LT. NGE) GOTO 230 NGB = NTGRD NGE = I ENDIF IPR(214) = IPR(214) - 1 GOTO 10 ENDIF NGE = NGE + 2 NXYZP = 555 NXYZM = 100 DO 240 I = 1, 3 NXYZP = NXYZP 1 + NXYZ(I) * NXYZM / IPR(193 + I) NXYZM = NXYZM / 10 240 CONTINUE VOID(NGE - 1) = NXYZP VOID(NGE) = M VOID(M) = CSLA ENDIF ENDIF 250 CONTINUE IF (IPR(189) .EQ. 2) THEN IF (NGE .GT. NGB) THEN NGB = NGB + 2 NXYZP = NINT(VOID(NGB - 1)) NXYZM = 100 DO 260 I = 1, 3 NXYZI = NXYZP / NXYZM NXYZ0(I) = (NXYZI - 5) * IPR(193 + I) NXYZP = NXYZP - NXYZI * NXYZM NXYZM = NXYZM / 10 260 CONTINUE NGRD = NINT(VOID(NGB)) GOTO 170 ENDIF ENDIF ENDIF 270 CONTINUE J1 = -1 280 J1 = J1 + 1 IF (J1 .EQ. IPR(194)) GOTO 300 IF (IPR(197) .EQ. 1 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (-2) WRITE (LU7, 99998) CHAR(IPR(185) + ICHAR('W')), J1, 1 IPR(194) - 1, CHAR(IPR(186) + ICHAR('W')), 2 CHAR(IPR(187) + ICHAR('W')) ENDIF J2 = -1 290 J2 = J2 + 1 IF (J2 .EQ. IPR(195)) GOTO 280 KK0 = J1 * N23 + J2 * N3 KKM = KK0 + N3 KK0 = KK0 + 1 IF (IPR(197) .EQ. 1 .AND. IGBL(63) .GT. 2) THEN CALL PLA269 (1) WRITE (LU7, 99995) (CHAR(NINT(VOID(KK))), KK = KK0, KKM) ENDIF GOTO 290 300 PAR(79) = PAR(98) / NTGRD PAR(150) = IPR(188) * PAR(79) IF (IWIN .EQ. 1) THEN WRITE (PRBUF, 99990) PAR(84), IPR(198) CALL GGIP20 (0.0, PRBUF, 68, 0.35, 0, 2, 0.5, 5.0) CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 0, 2, 21.0, 5.0) CALL GGIP20 (0.0, 'WorkinG', 7, 3.0, 0, 10, 5.0, 8.0) CALL GGIP20 (0.0, 'Collect S.A.R.', 14, 0.35, 0, 2, 11.0, 1 3.0) IF (IPR(483) .GT. 0 .AND. IPR(484) .EQ. 0) THEN WRITE (PRBUF, 99968) CALL GGIP20 (0.0, PRBUF, 60, 0.5, 0, 2, 3.0, 1.0) ENDIF CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF IF (PAR(150) .GT. 0.0) THEN IF (IGBL(63) .GT. 1) THEN IF (IPR(197) .EQ. 1) CALL PLA269 (0) CALL PLA269 (3) PCT = PAR(150) * 100.0 / PAR(98) WRITE (LU6, 99994) PAR(150), PAR(98), PCT WRITE (LU7, 99994) PAR(150), PAR(98), PCT IF (IPR(189) .EQ. 2) THEN WRITE (LU6, 99981) CALL PLA269 (6) WRITE (LU7, 99981) IF (IPR(210) .NE. 1) THEN CALL PLA269 (4) WRITE (LU7, 99980) WRITE (LU6, 99980) ENDIF WRITE (PRBUF, 99984) WRITE (LU6, 99970) PRBUF(1:80) CALL PLA269 (3) WRITE (LU7, 99970) PRBUF(1:80) IF (IWIN .EQ. 1) THEN IF (ISLA - ISAR .GT. 15) 1 PRBUF(55:) = ' Sqrt(Eigenvalues) (Ang.)' VRT = VRT - 0.8 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 1 2, 1.0, VRT) VRT = VRT - 0.2 ENDIF ENDIF ENDIF DO 340 K = ISAR + 1, ISLA KISAR = K - ISAR APERC = JATC(K) * 100.0 / NTGRD AVOL = APERC * PAR(98) / 100.0 PAR(289) = MAX (PAR(289), AVOL) DO 310 L = 1, 3 XXO(K, L) = XXO(K, L) / JATC(K) SXYZ(9 + L, KISAR) = XXO(K, L) 310 CONTINUE DUMW(1, 1) = SXYZ(4, KISAR) - SXYZ(1, KISAR)**2 / JATC(K) DUMW(1, 2) = SXYZ(7, KISAR) 1 - SXYZ(1, KISAR) * SXYZ(2, KISAR) / JATC(K) DUMW(1, 3) = SXYZ(8, KISAR) 1 - SXYZ(1, KISAR) * SXYZ(3, KISAR) / JATC(K) DUMW(2, 2) = SXYZ(5, KISAR) 1 - SXYZ(2, KISAR)**2 / JATC(K) DUMW(2, 3) = SXYZ(9, KISAR) 1 - SXYZ(2, KISAR) * SXYZ(3, KISAR) / JATC(K) DUMW(3, 3) = SXYZ(6, KISAR) 1 - SXYZ(3, KISAR)**2 / JATC(K) CALL GEN024 (DUMW, EV, EW, DUMV) CALL GEN004 (ROR, DUMV, DUMW) DO 330 I = 1, 3 VMAX = 0.0 DO 320 J = 1, 3 VMAX = MAX (VMAX, ABS(DUMW(J, I))) 320 CONTINUE OHASHI = IATC(K) * AVOL / JATC(K) IATCK = MIN (999999, IATC(K)) OHASH = MIN (9999.9, OHASHI) WRITE (PRBUF, 99987) K - ISAR, JATC(K), IATCK, 1 NINT(APERC), NINT(AVOL), OHASH, 2 (XXO(K, L), L = 1, 3), I, (DUMW(J, I) / VMAX, J = 1, 3), 3 SQRT(EW(I) / JATC(K)) IF (I .NE. 1) CALL GEN038 (PRBUF, 1, 53) WRITE (LU6, 99972) PRBUF(1:80) IF (IGBL(63) .GT. 1) THEN CALL PLA269 (1) WRITE (LU7, 99972) PRBUF(1:80) ENDIF IF (IWIN .EQ. 1) THEN IF (ISLA - ISAR .GT. 15) THEN IF (I .EQ. 3) THEN WRITE (PRBUF, 99967) K - ISAR, JATC(K), IATCK, 1 NINT(APERC), NINT(AVOL), OHASH, 2 (XXO(K, L), L = 1, 3), (SQRT(EW(L) / JATC(K)), L = 1, 3) VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF ELSE VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT) ENDIF ENDIF 330 CONTINUE 340 CONTINUE N1 = ISAR + 1 RHODUM = 0.0 CALL PLA138 (2, 4.5, N1, ISLA, RHODUM, IDUM) ELSE WRITE (PRBUF, 99988) IF (IWIN .EQ. 1) THEN VRT = VRT - 5.0 CALL GGIP20 (0.0, PRBUF, 60, 0.45, 3, 2, 1.0, VRT) ENDIF WRITE (LU6, 99971) PRBUF IF (IGBL(63) .GT. 1) WRITE (LU7, 99971) PRBUF IPR(210) = 0 ENDIF IF (IPR(200) .EQ. 2) THEN WRITE (LU6, 99978) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (3) WRITE (LU7, 99978) ENDIF WRITE (LU20, 99973) '_601', PAR(289), PAR(289) IF (PAR(289) .GT. 20.0) THEN CALL PLA015 (0, 4) ELSE CALL PLA015 (0, 3) ENDIF ENDIF GOTO 470 ENDIF IF (IVOIDX + 1 .EQ. N1) THEN IF (IPR(198) .GT. 0) THEN IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. 1 IPR(121) .EQ. 0 .AND. IGBL(3) .NE. 5) THEN CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 0, 2, 21.0, 5.0) WRITE (PRBUF, 99990) PAR(84), IPR(198) CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 1, 2, 21.0, 5.0) WRITE (LU6, 99972) PRBUF(1:80) CALL GGIP20 (0.0, 'Collect S.A.R.', 14, 0.35, 3, 2, 11.0, 1 3.0) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF ENDIF ENDIF XXO(IAT, IPR(185)) = IVOIDX * PAR(81) IVOIDY = -1 350 IVOIDY = IVOIDY + 1 IF (IVOIDY .GE. N2) GOTO 140 XXO(IAT, IPR(186)) = IVOIDY * PAR(82) IVOIDZ = -1 360 IVOIDZ = IVOIDZ + 1 IF (IVOIDZ .GE. N3) GOTO 350 XXO(IAT, IPR(187)) = IVOIDZ * PAR(83) NHV = NHV + 1 IF (NINT(VOID(NHV)) .NE. 0) GOTO 360 DO 380 IO = 1, 3 JO = 4 - IO KO = JO + 3 XXO(IAT, KO) = 0.0 DO 370 LO = JO, 3 XXO(IAT, KO) = XXO(IAT, KO) + XXO(IAT, LO) * OR(JO, LO) 370 CONTINUE 380 CONTINUE IPR(199) = 0 CALL PLA070 (IAT, KAT) IF (IPR(2) .NE. 0) THEN IF (IGBL(3) .EQ. 1) IPR(2) = 0 GOTO 470 ENDIF IF (IPR(199) .LT. 0) THEN IPR(190) = IPR(190) + 1 VOID(NHV) = ICHAR(' ') ELSE IF (IPR(199) .EQ. 0) THEN DO 400 JS = 1, NSYM DO 390 I9 = 1, 3 XJX(I9 + 3) = 0.0 XJX(I9) = XXO(IAT, I9) 390 CONTINUE CALL SGSM (ICL, JS, XJX, LU6, 3, IERR) IVDX = MOD(NINT(XJX(6 + IPR(185)) / PAR(81)) + N1, N1) IVDY = MOD(NINT(XJX(6 + IPR(186)) / PAR(82)) + N2, N2) IVDZ = MOD(NINT(XJX(6 + IPR(187)) / PAR(83)) + N3, N3) NHVL = IVDX * N23 + IVDY * N3 + IVDZ + 1 IF (NINT(VOID(NHVL)) .EQ. 0) THEN IPR(190) = IPR(190) + 1 IPR(198) = IPR(198) + 1 IF (IPR(198) .EQ. 1) WRITE (LU6, 99991) IF (MOD(IPR(198), 1000) .EQ. 0) THEN IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. 1 IGBL(3) .NE. 5 .AND. IPR(121) .EQ. 0) THEN CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 0, 2, 21.0, 1 5.0) WRITE (PRBUF, 99990) PAR(84), IPR(198) CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 1, 2, 21.0, 1 5.0) CALL GGIP (0.0, 0.0, 0.0, 6) ELSE IF (IPR(198) .GT. IPR(491) * NSYM) THEN IF (IGBL(3) .EQ. 1) THEN WRITE (LU20, 99973) '_602', 1.0, 1.0 GOTO 460 ENDIF ENDIF ENDIF ENDIF VOID(NHVL) = ICHAR('>') ENDIF 400 CONTINUE ELSE CRIT = PAR(23) - PAR(20) CRIT2 = CRIT**2 LSKX = INT(CRIT / (PAR(81) * PAR(100 + IPR(185)))) + 1 LSKY = INT(CRIT / (PAR(82) * PAR(100 + IPR(186)))) + 1 LSKZ = INT(CRIT / (PAR(83) * PAR(100 + IPR(187)))) + 1 IVD = IPR(59) + 1 IF (IVD .LT. 10) THEN ICHR = ICHAR('0') + IVD ELSE ICHR = ICHAR('*') ENDIF DO 450 JS = 1, NSYM DO 410 I = 1, 3 XJX(I + 3) = 0.0 XJX(I) = XXO(KAT, I) 410 CONTINUE CALL SGSM (ICL, JS, XJX, LU6, 3, IERR) XXOM5 = XJX(6 + IPR(185)) XXOM6 = XJX(6 + IPR(186)) XXOM7 = XJX(6 + IPR(187)) LVKX = NINT (XXOM5 / PAR(81)) LVKY = NINT (XXOM6 / PAR(82)) LVKZ = NINT (XXOM7 / PAR(83)) LXMIN = MAX (LVKX - LSKX, IVOIDX) LYMIN = MAX (LVKY - LSKY, 0) LZMIN = MAX (LVKZ - LSKZ, 0) LXMAX = MIN (LVKX + LSKX, N1 - 1) LYMAX = MIN (LVKY + LSKY, N2 - 1) LZMAX = MIN (LVKZ + LSKZ, N3 - 1) LVOIDX = LXMIN - 1 420 LVOIDX = LVOIDX + 1 IF (LVOIDX .GT. LXMAX) GOTO 450 XJX(IPR(185)) = LVOIDX * PAR(81) - XXOM5 LVOIDY = LYMIN - 1 430 LVOIDY = LVOIDY + 1 IF (LVOIDY .GT. LYMAX) GOTO 420 XJX(IPR(186)) = LVOIDY * PAR(82) - XXOM6 NHVL = LVOIDX * N23 + LVOIDY * N3 + LZMIN LVOIDZ = LZMIN - 1 440 LVOIDZ = LVOIDZ + 1 IF (LVOIDZ .GT. LZMAX) GOTO 430 NHVL = NHVL + 1 IF (NINT(VOID(NHVL)) .NE. 0) GOTO 440 XJX(IPR(187)) = LVOIDZ * PAR(83) - XXOM7 IF ((O11 * XJX(1) + O12 * XJX(2) + O13 * XJX(3))**2 1 + (O22 * XJX(2) + O23 * XJX(3))**2 2 + (O33 * XJX(3))**2 .LT. CRIT2) VOID(NHVL) = ICHR GOTO 440 450 CONTINUE IPR(199) = 0 ENDIF GOTO 360 460 IPR(210) = 0 470 IF (IPR(188) .GT. 0) THEN IF (IPR(326) .EQ. 2) THEN IF (IWIN .EQ. 1) CALL PLA127 ELSE IF (IPR(326) .EQ. 3) THEN IPR(580) = 2 C * GENERATE F3D STYLE INPUT FOR SOLV-MAP OPEN (UNIT = LU65, FILE = NAME(1)(1:KNM(1))//'.slv', 1 STATUS = 'UNKNOWN') WRITE (LU65, 99966) JID(1:50), 1 ((OR(I, J), J = 1, 3), I = 1, 3), 2 (PAR(I), I = 101, 106), (IPR(I), I = 395, 397) NX = IPR(395) NY = IPR(396) NZ = IPR(397) MXYZ = NX * NY * NZ NXY = NX * NY CALL GEN074 (VOID, 0.0, 1, MXYZ) REWIND LU15 480 READ (LU15, END = 490) IX, IY, IZ IF (IX .LT. 0) IX = IX + NX IF (IY .LT. 0) IY = IY + NY IF (IZ .LT. 0) IZ = IZ + NZ IF (IX .GE. NX) IX = IX - NX IF (IY .GE. NY) IY = IY - NY IF (IZ .GE. NZ) IZ = IZ - NZ VOID (IZ * NXY + IY * NX + IX + 1) = 1.0 GOTO 480 490 DO 510 K = 1, NZ M = (K - 1) * NXY WRITE (LU65, 99965) K - 1 DO 500 J = 1, NY N = M + (J - 1) * NX WRITE (LU65, 99964) (NINT(VOID(N + I)), I = 1, NX) 500 CONTINUE 510 CONTINUE WRITE (LU65, 99963) IPR(39) DO 520 I = 1, IPR(39) CALL GEN048 (-4, IFG(I), 15, IVAL) NQ1 = LMT(IVAL + 1, 1) CALL GEN020 (1, NQ1, 2, 2) N = 0 IF (NQ1(1:1) .EQ. ' ') N = 1 WRITE (LU65, 99962) NQ1(1+N:4+N), (XXO(I, J), J = 1, 3) 520 CONTINUE CLOSE (LU65) C * F3D PLPATH = ' ' NE = FINDEXE ('F3DEXE', PLPATH, 'f3d') IF (NE .GT. 0) THEN PLPATH(NE + 1:) = ' '//NAME(1)(1:KNM(1))//'.slv &' CALL SYSTEM (PLPATH) ENDIF IPR(580) = -2 IPR(2) = -1 ENDIF ENDIF IGBL(23) = 10 RETURN 99999 FORMAT ('Search for and Analysis of Solvent Accessible Voids', 1 ' in the Structure - Grid =', F5.2, 2 'Angstrom, Probe Radius =', F6.2, ' Angstrom.') 99998 FORMAT (A, '-Section : ', I5, ' - (Max =', I5, ') --- ', 1 A, '-Vertical and ', A, '-Horizontal', /) 99997 FORMAT (//, 'SOLV-Map Gridpoint Entries: ', //, 1 '- Numerical : Atom Type Number', /, 2 '- ''*'' : Atom Type Number > 9', /, 3 '- Alphabetic : Independent Solvent Accessible Void', 4 /) 99996 FORMAT (/, 'Atom Type Number ', I3, ' = Label ', A) 99995 FORMAT (130A) 99994 FORMAT (':: Total Potential Solvent Area Vol', F9.1, ' Ang^3', /, 1 18X, 'per Unit Cell Vol', F9.1, ' Ang^3 [',F4.1,'%]', /) 99993 FORMAT (/, A, /) 99992 FORMAT (':: Nr of VOID Grid-points =', I8, 1 ', - Percent Filled Space:', F5.1) 99991 FORMAT (':: Note: VOID/SOLV/SQUEEZE is relatively', 1 ' compute intense and experimental', /) 99990 FORMAT (':: Nr of gridpoints at least', F5.2, ' Ang.', 1 ' from nearest vdWaals Surface=', I8) 99989 FORMAT (3(/, ':: Grid: ', A, '-Axis Step =', F7.4, 1 ' = Points', I4, ', Angstrom Step =', F5.2), //) 99988 FORMAT (':: Unit cell Contains NO Residual Solvent', 1 ' Accessible Void.') 99987 FORMAT (I2, I7, '[', I6, ']', I3, I6, '[', F6.1, ']', 1X, 3F6.3, 1 I2, 1X, 3F6.3, F6.2) 99986 FORMAT (':: VOID/SOLV Gridstep (Angstrom) (re)set to', F5.2, 1 ', Percent Memory =', F5.1) 99985 FORMAT ('(See A.I. Kitajgorodskij, Molecular Crystals and', 1 ' Molecules, New-York, Academic Press, 1973.)', /) 99984 FORMAT ('Area #GridPoint VolPerc. Vol(A^3)', 2X, 1 'X(av) Y(av) Z(av) Eigenvector(frac) Sig(Ang)') 99981 FORMAT ('Note: Expected volumes for solvent molecules are:', 1 /, 6X, 'A hydrogen bonded H2O-molecule 40 Ang^3', 2 /, 6X, 'Small molecules (e.g. Toluene) 100-300 Ang^3', 3 //, 6X, 'Values below for gridpoints and volumes in [] ' 4 /, 6X, 'refer to areas where atom centers may reside.') 99980 FORMAT (/, ':: Use the CALC SQUEEZE instruction to calculate ' 1 , 'and optionally correct for', /, 2 ':: Density identified in solvent accessible areas', 3 ' (Reflection data required)') 99979 FORMAT (/, ':: Internal Problem: Request Aborted') 99978 FORMAT (' :: Note: use CALC VOID (not CALC SOLV) for', 1 ' Packing Index. ', /) 99976 FORMAT ('No Packing Index - Disordered Structure') 99975 FORMAT ('van der Waals (or ion) Radii used in the Analysis', 1 /, 80('='), /, 16(3X, A)) 99974 FORMAT (80('-'), /, 16F5.2) 99973 FORMAT (A, 2F10.0) 99972 FORMAT (A) 99971 FORMAT (/, A, /) 99970 FORMAT (/, A, /, 80('-')) 99969 FORMAT (A, /, 132('='), /) 99968 FORMAT ('Warning: No Hydrogen Atoms in VOID/SQUEEZE Model') 99967 FORMAT (I2, I7, '[', I6, ']', I3, I6, '[', F6.1, ']', 1X, 3F6.3, 1 3F8.3) 99966 FORMAT ('TITL ', A, /, 'TRAN ', 3F9.4, F8.4, 2F9.4, 2F8.4, F9.4, 1 /, 'CELL ', 6F9.4, /, 'SIZE', 3I8) 99965 FORMAT ('SECTION', I8) 99964 FORMAT (250I1) 99963 FORMAT ('ATOMS', I8) 99962 FORMAT (A, 3F10.4) END SUBROUTINE PLA126 (ISLA, NXYZ, IJGR, NADD) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 DIMENSION NXYZ(3), IJGR(3), VO(3), IJGRD(3) IPR(188) = IPR(188) + 1 IF (IPR(189) .EQ. 2) THEN JATC(ISLA) = JATC(ISLA) + 1 IF (NADD .EQ. 2) IATC(ISLA) = IATC(ISLA) + 1 ISL = IPR(530) IATP(ISLA) = IATP(ISLA) + 1 DO 10 I = 1, 3 J = IPR(184 + I) V6(J) = PAR(80 + I) * (NXYZ(I) + IJGR(I)) XXO(ISLA, J) = XXO(ISLA, J) + V6(J) 10 CONTINUE VO(1) = OR(1, 1) * V6(1) + OR(1, 2) * V6(2) + OR(1, 3) * V6(3) VO(2) = OR(2, 2) * V6(2) + OR(2, 3) * V6(3) VO(3) = OR(3, 3) * V6(3) SXYZ(1, ISL) = SXYZ(1, ISL) + VO(1) SXYZ(2, ISL) = SXYZ(2, ISL) + VO(2) SXYZ(3, ISL) = SXYZ(3, ISL) + VO(3) SXYZ(4, ISL) = SXYZ(4, ISL) + VO(1)**2 SXYZ(5, ISL) = SXYZ(5, ISL) + VO(2)**2 SXYZ(6, ISL) = SXYZ(6, ISL) + VO(3)**2 SXYZ(7, ISL) = SXYZ(7, ISL) + VO(1) * VO(2) SXYZ(8, ISL) = SXYZ(8, ISL) + VO(1) * VO(3) SXYZ(9, ISL) = SXYZ(9, ISL) + VO(2) * VO(3) IF (IPR(326) .GT. 0) THEN DO 20 I = 1, 3 IF (IPR(326) .EQ. 1) THEN IJG = MOD(NXYZ(I) + IJGR(I), IPR(193 + I)) IF (IJG .LT. 0) IJG = IJG + IPR(193 + I) IJGRD(IPR(184 + I)) = IJG ELSE IJGRD(IPR(184 + I)) = NXYZ(I) + IJGR(I) ENDIF 20 CONTINUE WRITE (LU15) IJGRD, ISL, NADD ENDIF ENDIF RETURN END SUBROUTINE PLA127 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /ISCR/ NXYZ(3), NXYZ0(3), IGR(3), JGR(3), KGR(3), MGR(3), 1 IJGR(3) COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 DIMENSION IGMN(3), IGMX(3), ISH(3), IMX(3), 1 XMN(3), XMX(3) COMMON /UNITC/ IUNCL(2, 12) IPR(116) = 1 IPR(140) = 0 IPR(526) = 0 IND3 = 3 IND2 = 2 IND1 = 1 IPR(527) = 1 IPR(528) = 1 IPR(529) = 0 IPR(532) = 0 IPR(533) = 1 IPR(534) = 1 IGBL(75) = 0 NAT = IPR(39) NSYM = IPR(48) NRES = IPR(75) 10 CALL PLA013 (1, 1) IF (IGGT(1:4) .EQ. 'EXIT') LRET = 2 IF (IGGT(1:1) .EQ. 'N') LRET = 2 IF (LRET .EQ. 1) THEN GOTO 30 ELSE IF (LRET .EQ. 2) THEN GOTO 620 ELSE IF (LRET .EQ. 3) THEN GOTO 20 ELSE IF (LRET .EQ. 4) THEN GOTO 60 ENDIF 20 IPR(526) = -1 30 IF (IPR(526) .EQ. -1) THEN DUMMY = PAR(389) / GL(5) CALL GEN051 (1, RMAT, DUMMY, IPR(479)) IPR(526) = 0 ELSE IF (IPR(526) .EQ. 0) THEN CALL GEN021 (RMAT, 1) DO 40 I = 1, 3 X = - GL(27 + I) / GL(5) L = I CALL GEN051 (0, RMAT, X, L) 40 CONTINUE ELSE IF (IPR(526) .EQ. 1) THEN CALL GEN043 (2, RMAT, 90.0 / GL(5)) IND3 = 1 IND2 = 2 IND1 = 3 ELSE IF (IPR(526) .EQ. 2) THEN CALL GEN043 (1, RMAT, -90.0 / GL(5)) IND3 = 2 IND2 = 1 IND1 = 3 ELSE IF (IPR(526) .EQ. 3) THEN CALL GEN043 (1, RMAT, 0.0 / GL(5)) IND3 = 3 IND2 = 2 IND1 = 1 ELSE GOTO 50 ENDIF CALL GEN096 (RMAT, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM) GL(28) = IROTX GL(29) = IROTY GL(30) = IROTZ IPR(526) = 4 50 ANG = IPR(116) * 3.0 / GL(5) CALL GEN043 (2, ROTM1, - ANG) CALL GEN043 (2, ROTM2, ANG) 60 CALL GGIP (HORS, VERT, 0.0, 1) ISTER = IPR(533) HRS = HORS / ISTER CALL PLA117 (HORS, VERT, 0) DO 70 I = 1, 3 IGMN(I) = 999 IGMX(I) = -999 XMN(I) = 999.0 XMX(I) = -999.0 70 CONTINUE NOFF = 0 NBOND = 0 NP = 0 IF (IPR(527) .EQ. 1) THEN DO 110 I = 1, 2 V3(1) = I - 1 DO 100 J = 1, 2 V3(2) = J - 1 DO 90 K = 1, 2 V3(3) = K - 1 CALL GEN002 (1, OR, V3, V2, XLNG) VOID(NOFF + 1) = - (V3(1) * 4 + V3(2) * 2 + V3(3)) DO 80 M = 1, 3 XMN(M) = MIN (XMN(M), V2(M)) XMX(M) = MAX (XMX(M), V2(M)) VOID (NOFF + 1 + M) = V2(M) 80 CONTINUE NP = NP + 1 NOFF = NOFF + 7 90 CONTINUE 100 CONTINUE 110 CONTINUE DO 130 I = 1, 2 DO 120 J = 1, 12 JNSC(I, J) = IUNCL(I, J) 120 CONTINUE 130 CONTINUE NBOND = 12 ENDIF IF (IPR(528) .EQ. 1) THEN DO 250 K = 1, NRES IF (IPR(140) .EQ. 0 .OR. K .EQ. IPR(140)) THEN CALL GEN074 (V5, 0.0, 1, 3) N = 0 DO 160 I = 1, NAT CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .EQ. K) THEN N = N + 1 DO 150 J = 1, 3 V5(J) = V5(J) + XXO(I, J) 150 CONTINUE ENDIF 160 CONTINUE DO 170 J = 1, 3 V5(J) = V5(J) / N 170 CONTINUE IF (IPR(537) .EQ. 1) THEN NS = NSYM ELSE NS = 1 ENDIF DO 240 N = 1, NS DO 180 I = 1, 3 XJX(I + 3) = 0.0 XJX(I) = V5(I) 180 CONTINUE CALL SGSM (IDM, N, XJX, LU6, 3, IERR) DO 190 I = 1, 3 XJX(I + 3) = - (INT(XJX(6 + I) + 5.0) - 5) 190 CONTINUE DO 230 I = 1, NAT CALL GEN048 (-6, IFG(I), 9, IRESI) IF (IRESI .EQ. K) THEN DO 200 J = 1, 3 XJX(J) = XXO(I, J) 200 CONTINUE CALL SGSM (IDM, N, XJX, LU6, 3, IERR) DO 210 J = 1, 3 V2(1) = OR(1, 1) * XJX(7) + OR(1, 2) * XJX(8) 1 + OR(1, 3) * XJX(9) V2(2) = OR(2, 2) * XJX(8) + OR(2, 3) * XJX(9) V2(3) = OR(3, 3) * XJX(9) 210 CONTINUE DO 220 J = 1, 3 XMN(J) = MIN (XMN(J), V2(J)) XMX(J) = MAX (XMX(J), V2(J)) VOID (NOFF + 1 + J) = V2(J) 220 CONTINUE VOID (NOFF + 1) = I NP = NP + 1 NOFF = NOFF + 7 ENDIF 230 CONTINUE 240 CONTINUE ENDIF 250 CONTINUE NOF = IPR(527) * 8 DO 300 I = NOF + 1, NP NI = NINT (VOID(I * 7 - 6)) DO 260 K = 1, 3 V2(K) = VOID(I * 7 - 6 + K) 260 CONTINUE CALL GEN048 (-4, IFG(NI), 15, NO1) DISTI = REL(IEN(NO1 + 1)) + 0.4 DO 290 J = NOF + 1, NP NJ = NINT (VOID(J * 7 - 6)) DO 270 K = 1, 3 V3(K) = VOID(J * 7 - 6 + K) 270 CONTINUE CALL GEN048 (-4, IFG(NJ), 15, NO2) DISTMX = DISTI + REL(IEN(NO2 + 1)) DIST = 0 DO 280 K = 1, 3 DIST = DIST + (V2(K) - V3(K))**2 280 CONTINUE IF (SQRT(DIST) .LT. DISTMX) THEN IF (NBOND .LT. NP23) THEN NBOND = NBOND + 1 JNSC(1, NBOND) = I JNSC(2, NBOND) = J IF (NBOND .EQ. NP23) WRITE (LU6, 99997) NP23 ENDIF ENDIF 290 CONTINUE 300 CONTINUE ENDIF NVL = IPR(531) NF = NOFF REWIND LU15 310 READ (LU15, END = 340) IGR, NV, NADD IF (NVL .NE. 0 .AND. NV .NE. NVL) GOTO 310 IF (IPR(529) .NE. 1 .OR. NADD .EQ. 2) THEN DO 320 I = 1, 3 IF (IPR(535) .NE. 0) THEN IF (IGR(I) .LT. 0) IGR(I) = IGR(I) + IPR(394 + I) ENDIF V3(I) = FLOAT(IGR(I)) / IPR(394 + I) 320 CONTINUE V2(1) = OR(1, 1) * V3(1) + OR(1, 2) * V3(2) + OR(1, 3) * V3(3) V2(2) = OR(2, 2) * V3(2) + OR(2, 3) * V3(3) V2(3) = OR(3, 3) * V3(3) NP = NP + 1 NOFF = NOFF + 7 IF (NOFF .GT. NPVD) GOTO 630 DO 330 I = 1, 3 IGMN(I) = MIN (IGMN(I), IGR(I)) IGMX(I) = MAX (IGMX(I), IGR(I)) XMN(I) = MIN (XMN(I), V2(I)) XMX(I) = MAX (XMX(I), V2(I)) VOID(NOFF - 6 + I) = V2(I) VOID(NOFF - 3 + I) = IGR(I) 330 CONTINUE ENDIF GOTO 310 340 DO 350 I = 1, 3 ISH(I) = - IGMN(I) + 1 IMX(I) = IGMX(I) + ISH(I) + 1 V8(I) = (XMN(I) + XMX(I)) / 2.0 350 CONTINUE WRITE (LU6, 99999) WRITE (LU6, 99998) 1 (IPR(394 + I), IGMN(I), IGMX(I), ISH(I), IMX(I), I = 1, 3) CALL GEN074 (XMN, 999.0, 1, 3) CALL GEN074 (XMX, -999.0, 1, 3) DO 390 I = 1, NP N = (I - 1) * 7 DO 370 M = 1, 3 V4(M) = VOID(N + 1 + M) - V8(M) 370 CONTINUE CALL GEN002 (1, RMAT, V4, V5, XLNG) DO 380 M = 1, 3 XMN(M) = MIN (XMN(M), V5(M)) XMX(M) = MAX (XMX(M), V5(M)) VOID(N + 1 + M) = V5(M) VOID(N + 4 + M) = VOID(N + 4 + M) + ISH(M) 380 CONTINUE 390 CONTINUE SHX = HORS / ((XMX(1) - XMN(1)) * ISTER) SHY = VERT / (XMX(2) - XMN(2)) SCALE = MIN (SHX, SHY) * 0.80 DO 410 I = 1, NP N = (I - 1) * 7 + 1 DO 400 M = 1, 3 VOID (N + M) = SCALE * VOID(N + M) 400 CONTINUE 410 CONTINUE IP1 = IMX(IND1) + 1 IP2 = (IMX(IND2) + 1) * IP1 IP3 = (IMX(IND3) + 1) * IP2 IB = NOFF + 1 IE = NOFF + IP3 * 4 IF (IE .GT. NPVD) GOTO 630 CALL GEN074 (VOID, 0.0, IB, IE) NF0 = NF 430 NF0 = NF0 + 7 IF (NF0 .GT. NOFF) GOTO 450 DO 440 I = 1, 3 V2(I) = VOID (NF0 - 6 + I) IGR(I) = NINT(VOID(NF0 - 3 + I)) 440 CONTINUE IADR = (IGR(IND3) * IP2 + IGR(IND2) * IP1 + IGR(IND1)) * 4 + NOFF VOID(IADR + 1) = 99.0 VOID(IADR + 2) = V2(1) VOID(IADR + 3) = V2(2) VOID(IADR + 4) = V2(3) GOTO 430 450 DO 500 K = 1, IMX(IND3) + 1 NBK = (K - 1) * IP2 DO 490 J = 1, IMX(IND2) + 1 NBJ = (J - 1) * IP1 DO 480 I = 1, IMX(IND1) + 1 NB = (NBK + NBJ + I - 1) * 4 + 1 + NOFF N = - 1 IF (VOID(NB) .GT. 0.0) THEN MBK = (K - 1) * IP2 DO 470 J0 = 1, 3 MBJ = (J + J0 - 3) * IP1 DO 460 I0 = 1, 3 MB = (MBK + MBJ + I + I0 - 3) * 4 + 1 + NOFF IF (VOID(MB) .NE. 0.0) THEN N = N + 1 ENDIF 460 CONTINUE 470 CONTINUE VOID(NB) = N ENDIF 480 CONTINUE 490 CONTINUE 500 CONTINUE HRSH = HORS / (2.0 * ISTER) VRTH = VERT / 2.0 IF (ISTER .EQ. 1) THEN COL1 = 1.0 + IPR(116) COL2 = 3.0 ELSE COL1 = 1.0 COL2 = 1.0 ENDIF IF ((IPR(116) .EQ. 0 .OR. IPR(533) .EQ. 2) .AND. 1 IPR(346) .EQ. 1) THEN IF (IPR(529) .EQ. 1) THEN CL1 = 2 CL2 = 2 ELSE CL1 = 5 CL2 = 5 ENDIF ELSE CL1 = COL1 CL2 = COL2 ENDIF N0 = 8 IF (IPR(534) .EQ. 2) THEN N1 = 1 N3 = 3 N4 = 1 ELSE N1 = 2 N3 = 2 N4 = 0 ENDIF CALL GGIP (HRSH, VRTH, 0.0, -3) DO 570 K = 1, IMX(IND3) + 1 NBK = (K - 1) * IP2 DO 560 J = 1, IMX(IND2) + 1 NBJ = (J - 1) * IP1 DO 550 I = 1, IMX(IND1) + 1 NB = (NBK + NBJ + I - 1) * 4 + NOFF N = NINT(VOID(NB + 1)) IF (N .GT. 0) THEN IF (N .LT. N0) THEN DO 510 L = 1, 3 V2(L) = VOID(NB + 1 + L) 510 CONTINUE CALL GEN002 (1, ROTM1, V2, V4, XLNG) DO 540 J0 = N1, N3 DO 530 I0 = N1, N3 IF (ABS(J0 -2) + ABS(I0 -2) .EQ. N4) THEN MB = NB + ((J0 - 2) * IP1 + I0 - 2) * 4 M = NINT (VOID(MB + 1)) IF (M .GT. 0 .AND. M .LT. N0) THEN DO 520 L = 1, 3 V3(L) = VOID(MB + 1 + L) 520 CONTINUE CALL GEN002 (1, ROTM1, V3, V5, XLNG) CALL GGIP (0.0, CL1, 0.0, 0) CALL GGIP (V4(1), V4(2), 0.0, 3) CALL GGIP (V5(1), V5(2), 0.0, 2) IF (IPR(116) .EQ. 1) THEN CALL GEN002 (1, ROTM2, V2, V6, XLNG) CALL GEN002 (1, ROTM2, V3, V8, XLNG) CALL GGIP (0.0, CL2, 0.0, 0) IF (ISTER .EQ. 2) THEN V61 = V6(1) + HRS V81 = V8(1) + HRS ELSE V61 = V6(1) V81 = V8(1) ENDIF CALL GGIP (V61, V6(2), 0.0, 3) CALL GGIP (V81, V8(2), 0.0, 2) ENDIF ENDIF ENDIF 530 CONTINUE 540 CONTINUE ENDIF ENDIF 550 CONTINUE 560 CONTINUE 570 CONTINUE IF (NBOND .GT. 0) THEN DO 590 I = 1, NBOND DO 580 J = 1, 3 V3(J) = VOID((JNSC(1, I) - 1) * 7 + 1 + J) V4(J) = VOID((JNSC(2, I) - 1) * 7 + 1 + J) 580 CONTINUE CALL GEN002 (1, ROTM1, V3, V5, XLNG) CALL GEN002 (1, ROTM1, V4, V6, XLNG) CALL GGIP (0.0, COL1, 0.0, 0) CALL GGIP (V5(1), V5(2), 0.0, 3) CALL GGIP (V6(1), V6(2), 0.0, 2) IF (IPR(116) .EQ. 1) THEN CALL GEN002 (1, ROTM2, V3, V5, XLNG) CALL GEN002 (1, ROTM2, V4, V6, XLNG) IF (ISTER .EQ. 2) THEN V5(1) = V5(1) + HRS V6(1) = V6(1) + HRS ELSE CALL GGIP (0.0, COL2, 0.0, 0) ENDIF CALL GGIP (V5(1), V5(2), 0.0, 3) CALL GGIP (V6(1), V6(2), 0.0, 2) ENDIF 590 CONTINUE NLAB = IPR(527) * 8 + IGBL(75) * NAT IF (NLAB .GT. 0) THEN DO 610 I = 1, NLAB NQ1 = ' ' NL = NINT (VOID((I - 1) * 7 + 1)) DO 600 J = 1, 3 V2(J) = VOID((I - 1) * 7 + J + 1) 600 CONTINUE CALL GEN002 (1, ROTM1, V2, V3, XLNG) CALL GEN002 (1, ROTM2, V2, V4, XLNG) IENR = 0 IF (NL .LE. 0) THEN IF (IPR(532) .NE. 0) THEN IF (NL .EQ. 0) THEN NQ1 = 'O' ELSE IF (NL .EQ. -4) THEN NQ1 = 'a' ELSE IF (NL .EQ. -2) THEN NQ1 = 'b' ELSE IF (NL .EQ. -1) THEN NQ1 = 'c' ENDIF ENDIF ELSE CALL PLA047 (XLAB(NL), NQ1, MN, IENR, 0, IGBL(55), 0, 0) ENDIF IF (IENR .NE. 1 .OR. IPR(232) .EQ. 1) THEN CALL GGIP20 (0.0, NQ1, 5, PAR(349), NINT(COL1), 2, 1 V3(1) + 0.4, V3(2) - 0.4) IF (IPR(116) .EQ. 1) THEN IF (ISTER .EQ. 2) V4(1) = V4(1) + HRS CALL GGIP20 (0.0, NQ1, 5, PAR(349), NINT(COL2), 2, 1 V4(1) + 0.4, V4(2) - 0.4) ENDIF ENDIF 610 CONTINUE ENDIF ENDIF GOTO 10 620 RETURN 630 STOP 'STOP: VOID Array too small; raise NPVD for larger version' 99999 FORMAT (/, 'NGRID IGMN IGMX ISH IMX', /) 99998 FORMAT (5I5, /) 99997 FORMAT (/, ':: Bonds Skipped: NBOND .GE. NP23 =', I6, /) END SUBROUTINE PLA129 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256, NP23=18000,NP25=99,NP29=63,NP34=509,NP38=125,NP39=30, 3 NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 DID*9, TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /SFCLC/ NATO, NNG(3), NGRID COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /CIF/ CIFDIR CHARACTER CIFDIR(NP34)*36 DIMENSION STAT(20, 9) INTEGER HMAX COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 PAGET = 'SQUEEZE' CALL PLA269 (-2) WRITE (LU7, 99991) IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(3) .NE. 5) THEN IWIN = 1 CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.8 WRITE (BCD, '(24X, ''PLATON/SQUEEZE '')') CALL GGIP20 (0.0, BCD, 80, 0.50, 5 + IGBL(68), 2, 1.0, VRT) WRITE (BCD, 99976) VRT = VRT - 1.0 CALL GGIP20 (0.0, BCD, 80, 0.40, 5 + IGBL(68), 2, 0.1, VRT) CALL GGIP (0.0, 0.0, 0.0, 6) VRT = VRT - 0.2 ELSE IWIN = 0 ENDIF NSYM = IPR(48) NSYMH = IPR(255) ICNTR = IPR(257) ICENT = ICNTR - 1 EPS = 2.0 - ICENT IND1 = 1 IND2 = 2 IND3 = 3 CALL PLA130 (NATO, 0) IF (NATO .LT. 0) GOTO 260 IF (IGBL(15) .LT. 0) THEN IPR(2) = 43 GOTO 260 ENDIF IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) THEN IHEXL = 1 ELSE IHEXL = 0 ENDIF NREF = 0 HMAX = -999 KMAX = -999 LMAX = -999 CALL GEN108 (LU17, 0) IEND = -1 5 CALL PLA133 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI, 1 UCINT, ACALS, BCALS, ACOR, IEND) IF (IEND .EQ. 0) THEN HMAX = MAX (HMAX, IABS(IHT)) KMAX = MAX (KMAX, IABS(IKT)) IF (IHEXL .EQ. 1) THEN HMAX = MAX (KMAX, HMAX, IABS(IHT + IKT)) KMAX = HMAX ENDIF LMAX = MAX (LMAX, IABS(ILT)) NREF = NREF + 1 WRITE (LU17, 99972) IHT, IKT, ILT, MAX(0.0, XI), SIGI GOTO 5 ENDIF IF (IPR(259) .EQ. 4) THEN HMAX = MAX (HMAX, KMAX) KMAX = HMAX ELSE IF (IPR(259) .EQ. 7) THEN HMAX = MAX (HMAX, KMAX, LMAX) KMAX = HMAX LMAX = HMAX ENDIF IF (NREF .EQ. 0) THEN IPR(2) = 39 GOTO 260 ENDIF WRITE (LU6, 99999) NREF, HMAX, KMAX, LMAX CALL PLA269 (3) WRITE (LU7, 99999) NREF, HMAX, KMAX, LMAX N1 = IPR(395) N2 = IPR(396) N3 = IPR(397) N23 = N2 * N3 N123 = N1 * N23 CALL GEN074 (VOID, 0.0, 1, N123) DO 20 I = 1, 3 DO 10 J = 4, 8 NNG(I) = 2**J IF (PAR(100 + I) * 3.0 .LT. NNG(I)) GOTO 20 10 CONTINUE 20 CONTINUE IF (NNG(1) .LE. 2 * HMAX) NNG(1) = NNG(1) * 2 IF (NNG(2) .LE. 2 * KMAX) NNG(2) = NNG(2) * 2 IF (NNG(3) .LE. 2 * LMAX) NNG(3) = NNG(3) * 2 M1 = NNG(1) M2 = NNG(2) M3 = NNG(3) IPR(395) = M1 IPR(396) = M2 IPR(397) = M3 NGRID = M1 * M2 * M3 PAR(79) = PAR(98) / NGRID WRITE (LU6, 99992) (PAR(100 + I), I= 1, 3), N1, N2, N3, 1 M1, M2, M3, PAR(101) / M1, PAR(102) / M2, 2 PAR(103) / M3 CALL PLA269 (5) WRITE (LU7, 99992) (PAR(100 + I), I = 1, 3), N1, N2, N3, 1 M1, M2, M3, PAR(101) / M1, PAR(102) / M2, 2 PAR(103) / M3 CALL GEN108 (LU15, 0) 30 READ (LU15, END = 40) IX, IY, IZ, IV VOID(IX * N23 + IY * N3 + IZ + 1) = IV GOTO 30 40 CALL GEN108 (LU15, 0) DO 70 I = 1, M1 IX = I - 1 X0 = FLOAT(IX) * N1 / M1 JX0 = INT(X0) X0 = 1.0 - X0 + JX0 JX1 = MOD(JX0 + 1, N1) * N23 + 1 JX0 = JX0 * N23 + 1 DO 60 J = 1, M2 IY = J - 1 Y0 = FLOAT(IY) * N2 / M2 JY0 = INT(Y0) Y0 = 1.0 - Y0 + JY0 JY1 = MOD(JY0 + 1, N2) * N3 JY0 = JY0 * N3 DO 50 K = 1, M3 IZ = K - 1 Z0 = FLOAT(IZ) * N3 / M3 JZ0 = INT(Z0) Z0 = 1.0 - Z0 + JZ0 JZ1 = MOD(JZ0 + 1, N3) VI = 0.0 IVV = 0 IV0 = NINT(VOID(JX0 + JY0 + JZ0)) IF (IV0 .NE. 0) THEN VI = VI + X0 * Y0 * Z0 IVV = IV0 ENDIF IV1 = NINT(VOID(JX0 + JY0 + JZ1)) IF (IV1 .NE. 0) THEN VI = VI + X0 * Y0 * (1.0 - Z0) IVV = IV1 ENDIF IV2 = NINT(VOID(JX0 + JY1 + JZ0)) IF (IV2 .NE. 0) THEN VI = VI + X0 * (1.0 - Y0) * Z0 IVV = IV2 ENDIF IV3 = NINT(VOID(JX0 + JY1 + JZ1)) IF (IV3 .NE. 0) THEN VI = VI + X0 * (1.0 - Y0) * (1.0 - Z0) IVV = IV3 ENDIF IV4 = NINT(VOID(JX1 + JY0 + JZ0)) IF (IV4 .NE. 0) THEN VI = VI + (1.0 - X0) * Y0 * Z0 IVV = IV4 ENDIF IV5 = NINT(VOID(JX1 + JY0 + JZ1)) IF (IV5 .NE. 0) THEN VI = VI + (1.0 - X0) * Y0 * (1.0 - Z0) IVV = IV5 ENDIF IV6 = NINT(VOID(JX1 + JY1 + JZ0)) IF (IV6 .NE. 0) THEN VI = VI + (1.0 - X0) * (1.0 - Y0) * Z0 IVV = IV6 ENDIF IV7 = NINT(VOID(JX1 + JY1 + JZ1)) IF (IV7 .NE. 0) THEN VI = VI + (1.0 - X0) * (1.0 - Y0) * (1.0 - Z0) IVV = IV7 ENDIF IF (VI .GT. 0.5) THEN LOC = 2 * ((IZ * M2 + IY) * M1 + IX + 1) WRITE (LU15) LOC, IVV ENDIF 50 CONTINUE 60 CONTINUE 70 CONTINUE CALL PLA137 (HMAX, KMAX, LMAX, NREF, IADR, NREFA) IF (NREFA .LT. 0) GOTO 260 NLPMX = IPR(142) NLOPM = NLPMX FS000 = 0.0 FSOLD = 0.0 RFSOD = 999.0 DO 250 NLOOP = 1, NLPMX SUMFO = 0.0 SUMFC = 0.0 SMFO = 0.0 N13 = 0 IF (NLOOP .GT. 2) EPS = 1.0 DO 80 N = 1, NREFA IH = NINT(VOID(N13 + 9)) IK = NINT(VOID(N13 + 10)) IL = NINT(VOID(N13 + 11)) ST = SQRT(GEN095 (PAR(191), IH, IK, IL)) IF (ST .GT. PAR(290)) THEN FO = VOID(N13 + 1) ACAL = VOID(N13 + 3) + VOID(N13 + 12) + EPS * VOID(N13 + 5) BCAL = VOID(N13 + 4) + VOID(N13 + 13) + EPS * VOID(N13 + 6) FC = SQRT(ACAL**2 + BCAL**2) SUMFO = SUMFO + FO SUMFC = SUMFC + FC ENDIF N13 = N13 + 13 80 CONTINUE SCF = SUMFC / SUMFO WRITE (LU6, 99997) SCF, PAR(290) CALL PLA269 (3) WRITE (LU7, 99997) SCF, PAR(290) SUMFO = SUMFO * SCF SUMDL = 0.0 SMFO = 0.0 SMDL = 0.0 N13 = 0 N112 = 0 NOUTL = 0 DO 90 N = 1, NREFA FO = VOID(N13 + 1) * SCF SIGF = MAX (VOID(N13 + 2) * SCF, 0.0001) ACAL = VOID(N13 + 3) + VOID(N13 + 12) BCAL = VOID(N13 + 4) + VOID(N13 + 13) ACALS = ACAL + EPS * VOID(N13 + 5) BCALS = BCAL + EPS * VOID(N13 + 6) FCS = SQRT(ACALS**2 + BCALS**2) DELTA = ABS(FO - FCS) IF (NLOOP .EQ. 1) THEN IH = NINT(VOID(N13 + 9)) IK = NINT(VOID(N13 + 10)) IL = NINT(VOID(N13 + 11)) ENDIF IF (NLOOP .GT. 1 .AND. DELTA .GT. PAR(292) * SIGF) THEN IH = NINT(VOID(N13 + 9)) IK = NINT(VOID(N13 + 10)) IL = NINT(VOID(N13 + 11)) VOID(N13 + 7) = 0.0 VOID(N13 + 8) = 0.0 NOUTL = NOUTL + 1 IF (NOUTL .EQ. 1) THEN WRITE (LU6, 99987) PAR(292) CALL PLA269 (1) WRITE (LU7, 99987) PAR(292) ENDIF WRITE (LU6, 99986) IH, IK, IL, FO, FCS, SIGF, DELTA / SIGF CALL PLA269 (1) WRITE (LU7, 99986) IH, IK, IL, FO, FCS, SIGF, DELTA / SIGF ELSE SUMDL = SUMDL + DELTA IF (FO .GT. 4 * SIGF) THEN SMFO = SMFO + FO SMDL = SMDL + DELTA N112 = N112 + 1 ENDIF VOID(N13 + 7) = FO * ACALS / FCS - ACAL VOID(N13 + 8) = FO * BCALS / FCS - BCAL ENDIF IF (NLOOP .LT. NLOPM) THEN VOID(N13 + 5) = 0.0 VOID(N13 + 6) = 0.0 ENDIF N13 = N13 + 13 90 CONTINUE RF = SUMDL / SUMFO RFS = SMDL / SMFO WRITE (BCD, 99993) NLOOP, RF, NREFA, RFS, N112 WRITE (LU6, 99970) BCD CALL PLA269 (5) WRITE (LU7, 99970) BCD IF (IWIN .EQ. 1) THEN WRITE (BCD, 99977) NLOOP, RF, NREFA, RFS, N112, NINT(FS000) VRT = VRT - 0.7 CALL GGIP20 (0.0, BCD, 80, 0.35, 1, 2, 0.1, VRT) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF IF (NLOOP .LT. NLOPM) THEN CALL GEN108 (LU15, 0) DO 110 I = 1, 2 DO 100 J = 1, NP41 SXYZ(I, J) = 0.0 100 CONTINUE 110 CONTINUE NV = 0 IBOT = NREFA * 13 ITOP = IBOT + NGRID * 2 IF (ITOP + 3 * (M1 + 2) * (M2 + 2) .GT. IADR) THEN WRITE (LU6, 99996) 2, CHAR(IPR(223)) WRITE (LU7, 99996) 2, CHAR(IPR(223)) GOTO 260 ENDIF IF (IPR(304) .EQ. 0) THEN CALL PLA136 (VOID(1), VOID(IBOT + 1), VOID(ITOP + 1), 1 NREFA, FS000) ELSE CALL PLA136 (VOID(1), VOID(IBOT + 1), VOID(ITOP + 1), 1 NREFA, 0.000) ENDIF CALL GEN108 (LU9, 0) 120 READ (LU15, END = 130) ILOC, NVOID LOC = IBOT + ILOC DELRHO = VOID(LOC - 1) / NGRID WRITE (LU9) LOC, DELRHO SXYZ(1, NVOID) = SXYZ(1, NVOID) + 1 SXYZ(2, NVOID) = SXYZ(2, NVOID) + DELRHO NV = MAX (NV, NVOID) GOTO 120 130 FS000 = 0 WRITE (PRBUF, 99995) WRITE (LU6, 99974) PRBUF(1:80) CALL PLA269 (3) WRITE (LU7, 99974) PRBUF(1:80) DO 140 I = 1, NV YUNK = SXYZ(2, I) IF (YUNK .GT. 0.0) FS000 = FS000 + YUNK VVOL = SXYZ(1, I) * PAR(79) AVOL = VVOL / (YUNK / 8) WRITE (PRBUF, 99984) I, (SXYZ(J, I), J = 10, 12), 1 NINT (VVOL), NINT (YUNK), MAX (0.0, VVOL / YUNK), 2 MAX (0, NINT(AVOL)) WRITE (LU6, 99975) PRBUF(1:80) CALL PLA269 (1) WRITE (LU7, 99975) PRBUF(1:80) 140 CONTINUE PAR(149) = FS000 WRITE (LU6, 99994) NINT(FS000) CALL PLA269 (2) WRITE (LU7, 99994) NINT(FS000) VA = 0 DO 150 I = IBOT + 1, ITOP, 2 VA = VA + VOID(I) / NGRID VOID(I) = 0.0 VOID(I + 1) = 0.0 150 CONTINUE WRITE (LU6, 99985) NINT(VA) CALL PLA269 (2) WRITE (LU7, 99985) NINT(VA) CALL GEN108 (LU9, 0) DRHOMN = 99999.0 DRHOMX = -99999.0 160 READ (LU9, END = 170) LOC, DELRHO DRHOMN = MIN (DRHOMN, DELRHO) DRHOMX = MAX (DRHOMX, DELRHO) IF (DELRHO .GT. PAR(285)) VOID(LOC - 1) = DELRHO GOTO 160 170 DRHOMX = DRHOMX * NGRID / PAR(98) DRHOMN = DRHOMN * NGRID / PAR(98) WRITE (LU6, 99983) DRHOMN, DRHOMX, PAR(285), 1 PAR(329), PAR(330), PAR(269) CALL PLA269 (3) WRITE (LU7, 99983) DRHOMN, DRHOMX, PAR(285), 1 PAR(329), PAR(330), PAR(269) CALL GEN028 (VOID(IBOT + 1), NNG, 3, 1) IF (IPR(304) .NE. 0) THEN WRITE (LU6, 99969) VOID(IBOT + 1) WRITE (LU7, 99969) VOID(IBOT + 1) ENDIF N13 = 0 DO 180 I = 1, NREFA IH = NINT(VOID(N13 + 9)) IK = NINT(VOID(N13 + 10)) IL = NINT(VOID(N13 + 11)) IF (IH .LT. 0) IH = IH + M1 IF (IK .LT. 0) IK = IK + M2 IF (IL .LT. 0) IL = IL + M3 LOC = IBOT + 2 * ((IL * M2 + IK) * M1 + IH + 1) VOID(N13 + 5) = VOID(LOC - 1) VOID(N13 + 6) = VOID(LOC) N13 = N13 + 13 180 CONTINUE IF (ABS(ABS(FS000) - ABS(FSOLD)) .LT. PAR(250) * NSYM 1 .AND. FS000 .GT. 1.0 .AND. RFSOD - RFS .LT. 0.005) THEN NLOPM = NLOOP + 1 ELSE FSOLD = FS000 RFSOD = RFS ENDIF ELSE OPEN (LU61, FILE = NAME(1)(1:KNM(1))//'.sqf', 1 STATUS = 'UNKNOWN') WRITE (LU61, 99968) (CIFDIR(I), I = 503, 508) DO 185 I = 1, NV WRITE (LU61, 99967) I, SXYZ(10, I), SXYZ(11, I), 1 SXYZ(12, I), SXYZ(1, I) * PAR(79), SXYZ(2, I) 185 CONTINUE WRITE (LU61, 99966) CIFDIR(509) CLOSE (LU61) CALL GEN108 (LU17, 0) DO 200 I = 1, 20 DO 190 J = 1, 9 STAT(I, J) = 0.0 190 CONTINUE 200 CONTINUE I8MAX = 0 SCLI8 = 1.0 DO 220 K = 1, 2 IF (K .EQ. 2) THEN IF (I8MAX .GT. 99999000) THEN SCLI8 = FLOAT(99999000) / FLOAT (I8MAX) ENDIF ENDIF NPRT = 0 IEND = -1 210 CALL PLA133 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI, 1 DUM1, DUM2, DUM3, DUM4, IEND) IF (IEND .EQ. 1) GOTO 220 ISIGI = NINT(SCLI8 * SIGI) IHKL = ILT * MHK + IKT * MPH + IHT IF (IHKL .GT. 0) THEN ISGN = 1 ELSE ISGN = -1 IHKL = - IHKL ENDIF N = NINT(VOID(IADR + IHKL)) - 1 IF (N .GE. 0) THEN FO = SQRT(MAX(0.0, XI)) * SCF ACALM = VOID(N * 13 + 3) + VOID(N * 13 + 12) BCALM = (VOID(N * 13 + 4) + VOID(N * 13 + 13)) * ISGN ACALS = VOID(N * 13 + 5) BCALS = VOID(N * 13 + 6) * ISGN ACALT = ACALS + ACALM BCALT = BCALS + BCALM FCALT = SQRT(ACALT**2 + BCALT**2) FOA = (FO * ACALT / FCALT - ACALS) / SCF FOB = (FO * BCALT / FCALT - BCALS) / SCF IXI = NINT (SCLI8 * (FOA**2 + FOB**2)) NXI = NINT (SCLI8 * XI) IF (K .EQ. 1) THEN I8MAX = MAX (I8MAX, IXI) I8MAX = MAX (I8MAX, ISIGI) I8MAX = MAX (I8MAX, NXI) ELSE IF (IGBL(37) .NE. 0) THEN WRITE (LU17, 99979) IH, IK, IL, IXI, ISIGI, 1 (V2(I), V3(I), I = 1, 3), NXI, ACALS, BCALS, 1.0 ELSE WRITE (LU17, 99978) IH, IK, IL, IXI, ISIGI, 1 NXI, ACALS, BCALS, 1.0 ENDIF ST = SQRT(GEN095(PAR(191), IH, IK, IL)) FCS = SQRT(ACALS**2 + BCALS**2) FCM = SQRT(ACALM**2 + BCALM**2) PFCS = ATAN2(BCALS, ACALS) * GL(5) PFCM = ATAN2(BCALM, ACALM) * GL(5) PFCT = ATAN2(BCALT, ACALT) * GL(5) DEL1 = MOD(PFCM + 360.0 - PFCS, 360.0) IF (DEL1 .GT. 180.0) DEL1 = 360.0 - DEL1 DEL2 = MOD(PFCM + 360.0 - PFCT, 360.0) IF (DEL2 .GT. 180.0) DEL2 = 360.0 - DEL2 IF (SIGI .GT. 0.0) THEN DELS = ABS(FO**2 - FCALT**2) / (SCF**2 * SIGI) IF (ST .LE. PAR(286) .AND. DELS .GT. PAR(288)) THEN NPRT = NPRT + 1 IF (NPRT .EQ. 1) THEN CALL PLA269 (-2) WRITE (LU7, 99998) ENDIF CALL PLA269 (1) WRITE (LU7, 99973) IH, IK, IL, ST, FO, FCM, FCS, 1 FCALT, DELS, XI * SCF**2, SIGI * SCF**2 ENDIF ENDIF N = MAX (1, MIN (20, INT(ST * 20 + 0.5))) STAT(N, 1) = STAT(N, 1) + FCM STAT(N, 2) = STAT(N, 2) + FCS STAT(N, 3) = STAT(N, 3) + FCALT STAT(N, 4) = STAT(N, 4) + FO STAT(N, 5) = STAT(N, 5) + DEL1 STAT(N, 6) = STAT(N, 6) + DEL2 STAT(N, 7) = STAT(N, 7) + 1.0 STAT(N, 8) = STAT(N, 8) + ABS(FCM - FO) STAT(N, 9) = STAT(N, 9) + ABS(FCALT - FO) ENDIF ENDIF GOTO 210 220 CONTINUE WRITE (LU17, 99971) CALL PLA269 (0) WRITE (LU7, 99989) DO 240 I = 1, 20 IF (STAT(I, 7) .GT. 0.0) THEN IF (STAT(I, 4) .NE. 0.0) THEN STAT(I, 8) = STAT(I, 8) / STAT(I, 4) STAT(I, 9) = STAT(I, 9) / STAT(I, 4) ELSE STAT(I, 8) = 0.0 STAT(I, 9) = 0.0 ENDIF DO 230 J = 1, 6 STAT(I, J) = STAT(I, J) / STAT(I, 7) 230 CONTINUE ST = I / 20.0 WRITE (LU7, 99988) ST, (STAT(I, K), K = 1, 9) ENDIF 240 CONTINUE WRITE (LU7, 99982) IF (MAX(-PAR(329), PAR(330)) .GT. 1.0) 1 WRITE (LU7, 99981) PAR(329), PAR(330) IF (IPR(489) + IPR(490) .GT. 0) 1 WRITE (LU7, 99980) IPR(489) + IPR(490) WRITE (LU6, 99990) WRITE (LU7, 99990) GOTO 260 ENDIF 250 CONTINUE 260 IF (IWIN .EQ. 1) CALL PLA297 (0) RETURN 99999 FORMAT (/, ':: # Accepted Reflns Hmax Kmax Lmax', /, 1 '::', 12X, I6, 3X, 3I5) 99998 FORMAT (' H K L Sinth/l F(obs) F(mod) F(solv) ', 1 'F(tot) D(F^2)/S I Sig(I)', /) 99997 FORMAT (/, ':: Fo-scale =', E12.6, ' - SinT/L-Min =', F5.2, 1 ' for Fo/Fc-Scaling', /) 99996 FORMAT (/, 'F: Scratch Array Overrun Code', I2, ' (Fatal)', /, 1 ' Use larger program version i.e. larger NPVD', A, /) 99995 FORMAT ('Void X(av) Y(av) Z(av) Volume Ang^3 El-Count (e-)', 1 ' Vol/Electron Vol/Atom') 99994 FORMAT (/, 'Total (Positive) Electron Count in Voids/Cell =', I6) 99993 FORMAT (':: Cycle =', I3, ', R(F) =', F5.2, ', Nref(Hemi) =', 1 I6, ', R(F > 4SIGF) =', F5.2, ' Nref =', I6) 99992 FORMAT (/, ':: A, B, C (Angstrom) = ', 3F10.3, /, 1 ':: NX, NY, NZ (SOLV-MAP) = ', 3I10, /, 2 ':: NX, NY, NZ (FFT-MAP) = ', 3I10, /, 3 ':: Resolution (FFT-MAP) = ', 3F10.2, ' Angstrom') 99991 FORMAT ('SQUEEZE - Procedure (cf. BYPASS-procedure - ', 1 'P. van der Sluis & A.L. Spek (1990). Acta Cryst. A46, ', 2 '194-201)', /, 120('=')) 99990 FORMAT (/, 'Note on how to Proceed after SQUEEZE:', /, 80('='), / 1 '- The file .hkp now contains solvent free reflection data.', /, 2 '- Rename this file .hkp to .hkl', /, 3 '- Use this new .hkl file to continue SHELXL refinement with ', 4 'a solvent-free .ins.', /, 4 '- After L.S.-convergence, run PLATON with the new .hkl and', 5 ' .res files', /, ' with the instruction ''CALC FCF'' to ', 6 'produce a final FoFc-CIF on .hkp', /, 7 '- Rename this .hkp file to .fcf.', /, 8 '- Append the .sqf file produced by PLATON', 9 ' (detailing the SQUEEZE results)', /, * ' to the .cif produced by SHELXL', /, 80('=')) 99989 FORMAT ('SQUEEZE Statistics on the Difference Map Phasing', /, 1 80('='), //, 2 'FcMod = Average contribution to Fc from discrete model', /, 3 'FcSolv = Average contribution to Fc from solvent region', /, 4 'FcTot = Average Fc total ( = model + solvent contrib.)', /, 5 'DelMS = Average Phase difference between model and', 6 ' solvent contrib.', /, 7 'DelMT = Average Phase difference between model and', 8 ' combined contrib.', /, 9 'N = Number of reflections in Sin(Theta)/Lambda range',/, * 'R(Mod) = SIGMA(ABS(ABS(FcMod) - Fo)) / SIGMA(Fo)', /, 1 'R(Tot) = SIGMA(ABS(ABS(FcTot) - Fo)) / SIGMA(Fo)', /, 2 /, 'SinT/L ', 3 ' N R(Mod) R(Tot)', /, 80('=')) 99988 FORMAT (F4.2, 4F9.2, 2F8.2, F7.0, 2F7.3) 99987 FORMAT (':: Omitted Outliers H K L Fo Fc Sig Del/Sig', 1 ' - [Abs(Fo-Abs(Fc))>', F5.0, 'Sig]', /) 99986 FORMAT (3I5, 4F12.2) 99985 FORMAT (/, 'Total (Fo-Fc)map Electron Count in Unit Cell =', I6) 99984 FORMAT (I4, 1X, 3F6.3, 3X, I10, I9, 8X, F10.1, 4X, I5) 99983 FORMAT (/, 'VOID-Fo-Fc-Map: Rho(min) =', F10.2, 1 ', Rho(max) =', F10.2, ', RhoCutOff =', F6.2, /, 2 'PeaksCloseToAtoms: Rho(min) =', F10.2, ', Rho(max) =', 3 F10.2, ', RhoCutOff =', F6.2) 99982 FORMAT (/, 'Comments on and Analysis of the SQUEEZE run', 1 /, 80('=')) 99981 FORMAT (/, '- Significant Residual Density Excursion(s) in the', 1 /, ' Ordered part of the Structure:', 2F6.1) 99980 FORMAT (/, '- Model includes', I4, ' Isotropic Non-H-Atoms', /, 1 ' Rerun SQUEEZE with Anisotropically Refined Model') 99979 FORMAT (3I4, 2I8, 4X, 6F8.5, I8, 2F8.2, F8.4) 99978 FORMAT (3I4, 2I8, 52X, I8, 2F8.2, F8.4) 99977 FORMAT (I3, F9.3, 3X, I10, F12.3, I11, I10) 99976 FORMAT ('Cycle R(F) Nref(Hemi) R(F .gt. 4Sig Nref El/Cell') 99975 FORMAT (A) 99974 FORMAT (A, /, 80('=')) 99973 FORMAT (3I3, 6F8.2, F12.2, F10.2) 99972 FORMAT (3I4, 2F15.2) 99971 FORMAT (1X) 99970 FORMAT (/, A, /) 99969 FORMAT ('FFT-F000 = ', F10.2) 99968 FORMAT ('# SQUEEZE RESULTS (APPEND TO CIF)', /, 1 'loop_', 6(/, 2X, A)) 99967 FORMAT (I10, 3(F10.3), F10.1, F10.1) 99966 FORMAT (A, /, ';', /, ';') END SUBROUTINE PLA130 (NATO, MBRAV) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256, 2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) DIMENSION RIK(3, 3), UKL(3, 3) NAT = IPR(37) NSYMR = IPR(255) NSYMI = IPR(257) IF (MBRAV .NE. 0) THEN IBV = IPR(256) ELSE IBV = 1 ENDIF NSYML = NSYMR * NSYMI * IBV IF (NAT * NSYML .GT. NP1) THEN WRITE (LU6, 99997) NP1 NATO = -1 GOTO 200 ENDIF CALL GEN021 (UKL, 0) C * GET ATOM PARAMETERS FROM (SAVE)FILE NUEQ = 0 NPDS = 0 CALL GEN108 (LU4, 0) 10 READ (LU4, END = 90) ICT, XNQNR, (FN(K), K = 1, 8) DO 20 I = 1, NAT IF (NINT(XLAB(I)) .EQ. NINT(XNQNR)) THEN K = I IF (ICT .EQ. 1) THEN CALL GEN048 (-1, IFG(K), 30, IVAL) IF (IVAL .EQ. 1) THEN FN(4) = 0.0 CALL PLA047 (XNQNR, NQ1, MN, IENR, 1, IGBL(55), 0, 0) WRITE (LU6, 99996) NQ1 WRITE (LU7, 99996) NQ1 ENDIF DO 40 J = 1, 4 XXO(K, J) = FN(J) 40 CONTINUE CALL GEN048 (-4, IFG(K), 15, NO1) M = IEN (NO1 + 1) IF (IPR(493) .NE. 5) THEN M = (M - 1) * 15 DO 50 J = 1, 9 CON(K, J) = SFAC(M + J) 50 CONTINUE ELSE CON(K, 9) = RNSCL(M) ENDIF IF (IPR(493) .EQ. 1) THEN M = M + 14 ELSE IF (IPR(493) .EQ. 2) THEN M = M + 12 ELSE IF (IPR(493) .EQ. 3) THEN M = M + 10 ELSE M = 0 ENDIF IATP(K) = M ELSE IF (ICT .EQ. 2) THEN IF (IPR(210) .EQ. - 2) THEN DO 60 J = 1, 6 DUMA(J) = FN(J) 60 CONTINUE CALL GEN025 (UIJ, DUMA, -1) CALL PLA210 (PAR, OR, UIJ, UKL, DUMA, DUMV, XSD(K, 1)) IF (XSD(K, 1) .LT. 0.00) THEN XSD(K, 1) = 0.03 NPDS = NPDS + 1 ENDIF CALL GEN048 (1, IFG(K), 4, 0) NUEQ = NUEQ + 1 ELSE DO 70 J = 1, 6 XSD(K, J) = FN(J) 70 CONTINUE ENDIF ELSE IF (ICT .EQ. 4) THEN XSD(K, 1) = FN(1) ELSE IF (ICT .EQ. 6) THEN GOTO 90 ENDIF GOTO 10 ENDIF 20 CONTINUE GOTO 10 90 IF (IPR(210) .EQ. -3) THEN DO 95 K = 1, NAT XSD(K, 1) = PAR(247) CALL GEN048 (1, IFG(K), 4, 0) 95 CONTINUE ENDIF K = NAT IF (NSYML .GT. 1) THEN DO 160 L = 2, NSYML DO 170 I = 1, NAT CALL GEN048 (-1, IFG(I), 4, IVAL) DO 100 M = 1, 3 XJX(M) = XXO(I, M) XJX(M + 3) = 0.0 100 CONTINUE CALL SGSM (ICL, L, XJX, LU7, 3, IERR) K = K + 1 DO 110 M = 1, 3 XXO(K, M) = XJX(M + 6) 110 CONTINUE XLAB(K) = XLAB(I) XXO(K, 4) = XXO(I, 4) IFG(K) = IFG(I) JFG(K) = JFG(I) DO 120 M = 1, 9 CON(K, M) = CON(I, M) 120 CONTINUE IATP(K) = IATP(I) IF (IVAL .EQ. 1) THEN CALL SGSM (ICL, L, XJX, LU7, 6, IERR) DO 130 M = 1, 9 J0 = MOD (M - 1, 3) + 1 K0 = ((M - 1) / 3) + 1 RIK(J0, K0) = XJX(M) 130 CONTINUE CALL GEN005 (RIK, RIK) DO 140 J = 1, 6 DUMA(J) = XSD(I, J) 140 CONTINUE CALL GEN025 (UKL, DUMA, -1) CALL GEN001 (1, RIK, UKL, UIJ) CALL GEN025 (UIJ, DUMA, 1) DO 150 J = 1, 6 XSD(K, J) = DUMA(J) 150 CONTINUE ELSE XSD(K, 1) = XSD(I, 1) ENDIF 170 CONTINUE 160 CONTINUE ENDIF NATO = K IF (NUEQ .GT. 0) WRITE (LU6, 99999) NUEQ IF (NPDS .GT. 0) WRITE (LU6, 99998) NPDS 200 RETURN 99999 FORMAT (':: # Anisotropic atoms converted to isotropic =', I4) 99998 FORMAT (':: # of NPDs reset to U = 0.03 =', I4) 99997 FORMAT ('F: # of Atoms in Expanded set exceeds NP1 =', I5) 99996 FORMAT (':: ', A, ' OMITted From SF-Calculations') END SUBROUTINE PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, SNTHA) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /SFCLC/ NATO, NNG(3), NGRID APIK = GL(8) IBV = IPR(256) ACALA = 0.0 BCALA = 0.0 STLK = GEN095 (PAR(191), IH, IK, IL) SNTHA = SQRT(STLK) * PAR(17) IF (IPR(414) .LT. 4) THEN DO 20 I = 1, NATO ARG = GL(6) * (IH * XXO(I, 1) + IK * XXO(I, 2) 1 + IL * XXO(I, 3)) CARG = COS(ARG) SARG = SIN(ARG) CALL GEN048 (-1, IFG(I), 4, IVAL) IF (IVAL .EQ. 0) THEN TF = EXP(- APIK * STLK * XSD(I, 1)) ELSE TF = XSD(I, 1) * IH**2 * PAR(191) 1 + XSD(I, 2) * IK**2 * PAR(192) 2 + XSD(I, 3) * IL**2 * PAR(193) 3 + 2.0 * XSD(I, 4) * IK * IL * PAR(114) * PAR(115) 4 + 2.0 * XSD(I, 5) * IH * IL * PAR(113) * PAR(115) 5 + 2.0 * XSD(I, 6) * IH * IK * PAR(113) * PAR(114) TF = EXP(- GL(7) * TF) ENDIF FACT = XXO(I, 4) * IBV * TF FSC = CON(I, 9) IF (IPR(493) .NE. 5) THEN DO 10 J = 1, 7, 2 FSC = FSC + CON(I, J) * EXP(- CON(I, J + 1) * STLK) 10 CONTINUE ENDIF FACTR = FACT * FSC ACAL = ACAL + FACTR * CARG BCAL = BCAL + FACTR * SARG IATPI = IATP(I) IF (IATPI .NE. 0) THEN FACTD = FACT * SFAC(IATPI) FACTC = FACT * SFAC(IATPI + 1) ACALA = ACALA + FACTD * CARG - FACTC * SARG BCALA = BCALA + FACTD * SARG + FACTC * CARG ENDIF 20 CONTINUE ENDIF RETURN END SUBROUTINE PLA132 (IH, IK, IL, XI, SIGI, CALI, UCINT, 1 ACALS, BCALS, ACOR, IEND) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /PL130/ TRMX(3, 3), STHKM, ISKIP, ITSKP, IOBS, ICALC, 1 NDEC, SHXMP DIMENSION XINT(2) CHARACTER EXTEN*4, FOFC*4 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /HKL/ IH0, IK0, IL0, HMAX, KMAX, LMAX COMMON /MOLEN/ FMOL CHARACTER FMOL*19 CHARACTER XDATA*10 INTEGER HMAX CALI = 0.0 UCINT = 0.0 ACALS = 0.0 BCALS = 0.0 ACOR = 1.0 IF (IEND .EQ. -1) THEN ISKIP = 0 ITSKP = 0 PAR(166) = 0.0 SHXMP = 1.0 IF (IPR(408) .EQ. 2 .AND. PAR(168) .GT. 0) PAR(165) = PAR(168) STHKM = (SIN(PAR(165) / GL(5)) / PAR(17))**2 IF (IABS(IGBL(8)) .NE. 2) THEN DO 20 I = 1, 3 DO 10 J = 1, 3 TRMX(I, J) = TM1(I, J) 10 CONTINUE 20 CONTINUE ELSE IF (IGBL(29) .LE. 0) THEN K = 230 DO 40 I = 1, 3 DO 30 J = 1, 3 K = K + 1 TRMX(I, J) = PAR(K) 30 CONTINUE 40 CONTINUE ELSE CALL GEN021 (TRMX, 1) ENDIF ENDIF CALL GEN074 (V2, 0.0, 1, 3) CALL GEN074 (V3, 0.0, 1, 3) NDEC = 0 IF (IPR(408) .LE. 0) THEN IF (IGBL(15) .EQ. 0) THEN EXTEN = '.hkl' ELSE IF (IGBL(15) .EQ. 1) THEN EXTEN = '.fcf' ENDIF FOFC = 'FoFc' IF (IPR(132) .EQ. 0) THEN FOFC = ' OBS' ELSE IF (IPR(132) .EQ. 1) THEN FOFC = 'CALC' ELSE IF (IPR(132) .EQ. 2) THEN FOFC = 'DELT' ELSE IF (IPR(132) .EQ. 3) THEN FOFC = 'DELG' ENDIF WRITE (LU6, 99998) FNLU16(1:KNM16), FOFC, 1 ((TRMX(I, J), J = 1, 3), I = 1, 3) IF (IGBL(63) .GT. 0) THEN CALL PLA269 (4) WRITE (LU7, 99998) FNLU16(1:KNM16), FOFC, 1 ((TRMX(I, J), J = 1, 3), I = 1, 3) ENDIF CALL GEN108 (LU16, 0) IF (IGBL(29) .GT. 0) THEN IF (JID(1:1) .EQ. ' ') THEN XDATA = JID(2:11) ELSE XDATA = JID(1:10) ENDIF I = INDEX (XDATA, ' ') IF (I .GT. 1) XDATA(I:10) = ' ' 50 READ (LU16, 99997, END = 60) IDM I = INDEX (IDM, 'data_') J = INDEX (IDM, CHAR(13)) IF (I .EQ. 0) GOTO 50 IF (J .EQ. 0) THEN J = I + 14 ELSE J = J - 1 ENDIF IF (I .GT. J) GOTO 60 IF (IDM(I + 5:J) .EQ. XDATA) GOTO 70 GOTO 50 60 WRITE (LU6, 99990) JID(1:10) WRITE (LU22, 99990) JID(1:10) WRITE (LU20, 99997) '_900 1 1' CALL PLA015 (0, 51) GOTO 240 ENDIF 70 IF (IGBL(29) .EQ. 1) THEN NDEC = 2 ICALC = 0 IOBS = 0 IDIF = 0 80 READ (LU16, 99997, END = 240, ERR = 240) IDM IF (PAR(101) .GT. 0.0) THEN N = INDEX (IDM, 'cell_') IF (N .NE. 0) THEN M = INDEX (IDM, '(') IF (M .NE. 0) IDM(M:) = ' ' NB = INDEX (IDM, '_cell_length_a') IF (NB .NE. 0) THEN READ (IDM(NB + 14:), *) PAR(455) DLDS = MAX (0.01, PAR(107) * 2.0) IF (ABS(PAR(455) - PAR(101)) .GT. DLDS) 1 IDIF = IDIF + 1 ELSE NB = INDEX (IDM, '_cell_length_b') IF (NB .NE. 0) THEN READ (IDM(NB + 14:), *) PAR(456) DLDS = MAX (0.01, PAR(108) * 2.0) IF (ABS(PAR(456) - PAR(102)) .GT. DLDS) 1 IDIF = IDIF + 1 ELSE NB = INDEX (IDM, '_cell_length_c') IF (NB .NE. 0) THEN READ (IDM(NB + 14:), *) PAR(457) DLDS = MAX (0.01, PAR(109) * 2.0) IF (ABS(PAR(457) - PAR(103)) .GT. DLDS) 1 IDIF = IDIF + 1 ELSE NB = INDEX (IDM, '_cell_angle_alpha') IF (NB .NE. 0) THEN READ (IDM(NB + 17:), *) PAR(458) DLDS = MAX (0.01, PAR(110) * 2.0) IF (ABS(PAR(458) - PAR(104)) .GT. DLDS) 1 IDIF = IDIF + 1 ELSE NB = INDEX (IDM, '_cell_angle_beta') IF (NB .NE. 0) THEN READ (IDM(NB + 16:), *) PAR(459) DLDS = MAX (0.01, PAR(111) * 2.0) IF (ABS(PAR(459) - PAR(105)) .GT. DLDS) 1 IDIF = IDIF + 1 ELSE NB = INDEX (IDM, '_cell_angle_gamma') IF (NB .NE. 0) THEN READ (IDM(NB + 17:), *) PAR(460) DLDS = MAX (0.01, PAR(112) * 2.0) IF (ABS(PAR(460) - PAR(106)) .GT. DLDS) 1 IDIF = IDIF + 1 IF (IDIF .GT. 0) GOTO 260 ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF GOTO 80 ENDIF ENDIF IF (INDEX (IDM, '_refln_F_squared_calc') .NE. 0) THEN IF (IOBS .EQ. 1) THEN ICALC = 2 ELSE ICALC = 1 ENDIF ENDIF IF (INDEX (IDM, '_refln_F_squared_meas') .NE. 0) THEN IF (ICALC .EQ. 1) THEN IOBS = 2 ELSE IOBS = 1 ENDIF ENDIF IF (INDEX (IDM, '_shelx_F_squared_multiplier') .NE. 0) THEN READ (IDM(28:), '(F10.0)') SHXMP ENDIF IF (INDEX (IDM, '_refln_observed_status') .NE. 0) THEN 85 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_sint/lambda') .NE. 0) GOTO 85 BACKSPACE LU16 ELSE GOTO 80 ENDIF IF (IPR(132) .EQ. 0 .AND. IOBS .EQ. 0 .OR. 1 IPR(132) .EQ. 1 .AND. ICALC .EQ. 0) GOTO 240 ELSE IF (IGBL(29) .EQ. 2) THEN 90 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_scale_group_code') .EQ. 0) GOTO 90 NDEC = 3 ELSE IF (IGBL(29) .EQ. 3) THEN 100 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_F_squared_sigma') .EQ. 0) GOTO 100 IOBS = 1 ICALC = 2 NDEC = 3 ELSE IF (IGBL(29) .EQ. 4) THEN 110 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_10*F_sigm') .EQ. 0 .AND. 1 INDEX (IDM, '_refln_F_10*sigm') .EQ. 0) GOTO 110 IOBS = 1 ICALC = 2 NDEC = 0 FMOL = '(I4,2I3,2F7.0,F6.0)' 120 READ (LU16, 99997, END = 240) IDM NB = 1 NE = 80 CALL GEN039 (1, IDM, 1, 80, NB, NE) IF (NE .EQ. 0) THEN GOTO 120 ELSE IF (NE .EQ. 31) THEN FMOL(3:3) = '5' ENDIF BACKSPACE LU16 ELSE IF (IGBL(29) .EQ. 5 .OR. IGBL(29) .EQ. 8) THEN 130 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_') .EQ. 0) GOTO 130 135 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_') .NE. 0) GOTO 135 IOBS = 1 ICALC = 2 BACKSPACE LU16 ELSE IF (IGBL(29) .EQ. 6 .OR. IGBL(29) .EQ. 10) THEN 140 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_observed_status') .EQ. 0) GOTO 140 ELSE IF (IGBL(29) .EQ. 7) THEN 150 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_observed_status') .EQ. 0) GOTO 150 IOBS = 1 ICALC = 2 FMOL = '(3I4,3F8.0)' BACKSPACE LU16 ELSE IF (IGBL(29) .EQ. 9) THEN 155 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_observed_status') .EQ. 0) GOTO 155 ELSE IF (IGBL(29) .EQ. 21) THEN 160 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_B_calc') .EQ. 0) GOTO 160 ELSE IF (IGBL(29) .EQ. 22) THEN 170 READ (LU16, 99997, END = 240) IDM IF (INDEX (IDM, '_refln_phase_calc') .EQ. 0) GOTO 170 ELSE READ (LU16, 99997, END = 240) PRBUF(1:20) CALL GEN108 (LU16, 0) NDEC = INDEX (PRBUF(13:20), '.') IF (NDEC .GT. 0) NDEC = 8 - NDEC IF (IGBL(29) .EQ. -1) THEN IF (IPR(210) .EQ. -1) WRITE (LU6, 99999) ENDIF ENDIF PAR(230) = 10**NDEC ELSE HMAX = INT(2 * PAR(101) * PAR(287)) + 1 KMAX = INT(2 * PAR(102) * PAR(287)) + 1 LMAX = INT(2 * PAR(103) * PAR(287)) + 1 IF (IPR(408) .EQ. 2) THEN IL0 = - LMAX - 1 ELSE IL0 = -1 ENDIF XI = 100 SIGI = 10 PAR(230) = 1 GOTO 180 ENDIF ENDIF GOTO 200 180 IL0 = IL0 + 1 IF (IL0 .GT. LMAX) GOTO 240 IK0 = - KMAX - 1 190 IK0 = IK0 + 1 IF (IK0 .GT. KMAX) GOTO 180 IH0 = - HMAX - 1 200 IF (IPR(408) .LE. 0) THEN GOTO 220 210 IF (INDEX(PRBUF, ' 5 sig(I))' 1 , /, 1X, 80('='), /) 99991 FORMAT (':: Deleted : IHO =', I5, ', IKO =', I5, ', ILO =', 1 I5, ' I = ', F10.2, 2X, 'SIGI =', F10.2) 99990 FORMAT (/, ':: Data Set TOO Large (Raise NPVD of array VOID)', /) 99989 FORMAT (/, ':: Actual Theta-Max:', F7.2, ' Deg.', 1 ' -- Applied Theta Limit:', F7.2, /) 99988 FORMAT (/, 1 'Number of Independent Type H, K, L Reflections =', I7) 99987 FORMAT ( 1 'Number of Independent Type -H,-K,-L Reflections =', I7) 99986 FORMAT ( 1 'Number of Independent Centrosymmetric Reflections =', I7) 99985 FORMAT ('Number of Bijvoet Pairs', 30X, '=', I7) 99984 FORMAT (/,'Total Number of Reflections Encountered on INPUT', 5X, 1 '=', I7, //, 'Number of Less-Thans of Type H, K, L', 16X, '=', 2 I7) 99983 FORMAT ('Number of Less-Thans of Type -H,-K,-L', 16X, '=', I7) 99982 FORMAT (':: Number of Deleted > TH(Max) Reflections =', I7, /, 1 ':: Number of Deleted Non-Int. Reflections =', I7, /, 2 ':: Number of Deleted Bravais Reflections =', I7, /) 99981 FORMAT (//, 'CONSISTENCY +HKL:', F11.2, ' PERCENT') 99980 FORMAT ('CONSISTENCY -HKL:', F11.2, 1 /, 'FRIEDEL CONSIST.:', F11.2) 99979 FORMAT (':: Too Many Reflections in this Zone', /, 1 'Try Again with Zones Perp to the Longest Axis', //) 99978 FORMAT (/, 'Report Expected Number of Independent Reflections', 1 ' for given Symmetry and Resolution.') 99977 FORMAT ('ZONE - ', A, ' =', I5, 63X, 1 ': + = +HKL, - = -HKL, L = ILT = 2, N = I/SIG(I)+.5 ', 2 /, 131('-'), /, 4X, A, '--->', A, /, 3X, A, /) 99976 FORMAT (20('*'), ' ZONE ', A, ' = ', I4, 1X, 24('*')) 99975 FORMAT (20('*'), ' Spacegroup Extinctions ', 16('*')) 99974 FORMAT (I4, 5X, A) 99973 FORMAT ( 12(' H K L ILT I & SIG I & SIG', 2 10X), /, 130('-')) 99972 FORMAT (A, 10X, A) 99971 FORMAT (80('='), /, 'PLATON/ASYM-(Version', I8, 1 ') FCF-File Validation for:', A, /, 80('='), /, 2 'Crystal Data From: ', A, /, 3 'Fo/Fc Data From: ', A, 1X, 'FCF-TYPE=', A, /, 4 'Space Group : ', A, /, 5 'Wavelength (Ang) : ', F10.5, /, 6 'Unit Cell (CIF) : ', 3F9.4, 3F9.3) 99970 FORMAT (/, 80('='), /, 'Resolution & Completeness Statistics', 1 9X, '(Cumulative)', /, 80('='), 2 /, 'Theta sin(th)/Lambda Complete Expected Measured Missing', 3 /, 80('-')) 99969 FORMAT (F6.2, 2F10.3, 4X, 3I9) 99968 FORMAT (/, 80('='), /, 'Summary of Reflection Data in FCF', /, 1 80('='), /, 'Total (in FCF) ..............', I7, 2X, 2 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Obs', /, 3 'Actual Theta(Max) (Deg.) .....', F7.2, 2X, 4 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Exp', /, 5 'Actual Theta(Min) (Deg.) .....', F7.2, //, 6 'Unique (Expected) ............', I7, 2X, 7 '(HKL', I6, ', -H-K-L', I6, ')', /, 8 'Unique (in FCF) ..............', I7, 2X, 9 '(HKL', I6, ', -H-K-L', I6, ')', /, * 'Observed [I .gt. 2 Sig(I)] ...', I7, 2X, 1 '(HKL', I6, ', -H-K-L', I6, ')', /, 2 'Less-Thans ...................', I7, 2X, 3 '(HKL', I6, ', -H-K-L', I6, ')', /, 4 'Missing (Total) ..............', I7, 2X, 5 '(HKL', I6, ', -H-K-L', I6, ')', //, 6 'Missing Below Th(Min) ........', I7, /, 7 'Missing Th(Min) to STh/L=', F5.3, I7, /, 8 'Missing STh/L=', F5.3, ' to Th(Max)', I7, /, 9 'Missing Very Strong Refl. ....', I7, //, * 'Space Group Extinctions ......', I7) 99967 FORMAT (/, 80('='), /, 'Reflections with Large Ratio:', 1 ' abs((I(obs) - I(calc)) / Sigma(I)) .GT. 10.0', /, 80('='), 2 /, ' Nr H K L Theta', 5X, 3 'I(obs)', 4X, 'I(calc) Sigma(I) Ratio', /, 80('-')) 99966 FORMAT (I5, 3I4, F7.2, 2F11.2, F9.2, F9.2, F8.2, F8.2) 99965 FORMAT (/, 80('='), /, 1 'R-Value Statistics as a Function of Resolution', 2 ' (in Resolution Shell)', /, 80('='), /, 3 'Theta sin(Th)/Lambda # R1 wR2 S av(I/Sigma)', 4 3X, 'av(I) av(Sigma)', /, 80('-')) 99964 FORMAT (F6.2, F10.3, I7, 3F7.3, F8.2, F12.2, F8.2) 99963 FORMAT ('Requested FCF-FILE not Found:', A) 99962 FORMAT (55X, 9('-'), /, 46X, 'Average =', F9.2) 99961 FORMAT ('Number of Bijvoet Pairs ......', I7) 99960 FORMAT (/, 'For I(calc) < 2 Sigma(I): = ', F10.2, 1 ' and = ', F10.2) 99959 FORMAT (A) 99958 FORMAT (1X) 99957 FORMAT (60('-'), ' ACTA Min. Res. ----') 99956 FORMAT (A, 2I10, A) 99955 FORMAT (A, 2F10.2) 99954 FORMAT (/, '>> No CELL DATA Found !! - Abort') 99953 FORMAT (F7.3) 99952 FORMAT ('SHELX WGHT Pars. : ', 2F9.4) 99951 FORMAT ('Extinction Par. : ', F9.4) 99950 FORMAT (/, 80('='), /, 'Reflections with Large Ratio:', 1 ' abs((I(obs) - I(calc)) / SigW(I)) .GT. 2.5 ', /, 80('='), 2 /, ' Nr H K L Theta', 5X, 3 'I(obs)', 4X, 'I(calc) Sigma(I) Ratio SigW(I) RatioW', 4 /, 80('-')) 99949 FORMAT (55X, 9('-'), 8X, 8('-'),/, 46X, 1 'Average =', F9.2, 8X, F8.2) 99948 FORMAT (/, 80('='), /, 1 'R-Value Statistics as a Function of Resolution', 2 ' (in Resolution Shell)', /, 80('='), /, 3 'Theta sin(Th)/Lambda # R1 wR2 S av(I/SigW)', 4 3X, 'av(I) av(SigW)', /, 80('-')) END SUBROUTINE PLA141 (JP, IND, LPUN, IRM) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30, NP44=512,NPY = NPVD + 2 * NP23 - 1114) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1 COMMON /CHAR0/ AR, CID, ZONE CHARACTER XAR*60, ICRD*80 COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2), 1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2), 2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252), 3 STAT(20, 10), IAR(NPY) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 CHARACTER IDSM*1 NSYMH = IPR(255) IHU = 2 * (IHKL(IND1) + IHM(IND1) + 1) + 1 - IND IF (IND .EQ. 1) THEN IDSM = '+' ELSE IDSM = '-' ENDIF IF (JP .GT. 0) THEN SA = 0.0 SB = 0.0 DO 10 K = 1, JP SY = RB(K, IND) SZ = 1.0 / (SY**2) SA = SA + RA(K, IND) * SZ SB = SB + SZ 10 CONTINUE RM = SA / SB SM0 = 1.0 / SQRT(SB) IRM = NINT(RM) ISM = NINT(SM0) SMA = 0.0 SMB = 0.0 DO 20 K = 1, JP DEL = ABS(RA(K, IND)) - ABS(RM) IF (JP .NE. 1 .AND. DEL .LE. 0.0) DEL = ABS(DEL) SMA = SMA + (DEL / RB(K, IND))**2 SMB = SMB + (RA(K, IND) / RB(K, IND))**2 20 CONTINUE SM(1, IND) = SM(1, IND) + SMA * JP SM(2, IND) = SM(2, IND) + SMB * (JP - 1) IF (IND .NE. 1) THEN DO 30 MM = 1, 3 IHKLE(MM) = - IHKL(MM) 30 CONTINUE ENDIF ILT = 1 IF (RM .LT. SIG * SM0) ILT = 2 IF (IKS(IND3) .NE. -1) THEN IDSM = '*' IF (IPR(468) .EQ. 0) THEN NDC = NINT(RM / SM0) ELSE NDC = JP ENDIF IF (NDC .LT. 10) IDSM = CHAR(ICHAR('0') + NDC) IF (ILT .EQ. 2) THEN IDSM = 'L' IPR(374 + IND) = IPR(374 + IND) + 1 ENDIF ENDIF JPA = - 1 IF (IABS(IPR(392) - 2) .EQ. 1 .OR. IKS(IND3) .EQ. -1) THEN 40 JPA = JPA + 2 IF (JPA .LE. JP) THEN JPB = JPA + 1 IF (JPB .GT. JP) JPB = JP LPAB = 0 DO 50 K = JPA, JPB LPAB = LPAB + 1 IRAB(LPAB, 1) = NINT(RA(K, IND)) IRAB(LPAB, 2) = NINT(RB(K, IND)) 50 CONTINUE IF (IPR(408) .NE. 2) THEN WRITE (XAR, 99999) (IRAB(K, 1), IRAB(K, 2), K = 1, LPAB) AR(IPL) = XAR IF (JPA .EQ. 1) WRITE (XAR, 99997) 1 (IHKLE(MM), MM = 1, 3), IRM, ISM, ILT AR(IPL)(1:30) = XAR(1:30) IPL = IPL + 1 IF (IPL .GT. 102) THEN IPL = 1 IF (IGBL(22) .NE. -1) THEN CALL PLA269 (0) WRITE (LU7, 99998) DO 60 I = 1, 51 WRITE (LU7, 99995) AR(I), AR(I + 51) 60 CONTINUE ENDIF ENDIF ENDIF GOTO 40 ENDIF ENDIF IF (IKS(IND3) .NE. -1) THEN IPR(376 + IND) = IPR(376 + IND) + 1 IF (ILT .EQ. 1) THEN IF (IND .EQ. 1) THEN IPR(383) = IPR(383) + 1 ELSE IPR(362) = IPR(362) + 1 ENDIF ENDIF IF (IPR(408) .LT. 2) THEN IF (LPUN .GT. 0) WRITE (LPUN, 99996) 1 (IHKLE(MM), MM = 1, 3), IRM, ISM IF (IPR(408) .LT. 0) THEN IF (NSYMH .GT. 1) THEN DO 70 I = 1, 3 XX(I) = IHKLE(I) IHKLS(I, 1) = IHKLE(I) 70 CONTINUE XX(4) = 0.0 N = 1 DO 100 I = 2, NSYMH CALL SGSM (ICRD, I, XX, LU7, 5, IERR) DO 80 J = 1, 3 IHKLS(J, N + 1) = NINT(XX(J + 6)) 80 CONTINUE DO 90 K = 1, N IF (IHKLS(1, K) .EQ. IHKLS(1, N + 1)) THEN IF (IHKLS(2, K) .EQ. IHKLS(2, N + 1)) THEN IF (IHKLS(3, K) .EQ. IHKLS(3, N + 1)) GOTO 100 ENDIF ENDIF IF (IHKLS(1, K) .EQ. - IHKLS(1, N + 1)) THEN IF (IHKLS(2, K) .EQ. - IHKLS(2, N + 1)) THEN IF (IHKLS(3, K) .EQ. - IHKLS(3, N + 1)) 1 GOTO 100 ENDIF ENDIF 90 CONTINUE N = N + 1 IF (LPUN .GT. 0) WRITE (LPUN, 99996) 1 (IHKLS(J, N), J = 1, 3), IRM, ISM 100 CONTINUE ENDIF ENDIF ENDIF ENDIF ENDIF IF (IHU .GT. 0 .AND. IHU .LE. NP44) THEN CID(IHU:IHU) = IDSM IF (IDSM .NE. '+' .AND. IDSM .NE. '-') THEN STHK = GEN095 (PAR(191), IHKLE(1), IHKLE(2), IHKLE(3)) IF (STHK .LT. 0.09) IPR(512) = IPR(512) - 1 ENDIF ENDIF RETURN 99999 FORMAT (28X, 2(I10, I6)) 99998 FORMAT ( 12(' H K L ILT I & SIG I & SIG', 2 10X), /, 130('-')) 99997 FORMAT (1X, 3I3, 1X, I9, I6, I2) 99996 FORMAT (3I4, 2I8) 99995 FORMAT (A, 10X, A) END SUBROUTINE PLA142 (LEV, NHEAD) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP23=18000,NP38=125,NP39=30,NP44=512, 2 NPY=NPVD+2*NP23-1114) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2), 1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2), 2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252), 3 STAT(20, 10), IAR(NPY) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1 COMMON /CHAR0/ AR, CID, ZONE CHARACTER THFL*1 SHOR = 0.0 STEP = 0.0 STPA = 0.0 STPB = 0.0 SVER = 0.0 CHOR = 0.0 SCAL = 0.0 JMAX = 0 IF (IGBL(22) .GT. 0) THEN IGBL(23) = 14 CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP (0.0, 1.0, 0.0, 0) CALL PLA117 (HORS, VERT, -1) IF (IPR(406) .EQ. 1) THEN KNMXT = KNM(3) + KXT + 1 WRITE (PRBUF, 99989) FNLU1(1:KNMXT), 1 DTYPE(IABS(IGBL(8))) CALL GGIP20 (0.0, PRBUF, KNMXT + 8, 0.3, -1, 2, 17.0, 1.0) IF (IPR(408) .LE. 0) THEN WRITE (PRBUF, 99989) FNLU16(1:KNM16), RDTYPE CALL GGIP20 (0.0, PRBUF, KNM16 + 8, 0.3, -1, 2, 17.0, 0.2) ELSE WRITE (PRBUF, 99988) CALL GGIP20 (0.0, PRBUF, 14, 0.3, -1, 2, 17.0, 0.2) ENDIF THOR = VERT + 2.5 IF (IPR(257) .EQ. 1) THEN IF (IPR(393) .EQ. 1) THEN WRITE (PRBUF, 99991) ELSE WRITE (PRBUF, 99990) ENDIF CALL GGIP20 (0.0, PRBUF, 18, 0.3, 2, 2, VERT + 1.9, 1 VERT - 0.8) ENDIF WRITE (PRBUF, 99987) 'SpaceGr ', SPGRNM(1)(1:7) CALL GGIP20 (0.0, PRBUF, 15, 0.3, 1, 2, THOR, VERT - 1.5) WRITE (PRBUF, 99996) 'a ', PAR(101) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 2.1) WRITE (PRBUF, 99996) 'b ', PAR(102) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 2.7) WRITE (PRBUF, 99996) 'c ', PAR(103) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 3.3) WRITE (PRBUF, 99996) 'alpha ', PAR(104) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 3.9) WRITE (PRBUF, 99996) 'beta ', PAR(105) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 4.5) WRITE (PRBUF, 99996) 'gamma ', PAR(106) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 5.1) WRITE (PRBUF, 99984) 'lambda ', PAR(17) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 5.7) WRITE (PRBUF, 99996) 'Th(max)', PAR(446) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 6.3) WRITE (PRBUF, 99996) 'SigOmit', SIG CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 6.9) WRITE (PRBUF, 99995) 'Total ', IPR(373) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 7.5) WRITE (PRBUF, 99995) 'Unique ', IPR(377) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 8.1) WRITE (PRBUF, 99995) 'Obsd ', IPR(383) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 8.7) ENDIF ANG1 = ACOS(PAR(115 + IND1)) ANG2 = ACOS(PAR(115 + IND2)) ANG3 = ACOS(PAR(115 + IND3)) SHOR = PAR(112 + IND1) STEP = 1.0 / PAR(100 + IND3) STPA = PAR(112 + IND3) * COS(ANG2) STPB = PAR(112 + IND3) * (COS(ANG1) - COS(ANG2) * COS(ANG3)) / 1 SIN(ANG3) SVER = PAR(112 + IND2) * SIN(ANG3) CHOR = PAR(112 + IND2) * COS(ANG3) SHFT = 0.8 SCA1 = (VERT - 1.0) / 1 (PAR(112 + IND2) * SIN (ANG3) * (IHM(IND2) * 2 + 4)) SCA2 = (VERT - SHFT) / 1 (PAR(112 + IND1) * (IHM(IND1) * 2 + 1)) SCAL = MIN (SCA1, SCA2) SVER = SVER * SCAL SHOR = SHOR * SCAL CHOR = CHOR * SCAL STEP = STEP * SCAL STPA = STPA * SCAL STPB = STPB * SCAL ENDIF CALL GEN108 (LU14, 0) 10 READ (LU14, 99997, END = 80) CID IF (CID(1:4) .NE. 'ZONE') GOTO 10 READ (CID(11:15), 99994) NL IF (NL .NE. LEV) GOTO 10 IKS(IND3) = NL IPR(382) = MAX (IPR(382), NL) WRITE (CID(16:29), 99993) IHM(IND3) IF (IGBL(22) .GE. 0) THEN HRT = SHFT VRT = VERT - 0.4 CALL GGIP20 (0.0, CID, 29, 0.2, -1, 1, HRT, VRT) ENDIF READ (LU14, 99997, END = 80) CID NS = - IHM(IND2) READ (LU14, 99997, END = 80) CID IF (IGBL(22) .GE. 0) THEN VRT = VRT - SVER CALL GGIP20 (0.0, CID(1:5), 5, 0.2, -1, 1, HRT, VRT) HRT = HRT + 1.45 + SHOR + NS * CHOR DO 20 I = 11, NP44, 2 IF (HRT .GT. (SHFT + 1.0)) THEN CALL GGIP20 (0.0, CID(I:I), 1, 0.2, -1, 1, HRT, VRT) ENDIF HRT = HRT + SHOR 20 CONTINUE ENDIF READ (LU14, 99997, END = 80) CID IF (IGBL(22) .GE. 0) THEN VRT = VRT - SVER CALL GGIP20 (0.0, CID, 15, 0.2, -1, 2, SHFT, VRT) CX = SHFT + 1.5 + 1 (IHM(IND1) + 1) * SHOR + (NS + IHM(IND2) + 1) * CHOR CY = VRT - (IHM(IND2) + 1) * SVER IF (IPR(387) .EQ. 1) THEN CXS = CX - LEV * STPA CYS = CY + LEV * STPB JMAX = NINT(SIN(PAR(446) / GL(5)) / (PAR(17) * 0.05)) DO 40 J = 10, JMAX STL = J * 0.05 IF (J .EQ. 12) THEN CALL GGIP (0.0, 2.0, 0.0, 0) ELSE CALL GGIP (0.0, 1.0, 0.0, 0) ENDIF CR = SCAL * 2.0 * STL CR = SQRT (MAX(0.0, CR**2 - (NL * STEP)**2)) CALL PLA289 (CXS, CYS, CR, 120) 40 CONTINUE ENDIF IF (IPR(388) .EQ. 1) THEN CALL GGIP (0.0, 5.0 + IGBL(68), 0.0, 0) CXV = CX + IHM(IND2) * CHOR CYV = CY - IHM(IND2) * SVER CXH = CX + IHM(IND1) * SHOR CALL GGIP (CXV, CYV, 0.0, 3) CALL GGIP (CX, CY, 0.0, 2) CALL GGIP (CXH, CY, 0.0, 2) CALL GGIP (CX, CY, 0.0, 3) CALL GGIP (0.0, 1.0, 0.0, 0) CXV = CX - IHM(IND2) * CHOR CYV = CY + IHM(IND2) * SVER CXH = CX - IHM(IND1) * SHOR CALL GGIP (CXV, CYV, 0.0, 3) CALL GGIP (CX, CY, 0.0, 2) CALL GGIP (CXH, CY, 0.0, 2) CALL GGIP (CX, CY, 0.0, 3) ENDIF ENDIF READ (LU14, 99997, END = 80) CID 50 READ (LU14, 99997, END = 80) CID IF (CID(1:4) .NE. 'ZONE') THEN NS = NS + 1 IF (IGBL(22) .GE. 0) THEN VRT = VRT - SVER CALL GGIP (0.0, 1.0, 0.0, 0) ENDIF READ (CID(1:4), 99992) NK IKS(IND2) = NK IF (IGBL(22) .GE. 0) THEN CALL GGIP20 (0.0, CID(1:5), 5 + IGBL(68), 0.2, -1, 1, SHFT, 1 VRT) HRT = SHFT + 1.5 + SHOR + NS * CHOR ENDIF IKS(IND1) = - IHM(IND1) - 1 DO 70 I = 11, NP44, 2 IF (IT(NL + 1) .EQ. 0) THEN IKS(IND1) = IKS(IND1) + 1 IF (CID(I:I) .EQ. 'E') THEN CID(I:I) = ' ' IPR(385) = IPR(385) + 1 ENDIF IF (CID(I+1:I+1) .NE. ' ' .AND. CID(I+1:I+1) .NE. '-' 1 .AND. CID(I+1:I+1) .NE. '#') THEN IPR(390) = IPR(390) + 1 IF (CID(I+1:I+1) .EQ. '?') THEN IPR(391) = IPR(391) + 1 ENDIF ENDIF IF (CID(I:I) .NE. ' ' .AND. CID(I:I) .NE. '+' 1 .AND. CID(I:I) .NE. '#') THEN STHK = GEN095 (PAR(191), IKS(1), IKS(2), IKS(3)) STHL = SQRT (STHK) IF (CID(I:I) .EQ. '?') THEN IPR(386) = IPR(386) + 1 IF (IGBL(22) .NE. -1) THEN IF (IPR(386) .EQ. 1) THEN CALL PLA269 (0) WRITE (LU7, 99999) CALL PLA269 (3) ENDIF CALL PLA269 (1) WRITE (LU7, 99998) IPR(386), IKS(1), IKS(2), IKS(3), 1 STHL ENDIF TH = ASIN (STHL * PAR(17)) * GL(5) TH25 = MIN (ASIN (0.6 * PAR(17)) * GL(5), PAR(446)) IF (TH .LT. PAR(445)) THEN IPR(553) = IPR(553) + 1 ELSE IF (TH .GT. TH25) THEN IPR(557) = IPR(557) + 1 ELSE IPR(555) = IPR(555) + 1 ENDIF IF (STHL .LE. 0.5) THEN ACAL = 0.0 BCAL = 0.0 CALL PLA131 (IKS(1), IKS(2), IKS(3), ACAL, BCAL, 1 ACALA, BCALA, SNTHA) CALC = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2 IF (IGBL(22) .LT. 0) THEN NHEAD = NHEAD + 1 IF (NHEAD .EQ. 1) WRITE (LU22, 99999) IF (TH .LT. PAR(445)) THEN THFL = '*' ELSE THFL = ' ' ENDIF IF (CALC / CALIM .GT. 1.0) IPR(584) = IPR(584) + 1 WRITE (LU22, 99998) NHEAD, IKS(1), IKS(2), IKS(3), 1 STHL, TH, THFL, CALC, CALC / CALIM ENDIF ENDIF ENDIF IPR(384) = IPR(384) + 1 ISTH = INT(STHL * 20.0) - 8 DO 60 J = 1, 10 IF (ISTH .LE. J) THEN ICNT(J, 1) = ICNT(J, 1) + 1 IF (CID(I:I) .NE. '?') ICNT(J, 2) = ICNT(J, 2) + 1 ENDIF 60 CONTINUE ENDIF ENDIF IF (IGBL(22) .GE. 0) THEN IF (CID(I:I) .EQ. '*') THEN NCOL = 2 ELSE IF (CID(I:I) .EQ. 'L') THEN NCOL = 4 ELSE IF (CID(I:I) .EQ. 'E') THEN NCOL = 4 ELSE IF (CID(I:I) .EQ. '+') THEN NCOL = 1 ELSE IF (CID(I:I) .EQ. '?') THEN NCOL = 5 + IGBL(68) ELSE IF (CID(I:I) .EQ. '#') THEN NCOL = 5 + IGBL(68) ELSE IF (IPR(468) .EQ. 0 .OR. CID(I:I) .EQ. '1') THEN NCOL = 3 ELSE NCOL = 2 ENDIF ENDIF IF (IPR(369) .NE. 0) THEN IF (CID(I:I) .NE. '?' .AND. CID(I:I) .NE. '#' 1 .AND. CID(I:I) .NE. ' ') THEN NCOL = 4 CID(I:I) = '.' ENDIF ENDIF CALL GGIP20 (0.0, CID(I:I), 1, 0.2, NCOL, 1, HRT - 0.1, 1 VRT - 0.1) HRT = HRT + SHOR ENDIF 70 CONTINUE GOTO 50 ENDIF GOTO 90 80 IF (NHEAD .GT. 0) THEN WRITE (LU22, 99983) MAX (0.0, PAR(445)) IF (PAR(167) .GT. 0.0) WRITE (LU22, 99982) PAR(167) ENDIF CALL GEN108 (LU14, 0) LEV = -1 90 IT (NL + 1) = 1 IF (IPR(406) .EQ. 1) THEN IF (IGBL(22) .GE. 0) THEN PRBUF = 'Resol Perc' CALL GGIP20 (0.0, PRBUF(1:10), 10, 0.3, 2, 2, THOR, 0.1) ENDIF DO 100 I = 10, JMAX IF (I .LT. 20) THEN IF (I .EQ. 12) THEN NCOL = 2 ELSE NCOL = 1 ENDIF IF (ICNT(I - 9, 1) .NE. 0) THEN YDUM = ICNT(I - 9, 2) * 100.0 / ICNT(I - 9, 1) ELSE YDUM = 0.0 ENDIF IF (IGBL(22) .GE. 0) THEN WRITE (PRBUF, 99986) I * 0.05, YDUM CALL GGIP20 (0.0, PRBUF(1:10), 10, 0.3, NCOL, 2, THOR, 1 (I - 9) * 0.6) ENDIF ENDIF 100 CONTINUE IF (IGBL(22) .GE. 0) THEN JMX = MIN (JMAX, 20) + 1 WRITE (PRBUF, 99985) 'Layer 0 -', IPR(382) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 2, 2, THOR, (JMX - 5) * 0.6) WRITE (PRBUF, 99995) 'SpGrExt', IPR(385) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 4, 2, THOR, (JMX - 6) * 0.6) WRITE (PRBUF, 99995) 'MaxUniq', IPR(384) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, (JMX - 7) * 0.6) WRITE (PRBUF, 99995) 'Missing', IPR(386) CALL GGIP20 (0.0, PRBUF, 13, 0.3, 5 + IGBL(68), 2, THOR, 1 (JMX - 8) * 0.6) CALL GGIP (0.0, 1.0, 0.0, 0) ENDIF ENDIF RETURN 99999 FORMAT (/, 80('='), /, 1 'Missing Reflections (Asymmetric Reflection Unit)', 2 ' below sin(th)/lambda = 0.5', /, 80('='), /, 3 ' Nr H K L sin(th)/lambda', 3X, 4 'Theta', 6X, 'I(calc)', 2X, 'I(calc)/I(max)', /, 80('-')) 99998 FORMAT (I5, 3X, 3I5, 3X, F10.3, 6X, F7.2, A, F12.2, F13.5) 99997 FORMAT (A) 99996 FORMAT (A, F6.2) 99995 FORMAT (A, I6) 99994 FORMAT (I5) 99993 FORMAT (3X, '(Max =', I4, ')') 99992 FORMAT (I4) 99991 FORMAT ('Friedels Averaged ') 99990 FORMAT ('No Friedel Average') 99989 FORMAT (A, '-', A) 99988 FORMAT ('Generated Data') 99987 FORMAT (2A) 99986 FORMAT (F4.2, F6.1) 99985 FORMAT (A, I4) 99984 FORMAT (A, F6.4) 99983 FORMAT (/, ' ** Note: I(max) is the maximum I(obs) ', 1 'encountered in the fcf-file **', //, 6X, 2 'Starred Reflections have a Theta below Theta(Min) =', F6.2, /) 99982 FORMAT (35X, 'From CIF: Theta(Min) =', F6.2, /) END SUBROUTINE PLA143 PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30, NP44=512,NPY = NPVD + 2 * NP23 - 1114) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2), 1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2), 2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252), 3 STAT(20, 10), IAR(NPY) COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1 COMMON /CHAR0/ AR, CID, ZONE COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 CALL GEN038 (CID, 1, NP44) LTNR = IPR(241) IMX = 2 * IHM(IND1) + 1 J = -1 DO 10 I = 1, IMX IKS(IND1) = - IHM(IND1) - 1 + I J = J + 2 IF (IKS(IND3) .EQ. 0) THEN IF (IKS(IND2) .LT. 0) THEN GOTO 10 ELSE IF (IKS(IND2) .EQ. 0) THEN IF (IKS(IND1) .LE. 0) GOTO 10 ENDIF ENDIF STHK = GEN095 (PAR(191), IKS(1), IKS(2), IKS(3)) IF (STHK .LT. ATHM) THEN IF (LTNR .GT. 1) THEN IF (GEN049 (LAT(LTNR), IKS(1), IKS(2), IKS(3)) .LT. 0.0) 1 GOTO 10 ENDIF CALL PLA139 (IKS(1), IKS(2), IKS(3), IEXT, IASM) IF (J .GT. 0 .AND. J .LT. NP44) THEN IF (IEXT .EQ. 0) THEN IF (IASM .EQ. 1) THEN CID(J:) = ' ?' IF (STHK .LT. 0.09) IPR(512) = IPR(512) + 1 ELSE CID(J:) = ' #' ENDIF ELSE IF (IASM .EQ. 1) CID(J:) = ' E' ENDIF ENDIF ENDIF 10 CONTINUE RETURN END SUBROUTINE PLA144 PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000, 1 NP22=256,NP23=18000,NP38=125,NP39=30,NP45=2048) COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 INTEGER HMAX COMMON /TODAY/ DATIJD COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 CHARACTER DATIJD*25 CHARACTER FNLU18*80 IGBL(1) = 2 IF (IPR(30) .EQ. 0) THEN IGBL(23) = 21 IPR(500) = NINT (FN(1)) IPR(511) = 0 IF (IPR(220) .GT. 1 .AND. IFL(2)(2:4) .EQ. 'OBS') CALL PLA140 FNLU18 = NAME(1)(1:KNM(1)) //'.cpi' OPEN (UNIT = LU18, FILE = FNLU18, STATUS = 'UNKNOWN') IGBL(18) = 2 IF (IPR(511) .EQ. 1) THEN CALL PLA293 (PAR(17), 0) ELSE CALL PLA293 (1.5418, 0) IF (IPR(37) .EQ. 0) GOTO 140 CALL PLA287 (1, 1, 0) ENDIF 10 IF (IPR(500) .LE. 0 .OR. IPR(500) .GT. 5) THEN IF (PAR(17) .GT. 1.0) THEN IPR(500) = 2 PAR(371) = 0.1 ELSE IPR(500) = 1 PAR(371) = 1 ENDIF ENDIF STHKM = PAR(287)**2 NREFL = 0 NREFS = 0 AMX = 0.0 IF (IPR(511) .EQ. 0) THEN HMAX = INT(2 * PAR(101) * PAR(287)) + 1 KMAX = INT(2 * PAR(102) * PAR(287)) + 1 LMAX = INT(2 * PAR(103) * PAR(287)) + 1 IBVT = IPR(241) IL = - 1 20 IL = IL + 1 IF (IL .GT. LMAX) GOTO 55 IF (IL .GT. 0) THEN IK = - KMAX - 1 ELSE IK = -1 ENDIF 30 IK = IK + 1 IF (IK .GT. KMAX) GOTO 20 IF (IL .EQ. 0 .AND. IK .EQ. 0) THEN IH = 0 ELSE IH = - HMAX - 1 ENDIF 40 IH = IH + 1 IF (IH .GT. HMAX) GOTO 30 IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 40 IF (IBVT .GT. 1) THEN IF (GEN049 (LAT(IBVT), IH, IK, IL) .LT. 0) GOTO 40 ENDIF STHK = GEN095 (PAR(191), IH, IK, IL) IF (STHK .LE. STHKM) THEN ACAL = 0.0 BCAL = 0.0 CALL PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, SNTHA) A = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2 IF (SNTHA .LT. 1.0) THEN TH = ASIN(SNTHA) A = A * (1.0 + COS(2 * TH) ** 2) / 1 (SIN(TH) **2 * COS(TH)) NREFL = NREFL + 1 VOID(18000 + NREFL * 5 - 4) = IH VOID(18000 + NREFL * 5 - 3) = IK VOID(18000 + NREFL * 5 - 2) = IL VOID(18000 + NREFL * 5 - 1) = TH VOID(18000 + NREFL * 5) = A AMX = MAX (AMX, A) TH = TH * GL(5) IF (TH .LT. 20.0) THEN NREFS = NREFS + 1 JNSC(1, NREFS) = NINT(TH * 1000.0) JNSC(2, NREFS) = NREFL ENDIF ENDIF ENDIF GOTO 40 ELSE CALL GEN108 (LU17, 0) 50 READ (LU17, 99993, END = 55) IH, IK, IL, A IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 55 STHK = GEN095 (PAR(191), IH, IK, IL) IF (STHK .LE. STHKM) THEN TH = ASIN(SQRT(STHK) * PAR(17)) A = A * (1.0 + COS(2 * TH) ** 2) / 1 (SIN(TH) **2 * COS(TH)) NREFL = NREFL + 1 VOID(18000 + NREFL * 5 - 4) = IH VOID(18000 + NREFL * 5 - 3) = IK VOID(18000 + NREFL * 5 - 2) = IL VOID(18000 + NREFL * 5 - 1) = TH VOID(18000 + NREFL * 5) = A AMX = MAX (AMX, A) TH = TH * GL(5) IF (TH .LT. 20.0) THEN NREFS = NREFS + 1 JNSC(1, NREFS) = NINT(TH * 1000.0) JNSC(2, NREFS) = NREFL ENDIF ENDIF GOTO 50 ENDIF 55 CALL GEN037 (JNSC, 1, NREFS) CALL PLA269 (0) WRITE (LU7, 99987) CALL PLA269(5) DO 56 I = 1, NREFS TTH = 0.002 * JNSC(1, I) J = JNSC(2, I) IH = NINT(VOID(18000 + J * 5 - 4)) IK = NINT(VOID(18000 + J * 5 - 3)) IL = NINT(VOID(18000 + J * 5 - 2)) IR = NINT(VOID(18000 + J * 5)) CALL PLA269 (1) D = PAR(17) / (2.0 * SIN (TTH / (2.0 * GL(5)))) WRITE (LU7, 99988) IH, IK, IL, TTH, IR, D 56 CONTINUE 60 CALL GEN074 (VOID, 0.0, 1, 18000) AMN = AMX / 2500.0 IF (IPR(500) .EQ. 5) THEN FIN = 180.0 ELSE FIN = 20.0 * IPR(500) ENDIF IFN = NINT (FIN / PAR(411)) SRT = PAR(411) AL = PAR(371) SCL = PAR(372) N = 0 NP = 0 70 N = N + 1 IF (N .GT. NREFL) GOTO 90 TH = VOID(18000 + N * 5 - 1) A = VOID(18000 + N * 5) IP = NINT (2.0 * TH * GL(5) / PAR(411)) IF (IP .GT. IFN) GOTO 70 VOID(IP) = VOID(IP) + A NP = NP + 1 I = 0 80 I = I + 1 FACT = A / (1 + AL * I * I) IF (IP + I .LE. IFN) VOID(IP + I) = VOID(IP + I) + FACT IF ((IP - I) .GT. 0) VOID(IP - I) = VOID(IP - I) + FACT IF (FACT .GT. AMN) GOTO 80 GOTO 70 90 VM = 0.0 DO 100 I = 1, IFN VM = MAX (VOID(I), VM) 100 CONTINUE VM = VM / (VERT - 4.0) 110 BCD(1:25) = 'Simulated Powder Pattern'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, BCD, 25, 1.2, 4, 8, 0.6, VERT - 1.8) CALL GGIP20 (0.0, BCD, 25, 1.2, 2, 8, 0.5, VERT - 1.9) VRT = VERT - 3.0 WRITE (LINE, 99989) PAR(17) CALL GGIP20 (0.0, LINE, 17, 0.35, 1, 1, HORS - 5.0, VRT) VRT = VRT - 0.7 WRITE (LINE, 99990) SPGRNM(1)(1:7) CALL GGIP20 (0.0, LINE, 17, 0.35, 1, 1, HORS - 5.0, VRT) WRITE (LINE, '(''a '', F7.2)') PAR(101) VRT = VRT - 0.7 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''b '', F7.2)') PAR(102) VRT = VRT - 0.7 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''c '', F7.2)') PAR(103) VRT = VRT - 0.7 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''alpha'', F7.2)') PAR(104) VRT = VRT - 0.7 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''beta '', F7.2)') PAR(105) VRT = VRT - 0.7 CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT) WRITE (LINE, '(''gamma'', F7.2)') PAR(106) VRT = VRT - 0.7 CALL GGIP20 (0.0, LINE, 14, 0.35, 1, 1, HORS - 4.0, VRT) IF (IPR(511) * IPR(512) .NE. 0) THEN WRITE (LINE, 99991) IPR(512) CALL GGIP20 (90.0, LINE, 35, 0.45, 2, 2, 3.0, 2.5) ENDIF IF (IPR(511) .EQ. 0) THEN LINE = 'I(cal)' ELSE LINE = 'I(obs)' ENDIF CALL GGIP20 (90.0, LINE, 6, 0.5, 1, 2, 1.75, VERT - 5.0) CALL PLA117 (HORS, VERT, -1) IF (IPR(55) .NE. -1) CALL GGIP20 1 (0.0, JID(75:80), 6, 0.45, 1, 2, 10.5, 24.25) CALL GGIP (0.0, 0.0, 0.0, 6) XSTEP = (HORS - 2.0) / IFN IF (NP .GT. 0) THEN CALL GEN108 (LU18, 0) WRITE (LU18, 99999) WRITE (LINE, 99998) SRT CALL GEN039 (-1, LINE, 1, 10, NB, NE) WRITE (LU18, 99997) LINE(NB:NE) WRITE (LINE, 99998) FIN CALL GEN039 (-1, LINE, 1, 10, NB, NE) WRITE (LU18, 99997) LINE(NB:NE) WRITE (LINE, 99998) PAR(411) CALL GEN039 (-1, LINE, 1, 10, NB, NE) WRITE (LU18, 99997) LINE(NB:NE) WRITE (LU18, 99995) KRAD(1:2), PAR(17), DATIJD(5:24) CALL GEN039 (-1, JID, 1, 50, NB, NE) WRITE (LU18, 99997) JID(NB:50) WRITE (LU18, 99994) XP = 1.0 NB = 1 NE = 1 CALL GGIP (XP, 1.5, 0.0, 3) DO 120 I = 1, IFN XP = XP + XSTEP YP = MIN (VERT - 4.0, 1.5 + VOID(I) * SCL / VM) CALL GGIP (XP, YP, 0.0, 2) IF (IPR(569) .EQ. 1 .OR. IPR(570) .EQ. 1) THEN IF (I .GT. 1 .AND. I .LT. IFN .AND. YP .GT. 3.0) THEN IF (VOID(I - 1) .LT. VOID(I) .AND. 1 VOID(I + 1) .LT. VOID(I)) THEN THETA = I * PAR(411) / 2 D = PAR(17) / (2 * SIN(THETA / GL(5))) IF (IPR(569) .EQ. 1) THEN WRITE (NQ1, 99996) D ELSE WRITE (NQ1, 99996) THETA ENDIF XPP = XP + 0.0875 YPP = YP CALL GGIP20 (90.0, NQ1, 7, 0.175, 2, 1, XPP, YPP) CALL GGIP (XP, YP, 0.0, 3) ENDIF ENDIF ENDIF WRITE (LINE, 99992) NINT(VOID(I) * 10000.0 / VM) CALL GEN039 (-1, LINE, 1, 10, NB, NE) WRITE (LU18, 99997) LINE(NB:NE) 120 CONTINUE ENDIF IF (FIN .GT. 40.0) THEN IS = 5 ELSE IS = 1 ENDIF XP = 1.0 XST = IS * XSTEP / PAR(411) N = 0 130 CALL GGIP (XP, 0.8, 0.0, 3) CALL GGIP (XP, 1.2, 0.0, 2) CALL GEN040 (N, NQ1, IP) CALL GGIP20 (0.0, NQ1, IP, 0.2, 1, 1, XP + 0.1, 1.1) IF (N .GT. 0 .AND. IPR(569) .EQ. 1) THEN NN = NINT(50.0 * PAR(17) / SIN(N / (GL(5) * 2.0))) CALL GEN040 (NN, NQ1, IP) CALL GGIP20 (0.0, NQ1, IP, 0.175, 2, 1, XP + 0.01, 0.6) ENDIF XP = XP + XST N = N + IS IF (N .LE. NINT (FIN)) GOTO 130 CALL GGIP20 (0.0, '2-Theta Deg. / d * 100 Ang.', 1 12 + 15 * IPR(569), 0.35, 1, 1, HORS - 8.0, 0.1) CALL PLA013 (0, 1) CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1 1, 80, 7, NP17) IF (IFL(1)(1:4) .EQ. 'RADN') THEN WL = FN(1) CALL PLA293 (WL, 0) IPR(549) = 0 GOTO 10 ELSE IF (IFL(1)(1:4) .NE. 'EXIT') THEN IF (LRET .EQ. 1) THEN GOTO 110 ELSE IF (LRET .EQ. 2) THEN GOTO 140 ELSE IF (LRET .EQ. 3) THEN GOTO 60 ELSE IF (LRET .EQ. 4) THEN GOTO 10 ENDIF ENDIF 140 CLOSE (LU18, ERR = 150) ENDIF 150 RETURN 99999 FORMAT ('SIETRONICS XRD SCAN') 99998 FORMAT (F10.3) 99997 FORMAT (A) 99996 FORMAT (F6.2) 99995 FORMAT (A, /, F7.5, /, A, /, '1') 99994 FORMAT ('SCANDATA') 99993 FORMAT (3I4, F8.0) 99992 FORMAT (I10) 99991 FORMAT ('Missing Low Order Reflections =', I4) 99990 FORMAT ('SpGroup ', A) 99989 FORMAT ('Lambda ', F8.5) 99988 FORMAT (3I5, F8.2, I10, F10.3) 99987 FORMAT ('2-Theta Sorted Reflection Listing', /, 80('='), //, 4X, 1 'H K L 2-Theta Intensity',5X, 'd Ang', /, 80('=')) END SUBROUTINE PLA150 (MODE) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9,MP3=1000,MP1=NPVD + 2 * NP23 - 1836 - 87 * MP3) COMMON // SFC(1616), F(84), PEAK(MP3, 46), ICON(MP3, 40), 1 NCON(MP3), G(52), E(84), C(MP1) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) CHARACTER LABI*4, ATTP*2 DIMENSION DA(NP10), IA(NP10) COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /PL130/ TRMX(3, 3), STHKM, ISKIP, ITSKP, IOBS, ICALC, 1 NDEC, SHXMP COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 CHARACTER STAR*50 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 DIMENSION MCONT(NP10) S = 0 NSYM = IPR(48) NSYMH = IPR(255) CENT = 2 - IPR(257) IBVT = IPR(241) LATTS = IPR(256) * IPR(257) IGBL(25) = 1 IF (IPR(220) .GT. 1) THEN IF (IFL(2)(1:4) .EQ. 'AUTO') IGBL(25) = 0 ENDIF C * SETUP-MODE PARAMETERS IF (MODE .EQ. 0) THEN IPR(525) = 0 IF (IPR(220) .GT. 1) THEN DO 10 I = 2, IPR(220) IF (IFL(I)(1:4) .EQ. 'PATT') THEN IPR(525) = 1 ELSE IF (IFL(I)(1:4) .EQ. 'PATR') THEN IPR(525) = -1 ENDIF 10 CONTINUE ENDIF ELSE C * EXOR-MODE PARAMETERS IF (FN(1) .GT. 0.0) PAR(284) = FN(1) IF (FN(2) .GE. 0.0) PAR(281) = FN(2) IF (FN(3) .GT. 0.0) PAR(282) = FN(3) IF (FN(4) .GT. 0.0) PAR(283) = FN(4) IF (FN(5) .GT. 0.0) IPR(482) = NINT(FN(5)) IF (FN(6) .NE. 0.0) IPR(467) = NINT(FN(6)) IGBL(31) = 6 CALL PLA021 ENDIF IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN IGBL(23) = 27 IGGT(2:21) = NAME(1)(1:20) PAR1 = -999.0 PAR2 = FLOAT(-KNM(1)) CALL GGIP (PAR1, PAR2, 0.0, 5) IF (MODE .EQ. 0) THEN IF (IPR(525) .NE. 0) THEN CALL GGIP (HORS, VERT, 0.0, 1) BCD = 'PATTERSON'//CHAR(0) CALL GGIP20 (0.0, BCD, 10, 1.0, 4, 6, 10.1, VERT - 1.5) CALL GGIP20 (0.0, BCD, 10, 1.0, 2, 6, 9.9, VERT - 1.6) CALL GGIP (0.0, 0.0, 0.0, 6) VRT = VERT - 1.8 ENDIF ELSE CALL GGIP (HORS, VERT, 0.0, 1) BCD = 'E.X.O.R'//CHAR(0) CALL GGIP20 (0.0, BCD, 7, 1.8, 4, 15, 1.7, VERT - 2.3) CALL GGIP20 (0.0, BCD, 7, 1.8, 2, 15, 1.5, VERT - 2.4) ENDIF ENDIF IGBL(70) = 0 CALL PLA080 ICNT3 = 3 IF (IABS(IGBL(8)) .NE. 2 .AND. IPR(30) .EQ. 0) THEN CALL PLA069 CALL PLA073 (1) ICNT3 = 2 ENDIF Z = 0.004 / PAR(17)**2 L = 1 DO 50 I = 1, IAN N = IEN(I) L = L - 1 W = 0.0 DO 40 N0 = 1, 51 X = 0.0 Y = 0.0 DO 30 K = 1, 6 M = L + K SFC(M) = SFAC((N - 1) * 15 + 9) DO 20 J = 1, 7, 2 V = - SFAC((N - 1) * 15 + J + 1) * (W + X) SFC(M) = SFC(M) + SFAC((N - 1) * 15 + J) * EXP(V) 20 CONTINUE X = X + Z Y = Y + SFC(M) 30 CONTINUE SFC(L + 2) = 1.25 * Y - 3.75 * (SFC(L + 1) + SFC(L + 6)) L = L + 2 W = W + 5.0 * Z 40 CONTINUE 50 CONTINUE IF (IGBL(16) .EQ. 0) THEN CALL GEN108 (LU21, 0) MF = 1 DO 70 J = 1, 51 G(J) = 0.0 F(J) = 0.0 M = 2 * J - 1 DO 60 K = 1, IAN Y = SFC(M) * SFC(M) * CONT(K, ICNT3) G(J) = G(J) + Y F(J) = F(J) + Y * SFC(M) M = M + 101 60 CONTINUE 70 CONTINUE WRITE (LU7, 99967) PAR(17) CALL GEN074 (C, 999.0, 4, 6) CALL GEN074 (C, -999.0, 7, 9) IHMIN = 999 IKMIN = 999 ILMIN = 999 IHMAX = -999 IKMAX = -999 ILMAX = -999 THMAX = 0.0 THMIN = 1.0 IEND = -1 MR = 0 MN = 0 IH = 0 IK = 0 IL = 0 90 CALL PLA132 (NI, NJ, NK, T, W, CALI, UCINT, 1 ACALS, BCALS, ACOR, IEND) K = 0 IF (IEND .EQ. 0 .AND. ABS(NI) + ABS(NJ) + ABS(NK) .NE. 0) THEN IF (W .LE. 0.0) THEN IF (T .LE. 0.0) GOTO 90 W = SQRT(ABS(T)) ENDIF MN = MN + 1 IF (GEN050 (TRMX, NI, NJ, NK, IH, IK, IL) .LT. 0.0) GOTO 110 IF (IBVT .GT. 1) THEN IF (GEN049 (LAT(IBVT), IH, IK, IL) .LT. 0) GOTO 110 ENDIF U = -9999999.0 U1 = U P = 0.0 R = 0.0 XJX(1) = IH XJX(2) = IK XJX(3) = IL XJX(4) = 0.0 DO 100 N = 1, NSYMH CALL SGSM (LINE, N, XJX, 0, 5, IERR) IF (MAX(ABS(XJX(7)), ABS(XJX(8))) .GE. 99.5) GOTO 110 Q1 = XJX(7) + 200.0 * (XJX(8) + 200.0 * XJX(9)) Q = ABS(Q1) IF (CENT .EQ. 0) Q1 = Q IF (NINT(Q1) .GE. NINT(U1)) THEN O = XJX(10) / GL(5) O = COS(O) + 21.42 * SIN(O) * CENT R = R + O IF (NINT(Q1) .GT. NINT(U1)) THEN R = O U1 = Q1 ENDIF ENDIF IF (NINT(Q) .GE. NINT(U)) THEN P = P + 1.0 IF (NINT(Q) .GT. NINT(U)) THEN P = 1.0 U = Q ENDIF ENDIF 100 CONTINUE IF (ABS(R) .GE. 0.1) GOTO 120 110 MR = MR + 1 IF (MR .EQ. 1) WRITE (LU7, 99983) IF (K .GT. 50) THEN WRITE (LU7, 99980) NI, NJ, NK, T, W, S ELSE WRITE (LU7, 99980) NI, NJ, NK, T, W ENDIF GOTO 90 120 QS = GEN095 (PAR(191), IH, IK, IL) CALL GEN046 (U, X1, Y1, Z1) IHMAX = MAX (IHMAX, IH) IKMAX = MAX (IKMAX, IK) ILMAX = MAX (ILMAX, IL) IHMIN = MIN (IHMIN, IH) IKMIN = MIN (IKMIN, IK) ILMIN = MIN (ILMIN, IL) C(7) = MAX (C(7), X1) C(8) = MAX (C(8), Y1) C(9) = MAX (C(9), Z1) C(4) = MIN (C(4), X1) C(5) = MIN (C(5), Y1) C(6) = MIN (C(6), Z1) S = QS * PAR(17)**2 O = S * 50.0 K = INT(O) IF (K .GT. 50) GOTO 110 THMAX = MAX (THMAX, S) THMIN = MIN (THMIN, S) O = MOD (O, 1.0) EE = SQRT ((O * (G(K + 2) - G(K + 1)) + G(K + 1)) * P) IF (EE. NE. 0.0) EE = EXP (3.94784 * QS) / EE V = T * 100.0 W = W * 100.0 IF (V .LT. W) V = 0.5 * W V = SQRT(V) W = W / (2.0 * V) F(MF) = U F(MF + 1) = V IF (ABS(W) .GT. 0.00001) THEN F(MF + 2) = W**2 ELSE F(MF + 2) = 1.E-10 ENDIF F(MF + 3) = GL(8) * QS F(MF + 4) = MIN (EE * V, 900.0) F(MF + 5) = 0.0 MF = MF + 6 IF (MF .GT. 79) THEN WRITE (LU21) F MF = 1 ENDIF GOTO 90 ENDIF WRITE (LU7, 99994) MN, MR IF (MN .EQ. 0) GOTO 1020 CLOSE (LU16) THMIN = NINT(ASIN(SQRT(THMIN)) * 572.9578) / 10.0 IF (THMAX .GT. 1.0) THEN THMAX = 90.0 ELSE THMAX = NINT(ASIN(SQRT(THMAX)) * 572.9578) / 10.0 ENDIF WRITE (LU7, 99991) IHMIN, IHMAX, IKMIN, IKMAX, ILMIN, ILMAX, 1 THMIN, THMAX F(MF) = 0.0 WRITE (LU21) F CALL GEN108 (LU21, 1) HB = C(7) - C(4) + 1.0 GD = C(8) - C(5) + 1.0 GA = 1.0 - C(4) - HB * (C(5) + GD * C(6)) NE = -5 R = 0.0 S = 0.0 NM = 0 CALL GEN074 (C, 0.0, 1, MP1) NT = 0 M = MP1 130 READ (LU21) F DO 170 I = 1, 79, 6 IF (0.5 .GT. ABS(F(I))) THEN CALL GEN108 (LU21, 0) IF (M .EQ. MP1) THEN DO 140 K = 1, NT IF (K + 10 .GT. M) GOTO 150 IF (C(K) .GE. 1.0) THEN M = M - 8 C(K) = M + 1 ENDIF 140 CONTINUE 150 CALL GEN074 (C, 0.0, NT + 1, MP1) M = NT GOTO 130 ENDIF GOTO 180 ENDIF CALL GEN046 (F(I), X, Y, Z) N = NINT(GA + X + HB * (Y + GD * Z)) IF (N .GT. 0 .AND. N .LE. M) THEN IF (M .NE. MP1) THEN N = NINT(C(N)) V = F(I + 1) W = 1.0 / F(I + 2) C(N + 1) = C(N + 1) + V * W C(N + 2) = C(N + 2) + W C(N + 3) = F(I + 3) C(N + 4) = C(N + 4) + F(I + 4) * W C(N + 6) = C(N + 6) + V * V * W C(N + 7) = F(I) ELSE NT = MAX (N, NT) ENDIF C(N) = C(N) + 1.0 ENDIF 170 CONTINUE GOTO 130 180 DO 190 J = 1, NT M = NINT(C(J)) IF (M .NE. 0) THEN NE = NE + 6 E(NE) = C(M + 7) W = 1.0 / C(M + 2) E(NE + 1) = C(M + 1) * W E(NE + 2) = W E(NE + 3) = C(M + 3) E(NE + 4) = MIN (900.0, C(M + 4) * W) E(NE + 5) = 0.0 IF (NE .GE. 79) THEN WRITE (LU9) E NE = - 5 ENDIF NM = NM + 1 IF (C(M) .GT. 1.0 .AND. C(M + 1) .GE. 1.E-8) THEN X = C(M + 2) * C(M + 6) Y = C(M + 1) **2 S = S + W * X * (C(M) - 1.0) R = R + W * C(M) * (X - Y) IF (1.04 * Y .LE. X) THEN U = 1.0 / (SQRT(W) * C(M + 1)) W = SQRT(ABS(X / Y - 1.0)) N = NINT(C(M)) CALL GEN046 (C(M + 7), X, Y, Z) ENDIF ENDIF ENDIF 190 CONTINUE E(NE + 6) = 0.0 WRITE (LU9) E T = 0.0 IF (S .NE. 0.0) T = SQRT(ABS(R / S)) WRITE (LU7, 99985) NM, T CALL GEN108 (LU9, 1) L = 0 CALL GEN074 (C, 0.0, 1, 64) CALL GEN074 (E, 0.0, 1, 64) DO 250 M = 1, 2 200 READ (LU9) F I = -5 210 I = I + 6 IF (0.5 .LE. ABS(F(I))) THEN X = 1.0 + SQRT(2.584724 * F(I + 3)) K = MIN (14, INT(X)) T = MIN (X - FLOAT(K), 1.0) W = F(I + 4) P = 1.0 - T IF (M .EQ. 1) THEN C(K) = C(K) + P * W**2 C(K + 1) = C(K + 1) + T * W**2 C(K + 15) = C(K + 15) + P C(K + 16) = C(K + 16) + T ELSE W = W * (P * C(K + 30) + T * C(K + 31)) F(I + 4) = MIN (W, 9.0) F(I + 1) = F(I + 1) * Q F(I + 2) = F(I + 2) * Q**2 V = ABS(1.0 - W**2) C(K) = C(K) + P * V / MAX (C(K + 15), 0.01) C(K + 1) = C(K + 1) + T * V / MAX (C(K + 16), 0.01) CALL GEN046 (F(I), X, Y, Z) IF (L .GE. 4) L = 0 L = L + 1 C(L + 45) = F(I + 1) C(L + 49) = SQRT(F(I + 2)) ENDIF IF (I .LT. 79) GOTO 210 IF (M .EQ. 2) WRITE (LU21) F GOTO 200 ENDIF IF (M .EQ. 1) THEN Q = 1.0 U = 0.0 DO 230 J = 1, 10 CALL GEN074 (E, 0.0, 1, 8) DO 220 I = 1, 15 X = E(8)**2 P = EXP(X * U) * C(I) V = P / MAX (1.E-5, C(I + 15)) W = P * Q Z = C(I + 15) - W E(1) = E(1) + V * P W = W * X E(2) = E(2) + V * W P = Q * X E(3) = E(3) + V * W * P E(4) = E(4) + Z * V E(5) = E(5) + Z * V * P E(6) = E(6) + C(I) E(7) = E(7) + C(I + 15) E(8) = E(8) + 0.622004 220 CONTINUE X = 1.0 / (0.1 + E(1)) W = - X * E(2) Z = 1.0 / (0.1 + E(3) + W * E(2)) Y = Z * W X = X + W * Y U = U + E(4) * Y + E(5) * Z IF (ABS(U) .GE. 0.1) THEN U = SIGN (0.09999, U) X = 0.0 Y = 1.0 / (0.1 + E(3)) ENDIF Q = Q + E(4) * X + E(5) * Y 230 CONTINUE Q = SQRT(MAX(Q, 0.0)) * SQRT(FLOAT(LATTS)) * 0.96 U = 0.05 - 0.5 * U DO 240 I = 1, 15 C(I + 30) = SQRT((C(I + 15) + 0.01 * E(7)) 1 / (C(I) + 0.01 * E(6))) 240 CONTINUE ENDIF CALL GEN108 (LU9, 0) 250 CONTINUE WRITE (LU21) F WRITE (LU7, 99984) Q, U IF (IPR(525) .LE. 0) THEN CALL GEN108 (LU21, 1) CALL GEN108 (LU17, 0) EKW = 0.0 NEK = 0 260 READ (LU21) F DO 270 I = 1, 79, 6 IF (0.5 .GT. ABS(F(I))) GOTO 280 CALL GEN046 (F(I), C(1), C(2), C(3)) V = F(I + 1) * 100.0 W = SQRT(F(I + 2)) * 100.0 WRITE (LU17, 99982) NINT(C(1)), NINT(C(2)), 1 NINT(C(3)), NINT(V), NINT(W) EKW = EKW + ABS(F(I+4)**2 - 1.0) NEK = NEK + 1 270 CONTINUE GOTO 260 280 WRITE (LU17, 99981) WRITE (LU7, 99979) EKW / NEK IGBL(16) = 1 ENDIF ENDIF C * EXOR (MODE > 0) IF (MODE .GT. 0) THEN KNOWN = 0 DO 285 I = 2, IAN IF (LMT(I, 1) .NE. ' Q') THEN IF (CONT(I, 3) .NE. CONT(1, 3)) KNOWN = 1 ENDIF 285 CONTINUE UT = 2.0 * (GL(6) / PAR(17))**2 SS = PAR(284)**2 N = 0 M = 0 CALL GEN108 (LU21, 0) CALL GEN108 (LU4, 0) IF (SS .LE. 1.E9) THEN 290 READ (LU21) F WRITE (LU4) F DO 320 I = 1, 79, 6 IF (NINT(F(I)) .EQ. 0) THEN CALL GEN108 (LU21, 0) CALL GEN108 (LU4, 1) 300 READ (LU4) F DO 310 J = 1, 79, 6 IF (NINT(F(J)) .EQ. 0) THEN WRITE (LU21) F CALL GEN108 (LU21, 1) CALL GEN108 (LU4, 0) WRITE (LU7, 99999) SQRT(SS), M, N GOTO 330 ENDIF X = 0.0 IF (SS * F(J + 2) .GT. F(J + 1)**2) THEN X = 1.0 M = M + 1 ENDIF F(J + 3) = MOD(F(J + 3), UT) + UT * X 310 CONTINUE WRITE (LU21) F GOTO 300 ENDIF N = N + 1 320 CONTINUE GOTO 290 ENDIF 330 EXPMX = PAR(98) / (12.0 * NSYM) CRIT0 = 0.33 PICKUP = 1.0 IAN0 = IAN IF (LMT(IAN, 1) .EQ. ' Q') IAN0 = IAN - 1 DO 340 I = 1, IAN0 DA(I) = 1000.0 - IATNR(IEN(I)) IA(I) = I 340 CONTINUE CALL GEN013 (DA, IA, 1, IAN0) IRMIN = IAN0 DO 350 I = 1, IAN0 DA(I) = 1000.0 - DA(I) IF (NINT(DA(I)) .LE. 1) IRMIN = IRMIN - 1 350 CONTINUE RATIO = DA(1) / DA(IRMIN) CRIT = CRIT0 / RATIO DO 360 I = 1, 3 V2(I) = 2.0 * PAR(112 + I) 360 CONTINUE IF (IPR(37) .GT. MP3) STOP 'MEMORY (MP3) PROBLEM' NPK = 0 LOOP = 0 VRT = VERT - 3.0 380 LOOP = LOOP + 1 NAT = MIN (MP3, IPR(37) + NPK) IF (LOOP .EQ. 1) THEN DO 420 J = 1, NAT DO 390 I = 1, 3 XJX(I) = CON(J, I + 2) PEAK(J, I) = XJX(I) 390 CONTINUE PEAK(J, 5) = 100.0 XJX(10) = 0.0 CALL SGSM (LINE, 0, XJX, LU6, 19, IERR) PEAK(J, 6) = XJX(10) ATTP = LMT(NINT(CON(J, NP4 - 1)), 1) DO 400 I = 1, IAN0 IF (ATTP .EQ. LMT(IA(I), 1)) GOTO 410 400 CONTINUE 410 PEAK(J, 4) = XJX(10) * DA(I) / DA(1) 420 CONTINUE ELSE DO 450 I = 1, NAT IF (I .LE. IPR(37)) THEN DO 430 J = 1, 3 XJX(J) = CON(I, J + 2) PEAK(I, J) = XJX(J) 430 CONTINUE PEAK(I, 4) = CON(I, NP4) PEAK(I, 5) = 0.0 ELSE DO 440 J = 1, 3 XJX(J) = XXO(I - IPR(37), J) PEAK(I, J) = XJX(J) 440 CONTINUE PEAK(I, 4) = PEAK(I, 6) * CRIT PEAK(I, 5) = XXO(I - IPR(37), 4) / PAR(98) IF (PEAK(I, 5) .LT. PICKUP) PEAK(I, 4) = 0.0 ENDIF XJX(10) = 0.0 CALL SGSM (LINE, 0, XJX, 6, 19, IERR) PEAK(I, 6) = XJX(10) 450 CONTINUE ENDIF CALL GEN097 (NCON, 1, NAT, 0) DO 560 I = 1, NAT DO 550 J = I, NAT DO 540 N = 1, NSYM IF (J .NE. I .OR. N .NE. 1) THEN DO 460 K = 1, 3 XJX(K) = PEAK(J, K) XJX(K + 3) = 0.0 460 CONTINUE NS = N CALL SGSM (LINE, NS, XJX, LU6, 3, IERR) K = 1 GOTO 480 470 XJX(6 + K) = XJX(6 + K) - 1.0 480 IF ((PEAK(I, K) - XJX(6 + K)) .LE. V2(K)) GOTO 470 GOTO 500 490 IF (ABS(PEAK(I, K) - XJX(6 + K)) .LE. V2(K)) GOTO 510 500 XJX(6 + K) = XJX(6 + K) + 1.0 IF ((PEAK(I, K) - XJX(6 + K)) .GE. - V2(K)) GOTO 490 K = K - 1 IF (K .EQ. 0) GOTO 540 GOTO 500 510 K = K + 1 IF (K .GT. 3) THEN DO 520 L = 1, 3 V3(L) = PEAK(I, L) - XJX(6 + L) 520 CONTINUE CALL GEN002 (2, OR, V3, V4, DIST) IF (DIST .LT. 2.0) THEN IF (I .NE. J .OR. DIST .GT. 0.05) THEN IF (NCON(I) .LT. 40) THEN NCON(I) = NCON(I) + 1 PEAK(I, 6 + NCON(I)) = DIST ICON(I, NCON(I)) = J ENDIF IF (NCON(J) .LT. 40) THEN NCON(J) = NCON(J) + 1 PEAK(J, 6 + NCON(J)) = DIST ICON(J, NCON(J)) = I ENDIF ENDIF ENDIF GOTO 530 ENDIF GOTO 480 530 K = K - 1 GOTO 500 ENDIF 540 CONTINUE 550 CONTINUE 560 CONTINUE NRNEW = 0 NRSH = 0 RSHN = 0.0 DO 590 I = 1, NAT IF (PEAK(I, 4) / PEAK(I, 6) .GE. CRIT) THEN JMAX = NCON(I) DO 570 J = 1, JMAX BONDIJ = PEAK(I, J + 6) IF (BONDIJ .LT. 1.3) THEN K = ICON(I, J) IF (BONDIJ .LT. 0.9 .OR. 1 PEAK(I, 4) .GT. PEAK(K, 4) * 3) THEN PEAK(K, 4) = 0.0 ENDIF ENDIF IF (PEAK(I, 5) .GT. 0.0 .AND. PEAK(I, 5) .LT. 2.0) THEN IF (BONDIJ .GT. 1.6) GOTO 590 ENDIF IF (LOOP .EQ. 1) THEN PHMIN = 2.0 ELSE PHMIN = 1.0 ENDIF IF (BONDIJ .LT. 1.8 .AND. PEAK(I, 5) .GT. 0.0 1 .AND. PEAK(I, 5) .LT. PHMIN) GOTO 590 570 CONTINUE IF (RSHN .LT. EXPMX) THEN NRSH = NRSH + 1 RSHN = RSHN + PEAK(I, 6) NCONM = MIN (NCON(I), 6) WRITE (LU7, 99978) NRSH, I, (PEAK(I, J), J = 1, 6 + NCONM) WRITE (LU7, 99977) (ICON(I, J), J = 1, NCONM) DO 580 J = 1, 3 CON(NRSH, J + 2) = PEAK(I, J) 580 CONTINUE CON(NRSH, NP4 - 1) = IA(1) CON(NRSH, NP4) = PEAK(I, 4) IF (PEAK(I, 5) .GT. 0.0) NRNEW = NRNEW + 1 DATC(NRSH) = 1000.0 - PEAK(I, 4) / PEAK(I, 6) IATC(NRSH) = I ENDIF ENDIF 590 CONTINUE IF (NRSH .EQ. 0) WRITE( LU6, 99969) IPR(37) = NRSH IF (NRNEW .EQ. 0 .AND. LOOP .GT. 2) GOTO 600 IF (LOOP .LT. IABS(IPR(467))) THEN CALL PLA151 (LOOP) IF (IPR(2) .EQ. 0) CALL PLA152 (-2, NPK) GOTO 380 ENDIF 600 CALL GEN108 (LU2, 0) HRT = 0.57 * HORS VRT = VERT - 3.4 WRITE (LU2, 99990) JID(1:6), PAR(17), (PAR(100 + I), I = 1, 12) WRITE (LU2, 99989) IPR(242) DO 610 I = 2, IPR(255) NUMS = I CALL SGSM (LINE, NUMS, XJX, 0, 17, IERR) WRITE (LU2, 99988) LINE(1:60) 610 CONTINUE WRITE (LU2, 99987) (LMT(I, 1), I = 1, IAN0) WRITE (LU2, 99986) (NINT(CONT(I, 3)), I = 1, IAN0) WRITE (LU2, 99995) PAR(74) FACT = 0.5 XPEAK = 999.0 N = 0 DELTA = 1.0 CALL GEN097 (MCONT, 1, NP10, 0) CALL GEN013 (DATC, IATC, 1, NRSH) DO 615 I = 1, NRSH DATC(I) = (1000.0 - DATC(I)) * DA(1) IF (XPEAK - DATC(I) .GT. DELTA) THEN IF (N .LT. IRMIN) THEN N = N + 1 IF (N .LT. IRMIN) THEN DELT = DA(N) - DA(N + 1) ELSE DELT = 999.0 ENDIF ENDIF ENDIF XPEAK = DATC(I) DELTA = DELT * FACT * XPEAK / DA(N) MCONT(N) = MCONT(N) + 1 615 CONTINUE N = 0 NEL0 = 1 L = 0 NATR = 0 DO 620 I = 1, NRSH K = IATC(I) NATR = NATR + 1 N = N + 1 L = L + NINT(NSYM * PEAK(K, 6)) IF (NEL0 .LT. IAN0 .AND. NINT(DA(NEL0 + 1)) .NE. 1) THEN IF ((KNOWN .EQ. 0 .AND. N .GT. MCONT(NEL0)) .OR. 1 (KNOWN .EQ. 1 .AND. L .GT. NINT(CONT(IA(NEL0), 3)))) THEN L = NINT(NSYM * PEAK(K, 6)) NEL0 = NEL0 + 1 N = 1 ENDIF ENDIF LABI(1:4) = LMT(IA(NEL0), 1)(1:2)//' ' IF (LABI(1:1) .NE. ' ') THEN L0 = 1 NO = 50 + N ELSE LABI(1:4) = LMT(IA(NEL0), 1)(2:2)//' ' L0 = 0 NO = 500 + N ENDIF IF (NO .LT. 100) THEN WRITE (LABI(2 + L0 : 3 + L0), 99971) NO ELSE WRITE (LABI(2:4), 99972) NO ENDIF WRITE (LU2, 99993) LABI, IA(NEL0), (PEAK(K, J), J = 1, 3), 1 10 + PEAK(K, 6), RP(2) IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN IF (I .EQ. 1) THEN WRITE (IDM, 99975) VRT = VERT - 0.5 CALL GGIP20 (0.0, IDM, 38, 0.3, 5 + IGBL(68), 2, HRT, VRT) ENDIF IF (I .LE. 42) THEN WRITE (IDM, 99976) I, LABI, (PEAK(K, J), J = 1, 3), 1 DATC(I) VRT = VRT - 0.45 CALL GGIP20 (0.0, IDM, 38, 0.3, 1, 2, HRT, VRT) ENDIF ENDIF 620 CONTINUE WRITE (LU2, 99996) (PAR(I), I = 231, 239) WRITE (IDM, 99992) PAR(281), PAR(282), NATR WRITE (LU6, 99970) IDM IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) 1 CALL GGIP20 (0.0, IDM, 56, 0.3, 5 + IGBL(68), 2, 0.2, 0.2) ELSE IF (IABS(IPR(525)) .EQ. 1) THEN NPK = 30 MDIP = 0 CALL PLA152 (0, NPK) IF (XXO(1, 4) .GT. 0.0) THEN PMAX = 999.0 / XXO(1, 4) ELSE PMAX = 1.0 ENDIF DO 800 I = 1, NPK DO 810 J = 1, 3 XXO(I, J) = MOD (XXO(I, J), 1.0) 810 CONTINUE XXO(I, 4) = XXO(I, 4) * PMAX 800 CONTINUE NPKM = MIN (35, NPK) NPRV = 50 DO 1000 I = 1, NPKM NSTAR = NINT(XXO(I, 4) * 50 / 999.0) STAR = ' ' IF (NSTAR .GT. 0) THEN DO 900 J = 1, NSTAR STAR(J:J) = '*' 900 CONTINUE ENDIF NDIF = NPRV - NSTAR NPRV = NSTAR IF (NDIF .GT. 0) THEN IF (I .GT. 2) MDIP = MAX (MDIP, NDIF) DO 950 J = 1, NDIF STAR(51-J:51-J) = '<' 950 CONTINUE ENDIF WRITE (LINE, 99998) I, (XXO(I, J), J = 1, 4), STAR WRITE (LU7, 99968) LINE IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, LINE, 80, 0.3, 1, 2, 2.2, VRT) ENDIF 1000 CONTINUE WRITE (LU7, 99974) MDIP IF (MDIP .LT. IGBL(89)) THEN LINE = 'EQUAL ATOM TYPE PATTERSON' ELSE LINE = 'HEAVY ATOM TYPE PATTERSON' ENDIF CALL GGIP20 (0.0, LINE, 80, 0.4, 5 + IGBL(68), 2, 12.0, 2.0) ENDIF ENDIF IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN IF (MODE .NE. 0 .OR. IPR(525) .NE. 0) THEN 1010 IF (IPR(467) .GT. 0) THEN WRITE (SBCD, 99997) CHAR(0) ELSE WRITE (SBCD, 99973) CHAR(0) ENDIF CALL PLA013 (0, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 1010 OPEN (LU61, FILE = 'NEXT', STATUS = 'UNKNOWN') WRITE (LU61, 99968) IGGT CLOSE (LU61) ENDIF ENDIF 1020 IF (MODE .EQ. 0 .AND. IPR(2) .EQ. 0) IPR(2) = -13 RETURN 99999 FORMAT (':: Omit = ', F5.1, ' => ', I6, 1' Reflections Suppressed out of', I6, /) 99998 FORMAT (I3, 3F6.3, F6.0, 2X, A) 99997 FORMAT ('[END]', A) 99996 FORMAT ('HKLF 4 1', 9F8.4, /, 'END') 99995 FORMAT ('FVAR', F10.3) 99994 FORMAT (/, I7,' Reflections Read, of Which', I5, ' Rejected', /) 99993 FORMAT (A, I4, 5F10.4) 99992 FORMAT ('Sin(Th)/Lam =', F5.2, '-', F4.2, 1 ' - Number of Remaining Atoms:', I3) 99991 FORMAT ('IHMIN, IHMAX =', 2I5, /, 1 'IKMIN, IKMAX =', 2I5, /, 2 'ILMIN, ILMAX =', 2I5, /, 3 'THMIN, THMAX =', 2F5.1) 99990 FORMAT ('TITL ', A, ' - EXOR', /, 1 'CELL ', F7.5, 6F10.4, /, 2 'ZERR 1', 6X, 6F10.4) 99989 FORMAT ('LATT ', I3) 99988 FORMAT ('SYMM ', A) 99987 FORMAT ('SFAC ', 16(1X, A)) 99986 FORMAT ('UNIT ', 2I5, 14I4) 99985 FORMAT (I5, ' Unique Reflections R =', F8.4) 99984 FORMAT ('Overall Scale', F12.5, 10X, 'Estimated U =', F6.3) 99983 FORMAT (/, 'Excluded Reflections') 99982 FORMAT (3I4, 2I8) 99981 FORMAT (1X) 99980 FORMAT (3I4, 2F12.2, F10.2) 99979 FORMAT ('AVER ABS(E**2-1) =', F5.2) 99978 FORMAT (2I4, 3F7.3, F6.3, F7.2, F6.3, 6F5.2, 4(/, 44X, 6F5.2)) 99977 FORMAT (48X, 7I5) 99976 FORMAT (I2, 1X, A, 3F7.3, F6.1) 99975 FORMAT ('Nr Label x y z PP') 99974 FORMAT ('PATT DIP', I3) 99973 FORMAT ('[REF-XYZU]', A) 99972 FORMAT (I3) 99971 FORMAT (I2) 99970 FORMAT (/, A, /) 99969 FORMAT ('No Atoms') 99968 FORMAT (A) 99967 FORMAT (/, 'Wavelength =', F8.5, /) END SUBROUTINE PLA151 (LOOP) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP47=9,MP2=1700,MP5=MP2*5,MP6=2000,MP3=1000, 4 MP1=NPVD+2*NP23-MP2-87*MP3-3*MP5-2*MP6-1700) COMMON // SFC(1616), F(84), PEAK(MP3, 46), ICON(MP3, 40), 1 NCON(MP3), CT(MP5), D1(MP5), D2(MP5), IN(MP2), A(MP6), E(MP6), 3 B(MP1) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /COM3/ NGRID, STHM, ITOP DIMENSION ENB(16) N = 0 NSYMH = IPR(255) CENT = 2 - IPR(257) LATTS = IPR(256) * IPR(257) NAT = IPR(37) NV = IPR(482) TPI = GL(6) STHMN = GL(8) * PAR(281)**2 STHM = GL(8) * PAR(282)**2 VMAX = 0.0 VMEAN = 0.0 IF (LOOP .GT. 1) THEN CT(1) = MIN (0.08, MAX (0.03, RP(2))) ELSE CT(1) = 0.05 ENDIF L = 1 DO 20 I = 1, NAT IN(I) = NINT(CON(I, NP4 - 1)) DO 10 J = 1, 3 CT(L + J) = CON(I, J + 2) 10 CONTINUE CT(L + 4) = CON(I, NP4) CT(L + 5) = CT(1) L = L + 5 20 CONTINUE WRITE (IDM, 99999) WRITE (LU6, 99997) IDM IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, IDM, 80, 0.3, 5 + IGBL(68), 2, 0.2, VRT) ENDIF NC = 0 NISO = 0 30 NC = NC + 1 IF (NC .GT. 1) NISO = 1 R = 0.0 NN = NISO + NAT K = 1 DO 40 I = 1, NAT IF (NV .EQ. 0) THEN CON(I, NP4) = CT(K + 4) RP(2) = CT(1) ENDIF K = K + 5 CT(K) = CT(1) 40 CONTINUE IF (NV .LT. 0) THEN GOTO 170 ELSE IF (NV .GT. 0) THEN I = ((NN * (NN + 3)) / 2) + 10 CALL GEN074 (B, 0.0, 1, I) ENDIF NR = 0 CALL GEN074 (A, 0.0, 1, MP6) CALL GEN074 (E, 0.0, 1, MP6) CALL GEN074 (D1, 0.0, 1, MP5) CALL GEN074 (D2, 0.0, 1, MP5) CR1 = 0.0 CR2 = 0.0 CR3 = 0.0 CR4 = 0.0 XVL = 100.0 * (PAR(17)**2) / GL(8) 50 READ (LU21) F DO 140 I = 1, 79, 6 IF (NINT(F(I)) .EQ. 0) GOTO 150 IF (F(I + 3) .GT. STHM) GOTO 140 NR = NR + 1 V = XVL * F(I + 3) U = MOD (V, 2.0) M = INT (V - U) - 100 U = 0.5 * U DO 60 K = 1, IAN M = M + 101 ENB(K) = SFC(M) + U * (SFC(M + 2) 1 - SFC(M) + SFC(M + 1) - U * SFC(M + 1)) 60 CONTINUE CALL GEN046 (F(I), XJX(1), XJX(2), XJX(3)) U = 0.0 V = 0.0 J = 1 DO 70 K = 1, NAT J = J + 5 E(K) = EXP( - CT(J) * F(I + 3)) * ENB(IN(K)) * LATTS 70 CONTINUE DO 90 NSM = 1, NSYMH XJX(4) = 0.0 CALL SGSM (LINE, NSM, XJX, LU6, 5, IERR) XJX10 = XJX(10) / 360.0 K = 1 N = 0 DO 80 NI = 1, NAT W = CT(K + 4) R = E(NI) * W S = TPI * (CT(K + 1) * XJX(7) + CT(K + 2) * XJX(8) 1 + CT(K + 3) * XJX(9) + XJX10) P = R * COS(S) R = R * SIN(S) U = U + P V = V + R * CENT K = K + 5 IF (NV .GT. 0) THEN IF (F(I + 3) .GT. STHMN) THEN E5 = 1.0 / MAX (W, 0.0001) N = N + 1 D1(N) = D1(N) + E5 * P D2(N) = D2(N) + E5 * R N = N + 1 D1(N) = D1(N) - F(I + 3) * P D2(N) = D2(N) - F(I + 3) * R ENDIF ENDIF 80 CONTINUE 90 CONTINUE F(I + 4) = U F(I + 5) = V FCK = U ** 2 + V ** 2 FC = SQRT(FCK) FO = F(I + 1) FOK = FO ** 2 DELTA = FO - FC DELTA2 = FOK - FCK W = 1.0 / (F(I + 2) * (4.0 * FOK) + (0.01 * FOK) ** 2) CR3 = CR3 + W * DELTA2**2 CR4 = CR4 + W * FOK**2 W = SQRT(W) CR1 = CR1 + ABS(DELTA) CR2 = CR2 + FO IF (NV .GT. 0) THEN IF (F(I + 3) .GT. STHMN) THEN Y = DELTA2 Q = W CALL GEN074 (E, 0.0, 1, NN) U = U * Q V = V * Q DO 110 J = 2, N, 2 K = J / 2 + NISO E(K) = E(K) + 2 * (U * D1(J - 1) + V * D2(J - 1)) IF (NISO .EQ. 1) THEN E(1) = E(1) + 2 * (U * D1(J) + V * D2(J)) ENDIF D1(J - 1) = 0.0 D2(J - 1) = 0.0 D1(J) = 0.0 D2(J) = 0.0 110 CONTINUE W = W * Y M = NN + 1 DO 130 N = 1, NN Y = E(N) L = M M = L + NN - N + 1 IF (Y .NE. 0.0) THEN A(N) = W * Y + A(N) B(N) = B(N) + Y ** 2 DO 120 K = N, NN B(L) = Y * E(K) + B(L) L = L + 1 120 CONTINUE ENDIF 130 CONTINUE ENDIF ENDIF 140 CONTINUE WRITE (LU4) F GOTO 50 150 R = CR3 / FLOAT(NR - NN) WRITE (LU4) F CALL GEN108 (LU4, 1) CALL GEN108 (LU21, 0) U = CR1 / CR2 W = SQRT(CR3 / CR4) RNC = LOOP + FLOAT (NC) / 10.0 WRITE (IDM, 99998) RNC, U, W, NR, NN, VMEAN, VMAX, CT(1) WRITE (LU6, '(A)') IDM IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN VRT = VRT - 0.5 CALL GGIP20 (0.0, IDM, 80, 0.3, 1, 2, 0.2, VRT) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF IF (NV .EQ. 0) WRITE (LU7, 99996) U, W, NR, NN NV = NV - 1 IF (NV .LT. 0) GOTO 30 CALL GEN012 (B, A, NN, 0.0, 0.0, R) IF (NISO .EQ. 1) CT(1) = MAX (CT(1) + B(1), 0.02) VMAX = 0.0 VMEAN = 0.0 K = 0 DO 160 N = 1 + NISO, NN K = K + 5 WRITE(6,'(I5,3F10.4)') N,CT(K),B(N),CT(K)+B(N) CT(K) = CT(K) + B(N) V = B(N) / A(N) VMEAN = VMEAN + ABS(V) VMAX = MAX (VMAX, ABS(V)) 160 CONTINUE VMEAN = VMEAN / NN IF (VMEAN .LT. PAR(283)) NV = 0 GOTO 30 170 RETURN 99999 FORMAT ('Cyc R wR2 Nref Npar', 1 1X, 'Mean(s/u) Max(s/u) U(iso)') 99998 FORMAT (F3.1, 2F7.3, I6, I5, F8.4, F9.4, F7.2) 99997 FORMAT (/, A, /) 99996 FORMAT (':: RVAL=', 2F10.3, 2I10) END SUBROUTINE PLA152 (MODE, NPK) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30,MP3=1000,MP1=NPVD+2*NP23-1700-87*MP3) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /COM3/ NGRID, STHM, ITOP COMMON // SFC(1616), F(84), PEAK(MP3, 46), ICON(MP3, 40), 1 NCON(MP3), VOID(MP1) DO 20 I = 1, 3 DO 10 J = 4, 8 IPR(I + 394) = 2**J IF (PAR(I + 100) * 3.0 .LT. IPR(I + 394)) GOTO 20 10 CONTINUE 20 CONTINUE M1 = IPR(395) M2 = IPR(396) M3 = IPR(397) NGRID = M1 * M2 * M3 ITOP = NGRID * 2 ITOP2 = ITOP + 3 * (M1 + 2) * (M2 + 2) IF (ITOP2 .GT. MP1) THEN IPR(2) = 49 ELSE CALL PLA153 (MODE, VOID(1), VOID(ITOP + 1), NPK) ENDIF RETURN END SUBROUTINE PLA153 (MODE, FFT, R3D, NPK) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63, 2 NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /COM3/ NGRID, STHM, ITOP DIMENSION F(84), FFT(*), R3D(*) CHARACTER LINE*80 ACAL = 0.0 BCAL = 0.0 FCAL = 0.0 PCAL = 0.0 NSYMH = IPR(255) IF (MODE .EQ. 0) THEN LU = LU21 ISW = -5 ELSE LU = LU4 ISW = 5 ENDIF CALL GEN108 (LU, 0) M1 = IPR(395) M2 = IPR(396) M3 = IPR(397) FS000 = 0.0 CALL GEN074 (FFT, 0.0, 1, ITOP) FFT(1) = FS000 20 READ (LU) F DO 50 I = 1, 79, 6 IF (NINT(F(I)) .EQ. 0) GOTO 60 CALL GEN046 (F(I), C2, C3, C4) IF (MODE .EQ. 0) THEN ACAL = F(I + 1) ** 2 BCAL = 0.0 ELSE IF (F(I + 3) .GT. STHM) GOTO 50 FC = SQRT(F(I + 4)**2 + F(I + 5)**2) + 1.E-8 IF (MODE .LT. 0) THEN FRAC = F(I + 1) / FC - 1.0 ELSE FRAC = F(I + 1) / FC ENDIF AC = F(I + 4) * FRAC BC = F(I + 5) * FRAC FCAL = FRAC * FC PCAL = ATAN2(BC, AC) * GL(5) ENDIF DO 40 N = 1, NSYMH XJX(1) = C2 XJX(2) = C3 XJX(3) = C4 XJX(4) = PCAL CALL SGSM (LINE, N, XJX, LU6, ISW, IERR) IHT = NINT(XJX(7)) IKT = NINT(XJX(8)) ILT = NINT(XJX(9)) IF (MODE .NE. 0) THEN PHAS = XJX(10) / GL(5) ACAL = FCAL * COS(PHAS) BCAL = FCAL * SIN(PHAS) ENDIF ISN = 1 DO 30 J = 1, 2 IF (J .EQ. 2) ISN = -1 IH = ISN * IHT IK = ISN * IKT IL = ISN * ILT IF (IH .LT. 0) IH = IH + M1 IF (IK .LT. 0) IK = IK + M2 IF (IL .LT. 0) IL = IL + M3 LOC = 2 * ((IL * M2 + IK) * M1 + IH + 1) FFT(LOC -1) = ACAL FFT(LOC) = BCAL * ISN 30 CONTINUE 40 CONTINUE 50 CONTINUE GOTO 20 60 CALL GEN028 (FFT, IPR(395), 3, -1) RHOMIN = PAR(268) CALL PLA134 (FFT, R3D, 0, RHOMIN, MODE, NPK, 1) RETURN END SUBROUTINE PLA155 (TNP) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NPP=NPVD+2*NP23,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB, 1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11) COMMON // A(NPP) COMMON /WORDD/ IH(20), IR CHARACTER IH*1, IR*80, KEY*4 DO 10 I = 1, 10 IH(I) = CHAR(47 + I) 10 CONTINUE IH(11) = '.' IH(12) = '-' IH(13) = '+' IH(14) = 'X' IH(15) = 'Y' IH(16) = 'Z' IH(17) = ',' IH(18) = '=' IH(19) = '/' IH(20) = CHAR(32) LR = 1 OPEN (LR, FILE = 'shelxs.ins', STATUS = 'OLD', ERR = 320) LH = 3 OPEN (LH, FILE = 'shelxs.hkl', STATUS = 'OLD', ERR = 320) LI = 10 OPEN (LI, FILE = 'shelxs.lis', STATUS = 'UNKNOWN', ERR = 320) LP = 60 OPEN (LP, FILE = 'shelxs.res', STATUS = 'UNKNOWN', ERR = 320) LA = 2 OPEN (LA, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320) LB = 4 OPEN (LB, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320) LF = 8 OPEN (LF, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320) LG = 9 OPEN (LG, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320) WRITE (LI, 99998) CALL GEN074 (A, 0.0, 1, 76) IER = 0 LX = 25 LL = 1 LZ = 0 LQ = 0 LY = 65 LJ = 0 NB = 4 JR = 4 HS = 0.0 X = 0.0 A(14) = 1.0 A(16) = 1.0 A(19) = 1.0 A(26) = 1.2 A(27) = 5.0 A(28) = 0.005 A(29) = 0.7 A(32) = 1.5 CALL GEN074 (A, -2.0, 33, 35) CALL GEN074 (A, 2.0, 36, 38) A(39) = TNP A(43) = 4.0 A(52) = 2.0 A(53) = 1.0 A(56) = 28.0 A(58) = 0.5 A(59) = 1.5 A(64) = 1.0 A(65) = 1.0 A(69) = 1.0 A(73) = 1.0 CALL GEN074 (F, 1.0, 121, 123) CALL GEN074 (F, 0.0, 124, 126) GOTO 50 40 WRITE (LP, 99996) IR(1:JR) 50 READ (LR, 99996) IR KEY = IR(1:4) CALL GEN039 (1, IR, 4, 80, NB, JR) WRITE (LI, 99996) IR(1:JR) IF (KEY .EQ. 'TITL') GOTO 40 CALL GEN074 (G, 0.0, 1, 126) NA = 0 JD = 0 NJ = LY + 7 L = LY + 21 N = 4 IF (KEY .EQ. 'SYMM') THEN J = LY + 10 DO 60 I = J, L A(I + 2) = 0.0 60 CONTINUE ENDIF 70 W = 1.0 80 V = 0.0 NB = 0 Y = 1.0 U = 10.0 Z = 1.0 100 N = N + 1 K = 10 IF (N .LE. JR) THEN X = 0.0 DO 110 KK = 1, 19 IF (IR(N:N) .EQ. IH(KK)) THEN IF (KK .LT. 11) THEN Z = Y * Z V = U * ABS(V) + Z * X NB = 1 IF (V .NE. 0.0) THEN V = SIGN(V, W) W = V ENDIF GOTO 100 ENDIF K = KK - 9 GOTO 130 ENDIF X = X + 1.0 110 CONTINUE K = 1 ENDIF 130 IF (KEY .NE. 'SYMM') THEN IF (K .EQ. 2) GOTO 160 IF (NB .EQ. 0) THEN IF (K .EQ. 1) K = 6 IF (IABS(K - 6) .GT. 1) GOTO 150 IF (IR(N:N) .EQ. IH(20)) GOTO 150 JD = JD + 1 DO 140 K = 1, 4 IF (N .GT. JR) GOTO 220 IF (IR(N:N) .EQ. IH(17)) GOTO 70 IF (IR(N:N) .EQ. IH(18)) GOTO 180 IF (IR(N:N) .EQ. IH(19)) GOTO 220 IF (IR(N:N) .EQ. IH(20)) GOTO 70 N = N + 1 140 CONTINUE GOTO 70 ENDIF NA = NA + 1 G(NA) = V 150 IF (K .LT. 9) THEN GOTO 210 ELSE IF (K .EQ. 9) THEN GOTO 180 ELSE GOTO 220 ENDIF ENDIF IF (K .EQ. 1) THEN GOTO 100 ELSE IF (K .EQ. 2) THEN GOTO 160 ELSE IF (K .EQ. 3 .OR. K .EQ. 4) THEN A(L) = AINT(24.5 * V) / 24.0 GOTO 210 ELSE IF (K .GE. 5 .AND. K .LE. 7) THEN K = K + NJ A(K) = W GOTO 70 ELSE IF (K .EQ. 8 .OR. K .EQ. 10) THEN A(L) = A(L) + AINT(24.5 * V) / 24.0 L = L + 1 NJ = NJ + 3 IF (NJ + 8 .LT. L) GOTO 70 LY = LY + 12 GOTO 40 ELSE IF (K .EQ. 9) THEN GOTO 190 ENDIF 160 U = 1.0 Y = 0.1 GOTO 100 180 WRITE (LP, 99996) IR(1: JR) 190 READ (LR, 99996) IR NB = 4 JR = 4 CALL GEN039 (1, IR, 4, 80, NB, JR) WRITE (LI, 99996) IR(1: JR) N = 4 GOTO 70 210 IF (K .NE. 3) GOTO 70 W = -1.0 GOTO 80 220 IF (KEY .EQ. 'CELL') THEN DO 230 J = 1, 7 A(J) = G(J) 230 CONTINUE U = 2.0 * A(2) * A(3) * A(4) DO 240 J = 2, 4 X = A(J + 3) / GL(5) G(J) = COS(X) G(J + 3) = SIN(X) A(J + 9) = U * G(J) / A(J) A(J + 6) = A(J) * A(J) 240 CONTINUE X = (G(2) * G(3) - G(4)) / (G(5) * G(6)) Y = SQRT(ABS(1.0 - X * X)) A(46) = 1.0 / (A(2) * G(6) * Y) A(48) = 1.0 / (A(3) * G(5)) A(47) = X * A(48) / Y A(49) = (-G(6) * G(2) * X - G(5) * G(3)) / 1 (A(4) * G(5) * G(6) * Y) A(51) = 1.0 / A(4) A(50) = -G(2) * A(51) / G(5) A(60) = 1.0 / (A(46) * A(48) * A(51)) GOTO 40 ENDIF IF (KEY .EQ. 'LATT') THEN IF (G(1) .LT. 0.0) A(23) = 1.0 LL = NINT(ABS(G(1))) GOTO 40 ENDIF IF (KEY .EQ. 'SFAC') THEN IF (LL .LE. 65) THEN N = 3 * LL L = INT(4.1 - 2.0 * A(23)) CALL GEN074 (F, 0.5, 1, 12) CALL GEN074 (F, 0.0, 1, 3) IF (N .EQ. 12) THEN F(4) = 0.0 F(8) = 0.0 F(12) = 0.0 ELSE IF (N .EQ. 9) THEN F(4) = 0.6666667 F(5) = 0.3333333 F(6) = 0.3333333 F(7) = 0.3333333 F(8) = 0.6666667 F(9) = 0.6666667 ELSE IF (N .GT. 12) THEN F(LL - 1) = 0.0 N = 4 ENDIF LL = LY + 8 DO 260 K = 2, L, 2 DO 250 J = 1, N, 3 LL = LL + 4 A(LL) = 3.0 - FLOAT(K) A(LL + 1) = F(J) + 99.5 A(LL + 2) = F(J + 1) + 99.5 A(LL + 3) = F(J + 2) + 99.5 250 CONTINUE 260 CONTINUE LQ = LL - 1 F(1) = 1.1 ENDIF LQ = LQ + 5 A(LQ) = AINT (0.5 + G(1) + G(3) + G(5) + G(7) + G(9)) A(LQ + 1) = G(13) LZ = LZ + 1 A(LQ + 3) = G(12) A(LQ + 4) = G(14) GOTO 40 ENDIF IF (KEY .EQ. 'UNIT') THEN J = LL + 4 LE = LQ + 3 LX = LQ + 5 U = 0.0 V = 0.0 P = 0.0 Q = 0.0 R = 0.0 HS = 0.0 Z = 0.0 Y = 0.0 DO 270 I = 1, NA IF (A(J) .GT. 1.5) Z = Z + G(I) W = A(J) * G(I) P = P + W Q = Q + A(J + 4) * G(I) A(J + 4) = G(I) R = R + A(J + 3) * G(I) HS = MAX (HS, A(J) * A(J)) U = U + W * A(J) V = V + W * A(J) * A(J) Y = Y + W * SQRT(A(J)) J = J + 5 270 CONTINUE T = Q * 1.66052 / A(60) Z = A(60) / Z X = FLOAT(LL - LY - 8) WRITE (LI, 99995) A(60), Z, P, Q, T A(24) = SQRT(0.25 * X / U) T = (2.0 - A(23)) / X A(45) = V / (U * SQRT(T * U)) Y = Y**2 / (T * P**3) X = 15.0 * (250.0 + A(60) / X) / FLOAT(LY - 53) FF = AINT (MIN (X, 150.0 + 0.5 * X, 300.0 + 0.25 * X)) A(44) = - MIN (20.0 + ABS(FF) * 0.5, 160.1 + 40.0 * A(23)) A(40) = FF L = 0 M = 0 N = 0 T = 30.0 DO 280 K = 65, LY, 12 IF (A(K) .LT. - 0.5) L = 1 IF (A(K + 4) .LT. - 0.5) M = 1 IF (A(K + 8) .LT. - 0.5) N = 1 IF (ABS(A(K + 9)) + ABS(A(K + 10)) + ABS(A(K + 11)) .GT. 0.1) 1 T = 20.0 280 CONTINUE A(42) = MAX (-1.1 + 0.3 * A(23), 1 MIN (-0.2, -T * Y * (2.0 - A(23)))) IF (T .LE. 25.0) THEN IF (A(23) .LT. 0.5) L = 3 IF (L + M + N .GT. 2) A(44) = ABS(A(44)) ENDIF GOTO 40 ENDIF IF (KEY .EQ. 'OMIT') THEN IF (NA .EQ. 3) THEN IF (F(1) .GT. 119.5) GOTO 330 F(1) = F(1) + 1.0 I = INT(F(1)) F(I) = G(1) + 200.0 * (G(2) + 200.0 * G(3)) ELSE A(52) = 0.5 * ABS(G(1)) IF (NA .EQ. 2) A(53) = (SIN(8.726646E-3 * G(2)))**2 ENDIF GOTO 40 ENDIF IF (KEY .NE. 'HKLF') GOTO 50 A(41) = -4.0 -3.0 * A(23) IF (ABS(A(41)) .LT. 0.99) GOTO 330 A(41) = SIGN(AINT(ABS(A(41))) + 0.1, A(41)) A(60) = ABS(A(60)) CLOSE (UNIT = LR, STATUS = 'KEEP') IF (G(2) .EQ. 0.0) THEN G(2) = 1.0 G(3) = 1.0 G(7) = 1.0 G(11) = 1.0 ENDIF DO 290 I = 1, 11 HKLF(I) = G(I) 290 CONTINUE A(54) = 7.0 IF (HS .GT. 290.0) A(54) = 4.0 U = 195.0 IF (A(20) .LT. -8.E9) U = 45.0 U = 0.28 * (2.0 - A(23)) * A(60) / FLOAT(LL - LY - 8) U = U * 12.0 / (FLOAT(LY - 53) * (2.0 - A(23))) A(57) = 5.0 + AINT(U) LV = LE - 6 LX = LX - 8 WRITE (LG) F CALL GEN108 (LG, 0) U = 2.0 * A(2) * A(3) * A(4) DO 300 J = 2, 4 F(J) = U * COS(1.74533E-2 * A(J + 3)) / A(J) F(J + 3) = F(J) * F(J) 300 CONTINUE V = U * U U = 0.5 * A(1) * A(1) / (V - A(8) * F(5) - A(9) * F(6) 1 - A(10) * F(7)+ F(2) * F(3) * F(4)) DO 310 J = 8, 10 A(J + 6) = 0.5 * U * ((V / A(J)) - F(J - 3)) A(J + 9) = -2.0 * U * A(J) * A(J + 3) 310 CONTINUE A(17) = A(17) + U * A(12) * A(13) A(18) = A(18) + U * A(11) * A(13) A(19) = A(19) + U * A(11) * A(12) LD = LX CALL PLA156 (IER) IF (IER .NE. 0) GOTO 340 CALL PLA157 (IER) IF (IER .NE. 0) GOTO 340 CALL PLA158 CALL PLA159 CLOSE (LI) CLOSE (LP) GOTO 350 320 WRITE (6, 99999) GOTO 350 330 WRITE (LI, 99994) RETURN 340 WRITE (6, 99997) 350 RETURN 99999 FORMAT (/, '** CANNOT OPEN FILE') 99998 FORMAT ('SHELXS-86 - ', 1 'Crystal Structure Solution - Stripped Version ', /) 99997 FORMAT ('** Problem in SHX86') 99996 FORMAT (A) 99995 FORMAT (/, 'V =', F10.2, 5X, 'At Vol =', F6.1, 5X, 'F(000) =', 1 F8.1, //, ' Cell Wt =', F10.2, ' Rho =', F7.3, /) 99994 FORMAT (/, '** ERROR') END SUBROUTINE PLA156 (IER) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NPP=NPVD+2*NP23,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB, 1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11) COMMON // A(NPP) DIMENSION E(87), RS(13), SO(14), SU(14), IP(20) DATA RS /5.0, 3.5, 2.5, 2.0, 1.7, 1.5, 1.4, 1.3, 1.2, 1.1, 1 1.0, 0.9, 0.8/ LZ = LX + 7 CALL GEN074 (SO, 0.0, 1, 14) CALL GEN074 (SU, 0.0, 1, 14) ML = LY + 12 DO 10 I = ML, LL, 4 A(I + 1) = A(I + 1) - 99.5 A(I + 2) = A(I + 2) - 99.5 A(I + 3) = A(I + 3) - 99.5 10 CONTINUE CALL GEN074 (A, 0.0, 61, 64) CALL GEN074 (E, 0.0, 52, 87) SB = 1.0 N = 1 NR = 0 ND = 0 NU = 0 NX = 0 M = IABS(INT(G(1))) + 1 G(1) = 0.5 40 READ (LH, 99999, ERR = 40, END = 120) J, K, L, T, S T = T * G(2) S = S * G(2) IF (S .LT. 1.E-4) S = 0.1 IF (T .LT. 0.5 * S) T = MIN (0.25 * S, 0.5 * SB) SB = 0.8 * SB + 0.2 * S IF (IABS(J) + IABS(K) + IABS(L) .EQ. 0) GOTO 120 X = FLOAT(J) Y = FLOAT(K) Z = FLOAT(L) F(N + 1) = T F(N + 2) = S IF (T .LT. 1.E-6) GOTO 100 U = X * G(3) + Y * G(4) + Z * G(5) V = X * G(6) + Y * G(7) + Z * G(8) W = X * G(9) + Y * G(10) + Z * G(11) IF (ABS(AMOD(U + 999.5, 1.0) - 0.5) 1 + ABS(AMOD(V + 999.5, 1.0) - 0.5) 2 + ABS(AMOD(W + 999.5, 1.0) - 0.5) .GT. 0.01) GOTO 80 J = ML 50 J = J + 4 IF (J .LE. LL) THEN IF (ABS(AMOD(U * A(J + 1) + V * A(J + 2) + 1 W * A(J + 3) + 999.5, 1.0) - 0.5) .LT. 0.01) THEN GOTO 50 ELSE GOTO 80 ENDIF ENDIF F(N) = 0.0 DO 60 K = 65, LY, 12 X = U * A(K) + V * A(K + 3) + W * A(K + 6) Y = U * A(K + 1) + V * A(K + 4) + W * A(K + 7) Z = U * A(K + 2) + V * A(K + 5) + W * A(K + 8) IF (MAX(ABS(X), ABS(Y), ABS(Z)) .GT. 99.5) GOTO 100 X = AINT(1.001 * X) Y = AINT(1.001 * Y) Z = AINT(1.001 * Z) F(N) = MAX (F(N), ABS(X + 200.0 * (Y + 200.0 * Z))) A(61) = MAX (A(61), ABS(X)) A(62) = MAX (A(62), ABS(Y)) A(63) = MAX (A(63), ABS(Z)) 60 CONTINUE CALL GEN046 (F(N), X, Y, Z) IF (E(52) .GT. X) E(52) = X IF (E(53) .LT. X) E(53) = X IF (E(54) .GT. Y) E(54) = Y IF (E(55) .LT. Y) E(55) = Y IF (E(56) .GT. Z) E(56) = Z IF (E(57) .LT. Z) E(57) = Z K = 65 70 K = K + 12 IF (K .LE. LY) THEN Q = AINT(1.001 * (X * A(K) + Y * A(K + 3) + Z * A(K + 6))) + 1 200.0 * (AINT(1.001 * (X * A(K + 1) + Y * A(K + 4) + 2 Z * A(K + 7))) + 200.0 * AINT(1.001 * (X * A(K + 2) + 3 Y * A(K + 5) + Z * A(K + 8)))) IF (A(23) .LT. 0.5) Q = ABS(Q) IF (Q + 0.5 .LT. F(N)) GOTO 70 YUNK = ABS(AMOD(0.5 + ABS(X * A(K + 9) + Y * A(K + 10) + 1 Z * A(K + 11)), 1.0) - 0.5) - 0.01 IF (YUNK .LT. 0.0) THEN GOTO 70 ELSE GOTO 80 ENDIF ENDIF Q = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) + 1 Y * Z * A(17) + X * Z * A(18) + X * Y * A(19) IF (Q .GT. A(64)) A(64) = Q IF (Q .GE. 1.0) GOTO 90 N = N + 3 IF (N .GE. 126) THEN WRITE (LA) F N = 1 ENDIF GOTO 110 80 IF (F(N + 1) .LT. A(52) * F(N + 2)) GOTO 100 90 NU = NU + 1 100 NR = NR + 1 110 ND = ND + 1 GOTO 40 120 F(N) = 0.0 WRITE (LA) F CALL GEN108 (LA, 0) CLOSE (LH, STATUS = 'KEEP') IF (A(64) .GT. 1.0) A(64) = 1.0 X = 2.0 * GL(5) * ATAN2(SQRT(A(64)), SQRT(1.0 - A(64))) WRITE (LI, 99998) ND, NR, A(61), A(62), A(63), X IF (A(20) .LT. - 8.E9) A(22) = MIN (A(22) * A(22), A(64)) NU = 0 NR = 0 L = 1 QH = E(53) - E(52) + 1.0 QK = E(55) - E(54) + 1.0 QL = FLOAT(LX) + 7.3 QC = QL + 0.8 - E(52) - QH * (E(54) - QK * E(56)) RA = 0.0 RB = 0.0001 RC = 0.0 RD = 0.0001 130 QM = FLOAT(NPP) + 0.3 JF = 0 N = INT(MIN(QC + E(53) + QH * (E(55) + QK * E(57)), QM)) NF = 0 M = LX + 8 140 CALL GEN074 (A, 0.0, M, N) IF (LZ .LT. N) LZ = N 160 READ (LA) F I = - 2 170 I = I + 3 IF (I .GT. 126) GOTO 160 IF (F(I) .GE. 0.5) THEN CALL GEN046 (F(I), X, Y, Z) Q = QC + QH * (Y + QK * Z) + X IF (Q .GE. QL) THEN IF (Q .LE. QM) THEN J = INT(Q) IF (NF .EQ. 0) THEN A(J) = 1.0 ELSE IF (NF .EQ. 1) THEN K = INT(A(J)) W = MAX (F(I + 1) / F(I + 2), 3.0) / F(I + 2) A(K) = F(I) A(K + 1) = A(K + 1) + W A(K + 2) = A(K + 2) + W * F(I + 1) A(K + 3) = A(K + 3) + 1.0 A(K + 4) = A(K + 4) + F(I + 1) ELSE K = INT(A(J)) A(K + 1) = A(K + 1) + ABS(F(I + 1) - A(K + 2)) A(K + 4) = A(K + 4) + 1.0 / F(I + 2)**2 ENDIF ENDIF ENDIF GOTO 170 ENDIF CALL GEN108 (LA, 0) IF (NF .EQ. 0) THEN NF = 1 Q = 0.3 DO 180 I = M, N IF (A(I) .GE. 0.5) THEN A(I) = Q Q = Q + 5.0 IF (I + INT(Q) .GT. NPP) GOTO 190 K = I ENDIF 180 CONTINUE JF = 1 Q = Q + 5.0 K = N 190 I = K QM = FLOAT(I) + 1.0 DO 200 J = M, I A(J) = A(J) + QM 200 CONTINUE M = I + 1 QM = QM - 0.7 N = I + INT(Q - 5.0) GOTO 140 ENDIF I = M - 5 IF (NF .LT. 2) THEN 210 I = I + 5 IF (I .GT. N) THEN NF = 2 GOTO 160 ENDIF A(I + 2) = A(I + 2) / A(I + 1) A(I + 1) = 0.0 IF (A(I + 3) .GT. 1.5) RB = RB + A(I + 4) A(I + 4) = 0.0 GOTO 210 ENDIF READ (LG) F CALL GEN108 (LG, 0) JU = INT(F(1)) 220 I = I + 5 IF (I .LE. N) THEN NR = NR + 1 G(L) = A(I) V = A(I + 2) G(L + 1) = SQRT(MAX (1.E-8, V)) W = 1.0 / SQRT(A(I + 4)) CALL GEN046 (G(L), X, Y, Z) J = INT(X) K = INT(Y) NI = INT(Z) IF (A(I + 3) .GE. 1.5) THEN RA = RA + A(I + 1) P = A(I + 1) / (A(I + 3) * SQRT(A(I + 3) - 1.0)) IF (P .GE. 5.0 * W) THEN NX = NX + 1 ENDIF W = MAX (P, W) ENDIF P = 0.0 T = 0.0 DO 230 K = 65, LY, 12 Q = AINT(1.001 * (X * A(K) + Y * A(K + 3) + Z * A(K + 6))) + 1 200.0 * (AINT(1.001 * (X * A(K + 1) + Y * A(K + 4) 2 + Z * A(K + 7))) + 200.0 * AINT(1.001 * (X * A(K + 2) 3 + Y * A(K + 5) + Z * A(K + 8)))) S = SIGN(1.0, Q) * (X * A(K + 9) + Y * A(K + 10) 1 + Z * A(K + 11)) IF (A(23) .LT. 0.5) Q = ABS(Q) IF (Q + 0.5 .GE. G(L)) P = P + 1.0 IF (0.5 - Q .GE. G(L)) 1 T = 10.0 * AINT(12.0 * AMOD(400.01 - S, 1.0) + 12.0) 230 CONTINUE Q = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) 1 + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19) G(L + 2) = Q + AINT(AMOD(X + 998.01, 2.0) + 1 AMOD(Y + 998.01, 2.0) * 2.0 + AMOD(Z + 998.01, 2.0) * 4.0) G(L + 3) = T + (1.0 / P) J = 58 + INT(MIN(14.1, 33.3333 * Q / (A(1) * A(1)))) E(J) = E(J) + 1.0 E(J + 15) = E(J + 15) + V / P S = 0.5 * A(1) / SQRT(Q) K = 13 240 IF (RS(K) .LE. S) THEN K = K - 1 IF (K .GT. 0) GOTO 240 ENDIF K = K + 1 SU(K) = SU(K) + 1.0 IF (Q .LE. A(53)) THEN J = 1 250 J = J + 1 IF (JU .GE. J) THEN IF (ABS(G(L) - F(J)) .GE. 0.5) GOTO 250 ELSE IF (V .GT. W * A(52)) GOTO 260 ENDIF ENDIF G(L + 1) = - G(L + 1) SO(K) = SO(K) + 1.0 NU = NU + 1 260 RC = RC + W RD = RD + V L = L + 4 IF (L .GE. 124) THEN WRITE (LB) G L = 1 ENDIF GOTO 220 ENDIF QC = QC - QM + QL IF (JF .EQ. 0) GOTO 130 G(L) = 0.0 WRITE (LB) G CALL GEN108 (LB, 0) NU = NR - NU RA = RA / RB RC = RC / RD WRITE (LI, 99991) NR, NU, RA, RC I = 0 X = 0.0 NQ = 1 DO 270 I = 1, 13 IF (SU(I) .GT. 0.5) NQ = I 270 CONTINUE DO 280 I = 2, 4 X = AINT(A(I) / RS(NQ)) J = I + I + 18 G(J - 1) = - X G(J) = X + 0.5 280 CONTINUE DO 290 I = 1, NQ P = 0.5 * A(1) / RS(I) G(I + 30) = P * P G(I + 50) = 1 2.0 * GL(5) * ATAN2(P, SQRT(MAX (0.0, 1.0 - G(I + 30)))) SO(I) = SU(I) - SO(I) G(I) = 0.0 290 CONTINUE G(14) = 0.0 Z = 0.0 IF (LY .NE. 77) THEN IF (LY .LT. 90) THEN GOTO 320 ELSE GOTO 310 ENDIF ENDIF IF (A(81) * A(85) .LT. 0.0) GOTO 310 300 G(21) = 0.0 GOTO 320 310 G(23) = 0.0 IF (LY .EQ. 101) THEN IF (ABS(A(78)) + ABS(A(90)) .LT. 0.1) GOTO 300 ENDIF 320 Y = G(23) 330 X = G(21) 340 J = ML 350 J = J + 4 IF (J .LE. LL) THEN YUNK = ABS(AMOD(X * A(J + 1) + Y * A(J + 2) + Z * A(J + 3) 1 + 999.5, 1.0) - 0.5) - 0.01 IF (YUNK .LT. 0.0) THEN GOTO 350 ELSE GOTO 380 ENDIF ENDIF W = X + 200.0 * (Y + 200.0 * Z) + 0.5 K = 65 360 K = K + 12 IF (K .LE. LY) THEN Q = AINT(1.001 * (X * A(K) + Y * A(K + 3) + Z * A(K + 6))) 1 + 200.0 * (AINT(1.001 * (X * A(K + 1) + Y * A(K + 4) 2 + Z * A(K + 7))) + 200.0 * AINT(1.001 * (X * A(K + 2) 3 + Y * A(K + 5) + Z * A(K + 8)))) IF (ABS(Q) .GT. W) GOTO 380 IF (A(23) .LT. 0.5) Q = ABS(Q) IF (Q + 1.0 .LT. W) GOTO 360 YUNK =ABS(AMOD(0.5 + ABS(X * A(K + 9) + Y * A(K + 10) 1 + Z * A(K + 11)), 1.0) - 0.5) - 0.01 IF (YUNK .LT. 0.0) THEN GOTO 360 ELSE GOTO 380 ENDIF ENDIF Q = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) 1 + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19) IF (Q .GE. 0.0001) THEN K = 30 + NQ 370 IF (G(K) .GE. Q) THEN K = K - 1 IF (K .GT. 30) GOTO 370 ENDIF K = K - 29 G(K) = G(K) + 1.0 ENDIF 380 X = X + 1.0 IF (X .LT. G(22)) GOTO 340 Y = Y + 1.0 IF (Y .LT. G(24)) GOTO 330 Z = Z + 1.0 IF (Z .LT. G(26)) GOTO 320 WRITE (LI, 99990) (RS(I), I = 1, NQ) WRITE (LI, 99989) (SO(I), I = 1, NQ) WRITE (LI, 99988) (SU(I), I = 1, NQ) WRITE (LI, 99987) (G(I), I = 1, NQ) WRITE (LI, 99986) (G(I + 50), I = 1, NQ) CALL GEN074 (G, 0.0, 1, 5) Q = 0.015 DO 390 I = 58, 72 IF (E(I) .GE. 9.5) THEN P = ALOG(E(I + 15) / E(I)) G(1) = G(1) + 1.0 G(2) = G(2) + Q G(3) = G(3) + Q * Q G(4) = G(4) + P G(5) = G(5) + P * Q ENDIF Q = Q + 0.03 390 CONTINUE P = 20.0 IF (G(1) .GE. 0.5) THEN Q = G(1) * G(3) - G(2) * G(2) IF (Q .GE. 1.E-6) P = (G(2) * G(4) - G(1) * G(5)) / Q ENDIF P = P / (A(1) * A(1)) T = 10.0 / (A(64) + 0.001) NR = 1 ND = LX + 39 LH = ND I = INT(A(29) * 0.1) IF (I .GT. 0) LH = LH + 2 * INT(1.5 + A(I + 60)) LD = LH - 2 W = 1.0 / (A(27) * A(27)) W = W * W U = GL(8) * A(28) / (A(1) * A(1)) DO 530 M = 1, 4 IF (M .EQ. 1) CALL GEN074 (G, 0.0, 1, 38) IF (M .EQ. 2) THEN J = LX + 27 DO 400 K = J, LH, 2 A(K) = 0.0 A(K + 1) = 0.0 400 CONTINUE R = 0.0 Q = 0.0 DO 410 K = 12, 19 R = R + G(K) Q = Q + G(K + 19) 410 CONTINUE R = R / MAX (Q, 0.01) DO 420 K = 31, 38 G(K) = G(K) * R 420 CONTINUE J = LX + 8 DO 430 K = 1, 19 A(J) = G(K) / MAX (G(K + 19), 0.01) J = J + 1 430 CONTINUE DO 440 K = 12, 19 A(J) = AMOD(A(29), 10.0) * (A(J) - 1.0) + 1.0 440 CONTINUE IF (A(29) .LT. 5.0) GOTO 530 ENDIF IF (M .EQ. 3) THEN IF (A(29) .GE. 5.0) THEN DO 450 K = ND, LH, 2 A(K) = AMOD(A(29), 10.0) * (A(K) / MAX (A(K + 1), 0.01) 1 - 1.0) + 1.0 450 CONTINUE ENDIF ENDIF IF (M .EQ. 4) THEN J = LX + 27 L = J + 3 DO 460 K = J, L A(K + 4) = A(K) / MAX (A(K + 4), 0.01) 460 CONTINUE ENDIF 470 READ (LB) F DO 510 I = 1, 124, 4 IF (F(I) .LT. 0.5) GOTO 520 QC = AMOD(F(I + 2), 1.0) R = F(I + 1)**2 * EXP(P * QC) * AMOD(F(I + 3), 10.0) Q = QC * T N = INT(Q) Q = Q - FLOAT(N) N = N + 1 S = 1.0 - Q L = INT(12.0 + F(I + 2)) IF (M .EQ. 1) THEN G(L) = G(L)+ 1.0 G(L + 19) = G(L + 19) + R G(N) = G(N) + S G(N + 1) = G(N + 1) + Q G(N + 19) = G(N + 19) + R * S G(N + 20) = G(N + 20) + R * Q GOTO 510 ENDIF K = N + LX + 7 L = L + LX + 7 R = R * A(L) * (A(K) * S + A(K + 1) * Q) CALL GEN046 (F(I), XX, YY, ZZ) E(1) = ABS(XX) E(2) = ABS(YY) E(3) = ABS(ZZ) IF (A(29) .GE. 5.0) THEN J = INT(A(29) * 0.1) J = INT(0.5 + 2.0 * E(J)) + LX + 39 IF (M .EQ. 2) THEN A(J) = A(J) + 1.0 A(J + 1) = A(J + 1) + R GOTO 510 ENDIF R = R * A(J) ENDIF IF (IABS(N - 5) .LE. 2) THEN IF (E(1) .LE. 0.5) THEN IF (MIN(E(2), E(3)) .LT. 0.5) GOTO 490 J = LX + 27 GOTO 480 ENDIF IF (E(2) .LE. 0.5) THEN IF (E(3) .LT. 0.5) GOTO 490 J = LX + 28 GOTO 480 ENDIF J = LX + 29 IF (E(3) .GT. 0.5) J = J + 1 480 IF (M .EQ. 3) THEN A(J) = A(J) + 1.0 A(J + 4) = A(J + 4) + R GOTO 490 ENDIF A(J + 8) = A(J + 8) + ABS(1.0 - R * A(J + 4)) ENDIF 490 IF (M .EQ. 4) THEN IF (R .GT. 0.001) R = SQRT(SQRT(1.0 / 1 ((1.0 / (R * R)) + W))) * EXP(U * QC) G(NR) = F(I) L = 4 E(4) = F(I) G(NR + 1) = F(I + 1) G(NR + 2) = R NR = NR + 3 IF (NR .GE. 126) THEN WRITE (LA) G NR = 1 ENDIF IF (R .GE. ABS(A(26))) THEN IF (F(I + 1) .GE. 0.0) THEN DO 500 K = 4, L LD = LD + 4 A(LD) = E(K) IF (LD .GT. NPP - 2000) GOTO 760 A(LD + 1) = MIN (R, 9.0) A(LD + 2) = 0.0 A(LD + 3) = 1.0 IF (A(26) .GT. 0.0) THEN A(LD + 2) = AINT(F(I + 3) * 0.1) * 10.0 A(LD + 3) = 1.0 / AMOD(F(I + 3), 10.0) ENDIF 500 CONTINUE ENDIF ENDIF ENDIF 510 CONTINUE GOTO 470 520 CALL GEN108 (LB, 0) 530 CONTINUE G(NR) = 0.0 WRITE (LA) G CALL GEN108 (LA, 0) NA = LX + 4 AP = 0.0 M = LY + 12 DO 540 I = M, LL, 4 A(I + 1) = A(I + 1) + 99.5 A(I + 2) = A(I + 2) + 99.5 A(I + 3) = A(I + 3) + 99.5 540 CONTINUE JJ = IABS(INT(A(54))) M = 0 K = 0 I = 0 DO 550 J = 65, LY, 12 IF (ABS(A(J + 1)) .GT. 0.5) I = 1 IF (ABS(A(J + 2)) .GT. 0.5) K = 1 IF (ABS(A(J + 5)) .GT. 0.5) M = 1 550 CONTINUE J = LX + 27 IF (I + K + M .EQ. 3) THEN DO 570 M = 1, 2 K = J + 2 X = A(J) + A(J + 1) + A(K) DO 560 I = J, K A(I) = X 560 CONTINUE J = J + 8 570 CONTINUE GOTO 600 ENDIF IF (I .NE. 0) THEN I = LX + 28 GOTO 580 ENDIF IF (K .NE. 0) THEN I = LX + 29 GOTO 580 ENDIF IF (M .EQ. 0) GOTO 600 J = LX + 28 I = LX + 29 580 M = J + 8 DO 590 K = J, M, 8 X = A(K) + A(I) A(K) = X A(I) = X I = I + 8 590 CONTINUE 600 J = LX + 27 DO 610 I = 1, 4 G(I) = A(J + 8) / MAX (A(J), 0.01) J = J + 1 610 CONTINUE IF (LZ .LT. LD + 3) LZ = LD + 3 T = ABS(A(26)) S = T DO 620 I = 5, 14 IP(I) = 0 G(I) = T T = T + 0.1 620 CONTINUE I = LX + 4 K = LH - 2 IF (LD .LE. LH) THEN WRITE (LI, 99982) S GOTO 760 ENDIF 630 M = 1 640 K = K + 4 IF (K .LE. LD) THEN Q = A(K + 1) DO 650 L = 5, 14 IF (Q .GT. G(L)) IP(L) = IP(L) + 1 650 CONTINUE I = I + 4 A(I) = A(K) F(M) = A(K) F(M + 1) = A(K + 2) + Q F(M + 2) = A(K + 3) A(I + 1) = F(M + 1) M = M + 3 A(I + 2) = -1.0 A(I + 3) = A(K + 3) IF (M .LT. 126) GOTO 640 WRITE (LF) F GOTO 630 ENDIF LD = I F(M) = 0.0 WRITE (LF) F CALL GEN108 (LF, 0) WRITE (LI, 99983) (G(I), I = 5, 14), (IP(I), I = 5, 14) WRITE (LI, 99984) (G(I), I = 1, 4) WRITE (LI, 99981) P = 2.0 * A(52) Q = 114.59 * ATAN2(SQRT(A(53)), SQRT(ABS(1.0 - A(53)))) J = INT(AINT(A(29) * 0.1)) U = A(29) - 10.0 * FLOAT(J) WRITE (LI, 99980) A(26), A(27), A(28), U, J, P, Q IF (ABS(A(39)) .GE. 0.5) THEN J = INT(A(40)) K = INT(A(41)) Q = AMOD(ABS(A(41)), 1.0) WRITE (LI, 99978) A(39), J, K, Q, A(42) L = INT(A(43)) M = INT(A(44)) WRITE (LI, 99977) L, M ENDIF I = INT(A(54)) IF (I .EQ. 2) I = 6 J = INT(A(57)) WRITE (LI, 99975) I, J, A(58), A(59) L = LX + 4 660 L = L + 4 IF (L .LE. LD) THEN A(L) = ABS(A(L)) A(L + 3) = 0.0 GOTO 660 ENDIF LJ = LL - 1 IF (IABS(JJ - 1) .LT. 2) GOTO 750 IF (LX .NE. LV) THEN M = 0 CALL GEN074 (F, 0.0, 1, 3) I = LX + 4 670 I = I + 4 IF (I .LE. LD) THEN R = AMOD(A(I + 1), 10.0) CALL GEN046 (A(I), X, Y, Z) X = X * GL(6) Y = Y * GL(6) Z = Z * GL(6) O = 0.0 P = 0.0 J = LV 680 J = J + 8 IF (J .LE. LX) THEN K = INT(0.001 * A(J + 1)) * 5 + LJ Q = A(K) * A(J + 5) DO 690 K = 65, LY, 12 U = X * A(K) + Y * A(K + 3) + Z * A(K + 6) V = X * A(K + 1) + Y * A(K + 4) + Z * A(K + 7) W = X * A(K + 2) + Y * A(K + 5) + Z * A(K + 8) T = U * A(J + 2) + V * A(J + 3) + W * A(J + 4) 1 + X * A(K + 9) + Y * A(K + 10) + Z * A(K + 11) O = O + Q * SIN(T) P = P + Q * COS(T) 690 CONTINUE GOTO 680 ENDIF O = O * A(23) Q = SQRT(O * O + P * P) IF (Q .GE. 1.E-6) THEN A(I + 2) = GL(5) * ATAN2(O, P) IF (A(I + 2) .LT. 0.0) A(I + 2) = A(I + 2) + 360.0 IF (R .GE. A(32)) THEN F(1) = F(1) + R * R F(2) = F(2) + R * Q F(3) = F(3) + Q * Q M = M + 1 A(I + 3) = Q / R ENDIF ENDIF GOTO 670 ENDIF J = (LX - LV) / 8 R = SQRT(ABS(1.0 - F(2) * F(2) / (F(1) * F(3)))) WRITE (LI, 99974) R, J, M, A(32) ENDIF IF (ABS(A(39)) .LE. 0.5) THEN IF (AP .LE. 0.5) THEN IF (LE .LT. LQ + 4) GOTO 750 ENDIF ENDIF I = LX + 4 700 I = I + 4 IF (I .LE. LD) THEN A(I + 3) = AMOD(A(I + 1), 10.0) GOTO 700 ENDIF N = (LD - NA) / 4 M = 1 710 M = 3 * M + 1 IF (M .LT. N) GOTO 710 720 M = M / 3 N = 4 * M NJ = NA + N NI = NJ + 4 DO 740 I = NI, LD, 4 Q = A(I) R = A(I + 1) S = A(I + 2) T = A(I + 3) J = I 730 K = J - N IF (A(K + 3) .LE. T) THEN A(J) = A(K) A(J + 1) = A(K + 1) A(J + 2) = A(K + 2) A(J + 3) = A(K + 3) J = K IF (J .GT. NJ) GOTO 730 ENDIF A(J) = Q A(J + 1) = R A(J + 2) = S A(J + 3) = T 740 CONTINUE IF (M .GT. 2) GOTO 720 750 LZ = NA RETURN 760 IER = 1 RETURN 99999 FORMAT (3I4, 2F8.2) 99998 FORMAT (//, I8, 2X, 'Reflections Read, of Which', I6, ' Rejected' 1 //, 3X, 'Maximum H, K, L and 2-Ttheta=', 3F6.0, F8.2) 99991 FORMAT (/I8, ' Unique Reflections, of Which', I7, 2X, 1 'Observed', //, 3X, 'R(int) =', F7.4, 5X, 2 'R(sigma) =', F7.4, 6X, 'Friedel Opposites Merged') 99990 FORMAT (///, 'Number of Unique Data as a Function of Resolution ', 1 'in Angstroms', //, ' Resolution inf', 13F8.2) 99989 FORMAT (/, 'N(observed) ', 13F8.0) 99988 FORMAT (/, 'N(measured) ', 13F8.0) 99987 FORMAT (/, 'N(theory) ', 13F8.0) 99986 FORMAT (/, 'Two-Ttheta 0.0', 13F8.1) 99984 FORMAT (//, 19X, 'Centric Acentric 0KL H0L HK0', 1 6X, 'Rest', //, 'Mean abs(E*E-1) 0.968 0.736', 2 4F9.3) 99983 FORMAT (///, 'Observed E .gt. ', 10F6.3, //, ' Number', 1 8X, 10I6) 99982 FORMAT (/, '** No Observed E Above', F7.3) 99981 FORMAT (/, 6X, 'Summary of Parameters', /) 99980 FORMAT ('ESEL EMIN', F7.3, 3X, 'EMAX', F7.3, 3X, 'DELU', F6.3, 1 3X, 'RENORM', F6.3, 3X, 'AXIS', I2, /, 2 'OMIT S', F6.2, 3X, '2THETA(MAX)', F7.1) 99978 FORMAT ('TREF NP', F10.0, 3X, 'NE', I6, 3X, 'NTAN', I4, 1 ' TW', F7.3, 3X, 'WN', F7.3) 99977 FORMAT ('SUBS TYPE', I4, 3X, 'NS', I5) 99975 FORMAT ('FMAP CODE', I3, /, 'PLAN NPEAKS', I5, 1 3X, 'DEL1', F6.3, 3X, 'DEL2', F6.3) 99974 FORMAT (///, 'RE =', F7.4, ' for', I4, ' Atoms and', 1 I5, ' E Greater Than', F7.3) END SUBROUTINE PLA157 (IER) PARAMETER (NPVD=40000000,NP23=18000,NPP=NPVD+2*NP23) COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB, 1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11) COMMON // A(NPP) DIMENSION IP(27) NQ = 0 CALL GEN097 (IP, 1, 27, 0) NC = 0 NT = 0 NA = LZ IF (ABS(A(39)) .LT. 0.5) GOTO 840 IF (ABS(ABS(A(54)) - 1.5) .LT. 0.8) GOTO 840 A(22) = A(43) A(28) = 0.0 PA = 0.1 PS = 0.1 PF = 0.1 NF = 1 NB = NA NY = INT (MAX (ABS(A(40)), 10.0)) NZ = MIN (LD, INT(0.5 * (ABS(A(44)) + FLOAT(NY)) + 1.1) * 4 1 + LX) MT = INT(A(43)) I = NA J = NA IF (MT .EQ. 5) GOTO 10 IF (MT .GT. 3) GOTO 30 IF (MT .LT. 1) GOTO 30 10 I = I + 4 IF (I .LE. LD) THEN CALL GEN046 (A(I), F(1), F(2), F(3)) F(5) = AMOD(ABS(F(1)) + 0.1, 2.0) + AMOD(ABS(F(2)) + 0.1, 2. ) + 1 AMOD(ABS(F(3)) + 0.1, 2.0) IF (ABS(F(MT)) .GT. 0.5) GOTO 10 K = I + 3 DO 20 L = I, K P = A(L) A(L) = A(J + 4) A(J + 4) = P J = J + 1 20 CONTINUE GOTO 10 ENDIF NZ = MIN (NZ, J) 30 MA = LX + 4 NS = 0 ME = LD + 4 IF (MT .GE. 0) GOTO 440 N = MIN (LX + 4 - 4 * MT, NZ) I = NA J = MIN (NZ - 4 * MT, LD) 40 I = I + 4 IF (I .GT. N) GOTO 440 K = I + 3 DO 50 L = I, K P = A(L) A(L) = A(J) A(J) = P J = J + 1 50 CONTINUE J = J - 8 IF (J .GT. NZ) GOTO 40 NZ = NZ - 4 N = MIN (N, NZ) GOTO 40 60 L = NA MB = NT + ((NZ - LX) / 4) - 3 70 L = L + 4 IF (L .GT. NZ) GOTO 240 R = AMOD(A(L + 1), 10.0) * A(45) NQ = MB IZ = (L - LX - 4) / 4 W = A(L) - 0.5 80 PQ = 0.0001 RR = 0.0001 Q = 1.0 PI = 0.0 NN = NT+2 I = ME K = I MZ = NT 90 J = MZ 100 MZ = K + 2 * ((J - K) / 4) IF (A(MZ) .GT. W) GOTO 90 K = MZ IF (J .GT. K + 2) GOTO 100 W = W + 1.0 110 I = I + 2 120 IF (I .GE. J) GOTO 150 X = W - A(I) - A(J) IF (X .GT. 1.0) GOTO 110 IF (X .LE. 0.0) THEN J = J - 2 GOTO 120 ENDIF 130 NI = INT(A(I + 1) * Q) NJ = INT(A(J + 1)) IF (IABS(NJ) .LE. IABS(NI)) THEN K = NI NI = NJ NJ = K ENDIF IF (A(23) .LE. 0.5) THEN NJ = - IABS(NJ) NI = IABS(NI) ENDIF IF (NI + NJ .NE. 0) THEN N = IABS(NJ) M = IABS(NI) IF (M .NE. IZ) THEN IF (N .NE. IZ) THEN IF (NS .NE. 2) THEN IF (NS .NE. 4) THEN K = N * 4 + LX + 5 NK = M * 4 + LX + 5 P =(AMOD(A(K), 10.0) * AMOD(A(NK), 10.0))**2 PQ = PQ + P IF (NS .EQ. 1) THEN N = N + NT + 1 A(N) = A(N) + P M = M + NT + 1 A(M) = A(M) + P ENDIF GOTO 140 ENDIF ENDIF IF (NQ + 3 .GT. NPP) GOTO 850 NQ = NQ + 2 A(NQ) = FLOAT(NI) Y = AMOD(ABS(A(I + 1)), 1.0) IF (Q .LT. 0.0) Y = AMOD(1.008 - Y, 1.0) A(NQ + 1) = SIGN(FLOAT(N) + AMOD(ABS(A(J + 1)) + Y, 1.0), 1 FLOAT(NJ)) ENDIF ENDIF ENDIF 140 IF (Q .LT. 0) THEN GOTO 160 ELSE GOTO 110 ENDIF 150 Q = - 1.0 I = ME J = MZ 160 I = I + 2 170 X = W + A(I) - A(J) IF (X .LT. 0.0) GOTO 160 IF (X .LT. 1.0) GOTO 130 J = J + 2 IF (J .LT. NN) GOTO 170 IF (NS .NE. 3) THEN IF (NS .GT. 0) GOTO 180 ENDIF A(L + 3) = R * SQRT(PQ) GOTO 70 180 IF (NS .EQ. 1) GOTO 270 I = MB 190 I = I + 2 IF (I .LE. NQ) THEN Q = 1.0 N = IABS(INT(A(I))) NI = 4 * N + LX + 5 M = IABS(INT(A(I + 1))) NJ = 4 * M + LX + 5 J = I 200 J = J + 2 210 IF (J .LE. NQ) THEN IF (IABS(INT(A(J))) .NE. N) GOTO 200 IF (IABS(INT(A(J + 1))) .NE. M) GOTO 200 Q = Q + 1.0 T = A(J) V = A(J + 1) A(J) = A(NQ) A(J + 1) = A(NQ + 1) NQ = NQ - 2 IF (A(L + 1) .LT. 10.0) GOTO 200 K = 720 + INT(12.0 * AMOD(ABS(A(I + 1)), 1.0)) 1 - INT(12.0 * AMOD(ABS(V), 1.0)) IF (A(I) * T .LE. 0.0) THEN IF (A(NI) .LT. 10.0) GOTO 210 K = K + INT(SIGN(0.1 * A(NI), A(I))) ENDIF IF (A(I + 1) * V .LE. 0.0) THEN IF (A(NJ) .LT. 10.0) GOTO 210 K = K + INT(SIGN(0.1 * A(NJ), A(I + 1))) ENDIF IF (MOD(K, 12) .NE. 0) Q = -9.E5 GOTO 210 ENDIF IF (Q .LT. 0.0) GOTO 190 IF (NS .EQ. 4) THEN IF (M .LE. IZ) THEN PA = PA + 1.0 IF (L .LE. NC) PS = PS + 1.0 ENDIF ENDIF Q = SQRT(Q) X = AMOD(A(NJ), 10.0) * AMOD(A(NI), 10.0) IF (NJ .EQ. NI) Q = Q * (X - 1.0) / X RR = RR + (X * Q)**2 A(I) = SIGN(ABS(A(I)) + Q * 0.1, A(I)) X = X * Q * R Y = X * SQRT(2.0 - A(23)) Y = MIN (Y * (0.5658 + Y * (Y * 0.0106 - 0.1304)), 1 Y / (0.56 + Y)) PQ = PQ + X * (X + 2.0 * Y * PI) PI = PI + X * Y GOTO 190 ENDIF A(L + 3) = SQRT(PQ) IF (NS .NE. 2) THEN NQ = NQ + 2 A(NQ) = 0.0 A(NQ + 1) = FLOAT(IZ) I = MB 220 I = I + 2 IF (I .LE. NQ) THEN F(NF) = A(I) F(NF + 1) = A(I + 1) NF = NF + 2 IF (NF .GE. 126) THEN WRITE (LB) F NF = 1 ENDIF GOTO 220 ENDIF IF (PA .GT. 2.0 * PS + 0.5) GOTO 520 GOTO 70 ENDIF A(28) = A(28) + A(L + 3)**2 I = MB 230 I = I + 2 IF (I .LE. NQ) THEN IF (L .LE. NB) THEN IF (INT(ABS(A(I + 1))) .LT. IZ) PF = PF + 1.0 ENDIF MB = MB + 2 A(MB) = A(I) A(MB + 1) = A(I + 1) GOTO 230 ENDIF MB = MB + 2 IF (MB .GT. NPP - 2000) GOTO 850 A(MB) = 0.0 MB = MB + 1 A(MB) = FLOAT(IZ) MB = MB + 1 A(MB) = A(L + 3) A(MB + 1) = 125.0 / RR GOTO 70 240 IF (NS .NE. 0) GOTO 290 NS = 1 IF (IABS(MT - 2) .NE. 2) GOTO 290 IZ = 0 I = NT + 2 CALL GEN074 (A, 1.0, I, MB) 260 READ (LA) F NF = - 2 270 NF = NF + 3 IF (NF .GT. 124) GOTO 260 IF (0.5 .LE. F(NF)) THEN CALL GEN046 (F(NF), X, Y, Z) R = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) 1 + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19) IF (0.005 .GT. R) GOTO 270 IF (EXP(2.0 * R / A(1)**2) * F(NF + 2) .GT. 0.65 + 0.05 * A(23)) 1 GOTO 270 W = F(NF) - 0.5 GOTO 80 ENDIF I = LX + 4 CALL GEN108 (LA, 0) J = NT + 1 280 I = I + 4 IF (I .LE. NZ) THEN J = J + 1 A(I + 3) = A(I + 3) * A(J) GOTO 280 ENDIF 290 IF (NS .EQ. 1) THEN IF (MT .GT. 6) THEN T = FLOAT(6 - MT) / A(1)**2 I = NA 300 I = I + 4 IF (I .LE. NZ) THEN CALL GEN046 (A(I), X, Y, Z) A(I + 3) = A(I + 3) * EXP(T * (X * X * A(14) 1 + Y * Y * A(15) + Z * Z * A(16) + Y * Z * A(17) 2 + X * Z * A(18) + X * Y * A(19))) GOTO 300 ENDIF ENDIF NB = NA NC = LX + 4 * INT(ABS(A(44)) + 1.1) 310 Q = 0.01 I = NB 320 I = I + 4 IF (I .LE. NZ) THEN IF (Q .LE. A(I + 3)) THEN Q = A(I + 3) M = I ENDIF GOTO 320 ENDIF IF (Q .GE. 0.1) THEN K = M + 3 DO 330 I = M, K P = A(I) A(I) = A(NB + 4) A(NB + 4) = P NB = NB + 1 330 CONTINUE IF (NB .LT. NC) GOTO 310 ENDIF I = NB NZ = MIN (NZ, NC) 340 I = I + 4 IF (I .LE. LD) THEN A(I + 3) = AMOD(A(I + 1), 10.0) GOTO 340 ENDIF N = (LD - NB) / 4 M = 1 350 M = 3 * M + 1 IF (M .LT. N) GOTO 350 360 M = M / 3 N = 4 * M NJ = NB + N NI = NJ + 4 DO 380 I = NI, LD, 4 Q = A(I) R = A(I + 1) S = A(I + 2) T = A(I + 3) J = I 370 K = J - N IF (A(K + 3) .LE. T) THEN A(J) = A(K) A(J + 1) = A(K + 1) A(J + 2) = A(K + 2) A(J + 3) = A(K + 3) J = K IF (J .GT. NJ) GOTO 370 ENDIF A(J) = Q A(J + 1) = R A(J + 2) = S A(J + 3) = T 380 CONTINUE IF (M .GT. 2) GOTO 360 NS = 2 NZ = NB MB = NT IF (MT .NE. 0) GOTO 440 ENDIF IF (NS .EQ. 2) THEN K = MB + 3 A(K - 1) = 0.0 A(K) = 0.0 J = NT + 2 DO 390 I = J, K A(ME) = A(I) ME = ME + 1 390 CONTINUE NS = 3 NC = MIN (LD, LX + 4 + 4 * NY) GOTO 430 ENDIF IF (NS .NE. 3) GOTO 520 NF = 1 NC = NB 400 Q = 0.01 I = NC 410 I = I + 4 IF (I .LE. NZ) THEN IF (Q .LE. A(I + 3)) THEN Q = A(I + 3) M = I ENDIF GOTO 410 ENDIF IF (Q .GE. 0.1) THEN K = M + 3 DO 420 I = M, K P = A(I) A(I) = A(NC + 4) A(NC + 4) = P NC = NC + 1 420 CONTINUE IF (NC .LT. LX + 4 + 4 * NY) GOTO 400 ENDIF NS = 4 430 NZ = NC 440 L = MA NT = ME A(NT) = 0.0 P = 0.0 450 L = L + 4 NG = NT P = P + 1.0 CALL GEN046 (A(L), X, Y, Z) DO 470 M = 65, LY, 12 W = AINT(1.001 * (X * A(M) + Y * A(M + 3) + Z * A(M + 6))) 1 + 200.0 * (AINT(1.001 * (X * A(M + 1) + Y * A(M + 4) 2 + Z * A(M + 7))) + 200.0 * AINT (1.001 * (X * A(M + 2) 3 + Y * A(M + 5) + Z * A(M + 8)))) Q = 1.0 - A(23) * (1.0 - SIGN(1.0, W)) W = ABS(W) J = NG 460 J = J + 2 IF (J .LE. NT) THEN IF (ABS(W - A(J)) .GT. 0.5) THEN GOTO 460 ELSE GOTO 470 ENDIF ENDIF NT = NT + 2 A(NT) = W A(NT + 1) = Q * (P + AMOD (900.004 - Q * (X * A(M + 9) 1 + Y * A(M + 10) + Z * A(M + 11)), 1.0)) 470 CONTINUE IF (NT .GT. NPP - 3000) GOTO 850 IF (L .LT. NZ) GOTO 450 N = (NT - ME) / 2 M = 1 480 M = 3 * M + 1 IF (M .LT. N) GOTO 480 490 M = M / 3 N = M * 2 NJ = ME + N NI = NJ + 2 DO 510 I = NI, NT, 2 Q = A(I) T = A(I + 1) J = I 500 K = J - N IF (A(K) .GE. Q) THEN A(J) = A(K) A(J + 1) = A(K + 1) J = K IF (J .GT. NJ) GOTO 500 ENDIF A(J) = Q A(J + 1) = T 510 CONTINUE IF (M .GT. 2) GOTO 490 IF (NS .EQ. 0) GOTO 60 L = NA MB = NT IF (NS .GT. 2) THEN NZ = MIN (LD, NC + 2 * NY) IF (NS .EQ. 4) THEN L = MA NZ = NC IF (A(41) .LT. 0.0) NZ = LD A(41) = ABS(A(41)) ENDIF ENDIF GOTO 70 520 F(NF) = 0.0 F(NF + 1) = 0.0 WRITE (LB) F CALL GEN108 (LB, 0) J = (NB - LX - 4) / 4 WRITE (LI, 99998) J, PF J = (NC - LX - 4) / 4 WRITE (LI, 99999) J, PS, IZ, PA NY = NT + 4 M = LD - 1 NQ = M IF (A(42) .GE. 0.9999) THEN IF (A(44) .GT. 0.0) GOTO 830 ENDIF R = 0.75 + 0.05 * A(23) A(NT + 2) = 9.E9 NQ = NT + 3 A(NQ) = -1.0 MZ = INT(MIN(0.3 * FLOAT(NPP) + 0.7 * FLOAT(NQ), FLOAT(NQ) 1 + 10000.0)) 530 READ (LA) F I = -2 540 I = I + 3 IF (I .GT. 124) GOTO 530 IF (0.5 .LE. F(I)) THEN CALL GEN046 (F(I), X, Y, Z) P = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) 1 + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19) IF (0.005 .GT. P) GOTO 540 P = EXP(2.0 * P / A(1)**2) * F(I + 2) IF (P .GT. R) GOTO 540 M = NQ DO 560 N = 65, LY, 12 Q = ABS(AINT(1.001 * (X * A(N) + Y * A(N + 3) 1 + Z * A(N + 6))) + 200.0 * (AINT(1.001 * (X * A(N + 1) 2 + Y * A(N + 4) + Z * A(N + 7))) + 200.0 * AINT(1.001 * 3 (X * A(N + 2) + Y * A(N + 5) + Z * A(N + 8))))) J = M 550 J = J + 2 IF (J .LE. NQ) THEN IF (ABS(Q - A(J)) .LT. 0.5) THEN GOTO 560 ELSE GOTO 550 ENDIF ENDIF NQ = NQ + 2 A(NQ) = Q A(NQ + 1) = P 560 CONTINUE 570 IF (NQ .LT. MZ) GOTO 540 R = R - 0.01 J = NT + 3 K = NQ NQ = J 580 J = J + 2 IF (J .GT. K) GOTO 570 IF (A(J + 1) .LE. R) THEN NQ = NQ + 2 A(NQ) = A(J) A(NQ + 1) = A(J + 1) ENDIF GOTO 580 ENDIF CALL GEN108 (LA, 0) NY = NQ + 1 N = (NQ - NT - 3) / 2 M = 1 590 M = 3 * M + 1 IF (M .LT. N) GOTO 590 600 M = M / 3 N = M + M NJ = NT + 3 + N NI = NJ + 2 DO 620 I = NI, NQ, 2 Q = A(I) T = A(I + 1) J = I 610 K = J - N IF (A(K) .GE. Q) THEN A(J) = A(K) A(J + 1) = A(K + 1) J = K IF (J .GT. NJ) GOTO 610 ENDIF A(J) = Q A(J + 1) = T 620 CONTINUE IF (M .GT. 2) GOTO 600 A(NQ + 2) = 9.E9 MZ = 5 * MIN ((NPP - NQ - 111) / 13, 1000) + NQ + 10 NY = MAX (MZ + 1, NY) PZ = 0.0 M = NQ + 2 MP = M + 5 KZ = 0 NI = NT + 2 JN = NI + 1 NL = 0 L = LX + 4 630 L = L + 4 IF (L .GT. NC) GOTO 820 NL = NL + 1 I = NQ + 2 N = MZ NU = -1 S = 1.0 Q = -1.0 R = A(L) X = A(NQ) - R + 0.5 J = ME + 2 IF (X .GE. A(J)) THEN NM = NT 640 K = NM 650 NM = J + 2 * ((K - J) / 4) IF (A(NM) .GT. X) GOTO 640 J = NM IF (K .GT. J + 2) GOTO 650 ENDIF 660 I = I - 2 670 X = A(J) - A(I) + R IF (X .LT. -0.5) GOTO 660 IF (X .LT. 0.5) GOTO 790 J = J - 2 IF (J .GT. ME) GOTO 670 S = -1.0 NU = 0 680 J = J + 2 690 X = R - A(I) - A(J) IF (X .GT. 0.5) GOTO 680 IF (X .GT. -0.5) GOTO 790 I = I - 2 IF (I .GT. JN) GOTO 690 Q = 1.0 NU = 1 700 I = I + 2 710 X = R + A(I) - A(J) IF (X .LT. -0.5) GOTO 700 IF (X .LT. 0.5) GOTO 790 J = J + 2 IF (J .LT. NI) GOTO 710 720 J = MZ 730 J = J + 3 IF (J .GT. N) GOTO 630 S = A(J) + R I = J + 3 K = N + 3 740 K = K - 3 750 IF (K .LE. I) GOTO 730 X = S + A(I) + A(K) IF (X .LT. -0.5) GOTO 740 IF (X .LT. 0.5) GOTO 760 I = I + 3 GOTO 750 760 G(1) = FLOAT(NL) + AMOD(ABS(A(I + 1)) + ABS(A(J + 1)) 1 + ABS(A(K + 1)), 1.0) G(2) = A(J + 1) G(3) = A(I + 1) G(4) = A(K + 1) KZ = KZ + 1 P = 2.0 - A(I + 2) - A(J + 2) - A(K + 2) DO 770 NJ = 1, 4 NM = INT(ABS(G(NJ))) * 4 + LX + 5 P = P * AMOD(A(NM), 10.0) 770 CONTINUE IF (P .LT. PZ) GOTO 740 IF (M .LT. MP) M = MP A(MP) = P A(MP + 1) = G(1) A(MP + 2) = G(2) A(MP + 3) = G(3) A(MP + 4) = G(4) IF (M .GE. MZ - 8) THEN PZ = P NJ = NQ + 2 780 NJ = NJ + 5 IF (NJ .GT. M) GOTO 740 IF (A(NJ) .LE. PZ) THEN PZ = A(NJ) MP = NJ ENDIF GOTO 780 ENDIF MP = MP + 5 GOTO 740 790 NM = INT(ABS(A(J + 1))) IF (NM .LT. NL) THEN K = MZ 800 K = K + 3 IF (K .LE. N) THEN IF (NM .EQ. INT(ABS(A(K + 1)))) GOTO 810 GOTO 800 ENDIF IF (N .GT. NPP - 5) GOTO 720 N = N + 3 IF (NY .LT. N + 2) NY = N + 2 A(N) = A(J) * S X = AMOD(ABS(A(J + 1)), 1.0) IF (S .LT. 0.0) X = AMOD(1.008 - X, 1.0) A(N + 1) = SIGN(AINT(ABS(A(J + 1))) + X, A(J + 1) * S) A(N + 2) = A(I + 1)**2 ENDIF 810 IF (NU .LT. 0) THEN GOTO 660 ELSE IF (NU .EQ. 0) THEN GOTO 680 ELSE GOTO 700 ENDIF 820 I = (M - NQ) / 5 A(43) = 64.0 * A(45) / SQRT(FLOAT(I) + 24.0) IF (I .EQ. 0) A(43) = 0.0 WRITE (LI, 99997) KZ, I 830 LZ = M LQ = NQ + 2 N = ((M - LQ) / 5) * 8 + M + 5 IF (N .GT. NY) NY = N A(27) = PF A(29) = FLOAT(ME) LR = NB LH = NC 840 LE = NA RETURN 850 IER = 1 RETURN 99999 FORMAT (/, I6, ' Large E-Values Refined Using', F9.0, 1 ' Unique TPR', /, I6, ' Reflections and', F9.0, 2 ' Unique TPR for R(alpha)') 99998 FORMAT (//, I6, ' Subset Reflections and', 1 F8.0, ' Unique TPR for Filter') 99997 FORMAT (/, I8, ' Negative Quartets Found,', I5, ' Used') END SUBROUTINE PLA158 PARAMETER (NPVD=40000000,NP23=18000,NPP=NPVD+2*NP23) C * TANGENT REFINEMENT COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB, 1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11) COMMON // A(NPP) COMMON /WORDD/ IH(20), IR DIMENSION IP(20), ID(31), SN(15), B(64), C(64), D(126), 1 E(126), FB(64), FC(64), FD(64), FE(64), PM(64), PR(64) CHARACTER IH*1, IR*80 NG = 0 RR = 1.E8 W = 0.0 S = 0.0 NA = LE IF (ABS(A(39)) .LT. 0.5) GOTO 810 TW = AMOD(A(41), 1.0) MB = -1 IF (A(27) .LT. 0.5) MB = 0 IF (MB .NE. 0) TW = 5.0 * TW ME = INT(A(29)) NB = LR NC = LH NI = ME + 1 NJ = (NC - LX - 4) / 4 + ME CALL GEN074 (A, 0.1, NI, NJ) MP = LZ + 5 NE = MP A(NE) = 0.0 J = LQ 20 J = J + 5 IF (J .LE. LZ) THEN K = J + 3 DO 30 L = J, K M = INT(ABS(A(L + 1))) NE = NE + 2 A(NE) = - FLOAT(M) A(NE + 1) = FLOAT(J) M = M + ME A(M) = A(M) + 2.0 30 CONTINUE GOTO 20 ENDIF ML = MP DO 40 I = NI, NJ J = INT(A(I)) A(I) = FLOAT(ML) ML = ML + J 40 CONTINUE I = MP 50 I = I + 2 IF (I .LE. NE) THEN 60 IF (A(I) .GT. 0.0) GOTO 50 M = INT(0.1 - A(I)) + ME A(M) = A(M) + 2.0 M = INT(A(M)) Q = A(M) A(M) = - A(I) IF (I .EQ. M) GOTO 50 A(I) = Q Q = A(M + 1) A(M + 1) = A(I + 1) A(I + 1) = Q GOTO 60 ENDIF L = 0 NF = 1 K = LX + 4 70 K = K + 4 IF (K .LE. NC) THEN L = L + 1 NJ = L + ME NJ = INT(A(NJ)) 80 IF (INT(A(NJ)) .LT. L) GOTO 70 J = INT(A(NJ + 1)) NJ = NJ - 2 T = AMOD(A(J + 1), 1.0) W = AINT(A(J + 1)) X = AINT(A(J + 2)) Y = AINT(A(J + 3)) Z = AINT(A(J + 4)) 90 IF (INT(ABS(W)) .EQ. L) THEN S = SIGN(1.0, W) G(NF) = T + FLOAT(L) G(NF + 1) = S * X G(NF + 2) = S * Y G(NF + 3) = S * Z NF = NF + 4 IF (NF .GE. 122) THEN WRITE (LG) G NF = 1 ENDIF GOTO 80 ENDIF S = W W = X X = Y Y = Z Z = S GOTO 90 ENDIF G(NF) = 0.0 WRITE (LG) G CALL GEN108 (LG, 0) WF = 0.0 MS = ME - 3 IF (MB .NE. 0) THEN IF (A(44) .LE. 0.0) THEN M = (NB - LX - 4) / 4 N = LZ LZ = LQ I = LQ 100 I = I + 5 IF (I .LE. N) THEN IF (INT(A(I + 1)) .LE. M) THEN LZ = LZ + 5 A(LZ) = A(I) A(LZ + 1) = A(I + 1) A(LZ + 2) = A(I + 2) A(LZ + 3) = A(I + 3) A(LZ + 4) = A(I + 4) ENDIF GOTO 100 ENDIF 110 Q = - 1.0 N = 0 I = LQ 120 I = I + 5 IF (I .LE. LZ) THEN IF (A(I) .GE. Q) THEN N = I Q = A(I) ENDIF GOTO 120 ENDIF IF (N .NE. 0) THEN ME = ME + 4 A(ME - 3) = A(N + 1) A(ME - 2) = A(N + 2) A(ME - 1) = A(N + 3) A(ME) = A(N + 4) Q = 1.0 K = ME - 3 DO 130 I = K, ME J = INT(ABS(A(I))) * 4 + LX + 5 Q = Q * AMOD(A(J), 10.0) 130 CONTINUE WF = WF + Q LQ = LQ + 5 A(N) = A(LQ) A(N + 1) = A(LQ + 1) A(N + 2) = A(LQ + 2) A(N + 3) = A(LQ + 3) A(N + 4) = A(LQ + 4) IF (ME .LT. MS + 400) GOTO 110 ENDIF ENDIF ENDIF I = (ME - MS) / 4 WRITE (LI, 99999) I TS = 0.0 TZ = 0.0 NS = ME I = LX + 4 140 I = I + 4 IF (I .LE. LD) THEN TS = TS + A(I + 3) TZ = TZ + A(I + 3)**2 / (A(I + 3) + 5.0) IF (I .LE. NC) THEN IF (A(23) .GE. 0.5) THEN IF (A(I + 1) .LT. 10.0) GOTO 140 IF (A(I + 1) .LT. 120.0) GOTO 140 IF (A(I + 1) .GT. 130.0) GOTO 140 ENDIF IF (NS - ME .LE. 64) THEN CALL GEN046 (A(I), X, Y, Z) IF (AMOD(900.1 + Z, 2.0) + AMOD(98.1 + Y, 2.0) + 1 AMOD(98.1 + X, 2.0) .LE. 0.5) THEN NS = NS + 1 A(NS) = FLOAT((I - LX - 4) / 4) J = INT(X) K = INT(Y) L = INT(Z) T = AMOD(A(I + 1), 10.0) ENDIF ENDIF ENDIF GOTO 140 ENDIF NQ = 1 MQ = 1 IF (A(39) .GE. 0.0) THEN X = 2.0 * FLOAT(NPP - NS) I = INT(A(39) - 0.5) NQ = MIN (64, I + 1, INT(X / FLOAT(NC - LX - 4))) K = I + NQ NQ = I / (K / NQ) + 1 MQ = MIN (126, INT(X / FLOAT(NB - LX - 4)), (1 - MB) * NQ) ENDIF ML = NS + MAX (((NC - LX - 4) / 2) * NQ, 1 ((NB - LX - 4) / 2) * MQ) I = - MQ * MB MT = INT(A(41)) NE = NS + 1 NM = 2 * NQ NL = NE - NM MH = 2 * MQ ML = NE - MH RN = 2097152.0 * AMOD(SQRT(0.4321 * ABS(A(40))), 1.0) PQ = 9.E9 TN = 0.3 PS = 0.0 DO 150 NJ = 1, 15 SN(NJ) = SIN(FLOAT(NJ - 1) * 0.523598) 150 CONTINUE CALL GEN097 (ID, 1, 31, 0) 160 CALL GEN074 (FB, 0.0, 1, NQ) CALL GEN074 (FC, 0.0001, 1, NQ) CALL GEN074 (FD, 0.0, 1, NQ) CALL GEN074 (FE, 0.0, 1, NQ) CALL GEN074 (B , 0.0, 1, NQ) CALL GEN074 (C , 0.0, 1, NQ) CALL GEN074 (PM, 9.E9, 1, NQ) CALL GEN074 (D, -1.E-6, 1, MQ) CALL GEN074 (E, 0.0, 1, MQ) NZ = MB MM = MQ PN = 0.1 170 DO 180 I = 1, MQ RN = AMOD((1.0 + 2.0 * AINT(RN / 2.0 + 0.3)) * 5.0, 2097152.0) F(I) = 0.0 IF (MB .EQ. 0) THEN PM(I) = 0.0 PR(I) = RN ENDIF G(I) = RN 180 CONTINUE IF (A(39) .LT. 0.0) G(1) = - A(39) 190 N = NE M = NB IF (NZ .EQ. 0) M = NC DO 210 I = 1, MM R = G(I) R = AMOD(7169.0 * SQRT(R / 2097152.0), 1.0) K = N L = LX + 4 200 L = L + 4 IF (L .LE. M) THEN P = AMOD(A(L + 1), 10.0) IF (MB .NE. 0) P = P * 0.2 IF (L .GT. NB) P = P * TW R = AMOD((1.0 + 2.0 * AINT(1048576.0 * R + 0.3)) * 5.0, 1 2097152.0) / 2097152.0 Q = R IF (L .LE. NA) Q = A(L + 2) / 360.0 IF (A(23) .LE. 0.5) THEN Q = SIGN(1.0, AMOD(Q + 0.75, 1.0) - 0.5) A(K) = P * Q A(K + 1) = - A(K) ELSE IF (A(L + 1) .GT. 10.0) 1 Q = AMOD(AINT(0.1 * A(L + 1)) / 24.0 + 9.25 - Q, 0.5) 2 - 0.25 + Q Q = Q * 6.28319 A(K) = P * COS(Q) A(K + 1) = P * SIN(Q) ENDIF K = K + MM * 2 GOTO 200 ENDIF N = N + 2 210 CONTINUE MU = 1 IF (MB .EQ. 0) GOTO 240 M = LD + 2 IZ = 5 IF (A(22) .LT. 3.5) GOTO 390 DO 220 K = 65, LY, 12 IF (ABS(A(K + 9)) + ABS(A(K + 10)) + ABS(A(K + 11)) .GT. 0.1) 1 IZ = MIN (IZ + 1, 8) 220 CONTINUE GOTO 390 230 CALL GEN108 (LB, 0) CALL GEN108 (LG, 0) 240 MU = NZ NZ = NZ + 1 IF (NZ .GT. MT) GOTO 710 READ (LG) G NG = 1 MP = 0 250 READ (LB) F M = -1 260 M = M + 2 IF (M .GT. 125) GOTO 250 P = F(M) T = ABS(P) XQ = F(M + 1) Z = ABS(XQ) 270 I = INT(T) * NM + NL J = INT(Z) * NM + NL IF (I .EQ. NL) GOTO 400 IF (MU .EQ. 0) GOTO 260 280 KI = INT(T) * 4 + LX + 5 KJ = INT(Z) * 4 + LX + 5 T = 10.0 * AMOD(T, 1.0) Z = AMOD(Z, 1.0) IF (A(23) .GT. 0.5) GOTO 320 IF (Z .GT. 0.25) J = J + 1 IF (ABS(T - 1.0) .LE. 0.001) THEN DO 290 K = 1, MM D(K) = D(K) + A(I) * A(J) I = I + 2 J = J + 2 290 CONTINUE GOTO 380 ENDIF 300 DO 310 K = 1, MM D(K) = D(K) + T * A(I) * A(J) I = I + 2 J = J + 2 310 CONTINUE GOTO 380 320 R = SIGN(1.0, P) S = SIGN(1.0, XQ) K = INT(12.0 * Z) V = SN(K + 1) * T U = SN(K + 4) * T KJ = INT(0.1 * A(KJ)) IF (KJ .LT. 12) GOTO 360 IF (ABS(V) .GT. 0.001) GOTO 360 KI = INT(0.1 * A(KI)) IF (KI .NE. 12) GOTO 350 T = U IF (KJ .EQ. 12) GOTO 300 IF (KJ .NE. 18) GOTO 360 T = T * S J = J + 1 330 DO 340 K = 1, MM E(K) = E(K) + T * A(I) * A(J) I = I + 2 J = J + 2 340 CONTINUE GOTO 380 350 IF (KI .EQ. 18) THEN T = U * R I = I + 1 IF (KJ .EQ. 12) GOTO 330 T = -T * S J = J + 1 IF (KJ .EQ. 18) GOTO 300 J = J - 1 I = I - 1 ENDIF 360 DO 370 K = 1, MM Y = R * A(I + 1) X = U * A(I) - V * Y Y = U * Y + V * A(I) Q = S * A(J + 1) D(K) = D(K) + X * A(J) - Y * Q E(K) = E(K) + X * Q + Y * A(J) I = I + 2 J = J + 2 370 CONTINUE 380 IF (NZ .GT. 0) GOTO 260 390 M = M + 2 P = A(M) XQ = A(M + 1) T = ABS(P) Z = ABS(XQ) IF (NZ .EQ. 0) GOTO 270 I = INT(T) * MH + ML J = INT(Z) * MH + ML IF (I .GT. ML) GOTO 280 IF (J .GT. ML) THEN GOTO 440 ELSE GOTO 630 ENDIF 400 IF (J .EQ. NL) GOTO 630 IF (NZ .EQ. 0) GOTO 440 IF (MU .EQ. 0) GOTO 450 MP = MP + 1 IF (NZ .EQ. MT) GOTO 410 IF (A(43) .LT. 1.E-6) GOTO 450 410 IF (MP .NE. INT(G(NG))) GOTO 450 N = INT(ABS(G(NG + 1))) * NM + NL K = INT(ABS(G(NG + 2))) * NM + NL L = INT(ABS(G(NG + 3))) * NM + NL IF (A(23) .LE. 0.5) THEN IF (AMOD(G(NG), 1.0) .GT. 0.25) N = N + 1 DO 420 I = 1, NQ B(I) = B(I) + A(N) * A(K) * A(L) N = N + 2 K = K + 2 L = L + 2 420 CONTINUE ELSE I = INT(12.0 * AMOD(G(NG), 1.0)) Q = SN(I + 1) P = SN(I + 4) R = SIGN(1.0, G(NG + 1)) S = SIGN(1.0, G(NG + 2)) T = SIGN(1.0, G(NG + 3)) DO 430 I = 1, NQ U = A(N) * A(K) - A(N + 1) * A(K + 1) * R * S V = A(N) * A(K + 1) * S + A(N + 1) * A(K) * R X = U * A(L) - V * A(L + 1) * T Y = U * A(L + 1) * T + V * A(L) B(I) = B(I) + P * X + Q * Y C(I) = C(I) - P * Y + Q * X N = N + 2 K = K + 2 L = L + 2 430 CONTINUE ENDIF NG = NG + 4 IF (NG .GE. 122) THEN READ (LG) G NG = 1 ENDIF GOTO 410 440 M = M + 2 Z = A(M) RR = A(M + 1) 450 L = 4 * INT(XQ) + LX + 4 K = MU IF (L .GE. NB) MU = 1 IF (K .EQ. 0) GOTO 260 P = AMOD(A(L + 1), 10.0) IF (A(L + 1) .GE. 10.0) THEN Q = 0.261799 * AINT(0.1 * A(L + 1)) U = COS(Q) V = SIN(Q) IF (NZ .LE. 0) THEN DO 460 K = 1, MM X = D(K) * U + E(K) * V E(K) = X * V D(K) = X * U 460 CONTINUE ELSE DO 470 K = 1, NQ X = B(K) * U + C(K) * V Y = D(K) * U + E(K) * V C(K) = X * V E(K) = Y * V B(K) = X * U D(K) = Y * U 470 CONTINUE ENDIF ENDIF T = P * A(45) IF (NZ .GT. 0) Z = A(L + 3) ZG = 1.0 / (Z + 5.0) IF (NZ .EQ. 0) THEN GOTO 530 ELSE IF (NZ .GT. 0) THEN GOTO 560 ENDIF IF (IZ .GT. 0) GOTO 530 IF (A(23) .GT. 0.5) GOTO 510 DO 480 K = 1, MQ F(K) = F(K) + (Z - T * ABS(D(K)))**2 D(K) = -1.E-6 480 CONTINUE GOTO 390 490 DO 500 K = 1, MM W = SIGN(P, D(K)) * MIN (1.0, D(K)**2 * RR) D(K) = -1.E-6 A(J + 1) = -W A(J) = W J = J + 2 500 CONTINUE GOTO 550 510 DO 520 K = 1, MQ F(K) = F(K) + (Z - T * SQRT(D(K)**2 + E(K)**2))**2 E(K) = 0.0 D(K) = -1.E-6 520 CONTINUE GOTO 390 530 IF (A(23) .LT. 0.5) GOTO 490 DO 540 K = 1, MM W = D(K)**2 + E(K)**2 W = P * MIN (1.0, W * RR) / SQRT(W) A(J + 1) = W * E(K) E(K) = 0.0 A(J) = W * D(K) D(K) = - 1.E-6 J = J + 2 540 CONTINUE 550 IF (L .LT. NB) GOTO 390 GOTO 630 560 ZZ = (Z / T)**2 ZT = ZZ IF (A(L + 1) .GT. 10.0) ZT = 9.E9 IF (NZ .GE. MT) THEN IF (A(23) .LE. 0.5) THEN DO 570 K = 1, NQ W = B(K) * D(K) FB(K) = FB(K) + W FC(K) = FC(K) + ABS(W) W = T * ABS(D(K)) FD(K) = FD(K) + ZG * (Z - W)**2 FE(K) = FE(K) + W 570 CONTINUE ELSE DO 580 K = 1, NQ FB(K) = FB(K) + B(K) * D(K) + C(K) * E(K) W = SQRT(D(K)**2 + E(K)**2) FC(K) = FC(K) + W * SQRT(B(K)**2 + C(K)**2) FD(K) = FD(K) + ZG * (Z - W * T)**2 FE(K) = FE(K) + W * T 580 CONTINUE ENDIF IF (L .GT. NC) GOTO 610 ENDIF IF (L .GT. NA) THEN IF (A(23) .GE. 0.5) THEN DO 590 K = 1, NQ U = D(K) - A(43) * B(K) V = E(K) - A(43) * C(K) W = U**2 + V**2 X = D(K)**2 + E(K)**2 IF (X .GE. ZT) THEN X = ZZ / X Y = SIGN(SQRT(ABS(1.0 -X)), B(K) * E(K) - D(K) * C(K)) X = SQRT(X) U = D(K) * X - E(K) * Y V = E(K) * X + D(K) * Y ENDIF W = P / SQRT(W) A(J + 1) = W * V A(J) = W * U J = J + 2 590 CONTINUE ELSE DO 600 K = 1, NQ W = SIGN(P, D(K) - A(43) * B(K)) A(J + 1) = -W A(J) = W J = J + 2 600 CONTINUE ENDIF ENDIF 610 DO 620 K = 1, NQ B(K) = 0.0 C(K) = 0.0 D(K) = -1.E-6 E(K) = 0.0 620 CONTINUE IF (NZ .EQ. MT) GOTO 260 IF (L .LT. NC) GOTO 380 630 IF (NZ .GT. 0) GOTO 230 M = LD + 2 IZ = IZ - 1 IF (IZ .GT. NZ) GOTO 390 IF (NZ .EQ. 0) GOTO 240 J = MS 640 J = J + 4 IF (J .LE. ME) THEN K = INT(A(J)) * MH + ML L = INT(ABS(A(J + 1))) * MH + ML M = INT(ABS(A(J + 2))) * MH + ML N = INT(ABS(A(J + 3))) * MH + ML IF (A(23) .LE. 0.5) THEN IF (AMOD(A(J), 1.0) .GT. 0.25) K = K + 1 DO 650 I = 1, MQ E(I) = E(I) + A(K) * A(L) * A(M) * A(N) K = K + 2 L = L + 2 M = M + 2 N = N + 2 650 CONTINUE GOTO 640 ENDIF I = INT(12.0 * AMOD(A(J), 1.0)) Q = SN(I + 1) P = SN(I + 4) R = SIGN(1.0, A(J + 1)) S = SIGN(1.0, A(J + 2)) T = SIGN(1.0, A(J + 3)) DO 660 I = 1, MQ U = A(K) * A(L) - A(K + 1) * A(L + 1) * R V = A(K) * A(L + 1) * R + A(K + 1) * A(L) X = U*A(M) - V * A(M + 1) * S Y = U*A(M + 1) * S + V * A(M) E(I) = E(I) + P * (X * A(N) - V * A(N + 1) * T) 1 - Q * (Y * A(N + 1) * T + X * A(N)) K = K + 2 L = L + 2 M = M + 2 N = N + 2 660 CONTINUE GOTO 640 ENDIF J = 0 Q = -9.E9 670 DO 680 I = 1, NQ IF (PM(I) .GE. Q) THEN Q = PM(I) M = I ENDIF 680 CONTINUE 690 J = J + 1 IF (J .LE. MQ) THEN P = F(J) / A(28) IF (WF .GT. 0.1) P = P + MAX (0.0, E(J) / WF + 0.25)**2 F(J) = 0.0 E(J) = 0.0 IF (P .GT. Q) GOTO 690 PM(M) = P PR(M) = G(J) Q = P GOTO 670 ENDIF PN = PN + 1.0 IF (A(39) .GE. 0.0) THEN IF (Q .GE. 0.125) THEN IF (PN .LT. 5.0) GOTO 170 ENDIF ENDIF MM = NQ DO 700 I = 1, NQ G(I) = PR(I) 700 CONTINUE NZ = 0 GOTO 190 710 Q = 9.E9 R = 0.0 V = 0.0 T = 0.0 M = 0 DO 720 K = 1, NQ D(K) = FB(K) / FC(K) E(K) = FE(K) / TS C(K) = FD(K) / TZ P = C(K) IF (ABS(FC(K)) .GT. 0.001) P = P + MAX (0.0, D(K) - A(42))**2 I = INT(MIN(31.5, 1.0 + 50.0 * P)) ID(I) = ID(I) + 1 IF (P .LE. Q) THEN Q = P R = C(K) S = D(K) W = PR(K) V = PM(K) T = E(K) M = K ENDIF B(K) = P 720 CONTINUE IF (TN .GE. 0.8) THEN IF (A(40) .GT. 0.0) GOTO 750 ENDIF DO 740 K = 1, NQ J = 1 IR(1:1) = ' ' IF (K .EQ. M) IR(1:1) = '*' L = K + K - 2 + NL N = ME 730 N = N + 1 IF (N .LE. NS) THEN I = INT(A(N)) * NM + L J = J + 1 IR(J:J) = IH(13) IF (A(I) .LT. 0.0) IR(J:J) = IH(12) GOTO 730 ENDIF 740 CONTINUE 750 M = M + M - 2 + NL K = 0 J = 1 IR(1:1) = ' ' N = ME 760 N = N + 1 IF (N .LE. NS) THEN I = INT(A(N)) * NM + M J = J + 1 IR(J:J) = IH(13) IF (A(I) .LT. 0.0) IR(J:J) = IH(12) GOTO 760 ENDIF IF (PQ .GE. Q) THEN I = LX + 4 770 I = I + 4 IF (I .LE. NC) THEN M = M + NM U = -9.E9 IF (ABS(A(M)) + ABS(A(M + 1)) .GT. 0.01) U = 1 57.29578 * ATAN2(A(M + 1) * A(23), A(M)) IF (U .LT. 0.0) U = U + 360.0 A(I + 2) = U GOTO 770 ENDIF PQ = Q PS = W ENDIF TN = TN + FLOAT(NQ) IF (TN .LT. A(39)) GOTO 160 DO 780 I = 1, 31 F(I) = FLOAT(I - 1) * 0.02 780 CONTINUE F(32) = 9.999 WRITE (LI, 99997) (F(I), F(I + 1), ID(I), I = 1, 31) IF (TN .LT. 1.1) TN = 1.1 WRITE (LI, 99998) TN, PS, PQ K = 0 I = NA 790 M = 0 800 I = I + 4 IF (I .LE. NC) THEN K = K + 1 A(I) = ABS(A(I)) IF (A(I + 2) .LT. - 8.E9) GOTO 800 NA = NA + 4 P = A(NA) A(NA) = A(I) A(I) = P P = A(NA + 1) A(NA + 1) = A(I + 1) A(I + 1) = P P = A(NA + 2) A(NA + 2) = A(I + 2) A(I + 2) = P CALL GEN046 (A(NA), X, Y, Z) M = M + 1 IP(M) = K IP(M + 4) = INT(X) IP(M + 8) = INT(Y) IP(M + 12) = INT(Z) IP(M + 16) = INT(A(NA + 2) + 0.5) F(M) = AMOD(A(NA + 1), 10.0) Q = 0.0174533 * A(NA + 2) P = F(M) * COS(Q) Q = F(M) * SIN(Q) GOTO 790 ENDIF IF (M .GT. 0) WRITE (LI, 99996) (IP(J), IP(J + 4), 1 IP(J + 8), IP(J + 12), F(J), IP(J + 16), J = 1, M) M = 0 P = 0.0 810 LE = NA RETURN 99999 FORMAT (//, I4, ' NQR Included in Filter') 99998 FORMAT (//, F10.0, ' Phase Sets Refined - Best Solution is Code', 1 F10.0, ' With CFOM =', F8.4) 99997 FORMAT (//, 'CFOM Range Frequency', /, 1 31(/F6.3, ' - ', F5.3, I7)) 99996 FORMAT (4(I7, '.', 3I4, F6.3, I4)) END SUBROUTINE PLA159 PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NPP=NPVD+2*NP23,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB, 1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11) COMMON // A(NPP) W = 0.0 10 NA = LE NZ = INT(A(54)) IF (NZ .LT. 4) GOTO 240 IF (NZ .EQ. 5) GOTO 240 IF (NA .LE. LX - 4) GOTO 240 NT = LD + 4 A(NT) = 0.0 PQ = 10.0 NB = LX + 4 I = NB 20 I = I + 4 P = AMOD (A(I + 1), 10.0) Q = 1.74533E-2 * A(I + 2) A(I + 2) = P * COS(Q) A(I + 3) = P * SIN(Q) IF (I .LT. NA) GOTO 20 30 IF (NT .LE. NPP - 6) THEN NQ = NT I = NB 40 I = I + 4 IF (I .LE. NA) THEN CALL GEN046 (A(I), X, Y, Z) DO 60 J = 65, LY, 12 P = 6.283185 * (X * A(J + 9) + Y * A(J + 10) 1 + Z * A(J + 11)) U = COS(P) V = SIN(P) P = U * A(I + 2) + V * A(I + 3) Q = U * A(I + 3) - V * A(I + 2) W = AINT(1.001 * (X * A(J) + Y * A(J + 3) + Z * A(J + 6))) 1 + 200.0 * (AINT(1.001 * (X * A(J + 1) + Y * A(J + 4) 2 + Z * A(J + 7))) + 200.0 * AINT(1.001 * (X * A(J + 2) 3 + Y * A(J + 5) + Z * A(J + 8)))) IF (W .LT. 0.0) Q = - Q W = ABS(W) K = NQ 50 K = K + 3 IF (K .LE. NT) THEN IF (ABS(W - A(K)) .LT. 0.5) THEN GOTO 60 ELSE GOTO 50 ENDIF ENDIF NT = NT + 3 A(NT) = W A(NT + 1) = P A(NT + 2) = Q * A(23) IF (NT .GT. NPP - 6) GOTO 70 60 CONTINUE NQ = NT GOTO 40 ENDIF 70 LZ = NT + 3 A(LZ) = 9.E9 M = (LZ - LD) / 3 80 M = M / 2 IF (M .GT. 0) THEN N = M * 3 K = LZ - N J = LD + 4 90 I = J 100 L = I + N IF (A(I) .GE. A(L)) THEN Q = A(L) A(L) = A(I) A(I) = Q Q = A(L + 1) A(L + 1) = A(I + 1) A(I + 1) = Q Q = A(L + 2) A(L + 2) = A(I + 2) A(I + 2) = Q I = I - N IF (I .GT. LD + 4) GOTO 100 ENDIF J = J + 3 IF (J .GT. K) THEN GOTO 80 ELSE GOTO 90 ENDIF ENDIF ENDIF 110 NB = NA S = 0.0 L = NB 120 L = L + 4 IF (L .LE. LD) THEN P = AMOD(A(L + 1), 10.0) U = 0.0 V = 0.0 Z = A(L) - 0.5 Q = 1.0 I = LD + 4 K = I M = NT 130 J = M 140 M = K + 3 * ((J - K) / 6) IF (A(M) .GT. Z) GOTO 130 K = M IF (J .GT. K + 3) GOTO 140 Z = Z + 0.5 150 I = I + 3 160 IF (I .GT. J) GOTO 180 X = Z - A(I) - A(J) IF (X .GT. 0.5) GOTO 150 IF (X .LE. - 0.5) THEN J = J - 3 GOTO 160 ENDIF 170 U = U + A(I + 1) * A(J + 1) - A(I + 2) * A(J + 2) * Q V = V + A(I + 1) * A(J + 2) + A(I + 2) * A(J + 1) * Q IF (Q .LT. 0.0) THEN GOTO 190 ELSE GOTO 150 ENDIF 180 I = LD + 4 J = M Q = -1.0 190 I = I + 3 200 X = Z + A(I) - A(J) IF (X .LT. -0.5) GOTO 190 IF (X .LT. 0.5) GOTO 170 J = J + 3 IF (J .LT. LZ) GOTO 200 IF (A(L + 1) .GE. 10.0) THEN W = 0.261799 * AINT(0.1 * A(L + 1)) X = COS(W) W = SIN(W) V = X * U + W * V U = X * V V = W * V ENDIF W = SQRT(U * U + V * V) X = P * W * A(45) IF (S .LT. X) S = X IF (X .LT. PQ) GOTO 120 NA = NA + 4 Q = A(L) T = A(L + 1) J = L 210 J = J - 4 IF (J .GE. NA) THEN A(J + 4) = A(J) A(J + 5) = A(J + 1) GOTO 210 ENDIF A(NA) = Q A(NA + 1) = T A(NA + 2) = P * U / W A(NA + 3) = P * V * A(23) / W IF (NA - NB .LT. 400) GOTO 120 ENDIF PQ = PQ * 0.8 IF (S .GE. 0.1) THEN IF (NA .NE. LD) THEN IF (NA .GT. NB) GOTO 30 PQ = 0.8 * S GOTO 110 ENDIF ENDIF I = (NA - LX - 4) / 4 J = (LD - LX - 4) / 4 P = ABS(A(26)) I = LX + 4 220 N = - 2 230 I = I + 4 IF (I .LE. NA) THEN N = N + 3 F(N) = A(I) F(N + 1) = A(I + 2) F(N + 2) = A(I + 3) IF (N .LT. 124) GOTO 230 WRITE (LA) F GOTO 220 ENDIF N = N + 3 F(N) = 0.0 WRITE (LA) F CALL GEN108 (LA, 0) LE = - 1 240 IF (NZ .EQ. 0) GOTO 650 IF (ABS(A(55)) .LE. 0.5) THEN WP = 1.0 IF (NZ .LT. 4) WP = 0.0 XJ = A(2) YJ = A(3) ZJ = A(4) IX = 0 IY = 0 IZ = 0 KP = 1 IF (A(23) .GE. 0.5) THEN IF (NZ .LT. 4) KP = 2 ENDIF ML = LY + 12 DO 260 I = 1, 3 J = I + 30 DO 250 K = I, J, 6 F(K) = 9.E9 F(K + 3) = 1.0 250 CONTINUE 260 CONTINUE DO 310 L = ML, LL, 4 DO 300 N = 65, LY, 12 W = A(L) DO 290 K = 1, KP WWP = W * WP X = AMOD(A(N + 9) * WWP + A(L + 1) + 0.501, 1.0) - 0.001 Y = AMOD(A(N + 10) * WWP + A(L + 2) + 0.501, 1.0) - 0.001 Z = AMOD(A(N + 11) * WWP + A(L + 3) + 0.501, 1.0) - 0.001 IX = 9 IF (MAX (ABS(A(N + 1)), ABS(A(N + 2))) .LE. 0.01) THEN IX = 1 IF (ABS(X) .LE. 0.01) THEN IF (A(N) * W .GE. 0.5) IX = 0 ENDIF ENDIF IY = 9 IF (MAX (ABS(A(N + 3)), ABS(A(N + 5))) .LE. 0.01) THEN IY = 1 IF (ABS(Y) .LE. 0.01) THEN IF (A(N + 4) * W .GE. 0.5) IY = 0 ENDIF ENDIF IZ = 9 IF (MAX (ABS(A(N + 6)), ABS(A(N + 7))) .LE. 0.01) THEN IZ = 1 IF (ABS(Z) .LE. 0.01) THEN IF (A(N + 8) * W .GE. 0.5) IZ = 0 ENDIF IF (A(N + 8) * W .GE. 0.0) THEN IF (IZ .NE. 0) THEN IF (IX + IY .LT. 1) F(6) = MIN (F(6), Z) IF (IX .LT. 1) F(12) = MIN (F(12), Z) IF (IY .LT. 1) F(18) = MIN (F(18), Z) IF (F(30) .GT. Z) F(30) = Z ENDIF GOTO 270 ENDIF IF (IX + IY .LT. 1) F(3) = MIN (F(3), Z) IF (IX .LT. 1) F(9) = MIN (F(9), Z) IF (IY .LT. 1) F(15) = MIN (F(15), Z) IF (F(27) .GT. Z) F(27) = Z ENDIF 270 IF (IY .LT. 2) THEN IF (A(N + 4) * W .GE. 0.0) THEN IF (IY .NE. 0) THEN IF (IX + IZ .LT. 1) F(11) = MIN (F(11), Y) IF (IX .LT. 1) F(5) = MIN (F(5), Y) IF (IZ .LT. 1) F(35) = MIN (F(35), Y) IF (F(17) .GT. Y) F(17) = Y ENDIF GOTO 280 ENDIF IF (IX + IZ .LT. 1) F(8) = MIN (F(8), Y) IF (IX .LT. 1) F(2) = MIN (F(2), Y) IF (IZ .LT. 1) F(32) = MIN (F(32), Y) IF (F(14) .GT. Y) F(14) = Y ENDIF 280 IF (IX .LT. 2) THEN IF (A(N) * W .GE. 0.0) THEN IF (IX .NE. 0) THEN IF (IY + IZ .LT. 1) F(16) = MIN (F(16), X) IF (IY .LT. 1) F(22) = MIN (F(22), X) IF (IZ .LT. 1) F(28) = MIN (F(28), X) IF (F(4) .GT. X) F(4) = X ENDIF ELSE IF (IY + IZ .LT. 1) F(13) = MIN (F(13), X) IF (IY .LT. 1) F(19) = MIN (F(19), X) IF (IZ .LT. 1) F(25) = MIN (F(25), X) IF (F(1) .GT. X) F(1) = X ENDIF ENDIF W = - W 290 CONTINUE 300 CONTINUE 310 CONTINUE DO 320 I = 1, 27, 13 F(I + 6) = F(I) F(I + 9) = F(I + 3) 320 CONTINUE DO 330 I = 3, 13, 5 F(I + 18) = F(I) F(I + 21) = F(I + 3) 330 CONTINUE DO 350 I = 1, 31, 6 J = I + 2 DO 340 K = I, J F(K) = 0.5 * F(K) IF (F(K) .LT. 1.0) F(K + 3) = 0.5 * F(K + 3) IF (F(K) .GT. 1.0) F(K) = 0.0 340 CONTINUE 350 CONTINUE RE = 19.6 * A(1) / SQRT(A(64)) U = 9.E9 DO 380 M = 1, 31, 6 DO 370 N = 1, 3 L = N 360 K = 1 IF (0.501 .LE. F(M + 5)) K = 2 J = 1 IF (0.501 .LE. F(M + 4)) J = 2 V = FLOAT(J * K) * F(M + 3) IF (V .LE. U) THEN IF (U .GT. V + 0.01) W = 9.E9 U = V + 0.001 X = YJ * FLOAT(J) - RE Y = ZJ * FLOAT(K) - RE Z = X * X + Y * Y IF (Z .LE. W) THEN W = Z A(55) = FLOAT(L) IX = INT(100.01 * F(M + 1)) - J IY = INT(100.01 * F(M + 2)) - K IZ = J KP = K A(56) = INT(3.5 + 100.0 * F(M + 3) * XJ / RE) A(36) = F(M + 3) * 100.0 / (A(56) - 3.0) A(33) = 100.0 * F(M) - A(36) ENDIF ENDIF X = YJ YJ = ZJ ZJ = X X = F(M + 1) F(M + 1) = F(M + 2) F(M + 2) = X X = F(M + 4) F(M + 4) = F(M + 5) F(M + 5) = X L = -L IF (L .LT. 0) GOTO 360 X = XJ XJ = YJ YJ = ZJ ZJ = X X = F(M) F(M) = F(M + 1) F(M + 1) = F(M + 2) F(M + 2) = X X = F(M + 3) F(M + 3) = F(M + 4) F(M + 4) = F(M + 5) F(M + 5) = X 370 CONTINUE 380 CONTINUE J = INT(A(55)) K = INT(A(56)) L = NZ IF (NZ .EQ. 2) L = 6 A(34) = IX A(35) = IY A(37) = IZ A(38) = KP ENDIF IF (NZ .LT. 7) GOTO 650 IF (LE .LT. 0) GOTO 650 A(54) = A(54) - 1.0 LZ = LD + 8 MB = LZ + 1251 NB = MB - 9 RC = 0.0 HM = 0.0 S = 27.0 * (A(57) - 5.0) R = S T = 0.0 I = LV 390 I = I + 8 IF (I .LE. LD) THEN J = INT(A(I + 1) * 0.001) * 5 + LJ A(I + 6) = A(J) IF (I .LE. LX) THEN IF (HM .LT. A(J)) HM = A(J) R = R + A(I + 5) * A(J) * A(J) ENDIF GOTO 390 ENDIF 400 READ (LF) F DO 440 I = 1, 124, 3 IF (F(I) .LT. 0.5) GOTO 450 IF (F(I + 1) .GE. 0.0) THEN P = AMOD(F(I + 1), 10.0) IF (ABS(P**2 - 0.8) .GE. T) THEN 410 IF (NB + 16 .GE. NPP) THEN T = T + 0.05 J = MB 420 J = J + 9 430 IF (J .GT. NB) GOTO 410 IF (ABS(A(NB + 5)**2 - 0.8) .GT. T) GOTO 420 A(J + 4) = A(NB + 4) A(J + 5) = A(NB + 5) A(J + 6) = A(NB + 6) NB = NB - 9 GOTO 430 ENDIF NB = NB + 9 A(NB + 6) = F(I) A(NB + 5) = P A(NB + 4) = F(I + 2) ENDIF ENDIF 440 CONTINUE GOTO 400 450 CALL GEN108 (LF, 0) DO 480 I = MB, NB, 9 CALL GEN046 (A(I + 6), X, Y, Z) A(I) = X A(I + 1) = Y A(I + 2) = Z Q = SQRT(X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) 1 + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)) / A(1) A(I +7)=47.0 * Q * SQRT(Q) T = S * (3.834 / (3.834 + A(I + 7)))**2 J = LV 460 J = J + 8 IF (J .GT. LX) GOTO 470 K = INT(A(J + 1) * 0.001) * 5 + LJ W = SQRT(A(K) * SQRT(A(K))) T = T + A(J + 5) * (W * A(K) / (W + A(I + 7)))**2 GOTO 460 470 P = A(I + 5) A(I + 8) = SQRT(R / T) P = P / A(I + 8) A(I + 3) = P RC = RC + P * P A(I + 5) = 0.0 A(I + 6) = 0.0 480 CONTINUE J = LZ DO 490 I = 1, 1251 A(J) = SIN(6.283185E-3 * FLOAT(I - 1)) J = J + 1 490 CONTINUE IX = (LD - LX) / 16 IZ = LV + 1 NA = LD + 8 KP = (LD - LV) / 8 SM = 0.0 IY = 0 500 I = NA 510 I = I - 8 IF (I .LT. IZ) GOTO 600 IF (A(I + 5) .EQ. 0.0) GOTO 510 NK = -2 DO 520 J = 65, LY, 12 NK = NK + 3 G(NK) = 1000.0 * (A(I + 2) * A(J) + A(I + 3) * A(J + 1) 1 + A(I + 4) * A(J + 2) + A(J + 9)) G(NK + 1) = 1000.0 * (A(I + 2) * A(J + 3) 1 + A(I + 3) * A(J + 4) 2 + A(I + 4) * A(J + 5) + A(J + 10)) G(NK + 2) = 1000.0 * (A(I + 2) * A(J + 6) 1 + A(I + 3) * A(J + 7) 2 + A(I + 4) * A(J + 8) + A(J + 11)) 520 CONTINUE 530 RA = 0.0 RB = 0.0 X = G(1) Y = G(2) Z = G(3) W = SQRT(A(I + 6) * SQRT(A(I + 6))) T = W * A(I + 6) * A(I + 5) * A(24) IF (LY .EQ. 65) THEN DO 540 J = MB, NB, 9 KZ = LZ + INT(AMOD(1000000.5 + A(J) * X + A(J + 1) * Y 1 + A(J + 2) * Z, 1000.0)) O = T / (W + A(J + 7)) U = A(J + 5) - A(KZ + 250) * O V = A(J + 6) - A(KZ) * O * A(23) S = (V * V + U * U) / A(J + 4) RA = RA + S IF (IX .GE. IY) THEN A(J + 6) = V A(J + 5) = U ENDIF RB = RB + A(J + 3) * SQRT(S) 540 CONTINUE ELSE XJ = G(4) YJ = G(5) ZJ = G(6) IF (LY .EQ. 77) THEN DO 550 J = MB, NB, 9 KZ = LZ + INT(AMOD(1000000.5 + A(J) * X + A(J + 1) * Y 1 + A(J + 2) * Z, 1000.0)) KY = LZ + INT(AMOD(1000000.5 + A(J) * XJ + A(J + 1) * YJ 1 + A(J + 2) * ZJ, 1000.0)) O = T / (W + A(J + 7)) U = A(J + 5) - O * (A(KZ + 250) + A(KY + 250)) V = A(J + 6) - A(23) * O * (A(KZ) + A(KY)) S = (V * V + U * U) / A(J + 4) RA = RA + S IF (IX .GE. IY) THEN A(J + 6) = V A(J + 5) = U ENDIF RB = RB + SQRT(S) * A(J + 3) 550 CONTINUE ELSE IF (LY .EQ. 101) THEN XK = G(7) YK = G(8) ZK = G(9) XL = G(10) YL = G(11) ZL = G(12) DO 560 J = MB, NB, 9 KZ = LZ + INT(AMOD(1000000.5 + A(J) * X + A(J + 1) * Y 1 + A(J + 2) * Z, 1000.0)) KY = LZ + INT(AMOD(1000000.5 + A(J) * XJ + A(J + 1) * YJ 1 + A(J + 2) * ZJ, 1000.0)) KX = LZ + INT(AMOD(1000000.5 + A(J) * XK + A(J + 1) * YK 1 + A(J + 2) * ZK, 1000.0)) KW = LZ + INT(AMOD(1000000.5 + A(J) * XL + A(J + 1) * YL 1 + A(J + 2) * ZL, 1000.0)) O = T / (W + A(J + 7)) U = A(J + 5) - O * (A(KZ + 250) + A(KY + 250) 1 + A(KX + 250) + A(KW + 250)) V = A(J + 6) - A(23) * O * (A(KZ) + A(KY) + A(KX) + A(KW)) S = (V * V + U * U) / A(J + 4) RA = RA + S IF (IX .GE. IY) THEN A(J + 6) = V A(J + 5) = U ENDIF RB = RB + SQRT(S) * A(J + 3) 560 CONTINUE ELSE DO 580 J = MB, NB, 9 X = 0.0 Y = 0.0 DO 570 K = 1, NK, 3 KZ = LZ + INT(AMOD(1000000.5 + A(J) * G(K) 1 + A(J + 1) * G(K + 1) + A(J + 2) * G(K + 2), 1000.0)) X = X + A(KZ + 250) Y = Y + A(KZ) 570 CONTINUE O = T / (W + A(J + 7)) V = A(J + 6) - Y * A(23) * O U = A(J + 5) - X * O S = (U * U + V * V) / A(J + 4) RA = RA + S IF (IX .GE. IY) THEN A(J + 6) = V A(J + 5) = U ENDIF RB = RB + SQRT(S) * A(J + 3) 580 CONTINUE ENDIF ENDIF W = RB * RB / (RA * RC) IF (IY .LT. 0) THEN GOTO 590 ELSE IF (IY .EQ. 0) THEN GOTO 510 ENDIF IF (W .LT. SM) GOTO 510 IY = -IY GOTO 530 590 A(I + 5) = 0.0 KP = KP - 1 IX = IX - 1 IY = - IY SM = W 600 IF (IY .NE. IX + 1) THEN IF (IY .EQ. 0) THEN SM = W IZ = LX + 1 DO 610 J = MB, NB, 9 A(J + 5) = - A(J + 5) A(J + 6) = - A(J + 6) 610 CONTINUE ENDIF IF (IX .GT. 0) THEN IF (I .GT. IZ - 1) GOTO 510 IY = IX + 1 GOTO 500 ENDIF ENDIF I = 1 G(1) = -0.5 G(2) = 0.8 G(3) = -0.02 G(4) = -0.5 G(5) = 1.9 G(6) = -0.02 G(7) = 1.0 G(8) = 2.4 G(9) = -0.01 X = 0.0 Y = 0.0 DO 620 J = MB, NB, 9 X = X + A(J + 5) * A(J + 5) + A(J + 6) * A(J + 6) Y = Y + A(J + 3) * A(J + 3) 620 CONTINUE X = SQRT(Y / X) DO 640 J = MB, NB, 9 F(I) = A(J) + 200.0 * (A(J + 1) + 200.0 * A(J + 2)) W = 1.0 IF (HM .LE. 18.5) THEN U = A(14) * A(J) * A(J) + A(15) * A(J + 1) * A(J + 1) + A(16) 1 * A(J + 2) * A(J + 2) + A(17) * A(J + 1) * A(J + 2) 2 + A(18) * A(J) * A(J + 2) + A(19) * A(J) * A(J + 1) U = U * GL(8) / (A(1) * A(1)) S = SQRT(U + U) DO 630 K = 1, 7, 3 V = G(K + 1) * S W = W + G(K) * SIN(V) * EXP(U * G(K+2)) / V 630 CONTINUE W = SQRT(W) ENDIF U = X * A(J + 5) V = X * A(J + 6) S = SQRT(U * U + V * V) O = SQRT(1.0 / A(J + 4)) T = 100.0 * W * (2.0 * A(J + 3) * TANH(S * O * A(J + 3) 1 * A(J + 8)**2) / S - O) IF (A(54) .GT. 6.5) T = T * A(J + 8) F(I + 1) = U * T F(I + 2) = V * T IF (I .GE. 124) THEN WRITE (LA) F I = -2 ENDIF I = I + 3 640 CONTINUE F(I) = 0.0 WRITE (LA) F CALL GEN108 (LA, 0) S = SQRT(1.0 - SM) J = (NB - MB + 9) / 9 I = NB + 8 M = 0 P = 0.0 650 LE = 0 I = LV 660 I = I + 8 IF (I .LE. LX) THEN J = INT(0.001 * A(I + 1)) * 5 + LJ A(I + 7) = (0.1 + A(J + 1))**2 GOTO 660 ENDIF IF (A(57) .LT. 0.0) LX = LV RR = 0.1 IF (MAX (A(5), A(6), A(7)) .GT. 110.0) RR = 0.3 NZ = INT(A(54)) IF (NZ .EQ. 6) NZ = 4 IF (NZ .GT. 6) NZ = 6 LX = MIN (LX, LV) RR = 0.5 LD = LX IF (NZ .EQ. 0) GOTO 990 IF (ABS(A(57)) .LT. 0.5) GOTO 990 TP = A(LX + 6) A(LX + 6) = 9.E9 MP = (INT(ABS(A(57))) * 8) + LX A(MP + 6) = MAX (0.0, 0.7 * A(20)) ML = LY + 12 NX = INT(A(56)) LZ = MP + 16 IF (LZ + 8600 .GT. NPP) GOTO 990 NL = 0 NH = LZ + 8134 CALL GEN074 (A, 0.0, LZ, NH) MA = MAX (MIN (INT(ABS(A(55))), 3), 1) NS = LZ + 8427 NA = NH - 3 SS = 0.0 ZZ = A(33) KP = 1 NF = 1 NG = 1 WP = 1.0 680 READ (LA) F I = - 2 690 I = I + 3 IF (I .GT. 124) GOTO 680 IF (ABS(F(I)) .GE. 0.5) THEN S = F(I + 1) * F(I + 1) + F(I + 2) * F(I + 2) IF (S .LT. 1.E-10) GOTO 690 U = SQRT(S) CALL GEN046 (F(I), X, Y, Z) EZ = 0.0 L = NA DO 720 K = 65, LY, 12 P = AINT(1.001 * (X * A(K)+ Y * A(K + 3) + Z * A(K + 6))) Q = AINT(1.001 * (X * A(K + 1) + Y * A(K + 4) + Z * A(K + 7))) R = AINT(1.001 * (X * A(K + 2) + Y * A(K + 5) + Z * A(K + 8))) W = P + 200.0 * (Q + 200.0 * R) A(L + 7) = ABS(W) IF (ABS(W - F(I)) .LT. 0.5) EZ = EZ + 1.0 IF (ABS(W + F(I)) .LT. 0.5 - A(23)) EZ = EZ + 1.0 J = NA 700 J = J + 4 IF (J .LE. L) THEN IF (ABS(A(J + 3) - A(L + 7)) .LT. 0.5) THEN GOTO 720 ELSE GOTO 700 ENDIF ENDIF DO 710 J = 1, MA A(L + 4) = P P = Q Q = R R = A(L + 4) 710 CONTINUE IF (A(55) .GE. 0.0) THEN T = P P = Q Q = T ENDIF IF (ABS(Q) .LE. 63.5) THEN T = 127.0 * P + Q IF (ABS(T) .LE. 8134.5) THEN M = INT(ABS(T) + 0.001) + LZ L = L + 4 IF (NF .LE. 1) THEN A(M) = 1.1 GOTO 720 ENDIF A(L + 2) = 100.0 * (X * A(K + 9) + Y * A(K + 10) 1 + Z * A(K + 11)) A(L + 1) = T ENDIF ENDIF 720 CONTINUE IF (NF .EQ. 1) GOTO 690 R = 0.0 P = F(I + 1) K = NA T = SQRT(EZ) Q = F(I + 2) Q = Q * T P = P * T 730 K = K + 4 IF (K .GT. L) GOTO 690 Y = SIGN(1.0, A(K + 1) + 0.1) X = Y * A(K) Z = Q * Y SS = SS + SQRT(P * P + Q * Q) T = ABS(A(K + 1)) + 0.001 M = INT(T)+LZ N = INT(A(M)) R = Y * A(K + 2) N = N * NH + NS A(N) = T S = 0.0628319 * (X * ZZ + R) O = SIN(S) S = COS(S) T = P * S + Z * O S = P * O - Z * S Z = 0.0628319 * X * A(36) W = COS(Z) Z = SIN(Z) M = N + 1 DO 740 N = 3, NH, 2 A(M) = A(M) + T A(M + 1) = A(M + 1) + S O = T * W - S * Z S = T * Z + S * W T = O M = M + 2 740 CONTINUE GOTO 730 ENDIF CALL GEN108 (LA, 0) IF (NF .EQ. 1) THEN NF = 2 M = 0 DO 750 I = LZ, NH M = M + INT(A(I)) 750 CONTINUE IF (M .LE. 0) THEN WRITE (LI, 99999) ELSE NH = MIN (NX, ((NPP - NS) / M - 1) / 2) IF (NH .GE. NX) THEN NH = NH + NH + 1 IF (NH .GT. 2) GOTO 760 ENDIF ENDIF GOTO 990 760 NL = NS + (NH * M) CALL GEN074 (A, 0.0, NS, NL) K = 0 L = LZ + 8134 DO 780 I = LZ, L IF (A(I) .GE. 0.5) THEN A(I) = FLOAT(K) K = K + 1 ENDIF 780 CONTINUE GOTO 680 ENDIF NC = -1 NB = -1 NA = LZ G(NG) = -1.0 NG = 0 EZ = 9999.0 A(44) = 0.0 YM = AMOD(A(34) + 1000.1, 100.0) - 0.1 ZM = AMOD(A(35) + 1000.1, 100.0) - 0.1 A(NL) = 1000000.0 SS = 999.1 / SS DO 790 I = 1, 126 G(I) = SIN(6.283185E-2 * FLOAT(I - 1)) 790 CONTINUE MS = NS + 1 800 Z = 0.0 W = 63.5 NK = NA + 2808 CALL GEN074 (A, 0.0, NA, NK) CALL GEN074 (F, 0.0, 1, 106) NK = MS DO 870 I = NS, NL, NH IF (W .LE. A(I)) THEN K = INT(AMOD(Z * A(38), 100.0)) L = INT(AMOD(Z * ZM, 100.0)) N = NA DO 830 J = 1, 53 L = MOD(L, 100) W = G(L + 1) Z = G(L + 26) DO 820 M = 1, 53 A(N) = A(N) + F(M) * Z + F(M + 53) * W N = N + 1 820 CONTINUE L = L + K 830 CONTINUE IF (I .EQ. NL) GOTO 860 Z = AINT(A(I) / 127.0 + 0.5) + 0.0001 W = 127.0 * Z + 63.5 CALL GEN074 (F, 0.0, 1, 106) ENDIF U = AMOD(A(I) + 63.0, 127.0) + 37.0 K = INT(AMOD (U * A(37), 100.0)) L = INT(AMOD (U * YM, 100.0)) U = A(NK) * SS V = A(NK + 1) * SS DO 850 J = 1, 53 L = MOD(L, 100) F(J) = F(J) + U * G(L + 26) - V * G(L + 1) F(J + 53) = F(J + 53) - V * G(L + 26) - U * G(L + 1) L = L + K 850 CONTINUE 860 NK = NK + NH 870 CONTINUE IF (NC .LT. 0) GOTO 980 Z = A(35) DO 970 I = 53, 2703, 53 Z = Z + A(38) Y = A(34) DO 960 K = 1, 51 Y = Y + A(37) NK = I + K M = NK + NB IF (EZ .GT. A(M)) EZ = A(M) P = A(M) IF (P * 1.2 .LT. A(MP + 6)) GOTO 960 IF (A(M - 1) .GT. P) GOTO 960 IF (A(M + 1) .GT. P) GOTO 960 IF (MAX (A(M - 54), A(M - 53), A(M - 52)) .GT. P) GOTO 960 IF (MAX (A(M + 52), A(M + 53), A(M + 54)) .GT. P) GOTO 960 L = NK + NC IF (MAX (A(L - 53), A(L - 1), A(L), A(L + 1), 1 A(L + 53)) .GT. P) GOTO 960 N = NK + NA IF (MAX (A(N - 53), A(N - 1), A(N), A(N + 1), 1 A(N + 53)) .GT. P) GOTO 960 Q = P + P U = A(L) - A(N) V = A(M - 1) - A(M + 1) W = A(M - 53) - A(M + 53) R = U / (A(N) + A(L) - Q) S = V / (A(M - 1) + A(M + 1) - Q) T = W / (A(M - 53) + A(M + 53) - Q) H = P - (U * R + V * S + W * T) * 0.0416667 IF (H .GT. A(44)) A(44) = H IF (H .LT. A(20)) GOTO 960 W= 0.01 * ZZ + A(36) * (0.005 * R - 0.01) V= 0.005 * (Y + Y + A(37) * S) U= 0.005 * (Z + Z + A(38) * T) IF (A(55) .GE. 0.0) THEN T = U U = V V = T ENDIF DO 880 NK = 1, MA T = W W = V V = U U = T 880 CONTINUE SK = 0.0 XS = 0.0 YS = 0.0 ZS = 0.0 CS = 1.0 DO 920 NK = 1, KP DO 910 L = 65, LY, 12 XA = U * A(L) + V * A(L + 1) + W * A(L + 2) 1 + WP * A(L + 9) YA = U * A(L + 3) + V * A(L + 4) + W * A(L + 5) 1 + WP * A(L + 10) ZA = U * A(L + 6) + V * A(L + 7) + W * A(L + 8) 1 + WP * A(L + 11) DO 900 M = ML, LL, 4 O = CS * A(M) * XA + A(M + 1) P = CS * A(M) * YA + A(M + 2) Q = CS * A(M) * ZA + A(M + 3) N = LV R = AMOD(O - U, 1.0) - 0.5 S = AMOD(P - V, 1.0) - 0.5 T = AMOD(Q - W, 1.0) - 0.5 IF (R * R * A(8) + S * S * A(9) + T * T * A(10) 1 + S * T * A(11) + R * T * A(12) 2 + R * S * A(13) .LE. RR) THEN XS = XS + R + U YS = YS + S + V ZS = ZS + T + W SK = SK + 1.0 ENDIF 890 N = N + 8 IF (N .LE. LD) THEN R = AMOD(O - A(N + 2), 1.0) - 0.5 S = AMOD(P - A(N + 3), 1.0) - 0.5 T = AMOD(Q - A(N + 4), 1.0) - 0.5 YUNK = R * R * A(8) + S * S * A(9) + T * T * A(10) 1 + S * T * A(11) + R * T * A(12) 2 + R * S * A(13) - A(N + 7) IF (YUNK .LT. 0.0) THEN GOTO 960 ELSE GOTO 890 ENDIF ENDIF 900 CONTINUE 910 CONTINUE CS = -1.0 920 CONTINUE J = LD + 8 NK = J 930 J = J - 8 IF (A(J + 6) .LT. H) GOTO 930 940 NK = NK - 8 IF (J .LT. NK) THEN N = NK + 7 DO 950 L = NK, N A(L + 8) = A(L) 950 CONTINUE GOTO 940 ENDIF A(J + 8) = 0.0 A(J + 9) = 1000.1 SK = 1.0 / SK A(J + 10) = XS * SK A(J + 11) = YS * SK A(J + 12) = ZS * SK A(J + 13) = SK A(J + 14) = H A(J + 15) = RR LD = MIN (LD + 8, MP) 960 CONTINUE 970 CONTINUE 980 NC = NB NB = NA NA = NA + 2809 IF (NA .GT. LZ + 8426) NA = LZ MS = MS + 2 NG = NG + 1 ZZ = ZZ + A(36) IF (NX .NE. NG) GOTO 800 A(LX + 6) = TP 990 IF (A(54) .GT. 6.5) GOTO 10 I = LV 1000 I = I + 8 IF (I .LE. LD) THEN WRITE (LP, 99997) A(I + 2), A(I + 3), A(I + 4) GOTO 1000 ENDIF WRITE (LP, 99998) (HKLF(I), I = 1, 11) RETURN 99999 FORMAT (/, '** No Data for Fourier', ///) 99998 FORMAT ('HKLF ', 2F6.2, 9F7.3, /, 'END ', //) 99997 FORMAT ('Q000 1', 3F8.4) END SUBROUTINE PLA160 (MODE, TM1) C ******************************************************************* PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP18=50, 1 NPVD=40000000,NP22=256,NP23=18000,NP38=125,NP39=30, 4 NCS=50, NZM = 200000, NRS = NPVD - 10 * NZM) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // XYZDUM(2, NP23), RS(NRS), TNZ(NZM, 10) COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10) COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12), 1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12), 2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA, 3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC, 4 RAVERA, RAVERH COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS COMMON /SFCLC/ NATO, NNG(3), NGRID COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5 INTEGER HMAX DIMENSION TM1(3, 3), YPAR(107) COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /DSPGR/ TYPE, NLAUE CHARACTER TYPE(NCS)*16, NLAUE(13)*5 COMMON /LPLATC/ BLATT(NP18), CLATT(NP18) CHARACTER BLATT*1, CLATT*1 LH = 0 LK = 0 LL = 0 JH = 0 JK = 0 JL = 0 IND1 = 1 IND2 = 2 IND3 = 3 HMAX = 0 STLM = 0.0 LTNR = 0 KMAX = 0 LMAX = 0 IUNIT = 0 IPCNTC = 0 IPCNTA = 0 IPCNTH = 0 IFRQC = 0 IFRQA = 0 IFRQH = 0 ISPGRC = 0 ISPGRA = 0 ISPGRH = 0 RAVERC = 100.0 RAVERA = 100.0 RAVERH = 100.0 CRI(11) = PAR(141) IWIN = IGBL(25) * IGBL(32) C * FSPGR - DETERMINE SPACEGROUP FROM OBSERVED DATA IF (MODE .EQ. 1) THEN RMAX = PAR(430) PAGET = 'SPGRfrEx' CALL PLA269 (-2) STLM = SIN (PAR(419) / GL(5)) / PAR(17) WRITE (LU7, 99985) JID(1:9) WRITE (LU6, 99985) JID(1:9) C * NEWSYM : FIND SPACEGROUP (POSSIBLE HIGHER SYMMETRY) ELSE IF (MODE .EQ. 2) THEN RMAX = PAR(429) IF (IWIN .EQ. 1) THEN BCD = 'NewSym'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, BCD, 7, 1.4, 4, 8, 9.6, VERT - 1.8) CALL GGIP20 (0.0, BCD, 7, 1.4, 2, 8, 9.4, VERT - 1.9) CALL GGIP (0.0, 0.0, 0.0, 6) VRT = VERT - 5.5 CALL GEN038 (PRBUF, 1, 80) ENDIF PAGET = 'NEWSYM' CALL PLA269 (0) STLM = 0.0 WRITE (LU7, 99986) PAR(248), JID(1:9) WRITE (LU6, 99986) PAR(248), JID(1:9) LTNR = IPR(241) NSYM = IPR(48) NSYMH = IPR(255) ICNTR = IPR(257) CALL PLA130 (NATO, 0) IF (NATO .LT. 0) THEN WRITE (LU6, 99998) GOTO 310 ENDIF HMAX = INT(4 * PAR(101) / 3) KMAX = INT(4 * PAR(102) / 3) LMAX = INT(4 * PAR(103) / 3) MPH = 2 * HMAX + 1 MPK = 2 * KMAX + 1 MHK = MPH * MPK ENDIF IMODE = IPR(365) IF (IMODE .EQ. 0) IMODE = 3 IF (IMODE .NE. 2) THEN CALL PLA169 (0, 0, 0, 0.0, LU6) CALL PLA162 (0, 0, 0, 0, 0, 0.0, 0.0, IDUM) ENDIF IF (IMODE .GT. 1) THEN DO 20 I = 1, 12 NNZ(I) = 0 ANZ(I) = 0.0 DO 10 J = 1, 10 IF (I .EQ. 12) THEN VAL = (1.0 - EXP(- J * 0.1)) * 100.0 ELSE VAL = 0.0 ENDIF PNZ(I, J) = VAL 10 CONTINUE 20 CONTINUE ENDIF NREF = 0 OPEN (UNIT = LU8, STATUS = 'SCRATCH', FORM = 'UNFORMATTED') IF (MODE .EQ. 2) GOTO 60 SCALE = 100.0 IEND = -1 30 CALL PLA132 (JH, JK, JL, RINT, RSIG, CALI, UCINT, ACALS, BCALS, 1 ACOR, IEND) IF (IEND .EQ. 1) GOTO 40 IF (RINT .LT. 999999.0) GOTO 30 SCALE = 1.0 40 IUNIT = NINT(GEN120 (TM1)) IEND = -1 50 CALL PLA132 (JH, JK, JL, RINT, RSIG, CALI, UCINT, ACALS, BCALS, 1 ACOR, IEND) IF (IEND .EQ. 1) GOTO 140 IF (IUNIT .NE. 1) THEN IH = JH IK = JK IL = JL IF (GEN050 (TM1, IH, IK, IL, JH, JK, JL) .LT. 0.0) GOTO 50 ENDIF IF (JH .EQ. 0 .AND. JK .EQ. 0 .AND. JL .EQ. 0) GOTO 140 IX = NINT(MAX(0.0, RINT * SCALE)) IF (RSIG .LE. 0.0) RSIG = 0.5 IS = NINT(RSIG * SCALE) GOTO 100 60 JH = - HMAX -1 70 JH = JH + 1 IF (JH .GT. HMAX) THEN CALL GGIP20 (0.0, PRBUF, 20, 0.8, 0, 2, 7.0, VRT) GOTO 140 ENDIF JK = - KMAX - 1 80 JK = JK + 1 IF (JK .GT. KMAX) GOTO 70 JL = - 1 90 JL = JL + 1 IF (JL .GT. LMAX) GOTO 80 IF (JH .EQ. 0 .AND. JK .EQ. 0 .AND. JL .EQ. 0) GOTO 90 IF (LTNR .GT. 1) THEN IF (GEN049 (LAT(LTNR), JH, JK, JL) .LT. 0.0) GOTO 90 ENDIF CALL PLA139 (JH, JK, JL, IEXT, IASM) IF (IEXT .NE. 0) GOTO 90 100 STLK = GEN095 (PAR(191), JH, JK, JL) STL = SQRT(STLK) FSC = 1.0 IF (MODE .EQ. 2) THEN IF (STL .LT. PAR(248)) THEN ACAL = 0.0 BCAL = 0.0 CALL PLA131 (JH, JK, JL, ACAL, BCAL, ACALA, BCALA, DUM) IX = MIN (999999999, NINT(100.0 * (ACAL**2 + BCAL**2))) IS = MAX (1, NINT(SQRT(FLOAT(IX)))) ELSE GOTO 90 ENDIF ENDIF IF (IMODE .NE. 2) CALL PLA169 (1, IX, IS, STL, LU6) IF (STL .GT. STLM) THEN XI = IX SI = IS WRITE (LU8) JH, JK, JL, XI, SI, FSC, STL NREF = NREF + 1 IF (IMODE .GT. 1) THEN IF (JH .NE. 0 .AND. JK .NE. 0 .AND. JL .NE. 0) THEN DO 120 I = 1, 10 IF (STL .LE. STLS(I)) THEN NNZ(I) = NNZ(I) + 1 IF (NNZ(I) .LE. NZM) THEN TNZ(NNZ(I), I) = XI ANZ(I) = ANZ(I) + XI NNZ(11) = NNZ(11) + 1 ELSE IF (NNZ(I) .EQ. NZM) THEN WRITE (LU6, 99987) STOP ENDIF GOTO 130 ENDIF 120 CONTINUE 130 CONTINUE ENDIF ENDIF IF (IMODE .NE. 2) THEN IF (SI .GT. 0.0) THEN XISI = XI / SI ELSE XISI = 0.0 ENDIF CALL PLA161 (0, JH, JK, JL, XISI, FSC) ENDIF ENDIF IF (MODE .EQ. 1) THEN GOTO 50 ELSE IF (MOD(NREF, 1000) .EQ. 0) THEN CALL GGIP20 (0.0, PRBUF, 20, 0.8, 0, 2, 7.0, VRT) WRITE (PRBUF, 99983) NREF CALL GGIP20 (0.0, PRBUF, 20, 0.8, 1, 2, 7.0, VRT) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF GOTO 90 ENDIF 140 IF (IMODE .NE. 2) THEN CALL PLA169 (-1, 0, 0, 0.0, LU6) IF (IPR(210) .NE. -3) THEN CALL PLA169 (-2, 0, 0, 0.0, LU6) CALL PLA169 (-2, 0, 0, 0.0, LU7) ENDIF CALL PLA162 (-1, 0, 0, 0, 0, 0.0, 0.0, NR) IF (NR .GT. 0) THEN NXCT = 0 ELSE NXCT = 1 NR = - NR ENDIF IPR(94) = 2 IAPPEND = 0 IF (IMODE .EQ. 1 .AND. NR .NE. 1 .AND. NXCT .NE. 0) THEN CALL PLA164 (IMODE, 0, LAT(1), TM1, PAR(383)) IAPPEND = 1 ENDIF CALL PLA164 (IMODE, IAPPEND, LAT(NR), TM1, PAR(383)) LRET0 = 0 ISPR47 = 0 REWIND LU2 IF (IPR(548) .EQ. 0) 1 CALL PLA171 (LRET0, TM1, LU2, ISPR47, YPAR, 0) ELSE CALL GEN021 (TRMX, 1) WRITE (LU2, 99999) ((TM1(I, J), J = 1, 3), I = 1, 3), ILAT0 CALL PLA167 ENDIF IF (IMODE .GT. 1) THEN CALL GEN074 (AVNZ, 0.0, 1, 3) NZMX = 10 ANZM = 0.0 DO 160 I = 1, NZMX IF (NNZ(I) .GT. 0) THEN ANZ(I) = ANZ(I) / NNZ(I) ANZM = MAX (ANZ(I), ANZM) ELSE NZMX = I - 1 GOTO 170 ENDIF 160 CONTINUE 170 DO 200 I = 1, NZMX DO 190 J = 1, 10 XANZ = J * 0.1 * ANZ(I) NZ = 0 DO 180 K = 1, NNZ(I) IF (K .GT. NZM) THEN WRITE (LU6, 99987) STOP ENDIF IF (TNZ(K, I) .LE. XANZ) NZ = NZ + 1 180 CONTINUE PNZ(I, J) = FLOAT(NZ) * 100.0 / FLOAT(NNZ(I)) 190 CONTINUE 200 CONTINUE IAE = MIN (6, NZMX) IAB = MIN (3, IAE) IAT = IAE - IAB + 1 DO 220 J = 1, 10 AVER = 0 IF (IAB .GT. 0) THEN DO 210 I = IAB, IAE AVER = AVER + PNZ(I, J) 210 CONTINUE ENDIF PNZ(11, J) = AVER / IAT 220 CONTINUE WRITE (LU7, 99994) IF (ANZM .NE. 0.0) THEN DO 230 I = 1, 10 WRITE (LU7, 99993) I, (PNZ(I, J), J = 1, 10), 1 NNZ(I), ANZ(I) * 1000.0 / ANZM 230 CONTINUE ENDIF WRITE (LU7, 99992) (0.1 * J, J = 1, 10), IAB, IAE, 1 (PNZ(11, J), J = 1, 10), 2 (PNZ(12, J), J = 1, 10), 3 (PNZ(13, J), J = 1, 10) DO 250 I = 11, 13 DO 240 J = 1, 10 PNZ(I, J) = PNZ(I, J) - 0.1 * J * PNZ(I, 10) 240 CONTINUE 250 CONTINUE DO 270 I = 11, 13 DO 260 J = 1, 10 PNZ(I, J) = PNZ(I, J) - PNZ(12, J) AVNZ(I - 10) = AVNZ(I - 10) + PNZ(I, J) 260 CONTINUE 270 CONTINUE IPERC = NINT(100.0 * AVNZ(1) / AVNZ(3)) WRITE (LU7, 99991) IPERC WRITE (LU7, 99992) (0.1 * J, J = 1, 10), IAB, IAE, 1 (PNZ(11, J), J = 1, 10), 2 (PNZ(12, J), J = 1, 10), 3 (PNZ(13, J), J = 1, 10) ENDIF IF (IMODE .GT. 1) THEN CALL PLA162 (0, 0, 0, 0, 0, 0.0, 0.0, IDUM) IF (IMODE .EQ. 3) THEN K = 0 DO 5401 I = 1, 3 DO 5402 J = 1, 3 K = K + 1 TRMX (I, J) = TLATT (K, NRLT) 5402 CONTINUE 5401 CONTINUE LAUE = NLAUE(LLAUE(NRLT)) ILAT0 = CLATT(NRLT) ILAT1 = BLATT(NRLT) ENDIF CALL GEN108 (LU8, 0) DO 280 NRF = 1, NREF READ (LU8) KH, KK, KL, XI, SI, FSC, STL IF (GEN050 (TRMX, KH, KK, KL, LH, LK, LL) .GE. 0.0) THEN IF (LL .LT. 0) THEN IH = - LH IK = - LK IL = - LL ELSE IF (LL .EQ. 0) THEN IL = 0 IF (LK .LT. 0) THEN IK = - LK IH = - LH ELSE IF (LK .EQ. 0) THEN IK = 0 IH = IABS(LH) ELSE IK = LK IH = LH ENDIF ELSE IH = LH IK = LK IL = LL ENDIF IF (SI .GT. 0.0) THEN XISI = XI / SI ELSE XISI = 0.0 ENDIF CALL PLA161 (1, IH, IK, IL, XISI, FSC) ENDIF 280 CONTINUE CALL PLA162 (-2, 0, 0, 0, 0, 0.0, 0.0, LATT) IF (IPR(548) .EQ. 0) THEN M = 2 + IWIN ELSE M = 2 ENDIF DO 300 N = 1, M IF (N .EQ. 1) THEN LU = LU6 ELSE IF (N .EQ. 2) THEN LU = LU7 ELSE LU = 0 ENDIF 290 WRITE (PRBUF, 99990) ((TRMX(I, J), J = 1, 3), I = 1, 3) IF (LU .GT. 0) THEN IF (LU .EQ. LU7) CALL PLA269 (0) WRITE (LU, 99997) WRITE (LU, 99995) WRITE (LU, 99989) PRBUF(1:80) ELSE CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 1.0 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 0.1, VRT) ENDIF WRITE (PRBUF, 99988) IF (LU .GT. 0) THEN WRITE (LU, 99984) PRBUF(1:80) ELSE VRT = VRT - 1.0 CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 0.1, 1 VRT) ENDIF CALL PLA168 IF (LU .EQ. LU7) 1 WRITE (LU2, 99982) ISPGRC, ISPGRA, ISPGRH, IPCNTC IF (LU .EQ. 0) THEN CALL PLA015 (0, 39) CALL PLA013 (2, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 290 ENDIF 300 CONTINUE ENDIF 310 IF (IPR(2) .EQ. 0) IPR(2) = -1 CLOSE (LU8) RETURN 99999 FORMAT ('TRMX ', 9F7.3, 1X, A) 99998 FORMAT (/, ':: No Atoms Found on Input. Abort', /) 99997 FORMAT (/, 'Tentative Space Group Assignment - ', 1 '(Please Check Carefully)', /, 80('='), /) 99995 FORMAT (':: NOTE: Space Group Determination Pitfalls:', /, 1 ' - Twinning, Pseudo-Symmetry, Mult.Refl.') 99994 FORMAT (/, 'Nz-Test Statistics', /, 18('=')) 99993 FORMAT ('Shell', I2, 10F6.2, I6, F7.1) 99992 FORMAT (/, ' z ->', 10F6.1, /, 'Av', I1, ':', I2, 1X, 10F6.2, 1 /, 'NonCent', 10F6.2, /, 'CentroS', 10F6.2) 99991 FORMAT (/, 'Normalized N(z) curves (', I3, ' Percent Centric)', 1 /, 43('=')) 99990 FORMAT ('Candidate Space Groups in (', 1 3F5.2, '/', 3F5.2, '/', 3F5.2, ') Cell') 99989 FORMAT (/, A, /, 80('='), /) 99988 FORMAT ('Name # AbsFreq', 1 ' StandSet. R(av)Perc. N A/C-Prob') 99987 FORMAT (':: Increase NZM in FSPGR', //) 99986 FORMAT ('NEWSYM - Determine Symmetry from F(calc) data', 1 '(Resol = ', F5.2, ') for: ', A, /, 80('=')) 99985 FORMAT ('SPGR - Determine SpaceGroup from Observed ', 1 'Extinctions for: ', A, /, 80('=')) 99984 FORMAT (A, /, 80('-')) 99983 FORMAT ('REFL No =', I8) 99982 FORMAT ('SGNR', 4I5) END SUBROUTINE PLA161 (MODE, IH, IK, IL, XISI, FSC) CALL PLA162 (1, IH, IK, IL, MOD(IH + IK, 2), XISI, FSC, IDUM) CALL PLA162 (2, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC, IDUM) CALL PLA162 (3, IH, IK, IL, MOD(IK + IL, 2), XISI, FSC, IDUM) CALL PLA162 (4, IH, IK, IL, MOD(IH + IK + IL, 2), XISI, FSC, 1 IDUM) CALL PLA162 (5, IH, IK, IL, MOD(- IH + IK + IL, 3), XISI, 1 FSC, IDUM) CALL PLA162 (6, IH, IK, IL, MOD(IH - IK + IL, 3), XISI, 1 FSC, IDUM) CALL PLA162 (41, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) CALL PLA162 (42, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM) CALL PLA162 (43, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (44, IH, IK, IL, MOD(IH, 3), XISI, FSC, IDUM) CALL PLA162 (45, IH, IK, IL, MOD(IK, 3), XISI, FSC, IDUM) CALL PLA162 (46, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM) IF (MOD(-IH + IK + IL, 3) .EQ. 0 .OR. 1 MOD( IH - IK + IL, 3) .EQ. 0) THEN MODRTWIN = 0 ELSE MODRTWIN = 1 ENDIF CALL PLA162 (47, IH, IK, IL, MODRTWIN , XISI, FSC, IDUM) IF (MOD (IK, 2) .EQ. 0 .AND. MOD (IK + IL, 4) .EQ. 2) THEN MODRTWIN = 1 ELSE MODRTWIN = 0 ENDIF CALL PLA162 (48, IH, IK, IL, MODRTWIN , XISI, FSC, IDUM) IF (MOD (IH, 2) .EQ. 0 .AND. MOD (IH + IL, 4) .EQ. 2) THEN MODRTWIN = 1 ELSE MODRTWIN = 0 ENDIF CALL PLA162 (49, IH, IK, IL, MODRTWIN , XISI, FSC, IDUM) IF (MOD (IH, 2) .EQ. 0 .AND. MOD (IH + IK, 4) .EQ. 2) THEN MODRTWIN = 1 ELSE MODRTWIN = 0 ENDIF CALL PLA162 (50, IH, IK, IL, MODRTWIN , XISI, FSC, IDUM) IF (MODE .NE. 0) THEN IF (IH .EQ. 0) THEN CALL PLA162 (7, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM) CALL PLA162 (8, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (9, IH, IK, IL, MOD(IK + IL, 2), XISI, FSC, 1 IDUM) CALL PLA162 (19, IH, IK, IL, MOD(IK + IL, 4), XISI, FSC, 1 IDUM) IF (IK .EQ. 0) THEN CALL PLA162 (10, IH, IK, IL, 0, XISI, FSC, IDUM) CALL PLA162 (11, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (12, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (18, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (20, IH, IK, IL, MOD(IL, 4), XISI, FSC, IDUM) CALL PLA162 (24, IH, IK, IL, MOD(IL, 4), XISI, FSC, IDUM) CALL PLA162 (31, IH, IK, IL, MOD(IL, 6), XISI, FSC, IDUM) CALL PLA162 (39, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM) ELSE IF (IL .EQ. 0) THEN CALL PLA162 (14, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM) CALL PLA162 (15, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM) CALL PLA162 (17, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM) CALL PLA162 (21, IH, IK, IL, MOD(IK, 4), XISI, FSC, IDUM) CALL PLA162 (23, IH, IK, IL, MOD(IK, 4), XISI, FSC, IDUM) ENDIF ELSE IF (IK .EQ. 0) THEN CALL PLA162 (10, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) CALL PLA162 (11, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (12, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC, 1 IDUM) CALL PLA162 (20, IH, IK, IL, MOD(IH + IL, 4), XISI, FSC, 1 IDUM) IF (IL .EQ. 0) THEN CALL PLA162 (14, IH, IH, IL, 0, XISI, FSC, IDUM) CALL PLA162 (16, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) CALL PLA162 (22, IH, IK, IL, MOD(IH, 4), XISI, FSC, IDUM) ENDIF ELSE IF (IL .EQ. 0) THEN CALL PLA162 (13, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) CALL PLA162 (14, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM) CALL PLA162 (15, IH, IK, IL, MOD(IH + IK, 2), XISI, FSC, 1 IDUM) CALL PLA162 (21, IH, IK, IL, MOD(IH + IK, 4), XISI, FSC, 1 IDUM) IF (IH .EQ. IK) THEN CALL PLA162 (32, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) ENDIF ELSE IF (IH .EQ. IK) THEN CALL PLA162 (25, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (26, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) CALL PLA162 (27, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC, 1 IDUM) CALL PLA162 (28, IH, IK, IL, MOD(2 * IH + IL, 4), XISI, 1 FSC, IDUM) CALL PLA162 (34, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM) ELSE IF (IH .EQ. -IK .AND. IH .NE. 0) THEN CALL PLA162 (29, IH, IK, IL, MOD(IH + IL, 3), XISI, FSC, 1 IDUM) CALL PLA162 (30, IH, IK, IL, MOD(- IH + IL, 3), XISI, 1 FSC, IDUM) CALL PLA162 (33, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (40, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM) ELSE IF (IK .EQ. -2 * IH .AND. IH .NE. 0) THEN CALL PLA162 (35, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (37, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM) ELSE IF (IH .EQ. - 2 * IK .AND. IH .NE. 0) THEN CALL PLA162 (36, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM) CALL PLA162 (38, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM) ENDIF ENDIF RETURN END SUBROUTINE PLA162 (NEX, IH, IK, IL, MHKL, XISI, FSC, LATT) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30,NCS=50) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10) COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12), 1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12), 2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA, 3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC, 4 RAVERA, RAVERH COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /LFSPGR/ EX COMMON /DSPGR/ TYPE, NLAUE CHARACTER TYPE(NCS)*16, NLAUE(13)*5 COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1, LAUE*5 LOGICAL EX(NCS) COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 CHARACTER PRBUF*132, TYP0*3 C ******************************************************************C C*******************************************************************C IF (NEX .GT. 0) THEN IF (MHKL .EQ. 0) THEN SUM(NEX, 1) = SUM(NEX, 1) + FSC * XISI SUM(NEX, 4) = SUM(NEX, 4) + FSC NUM(NEX, 1) = NUM(NEX, 1) + 1 ELSE SUM(NEX, 2) = SUM(NEX, 2) + FSC * XISI SUM(NEX, 5) = SUM(NEX, 5) + FSC NUM(NEX, 2) = NUM(NEX, 2) + 1 IF (XISI .GT. XMFS(NEX)) THEN IF (IH .NE. 5 .AND. IK .NE. 5 .AND. IL .NE. 5) THEN XMFS(NEX) = XISI NUM(NEX, 3) = IH NUM(NEX, 4) = IK NUM(NEX, 5) = IL ENDIF ENDIF ENDIF ELSE IF (NEX .EQ. 0) THEN DO 20 I = 1, NCS XMFS(I) = 0.0 DO 10 J = 1, 5 SUM(I, J) = 0.0 NUM(I, J) = 0 10 CONTINUE 20 CONTINUE IPR(481) = 0 ELSE IF (NEX .LT. 0) THEN DO 30 I = 1, NCS IF (NUM(I, 1) .GT. 0) SUM(I, 1) = SUM(I, 1) / SUM(I, 4) IF (NUM(I, 2) .GT. 0) SUM(I, 2) = SUM(I, 2) / SUM(I, 5) IF (SUM(I, 2) .GT. 0.0) THEN SUM(I, 3) = SUM(I, 1) / SUM(I, 2) ELSE IF (SUM(I, 1) .GT. 1.0) THEN SUM(I, 3) = 99.00 ELSE SUM(I, 3) = 0.0 ENDIF ENDIF IF ((SUM(I, 2) .LT. CRI(1) .AND. SUM(I, 3) .GT. CRI(2)) 1 .OR. (SUM(I, 2) .LT. CRI(3) .AND. SUM(I, 3) .GT. CRI(4)) 2 .OR. (SUM(I, 2) .LT. CRI(5) .AND. SUM(I, 3) .GT. CRI(6)) 3 .OR. (SUM(I, 2) .LT. CRI(7) .AND. SUM(I, 3) .GT. CRI(8)) 4 .OR. (SUM(I, 2) .LT. CRI(9) .AND. SUM(I, 3) .GT. CRI(10)) 5 .OR. SUM(I, 3) .GT. CRI(11)) THEN IF (XMFS(I) .GT. 5.0) THEN EXT(I) = '?' ELSE EXT(I) = 'E' ENDIF EX(I) = .TRUE. ELSE IF (SUM(I, 2) .GT. 0.0 .AND. SUM(I, 2) .LT. 1.5 1 .AND. XMFS(I) .LT. 3.0) THEN EXT(I) = '?' EX(I) = .TRUE. ELSE IF (SUM(I, 3) .GT. 2.0) THEN EXT(I) = '>' ELSE EXT(I) = ' ' ENDIF EX(I) = .FALSE. ENDIF ENDIF 30 CONTINUE IF (EX(1) .AND. EX(2) .AND. EX(3)) THEN LATT = 5 NXCT = NUM(1, 2) + NUM(2, 2) + NUM(3, 2) ELSE IF (EX(5)) THEN LATT = 7 NXCT = NUM(5, 2) ELSE IF (EX(4)) THEN LATT = 6 NXCT = NUM(4, 2) ELSE IF (EX(1)) THEN LATT = 4 NXCT = NUM(1, 2) ELSE IF (EX(2)) THEN LATT = 3 NXCT = NUM(2, 2) ELSE IF (EX(3)) THEN LATT = 2 NXCT = NUM(3, 2) ELSE LATT = 1 NXCT = 0 ENDIF IF (NXCT .NE. 0) LATT = - LATT IF (IPR(548) .EQ. 0) THEN M = 2 + IWIN ELSE M = 2 ENDIF DO 200 N = 1, M NRSC = 0 IF (N .EQ. 1) THEN LU = LU6 ELSE IF (N .EQ. 2) THEN LU = LU7 ELSE LU = 0 ENDIF 40 IF (LU .EQ. LU7) CALL PLA269 (0) IF (LU .EQ. 0) THEN CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT ENDIF IF (NEX .EQ. -1) THEN WRITE (PRBUF, 99994) IF (LU .GT. 0) THEN WRITE (LU, 99988) PRBUF(1:80) ELSE VRT = VRT - 0.8 CALL GGIP20 (0.0, PRBUF, 80, 0.30, 1, 2, 1.0, VRT) VRT = VRT - 0.4 ENDIF ELSE IF (NEX .EQ. -2) THEN WRITE (PRBUF, 99990) IF (LU .GT. 0) WRITE (LU, 99989) PRBUF(1:80) ENDIF PAR(428) = (SUM(1, 1) * NUM(1, 1) + SUM(1, 2) * NUM(1, 2)) 1 / (NUM(1, 1) + NUM(1, 2)) DO 50 I = 1, NCS IF (NEX .EQ. -1) THEN IF (I .GT. 6 .AND. I .LE. 40) GOTO 50 ELSE IF (NEX .EQ. -2) THEN IF (I .GT. 46) GOTO 50 ENDIF IF (EXT(I) .NE. ' ') THEN TYP0 = TYPE(I)(14:16) NRSC = 1 ELSE TYP0 = ' ' ENDIF WRITE (PRBUF, 99999) IF (I .EQ. 1) THEN IF (LU .GT. 0) THEN WRITE (LU, 99987) PRBUF(1:80) WRITE (LU, 99998) WRITE (LU, 99997) ELSE VRT = VRT - 0.5 CALL GGIP20 (0.0, PRBUF, 80, 0.30, 5 + IGBL(68), 2, 1 1.0, VRT) VRT = VRT - 0.4 WRITE (PRBUF, 99998) CALL GGIP20 (0.0, PRBUF, 80, 0.30, 5 + IGBL(68), 2, 1 1.0, VRT) ENDIF ENDIF WRITE (PRBUF, 99996) I, EXT(I), TYP0, TYPE(I)(1:13), 1 SUM(I, 1), SUM(I, 2), NUM(I, 1), NUM(I, 2), XMFS(I), 2 (NUM(I, J), J = 3, 5), SUM(I, 3) IF (LU .GT. 0) THEN IF (LU .EQ. LU6) THEN IF (TYP0 .NE. ' ') THEN IPR(481) = IPR(481) + 1 WRITE (LU6, 99987) PRBUF(1:80) WRITE (LU2, 99995) EXT(I), TYP0, TYPE(I)(1:13), 1 SUM(I, 1), SUM(I, 2), NUM(I, 1), NUM(I, 2), 2 XMFS(I), (NUM(I, J), J = 3, 5), SUM(I, 3) ENDIF ELSE IF (LU .EQ. LU7) THEN WRITE (LU7, 99987) PRBUF(1:80) ENDIF ELSE VRT = VRT - 0.4 CALL GGIP20 (0.0, PRBUF, 80, 0.30, 1, 2, 1.0, VRT) ENDIF 50 CONTINUE IF (LU .GT. 0) THEN IF (NRSC .EQ. 0) WRITE (LU, 99993) IF (NEX .EQ. -2) THEN IF (LU .EQ. LU7) CALL PLA269 (0) WRITE (LU, 99991) (CRI(J), J = 1, 10) ENDIF ELSE CALL PLA013 (2, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 40 ENDIF 200 CONTINUE ENDIF RETURN 99999 FORMAT ('Nr Ex. Condition Aver(I/sig(I)) ', 1 'Number of Refl', 2X, 'I/sigI', 12X, '.T/F.') 99998 FORMAT (24X, '.True. .False. .True. .False. Max.F', 1 ' H K L Ratio') 99997 FORMAT (78('=')) 99996 FORMAT (I2, 1X, A, 1X, A, 1X, A, 2F8.2, 2I7, F9.2, 2X, 3I3, 1 F6.1) 99995 FORMAT ('EXTI ', A, 1X, A, 1X, A, 2F7.2, 2I7, F9.2, 2X, 3I3, 1 F8.2) 99994 FORMAT ('Analysis of General Reflections for Bravais ', 1 'Centering') 99993 FORMAT (':: No Extinction Conditions Found') 99991 FORMAT (/, 'NOTE: Reflections obscured by BeamStop Excluded', 1 ' from Statistics', /, 2 ' 5 0 0 etc. not included in Exception list (Fe?)', //, 3 'Extinction Conditions have been Marked with E when', /, 4 ' (.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /, 5 '.or. (.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /, 6 '.or. (.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /, 7 '.or. (.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /, 8 '.or. (.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /) 99990 FORMAT ('Analysis of Systematic Absences') 99989 FORMAT (/, A, /, 31('=')) 99988 FORMAT (/, A, /) 99987 FORMAT (A) END SUBROUTINE PLA163 (NAME) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP18=50, 1 NP22=256,NP38=125,NP39=30,NCS=50) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12), 1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12), 2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA, 3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC, 4 RAVERA, RAVERH COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS CHARACTER NAME*7, NAME1*7, NAME2*5 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 LINE = 'SPGR '//NAME CALL GEN038 (LINE, 13, 80) CALL SGSM (LINE, 0, FN, 0, 0, IERR) CALL SGSM (LINE, 0, FN, 0, 18, IERR) IF (NAME .EQ. 'Pa ') THEN NAME1 = 'Pc' NAME2 = 'C-BA' ELSE IF (NAME .EQ. 'P2/a ') THEN NAME1 = 'P2/c' NAME2 = 'C-BA' ELSE IF (NAME .EQ. 'P21/a ') THEN NAME1 = 'P21/c' NAME2 = 'C-BA' ELSE IF (NAME .EQ. 'Pn ') THEN NAME1 = 'Pc' NAME2 = 'A-B-N' ELSE IF (NAME .EQ. 'P2/n ') THEN NAME1 = 'P2/c' NAME2 = 'A-B-N' ELSE IF (NAME .EQ. 'P21/n ') THEN NAME1 = 'P21/c' NAME2 = 'A-B-N' ELSE IF (NAME .EQ. 'Pb-3 ') THEN NAME1 = 'Pa-3' NAME2 = 'BA-C' ELSE NAME1 = LINE(1:7) NAME2 = LINE(8:11) ENDIF IF (NAME2(1:3) .EQ. ' ') NAME2 = 'ABC ' CALL GEN020 (1, NAME2, 1, 5) IL = NINT(FN(3)) ID2 = NINT(FN(5)) ID3 = 1 IF (ID2 .EQ. 2) THEN NZP = IPERC ELSE NZP = 100 - IPERC ENDIF IF (LINE(71:72) .EQ. ' C') THEN LINE(71:77) = ' Chiral' ELSE LINE(71:77) = ' ' ENDIF RAVER = RVL(IL, 1) ISGNR = NINT(FN(1)) READ (LINE(66:70), 99997) IFRQ WRITE (PRBUF, 99999) IL, ID2, ID3, NAME, ISGNR, 1 IFRQ, NAME1, NAME2, RAVER, NTL(IL, 3) , 2 NZP, LINE(71:77), LINE(14:14) IF (LU .EQ. 0) THEN VRT = VRT - 0.7 IF (RVL(IL, 1) .GT. RMAX) THEN NCOL = 2 ELSE NCOL = 1 ENDIF CALL GGIP20 (0.0, PRBUF(13:80), 68, 0.35, NCOL, 2, 0.1, VRT) ELSE WRITE (LU, 99998) PRBUF(13:80) IF (LU .EQ. LU7) THEN WRITE (LU2, 99998) PRBUF(1:80) IF (LINE(14:14) .EQ. 'C') THEN IF (RAVER .LT. RAVERC) THEN IF (NZP .GT. IPCNTC) THEN IF (IFRQ .GT. IFRQC) THEN ISPGRC = ISGNR IFRQC = IFRQ RAVERC = RVL(IL, 1) IPCNTC = NZP ENDIF ENDIF ENDIF ELSE IF (RAVER .LT. RAVERA) THEN IF (NZP .GT. IPCNTA) THEN IF (IFRQ .GT. IFRQA) THEN ISPGRA = ISGNR IFRQA = IFRQ RAVERA = RVL(IL, 1) IPCNTA = NZP ENDIF ENDIF ENDIF IF (LINE(71:72) .EQ. ' C') THEN IF (RAVER .LT. RAVERH) THEN IF (NZP .GT. IPCNTH) THEN IF (IFRQ .GT. IFRQH) THEN ISPGRH = ISGNR IFRQH = IFRQ RAVERH = RVL(IL, 1) IPCNTH = NZP ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF RETURN 99999 FORMAT ('SPGR ', 3I2, 1X, A, I4, I6, 2X, A, ' :', A, F8.2, 1 I6, I4, A, 1X, A) 99998 FORMAT (A) 99997 FORMAT (I5) END SUBROUTINE PLA164 (IMODE, IAPPEND, OLATT, TM1, AXCRIT) PARAMETER (NP12=600,NP13=500,NP17=99,NP18=50,NPVD=40000000, 1 NP23=18000, NP38=125,NP39=30,NCS=50,NSCR=2*NP23-1501*14) C ********************************************************************** C ********************************************************************** C ********************************************************************** INTEGER DOT DIMENSION MS(10, 55) REAL MAXD, V(3), ORT(3, 3), TAU(3) LOGICAL CHANGE DIMENSION TM1(3, 3) CHARACTER OLATT*1, LAT0*1, LATT*1 COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /CHARS/ LAT0, LATT(3) COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8) COMMON // DHX(3, 1501), TT(1501, 11), ISCR(NSCR), VOID(NPVD) COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT(3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12), 1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12), 2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA, 3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC, 4 RAVERA, RAVERH COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5 COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7) CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS COMMON /LPLATC/ BLATT(NP18), CLATT(NP18) CHARACTER BLATT*1, CLATT*1 IWIN = IGBL(25) * IGBL(32) K1 = 1 IF (IMODE .EQ. 0) THEN LUIM = 2 + IWIN ELSE IF (IMODE .GT. 0) THEN IF (IAPPEND .EQ. 0) THEN NRLT0 = 1 NRLT = 1 ELSE NRLT0 = NRLT0 + 1 NRLT = NRLT + 1 ENDIF LUIM = 2 DO 10 I = 1, 6 XCELL(I, NRLT0) = PAR(100 + I) 10 CONTINUE XCELL(7, NRLT0) = GEN045 (PAR(101)) DO 20 I = 1, 9 TLATT(I, NRLT0) = 0.0 20 CONTINUE TLATT (1, NRLT0) = 1.0 TLATT (5, NRLT0) = 1.0 TLATT (9, NRLT0) = 1.0 BLATT(NRLT0) = OLATT CLATT(NRLT0) = 'a' LLAUE(NRLT0) = 1 RVAL(NRLT0, 1) = 0.0 RVAL(NRLT0, 2) = 0.0 RVAL(NRLT0, 3) = 0.0 ENDIF NLPB = 0 NLPE = 0 IPR(117) = 4 30 IPR117 = IPR(117) IF (IPR(117) .EQ. 1) THEN NLPB = 72 NLPE = 127 ELSE IF (IPR(117) .EQ. 2) THEN NLPB = 72 NLPE = 92 ELSE IF (IPR(117) .EQ. 3) THEN NLPB = 72 NLPE = 79 ELSE IF (IPR(117) .EQ. 4) THEN NLPB = 16 NLPE = 16 ELSE IF (IPR(117) .EQ. 5) THEN NLPB = 16 NLPE = 23 ELSE IF (IPR(117) .EQ. 6) THEN NLPB = 16 NLPE = 36 ELSE IF (IPR(117) .EQ. 7) THEN NLPB = 16 NLPE = 71 ENDIF NLP = NLPB - 1 40 NLP = NLP + 1 50 CALL GEN101 (IPR(94), NVEC, DHX) CALL GEN074 (AXES, 0.0, 1, 345) CALL GEN074 (TT, 0.0, 1, NVEC * 11) IDET = 1 DO 60 I = 1, 6 OCELL(I) = PAR(100 + I) 60 CONTINUE OCELL(7) = GEN045 (OCELL) LATT(1) = OLATT DO 70 I = 1, 7 IF (LAT(I) .EQ. OLATT) GOTO 80 70 CONTINUE I = 1 80 DO 100 J = 1, 3 DO 90 K = 1, 3 TPS(J, K) = TRNSX(J, K, I) TPQ(J, K) = TRNSX(J, K, NLP) 90 CONTINUE 100 CONTINUE CALL GEN004 (TPQ, TPS, TP) CALL GEN026 (1, G, OCELL, GL(5)) CALL GEN001 (1, TP, G, G) CALL PLA088 (G, TP, PAR(440)) CALL GEN026 (-1, G, RCELL, GL(5)) RCELL(7) = GEN045 (RCELL) K = 0 L = 0 DO 120 I = 1, 3 DO 110 J = 1, 3 TPS(I, J) = TP(I, J) K = K + 1 TLATT(K, NRLT0 + 1) = TP(I, J) IF (NRLT0 .NE. 0) THEN IF (TLATT(K, NRLT0 + 1) .NE. TLATT(K, NRLT0)) L = 1 ELSE L = 1 ENDIF 110 CONTINUE 120 CONTINUE BLATT(NRLT0 + 1) = 'P' CLATT(NRLT0 + 1) = 'a' LLAUE(NRLT0 + 1) = 1 RVAL(NRLT0 + 1, 1) = 0.0 RVAL(NRLT0 + 1, 2) = 0.0 RVAL(NRLT0 + 1, 3) = 0.0 DO 130 K = 1, 7 XCELL(K, NRLT0 + 1) = RCELL(K) 130 CONTINUE IF (NRLT0 .NE. 0) THEN IF (BLATT(NRLT0 + 1) .NE. BLATT(NRLT0)) L = 1 ELSE L = 1 ENDIF NRLT0 = NRLT0 + L NRLT = NRLT0 CALL GEN044 (RCELL, OR) CALL GEN005 (OR, ORT) CALL GEN003 (ORT, ROTQ, DET, 0) DO 160 K = 1, NVEC DO 140 I = 1, 3 V(I) = DHX(I, K) 140 CONTINUE CALL GEN002 (1, OR, V, T, XLNG) DKW = 0.0 DO 150 J = 1, 3 TT(K, J) = T(J) TT(K, J + 3) = T(J) * T(J) DKW = DKW + TT(K, J + 3) 150 CONTINUE TT(K, 7) = T(1) * T(2) TT(K, 8) = T(1) * T(3) TT(K, 9) = T(2) * T(3) TT(K, 10) = SQRT(ABS(DKW)) TT(K, 11) = K 160 CONTINUE 170 CHANGE = .FALSE. DO 180 K = 1, NVEC - 1 IF (TT(NINT(TT(K, 11)), 10) .GT. TT(NINT(TT(K + 1, 11)), 10)) 1 THEN CALL GEN018 (TT(K, 11), TT(K + 1, 11)) CHANGE = .TRUE. ENDIF 180 CONTINUE IF (CHANGE) GOTO 170 I = NVEC ITEL = 0 MAXD = 0.0 DO 230 J = 1, NVEC DO 190 I = 1, 3 V(I) = DHX(I, J) 190 CONTINUE CALL GEN002 (1, ROTQ, V, TAU, XLNG) TC(1) = TAU(2) * TAU(2) + TAU(3) * TAU(3) TC(2) = TAU(1) * TAU(1) + TAU(3) * TAU(3) TC(3) = TAU(1) * TAU(1) + TAU(2) * TAU(2) TC(4) = -2 * TAU(1) * TAU(2) TC(5) = -2 * TAU(1) * TAU(3) TC(6) = -2 * TAU(2) * TAU(3) DO 220 K = 1, NVEC DOT = 0 DO 200 N = 1, 3 DOT = DOT + ABS(NINT(DHX(N, J) * DHX(N, K))) 200 CONTINUE IF (DOT .GT. IPR(94) .OR. DOT .LE. 0) GOTO 220 TAND = TT(K, 4) * TC(1) + TT(K, 5) * TC(2) 1 + TT(K, 6) * TC(3) + TT(K, 7) * TC(4) 2 + TT(K, 8) * TC(5) + TT(K, 9) * TC(6) TAND = ATAN(SQRT(ABS(TAND)) / DOT) * GL(5) IF (TAND .GT. AXCRIT) GOTO 220 IF (ITEL .EQ. 15) THEN CALL GEN122 (AXES, 8, ITEL) CALL GEN122 (AXES, 7, ITEL) ITEL = 8 END IF ITEL = ITEL + 1 DO 210 I = 1, 3 AXES(ITEL, I) = DHX(I, K) AXES(ITEL, I + 3) = DHX(I, J) AXES(ITEL, I + 9) = TT(K, I) / TT(K, 10) 210 CONTINUE AXES(ITEL, 7) = TAND AXES(ITEL, 8) = TT(K, 10) AXES(ITEL, 9) = DOT IF (TAND .GT. MAXD) MAXD = TAND 220 CONTINUE 230 CONTINUE IF (ITEL .GT. IPR(514)) THEN CALL GEN122 (AXES, 7, ITEL) ITEL = IPR(514) ENDIF METRIC = 0 NTEL = ITEL IBEG = 1 IEND = 0 ISOL = 0 CALL GEN122 (AXES, 7, ITEL) GOTO 250 240 CALL GEN122 (AXES, 7, ITEL) IF (ITEL .EQ. 7) THEN ITEL = ITEL - 4 ELSE ITEL = ITEL - 2 ENDIF 250 IF (LUIM .EQ. 3) THEN BCD = 'LePage'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, BCD, 7, 1.4, 4, 8, 10.6, VERT - 1.8) CALL GGIP20 (0.0, BCD, 7, 1.4, 2, 8, 10.4, VERT - 1.9) IF (NLPE .GT. NLPB) THEN WRITE (BCD, 99996) NLP - NLPB + 1, 1 ((TPQ(I, J), J = 1, 3), I = 1, 3), GEN084 (TRNSX, NLP) CALL GGIP20 (0.0, BCD, 80, 0.35, 3, 2, 0.1, 6.0) ENDIF ENDIF 260 DO 280 I = 1, 3 DO 270 J = 1, 3 TP(I, J) = TPS(I, J) 270 CONTINUE 280 CONTINUE IF (ITEL .EQ. -1) THEN ITEL = 0 ELSE IF (ITEL .EQ. -2) THEN GOTO 640 ELSE CALL GEN122 (AXES, 8, ITEL) ENDIF IF (ITEL .GT. 1 .AND. MOD(ITEL, 2) .EQ. 0) ITEL = ITEL - 1 CALL PLA165 (ITEL, MAXD, AXCRIT, ISOL, LUIM) IF (MAXD .LE. PAR(441) .AND. METRIC .EQ. 0 .AND. ISOL .EQ. 1) 1 THEN METRIC = 1 NTEL = ITEL DO 290 I = 1, 9 AXES(I, 23) = I 290 CONTINUE ENDIF IF (ITEL .GT. 0 .AND. (METRIC .EQ. 0 .OR. ISOL .EQ. 0)) GOTO 620 ILAT0 = LAT0 DO 310 I = 1, 3 DO 300 J = 1, 3 TRMX(I, J) = TP(I, J) 300 CONTINUE 310 CONTINUE CALL GEN004 (TRMX, TM1, TRMXT) ILAT1 = LATT(3) CALL PLA167 IF (ILAT0 .EQ. 'a') THEN I1 = 1 I2 = 1 ELSE IF (ILAT0 .EQ. 'm') THEN I1 = 2 I2 = 2 ELSE IF (ILAT0 .EQ. 'o') THEN I1 = 3 I2 = 3 ELSE IF (ILAT0 .EQ. 't') THEN I1 = 4 I2 = 5 ELSE IF (ILAT0 .EQ. 'h') THEN IF (ILAT1 .EQ. 'R') THEN I1 = 6 I2 = 7 ELSE I1 = 6 I2 = 10 ENDIF ELSE I1 = 11 I2 = 12 ENDIF IF (IMODE .EQ. 3) THEN RVLX = 100.0 ELSE RVLX = 0.0 ENDIF DO 430 I0 = I2, I1, - 1 RVLX = MIN (RVLX, RVL(I0, 1)) IF (IMODE .NE. 0) THEN YUNK = ABS(CELL(4) - 90.0) + ABS(CELL(5) - 90.0) + 1 ABS(CELL(6) - 90.0) IF (YUNK .LT. 0.001) THEN YUNK = 0.0 DO 330 I = 1, 3 DO 320 J = 1, 3 IF (I .NE. J) THEN YUNK = YUNK + ABS(TRMXT(I, J)) ENDIF 320 CONTINUE 330 CONTINUE IF (YUNK .LT. 0.001) THEN DO 340 I = 1, 3 TRMXT(I, I) = ABS(TRMXT(I, I)) 340 CONTINUE ENDIF ENDIF WRITE (LU2, 99999) ((TRMXT(I, J), J = 1, 3), I = 1, 3), 1 ILAT0, ILAT1, I0, (RVL(I0, K), K = 1, 3), 2 (NTL(I0, K), K = 1, 3), (CELL(I), I = 1, 7) IF (RVL(I0, 1) .LE. 40) THEN CLATT(NRLT0 + 1) = ILAT0 BLATT(NRLT0 + 1) = ILAT1 CALL GEN020 (-1, CLATT(NRLT0 + 1), 1, 1) CALL GEN020 ( 1, BLATT(NRLT0 + 1), 1, 1) LLAUE(NRLT0 + 1) = I0 DO 350 I = 1, 3 RVAL(NRLT0 + 1, I) = RVL(I0, I) 350 CONTINUE DO 360 I = 1, 7 XCELL(I, NRLT0 + 1) = CELL(I) 360 CONTINUE M = 0 DO 380 K = 1, 3 DO 370 J = 1, 3 M = M + 1 TLATT(M, NRLT0 + 1) = TRMXT(K, J) 370 CONTINUE 380 CONTINUE DO 420 I = 1, NRLT0 DIFF = 0.0 DO 390 M = 1, 9 DIFF = DIFF + ABS(TLATT(M, I) - TLATT(M, NRLT0 + 1)) 390 CONTINUE IF (DIFF .LT. 0.001) THEN IF (CLATT(NRLT0 + 1) .EQ. CLATT(I)) THEN IF (BLATT(NRLT0 + 1) .EQ. BLATT(I)) THEN IF (LLAUE(NRLT0 + 1) .EQ. LLAUE(I)) THEN IF (I .EQ. 1) THEN DO 400 J = 1, 3 RVAL(1, J) = RVAL(NRLT0 + 1, J) 400 CONTINUE GOTO 430 ELSE IF (RVAL(NRLT0 + 1, 1) .EQ. RVAL(I, 1)) THEN DIFF = 0.0 DO 410 J = 1, 7 DIFF = DIFF + 1 ABS(XCELL(J, I) - XCELL(J, NRLT0 + 1)) 410 CONTINUE IF (DIFF .LT. 0.01) GOTO 430 ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF 420 CONTINUE NRLT0 = NRLT0 + 1 IF (RVAL(NRLT0, 1) .LT. RMAX) THEN IF (K1 .EQ. 1) THEN IF (BLATT(NRLT0) .EQ. 'P' .AND. 1 CLATT(NRLT0) .EQ. 'a') THEN NRLT = NRLT0 ENDIF ENDIF IF (LLAUE(NRLT0) .GT. K1) THEN NRLT = NRLT0 K1 = LLAUE(NRLT0) ENDIF ENDIF ENDIF ENDIF 430 CONTINUE IF ((IMODE .EQ. 1 .OR. RVLX .GT. RMAX) .AND. ITEL .GT. 0) THEN IF (IMODE .EQ. 1 .AND. (IEND .LT. IBEG .AND. ITEL .EQ. 1)) THEN ITEL = 0 GOTO 240 ENDIF DO 440 I = 1, NTEL AXES(I, 23) = MOD(AXES(I, 23), 1000.0) 440 CONTINUE CALL GEN122 (AXES, 23, NTEL) IF (IEND .EQ. 0) THEN IF (NTEL .GT. 1) THEN DO 460 I = 1, NTEL IEND = IEND + 1 MS(10, IEND) = 1 DO 450 J = 1, 9 IF (J .EQ. I) THEN MS(J, IEND) = 1 ELSE MS(J, IEND) = 0 ENDIF 450 CONTINUE 460 CONTINUE ENDIF IEND = IEND + 1 DO 470 J = 1, 10 MS(J, IEND) = 0 470 CONTINUE ENDIF IF (ILAT0 .EQ. 'c') THEN DO 490 J = 1, 3 IEND = IEND + 1 MS(10, IEND) = 5 DO 480 I = 1, 9 IF (ABS(ABS(AXES(J, 13 + I)) - 90.0) .LT. AXCRIT) THEN MS(I, IEND) = 1 ELSE MS(I, IEND) = 0 ENDIF 480 CONTINUE MS(J, IEND) = 1 490 CONTINUE V(1) = 1.0 DO 520 I = 1, 4 IF (I .GT. 2) THEN V(2) = -1.0 ELSE V(2) = 1.0 ENDIF IF (MOD(I, 2) .EQ. 0) THEN V(3) = -1.0 ELSE V(3) = 1.0 ENDIF IEND = IEND + 1 MS(10, IEND) = 3 DO 510 J = 1, 9 DOT = 0 DO 500 K = 1, 3 DOT = DOT + NINT(AXES(J, K) * V(K)) 500 CONTINUE IF (DOT .EQ. 0) THEN MS(J, IEND) = 1 ELSE MS(J, IEND) = 0 ENDIF 510 CONTINUE 520 CONTINUE ELSE IF (ILAT0 .EQ. 'h') THEN IF (ILAT1 .EQ. 'P') THEN DO 540 J = 1, 7 IF (NINT(AXES(J, 13)) .EQ. 2) THEN IEND = IEND + 1 MS(10, IEND) = 3 DO 530 I = 1, 7 IF (ABS(ABS(AXES(J, 13 + I)) - 90.0) .LT. AXCRIT) 1 THEN MS(I, IEND) = 1 ELSE MS(I, IEND) = 0 ENDIF 530 CONTINUE MS(J, IEND) = 1 ENDIF 540 CONTINUE ENDIF ELSE IF (ILAT0 .EQ. 't') THEN IEND = IEND + 1 MS(10, IEND) = 3 DO 550 I = 1, 9 IF (NINT(AXES(I, 13)) .EQ. 4) THEN MS(I, IEND) = 1 J = I ELSE MS(I, IEND) = 0 ENDIF 550 CONTINUE N = 1 DO 560 I = 1, 5 IF (ABS(ABS(AXES(J, 13 + I)) - 90.0) .LT. AXCRIT) THEN N = N + 1 MS(I, IEND) = 1 IF (N .EQ. 3) GOTO 570 ENDIF 560 CONTINUE ENDIF ENDIF 570 IF (IEND .GE. IBEG) THEN IF (IBEG .GT. 1) THEN DO 590 I = 1, IBEG - 1 DO 580 J = 1, 10 IF (MS(J, IBEG) .NE. MS(J, I)) GOTO 590 580 CONTINUE IBEG = IBEG + 1 GOTO 640 590 CONTINUE ENDIF DO 600 I = 1, NTEL AXES(I, 23) = MOD(AXES(I, 23), 1000.0) 600 CONTINUE DO 610 I = 1, NTEL IF (MS(I, IBEG) .EQ. 0) AXES(I, 23) = AXES(I, 23) + 1000.0 610 CONTINUE CALL GEN122 (AXES, 23, NTEL) ITEL = MS(10, IBEG) IBEG = IBEG + 1 GOTO 260 ENDIF IF (IEND .GT. 0) ITEL = 1 620 IF (IWIN .EQ. 1 .AND. IMODE .EQ. 0) THEN IF (METRIC .EQ. 0 .OR. NLP .LT. NLPE) THEN WRITE (SBCD, 99997) CHAR(0) ELSE WRITE (SBCD, 99998) CHAR(0) ENDIF CALL PLA015 (0, 39) CALL PLA013 (0, 1) IF (IPR(117) .NE. IPR117) GOTO 30 IF (IGGT(1:4) .EQ. 'REST' .OR. IGGT(1:4) .EQ. 'PLOT') GOTO 50 IF (IGGT(1:4) .EQ. 'EXIT') GOTO 640 IF (IGGT(1:3) .EQ. 'END') GOTO 630 IF (IGGT(1:1) .EQ. '!' .OR. IGGT(1:4) .EQ. 'NEXT') THEN IF (METRIC .EQ. 0) THEN GOTO 240 ELSE GOTO 630 ENDIF ENDIF ENDIF 630 IF (NLP .LT. NLPE) GOTO 40 640 IF (IMODE .GT. 0) THEN OPEN (LU61, FILE = NAME(1)(1:KNM(1))//'.trm', 1 STATUS = 'UNKNOWN', FORM = 'UNFORMATTED') NREXT = IPR(481) AVIOS = PAR(428) WRITE (LU61) NRLT0, NRLT, NREXT, AVIOS, RMAX, 1 RVL, NTL, TLATT, XCELL, LLAUE, RVAL, CLATT, BLATT CLOSE (LU61) ENDIF CALL GEN038 (IGGT, 1, 80) IGBL(23) = 10 RETURN 99999 FORMAT ('TRMX ', 9F7.3, 1X, A, A, I3, ' =', /, 5X, 3F6.1, 3I8, 1 ' = ', /, 5X, 3F10.4, 3F8.3, F10.2) 99998 FORMAT ('[END]', A) 99997 FORMAT ('[NEXT]', A) 99996 FORMAT ('TRANS:', I2, ' (', 3F6.2, ' /', 3F6.2, ' /', 1 3F6.2, ') Det =', F5.2) END SUBROUTINE PLA165 (ITEL, MAXD, AXCRIT, ISOL, LUIM) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30,NSCR=2*NP23-1501*14) REAL MAXD, BB(3, 3) CHARACTER LATT*1, LAT0*1 CHARACTER SYST0*10, SYST*12, LINE*80 COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /CHARS/ LAT0, LATT(3) COMMON // DHX(3, 1501), TT(1501, 11), ISCR(NSCR), VOID(NPVD) COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT(3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 LATT(3) = 'P' MAXD = 0.0 ANGM = 0.0 ANGMN = 0.0 IF (ITEL .GT. 0) THEN ANGM = 0.0 ANGMN = 180.0 DO 20 I = 1, ITEL IF (AXES(I, 7) .GT. MAXD) MAXD = AXES(I, 7) AXES(I, 13) = 0.0 DO 10 J = 1, ITEL ANG = 0.0 AXES(I, J + 13) = 0.0 IF (I .NE. J) THEN ANG = AXES(I, 10) * AXES(J, 10) 1 + AXES(I, 11) * AXES(J, 11) 2 + AXES(I, 12) * AXES(J, 12) IF (ABS(ANG) .LT. 0.00001) THEN ANG = 90.0 ELSE IF (ANG .GE. 1.0) THEN ANG = 0 ELSE ANG = ACOS(ANG) * GL(5) IF (ANG .LT. 0.0) ANG = ANG + 180.0 IF (ANG .LT. 90.0) ANG = 180.0 - ANG ENDIF IF (ANG .GT. ANGM) ANGM = ANG IF (ANG .LT. ANGMN) ANGMN = ANG AXES(I, J + 13) = ANG IF (ANG + AXCRIT .GT. 90.0 .AND. 1 ANG - AXCRIT .LT. 90.0) 1 AXES(I, 13) = AXES(I, 13) + 1 ENDIF 10 CONTINUE 20 CONTINUE ENDIF IF (ITEL .EQ. 0) THEN SYST = 'Anorthic' CALL GEN021 (TM, 1) ELSE IF (ITEL .EQ. 1) THEN SYST = 'Monoclinic' DO 30 N = 1, 3 TM(2, N) = AXES(ITEL, N) 30 CONTINUE YDUM = COS((90.0 - AXCRIT) / GL(5)) D1 = 999.0 D2 = 0.0 DO 60 K = 1, NVEC DUM = (TT(K, 1) * AXES(ITEL, 10) 1 + TT(K, 2) * AXES(ITEL, 11) 2 + TT(K, 3) * AXES(ITEL, 12)) / TT(K,10) IF (ABS(DUM) .GT. YDUM) GOTO 60 IF (TT(K, 10) .GE. D1) THEN IF (TT(K, 10) .GT. D2) GOTO 60 I = 3 D2 = TT(K, 10) ELSE D2 = D1 DO 40 N = 1, 3 TM(3, N) = TM(1, N) CL(3, N) = CL(1, N) 40 CONTINUE I = 1 D1 = TT(K, 10) ENDIF DO 50 N = 1, 3 TM(I, N) = DHX(N, K) CL(I, N) = TT(K, N) 50 CONTINUE 60 CONTINUE DUM = CL(1, 1) * CL(3, 1) + CL(1, 2) * CL(3, 2) 1 + CL(1, 3) * CL(3, 3) IF (DUM .GT. 0.0) THEN DO 70 N = 1, 3 TM(3, N) = - TM(3, N) 70 CONTINUE ENDIF CALL GEN003 (TM, BB, DET, 0) IF (DET .LE. 0) THEN DO 80 N = 1, 3 TM(2, N) = - TM(2, N) 80 CONTINUE ENDIF ELSE IF (ITEL .EQ. 3) THEN SYST = 'Hexagonal ' IF (ANGM .GT. 120.0 + AXCRIT .OR. 1 ANGMN .LT. 120.0 - AXCRIT) THEN SYST = 'Orthorhombic' ZANG = 90 GOTO 170 ENDIF DOT = 0.0 K = 0 DO 100 I3 = 1, 3, 2 K = K + 1 DO 90 J3 = 1, 3 TM(K, J3) = AXES(I3, J3) CL(K, J3) = AXES(I3, J3 + 9) IF (K .EQ. 2) DOT = DOT + CL(1, J3) * CL(2, J3) 90 CONTINUE 100 CONTINUE IF (DOT .GT. 0) THEN DO 110 J3 = 1, 3 TM(2, J3) = - TM(2, J3) CL(2, J3) = - CL(2, J3) 110 CONTINUE ENDIF CRS1 = CL(1, 2) * CL(2, 3) - CL(1, 3) * CL(2, 2) CRS2 = CL(1, 3) * CL(2, 1) - CL(1, 1) * CL(2, 3) CRS3 = CL(1, 1) * CL(2, 2) - CL(1, 2) * CL(2, 1) TM(3, 1) = CRS1 * ROTQ(1, 1) + CRS2 * ROTQ(2, 1) 1 + CRS3 * ROTQ(3, 1) TM(3, 2) = CRS1 * ROTQ(1, 2) + CRS2 * ROTQ(2, 2) 2 + CRS3 * ROTQ(3, 2) TM(3, 3) = CRS1 * ROTQ(1, 3) + CRS2 * ROTQ(2, 3) 3 + CRS3 * ROTQ(3, 3) CALL GEN003 (TM, BB, DET, 0) DO 120 N = 1, 3 TMDUM = TM(3, N) * 3 / DET TM(3, N) = NINT(TMDUM) 120 CONTINUE DO 140 LOOP = 1, 2 MODL = 3 H(1) = 2 H(2) = 1 H(3) = 1 CALL GEN092 (MODL, H, TM, NUM) IF (NUM .EQ. 0) GOTO 230 DO 130 N = 1, 3 TM(1, N) = - TM(1, N) TM(2, N) = - TM(2, N) 130 CONTINUE 140 CONTINUE GOTO 310 ELSE IF (ITEL .EQ. 5) THEN SYST = 'Tetragonal' ZANG = 90.0 GOTO 170 ELSE IF (ITEL .EQ. 7) THEN SYST = 'Hexagonal' ZANG = 120.0 GOTO 170 ELSE IF (ITEL .EQ. 9) THEN SYST = 'Cubic' K3 = 0 N90 = 4 DO 160 I3 = 1, 9 IF (NINT(AXES(I3, 13)) .EQ. N90) THEN K3 = K3 + 1 IF (K3 .LE. 3) THEN DO 150 J3 = 1, 3 TM(K3, J3) = AXES(I3, J3) 150 CONTINUE ENDIF ENDIF 160 CONTINUE IF (K3 .NE. 3) GOTO 310 ELSE GOTO 320 ENDIF GOTO 230 170 N90 = ITEL - 1 IOK = 0 DO 180 I = 1, ITEL IF (NINT(AXES(I, 13)) .EQ. N90) IOK = 1 180 CONTINUE IF (IOK .EQ. 0) GOTO 310 YDUM1 = COS((ZANG - AXCRIT) / GL(5)) YDUM2 = COS((ZANG + AXCRIT) / GL(5)) K = 0 DO 210 I3 = 1, ITEL IF (NINT(AXES(I3, 13)) .LT. 2) GOTO 310 IF (ITEL .LE. 3) THEN K3 = I3 GOTO 190 ENDIF IF (NINT(AXES(I3, 13)) .EQ. N90) THEN K3 = 3 GOTO 190 ENDIF K = K + 1 IF (K .GT. 2) THEN K3 = 0 ELSE K3 = K ENDIF 190 IF (K3 .GT. 0) THEN DO 200 J3 = 1, 3 TM(K3, J3) = AXES(I3, J3) CL(K3, J3) = AXES(I3, J3 + 9) 200 CONTINUE ENDIF 210 CONTINUE DUM = CL(1, 1) * CL(2, 1) + CL(1, 2) * CL(2, 2) 1 + CL(1, 3) * CL(2, 3) IF (DUM .GT. 0.0) THEN DO 220 N = 1, 3 TM(2, N) = - TM(2, N) 220 CONTINUE DUM = - DUM ENDIF IF ((DUM .GT. YDUM1) .OR. (DUM .LT. YDUM2)) GOTO 310 230 LAT0 = SYST(1:1) CALL GEN020 (-1, LAT0, 1, 1) CALL GEN003 (TM, BB, DET, 0) IF (DET .LT. 0) THEN DO 240 N = 1, 3 TM(3, N) = - TM(3, N) 240 CONTINUE ENDIF IDET = NINT(ABS(DET)) IF (IDET .NE. 2) THEN IF (IDET .EQ. 3) LATT(3) = 'R' IF (IDET .EQ. 4) LATT(3) = 'F' ELSE MODL = 2 LATT(3) = 'A' H(1) = 0 H(2) = 1 H(3) = 1 CALL GEN092 (MODL, H, TM, NUM) IF (NUM .EQ. 0) GOTO 250 LATT(3) = 'B' H(1) = 1 H(2) = 0 H(3) = 1 CALL GEN092 (MODL, H, TM, NUM) IF (NUM .EQ. 0) GOTO 250 LATT(3) = 'C' H(1) = 1 H(2) = 1 H(3) = 0 CALL GEN092 (MODL, H, TM, NUM) IF (NUM .EQ. 0) GOTO 250 LATT(3) = 'I' H(1) = 1 H(2) = 1 H(3) = 1 CALL GEN092 (MODL, H, TM, NUM) IF ((NUM .NE. 0) .OR. (IDET .GT. 4)) THEN WRITE (LU6, 99988) WRITE (LU7, 99988) STOP 'STOPPED: "WRONG DETERMINANT!"' ENDIF 250 CONTINUE ENDIF IF ((ITEL .LT. 3) .AND. (LATT(3) .EQ. 'A')) THEN DO 260 N = 1, 3 CALL GEN018 (TM(1, N), TM(3, N)) TM(2, N) = - TM(2, N) 260 CONTINUE LATT(3) = 'C' ENDIF IF ((ITEL .EQ. 3) .AND. ((LATT(3) .EQ. 'A') .OR. 1 (LATT(3) .EQ. 'B'))) THEN IF (LATT(3) .EQ. 'A') THEN DO 270 N = 1, 3 CALL GEN018 (TM(1, N), TM(3, N)) CALL GEN018 (TM(1, N), TM(2, N)) 270 CONTINUE ELSE DO 280 N = 1, 3 CALL GEN018 (TM(2, N), TM(3, N)) TM(1, N) = - TM(1, N) 280 CONTINUE ENDIF LATT(3) = 'C' ENDIF CALL PLA166 (ITEL, LATT(1), AXCRIT, PAR(441), LUIM) CALL GEN004 (TM(1, 1), TP, TP) IF (LAT0 .EQ. 'm') THEN IF (LATT(3) .EQ. 'A') THEN TG(1, 1) = TP(1, 1) TG(1, 2) = TP(1, 2) TG(1, 3) = TP(1, 3) TP(1, 1) = TP(3, 1) TP(1, 2) = TP(3, 2) TP(1, 3) = TP(3, 3) TP(2, 1) = - TP(2, 1) TP(2, 2) = - TP(2, 2) TP(2, 3) = - TP(2, 3) TP(3, 1) = TG(1, 1) TP(3, 2) = TG(1, 2) TP(3, 3) = TG(1, 3) LATT(3) = 'C' ELSE IF (LATT(3) .EQ. 'I') THEN TG(1, 1) = TP(1, 1) TG(1, 2) = TP(1, 2) TG(1, 3) = TP(1, 3) TG(3, 1) = TP(3, 1) TG(3, 2) = TP(3, 2) TG(3, 3) = TP(3, 3) TP(1, 1) = -TG(1, 1) - TG(3, 1) TP(1, 2) = -TG(1, 2) - TG(3, 2) TP(1, 3) = -TG(1, 3) - TG(3, 3) TP(3, 1) = TG(1, 1) TP(3, 2) = TG(1, 2) TP(3, 3) = TG(1, 3) LATT(3) = 'C' ENDIF ENDIF IF (LAT0 .EQ. 'c') THEN LAT1 = 7 ELSE IF (LAT0 .EQ. 'h') THEN IF (LATT(3) .EQ. 'R') THEN LAT1 = 5 ELSE LAT1 = 6 ENDIF ELSE IF (LAT0 .EQ. 't') THEN LAT1 = 4 ELSE IF (LAT0 .EQ. 'o') THEN LAT1 = 3 ELSE IF (LAT0 .EQ. 'm') THEN LAT1 = 2 ELSE LAT1 = 1 ENDIF CALL GEN104 (LAT1, TP) CALL GEN003 (TP, TG, DETM, 0) SYST0 = 'Metrically' IF (MAXD .GT. PAR(441)) SYST0 = 'Pseudo' DO 290 LUI = 1, LUIM IF (LUI .EQ. 1) THEN LU = LU6 ELSE IF (LUI .EQ. 2) THEN LU = LU7 ELSE LU = 0 ENDIF WRITE (LINE, 99999) IF (LU .NE. 0) THEN WRITE (LU, 99989) WRITE (LU, 99995) LINE WRITE (LU, 99990) ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 5.0) ENDIF WRITE (LINE, 99998) (TP(1, J), J = 1, 3), 1 (TG(J, 1), J = 1, 3), SYST0 IF (LU .NE. 0) THEN WRITE (LU, 99995) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 4.5) ENDIF WRITE (LINE, 99997) (TP(2, J), J = 1, 3), 1 (TG(J, 2), J = 1, 3), SYST IF (LU .NE. 0) THEN WRITE (LU, 99995) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 4.0) ENDIF WRITE (LINE, 99996) (TP(3, J), J = 1, 3), 1 (TG(J, 3), J = 1, 3), MAXD IF (LU .NE. 0) THEN WRITE (LU, 99995) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 3.5) ENDIF 290 CONTINUE CALL GEN026 (1, G, OCELL, GL(5)) CALL GEN001 (1, TP, G, G) CALL GEN026 (-1, G, CELL, GL(5)) CELL(7) = GEN045 (CELL) DO 300 LUI = 1, LUIM IF (LUI .EQ. 1) THEN LU = LU6 ELSE IF (LUI .EQ. 2) THEN LU = LU7 ELSE LU = 0 ENDIF WRITE (LINE, 99994) IF (LU .NE. 0) THEN WRITE (LU, 99989) WRITE (LU, 99995) LINE WRITE (LU, 99990) ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 2.5) ENDIF WRITE (LINE, 99993) LATT(1), (OCELL(J), J = 1, 7) IF (LU .NE. 0) THEN WRITE (LU, 99995) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 2.0) ENDIF WRITE (LINE, 99992) (RCELL(I), I = 1, 7) IF (LU .NE. 0) THEN WRITE (LU, 99995) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1.5) ENDIF WRITE (LINE, 99991) LAT0, LATT(3), (CELL(J), J = 1, 7) IF (LU .NE. 0) THEN WRITE (LU, 99995) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1.0) ENDIF 300 CONTINUE ISOL = 1 RETURN 310 CALL PLA166 (ITEL, LATT(1), AXCRIT, PAR(441), LUIM) ISOL = 0 RETURN 320 WRITE (LU6, 99987) ITEL STOP ' WRONG "ITEL" NUMBER ' 99999 FORMAT ('==== Transformation Matrix: Input (a,b,c) to ', 1 'Conventional Cell(a'', b'', c'') ==== ') 99998 FORMAT ('(a'') (', 3(F6.3), ') (a) (x'') (', 3(F6.3), 1 ') (x) ', A) 99997 FORMAT ('(b'') = (', 3(F6.3), ') (b). (y'') = (', 3(F6.3), 1 ') (y) ', A) 99996 FORMAT ('(c'') (', 3(F6.3), ') (c) (z'') (', 3(F6.3), 1 ') (z) FOM:', F7.3) 99995 FORMAT (A) 99994 FORMAT (16X, 'Latt', 5X, 'a', 7X, 'b', 7X, 'c', 1 5X, 'Alpha', 3X, 'Beta', 2X, 'Gamma', 6X, 'Volume') 99993 FORMAT ('Input Cell', 8X, A, 2X, 3(1X, F7.3), 3(F7.2), F12.2) 99992 FORMAT ('Reduc Cell', 8X, 'P', 2X, 3(1X, F7.3), 3(F7.2), F12.2) 99991 FORMAT ('Conv. Cell', 7X, 2A, 2X, 3(1X, F7.3), 3(F7.2), F12.2) 99990 FORMAT (80('-')) 99989 FORMAT (1X) 99988 FORMAT (//, 'THERE IS SOMETHING WRONG IN LATT TYPE ANALYSIS') 99987 FORMAT ('Wrong ITEL =', I5) END SUBROUTINE PLA166 (ITEL, LATT, P2, P3, LUIM) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3), 1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3), 2 TRMXT(3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7), 3 IDET, NVEC CHARACTER LATT*1, LINE*80 VERT = GL(1) DO 20 L = 1, LUIM IF (L .EQ. 1) THEN LU = LU6 ELSE IF (L .EQ. 2) THEN CALL PLA269 (0) LU = LU7 ELSE LU = 0 ENDIF WRITE (LINE, 99993) IPR(94) IF (LU .EQ. 0) THEN CALL GGIP20 (0.0, LINE, 18, 0.35, 1, 2, 0.1, VERT - 2.5) ENDIF WRITE (LINE, 99999) P2, P3, LATT IF (LU .NE. 0) THEN WRITE (LU, 99996) WRITE (LU, 99992) LINE WRITE (LU, 99995) ELSE CALL GGIP20 (0.0, LINE, 76, 0.4, 1, 2, 0.1, VERT - 3.5) ENDIF IF (ITEL .GT. 0) THEN WRITE (LINE, 99998) IF (LU .NE. 0) THEN WRITE (LU, 99992) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 1 0.1, VERT - 4.5) ENDIF WRITE (LINE, 99994) (I, I = 1, 9) IF (LU .NE. 0) THEN WRITE (LU, 99992) LINE WRITE (LU, 99995) ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 1 VERT - 5.0) ENDIF DO 10 I = 1, ITEL WRITE (LINE, 99997) I, AXES(I, 8), NINT(AXES(I, 13)), 1 (NINT(AXES(I, K)), K = 1, 6), NINT(AXES(I, 9)), 2 AXES(I, 7), (AXES(I, 13 + J), J = 1, ITEL) IF (LU .NE. 0) THEN WRITE (LU, 99992) LINE ELSE CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1 VERT - 5.1 - I * 0.5) ENDIF 10 CONTINUE ENDIF 20 CONTINUE RETURN 99999 FORMAT ('Possible 2-Fold Axes - 2-Axis Crit =', F5.2, 1 ', Exp. Error =', F5.2, ' Deg., LATT = ', A) 99998 FORMAT (17X, 'Rows', 6X, 'Products', 7X, 'Angle Between Two ', 1 'Direct Axes ') 99997 FORMAT (I2, F7.3, I2, 2(1X, 3I2), I3, F6.3, 1X, 9(1X, F4.0)) 99996 FORMAT (1X) 99995 FORMAT (80('-')) 99994 FORMAT ('Nr', 3X, 'D', 4X, 'N', 1X, 'Direct', 2X, 2 'Recip Dot Delta', 9(I4, 1X)) 99993 FORMAT ('Max. Dot Prod =', I3) 99992 FORMAT (A) END SUBROUTINE PLA167 PARAMETER (NP12=600,NP13=500,NP17=99,NP18=50,NPVD=40000000, 1 NP23=18000,NP38=125,NP39=30,NCS=50, NZM = 200000, 2 NRS = NPVD-10*NZM) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON // XYZDUM(2, NP23), RS(NRS), TNZ(NZM, 10) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12), 1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12), 2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA, 3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC, 4 RAVERA, RAVERH COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5 DIMENSION DUMV(3, 3), AA(3, 3), BB(3, 3), V(6) COMMON /HKLMX/ HMAX, KMAX, LMAX, IHM, IHKM, IHKP INTEGER HMAX LH = 0 LK = 0 LL = 0 IH = 0 IK = 0 IL = 0 NLB = 0 NLE = 0 DO 20 I = 1, 12 XTL(I) = 0.0 XNM(I) = 0.0 DO 10 J = 1, 3 RVL(I, J) = 0.0 NTL(I, J) = 0 10 CONTINUE 20 CONTINUE STLMX = 0.0 HMAX = 0 KMAX = 0 LMAX = 0 CALL GEN108 (LU8, 0) DO 30 I = 1, NREF READ (LU8) KH, KK, KL, XI, SI, STL, STL IF (GEN050 (TRMX, KH, KK, KL, LH, LK, LL) .GE. 0.0) THEN HMAX = MAX (HMAX, IABS(LH)) KMAX = MAX (KMAX, IABS(LK)) LMAX = MAX (LMAX, IABS(LL)) STLMX = MAX (STLMX, STL) IF (ILAT0 .EQ. 'h') THEN HMAX = MAX (HMAX, KMAX, IABS(LH + LK)) KMAX = HMAX ENDIF ENDIF 30 CONTINUE IF (ILAT0 .EQ. 't') THEN HMAX = MAX (HMAX, KMAX) KMAX = HMAX ELSE IF (ILAT0 .EQ. 'c') THEN HMAX = MAX (HMAX, KMAX, LMAX) KMAX = HMAX LMAX = HMAX ENDIF IHM = 2 * HMAX + 1 IHKM = (2 * KMAX + 1) * IHM IHKLM = (2 * LMAX + 1) * IHKM IHKP = (IHKLM + 1) / 2 IF (IHKLM .GT. NPVD) THEN WRITE (LU6, 99989) HMAX, KMAX, LMAX, IHKLM, NPVD STOP ' FORCED ...' ENDIF CALL GEN026 (1, AA, PAR(101), GL(5)) CALL GEN001 (1, TRMX, AA, DUMV) CALL GEN003 (DUMV, BB, DET, 0) CALL GEN025 (BB, V, 1) IF (ILAT0 .EQ. 'a') THEN NLB = 1 NLE = 1 ELSE IF (ILAT0 .EQ. 'm') THEN NLB = 2 NLE = 2 ELSE IF (ILAT0 .EQ. 'o') THEN NLB = 3 NLE = 3 ELSE IF (ILAT0 .EQ. 't') THEN NLB = 4 NLE = 5 ELSE IF (ILAT0 .EQ. 'h') THEN NLB = 6 NLE = 10 ELSE IF (ILAT0 .EQ. 'c') THEN NLB = 11 NLE = 12 ENDIF DO 70 NL = NLB, NLE DO 40 I = 1, IHKLM RS(I) = - 2.0 J = I - 1 JL = J / IHKM JH = J - JL * IHKM JL = JL - LMAX JK = JH / IHM JH = JH - JK * IHM - HMAX JK = JK - KMAX IF (JH .NE. 0 .AND. JK .NE. 0 .AND. JL .NE. 0) THEN IF (GEN049 (ILAT1, JH, JK, JL) .GT. 0.0) THEN STLK = GEN095 (V, JH, JK, JL) STL = SQRT(STLK) IF (STL .LE. STLMX) RS(I) = - 1.0 ENDIF ENDIF 40 CONTINUE CALL GEN108 (LU8, 0) DO 50 NRF = 1, NREF READ (LU8) KH, KK, KL, XI, SI, STL, STL IF (GEN050 (TRMX, KH, KK, KL, IH, IK, IL) .GT. 0.0) THEN IND = IL * IHKM + IK * IHM + IH + IHKP IF (XI .GT. 2.5 * SI) THEN IF (RS(IND) .GT. - 0.5) THEN RS(IND) = (RS(IND) + XI) / 2.0 ELSE RS(IND) = XI ENDIF ELSE RS(IND) = 0.0 ENDIF ENDIF 50 CONTINUE DO 60 I = 1, IHKLM IF (RS(I) .GT. -1.5) THEN IN(1) = I I0 = I - 1 IR(3) = I0 / IHKM IR(1) = I0 - IR(3) * IHKM IR(3) = IR(3) - LMAX IR(2) = IR(1) / IHM IR(1) = IR(1) - IR(2) * IHM - HMAX IR(2) = IR(2) - KMAX ISET = IR(3) * IHKM + IHKP IR1M = IR(1) * IHM IR2M = IR(2) * IHM IF (ILAT0 .EQ. 'a') THEN CALL PLA170 (NL, 1, 1) ELSE IF (ILAT0 .EQ. 'm') THEN IN(2) = ISET - IR2M + IR(1) CALL PLA170 (NL, 1, 2) ELSE IF (ILAT0 .EQ. 'o') THEN IN(2) = ISET - IR2M + IR(1) IN(3) = ISET + IR2M - IR(1) IN(4) = ISET - IR2M - IR(1) CALL PLA170 (NL, 1, 4) ELSE IF (ILAT0 .EQ. 't') THEN IN(2) = ISET + IR1M - IR(2) IN(3) = ISET - IR2M - IR(1) IN(4) = ISET - IR1M + IR(2) IF (NL .EQ. 5) THEN IN(5) = ISET + IR2M - IR(1) IN(6) = ISET + IR1M + IR(2) IN(7) = ISET - IR2M + IR(1) IN(8) = ISET - IR1M - IR(2) CALL PLA170 (NL, 1, 8) ELSE CALL PLA170 (NL, 1, 4) ENDIF ELSE IF (ILAT0 .EQ. 'h') THEN IHPK = IR(1) + IR(2) IRPM = IHPK * IHM IF (NL .LT. 9) THEN IN(2) = ISET - IRPM + IR(2) IN(3) = ISET + IR1M - IHPK IF (NL .EQ. 7) THEN IN(4) = ISET - IR1M - IR(2) IN(5) = ISET - IR2M + IHPK IN(6) = ISET + IRPM - IR(1) CALL PLA170 (7, 1, 6) ELSE IF (NL .EQ. 8) THEN IN(4) = ISET + IR1M + IR(2) IN(5) = ISET + IR2M - IHPK IN(6) = ISET - IRPM + IR(1) CALL PLA170 (8, 1, 6) ELSE CALL PLA170 (6, 1, 3) ENDIF ELSE IN(2) = ISET + IRPM - IR(2) IN(3) = ISET + IR1M - IHPK IN(4) = ISET - IR2M - IR(1) IN(5) = ISET - IRPM + IR(2) IN(6) = ISET - IR1M + IHPK IF (NL .EQ. 10) THEN IN(7) = ISET + IR1M + IR(2) IN(8) = ISET - IR2M + IHPK IN(9) = ISET - IRPM + IR(1) IN(10) = ISET - IR1M - IR(2) IN(11) = ISET + IR2M - IHPK IN(12) = ISET + IRPM - IR(1) CALL PLA170 (NL, 1, 12) ELSE CALL PLA170 (NL, 1, 6) ENDIF ENDIF ELSE IF (ILAT0 .EQ. 'c') THEN IST1 = IR(1) * IHKM + IHKP IST2 = IR(2) * IHKM + IHKP IR3M = IR(3) * IHM IN(2) = ISET - IR2M + IR(1) IN(3) = ISET + IR2M - IR(1) IN(4) = ISET - IR2M - IR(1) IN(5) = IST1 + IR3M + IR(2) IN(6) = IST2 + IR1M + IR(3) IN(7) = IST1 - IR3M - IR(2) IN(8) = IST2 - IR1M - IR(3) IN(9) = IST2 + IR1M - IR(3) IN(10) = IST1 - IR3M + IR(2) IN(11) = IST1 + IR3M - IR(2) IN(12) = IST2 - IR1M + IR(3) IF (NL .EQ. 12) THEN IN(13) = ISET + IR1M + IR(2) IN(14) = ISET + IR1M - IR(2) IN(15) = ISET - IR1M + IR(2) IN(16) = ISET - IR1M - IR(2) IN(17) = IST1 + IR2M + IR(3) IN(18) = IST2 + IR3M + IR(1) IN(19) = IST1 - IR2M - IR(3) IN(20) = IST2 - IR3M - IR(1) IN(21) = IST2 - IR3M + IR(1) IN(22) = IST1 + IR2M - IR(3) IN(23) = IST1 - IR2M + IR(3) IN(24) = IST2 + IR3M - IR(1) CALL PLA170 (NL, 1, 24) ELSE CALL PLA170 (NL, 1, 12) ENDIF ENDIF ENDIF 60 CONTINUE 70 CONTINUE DO 80 J = 1, 12 IF (XNM(J) .GT. 0.0) THEN RVL(J, 1) = XTL(J) * 100.0 / XNM(J) ENDIF IF (NTL(J, 1) .GT. 0) THEN RVL(J, 2) = 100.0 * NTL(J, 2) / NTL(J, 1) ENDIF IF (NTL(J, 2) .GT. 0) THEN RVL(J, 3) = 100.0 * NTL(J, 3) / NTL(J, 2) ENDIF 80 CONTINUE RETURN 99989 FORMAT (':: Increase NPVD: hm, km, lm =', 3I5, /, 1 ':: NPVD(needed/current)', 2I10) END SUBROUTINE PLA168 PARAMETER (NP18=50,NCS=50) COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS COMMON /DSPGR/ TYPE, NLAUE CHARACTER TYPE(NCS)*16, NLAUE(13)*5 COMMON /LFSPGR/ EX COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5 LOGICAL EX(NCS) IF (LAUE .EQ. NLAUE(13)) THEN IVAL = 13 IF (ILAT1 .EQ. 'R') THEN NB = 6 NE = 7 ELSE NB = 1 NE = 12 ENDIF DO 10 I = NB, NE IF (RVL(I, 1) .GT. 0.0) THEN IF (IVAL .EQ. 13) THEN IVAL = I ELSE IF (RVL(I, 1) .LT. RMAX) THEN IVAL = I ENDIF ENDIF 10 CONTINUE LAUE = NLAUE(IVAL) ENDIF C********************************************************************* C * TRICLINIC : LAUE CLASS -1 * C********************************************************************* IF (ILAT0 .EQ. 'a') THEN IF (ILAT1 .EQ. 'P') THEN CALL PLA163 ('P1 ') CALL PLA163 ('P-1 ') ELSE IF (ILAT1 .EQ. 'A') THEN CALL PLA163 ('A1 ') CALL PLA163 ('A-1 ') ELSE IF (ILAT1 .EQ. 'B') THEN CALL PLA163 ('B1 ') CALL PLA163 ('B-1 ') ELSE IF (ILAT1 .EQ. 'C') THEN CALL PLA163 ('C1 ') CALL PLA163 ('C-1 ') ELSE IF (ILAT1 .EQ. 'I') THEN CALL PLA163 ('I1 ') CALL PLA163 ('I-1 ') ELSE IF (ILAT1 .EQ. 'F') THEN CALL PLA163 ('F1 ') CALL PLA163 ('F-1 ') ELSE IF (ILAT1 .EQ. 'R') THEN CALL PLA163 ('R1 ') CALL PLA163 ('R-1 ') ENDIF C********************************************************************* C * MONOCLINIC : B-UNIQUE LAUE CLASS 1 2/M 1 * C********************************************************************* ELSE IF (ILAT0 .EQ. 'm') THEN IF (ILAT1 .EQ. 'I') THEN IF (EX(10) .AND. EX(11)) THEN CALL PLA163 ('Ia ') CALL PLA163 ('I2/a ') ELSE CALL PLA163 ('I2 ') CALL PLA163 ('Im ') CALL PLA163 ('I2/m ') ENDIF ELSE IF (ILAT1 .EQ. 'A') THEN IF (EX(10)) THEN CALL PLA163 ('Aa ') CALL PLA163 ('A2/a ') ELSE CALL PLA163 ('A2 ') CALL PLA163 ('Am ') CALL PLA163 ('A2/m ') ENDIF ELSE IF (ILAT1 .EQ. 'C') THEN IF (EX(11)) THEN CALL PLA163 ('Cc ') CALL PLA163 ('C2/c ') ELSE CALL PLA163 ('C2 ') CALL PLA163 ('Cm ') CALL PLA163 ('C2/m ') ENDIF ELSE IF (EX(12)) THEN IF (EX(17)) THEN CALL PLA163 ('P21/n ') CALL PLA163 ('P21 ') CALL PLA163 ('Pn ') ELSE CALL PLA163 ('Pn ') CALL PLA163 ('P2/n ') ENDIF IF (EX(10)) THEN IF (EX(17)) THEN CALL PLA163 ('P21/a ') CALL PLA163 ('Pa ') ELSE CALL PLA163 ('Pa ') CALL PLA163 ('P2/a ') ENDIF ENDIF IF (EX(11)) THEN IF (EX(17)) THEN CALL PLA163 ('P21/c ') CALL PLA163 ('Pc ') ELSE CALL PLA163 ('Pc ') CALL PLA163 ('P2/c ') ENDIF ENDIF ELSE IF (EX(10)) THEN IF (EX(17)) THEN CALL PLA163 ('P21/a ') CALL PLA163 ('P21 ') CALL PLA163 ('Pa ') ELSE CALL PLA163 ('Pa ') CALL PLA163 ('P2/a ') ENDIF ELSE IF (EX(11)) THEN IF (EX(17)) THEN CALL PLA163 ('P21/c ') CALL PLA163 ('P21 ') CALL PLA163 ('Pc ') ELSE CALL PLA163 ('Pc ') CALL PLA163 ('P2/c ') ENDIF ELSE IF (EX(17)) THEN CALL PLA163 ('P21 ') CALL PLA163 ('P21/m ') ELSE CALL PLA163 ('P2 ') CALL PLA163 ('Pm ') CALL PLA163 ('P2/m ') ENDIF ENDIF ENDIF C******************************************************************* C * ORTHORHOMBIC LAUE CLASS 3 = 2/m 2/m 2/m * C******************************************************************* ELSE IF (ILAT0 .EQ. 'o') THEN IF (ILAT1 .EQ. 'F') THEN IF (EX(19) .AND. EX(20) .AND. EX(21)) THEN CALL PLA163 ('Fddd ') ELSE IF (EX(19) .AND. EX(20)) THEN CALL PLA163 ('Fdd2 ') ELSE IF (EX(19) .AND. EX(21)) THEN CALL PLA163 ('Fd2d ') ELSE IF (EX(20) .AND. EX(21)) THEN CALL PLA163 ('F2dd ') ELSE CALL PLA163 ('Fmm2 ') CALL PLA163 ('Fm2m ') CALL PLA163 ('F2mm ') CALL PLA163 ('F222 ') CALL PLA163 ('Fmmm ') ENDIF ELSE IF (ILAT1 .EQ. 'I') THEN IF (EX(7) .AND. EX(8)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Ibca ') ELSE CALL PLA163 ('Iba2 ') CALL PLA163 ('Ibam ') ENDIF ELSE IF (EX(12)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Ic2a ') CALL PLA163 ('Icma ') ELSE CALL PLA163 ('Ibm2 ') CALL PLA163 ('Ic2m ') CALL PLA163 ('Ibmm ') CALL PLA163 ('Icmm ') ENDIF ENDIF ELSE IF (EX(9)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('I2cb ') CALL PLA163 ('Imcb ') ELSE IF (EX(15)) THEN CALL PLA163 ('Ima2 ') CALL PLA163 ('I2cm ') CALL PLA163 ('Imam ') CALL PLA163 ('Imcm ') ENDIF ELSE IF (EX(12)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Im2a ') CALL PLA163 ('I2mb ') CALL PLA163 ('Imma ') CALL PLA163 ('Immb ') ELSE IF (EX(15)) THEN CALL PLA163 ('I222 ') CALL PLA163 ('Imm2 ') CALL PLA163 ('Im2m ') CALL PLA163 ('I2mm ') CALL PLA163 ('I212121') CALL PLA163 ('Immm ') ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'A') THEN IF (EX(7) .AND. EX(8)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Abaa ') CALL PLA163 ('Acaa ') ELSE IF (EX(14)) THEN CALL PLA163 ('Aba2 ') CALL PLA163 ('Acam ') ENDIF ELSE IF (EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Ac2a ') CALL PLA163 ('Abma ') ELSE IF (EX(14)) THEN CALL PLA163 ('Abm2 ') CALL PLA163 ('Ac2m ') CALL PLA163 ('Abmm ') CALL PLA163 ('Acmm ') ENDIF ENDIF ELSE IF (EX(9)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('A2aa ') CALL PLA163 ('Amaa ') ELSE IF (EX(14)) THEN CALL PLA163 ('A21am ') CALL PLA163 ('Ama2 ') CALL PLA163 ('Amam ') ENDIF ELSE IF (EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('A21ma ') CALL PLA163 ('Am2a ') CALL PLA163 ('Amma ') ELSE IF (EX(14) .AND. EX(16)) THEN CALL PLA163 ('A2122 ') ELSE IF (EX(14)) THEN CALL PLA163 ('A222 ') CALL PLA163 ('Amm2 ') CALL PLA163 ('Am2m ') CALL PLA163 ('A2mm ') CALL PLA163 ('Ammm ') ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'B') THEN IF (EX(7) .AND. EX(8)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Bbab ') CALL PLA163 ('Bbcb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Bba2 ') CALL PLA163 ('Bbcm ') ENDIF ELSE IF (EX(12)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Bb2b ') CALL PLA163 ('Bbmb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Bb21m ') CALL PLA163 ('Bbm2 ') CALL PLA163 ('Bbmm ') ENDIF ENDIF ELSE IF (EX(8)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('B2cb ') CALL PLA163 ('Bmab ') ELSE IF (EX(13)) THEN CALL PLA163 ('Bma2 ') CALL PLA163 ('B2cm ') CALL PLA163 ('Bmam ') CALL PLA163 ('Bmcm ') ENDIF ELSE IF (EX(12)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Bm21b ') CALL PLA163 ('Bmmb ') CALL PLA163 ('B2mb ') ELSE IF (EX(17)) THEN CALL PLA163 ('B2212 ') ELSE CALL PLA163 ('B222 ') CALL PLA163 ('Bmm2 ') CALL PLA163 ('B2mm ') CALL PLA163 ('Bm2m ') CALL PLA163 ('Bmmm ') ENDIF ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'C') THEN IF (EX(7) .AND. EX(8)) THEN IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Ccca ') CALL PLA163 ('Cccb ') ELSE CALL PLA163 ('Ccc2 ') CALL PLA163 ('Cccm ') ENDIF ELSE IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Cc2a ') CALL PLA163 ('Ccmb ') ELSE CALL PLA163 ('Ccm21 ') CALL PLA163 ('Cc2m ') CALL PLA163 ('Ccmm ') ENDIF ENDIF ELSE IF (EX(10) .AND. EX(11)) THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('C2cb ') CALL PLA163 ('Cmca ') ELSE CALL PLA163 ('Cmc21 ') CALL PLA163 ('C2cm ') CALL PLA163 ('Cmcm ') ENDIF ELSE IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('Cm2a ') CALL PLA163 ('C2mb ') CALL PLA163 ('Cmma ') CALL PLA163 ('Cmmb ') ELSE IF (EX(18)) THEN CALL PLA163 ('C2221 ') ELSE CALL PLA163 ('C222 ') CALL PLA163 ('Cm2m ') CALL PLA163 ('C2mm ') CALL PLA163 ('Cmm2 ') CALL PLA163 ('Cmmm ') ENDIF ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'P') THEN IF (EX(9)) THEN IF (EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pnnn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pnnb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pnna ') ELSE CALL PLA163 ('Pnn2 ') CALL PLA163 ('Pnnm ') ENDIF ENDIF IF (EX(11)) THEN IF (EX(15)) THEN CALL PLA163 ('Pncn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pncb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pnca ') ELSE CALL PLA163 ('Pnc2 ') CALL PLA163 ('Pncm ') ENDIF ENDIF IF (EX(10)) THEN IF (EX(15)) THEN CALL PLA163 ('Pnan ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pnab ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pnaa ') ELSE CALL PLA163 ('Pna21 ') CALL PLA163 ('Pnam ') ENDIF ENDIF IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pn2n ') CALL PLA163 ('Pnmn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pn2b ') CALL PLA163 ('Pnmb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pn21a ') CALL PLA163 ('Pnma ') ELSE CALL PLA163 ('Pnm21 ') CALL PLA163 ('Pn21m ') CALL PLA163 ('Pnmm ') ENDIF ENDIF ELSE IF (EX(8)) THEN IF (EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pcnn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pcnb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pcna ') ELSE CALL PLA163 ('Pcn2 ') CALL PLA163 ('Pcnm ') ENDIF ENDIF IF (EX(11)) THEN IF (EX(15)) THEN CALL PLA163 ('Pccn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pccb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pcca ') ELSE CALL PLA163 ('Pcc2 ') CALL PLA163 ('Pccm ') ENDIF ENDIF IF (EX(10)) THEN IF (EX(15)) THEN CALL PLA163 ('Pcan ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pcab ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pcaa ') ELSE CALL PLA163 ('Pca21 ') CALL PLA163 ('Pcam ') ENDIF ENDIF IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pc21n ') CALL PLA163 ('Pcmn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pc21b ') CALL PLA163 ('Pcmb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pc2a ') CALL PLA163 ('Pcma ') ELSE CALL PLA163 ('Pcm21 ') CALL PLA163 ('Pc2m ') CALL PLA163 ('Pcmm ') ENDIF ENDIF ELSE IF (EX(7)) THEN IF (EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pbnn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pbnb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pbna ') ELSE CALL PLA163 ('Pbn21 ') CALL PLA163 ('Pbnm ') ENDIF ENDIF IF (EX(11)) THEN IF (EX(15)) THEN CALL PLA163 ('Pbcn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pbcb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pbca ') ELSE CALL PLA163 ('Pbc21 ') CALL PLA163 ('Pbcm ') ENDIF ENDIF IF (EX(10)) THEN IF (EX(15)) THEN CALL PLA163 ('Pban ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pbab ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pbaa ') ELSE CALL PLA163 ('Pba2 ') CALL PLA163 ('Pbam ') ENDIF ENDIF IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pb2n ') CALL PLA163 ('Pbmn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pb2b ') CALL PLA163 ('Pbmb ') ELSE IF (EX(13)) THEN CALL PLA163 ('Pb21a ') CALL PLA163 ('Pbma ') ELSE CALL PLA163 ('Pb21m ') CALL PLA163 ('Pbm2 ') CALL PLA163 ('Pbmm ') ENDIF ENDIF ELSE IF (EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('P2nn ') CALL PLA163 ('Pmnn ') ELSE IF (EX(14)) THEN CALL PLA163 ('P21nb ') CALL PLA163 ('Pmnb ') ELSE IF (EX(13)) THEN CALL PLA163 ('P2na ') CALL PLA163 ('Pmna ') ELSE CALL PLA163 ('Pmn21 ') CALL PLA163 ('P21nm ') CALL PLA163 ('Pmnm ') ENDIF ENDIF IF (EX(11)) THEN IF (EX(15)) THEN CALL PLA163 ('P21cn ') CALL PLA163 ('Pmcn ') ELSE IF (EX(14)) THEN CALL PLA163 ('P2cb ') CALL PLA163 ('Pmcb ') ELSE IF (EX(13)) THEN CALL PLA163 ('P21ca ') CALL PLA163 ('Pmca ') ELSE CALL PLA163 ('Pmc21 ') CALL PLA163 ('P2cm ') CALL PLA163 ('Pmcm ') ENDIF ENDIF IF (EX(10)) THEN IF (EX(15)) THEN CALL PLA163 ('P2an ') CALL PLA163 ('Pman ') ELSE IF (EX(14)) THEN CALL PLA163 ('P21ab ') CALL PLA163 ('Pmab ') ELSE IF (EX(13)) THEN CALL PLA163 ('P2aa ') CALL PLA163 ('Pmaa ') ELSE CALL PLA163 ('P21am ') CALL PLA163 ('Pma2 ') CALL PLA163 ('Pmam ') ENDIF ENDIF IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN IF (EX(15)) THEN CALL PLA163 ('Pm21n ') CALL PLA163 ('P21mn ') CALL PLA163 ('Pmmn ') ELSE IF (EX(14)) THEN CALL PLA163 ('Pm21b ') CALL PLA163 ('P2mb ') CALL PLA163 ('Pmmb ') ELSE IF (EX(13)) THEN CALL PLA163 ('P21ma ') CALL PLA163 ('Pm2a ') CALL PLA163 ('Pmma ') ELSE IF (EX(16)) THEN IF (EX(17)) THEN IF (EX(18)) THEN CALL PLA163 ('P212121') IF (EXT(16) .EQ. '?') CALL PLA163 ('P22121 ') IF (EXT(17) .EQ. '?') CALL PLA163 ('P21221 ') IF (EXT(18) .EQ. '?') CALL PLA163 ('P21212 ') IF (EXT(16) .EQ. '?' .AND. EXT(17) .EQ. '?') 1 CALL PLA163 ('P2221 ') IF (EXT(16) .EQ. '?' .AND. EXT(18) .EQ. '?') 1 CALL PLA163 ('P2212 ') IF (EXT(17) .EQ. '?' .AND. EXT(18) .EQ. '?') 1 CALL PLA163 ('P2122 ') ELSE CALL PLA163 ('P21212 ') ENDIF ELSE IF (EX(18)) THEN CALL PLA163 ('P21221 ') ELSE CALL PLA163 ('P2122 ') ENDIF ENDIF ELSE IF (EX(17)) THEN IF (EX(18)) THEN CALL PLA163 ('P22121 ') ELSE CALL PLA163 ('P2212 ') ENDIF ELSE IF (EX(18)) THEN CALL PLA163 ('P2221 ') ELSE CALL PLA163 ('P222 ') CALL PLA163 ('Pmm2 ') CALL PLA163 ('Pm2m ') CALL PLA163 ('P2mm ') CALL PLA163 ('Pmmm ') ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF C********************************************************************** C * TETRAGONAL : LAUE CLASSES 4 = 4/M AND 5 = 4/M 2/M 2/M * C********************************************************************** ELSE IF (ILAT0 .EQ. 't') THEN IF (ILAT1 .EQ. 'I') THEN IF (LAUE .EQ. ' 4/m') THEN IF (EX(13) .AND. EX(14)) THEN CALL PLA163 ('I41/a ') ELSE IF (EX(24)) THEN CALL PLA163 ('I41 ') ELSE CALL PLA163 ('I-4 ') CALL PLA163 ('I4 ') CALL PLA163 ('I4/m ') ENDIF ENDIF ELSE IF (LAUE .EQ. '4/mmm') THEN IF (EX(13) .AND. EX(14)) THEN IF (EX(7) .AND. EX(8)) THEN CALL PLA163 ('I41/acd') ELSE IF (EX(28)) THEN CALL PLA163 ('I41/amd') ENDIF ENDIF ELSE IF (EX(7) .AND. EX(8)) THEN IF (EX(28)) THEN CALL PLA163 ('I41cd ') ELSE CALL PLA163 ('I4cm ') CALL PLA163 ('I-4c2 ') CALL PLA163 ('I4/mcm ') ENDIF ELSE IF (EX(28)) THEN CALL PLA163 ('I41md ') CALL PLA163 ('I-42d ') ELSE IF (EX(24)) THEN CALL PLA163 ('I4122 ') ELSE CALL PLA163 ('I-42m ') CALL PLA163 ('I-4m2 ') CALL PLA163 ('I4mm ') CALL PLA163 ('I422 ') CALL PLA163 ('I4/mmm ') ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'P') THEN IF (LAUE .EQ. ' 4/m') THEN IF (EX(15)) THEN IF (EX(18)) THEN CALL PLA163 ('P42/n ') ELSE CALL PLA163 ('P4/n ') ENDIF ELSE IF (EX(24)) THEN CALL PLA163 ('P41 ') CALL PLA163 ('P43 ') ELSE IF (EX(18)) THEN CALL PLA163 ('P42 ') CALL PLA163 ('P42/m ') ELSE CALL PLA163 ('P-4 ') CALL PLA163 ('P4 ') CALL PLA163 ('P4/m ') ENDIF ENDIF ELSE IF (LAUE .EQ. '4/mmm') THEN IF (EX(15)) THEN IF (EX(9)) THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P4/nnc ') ELSE CALL PLA163 ('P42/nnm') ENDIF ELSE IF (EX(8)) THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P4/ncc ') ELSE CALL PLA163 ('P42/ncm') ENDIF ELSE IF (EX(7)) THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P42/nbc') ELSE CALL PLA163 ('P4/nbm ') ENDIF ELSE IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P42/nmc') ELSE CALL PLA163 ('P4/nmm ') ENDIF ENDIF ELSE IF (EX(9)) THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P4nc ') CALL PLA163 ('P4/mnc ') ELSE CALL PLA163 ('P-4n2 ') CALL PLA163 ('P42nm ') CALL PLA163 ('P42/mnm') ENDIF ELSE IF (EX(8)) THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P4cc ') CALL PLA163 ('P4/mcc ') ELSE CALL PLA163 ('P-4c2 ') CALL PLA163 ('P42cm ') CALL PLA163 ('P42/mcm') ENDIF ELSE IF (EX(7)) THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P42bc ') CALL PLA163 ('P42/mbc') ELSE CALL PLA163 ('P-4b2 ') CALL PLA163 ('P4bm ') CALL PLA163 ('P4/mbm ') ENDIF ELSE IF (EX(25) .OR. EX(33)) THEN IF (EX(17)) THEN CALL PLA163 ('P-421c ') ELSE CALL PLA163 ('P42mc ') CALL PLA163 ('P-42c ') CALL PLA163 ('P42/mmc') ENDIF ELSE IF (EX(24)) THEN IF (EX(17)) THEN CALL PLA163 ('P41212 ') CALL PLA163 ('P43212 ') ELSE CALL PLA163 ('P4122 ') CALL PLA163 ('P4322 ') ENDIF ELSE IF (EX(18)) THEN IF (EX(17)) THEN CALL PLA163 ('P42212 ') ELSE CALL PLA163 ('P4222 ') ENDIF ELSE IF (EX(17)) THEN CALL PLA163 ('P4212 ') CALL PLA163 ('P-421m ') ELSE CALL PLA163 ('P-42m ') CALL PLA163 ('P422 ') CALL PLA163 ('P-4m2 ') CALL PLA163 ('P4mm ') CALL PLA163 ('P4/mmm ') ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF C*********************************************************************** C * TRI/HEXAGONAL LAUE CLASSES 6=-3, 7=-3m1, 8=-31m, 9=6/m, 10=6/mmm * C*********************************************************************** ELSE IF (ILAT0 .EQ. 'h') THEN IF (LAUE .EQ. ' 6/m') THEN IF (EX(31)) THEN CALL PLA163 ('P61 ') CALL PLA163 ('P65 ') ELSE IF (EX(39)) THEN CALL PLA163 ('P62 ') CALL PLA163 ('P64 ') ELSE IF (EX(18)) THEN CALL PLA163 ('P63 ') CALL PLA163 ('P63/m ') ELSE CALL PLA163 ('P-6 ') CALL PLA163 ('P6 ') CALL PLA163 ('P6/m ') ENDIF ELSE IF (LAUE .EQ. '6/mmm') THEN IF (EX(33) .OR. EX(11) .OR. EX(8)) THEN IF (EX(25) .OR. EX(35) .OR. EX(36)) THEN CALL PLA163 ('P6cc ') CALL PLA163 ('P6/mcc ') ELSE CALL PLA163 ('P63cm ') CALL PLA163 ('P-6c2 ') CALL PLA163 ('P63/mcm') ENDIF ELSE IF (EX(25) .OR. EX(35) .OR. EX(36)) THEN CALL PLA163 ('P63mc ') CALL PLA163 ('P-62c ') CALL PLA163 ('P63/mmc') ELSE IF (EX(31)) THEN CALL PLA163 ('P6122 ') CALL PLA163 ('P6522 ') ELSE IF (EX(39)) THEN CALL PLA163 ('P6222 ') CALL PLA163 ('P6422 ') ELSE IF (EX(18)) THEN CALL PLA163 ('P6322 ') ELSE CALL PLA163 ('P-62m ') CALL PLA163 ('P6mm ') CALL PLA163 ('P622 ') CALL PLA163 ('P-6m2 ') CALL PLA163 ('P6/mmm ') ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'R') THEN IF (LAUE .EQ. ' -3') THEN CALL PLA163 ('R3 ') CALL PLA163 ('R-3 ') ELSE IF (LAUE .EQ. ' -3m1') THEN IF (EX(33) .OR. EX(11) .OR. EX(8)) THEN CALL PLA163 ('R3c ') CALL PLA163 ('R-3c ') ELSE CALL PLA163 ('R3m ') CALL PLA163 ('R32 ') CALL PLA163 ('R-3m ') ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'P') THEN IF (LAUE .EQ. ' -3') THEN IF (EX(39)) THEN CALL PLA163 ('P31 ') CALL PLA163 ('P32 ') IF (EXT(5) .EQ. '>') THEN CALL PLA163 ('P-3 ') CALL PLA163 ('R-3 ') ENDIF ELSE CALL PLA163 ('P3 ') CALL PLA163 ('P-3 ') ENDIF ELSE IF (LAUE .EQ. ' -3m1') THEN IF (EX(33) .OR. EX(8) .OR. EX(11)) THEN CALL PLA163 ('P3c1 ') CALL PLA163 ('P-3c1 ') ELSE IF (EX(39)) THEN CALL PLA163 ('P3121 ') CALL PLA163 ('P3221 ') IF (EXT(47) .NE. ' ') THEN CALL PLA163 ('R-3 ') ENDIF ELSE CALL PLA163 ('P321 ') CALL PLA163 ('P3m1 ') CALL PLA163 ('P-3m1 ') ENDIF ENDIF ELSE IF (LAUE .EQ. ' -31m') THEN IF (EX(25) .OR. EX(35) .OR. EX(36)) THEN CALL PLA163 ('P31c ') CALL PLA163 ('P-31c ') ELSE IF (EX(39)) THEN CALL PLA163 ('P3112 ') CALL PLA163 ('P3212 ') IF (EXT(47) .NE. ' ') THEN CALL PLA163 ('R-3 ') ENDIF ELSE CALL PLA163 ('P312 ') CALL PLA163 ('P31m ') CALL PLA163 ('P-31m ') ENDIF ENDIF ENDIF ENDIF ENDIF C*********************************************************************** C * CUBIC LAUE CLASS 11 : m-3 , 12 : m-3m * C*********************************************************************** ELSE IF (ILAT0 .EQ. 'c') THEN IF (ILAT1 .EQ. 'F') THEN IF (EX(19)) THEN IF ((EX(25) .OR. EX(33)) .AND. (EX(26) .OR. EX(43))) THEN CALL PLA163 ('Fd-3c ') ELSE IF (LAUE .EQ. ' m-3m') THEN CALL PLA163 ('Fd-3m ') ELSE CALL PLA163 ('Fd-3 ') ENDIF ENDIF ELSE IF ((EX(25) .OR. EX(33)) .AND. (EX(26) .OR. EX(43))) THEN CALL PLA163 ('F-43c ') CALL PLA163 ('Fm-3c ') ELSE IF (EX(24)) THEN CALL PLA163 ('F4132 ') ELSE IF (LAUE .EQ. ' m-3m') THEN CALL PLA163 ('F-43m ') CALL PLA163 ('F432 ') CALL PLA163 ('Fm-3m ') ELSE CALL PLA163 ('F23 ') CALL PLA163 ('Fm-3 ') ENDIF ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'I') THEN IF (EX(7) .AND. EX(8)) THEN IF (EX(25) .AND. EX(28)) THEN CALL PLA163 ('Ia-3d ') ELSE CALL PLA163 ('Ia-3 ') ENDIF ELSE IF (EX(25) .AND. EX(28)) THEN CALL PLA163 ('I-43d ') ELSE IF (EX(24)) THEN CALL PLA163 ('I4132 ') ELSE IF (LAUE .EQ. ' m-3m') THEN CALL PLA163 ('I-43m ') CALL PLA163 ('I432 ') CALL PLA163 ('Im-3m ') ELSE CALL PLA163 ('I23 ') CALL PLA163 ('I213 ') CALL PLA163 ('Im-3 ') ENDIF ENDIF ENDIF ENDIF ELSE IF (ILAT1 .EQ. 'P') THEN IF (EX(9)) THEN IF (LAUE .EQ. ' m-3m') THEN IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('Pn-3n ') ELSE CALL PLA163 ('Pn-3m ') ENDIF ELSE CALL PLA163 ('Pn-3 ') ENDIF ELSE IF (EX(7) .OR. EX(11) .OR. EX(13)) THEN CALL PLA163 ('Pa-3 ') ELSE IF (EX(8) .OR. EX(10) .OR. EX(14)) THEN CALL PLA163 ('Pb-3 ') ELSE IF (EX(25) .OR. EX(33)) THEN CALL PLA163 ('P-43n ') CALL PLA163 ('Pm-3n ') ELSE IF (EX(24)) THEN CALL PLA163 ('P4132 ') CALL PLA163 ('P4332 ') ELSE IF (EX(18)) THEN IF (LAUE .EQ. ' m-3m') THEN CALL PLA163 ('P4232 ') ELSE CALL PLA163 ('P213 ') ENDIF ELSE IF (LAUE .EQ. ' m-3m') THEN CALL PLA163 ('P432 ') CALL PLA163 ('P-43m ') CALL PLA163 ('Pm-3m ') ELSE CALL PLA163 ('P23 ') CALL PLA163 ('Pm-3 ') ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF RETURN END SUBROUTINE PLA169 (MODE, IRII, IRISIG, SINTL, LU) COMMON /STAT9/ ST(20, 3), NSTAT(20, 3), NSTOT(20) CHARACTER BALK*40 COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10) IF (MODE .EQ. 0) THEN CALL GEN097 (NSTOT, 1, 20, 0) CALL GEN097 (NSTAT, 1, 60, 0) CALL GEN074 (ST, 0.0, 1, 60) ELSE IF (MODE .EQ. 1) THEN DO 10 I = 1, 10 IF (SINTL .LT. STLS(I)) GOTO 20 10 CONTINUE GOTO 30 20 NSTOT(I) = NSTOT(I) + 1 RSIG = IRISIG IRI = IRII IF (IRI .LE. 0) IRI = 1 IF (RSIG .LE. 0.0) RSIG = SQRT(FLOAT(IRI)) XIDSI = FLOAT(IRI) / RSIG IF (XIDSI .GE. 0.25) THEN NSTAT(I, 1) = NSTAT(I, 1) + 1 IF (XIDSI .GT. 1.0) THEN NSTAT(I, 2) = NSTAT(I, 2) + 1 IF (XIDSI .GE. 2.0) THEN NSTAT(I, 3) = NSTAT(I, 3) + 1 ENDIF ENDIF ENDIF 30 CONTINUE ELSE IF (MODE .EQ. -1) THEN DO 50 I = 1, 20 IF (NSTOT(I) .GT. 0) THEN DO 40 J = 1, 3 ST(I, J) = 100.0 * NSTAT(I, J) / NSTOT(I) 40 CONTINUE ENDIF 50 CONTINUE ELSE IF (MODE .EQ. -2) THEN WRITE (LU, 99999) DO 70 I = 1, 20 IF (NSTOT(I) .GT. 0) THEN L = NINT (ST(I, 3) * 0.4) DO 60 K = 1, 40 IF (K .GT. L) THEN BALK(K:K) = '.' ELSE BALK(K:K) = '*' ENDIF 60 CONTINUE WRITE (LU, 99998) I, STLS(I), 1 / (2 * STLS(I)), NSTOT(I), 1 (ST(I, J), J = 1, 3), BALK ENDIF 70 CONTINUE WRITE (LU, 99997) ENDIF RETURN 99999 FORMAT (/, 'Intensity Distribution', /, 80('='), //, 1 'sh st/l Ang # 0.25 1.0 2.0 ', 2 '0 Percent Distr. for I gt 2.0 s(I) 100', 3 /, 80('=')) 99998 FORMAT (I2, 2F5.2, I6, 3F6.1, 2X, A) 99997 FORMAT (36X, 'I', 19X, 'I', 19X, 'I', /, 1 36X, '0%',17X, '50%', 16X, '100%') END SUBROUTINE PLA170 (N, M0, M) PARAMETER (NPVD=40000000,NP18=50,NP23=18000,NCS=50,NZM = 200000, 1 NRS = NPVD - 10 * NZM) COMMON // XYZDUM(2, NP23), RS(NRS), TNZ(NZM, 10) COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12), 1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12), 2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA, 3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC, 4 RAVERA, RAVERH COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS COMMON /HKLMX/ HMAX, KMAX, LMAX, IHM, IHKM, IHKP INTEGER HMAX FMN(N) = 0.0 ITL(N) = 0 NCNT = 0 IF (RS(IN(M0)) .GT. -1.5) NTL(N, 1) = NTL(N, 1) + 1 DO 20 J = M0, M DO 10 K = 1, 2 IF (K .EQ. 1) THEN INJ = IN(J) L = J ELSE INJ = - IN(J) + 2 * IHKP L = J + 24 ENDIF XN(L) = RS(INJ) RS(INJ) = -2.0 IF (XN(L) .GT. - 0.5) THEN NCNT = 1 IF (XN(L) .GT. 0.0) THEN FMN(N) = FMN(N) + XN(L) ITL(N) = ITL(N) + 1 ENDIF ENDIF 10 CONTINUE 20 CONTINUE NTL(N, 2) = NTL(N, 2) + NCNT IF (ITL(N) .GT. 1) THEN FMN(N) = FMN(N) / ITL(N) NTL(N, 3) = NTL(N, 3) + 1 DO 40 J = M0, M DO 30 K = 1, 2 IF (K .EQ. 1) THEN INJ = IN(J) L = J ELSE INJ = - IN(J) + 2 * IHKP L = J + 24 ENDIF IF (XN(L) .GT. 0.0) THEN XTL(N) = XTL(N) + ABS(XN(L) - FMN(N)) XNM(N) = XNM(N) + XN(L) ENDIF 30 CONTINUE 40 CONTINUE ENDIF RETURN END SUBROUTINE PLA171 (LRET0, TM, LU, ISPR47, YPAR, KNN) PARAMETER (NP12=600,NP13=500,NP17=99,NP18=50,NP38=125,NP39=30, 1 NP45=2048,NSITE=70) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE CHARACTER NLAUE(14)*5, XSYST(8)*12, IBVL(8)*1, SITE(NSITE)*5 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18), 1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT, 2 RMAX, AVIOS COMMON /LPLATC/ BLATT(NP18), CLATT(NP18) CHARACTER BLATT*1, CLATT*1 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 CHARACTER LINE*80, LIJN*80, ICH*1 DIMENSION YPAR(*), TM(3, 3), FNN(9), DUM(3, 3), 1 AA(3, 3), BB(3, 3) CHARACTER NSYS*1 LOGICAL EXST EXST = .FALSE. IF (KNN .EQ. 9) THEN DO 10 I = 1, 9 FNN(I) = FN(I) 10 CONTINUE ENDIF 20 IF (IGBL(50) .EQ. 0) THEN BCD(1:16) = 'S.Y.S.T.E.M - S'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) VRT = VERT - 0.7 IF (NREXT .GT. 0) THEN LIJN = '(Pseudo)Extinctions Found in Input Reflection file' CALL GGIP20 (0.0, LIJN, 80, 0.375, 2, 2, 0.1, VRT) VRT = VRT - 0.2 CALL GGIP (0.0, VRT, 0.0, 3) CALL GGIP (HORS, VRT, 0.0, 2) VRT = VRT - 0.5 LIJN = ' Ex. Condition av[I/sig(I)] Number of Refl '// 1 'I/sigI .T./.F.' CALL GGIP20 (0.0, LIJN, 80, 0.375, 5 + IGBL(68), 2, 0.1, VRT) VRT = VRT - 0.5 LIJN = ' .True. .False. .True. .False.'// 1 ' Max.F H K L Ratio' CALL GGIP20 (0.0, LIJN, 80, 0.375, 5 + IGBL(68), 2, 0.1, VRT) VRT = VRT - 0.2 CALL GGIP (0.0, VRT, 0.0, 3) CALL GGIP (HORS, VRT, 0.0, 2) VRT = VRT - 0.5 30 READ (LU, 99988, END = 40) LINE IF (LINE(1:4) .EQ. 'EXTI') THEN CALL GGIP20 (0.0, LINE(6:80), 75, 0.375, 1, 2, 0.1, VRT) VRT = VRT - 0.5 ENDIF GOTO 30 40 VRT = VRT + 0.3 CALL GGIP (0.0, VRT, 0.0, 3) CALL GGIP (HORS, VRT, 0.0, 2) VRT = VRT - 0.5 ENDIF LIJN = 'Cell Transformations to Optional Crystal System, '// 1 'Lattice Type and Laue Class' CALL GGIP20 (0.0, LIJN, 80, 0.375, 2, 2, 0.1, VRT) VRT = VRT - 0.3 CALL GGIP (0.0, VRT, 0.0, 3) CALL GGIP (HORS, VRT, 0.0, 2) LIJN = ' # Latt Laue Rav %Ct %Nav '// 1 'Transformation Matrix / Cell + Volume' VRT = VRT - 0.5 CALL GGIP20 (0.0, LIJN, 80, 0.375, 5 + IGBL(68), 2, 0.1, VRT) VRT = VRT - 0.2 CALL GGIP (0.0, VRT, 0.0, 3) CALL GGIP (HORS, VRT, 0.0, 2) VRT = VRT - 0.2 PAR(360) = VRT PAR(361) = 0.75 DO 50 K = 1, NRLT0 VRT = VRT - 0.5 IF (RVAL(K, 1) .LT. RMAX .AND. 1 (RVAL(K, 2) .GT. 80 .OR. RVAL(K, 1) .LT. 0.001)) THEN ICOL = 3 ELSE ICOL = 2 ENDIF WRITE (LIJN, 99998) K, CLATT(K), BLATT(K), 1 NLAUE(LLAUE(K)), (NINT(RVAL(K, J)), J = 1, 3), 2 (TLATT(J, K), J = 1, 9) CALL GEN065 (0, LIJN, 80, 5) CALL GGIP20 (0.0, LIJN, 80, 0.35, ICOL, 2, 0.1, VRT) WRITE (LIJN, 99997) (XCELL(J, K), J = 1, 7) VRT = VRT - 0.25 CALL GGIP20 (0.0, LIJN, 80, 0.20, 1, 1, 9.0, VRT) 50 CONTINUE ISPR47 = 0 IF (KNN .EQ. 9) THEN DO 60 I = 1, 9 FN(I) = FNN(I) 60 CONTINUE KNN = 0 KN = 9 KL = 0 ENDIF IF (KN .EQ. 9) GOTO 90 INQUIRE (FILE = '.newsym.ntr', EXIST = EXST) IF (EXST) THEN OPEN (LU61, FILE = '.newsym.ntr', STATUS = 'UNKNOWN') READ (LU61, 99988) LINE CLOSE (LU61, STATUS = 'DELETE') ISPR47 = 1 GOTO 80 ENDIF 70 WRITE (SBCD, 99996) NRLT, CHAR(0) IGBL(28) = 1 CALL PLA013 (0, 1) IGBL(28) = 0 IF (IGGT(1:4) .EQ. 'PLOT') GOTO 20 IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220 IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN LINE = IGGT CALL GEN038 (IGGT, 1, 80) ELSE WRITE (LINE, 99987) NRLT ENDIF 80 CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) 90 IF (KN .EQ. 1 .AND. FN(1) .GT. 0 .AND. FN(1) .LE. NRLT0) THEN NRLT = NINT(FN(1)) ELSE IF (KN .EQ. 0 .AND. KL .EQ. 0) THEN GOTO 150 ELSE IF (KN .GE. 9) THEN CALL GEN003 (FN(1), DUM, DET, 0) IF (ABS(DET) .LT. 0.01) THEN WRITE (LU6, 99994) GOTO 70 ENDIF DO 100 I = 1, 9 TLATT(I, NP18) = FN(I) K = (I - 1) / 3 + 1 J = MOD (I - 1, 3) + 1 TM(K, J) = FN(I) 100 CONTINUE CLATT(NP18) = ' ' BLATT(NP18) = ' ' LLAUE(NP18) = 13 RVAL(NP18, 1) = 0.0 RVAL(NP18, 2) = 0.0 RVAL(NP18, 3) = 0.0 IF (KL .GT. 0 .AND. IFL(KL)(1:4) .NE. 'TRMX') THEN CLATT(NP18) = IFL(KL)(1:1) BLATT(NP18) = IFL(KL)(2:2) CALL GEN020 (-1, CLATT(NP18), 1, 1) CALL GEN020 (1, BLATT(NP18), 1, 1) ENDIF DO 120 K = 1, NRLT0 DO 110 I = 1, 9 IF (TLATT(I, K) .NE. TLATT(I, NP18)) GOTO 120 110 CONTINUE IF (BLATT(K) .NE. BLATT(NP18)) GOTO 120 IF (CLATT(K) .NE. CLATT(NP18)) GOTO 120 NRLT = K GOTO 70 120 CONTINUE NRLT0 = NRLT0 + 1 CALL GEN026 (1, AA, YPAR(81), GL(5)) CALL GEN003 (AA, BB, DET, 0) YPAR(95) = BB(1, 1) YPAR(96) = BB(2, 2) YPAR(97) = BB(3, 3) YPAR(98) = BB(2, 3) YPAR(99) = BB(1, 3) YPAR(100) = BB(1, 2) CALL GEN001 (1, TM, AA, BB) CALL GEN026 (-1, BB, YPAR(101), GL(5)) CALL GEN003 (BB, AA, DET, 0) YPAR(107) = SQRT(DET) DO 130 I = 1, 9 TLATT(I, NRLT0) = TLATT(I, NP18) 130 CONTINUE DO 140 I = 1, 7 XCELL(I, NRLT0) = YPAR(100 + I) 140 CONTINUE CLATT(NRLT0) = CLATT(NP18) BLATT(NRLT0) = BLATT(NP18) LLAUE(NRLT0) = 13 NRLT = NRLT0 IF (ISPR47 .EQ. 0) GOTO 20 ELSE CALL PLA015 (0, 24) GOTO 70 ENDIF ENDIF 150 IF (CLATT(NRLT) .EQ. ' ') THEN IF (ISPR47 .EQ. 1) THEN IFL(1) = IFL(2) GOTO 170 ENDIF 160 WRITE (BCD, 99993) CHAR(0) CALL GGIP (-999.0, 3.0, 80.0, 112) NALF = 0 NBET = 0 NGAM = 0 NA12 = 0 NA13 = 0 NA23 = 0 NSYS = 'a' IF (ABS(XCELL(4, NRLT) - 90.0) .LT. 0.05) NALF = 1 IF (ABS(XCELL(5, NRLT) - 90.0) .LT. 0.05) NBET = 1 IF (ABS(XCELL(6, NRLT) - 90.0) .LT. 0.05) NGAM = 1 IF (ABS(XCELL(6, NRLT) - 120.0) .LT. 0.05) NGAM = 2 IF (ABS(XCELL(1, NRLT) - XCELL(2, NRLT)) .LT. 0.01) NA12 = 1 IF (ABS(XCELL(1, NRLT) - XCELL(3, NRLT)) .LT. 0.01) NA13 = 1 IF (ABS(XCELL(2, NRLT) - XCELL(3, NRLT)) .LT. 0.01) NA23 = 1 IF (NALF + NBET + NGAM .EQ. 1) THEN NSYS = 'm' ELSE IF (NALF .EQ. 1 .AND. NBET .EQ. 1 .AND. NGAM .EQ. 2) THEN IF (NA12 .EQ. 1) THEN NSYS = 'h' ELSE NSYS = 'm' ENDIF ELSE IF (NALF .EQ. 1 .AND. NBET .EQ. 1 .AND. NGAM .EQ. 1) THEN IF (NA12 .EQ. 1 .AND. NA13 .EQ. 1 .AND. NA23 .EQ. 1) THEN NSYS = 'c' ELSE IF (NA12 .EQ. 1) THEN NSYS = 't' ELSE NSYS = 'o' ENDIF ENDIF WRITE (SBCD, 99987) NRLT, NSYS, CHAR(0) CALL PLA013 (0, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 160 IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220 IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN LINE = IGGT CALL GEN038 (IGGT, 1, 80) ELSE LINE = NSYS ENDIF CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) 170 CLATT(NRLT) = IFL(1)(1:1) BLATT(NRLT) = IFL(1)(2:2) CALL GEN020 (-1, CLATT(NRLT), 1, 1) CALL GEN020 ( 1, BLATT(NRLT), 1, 1) GOTO 150 ENDIF IF (BLATT(NRLT) .EQ. ' ') THEN 180 WRITE (BCD, 99990) CHAR(0) CALL GGIP (-999.0, 3.0, 80.0, 112) WRITE (SBCD, 99992) NRLT, CHAR(0) CALL PLA013 (0, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 180 IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220 IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN LINE = IGGT CALL GEN038 (IGGT, 1, 80) ELSE LINE = 'P ' ENDIF CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) BLATT(NRLT) = IFL(1)(1:1) CALL GEN020 (1, BLATT(NRLT), 1, 1) ENDIF IF (LLAUE(NRLT) .EQ. 13) THEN IF (ISPR47 .EQ. 1) THEN FN(1) = FN(10) GOTO 200 ENDIF 190 WRITE (BCD, 99989) CHAR(0) CALL GGIP (-999.0, 3.0, 80.0, 112) ICH = CLATT(NRLT) IF (ICH .EQ. 'a') THEN IVAL = 1 ELSE IF (ICH .EQ. 'm') THEN IVAL = 2 ELSE IF (ICH .EQ. 'o') THEN IVAL = 3 ELSE IF (ICH .EQ. 't') THEN IVAL = 4 ELSE IF (ICH .EQ. 'h') THEN IF (BLATT(NRLT) .EQ. 'R') THEN IVAL = 6 ELSE IVAL = 9 ENDIF ELSE IF (ICH .EQ. 'c') THEN IVAL = 11 ENDIF WRITE (SBCD, 99991) NRLT, IVAL, CHAR(0) CALL PLA013 (0, 1) IF (IGGT(1:4) .EQ. 'PLOT') GOTO 190 IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220 IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN LINE = IGGT CALL GEN038 (IGGT, 1, 80) ELSE WRITE (LINE, 99999) IVAL ENDIF CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17) IF (KN .EQ. 0) FN(1) = 1.0 IF (NINT(FN(1)) .LT. 1 .OR. NINT(FN(1)) .GT. 12) FN(1) = 1.0 200 LLAUE(NRLT) = NINT(FN(1)) DO 210 I = 1, 3 RVAL(NRLT, I) = RVL(LLAUE(NRLT), I) 210 CONTINUE IF (ISPR47 .EQ. 0) GOTO 20 ENDIF RETURN 220 LRET0 = 1 RETURN 99999 FORMAT (I3) 99998 FORMAT (I2, ' = ', A, A, 1X, A, 3I4, 1X, 9F6.3) 99997 FORMAT (3F7.3, 3F7.2, F10.0) 99996 FORMAT ('Enter TRMX Matrix or Click on / Select TRMX #[', I2, ']', 1 A) 99994 FORMAT (':: Error - Determinant TRMX = 0.0', /) 99993 FORMAT ('a=Anorthic, m=Monoclinic, o=Orthorhombic, ', 1 't=Tetragonal, h=hexagonal, c=cubic', A) 99992 FORMAT ('Enter Lattice Centering Type for TRMX #', I3, '[P]', A) 99991 FORMAT ('Enter Laue Class for TRMX #', I3, '[', I2, ']', A) 99990 FORMAT ('Options: P, A, B, C, F, I, R :', A) 99989 FORMAT ('1=-1,2=2/m,3=mmm,4=4/m,5=4/mmm,6=-3,', 1 '7=-3m1,8=-31m,9=6/m,10=6/mmm,11=m-3,12=m-3m',A) 99988 FORMAT (A) 99987 FORMAT ('Enter Crystal System for TRMX #', I3, '[', A, ']', A) END SUBROUTINE PLA172 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), VOID(NPVD) CHARACTER N113*3 DIMENSION LV(6) NRES = 0 K = 0 JSORT = 0 LVK = 0 J0 = 0 ISL = 0 C * TABLE LIST FUNCTION C*********************************************************************** C*********************************************************************** C*********************************************************************** CALL GEN108 (LU2, 0) IPR(239) = 0 IPR(245) = IPR(37) * 12 IPR(246) = IPR(245) * 2 IPR(247) = IPR(246) + IPR(251) * 4 IPR(248) = IPR(247) + IPR(252) * 5 IPR(249) = IPR(248) + IPR(253) * 6 IPR(250) = IPR(249) + IPR(254) * 4 IPR(233) = IPR(37) * 2 IPR(234) = IPR(233) + IPR(251) * 2 IPR(235) = IPR(234) + IPR(252) * 2 IPR(236) = IPR(235) + IPR(253) * 2 IF (IPR(236) .GT. NP23) THEN IPR(236) = IPR(235) IPR(237) = IPR(235) IPR(238) = IPR(235) IPR(253) = 0 IPR(254) = 0 IPR(452) = 0 WRITE (LU6, 99998) WRITE (LU6, 99997) WRITE (LU6, 99996) ELSE IPR(237) = IPR(236) + IPR(254) * 2 IF (IPR(237) .GT. NP23) THEN IPR(237) = IPR(236) IPR(238) = IPR(236) IPR(254) = 0 IPR(452) = 0 WRITE (LU6, 99997) WRITE (LU6, 99996) ELSE IPR(238) = IPR(237) + IPR(452) * 2 IF (IPR(238) .GT. NP23) THEN IPR(238) = IPR(237) IPR(452) = 0 WRITE (LU6, 99996) ENDIF ENDIF ENDIF IPR(226) = 0 IPR(227) = IPR(233) IPR(228) = IPR(234) IPR(229) = IPR(235) IPR(230) = IPR(236) IPR(231) = IPR(237) LV(1) = 1 LV(2) = IPR(246) + 1 LV(3) = IPR(247) + 1 LV(4) = IPR(248) + 1 LV(5) = IPR(249) + 1 LV(6) = IPR(250) + 1 K0 = 0 10 IPR53S = IGBL(5) IGBL(5) = LU2 CALL PLA006 (0, IS) IF (IS .GE. 0) THEN IGBL(5) = IPR53S N113 = IFL(1)(1:3) IF (N113 .EQ. 'RES') THEN NRES = NINT(FN(1)) GOTO 10 ELSE IF (IS .GT. 24 .AND. IS .LT. 29) THEN K0 = 1 K = 1 ELSE IF (N113 .EQ. 'BON') THEN K0 = 2 K = 2 ELSE IF (N113 .EQ. 'ANG') THEN K0 = 3 K = 3 ELSE IF (N113 .EQ. 'TOR') THEN K0 = 4 K = 4 ELSE IF (N113 .EQ. 'NON') THEN K0 = 5 K = 2 ELSE IF (N113 .EQ. 'HBO') THEN K0 = 6 K = 3 ENDIF IF (K0 .GT. 0) THEN NQH = 0 DO 20 I = 1, K NQ1 = IFL(I + 1) CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD, 1 VOID(LV(K0) + I - 1), V1(I), NIEN) IF (NIEN .GE. 0) THEN NIEN = IEN(NIEN + 1) IF (NIEN .EQ. 1 .OR. NIEN .EQ. 33 .OR. 1 NIEN .EQ. 113) THEN IF (IPR(454) .EQ. 0) GOTO 10 NQH = IPR(465) ENDIF ELSE WRITE (LU6, 99999) IFL(I + 1), NIEN, NQ1 GOTO 10 ENDIF 20 CONTINUE IF (K0 .EQ. 1) THEN IF (IS .EQ. 28) THEN C * ATOM JSORT = NINT(V1(2)) LVK = LV(K0) * 16 + 5 XJX(1) = FN(1) XJX(2) = FN(2) XJX(3) = FN(3) XJX(10) = 0.0 CALL SGSM (IDM, 0, XJX, LU6, 19, IERR) FN(4) = FN(4) / XJX(10) FN(8) = FN(8) / XJX(10) J0 = 4 GOTO 50 ELSE IF (IS .EQ. 25) THEN C * UIJ JNSC(2, IPR(225 + K0)) = LVK + 7 ISL = LV(K0) DO 30 J = 1, 7 VOID(LV(K0)) = FN(J) LV(K0) = LV(K0) + 1 30 CONTINUE ELSE IF (IS .EQ. 26) THEN C * SUIJ DO 40 J = 1, 7 VOID(ISL + IPR(245)) = FN(J) ISL = ISL + 1 40 CONTINUE ELSE IF (IS .EQ. 27) THEN C * U JNSC(2, IPR(225 + K0)) = LVK + 1 VOID(LV(K0)) = FN(1) VOID(LV(K0) + IPR(245)) = FN(2) LV(K0) = LV(K0) + 1 ENDIF GOTO 10 ELSE IF (K0 .EQ. 2) THEN IF (V1(1) .GT. V1(2)) THEN CALL GEN018 (V1(1), V1(2)) CALL GEN018 (VOID(LV(K0)), VOID(LV(K0) + 1)) ENDIF JSORT = NINT(V1(1)) J0 = 2 ELSE IF (K0 .EQ. 3) THEN IF (V1(1) .GT. V1(3)) THEN CALL GEN018 (V1(1), V1(3)) CALL GEN018 (VOID(LV(K0)), VOID(LV(K0) + 2)) ENDIF JSORT = NINT(V1(2)) J0 = 2 ELSE IF (K0 .EQ. 4) THEN IF (V1(2) .GT. V1(3)) THEN CALL GEN018 (V1(2), V1(3)) CALL GEN018 (V1(1), V1(4)) CALL GEN018 (VOID(LV(K0) + 1), VOID(LV(K0) + 2)) CALL GEN018 (VOID(LV(K0)), VOID(LV(K0) + 3)) ENDIF JSORT = NINT(V1(2)) J0 = 2 ELSE IF (K0 .EQ. 5) THEN J0 = 2 JSORT = NINT(V1(1)) ELSE IF (K0 .EQ. 6) THEN J0 = 8 JSORT = NINT(V1(1)) VOID(LV(K0) + 2) = FN(9) ENDIF LVK = LV(K0) 50 IF (IPR(225 + K0) .LT. IPR(232 + K0)) THEN IPR(225 + K0) = IPR(225 + K0) + 1 JNSC(1, IPR(225 + K0)) = JSORT 1 + NQH + IPR(240) * IPR(466) * NRES JNSC(2, IPR(225 + K0)) = LVK DO 60 J = 1, J0 VOID(LV(K0) + K + J - 1) = FN(J) IF (IS .EQ. 28) 1 VOID(LV(K0) + K + J + IPR(245) - 1) = FN(J + 4) 60 CONTINUE LV(K0) = LV(K0) + K + J0 ENDIF ENDIF GOTO 10 C * END OF FILE ENDIF CALL GEN108 (LU2, 0) IF (IPR(226) .GT. 0) THEN CALL GEN037 (JNSC, 1, IPR(226)) CALL GEN037 (JNSC, IPR(233) + 1, IPR(227)) CALL GEN037 (JNSC, IPR(234) + 1, IPR(228)) IF (IPR(253) .GT. 0) CALL GEN037 (JNSC, IPR(235) + 1, IPR(229)) IF (IPR(254) .GT. 0) CALL GEN037 (JNSC, IPR(236) + 1, IPR(230)) C * LIST SECTION I = IPR(431) IF (I .GE. 0) THEN C * TITLE PAGE SUPPLEMENTARY MATERIAL CALL PLA173 (-1, LU13, 0, 0) ELSE C * CIF - HEADER CALL PLA173 (-1, LU2, 0, 0) ENDIF C * CRYSTAL DATA PUB IF (I .EQ. 2) CALL PLA173 (0, LU12, 1, 0) IF (I .EQ. 3) CALL PLA173 (0, LU12, 0, 0) C * CIF - FILE CRYSTAL DATA IF (I .LT. 0) CALL PLA173 (0, LU2, 1, 0) C * CRYSTAL DATA SUP (SU, JA, IC) IF (I .EQ. 0 .OR. I .EQ. 3) CALL PLA173 (0, LU13, 1, 0) C * ATOMS FOR CIF IF (I .LT. 0) CALL PLA173 (1, LU2, 1, 0) C * NON-H ATOMS PUB (AC, JA, IC) IF (I .EQ. 1 .OR. I .EQ. 2 .OR. I .EQ. 3) 1 CALL PLA173 (1, LU12, 0, 0) C * NON-H ATOMS SUP (SU, IC) IF (I .EQ. 0 .OR. I .EQ. 3) CALL PLA173 (1, LU13, 0, 0) C * H -ATOMS SUP IF (IPR(484) .GT. 0) THEN IF (I .GE. 0) CALL PLA173 (2, LU13, 1, 0) IF (I .LT. 0) CALL PLA173 (2, LU2, 1, 0) ENDIF C * ANISOTROPIC DISPLACEMENT PARAMETERS SUP IF (IPR(32) .EQ. 2) THEN IF (I .LT. 0) THEN CALL PLA173 (3, LU2, 0, 0) ELSE CALL PLA173 (3, LU13, 0, 0) ENDIF ENDIF IF (IPR(251) .GT. 0) THEN C * BOND DISTANCES (NON-H) PUB (AC, JA, IC) IF (I .EQ. 1 .OR. I .EQ. 2 .OR. I .EQ. 3) 1 CALL PLA173 (4, LU12, 0, 2) C * BOND DISTANCES SUP IF (I .LT. 0) THEN CALL PLA173 (4, LU2, 1, 1) ELSE CALL PLA173 (4, LU13, 1, 2) ENDIF ENDIF IF (IPR(252) .GT. 0) THEN C * BOND ANGLES (NON-H) PUB (AC, JA, IC) IF (I .EQ. 1 .OR. I .EQ. 2 .OR. I .EQ. 3) 1 CALL PLA173 (5, LU12, 0, 2) C * BOND ANGLES SUP IF (I .GE. 0) CALL PLA173 (5, LU13, 1, 2) IF (I .LT. 0) CALL PLA173 (5, LU2, 1, 1) ENDIF C * TORSION ANGLES SUP (SU) IF (IPR(253) .GT. 0) THEN IF (I .EQ. 0) CALL PLA173 (6, LU13, 0, 1) IF (I .EQ. -1) CALL PLA173 (6, LU2, 0, 1) ENDIF C * CONTACT-DISTANCES IF (IPR(254) .GT. 0) THEN IF (I .EQ. 0) CALL PLA173 (7, LU13, 1, 2) IF (I .EQ. -1) CALL PLA173 (7, LU2, 1, 1) ENDIF C * HBONDS IF (IPR(452) .GT. 0) THEN IF (I .EQ. 0) CALL PLA173 (8, LU13, 0, 1) IF (I .EQ. -1) CALL PLA173 (8, LU2, 0, 1) ENDIF C * FINISH IF (I .EQ. 0) CALL PLA173 (9, LU13, 0, 0) IF (I .LT. 0) CALL PLA173 (9, LU2, 0, 0) ENDIF RETURN 99999 FORMAT ('Ignored Label Problem in PLA172 for :', A, I10, 1X, A) 99998 FORMAT (':: Too Many Torsions -> Skipped') 99997 FORMAT (':: Too Many Non-Bonding -> Skipped') 99996 FORMAT (':: Too Many H-Bonds -> Skipped') END SUBROUTINE PLA173 (MODE, LU, INCLH, NCOL) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118, 1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP34=509,NP38=125,NP39=30, 3 NP41=200,NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9), 1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10), 2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10), 3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770) COMMON // JNSC(2, NP23), VOID(NPVD) CHARACTER FORMA*79, FORMB*67, FORMC*120, FORMT*100, FORMHA*75, 1 FORMHB*75, FORMHT*75, FORMNB*77, FORMBH*79 , CTAB*1, FPARSU*18, 2 FBOND*82, FANGL*88, FORMAN*88, FORMHC*120, FORMNH*151, FVOLU*40, 3 FORMCD*104, FORHBF*88, DCHAR*3 CHARACTER DISOR*1, UTYPE*5, SCTYP*3, ASCF*4, ASRF*1 COMMON /CIF/ CIFDIR CHARACTER CIFDIR(NP34)*36 CHARACTER CIFTYPE*3 COMMON /TODAY/ DATIJD CHARACTER DATIJD*25 C * PRINT TABLES C * MODE = -1 - HEADER C * MODE = 0 - CRYSTAL DATA ETC C * MODE = 1 - NON-H COORDINATES C * MODE = 2 - H-ATOM COORDINATES C * MODE = 3 - DISPLACEMENT PARAMETERS C * MODE = 4 - BONDS C * MODE = 5 - ANGLES C * MODE = 6 - TORSIONS C * MODE = 7 - INTER CONTACTS C * MODE = 8 - HBONDS C * MODE = 9 - FINISH C * LU7 = LIS-FILE C * LU12 = PUB-FILE C * LU13 = SUP-FILE C * LU2 = CIF-FILE DCHAR = ' ' N = 1 IF (IPR(493) .EQ. 0) IPR(493) = 2 IF (PAR(170) .LT. 0) THEN IF (KRAD(1:2) .EQ. 'Mo') THEN PAR(170) = 0.35 ELSE IF (KRAD(1:2) .EQ. 'Cu') THEN PAR(170) = 0.14 ELSE PAR(170) = 0.0 ENDIF ENDIF C * SETUP FORMATS FBOND( 1: 28) = '(8X,''a, b, c [Angstrom]'', 9X' FBOND( 29: 45) = ', F9.4,''('',I2,'')''' FBOND( 46: 82) = FBOND(29:45)//FBOND(29:45)//',A)' FANGL( 1: 34) = '(8X,''alpha, beta, gamma [deg]'', 3X' FANGL( 35: 88) = FBOND(29:82) FVOLU( 1: 40) = '(8X,''V [Ang**3]'',42X,F10.1,''('',I2,'')'',A)' C * SETUP FORMAT COORDINATES FORMC( 1: 7) = '(1X,2A ' FORMC( 8: 23) = ',F9.0,''('',I2,'')''' FORMC( 24: 55) = FORMC(8:23)//FORMC(8:23) FORMC( 56:120) = FORMC(24:55)//FORMC(24:55)//')' C * SETUP FORMAT BONDS FORMB(1 : 3) = '(1X' FORMB(4 : 33) = ', A , A , A ,F8.4,''('',I2,'')''' FORMB(34 : 67) = ',5X'//FORMB(4:33)//')' C * SETUP FORMAT BOND ANGLES FORMA(1 : 3) = '(1X' FORMA(4 : 39) = ', A , A, A , A , A ,F8.4,''('',I2,'')''' FORMA(40 : 79) = ',3X'//FORMA(4:39)//')' C * SETUP FORMAT TORSION ANGLES FORMT(1 : 3) = '(1X' FORMT(4 : 38) = ', A , A , A , A , A , A , A ,' FORMT(39 : 54) = 'F8.4,''('',I2,'')'')' C * SETUP FORMAT TABLE HEADERS FORMHB(1 : 41) = ' (8X,''Table '',A,I1,'' - Bond Distances '',' FORMHB(42: 75) = '''(Angstrom) '',A,/,19X,''for: '',A,/)' FORMHA(1 : 41) = ' (4X,''Table '',A,I1,'' - Bond Angles '',' FORMHA(42: 75) = '''(Degrees) '',A,/,15X,''for: '',A,/)' FORMHT(1 : 41) = ' (9X,''Table '',A,I1,'' - Torsion Angles '',' FORMHT(42: 75) = '''(Degrees) '',A,/,20X,''for: '',A,/)' FORMNB(1 : 43) = ' (8X,''Table '',A,I1,'' - Contact Distances'',' FORMNB(44: 77) = '''(Angstrom) '',A,/,19X,''for: '',A,/)' FORMBH(1 : 41) = ' (8X,''Table '',A,I1,'' - Hydrogen Bonds '',' FORMBH(42: 79) = '''(Angstrom, Deg)'',A,/,19X,''for: '',A,/)' FORMAN( 1: 40) = ' (4X,''Table '',A,I1,'' - (An)isotropic '',' FORMAN(41: 72) = ''' Displacement Parameters '',A,/,' FORMAN(73: 88) = '15X,''for: '',A,/)' FORMHC( 1: 40) = ' (8X,''Table '',A,I1,'' - Hydrogen Atom '',' FORMHC(41: 85) = '''Positions and Isotropic Displacement'',/,19X,' FORMHC(86:104) = '''Parameters '',A,/,' FORMHC(105:120)= '19X,''for: '',A,/)' FORMNH( 1: 43) = ' (8X,''Table '',A,I1,'' - Final Coordinates'',' FORMNH(44: 88) = ''' and Equivalent Isotropic Displacement'',/,19' FORMNH(89:133) = 'X,''Parameters of the non-Hydrogen atoms '',A,' FORMNH(134:151)= '/,19X,''for: '',A,/)' FORMCD( 1: 43) = ' (8X,''Table '',A,I1,'' - Crystal Data and '',' FORMCD(44: 88) = '''Details of the Structure Determination'',A,/,' FORMCD(89:104) = '19X,''for: '',A,/)' FORHBF( 1:38) = '(A,1X,A,1X,A,F7.4,''('',I2,'')'',F7.4,''('',' FORHBF(39:73) = 'I2,'')'',F7.4,''('',I2,'')'',F7.1,''('',I2,' FORHBF(74:88) = ''')'',1X,A,'' '')' FPARSU(1:18) = '(F10.0,''('',I2,'')'')' IF (LU .NE. LU2) THEN IF (MODE .LT. 4) THEN LSTART = 8 ELSE LSTART = 4 ENDIF IF (LU .EQ. LU12) THEN IF (MODE .NE. 7) IPR(239) = IPR(239) + 1 IDOUBL = 2 NTAB = IPR(239) CTAB = ' ' ELSE IF (LU .EQ. LU13) THEN IF (MODE .NE. -1) IGBL(84) = IGBL(84) + 1 NTAB = IGBL(84) CTAB = 'S' IF (IPR(431) .EQ. 2 .OR. IPR(431) .EQ. 3) THEN IDOUBL = 1 ELSE IDOUBL = IPR(274) ENDIF ELSE IF (LU .EQ. LU7) THEN IDOUBL = 1 NTAB = 0 CTAB = ' ' ENDIF MXLIN = IPR(243) / IDOUBL LSTART = LSTART / IDOUBL IF (IDOUBL .EQ. 1) THEN DCHAR = ' ' ELSE DCHAR = ' '//CHAR(10) ENDIF ELSE MXLIN = 99999 LSTART = 1 IDOUBL = 1 ENDIF IF (MODE .EQ. -1) THEN C * COVER PAGE SUPPLEMENTARY MATERIAL IF (LU .NE. LU2) THEN IF (LU .EQ. LU12) THEN WRITE (LU, 99983) CHAR(12) ELSE IF (LU .EQ. LU13) THEN IGBL(85) = IGBL(85) + 1 WRITE (LU, 99982) CHAR(12), IGBL(85) ENDIF WRITE (LU, 99999) JID(1:40), DATIJD(5:24) J = IPR(431) NTB = IGBL(84) IF (J .EQ. 0 .OR. J .EQ. 3) THEN CALL PLA176 (0, LU, CTAB, NTB, FORMCD, JID) CALL PLA176 (0, LU, CTAB, NTB, FORMNH, JID) ENDIF IF (IPR(484) .GT. 0) 1 CALL PLA176 (0, LU, CTAB, NTB, FORMHC, JID) IF (IPR(32) .GT. 0) THEN FORMAN( 4 : 4) = '8' FORMAN(73 : 74) = '19' CALL PLA176 (0, LU, CTAB, NTB, FORMAN, JID) FORMAN( 4 : 4) = '4' FORMAN(73 : 74) = '15' ENDIF IF (IPR(251) .GT. 0) 1 CALL PLA176 (0, LU, CTAB, NTB, FORMHB, JID) IF (IPR(252) .GT. 0) THEN FORMHA( 4 : 4) = '8' FORMHA(60 : 61) = '19' CALL PLA176 (0, LU, CTAB, NTB, FORMHA, JID) FORMHA( 4 : 4) = '4' FORMHA(60 : 61) = '15' ENDIF IF (IPR(253) .GT. 0 .AND. J .EQ. 0) THEN FORMHT( 4 : 4) = '8' FORMHT(60 : 61) = '19' CALL PLA176 (0, LU, CTAB, NTB, FORMHT, JID) FORMHT( 4 : 4) = '9' FORMHT(60 : 61) = '20' ENDIF IF (IPR(254) .GT. 0) 1 CALL PLA176 (0, LU, CTAB, NTB, FORMNB, JID) IF (IPR(452) .GT. 0) 1 CALL PLA176 (0, LU, CTAB, NTB, FORMBH, JID) ELSE C * CIF - FILE - HEADER WRITE (LU, 99300) JID(1:40) WRITE (LU, 99299) IF (IPR(431) .EQ. -1) THEN WRITE (LU, 99298) 'global' CIFTYPE = 'ACC' ELSE WRITE (LU, 99298) DATANM CIFTYPE = 'CSD' ENDIF WRITE (LU, 99299) WRITE (LU, 99297) WRITE (LU, 99296) CIFDIR(71), DATIJD(5:24), CIFDIR(72), 1 CIFTYPE, CIFDIR(73) WRITE (LU, 99295) WRITE (LU, 99294) IF (IPR(399) .EQ. 0) THEN WRITE (LU, 99293) CIFDIR(437), CIFDIR(438) WRITE (LU, 99292) CIFDIR(325), '?' WRITE (LU, 99292) CIFDIR(326), '?' WRITE (LU, 99292) CIFDIR(327), '?' ELSE WRITE (LU, 99278) CIFDIR(437), CIFDIR(438) WRITE (LU, 99277) WRITE (LU, 99292) CIFDIR(325), 1 '''a.l.spek@chem.uu.nl''' WRITE (LU, 99292) CIFDIR(326), '''+31 30 2533940''' WRITE (LU, 99292) CIFDIR(327), '''+31 30 2532538''' ENDIF IF (IPR(431) .EQ. -1) THEN WRITE (LU, 99291) WRITE (LU, 99290) CIFDIR(336), CIFDIR(436) WRITE (LU, 99292) CIFDIR(335), '?' WRITE (LU, 99291) WRITE (LU, 99289) CIFDIR(328) WRITE (LU, 99295) WRITE (LU, 99288) WRITE (LU, 99287) CIFDIR(305), CIFDIR(299), CIFDIR(298), 1 CIFDIR(297), CIFDIR(301), CIFDIR(300), 2 CIFDIR(303), CIFDIR(302), CIFDIR(294), 3 CIFDIR(291), CIFDIR(295), CIFDIR(314), 4 CIFDIR(318), CIFDIR(288), CIFDIR(308), 5 CIFDIR(321), CIFDIR(320), CIFDIR(307), 6 CIFDIR(309), CIFDIR(310), CIFDIR(311), 7 CIFDIR(312) ELSE IF (IPR(431) .EQ. -2) THEN WRITE (LU, '(A, A)') CIFDIR(435), '?' ENDIF WRITE (LU, 99295) WRITE (LU, 99286) WRITE (LU, 99285) CIFDIR(337), CIFDIR(439) WRITE (LU, 99284) WRITE (LU, 99283) CIFDIR(323), CIFDIR(469), CIFDIR(322) IF (IPR(399) .EQ. 1) THEN WRITE (LU, 99279) WRITE (LU, 99277) ENDIF IF (IPR(431) .EQ. -1) THEN WRITE (LU, 99295) WRITE (LU, 99282) WRITE (LU, 99248) CIFDIR(440), CIFDIR(338) WRITE (LU, 99252) WRITE (LU, 99281) CIFDIR(339) WRITE (LU, 99250) CIFDIR(424), CIFDIR(425) WRITE (LU, 99251) WRITE (LU, 99259) CIFDIR(344), CHAR(92), CHAR(39) WRITE (LU, 99258) WRITE (LU, 99257) IF (IPR(399) .EQ. 0) THEN WRITE (LU, 99265) CIFDIR(343) ELSE WRITE (LU, 99274) CIFDIR(343) ENDIF WRITE (LU, 99245) CIFDIR(345) WRITE (LU, 99295) WRITE (LU, 99298) DATANM ENDIF WRITE (LU, 99295) WRITE (LU, 99280) ENDIF ELSE IF (MODE .EQ. 0) THEN IF (IPR(215) .EQ. 0) THEN CALL PLA283 (0, 1, N, IDM) CALL PLA283 (2, IPR(260), N1, ICL) ELSE CALL GEN038 (IDM, 1, 80) CALL GEN038 (ICL, 1, 80) IDM(80:80) = '?' ICL(80:80) = '?' N = 80 N1 = 80 ENDIF DO 10 I = 1, 3 IFB = 17 + 17 * I FBOND(IFB : IFB) = CHAR(ICHAR('0') + IPR(286 + I)) IFA = 23 + 17 * I FANGL(IFA : IFA) = CHAR(ICHAR('0') + IPR(289 + I)) 10 CONTINUE FVOLU(26 : 26) = CHAR(ICHAR('0') + IPR(294)) C * CIF-FILE IF (LU .EQ. LU2) THEN WRITE (LU, 99281) CIFDIR(116) WRITE (LU, 99292) CIFDIR(113), '?' WRITE (LU, 99292) CIFDIR(112), '?' IF (INDEX (RLWS(4), '?') .EQ. 0) THEN WRITE (LU, 99197) CIFDIR(107), RLWS(4)(1:79) ELSE WRITE (LU, 99397) CIFDIR(107), IDM(N:80) ENDIF WRITE (LU, 99253) WRITE (LU, 99292) CIFDIR(108), '?' IF (INDEX (RLWS(5), '?') .EQ. 0) THEN WRITE (LU, 99197) CIFDIR(109), RLWS(5)(1:79) ELSE N1 = MAX (5, N1) WRITE (LU, 99397) CIFDIR(109), ICL(N1:80) ENDIF WRITE (LU, 99292) CIFDIR(482), '?' IF (INDEX (RLWS(4), '?') .EQ. 0) THEN WRITE (LU, 99396) CIFDIR(110), PAR(308) ELSE WRITE (LU, 99396) CIFDIR(110), PAR(163) / IPR(260) ENDIF WRITE (LU, 99399) CIFDIR(94) WRITE (LU, 99270) CIFDIR(70), CIFDIR(52), CIFDIR(67), 1 CIFDIR(66), CIFDIR(68) DO 2 I = 1, IAN K = IENS(IAN + 1 - I) IF (NINT(CONT(K, 2) / IPR(260)) .GT. 0) THEN J = (IEN(K) - 1) * 15 IF (IPR(493) .EQ. 1) THEN J0 = J + 13 ELSE IF (IPR(493) .EQ. 2) THEN J0 = J + 11 ELSE IF (IPR(493) .EQ. 3) THEN J0 = J + 9 ELSE J0 = 0 ENDIF IF (J0 .NE. 0) THEN WRITE (LU, 99261) LMT(K, 1)(1:2), LMT(K, 1)(1:2), 1 (SFAC(J0 + L), L = 1, 2) ELSE WRITE (LU, 99061) LMT(K, 1)(1:2), LMT(K, 1)(1:2) ENDIF ENDIF 2 CONTINUE WRITE (LU, 99295) WRITE (LU, 99269) WRITE (LU, 99376) CIFDIR(418), KRSYST CALL GEN039 (0, SPGRNM(3), 1, 17, K03, K3) IF (K03 .GE. K3) THEN SPGRNM(3)(1:1) = '?' K03 = 1 K3 = 1 ENDIF CALL GEN039 (1, SPGRNM(1), 15, 26, K01, K1) IF (K01 .GE. K1) SPGRNM(1)(K01:K01) = '?' WRITE (LU, 99375) CIFDIR(421), SPGRNM(3)(K03:K3), 1 CIFDIR(422), SPGRNM(1)(K01:K1), 2 CIFDIR(420), IPR(202) WRITE (LU, 99373) CIFDIR(480), CIFDIR(419) NSYM = IPR(48) XJX(4) = 0.0 XJX(5) = 0.0 XJX(6) = 0.0 DO 100 I = 1, NSYM ISYM = I CALL SGSM (ICL, ISYM, XJX, 0, 20, IERR) CALL GEN020 (-1, ICL, 1, 30) WRITE (LU, 99984) ISYM, ICL(1:30) 100 CONTINUE WRITE (LU, 99291) WRITE (PRBUF, FBOND) PAR(101), IPR(281), PAR(102), IPR(282), 1 PAR(103), IPR(283), DCHAR CALL GEN065 (0, PRBUF, 80, 1) WRITE (LU, 99388) CIFDIR(78), PRBUF(36:48), 1 CIFDIR(79), PRBUF(49:61), 2 CIFDIR(80), PRBUF(62:74) WRITE (PRBUF, FANGL) PAR(104), IPR(284), PAR(105), IPR(285), 1 PAR(106), IPR(286), DCHAR CALL GEN065 (0, PRBUF, 80, 3) WRITE (LU, 99388) CIFDIR(74), PRBUF(36:48), 1 CIFDIR(75), PRBUF(49:61), 2 CIFDIR(76), PRBUF(62:74) WRITE (PRBUF, FVOLU) PAR(98), IPR(293), DCHAR CALL GEN065 (0, PRBUF, 80, 1) WRITE (LU, 99382) CIFDIR(93), PRBUF(62:74) IF (INDEX (RLWS(4), '?') .EQ. 0) THEN CALL PLA175 (2, LU, 77, '(A, I6)', IPR(276), 0.0) ELSE CALL PLA175 (2, LU, 77, '(A, I6)', IPR(260), 0.0) ENDIF CALL PLA175 (2, LU, 88, '(A, I6)', IPR(261), 0.0) CALL PLA175 (1, LU, 87, ' ?', 0, 0.0) CALL PLA175 (1, LU, 90, ' ?', 0, 0.0) CALL PLA175 (1, LU, 89, ' ?', 0, 0.0) IF (IPR(399) .EQ. 1) THEN WRITE (LU, 99255) CIFDIR(92) ELSE WRITE (LU, 99268) CIFDIR(92) ENDIF WRITE (LU, 99291) WRITE (LU, 99243) CIFDIR(239), CCIF(5)(1:NCIF(5)), 1 CIFDIR(234), CCIF(14)(1:NCIF(14)) CALL PLA175 (3, LU, 251, '(A, F10.3)', 0, PAR(302)) CALL PLA175 (3, LU, 252, '(A, F10.3)', 0, PAR(303)) CALL PLA175 (3, LU, 253, '(A, F10.3)', 0, PAR(304)) CALL PLA175 (1, LU, 254, ' ?', 0, 0.0) CALL PLA175 (3, LU, 236, '(A, F10.3)', 0, PAR(158)) IF (INDEX (RLWS(4), '?') .EQ. 0) THEN CALL PLA175 (3, LU, 235, '(A, F10.3)', 0, PAR(267)) ELSE CALL PLA175 (3, LU, 235, '(A, F10.3)', 0, PAR(160)) ENDIF CALL PLA175 (1, LU, 238, '''Not Measured''', 0, 0.0) CALL PLA175 (2, LU, 240, '(A, I10)', NINT(PAR(157)), 0.0) IF (INDEX (RLWS(4), '?') .EQ. 0) THEN CALL PLA175 (3, LU, 229, '(A, F10.3)', 0, PAR(301)) ELSE XMUM = PAR(162) IF (XMUM .EQ. 0.0) XMUM = -999999.0 CALL PLA175 (3, LU, 229, '(A, F10.3)', 0, XMUM) ENDIF CALL PLA175 (1, LU, 237, ' ?', 0, 0.0) IF (IPR(485) .EQ. 4) THEN WRITE (LU, 99247) CIFDIR(232), CIFDIR(233) ELSE WRITE (LU, 99244) WRITE (LU, 99246) CIFDIR(232), CCIF(15)(1:NCIF(15)), 1 CIFDIR(233) ENDIF CALL PLA175 (3, LU, 231, '(A, F10.3)', 0, PAR(307)) CALL PLA175 (3, LU, 230, '(A, F10.3)', 0, PAR(306)) WRITE (LU, 99295) WRITE (LU, 99266) WRITE (LU, 99265) CIFDIR(256) CALL PLA175 (2, LU, 133, '(A, I6)', IPR(310), 0.0) CALL PLA175 (3, LU, 164, '(A, F10.5)', 0, PAR(17)) IF (IPR(493) .LT. 5) THEN WRITE (LU, 99362) CIFDIR(481), 'x-ray' IF (IPR(493) .LT. 4) THEN WRITE (LU, 99362) CIFDIR(163), KRAD(1:3)//CHAR(92)//'a' ELSE WRITE (LU, 99362) CIFDIR(163), '?' ENDIF ELSE WRITE (LU, 99362) CIFDIR(481), 'neutron' ENDIF IF (IPR(399) .EQ. 0) THEN CALL PLA175 (1, LU, 162, ' ?', 0, 0.0) CALL PLA175 (1, LU, 159, ' ?', 0, 0.0) ELSE WRITE (LU, 99392) CIFDIR(162), CIFDIR(159) ENDIF WRITE (LU, 99291) CALL PLA175 (1, LU, 441, ' ?', 0, 0.0) CALL PLA175 (1, LU, 137, ' ?', 0, 0.0) IF (IPR(399) .EQ. 1) THEN CALL PLA175 (3, LU, 463, '(A, F10.1)', 0, 18.4) ELSE CALL PLA175 (1, LU, 463, ' ?', 0, 0.0) ENDIF WRITE (LU, 99291) CALL PLA175 (1, LU, 227, ' ?', 0, 0.0) CALL PLA175 (1, LU, 225, ' ?', 0, 0.0) CALL PLA175 (1, LU, 226, ' ?', 0, 0.0) CALL PLA175 (1, LU, 224, ' ?', 0, 0.0) WRITE (LU, 99357) CIFDIR(221), CIFDIR(222), CIFDIR(223) WRITE (LU, 99291) WRITE (LU, 99355) CALL PLA175 (2, LU, 204, '(A, I6)', IPR(262), 0.0) CALL PLA175 (3, LU, 196, '(A, F8.4)', 0, PAR(197)) CALL PLA175 (3, LU, 197, '(A, F8.4)', 0, PAR(198)) CALL PLA175 (2, LU, 199, '(A, I6)', IPR(267), 0.0) CALL PLA175 (2, LU, 198, '(A, I6)', IPR(268), 0.0) CALL PLA175 (2, LU, 201, '(A, I6)', IPR(269), 0.0) CALL PLA175 (2, LU, 200, '(A, I6)', IPR(270), 0.0) CALL PLA175 (2, LU, 203, '(A, I6)', IPR(271), 0.0) CALL PLA175 (2, LU, 202, '(A, I6)', IPR(272), 0.0) CALL PLA175 (3, LU, 207, '(A, F6.2)', 0, PAR(167)) CALL PLA175 (3, LU, 206, '(A, F6.2)', 0, PAR(168)) CALL PLA175 (3, LU, 444, '(A, F6.2)', 0, PAR(312)) CALL PLA175 (3, LU, 458, '(A, F6.3)', 0, PAR(313)) CALL PLA175 (3, LU, 459, '(A, F6.3)', 0, PAR(314)) WRITE (LU, 99351) CIFDIR(205) WRITE (LU, 99324) CALL PLA175 (2, LU, 410, '(A, I8)', IPR(263), 0.0) WRITE (LU, 99323) CALL PLA175 (2, LU, 442, '(A, I8)', IPR(264), 0.0) IF (CCIF(1)(2:3) .EQ. '2s') CCIF(1) = 'I>2'//CHAR(92)//'s(I)' WRITE (LU, 99322) CIFDIR(443), CCIF(1)(1:NCIF(1)) WRITE (LU, 99291) IF (IPR(399) .EQ. 1) THEN WRITE (LU, 99394) CIFDIR(118), CIFDIR(117), CIFDIR(119) ELSE WRITE (LU, 99393) CIFDIR(118), CIFDIR(117), CIFDIR(119) ENDIF WRITE (LU, 99391) CIFDIR(123) IF (IPR(400) .EQ. 1) THEN WRITE (LU, 99390) CIFDIR(122), 1 ' ''SHELXL-97 (Sheldrick, 1997)''' ELSE WRITE (LU, 99390) CIFDIR(122), ' ?' ENDIF WRITE (LU, 99264) CIFDIR(120) WRITE (LU, 99389) CIFDIR(121) WRITE (LU, 99295) WRITE (LU, 99263) IF (IPR(400) .EQ. 0) THEN WRITE (LU, 99332) CIFDIR(373) ELSE WRITE (LU, 99276) CIFDIR(373) ENDIF WRITE (LU, 99348) CIFDIR(369), CCIF(2)(1:NCIF(2)) WRITE (LU, 99347) CIFDIR(358), CCIF(3)(1:NCIF(3)) WRITE (LU, 99346) CIFDIR(370), CCIF(9)(1:NCIF(9)) WRITE (LU, 99342) CIFDIR(451), RLWS(1) IF (IPR(484) .LE. 0) THEN CCIF(12) = ' .' CCIF(13) = ' .' NCIF(12) = 2 NCIF(13) = 2 ENDIF WRITE (LU, 99345) CIFDIR(48), CCIF(10)(1:NCIF(10)), 1 CIFDIR(49), CCIF(11)(1:NCIF(11)), 2 CIFDIR(50), CCIF(12)(1:NCIF(12)) WRITE (LU, 99301) CIFDIR(357), CCIF(13)(1:NCIF(13)) WRITE (LU, 99344) CIFDIR(354), CCIF(4)(1:NCIF(4)) IF (CCIF(4)(1:4) .NE. 'none') THEN IF (PAR(229) .GT. 999990) THEN PRBUF(1:1) = '?' CALL GEN038 (PRBUF, 2, 20) ELSE FPARSU(6:6) = CHAR(ICHAR('0') + IPR(278)) WRITE (PRBUF, FPARSU) PAR(229), IPR(277) CALL GEN065 (0, PRBUF, 80, 1) ENDIF WRITE (LU, 99981) CIFDIR(352), PRBUF(1:20) WRITE (LU, 99342) CIFDIR(353), RLWS(2) ENDIF IF (IPR(257) .EQ. 2) THEN WRITE (LU, 99341) CIFDIR(349), CIFDIR(350) ELSE WRITE (LU, 99254) CIFDIR(349) IF (PAR(433) .LT. 999999.0) THEN FPARSU(6:6) = CHAR(ICHAR('0') + IPR(280)) WRITE (PRBUF, FPARSU) PAR(433), IPR(279) CALL GEN065 (0, PRBUF, 80, 1) WRITE (LU, 99981) CIFDIR(350), PRBUF(1:20) ELSE CALL PLA175 (1, LU, 350, ' ?', 0, 0.0) ENDIF WRITE (LU, 99060) CIFDIR(478), CCIF(17)(1:NCIF(17)) ENDIF CALL PLA175 (2, LU, 361, '(A, I10)', IPR(265), 0.0) CALL PLA175 (2, LU, 360, '(A, I10)', IPR(266), 0.0) CALL PLA175 (2, LU, 362, '(A, I10)', IPR(273), 0.0) CALL PLA175 (1, LU, 359, ' ?', 0, 0.0) CALL PLA175 (3, LU, 363, '(A, F10.4)', 0, PAR(309)) CALL PLA175 (3, LU, 445, '(A, F10.4)', 0, PAR(173)) CALL PLA175 (3, LU, 446, '(A, F10.4)', 0, PAR(174)) CALL PLA175 (3, LU, 460, '(A, F10.4)', 0, PAR(310)) CALL PLA175 (3, LU, 447, '(A, F10.3)', 0, PAR(299)) CALL PLA175 (3, LU, 365, '(A, F10.3)', 0, PAR(300)) CALL PLA175 (3, LU, 448, '(A, F10.3)', 0, PAR(178)) CALL PLA175 (3, LU, 461, '(A, F10.3)', 0, PAR(179)) CALL PLA175 (3, LU, 347, '(A, F10.3)', 0, PAR(177)) CALL PLA175 (3, LU, 348, '(A, F10.3)', 0, PAR(176)) CALL PLA175 (3, LU, 462, '(A, F10.3)', 0, PAR(175)) WRITE (LU, 99295) WRITE (LU, 99262) ENDIF C * CRYSTAL DATA TABLE (INCLH = 0: PARTIAL, = 1 : FULL) IF (LU .NE. LU2) THEN IF (LU .EQ. LU12) THEN WRITE (LU, 99983) CHAR(12) ELSE IF (LU .EQ. LU7) THEN CALL PLA269 (0) ELSE IF (LU .EQ. LU13) THEN IGBL(85) = IGBL(85) + 1 WRITE (LU, 99982) CHAR(12), IGBL(85) ENDIF IF (INCLH .EQ. 0) THEN WRITE (LU, 99978) CTAB, NTAB, DCHAR, JID(1:40), DCHAR ELSE CALL PLA176 (-1, LU, CTAB, NTAB, FORMCD, JID) ENDIF IF (INCLH .GT. 0) WRITE (LU, 99977) IF (INDEX (RLWS(4), '?') .EQ. 0) THEN N2 = INDEX(RLWS(4), CHAR(39)) CALL GEN038 (PRBUF, 1, 80) IF (N2 .GT. 1 .AND. N2 .LT. 59) THEN WRITE (LU, 99976) PRBUF(1:59-N2)//RLWS(4)(1:N2-1), DCHAR ELSE WRITE (LU, 99976) PRBUF(1:57)//'?', DCHAR ENDIF WRITE (LU, 99975) PAR(308), DCHAR ELSE WRITE (LU, 99976) IDM(23:80), DCHAR WRITE (LU, 99975) PAR(163) / IPR(260), DCHAR ENDIF IF (INCLH .GT. 0) WRITE (LU, 99974) KRSYST, DCHAR WRITE (LU, 99973) SPGRNM(1)(1:7), SPGRNM(1)(8:11), 1 IPR(202), DCHAR WRITE (PRBUF, FBOND) PAR(101), IPR(281), PAR(102), IPR(282), 1 PAR(103), IPR(283), DCHAR CALL GEN065 (LU, PRBUF, 80, 1) WRITE (PRBUF, FANGL) PAR(104), IPR(284), PAR(105), IPR(285), 1 PAR(106), IPR(286), DCHAR IF (INDEX (KRSYST, 'Tri') .NE. 0 .OR. 1 INDEX (KRSYST, 'Mon') .NE. 0) THEN CALL GEN065 (LU, PRBUF, 80, 3) ENDIF WRITE (PRBUF, FVOLU) PAR(98), IPR(293), DCHAR CALL GEN065 (LU, PRBUF, 80, 1) IF (INDEX (RLWS(4), '?') .EQ. 0) THEN WRITE (LU, 99970) IPR(276), DCHAR IF (PAR(158) .LT. 10000.0) THEN WRITE (LU, 99969) PAR(158), PAR(267), DCHAR ELSE WRITE (LU, 99948) PAR(160), DCHAR ENDIF WRITE (LU, 99967) KRAD, PAR(301), DCHAR ELSE WRITE (LU, 99970) IPR(260), DCHAR IF (PAR(158) .LT. 10000.0) THEN WRITE (LU, 99969) PAR(158), PAR(160), DCHAR ELSE WRITE (LU, 99948) PAR(160), DCHAR ENDIF WRITE (LU, 99967) KRAD, PAR(162), DCHAR ENDIF IF (INCLH .GT. 0) WRITE (LU, 99968) NINT(PAR(157)), DCHAR IF (INCLH .GT. 0) THEN WRITE (LU, 99966) MAX (0.0, PAR(304)), MAX(0.0, PAR(303)), 1 MAX (0.0, PAR(302)), DCHAR WRITE (LU, 99965) ENDIF WRITE (LU, 99964) IPR(261), DCHAR WRITE (LU, 99963) KRAD, MAX (0.0, PAR(17)), DCHAR IF (INCLH .GT. 0) THEN WRITE (LU, 99962) MAX (0.0, PAR(167)), MAX(0.0, PAR(168)), 1 DCHAR WRITE (LU, 99957) 1 (MIN(999, MAX (-99, IPR(I))), I = 267, 272), DCHAR WRITE (LU, 99956) MAX (0, IPR(262)), MAX(0, IPR(263)), 1 MAX (0.0, PAR(197)), DCHAR IF (IPR(400) .EQ. 1) PAR(180) = 2.0 WRITE (LU, 99955) PAR(180), MAX (0, IPR(264)), DCHAR WRITE (LU, 99954) WRITE (LU, 99953) MAX (0, IPR(265)), 1 MAX (0, IPR(266)), DCHAR ENDIF WRITE (LU, 99952) MAX (0.0, PAR(173)), MAX (0.0, PAR(174)), 1 MAX (0.0, PAR(299)), DCHAR IF (INCLH .GT. 0) THEN WRITE (LU, 99951) RLWS(1)(9:70), DCHAR WRITE (LU, 99950) MAX (0.0, PAR(178)), 1 MAX (0.0, PAR(179)), DCHAR IF (PAR(433) .LT. 999999.0) THEN FPARSU(6:6) = CHAR(ICHAR('0') + IPR(280)) WRITE (PRBUF, FPARSU) PAR(433), IPR(279) CALL GEN065 (0, PRBUF, 80, 1) WRITE (LU, 99947) PRBUF(1:14), DCHAR ENDIF WRITE (LU, 99949) MIN (0.0, PAR(176)), MAX (0.0, PAR(177)) ENDIF ENDIF ELSE IF (MODE .LT. 4) THEN IF (LU .EQ. LU12) THEN WRITE (LU, 99983) CHAR(12) ELSE IF (LU .EQ. LU13) THEN IGBL(85) = IGBL(85) + 1 WRITE (LU, 99982) CHAR(12), IGBL(85) ENDIF C * MODE = 1 - COORDINATES AND (AN)ISOTROPIC DISPLACEMENT PARAMETERS IF (MODE .EQ. 1) THEN C * CIF - COORDINATES + (AN)ISO IF (LU .EQ. LU2) THEN WRITE (LU, 99499) CIFDIR(22), CIFDIR(35), CIFDIR(34), 1 CIFDIR(19), CIFDIR(20), CIFDIR(21), 2 CIFDIR(30), CIFDIR(36), CIFDIR(11), 3 CIFDIR(31) ELSE CALL PLA176 (-1, LU, CTAB, NTAB, FORMNH, JID) WRITE (LU, 99998) ENDIF C * MODE = 2 - H-ATOM COORDINATES ELSE IF (MODE .EQ. 2) THEN IF (LU .NE. LU2) THEN CALL PLA176 (-1, LU, CTAB, NTAB, FORMHC, JID) WRITE (LU, 99995) ENDIF C * MODE = 3 - DISPLACEMENT PARAMETERS ELSE IF (MODE .EQ. 3) THEN IF (LU .EQ. LU2) THEN WRITE (LU, 99799) 1 CIFDIR(1), CIFDIR(3), CIFDIR(6), CIFDIR(8), CIFDIR(7), 2 CIFDIR(5), CIFDIR(4) ELSE CALL PLA176 (-1, LU, CTAB, NTAB, FORMAN, JID) WRITE (LU, 99997) ENDIF ENDIF ITEL = LSTART NAT = IPR(226) IF (IPR(240) .EQ. 0) THEN NRO = 0 ELSE NRO = 1 ENDIF NDISO = 0 DO 380 I = 1, NAT DISOR = ' ' NR = JNSC(1, I) / IPR(466) N4 = JNSC(2, I) N1 = N4 / 16 N4 = N4 - N1 * 15 - 1 N1 = N1 + 1 N2 = N1 + 2 N3 = N1 + 4 IF (LU .EQ. LU2) N2 = N2 + 1 IF (N4 .NE. N3) THEN UTYPE = 'Uani ' IF (MODE .EQ. 3) THEN N4 = N4 - 1 ELSE N3 = N4 ENDIF ELSE UTYPE = 'Uiso ' ENDIF IF (MODE .EQ. 3 .AND. N4 .EQ. N3) GOTO 380 CALL PLA047 (VOID(N1 - 1), NQ1, IDUM, IENR, IPR(119), 1 IGBL(55), 0, 1) N = IEL(IENR) M = N / 100 SCTYP = CHAR (ICHAR('A') + M - 1)//' ' N = N - M * 100 IF (N .GT. 0) SCTYP(2 : 2) = CHAR (ICHAR('a') + N - 1) IF (IENR .EQ. 1 .OR. IENR .EQ. 33 .OR. IENR .EQ. 113) THEN IF (MODE .EQ. 1) GOTO 380 ELSE IF (MODE .EQ. 2) GOTO 380 ENDIF N = 0 IPS = -4 FORMC(5 : 5) = '2' IF (LU .EQ. LU2) THEN FORMC(2 : 2) = '1' ELSE FORMC(2 : 2) = '3' ENDIF IF (MODE .LT. 3) THEN IF (LU .EQ. LU2) THEN FORMC(2 : 2) = '1' FORMC(5 : 5) = '3' ELSE FORMC(2 : 2) = '7' FORMC(5 : 5) = '2' ENDIF IF (VOID(N2 + 1) .LT. 1.0) THEN DISOR = '*' NDISO = NDISO + 1 ENDIF DO 350 M = N1, N2 N = N + 1 IPS = IPS + 16 IF (M - N1 .EQ. 3) THEN FORMC(IPS - 2 : IPS - 2) = '6' MDEC = 3 ELSE FORMC(IPS - 2 : IPS - 2) = '9' MDEC = MIN (IPR(183), 5) ENDIF STDV = MAX (0.0, VOID(IPR(245) + M)) CALL GEN041 (VOID(M), STDV, ISDV(N), MDEC, IDEC, IPR(68)) FORMC(IPS : IPS) = CHAR(ICHAR('0') + IDEC) DEV(N) = VOID(M) 350 CONTINUE ENDIF C * UEQ, U OR UIJ DO 360 M = N3, N4 N = N + 1 STDV = MAX (0.0, VOID(IPR(245) + M)) CALL GEN041 (VOID(M), STDV, ISDV(N), 4, IDEC, IPR(68)) IPS = IPS + 16 IF (MODE .EQ. 3) THEN IF (LU .EQ. LU2 .AND. IPS .GE. 60) THEN FORMC(IPS - 2 : IPS - 2) = '8' ELSE FORMC(IPS - 2 : IPS - 2) = '7' ENDIF ENDIF FORMC(IPS : IPS) = CHAR(ICHAR('0') + IDEC) DEV(N) = VOID(M) 360 CONTINUE IF (LU .NE. LU2) THEN ITEL = ITEL + 1 IF (NR .GT. NRO) THEN ITEL = ITEL + 1 NRO = NR WRITE (LU, 99985) IF (IDOUBL .EQ. 2) WRITE (LU, 99985) ENDIF IF (ITEL .GT. MXLIN) THEN ITEL = LSTART + 1 IF (LU .EQ. LU12) THEN WRITE (LU, 99983) CHAR(12) ELSE IGBL(85) = IGBL(85) + 1 WRITE (LU, 99982) CHAR(12), IGBL(85) ENDIF IF (MODE .EQ. 1) THEN CALL PLA176 (1, LU, CTAB, NTAB, FORMNH, JID) WRITE (LU, 99998) ELSE IF (MODE .EQ. 2) THEN CALL PLA176 (1, LU, CTAB, NTAB, FORMHC, JID) WRITE (LU, 99995) ELSE IF (MODE .EQ. 3) THEN CALL PLA176 (1, LU, CTAB, NTAB, FORMAN, JID) WRITE (LU, 99997) ENDIF ENDIF ENDIF IF (LU .EQ. LU2) THEN IF (MODE .EQ. 1 .OR. MODE .EQ. 2) THEN ASCF = '.' ASRF = '.' NQ4 = NQ1 CALL PLA046 (2, NQ4, IX, LBB, LBC, LBD, XNQNR, YNQNR, NR) IF (NR .GT. 0) THEN CALL GEN048 (-1, JFG(NR), 29, IVL) IF (IVL .GT. 0) ASCF = 'calc' CALL GEN048 (-1, JFG(NR), 30, IVL) IF (IVL .GT. 0) ASRF = 'R' CALL GEN048 (-1, JFG(NR), 31, IVL) IF (IVL .GT. 0) ASRF = 'G' ENDIF WRITE (PRBUF, FORMC) NQ1, SCTYP, UTYPE, 1 (DEV(M), ISDV(M), M = 1, N) PRBUF(82:) = ASCF//' '//ASRF ELSE IF (MODE .EQ. 3) THEN WRITE (PRBUF, FORMC) DISOR, NQ1, 1 (DEV(M), ISDV(M), M = 1, N) ENDIF CALL GEN065 (0, PRBUF, 90, 1) CALL GEN103 (PRBUF, 90) WRITE (LU, 99983) PRBUF(1:80) ELSE WRITE (PRBUF, FORMC) DISOR, NQ1, 1 (DEV(M), ISDV(M), M = 1, N) CALL GEN065 (LU, PRBUF, 80, 3) IF (IDOUBL .EQ. 2) WRITE (LU, 99985) ENDIF 380 CONTINUE IF (LU .NE. LU2) THEN IF (MODE .EQ. 1) THEN WRITE (LU, 99993) IF (NDISO .GT. 0) WRITE (LU, 99996) ELSE IF (MODE .EQ. 2) THEN WRITE (LU, 99989) WRITE (LU, 99988) WRITE (LU, 99987) ELSE IF (MODE .EQ. 3) THEN WRITE (LU, 99989) WRITE (LU, 99988) WRITE (LU, 99987) WRITE (LU, 99986) ENDIF ENDIF C * BOND TABLE ELSE IF (MODE .EQ. 4) THEN CALL PLA174 (MODE, FORMB, FORMHB, LU, CTAB, NTAB, MXLIN, 1 LSTART, NCOL, INCLH, 33, 11, 4, IDOUBL) C * ANGLE TABLE ELSE IF (MODE .EQ. 5) THEN CALL PLA174 (MODE, FORMA, FORMHA, LU, CTAB, NTAB, MXLIN, 1 LSTART, NCOL, INCLH, 39, 11, 2, IDOUBL) C * TORSION TABLE ELSE IF (MODE .EQ. 6) THEN CALL PLA174 (MODE, FORMT, FORMHT, LU, CTAB, NTAB, MXLIN, 1 LSTART, NCOL, INCLH, 42, 0, 2, IDOUBL) C * INTER-CONTACTS ELSE IF (MODE .EQ. 7) THEN CALL PLA174 (MODE, FORMB, FORMNB, LU, CTAB, NTAB, MXLIN, 1 LSTART, NCOL, INCLH, 33, 11, 4, IDOUBL) C * H-BONDS ELSE IF (MODE .EQ. 8) THEN CALL PLA174 (MODE, FORHBF, FORMBH, LU, CTAB, NTAB, MXLIN, 1 LSTART, NCOL, INCLH, 42, 0, 4, IDOUBL) C * FINISH ELSE IF (MODE .EQ. 9) THEN IF (LU .EQ. LU13) THEN IGBL(85) = IGBL(85) + 1 WRITE (LU, 99982) CHAR(12), IGBL(85) WRITE (LU, 99249) CALL PLA043 (0, -1, LU, 0) ENDIF IF (LU .EQ. LU2) THEN WRITE (LU, 99001) WRITE (LU, 99002) WRITE (LU, 99003) WRITE (LU, 99004) WRITE (LU, 99005) WRITE (LU, 99006) WRITE (LU, 99007) WRITE (LU, 99260) ENDIF ENDIF RETURN 99999 FORMAT ( 1 8X, A, ' : ', A, ////, 2 17X, 43('='), /, 3 17X, 'S U P P L E M E N T A R Y M A T E R I A L', /, 4 17X, 43('='), //, 2 17X, 'B E L O N G I N G TO T H E P A P E R', /////////, 3 35X, 'b y', //////////, 4 29X, 'C o n t e n t s', /, 29X, 15('='), /) 99998 FORMAT (8X, 'Atom', 10X, 'x', 12X, 'y', 12X, 'z', 6X, 1 'U(eq) [Ang^2]', /, 8X, '----', 4X, 3(5X, '---', 5X), 2 11('-'), /) 99997 FORMAT (4X, 'Atom', 4X, 'U(1,1) or U', 1 2X, 'U(2,2)', 5X, 'U(3,3)', 5X, 'U(2,3)', 5X, 'U(1,3)', 2 5X, 'U(1,2)', /, 4X, '----', 6X, 6('------',5X)) 99996 FORMAT (/, 11X, 'Starred Atom sites have a S.O.F less ', 1 'than 1.0') 99995 FORMAT (8X, 'Atom', 10X, 'x', 12X, 'y', 12X, 'z', 5X, 1 'U(iso) [Ang^2]', /, 8X, '----', 4X, 3(5X, '---', 5X), 11('-')) 99993 FORMAT (/, 10X, 1 'U(eq) = 1/3 of the trace of the orthogonalized U Tensor') 99989 FORMAT (/, 11X, 55('='), /) 99988 FORMAT (9X,'The Temperature Factor has the Form of Exp(-T) Where') 99987 FORMAT (8X,'T = 8*(Pi**2)*U*(Sin(Theta)/Lambda)**2 for Isotr', 1 'opic Atoms') 99986 FORMAT (8X, 'T = 2*(Pi**2)*Sumij(h(i)*h(j)*U(i,j)*Astar(i)*Astar', 1 '(j)), for', /, 6X, 'Anisotropic Atoms. Astar(i) are Reciprocal', 2 ' Axial Lengths and', /, 10X, 'h(i) are the Reflection Indices.') 99985 FORMAT (1X) 99984 FORMAT (I4, 1X, A) 99983 FORMAT (A) 99982 FORMAT (A, 35X, '-', I3, ' -', /) 99981 FORMAT (A, 2X, A) 99978 FORMAT (8X, 'Table ', A, I2, ' - Crystallographic Data', /, A, 1 19X, 'for: ', A, /, A) 99977 FORMAT (35X, 'Crystal Data', /) 99976 FORMAT (8X, 'Formula', 1X, A, A) 99975 FORMAT (8X, 'Formula Weight', 43X, F9.2, A) 99974 FORMAT (8X, 'Crystal System', 40X, A, A) 99973 FORMAT (8X, 'Space group', 34X, A, 1X, A, ' (No.', I3, ')', A) 99970 FORMAT (8X, 'Z', 60X, I5, A) 99969 FORMAT (8X, 'D(obs), D(calc) [g/cm**3]', 29X, F5.3, ', ', F5.3, A) 99968 FORMAT (8X, 'F(000)', 52X, I8, A) 99967 FORMAT (8X, 'Mu(', A, ') [ /mm ]', 43X, F7.3, A) 99966 FORMAT (8X, 'Crystal Size [mm]', 27X, 2(F6.2, ' x'), F6.2, A) 99965 FORMAT (31X, 'Data Collection', /) 99964 FORMAT (8X, 'Temperature (K)',46X, I5, A) 99963 FORMAT (8X, 'Radiation [Angstrom]', 29X, A, 5X, F8.5, A) 99962 FORMAT (8X, 'Theta Min-Max [Deg]', 35X, F5.1, ',', 1X, F5.1, A) 99957 FORMAT (8X, 'Dataset', 32X, I3, ':', I3, ' ;', I4, ':', I3, 1 ' ;', I4, ':', I3, A) 99956 FORMAT (8X, 'Tot., Uniq. Data, R(int)', 20X, I6, ', ', I6, 1 ', ', F6.3, A) 99955 FORMAT (8X, 'Observed data [I > ', F3.1, ' sigma(I)]', 26X, I8, A) 99954 FORMAT (34X, 'Refinement', /) 99953 FORMAT (8X, 'Nref, Npar', 45X, I5, ',', I5, A) 99952 FORMAT (8X, 'R, wR2, S', 36X, F7.4, ',', F7.4, ',', F5.2, A) 99951 FORMAT (8X, 'w = ', A, A) 99950 FORMAT (8X, 'Max. and Av. Shift/Error', 31X, F5.2, ',', F5.2, A) 99949 FORMAT (8X, 'Min. and Max. Resd. Dens. [e/Ang^3]', 20X, 1 F5.2, ',', F5.2) 99948 FORMAT (8X, 'D(calc) [g/cm**3]', 44X, F5.3, A) 99947 FORMAT (8X, 'Flack x', 45X, A, A) 99799 FORMAT (/, 'loop_', 7(/, A)) 99499 FORMAT (/, 'loop_', 10(/, A)) 99399 FORMAT (A, '''see text''') 99397 FORMAT (A, /, '''', A, '''') 99197 FORMAT (A, /, '''', A) 99396 FORMAT (A, F10.2) 99394 FORMAT (A, /, 1 '''Locally modified CAD4 Software (Enraf-Nonius, 1989)''', 1 /, A, '''SET4 (de Boer & Duisenberg, 1984)''', 2 /, A, '''HELENA (Spek, 1997)''') 99393 FORMAT (A, ' ?', /, A, ' ?', /, A, ' ?') 99392 FORMAT (A, ' ''Rotating Anode'' ', /, A, ' ''graphite'' ') 99391 FORMAT (A, ' ?') 99390 FORMAT (A, A) 99389 FORMAT (A, ' ''PLATON (Spek, 2003)'' ') 99388 FORMAT (A, 1X, A, /, A, 1X, A, /, A, 1X, A) 99382 FORMAT (A, 1X, A) 99376 FORMAT (A, 1X, A) 99375 FORMAT (A, 1X, '''', A, '''', /, A, 1X, '''', A, '''', /, A, I10) 99373 FORMAT (/, 'loop_', 2(/, A)) 99362 FORMAT (A, 1X, '''', A, '''') 99357 FORMAT (/, 'loop_', /, A, /, A, /, A, /, 1 ' ? ? ?') 99355 FORMAT ('# number of measured reflections (redundant set)') 99351 FORMAT (A, /, ';', /, ';') 99348 FORMAT (A, 1X, A) 99347 FORMAT (A, 1X, A) 99346 FORMAT (A, 1X, '''', A, '''', /, A, /, A) 99345 FORMAT (3(A, '''', A, '''', /)) 99344 FORMAT (A, 1X, '''', A, '''') 99342 FORMAT (A, /, A) 99341 FORMAT (A, ' ?', /, A, '.') 99332 FORMAT (A, ' ?') 99324 FORMAT (/, '# number of unique reflections') 99323 FORMAT ('# number of observed reflections (> n sig(I))') 99322 FORMAT (A, 1X, A) 99300 FORMAT ('# CIF-file generated for ', A, /) 99299 FORMAT ('#', 78('=')) 99298 FORMAT ('data_', A) 99297 FORMAT (/, '# 0. AUDIT DETAILS', /) 99296 FORMAT (A, 1X, '''',A, '''', /, 2 A, ' ''PLATON option'' ', /, 3 A, /, ';', /, ';') 99295 FORMAT (/, '#', 79('='), /) 99294 FORMAT ('# 1. SUBMISSION DETAILS', /) 99293 FORMAT (A, '# Name of author for correspondence', 1 /, ';', / ';', /, 2 A, '# address of author for correspondence', 3 /, ';', /, ';', /) 99292 FORMAT (A, 1X, A) 99291 FORMAT (1X) 99290 FORMAT (A, ' ''Acta Crystallographica C'' ', /, 1 '# Publication choise FI, CI or EI for Inorganic', /, 2 '# FM, CM or EM for Metal-organic', /, 3 '# FO, CO or EO for Organic', /, A, ' ?') 99289 FORMAT (A, '# Include date of submission', /, ';', /, 1 'Date of submission ?', //, 2 'Please consider this CIF submission for publication as a', /, 3 'Regular Structural Paper in Acta Crystallographica C. ', /, ';') 99288 FORMAT ('# 2. PROCESSING SUMMARY (JOURNAL OFFICE ONLY)', /) 99287 FORMAT (A, ' ?', //, 3(A, ' ?', /), /, 4(A, ' ?', /), /, 1 2(A, ' ?', /), A, /, ';', /, ';', //, A, ' ?', /, 2 A, /, ';', /, ';', //, 7(A, ' ?', /), //, 3 2(A, ' ?', /)) 99286 FORMAT ('# 3. TITLE AND AUTHOR LIST', /) 99285 FORMAT (A, /, ';', /, ';', /, 1 A, /, ';', /, ';') 99284 FORMAT (/, '# The loop structure below should contain the ', 1 'names and adresses of all', /, '# authors, in the ', 2 'required order of publication. Repeat as necessary.', /) 99283 FORMAT (/, 'loop_', 3(/, A), /, '''?'' # author name', 1 /, '; # author related footnote', /, ';', 2 /, '; # Address of this author', /, ';') 99282 FORMAT ('# 4. TEXT', /) 99281 FORMAT (A, /, ';', /, ';') 99280 FORMAT ('# 5. CHEMICAL DATA', /) 99279 FORMAT (' ''Spek, Anthony L.''', /, 1 '; # author related footnote', /, ';') 99278 FORMAT (A, '# Name of author for correspondence', 1 /, '; Prof. Dr. A.L. Spek', /, ';', /, 2 A, '# Address of author for correspondence') 99277 FORMAT ('; Bijvoet Center for Biomolecular Research', /, 1 ' Crystal and Structural Chemistry', /, 2 ' Utrecht University', /, 3 ' Padualaan 8', /, 4 ' 3584 CH Utrecht', /, 5 ' The Netherlands', /, ';') 99276 FORMAT (A, /, ';', /, 1 ' Refinement on F^2^ for ALL reflections except those', / 2 , ' flagged by the user for potential systematic errors.', 3 /, ' Weighted R-factors wR and all goodnesses of fit S', /, 4 ' are based on F^2^, conventional R-factors R are based', 5 /, ' on F, with F set to zero for negative F^2^. The', /, 6 ' observed criterion of F^2^ > 2sigma(F^2^) is used only', 7 /, ' for calculating -R-factor-obs etc. and is not', /, 8 ' relevant to the choice of reflections for refinement.' 9 , /, ' R-factors based on F^2^ are statistically about twice', * /, ' as large as those based on F, and R-factors based on', 1 /, ' ALL data will be even larger.', /, ';') 99274 FORMAT (A, /, ';', /, 'This work was supported in part (ALS) ', 1 'by the Council for the Chemical', /, 'Sciences of the ', 2 'Netherlands Organization for Scientific Research ', 3 '(CW-NWO).', /, ';') 99270 FORMAT (/, 'loop_', 5(/, A)) 99269 FORMAT ('# 6. CRYSTAL DATA', /) 99268 FORMAT (A, /, ';', /, ';') 99266 FORMAT ('# 7. EXPERIMENTAL DATA', /) 99265 FORMAT (A, /, ';', /, ';') 99264 FORMAT (A, ' ?') 99263 FORMAT ('# 8. REFINEMENT DATA', /) 99262 FORMAT ('# 9. ATOMIC COORDINATES AND DISPLACEMENT PARAMETERS') 99261 FORMAT (A, 2X, A, 2F10.4, /, 1 ' ''International Tables Vol C Tables 4.2.6.8 and 6.1.1.4''') 99260 FORMAT (/, '#===END') 99259 FORMAT (A, /, ';', /, ' Allen, F.H. (2002).', /, 1 ' Acta Cryst. B58, 380-388.', //, 2 ' Altomare, A., Burla, M.C., Camalli, M., Cascarano, G.L.,', 3 ' Giacovazzo, C.', /, ' Guagliardi, A., Moliterni, A.G.G.,', 4 ' Polidori, G. & Spagna, R.', /, 5 ' (1999) J. Appl. Cryst. 32, 115-119.', //, 6 ' Beurskens, P.T., Beurskens, G., de Gelder, R.,', 7 ' Garc', A, A, 'ia-Granda, S.,', /, ' Gould, R.O., Israel, R.', 8 ' & Smits, J.M.M. (1999) The DIRDIF99 Program System,', /, 9 ' Technical Report of the Crystallography Laboratory,', /, 1 ' University of Nijmegen, The Netherlands.', //, 2 ' Boer, J.L. de & Duisenberg, A.J.M. (1984). Acta Cryst.', 3 ' A40, C-410.', //, 4 ' Boeyens, J.C.A. (1978). J.Cryst.Mol.Struct. 8, 317-320.', //, 5 ' Cremer, D. & Pople, J.A. (1975). J. Am. Chem. Soc. 97,', 6 ' 1354-1358.', //, 7 ' Duisenberg, A.J.M. (1992). J. Appl. Cryst. 25, 92-96.', /) 99258 FORMAT (' Duisenberg, A.J.M., Kroon-Batenburg, L.M.J. &', 1 ' Schreurs, A.M.M. (2003).', /, 2 ' J. Appl. Cryst. 36, 220-229.', //, 3 ' Enraf-Nonius (1989). CAD-4 Software. Version 5.', 4 ' Enraf-Nonius, Delft,', /, ' The Netherlands.', //, 5 ' Flack, H.D. (1983). Acta Cryst. A39, 876-881.', //, 6 ' Hooft, R.W.W. (1998). Collect Software, Nonius', 7 ' B.V., Delft, The Netherlands.', //, 8 ' LePage, Y. (1987). J. Appl. Cryst. 20, 264-269.', //, 9 ' Mackay, A.L. (1984). Acta Cryst. A40, 165-166.', //, * ' Meulenaer, J. de & Tompa, H. (1965). Acta Cryst. 19,', 1 ' 1014-1018.', //, ' North, A.C.T.,', 2 ' Phillips, D.C. & Mathews, F.S. (1968).', /, ' Acta Cryst.', 3 ' A24, 351-359.', //, ' Otwinowski, Z. & Minor, W. (1997).', 4 ' Methods in Enzymology, Vol. 276,', /, 3X, 'Macromolecular', 5 ' Crystallography, Part A, edited by C.W. Carter &', /, 3X, 6 ' R.M. Sweet, pp. 307-326. London: Academic Press.', //, 7 ' Sheldrick, G.M. (1986). SHELXS86.', 8 ' University of G\"ottingen, Germany.', /) 99257 FORMAT (' Sheldrick, G.M. (1993). SHELXL93.', 1 ' University of G\"ottingen, Germany.', //, 2 ' Sheldrick, G.M. (1997). SHELXS97.', 3 ' University of G\"ottingen, Germany.', //, 4 ' Sheldrick, G.M. (1997). SHELXL97.', 5 ' University of G\"ottingen, Germany.', //, 6 ' Sluis, P. van der & Spek, A.L. (1990). Acta Cryst. A46,', 7 ' 194-201.', //, 8 ' Spek, A.L. (1987). Acta Cryst. C43, 1233-1235.', //, 9 ' Spek, A.L. (1988). J. Appl. Cryst. 21, 578-579.', //, * ' Spek, A.L. (1994). Am. Crystallogr. Assoc.-Abstracts,', 1 ' 22, 66.', //, 2 ' Spek, A.L. (1997). HELENA, Program for Datareduction,', 3 ' Utrecht', /, ' University, The Netherlands.', //, 4 ' Spek, A.L. (2003). J. Appl. Cryst. 36, 7-13.', //, 5 ' Wilson, A.J.C. (1992). Ed. International Tables for', 6 ' Crystallography,', /, ' Volume C, Kluwer Academic', 7 ' Publishers, Dordrecht, The Netherlands.', 8 /, ';') 99255 FORMAT (A, /, ';', /, 1 'Least Squares Treatment of 25 SET4 setting angles.', /, 2 ';') 99254 FORMAT (A, /, ' ''Flack H.D. (1983), Acta Cryst. A39, 876-881'' ') 99060 FORMAT (/, '# Permitted for _chemical_absolute_configuration:', /, 1 '# Absolute configuration details', /, 2 '# rm = Det. by chiral ref. mol. with known abs.conf', /, 3 '# ad = Det. by anomalous dispersion', /, 4 '# rmad = Det. by ''rm'' and ''ad'' ', /, 5 '# syn = Det. with reference to synthesis', /, 6 '# unk = Unknown/Arbitrary', /, A, A, /) 99253 FORMAT ('# Ex: ''C12 H16 N2 O6, H2 O'' and', 1 ' ''(Cd 2+)3, (C6 N6 Cr 3-)2, 2(H2 O)'' ') 99252 FORMAT (/, '# Insert blank lines between paragraphs', /) 99251 FORMAT (/, '# Insert blank lines between references', /) 99250 FORMAT (A, /, ';', /, ' ?', /, ';', /, 1 A, /, ';', /, ' ?', /, ';') 99249 FORMAT (/, ' Translation of Symmetry Code to Equiv.Pos', //) 99248 FORMAT (A, /, ';', /, ' ?', /, ';', /, 1 A, /, ';', /, ' ?', /, ';') 99247 FORMAT (A, ' '' psi-scan'' ', /, A, /, 1 ' ''(North et al., 1968)'' ') 99246 FORMAT (A, '''', A, '''', /, 1 '# Example: ''(North et al., 1968)''', /, 2 A, ' ?') 99245 FORMAT (A, /, 1 '; View of the title compound with the atom numbering scheme.', 2 /, 'Displacement ellipsoids for non-H atoms are drawn at the', 3 ' 50% probability level.', /, ';') 99244 FORMAT (/, '# Permitted for _exptl_absorpt_correction_type :', /, 1 '# analytical ''analytical from crystal shape''', /, 2 '# Example: de Meulenaer&Tompa: ABST', /, 3 '# cylinder ''cylindrical''', /, 4 '# gaussian ''Gaussian from crystal shape''', /, 5 '# Example: PLATON/ABSG', /, 6 '# integration ''integration from crystal shape''', /, 7 '# multi-scan ''symmetry-related measurements''', /, 8 '# Example: SADABS, MULABS', /, 9 '# none ''no absorption corr. applied''', /, * '# numerical ''numerical from crystal shape''', /, 1 '# psi-scan ''psi-scan corrections''', /, 2 '# Example: PLATON/ABSP', /, 3 '# refdelf ''refined from delta-F''', /, 4 '# Example: SHELXA, DIFABS, DELABS', /, 5 '# sphere ''spherical''', /, 6 '# Example: PLATON/ABSS') 99243 FORMAT (2(A, '''', A, '''', /)) 99301 FORMAT (/, '# Permitted for _refine_ls_hydrogen_treatment :', /, 1 '# refall - refined all H parameters', /, 2 '# refxyz - refined H coordinates only', /, 3 '# refU - refined H U only', /, 4 '# noref - no refinement of H parameters', /, 5 '# constr - H parameters constrained', /, 6 '# mixed - some constrained, some independent', /, 7 '# undef - H-atom parameters not defined', /, 8 A, '''', A, '''', /) 99061 FORMAT (A, 2X, A, 2(' ?'), /, 1 ' ''International Tables Vol C Tables 4.2.6.8 and 6.1.1.4''') 99001 FORMAT (/, '# Loop Mechanism for Extra Tables(s)', /, 1 /, '#loop_', 2 /, '#_publ_manuscript_incl_extra_item', 3 /, '#''_geom_extra_tableA_col_1''', 4 /, '#''_geom_extra_tableA_col_2''', 5 /, '#''_geom_extra_tableA_col_3''', 6 /, '#''_geom_extra_table_head_A''', 7 /, '#''_geom_table_footnote_A''', 8 /, '#''_geom_extra_tableB_col_1''', 9 /, '#''_geom_extra_tableB_col_2''', * /, '#''_geom_extra_tableB_col_3''', 1 /, '#''_geom_extra_table_head_B''', 2 /, '#''_geom_table_footnote_B''', /) 99002 FORMAT (/, '#', 1 /, '#loop_', 2 /, '#_geom_extra_tableA_col_1', 3 /, '#_geom_extra_tableA_col_2', 4 /, '#_geom_extra_tableA_col_3', 5 /, '# ? ? ?', /) 99003 FORMAT (/, '#', 1 /, '#loop_', 2 /, '#_geom_extra_tableB_col_1', 3 /, '#_geom_extra_tableB_col_2', 4 /, '#_geom_extra_tableB_col_3', 5 /, '# ? ? ?', /) 99004 FORMAT (/, '#', 1 /, '#_geom_table_footnote_A', 2 /, '#;', /, '# ?', /, '#;', /) 99005 FORMAT (/, '#', 1 /, '#_geom_table_footnote_B', 2 /, '#;', /, '# ?', /, '#;', /) 99006 FORMAT (/, '#', 1 /, '#_geom_table_footnote_A', 2 /, '#;', /, '# ?', /, '#;', /) 99007 FORMAT (/, '#', 1 /, '#_geom_table_footnote_B', 2 /, '#;', /, '# ?', /, '#;', /) END SUBROUTINE PLA174 (MODE, FORM, FORMH, LU, CTAB, NTAB, MXLIN, 1 LSTART, NCOL, INCLH, IPS1, IPS2, IDECM, IDOUBL) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP34=509,NP38=125,NP39=30, 3 NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /CIF/ CIFDIR CHARACTER CIFDIR(NP34)*36 COMMON // JNSC(2, NP23), VOID(NPVD) DIMENSION DHA(4), IDHA(4) CHARACTER CTAB*1 CHARACTER FORM*(*), FORMH*(*), DASH*1, GSS(4)*8 ISPACE = 0 JMX = 0 NHATS = 0 NHET = 0 IF (MODE .EQ. 4) THEN ISPACE = 8 IF (LU .EQ. LU2) THEN WRITE (LU, 99995) WRITE (LU, 99994) WRITE (LU, 99993) CIFDIR(277) WRITE (LU, 99998) CIFDIR(265), CIFDIR(266), CIFDIR(267), 1 CIFDIR(269), CIFDIR(270), CIFDIR(268) ISPACE = 1 ENDIF ELSE IF (MODE .EQ. 5) THEN ISPACE = 4 IF (LU .EQ. LU2) THEN WRITE (LU, 99997) CIFDIR(258), CIFDIR(259), CIFDIR(260), 1 CIFDIR(257), CIFDIR(262), CIFDIR(263), 2 CIFDIR(264), CIFDIR(261) ISPACE = 1 ENDIF ELSE IF (MODE .EQ. 6) THEN ISPACE = 9 IF (LU .EQ. LU2) THEN WRITE (LU, 99996) CIFDIR(279), CIFDIR(280), CIFDIR(281), 1 CIFDIR(282), CIFDIR(278), CIFDIR(284), 2 CIFDIR(285), CIFDIR(286), CIFDIR(287), 3 CIFDIR(283) ISPACE = 1 ENDIF ELSE IF (MODE .EQ. 7) THEN ISPACE = 8 IF (LU .EQ. LU2) THEN WRITE (LU, 99998) CIFDIR(271), CIFDIR(272), CIFDIR(273), 1 CIFDIR(275), CIFDIR(276), CIFDIR(274) ISPACE = 1 ENDIF ELSE IF (MODE .EQ. 8) THEN ISPACE = 1 IF (LU .EQ. LU2) THEN WRITE (LU, 99992) 1 CIFDIR(426)(1:29), CIFDIR(427)(1:29), CIFDIR(428)(1:29), 2 CIFDIR(429)(1:23), CIFDIR(430)(1:23), CIFDIR(431)(1:23), 3 CIFDIR(432)(1:21), CIFDIR(433)(1:27), CIFDIR(434)(1:21) FORM(84:86) = 'yes' ENDIF ENDIF IN01 = IPR(229 + MODE) + 1 IN02 = IPR(223 + MODE) IF (MODE .LT. 7) THEN JMX = MODE - 2 ELSE IF (MODE .EQ. 7) THEN JMX = 2 ENDIF IF (LU .EQ. LU12) THEN WRITE (LU, 99990) CHAR(12) ELSE IF (LU .EQ. LU13) THEN IGBL(85) = IGBL(85) + 1 WRITE (LU, 99999) CHAR(12), IGBL(85) ENDIF DASH = ' ' IF (LU .NE. LU2) THEN CALL PLA176 (-1, LU, CTAB, NTAB, FORMH, JID) IF (MODE .EQ. 7) THEN DASH = '.' ELSE DASH = '-' ENDIF ENDIF IF (MODE .EQ. 8) THEN DO 20 J = IN01, IN02 L = JNSC(2, J) CALL PLA047 ( VOID(L), NQ1, ISOP, IENR, IPR(119), 1 IGBL(55), 0, 1) CALL PLA047 ( VOID(L + 1), NQ2, ISOP, IENR, IPR(119), 1 IGBL(55), 0, 1) CALL PLA047 (- VOID(L + 2), NQ3, ISOP, IENR, IPR(119), 1 IGBL(55), 0, 1) IF (LU .EQ. LU13) THEN NQ1(6:7) = '--' NQ2(6:7) = '..' ENDIF IF (ISOP .EQ. 1) THEN GSS(3) = ' . ' ELSE MISOP = MOL(ISOP) / NINT(PAR(42)) MISOPH = MISOP / 1000 MISOPT = MISOP - MISOPH * 1000 WRITE (GSS(3)(1:8), 99991) MISOPH, MISOPT ENDIF NDECM = IDECM M = 0 DO 10 K = 1, 7, 2 M = M + 1 IF (K .EQ. 7) NDECM = 2 DHA(M) = VOID(L + K + 2) CALL GEN041 (DHA(M), VOID(L + K + 3), IDHA(M), NDECM, 1 IDEC, IPR(68)) IPS = 1 + M * 16 FORM(IPS:IPS) = CHAR(ICHAR('0') + IDEC) 10 CONTINUE WRITE (PRBUF, FORM) NQ1, NQ2, NQ3, 1 (DHA(M), IDHA(M), M = 1, 4), GSS(3) IF (IDOUBL .EQ. 2) WRITE (LU, '(1X)') CALL GEN065 (LU, PRBUF, 80, 1) 20 CONTINUE GOTO 110 ENDIF IF (IDOUBL .EQ. 2) WRITE (LU, '(1X)') FORM(2 : 2) = CHAR(ICHAR('0') + ISPACE) NLIN = MXLIN - LSTART ITEL = LSTART IN3 = IPR(231) IN1 = IN3 + 1 IN2 = IN3 DO 30 J = IN01, IN02 MJNSC = MOD(JNSC(1, J), IPR(466)) IF (INCLH .NE. 0 .OR. MJNSC .LE. IPR(465)) THEN IN2 = IN2 + 1 JNSC(1, IN2) = MJNSC JNSC(2, IN2) = JNSC(2, J) ENDIF 30 CONTINUE IC = NLIN * NCOL ICP2 = NCOL IN = IN2 - IN1 + 1 INP = (IN + NCOL - 1) / NCOL INP = INP * NCOL INM = INP - IN IN2P = IN2 + INM DO 40 J = 1, INM JNSC(2, J + IN2) = 0 40 CONTINUE IM = (INP + IC - 1) / IC IC3 = INP - (IM - 1) * IC DO 70 M = 1, IM I = (M - 1) * NLIN * NCOL + IN1 - 1 IF (M .GE. IM) IC = IC3 ICS = IC / NCOL DO 60 J = 1, NCOL DO 50 K = 1, ICS IND = I + (J - 1) * ICS + K JNSC(1, IND) = (K - 1) * NCOL + J 50 CONTINUE 60 CONTINUE CALL GEN037 (JNSC, I + 1, I + IC) 70 CONTINUE K = 0 DO 100 I = IN1, IN2P K = K + 1 L = JNSC(2, I) IF (L .LE. 0) THEN ICP2 = ICP2 - 1 ELSE NHATS = 0 NHET = 0 DO 80 J = 1, JMX VOIDLJ = VOID(L + J - 1) IF (LU .EQ. LU2) VOIDLJ = - VOIDLJ CALL PLA047 (VOIDLJ, NQ1, ISOP, IENR, IPR(119), IGBL(55), 1 0, 1) IF (IENR .EQ. 1) NHATS = NHATS + 1 IF (IENR .GT. 2) NHET = NHET + 1 NAMS(K, J) = NQ1//' ' IF (LU .EQ. LU2) THEN IF (ISOP .EQ. 1) THEN GSS(J) = ' . ' ELSE MISOP = MOL(ISOP) / NINT(PAR(42)) MISOPH = MISOP / 1000 MISOPT = MISOP - MISOPH * 1000 WRITE (GSS(J), 99991) MISOPH, MISOPT ENDIF ENDIF 80 CONTINUE V2(K) = VOID(L + JMX) CALL GEN041 (V2(K), VOID(L + JMX + 1), ISDV(K), 1 IDECM, IDEC, IPR(68)) IPS = K * IPS1 - IPS2 FORM(IPS : IPS) = CHAR(ICHAR('0') + IDEC) ENDIF IF (K .GE. NCOL) THEN ITEL = ITEL + 1 IF (ITEL .GT. MXLIN) THEN ITEL = LSTART + 1 IF (LU .EQ. LU12) THEN WRITE (LU, 99990) CHAR(12) ELSE IF (LU .EQ. LU13) THEN IGBL(85) = IGBL(85) + 1 WRITE (LU, 99999) CHAR(12), IGBL(85) ENDIF IF (LU .NE. LU2) THEN CALL PLA176 (1, LU, CTAB, NTAB, FORMH, JID) ENDIF IF (IDOUBL .EQ. 2) WRITE (LU, '(1X)') ENDIF WRITE (PRBUF, FORM) ((NAMS(M, J)(1:7), DASH, J = 1, JMX - 1), 1 NAMS(M, JMX)(1:7), V2(M), ISDV(M), M = 1, ICP2) IF (LU .EQ. LU2) THEN DO 90 M = 1, JMX J = 38 + M * 8 PRBUF(J : J + 8) = GSS(M) 90 CONTINUE IF (MODE .LT. 7 .AND. NHATS .EQ. 0 .AND. 1 NHET .GT. 0 .AND. JMX .LT. 4) THEN PRBUF(78:80) = 'yes' ELSE PRBUF(78:80) = 'no ' ENDIF ENDIF CALL GEN065 (LU, PRBUF, 80, 1) IF (IPR(431) .GE. 0 .AND. IDOUBL .EQ. 2) WRITE (LU, '(1X)') K = 0 ICP2 = NCOL ENDIF 100 CONTINUE 110 RETURN 99999 FORMAT (A, 35X, '-', I3, ' -', /) 99998 FORMAT (/, 'loop_', 6(/, A)) 99997 FORMAT (/, 'loop_', 8(/, A)) 99996 FORMAT (/, 'loop_', 10(/, A)) 99995 FORMAT (/, '#', 79('='), /) 99994 FORMAT ('# 10. MOLECULAR GEOMETRY', /) 99993 FORMAT (A, /, ';', /, 1 ' Bond distances, angles etc. have been calculated using the', 2 /, 3 ' rounded fractional coordinates. All su''s are estimated', /, 4 ' from the variances of the (full) variance-covariance matrix' 5 , '.', /, ' The cell esds are taken into account in the', 6 ' estimation of', /, 7 ' distances, angles and torsion angles', /, 7 ';') 99992 FORMAT (/, 'loop_', 9(/, A), /, '#', /, 1 '#D H A D - H H...A D...A D - H...A symm(A)', /, 2 '#') 99991 FORMAT (I3, '_', I3, 1X) 99990 FORMAT (A) END SUBROUTINE PLA175 (MODE, LU, NCIFDIR, STR, IVAR, VAR) PARAMETER (NP34=509) COMMON /CIF/ CIFDIR CHARACTER CIFDIR(NP34)*36, STR*(*) IF (MODE .EQ. 1) THEN WRITE (LU, 99999) CIFDIR(NCIFDIR), STR ELSE IF (MODE .EQ. 2) THEN IF (IABS(IVAR) .LT. 999999) THEN WRITE (LU, STR) CIFDIR(NCIFDIR), IVAR ELSE WRITE (LU, 99999) CIFDIR(NCIFDIR), ' ?' ENDIF ELSE IF (MODE .EQ. 3) THEN IF (ABS(VAR) .LT. 10000.0) THEN WRITE (LU, STR) CIFDIR(NCIFDIR), VAR ELSE WRITE (LU, 99999) CIFDIR(NCIFDIR), ' ?' ENDIF ENDIF RETURN 99999 FORMAT (2A) END SUBROUTINE PLA176 (MODE, LU, CTAB, NTB, FORM, JID) CHARACTER CTAB*1, FORM*(*), JID*(*), CHCON*11 IF (MODE .LE. 0) THEN N = 1 CHCON = ' ' ELSE N = 11 CHCON = '(continued)' ENDIF IF (MODE .EQ. 0) NTB = NTB + 1 IF (NTB .GT. 9) FORM(19:19) = '2' WRITE (LU, FORM) CTAB, NTB, CHCON(1:N), JID(1:40) RETURN END SUBROUTINE PLA178 (NPC, LU) PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) INTEGER KJ(3), NCL(30), SKI(8, 30), INC(3, 7), IG(4, 4), NQ(7), 1 MQ(7), GC(4, 4), Q(27), NVV(8), MVV(8), LVV(8), TR(3, 3, 85), 2 IV(7, 7), NL(4), TP(4, 4, 7), SB(30), IDT(13), TT(20, 14) REAL G(4, 4), GN(4, 4), A(4, 4), AW(3, 3), AV(4, 4), PP(4, 4, 6), 1 GW(3, 3), GG(3, 3), AC(6), E(4,4), GV(4, 4), GS(7, 7), AD(4, 4), 2 O(7, 7) CHARACTER Y(6)*1, HT(7)*1, NPC*1, PRBUF*132 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 COMMON /CGGT/ IGGT CHARACTER IGGT*80 DATA Y/ 'a', 'm', 'o', 't', 'h', 'c'/ DATA HT/ 'P', 'A', 'B', 'C', 'F', 'I', 'R'/ DATA GC /0,12,13,14,12,0,23,24,13,23,0,34,14,24,34,0/ DATA Q /1,1,4,1,1,2,3,2,2,1,1,3,1,1,4,4,3*2,3,3,4,2,3,4,4,1/ DATA PP /-1.0,3*0.0,1.0,0.0,1.0,2*0.0,1.0,2*0.0,1.0,2*0.0,1.0, 1 -1.0,3*0.0,2*1.0,4*0.0,1.0,0.0,1.0,2*0.0,1.0,-1.0,3*0.0,2*1.0, 2 5*0.0,2*1.0,0.0,1.0,2*0.0,-1.0,2*0.0,2*1.0,4*0.0,1.0,2*0.0, 3 1.0,0.0,1.0,0.0,-1.0,2*0.0,2*1.0,5*0.0,1.0,0.0,2*1.0,3*0.0, 4 -1.0,0.0,1.0,0.0,1.0, 4*0.0,1.0,0.0,2*1.0,0.0/ DATA NVV /14,15,19,14,14,17,18,16/ DATA IV /0,5,6,7,2,3,4,5,0,7,6,1,4,3,6,7,0,5,4,1,2,7,6,5,0,3,2,1, 1 2,1,4,3,0,0,0,3,4,1,2,3*0,4,3,2,1,3*0/ DATA AD /1.0,4*0.0,1.0,4*0.0,1.0,4*0.0,1.0/ DATA INC /1,3*0,1,3*0,1,3*-1,1,1,0,1,0,1,0,1,1/ DATA SKI /0,0,14,0,2*14,1,61,0,0,3*14,0,2,61,0,4*13,0,3,65,6*12,4, 1 66,12,0,12,0,12,34,1,51,0,3*13,24,0,5,57,2*12,14,12,2*14,6,57,0, 2 0,14,0,14,34,1,41,0,0,2*14,24,0,2,41,0,0,14,23,0,23,13,41,0,4*13, 3 34,7,46,12,4*13,12,4,46,0,0,14,0,24,34,1,31,0,0,14,23,24,0,2,31, 4 0,13,2*14,13,0,4,36,0,2*13,2*23,0,7,36,12,0,14,0,12,34,8,34,12,0, 5 14,0,14,34,9,34,0,2*13,2*23,34,7,36,12,13,2*14,13,12,4,36,12, 6 4*13,34,3,35,0,13,14,0,24,34,1,21,0,13,14,2*23,0,10,26,0,13,14, 7 23,13,0,28,26,0,13,2*14,13,34,11,26,0,13,14,13,14,34,12,26,0,13, 8 14,2*23,34,10,26,12,13,2*14,13,34,11,26,12,13,14,13,14,34,12,26, 9 12,13,14,23,24,34,1,11/ DATA (((TR(I, J, K), I = 1, 3), J = 1, 3), K = 1, 21) / 1 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 1, 1, 2 1, 1, 0,-1, 1, 0, 1, 1, 2, 0, 1, 1, 1, 0, 1, 1, 1, 0, 3 1, 0, 0, 0, 0, 1, 1, 3, 2, 1,-1, 0, 0, 1,-1, 1, 1, 1, 4 1, 0, 0, 0, 1, 0, 1, 1, 2, 2, 1, 0, 0, 1, 0, 0, 0, 1, 5 1,-1, 0, 1, 1, 0, 0, 0, 1,-1,-1,-2, 0, 1, 0, 1, 0, 0, 6 0, 1, 1, 1, 1, 0,-1, 0,-1,-1,-1,-1, 1,-1, 0, 0, 0, 1, 7 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 8 0,-1, 0,-1, 0, 0, 0, 0,-1, 0, 0,-1, 0,-1, 0,-1, 0, 0, 9 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, *-1, 0, 0, 0, 0,-1, 0,-1, 0, 1, 0, 0, 0,-1, 0,-1, 0,-1, 1 0, 0,-1, 0, 1, 0, 1, 0, 1/ DATA (((TR(I, J, K), I = 1, 3), J = 1, 3), K = 22, 85) / 1 1,0,1,0,1,0,-1,2*0,1,0,1,0,-1,3*0,-1,1,3*0,1,3*0,2*1, 1 3*0,-1,3*0,2*-1,3*0,1,3*0,2*-1,3*0,-1,3*0,3*1,0,0,3*-1,0,-1,1,1, 2 0,0,-1,1,1,4*-1,0,0,1,1,-1,1,2*-1,1,0,0,4*-1,1,1,0,1,1,0,-1,0,1, 3 0,0,1,1,0,-1,1,1,4*0,3*1,0,-1,1,-1,0,0,1,1,-1,0,1,1,-1,1,3*0,1, 4 1,2*-1,1,1,3*0,-1,1,3*-1,0,1,0,1,0,1,1,2*-1,0,1,0,1,0,5*-1,1,3*0, 5 1,1,0,0,1,3*0,1,0,-1,0,1,0,-1,1,1,4*0,1,0,1,3*0,1,1,-1,0,0,3*1, 6 4*0,-1,1,0,-1,0,1,3*0,1,1,0,0,1,2,3*0,1,0,1,0,-2,-1,3*0,1,1,2,1, 7 1,4*0,-1,1,0,-1,1,2,3*0,1,-1,4*1,3*0,-1,1,1,2*-1,1,3*0,1,2,1,1,0, 8 1,3*0,1,0,0,1,2,1,0,0,1,-1,6,-6,0,0,6,-6,3*3,6,6,0,0,-6,6,3,2*-3, 9 2*-6,0,0,6,6,-3,3,-3,-6,6,0,0,2*-6,2*-3,3,3,-3,3,6,6,0,-3,3,3, * 2*-3,3,6,-6,0,3*3,-3,3,3,6,0,6,3,3,-3,3*3,6,0,-6,-3,3,-3,3,3,-3, 1 0,6,6,3,-3,3,3,2*-3,0,6,-6,4*3,-3,0,3,3,3*0,6,3,0,3,3,0,-3,0,6, 2 0,0,3,3,0,-3,3,6,0,0,3,-3,0,0,3,-3,3*6,3,3,0,0,-3,3,6,2*-6,2*-3, 3 0,0,3,3,-6,6,-6,-3,3,0,0,2*-3,2*-6,6,0,0,6,3,3,0,-3,3,3*0,6,3, 4 -3,0,3,3,0,6,3*0,3,3,0,-3,3,6,3*0,-3,3,0,2*-3,0,6,0,3,0,3,3,0,-3, 5 0,6,0,3,0,2*-3,0,-3,0,0,6,6,0,0,2,4,-2,2,2*-2,6,6,3*0,6,4,2,-4,0, 6 6,3*0,6,0,-3,3,6,3*0,3,3,3,0,-3,0,6,0,3,0,3*3,3*0,6,3,-3,0,-4,-8, 7 -2,6,0,0,-2,-4,2,2,2*-2,6,6,0,4,-4,2,8,4,-2,0,6,0,4,2,2/ DATA MVV/ 14, 15, 14, 17, 19, 14, 18, 16/ DATA LVV/ 14, 14, 20, 22, 16, 21, 14, 23/ DATA TT /141,1741,1841,657,2957,3057,3157,131,934,3234,3334,121, 1 1721,1821,3426,3526,3626,3726,3826,3926,146,1746,1846,5457,5557, 2 5657,5757,136,935,3235,3335,126,1726,1826,5826,5926,6026,6126, 3 6226,6326,6446,6546,6646,6757,6857,6957,7057,135,6436,6536,6636, 4 6426,6526,6626,7126,7226,7326,7426,7526,7626,131,934,121,1721, 5 1821,3426,3526,13*0,136,935,126,1726,1826,5826,5926,13*0,4634, 6 934,4734,121,4826,4926,5026,5126,5226,5326,10*0,7726,7826, 7 7926,17*0,121,1721,1821,17*0,8021,4026,4126,17*0,8121,4226,4326, 8 17*0,8221,4426,4526,17*0,8026,8126,8226,17*0,126,1726,1826,17*0, 9 8326,8426,8526,17*0/ DATA SB/21, 21, 21, 21, 11, 4, 4, 8, 8, 8, 8, 8, 4, 4, 4, 4, 4, 1 4, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1/ DATA IDT /61,66,65,41,46, 51,57,31,32,33,34,35,36/ DATA TP /6,4*0,6,4*0,6,4*0,6,6,4*0,3,3,0,0,-3,3,0,0,6,0,6,3,0,-3, 1 0,0,6,0,0,3,0,3,3*0,6,6,3,3,0,0,-3,3,4*0,6,0,6,0,0,6,0,3,3,0,3, 2 0,3,0,3,3,5*0,6,-3,3,3,0,3,-3,3,0,3,3,-3,0,3*3,6,4,2,2,0,-2,2,2, 3 0,-2,-4,2,0,6,6,0,6/ BCD(1:24) = 'Delaunay Cell Reduction'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, BCD, 24, 1.2, 4, 8, 0.6, VERT - 1.8) CALL GGIP20 (0.0, BCD, 24, 1.2, 2, 8, 0.5, VERT - 1.9) PAGET = 'DELRED' M = 0 ZW4 = 0.0 AAC = PAR(381) ACL = PAR(382) ISYS = 1 NBR = 1 ISE = 1 NCP = 0 IZ = 1 INO = 0 IK = 0 CALL GEN074 (AW, 0.0, 1, 9) CALL GEN074 (GW, 0.0, 1, 9) CALL GEN097 (NCL, 1, 30, 0) DO 1 I = 1, 6 AC(I) = PAR(100 + I) 1 CONTINUE DO 2 I = 1, 7 NQ(I) = I 2 CONTINUE CALL PLA269 (0) VRT = VERT - 5.0 WRITE (PRBUF, 99999) PAR(382), PAR(381) WRITE (LU, '(A, /, 80(''=''), /)') PRBUF(1:80) CALL GGIP20 (0.0, PRBUF, 80, 0.45, 1, 2, 0.2, VRT) WRITE (PRBUF, 99998) WRITE (LU, '(A, /)') PRBUF(1:80) VRT = VRT - 1.5 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT) WRITE (PRBUF, 99997) NPC, AC WRITE (LU, 99987) PRBUF(1:80) VRT = VRT - 1.5 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68), 2, 0.2, VRT) CALL GEN026 (1, GG, PAR(101), GL(5)) DO 101 I = 1, 7 IF (NPC .EQ. HT(I)) M = I 101 CONTINUE DO 1112 I = 1, 4 DO 1111 J = 1, 4 G(I, J) = 0.0 AV(I, J) = 0.0 AD(I, J) = TP(I, J, M) / 6.0 1111 CONTINUE 1112 CONTINUE DO 1024 I = 1, 3 DO 1023 J = 1, 3 DO 1022 K = 1, 3 DO 1021 L = 1, 3 G(I, J) = G(I, J) + GG(K, L) * AD(K, I) * AD(L, J) 1021 CONTINUE 1022 CONTINUE 1023 CONTINUE 1024 CONTINUE DO 105 I = 1, 3 DO 108 J = 1, 3 G(4, 4) = G(4, 4) + G(I, J) G(I, 4) = G(I, 4) - G(I, J) 108 CONTINUE G(4, I) = G(I, 4) 105 CONTINUE 104 MC = 0 DO 1062 I = 1, 4 DO 1061 J = 1, 4 A(I, J) = AD(I, J) GN(I, J) = G(I, J) IF (ABS(G(I, J)) .LT. 0.00006) G(I, J) = 0.0 IF (MC .EQ. 0 .AND. J .GT. I .AND. G(I, J) .GT. 0.0) 1 MC = J + 2 * I - 3 - I / 3 1061 CONTINUE 1062 CONTINUE IF (MC .EQ. 0) GOTO 109 DO 1074 I = 1, 4 DO 1073 J = 1, 4 G(I, J) = 0.0 AD(I, J) = 0.0 DO 1072 K = 1, 4 AD(I, J) = AD(I, J) + A(I, K) * PP(K, J, MC) DO 1071 L = 1, 4 G(I, J) = G(I, J) + GN(K, L) * PP(K, I, MC) * PP(L, J, MC) 1071 CONTINUE 1072 CONTINUE 1073 CONTINUE 1074 CONTINUE GO TO 104 109 CONTINUE DO 2033 IST = 0, 10 DO 1102 I = 1, 4 DO 1101 J = 1, 4 IG(I, J) = GC(I, J) A(I, J) = AD(I, J) 1101 CONTINUE 1102 CONTINUE DO 2012 I = 1, 3 DO 2011 J = I, 4 ZW1 = 0.0025 * (G(I, I) + G(J, J)) * IST IF (ABS(G(I, J)) .LT. ZW1) IG(I, J) = 0 DO 2022 K = 1, 3 DO 2021 L = K, 4 IF (IG(K, L) .EQ. 10 * K + L .AND. 1 (K .GT. I .OR. L .GT. J) .AND. 2 ABS(G(I, J) - G(K, L)) .LT. 3.0 * 3 (ZW1 + 0.0025 * (G(K, K) + G(L, L)) * IST)) 4 IG(K, L) = IG(I, J) 2021 CONTINUE 2022 CONTINUE IG(J, I) = IG(I, J) 2011 CONTINUE 2012 CONTINUE DO 2032 IC = 1, 30 DO 2031 INL1 = 1, 4 NL(1) = INL1 DO 205 INL2 = 1, 4 NL(2) = INL2 IF (NL(1) .EQ. NL(2)) GOTO 205 DO 206 INL3 = 1, 4 NL(3) = INL3 IF (NL(3) .EQ. NL(1) .OR. NL(3) .EQ. NL(2)) GOTO 206 NL(4) = 10 - NL(1) - NL(2) - NL(3) DO 207 MX = 1, 6 M1 = NL(1 + MX / 4 + MX / 6) M2 = NL(1 + MX - 2 * (MX / 4) - MX / 6) IYUNK = IG(M1, M2) - 5 * SKI(MX, IC) IF (IYUNK .GT. 0) THEN GOTO 206 ELSE IF (IYUNK .LT. 0) THEN N1 = NL(SKI(MX, IC) / 10) N2 = NL(SKI(MX, IC) - 10 * (SKI(MX, IC) / 10)) IF (IG(M1, M2) .NE. IG(N1, N2)) GOTO 206 ENDIF 207 CONTINUE IF (NCP .GT. 0) THEN DO 210 I = 1, NCP IF (IC .EQ. NCL(I)) GOTO 206 210 CONTINUE ENDIF NCP = NCP + 1 NCL(NCP) = IC ISE = SB(IC) DO 501 IS = 1, ISE IF (IC .NE. 30) GOTO 220 DO 1304 I = 1, 7 DO 1303 J = 1, 7 IF (I .LT. 4 .AND. J .LT. 4) A(I, J) = 1 A(I, J) - A(4, J) GS(I, J) = 0.0 DO 1302 K = 1, 3 DO 1301 L = 1, 3 GS(I, J) = GS(I, J) + G(K, L) 1 * INC(K, I) * INC(L, J) 1301 CONTINUE 1302 CONTINUE 1303 CONTINUE 1304 CONTINUE DO 3022 I = 1, 6 DO 3021 J = I, 7 O(I, J) = GS(I, I) * GS(J, J) 1 - GS(I, J) * GS(I, J) IF (GS(I, I) .GT. GS(J, J)) THEN NQ(I) = NQ(I) + 1 NQ(J) = NQ(J) - 1 ENDIF O(J, I) = O(I, J) 3021 CONTINUE 3022 CONTINUE DO 303 I = 1, 7 MQ(NQ(I)) = I 303 CONTINUE ZW1 = GS(MQ(1), MQ(1)) ZW2 = GS(MQ(2), MQ(2)) ZW3 = GS(MQ(3), MQ(3)) IF (IV(MQ(1), MQ(2)) .EQ. MQ(3)) 1 ZW3 = GS(MQ(4), MQ(4)) DO 304 I = 1, 5 ID = MQ(I) IF (ZW1 .LT. GS(ID, ID)) GOTO 304 DO 305 J = I, 6 JD = MQ(J) IF (J .EQ. I .OR. ZW2 .LT. GS(JD, JD)) GOTO 305 DO 306 K = J, 7 KD = MQ(K) IF (K .EQ. J .OR. ZW3 .LT. GS(KD, KD) .OR. 1 KD .EQ. IV(ID, JD)) GOTO 306 IF (O(ID, JD) + O(JD, KD) 1 + O(ID, KD) .GE. ZW4) THEN KJ(1) = ID KJ(2) = JD KJ(3) = KD ZW4 = O(ID, JD) + O(ID, KD) + O(JD, KD) ENDIF 306 CONTINUE 305 CONTINUE 304 CONTINUE DO 3073 M = 1, 3 DO 3072 L = 1, 3 GV(M, L) = GS(KJ(M), KJ(L)) GN(M, L) = 0.0 IF (GV(M, L) .NE. 0.0) GN(M, L) = 1 GV(M, L) / ABS(GV(M, L)) DO 3071 J = 1, 3 AV(L, M) = AV(L, M) + A(L, J) * INC(J, KJ(M)) 3071 CONTINUE 3072 CONTINUE 3073 CONTINUE N = INT(14.5 + GN(1, 2) + 3.0 * GN(1, 3) 1 + 9.0 * GN(2, 3)) IF (GV(1, 1) .EQ. GV(2, 2) .AND. 1 ABS(GV(2, 3)) .GT. ABS(GV(1, 3))) IZ = IZ + 1 IF (GV(3, 3) .EQ. GV(2, 2) .AND. 1 ABS(GV(1, 3)) .GT. ABS(GV(1, 2))) IZ = IZ + 2 IF (GV(1, 1) .EQ. GV(3, 3) .AND. 1 ABS(GV(2, 3)) .GT. ABS(GV(1, 2))) IZ = IZ + 4 DO 3103 I = 1, 3 DO 3102 J = 1, 3 E(I, J) = 0.0 DO 3101 K = 1, 3 E(I, J) = E(I, J) + TR(I, K, 23 + Q(N)) 1 * TR(K, J, NVV(IZ)) 3101 CONTINUE 3102 CONTINUE 3103 CONTINUE GOTO 380 220 IF (IS .LE. 1) THEN DO 222 I = 1, 4 DO 225 J = 1, 4 GV(J, I) = 0.0 E(J, I) = 0.0 225 CONTINUE E(NL(I), I) = 1.0 222 CONTINUE DO 2214 I = 1, 4 DO 2213 J = 1, 4 A(I, J) = AD(I, 1) * E(1, J) 1 + AD(I, 2) * E(2, J) 1 + AD(I, 3) * E(3, J) 3 + AD(I, 4) * E(4, J) DO 2212 K = 1, 4 DO 2211 L = 1, 4 GV(I, J) = GV(I, J) 1 + G(K, L) * E(L, J) * E(K, I) 2211 CONTINUE 2212 CONTINUE 2213 CONTINUE 2214 CONTINUE DO 2232 I = 1, 3 DO 2231 J = 1, 3 GN(I, J) = GV(I, J) A(I, J) = A(I, J) - A(4, J) 2231 CONTINUE 2232 CONTINUE ENDIF ISYS = SKI(8, IC) / 10 NBR = SKI(8, IC) - 10 * ISYS N = SKI(7, IC) IF (IS .NE. 1) THEN DO 2512 I = 1, 3 DO 2511 J = 1, 3 A(I, J) = AW(I, J) GN(I, J) = GW(I, J) 2511 CONTINUE 2512 CONTINUE N = TT(IS - 1, IK) / 100 ISYS = (TT(IS - 1, IK) - 100 * N) / 10 NBR = TT(IS - 1, IK) - 100 * N - 10 * ISYS ENDIF ZW1 = 1.0 - 0.83333333 * FLOAT(N / 54) DO 2244 I = 1, 3 DO 2243 J = 1, 3 AV(I, J) = 0.0 GV(I, J) = 0.0 DO 2242 K = 1, 3 AV(I, J) = AV(I, J) 1 + A(I, K) * ZW1 * TR(K, J, N) DO 2241 L = 1, 3 GV(I, J) = GV(I, J) + ZW1 * ZW1 * GN(K, L) * 1 TR(L, J, N) * TR(K, I, N) 2241 CONTINUE 2242 CONTINUE 2243 CONTINUE 2244 CONTINUE IZ = 1 IF (ISYS .LT. 3) THEN GOTO 324 ELSE IF (ISYS .GT. 3) THEN GOTO 400 ENDIF IF (GV(1, 1) .GT. GV(2, 2)) IZ = IZ + 1 IF (GV(1, 1) .GT. GV(3, 3)) IZ = IZ + 2 IF (GV(2, 2) .GT. GV(3, 3)) IZ = IZ + 4 DO 3432 L = 1, 3 DO 3431 M = 1, 3 E(L, M) = TR(L, M, MVV(IZ)) 3431 CONTINUE 3432 CONTINUE IF (NBR .GT. 1 .AND. NBR .LT. 5) NBR = 4 - IZ / 3 GOTO 380 324 ZW = GV(1, 1) + GV(3, 3) - GV(1, 3) 1 * SIGN(2.0, GV(1, 3)) IF (ZW .LT. GV(1, 1)) IZ = IZ + 1 IF (ZW .LT. GV(3, 3)) IZ = IZ + 2 IF (GV(3, 3) .LT. GV(1, 1)) IZ = IZ + 4 IF (NBR .EQ. 6) NBR = 2 * (MOD(IZ + 2, 4) 1 + (IZ / 6) * (6 / IZ)) DO 3232 I = 1, 3 DO 3231 J = 1, 3 E(I, J) = TR(I, J, LVV(IZ)) IF (I .NE. 3) E(I, J) = - E(I, J) 1 * SIGN(1.0, GV(1, 3)) 3231 CONTINUE 3232 CONTINUE 380 DO 3822 I = 1, 3 DO 3821 J = 1, 3 A(I, J) = AV(I, J) GN(I, J) = GV(I, J) 3821 CONTINUE 3822 CONTINUE DO 3814 I = 1, 3 DO 3813 J = 1, 3 AV(I, J) = A(I, 1) * E(1, J) + A(I, 2) * E(2, J) 1 + A(I, 3) * E(3, J) GV(I, J) = 0.0 DO 3812 K = 1, 3 DO 3811 L = 1, 3 GV(I, J) = GV(I, J) 1 + GN(K, L) * E(L, J) * E(K, I) 3811 CONTINUE 3812 CONTINUE 3813 CONTINUE 3814 CONTINUE IF (ISYS .NE. 2 .OR. GV(1, 3) .LE. 0.0) GOTO 400 DO 325 I = 1, 3 AV(I, 3) = - AV(I, 3) 325 CONTINUE GV(1, 3) = - GV(1, 3) GV(3, 1) = GV(1, 3) 400 DO 4042 I = 1, 2 II = I + 1 DO 4041 J = II, 3 N = 6 - I - J A(N, N) = AV(I, I) * AV(J, J) 1 - AV(I, J) * AV(J, I) A(J, I) = AV(N, I) * AV(J, N) 1 - AV(N, N) * AV(J, I) A(I, J) = AV(N, J) * AV(I, N) 1 - AV(N, N) * AV(I, J) 4041 CONTINUE 4042 CONTINUE ZW1 = A(1, 1) * AV(1, 1) + A(1, 2) * AV(2, 1) 1 + A(1, 3) * AV(3, 1) DO 401 I = 1, 3 DO 406 J = 1, 3 AV(I, J) = AV(I, J) * SIGN(1.0, ZW1) IF (IS .EQ. 1) AW(I, J) = AV(I, J) IF (IS .EQ. 1) GW(I, J) = GV(I, J) A(J, I) = A(J, I) / ABS(ZW1) 406 CONTINUE AC(I) = SQRT(GV(I, I)) J = I + 1 - 3 * (I / 3) ZW = GV(I, J) / SQRT(GV(I, I) * GV(J, J)) AC(9 - I - J) = 57.29578 1 * ATAN2(SQRT(1.0 - ZW * ZW), ZW) 401 CONTINUE IF (ISYS .NE. 2) GOTO 407 XM = GV(1, 1) / GV(2, 2) YM = GV(3, 3) / GV(2, 2) ZM = XM + YM + 2.0 * GV(1, 3) / GV(2, 2) IF (NBR .EQ. 1) GOTO 407 ZW = GV(3, 3) + FLOAT(NBR / 4) * (GV(1, 1) - GV(3, 3)) 1 + FLOAT(NBR / 6) * (GV(3, 3) + GV(1, 3) * 2.0) ZM = (GV(1, 1) + FLOAT((NBR / 4) - (NBR / 6)) * 1 (GV(3, 3) - GV(1, 1))) / ZW YM = GV(2, 2) / ZW XM = ((GV(1, 1) + GV(3, 3) + GV(1, 3) * 2.0) * 1 FLOAT((NBR / 2) - (NBR / 4)) * 2 FLOAT(1 - (NBR / 6)) 2 + FLOAT(NBR / 6) * GV(3, 3)) / ZW 407 IF (IS .EQ. 1) THEN 1407 CALL PLA015 (0, 39) CALL PLA013 (1, 1) CALL GEN020 (1, IGGT, 1, 80) IF (IGGT(1:4) .EQ. 'PLOT') THEN GOTO 1407 ELSE IF (IGGT(1:4) .EQ. 'EXIT' .OR. 1 IGGT(1:1) .EQ. 'N') THEN CALL GEN038 (IGGT, 1, 80) GOTO 5000 ENDIF CALL PLA269 (0) CALL GGIP (HORS, VERT, 0.0, 1) WRITE (PRBUF, 99993) NCP, IC, IST, Y(ISYS), HT(NBR) WRITE (LU, 99987) PRBUF(1:80) VRT = VERT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68), 1 2, 0.2, VRT) VRT = VRT - 0.2 ENDIF ISJ = IS - 1 IF (IS .NE. 1) THEN WRITE (PRBUF, 99991) ISJ, Y(ISYS), HT(NBR) WRITE (LU, 99988) PRBUF(1:80) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 3, 2, 0.2, VRT) ENDIF IF (ISYS .EQ. 2) THEN WRITE (PRBUF, 99989) XM, YM, ZM WRITE (LU, 99988) PRBUF(1:80) ENDIF IF ((ISYS .NE. 1 .AND. ISYS .NE. 5 .AND. 1 (ABS(AC(4) - 90.0) .GE. AAC .OR. 2 ABS(AC(6) - 90.0) .GE. AAC)) .OR. 3 (ISYS .GT. 2 .AND. ABS(AC(5) - 90.0) .GE. AAC) .OR. 4 (ISYS .EQ. 5 .AND. (ABS(AC(6) - 120.0) .GE. AAC .OR. 5 ABS(AC(4) - 90.0) .GE. AAC)) .OR. (ISYS .GT. 3 .AND. 6 ABS(AC(1) - AC(2)) .GE. ACL) .OR. (ISYS .EQ. 6 .AND. 7 (ABS(AC(1) - AC(3)) .GE. ACL .OR. 8 ABS(AC(2) - AC(3)) .GE. ACL))) GOTO 503 505 WRITE (PRBUF, 99996) (AC(I), I = 1, 3) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT) WRITE (LU, 99988) PRBUF(1:80) WRITE (PRBUF, 99995) (AC(I), I = 4, 6) VRT = VRT - 0.55 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT) WRITE (LU, 99987) PRBUF(1:80) WRITE (PRBUF, 99994) VRT = VRT - 0.7 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68), 1 2, 0.2, VRT) WRITE (LU, 99988) PRBUF(1:80) DO 410 I = 1, 3 WRITE (PRBUF, 99992) (GV(I, J), J = 1, 3), 1 (AV(I, K), K = 1, 3), (A(I, L), L = 1, 3) WRITE (LU, 99987) PRBUF(1:80) VRT = VRT - 0.55 CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT) 410 CONTINUE GOTO 504 503 WRITE (PRBUF, 99990) (AC(I), I = 1, 6) VRT = VRT - 0.40 CALL GGIP20 (0.0, PRBUF, 80, 0.30, 2, 2, 0.2, VRT) WRITE (LU, 99988) PRBUF(1:80) IF (INO .EQ. 1) GOTO 505 504 DO 502 I = 1, 13 IF (IS .EQ. 1 .AND. 10 * ISYS + NBR .EQ. IDT(I)) 1 IK = I 502 CONTINUE IF (IK .EQ. 7 .AND. IC .EQ. 6) IK = 14 501 CONTINUE 206 CONTINUE 205 CONTINUE 2031 CONTINUE 2032 CONTINUE 2033 CONTINUE CALL PLA015 (0, 39) CALL PLA013 (1, 1) 5000 RETURN 99999 FORMAT ('Delaunay Cell Reduction [Tol-Axis =', F5.2, 1 ', Tol-Angle =', F5.2, ']') 99998 FORMAT ('See: H. Zimmermann & H. Burzlaff, ', 1 'Z. fur Krist. (1985) 170, 241-246') 99997 FORMAT ( 'INPUT CELL: ', A, 6F9.3) 99996 FORMAT (9X, 'a =', F9.3, 11X, 'b =', F9.3, 11X, 'c =', F9.3) 99995 FORMAT ( 5X, 'alpha =', F9.3, 8X, 'beta =', F9.3, 7X, 1 'gamma =', F9.3) 99994 FORMAT (7X, 'Metric Tensor', 12X, 'Transf.-Matrix', 6X, 1 'Inverse Matrix') 99993 FORMAT (2X, ' Proposal', I3, ' Delaunay Case', 1 I3, 4X, 'Cycle', I3, 6X, 'Lattice Type: ', 2A) 99992 FORMAT (3(F9.2), 2X, 3(F6.2), 2X, 3(F6.2)) 99991 FORMAT (4X, 'Subgroup Cell No.', I3, 24X, 'Lattice Type: ', 2A) 99990 FORMAT (5X, 'Out of Range [', 6F9.3, ']') 99989 FORMAT (' Reduced Monoclinic Lattice Coordinates:', 1 3X, 'xm = ', F6.3, 1X, 'ym = ', F6.3, 1X, 'zm = ', F6.3) 99988 FORMAT (/, A) 99987 FORMAT (A) END SUBROUTINE PLA179 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /ISCR/ RIK(3, 3), UKL(3, 3), INSCR(3) COMMON /FNAME/ KNM(8), KXT, KNM16 COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80, 1 RDTYPE*7 COMMON /SFCLC/ NATO, NNG(3), NGRID COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH, 1 ICNTR, IND1, IND2, IND3 DIMENSION ORO(3, 3) INTEGER HMAX COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 NSYMH = IPR(255) ICNTR = IPR(257) AN0 = 0.0 NATO = 0 IND1 = 1 IND2 = 2 IND3 = 3 CALL PLA130 (NATO, 0) IF (NATO .LT. 0) THEN IPR(1) = 1 IPR(2) = 42 GOTO 150 ENDIF IF (IPR(210) .EQ. -2) THEN IF (IGBL(29) .EQ. 1) THEN IPR(1) = 1 IPR(2) = 44 GOTO 150 ENDIF IF (IPR(16) .EQ. 0) THEN CALL GEN044 (PAR(241), ORO) CALL GEN021 (RIK, 0) WRITE (LU6, 99999) NAME(4)(1:KNM(4)) CALL GEN108 (LU16, 0) 10 READ (LU16, 99992, END = 30) 1 IH, IK, IL, (V2(I), V3(I), I = 1, 3) IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 30 DO 20 I = 1, 3 V4(I) = PAR(134 + I) * V2(I) V5(I) = PAR(134 + I) * V3(I) 20 CONTINUE CALL GEN002 (2, ORO, V4, V2, DUM) CALL GEN002 (2, ORO, V5, V3, DUM) XX = V3(1) - V2(1) YY = V3(2) - V2(2) ZZ = V3(3) - V2(3) XSQ = XX**2 YSQ = YY**2 ZSQ = ZZ**2 RIK(1, 1) = RIK(1, 1) + YSQ + ZSQ RIK(1, 2) = RIK(1, 2) - XX * YY RIK(1, 3) = RIK(1, 3) - XX * ZZ RIK(2, 2) = RIK(2, 2) + ZSQ + XSQ RIK(2, 3) = RIK(2, 3) - YY * ZZ RIK(3, 3) = RIK(3, 3) + XSQ + YSQ GOTO 10 30 CALL GEN024 (RIK, UKL, V8, DUMV) QM(1, 1) = DUMV(1, 2) QM(1, 2) = DUMV(2, 2) QM(1, 3) = DUMV(3, 2) QM(2, 1) = DUMV(1, 3) QM(2, 2) = DUMV(2, 3) QM(2, 3) = DUMV(3, 3) QM(3, 1) = DUMV(1, 1) QM(3, 2) = DUMV(2, 1) QM(3, 3) = DUMV(3, 1) CALL GEN004 (QM, ORO, RIK) ELSE DO 40 I = 1, 9 J = MOD (I - 1, 3) + 1 K = ((I - 1) / 3) + 1 QM(J, K) = PAR(180 + I) 40 CONTINUE CALL GEN003 (QM, RIK, DET, 0) ENDIF ENDIF NREF = 0 SOMXO = 0.0 SOMXC = 0.0 IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) THEN IHEXL = 1 ELSE IHEXL = 0 ENDIF CALL GEN108 (LU9, 0) HMAX = -999 KMAX = -999 LMAX = -999 CALL PLA290 (0) IEND = -1 50 CALL PLA133 (IH, IK, IL, IHT, IKT, ILT, XOBS, SIGI, 1 UCINT, ACALS, BCALS, ABSCOR, IEND) IF (IEND .EQ. 1) THEN PAR(166) = ASIN(SQRT(PAR(166)) * PAR(17)) * GL(5) IF (IPR(259) .EQ. 4) THEN HMAX = MAX (HMAX, KMAX) KMAX = HMAX ELSE IF (IPR(259) .EQ. 7) THEN HMAX = MAX (HMAX, KMAX, LMAX) KMAX = HMAX LMAX = HMAX ENDIF IF (NREF .EQ. 0) THEN WRITE (LU6, 99998) IPR(210) = 0 GOTO 150 ELSE GOTO 70 ENDIF ENDIF HMAX = MAX (HMAX, IABS(IHT)) KMAX = MAX (KMAX, IABS(IKT)) LMAX = MAX (LMAX, IABS(ILT)) IF (IHEXL .EQ. 1) THEN HMAX = MAX (KMAX, HMAX, IABS(IHT + IKT)) KMAX = HMAX ENDIF IF (IPR(259) .EQ. 4) THEN HMAX = MAX (HMAX, KMAX) KMAX = HMAX ELSE IF (IPR(259) .EQ. 7) THEN HMAX = MAX (HMAX, KMAX, LMAX) KMAX = HMAX LMAX = HMAX ENDIF NREF = NREF + 1 ACAL = 0.0 BCAL = 0.0 IF (IGBL(29) .EQ. -1) THEN IF (IPR(210) .EQ. -1) THEN ACAL = ACALS BCAL = BCALS XOBS = UCINT * ABSCOR ELSE IF (IPR(210) .EQ. -4) THEN IF (IPR(414) .EQ. 4) THEN ACAL = ACALS BCAL = BCALS XOBS = ACAL **2 + BCAL ** 2 ENDIF ENDIF ENDIF CALL PLA131 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA, SNTHA) ACAL = ACAL + ACALA BCAL = BCAL + BCALA XCAL = ACAL ** 2 + BCAL ** 2 IF (IPR(193) .EQ. 2) THEN IH2 = NINT (PAR(332) * IHT + PAR(333) * IKT + PAR(334) * ILT) IK2 = NINT (PAR(335) * IHT + PAR(336) * IKT + PAR(337) * ILT) IL2 = NINT (PAR(338) * IHT + PAR(339) * IKT + PAR(340) * ILT) ACL = 0.0 BCL = 0.0 CALL PLA131 (IH2, IK2, IL2, ACL, BCL, ACLA, BCLA, SNTHA) ACL = ACL + ACLA BCL = BCL + BCLA XCL = ACL ** 2 + BCL ** 2 XCAL = (1.0 - PAR(341)) * XCAL + PAR(341) * XCL ENDIF IF (PAR(229) .LT. 99999.0) THEN SN2TH = 2 * SNTHA * SQRT(1.0 - SNTHA ** 2) XOBS = XOBS * 1 (1.0 + 0.001 * PAR(229) * XCAL * PAR(17)**3 / SN2TH) ** 0.25 ENDIF IF (XOBS .GT. 2 * SIGI) THEN SOMXO = SOMXO + XOBS SOMXC = SOMXC + XCAL ENDIF IF (IPR(210) .EQ. -2) THEN SUMT = 0 DO 60 I = 1, 3 V4(I) = PAR(134 + I) * V2(I) V5(I) = PAR(134 + I) * V3(I) SUMT = SUMT + ABS(V2(I)) + ABS(V3(I)) 60 CONTINUE TPRIM = IH * V4(1) + IK * V4(2) + IL * V4(3) TDIFF = IH * V5(1) + IK * V5(2) + IL * V5(3) THHKL = ASIN(SNTHA) * GL(5) CALL GEN002 (2, RIK, V4, V2, DUM) CALL GEN002 (2, RIK, V5, V3, DUM) THETA = 90.0 - GEN027 (V2, V3, GL(5)) / 2.0 CALL PLA291 (TPRIM, TDIFF, THETA, THHKL, ITEST) IF (ITEST .NE. 0) THEN IPR(210) = 0 GOTO 150 ENDIF IF (SUMT .LT. 0.001) THEN WRITE (LU6, 99997) IPR(210) = 0 GOTO 150 ENDIF PMU = 90.0 - ACOS(V2(3)) * GL(5) SMU = 90.0 - ACOS(V3(3)) * GL(5) VXY = SQRT(V2(1)**2 + V2(2)**2) PHIP = ACOS(V2(1) / VXY) * GL(5) IF (V2(2) .LT. 0.0) PHIP = 360.0 - PHIP PHIP = MOD(PHIP, 360.0) VXY = SQRT(V3(1)**2 + V3(2)**2) PHISE = ACOS(V3(1) / VXY) * GL(5) IF (V3(2) .LT. 0.0) PHISE = 360.0 - PHISE PHISE = MOD(PHISE, 360.0) ENDIF IF (ACAL .NE. 0.0 .AND. BCAL .NE. 0) THEN PCAL = ATAN2 (BCAL, ACAL) * GL(5) ELSE PCAL = 0.0 ENDIF WRITE (LU9) IH, IK, IL, IHT, IKT, ILT, XOBS, XCAL, SIGI, 1 PCAL, PMU, SMU, PHIP, PHISE, THETA GOTO 50 70 IF (IPR(414) .EQ. 5 .AND. IPR(210) .EQ. -4) THEN SCF = 1.0 SCF = 100.0 / (SOMXO * PAR(240)) ELSE IF (IPR(414) .EQ. 4 .AND. IPR(210) .EQ. -4) THEN SCF = 1.0 / PAR(240) ELSE SCF = SOMXC / (SOMXO * PAR(240)) ENDIF IF (IPR(210) .EQ. -2) THEN PAGET = 'DELABS' CALL PLA269 (0) WRITE (LU7, 99989) CALL PLA290 (-1) ENDIF CALL GEN108 (LU9, 0) CALL GEN108 (LU17, 0) FCLM = 0.0 NR7 = 0 DO 80 I = 1, NREF READ (LU9) IH, IK, IL, IHT, IKT, ILT, XOBS, XCAL, SIGI, 1 PCAL, PMU, SMU, PHIP, PHISE, THETA XOBS = XOBS * SCF SIGI = SIGI * SCF XCAL = XCAL / PAR(240) IF (IPR(210) .EQ. -2) THEN WRITE (LU17, 99994) IH, IK, IL, XOBS, XCAL, SIGI, PMU, SMU, 1 PHIP, PHISE, THETA ELSE VOID(NR7 + 1) = IHT VOID(NR7 + 2) = IKT VOID(NR7 + 3) = ILT VOID(NR7 + 4) = XOBS * PAR(240) VOID(NR7 + 5) = XCAL * PAR(240) VOID(NR7 + 6) = SIGI * PAR(240) VOID(NR7 + 7) = PCAL FCLM = MAX (FCLM, SQRT(XCAL * PAR(240))) NR7 = NR7 + 7 ENDIF 80 CONTINUE IF (IPR(210) .EQ. -2) THEN IF (IGBL(37) .GT. 0) THEN CALL PLA180 ELSE WRITE (LU6, 99993) GOTO 150 ENDIF ELSE IF (IPR(210) .EQ. -1 .OR. IPR(210) .EQ. -4) THEN SUM1 = 0.0 SUM2 = 0.0 SUM3 = 0.0 SUM4 = 0.0 IPR(411) = HMAX IPR(412) = KMAX IPR(413) = LMAX MPH = 2 * HMAX + 1 MPK = 2 * KMAX + 1 MPL = 2 * LMAX + 1 MHK = MPH * MPK MHKL = MPL * MHK MHKLH = (MHKL - 1) / 2 IADR = NPVD - MHKLH IADR1 = NPVD - MHKL IF (IADR1 .LT. NR7) THEN WRITE (LU6, 99985) GOTO 150 ENDIF DO 90 I = 1, MHKL VOID(IADR1 + I) = - 1.0 90 CONTINUE NR7 = 0 DO 100 I = 1, NREF IHT = NINT(VOID(NR7 + 1)) IKT = NINT(VOID(NR7 + 2)) ILT = NINT(VOID(NR7 + 3)) IHKL = ILT * MHK + IKT * MPH + IHT N = NINT (VOID(IADR + IHKL)) IF (N .LT. 0) THEN VOID(IADR + IHKL) = I ELSE XOBS1 = VOID((N - 1) * 7 + 4) SIGI1 = VOID((N - 1) * 7 + 6) IF (SIGI1 .GT. 0.0) THEN WGTI1 = 1.0 / SIGI1**2 ELSE WGTI1 = 1.0 ENDIF XOBS2 = VOID(NR7 + 4) SIGI2 = VOID(NR7 + 6) IF (SIGI2 .GT. 0.0) THEN WGTI2 = 1.0 / SIGI2**2 ELSE WGTI2 = 1.0 ENDIF WGTIS = WGTI1 + WGTI2 VOID((N - 1) * 7 + 4) = 1 (WGTI1 * XOBS1 + WGTI2 * XOBS2) / WGTIS VOID((N - 1) * 7 + 6) = 1.0 / SQRT(WGTIS) ENDIF NR7 = NR7 + 7 100 CONTINUE IF (IPR(210) .EQ. -1) THEN NSYMC = NSYMH * ICNTR ELSE NSYMC = NSYMH * 2 ENDIF IF (NSYMC .GT. 1) THEN DO 120 I = 1, MHKL J = MHKL + 1 - I K = NINT(VOID(IADR1 + J)) IF (K .GT. 0) THEN VOID(IADR1 + J) = -1 IHT = NINT(VOID((K - 1) * 7 + 1)) IKT = NINT(VOID((K - 1) * 7 + 2)) ILT = NINT(VOID((K - 1) * 7 + 3)) XOBS = VOID((K - 1) * 7 + 4) SIGI = VOID((K - 1) * 7 + 6) PCAL = VOID((K - 1) * 7 + 7) IHKL0 = ILT * MHK + IKT * MPH + IHT IHKLN = IHKL0 PCALN = PCAL IHTN = IHT IKTN = IKT ILTN = ILT IF (SIGI .NE. 0.0) THEN SUMT = XOBS / SIGI**2 SUMN = 1.0 / SIGI**2 ELSE SUMT = XOBS SUMN = 1.0 ENDIF DO 110 L = 2, NSYMC XJX(1) = IHT XJX(2) = IKT XJX(3) = ILT XJX(4) = PCAL IF (L .GT. NSYMH) THEN NS = L - NSYMH IS = -1 ELSE NS = L IS = 1 ENDIF CALL SGSM (ICL, NS, XJX, LU7, 5, IERR) IH = NINT(XJX(7)) IK = NINT(XJX(8)) IL = NINT(XJX(9)) IHKL = (IL * MHK + IK * MPH + IH) * IS IF (IHKL .GT. IHKLN) THEN IHKLN = IHKL IHTN = IH IKTN = IK ILTN = IL PCALN = XJX(10) ENDIF IF (IHKL .NE. IHKL0) THEN NR = NINT(VOID(IADR + IHKL)) IF (NR .GT. 0) THEN XOBS = VOID((NR - 1) * 7 + 4) SIGI = VOID((NR - 1) * 7 + 6) IF (SIGI .NE. 0.0) THEN WGHT = 1.0 / SIGI**2 ELSE WGHT = 1.0 ENDIF SUMT = SUMT + XOBS * WGHT SUMN = SUMN + WGHT VOID(IADR + IHKL) = - 1.0 ENDIF ENDIF 110 CONTINUE VOID(IADR + IHKLN) = K NR = (K - 1) * 7 VOID(NR + 1) = IHTN VOID(NR + 2) = IKTN VOID(NR + 3) = ILTN VOID(NR + 4) = SUMT / SUMN VOID(NR + 6) = 1.0 / SQRT(SUMN) VOID(NR + 7) = PCALN ENDIF 120 CONTINUE ENDIF FCLS = 1.0 IF (FCLM .LT. 250.0) FCLS = 100.0 IF (IPR(210) .EQ. -1) THEN WRITE (LU17, 99995) DATANM, JID(1: 50), FCLM, PAR(157), 1 1.0 / (2.0 * PAR(287)) NSYM = IPR(48) XJX(4) = 0.0 XJX(5) = 0.0 XJX(6) = 0.0 DO 130 K = 1, NSYM ISYM = K CALL SGSM (ICL, ISYM, XJX, 0, 20, IERR) CALL GEN020 (-1, ICL, 1, 30) WRITE (LU17, 99991) ICL(1:30) 130 CONTINUE WRITE (LU17, 99988) (PAR(K), K = 101, 106), 1.0 / FCLS ENDIF NRF = 0 NRF1 = 0 CALL GEN108 (LU9, 0) DO 140 I = 1, MHKL NR0 = NINT(VOID(IADR1 + I)) IF (NR0 .GT. 0) THEN IHT = NINT(VOID((NR0 - 1) * 7 + 1)) IKT = NINT(VOID((NR0 - 1) * 7 + 2)) ILT = NINT(VOID((NR0 - 1) * 7 + 3)) XCAL = VOID((NR0 - 1) * 7 + 5) IF (IPR(408) .LE. 0) THEN XOBS = VOID((NR0 - 1) * 7 + 4) SIGI = VOID((NR0 - 1) * 7 + 6) ELSE XOBS = XCAL SIGI = SQRT (XOBS) ENDIF PCAL = VOID((NR0 - 1) * 7 + 7) CALL PLA139 (IHT, IKT, ILT, IEXT, IASM) IF (IEXT .NE. 0) GOTO 140 NRF1 = NRF1 + 1 IF (XOBS .GT. 2 * SIGI) THEN SUM1 = SUM1 + ABS(SQRT(XOBS) - SQRT(XCAL)) SUM2 = SUM2 + SQRT(XOBS) NRF = NRF + 1 ENDIF PXX = (MAX(0.0, XOBS) + 2.0 * XCAL) / 3.0 SGIK = SIGI**2 + (PAR(227) * PXX)**2 + PAR(228) * PXX SUM3 = SUM3 + ((XOBS - XCAL) ** 2) / SGIK SUM4 = SUM4 + XOBS ** 2 / SGIK STHL = SQRT(GEN095 (PAR(191), IHT, IKT, ILT)) IF (IPR(210) .EQ. -1) THEN WRITE (LU17, 99987) IHT, IKT, ILT, XCAL * FCLS, 1 XOBS * FCLS, SIGI * FCLS, STHL ELSE FOBS = SQRT(MAX(0.0, XOBS)) FCAL = SQRT(MAX(0.0, XCAL)) IF (FOBS .GT. 0.0) THEN IF (FCAL / FOBS .GT. PAR(270) .OR. IPR(414) .EQ. 5) THEN IF (ICNTR .EQ. 2) THEN SINA = 0.0 IF (ABS(PCAL) .LT. 90.0) THEN COSA = 1.0 ELSE COSA = -1.0 ENDIF ELSE PHI = PCAL / GL(5) SINA = SIN (PHI) COSA = COS (PHI) ENDIF IF (IPR(414) .EQ. 5) THEN AN0 = FOBS **2 COSA = 1.0 SINA = 0.0 ELSE IF (IPR(414) .EQ. 1) THEN AN0 = FOBS ELSE IF (IPR(414) .EQ. 2) THEN AN0 = 2 * FOBS - FCAL ELSE IF (IPR(414) .EQ. 3) THEN AN0 = FOBS - FCAL ELSE IF (IPR(414) .EQ. 4) THEN AN0 = FOBS ENDIF AI0 = AN0 * COSA BI0 = AN0 * SINA IF (AI0 .NE. 0.0 .OR. BI0 .NE. 0) 1 WRITE (LU9) IHT, IKT, ILT, AI0, BI0, 2 XOBS / SIGI, STHL ENDIF ENDIF ENDIF ENDIF 140 CONTINUE IF (IPR(210) .NE. -4 .AND. IPR(408) .LE. 0) THEN CALL PLA269 (3) WRITE (LU6, 99990) WRITE (LU7, 99990) ENDIF IF (IPR(414) .LT. 4) THEN N = 0 IF (PAR(227) .GT. 0) THEN N = INDEX (RLWS(1)(2:80), '''') IF (N .GE. 2) WRITE (LU6, 99986) RLWS(1)(2:N) ENDIF WRITE (LU6, 99996) SUM1 / SUM2, NRF, SQRT(SUM3 / SUM4), NRF1, 1 SQRT(SUM3 / (NREF - IPR(226))) IF (N .GE. 2) THEN CALL PLA269 (2) WRITE (LU7, 99986) RLWS(1)(2:N) ENDIF CALL PLA269 (6) WRITE (LU7, 99996) SUM1 / SUM2, NRF, SQRT(SUM3 / SUM4), NRF1, 1 SQRT (SUM3 / (NREF - IPR(226))) ENDIF ENDIF IF (IPR(210) .EQ. -1) WRITE (LU17, '(1X)') 150 CONTINUE RETURN 99999 FORMAT (/, ':: Reflection Data will be READ from File : ', A, 1 '.hkl', /) 99998 FORMAT (/, ':: However, no reflection data found', /) 99997 FORMAT (/, ':: No Direction Cosines Found on Reflection File',/) 99996 FORMAT (':: R1 =', F7.3, ' for', I6, 1 ' Refl. with I > 2 s(I) and', /, 2 ':: wR2 =', F7.3, ' for', I6, ' reflections', /, 3 ':: S =', F7.3, /) 99995 FORMAT ('#', /, '# h,k,l, Fc-squared, Fo-squared,', 1 ' sigma(Fo-squared) and status flag', /, '#', /, 2 'data_', A, /, '_shelx_title '' ', A, ' ''', /, 3 '_shelx_refln_list_code 4', /, 4 '_shelx_F_calc_maximum', F10.2, /, 5 '_exptl_crystal_F_000 ', F10.2, /, 6 '_reflns_d_resolution_high', F10.4, //, 6 'loop_', /, 7 ' _symmetry_equiv_pos_as_xyz') 99994 FORMAT (3I4, 2F15.2, F10.2, 5F9.2) 99993 FORMAT (':: No Direction Cosines !!') 99992 FORMAT (3I4, 20X, 6F8.5) 99991 FORMAT (1X, A) 99990 FORMAT (/, ':: Structure Factor Calculation including SQUEEZE', 1 ' Contribution', /) 99989 FORMAT ('Preparation for DELABS - Correction', /, 132('='), //, 1 'Anisotropic Displacement Parameters converted to ', 2 'the Isotropic Equivalent (When appropriate)', //, 3 'Structure Factors calculated with the current Model-', 4 'Parameters (i.e. x,y,z and U(eq))', //) 99988 FORMAT (/, '_cell_length_a', F9.5,/, 1 '_cell_length_b', F9.4, /, 2 '_cell_length_c', F9.4, /, 3 '_cell_angle_alpha', F9.3, /, 4 '_cell_angle_beta', F9.3, /, 5 '_cell_angle_gamma', F9.3, //, 6 '_shelx_F_squared_multiplier', F10.3, //, 7 'loop_', /, 8 ' _refln_index_h', /, 9 ' _refln_index_k', /, * ' _refln_index_l', /, 1 ' _refln_F_squared_calc', /, 2 ' _refln_F_squared_meas', /, 3 ' _refln_F_squared_sigma', /, 4 ' _refln_observed_status', /, 5 ' _refln_sint/lambda') 99987 FORMAT (3I4, 2F12.2, F10.2, ' o', F10.5) 99986 FORMAT (/, ':: ', A) 99985 FORMAT (/, 'NPVD too Small in PLA179', /) END SUBROUTINE PLA180 PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON // JNSC(2, NP23), VOID(NPVD - 15444), BUFF(11000), 1 ANORM(44, 44), ATB(44), ROWJ(88), TERMS(44), VEC(44, 44), 2 EIG(44), UM1(44), WORK(220), RDASH(44), SDASH(44) COMMON /REFL/ FC, FO, FM, PHI(2), MU(2), SINTH, COSTH COMMON /DRVR/ NCY, NSHAPE, NACOEF, NBCOEF, SFMU, ITCOR COMMON /SRES/ NUMREF, SUMRES, SUMFS, SUMRSQ, SUMFSQ COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /Q/ ICL, IFL(NP17) CHARACTER ICL*(NP45), IFL*7 REAL MU, MUMIN, MUMAX, A(18) INTEGER NP(16) CHARACTER THCOR*3 COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0 COMMON /CGG11/ BCD, SBCD CHARACTER BCD*132, SBCD*132 EXTERNAL PLA182 C * C * EMPIRICAL ABSORPTION CORRECTION ROUTINE C * THIS VERSION USES NON-LINEAR LEAST-SQUARES WITH UNIT WEIGHTS C * Reference - WALKER, N. & STUART, D. (1983) Acta Cryst. A39, 158-166. C * C * ADAPTED FOR INCLUSION IN PLATON C * IGBL(23) = 16 IF (IGBL(25) * IGBL(32) .EQ. 1) THEN BCD = 'DELABS'//CHAR(0) CALL GGIP (HORS, VERT, 0.0, 1) CALL GGIP20 (0.0, BCD, 7, 1.4, 4, 8, 10.6, VERT - 1.8) CALL GGIP20 (0.0, BCD, 7, 1.4, 2, 8, 10.4, VERT - 1.9) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF ITCOR = IPR(398) IF (ITCOR .GT. 0) THEN THCOR = 'YES' ELSE THCOR = 'NO ' ENDIF WRITE (LU6, 99987) THCOR WRITE (LU6, 99984) (NINT(PAR(331 + I)), I = 1, 9), PAR(341) CALL PLA269 (0) WRITE (LU7, 99991) IF (IPR(16) .EQ. 0) THEN WRITE (LU6, 99988) WRITE (LU7, 99988) ENDIF NACOEF = 34 NBCOEF = 10 NCO = NACOEF + NBCOEF MUMIN = 100.0 MUMAX = -100.0 NCYCLE = 4 + ITCOR NREF = 0 NTOT = 0 NCUTO = 0 NCUTC = 0 NLOW = 0 THMAX = 0.0 SFMU = PAR(17) * 7.0 NSHAPE = NACOEF FILTER = 0.00005 FILSTA = 0.0001 FILDEC = 0.00005 FILEND = 0.0 CALL GEN097 (NP, 1, 16, 0) CALL GEN074 (TERMS, 0.0, 1, NCO) CALL GEN108 (LU9, 0) CALL GEN108 (LU17, 0) 50 READ (LU17, 99983, END = 70) 1 IH, IK, IL, FOBS2, FCALC2, SIGF2, MU(1), MU(2), 2 PHI(1), PHI(2), THETA, UCINT, ACALS, BCALS IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 70 FO = SQRT(MAX(0.0, FOBS2)) FC = SQRT(FCALC2) SINTH = SIN(THETA / GL(5)) COSTH = COS(THETA / GL(5)) THMAX = MAX (THETA, THMAX) MUMIN = MIN (MUMIN, MU(1)) MUMIN = MIN (MUMIN, MU(2)) MUMAX = MAX (MUMAX, MU(1)) MUMAX = MAX (MUMAX, MU(2)) MU(1) = SIGN(SQRT(ABS(MU(1))) * SFMU, MU(1)) MU(2) = SIGN(SQRT(ABS(MU(2))) * SFMU, MU(2)) NREF = NREF + 1 IUSE = 0 IF (FOBS2 .GT. 0.0) THEN NTOT = NTOT + 1 DO 60 J = 1, 2 JJ = (J - 1) * 4 M = 0 IF (MU(J) .LT. 0.0) M = 8 N = INT(PHI(J) / 90.0 + 1.0) IOCT = N + JJ + M NP(IOCT) = NP(IOCT) + 1 60 CONTINUE IF (FOBS2 .LT. 1.5 * SIGF2) THEN NCUTO = NCUTO + 1 ELSE IF (FCALC2 .LT. 1.5 * SIGF2) THEN NCUTC = NCUTC + 1 ELSE IF (FC .GE. FO * 2.0) THEN NLOW = NLOW + 1 ELSE IUSE = 1 ENDIF ENDIF ENDIF ENDIF WRITE (LU9) IUSE, FC, FO, PHI, MU, SINTH, COSTH, 1 IH, IK, IL, FOBS2, SIGF2, UCINT, ACALS, BCALS GOTO 50 70 ENDFILE LU9 DO 180 NCY = 1, NCYCLE NUMREF = 0 SUMRES = 0.0 SUMFS = 0.0 SUMRSQ = 0.0 SUMFSQ = 0.0 DO 40 I = 1, NCO ATB(I) = 0.0 DO 30 J = 1, I ANORM(I, J) = 0.0 30 CONTINUE 40 CONTINUE CALL GEN108 (LU9, 0) IF (NCY .GT. 1 .AND. ITCOR .EQ. 1) NSHAPE = NCO DO 80 I = 1, NREF READ (LU9) IUSE, FC, FO, PHI, MU, SINTH, COSTH, 1 IH, IK, IL, FOBS2, SIGF2 IF (IUSE .EQ. 1) THEN CALL PLA181 (PS1, PS2, PS3) FM = FO * PS1 * PS2 * PS3 NUMREF = NUMREF + 1 SUMFS = SUMFS + FC SUMFSQ = SUMFSQ + FC**2 RESID = ABS(FC - FM) SUMRES = SUMRES + RESID SUMRSQ = SUMRSQ + RESID**2 DEL = FC - FM DCONST = FO * PS3 DO 310 J = 1, NACOEF JJ = J + NACOEF ROWJ(J) = DCONST * (ROWJ(J) * PS2 + PS1 * ROWJ(JJ)) 310 CONTINUE IF (ITCOR .EQ. 1 .AND. NCY .NE. 1) THEN NSTART = NACOEF + 1 DCONST = FO * PS1 * PS2 DO 320 J = NSTART, NSHAPE JJ = J + NACOEF ROWJ(J) = DCONST * ROWJ(JJ) 320 CONTINUE ENDIF DO 340 K = 1, NSHAPE DO 350 L = 1, K ANORM(K, L) = ANORM(K, L) + ROWJ(K) * ROWJ(L) 350 CONTINUE ATB(K) = ATB(K) + ROWJ(K) * DEL 340 CONTINUE ENDIF 80 CONTINUE IF (NREF .LT. 400) THEN WRITE (LU6, 99985) WRITE (LU7, 99985) GOTO 250 ENDIF IF (NCY .EQ. 1) THEN NZERO = NREF - NTOT WRITE (LU6, 99992) NREF, NZERO, NCUTO, NCUTC, NLOW, 1 THMAX, MUMIN, MUMAX, NP WRITE (LU7, 99992) NREF, NZERO, NCUTO, NCUTC, NLOW, 1 THMAX, MUMIN, MUMAX, NP WRITE (LU6, 99990) WRITE (LU7, 99990) RM = SUMRES / SUMFS RMS = SQRT(SUMRSQ / SUMFSQ) WRITE (LU6, 99986) NUMREF, RM , RMS WRITE (LU7, 99986) NUMREF, RM , RMS ENDIF AINFL = FILSTA - (NCY - 1) * FILDEC IF (AINFL .LT. FILEND) AINFL = FILEND DO 90 I = 1, NSHAPE UM1(I) = 1.0 IF (ANORM(I, I) .NE. 0.0) UM1(I) = 1.0 / SQRT(ANORM(I, I)) 90 CONTINUE DO 110 J = 1, NSHAPE UM1J = UM1(J) ATB(J) = ATB(J) * UM1J DO 100 K = 1, J ANORM(J, K) = ANORM(J, K) * UM1(K) * UM1J 100 CONTINUE 110 CONTINUE CALL GEN029 (ANORM, EIG, VEC, NSHAPE, NCO, NCO, WORK) DO 130 I = 1, NSHAPE SUM = 0.0 DO 120 J = 1, NSHAPE SUM = SUM + VEC(J, I) * ATB(J) 120 CONTINUE RDASH(I) = SUM 130 CONTINUE DO 140 I = 1, NSHAPE SDASH(I) = 0.0 IF (EIG(I) .GT. FILTER) 1 SDASH(I) = RDASH(I) / (EIG(I) + AINFL) 140 CONTINUE DO 160 J = 1, NSHAPE SUM = 0.0 DO 150 I = 1, NSHAPE SUM = SUM + VEC(J, I) * SDASH(I) 150 CONTINUE ATB(J) = SUM * UM1(J) 160 CONTINUE DO 170 J = 1, NSHAPE TERMS(J) = TERMS(J) + ATB(J) 170 CONTINUE 180 CONTINUE AMIN = 100.0 AMAX = -100.0 NTOT = 0 ATOT = 0.0 NSET = 1 SFMUSQ = SFMU**2 NUMREF = 0 SUMRES = 0.0 SUMFS = 0.0 SUMRSQ = 0.0 SUMFSQ = 0.0 CALL GEN108 (LU17, 0) CALL GEN108 (LU9, 0) DO 190 I = 1, NREF READ (LU9) IUSE, FC, FO, PHI, MU, SINTH, COSTH, 1 IH, IK, IL, FOBS2, SIGF2, UCINT, ACALS, BCALS NTOT = NTOT + 1 CALL PLA181 (PS1, PS2, PS3) ACR = PS1 * PS2 * PS3 ACR2 = ACR ** 2 IF (ACR2 .LE. AMIN) THEN AMIN = ACR2 APHINP = PHI(1) APHINS = PHI(2) AMUNP = MU(1) * ABS(MU(1)) / SFMUSQ AMUNS = MU(2) * ABS(MU(2)) / SFMUSQ IHMN = IH IKMN = IK ILMN = IL ENDIF IF (ACR2 .GE. AMAX) THEN AMAX = ACR2 APHIXP = PHI(1) APHIXS = PHI(2) AMUXP = MU(1) * ABS(MU(1)) / SFMUSQ AMUXS = MU(2) * ABS(MU(2)) / SFMUSQ IHMX = IH IKMX = IK ILMX = IL ENDIF ATOT = ATOT + ACR2 IF (IUSE .EQ. 1) THEN FM = FO * ACR NUMREF = NUMREF + 1 SUMFS = SUMFS + FC SUMFSQ = SUMFSQ + FC**2 RESID = ABS(FC - FM) SUMRES = SUMRES + RESID SUMRSQ = SUMRSQ + RESID**2 ENDIF FOBS2 = FOBS2 * ACR2 SIGF2 = SIGF2 * ACR2 WRITE (LU17, '(3I4, 2I8, I4, 48X, I8, 2F8.2, F8.4)') 1 IH, IK, IL, NINT(FOBS2), NINT(SIGF2), NSET, 2 NINT(UCINT), ACALS, BCALS, ACR2 190 CONTINUE WRITE (LU17, '(1X)') WRITE (LU6, 99995) WRITE (LU7, 99995) RM = SUMRES / SUMFS RMS = SQRT(SUMRSQ / SUMFSQ) WRITE (LU6, 99986) NUMREF, RM , RMS WRITE (LU7, 99986) NUMREF, RM , RMS AVER = ATOT / NTOT TVER = (AMIN / AMAX) ** 0.3333 TMIN = TVER * (AMIN / AMAX) WRITE (LU7, 99994) NTOT, AMIN, IHMN, IKMN, ILMN, APHINP, AMUNP, 1 APHINS, AMUNS, AMAX, IHMX, IKMX, ILMX, APHIXP, AMUXP, 2 APHIXS, AMUXS, AVER, TMIN, TVER WRITE (LU7, 99993) (TERMS(J), J = 1, NSHAPE) WRITE (LU6, 99989) NTOT, TMIN, TVER MAXM = INT(MUMAX / 5.0 + 0.8) MINM = INT(MUMIN / 5.0 - 0.8) MRANGE = MAXM - MINM + 1 MUS = MAXM * 5 MUF = MINM * 5 CALL PLA269 (0) DO 220 J = 1, 2 NPS = (J - 1) * 180 NPF = NPS + 170 WRITE (LU7, 99996) NPS, NPF, MUF, MUS, (JJ, JJ = NPS, NPF, 10) DO 210 I = 1, MRANGE II = (MAXM - (I - 1)) * 5 RMU = II IF (II .GT. 0) RMU = SQRT(RMU) * SFMU IF (II .LT. 0) RMU = -SQRT(ABS(RMU)) * SFMU MU(1) = RMU MU(2) = RMU DO 200 K = 1, 18 KK = (K - 1) * 10 + NPS PHI(1) = KK PHI(2) = KK CALL PLA181 (PS1, PS2, PS3) A(K) = PS1 * PS2 200 CONTINUE WRITE (LU7, 99999) II, A 210 CONTINUE 220 CONTINUE 225 CALL PLA200 (7, 1, 0, 0) VERT = 25.0 HORS = 4.0 * VERT / 3.0 CALL GGIP20 (0.0, 'Absorption Surface A*(mu,phi)', 29, 0.7, 1 1, 2, 6.0, 22.0) CALL GGIP20 (0.0, '+ .... Mu - Range .... -', 24, 0.4, 1 1, 2, 9.0, 2.5) CALL GGIP20 (90.0, '0 .... Phi - Range ... 360', 26, 0.4, 1 1, 2, 32.5, 6.5) CALL GGIP (1.25, 1.25, 0.0, -3) CALL GGIP30 (PLA182, BUFF, 0.0, FLOAT(MUF), 0.0, 360.0, 1 FLOAT(MUS), 5.0, 1 1.0, 1.0, 12.0, 0.0, 0.0, HORS * 0.9, VERT * 0.9, 0.1) CALL GGIP (-1.25, -1.25, 0.0, -3) 226 CALL GGIP20 (0.0, 'Click on END to Proceed', 23, 1 0.75, 2, 2, 15.0, 1.0) CALL PLA013 (0, 1) CALL PLA006 (0, IS) IF (IFL(1)(1:4) .EQ. 'NEXT') THEN GOTO 229 ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN GOTO 229 ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN GOTO 229 ELSE IF (IFL(1)(1:4) .EQ. 'PLOT') THEN GOTO 225 ELSE GOTO 226 ENDIF 229 CALL GGIP (0.0, 0.0, 0.0, -1) IF (ITCOR .EQ. 1) THEN MAXM = INT(THMAX / 5.0 + 0.8) MRANGE = MAXM + 1 MEND = MAXM * 5 DO 230 I = 1, MRANGE THET = (I - 1) * 5.0 SINTH = SIN(THET / GL(5)) COSTH = COS(THET / GL(5)) CALL PLA181 (PS1, PS2, PS3) A(I) = PS3 230 CONTINUE WRITE (LU7, 99998) MEND, (I, I = 0, MEND, 5) WRITE (LU7, 99997) (A(I), I = 1, MRANGE) ENDIF 250 RETURN 99999 FORMAT (I4, 1X, 18F5.2) 99998 FORMAT (/, 'Curve for THETA = 0 --->', I3, /, 2X, 18(I7)) 99997 FORMAT (5X, 18F7.3) 99996 FORMAT (/, 'Absorption Surface for PHI =', I4, ' --->', I4, 1 ' WITH MU RANGE =', I3, ' --->', I3, /, 5X, 18(I3, 2X)) 99995 FORMAT (/, ':: Residuals After Correction') 99994 FORMAT (/, I6, ' Reflections corrected (Corrections on F**2)', 1 /, 'Min. absorption corr. =', F6.3, ' for ', 3I4, 2 2X, 'at Phi(P)=', F6.1, ' Mu(P)=', F6.1, 3 ' Phi(S)=', F6.1, ' Mu(S)=', F6.1, 4 /, 'Max. absorption corr. =', F6.3, ' for ', 3I4, 5 2X, 'at PHI(P)=', F6.1, ' MU(P)=', F6.1, 6 ' PHI(S)=', F6.1, ' MU(S)=', F6.1, 7 /, 'Average absorption correction =', F6.3, 8 //, 'Minimum, Maximum Virtual Transmission: ', 2F6.3) 99993 FORMAT (/, 10X, 'Values for the Fourier Expansion Coefficients', 1 //, 2(6F10.4, /), /, 2(4F10.4, /), /, 2 2(7F10.4, /), /, 2(5F10.4, /), /) 99992 FORMAT (/, I6, ' Reflections on Input', 1 /, I6, ' Rejected with I(obs) <= 0', 2 /, I6, ' Rejected with I(obs) / Sig(Iobs) < 1.5', 3 /, I6, ' Rejected with I(calc)/ Sig(Iobs) < 1.5', 4 /, I6, ' Rejected with Fcalc .GT. 2*Fobs', /, 5 /, 'Maximum THETA =', F6.2, ' degrees', 6 /, 'Minimum MU =', F6.2, ' degrees', 7 /, 'Maximum MU =', F6.2, ' degrees', /, 8 /, 'NUMBER OF REFLECTION PATHS IN EACH OCTANT', 9 /, 11X, 'Primary', 20X, 'Secondary', /, * 2(4X, '0-90 -180 -270 -360', 5X) 1 /, '+MU', 4I5, 8X, 4I5, /, '-MU', 4I5, 8X, 4I5) 99991 FORMAT ('DELABS: Empirical Absorption/Extinction Correction ', 1 'with the DIFABS Strategy', /, 132('='), //, 2 '(See: Walker, N. & Stuart, D. (1983) Acta Cryst. A39,', 3 ' 158-166)', /) 99990 FORMAT (/, ':: Residuals Before Correction') 99989 FORMAT (//, I6, ' Reflections corrected', 1 /, 'Minimum Transmission =', F6.3, 2 /, 'Maximum Transmission =', F6.3) 99988 FORMAT (':: Mu & Phi Based on Pseudo-Orientation Matrix', /) 99987 FORMAT (/, ':: DELABS Style Absorption Corr. THCOR = ', A, /) 99986 FORMAT (/, 'For the', I6, ' reflections R = ', F6.4, 1 ' and R2 = ', F6.4) 99985 FORMAT (/,':: Too Few Data to Fit Transmission Surface') 99984 FORMAT (/, ':: TWIN MATRIX & BASF:', 9I4, F10.3, /) 99983 FORMAT (3I4, 2F15.2, F10.2, 5F9.2, 1X, 3F8.0) END SUBROUTINE PLA181 (PS1, PS2, PS3) PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30) REAL MU COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON // JNSC(2, NP23), VOID(NPVD - 15444), BUFF(11000), 1 ANORM(44, 44), ATB(44), ROWJ(88), TERMS(44), VEC(44, 44), 2 EIG(44), UM1(44), WORK(220), RDASH(44), SDASH(44) COMMON /REFL/ FC, FO, FM, PHI(2), MU(2), ST, CT COMMON /DRVR/ NCY, NSHAPE, NACOEF, NBCOEF, SFMU, ITCOR DTOR = 1.0 / GL(5) INC = -34 DO 1 I = 1, 2 INC = INC + 34 SP = SIN(PHI(I) * DTOR) CP = COS(PHI(I) * DTOR) SM = SIN(MU(I) * DTOR) CM = COS(MU(I) * DTOR) SP2 = CP * SP * 2.0 CP2 = CP ** 2 - SP ** 2 SP3 = CP * SP2 + CP2 * SP CP3 = CP * CP2 - SP * SP2 SP4 = CP2 * SP2 * 2.0 CP4 = CP2 ** 2 - SP2 ** 2 SP5 = CP2 * SP3 + CP3 * SP2 CP5 = CP2 * CP3 - SP2 * SP3 SP6 = CP3 * SP3 * 2.0 CP6 = CP3 ** 2 - SP3 ** 2 SM2 = CM * SM * 2.0 CM2 = CM ** 2 - SM ** 2 SM3 = CM2 * SM + CM * SM2 CM3 = CM2 * CM - SM2 * SM SM4 = CM2 * SM2 * 2.0 CM4 = CM2 ** 2 - SM2 ** 2 ROWJ(INC + 1) = SP ROWJ(INC + 2) = SP2 ROWJ(INC + 3) = SP3 ROWJ(INC + 4) = SP4 ROWJ(INC + 5) = SP5 ROWJ(INC + 6) = SP6 ROWJ(INC + 7) = CP ROWJ(INC + 8) = CP2 ROWJ(INC + 9) = CP3 ROWJ(INC + 10) = CP4 ROWJ(INC + 11) = CP5 ROWJ(INC + 12) = CP6 ROWJ(INC + 13) = SM ROWJ(INC + 14) = SM2 ROWJ(INC + 15) = SM3 ROWJ(INC + 16) = SM4 ROWJ(INC + 17) = CM ROWJ(INC + 18) = CM2 ROWJ(INC + 19) = CM3 ROWJ(INC + 20) = CM4 ROWJ(INC + 21) = CP * SM + SP * CM ROWJ(INC + 22) = CP2 * SM + SP2 * CM ROWJ(INC + 23) = CP3 * SM + SP3 * CM ROWJ(INC + 24) = CP4 * SM + SP4 * CM ROWJ(INC + 25) = CP2 * SM2 + SP2 * CM2 ROWJ(INC + 26) = CP3 * SM3 + SP3 * CM3 ROWJ(INC + 27) = CP4 * SM4 + SP4 * CM4 ROWJ(INC + 28) = CP * CM - SP * SM ROWJ(INC + 29) = CP2 * CM - SP2 * SM ROWJ(INC + 30) = CP3 * CM - SP3 * SM ROWJ(INC + 31) = CP4 * CM - SP4 * SM ROWJ(INC + 32) = CP2 * CM2 - SP2 * SM2 ROWJ(INC + 33) = CP3 * CM3 - SP3 * SM3 ROWJ(INC + 34) = CP4 * CM4 - SP4 * SM4 1 CONTINUE PS1 = 1.0 PS2 = 1.0 PS3 = 1.0 IF (NCY .GT. 1) THEN DO 10 J = 1, NACOEF JJ = J + NACOEF PS1 = PS1 + TERMS(J) * ROWJ(J) PS2 = PS2 + TERMS(J) * ROWJ(JJ) 10 CONTINUE IF (ITCOR .EQ. 1) THEN ST2 = CT * ST * 2 CT2 = CT * CT - ST * ST ST3 = CT * ST2 + CT2 * ST CT3 = CT * CT2 - ST * ST2 ROWJ(72) = CT2 * ST2 * 2 ROWJ(77) = CT2 * CT2 - ST2 * ST2 ROWJ(73) = CT2 * ST3 + CT3 * ST2 ROWJ(78) = CT2 * CT3 - ST2 * ST3 ROWJ(69) = ST ROWJ(70) = ST2 ROWJ(71) = ST3 ROWJ(74) = CT ROWJ(75) = CT2 ROWJ(76) = CT3 IF (NCY .GT. 2) THEN NSTART = NACOEF + 1 DO 20 J = NSTART, NSHAPE JJ = J + NACOEF PS3 = PS3 + TERMS(J) * ROWJ(JJ) 20 CONTINUE ENDIF ENDIF ENDIF RETURN END FUNCTION PLA182 (X, Y, XMN, XMX, YMN, YMX) COMMON /REFL/ FC, FO, FM, PHI(2), MU(2), SINTH, COSTH COMMON /DRVR/ NCY, NSHAPE, NACOEF, NBCOEF, SFMU, ITCOR REAL MU IF (Y .GE. 0.0) THEN RMU = SQRT(Y) * SFMU ELSE RMU = - SQRT(ABS(Y)) * SFMU ENDIF MU(1) = RMU MU(2) = RMU PHI(1) = X PHI(2) = X IF (X .GE. XMN .AND. X .LE. XMX .AND. 1 Y .GE. YMN .AND. Y .LE. YMX) THEN CALL PLA181 (PS1, PS2, PS3) PLA182 = 2.5 * (PS1 * PS2) ** 2 ELSE PLA182 = 0.0 ENDIF RETURN END SUBROUTINE PLA183 PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000, 1 NP38=125,NP39=30,MR=300000,MZ=NPVD+2*NP23-9*MR-7656) DOUBLE PRECISION B(3570), C(84), E(84), F(84), DD, DT, TT COMMON // B, C, E, F, D(12), FF(MR), FC(MR), SG(MR), XI(MR), 1 XD(MR), YI(MR), YD(MR), ZI(MR), ZD(MR), DUMMY(MZ) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) DIMENSION TRMX(3, 3) COMMON /PAGENM/ PAGET, PAGEIND(25) CHARACTER PAGET*8, PAGEIND*8 IF (IGBL(37) .NE. 1) THEN IPR(2) = 56 GOTO 1000 ENDIF TH = PAR(417) DU = PAR(418) ME = IPR(523) MO = IPR(524) IHT = 0 IKT = 0 ILT = 0 CALL PLA293 (PAR(17), 0) IF (IPR(37) .EQ. 0) GOTO 1000 CALL PLA287 (1, 1, 0) PAGET = 'SHXABS' CALL PLA269 (0) WRITE (LU6, 99999) PAR(417), PAR(418), IPR(523), IPR(524) WRITE (LU7, 99999) PAR(417), PAR(418), IPR(523), IPR(524) K = 230 DO 4 I = 1, 3 DO 3 J = 1, 3 K = K + 1 TRMX(I, J) = PAR(K) 3 CONTINUE 4 CONTINUE NR = 0 U = 0.0 V = 0.0 10 READ (LU16, 99998, ERR = 10, END = 20) IH, IK, IL, OBS, Q, J, 1 XINR, XDNR, YINR, YDNR, ZINR, ZDNR IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 20 IF (OBS .LT. TH * Q) GOTO 10 IF (Q .LE. 0.0) GOTO 10 ACAL = 0.0 BCAL = 0.0 IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) .GT. 0.0) THEN CALL PLA131 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA, SNTHA) NR = NR + 1 CALC = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2 FF(NR) = OBS FC(NR) = CALC SG(NR) = Q U = U + OBS V = V + CALC XI(NR) = XINR YI(NR) = YINR ZI(NR) = ZINR XD(NR) = XDNR YD(NR) = YDNR ZD(NR) = ZDNR IF (NR .EQ. MR) GOTO 1001 ENDIF GOTO 10 20 N = NR IF (N .EQ. 0) GOTO 1000 NR = 0 SC = V / U DO 30 I = 1, 6 C(I) = 0.D0 30 CONTINUE DO 40 I = 1, 21 B(I) = 0.D0 40 CONTINUE DO 70 I = 1, N OBS = FF(I) * SC SIG = SG(I) * SC IF (AMIN1 (OBS, FC(I)) .GT. TH * SIG) THEN NR = NR + 1 FF(NR) = OBS FC(NR) = FC(I) SG(NR) = SIG XI(NR) = XI(I) YI(NR) = YI(I) ZI(NR) = ZI(I) XD(NR) = XD(I) YD(NR) = YD(I) ZD(NR) = ZD(I) F(1) = DBLE(XI(I))**2 F(2) = DBLE(YI(I))**2 F(3) = DBLE(ZI(I))**2 F(4) = DBLE(YI(I) * ZI(I)) F(5) = DBLE(XI(I) * ZI(I)) F(6) = DBLE(XI(I) * YI(I)) F(7) = DBLE(XD(I))**2 F(8) = DBLE(YD(I))**2 F(9) = DBLE(ZD(I))**2 F(10) = DBLE(YD(I) * ZD(I)) F(11) = DBLE(XD(I) * ZD(I)) F(12) = DBLE(XD(I) * YD(I)) L = 0 DO 60 J = 1, 6 C(J) = C(J) + F(J) + F(J + 6) DO 50 K = 1, J L = L + 1 B(L) = B(L) + F(J) * F(K) + F(J + 6) * F(K + 6) 50 CONTINUE 60 CONTINUE ENDIF 70 CONTINUE CALL GEN110 (6, 21, C, B) DO 80 I = 1, 6 D(I + 6) = SNGL(C(I)) 80 CONTINUE D(1) = SQRT (D(7)) D(2) = 0.5 * D(12) / D(1) D(3) = 0.5 * D(11) / D(1) D(4) = SQRT (D(8) - D(2)**2) D(5) = (0.5 * D(10) - D(2) * D(3)) / D(4) D(6) = SQRT (D(9) - D(3)**2 - D(5)**2) T = 0.0 S = 0.0 R = 0.0 U = 0.0 V = 0.0 DO 90 I = 1, NR U = U + FF(I) V = V + FC(I) XI(I) = XI(I) * D(1) + YI(I) * D(2) + ZI(I) * D(3) YI(I) = YI(I) * D(4) + ZI(I) * D(5) ZI(I) = ZI(I) * D(6) XD(I) = XD(I) * D(1) + YD(I) * D(2) + ZD(I) * D(3) YD(I) = YD(I) * D(4) + ZD(I) * D(5) ZD(I) = ZD(I) * D(6) P = ABS (1.0 - XI(I)**2 - YI(I)**2 - ZI(I)**2) Q = ABS (1.0 - XD(I)**2 - YD(I)**2 - ZD(I)**2) R = R + P + Q T = AMAX1 (T, P, Q) S = AMAX1 (S, 0.5 * (XI(I) * XD(I) + YI(I) * YD(I) 1 + ZI(I) * ZD(I) + 1.0)) 90 CONTINUE R = 0.5 * R / REAL(NR) S = 114.59156 * ATAN2 (SQRT (S), SQRT (1.0 - S)) WRITE (LU6, 99995) R, T, S WRITE (LU7, 99995) R, T, S CALL GEN109 (MO, ME, XI(1), YI(1), ZI(1), F, I) NP = I + 4 T = V / U U = 0.0 V = 0.0 DO 100 I = 1, NR P = SQRT (T * FF(I)) Q = SQRT (FC(I)) U = U + ABS (P - Q) V = V + Q 100 CONTINUE WRITE (LU6, 99997) NR, NP, U / V WRITE (LU7, 99997) NR, NP, U / V NN = (NP * (NP + 1)) / 2 DO 110 I = 1, NN B(I) = 0.D0 110 CONTINUE DO 120 I = 1, NP C(I) = 0.D0 120 CONTINUE DO 160 I = 1, NR CALL GEN109 (MO, ME, XI(I), YI(I), ZI(I), E, L) CALL GEN109 (MO, ME, XD(I), YD(I), ZD(I), F, L) S = 0.5 * (XI(I) * XD(I) + YI(I) * YD(I) + ZI(I) * ZD(I) + 1.0) DO 130 J = 1, L F(J) = F(J) + E(J) 130 CONTINUE F(L + 1) = DBLE(S) F(L + 2) = 1.0D0 F(L + 3) = 1.0D0 / DBLE(S) F(L + 4) = 1.0D0 / DBLE(S)**2 DD = DBLE(ALOG (FC(I) / FF(I))) M = 0 DO 150 J = 1, NP C(J) = C(J) + DD * F(J) DT = F(J) DO 140 K = 1, J M = M + 1 B(M) = B(M) + DT * F(K) 140 CONTINUE 150 CONTINUE 160 CONTINUE CALL GEN110 (NP, NN, C, B) TM = -9.E9 TZ = 9.E9 U = 0.0 V = 0.0 DO 190 I = 1, NR CALL GEN109 (MO, ME, XI(I), YI(I), ZI(I), E, L) CALL GEN109 (MO, ME, XD(I), YD(I), ZD(I), F, L) S = 0.5 * (XI(I) * XD(I) + YI(I) * YD(I) + ZI(I) * ZD(I) + 1.0) DO 170 J = 1, L F(J) = F(J) + E(J) 170 CONTINUE F(L + 1) = DBLE(S) F(L + 2) = 1.0D0 F(L + 3) = 1.0D0 / DBLE(S) F(L + 4) = 1.0D0 / DBLE(S)**2 TT = 0.0D0 DO 180 K = 1, NP TT = TT + C(K) * F(K) 180 CONTINUE T = SNGL(TT) T = AMIN1 (T, 15.0) TM = AMAX1 (TM, T) TZ = AMIN1 (TZ, T) S = SQRT (FC(I)) U = U + ABS (SQRT (FF(I) * EXP(T)) - S) V = V + S 190 CONTINUE WRITE (LU6, 99996) U / V WRITE (LU7, 99996) U / V O = 1.0 TA = -9.E9 TB = 9.E9 200 REWIND LU16 N = 0 210 READ (LU16, 99998, ERR = 210, END = 270) IH, IK, IL, 1 T, S, M, U, P, V, Q, W, R IF (IABS(IH) + IABS(IK) + IABS(IL) .EQ. 0) GOTO 210 U = U * D(1) + V * D(2) + W * D(3) V = V * D(4) + W * D(5) W = W * D(6) P = P * D(1) + Q * D(2) + R * D(3) Q = Q * D(4) + R * D(5) R = R * D(6) N = N +1 CALL GEN109 (MO, ME, U, V, W, E, L) CALL GEN109 (MO, ME, P, Q, R, F, L) Q = 0.5 * (U * P + V * Q + W * R + 1.0) DO 220 J = 1, L F(J) = F(J) + E(J) 220 CONTINUE F(L + 1) = DBLE(Q) F(L + 2) = 1.0D0 F(L + 3) = 1.0D0 / DBLE(Q) F(L + 4) = 1.0D0 / DBLE(Q)**2 P = -157.9137 * Q * DU DO 230 K = 1, NP P = P + SNGL(C(K) * F(K)) 230 CONTINUE P = EXP (AMAX1 (TZ, AMIN1 (P, TM))) TA = AMAX1 (TA, P) TB = AMIN1 (TB, P) Q = O * P T = T * Q S = S * Q IF (T .GT. 99999.99) GOTO 240 IF (S .GT. 99999.99) GOTO 240 IF (T .LT. -9999.99) GOTO 240 IF (S .LT. -9999.99) GOTO 240 WRITE (LU17, 99994) IH, IK, IL, T, S, M GOTO 210 240 IF (T .GT. 9999999.0) GOTO 250 IF (S .GT. 9999999.0) GOTO 250 IF (T .LT. -999999.0) GOTO 250 IF (S .GT. -999999.0) GOTO 260 250 REWIND LU17 O = O * 0.1 GOTO 200 260 WRITE (LU17, 99993) IH, IK, IL, T, S, M GOTO 210 270 I = 0 T = 0.0 WRITE (LU17, 99994) I, I, I, T, T, I T = (TB / TA)**0.3333 WRITE (LU6, 99992) N, T * TB / TA, T WRITE (LU7, 99992) N, T * TB / TA, T IPR(2) = -10 1000 RETURN 1001 WRITE (LU6, 99991) WRITE (LU7, 99991) RETURN 99999 FORMAT (/, ' SHXABS', 2F8.2, 2I5, /) 99998 FORMAT (3I4, 2F8.2, I4, 6F8.5) 99997 FORMAT (/, I8, ' Reflections used to determine', I3,' Parameters' 1 //' R1 =',F9.4,' Before Parameter Refinement') 99996 FORMAT (' R1 =',F9.4,' After Parameter Refinement'/) 99995 FORMAT (/, 'Mean and Maximum Errors in Direction Cosine Check ', 1 'Function =', 2F7.3, /, 'The mean error should not exceed,', 2 ' 0.005. Maximum 2-theta =', F8.2, ' degrees', /) 99994 FORMAT (3I4, 2F8.2, I4) 99993 FORMAT (3I4, 2F8.0, I4) 99992 FORMAT (I8,' Corrected reflections written to file ', //, 1 ' Minimum and Maximum Virtual Transmission =', 2F12.6, /) 99991 FORMAT (' ** Too many .raw data - use higher I/sigma ', 1 //, 'or larger version **') END SUBROUTINE PLA185 (MODE, SCL, NR, NOCLS) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99, 2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9,NXT1=100,NXT2=200, 3 NXT3=100, NXT4=200) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4), 1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10), 1 NPSI CHARACTER NRV*6 VERT = 25.0 IDM = ' H K L DIST(mm)' CALL GGIP20 (0.0, IDM, 19, 0.5, 5, 2, VERT + 0.1, VERT - 3.0) DO 10 I = 1, NFACES WRITE (IDM, 99999) (NINT(PMILL(I, J)), J = 1, 3), PMILL(I, 5) CALL GGIP20 (0.0, IDM, 18, 0.5, -1, 2, VERT + 0.1, 1 VERT - 3.5 - I * 0.8) 10 CONTINUE CALL GGIP (13.0, 12.0, 0.0, -3) IF (NVER .GT. NXT2) THEN CALL GGIP20 (0.0, 'Too Many Vertices ', 18, 0.75, 1 2, 2, 1.0, -6.5) GOTO 190 ELSE IF (NFACES + NVRR - 2 .NE. NEDGE) THEN WRITE (PRBUF, 99994) WRITE (LU6, 99998) PRBUF WRITE (LU7, 99998) PRBUF CALL GGIP20 (0.0, PRBUF, 18, 0.75, 2, 2, 1.0, -8.0) GOTO 190 ENDIF CALL GEN021 (DUMV, 1) CALL GEN004 (OP(1, 1, NR), DUMV, DUMV) CALL GEN003 (OP(1, 1, NR), PAT, DET, 0) CALL GEN007 (RAA, DUMV(1, 1), V3, 1) CALL GEN007 (RAA, DUMV(1, 2), V4, 1) CALL GEN007 (RAA, DUMV(1, 3), V5, 1) DO 20 I = 1, 2 V3(I) = V3(I) * SCL * 0.5 V4(I) = V4(I) * SCL * 0.5 V5(I) = V5(I) * SCL * 0.5 V1(I) = 1000000.0 V1(I + 2) = - 1000000.0 20 CONTINUE IF (NVER .GT. 0) THEN CALL GEN074 (V2, 0.0, 1, 3) DO 30 I = 1, NVER CALL GEN002 (MODE, DUMV, XTLV(1, I), XYZPL(1, I), XG) V1(1) = MIN (V1(1), XYZPL(1, I)) V1(2) = MIN (V1(2), XYZPL(2, I)) V1(3) = MAX (V1(3), XYZPL(1, I)) V1(4) = MAX (V1(4), XYZPL(2, I)) V2(1) = V2(1) + XYZPL(1, I) V2(2) = V2(2) + XYZPL(2, I) V2(3) = V2(3) + XYZPL(3, I) 30 CONTINUE V2(1) = V2(1) / NVER V2(2) = V2(2) / NVER V2(3) = V2(3) / NVER DO 40 I = 1, NVER XYZPL(1, I) = XYZPL(1, I) - V2(1) XYZPL(2, I) = XYZPL(2, I) - V2(2) XYZPL(3, I) = XYZPL(3, I) - V2(3) 40 CONTINUE DIS = 0.0 DO 50 I = 1, NVER DIS = MAX (DIS, SQRT (GEN009 (XYZPL(1, I), XYZPL(1, I)))) 50 CONTINUE SCAL = PAR(325) * SCL / DIS DO 90 I = 1, NFACES ANGLE = 0 DO 60 J = 1, 3 ANGLE = ANGLE + PAT(J, 3) * PMILL(I, J) CFACE(J, I) = 0.0 60 CONTINUE CFACE(4, I) = 0 CFACE(5, I) = ANGLE DO 80 K = 1, NVER DO 70 J = 4, 6 N = IABS(NINT(XTLV(J, K))) IF (N .EQ. I) THEN IF (ANGLE .LT. 0.0) N = - N XTLV(J, K) = N CFACE(1, I) = CFACE(1, I) + XYZPL(1, K) CFACE(2, I) = CFACE(2, I) + XYZPL(2, K) CFACE(3, I) = CFACE(3, I) + XYZPL(3, K) CFACE(4, I) = CFACE(4, I) + 1.0 ENDIF 70 CONTINUE 80 CONTINUE 90 CONTINUE IF (NOCLS .GE. 0) THEN COLR = 1.0 ELSE COLR = 0.0 ENDIF CALL GGIP (0.0, COLR, 0.0, 0) DO 110 I = 1, NVER DO 100 K = 1, 3 XYZPL(K, I) = SCAL * XYZPL(K, I) 100 CONTINUE IF (IGBL(75) .EQ. 1) THEN IF (NVER .LT. 100) THEN NV = 2 WRITE (NRV, 99997) NINT(XTLV(7, I)) ELSE NV = 3 WRITE (NRV, 99996) NINT(XTLV(7, I)) ENDIF CALL GGIP20 (0.0, NRV, NV, 0.3, -1, 2, 1 XYZPL(1, I), XYZPL(2, I)) ENDIF 110 CONTINUE DO 130 I = 1, NFACES DO 120 K = 1, 3 CFACE(K, I) = SCAL * (CFACE(K, I) / CFACE(4, I)) 120 CONTINUE IF (IGBL(75) .EQ. 1) THEN IF (CFACE(5, I) .GT. 0.0) THEN COLR = 1.0 SHT = 0.15 ELSE COLR = 4.0 SHT = -0.15 ENDIF IF (NOCLS .LT. 0) THEN COLR = 0.0 ENDIF CALL GGIP (0.0, COLR, 0.0, 0) WRITE (NRV, 99995) (NINT(PMILL(I, K)), K = 1, 3) CALL GGIP20 (0.0, NRV, 6, 0.25, -1, 2, 1 CFACE(1, I) - 0.5, CFACE(2, I) + SHT) ENDIF 130 CONTINUE ENDIF DO 180 I0 = 1, NEDGE I = IDG(I0, 3) J0 = IDG(I0, 4) MC = 0 IVIS = 0 IF (NOCLS .LT. 0) THEN COLR = 0.0 ELSE COLR = 1.0 ENDIF CALL GGIP (0.0, COLR, 0.0, 0) DO 170 K = 1, 3 DO 160 L = 1, 3 IF (ABS(XTLV(K + 3, I)) .EQ. ABS(XTLV(L + 3, J0))) THEN MC = MC + 1 IF (XTLV(K + 3, I) .GT. 0.0) IVIS = IVIS + 1 IF (MC .EQ. 2) THEN IF (IVIS .LT. 1) THEN XB = XYZPL(1, I) YB = XYZPL(2, I) DIST = SQRT ((XYZPL(1, J0) - XB)**2 1 + (XYZPL(2, J0) - YB)**2) NSTEP = NINT(DIST / 0.3) IF (NSTEP .GT. 0) THEN STEPX = (XYZPL(1, J0) - XB) / NSTEP STEPY = (XYZPL(2, J0) - YB) / NSTEP DO 140 II = 1, NSTEP, 2 CALL GGIP (XB, YB, 0.0, 3) XB = XB + STEPX YB = YB + STEPY CALL GGIP (XB, YB, 0.0, 2) XB = XB + STEPX YB = YB + STEPY 140 CONTINUE ENDIF ELSE IF (NOCLS .LT. 0) THEN COLR = 0.0 ELSE COLR = 1.0 ENDIF CALL GGIP (0.0, COLR, 0.0, 0) DELX = XYZPL(1, J0) - XYZPL(1, I) DELY = XYZPL(2, J0) - XYZPL(2, I) IF (DELX .EQ. 0) THEN DX = 0.025 DY = 0.0 ELSE IF (DELY .EQ. 0) THEN DX = 0.0 DY = 0.025 ELSE DY = - (DELX / DELY) DX = SQRT (0.000625 / (1 + DY**2)) DY = DX * DY ENDIF XB = XYZPL(1, I) - DX YB = XYZPL(2, I) - DY XE = XYZPL(1, J0) - DX YE = XYZPL(2, J0) - DY DO 150 II = 1, 2 CALL GGIP (XB, YB, 0.0, 3) CALL GGIP (XE, YE, 0.0, 2) XB = XB + 2 * DX YB = YB + 2 * DY XE = XE + 2 * DX YE = YE + 2 * DY 150 CONTINUE ENDIF GOTO 180 ENDIF ENDIF 160 CONTINUE 170 CONTINUE 180 CONTINUE IF (IPR(388) .EQ. 1) THEN IF (NOCLS .LT. 0) THEN COLR = 0.0 ELSE COLR = 2.0 ENDIF CALL GGIP (0.0, COLR, 0.0, 0) CALL GGIP (0.0, 0.0, 0.0, 3) CALL GGIP (V3(1), V3(2), 0.0, 2) CALL GGIP20 (0.0, 'a', 1, 0.35, -1, 2, V3(1) + 0.2, V3(2)) CALL GGIP (0.0, 0.0, 0.0, 3) CALL GGIP (V4(1), V4(2), 0.0, 2) CALL GGIP20 (0.0, 'b', 1, 0.35, -1, 2, V4(1) + 0.2, V4(2)) CALL GGIP (0.0, 0.0, 0.0, 3) CALL GGIP (V5(1), V5(2), 0.0, 2) CALL GGIP20 (0.0, 'c', 1, 0.35, -1, 2, V5(1) + 0.2, V5(2)) ENDIF 190 CALL GGIP (-13.0, -12.0, 0.0, -3) CALL GGIP (0.0, 0.0, 0.0, 0) RETURN 99999 FORMAT (3I3, F8.3) 99998 FORMAT (':: ', A) 99997 FORMAT (I2) 99996 FORMAT (I3) 99995 FORMAT (3I2) 99994 FORMAT ('Crystal not Finite') END SUBROUTINE PLA187 C * CALCULATES AN EMPIRICAL CORRECTION FOR ABSORPTION ANISOTROPY BASED C * ON A LEAST-SQUARES FIT OF REAL SPHERICAL HARMONIC FUNCTIONS TO THE C * EMPIRICAL TRANSMISSION SURFACE AS SAMPLED BY MULTIPLE SYMMETRY- C * EQUIVALENT AND/OR AZIMUTH ROTATION-EQUIVALENT REFLECTION C * MEASUREMENTS. (C.F. BLESSING, ACTA CRYST (1995), A51, 33-38) PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200, 3 NP45=2048,NP47=9,NMX=1000,NMAX=(NPVD+2*NP23-14*NMX-45600)/2) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // AZ(80, 80), BZ(80), UZ(80), VZ(80, 80), VA(80, 80), 1 YI(NMX), SIGYI(NMX), U0(3, NMX), U1(3, NMX), AII(NMX), SAA(NMX), 2 WI(NMX), IHH(NMX), IKK(NMX), ILL(NMX), SIGALM(80), ALM(80), 3 YLM0(80), YLM1(80), QI(80), XI(80), CORR(80, 80), DATA(NMAX), 4 INDEX(NMAX) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 DIMENSION S0(3), S1(3), FMUR(12), AMUR(12) DOUBLE PRECISION AZ, BZ, UZ, VZ, VA CHARACTER N0*1, N1*1, N2*1 DATA FMUR /0, 0.5, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10/ DATA AMUR /1.0, 0.48181, 0.24249, 0.07142, 0.02606, 0.01156, 1 0.005983, 0.00347, 0.002186, 0.001465, 0.001029, 0.00075/ IHM = - 9999 IKM = - 9999 ILM = - 9999 SMIN = 9.0 SMAX = 0.0 PAR(301) = FN(1) PAR(305) = FN(2) PAR(304) = FN(3) PAR(306) = FN(4) IPR(373) = NINT(FN(5)) IPR(374) = NINT(FN(6)) PAR(321) = PAR(301) * PAR(305) IF (PAR(321) .EQ. 0.0) THEN IGBL(23) = 16 NAUTO = IGBL(25) ELSE NAUTO = 0 ENDIF CALL PLA269 (-3) WRITE (LU7, 99999) IF (PAR(17) .LE. 0) THEN WRITE (LU6, '(''STOP : WAVELENGTH NOT GIVEN'')') WRITE (LU7, '(''STOP : WAVELENGTH NOT GIVEN'')') GOTO 830 ENDIF SINA = SIN(PAR(244) / GL(5)) COSA = COS(PAR(244) / GL(5)) COSBS = COS(PAR(139) / GL(5)) COSGS = COS(PAR(140) / GL(5)) SINBS = SIN(PAR(139) / GL(5)) SINGS = SIN(PAR(140) / GL(5)) DELTA = 0.0 DO 5 I = 1, 6 DELTA = DELTA + ABS(PAR(100 + I) - PAR(240 + I)) 5 CONTINUE IF (DELTA .GT. 0.01) THEN CALL GEN112 (QQ, PAR(231), 1) CALL GEN003 (QQ, DUMV, DET, 0) CALL GEN112 (DUMV, XJX(1), -1) XJX(10) = 0.0 XJX(11) = 0.0 XJX(12) = 0.0 LINE = 'SPGR '//SPGRNM(1)(1:11) CALL SGSM (LINE, NRSM, XJX, LU6, 16, IERR) CALL SGSM (LINE, NSM, XJX, LU6, 2, IERR) CALL SGSM (LINE, 0, XJX, LU6, 18, IERR) IPR(255) = NINT(XJX(4)) IPR(257) = NINT(XJX(5)) ENDIF FSQMIN = 1.0 FSQMAX = 1E10 STLMIN = 0.0 STLMAX = 9.0 SMIN1 = 0 SMAX1 = 9 IF (NAUTO .EQ. 1) THEN CALL PLA200 (6, 1, 0, 0) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF N3REJ = 0 N6REJ = 0 N7REJ = 0 IPR(371) = 0 IPR(372) = 0 CALL PLA290 (0) CALL GEN108 (LU16, 0) NINP = 0 10 READ (LU16, 99998, END = 30) IH, IK, IL, Y, SIGY, 1 (V1(K), V2(K), K = 1, 3) IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 30 NINP = NINP + 1 V3(1) = IH V3(2) = IK V3(3) = IL STH = SQRT(GEN095 (PAR(391), IH, IK, IL)) * PAR(17) DO 2050 K = 1, 3 V4(K) = PAR(134 + K) * V1(K) V5(K) = PAR(134 + K) * V2(K) 2050 CONTINUE TPRIM = GEN009 (V3, V4) TDIFF = GEN009 (V3, V5) DUMMY = GEN006 (V4, RAA, V5) / 1 SQRT(GEN006 (V4, RAA, V4) * GEN006 (V5, RAA, V5)) IF (ABS(DUMMY) .GT. 1.0) DUMMY = SIGN(1.0, DUMMY) IF (ABS(STH) .GT. 0.99999999) 1 WRITE (LU6,'(''|SIN(THETA)| > 1.0 ?'', 3I5,F10.5,/)') 2 IH, IK, IL, STH TH1 = ASIN(STH) * GL(5) TH2 = 90.0 - ACOS(DUMMY) * GL(5) / 2.0 CALL PLA291 (TPRIM, TDIFF, TH1, TH2, ITEST) IF (ITEST .NE. 0) GOTO 30 S0(1) = V1(1) S1(1) = V2(1) S0(2) = (V1(2) - V1(1) * COSGS) / SINGS S1(2) = (V2(2) - V2(1) * COSGS) / SINGS S0(3) = (V1(3) - V1(1) * COSBS + S0(2) * SINBS * COSA) / 1 (SINBS * SINA) S1(3) = (V2(3) - V2(1) * COSBS + S1(2) * SINBS * COSA) / 1 (SINBS * SINA) IPR(371) = IPR(371) + 1 S = GEN056 (IH, IK, IL, RBB) IF (S .LT. SMIN1 .OR. S .GT. SMAX1) THEN N3REJ = N3REJ + 1 GOTO 10 ENDIF IF (SIGY .LE. 0) THEN N6REJ = N6REJ + 1 GOTO 10 ENDIF IF (Y .LT. -4 * SIGY) THEN N7REJ = N7REJ + 1 GOTO 10 ENDIF SMIN = MIN (SMIN, S) SMAX = MAX (SMAX, S) NSYMH = IPR(255) ICNTR = IPR(257) IHKLM = -99999 DO 20 I = 1, NSYMH XJX(1) = IH XJX(2) = IK XJX(3) = IL XJX(4) = 0.0 NS = I CALL SGSM (ICL, NS, XJX, 0, 5, IERR) IH0 = NINT(XJX(7)) IK0 = NINT(XJX(8)) IL0 = NINT(XJX(9)) IHKL = IL0 * 250000 + IK0 * 500 + IH0 IF (IHKL .LT. 0 .AND. ICNTR .EQ. 2) THEN IH0 = - IH0 IK0 = - IK0 IL0 = - IL0 IHKL = - IHKL ENDIF IF (IABS(IHKL) .GT. IHKLM) THEN IHKLM = IABS(IHKL) J = IH0 K = IK0 L = IL0 ENDIF 20 CONTINUE IHM = MAX (IHM, IABS(J)) IKM = MAX (IKM, IABS(K)) ILM = MAX (ILM, IABS(L)) IF (IPR(372) .LT. NMAX) IPR(372) = IPR(372) + 1 IF (NAUTO .EQ. 1) THEN IF (MOD(IPR(372), 5000) .EQ. 0) CALL PLA200 (6, 1, 0, 1) ENDIF WRITE (LU29, REC = IPR(372)) 1 J, K, L, IH, IK, IL, Y, SIGY, S0, S1 GOTO 10 30 WRITE (LU7, '(''Read ='', I7, '' Measurements'')') IPR(371) IF (ITEST .NE. 0) THEN IPR(210) = 0 GOTO 830 ENDIF WRITE (LU7, '(''Accept ='', I7, '' Measurements'')') IPR(372) CALL PLA290 (-1) CALL PLA269 (6) 35 IF (IPR(373) .EQ. 0) IPR(373) = 8 IF (IPR(374) .GT. 7) IPR(374) = 7 AIMIN = 0.5 AIMAX = 1.5 IF (AIMIN .EQ. 0 .AND. AIMAX .EQ. 0) THEN IF (PAR(301) .GT. 0 .AND. PAR(304) .GT. 0 1 .AND. PAR(306) .GT. PAR(304)) THEN AIMIN = EXP(- PAR(301) * PAR(306)) AIMAX = EXP(- PAR(301) * PAR(304)) ELSE AIMIN = 0.5 AIMAX = 1.5 ENDIF ENDIF IF (AIMIN .GE. 0 .AND. AIMAX .GT. AIMIN) THEN AMEAN = 0.5 * (AIMIN + AIMAX) AIMIN = AIMIN / AMEAN AIMAX = AIMAX / AMEAN ENDIF IF (AIMIN .LT. 0) AIMIN = 0 IF (AIMAX .LT. 0) AIMAX = 1E10 CALL PLA269 (16) WRITE (LU7, 99997) IPR(373), IPR(374), PAR(301), PAR(305), 1 PAR(304), PAR(306), PAR(326) WRITE (LU7, 99982) FSQMIN, FSQMAX, STLMIN, STLMAX,AIMIN,AIMAX IF (PAR(301) .EQ. 0) THEN CALL PLA269 (2) WRITE (LU7, 99981) ELSE IF (PAR(305) .EQ. 0 .AND. PAR(304) .EQ. 0) THEN CALL PLA269 (2) WRITE (LU7, 99980) ELSE IF (PAR(305) .EQ. 0 .AND. PAR(304) .GT. 0) THEN CALL PLA269 (2) WRITE (LU7, 99979) END IF IF (NAUTO .EQ. 1) THEN 38 CALL PLA200 (6, 1, 0, 0) CALL PLA013 (0, 1) CALL PLA006 (0, IS) IF (IFL(1)(1:4) .EQ. 'MU') THEN PAR(301) = FN(1) PAR(321) = PAR(301) * PAR(305) IPR(441) = 0 ELSE IF (IFL(1)(1:4) .EQ. 'RADI') THEN PAR(305) = FN(1) PAR(321) = PAR(301) * PAR(305) IPR(442) = 0 ELSE IF (IFL(1)(1:4) .EQ. 'TMIN') THEN PAR(304) = FN(1) ELSE IF (IFL(1)(1:4) .EQ. 'TMAX') THEN PAR(306) = FN(1) ELSE IF (IFL(1)(1:5) .EQ. 'L0MAX') THEN IPR(373) = NINT(FN(1)) ELSE IF (IFL(1)(1:5) .EQ. 'L1MAX') THEN IPR(374) = NINT(FN(1)) ELSE IF (IFL(1)(1:4) .EQ. 'NEXT') THEN CALL GGIP20 (0.0, 'Click on NEXT-STEP to PROCEED', 29, 1 0.60, 0, 2, 18.0, 1.5) CALL GGIP (0.0, 0.0, 0.0, 6) GOTO 39 ELSE IF (IFL(1)(1:4) .EQ. 'END ') THEN GOTO 830 ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN GOTO 830 ELSE GOTO 38 ENDIF CALL GGIP (0.0, 0.0, 0.0, 6) GOTO 35 ENDIF 39 CALL PLA269 (7) WRITE (LU7, 99983) N3REJ, SMIN1, SMAX1, N6REJ, N7REJ WRITE (LU7, 99986) SMIN, SMAX NL = 2 * ILM + 1 NK = 2 * IKM + 1 NKL = NK * NL DO 40 I = 1, IPR(372) READ (LU29, REC = I) J, K, L DATA(I) = (J + IHM) * NKL + (K + IKM) * NL + (L + ILM) 40 CONTINUE CALL GEN053 (IPR(372), DATA, INDEX) DO 50 I = 1, IPR(372) READ (LU29, REC = INDEX(I)) J, K, L, 1 IH, IK, IL, Y, SIGY, S0, S1 WRITE (LU30, REC = I) IH, IK, IL, Y, SIGY, S0, S1 50 CONTINUE CALL GEN108 (LU8, 0) IHKL = NINT(DATA(INDEX(1))) NMEAS = 1 INDEX(IPR(372) + 1) = IPR(372) + 1 DATA(IPR(372) + 1) = -999999.0 DO 70 I = 2, IPR(372) + 1 IF (DATA(INDEX(I)) .EQ. IHKL) THEN NMEAS = NMEAS + 1 ELSE IH = IHKL / NKL IK = (IHKL - IH * NKL) / NL IL = IHKL - IH * NKL - IK * NL IH = IH - IHM IK = IK - IKM IL = IL - ILM WRITE (LU8) NMEAS, IH, IK, IL DO 60 J = 1, NMEAS IREC = I - J READ (LU30, REC = IREC) IH, IK, IL, Y, SIGY, S0, S1 WRITE (LU8) IH, IK, IL, Y, SIGY, S0, S1 60 CONTINUE IHKL = NINT(DATA(INDEX(I))) NMEAS = 1 ENDIF 70 CONTINUE IPR(376) = 0 IPR(375) = 0 CHISQ = 0 SUMSQ = 0 CALL GEN108 (LU8, 1) CALL GEN108 (LU9, 0) 80 READ (LU8, END = 150) N DO 100 J = 1, N READ (LU8) IH, IK, IL, YJ, SIGYJ, S0, S1 YI(J) = YJ SIGYI(J) = SIGYJ DO 90 K = 1, 3 U0(K, J) = - S0(K) U1(K, J) = S1(K) 90 CONTINUE 100 CONTINUE IF (N .LT. 2) GOTO 80 S = GEN056 (IH, IK, IL, RBB) IF (S .LT. STLMIN .OR. S .GT. STLMAX) GOTO 80 DO 110 I = 1, N IF (YI(I) / SIGYI(I) .LT. FSQMIN .OR. YI(I) .GT. FSQMAX) 1 GOTO 80 110 CONTINUE CALL GEN053 (N, YI, INDEX) M = N / 2 IF (MOD(N, 2) .EQ. 0) THEN YMEDIAN = 0.5 * (YI(INDEX(M)) + YI(INDEX(M + 1))) ELSE YMEDIAN = YI(INDEX(M + 1)) ENDIF NDATA = 0 SUMW = 0 DO 120 I = 1, N AI = YI(I) / YMEDIAN IF (AI .LT. AIMIN .OR. AI .GT. AIMAX) THEN WI(I) = 0.0 ELSE WI(I) = 1.0 / (SIGYI(I)**2) SUMW = SUMW + WI(I) NDATA = NDATA + 1 ENDIF 120 CONTINUE IF (NDATA .LT. 2) GOTO 80 IPR(376) = IPR(376) + 1 IPR(375) = IPR(375) + NDATA WRITE (LU9) NDATA, SUMW DO 140 I = 1, N IF (WI(I) .GT. 0) WRITE (LU9) 1 (U0(III, I), III = 1, 3), 2 (U1(III, I), III = 1, 3), WI(I), YI(I) DI = 0 DO 130 J = 1, N YJ = - WI(J) * YI(J) / SUMW IF (J .EQ. I) YJ = YJ + YI(J) DI = DI + YJ 130 CONTINUE CHISQ = CHISQ + WI(I) * DI**2 SUMSQ = SUMSQ + WI(I) * YI(I)**2 140 CONTINUE GOTO 80 150 CALL PLA269 (16) WRITE (LU7, 99984) STLMIN, STLMAX, FSQMIN, FSQMAX, AIMIN, AIMAX, 1 IPR(375), IPR(376) PAR(322) = SQRT(CHISQ / SUMSQ) Z1 = SQRT(CHISQ / (IPR(375) - IPR(376))) WQ = 1.0 / PAR(322)**2 IPR(377) = 0 LMAX = MAX (IPR(373), IPR(374)) DO 160 L = 1, LMAX IF ((MOD(L, 2) .EQ. 0 .AND. L .LE. IPR(373)) .OR. 1 (MOD(L, 2) .EQ. 1 .AND. L .LE. IPR(374))) 2 IPR(377) = IPR(377) + 2 * L + 1 160 CONTINUE 170 IF (IPR(375) / IPR(377) .LT. 10) THEN IPR(377) = IPR(377) - (2 * LMAX + 1) IF (IPR(377) .LE. 0) THEN WRITE (PRBUF, 99975) WRITE (LU6, 99976) PRBUF WRITE (LU7, 99976) PRBUF GOTO 830 ENDIF LMAX = LMAX - 1 IF (IPR(373) .GT. LMAX) IPR(373) = IPR(373) - 2 IF (IPR(374) .GT. LMAX) IPR(374) = IPR(374) - 2 GOTO 170 ENDIF DO 190 I = 1, 80 BZ(I) = 0 DO 180 J = I, 80 AZ(I, J) = 0 180 CONTINUE 190 CONTINUE CALL GEN108 (LU9, 1) 200 READ (LU9, END = 290) N, SUMW DO 210 I = 1, N READ (LU9) (U0(J, I), J = 1, 3), (U1(J, I), J = 1, 3), 1 WI(I), YI(I) 210 CONTINUE DO 280 I = 1, N CALL GEN055 (YLM0, U0(1, I), IPR(373), IPR(374)) CALL GEN055 (YLM1, U1(1, I), IPR(373), IPR(374)) DO 220 K = 1, IPR(377) QI(K) = 0.5 * (YLM0(K) + YLM1(K)) XI(K) = 0.0 220 CONTINUE YII = 0 DO 250 J = 1, N YJ = - WI(J) * YI(J) / SUMW IF (J .EQ. I) YJ = YJ + YI(J) YII = YII + YJ CALL GEN055 (YLM0, U0(1, J), IPR(373), IPR(374)) CALL GEN055 (YLM1, U1(1, J), IPR(373), IPR(374)) DO 240 K = 1, IPR(377) XI(K) = XI(K) + YJ * 0.5 * (YLM0(K) + YLM1(K)) 240 CONTINUE 250 CONTINUE DO 270 K = 1, IPR(377) BZ(K) = BZ(K) - WI(I) * YII * XI(K) DO 260 L = K, IPR(377) AZ(K, L) = AZ(K, L) + WQ * QI(K) * QI(L) 1 + WI(I) * XI(K) * XI(L) 260 CONTINUE 270 CONTINUE 280 CONTINUE GOTO 200 290 DO 310 I = 1, IPR(377) - 1 DO 300 J = I + 1, IPR(377) AZ(J, I) = AZ(I, J) 300 CONTINUE 310 CONTINUE CALL GEN054 (IPR(377), 80, AZ, UZ, VZ) UMAX = 0 DO 320 I = 1, IPR(377) UMAX = MAX (UMAX, ABS(SNGL(UZ(I)))) 320 CONTINUE NZERO = 0 T = PAR(326) * UMAX DO 330 I = 1, IPR(377) IF (ABS(UZ(I)) .LT. T) THEN UZ(I) = 0 NZERO = NZERO + 1 ELSE UZ(I) = 1 / UZ(I) ENDIF 330 CONTINUE DO 350 I = 1, IPR(377) DO 340 J = 1, IPR(377) AZ(I, J) = 0 340 CONTINUE AZ(I, I) = UZ(I) 350 CONTINUE DO 380 I = 1, IPR(377) DO 370 J = 1, IPR(377) VA(I, J) = 0 DO 360 K = 1, IPR(377) VA(I, J) = VA(I, J) + VZ(I, K) * AZ(K, J) 360 CONTINUE 370 CONTINUE 380 CONTINUE DO 400 I = 1, IPR(377) - 1 DO 390 J = I + 1, IPR(377) T = VZ(I, J) VZ(I, J) = VZ(J, I) VZ(J, I) = T 390 CONTINUE 400 CONTINUE DO 430 I = 1, IPR(377) DO 420 J = 1, IPR(377) AZ(I, J) = 0 DO 410 K = 1, IPR(377) AZ(I, J) = AZ(I, J) + VA(I, K) * VZ(K, J) 410 CONTINUE 420 CONTINUE 430 CONTINUE DO 450 I = 1, IPR(377) ALM(I) = 0.0 DO 440 J = 1, IPR(377) ALM(I) = ALM(I) + AZ(I, J) * BZ(J) 440 CONTINUE 450 CONTINUE CHISQ = 0 SUMSQ = 0 AIMIN = 1E10 AIMAX = 0 SUMA = 0 SUMASQ = 0 CHISQA = 0 CALL GEN108 (LU9, 0) 460 READ (LU9, END = 510) N, SUMW DO 480 I = 1, N READ (LU9) (U0(J, I), J = 1, 3), 1 (U1(J, I), J = 1, 3), WI(I), YI(I) CALL GEN055 (YLM0, U0(1, I), IPR(373), IPR(374)) CALL GEN055 (YLM1, U1(1, I), IPR(373), IPR(374)) AI = 1 DO 470 K = 1, IPR(377) AI = AI + ALM(K) * 0.5 * (YLM0(K) + YLM1(K)) 470 CONTINUE YI(I) = YI(I) * AI AIMIN = MIN (AIMIN, AI) AIMAX = MAX (AIMAX, AI) SUMA = SUMA + AI SUMASQ = SUMASQ + AI**2 CHISQA = CHISQA + (AI - 1)**2 480 CONTINUE DO 500 I = 1, N DI = 0 DO 490 J = 1, N YJ = - WI(J) * YI(J) / SUMW IF (J .EQ. I) YJ = YJ + YI(J) DI = DI + YJ 490 CONTINUE CHISQ = CHISQ + WI(I) * DI**2 SUMSQ = SUMSQ + WI(I) * YI(I)**2 500 CONTINUE GOTO 460 510 AMEAN = SUMA / IPR(375) RMSDA = SQRT(SUMASQ / IPR(375) - AMEAN**2) ZY = SQRT(CHISQ / (IPR(375) - IPR(376) - IPR(377))) PAR(323) = SQRT(CHISQ / SUMSQ) ZA = SQRT(WQ * CHISQA / (IPR(375) - IPR(376))) RA = SQRT(CHISQA / SUMASQ) DO 520 I = 1, IPR(377) SIGALM(I) = ZY * SQRT(AZ(I, I)) 520 CONTINUE DO 540 I = 1, IPR(377) DO 530 J = I, IPR(377) IF (AZ(I, I) * AZ(J, J) .GT. 0) THEN IF (I .EQ. J) THEN T = 1 ELSE T = SNGL(AZ(I, J) / SQRT(AZ(I, I) * AZ(J, J))) ENDIF ELSE T = 0 ENDIF CORR(I, J) = T CORR(J, I) = T 530 CONTINUE 540 CONTINUE IF (IPR(377) .LT. 80) THEN DO 560 I = IPR(377) + 1, 80 ALM(I) = 0 SIGALM(I) = 0 DO 550 J = 1, 80 CORR(I, J) = 0 CORR(J, I) = 0 550 CONTINUE 560 CONTINUE ENDIF CALL PLA269 (-18) WRITE (LU7, 99996) NPAR = 0 N0 = '0' N01 = 0 N02 = 0 N03 = 0 SUMA = 0 DO 580 L = 1, MAX (IPR(373), IPR(374)) N0 = CHAR(ICHAR('0') + L) N1 = ' ' N2 = '0' J = 1 DO 570 M = -L, L IF ((MOD(L, 2) .EQ. 0 .AND. L .LE. IPR(373)) .OR. 1 (MOD(L, 2) .EQ. 1 .AND. L .LE. IPR(374))) THEN NPAR = NPAR + 1 ALX = ABS(ALM(NPAR)) / SIGALM(NPAR) CALL PLA269 (1) WRITE (LU7, 99995) NPAR, N0, N1//N2, ALM(NPAR), ALX IF (ALX .GE. 1) N01 = N01 + 1 IF (ALX .GE. 2) N02 = N02 + 1 IF (ALX .GE. 3) N03 = N03 + 1 SUMA = SUMA + ALX J = J + 1 N2 = CHAR(ICHAR('0') + J / 2) IF (MOD(J, 2) .EQ. 1) THEN N1 = '-' ELSE N1 = '+' ENDIF N0 = ' ' ENDIF 570 CONTINUE 580 CONTINUE IPR(377) = NPAR WRITE (LU7, 99989) N01, N02, N03, SUMA / IPR(377), NZERO, PAR(326) CALL PLA269 (0) WRITE (LU7, 99988) WRITE (LU7, 99987) WRITE (LU6, 99985) IPR(375), IPR(376), IPR(377), 1 Z1, PAR(322), ZY, PAR(323), ZA, RA WRITE (LU7, 99985) IPR(375), IPR(376), IPR(377), 1 Z1, PAR(322), ZY, PAR(323), ZA, RA WRITE (LU7, 99992) AIMIN, AIMAX, AMEAN, RMSDA IF (PAR(305) .EQ. 0) THEN AMAX = 1.0 / AIMIN IF (PAR(304) .LE. 0 .OR. AMAX .LE. 0) GOTO 620 ASPHERE = EXP(- PAR(301) * PAR(304)) / AMAX IF (ASPHERE .GE. 1) GOTO 620 IF (ASPHERE .LT. AMUR(12)) ASPHERE = AMUR(12) DO 600 J = 2, 12 IF (ASPHERE .GE. AMUR(J)) GOTO 610 600 CONTINUE 610 X = (LOG(AMUR(J)) - LOG(ASPHERE)) / 1 (LOG(AMUR(J)) - LOG(AMUR(J - 1))) PAR(305) = (FMUR(J) - X * (FMUR(J) - FMUR(J-1))) / PAR(301) ENDIF GOTO 630 620 PAR(301) = 0.0 630 CALL PLA191 (1, PAR(301) * PAR(305), YUNK) IPR(432) = 0 IF (NAUTO .EQ. 1) THEN CALL PLA200 (6, 1, 0, 0) CALL GGIP (0.0, 0.0, 0.0, 6) ENDIF PAR(315) = 999.0 PAR(317) = 0.0 PAR(319) = 999.0 PAR(320) = 0.0 SUMN = 0 SUMA = 0 SUMASQ = 0 SUMV = 0 IPRINT = 101 XIMAX = 0.0 CALL GEN108 (LU8, 0) CALL GEN108 (LU9, 0) CALL PLA269 (-2) WRITE (LU7, 99994) 660 READ (LU8, END = 800) N, JH, JK, JL IPRINT = IPRINT - 1 THETA = GEN056 (JH, JK, JL, RBB) * PAR(17) IF (ABS(THETA) .GT. 1.0) THEN WRITE(LU6, 99977) N, JH, JK, JL, THETA STOP 'ASIN() PROBLEM IN MULABS' ENDIF THETA = ASIN(THETA) DO 780 I0 = 1, N READ (LU8) JH, JK, JL, YJ, SIGYJ, S0, S1 CALL GEN055 (YLM0, S0, IPR(373), IPR(374)) CALL GEN055 (YLM1, S1, IPR(373), IPR(374)) A = 1 V = 0 DO 690 J = 1, IPR(377) A = A + ALM(J) * 0.5 * (YLM0(J) + YLM1(J)) YLMJ = 0.5 * (YLM0(J) + YLM1(J)) * SIGALM(J) DO 680 K = 1, IPR(377) YLMK = 0.5 * (YLM0(K) + YLM1(K)) * SIGALM(K) V = V + CORR(J, K) * YLMJ * YLMK 680 CONTINUE 690 CONTINUE A = MAX (A, AIMIN) A = MIN (A, AIMAX) PAR(319) = MIN (PAR(319), 1.0 / A) PAR(320) = MAX (PAR(320), 1.0 / A) CALL PLA191 (0, THETA, A0) V = (A0 / A)**2 * (V / A**2) SIGA = SQRT(V) A = A0 / A YJ = YJ / A SGYJ = SQRT(SIGYJ**2 + YJ**2 * V) / A WRITE (LU9) JH, JK, JL, YJ, SGYJ XIMAX = MAX (XIMAX, YJ) PAR(315) = MIN (PAR(315), A) PAR(317) = MAX (PAR(317), A) SUMN = SUMN + 1 SUMA = SUMA + A SUMASQ = SUMASQ + A**2 SUMV = SUMV + V IF (IPRINT .GT. 0) THEN IHH(I0) = JH IKK(I0) = JK ILL(I0) = JL YI(I0) = YJ*A SIGYI(I0) = SGYJ AII(I0) = A SAA(I0) = SIGA DO 770 J = 1, 3 U0(J, I0) = S0(J) U1(J, I0) = S1(J) 770 CONTINUE ENDIF 780 CONTINUE IF (IPRINT .GT. 0) THEN IF (N .GE. 2) THEN CALL GEN053 (N, YI, INDEX) ELSE INDEX(1) = 1 ENDIF CALL PLA269 (N + 1) WRITE (LU7, 99978) DO 790 I = 1, N J = INDEX(I) WRITE (LU7, 99993) IHH(J), IKK(J), ILL(J), 1 YI(J), YI(J) / AII(J), SIGYI(J), AII(J), SAA(J), 2 (U0(K, J), K = 1, 3), (U1(K, J), K = 1, 3) 790 CONTINUE ENDIF GOTO 660 800 CALL GEN108 (LU9, 1) CALL GEN108 (LU17, 0) IF (XIMAX .GT. 99999.0) THEN SCF = 99999.0 / XIMAX ELSE SCF = 1.0 ENDIF NOUT = 0 810 READ (LU9, END = 820) JH, JK, JL, YJ, SGYJ YJ = YJ * SCF SGYJ = SGYJ * SCF NOUT = NOUT + 1 WRITE (LU17, 99990) JH, JK, JL, YJ, SGYJ GOTO 810 820 WRITE (LU17, 99978) WRITE (LU6, 99991) PAR(315), PAR(317), NINP, NOUT CALL PLA269 (4) WRITE (LU7, 99991) PAR(315), PAR(317), NINP, NOUT IF (NAUTO .EQ. 1) GOTO 35 830 RETURN 99999 FORMAT ('MULABS - Empirical Correction for Absorption ', 1 'Anisotropy. [c.f. R.H. Blessing, Acta Cryst. (1995), A51,', 2 ' 33-38]', /, 132('='), /) 99998 FORMAT (3I4, 2F8.0, 4X, 6F8.5) 99997 FORMAT (/, 'Absorption Correction Variables:', /, 132('-'), 1 /, 'L0max = ',I2, 23X, 2 'Even Order Limit of Spherical Harmonic Expansion', 5X, 3 'Y(l,m); l = 0, Lmax; m = -l, +l', /, 'L1max = ', I2, 23X, 4 'Odd Order Limit ', /, 'mu =', F11.3, ' mm**-1', 8X, 5 'Linear Absorption Coefficient', /, 'Radius = ', F10.3, ' mm', 6 12X, 'Estimated Radius of "Equivalent" Spherical Crystal', /, 7 'Tmin = ', F10.3,' mm', 12X, 8 'Estimated Minimum Crystal Thickness', /, 'Tmax = ', F10.3, 9 ' mm', 12X, 'Estimated Maximum Crystal Thickness', /, * 'Umin = ', E10.3, 15X, 'Eigenvalue Filtering Factor') 99996 FORMAT ('Fitted Absorption Anisotropy Expansion ', 1 'Coefficients A(l, m)', /, 59('-'), //, 2 'FSQ(Corr) = FSQ(Meas) / A', //, 'A = A(0)/(1 + SUM(L=1,Lmax)', 3 ' Sum(M=-L,L) A(L, M)*[0.5*[Y(L, M)(-U0) + Y(L,M)(U1)]])', //, 4 'A(0) = A(Sphere)(mu*R, Theta)', //, 5 'Y(l,m)(U) = Y(l,m)(X, Y, Z)', //, 5 'Where X, Y, and Z are Components of Unit Vectors Along the', 6 ' Reverse Incident Beam,', /, 7 ' -U0, or the Diffracted Beam, U1, Referred to Crystal', 8 ' Fixed Cartesian (i.e., Orthonormal) Axes.', /, 9 ' In Other Words X, Y, and, Z are Direction Cosines of the ', * 'Beam Direction Vectors.', //, 1 ' I L M A(l,m) Abs(A)/Sigma(A)', /, 2 ' - - - ------ ---------------', /, 3 ' 0 0 0 1.0') 99995 FORMAT (I2, 4X, A, 1X, A, 2X, E10.3, F10.3) 99994 FORMAT (' H K L I(Obs) I(obs)/A Sig[I(obs)/A]', 1 ' A Sig(A) K0 and K1 Direction Cosines (Cartesian)', /, 2 132('-')) 99993 FORMAT (3I3, 3F12.2, 2F8.4, 2(1X, 3F8.4)) 99992 FORMAT (//, 1 'Statistics of Fitted Anisotropy Correction Factors, AHI:', /, 2 'Amin = ', F10.4, /, 3 'Amax = ', F10.4, /, 4 'Amean = ', F10.3, /, 5 'Rmsda = <(A - Amean)**2>**1/2 = ', F10.4) 99991 FORMAT (/, 1 ':: MIN Transmission =', F9.5, /, 2 ':: MAX Transmission =', F9.5, //, 3 '::', I8, ' Reflections on Input', /, 4 '::', I8, ' Reflections on Output', /) 99990 FORMAT (3I4, 2F8.2) 99989 FORMAT (//, 1 'N1 = ', I3, ' A(l,m) with abs(A)/Sigma(A) .GE. 1', /, 2 'N2 = ', I3, ' " " " .GE. 2', /, 3 'N3 = ', I3, ' " " " .GE. 3', //, 4 ' = ', E9.2, //, 5 'N0 = ', I3, 10X, 'Zeroed Pseudo-Parameters From EigenValue', 6 ' Filtering', /, 7 'Umin = ', E11.3, 2X, 'Minimum Permitted EigenValue Magnitude', 8 ' Expressed as Fraction of the Maximum EigenValue Magnitude') 99988 FORMAT ( 1 'Statistics-of-Fit for the A(l,m) Expansion Coefficients:', /, 2 56('-'), //, 'Total Residual', 8X, 'CHISQ = CHISQ(Y) + ', 3 'CHISQ(A)', //, 'Fit Residual', 10X, 'CHISQ(Y) = Sum(H) ', 4 'Sum(I=1,N) WHI*(YHI*AHI - )**2', /, 31X, 5 '= Sum(H) Sum(I=1,N) ', 6 'WHI*(YHI*AHI - Sum(J=1,N) WHJ*YHJ*AHJ/Sum(J=1,N) WHJ)**2', //, 7 'Restraint Residual CHISQ(A) = Sum(H) Sum(I=1,N) W*(AHI - 1)' 8 , '**2', //, 'Where here the AHI are Absorption Anisotropy ', 9 'Correction Factors, i.e., Reciprocal Transmission Factors,', /, * ' FSQ(Corr) = FSQ(Meas)*A', /, ' A = 0.5*(A(-U0) + A(U1))' 1 , /,' A(U) = 1 + Sum(L=1,Lmax) Sum(M=-L,L) A(L,M)*Y(L,M)(U)' 2 , // , 'The Terms in THE Fit Residual are Weighted by', /, 3 ' WHI = 1/Sigma(YHI)**2,', //, 4 'And the Restraint Residual has a Constant Weighting Factor', /, 5 ' W = 1.0/()**2>/),', //, 6 'Which Serves to Adjust the Restraint Residual to a Scale', 7 ' Comparable to the Fit Residual.', /) 99987 FORMAT ('Standardized Root-MeanSquare Error-of-Fit', 9X, 1 'Z = Sqrt(CHISQ(Y)/(NOBS - NHKL - NPAR))', //, 2 'Normalized Root-Mean-Square Error-of-Fit', 10X, 'RW =', 3 ' Sqrt(CHISQ(Y)/Sum(WHI*(YHI*AHI)**2))', //, 4 'Standardized Root-Mean-Square Restraint Residual ZA = ', 5 'Sqrt(CHISQ(A)/(NOBS - NHKL))', //, 6 'Normalized Root-Mean-Square Restraint Residual', 7 ' RA = Sqrt(Sum((AHI - 1)**2)/Sum(AHI**2))') 99986 FORMAT (/, 'Sin(Theta)/Lambda Limits of the Unique Data:', /, 1 'Smin = ', F7.3, ', Smax = ', F7.3, ' A(-1)', /) 99985 FORMAT (/, 'Numerical Statistics-of-Fit:', //, 'N(obs) = ', I6, 2' Measurements', /, 'N(hkl) = ', I6, ' Unique Reflections', /, 3'N(par) = ', I6, ' Coefficients A(l,m)', //, 'Z = ',F6.3, 4' RW = ', F7.4, ' For All AHI = 1 (N(par) = 0)', //, 5'Z = ', F6.3, ' RW = ', F7.4, 6' For the AHI From the Fitted A(L,M)', /, 'ZA = ', F6.3, 7' RA = ',F7.4) 99984 FORMAT (//, 'Reflection Data Selected for Empirical Absorption', 1 ' Fitting:', /, 59('-'), //, 2 'Minimum Permitted sin(Theta/Lambda', 10X, '=', F11.3, 3 ' Ang**-1', /, 'Maximum Permitted sin(Theta)/Lambda)', 8X, 4 '=', F11.3,' Ang**-1', //, 'Minimum Permitted FSQ/Sigma(FSQ)', 5 12X, '= ', E10.3, /, 'Maximum Permitted FSQ', 23X, '= ', E10.3, 6 //, 'Minimum Permitted FSQ(I)/FSQ(Sample Median) = ', E10.3, /, 7 'Maximum Permitted FSQ(I)/FSQ(Ssmple Median) = ', E10.3, //, 8 'Nobs = ', I10, ' Reflection Measurements Selected', /, 9 'Nhkl = ', I10, ' Unique Reflections Represented') 99983 FORMAT (/, 'N3 = ', I5, 6X, 1 '" " " " Sin(TH)/L', 2 ' .LT. SMIN1 = ',F5.3,' OR .GT. SMAX1 = ', F5.3, /, 'N6 =', 3 I6, 6X, '" " " " Sigma(Ymeas', 4 ') .LE. 0', /, 'N7 =', 5 I6, 6X, '" " " " Ymeas .LT.', 6 ' -4*Sigma(Ymeas)') 99982 FORMAT ('FSQMIN = ', F5.2, 20X, 'Minimum FSQ/Sigma(FSQ) ', 1 'for Measurements Used for YLM Fit', /, 2 'FSQMAX = ', E10.3, 3 15X, 'Maximum FSQ for Measurements Used for YLM Fit', /, 4 'STLMIN = ', F5.2, ' Ang**-1', 12X, 'Min Sin(Theta)/Lambda ', 5 'For Reflections Used for YLM Fit', /, 6 'STLMAX = ', F5.2, 7 ' Ang**-1', 12X, 'Max Sin(Theta)/Lambda for Reflections Used', 8 ' for YLM Fit', /, 9 'Amin = ', E10.3, 15X, * 'Minimum Expected Relative Transmission Factor', /, 1 'Amax = ', E10.3, 15X, 2 'Maximum Expected Relative Transmission Factor') 99981 FORMAT (/, 4X, 'Mu = 0.0 Only Transmission Anisotropy Factors,', 1 ' 0 < A < Amax, Amean Approximately 1, will be Calculated.') 99980 FORMAT (//,' Radius = 0 and TMIN = 0. only Transmission ', 1 'Anisotropy Factors, 1 - X < A < 1 + X, = 1, will be ', 2 'Calculated.') 99979 FORMAT (4X, 'If Radius .EQ. 0, and Tmin .GT. 0, Radius will ', 1 'be Estimated From', /, 5X, 'A(Sphere) = A(LIMIT)/A(MAX),', /, 2 5X, 'Where A(Limit) = Exp(-Mu*Tmin),', /, 3 5X, 'and A(MAX) is the Maximum Transmission Anisotropy ', 4 'Factor From the YLM Fitting.') 99978 FORMAT (1X) 99977 FORMAT (4I5, F10.3) 99976 FORMAT (A) 99975 FORMAT (':: Too Few Data to Fit Transmission Surface') END SUBROUTINE PLA188 (MODE, JB, JE) PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256, 1 NP38=125,NP39=30,NP45=2048) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /Q/ ICL, IFL(NP17) COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4, 1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS, 2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, 1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80, ISWS(NP22)*4, 2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, 3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, 4 CHSG*6, ZSPG*7, SPGRNM(4)*26 COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10), 1 NPSI CHARACTER TXT(3)*3 TXT(1) = 'Obs' TXT(2) = 'Cal' TXT(3) = 'Cor' DO 90 J = JB, JE 10 CALL PLA200 (MODE, 1, 0, 0) CALL GGIP (13.0, 12.0, 0.0, -3) CALL GGIP20 (0.0, 'Psi-Scan', 8, 0.6, 1, 2, 15.3, -11.5) CALL GGIP20 (0.0, '0', 1, 0.25, 1, 2, 12.0, -0.1) CALL GGIP20 (0.0, '270', 3, 0.25, 1, 2, -0.2, -11.3) CALL GGIP20 (0.0, '180', 3, 0.25, 1, 2,-12.1, 0.3) CALL GGIP20 (0.0, '90', 2, 0.25, 1, 2, -0.2, 11.4) DO 70 K = 1, 4 CALL GGIP (0.0, FLOAT(K), 0.0, 0) IF (K .GT. 1) THEN TEMP1 = 9999999.0 DO 20 I = 1, 36 IF (PSIS(I, K, J) .GE. 0.01) 1 TEMP1 = MIN (TEMP1, PSIS(I, K, J)) 20 CONTINUE IPERC = NINT(TEMP1 * 100.0) IPX = 0 YPL = 10.5 + 1.5 - K * 0.75 CALL GGIP20 (0.0, TXT(K - 1), 3, 0.5, -1, 2, 8.4, YPL) CALL GEN040 (IPERC, NQ1, IPX) CALL GGIP20 (0.0, NQ1, IPX, 0.5, -1, 2, 11.0, YPL) ENDIF DO 60 I = 1, 36 PSI = PSIS(I, 1, J) / GL(5) XPL = COS(PSI) YPL = SIN(PSI) XP = 6.0 YP = 6.0 DS = 0.1 * (K - 1) IF (K .GT. 1) THEN PSS = PSIS(I, K, J) IF (PSS .LT. 0.0) PSS = 0.0 XP = PSS * XP YP = PSS * YP ENDIF XPL = XPL * (XP + 5.0) YPL = YPL * (YP + 5.0) IF (K .GT. 1) THEN IF (I .EQ. 1) THEN XP0 = XPL YP0 = YPL GOTO 30 ENDIF CALL GGIP (XPL, YPL, 0.0, 2) ENDIF 30 YPL = YPL - DS CALL GGIP (XPL, YPL, 0.0, 3) IF (K .LE. 1) THEN XPL = XPL * (5.0 / 11.5) YPL = YPL * (5.0 / 11.5) CALL GGIP (XPL, YPL, 0.0, 2) GOTO 60 ENDIF DO 50 L = 1, 3, 2 DY = DS * (2 - L) DO 40 M = 1, 3, 2 DX = DS * (2 - M) * (2 - L) XPL = XPL + DX YPL = YPL + DY CALL GGIP (XPL, YPL, 0.0, 2) 40 CONTINUE 50 CONTINUE YPL = YPL + DS CALL GGIP (XPL, YPL, 0.0, 3) 60 CONTINUE IF (K .NE. 1) THEN CALL GGIP (XP0, YP0, 0.0, 2) CALL GGIP (0.0, 0.0, 0.0, 3) ENDIF 70 CONTINUE CALL GGIP (0.0, 1.0, 0.0, 0) DO 80 JJ = 1, 3 XPL = 5 + JJ * 2 CALL GEN040 (IHKLPS(JJ, J), NQ1, IPX) CALL GGIP20 (0.0, NQ1, IPX, 0.5, -1, 2, XPL, -11.5) 80 CONTINUE CALL GGIP (0.0, 0.0, 0.0, 3) CALL GGIP (0.0, 0.0, 0.0, -1) CALL PLA013 (0, 1) CALL PLA006 (0, IS) IF (IFL(1)(1:4) .EQ. 'PLOT') GOTO 10 IF (IFL(1)(1:4) .EQ. 'EXIT') GOTO 100 90 CONTINUE 100 RETURN END SUBROUTINE PLA189 PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16, 1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000, 2 NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9) COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38) COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4), 1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1), 2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7), 3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11), 4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44), 5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11), 6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8), 7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3), 8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6), 9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4), * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3), 1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3), 2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3), 3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3), 4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3), 5 RORO(3, 3), DXI(3), NCIF(20) COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, 1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, 2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31, 3 LU60, LU61, LU62, LU63, LU64, LU65 COMMON // JNSC(2, NP23), VOID(NPVD) COMMON /ISCR/ IHLP(21) COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10), 1 NPSI IHO = 0 IKO = 0 ILO = 0 NPSI = 0 MPSI = 0 KAS = 0 I1 = IHLP(IHLP(1) + 1) - 13 10 I1 = I1 + 14 V6(1) = VOID(I1) V6(2) = VOID(I1 + 1) V6(3) = VOID(I1 + 2) V2(1) = VOID(I1 + 5) * PAR(135) V3(1) = VOID(I1 + 6) * PAR(135) V2(2) = VOID(I1 + 7) * PAR(136) V3(2) = VOID(I1 + 8) * PAR(136) V2(3) = VOID(I1 + 9) * PAR(137) V3(3) = VOID(I1 + 10) * PAR(137) IH = NINT(V6(1)) IK = NINT(V6(2)) IL = NINT(V6(3)) IF (IH .LT. - 999.0) GOTO 30 CALL GEN002 (-2, ROR, V6, V8, XLNG) IF (IH .NE. IHO .OR. IK .NE. IKO .OR. IL .NE. ILO) THEN IF (NPSI .GT. 0 .AND. IHKLPS(4, NPSI) .LT. 37) THEN WRITE (LU6, 99999) IHO, IKO, ILO NPSI = NPSI - 1 IF (IHKLPS(4, NPSI + 1) .EQ. 2) GOTO 130 ENDIF IHO = IH IKO = IK ILO = IL MPSI = 1 IF (NPSI .EQ. 10) THEN WRITE (LU6, 99998) GOTO 30 ENDIF NPSI = NPSI + 1 IHKLPS(1, NPSI) = IH IHKLPS(2, NPSI) = IK IHKLPS(3, NPSI) = IL QM(1, 3) = V8(1) QM(2, 3) = V8(2) QM(3, 3) = V8(3) YUNKM = 2.0 QM(1, 2) = 0.0 QM(2, 2) = 0.0 QM(3, 2) = 0.0 IF (NPSI .EQ. 1) THEN DO 20 J = 1, 3 YUNK = GEN009(OR(1, J), V8) / 1 SQRT(GEN009(OR(1, J), OR(1, J))) IF (ABS(YUNK) .LT. YUNKM) THEN YUNKM = ABS(YUNK) KAS = J ENDIF 20 CONTINUE ENDIF QM(KAS, 2) = 1.0 CALL GEN008 (QM(1, 2), QM(1, 3), QM(1, 1), 1) CALL GEN008 (QM(1, 3), QM(1, 1), QM(1, 2), 1) CALL GEN005 (QM, DUMV) CALL GEN004 (DUMV, OR, OP(1, 1, NPSI)) ENDIF CALL GEN002 (2, OP(1, 1, NPSI), V2, V4, XLNG) CALL GEN002 (2, OP(1, 1, NPSI), V3, V5, XLNG) IF (V5(3) .LT. 0.99999) THEN PHI = ATAN2(V5(2), V5(1)) * GL(5) ELSE PHI = 0.0 ENDIF MPSI = MPSI + 1 PSIS(MPSI, 1, NPSI) = MOD(360.0 + PHI, 360.0) PSIS(MPSI, 2, NPSI) = VOID(I1 + 3) PSIS(MPSI, 3, NPSI) = VOID(I1 + 11) IHKLPS(4, NPSI) = MPSI GOTO 10 30 IF (NPSI .GT. 0) THEN DO 120 K = 1, NPSI MPSI = IHKLPS(4, K) 40 ICHANGE = 0 DO 60 J = 2, MPSI - 1 IF (PSIS(J, 1, K) .