      PROGRAM PLATON
C * START-OF-PLATON_PROGRAM
      CALL MAJOR_PLATON_LOOP
C * END-OF-PLATON_PROGRAM
      END PROGRAM PLATON
C **********************************************************************
C * THIS RESEARCH PROGRAM MAY BE USED FREE OF CHARGE FOR USE WITHIN THE*
C *  ACADEMIC COMMUNITY AND NOT FOR PROFIT WITHOUT EXPLICIT PERMISSION.*
C * COMMERCIAL USERS SHOULD APPLY BY FILLING OUT AN APPLICATION FORM.  *
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 * PLEASE REPORT ENCOUNTERED ISSUES TO ITS AUTHOR WITH ASSOCIATED DATA*
C **********************************************************************
C *                                                                    *
C *                 *******************************                    *
C *                 *    P L A T O N - 2 0 2 5    *                    *
C *                 *******************************                    *
C *                                                                    *
C *                     (C) 1980-2025 A.L.SPEK                         *
C *                                                                    *
C *                   UTRECHT UNIVERSITY, UTRECHT                      *
C *                        THE NETHERLANDS                             *
C *                                                                    *
C *                         a.l.spek@uu.nl                             *
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 *        MAC-OSX           ''       .............         2009       *
C *        RASPBERRY PI      ''       .............         2013       *
C *        INTEL NUC/UBUNTU  ''       .............         2016       *
C *        MAC-OS / M1 / M2  ''       .............         2020       *
C *                                                                    *
C **********************************************************************
C * The PLATON program includes a large collection of tools for the    *
C * analysis and validation of crystal structures.                     *
C * Examples are: checkCIF, SQUEEZE, ADDSYM, TwinRotMat, CALC, ORTEP   *
C *                                                                    *
C * References: A.L.Spek (2003). J. Appl. Cryst. 36, 7-13.             *
C *             A.L.Spek (2009). Acta Cryst. 65, 148-155.              *
C *             A.L.Spek (2015). Acta Cryst. C71, 9-18.                *
C *             A.L.Spek (2018). Inorg. Chim. Acta, 470, 232-237.      *
C *             A.L.Spek (2020). Acta Cryst. E76, 1-11.                *
C **********************************************************************
C *                                                                    *
C * PLATON is developed and maintained on the LINUX platform and       *
C * depends on the availability of a FORTRAN compiler and the          *
C * X-Windows Library whose functionality is accessed through a small  *
C * C language driver routine (xdrvr.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:  gfortran -o platon platon.f xdrvr.c -lX11           *
C * Run:           platon name.cif, name.res or name.spf               *
C *                                                                    *
C * PLATON compiles natively on the MS-WINDOWS-11/WLS2/UBUNTU platform.*
C *                                                                    *
C * An MS-WINDOWS-11 executable is available from Dr. Louis Farrugia   *
C *                                                                    *
C * see: http://platonsoft.nl for more details                         *
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 MULT. ENTRY DATA-FILE*
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 *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 d3)  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 SPF/            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 (ICHX)          I INCLUDE C-H...X BONDS                *
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 (SPF)           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. 5 Ang)   *
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 (SAV)           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        (FCAL)   I (HANDLE DISORDERED SOLVENT REGION)   *
C *           I (PROBE radius)  I                                      *
C *           I (PSTEP n)       I                                      *
C *           : (CYCLE n)       I                                      *
C *-----------I-----------------I--------------------------------------*
C *CALC FCF   I (GENERATE)      I CALCULATE STRUCTURE FACTORS          *
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/Ueq         I LIST UIJ or U(eq)                    *
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/ORTEP       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  <FILE # 1>            *
C * -------------------------------------------------------------------*
C *                                                                    *
C *   TITL  <  TEXT >                                                  *
C *   CELL  <LAMBDA, A, B, C, ALPHA, BETA, GAMMA>                      *
C *   CESD  <ST.DEV. A, B, C, ALPHA, BETA, GAMMA>                      *
C *   SPGR  <SPACE GROUP NAME>                                         *
C *   ATOM  <ATOM LABEL, X, Y, Z, POP, SIG(X),SIG(Y),SIG(Z),SIG(POP)>  *
C *   UIJ   <ATOM LABEL, U11, U22, U33, U23, U13, U12>                 *
C *   SUIJ  <ATOM LABEL, S(U11),S(U22),S(U33),S(U23),S(U13),S(U12)>    *
C *         OR FOR ISOTROPIC TEMPERATURE FACTOR                        *
C *   U     <ATOM LABEL, U, S(U)                                       *
C *                ETC. FOR NEXT ATOMS                                 *
C *                                                                    *
C *              E X A M P L E of freeformat .spf file                 *
C *              -------------------------------------                 *
C *                                                                    *
C *   TITL NICKEL COMPOUND C2/C                                        *
C *   CELL 0.71073 11.12 7.564 18.93 90 131.1 90                       *
C *   CESD .01 .005 .01 0 .1 0                                         *
C *   SPGR C2/C                                                        *
C *   ATOM NI  .123 .544 -.176 1 .001 .002 .001 0.0                    *
C *   UIJ  NI  .011 .013 .025 -.011 .004 .009                          *
C *   SUIJ NI  .001 .001 .002 .002 .002 .001                           *
C *   ATOM C1  .345 .675 -.334 1 .010 .009 .005 0.0                    *
C *   U    C1  0.04 .01                                                *
C *                       ETC. ETC.                                    *
C *                                                                    *
C **********************************************************************
C *                                                                    *
C *   A SHELX(L) INPUT FILE WITH ATOM PARAMETERS IS ALSO ACCEPTABLE    *
C *   CIF STRUCTURED FILES ARE ACCEPTABLE AS WELL                      *
C *                                                                    *
C **********************************************************************
C *                                                                    *
C *                        R E M A R K S                               *
C *                        - - - - - - -                               *
C * # 1  -  AN INPUT FILE CONTAINING THE KEYWORD FVAR IS INTERPRETED   *
C *         FOLLOWING THE CONVENTIONS OF SHELX                         *
C * # 2  -  SYMMETRY MAY BE SPECIFIED ALSO WITH LATT AND SYMM RECORDS  *
C *         FOLLOWING THE CONVENTIONS OF SHELX                         *
C * # 3  -  RECORDS THAT START WITH AN ATOM LABEL, FOLLOWED BY THREE   *
C *         NUMBERS ARE INTERPRETED AS ATOM RECORDS                    *
C * # 4  -  AN ATOMLABEL MAY CONTAIN THE SYMBOLS ' AND "               *
C * # 5  -  AN ATOMLABEL (EXCLUDING PARENTHESES CANNOT TAKE MORE THAN  *
C *         SEVEN POSITIONS                                             *
C *                                                                    *
C **********************************************************************
C *                    C A L C U L A T I O N S                         *
C *                    -----------------------                         *
C *                                                                    *
C *   CALC INTRA (OR GEOM)    - FOR INTRAMOLECULAR GEOMETRY            *
C *   CALC INTER              - FOR INTERMOLECULAR GEOMETRY            *
C *   CALC COORDN             - FOR COORDINATION   GEOMETRY (NON C,H)  *
C *   CALC METAL              - FOR METAL-DISTANCE SCAN                *
C *                                                                    *
C **********************************************************************
C *                                                                    *
C *     A D D I T I O N A L  S P E C I A L  I N S T R U C T I O N S    *
C *  ---------------------------------------------------------------   *
C *                   (SHOULD PRECEDE THE ITEMS TO OPERATE ON)         *
C *                                                                    *
C * ANGSTROM  (SCALE)        -  ANGSTROM SCALE (DEFAULT 1.0)           *
C * TRNS      -N.KLM         -  APPLY AND FIX (FIRST ATOM IN RESD.)    *
C * TRNS       N.KLM         -  APPLY AND FIX (NEXT ATOM ONLY)         *
C * TRNS      T11,T12,...T33 -  APPLY CELL AXES TRANSFORMATION         *
C *           (SH1,SH2,SH3)     (+ ORIGIN SHIFT)                       *
C *                                                                    *
C * FVAR                     -  SIGNALS SHELX PARAMETER STYLE          *
C *                                                                    *
C * LABEL    X  Y  Z         -  ALTERNATIVE ATOM PARAMETERS TYPE       *
C *                                                                    *
C **********************************************************************
C *                                                                    *
C *   S U B R O U T I N E  F U N C T I O N  D E S C R I P T I O N      *
C *   -----------------------------------------------------------      *
C * PLATON                                                             *
C *   PLATON - MAIN                                                    *
C *   MAJOR_PLATON_LOOP                                                *
C * PLATON MAJOR LOOP ROUTINES-----------------------------------------*
C *   PLA000 - (FILE) INIT, OPEN                                       *
C *   PLA001 - DATA INITIALIZATION                                     *
C *   PLA002 - DATA INPUT HANDLING                                     *
C *   PLA003 - ERROR REPORT AND HANDLING                               *
C *   PLA004 - (FILE) CLOSE/TERMINATE ROUTINE                          *
C * DATA --------------------------------------------------------------*
C *   PLA005 - HANDLE COMMAND LINE SWITCHES                            *
C *   PLA006 - READ ROUTINE FOR MOST FREE FORMATTED INPUT DATA         *
C *   PLA007 - SEARCH/LOAD ENTRY                                       *
C * DETERMINE REFLECTION FILE TYPE ------------------------------------*
C *   PLA008 - DETERMINE REFLECTION FILE TYPE (1)                      *
C *   PLA009 - DETERMINE REFLECTION FILE TYPE (2)                      *
C *   PLA010 - DETERMINE REFLECTION FILE TYPE (3)                      *
C * GUI'S -------------------------------------------------------------*
C *   PLA011 - MAIN MENU TOOL SELECTION   (NH,NV)                      *
C *   PLA012 - MENU - WHAT NEXT ?                                      *
C *   PLA013 - SET SUBMENU OPTIONS                                     *
C *   PLA014 - GET ITEM NEAREST TO CLICK POSITION                      *
C *   PLA015 - NOTIFICATION MESSAGES                                   *
C *   PLA016 - SIDE MENU -OPTIONS                                      *
C * -------------------------------------------------------------------*
C *   PLA017 - SPF or RES & Instruction reading                        *
C *   PLA018 - NEAREST ATOM POS TO CLICK POS                           *
C *   PLA019 - NEAREST ATOM + READ/ANSWER                              *
C *   PLA020 - HANDLE EVENTS ON CANVAS (AREA #1)                       *
C *   PLA021 - SUBROUTINE TO PLA002                                    *
C *   PLA022 - ATOM CARD HANDLING (CALLED FROM PLA002)                 *
C *   PLA023 - LOAD & EXPAND COORDINATE DATA                           *
C *   PLA024 - ANALYSES OF AN. TEMP. AND OUTPUT OF CONNECTED SET       *
C *   PLA025 - SUPPORT PLA024                                          *
C *   PLA026 - LISTING OF (AN)ISOTROPIC THERMAL PARAMETERS + SHELX     *
C * TLS ANALYSIS ------------------------------------------------------*
C *   PLA027 - TLS - ANALYSIS (1)                                      *
C *   PLA028 - TMA - ANALYSIS (2)                                      *
C *   PLA029 - TMA - ANALYSIS (3)                                      *
C * R/S DETERMINATION -------------------------------------------------*
C *   PLA030 - R/S DETERMINATION                                       *
C *   PLA031 - PATH SORT
C *   PLA032 - LABUTE TOPOLOGY NUMBER                                  *
C * -------------------------------------------------------------------*
C *   PLA033 - SUPPORT NEWMAN PROJECTION CALCULATIONS                  *
C *   PLA034 - GENERATION OF TORSION ANGLE LIST                        *
C *   PLA035 - ANALYSIS OF METAL-RING GEOMETRY                         *
C *   PLA036 - GET DISORDER INFORMATION IN NAMS(,,)                    *
C *   PLA037 - ANALYSIS OF ATOM LABEL FOR ATOM TYPE/SERIAL NR.         *
C *   PLA038 - GENERATE BONDS FROM CONN ARRAY                          *
C *   PLA039 - GENERATE ANGLES FROM CONN ARRAY                         *
C *   PLA040 - SUBROUTINE MANAGES CONN-ARRAY                           *
C *   PLA041 - SPECIAL ME..O,N ETC. TEST                               *
C *   PLA042 - LATTICE/SPGR HEADER                                     *
C *   PLA043 - SYMMETRY CODE LISTING                                   *
C *   PLA044 - ROTATION SUPPORT                                        *
C *   PLA045 - LS-PLANE HANDLING                                       *
C *   PLA046 - PACK ATOM LABEL                                         *
C *   PLA047 - UNPACK ATOM LABEL                                       *
C *   PLA048 - ANALYSE RING INTERACTIONS                               *
C *   PLA049 - SU (esd) CALCULATION SUPPORT                            *
C *   PLA050 - CALC DISTANCE, ANGLE OR TORSION                         *
C *   PLA051 - SET PARAMETERS FOR ESD CALCULATION                      *
C *   PLA052 - SET PARAMETERS FOR ESD CALCULATION (LS-PLANE)           *
C *   PLA053 - CALC DISTANCE, ANGLE OR TORSION WITH ESD                *
C *   PLA054 - CALCULATE LEAST-SQUARES PLANE FOR ATOMS IN IATP()       *
C *   PLA055 - LEAST-SQUARES PLANE CALCULATION (WITH ESD)              *
C *   PLA056 - ATOM TO PLANE DISTANCE (WITH SU)                        *
C *   PLA057 - OUTPUT OF SHORT CONTACT                                 *
C *   PLA058 - SAVE SYMMETRY OPERARATIONS FROM CIF                     *
C *   PLA059 - ORTHONORMALIZE                                          *
C *   PLA060 - ADDSYM-SYMMETRY CHECK (MAIN)                            *
C *   PLA061 - ADDSYM - SEARCH FOR AXES AND PLANES                     *
C *   PLA062 - ADDSYM-SYMMETRY CHECK (2)                               *
C *   PLA063 - ADDSYM-SYMMETRY CHECK (3)                               *
C *   PLA064 - ADDSYM-SYMMETRY CHECK (4)                               *
C *   PLA065 - ADDSYM-SYMMETRY CHECK (5)                               *
C *   PLA066 - ACCUMULATE SHORTEST INTERMOLECULAR CONTACTS             *
C *   PLA067 - SETUP OF CONNECTED SETS, INTER AND COORDN. SCANS        *
C *   PLA068 - J-LOOP IN PLA067                                        *
C *   PLA069 - HANDLING OF SHORT INTRA,INTER OR COORDN DISTANCES       *
C *   PLA070 - STORAGE CONNECTIONS
C *   PLA071 - SUPPORT PLA067 (FIX/MOVE)                               *
C *   PLA072 - GENERATE ATOMS FOR SYMMETRY RELATED UNITS               *
C *   PLA073 - OUTPUT OF ATOM TABLES                                   *
C *   PLA074 - OUTPUT OF CONNECTION TABLES                             *
C *   PLA075 - LIST LEAST-SQUARES PLANES                               *
C *   PLA076 - RING PUCKERING ANALYSIS LOOP                            *
C *   PLA077 - LIST INTRA GEOMETRY (BONDS, ANGLE, TORSION)             *
C *   PLA078 - GENERATE RINGS AND PLANES                               *
C *   PLA079 - ANALYSIS OF COORDINATION                                *
C *   PLA080 - COMPOSE CALCULATED COMPOSITION FORMULA                  *
C *   PLA082 - CHECK REPORTED AGAINST CALCULATED COMPOSITION FORMULAE  *
C *   PLA083 - CALCULATE THE PRINCIPLE AXES OF INERTIA FOR RESD NR     *
C *   PLA084 - COMPARE BONDS/ANGLES                                    *
C *   PLA085 - NON CRYSTALLOGRAPHIC SYMMETRY SEARCH                    *
C *   PLA086 - EXPECTED # REFLECTIONS                                  *
C *   PLA087 - SETS IN/EXCLUDE AND DO/AC FLAGS AND INIT FOR PLA067     *
C *   PLA088 - PREPARE ATOM SET (PART1)                                *
C *   PLA089 - H-BOND ANALYSIS                                         *
C *   PLA090 - H-BOND ANALYSIS (SUBR)                                  *
C *   PLA091 - (HYDROGEN BOND) CLUSTER/AGGREGATE ANALYSIS              *
C *   PLA092 - HYDROGEN BOND NETWORK ANALYSIS                          *
C *   PLA093 - SUPPORT PLA091                                          *
C *   PLA094 - NETWORK ANALYSIS                                        *
C *   PLA095 - RING PUCKERING ANALYSIS                                 *
C *   PLA096 - VALENCE BOND ANALYSIS                                   *
C *   PLA097 - TRANSLATE ARU TO SYMMETRY                               *
C *   PLA098 - CALCULATE AVERAGE BOND DISTANCES (+ BP)                 *
C *   PLA099 - ATOM CHARACTERISTICS                                    *
C *   PLA100 - CELL PARAMETERS AND ORTHOG. AXES SYSTEM CALCULATION     *
C * POLYEDER PLOT -----------------------------------------------------*
C *   PLA101 - POLYEDER PLOT (1)                                       *
C *   PLA102 - POLYEDER PLOT (2)                                       *
C *   PLA103 - POLYEDER PLOT (3)                                       *
C * ADP (ORTEP) PLOT --------------------------------------------------*
C *   PLA106 - ADP-MAIN                                                *
C *   PLA107 - SUPPORT ADP                                             *
C *   PLA108 - DRAW                                                    *
C * -------------------------------------------------------------------*
C *   PLA109 - PLOT SPECIAL TEXT                                       *
C *   PLA110 - PLOT BOX                                                *
C * -------------------------------------------------------------------*
C *   PLA111 - ALL (NEWMAN AND PLANE PLOTTING IS INITIATED HERE)       *
C *   PLA112 - SUPPORT PLA111                                          *
C * POWDER PATTERN CALCULATION AND DISPLAY MODULE ---------------------*
C *   PLA113 - POWDER PATTERN MAIN                                     *
C *   PLA114 - POWDER PATTERN - GENERATE REFLECTION DATA               *
C *   PLA115 - POWDER PATTERN PLOT                                     *
C * VOID SEARCH MODULE ------------------------------------------------*
C *   PLA118 - SOLV/VOID                                               *
C *   PLA119 - SOLV/VOID J-LOOP                                        *
C *   PLA120 - SOLV/VOID PROBE                                         *
C *   PLA121 - SOLV/EXPAND                                             *
C *   PLA122 - SOLVENT ACCESSIBLE VOLUME STATISTICS                    *
C *   PLA123 - SOLVENT ACCESSIBLE VOLUME DISPLAY                       *
C * SQUEEZE MODULE ----------------------------------------------------*
C *   PLA125 - SQUEEZE MAIN ROUTINE                                    *
C *   PLA126 - SQUEEZE SOLV GRID TO FFT GRID REMAPPING                 *
C *   PLA127 - SQUEEZE RESULTS (FAB-FILE & CIF-FORMATTED SQUEEZE INFO  *
C *   PLA128 - SQUEEZE REPORT (GRAPHICS)                               *
C *   PLA129 - SQUEEZE REPORT                                          *
C *   PLA130 - GET REFLECTIONS FOR SQUEEZE AND DIFF. MAP.              *
C *   PLA131 - HYBRID SHELXL/SQUEEZE LOOP                              *
C * REFLECTION DATA ---------------------------------------------------*
C *   PLA132 - HKL/FCF-READ                                            *
C *   PLA133 - DETERMINE HMAX, KMAX & LMAX                             *
C *   PLA134 - HKL - READ / TRANS                                      *
C *   PLA135 - READ REFLECTIONS & SFCALC FOR SQUEEZE/FCF               *
C *   PLA136 - HANDLE ASYMMETRIC UNIT                                  *
C *   PLA137 - STRUCTUREFACTOR - CALCULATION                           *
C *   PLA139 - FCF to HKL EXTRACTION                                   *
C * PEAK SEARCH IN FOURIER MAP ----------------------------------------*
C *   PLA140 - PEAK SEARCH                                             *
C *   PLA141 - FOURIER + PEAKS                                         *
C *   PLA142 - FOURIER + PEAKS                                         *
C *   PLA143 - DISTANCE CALCULATION                                    *
C * RADIAL DISTRIUTION FUNCTION----------------------------------------*
C *   PLA144 - RADIAL DISTRIBUTION FUNCTION                            *
C * ASYM --------------------------------------------------------------*
C *   PLA145 - ASYM - MAIN ROUTINE                                     *
C *   PLA146 - ASYM - SUPPORT                                          *
C *   PLA147 - ASYM - GUI                                              *
C *   PLA148 - ASYM - SUPPORT                                          *
C *   PLA149 - ASYM - HKL AVERAGING AND MULTIPLICITY                   *
C * EXOR --------------------------------------------------------------*
C *   PLA151 - SETUP EXOR.BIN/EXOR (1)                                 *
C *   PLA152 - SETUP EXOR.BIN/EXOR (2)                                 *
C *   PLA153 - SETUP EXOR.BIN/EXOR (3)                                 *
C *   PLA154 - SETUP EXOR.BIN/EXOR (4)                                 *
C * SHELXS86 STRIPPED VERSION FOR SYSTEM-S ----------------------------*
C *   PLA155 - SHX86 CRYSTAL STRUCTURE SOLUTION (MODIFIED FOR SYSTEM=S *
C *   PLA156 - SHX86 READ REFLECTION DATA, GENERATE AND SORT E-VALUE   *
C *   PLA157 - SHX86 DERIVE PHASE RELATIONS                            *
C *   PLA158 - SHX86 TANGENT REFINEMENT                                *
C *   PLA159 - SHX86 PARTIAL STRUCTURE EXPANSION                       *
C * FSPGR/NEWSYM ------------------------------------------------------*
C *   PLA160 - FSPGR/NEWSYM  (1)                                       *
C *   PLA161 - FSPGR/NEWSYM  (2)                                       *
C *   PLA162 - FSPGR/NEWSYM  (3)                                       *
C *   PLA163 - FSPGR/NEWMAN  (4)                                       *
C * LEPAGE ------------------------------------------------------------*
C *   PLA164 - LEPAGE (1)                                              *
C *   PLA165 - LEPAGE (2)                                              *
C *   PLA166 - LEPAGE (3)                                              *
C * -------------------------------------------------------------------*
C *   PLA167 - LAUE (1) - LAUE AVERAGES                                *
C *   PLA168 - LAUE (2)                                                *
C *   PLA169 - LAUE (3)                                                *
C *   PLA170 - LAUE (4)                                                *
C * TABLES ------------------------------------------------------------*
C *   PLA171 - TABLE (1)                                               *
C *   PLA172 - TABLE (2)                                               *
C *   PLA173 - TABLE (3)                                               *
C *   PLA174 - TABLE (4)                                               *
C *   PLA175 - TABLE (5)                                               *
C * CIF FILE READ------------------------------------------------------*
C *   PLA176 - MAIN CIF-READ                                           *
C *   PLA177 - CHECK FOR/EMBEDDED MATERIAL BETWEEN ;:                  *
C *   PLA178 - SAVE EMBEDDED MATERIAL BETWEEN ;;                       *
C *   PLA179 - DATANAME > VALUE                                        *
C *   PLA180 - HANDLE CELL/CIF                                         *
C *   PLA181 - HANDLE CIF BOND,ANGLE etc. LOOPS                        *
C *   PLA182 - HANDLE WEIGHT EXPRESSION                                *
C *   PLA183 - CALCULATE SIGIW                                         *
C *   PLA184 - INSPECT CONTENT RES FILE  (TWIN,SAME etc.)              *
C *   PLA185 - HANDLE CELL DATA                                        *
C * ABSORPTION CORRECTION----------------------------------------------*
C *   PLA186 - MANAGE ABSORPTION CORRECTION CALLS                      *
C *   PLA187 - XTAL                                                    *
C *   PLA188 - PSI-SCAN PLOT                                           *
C *   PLA189 - PSI-SCAN                                                *
C *   PLA190 - MULABS                                                  *
C *   PLA191 - Spherical Absorption Correction                         *
C * ABSGAUSS-----------------------------------------------------------*
C *   PLA192 - ABSGAUSS (1)                                            *
C * ABSTOMPA ----------------------------------------------------------*
C *   PLA193 - ABSTOMPA (1)                                            *
C *   PLA194 - ABSTOMPA (2)                                            *
C *   PLA195 - ABSTOMPA (3)                                            *
C *   PLA196 - ABSTOMPA (4)                                            *
C *   PLA197 - ABSTOMPA (5)                                            *
C * -------------------------------------------------------------------*
C *   PLA198 - GUI - Absorption Correction                             *
C * -------------------------------------------------------------------*
C *   PLA199 - CHECK DIRCOS                                            *
C *   PLA200 - CHECK DIRCOS                                            *
C *   PLA201 - ANALYSE CRYSTAL DESCRIPTION                             *
C * SHXABS ------------------------------------------------------------*
C *   PLA202 - SHXABS                                                  *
C * -------------------------------------------------------------------*
C *   PLA204 - Display NPP                                             *
C *   PLA205 - SHELXTPLOT                                              *
C *   PLA206 - LIST IPR / PAR / IGBL / RGBL / CHK                      *
C *   PLA207 - CAVITY                                                  *
C *   PLA208 - EXPAND TO P1                                            *
C *   PLA209 - RENDER3D PREP                                           *
C *   PLA210 - CHECK FOR NEW PLATON SOURCE/VERSION & DOWNLOAD          *
C * MOLSYM ------------------------------------------------------------*
C *   PLA211 - MOLSYM/WORK (1)                                         *
C *   PLA212 - MOLSYM/WORK (2)                                         *
C *   PLA213 - MOLSYM/WORK (3)                                         *
C *   PLA214 - MOLSYM/WORK (4)                                         *
C *   PLA215 - MOLSYM/WORK (5)                                         *
C *   PLA216 - MOLSYM/WORK (6)                                         *
C *   PLA217 - MOLSYM/WORK (7)                                         *
C * CONPUC (BOEYENS) --------------------------------------------------*
C *   PLA218 - CONPUC MAIN                                             *
C *   PLA219 - CONPUC (BOEYENS) (2)                                    *
C *   PLA220 - CONPUC (BOEYENS) (3)                                    *
C *   PLA221 - CONPUC (BOEYENS) (4)                                    *
C *   PLA222 - CONPUC (BOEYENS) (5)                                    *
C *   PLA223 - CONPUC (BOEYENS) (6)                                    *
C *   PLA224 - CONPUC (BOEYENS) (7)                                    *
C *   PLA225 - CONPUC (BOEYENS) (8)                                    *
C * -------------------------------------------------------------------*
C *   PLA226 - ORIENTATION PARAMETERS                                  *
C *   PLA227 - CALCULATE THE UNIT VECTOR ALONG IAT TO JAT              *
C *   PLA228 - AUTO-RENUMBER                                           *
C *   PLA229 - RENUMBER SUPPORT                                        *
C * CHECKCIF ----------------------------------------------------------*
C *   PLA230 - IUCR-CHECK (CIF-VALIDATION) - MAIN                      *
C *   PLA231 - IUCR-CHECK (CIF-VALIDATION) - REPORT ALERTS             *
C *   PLA232 - IUCR-CHECK (CIF-VALIDATION) (3)                         *
C *   PLA233 - IUCR-CHECK (CIF-VALIDATION) (4)                         *
C *   PLA234 - IUCR-CHECK (CIF-VALIDATION) - CREATE VRF RECORD         *
C *   PLA235 - IUCR-CHECK (CIF-VALIDATION) - DISPLAY RESULT            *
C *   PLA236 - IUCR-CHECK (CIF-VALIDATION) - COLLECT ALERTS            *
C *   PLA237 - IUCR-CHECK (CIF-VALIDATION) - OVERVIEW                  *
C * HELENA ------------------------------------------------------------*
C *   PLA240 - HELENA MAIN                                                    *
C *   PLA241 - HELENA (2)                                              *
C *   PLA242 - HELENA (3)                                              *
C *   PLA243 - HELENA (4)                                              *
C *   PLA244 - HELENA (5)                                              *
C *   PLA245 - HELENA (6)                                              *
C *   PLA246 - HELENA (7)                                              *
C *   PLA247 - HELENA (8)                                              *
C *   PLA248 - HELENA (9)                                              *
C *   PLA249 - HELENA (10)                                             *
C * CONTOUR -----------------------------------------------------------*
C *   PLA250 - DENSITY CONTOUR MAP (1)                                 *
C *   PLA251 - DENSITY CONTOUR MAP (2)                                 *
C *   PLA252 - DENSITY CONTOUR MAP (3)                                 *
C *   PLA253 - DENSITY CONTOUR MAP (4)                                 *
C *   PLA254 - DENSITY CONTOUR MAP (5)                                 *
C *   PLA255 - DENSITY CONTOUR MAP (6)                                 *
C *   PLA256 - DENSITY CONTOUR MAP (7)                                 *
C *   PLA257 - DENSITY CONTOUR MAP (8)                                 *
C *   PLA258 - DENSITY CONTOUR MAP (9)                                 *
C *   PLA259 - DENSITY CONTOUR MAP (10)                                *
C *   PLA260 - DENSITY CONTOUR MAP (11)                                *
C * -------------------------------------------------------------------*
C *   PLA261 - GET FILENAME ARGUMENT                                   *
C *   PLA262 - NEWPAGE HANDLING                                        *
C *   PLA263 - SUBSTITUTE                                              *
C * DELAUNEY REDUCTION-------------------------------------------------*
C *   PLA265 - DELAUNEY-REDUCTION                                      *
C * -------------------------------------------------------------------*
C * KRIVY & GRUBER CELL REDUCTION--------------------------------------*
C *   PLA266 - KRIVY & GRUBER MAIN                                     *
C *   PLA267 - KRIVY REDUCTIE                                          *
C * -------------------------------------------------------------------*
C *   PLA268 - BOND IN SCRATCH VOID LIST MANAGEMENT                    *
C *   PLA269 - SAVE/RESTORE XXO,XSD,CON FROM SCRAT                     *
C *   PLA270 - MULTIPLY SYMMETRY OPERATIONS                            *
C *   PLA271 - LAST MINUTE UPDATE                                      *
C *   PLA272 - CHECK BONDS, ANGLES, TORSIONS etc. IN CIF               *
C *   PLA273 - SAVE ORIGINAL SYMMETRY CODES SUPPLIED IN CIF            *
C *   PLA274 - LIST SYMMETRY                                           *
C * PACK/UNPACK CHECK.DEF ---------------------------------------------*
C *   PLA275 - PACK/UNPACK check.def (1)    [Created as/from]          *
C *   PLA276 - PACK/UNPACK check.def (2)    [ check.f / .def]          *
C *   PLA277 - PACK/UNPACK check.def (3)    [   by PLATON   ]          *
C * -------------------------------------------------------------------*
C *   PLA278 - GENERATE platon_special.f from platon.f                 *
C *   PLA279 - Descriptors for Octahedral and Tetrahedral Distort.     *
C *   PLA280 - AUTO INSTRUCTIONS                                       *
C *   PLA281 - ALIAS SUBSTITUTION                                      *
C *   PLA282 - ALIAS SUBSTITUTION (REGISTER & LISTING)                 *
C *   PLA283 - GENERATE MOIETY/RESIDUE/SUM STRING                      *
C * STRAIN ------------------------------------------------------------*
C *   PLA284 - STRAIN (1)                                              *
C *   PLA285 - STRAIN (2)                                              *
C * -------------------------------------------------------------------*
C *   PLA286 - RESET                                                   *
C *   PLA287 - SETUP CONNECTED SET(S)                                  *
C *   PLA288 - DEFINE BOND                                             *
C *   PLA289 - PLOT CICLE                                              *
C *   PLA292 - UNIT #2 FILE OPEN                                       *
C *   PLA293 - Check Wavelength                                        *
C *   PLA294 - CCDC/CQBATCH                                            *
C *   PLA295 - MANAGE MOL-LIST FOR ORTEP                               *
C *   PLA296 - PRINT/PLOT LINE                                         *
C *   PLA297 - (SUPPORT ROUTINE)                                       *
C *   PLA299 - LISTS SHORT MANUAL + HELP FUNCTION                      *
C *   PLA300 - GET WEBPAGE                                             *
C * STRUCTURE TIDY-----------------------------------------------------*
C *   PLA301 - Structure Tidy (1)                                      *
C *   PLA302 - Structure Tidy (2)   'BURZ'                             *
C *   PLA303 - Structure Tidy (3)                                      *
C *   PLA304 - Structure Tidy (4)                                      *
C *   PLA305 - Structure Tidy (5)                                      *
C *   PLA306 - Structure Tidy (6)                                      *
C *   PLA307 - Structure Tidy (7)   'TRA'                              *
C *   PLA308 - Structure Tidy (8)                                      *
C *   PLA309 - Structure Tidy (9)                                      *
C *   PLA310 - Structure Tidy (10)  'BEST'                             *
C *   PLA311 - Structure Tidy (11)                                     *
C *   PLA312 - Structure Tidy (12)                                     *
C *   PLA313 - Structure Tidy (13)                                     *
C *   PLA314 - Structure Tidy (14)                                     *
C *   PLA315 - Structure Tidy (15)                                     *
C *   PLA316 - Structure Tidy (16)                                     *
C *   PLA317 - Structure Tidy (17)                                     *
C *   PLA318 - Structure Tidy (18)                                     *
C *   PLA319 - Structure Tidy (19)                                     *
C *   PLA320 - Structure Tidy (20)                                     *
C *   PLA321 - Structure Tidy (21)                                     *
C *   PLA322 - Structure Tidy (22)                                     *
C *   PLA323 - Structure Tidy (23)                                     *
C *   PLA324 - Structure Tidy (24)                                     *
C *   PLA325 - Structure Tidy (25)                                     *
C *   PLA326 - Structure Tidy (26)                                     *
C *   PLA327 - Structure Tidy (27)                                     *
C * -------------------------------------------------------------------*
C *   PLA330 - transformation h,k,l (and Direction Cosines)            *
C * -------------------------------------------------------------------*
C *   PLA340 - ANOMALOUS SCATTERING AND ABSORPTION CONTRIBUTIONS       *
C * -------------------------------------------------------------------*
C *   PLA344 - TRANSFORM OLD STYLE SQUEEZE.HKL TO ORIG.HKL             *
C *   PLA345 - CIF2SHELXL                                              *
C *   PLA346 - Create FCF from SHELXLxy CIF OR COPY EMBEDDED FCF       *
C *   PLA347 - Create FCF from SHELXLxy CIF                            *
C *   PLA348 - SPGR EXERCISE ROUTINE                                   *
C *   PLA349 -                                                         *
C * CHARGE FLIPPING ---------------------------------------------------*
C *   PLA350 - Charge Flipping (1)                                     *
C *   PLA351 - Charge Flipping (2)                                     *
C *   PLA352 - Charge Flipping (3)                                     *
C *   PLA353 - Charge Flipping (4)                                     *
C *   PLA354 - Charge Flipping (5)                                     *
C *   PLA355 - Charge Flipping (6)                                     *
C * RDIFFERENCE MAP ---------------------------------------------------*
C *   PLA360 - Difference Map (1)                                      *
C *   PLA361 - Difference Map (2)                                      *
C *   PLA362 - Difference Map (3)                                      *
C *   PLA363 - Difference Map (4)                                      *
C * WILSON PLOT--------------------------------------------------------*
C *   PLA370 - WILSON PLOT ETC. (1)                                    *
C *   PLA371 - WILSON PLOT ETC. (2)                                    *
C *   PLA372 - WILSON PLOT ETC. (3)                                    *
C *   PLA373 - WILSON PLOT ETC. (4)                                    *
C *   PLA374 - WILSON PLOT ETC. (5)                                    *
C *   PLA375 - WILSON PLOT ETC. (6)                                    *
C *   PLA376 - WILSON PLOT ETC. (7)                                    *
C *   PLA377 - WILSON PLOT ETC. (8)                                    *
C *   PLA378 - WILSON PLOT ETC. (9)                                    *
C *   PLA379 - WILSON PLOT ETC. (10) - N(Z) PLOT                       *
C * -------------------------------------------------------------------*
C *   PLA381 - PDB-READ HANDLER                                        *
C *   PLA382 - LIST                                                    *
C *   PLA383 - SHELXL TYPE INPUT RECORDS                               *
C *   PLA384 - DETERMINE ORGANIC/INORGANIC/METALORGANIC                *
C * ANOMALOUS DISPERSION VALUES ---------------------------------------*
C *   PLA385 - ANOMALOUS DISPERSION VALUES (1)                         *
C *   PLA386 - ANOMALOUS DISPERSION VALUES (2)                         *
C *   PLA387 - ANOMALOUS DISPERSION VALUES (3)                         *
C * -------------------------------------------------------------------*
C *   PLA390 - PRE-GEOM LSPL REQUESTS                                  *
C *   PLA391 - REMOVE '_$1' FROM LABEL                                 *
C *   PLA392 - REMOVE ' ^'  FROM LABEL                                 *
C *   PLA393 - CREATE CIF-style SYMMETRY CODE                          *
C *   PLA394 - ACCESSIBLE SURFACE AREA (ASA) ROUTINE                   *
C *   PLA395 - CHECK FOR SPECIAL SHORT CONTACTS                        *
C *   PLA396 - MolVolume
C * MP-TOOL------------------------------------------------------------*
C *   PLA400 - MP TOOL (1)                                             *
C *   PLA401 - MP TOOL (2)                                             *
C *   PLA402 - MP TOOL (3)                                             *
C * ------------- Bijvoet/Twinning & Anal-of-Var MODULE ---------------*
C *   PLA410 - Setup                                                   *
C *   PLA411 - MARK                                                    *
C * ANALYSIS OF VARIANCE ----------------------------------------------*
C *   PLA412 - Analysis of Variance & Listing                          *
C *   PLA413 - Analysis of Variance Listing                            *
C * TWINROTMAT --------------------------------------------------------*
C *   PLA414 - TwinRotMat (1)                                          *
C *   PLA415 - TwinRotMat (2)                                          *
C *   PLA416 - TwinRotMat (3)                                          *
C *   PLA417 - TwinRotMat (4)                                          *
C *   PLA418 - TwinRotMat (5)                                          *
C * -------------------------------------------------------------------*
C *   PLA419 - Scatter Plot                                            *
C *   PLA420 - Diederichs Plot etc.                                    *
C * BIJVOET PAIR ANALYSIS----------------------------------------------*
C *   PLA421 - Bijvoet Pair Analysis (1)                               *
C *   PLA422 - Bijvoet Pair Analysis (2)                               *
C *   PLA423 - Bijvoet Pair Analysis (3)                               *
C *   PLA424 - Bijvoet Pair Analysis (4)                               *
C *   PLA425 - Bijvoet Pair Analysis (5)                               *
C *   PLA426 - Bijvoet Pair Analysis (6)                               *
C * -------------------------------------------------------------------*
C *   PLA427 - COMPARE TWO FCF FILES                                   *
C * -------------------------------------------------------------------*
C *   PLA428 - TEST FOR SHELXL20XY                                     *
C *   PLA429 - TEST FOR PLATON & SHELXL  ETC.                          *
C *   PLA430 - GET UPDATE VERSION DATE                                 *
C *   PLA431 - INIT GRAPHICS                                           *
C *   PLA432 - TRMX - GRAPHICS                                         *
C *              ...                                                   *
C *   PLA439 - PLOT STRING                                             *
C * INTERACTIVE GEOMETRY CALCULATIONS CALCULATIONS---------------------*
C *   PLA440 - INTERACTIVE DIST,ANGLE,TORSION & FIT CALCULATION        *
C *   PLA441 - FIT 1 2 ETC.                                            *
C * MOLFIT ROUTINES ---------------------------------------------------*
C *   PLA442 - MOLFIT(QUATERNION)                                      *
C *   PLA443 - BMFIT                                                   *
C * -------------------------------------------------------------------*
C *   PLA445 - LOAD SFAC & BOND_VALENCE DATA                           *
C *   PLA446 - LOAD CIF_DATA                                           *
C * -------------------------------------------------------------------*
C *   SPAWN                                                            *
C *   FINDEXE                                                          *
C *   PRINTX                                                           *
C *   TRAILER                                                          *
C **********************************************************************
C * THE ARRAY IFG(1, )  CONTAINS THE FOLLOWING BIT FLAGS               *
C * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -      *
C * BIT 1    - DONE FLAG (PLA067)                                      *
C * BIT 2    - FIX  FLAG (PLA067)                                      *
C * BIT 3    - NEXT FLAG (PLA067)                                      *
C * BIT 4    - (0/1) ATOM IS ISO/ANISOTROPIC                           *
C * BIT 5    - FLAG FOR SYMMETRY RELATED ATOM                          *
C * BIT 6    - FLAG FOR SPECIAL POSITION ATOM                          *
C * BIT 7    - HYDROGEN ATOM IDENTIFICATION BIT                        *
C * BIT 8    - (0/1) ATOM WITH MORE THAN 9 CONNECTIONS                 *
C * BIT 9 -14- 6-BIT VARIABLE IN PLA067(RES)                           *
C * BIT 15-18- ATOM TYPE NR IN IEN                                     *
C * BIT 19   - METAL                                                   *
C * BIT 20   - POTENTIAL H - BOND  H-ATOM                              *
C * BIT 21   - POTENTIAL DONOR ATOM (X-H)                              *
C * BIT 22   - ACCEPTOR ATOM                                           *
C * BIT 23   - DONOR/ACCEPTOR ATOM                                     *
C * BIT 24-27- HATOM CALCULATION / HYBRIDISATION  TYPE                 *
C * BIT 28-29- R/S CONFIGURATION                                       *
C * BIT 30   - OMIT  (FROM SFCalc)                                     *
C * BIT 31   - C(O2), N(O3), S(O4), Cl(O4), P(O4)                      *
C *                                                                    *
C * IFG(2, ) FLAGS                                                     *
C *                                                                    *
C * BIT  1- 8- POPULATION PARAMETER NR                                 *
C * BIT  9   - SPECIAL FIX-BIT                                         *
C * BIT 10   - ISU (0/1)                                               *
C * BIT 11   - LABEL (0/1)                                             *
C * BIT 12   - HINC  (0/1)                                             *
C * BIT 13   - B OR H (0/1)                                            *
C * BIT 14-23- LABUTE-VALUE                                            *
C * BIT 24-26- EFFECTIVE # ATTACHED H-ATOMS                            *
C * BIT 27   - EXCLUDE ATOM  (ORTEP/SOLV)                              *
C * BIT 28   - B-H (0/1)                                               *
C * BIT 29   - (0/1) POPULATION SU                                     *
C * BIT 30   - ATOM OMITTED                                            *
C * BIT 31   -                                                         *
C *                                                                    *
C * IFG(3, ) FLAGS                                                     *
C *                                                                    *
C * BIT  1   - d      FLAG (CALC)                                      *
C * BIT  2   - C(ALC) FLAG (CALC)                                      *
C * BIT  3   - DUM    FLAG (CALC)                                      *
C * BIT  4   - S      FLAG (REFINEMENT)                                *
C * BIT  5   - G      FLAG (REFINEMENT-GROUP)                          *
C * BIT  6   - R      FLAG (REFINEMENT-RIDING)                         *
C * BIT  7   - D      FLAG (REFINEMENT)                                *
C * BIT  8   - T      FLAG (REFINEMENT)                                *
C * BIT  9   - U      FLAG (REFINEMENT)                                *
C * BIT 10   - P      FLAG (REFINEMENT)                                *
C * BIT 11   - A      FLAG (DISORDER ASSEMBLY)                         *
C * BIT 12   - B      FLAG (DISORDER ASSEMBLY)                         *
C * BIT 13   - S      FLAG (DISORDER ASSEMBLY)                         *
C * BIT 14-18-        SHELXL-STYLE PART                                *
C *                                                                    *
C * BIT 25-27-        TOTAL # OF ATTACHED H-ATOMS                      *
C * BIT 28-31-        EFFECTIVE # OF BONDS FOR ATOM I                  *
C * PAR(565)= Pearson's CC           PAR(566)= SQUEEZE SCF             *
C * PAR(567)= FLOAT Z CALC           PAR(568)= FLOAT Z REPORTED        *
C * PAR(569)= MolVol GridStep        PAR(570)= RVMIN TERMINATE R (FLIP)*
C * PAR(571)= CAVITY PARAMETER       PAR(572)= STLMAX (SQUEEZE HKL)    *
 
      MODULE parameters
      SAVE
      INTEGER,             PARAMETER         :: NP12 = 790
      INTEGER,             PARAMETER         :: NP13 = 600
      INTEGER,             PARAMETER         :: NP15 = 20
      INTEGER,             PARAMETER         :: NP17 = 99
      INTEGER,             PARAMETER         :: NP36 = 5000
      INTEGER,             PARAMETER         :: NP38 = 150
      INTEGER,             PARAMETER         :: NP39 = 46
      INTEGER,             PARAMETER         :: NP45 = 2048
      INTEGER,             PARAMETER         :: NP59 = 100000
      INTEGER,             PARAMETER         :: NP64 = 12
      INTEGER,             PARAMETER         :: NP67 = 5000
      INTEGER,             PARAMETER         :: NP71 = 27
      INTEGER,             PARAMETER         :: NP73 = 18000
      INTEGER,             PARAMETER         :: NP75 = 100
      INTEGER,             PARAMETER         :: NP76 = 100
      INTEGER,             PARAMETER         :: NP77 = 100
      INTEGER,             PARAMETER         :: NP86 = 500
      INTEGER,             DIMENSION(NP12)   :: IPR
      INTEGER,             DIMENSION(NP38)   :: IGBL
      REAL                                   :: TPMTDM
      REAL                                   :: TOMTCM
      REAL,                DIMENSION(NP17)   :: FN
      REAL,                DIMENSION(NP13)   :: PAR
      REAL,                DIMENSION(NP39)   :: RGBL
      CHARACTER(len=NP45)                    :: ICL
      CHARACTER(len=NP64)                    :: NQ0
      CHARACTER(len=NP64)                    :: NQ1
      CHARACTER(len=NP64)                    :: NQ2
      CHARACTER(len=NP64)                    :: NQ3
      CHARACTER(len=NP64)                    :: NQ4
      CHARACTER(len=NP64)                    :: NQ5
      CHARACTER(len=NP64)                    :: NQ6
      INTEGER,             DIMENSION(NP59)   :: LABB
      CHARACTER(len=NP64), DIMENSION(NP17)   :: IFL
      CHARACTER(len=NP64), DIMENSION(9, 4)   :: NAMS
      CHARACTER(len=NP64), DIMENSION(NP36)   :: ALAB
      CHARACTER(len=NP64), DIMENSION(NP36)   :: BLAB
      CHARACTER(len=NP64), DIMENSION(NP36)   :: CLAB
      CHARACTER(len=NP64), DIMENSION(NP86)   :: PLAB
      CHARACTER(len=8),    DIMENSION(NP77,2) :: CISO
      END MODULE parameters
 
      SUBROUTINE MAJOR_PLATON_LOOP
C * MAJOR PLATON LOOP (MANAGED BY THE VALUE OF IGBL(1) = [-2,-1,0,1,2,3,4,5])
      USE parameters
C * SET TO STARTING WITH GLOBAL PROGRAM INIT
      IGBL(1) = -2
      DO
        SELECT CASE (IGBL(1))
C * -2 : GLOBAL INIT (IGBL & RGBL ARRAYS), GET COMMAND-LINE ARGUMENTS
C *      CHECK FOR ESCAPE MODES TO (S, HELENA, SHX86, STIDY & COMPARE HKL PLOT)
          CASE (-2)
            CALL PLA000
C * -1 : INIT & FILE OPEN
          CASE (-1)
            CALL PLA000
C *  0 : MANAGE INPUT DATA FILE LU1
          CASE (0)
            CALL PLA000
C * RESTART FOR NEW DATASET
          CASE (1)
            CALL PLA001
C * READ DATA AND INSTRUCTIONS & EXECUTE INSTRUCTIONS
          CASE (2)
            CALL PLA002
C * ERROR HANDLING (AND SUMMARY)
          CASE (3)
            CALL PLA003
C * CLOSE & TERMINATE PLATON RUN
          CASE (4)
            CALL PLA004 (0)
          CASE DEFAULT
C * EXIT
            EXIT
        END SELECT
      END DO
      RETURN
      END SUBROUTINE MAJOR_PLATON_LOOP
 
      MODULE files
      SAVE
      INTEGER, PARAMETER :: NVDR = 100000000   ! real    array VOID size
      INTEGER, PARAMETER :: NVDI = 100000000   ! integer ARRAY IAR  size
      INTEGER, PARAMETER :: NP23 = 28000
      INTEGER, PARAMETER :: NP74 = 28000
      INTEGER, PARAMETER :: NVDS = 100000000   ! shx86
      INTEGER, PARAMETER :: NVDL = 100000000   ! laue
      INTEGER            :: KXT
      INTEGER            :: KERR
      INTEGER            :: IOST = 0
      INTEGER            :: KNMXT
      INTEGER            :: KNM16
      INTEGER            :: KNMFIL = 6
      INTEGER :: LU1  =  1 ! INPUT OF PARAMETER DATA (CIF/RES/SPF etc)
      INTEGER :: LU2  =  2 ! OUTPUT OF PLATON DATA FOR SHELX(L) ETC.
      INTEGER :: LU3  =  3 ! SAVE(D) INSTRUCTION FILE (INTERNAL USE ONLY)
      INTEGER :: LU4  =  4 ! SCRATCH FILE (BINARY) ATOMIC PARAMETERS
      INTEGER :: LU5  =  5 ! INPUT OF CONTROL RECORD(S) FOR CALCN(S)
      INTEGER :: LU6  =  6 ! INTERACTIVE OUTPUT TO TERMINAL DISPLAY
      INTEGER :: LU7  =  7 ! LINEPRINTER OUTPUT
      INTEGER :: LU8  =  8 ! SCRATCH-BINARY FILE  (PLANES ETC)
      INTEGER :: LU9  =  9 ! REFLECTION SCRATCH (BINARY)
      INTEGER :: LU10 = 10 ! VALIDATION-LIST-OUTPUT  (SCRATCH IN HELENA)
      INTEGER :: LU11 = 11 ! CIF-DATA SCRATCH        (SCRATCH IN HELENA)
      INTEGER :: LU12 = 12 ! IUCR-CHECK-DEF (VALIDATION)
      INTEGER :: LU13 = 13 ! CKF-FILE (VALIDATION)
      INTEGER :: LU14 = 14 ! SCRATCH (ASYM) OR CHECK.SUM
      INTEGER :: LU15 = 15 ! SAV-FILE
      INTEGER :: LU16 = 16 ! REFLECTION DATA IN
      INTEGER :: LU17 = 17 ! REFLECTION DATA OUT (HKP)
      INTEGER :: LU18 = 18 ! REFLECTION DATA OUT (HKS)
      INTEGER :: LU19 = 19 ! BIN
      INTEGER :: LU20 = 20 ! SCRATCH (FORMATTED)
      INTEGER :: LU21 = 21 ! MODIFIED SHELXL.RES FILE
      INTEGER :: LU22 = 22 ! PLUTON.PJN
      INTEGER :: LU23 = 23 ! DEF-FILE
      INTEGER :: LU24 = 24 ! SHELXL(20xy) _sx.ins
      INTEGER :: LU25 = 25 ! SHELXL(20xy) _sx.hkl
      INTEGER :: LU26 = 26 ! SHELXL(20xy) _sx.fab
      INTEGER :: LU27 = 27 ! BINARY REFLECTION FILE
      INTEGER :: LU28 = 28 ! _iucr_fcf
      INTEGER :: LU60 = 60 ! (.RAS,.POV,.SUP,_ACC.CIF)
      INTEGER :: LU61 = 61 !
      INTEGER :: LU62 = 62 !
      INTEGER :: LU63 = 63 !
      INTEGER :: LU64 = 64 !
      INTEGER :: LU65 = 65 !
      INTEGER :: LU66 = 66 ! checkCIF VRF file
      INTEGER :: LU67 = 67 !
      INTEGER :: LU68 = 68 ! ALERT SCRATCH FILE
      INTEGER :: LU98 = 98 ! - GRAPHICS
      INTEGER                         :: INDP
      INTEGER                         :: ISAVEMOD = 0
      INTEGER,     DIMENSION(2, NP23) :: JNSC
      INTEGER,     DIMENSION(NP74)    :: JNSX
      INTEGER,     DIMENSION(25)      :: INDEXP
      REAL,        DIMENSION(NVDR)    :: VOID
      CHARACTER(len=8)                :: PAGET = '        '
      CHARACTER(len=20)               :: DATIJD
      CHARACTER(len=80)               :: FNLU16
      CHARACTER(len=255)              :: PLAPATH
      CHARACTER(len=80)               :: SHLPATH
      CHARACTER(len=80)               :: SHTPATH
      CHARACTER(len=255)              :: BROWSER
      CHARACTER(len=255)              :: CGETENV
      CHARACTER(len=40)               :: CURLPATH
      CHARACTER(len=80)               :: CHECKDEF =
     1                                 '/usr/local/lib/platon/check.def'
      CHARACTER(len=40)               :: HTTPSERVER =
     1                                   'https://www.platonsoft.nl/'
      CHARACTER(len=80)               :: INCLUDEFILE
      CHARACTER(len=8), DIMENSION(25) :: PAGEIND
      LOGICAL                         :: DOS = .FALSE.
      LOGICAL                         :: EXST
      LOGICAL                         :: OPEND
      LOGICAL                         :: EXST1
      LOGICAL                         :: EXST16
      LOGICAL                         :: EXST21
      LOGICAL                         :: EXST61
      END MODULE files
 
      MODULE plato
      SAVE
      INTEGER                                :: NDERIV
      INTEGER, PARAMETER                     :: NP1  = 20000
      INTEGER, PARAMETER                     :: NP2  = 99
      INTEGER, PARAMETER                     :: NP6  = 100
      INTEGER, PARAMETER                     :: NP7  = 50
      INTEGER, PARAMETER                     :: NP8  = 50
      INTEGER, PARAMETER                     :: NP11 = 128
      INTEGER, PARAMETER                     :: NP19 = 31
      INTEGER, PARAMETER                     :: NP25 = 99
      INTEGER, PARAMETER                     :: NP29 = 63
      INTEGER, PARAMETER                     :: NP41 = 200
      INTEGER, PARAMETER                     :: NP47 = 9
      INTEGER, PARAMETER                     :: NP62 = 250
      INTEGER, PARAMETER                     :: NP65 = 20
      INTEGER, PARAMETER                     :: MP7  = 256
      INTEGER                                :: MXNW
      INTEGER                                :: NETTYPE
      INTEGER, DIMENSION(NP11)               :: MP
      INTEGER, DIMENSION(NP1)                :: JR
      INTEGER, DIMENSION(NP1)                :: JCA
      INTEGER, DIMENSION(NP8, 5)             :: KBO
      INTEGER, DIMENSION(NP11)               :: MOL
      INTEGER, DIMENSION(3, NP1)             :: IFG
      INTEGER, DIMENSION(3)                  :: ITR
      INTEGER, DIMENSION(NP19)               :: NCN
      INTEGER, DIMENSION(NP19)               :: JLN
      INTEGER, DIMENSION(0:NP29)             :: NPOL
      INTEGER, DIMENSION(NP29)               :: MLTI
      INTEGER, DIMENSION(0:NP29)             :: MPOL
      INTEGER, DIMENSION(NP1)                :: IATP
      INTEGER, DIMENSION(NP1)                :: IATC
      INTEGER, DIMENSION(NP1)                :: LABA
      INTEGER, DIMENSION(NP1)                :: JATC
      INTEGER, DIMENSION(NP1)                :: IFNT
      INTEGER, DIMENSION(NP6, 2)             :: IBON
      INTEGER, DIMENSION(NP7)                :: IDIR
      INTEGER, DIMENSION(NP11)               :: MOLS
      INTEGER, DIMENSION(MP7, 3)             :: IPPR
      INTEGER, DIMENSION(8)                  :: IXPV
      INTEGER, DIMENSION(6)                  :: ISDV
      INTEGER, DIMENSION(6)                  :: IXSD
      INTEGER, DIMENSION(4, 3, 5)            :: LHNT
      INTEGER, DIMENSION(64, 3)              :: NETW
      INTEGER, DIMENSION((NP65 + 1) * 5)     :: NALV
      INTEGER, DIMENSION(NP1)                :: NTRNS
      INTEGER, DIMENSION(10)                 :: IDBUF
      INTEGER, DIMENSION(NP47)               :: NEWLAT
      INTEGER, DIMENSION(NP65)               :: JENTRY
      INTEGER, DIMENSION(3, NP62)            :: IHKLOMIT
      REAL,    DIMENSION(4)                  :: V1
      REAL,    DIMENSION(3)                  :: V2
      REAL,    DIMENSION(3)                  :: V3
      REAL,    DIMENSION(3)                  :: V4
      REAL,    DIMENSION(3)                  :: V5
      REAL,    DIMENSION(3)                  :: V6
      REAL,    DIMENSION(3)                  :: V7
      REAL,    DIMENSION(3)                  :: V8
      REAL,    DIMENSION(NP25)               :: RP
      REAL,    DIMENSION(2, 132)             :: DP
      REAL,    DIMENSION(3, 3)               :: AA
      REAL,    DIMENSION(3, 3)               :: BB
      REAL,    DIMENSION(3, 3)               :: QQ
      REAL,    DIMENSION(3, 3)               :: OR
      REAL,    DIMENSION(3, 3)               :: QM
      REAL,    DIMENSION(3, 3)               :: TM1
      REAL,    DIMENSION(3, 3)               :: TM2
      REAL,    DIMENSION(3, 3)               :: UIJ
      REAL,    DIMENSION(3, 3)               :: RIK
      REAL,    DIMENSION(3, 3)               :: UKL
      REAL,    DIMENSION(3)                  :: ORG
      REAL,    DIMENSION(6)                  :: DEV
      REAL,    DIMENSION(6)                  :: SDV
      REAL,    DIMENSION(8)                  :: XPV
      REAL,    DIMENSION(5)                  :: RMS
      REAL,    DIMENSION(NP1, 6)             :: XXO
      REAL,    DIMENSION(NP1, 6)             :: XSD
      REAL,    DIMENSION(NP1, 9)             :: CON
      REAL,    DIMENSION(10, NP2)            :: XLS
      REAL,    DIMENSION(NP8, 6)             :: BOK
      REAL,    DIMENSION(4, NP29)            :: RCG
      REAL,    DIMENSION(3, 5)               :: PAC
      REAL,    DIMENSION(10, 2)              :: SLN
      REAL,    DIMENSION(3, 3)               :: PAT
      REAL,    DIMENSION(3, 3)               :: ROR
      REAL,    DIMENSION(3, 3)               :: RAA
      REAL,    DIMENSION(3, 3)               :: RBB
      REAL,    DIMENSION(3, 3)               :: DAM
      REAL,    DIMENSION(3, 3)               :: RORO
      REAL,    DIMENSION(3, 3)               :: UIJC
      REAL,    DIMENSION(3, 3)               :: TRNS
      REAL,    DIMENSION(3, 3)               :: RMAT
      REAL,    DIMENSION(3, 3)               :: ADIR
      REAL,    DIMENSION(3, 3)               :: AINV
      REAL,    DIMENSION(15, NP41)           :: SXYZ
      REAL,    DIMENSION(2, 100)             :: YMOL
      REAL,    DIMENSION(10)                 :: DBUF
      REAL,    DIMENSION(6)                  :: DUMA
      REAL,    DIMENSION(3)                  :: SHFT
      REAL,    DIMENSION(8)                  :: XSPV
      REAL,    DIMENSION(8)                  :: VECN
      REAL,    DIMENSION(15)                 :: BASF
      REAL,    DIMENSION(NP1)                :: DATC
      REAL,    DIMENSION(NP1, 6)             :: ANIS
      REAL,    DIMENSION(NP1, 7)             :: SUAN
      REAL,    DIMENSION(NP7, 3, 4)          :: XDIR
      REAL,    DIMENSION(3, 155)             :: SCIR
      REAL,    DIMENSION(3, 3)               :: DUMV
      REAL,    DIMENSION(3)                  :: VECIJ
      REAL,    DIMENSION(3)                  :: VIEWV
      REAL,    DIMENSION(10)                 :: TWINF
      REAL,    DIMENSION(3)                  :: VECJK
      REAL,    DIMENSION(3)                  :: VECKL
      REAL,    DIMENSION(63)                 :: RCONT
      REAL,    DIMENSION(3, 3)               :: ORRES
      REAL,    DIMENSION(3, 3)               :: TRNSM1
      REAL,    DIMENSION(3, 3)               :: ROTM1
      REAL,    DIMENSION(3, 3)               :: ROTM2
      CHARACTER(len=1), DIMENSION(7)         :: CVLAG =
     1 (/'S', 'G', 'R', 'D', 'T', 'U', 'P'/)
      CHARACTER(len=5),  DIMENSION(NP65 + 1) :: BNDTP
      CHARACTER(len=13), DIMENSION(NP65 + 1) :: POISSON
      CHARACTER(len=60), DIMENSION(NP29)     :: RFORM
      END MODULE plato
 
      MODULE atomdata
      SAVE
      INTEGER, PARAMETER       :: NP9    = 119
      INTEGER, PARAMETER       :: NP10   = 16
      INTEGER, PARAMETER       :: NP10P1 = 17 ! = NP10 + 1
      INTEGER, PARAMETER       :: NP53   = 1632
      INTEGER                  :: IAN
      INTEGER                  :: ICLR
      INTEGER, DIMENSION(NP10) :: NWX
      INTEGER, DIMENSION(NP10) :: NOX
      INTEGER, DIMENSION(NP9)  :: IEL = (/
     1  800,  300, 1500, 1400,  312, 1900,  218, 1600,  900,  321,
     2 1409,  103,  107,  112,  113,  118,  119,  120,  121,  200,
     3  201,  205,  209,  211,  301,  304,  305,  306,  313,  315,
     4  318,  319,  400,  425,  518,  519,  521,  600,  605,  613,
     5  618,  701,  704,  705,  805,  806,  807,  815,  914,  918,
     6 1100, 1118, 1201, 1209, 1221, 1223, 1304, 1307, 1314, 1315,
     7 1401, 1402, 1404, 1405, 1415, 1416, 1519, 1601, 1602, 1604,
     8 1613, 1615, 1618, 1620, 1621, 1801, 1802, 1805, 1808, 1814,
     9 1821, 1902, 1903, 1905, 1909, 1913, 1914, 1918, 2001, 2002,
     * 2003, 2005, 2008, 2009, 2012, 2013, 2100, 2200, 2300, 2405,
     1 2500, 2502, 2614, 2618, 1819,  307, 2601, 2602, 2603, 1523,
     2 1700, 2400,  823, 2600, 1518, 1501, 1502, 1503, 1200/)
      INTEGER, DIMENSION(NP10) :: IEN =
     1  (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
      INTEGER, DIMENSION(NP10) :: IACL
C * H, C, O, N, ....
      INTEGER, DIMENSION(NP10) :: IBCL =
     1  (/17, 3, 6, 2, 5, 4, 1, 7, 8, 9, 0, 0, 0, 0, 0, 0/)
      INTEGER, DIMENSION(NP10) :: IENS
C * H, C, O, N, ....
      INTEGER, DIMENSION(NP10) :: JACL
     1  = (/17, 1, 2, 4, 3, 5, 6, 7, 8, 0, 0, 0, 0, 0, 0, 0/)
C * ELEMENT CHARACTERISTICS   (NEGATIVE = NONMETAL)
C * 2 = LANTHANIDE, 3 = ACTINIDE, 4 = TRANSITION, 5 = ALKALI
C * 6 = ALKALI EARTH, 7 = HALOGEN
      INTEGER, DIMENSION(NP9)        :: IATPR = (/
     1   -1,   -1,   -1,   -1,   -7,   -1,   -7,   -1,   -7,   4,
     2    4,    3,    4,    1,    3,   -1,   -1,   -7,    4,  -1,
     3    6,    6,    1,    3,    6,    4,    2,    3,    3,   4,
     4    4,    5,   -1,    2,    2,    3,    2,   -7,    4,   3,
     5    5,    1,    2,   -1,   -1,    4,    4,    2,    1,   4,
     6    5,   -1,    2,    5,    2,    3,    3,    6,    4,   4,
     7    5,    4,    2,   -1,    3,    3,    4,    3,    1,   4,
     8    2,    1,    2,    4,    3,    6,    5,    4,    4,  -1,
     9    4,    1,    4,   -1,   -1,    2,    1,    6,    4,   2,
     *    4,   -1,    3,    4,    1,    2,    3,    4,    4,  -1,
     1    4,    2,    4,    4,    8,   -8,    8,    8,    8,  -1,
     2   -1,   -1,   -1,   -1,    8,    8,    8,    8,    8/)
C * ATOM NUMBERS
      INTEGER, DIMENSION(NP9) :: IATNR = (/
     1    1,    6,    8,    7,   17,   16,   35,   15,   53,   29,
     2   28,   89,   47,   13,   95,   18,   33,   85,   79,    5,
     3   56,    4,   83,   97,   20,   48,   58,   98,   96,   27,
     4   24,   55,    1,   66,   68,   99,   63,    9,   26,  100,
     5   87,   31,   64,   32,    2,   72,   80,   67,   49,   77,
     6   19,   36,   57,    3,   71,  103,  101,   12,   25,   42,
     7   11,   41,   60,   10,  102,   93,   76,   91,   82,   46,
     8   61,   84,   59,   78,   94,   88,   37,   75,   45,   86,
     9   44,   51,   21,   34,   14,   62,   50,   38,   73,   65,
     *   43,   52,   90,   22,   81,   69,   92,   23,   74,   54,
     1   39,   70,   30,   40,    0,    0,    0,    0,    0,    8,
     2    6,    0,    1,    0,    0,    0,    0,    0,    0/)
      INTEGER, DIMENSION(NP10) :: IENLB
      INTEGER, DIMENSION(NP10) :: IDOAC =
     1 (/3, 4, 5, 6, 7, 8, 9, 38, 84, 110, 10, 2, 0, 0, 0, 0/)
      INTEGER, DIMENSION(NP9)  :: IVALMAX = (/
     1    9,    9,   -9,   -9,    9,    9,    9,    9,    9,   9,
     2    3,    9,    1,    9,    9,    9,    9,    9,    3,   9,
     3    9,    9,    9,    9,    9,    9,    9,    9,    9,   3,
     4    3,    9,    9,    9,    9,    9,    3,    9,    3,   9,
     5    9,    9,    9,    9,    9,    9,    9,    9,    9,   3,
     6    9,    9,    9,    9,    9,    9,    9,    9,    4,   9,
     7    9,    9,    9,    9,    9,    9,    9,    9,    9,   2,
     8    9,    9,    9,    2,    9,    9,    9,    9,    9,   9,
     9    3,    5,    9,    9,    9,    9,    9,    9,    9,   9,
     *    9,    9,    9,    4,    9,    9,    9,    5,    9,   9,
     1    9,    9,    9,    9,    9,    9,    9,    9,    9,   9,
     2    9,    9,    9,    9,    9,    9,    9,    9,    9/)
      REAL, DIMENSION(3, NP10) :: RGB = RESHAPE( (/
     1 0.625,  0.625,  0.625, 0.750,  0.050,  0.050,
     3 0.400,  1.000,  0.400, 0.125,  0.125,  1.000,
     5 1.000,  1.000,  0.000, 0.800,  0.200,  0.200,
     7 0.320,  0.200,  0.320, 0.660,  0.160,  0.160,
     9 0.000,  0.000,  0.000, 0.000,  0.000,  0.000,
     1 0.000,  0.000,  0.000, 0.000,  0.000,  0.000,
     3 0.000,  0.000,  0.000, 0.000,  0.000,  0.000,
     5 0.000,  0.000,  0.000, 0.000,  0.000,  0.000/), (/3, NP10/))
C * MU(A) BASED ON MU/RHO VALUES FROM INT. TABLES C - TABLE 4.2.4.2
C * - P 193-199 (CF. SHELXL97):(MU(A) = (MU/RHO) / (ATWEIGHT * 1.66043))
C * CuKa/GaKa/MoKa/AgKa/InKa
C * (For GaKa & InKa for elements 93-98: PROGRAM FPRIME)
C * INKA 0.51359
      REAL, DIMENSION(NP9, 5) :: AMR = RESHAPE( (/
     1       0.7,       6.6,      15.1,      10.0,     261.4,
     2     205.0,    4205.6,     158.3,    3172.3,    2108.0,
     3    1846.5,   24710.1,    1950.4,      89.6,   30292.1,
     4     328.8,    3398.2,   20776.6,   15698.2,       4.4,
     5    3985.2,       2.9,   18976.3,   19827.6,     499.4,
     6    2123.8,    4599.7,   20451.3,   27300.7,    1608.8,
     7    1023.3,    3702.8,       0.7,    7737.1,    8715.3,
     8       0.0,    6421.3,      22.5,    1393.1,       0.0,
     9   22672.8,    2702.1,    6837.3,    3037.1,       1.4,
     *   10924.6,   16482.2,    8215.5,    2308.6,   14211.2,
     1     407.5,    4651.1,    4282.6,       2.0,   10335.5,
     2       0.0,       0.0,      65.2,    1198.4,    7866.1,
     3      46.7,    7290.6,    5275.7,      32.9,       0.0,
     4   28091.4,   13504.9,   26829.2,   18122.5,    1788.3,
     5    5639.4,   19867.3,    4930.1,   14944.2,   28987.3,
     6   23668.4,    5121.5,   12823.5,   10003.8,   21712.9,
     7    9234.2,    2714.5,     605.9,    3788.7,     120.2,
     8    6021.3,    2505.5,    5633.8,   11535.2,    7281.1,
     9    8522.0,    2936.6,   25757.6,     727.5,   17290.7,
     *    9235.6,   27902.5,     865.7,   12169.0,    3423.3,
     1    6166.2,    9776.5,    2992.7,    6727.8,       0.0,
     2       0.0,       0.0,       0.0,       0.0,      15.1,
     3       0.0,       0.0,       0.7,       0.0,       0.0,
     4       0.0,       0.0,       0.0,       0.0,
C * AGKA 0.56086
     1 0.614E+00, 0.745E+01, 0.182E+02, 0.117E+02, 0.341E+03,
     2 0.267E+03, 0.535E+04, 0.206E+03, 0.409E+04, 0.271E+04,
     3 0.238E+04, 0.311E+05, 0.251E+04, 0.116E+03, 0.250E+05,
     4 0.429E+03, 0.433E+04, 0.262E+05, 0.199E+05, 0.479E+01,
     5 0.511E+04, 0.313E+01, 0.240E+05, 0.250E+05, 0.652E+03,
     6 0.273E+04, 0.588E+04, 0.289E+05, 0.246E+05, 0.207E+04,
     7 0.133E+04, 0.475E+04, 0.614E+00, 0.985E+04, 0.111E+05,
     8 0.000E+00, 0.819E+04, 0.277E+02, 0.180E+04, 0.000E+00,
     9 0.285E+05, 0.346E+04, 0.872E+04, 0.387E+04, 0.128E+01,
     * 0.139E+05, 0.209E+05, 0.104E+05, 0.297E+04, 0.180E+05,
     1 0.532E+03, 0.592E+04, 0.549E+04, 0.206E+01, 0.131E+05,
     2 0.000E+00, 0.000E+00, 0.842E+02, 0.155E+04, 0.115E+05,
     3 0.596E+02, 0.922E+04, 0.674E+04, 0.412E+02, 0.000E+00,
     4 0.299E+05, 0.171E+05, 0.342E+05, 0.229E+05, 0.230E+04,
     5 0.720E+04, 0.251E+05, 0.630E+04, 0.189E+05, 0.227E+05,
     6 0.298E+05, 0.652E+04, 0.162E+05, 0.210E+04, 0.273E+05,
     7 0.192E+04, 0.350E+04, 0.789E+03, 0.482E+04, 0.156E+03,
     8 0.768E+04, 0.323E+04, 0.715E+04, 0.146E+05, 0.927E+04,
     9 0.107E+05, 0.378E+04, 0.323E+05, 0.947E+03, 0.219E+05,
     * 0.117E+05, 0.350E+05, 0.112E+04, 0.154E+05, 0.441E+04,
     1 0.780E+04, 0.124E+05, 0.307E+04, 0.847E+04, 0.000E+00,
     2 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.182E+02,
     3 0.000E+00, 0.000E+00, 0.614E+00, 0.0      , 0.0      ,
     4 0.0      , 0.0      , 0.0,       0.0,
C * MOKA 0.71073
     1 0.624E+00, 0.115E+02, 0.325E+02, 0.196E+02, 0.678E+03,
     2 0.532E+03, 0.100E+05, 0.410E+03, 0.773E+04, 0.518E+04,
     3 0.457E+04, 0.540E+05, 0.476E+04, 0.229E+03, 0.189E+05,
     4 0.851E+03, 0.822E+04, 0.407E+05, 0.365E+05, 0.661E+01,
     5 0.965E+04, 0.383E+01, 0.438E+05, 0.201E+05, 0.129E+04,
     6 0.518E+04, 0.111E+05, 0.209E+05, 0.201E+05, 0.401E+04,
     7 0.258E+04, 0.898E+04, 0.624E+00, 0.184E+05, 0.207E+05,
     8 0.000E+00, 0.154E+05, 0.515E+02, 0.349E+04, 0.000E+00,
     9 0.322E+05, 0.660E+04, 0.163E+05, 0.738E+04, 0.134E+01,
     * 0.258E+05, 0.382E+05, 0.195E+05, 0.563E+04, 0.331E+05,
     1 0.105E+04, 0.110E+05, 0.104E+05, 0.228E+01, 0.244E+05,
     2 0.000E+00, 0.000E+00, 0.165E+03, 0.302E+04, 0.300E+04,
     3 0.116E+03, 0.273E+04, 0.127E+05, 0.786E+02, 0.000E+00,
     4 0.257E+05, 0.316E+05, 0.387E+05, 0.419E+05, 0.436E+04,
     5 0.135E+05, 0.458E+05, 0.119E+05, 0.348E+05, 0.162E+05,
     6 0.330E+05, 0.121E+05, 0.301E+05, 0.399E+04, 0.398E+05,
     7 0.364E+04, 0.662E+04, 0.156E+04, 0.911E+04, 0.310E+03,
     8 0.144E+05, 0.611E+04, 0.132E+05, 0.272E+05, 0.174E+05,
     9 0.332E+04, 0.716E+04, 0.370E+05, 0.186E+04, 0.401E+05,
     * 0.219E+05, 0.403E+05, 0.220E+04, 0.286E+05, 0.834E+04,
     1 0.143E+05, 0.231E+05, 0.586E+04, 0.247E+04, 0.000E+00,
     2 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.325E+02,
     3 0.000E+00, 0.000E+00, 0.624E+00, 0.0      , 0.0      ,
     4 0.0      , 0.0      , 0.0,       0.0,
C * GAKA 1.3414
     1       0.6,      57.1,     193.4,     109.9,    4162.2,
     2    3294.4,    7840.1,    2560.5,   41756.0,   28058.5,
     3   25038.0,   74252.0,   26090.1,    1447.9,   92420.1,
     4    5181.0,    6173.2,   61961.4,   46030.9,      26.6,
     5   51793.2,      11.0,   56254.7,  100049.1,    7678.0,
     6   28360.2,   59203.9,  102821.8,   95858.6,   22109.5,
     7   14773.5,   48349.0,       0.6,   95237.5,   67379.9,
     8       0.0,   80378.8,     317.7,   19450.3,       0.0,
     9   67977.1,    4786.5,   85155.2,    5448.7,       1.7,
     *   31510.4,   48465.2,   87267.5,   30756.5,   41453.6,
     1    6349.0,    8795.2,   55362.7,       4.2,   29737.4,
     2       0.0,       0.0,    1045.0,   17004.7,   16653.4,
     3     732.4,   15119.3,   67162.7,     494.0,       0.0,
     4   85439.3,   39295.1,   80981.3,   53590.1,   23961.5,
     5   71418.3,   59082.9,   63110.1,   43704.6,   88080.1,
     6   71084.4,    9820.1,   37233.7,   21950.7,   64939.0,
     7   20068.6,   35966.3,    9182.7,    6972.5,    1947.9,
     8   75832.4,   33293.6,   11104.2,   33349.3,   90317.2,
     9   18296.1,   38783.4,   77588.3,   10857.6,   50984.7,
     *   71284.4,   84399.8,   12716.4,   35261.7,   44918.3,
     1   12343.5,   75481.0,    4188.7,   13676.4,       0.0,
     2       0.0,       0.0,       0.0,       0.0,     193.4,
     3       0.0,       0.0,       0.6,       0.0,       0.0,
     4       0.0,       0.0,       0.0,       0.0,
C * CUKa 1.5418
     1 0.655E+00, 0.899E+02, 0.304E+03, 0.173E+03, 0.624E+04,
     2 0.497E+04, 0.118E+05, 0.388E+04, 0.607E+05, 0.547E+04,
     3 0.476E+04, 0.143E+06, 0.382E+05, 0.222E+04, 0.144E+06,
     4 0.772E+04, 0.929E+04, 0.865E+05, 0.669E+05, 0.415E+02,
     5 0.750E+05, 0.166E+02, 0.843E+05, 0.143E+06, 0.113E+05,
     6 0.415E+05, 0.857E+05, 0.150E+06, 0.138E+06, 0.314E+05,
     7 0.213E+05, 0.700E+05, 0.655E+00, 0.977E+05, 0.367E+05,
     8 0.000E+00, 0.110E+06, 0.498E+03, 0.280E+05, 0.000E+00,
     9 0.102E+06, 0.719E+04, 0.105E+06, 0.819E+04, 0.194E+01,
     * 0.460E+05, 0.668E+05, 0.347E+05, 0.450E+05, 0.624E+05,
     1 0.940E+04, 0.132E+05, 0.803E+05, 0.576E+01, 0.450E+05,
     2 0.000E+00, 0.000E+00, 0.161E+04, 0.246E+05, 0.246E+05,
     3 0.114E+04, 0.223E+05, 0.968E+05, 0.768E+03, 0.000E+00,
     4 0.123E+06, 0.580E+05, 0.106E+06, 0.798E+05, 0.352E+05,
     5 0.102E+06, 0.881E+05, 0.912E+05, 0.634E+05, 0.113E+06,
     6 0.102E+06, 0.148E+05, 0.572E+05, 0.323E+05, 0.972E+05,
     7 0.295E+05, 0.525E+05, 0.135E+05, 0.105E+05, 0.297E+04,
     8 0.108E+06, 0.486E+05, 0.165E+05, 0.485E+05, 0.847E+05,
     9 0.270E+05, 0.565E+05, 0.118E+06, 0.159E+05, 0.754E+05,
     * 0.393E+05, 0.112E+06, 0.185E+05, 0.513E+05, 0.652E+05,
     1 0.183E+05, 0.410E+05, 0.629E+04, 0.203E+05, 0.000E+00,
     2 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.304E+03,
     3 0.000E+00, 0.000E+00, 0.655E+00, 0.0      , 0.0      ,
     4 0.0      , 0.0      , 0.0,       0.0/), (/119, 5/))
C * COVALENT RADII
      REAL, DIMENSION(NP9) :: REL = (/
     1 0.35, 0.68, 0.68, 0.68, 0.99, 1.04, 1.21, 1.05, 1.60, 1.52,
     2 1.50, 1.88, 1.59, 1.35, 1.75, 0.00, 1.21, 0.00, 1.50, 0.83,
     3 1.34, 0.35, 1.72, 1.75, 0.99, 1.69, 1.83, 1.75, 1.75, 1.23,
     4 1.35, 1.67, 0.35, 1.75, 1.73, 1.75, 1.99, 0.64, 1.35, 1.75,
     5 0.00, 1.26, 1.79, 1.27, 0.00, 1.57, 1.70, 1.74, 1.63, 1.32,
     6 1.33, 0.00, 1.87, 0.68, 1.72, 1.75, 1.75, 1.10, 1.35, 1.47,
     7 0.97, 1.48, 1.81, 0.00, 1.75, 1.70, 1.50, 1.61, 1.97, 1.50,
     8 1.80, 1.68, 1.82, 1.50, 1.53, 1.90, 1.47, 1.60, 1.45, 0.00,
     9 1.50, 1.46, 1.44, 1.22, 1.20, 1.80, 1.65, 1.12, 1.43, 1.76,
     * 1.35, 1.49, 1.79, 1.47, 1.64, 1.72, 1.75, 1.33, 1.37, 1.40,
     1 1.78, 1.94, 1.45, 1.56, 0.00, 0.00, 0.00, 0.00, 0.00, 0.68,
     2 0.68, 0.00, 0.23, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00/)
      REAL, DIMENSION(NP10P1, 99) :: CONT
      REAL, DIMENSION(5)          :: STWL = (/
     1 1.5418, 1.3414, 0.71073, 0.56086, 0.51359/)
      REAL, DIMENSION(NP10, 4) :: RADR
      REAL, DIMENSION(NP10, 3) :: ANOM
      REAL, DIMENSION(2242)    :: SFAC
C * ATOMIC WEIGHTS (C12-IUPAC 1989) - HANDBOOK FOR PHYSICS & CHEMISTRY
C * UPDATED (IUPAC 1993) FROM Inorg. Chim. Acta 217 (1994) 217-218
      REAL, DIMENSION(NP9) :: ATWT = (/
     1   1.00794,    12.011,   15.9994, 14.00674,   35.4527,    32.06,
     2    79.904, 30.973762, 126.90447,   63.546,   58.6934, 227.0278,
     3  107.8682, 26.981539,    241.06,   39.948,  74.92159,   209.99,
     4 196.96654,    10.811,   137.327, 9.012182, 208.98037,   249.08,
     5    40.078,   112.411,   140.115,   252.08,    244.06, 58.93320,
     6   51.9961, 132.90543,     2.014,   162.50,    167.26,   252.08,
     7   151.965, 18.998403,    55.845,   257.10,    223.02,   69.723,
     8    157.25,     72.61,  4.002602,   178.49,    200.59, 164.9303,
     9    114.82,    192.22,   39.0983,    83.80,  138.9055,    6.941,
     *   174.967,    262.11,    258.10,  24.3050,  54.93805,    95.94,
     1 22.989768,  92.90638,    144.24,  20.1797,    259.10, 237.0482,
     2    190.23, 231.03588,     207.2,   106.42,    146.92,   209.98,
     3 140.90765,    195.08,     242.0, 226.0254,   85.4678,  186.207,
     4 102.90550,    222.02,    101.07,  121.757, 44.955910,    78.96,
     5   28.0855,    150.36,   118.710,    87.62,  180.9479, 158.9253,
     6    98.906,    127.60,  232.0381,   47.867,  204.3833, 168.9342,
     7  238.0289,   50.9415,    183.84,   131.29,  88.90585,   173.04,
     8     65.39,    91.224,       0.0,      0.0,     999.0,    999.0,
     9     999.0,   15.9994,      12.0,      0.0,   1.00794,      0.0,
     *       0.0,       0.0,       0.0,      0.0,       0.0/)
C * VAN DER WAALS RADII - A.BONDI, J.CHEM.PHYS.(1964),68,441-451.
C * OTHER ENTRIES FROM CCDC/MERCURY
C * NEGATIVE ENTRIES WERE ESTIMATED AS COVALENT RADIUS + 0.8 ANG.
      REAL, DIMENSION(NP9) :: VDWR = (/
     1 1.20, 1.70, 1.52, 1.55, 1.75, 1.80, 1.85, 1.80, 1.98, 1.40,
     2 1.63,-2.68, 1.72,-2.15,-2.31, 1.88, 1.85, 0.00, 1.66,-1.63,
     3-2.14,-1.15,-2.34,-2.55,-1.79, 1.58,-2.63,-2.55,-2.55,-2.03,
     4-2.15,-2.47, 1.20,-2.55,-2.53,-2.55,-2.79, 1.47,-2.14,-2.55,
     5 0.00, 1.87,-2.59,-1.97, 1.40,-2.37, 1.55,-2.54, 1.93,-2.12,
     6 2.75, 2.02,-2.67, 1.82,-2.52,-2.55,-2.55, 1.73,-2.15,-2.27,
     7 2.27,-2.28,-2.61, 1.54,-2.55,-2.35,-2.17,-2.41, 2.02, 1.63,
     8-2.60,-2.48,-2.62, 1.72,-2.33,-2.70,-2.27,-2.15,-2.25, 0.00,
     9-2.30,-2.26,-2.24, 1.90, 2.10,-2.60, 2.17,-1.92,-2.23,-2.56,
     *-2.15, 2.06,-2.59,-2.27, 1.96,-2.52, 1.86,-2.13,-2.17, 2.16,
     1-2.58,-2.74,-2.25,-2.36, 0.00, 1.80, 0.00, 0.00, 0.00, 1.52,
     2 1.70, 1.80, 1.20, 1.80, 0.00, 0.00, 0.00, 0.00, 0.00/)
      REAL, DIMENSION(NP10)    :: SATWT
      REAL, DIMENSION(NP10, 9) :: CIFSF
C * NEUTRON SCATTERING LENGTHS (NEUTRON DATA BOOKLET, 2003)
      REAL, DIMENSION(NP9) :: RNSCL = (/
     1 -3.7423, 6.6484,  5.805,  9.36, 9.5792,  2.847,   6.79,  5.13,
     2    5.28,  7.718,   10.3,   0.0,  5.922,  3.449,    8.3, 1.909,
     3    6.58,    0.0,   7.90,  5.30,   5.07,   7.79,  8.532,   0.0,
     4    4.70,   4.83,   4.84,   0.0,    9.5,   2.49,  3.635,  5.42,
     5   6.674,   16.9,   7.79,   0.0,    5.3,  5.654,   9.45,   0.0,
     6     0.0,  7.288,    9.5, 8.185,   3.26,   7.77, 12.595,  8.44,
     7   4.065,   10.6,   3.67,  7.81,   8.24,  -1.90,   7.21,   0.0,
     8     0.0,  5.375, -3.750, 6.715,   3.63,  7.054,   7.69, 4.566,
     9     0.0,  10.55,   10.7,   9.1,  9.401,   5.91,   12.6,   0.0,
     *    4.58,   9.60,    7.7,  10.0,   7.08,    9.2,   5.90,   0.0,
     1    7.02,   5.57,   12.1, 7.970, 4.1507,   0.00,  6.225,  7.02,
     2    6.91,   7.34,    6.8,  5.68,  10.31, -3.370,  8.776,  7.07,
     3   8.417, -0.443,  4.755,  4.69,   7.75,  12.41,  5.680,  7.16,
     4     0.0,    0.0,    0.0,   0.0,    0.0, 6.6484,    0.0,   0.0,
     5 -3.7423,    0.0,    0.0,   0.0,    0.0,    0.0,    0.0/)
C * AVERAGE ATOMIC VOLUME
C * (D.W.M.Hofmann (2002). Acta Cryst. B58, 489-493)
      REAL, DIMENSION(NP9) :: ATVOL = (/
     1 5.08,13.87,11.39, 11.8, 25.8, 25.2, 32.7, 29.5, 46.2, 26.9,
     2 26.0, 74.0, 35.0, 39.6, 17.0,  0.0, 36.4,  0.0, 43.0,13.24,
     3 66.0, 36.0, 60.0,  0.0, 45.0, 51.0, 54.0,  0.0,  0.0, 29.4,
     4 28.1, 46.0, 5.08, 50.0, 54.0,  0.0, 53.0,11.17, 30.4,  0.0,
     5  0.0, 37.8, 56.0, 41.6,  0.0, 40.0, 38.0, 42.0, 55.0, 34.3,
     6 36.0,  0.0, 58.0, 22.6, 35.0,  0.0,  0.0, 36.0, 31.9, 38.0,
     7 26.0, 37.0, 50.0,  0.0,  0.0, 45.0, 41.9, 60.0, 52.0, 35.0,
     8  0.0,  0.0,  0.0, 38.0,  0.0,  0.0, 42.0, 42.7, 31.2,  0.0,
     9 37.3, 48.0, 42.0, 30.3, 37.3, 50.0, 52.8, 47.0, 43.0, 45.0,
     * 38.0, 46.7, 56.0, 27.3, 54.0, 49.0, 58.0, 24.0, 38.8, 45.0,
     1 44.0, 59.0, 39.0, 27.0,  0.0,  0.0,  0.0,  0.0,  0.0,11.39,
     2  0.0,  0.0, 5.08,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0/)
      REAL, DIMENSION(NP10, 3) :: DISPVAL
C ********************************************************************
C * TABLE OF ELEMENT SYMBOLS KNOWN TO THE PROGRAM.                   *
C * THE ELEMENTS ARE GIVEN IN THE ORDER OF THE 11 MOST FREQUENTLY    *
C * OCCURRING, AND THEN ALPHABETICALLY.                              *
C * RS = RESIDUE, CG = RING CENTRE OF GRAV., ZA,ZB,ZC   : AUXILLARY  *
C * OW = OXYGEN ATOM OF WATER MOLECULE                               *
C ********************************************************************
      CHARACTER(len=2), DIMENSION(NP9) :: ELB = (/
     1  'H ', 'C ', 'O ', 'N ', 'Cl', 'S ', 'Br', 'P ', 'I ', 'Cu',
     2  'Ni', 'Ac', 'Ag', 'Al', 'Am', 'Ar', 'As', 'At', 'Au', 'B ',
     3  'Ba', 'Be', 'Bi', 'Bk', 'Ca', 'Cd', 'Ce', 'Cf', 'Cm', 'Co',
     4  'Cr', 'Cs', 'D ', 'Dy', 'Er', 'Es', 'Eu', 'F ', 'Fe', 'Fm',
     5  'Fr', 'Ga', 'Gd', 'Ge', 'He', 'Hf', 'Hg', 'Ho', 'In', 'Ir',
     6  'K ', 'Kr', 'La', 'Li', 'Lu', 'Lr', 'Md', 'Mg', 'Mn', 'Mo',
     7  'Na', 'Nb', 'Nd', 'Ne', 'No', 'Np', 'Os', 'Pa', 'Pb', 'Pd',
     8  'Pm', 'Po', 'Pr', 'Pt', 'Pu', 'Ra', 'Rb', 'Re', 'Rh', 'Rn',
     9  'Ru', 'Sb', 'Sc', 'Se', 'Si', 'Sm', 'Sn', 'Sr', 'Ta', 'Tb',
     *  'Tc', 'Te', 'Th', 'Ti', 'Tl', 'Tm', 'U ', 'V ', 'W ', 'Xe',
     1  'Y ', 'Yb', 'Zn', 'Zr', 'Rs', 'Cg', 'Za', 'Zb', 'Zc', 'Ow',
     2  'Q ', 'X ', 'Hw', 'Z ', 'Or', 'Oa', 'Ob', 'Oc', 'L '/)
      CHARACTER(len=2),  DIMENSION(NP10, 2) :: LMT
      CHARACTER(len=80), DIMENSION(25)      :: LREF
      CHARACTER(len=10), DIMENSION(NP10P1)  :: COLR = (/
     1 'BLACK     ', 'RED       ', 'GREEN     ', 'BLUE      ',
     2 'YELLOW    ', 'ORANGE    ', 'VIOLET    ', 'BROWN     ',
     3 'COPPER    ', 'BRASS     ', 'BRONZE    ', 'SILVER    ',
     4 'QUARTZ    ', 'GOLD      ', 'MICA      ', 'STEELBLUE ',
     5 'VOID      '/)
      CHARACTER(len=10), DIMENSION(NP10P1) :: BWCT = (/
     1 'CONTOUR   ', 'NET       ', 'SHADE     ', 'SEGMENT   ',
     2 'DOTS      ', 'BLACK     ', 'CROSS     ', 'GLOBE     ',
     3 'PARALLEL  ', 'MERIDIAN  ', 'HORIZONTAL', 'VERTICAL  ',
     4 'MESH      ', 'DIAGONAL  ', 'SLANT     ', 'TEXTILE   ',
     5 'VOID      '/)
      CHARACTER(len=4),  DIMENSION(5) :: CSTWL = (/
     1 'CuKa', 'GaKa', 'MoKa', 'AgKa', 'InKa'/)
      CHARACTER(len=18), DIMENSION(NP53) :: VALENCE
      CHARACTER(len=6),  DIMENSION(10)   :: VALENCES = (/
     1 '(I)   ', '(II)  ', '(III) ', '(IV)  ', '(V)   ',  '(VI)  ',
     2 '(VII) ', '(VIII)', '(IX)  ', '      '/)
      REAL, DIMENSION(832) :: PENG
      CHARACTER(len=2),  DIMENSION(NP10) :: DISPTYPE
      END MODULE atomdata
 
      MODULE cchar
      SAVE
      INTEGER,             PARAMETER       :: NP52 = 200
      INTEGER,             PARAMETER       :: NP56 = 72
      INTEGER,             PARAMETER       :: NP57 = 72
      INTEGER,             PARAMETER       :: NP85 = 22
      INTEGER                              :: NCIF23
      INTEGER,             DIMENSION(NP56) :: NCIF
      CHARACTER(len=80)                    :: IDM
      CHARACTER(len=80)                    :: JID
      CHARACTER(len=19)                    :: FMOL
      CHARACTER(len=80)                    :: LINE = '      '
      CHARACTER(len=4)                     :: KRAD
      CHARACTER(len=6)                     :: CHSG
      CHARACTER(len=7)                     :: ZSPG
      CHARACTER(len=NP52)                  :: CFORM
      CHARACTER(len=132)                   :: PRBUF
      CHARACTER(len=80)                    :: FNLU1
      CHARACTER(len=2)                     :: XLDTP
      CHARACTER(len=32)                    :: DATANM
      CHARACTER(len=5)                     :: LAUEGR
      CHARACTER(len=12)                    :: UPDATE = '            '
      CHARACTER(len=9)                     :: EXTENS = 'spf'
      CHARACTER(len=28)                    :: PROGNM
      CHARACTER(len=80)                    :: NAMEFIL = 'platon'
      CHARACTER(len=12)                    :: SPGRNAMF
      CHARACTER(len=NP57)                  :: CCIF23
      CHARACTER(len=2),    DIMENSION(8)    :: JTP = (/
     1 '--', 'LN', 'AN', 'TR', 'AK', 'AE', 'HL', '  '/)
      CHARACTER(len=10),   DIMENSION(250)  :: TKST
      CHARACTER(len=NP57), DIMENSION(NP56) :: CCIF
      CHARACTER(len=NP52), DIMENSION(0:5)  :: RLWS
      CHARACTER(len=5),    DIMENSION(5)    :: DTYPE = (/
     1 'SPF  ', 'RES  ', 'CIF  ', 'PDB  ', 'C3D  '/)
      CHARACTER(len=125),  DIMENSION(55)   :: GRAPH
      CHARACTER(len=26),   DIMENSION(4)    :: SPGRNM
      CHARACTER(len=12),   DIMENSION(3)    :: KRSYST
      CHARACTER(len=80),   DIMENSION(2)    :: FILENAMES
      CHARACTER(len=6),    DIMENSION(NP85) :: CNRH
      END MODULE cchar
 
      MODULE mentry
      SAVE
      INTEGER, PARAMETER                   :: NP54 = 250
      INTEGER, PARAMETER                   :: NP66 = 27
      INTEGER                              :: NKAR
      INTEGER,          DIMENSION(NP54, 4) :: IENTRY
      CHARACTER(len=75),   DIMENSION(NP54) :: CENTRY
      CHARACTER(len=7), DIMENSION(-1:NP66) :: RDTYP = (/
     1 'HKL-EXT', 'HKL    ', 'LIST4  ', 'XTAL-F ', 'NRCVAX ', 'MOLEN  ',
     2 'CRYSTL1', 'TEXSAN1', 'MOLEN1 ', 'CRYSTL2', 'JANA2  ', 'TEXSAN2',
     3 'XD     ', 'REALS  ', 'TEXSAN3', 'JANA1-F', 'RIGAKU ', 'JANA3  ',
     4 'CRYSTLT', 'CRYSTL3', '       ', '       ', 'LIST3  ', 'LIST5  ',
     5 'LIST6  ', 'LIST7  ', 'LIST8  ', 'REALS-F', 'JANA-TW'/)
      END MODULE mentry
 
      MODULE xwdw
      SAVE
      INTEGER :: LRET
      INTEGER :: IWIN = 0
      REAL    :: HRT
      REAL    :: VRT
      REAL    :: HORS
      REAL    :: VERT
      REAL    :: VRTS
      REAL    :: XSH0 = 0.0     ! GRAPHICS ORIGIN (CHANGED IN SYSTEM S)
      REAL    :: YSH0 = 0.0     ! GRAPHICS ORIGIN (CHANGED IN SYSTEM S)
      END MODULE XWDW
 
      MODULE cggt
      SAVE
      LOGICAL            :: CC   = .FALSE.
      INTEGER            :: NCNT = 0
      INTEGER            :: NCHE
      INTEGER            :: LMOD
      INTEGER            :: NPLOT
      INTEGER            :: MEDIUM
      REAL               :: CHT
      REAL               :: THET
      REAL               :: XGGIP = 0.0
      REAL               :: YGGIP = 0.0
      REAL               :: ZGGIP = 0.0
      CHARACTER(len=132) :: BCD   = 'P.L.A.T.O.N'//CHAR(0)
      CHARACTER(LEN=79)  :: T111
      CHARACTER(len=79)  :: T112
      CHARACTER(len=80)  :: IGGT = ' '
      CHARACTER(len=132) :: SBCD = ' '
      CHARACTER(len=100) :: STRING
      END MODULE cggt
 
      MODULE cif
      SAVE
      INTEGER,            PARAMETER        :: NP78 = 50
      INTEGER,            PARAMETER        :: NP70 = 122
      INTEGER,            PARAMETER        :: NP34 = 976
      INTEGER,            PARAMETER        :: NP58 = 50
      INTEGER,            PARAMETER        :: NKW  = 51
      INTEGER                              :: NL
      INTEGER                              :: KW
      INTEGER                              :: NW
      INTEGER                              :: NLPM
      INTEGER                              :: NHTP
      INTEGER                              :: KNUM
      INTEGER                              :: NSTR
      INTEGER                              :: ILOOP
      INTEGER                              :: IVOID
      INTEGER                              :: NSTRS
      INTEGER                              :: ISEMCOL = 0
      INTEGER                              :: IRECMAX
      INTEGER                              :: LRETCIF = 0
      INTEGER,          DIMENSION(4)       :: ICOUNT
      INTEGER,          DIMENSION(4)       :: JCOUNT
      INTEGER,          DIMENSION(4)       :: KCOUNT
      INTEGER,          DIMENSION(5)       :: IATYPE
      INTEGER,          DIMENSION(NP58)    :: NLP
      INTEGER,          DIMENSION(999)     :: NDOC
      INTEGER,          DIMENSION(3, NP78) :: NOMIT
      REAL,             DIMENSION(2)       :: FA
      REAL,             DIMENSION(12)      :: CELL
      CHARACTER(len=NP70)                  :: NWRD = ' '
      CHARACTER(len=NP70)                  :: NWRDS
      CHARACTER(len=5000)                  :: STRSAVE
      CHARACTER(len=1)                     :: TTYPE
      CHARACTER(len=4)                     :: VTYPE
      CHARACTER(len=1)                     :: CTYPE
      CHARACTER(len=1), DIMENSION(4)       :: WLEVEL =
     1 (/'G', 'C', 'B', 'A'/)
      CHARACTER(len=61),  DIMENSION(5)       :: ATYPE = (/
     1 'CIF Construction/Syntax Error, Inconsistent or Missing Data. ',
     2 'Indicator that the Structure Model may be Wrong or Deficient.',
     3 'Indicator that the Structure Quality may be Low.             ',
     4 'Improvement, Methodology, Query or Suggestion.               ',
     5 'Informative Message, Check.                                  '/)
      CHARACTER(len=62),  DIMENSION(4)    :: ALEVEL = (/
     1 'A = Most Likely a Serious Problem - Resolve or Explain        ',
     2 'B = A Potentially Serious Problem - Consider Carefully        ',
     3 'C = Check. Ensure it is Not caused by an Omission or Oversight',
     4 'G = General Info/Check that it is not Something Unexpected    '
     5 /)
      CHARACTER(len=NKW), DIMENSION(NP34) :: CIFDIR
      END MODULE cif
 
      MODULE ccom
      SAVE
      INTEGER, PARAMETER                  :: NP42 = 250
      CHARACTER(len=254)                  :: FNM
      CHARACTER(len=80)                   :: LINE
      CHARACTER(len=58)                   :: BDAT
      CHARACTER(len=40)                   :: FILE1
      CHARACTER(len=50)                   :: FILE3
      CHARACTER(len=10)                   :: COMPD = '          '
      CHARACTER(len=80)                   :: EDITOR
      CHARACTER(len=40)                   :: HELPATH
      CHARACTER(len=80)                   :: DATAORG
      CHARACTER(len=40)                   :: PSLASER
      CHARACTER(len=80)                   :: PROBLEM
      CHARACTER(len=254)                  :: WORKDIR
      CHARACTER(len=13)                   :: COMPDFL
      CHARACTER(len=254)                  :: USRPATH
      CHARACTER(len=40)                   :: SHSPATH
      CHARACTER(len=40)                   :: SHDPATH
      CHARACTER(len=40)                   :: DIRPATH
      CHARACTER(len=40)                   :: CRUPATH
      CHARACTER(len=80)                   :: PSVIEWER
      CHARACTER(len=40)                   :: SIR04PATH
      CHARACTER(len=40)                   :: SIR97PATH
      CHARACTER(len=40)                   :: SIR11PATH
      CHARACTER(len=10),  DIMENSION(99)   :: JFL
      CHARACTER(len=2),   DIMENSION(16)   :: SFC
      CHARACTER(len=200), DIMENSION(2)    :: LNKS
      CHARACTER(len=50),  DIMENSION(NP42) :: TSPGR
      CHARACTER(len=8),   DIMENSION(6)    :: SSTAT = (/
     1 'Create  ', 'Data_Red', 'Setup   ', 'PhaseDet', 'Refine  ',
     2 'Finish  '/)
      CHARACTER(len=10),  DIMENSION(4)    :: SSTATA = (/
     1 'Isotropic ', 'Aniso     ', 'Hatoms    ', 'Weight_Ref'/)
      CHARACTER(len=10),  DIMENSION(9)    :: SSTATB = (/
     1 'shelxs86  ', 'shelxs97  ', 'sir97     ', 'sir2004   ',
     2 'dirdif08  ', 'shelxd    ', '          ', 'shelxt    ',
     3 'sir2011   '/)
      END MODULE ccom
 
      MODULE sgxyz
      SAVE
      INTEGER             :: IERR
      REAL, DIMENSION(14) :: SGX
      REAL, DIMENSION(14) :: SGY
      REAL, DIMENSION(14) :: SGZ
      END MODULE sgxyz
 
      SUBROUTINE PLA000
C * IGBL(1) = -2 - GLOBAL INIT & ESCAPES FOR (S, HELENA, SHX86, STIDY, COMPARE)
C * IGBL(1) = -1 - INIT & FILE-OPEN
C * IGBL(1) =  0 - MANAGE INPUT DATA FILE ON UNIT LU1
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE mentry
      USE xwdw
      USE cggt
      USE cif
      IMPLICIT NONE
      INTEGER :: META = 1
      INTEGER :: IUNIT
      INTEGER :: ISWVAL = 0
      INTEGER :: IDATAFRM
      REAL    :: TREF
C * IGBL(1) = -2 : GLOBAL INIT
      IF (IGBL(1) == -2) THEN
C * INIT GLOBAL PARAMETERS
        CALL GEN097 (IGBL, 2, NP38,   0)
        CALL GEN074 (RGBL, 1, NP39, 0.0)
        NCIF23 = -1
        XLDTP  = '  '
C * SET PLATON VERSION DATE
        IGBL(4) = 020225
C * GET CURRENT DATE&TIME
        CALL DATE_TIME (DATIJD)
        PROGNM = 'PLATON-'//DATIJD
C * GET EMBEDDED check.def VERSION DATE (IGBL(20)
        CALL CHECK (0, IGBL(20))
C * LOAD SFAC & BOND_VALENCE DATA IN MODULE atomdata
        CALL PLA445
C * LOAD KNOWN CIF DATANAMES IN MODULE CIF
        CALL PLA446
C * CHECK For Access to External Programs (PLATON & SHELXL ETC.)
        CALL PLA429
C * SET DEFAULT GRAPHICS MODE (EITHER X11 or POSTSCRIPT)
C STRIP_END
        IF (META == 1) CALL GGIP (-999.0, 0.0, 0.0, -2)
C * INITIALIZE GLOBAL PARAMETERS
C * VERT SIZE 'SCREEN' (CM) - CONSISTENT WITH A4 FORMAT
        RGBL(1)  = 19.5
        VERT     = RGBL(1)
C * SCREEN RATIO
        RGBL(2)  = 4.0 / 3.0
        HORS     = VERT * RGBL(2)
C * 2PI (6.28...)
        RGBL(5)  = 8 * ATAN2 (1.0, 1.0)
C * RAD = 57.295779 DEGREES
        RGBL(6)  = 360.0 / RGBL(5)
C * 2 * PI**2
        RGBL(7)  = RGBL(5)**2 / 2.0
C * 8 * PI**2
        RGBL(8)  = 4.0 * RGBL(7)
C * DelFromInputCrit
        RGBL(25) = 1.0
C * Min-Q-PEAK-Height
        RGBL(26) = 0.4
C * Min-Q-Peak-Dist
        RGBL(27) = 0.5
C * XROT
        RGBL(28) = 0.0
C * YROT
        RGBL(29) = 0.0
C * ZROT
        RGBL(30) = 0.0
C * ADDSYM ORGANIC PARAMETERS
        RGBL(31) = 0.25
        RGBL(32) = 0.45
        RGBL(33) = 0.45
C * ADDSYM INORGANIC DEFAULTS
        RGBL(34) = 0.25
        RGBL(35) = 0.25
        RGBL(36) = 0.25
C * ADDSYM (ALERT LEVEL) TOL
        RGBL(37) = 0.15
        RGBL(38) = 0.15
        RGBL(39) = 0.15
        RGBL(40) = 20.0
C * H-BOND DEFAULTS
        RGBL(41) = 0.5
        RGBL(42) = -0.12
        RGBL(43) = 100.0
        RGBL(44) = 0.5
        RGBL(45) = -0.12
        RGBL(46) = 100.0
C * SET MENU ON
        IGBL(25) = 1
C * SET ATOM SORT ON
        IGBL(33) = 1
C * SET AUTO-PLOT ON
        IGBL(35) = 1
C * SEARCH INCLUDES DI-HYDROGEN BONDS
        IGBL(56) = 1
C * WINDOW SIZE
        IGBL(62) = 4
C * SET PRINT LEVEL(S)
        IGBL(63) = 4
        IGBL(64) = 4
C * LPS OFF
        IGBL(70) = 0
C * 110 color (yellow/orange)
        IGBL(82) = 1
C * CHECK-DOC ON
        IGBL(83) = -1
C * DIP (LIGHT/HEAVY)
        IGBL(89) = 5
C * TOP CIF ETC. ENTRY LIST
        IGBL(86) = NVDR - 6
C * DEFAULT # OF L.S. CYCLES FOR SHELXL201n FCF CREATION
        IGBL(93) = 3
C * MAX + 1 LINES/PAGE
        IGBL(102) = 51
C * BOX (DECORATION) ON
        IGBL(103) = 1
C * KEEP (0/1) P21/n & I2/n
        IGBL(106) = 1
C * PAGEHEADER
        IGBL(137) = 1
C * INIT ERROR DOC COUNT
        CALL GEN097 (NDOC, 1, 999, 0)
C * BLANK LINES
        CALL GEN038 (LINE, 1, 80)
        CALL GEN038 (IDM,  1, 80)
        CALL GEN038 (ICL,  1, 80)
C * INIT REFLECTION ENTRY LIST
        CALL GEN097 (IENTRY, 1, NP54 * 4, 0)
C * RUN OVER SWITCHES AND ARGUMENTS
        CALL PLA005 (-1, ISWVAL)
C * SPECIAL ESCAPE OPTIONS
        SELECT CASE (IGBL(3))
C * ESCAPE TO COMPARE TWO FCF REFLECTION SETS '-d' and '-J'
          CASE (6, 47)
            CALL PLA427
          CASE (11)
C * ESCAPE TO 'BMFIT' TOOL ('platon -b1') - DATA on FILE.1, FILE.2, FILE.7
            IF (ISWVAL == 1) THEN
              WRITE (LU6, 99996)
              LINE = 'mol'
              CALL PLA443 (LINE)
              CALL SPAWN ('platon -p mol_bm.res', LU6, .true., KERR)
              STOP
C * ESCAPE TO MP TOOL ('platon -b2 MP1.ins')
            ELSE IF (ISWVAL == 2) THEN
              WRITE (LU6, 99995)
              CALL PLA400
            ELSE
C * SET NEXT MAIN LOOP PARAMETER
              IGBL(1) = -1
            END IF
C STRIP_END
C * ESCAPE TO 'NATIVE' STIDY MODE (-Y)
          CASE (39)
            CALL GEN038 (JID,  1, 80)
            CALL PLA301 (0)
C * SET NEXT MAIN PLATON LOOP PARAMETER
            IGBL(1) = 4
          CASE DEFAULT
C * SET NEXT MAIN PLATON LOOP PARAMETER
            IGBL(1) = -1
        END SELECT
C * IGBL(1) = -1: INIT & FILE OPEN MODE
      ELSE IF (IGBL(1) == -1) THEN
C * INIT GRAPHICS
        CALL PLA431
        CALL GEN038 (IGGT, 1, 80)
C * CHANNEL FOR SAVED INSTRUCTIONS
        OPEN (UNIT = LU3, STATUS = 'SCRATCH', FORM = 'FORMATTED')
C * OPEN LU21, LU22, LU23
        OPEN (UNIT = LU21, FILE = NAMEFIL(1:KNMFIL)//'_pl.res',
     1                            STATUS = 'UNKNOWN', IOSTAT = IOST)
        OPEN (UNIT = LU22, FILE = NAMEFIL(1:KNMFIL)//'.pjn',
     1                            STATUS = 'UNKNOWN', IOSTAT = IOST)
        OPEN (UNIT = LU23, FILE = NAMEFIL(1:KNMFIL)//'.def',
     1                            STATUS = 'UNKNOWN', IOSTAT = IOST)
C * CHECK FOR CONTENTS OF PLUTON-DEF-FILE
        READ (LU23, 99998, IOSTAT = IOST) ICL(1:80)
C * CHECK FOR/DELETE PLATON GENERATED .DEF
        IF (IOST == 0) THEN
          IF (INDEX (ICL, 'CREATED') /= 0) THEN
            CALL GEN108 (LU23, 0)
            ENDFILE (LU23, IOSTAT = IOST)
            IGBL(23) = 0
          ELSE
            IGBL(23) = 1
          END IF
        END IF
        CALL GEN108 (LU23, 0)
C * EXECUTE & ESCAPE FOR EXPLICIT PLUTON MODE ONLY
C *  8 - PLUTON/NATIVE '-p'
C * 12 - PLUTON/RENAME
C * 13 - PLUTON/HFIX
C * 26 - PLUTON/ANIS
        IF (IGBL(3) ==  8 .OR.
     1      IGBL(3) == 12 .OR.
     2      IGBL(3) == 13 .OR.
     3      IGBL(3) == 26) THEN
          CALL PLUTON (-1)
C * SET RETURN CODE TO 'TERMINATE'
          IGBL(1) = 4
        ELSE
C * CIF DATA SCRATCH (SYMM, BOND, ANGLE ETC.
          OPEN (UNIT = LU11, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1         IOSTAT = IOST)
C * CALL EXIT/STOP
          IF (IOST /= 0) CALL GEN127 ('OPEN ERROR FILE LU11')
C * REDIRECT CONSOLE-OUTPUT for -u & -V (-W) validation modes
          IF (IGBL(3) == 1 .OR. IGBL(3) == 33 .OR.
     1        IGBL(3) == 34) LU6 = LU20
          OPEN (UNIT = LU4, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1         IOSTAT = IOST)
C * CALL EXIT/STOP
          IF (IOST /= 0) CALL GEN127 ('OPEN ERROR FILE LU4')
          OPEN (UNIT = LU8, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1         IOSTAT = IOST)
C * CALL EXIT/STOP
          IF (IOST /= 0) CALL GEN127 ('OPEN ERROR FILE LU8')
          OPEN (UNIT = LU9, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1         IOSTAT = IOST)
C * CALL EXIT/STOP
          IF (IOST /= 0) CALL GEN127 ('OPEN ERROR FILE LU9')
          OPEN (UNIT = LU14, FILE = NAMEFIL(1:KNMFIL)//'.sum',
     1      STATUS = 'UNKNOWN', IOSTAT = IOST)
          OPEN (UNIT = LU17, FILE = NAMEFIL(1:KNMFIL)//'.hkp',
     1      STATUS = 'UNKNOWN', IOSTAT = IOST)
          CALL GEN108 (LU17, 0)
C * CHECK FOR SHELX-BIN
          INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.bin', EXIST = EXST21)
          OPEN (UNIT = LU19, FILE = NAMEFIL(1:KNMFIL)//'.bin',
     1      STATUS = 'UNKNOWN', FORM = 'UNFORMATTED', IOSTAT = IOST)
          IF (EXST21) THEN
            READ (LU19, IOSTAT = IOST)
            IF (IOST == 0) IGBL(16) = 1
          END IF
          IPR(437) = 0
C * SET NEXT MAIN PLATON LOOP PARAMETER VALUE
          IGBL(1)  = 0
        END IF
C * IGBL(1) = 0 : MANAGE DATA FILE ON UNIT LU1
      ELSE IF (IGBL(1) == 0) THEN
        IDATAFRM = 1
C * TARGET DEPENDENCY
        KNMXT = KNMFIL + KXT + 1
        FNLU1 = NAMEFIL(1:KNMFIL)//'.'//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 (UNIT = LU1)
          OPEN (UNIT = LU1, FILE = FNLU1(1:KNMFIL + KXT + 1),
     1     FORM = 'FORMATTED',  IOSTAT = IOST)
          IF (IOST /= 0) THEN
            WRITE (LU6, 99999, IOSTAT = IOST) FNLU1(1:KNMXT)
C * EXIT IN CASE OF -T OPTION
            IF (IGBL(3) == 30) THEN
              RETURN
C * SPF-DATA
            ELSE
              IGBL(8)  = 1
              IGBL(39) = 0
              LU1      = LU3
              IDATAFRM = 0
            END IF
          END IF
        END IF
        IF (IDATAFRM == 1) THEN
          WRITE (LU6, 99997, IOSTAT = IOST) FNLU1(1:KNMXT)
          IF (EXTENS(1:KXT) == 'lis') THEN
            WRITE (LU6, 99994)
C * SET NEXT MAIN LOOP PARAMETER
            IGBL(1) = 4
            RETURN
          END IF
          IGBL(39) = 1
        END IF
        CALL GEN108 (LU3,  0)
        CALL GEN108 (LU4,  0)
        CALL GEN108 (LU8,  0)
        CALL GEN108 (LU14, 0)
        CALL GEN108 (LU17, 0)
C * SET NEXT MAIN LOOP PARAMETER VALUE
        IGBL(1) = 1
      END IF
      RETURN
99999 FORMAT ('!! File ', A, ' NOT Available, Interactive Input ',
     1        'Assumed', /)
99998 FORMAT (A)
99997 FORMAT (':: Data from: ', A, /)
99996 FORMAT (':: RUN BMFIT TOOL')
99995 FORMAT (':: RUN MP TOOL')
99994 FORMAT (/, ':: Invalid Data Type', /)
      END SUBROUTINE PLA000
 
      MODULE menus
      SAVE
      INTEGER, PARAMETER       :: NP31 = 37
      INTEGER, PARAMETER       :: NP35 = 110
      INTEGER, PARAMETER       :: NP40 = 444
      INTEGER, PARAMETER       :: NP46 = 17
      INTEGER, DIMENSION(NP35) :: MNH
C * IOPT =  2 - Reflections Required
C *      = -2 - Check for Unique Calculation done
      INTEGER, DIMENSION(7, NP46) :: IOPT = RESHAPE ( (/
     1  1, -2,  1,  1,  2, -1,  2,
     2  1, -2,  1, -2,  2,  2,  2,
     3 -4, -3,  2, -2,  2,  5,  1,
     4 -4,  1,  2, -2,  2,  2,  1,
     5 -4,  1,  3, -2,  2,  5, -5,
     6  1, -2,  1, -2,  2,  5,  2,
     1  2, -3,  1, -2,  2,  1,  9,
     2  2, -2,  1,  1,  1,  2,  9,
     3  1,  1,  1,  1,  1,  1,  9,
     4  2,  1,  1, -2,  1,  1,  9,
     5 -8,  1,  2,  2,  1, -2, -5,
     6  1,  1,  2,  2,  1, -2, -5,
     3  2, -4,  2,  2,  1,  1, -2,
     4  1, -4,  2,  1,  1,  1,  1,
     5  1,  1,  2,  5,  1,  1,  1,
     6  2,  1,  1,  1,  1,  1,  1,
     7  1,  1,  1,  5,  1,  1,  1/), (/7, NP46/))
      INTEGER, DIMENSION(25, NP31) :: MENA = RESHAPE ( (/
C * # (0/1) SWITCH PARAMETERS POS = IPR(), NEG = IGBL()
C * ORTEP - MAIN (1)
     1   0, 116, 212, 351,   0, 440, 341, 311, 508,   0,
     2 -59, -75, 349,   0, 327, 328,   0,   0,   0,   0,
     3   0,   1,-103,   0,   0,
C * PLUTON MAIN (2)
     1   0, 116, 212,1004,2004,3004,4004,   4, 345,   0,
     2 -59,   0,  46,   0,   0,   0, -75,   0,   0,   0,
     3   0, 346,-103,   0,   0,
C * DPLUTON SUB1 (3)
     1   0, 173, 453, 448,   0, 344, 334, 351, 335, 349,
     21341, 343,   0,   0,   0,   0, -75, 105,   0,   0,
     3   0, 213, 141,-128,   0,
C * PLUTON SUB2 (4)
     1   0, 348, 338,1004,2004,3004,4004,   4, 345, 345,
     2   0, 339,   0,  63, 339, 452, -75,2508,   0,   0,
     3   0, 346,1508, 311,   0,
C * PLUTON SUB3 (5)
     1   0,1150,2150,3150,4150,5150,6150,7150,8150, 330,
     21329,2329,3329,   0,   0,   0, -75,   0,   0,   0,
     3   0, 346,-103,   0,   0,
C * PLUTON SUB4 (6)
     1   0,2341,3341,4341,1341,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0, -75,   0,   0,   0,
     3   0, 346,-103,   0,   0,
C * PLUTON SUB5 (7)
     1   0, -25,   0, -97, -105,  14, -55, 231, -30,   0,
     2 -35,   0,   0,   0,   0,  71, -46, -68, -69,   0,
     3 166,-127,   0, 462,   0,
C * ORTEP SUP1 (8)
     1   0, 173, 453, 448,   0, 344,   0,   0, -52, 330,
     2 536,   0, 211,1211,2211, 350,   0,   0,   0,   0,
     3   0,   0,   0, 341, 476,
C * ORTEP SUB2 (9)
     1 414, -69, 346, 618, -105, 506, -55, 312,   0,   0,
     2 341,   0,   0,   0,   0,   0,   0, -68,   0,   0,
     3   0,-104, 552, 476,   0,
C * PLATON/MAIN (10)
     1   0, -30, 110, -97,  68,  71, -55, 324,  87, -52,
     2 -59,   0,   0,   0,   0,   0, 605,   0,   0, -95,
     3   0,   0, -45, 462,   0,
C * PLATON/SUP1 (11)
     1   0,  29, 592, -56, 501, 502, 497, -61, 181,   0,
     2 154, 445, 363, -33,-121, 597,   0, 603, 645,   0,
     3   0, 346,-103,   0,   0,
C * PLATON/SUP2 (12)
     1   0, 449, -70,-130,-137,   0,   0,   0,  33,-106,
     2-136, 594,-109, -57, -74,   0, -46,   0, 647,   0,
     3 -35, -69, -68, 590,   0,
C * GEOM (13)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0, 346,-103,   0,   0,
C * ASYM (14)
     1   0,1394,2394,3394,   0, 406, 387, 388,   0,   0,
     2   0,   0, 369, 776, 468,   0,   0,   0,   0,   0,
     3   0,   0,-103,   0,   0,
C * HELENA (15)
     1   0,   0,   0,   0, 320, 428, 424, 425, 426,   0,
     2 371, 372, 373, 374, 375, 376, 377, 378, 379,   0,
     3   0,   0,   0,   0,   0,
C * ABSCOR (16)
     1 539, 540, 541, 542, 441, 442, 443, 444, 451,   0,
     2 -57, 445, 363, 331, 388, -75,   0,   0,   0,   0,
     3   0,   0,-103,   0,   0,
C * S (17)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * S (18)
     1   0,   0,   0,   0,   0,   0,   0,   0, 321, -40,
     2 -41, -34,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0, -42, -43,   0,   0,
C * S (19)
     1   0, -44,   0,   0,   0,   0,   0, -91, -51, -96,
     2-125,   0,   0,   0, -74,   0,-122, -68,   0,   0,
     3   0,   0,   0,   0,   0,
C * LEPAGE (20)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,-106,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * POWDER (21)
     1   0, 549,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0, 650,   0, 649,
     3 569, 570,-103,   0,   0,
C * CONTOUR (22)
     15414,1414,2414,3414,4414, 416,1416,2416,3416,4416,
     2   0,   0,   0,   0,   0, 458, -75,   0,   0,   0,
     3 182, 182,-103,   0,   0,
C * CONTOUR-SUP (23)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * SOLV (24)
     1   0, 116,   0,   0,   0,   0, -68, 598, 537,   0,
     2 535,   0, 527, 528, 529, 532, -75,   0,   0,   0,
     3   0, 346,-103,   0,   0,
C * TwRtMt (25)
     1   0,   0,   0,   0, 469,   0,1543,2543,3543,4543,
     2   0,   0, 608,   0,   0,   0, 575, 571, 572, 573,
     3 574,   0,   0,   0,   0,
C * ADDSYM (26)
     1   0,   0,   0,   0,   0, 568,   0, 708, 503,-106,
     2   0,   0,   0,   0,   0,   0,   0,   0, 566,   0,
     3   0,   0,   0,   0,   0,
C * EXOR (27)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * RDF (28)
     1 581,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * BIJVOET (29)
     1 594, 629,   0,   0,   0,   0, 666,   0,   0,   0,
     2   0,   0, 613,   0, 593,   0, 613, 613, 613,   0,
     3   0, 636, 634,   0,   0,
C * POLYHEDRA (30)
     1   0, 346, 355, 212,   0,   0,   0,   0,   0,   0,
     2 353, 358, 357, 359, 339,   0, 356,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * FLIPPER (31)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3 640, 614,   0,   0,   0,
C * ANAL-OF-VARIANCE (32)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0, 711,   0, 633, 634,   0,   0,   0,
     3   0,   0, 778,   0,   0,
C * ANOMALOUS DISPERSION (33)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,-103,   0,   0,
C * FCF-COMPARE (34)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0, 633, 634,   0,   0, 657,
     3   0,   0,   0,   0,   0,
C * WILSON PLOT + E-STATISTICS (35)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * SQUEEZE (36)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0,
C * SPGRfromEX (37)
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,-106,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0/), (/25, NP31/))
C * CODE nnmm : mm = number of devisions, nn = parameter with current value
      INTEGER, DIMENSION(25, NP31) :: MENS = RESHAPE ( (/
C * ORTEP-MAIN (1)
     1      4803, 2, 1, 1, 409, 1, 3503, 3603, 5603, 605, 6602, 1502, 1,
     2      508, 1, 1, 100, 9, 10, 10, 10, 2, 1, 2302, 2,
C * PLUTON-MAIN (2)
     1      1106, 4, 3, 2405, 1, 2, 1, 1, 203, 605, 6602, 508, 1, 100,
     2      2, 707, 1502, 9, 10, 10, 10, 303, 1, 3, 2,
C * PLUTON-SUB1 (3)
     1      1106, 1, 1, 1, 1410, 1, 1, 1, 1, 1, 1, 1, 7308, 100,
     2      9002, 605, 1502, 9, 10, 10, 10, 1, 1, 1, 2,
C * PLUTON-SUB2 (4)
     1      1106, 5102, 1, 2405, 1, 2, 1, 1, 203, 817, 3306, 1003, 904,
     2      1, 1, 1, 1502, 5602, 10, 10, 10, 303, 5603, 3603, 2,
C * PLUTON-SUB3 (5)
     1      1106, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 100, 1,
     2      1, 1502, 1, 10, 10, 10, 303, 1, 3, 2,
C * PLUTON/GEOM (6)
     1      1106, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 100, 1,
     2      1, 1502, 1, 10, 10, 10, 303, 1, 3, 2,
C * PLUTON/AUX (7)
     1      1106, 1, 6007, 1, 1, 1, 1, 1, 1, 1, 1, 4203,
     2      9906, 9102, 7605, 1, 1, 1, 1, 7005, 1, 1, 2, 1, 2,
C * PLATON/ORTEP/SUB1-MENU (8)
     1      4803, 1, 1, 1, 1410, 1, 1, 7104, 1, 1, 7208, 5304, 3802, 1,
     2      3802, 1, 100, 5805 ,5905, 2708, 2808, 2908, 3008, 3409, 2,
C * PLATON/ORTEP/SUB2-MENU (9)
     1      4803, 1, 1, 1, 1, 1, 1, 3703, 3703, 5203, 1, 1,
     2      2, 2, 2, 1, 100, 1, 10, 10, 10, 1, 7503, 3903, 2,
C * PLATON-MAIN (19)
     1      8603, 1, 1, 1, 2604, 1, 1, 1, 1, 1, 6602, 2, 2,
     2      1, 1, 1, 1, 8705, 8805, 2, 1, 2, 1, 1, 2,
C * PLATON/SUP1 (11)
     1      8603, 1, 1, 1, 1, 1, 1, 1, 1, 5203, 1, 1, 1,
     2      1, 1, 1, 7104, 1, 1, 7005, 1, 6504, 6404, 1, 2,
C * PLATON/SUP2 (12)
     1      8603, 2105, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1,
     2      1, 1, 1, 5404, 1, 5, 1, 1202, 1, 1, 1, 1, 2,
C * GEOM PLOT - MENU (13)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2302, 2,
C * ASYM-MENU (14)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 2507, 1309, 1,
     2      1, 1, 1, 5704, 1, 4102, 1, 1, 1, 1, 1, 1, 2,
C * HELENA MENU (15)
     1      1, 1, 4706, 1, 1, 1, 2703, 2803, 2902, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * ABSCOR MENU (16)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 2210, 9, 10, 10, 10, 1, 1, 1, 2,
C * SYSTEM-S MENU (17)
     1      4003, 3, 1, 3, 2, 3, 4, 2, 3, 3, 6, 6,
     2      1, 2, 6, 6, 2, 2, 2, 2, 2, 2, 2, 1, 2,
C * S/SUB-MENU (18)
     1      4003, 3, 2, 1, 1, 2, 1, 10004, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2,
C * S/SHELXL (19)
     1      4003, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 2, 1, 10204, 1, 1, 2, 2,
C * LEPAGE-MENU (20)
     1   3109, 3204, 4305, 6205, 4407, 7404, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * POWDER MENU (21)
     1   4904,    1, 4605, 5006, 6105, 4505, 10602, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * CONTOUR (22)
     1      1   ,6305,6305,6305,6305,1,1,1,1,1603, 2006, 1705,
     2      6, 6, 6, 1, 1502, 1805, 1908, 1, 5503, 1, 1, 2, 2,
C * CONTOUR-SUP (23)
     1      1,6304, 1, 1, 1, 1, 1, 9706, 9806, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1805, 1, 1, 1, 1, 1, 1, 1,
C * SOLV MENU (24)
     1      1, 6802, 6902, 1, 1, 1, 1, 1, 1, 100, 1, 6700,
     2      1, 1, 1, 1, 1502, 508, 10, 10, 10, 1, 1, 1, 1,
C * TwinRotMat-MENU (25)
     1      8406, 8206, 9405, 8305, 1, 1, 1, 1, 1, 1, 4, 9207,
     2      1, 1, 10103, 2, 1, 1,  1, 1, 1, 8506, 9305, 1, 1,
C * ADDSYM-MENU (26)
     1      7704, 7806, 7906, 8006, 8106, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 2, 1, 8900, 1, 1, 1, 1,
C * S/EXOR-MENU (27)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2,
C * RDF (28)
     1      1, 9505, 9606, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * BIJVOET (29)
     1      1, 1, 1, 1, 1, 10410,   1, 10006, 1, 1, 1, 1,
     2      2, 1, 1, 1, 1, 1, 10510, 1, 1, 1, 1, 1, 1,
C * POLYHEDRA (30)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 604, 1, 1,
     2      1, 1, 1,10305, 1, 1, 10, 10, 10, 1, 1, 2, 1,
C * FLIPPER (31)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 5, 5, 5,
     2      5, 6, 7, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * ANAL-OF-VARIANCE (32)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * ANOMALOUS DISPERSION (33)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * FCF COMPARE (34)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * WILSON-PLOT + E-STATISTICS (35)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * SQUEEZE (36)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
C * SPGRfromEX (37)
     1      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /), (/25, NP31/))
      INTEGER, DIMENSION(50, NP31) :: MENU = RESHAPE ( (/
C * REFERENCE TO MENUTEXT
C * ORTEP (1)
     1 37, 17,  2,  8, 38,217,219,220,271, 22, 26, 11, 10, 12,141,
     2142, 14, 18, 19, 20, 21,251, 23,148, 53, 37, 34,502,508, 38,
     3717,719,720,771, 22,526,511,510, 32,641,642, 14, 18, 19, 20,
     4 21,251,523,148, 53,
C * PLUTON-MAIN (2)
     1 37, 17,376,  4,  5,  6,  7,528,  3, 22, 26, 12, 13, 14, 15,
     2 16, 11, 18, 19, 20, 21, 99, 23, 24, 59, 37, 34,876,504,505,
     3506,507, 28,503, 22,526, 12,513, 14, 15, 16,511, 18, 19, 20,
     4 21,599,523, 24, 59,
C * PLUTON SUB1 (3)
     1537, 48, 50, 52, 54, 69,100,  8,  9, 10, 58, 66, 68, 14, 35,
     2 22, 11, 18, 19, 20, 21,234, 93,201, 59, 37,548,550,552, 54,
     3569,600,508,509,510,558,566, 68, 14,535, 22,511, 18, 19, 20,
     4 21,734,593,701, 59,
C * PLUTON SUB2 (4)
     1537, 60, 98,  4,  5,  6,  7,528,  3,607,216, 97, 95, 90, 92,
     2 94, 11,352, 19, 20, 21, 99,271,220, 59, 37,560,598,504,505,
     3506,507, 28,503,107,216, 97, 95,590,592,594,511,852, 19, 20,
     4 21,599,771,720, 59,
C * PLUTON SUB3 (5)
     1537, 71, 72, 73, 74, 75, 83, 84, 85, 86, 87, 88, 89, 14,  1,
     2  1, 11,  1, 19, 20, 21, 99, 23, 24, 59, 37,571,572,573,574,
     3575,583,584,585,586,587,588,589, 14,  1,  1,511,  1, 19, 20,
     4 21,599,523, 24, 59,
C * PLUTON SUB4 (6)
     1537, 55, 56, 57, 58, 80, 81, 82,215, 76, 77, 78, 79, 14,  1,
     2  1, 11, 49, 19, 20, 21, 99, 23, 24, 59, 37,555,556,557,558,
     3 80, 81, 82,215, 76, 77, 78, 79, 14,  1,  1,511, 49, 19, 20,
     4 21,599,523, 24, 59,
C * PLUTON SUB5 (7)
     1537,269,276, 30,324,218,241,284, 27,321, 91,242,326,325,305,
     2 32,153,280,243,289, 96,686,251, 49, 59, 37,769,276,530,824,
     3718,741,784,527,  1,591,242,326,325,305,532,653,780,743,289,
     4596,186,251,549, 59,
C * ORTEP MAIN (8)
     1537, 48, 50, 52, 54, 69,100,291,101, 86,293, 39,540, 41, 42,
     2 32, 14,273,274,189,190,191,192,216, 53,537,548,550,552, 54,
     3569,600,291,601,586,793, 39, 40,541,542,532, 14,273,274,189,
     4190,191,192,216, 53,
C * ORTEP/SUB1 (9)
     1537,243, 64,380,324,270,241,232,187,265,351,275,250,252,256,
     2 82, 14,280, 19, 20, 21,290,304,233, 53,537,743,564,880,824,
     3770,741,732,187,265,851,275,250,252,256, 82, 14,780, 19, 20,
     4 21,790,804,733, 53,
C * PLATON/MAIN (10)
     1 37, 27,231, 30, 31, 32,241,124,140,101, 26,279,250, 78, 79,
     2154,371,318,319,320,321,251,145, 49, 59, 37,527,731,530,531,
     3532,741,624,640,601,526,279,750, 78, 79,154,871,318,319,820,
     4321,251,645,549, 59,
C * PLATON/SUP1 (11)
     1537,237,855,247,261,262,264,266,138,265,350,149,156, 29,358,
     2364,291,370,408,289,  1,283,281,  1, 59,537,737,355,747,761,
     3762,764,766,638,265,850,649,656,529,858,864,291,870,908,289,
     4  1,283,281,  1, 59,
C * PLATON/SUP2 (12)
     1537,144,143,372,399,  1,  1,256,427,333,390,362,345,249,267,
     2268,153,428,409,627, 91,243,280,147, 59,537,644,643,872,899,
     3  1,  1,256,927,833,890,862,845,749,767,768,653,428,909,127,
     4591,743,780,647, 59,
C * GEOM (13)
     1  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,354,282,102, 67, 70, 64, 23,148, 53,  1,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,282,102, 67,
     4 70,564,523,148, 53,
C * ASYM (14)
     1  1,109,110,111,  1,128,108,112,  1,122,123,  1,125,443,134,
     2272,  1,103,  1,  1,  1,  1, 23,  1,104,  1,609,610,611,  1,
     3628,608,612,  1,122,123,  1,625,943,634,272,  1,103,  1,  1,
     4  1,  1,523,  1,104,
C * HELENA (15)
     1  1,  1,255,  1,185,155,657,658,659,  1,221,222,223,224,225,
     2226,227,228,229,  1,  1,  1,  1,  1,126,  1,  1,255,  1,685,
     3655,657,658,659,  1,721,722,723,724,725,726,727,728,729,  1,
     4  1,  1,  1,  1,126,
C * ABSCOR (16)
     1150,151,132,152,130,131,133,135,136,137,249,149,156, 36,112,
     2129,146, 18, 19, 20, 21,126, 23,248,104,650,651,632,652,630,
     3631,633,635,636,137,749,649,656,536,612,629,146, 18, 19, 20,
     4 21,126,523,248,104,
C * S (17)
     1 37,162,173,160,165,166,167,168,169,170,171,172,330,174,175,
     2176,177,178,179,180,181,163,182,261,184, 37,162,  1,160,165,
     3166,167,168,169,170,171,172,330,174,175,176,177,178,179,180,
     4181,163,182,261,184,
C * S/SUB (18)
     1537,162,161,257,205,164,214,208, 30,198,199,200,258,259,206,
     2 62, 63, 65,203,202,197,196,195,194,184,537,162,161,257,205,
     3164,214,208,530,698,699,700,258,259,206, 62, 63, 65,203,202,
     4197,696,695,194,184,
C * S/SHELXL (19)
     1537,193,213,  1,  1,212,  1,302,204,295,853,  1,  1,  1,267,
     2  1,366,280,240,  1,357,238,239,183,184,537,693,213,  1,  1,
     3212,  1,802,704,795,353,  1,  1,  1,767,  1,866,780,240,  1,
     4357,238,239,183,184,
C * LEPAGE (20)
     1210,211,244,278,245,296,  1,  1,  1,333,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1,  1,126, 25,210,211,244,278,245,
     3296,  1,  1,  1,833,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,  1,126, 25,
C * POWDER (21)
     1209,303,254,260,277,253,441,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,413,367,412,334,335, 23, 44, 25,209,803,254,260,277,
     3253,441,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,913,367,912,
     4834,835,523, 44, 25,
C * COUNTOUR (22)
     1 37, 63,207, 62, 65,613,114,115,116,121,139,117,118,119,120,
     2 61, 11,106,105,235,123,236, 23,103,104, 37,563,707,562,565,
     3113,614,615,616,621,139,117,118,119,120,561,511,106,105,235,
     4246,736,523,103,104,
C * CONTOUR-SUP (23)
     1 37,206,  1,  1,  1,  1,  1,347,348,346,  1,  1,  1,  1,  1,
     2  1,  1,106,  1,  1,  1,  1,  1,  1,  1, 37,706,  1,  1,  1,
     3  1,  1,347,348,346,  1,  1,  1,  1,  1,  1,  1,106,  1,  1,
     4  1,  1,  1,  1,  1,
C * SOLV (24)
     1  1, 17,288, 73, 74, 75,280,365,294, 14,292,287, 13,286,285,
     2 92, 11, 12, 19, 20, 21, 64, 23, 44, 25,  1,517,288, 73, 74,
     3 75,780,865,794, 14,792,287,513,786,785,592,511, 12, 19, 20,
     4 21,564,523, 44, 25,
C * TwinRotMat (25)
     1316,314,332,315,328,343,297,298,299,300,327, 95,374,  1,356,
     2103,344,336,337,338,339,317,331,301, 25,316,314,332,315,828,
     3343,797,798,799,800,327, 95,375,610,611,103,844,836,837,838,
     4839,317,331,301, 25,
C * ADDSYM (26)
     1309,310,311,312,313,230,  1,431,263,333,  1,  1,  1,  1,  1,
     2  1,  1,322,426,329,323,308,306,307, 25,309,310,311,312,313,
     3730,  1,931,763,833,  1,  1,  1,  1,  1,  1,  1,822,426,329,
     4323,308,306,307, 25,
C * S/EXOR (27)
     1  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1,  1,  1,184,  1,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,  1,  1,184,
C * RDF (28)
     1340,341,342,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1, 23, 44, 25,840,341,342,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,523, 44, 25,
C * BIJVOET (29)
     1374,383,  1,  1,  1,377,418,349,420,421,422,423,382,  1,359,
     2  1,411,879,378,  1,  1,389,388, 44, 25,375,883,  1,  1,  1,
     3377,419,349,420,421,422,423,410,  1,859,  1,911,379,878,  1,
     4  1,889,888, 44, 25,
C * POLYHEDRA (30)
     1  1, 64,276,  2,  1,  1,  1,  1,  1, 22,360,361, 13,363, 92,
     2 16, 93,  1, 19, 20, 21,  1, 23,148, 25,  1,564,776,502,  1,
     3  1,  1,  1,  1, 22,860,861,513,863,592, 16,593,  1, 19, 20,
     4 21,  1,523,148, 25,
C * FLIPPER (31)
     1  1,  1,  1,  1,  1,  1,  1,  1,  1,392,393,394,395,396,397,
     2  1,  1,  1,  1,  1,398,391,381,373, 25,  1,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4898,891,381,373, 25,
C * ANAL-OF-VARIANCE (32)
     1384,415,416,424,425,433,440,417,  1,  1,  1,  1,  1,432,385,
     2386,388,  1,  1,  1,  1,  1,444, 44, 25,384,415,416,424,433,
     3440,417,  1,  1,  1,  1,  1,  1,932,385,387,888,  1,  1,  1,
     4  1,  1,944, 44, 25,
C * ANOMALOUS DISPERSION (33)
     1400,401,402,403,404,405,406,  1,  1,434,435,436,437,438,  1,
     2  1,  1,  1,  1,  1,  1,  1, 23, 44, 25,400,401,402,403,404,
     3405,406,  1,  1,434,435,436,437,438,  1,  1,  3,  1,  1,  1,
     4  1,  1,523, 44, 25,
C * FCF-COMPARE (34)
     1384,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,385,
     2386,  1,  1,  1,414,  1,  1,  1, 44, 25,  1,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,385,387,  1,  1,  1,914,
     4  1,  1,  1, 44, 25,
C * WILSON-PLOT + E-STATISTICS (35)
     1430,429,439,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1,  1, 44, 25,430,429,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,  1, 44, 25,
C * SQUEEZE (36)
     1  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1,  1, 44, 25,  1,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,  1, 44, 25,
C * SPGRfromEX (37)
     1  1,  1,  1,  1,  1,  1,  1,  1,  1,333,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1,  1, 44, 25,  1,  1,  1,  1,  1,
     3  1,  1,  1,  1,833,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,  1, 44, 25/), (/50, NP31/))
      CHARACTER(len=11), DIMENSION(NP31) :: MENX = (/
     1 'ORTEP     1', 'PLUTON    2', 'Contents  3', 'Style     4',
     2 'View      5', 'GeomTy    6', 'Aux       7', 'ORT_SP1   8',
     3 'ORT_SP2   9', 'PLATON   10', 'PLA-SP1  11', 'PLA-SP2  12',
     4 'GEOM     13', 'ASYM     14', 'HELENA   15', 'ABSCOR   16',
     5 'SYSTEM-S 17', 'S-SUB    18', 'S-SHXL   19', 'LEPAGE   20',
     6 'POWDER   21', 'Contour  22', 'CON-Sup  23', 'SolvPlot 24',
     7 'TwinRotM 25', 'ADDSYM   26', 'S/EXOR   27', 'RDF      28',
     8 'BIJVOET  29', 'POLYHN   30', 'Flipper  31', 'ANALoVAR 32',
     9 'AnomDisp 33', 'FCF-Comp 34', 'WilsonPl 35', 'SQUEEZE  36',
     * 'SPGRfrEX 37'/)
      CHARACTER(len=11), DIMENSION(NP40) :: CMEN = (/
     1 '           ', 'Incl-HAtoms', 'BWC Res ARU', 'Solid-Style',
     2 'Rod  -Style', 'CPK  +Stick', 'Straw-Style', 'DeleteAtoms',
     3 'RenameAtoms', 'MoveLabel  ', 'Label -Hat+', 'LabelSize >',
     4 'UnitCellBox', 'Resd012..  ', 'H-Bonds-X  ', 'PackRange  ',
     5 'Stereo Opts', 'CRotY >>   ', '<<-RotZ+>> ', '<<-RotY+>> ',
     6 '<<-RotX+>> ', 'ViewOptions', 'Decoration ', 'Met Pov Ras',
     7 '        End', 'NoDisorder ', 'NoMove     ', 'Stick-Style',
     8 'AtomSort   ', 'Organic    ', 'Round      ', 'Parentheses',
     9 'ListRadii  ', 'Mono       ', 'HFIX   ANIS', 'Cell Dimens',
     * 'OptionMenus', 'Probability', 'Raster3D   ', 'Hetero El.s',
     1 'Envelope El', 'Octant El.s', 'ViewMin    ', 'EPS-File   ',
     2 'StyleA     ', 'BwcStyle   ', 'ToMainMenu ', 'DisplayText',
     3 'ENTRY-LIST ', 'NewText    ', 'NewText    ', 'MoveText   ',
     4 'PLUTON  End', 'TextSize   ', 'Distance   ', 'Angle      ',
     5 'Torsion    ', 'GeomCalc   ', 'Reset   End', 'SelPattern ',
     6 'Bonds      ', 'Fo-Fc-Map  ', 'Fo-Map     ', 'Color      ',
     7 'SQUEEZE-Map', 'ZoomCenter ', 'NextRing   ', 'Zoom       ',
     8 'DeleteText ', 'NextPlane  ', 'ViewUnit   ', 'ViewMin    ',
     1 'ViewXO     ', 'ViewYO     ', 'ViewZO     ', 'ListCell   ',
     2 'ListSymm   ', 'ListAtoms  ', 'ListBonds  ', 'ListTypes  ',
     3 'ListLines  ', 'ListARU    ', 'ViewAFace  ', 'ViewBFace  ',
     4 'ViewCFace  ', 'ViewInvert ', 'ViewLine   ', 'ViewPerp   ',
     5 'ViewBisect ', 'LabelARU   ', 'Auto-Plot  ', 'LabelCell  ',
     6 'OmitOutside', 'LabelAtom  ', 'Resolution>', 'InclZombie ',
     7 '<OverlapMrg', 'SelectColor', 'Col Res ARU', 'ChTextSize ',
     8 'NoSymm     ', 'Newman-Next', 'Up     Down', 'EPS    End ',
     9 'Ch-Cntr-Lev', 'Ch-Step-Siz', 'GlobalPattn', 'Resolution ',
     * 'Zone-H     ', 'Zone-K     ', 'Zone-L     ', 'Axes       ',
     1 'Plane-Horiz', 'Plane-abcd ', 'PlaneBisect', 'Plane-Perp ',
     2 'VertAngSize', 'Horiz Shift', 'Vert  Shift', 'Z-Rotation ',
     3 'PlaneXYXZYZ', 'OMIT  STH/L', 'OMIT SIG(I)', 'R/S-Determ ',
     4 'MissingRefl', 'Next-Step  ', 'EPS    HPGL', 'Summary    ',
     5 'LabelVert.s', 'Mu     (mm)', 'Radius (mm)', 'T(min) (mm)',
     6 'MuR        ', 'N-Measured ', 'Gauss  Grid', 'FaceAdd(mm)',
     7 'FaceDelete ', 'SHELXL-ATWT', 'PlaneDisTol', 'Norm-H-bond',
     8 'DeleteLabel', 'IncludLabel', 'EPS-Listing', 'Print-Level',
     1 'SAVE-InstrS', 'ZoomXtlPlot', 'Browser    ', 'b&w-EPS-col',
     2 'WriteDirCos', 'L0(max)    ', 'L1(max)    ', 'T(max) mm  ',
     3 'Portrait   ', 'List Uij   ', 'No-SCALE   ', 'CheckDirCos',
     4 'BetaPerpPar', 'LSR-MSM-MSA', 'DirCos-ABSP', 'ABST/P/NONE',
     5 'TREE   LIST', 'LOG  RELINK', 'ADDSYM SOLV', 'CELL HELENA',
     6 'TRMX   SPGR', 'FORM Z SX86', 'SHX/S/P/D/T', 'DIRDIF ORNT',
     7 'SIR97/04/11', 'EXOR  /S /D', 'SHELXL-ISO ', 'SHELXL-ANIS',
     8 'MULABS     ', 'HDIF   HFIX', 'SHELXL-HATS', 'SHELXL-WGHT',
     9 'PLUTON RENM', 'PLATON  ADP', 'INVRT HFREE', 'ASYM   VIEW',
     * 'SQUEEZE FCF', 'VALI REPORT', 'LstRES SXPS', 'SKIP ACCEPT',
     1 'LIST-REFL  ', 'AutoMolExpd', 'Fit Res 1&2', '           ',
     2 'RadBndAll  ', 'RadBndNorm ', 'RadBndToMet', 'RadBndToHat',
     3 'Edit-s.ins ', 'PruneS-Tree', 'Browse-lis ', 'Browse-lps ',
     4 'Laser-lps  ', 'Void-Check ', 'AddsymCheck', 'Valid-Check',
     5 'Asym-Residu', 'Browse-ps  ', 'Laser-ps   ', 'OmitOutlier',
     6 'XtalDisplay', 'F0**2-Map  ', '2Fo-Fc-Map ', '54 60 65 MX',
     7 'Ag Mo Cu X ', 'MaxDotProd ', 'ExpErrorDeg', 'Twin-Matrix',
     8 'Edit-s.res ', 'Flipper    ', 'ListFlags  ', 'BondTaper> ',
     1 'CalcCoordn ', 'LablFullNum', 'DisAnglTors', 'JoinDashDet',
     2 'Include RR1', 'Include RR2', 'Include RR3', 'Include RR4',
     3 'Include RR5', 'Include RR6', 'Include RR7', 'Include RR8',
     4 'Include RR9', 'NFTPercImpl', 'Join-Expand', 'FITbyCLICK ',
     5 'LsplDistEnd', 'ExcludeARU ', 'Def-Cntr-Lv', 'OmitFromSFC',
     6 'MaxRingSize', 'SHELXL-CGLS', 'SHELXL-LS  ', 'Anis    All',
     7 'Label-Alias', 'OvrlpSHADOW', 'X-LineWidth', 'Two-Ax-Crit',
     8 'Sub/SupCell', 'XR  YR  ZR ', 'D-H..H-A   ', 'CalcAbsCorr',
     9 'ReflListing', 'LstCellSymm', 'Prev   Next', 'LstAtomsUeq',
     * 'LineWidth  ', '<VertScale>', 'ScaleDegree', 'LstFlagRadi',
     1 'RemoveTree ', 'CSD-Search ', 'R-PLUTO    ', '<HorsScale>',
     2 'AutoRenum  ', 'InclDisCont', 'NoSubCell  ', 'TMA-Hincl  ',
     3 '(UAE)WLSPL ', 'AltLablPack', 'DebugOutput', 'SetWindSize',
     4 'MenuOff    ', 'LabelCg    ', 'DefineToEnd', 'ObsCalcDelt',
     5 'NrLinesNorm', 'NrLinesToMe', 'LstRadBonds', 'Perspective',
     6 'StepSize   ', 'Max2Axis   ', 'LstARU RCel', 'Reverse-B&W',
     7 'Tola       ', 'ADP-PLOT   ', 'Tolm       ', 'Uiso       ',
     8 'Ohashi-Vol ', 'Show-Mol   ', 'Void0123...', 'DotsContour',
     1 'MinDistCrit', 'LtReference', 'CoordRadDef', 'UnitFill   ',
     2 'ColorType  ', 'UnitSymPack', 'AutoEXTIref', 'RoundCell  ',
     3 'DspTwinMat1', 'DspTwinMat2', 'DspTwinMat3', 'DspTwinMat4',
     4 'HKLF5-Gener', 'Merg 4     ', 'InputLambda', 'LsplWithEnd',
     5 'PovrayStyle', 'ADDSYM-PLOT', 'ADDSYM-SHX ', 'ADDSYMExact',
     6 'NonFitPerc ', 'TolMetric  ', 'TolRotAxis ', 'TolInvers  ',
     7 'TolTransl  ', 'DeltaI/SigI', 'DeltaTheta ', 'NRefSelMin ',
     8 'HKLF5-CritI', 'MinQPeakHgt', 'MinQPeakDis', 'Q-Peak-Incl',
     9 'KeyInstruct', 'ListDetails', 'ADDSYMElmnt', 'DisplAllLab',
     * 'HorVerRatio', 'PovrayResol', 'EPS-TwinLat', 'FullListing',
     1 'ADDSYMEqual', 'TwinRotMat ', 'HKLF5-CritT', 'MaxIndexUVW',
     1 'KeepMon-I-n', 'Displ-d-val', 'Display-2Th', 'SelectTMat1',
     1 'SelectTMat2', 'SelectTMat3', 'SelectTMat4', 'Normalize  ',
     4 'RDF-radius ', 'RDFwidthPar', 'EPS-TwinLaw', 'RacemicTwin',
     5 'PNG        ', 'Fourier3D  ', 'Nr-Sections', 'Nr+Sections',
     6 'SigmaCriter', 'ExclDisOper', 'Angle2Lines', 'DefineCgEnd',
     7 'UisoMax    ', 'CremerPople', 'MaxNumRings', 'Zone-H,K,L ',
     8 'NpeakFmap  ', 'BondValence', 'ApplySlope ', 'Polyhedra  ',
     1 'PolyShade  ', 'FCF-Calc   ', 'InclAtoms  ', 'ResdSort   ',
     2 'VoidAxes   ', 'SirWindow  ', 'List-Pow   ', 'PLATON     ',
     3 'EXOR       ', 'UisoHRadius', 'Exclude H  ', 'PDF-Listing',
     4 'Converged  ', 'IcalFromCIF', 'IcalFromFCF', 'Inc H CH DH',
     5 'OutlierCrit', 'Manual Nu  ', 'Gaussian   ', 'LabelHetAts',
     6 'Continue   ', 'NPP-Bijvoet', 'InclWghtPar', 'NorProbPlot',
     7 'ScatterPlot', 'LogLog-Plot', 'Linear-Plot', 's.u.-Bar   ',
     8 'HKL-Display', 'NoExpand   ', 'Show       ', 'Ntry       ',
     9 'Nloop      ', 'Nsolve     ', 'Delta      ', 'Perc       ',
     * 'Uiso       ', 'Structure  ', 'PageHeader ', 'AnomDispPlt',
     1 'MuPlot     ', 'Anom-CuKa  ', 'Anom-GaKa  ', 'Anom-MoKa  ',
     2 'Anom-AgKa  ', 'Anom-InKa  ', '           ', 'Incl C-H..X',
     3 'GenerRandom', 'TPP-Bijvoet', 'Student-T  ', 'Displ-q-Val',
     4 'CPI-File   ', 'ReducedCell', 'I/s-log(I) ', 'I/sw-log(I)',
     5 'VarAnalysis', 'ParsonsDiff', 'BijvoetDiff', 'BtDiff-Th  ',
     6 'BtDiff-Fc2 ', 'BtDifSig-Th', 'BtDifSigFc2', 's(I)-log(I)',
     7 'log(s)-logI', 'ADDSYMPart#', 'NoMolFitInv', 'GenerSthlMx',
     8 'N(Z)-Stat  ', 'Wilson-Plot', 'NoInversion', 'I-or-F-Plot',
     9 's(I)-sqt(I)', 'Mu-CuKa    ', 'Mu-GaKa    ', 'Mu-MoKa    ',
     * 'Mu-AgKa    ', 'Mu-InKa    ', 'N(Z)-PLOT  ', '<I/s(I)>-Th',
     1 'Iobs   Ical', 'Volcal     ', 'ShowExtinct', 'K-Analyze  '/)
      CHARACTER(len=10), DIMENSION(7, NP46)  :: OPTS = RESHAPE ((/
     1 'PlutonAuto', 'Calc All  ', 'Calc Solv ', 'Addsym    ',
     2 'MULscanABS', 'Validation', 'System-S  ',
     3 'Ortep-Plot', 'Calc Intra', 'Calc K.P.I', 'Addsym-EQL',
     4 'ABSPsiScan', 'Asym-View ', 'fcf2hkl   ',
     5 'NewmanPlot', 'Calc Inter', 'Squeeze   ', 'Addsym-EXT',
     6 'ABSTompa  ', 'FCF-Valid ', 'Expand2P1 ',
     7 'Ring-Plots', 'Calc Coord', 'Hybrid    ', 'Addsym-PLT',
     8 'ABSGauss  ', 'DifFourier', 'FCF-Gener ',
     9 'Plane-Plot', 'Calc Metal', 'CalcFCFsqd', 'Addsym-SHX',
     * 'ABSXtal   ', 'ANALofVAR ', 'HKLF-Gener',
     1 'PolyPlot  ', 'Calc Geom ', 'ContourSol', 'Newsym    ',
     2 'ABSSphere ', 'ByvoetPair', 'HKL-Transf',
     3 'ContourDif', 'Calc Hbond', 'Solv F3D  ', 'Nonsym    ',
     4 'ShxAbs    ', 'AsymExpect', 'Exor-Res  ',
     5 'Contour-Fo', 'Calc TMA  ', 'Solv Plot ', 'LePage    ',
     6 'AnomDisVal', 'Asym-Valid', 'Anis-Res  ',
     7 'AutoMolFit', 'L.S.-Plane', 'CavityPlot', 'DelRed    ',
     8 'AnomDisPlt', 'SupplMater', 'Rename-Res',
     9 'hkl2Powder', 'DihedAngle', 'Calc SASA ', 'Molsym    ',
     * 'MuPlot    ', 'Expect-hkl', 'Auto-Renum',
     1 'SimPowderP', 'AngleLines', 'Flip Menu ', 'SPGRfromEX',
     2 '          ', 'CSD-Cell  ', 'Create-spf',
     3 'RadDistFun', 'AngLsplLin', 'Flip Show ', 'Asym      ',
     4 '          ', 'CSD-Quest ', 'Create-res',
     5 'Patterson ', 'CremerPopl', 'Flip Patt ', 'ASYMaverFR',
     6 '          ', 'StructTidy', 'Create-cif',
     7 'ShelxtPlot', 'BondValenc', 'Flipper 25', 'LePageTwin',
     8 'XtlPlanAgl', 'StrainAnal', 'Create-pdb',
     9 '          ', 'Volcal    ', 'Structure?', '          ',
     * 'Xtal Habit', '          ', 'HFIX-Res  ',
     1 'WilsonPlot', 'R/S-CIP   ', '          ', '          ',
     2 '          ', '          ', 'cif2fcf   ',
     3 'PlutoNativ', 'MolVolume ', '          ', 'TwinRotMat',
     4 '          ', '          ', 'cif2shelxl'/), (/7, NP46/))
      CHARACTER(len=11), DIMENSION(25) :: MENUSUB
      END MODULE menus
 
      MODULE dfspgr
      SAVE
      INTEGER,           PARAMETER         :: NCS = 52
      LOGICAL,           DIMENSION(NCS)    :: EX
      INTEGER                              :: LU
      INTEGER                              :: NREF
      INTEGER                              :: IPERC
      INTEGER                              :: IFRQC
      INTEGER                              :: IFRQA
      INTEGER                              :: IFRQH
      INTEGER                              :: ISPGRC
      INTEGER                              :: ISPGRA
      INTEGER                              :: ISPGRH
      INTEGER                              :: IPCNTC
      INTEGER                              :: IPCNTA
      INTEGER                              :: IPCNTH
      INTEGER,           DIMENSION(3)      :: IR
      INTEGER,           DIMENSION(24)     :: INZ
      INTEGER,           DIMENSION(12)     :: ITL
      INTEGER,           DIMENSION(10)     :: NNZ
      INTEGER,           DIMENSION(NCS, 5) :: NUM
      REAL                                 :: RAVERC
      REAL                                 :: RAVERA
      REAL                                 :: RAVERH
      REAL,              DIMENSION(48)     :: XN
      REAL,              DIMENSION(12)     :: XTL
      REAL,              DIMENSION(12)     :: XNM
      REAL,              DIMENSION(10)     :: ANZ
      REAL,              DIMENSION(12)     :: FMN
      REAL,              DIMENSION(11)     :: CRI = (/1.0, 2.5,
     1  1.5, 5.0, 2.5, 10.0, 10.0, 20.0, 50.0, 100.0, 5.0/)
      REAL,              DIMENSION(15, 10) :: PNZ
      REAL,              DIMENSION(NCS, 5) :: SUMZ
      REAL,              DIMENSION(20)     :: STLS
      REAL,              DIMENSION(NCS)    :: XMFS
      REAL,              DIMENSION(3)      :: AVNZ
      REAL,              DIMENSION(3, 3)   :: TRMXS
      CHARACTER(len=5)                     :: LAUE
      CHARACTER(len=1)                     :: ILAT0
      CHARACTER(len=1)                     :: ILAT1
      CHARACTER(len=1),  DIMENSION(NCS)    :: EXT
      CHARACTER(len=16), DIMENSION(NCS)    :: EXTYPE = (/
     1 'HKL:H+K=2N     C', 'HKL:H+L=2N     B', 'HKL:K+L=2N     A',
     2 'HKL:H+K+L=2N   I', 'HKL:-H+K+L=3N oR', 'HKL:H-K+L=3N  rR',
     3 '0KL:K=2N      bx', '0KL:L=2N      cx', '0KL:K+L=2N    nx',
     4 'H0L:H=2N      ay', 'H0L:L=2N      cy', 'H0L:H+L=2N    ny',
     5 'HK0:H=2N      az', 'HK0:K=2N      bz', 'HK0:H+K=2N    nz',
     6 'H00:H=2N     21x', '0K0:K=2N     21y', '00L:L=2N     21z',
     7 '0KL:K+L=4N    dx', 'H0L:H+L=4N    dy', 'HK0:H+K=4N    dz',
     8 'H00:H=4N     41x', '0K0:K=4N     41y', '00L:L=4N     41z',
     9 'HHL:L=2N     cxy', 'HHL:H=2N        ', 'HHL:H+L=2N      ',
     * 'HHL:2H+L=4N     ', 'H-HL:H+L=3N     ', 'H-HL:-H+L=3N    ',
     1 '00L:L=6N     61z', 'HH0:H=2N        ', 'H-HL:L=2N       ',
     2 'HHL:L=3N        ', 'H-2HL:L=2N      ', '-2HHL:L=2N      ',
     3 'H-2HL:L=3N      ', '-2HHL:L=3N      ', '00L:L=3N     31z',
     4 'H-HL:H=2N       ', 'HKL:H=2N      2X', 'HKL:K=2N      2Y',
     5 'HKL:L=2N      2Z', 'HKL:H=3N      3X', 'HKL:K=3N      3Y',
     6 'HKL:L=3N      3Z', '-HKL, H-KL=3NtwR', '-HKL:K2,KL4P2tw2',
     7 '-HKL:H2,HL4P2tw2', '-HKL:H2,HK4P2tw2', 'HKL:H+2L=3N     ',
     8 'HKL:H+K+L=3N    '/)
      END MODULE dfspgr
 
      MODULE pl273
      SAVE
      INTEGER                    :: NSCF
      INTEGER, DIMENSION(192)    :: NSID
      INTEGER, DIMENSION(4, 192) :: NSCIF
      END MODULE pl273
 
      MODULE strain1
      SAVE
      INTEGER, DIMENSION(2)    :: ICV
      REAL,    DIMENSION(2, 6) :: VCAB
      REAL,    DIMENSION(2, 6) :: CELAB
      REAL,    DIMENSION(2)    :: TEMPAB
      END MODULE strain1
 
      SUBROUTINE PLA001
C * DATA INITIALIZATION
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE menus
      USE cggt
      USE dfspgr
      USE strain1
      USE pl273
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      PNZ(14, 1:10) = (/  9.52, 18.13, 25.92, 32.97, 39.25, 45.12,
     1  50.34, 55.07, 59.34, 63.21/)
      PNZ(15, 1:10) = (/ 24.81, 34.53, 41.87, 47.38, 52.05, 56.14,
     1  59.72, 62.89, 65.72, 68.33/)
      DO  I = 1, 20
        STLS(I) = ((I * 0.1) ** 0.3333333) / 1.5418
      END DO
      CALL GEN097 (MNH, 1, NP35, 0)
      IAN      = 0
      NSCF     = 0
      MNH(6)   = 2
      MNH(7)   = 2
      IGBL(6)  = 1
C * # ALIASES
      IPR(759) = 0
      IPR(760) = 0
      DO I = 1, NP36
        ALAB(I) = ' '
        BLAB(I) = ' '
        CLAB(I) = ' '
      END DO
      ILAT0    = ' '
      ILAT1    = 'P'
      LAUE     = ' '
      KRAD     = '??'
      INDP     = 0
      PAGET    = 'GENERAL'
C * SET DEFAULT FVAR SCALE
      RP(1)    = 1.0
      CALL GEN097 (MLTI, 1, 63, 1)
      CALL GEN097 (IXSD, 1, 6,  0)
      IGBL(8) = IABS(IGBL(8))
      IF (IGBL(53) == 0) THEN
        DO I = 1, NP65 + 1
          CALL GEN038 (BNDTP(I), 1, 5)
        END DO
      END IF
      CALL GEN038 (JID,  1, 80)
      CALL GEN038 (IGGT, 1, 80)
      DO I = 1, 25
        CALL GEN038 (LREF(I), 1, 80)
      END DO
      DO I = 1, 5
        RLWS(I) = ' ?'
      END DO
      DO I = 1, 4
        CALL GEN038 (SPGRNM(I), 1, 26)
      END DO
      CALL GEN038 (ZSPG     , 1, 7)
C * INIT IBT - BIT ARRAY
      CALL GEN048 (0, I, 0, I)
      CALL GEN097 (IPPR, 1, MP7 * 3, 0)
      CALL GEN097 (IFG,  1, NP1 * 3, 0)
      IPPR(1, 1) = 10000
      IPPR(1, 2) = 0
      IPPR(1, 3) = 1
      DO I = 1, NP10
        IENLB(I) = 0
        DO J = 1, 4
          RADR(I, J) = -1
        END DO
        IACL(I)  = 1
        DO J = 1, 2
          LMT(I, J) = '  '
          IENS(I)   = I
        END DO
      END DO
      DO I = 1, NP10
        DO J = 1, 3
          DISPVAL(I, J) = 0.0
        END DO
      END DO
      CALL GEN074 (ANIS,   1, NP1 * 6, 0.0)
      CALL GEN074 (SUAN,   1, NP1 * 7, 0.0)
      CALL GEN074 (TEMPAB, 1,  2, 0.0)
      CALL GEN074 (CELAB,  1, 12, 0.0)
      CALL GEN074 (SGY,    1, 13, 0.0)
      CALL GEN021 (TM1,  1.0)
      CALL GEN021 (TM2,  1.0)
      CALL GEN021 (RMAT, 1.0)
      CALL GEN021 (OR,   1.0)
      CALL GEN097 (ICV, 1, 2, 0)
C * INIT IPR & PAR ARRAYS
      CALL GEN074 (PAR, 1, NP13, 0.0)
      CALL GEN097 (IPR, 1, NP12, 0)
C * SET DEFAULT ANGSTROM CELL
      CALL GEN074 (PAR,  101, 103,  1.0)
      CALL GEN074 (PAR,  104, 106, 90.0)
      CALL GEN074 (SHFT,   1,   3,  0.0)
      CALL GEN097 (NSID, 1, 192,  0)
      DO I = 0, NP29
        NPOL(I) = 0
        MPOL(I) = 0
      END DO
      PAR(98) = 1.0
      DO I = 1, 3
        KRSYST(1) = '           ?'
      END DO
C * INIT USED CIF-AUDIT TOOL
      DO I = 1, NP56
        CCIF(I) = ' ?'
        NCIF(I) = 2
      END DO
      NEWLAT(1) = 1
C * INIT SPACE GROUP SYMMETRY TO P1
      CALL SGSM (1, IDM, SGY, 0, 0, IERR)
      IPR(48)  = 1
      IPR(146) = 10
      IAN      = 0
      ICLR     = 4
C * DEFAULT AXIAL ORDER
      IPR(34) = 1
      IPR(35) = 2
      IPR(36) = 3
C * MIN-FIT-PAIR
      IPR(28)  = 5
      IPR(40)  = 1
C * SET DEFAULT = UNIT WEIGHTS FOR LEAST-SQUARES PLANES
      IPR(41)  = 0
C * SET PROBABILITY = 50 PERCENT
      IPR(45)  = 5
C * START READING FROM LU1
      IGBL(5)  = LU1
C * SET PP NR
      IPR(65)  = 1
C * SET MAX CIRCUIT
      IPR(66)  = 7
C * SET MAX CHAIN
      IPR(82)  = 5
C * SET ROUND OPTION ON
      IPR(68)  = 2
C * LABEL PARENTHESES ON
      IPR(71)  = 0
C * DEFAULT TRNS
      IPR(95)  = 0
C * MAXIMUM BOND OVERFLOW
      IPR(96)  = NP6
C * EXPAND DEFAULT
      IPR(110) = 1
C * SET FOR UNIT LENGTH POLYHEDRA
      IPR(125) = 1
C * MAXIMUM NUMBER OF RESIDUES
      IPR(129) = NP29
C * DEFAULT MAXIMUM SQUEEZE CYCLES
      IPR(142) = 15
C * RG-STEREO
      IPR(143) = 2
      IPR(144) = 3
C * IN/EXCLUDE DISORDER OPERATIONS
      IPR(154) = 0
C * SET MAXIMUM COORDINATION ABOUT METAL FOR RING SEARCH
      IPR(159) = 6
C * SET OBSOLETE ALERT ON
      IGBL(134) = 1
C * SET LABEL ON
      IGBL(75) = 1
C * SET BONDS IN CONTOUR ON
      IPR(458) = 1
C * MAX COORDINATION FOR NEWMAN PLOT
      IPR(163) = 4
C * MIN NUMBER OF ATOMS IN TMA ANALYSIS
      IPR(21)  = 7
C * SET NFIRST CATOMS (ADP)
      IPR(175) = 1
C * SET C-ATOM ADP PAR
      IPR(176) = 1
C * SET NFIRST HATOMS (ADP)
      IPR(177) = 0
C * SET NLINES HATOMS (ADP)
      IPR(178) = 0
C * SET NFIRST (ADP)
      IPR(179) = 1
C * SET LINES (ADP)
      IPR(180) = 4
C * SET DEFAULT TO SHELXL ATWT
      IPR(181) = 1
C * SET DEFAULT COORDINATE DECIMALS
      IPR(183) = 6
C * SET H-ATOM PLOT (ADP)
      IPR(212) = 1
C * SET PROBE GRID STEP
      IPR(214) = 6
C * SET REDUCED RING-SIZE (DISORDER ETC)
      IPR(216) = 6
C * SET MAX METAL-RING SIZE + 1
      IPR(217) = 6
C * SET MAX H-RING-SIZE + 1
      IPR(218) = 18
C * SET MAX RING-SIZE + 1
      IPR(219) = 24
      IPR(579) = IPR(219)
C * HETERO ADP STYLE DEFAULT
      IPR(211) = 0
C * SET R/S DETERMINATION ON
      IPR(324) = 1
C * SET BEL SIGNAL (CTRL-G = ASCII 7)
      IPR(223) = 7
C * ABSORB/XTAL - CELLDIM ON
      IPR(331) = 1
C * SET COLOR ON
      IPR(346) = 1
C * NONH/EXOR
      IPR(366) = 25
C * 'END' Status
      IPR(460) = 3
      IPR(551) = 3
      IPR(507) = 3
C * EXOR-LOOP-MAX
      IPR(467) = 3
C * SET DEFAULT NO-Hydrogen Atoms
      IPR(484) = -1
C * RING-POP-PAR
      IPR(222) = 100
C * SET NUMBER OF LINES PER PAGE (OMEGA)
      IPR(243) = 60
C * SET Z = 1
      IPR(260) = 1
C * SET DOUBLE SPACE FORMAT TO 2 (SUPPLEMENTARY MATERIAL)
      IPR(274) = 2
C * SET FULL H-BOND ANALYSIS
      IPR(300) = 1
C * SET APPROXIMATE MAXIMUM NUMBER OF RINGS
      IPR(302) = 25
C * ADP LABEL PLOT PARAMETER
      IPR(350) = 0
C * (1/0) POLYHEDRON SKELETON PLOT
      IPR(353) = 1
C * POLYHEDRON DEFAULT RANGE
      IPR(354) = -1
C * POLYHEDRON OMIT OUTSIDE DEFAULT
      IPR(356) = -1
C * PERSPECTIVE VIEW
      IPR(355) = 0
C * DRAW UNITCELL OUTLINE
      IPR(357) = 1
C * SHADE POLY
      IPR(358) = 1
C * Incl Atoms (Poly)
      IPR(359) = 1
C * (NO)CHECK (DIR COS)
      IPR(363) = 1
C * X-H/PLANE ANGLE CALC (0/1) default
      IPR(368) = 0
C * ASYM LIST OPTION
      IPR(392) = 3
C * ASYM ZONEL
      IPR(394) = 3
C * DEFAULT CONTOUR
      IPR(419) = 10
C * DEFAULT NUMBER OF DOAC ATOM TYPES
      IPR(480) = 11
C * EXOR/NV
      IPR(482) = 4
C * ANION/SOLVENT CRIT
      IPR(487) = 10
C * SET R/S-ANALYSIS DEPTH
      IPR(492) = 6
C * CONTOUR/ORTEP XR/YR/ZR
      IPR(505) = 1
C * SET MAXIMUM 2-AXES (LEPAGE)
      IPR(514) = 9
C * SET FOURIER CUT-OFF AT 2 SIGMA(I)
      IPR(515) = 2
C * PLA202 DEFAULTS
      IPR(523) = 6
      IPR(524) = 3
C * LABEL AXES TOGGLE (SOLV PLOT)
      IPR(532) = 1
C * TWINROTMAT - NSELMIN
      IPR(550) = 50
C * TWINROTMAT MAXIND
      IPR(567) = 5
C * (0/1) Displ d-val
      IPR(569) = 1
C * NUMBER OF MARCHING CUBE SECTION DEFAULTS
      IPR(577) = 5
      IPR(578) = 5
C * POPULATION MIN FOR R/S ANALYSIS
      IPR(582) = 2500
      IF (IGBL(47) > 0) THEN
        IPR(590) = 1
      ELSE
        IPR(590) = 0
      END IF
C * FCALC FOR BIJVOET (FROM CIF)
      IPR(594) = 1
C * MAXIMUM NUMBER OF BIJVOET PAIRS TO BE LISTED
      IPR(596) = 50
C * RESD SORT ON NR OF ATOMS
      IPR(597) = 1
C * PLOT VOID AXES
      IPR(598) = 1
C * MAXIMUM NUMBER OF TWIN_LAWS TESTED
      IPR(607) = 25
C * BIJVOET SELECTION CRITERIUM
      IPR(611) = 2
C * MAX SQUEEZE/SHELXL CYCLES
      IPR(682) = 5
      IPR(735) = 5
C * BIJVOET NU-CRIT
      PAR(487) = 10.0
C * ICHX
      IPR(645) = 0
C * HKLF DEFAULT
      IPR(648) = 4
C * ADD CALCULATED SOLVENT CONTRIBUTION FOR MISSING REFLECTIONS (= 1)
      IPR(681) = 1
C * MAXINUM NUMBER OF ATOMS IN P1 SET FOR ADDSYM/CheckCIF TEST
      IPR(737) = 2500
C * MONTE CARLO # IN SASA
      IPR(743) = 5000
C * AXIS/RAW TWINLOOP MAX DEFAULT
      IPR(774) = 2
C * SHOW ABSENCIES
      IPR(776) = 1
C * INIT PAR-PARAMETERS
C * INTRA TOLERANCE
      PAR(2)   = 0.4
C * INTER VDW TOLERANCE
      PAR(3)   = 0.2
C * DEFAULT CALC COORDN RADIUS
      PAR(7)   = 3.6
      PAR(11)  = 1.0
C * SMALL INCREMENT FOR  THE CALCULATION OF NUMERICAL DERIVATIVES
      PAR(12)  = 0.0001
      PAR(15)  = 160.0
      PAR(17)  = -999999.0
      PAR(18)  = 0.01
C * SYMMETRY EQUIVALENCE CRITERIUM
      PAR(22)  = 0.3
      PAR(24)  = 1.0
      PAR(25)  = 0.4
C * (EARTH)ALKALI ADDITIONAL INTRA TOLERANCE IN CONTACTS WITH NON-METALS
      PAR(26)  = 0.70
C * METAL-METAL TOL
      PAR(27)  = - PAR(2)
C * TOL CSD-CELL
      PAR(28)  = 0.25
      PAR(29)  = 1.0
C * DEFAULT U(ISO)
      PAR(30)  = 0.05
C * DEFAULT TRANS BASAL ANGLE
      PAR(31)  = 150.0
C * TRMXS DET - DEFAULT
      PAR(32)  = 1.0
      PAR(33)  = 100.0
C * RIND - LIMIT (TMA)
      PAR(34)  = 0.25
C * MAX RING-RING CG DIST
      PAR(36)  = 6.0
C * PLOT SIZE
      PAR(37)  = RGBL(1)
      PAR(38)  = RGBL(1)
C * SET RESCALE FACTOR FOR SPACEFILL
      PAR(39)  = 1.0
      PAR(40)  = 0.25
      PAR(41)  = 0.75
C * ARU-PACK CONSTANT
      PAR(42)  = 100.0
C * ADDSYM/LEPAGE CRITERIUM
      PAR(43)  = 1.0
C * ADP OVERLAP MARGIN
      PAR(44)  = 0.075
      PAR(48)  = 0.375
C * LSPL TOLERANCE
      PAR(49)  = 0.1
C * DEFAULT HOR/VERT RATIO
      PAR(50)  = (4.0 - IGBL(46)) / 3.0
      PAR(51)  = 1.25
      PAR(52)  = 0.5
      PAR(53)  = 0.2
C * TOL IN ADP
      PAR(54)  = 1.E-5
C * Cg-Ring-Ring ANGLE TEST
      PAR(62)  = 60.0
C * WAVEL SEL CRIT
      PAR(63)  = 0.0005
      PAR(69)  = 4.0
C * MAX-RING SLIPPAGE (ADP)
      PAR(70)  = 0.3
C * SMALL LABEL OFFSET
      PAR(71)  = 0.05
C * STICK LABEL SIZE
      PAR(72)  = 0.25
C * MOLSYM PARAMETER
      PAR(73)  = 0.1
C * DEFAULT FVAR
      PAR(74)  = 1.0
C * MOLSYM PARAMETER (DCM-MAX)
      PAR(75)  = 0.8
      PAR(76)  = 1.5
C * DIRECTION COSINE TEST PARAMETERS
      PAR(77)  = 0.03
      PAR(78)  = 0.5
C * SOLV/VOID DEFAULT GRID
      PAR(80)  = 0.2
C * SET PROBE RADIUS
      PAR(84)  = 1.20
C * ADP NORMAL BOND PARAMETERS
      PAR(85)  = 4
      PAR(86)  = 0.03
C * ADP KODE 4 PARAMETERS
      PAR(87)  = 2
      PAR(88)  = 0.02
C * ADP KODE 1 PARAMETERS
      PAR(89)  = 5
      PAR(90)  = 0.05
C * ADP DISORDER BOND PARAMETERS
      PAR(91)  = 2
      PAR(92)  = 0.02
C * SMALL INCREMENT FOR THE CALCULATION OF NUMERICAL DERIVATIVES
      PAR(93)  = 0.001
C * SET TAUPUCK CRITERIUM
      PAR(94)  = 10.0
C * SET MINIMUM NON-PLANAR TAU
      PAR(95)  = 5.0
C * SET TAUPLAN CRITERIUM
      PAR(96)  = 10.0
      PAR(97)  = 25.0
C * SPGR-FROM-EXT RATIO
      PAR(141) = 5.0
C * ASYM/SHELX OMIT TMAX
      PAR(165) = 90.0
C * CLOSE CONTACT COUNT CRITERIUM
      PAR(199) = -1.0
C * RADII SCALE
      PAR(213) = 0.5
C * TETRAEDER CRITERIA
      PAR(214) = 109.0
      PAR(215) = 20.0
      PAR(216) = 1.62
      PAR(217) = 0.2
C * OCTAEDER CRITERIA
      PAR(218) = 90.0
      PAR(219) = 20.0
      PAR(220) = 1.97
      PAR(221) = 0.4
C * DEFAULT HKLF - TRANSFORMATION
      PAR(231) = 1.0
      PAR(235) = 1.0
      PAR(239) = 1.0
C * DETERMINANT OF TRANSFORMATION MATRIX
      PAR(240) = 1.0
C * NEWSYM PARAMETERS U AND RESOLUTION & AXIAL CRIT
      PAR(247) = 0.05
      PAR(248) = 0.6
C * SET SQUEEZE STOP CRITERIUM FOOO
      PAR(249) = 0.0002
C * SET SQUEEZE STOP CRITERIUM  (ELECTRONS PER ASYMMETRIC VOID)
      PAR(250) = 0.1
C * CLOSE CONTACT COUNT CRITERIUM (H-H)
      PAR(251) = -0.25
      PAR(253) = -0.25
C * X-H..Cg(Pi) CRITERIA
      PAR(263) = 3.0
      PAR(264) = 40.0
C * DEFAULT H & NON-H ISOTROPIC RADII
      PAR(265) = 0.1
      PAR(266) = 0.2
C * RHO-CUT-OFF
      PAR(268) = 0.5
      PAR(269) = 0.5
C * RATIO (CONTOUR)
      PAR(270) = 0.2
C * RESOL (CONTOUR)
      PAR(271) = 0.3
C * HOR & VERT SIZE (ANGSTROM) CONTOUR-PLOT
      PAR(273) = 10.0
      PAR(272) = PAR(273) * 4.0 / 3.0
C * TOL (DIST TO CONTOUR-PLANE)
      PAR(279) = 1.5
C * BOND TEST CRIT
      PAR(280) = 0.1
C * EXOR/STHMN
      PAR(281) = 0.2
C * EXOR/STHM
      PAR(282) = 1.0
C * EXOR/SOEM
      PAR(283) = 0.05
C * EXOR/SS
      PAR(284) = 1.E5
C * SQUEEZE RHO-CUTOFF
      PAR(285) = 0.0
C * LISTING SINT/L MAX (SQUEEZE)
      PAR(286) = 0.15
C * DEFAULT SINTH/LAMBDA MAX
      PAR(287) = 1.0 / 1.54184
C * SQUEEZE LIST PAR
      PAR(288) = 2.0
C * SINTH/L - MIN FOR SQUEEZE SCALING
      PAR(290) = 0.2
C * SQUEEZE DELTA-F OUTLIER CRITERIUM
      PAR(292) = 500.0
C * SET X-H NORM VALUES
C * Allen & Bruno (Acta Cryst. (2010). B66, 380-386
      PAR(294) = 1.185
      PAR(295) = 1.506
      PAR(296) = 1.098
      PAR(297) = 1.036
      PAR(298) = 0.983
C * RELATIVE XTAL PLOTSCALE
      PAR(325) = 1.0
C * UMIN - MULABS
      PAR(326) = 0.5E-15
C * YES/NO C & P ANALYSE
      PAR(328) = 25.0
C * NON-INT LEVEL
      PAR(331) = 0.011
C * ADP LABEL SIZE
      PAR(349) = 0.25
C * INTERACTIVE TEXT-SIZE
      PAR(350) = 0.55
C * POWDER PARAMETERS (LORENTZIAN ALFA)
      PAR(371) = 0.1
      PAR(372) = 1.0
C * DELRED CRITERIA
      PAR(381) = 1.0
      PAR(382) = 0.5
      PAR(383) = 0.2
C * PLA030/DOUBLE BOND CRITERIUM
      PAR(384) = 1.41
C * DAMP IN C&P
      PAR(410) = 0.00000001
C * POWDER-SCAN STEP
      PAR(411) = 0.02
C * STHLMAX CONTOURMAP
      PAR(412) = 100.0
C * RATMIN (TWINROTMAT)
      PAR(413) = 4.0
C * THDEL (TWINROTMAT)
      PAR(414) = 0.10
C * HKLF5-PAR (TwinRotMat)
      PAR(415) = 0.1
C * ALPHA-MIN
      PAR(416) = 0.01
C * SHXABS - PARAM (TH & DU)
      PAR(417) = 5.0
      PAR(418) = 0.0
C * BEAM-STOP THETA-MIN
      PAR(419) = 2.5
C * TWIN-DELTH
      PAR(420) = 0.10
C * HIRSHFELD RIGID-BOND TEST CRIT
      PAR(421) = 5.0
C * METAL-RING MAX DIST (FOR RING SLIPPAGE)
      PAR(422) = 3.5
      PAR(423) = 2.0
      PAR(424) = 1.5
C * RING-RING SLIPPAGE ALPHA-MAX
      PAR(427) = 20.0
C * MINIMUM CAVITY RADIUS
      PAR(519) = 1.2
C * MAXIMUM EXPECTED CAVITY RADIUS
      PAR(520) = 5.0
C * NEWSYM/LAUE R_MAX
      PAR(429) = 5.0
C * SPGR/LAUE RMAX-GREEN/RED-COLOUR
      PAR(430) = 10.0
C * SPGR/LAUE RMAX=LIST
      PAR(431) = 40.0
C * SPGR/LAUE-%Ct COLOUR
      PAR(432) = 80.0
C * SPGR/LEPAGE CRIT
      PAR(439) = 0.4
      PAR(440) = 1000.0
      PAR(441) = 0.4
C * TOLERANCE ON SIN(THETA)/LAMBDA FOR SQUEEZE
      PAR(442) = 0.000
C * Y-X..Cg(Pi) CRITERIA
      PAR(447) = 4.0
      PAR(448) = 30.0
C * Default TwinPlot Resolution
      PAR(449) = 0.4
C * Default RDF-Radius
      PAR(450) = 5.0
C * DEFAULT RDF-SIGMA
      PAR(451) = 5.0
C * DEFAULT BIJVOET SIGMA-CRIT
      PAR(452) = 0.25
C * MIN. Bond Valence Contrib
      PAR(454) = 0.04
C * MAXIMUM Me-H DIST
      PAR(461) = 2.1
C * RFLMX (PLA350)
      PAR(466) = 0.50
C * REXMX (PLA350)
      PAR(467) = 0.30
C * RVALHALF (PLA350)
      PAR(468) = 0.40
C * (NON)MEROHEDRAL TEST
      PAR(473) = 0.10
C * DEFAULT FACTOR (FLIPPER)
      PAR(475) = 0.02
C * BIJVOET COVERAGE MIN
      PAR(476) = 80.0
C * RMS-FIT-MAX
      PAR(483) = 0.5
C * LESS THAN CRIT
      PAR(484) = 2.0
C * I/SIG-MAX
      PAR(485) = 400.0
C * SQUEEZE MISSING REFLECTION SIN(THETA)/LAMBDA
      PAR(486) = 0.25
C * TWO-THETA CUTOFF DEFAULT
      PAR(500) = 180.0
C * HOOFT Y STEP
      PAR(515) = 0.025
C * DEFAULT SINTH/LAMBDA MAX FOR HKLF-GENER
      PAR(540) = 1.0 / 1.54184
C * ZN-O,N ADD
      PAR(541) = 0.20
C * CU-O,N ADD
      PAR(542) = 0.35
C * MN-O,N ADD
      PAR(543) = 0.40
C * AG-O,N ADD
      PAR(544) = 0.20
C * CR-O,N ADD
      PAR(545) = 0.20
C * TL-O,N
      PAR(546) = 0.30
C * AVER TOL CREATE SHX
      PAR(547) = 0.20
C * PROBE RADIUS SASA OPTION
      PAR(557) = 1.84
C * GRIDSTEP MOLVOL
      PAR(569) = 0.1
C * DEF INIT (CIF)
      DO I = 262, 272
        IPR(I) = -999999
      END DO
      IPR(267) = - IPR(268)
      IPR(269) = - IPR(270)
      IPR(271) = - IPR(272)
      IPR(261) = -999999
      IPR(310) = -999999
      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(227) = -999999.0
      PAR(228) = -999999.0
      PAR(229) = -999999.0
      PAR(312) = -999999.0
      PAR(313) = -999999.0
      PAR(314) = -999999.0
      PAR(425) = -999999.0
      PAR(433) =  999999.0
      PAR(434) =  999999.0
      PAR(435) =  999999.0
      PAR(436) =  999999.0
      PAR(471) = -999999.0
      PAR(474) = -999999.0
      PAR(493) = -999999.0
      PAR(503) =  999999.0
      PAR(559) = -999999.0
      PAR(563) = -999999.0
C * NOW READ THE DATA
      IGBL(1)   = 2
C * FCF CHECK
      IGBL(129) = - IABS(IGBL(129))
      RETURN
      END SUBROUTINE PLA001
 
      MODULE chdat
      SAVE
      INTEGER, PARAMETER :: NP22 = 80
      INTEGER, PARAMETER :: NP24 = 224
      INTEGER, PARAMETER :: NP37 = 191
C * KEYWORDS (PLATON)
      CHARACTER(len=4), DIMENSION(NP24) :: ISWS = (/
     1 'TITL', 'MESS', 'REM ', 'ANGS', 'ROUN', 'FIT ', 'LSPL', 'RING',
     2 'NOMO', 'MOLV', 'DOAC', 'LINE', 'ENDS', 'PLOT', 'YES ', 'NO  ',
     3 'CALC', 'END ', 'INCL', 'EXCL', 'STOP', 'HELP', 'SAVE', 'UIJ ',
     4 'SUIJ', 'U   ', 'ATOM', 'LIST', 'CELL', 'CESD', 'SYMM', 'SPGR',
     5 'LATT', 'DIST', 'ANGL', 'TORS', 'HBON', 'BIJ ', 'SBIJ', 'B   ',
     6 'TRNS', 'FVAR', 'PARE', 'QUIT', 'SET ', 'AFIX', 'SFAC', 'UNIT',
     7 'WGHT', 'VIEW', 'BOX ', 'EXIT', 'BOND', 'ZERR', 'GEOM', 'L   ',
     8 'FMAP', 'INFO', 'TABL', 'RADI', 'BLOC', 'MENU', 'OMIT', 'GRID',
     9 'DFIX', 'JOIN', 'DETA', 'DEFI', 'HKLF', 'RADN', 'TRMX', 'PART',
     * 'INOR', 'ORGA', 'RTAB', 'SIMU', 'ENTR', 'ELLI', 'ORMA', 'EXTI',
     1 'SETU', 'EXOR', 'ABSG', 'FACE', 'ABST', 'ABSX', 'LEPA', 'ASYM',
     2 'ABSP', 'ABSS', 'CONT', 'REST', 'VALI', 'EXPT', 'PLUT', 'MOLE',
     3 'PLAN', 'TWIN', 'SPEC', 'MERG', 'SUMP', 'RESI', 'SHEL', 'MORE',
     4 'TIME', 'CGLS', 'ACTA', 'DAMP', 'DISP', 'SLIM', 'SIZE', 'EQIV',
     5 'EXYZ', 'EADP', 'NCSY', 'FREE', 'BIND', 'SAME', 'CONF', 'MPLA',
     6 'FLAT', 'CHIV', 'DELU', 'ISOR', 'SADI', 'ANIS', 'CONN', 'HFIX',
     7 'LAUE', 'BUMP', 'TEMP', 'DEFS', 'ABSC', 'SWAT', 'EMPI', 'LAMI',
     8 'HOPE', 'DMAT', 'SKIP', 'WPDB', 'BASF', 'MOVE', 'FRAG', 'FEND',
     9 'HALL', 'HTAB', 'MULA', 'HKLT', 'XTAL', 'HINC', 'HEXC', 'FILE',
     * 'RENA', 'SYST', 'DELR', 'EXP1', 'ARU ', 'VARI', 'FCF2', 'PORT',
     1 'POWD', 'FSUM', 'SCAL', 'CRYS', 'ROTM', 'CAVI', 'SHXA', 'DELE',
     2 'COLO', 'RESE', 'SCAT', 'STID', 'BIJV', 'FLIP', 'STRU', 'FROM',
     3 'STRA', 'CELA', 'CELB', 'CSUA', 'CSUB', 'CIF2', 'NOEX', 'RESD',
     4 'ANOM', 'MU  ', 'XTPL', 'ABIN', 'ANSC', 'ANSR', 'NEUT', 'PRIG',
     5 'RIGU', 'STIR', 'TWST', 'WIGL', 'XNPD', 'HYBR', 'BYPA', 'DANG',
     6 'ADDS', 'NEWS', 'SQUE', 'WILS', 'FCF ', 'PAIR', 'BEDE', 'LONE',
     7 'SASA', 'NONS', 'ADP ', 'SOLV', 'NEWM', 'RADI', 'VOLC', 'NONB',
     8 'CIP ', 'ORTE', '    ', '    ', '    ', '    ', '    ', '    '/)
C * SUB-KEYWORDS (PLATON)
      CHARACTER(len=4), DIMENSION(NP22) :: ISWSS = (/
     1 'GEOM', 'TMA ', 'INTR', 'INTE', 'NOTM', 'NOAN', 'NOTO', 'NOLS',
     2 'NOST', 'NORI', 'NOBO', 'NOMO', 'NOSY', 'NOBP', 'EWLS', 'TOLA',
     3 'COOR', 'META', 'AWLS', 'HBON', 'UWLS', 'SHEL', 'OMEG', 'ICHX',
     4 'SPF ', 'FIVE', 'ALL ', 'TOLP', 'TOLR', 'NOTH', 'VOID', 'PROB',
     5 'PSTE', 'LIST', 'EXPA', 'DIST', 'TOLE', 'MISS', 'SOLV', 'TOLM',
     6 'NODI', 'BOND', 'ANGL', 'TORS', 'CSD ', 'SQUE', 'SAV ', 'FCF ',
     7 'CYCL', 'NEWS', 'NOCH', 'PDB ', 'HINC', 'NONS', 'NONA', 'MAXD',
     8 'WLSP', 'FCAL', 'ADDS', 'DIFF', 'NOSO', 'DISO', 'GENE', 'EXPE',
     9 'MAXR', 'MOLS', 'RENU', 'PLOT', 'RDF ', 'GRID', 'F3D ', 'NOSF',
     * '    ', '    ', '    ', '    ', '    ', '    ', '    ', '    '/)
      CHARACTER(len=2), DIMENSION(16)   :: LABP = (/
     1 '  ', 'AU', 'E ', 'NE', 'N ', 'NW', 'W ', 'SW', 'S ', 'SE',
     2 'NU', '  ', '  ', '  ', '  ', 'MS'/)
C * KEYWORDS (PLUTON)
      CHARACTER(len=4), DIMENSION(NP37) :: CRD = (/
     1         'TITL', 'MESS', 'REM ', 'CELL', 'SPGR', 'LATT', 'LIST',
     2 'SYMM', 'ANGS', 'ROD ', 'ATOM', 'JOIN', 'END ', 'UIJ ', 'SUIJ',
     3 'U   ', 'VIEW', 'SOLI', 'STIC', 'LABE', 'UNLA', 'PUT ', 'RADI',
     4 'PACK', 'MOLE', 'INCL', 'EXCL', 'UNIT', 'RETR', 'STER', 'MONO',
     5 'SIZE', 'PLOT', 'RESE', 'SEGM', 'ECHO', 'HP  ', 'CAL ', 'COLO',
     6 'SET ', 'OMIT', 'STOP', 'RESI', 'ANGL', 'DETA', 'SAVE', 'OVER',
     7 'QUIT', 'ORT ', 'BOX ', 'FVAR', 'HELP', 'BIJ ', 'B   ', 'CESD',
     8 'SBIJ', 'CPK ', 'SFAC', 'DFIX', 'AFIX', 'DIST', 'TORS', 'BWC ',
     9 'TRNS', 'WAIT', 'INOR', 'ORGA', 'STRA', 'INFO', 'ARU ', 'CROT',
     * 'XROT', 'YROT', 'ZROT', 'DEFI', 'BLOC', 'RENA', 'GEOM', 'MENU',
     1 'ZERO', 'HKLF', 'L   ', 'PART', 'RTAB', 'SIMU', 'COOR', 'SADI',
     2 'DELE', 'ENTR', 'DIR ', 'HFIX', 'TRMX', 'PLAN', 'GRID', 'FMAP',
     3 'MOVE', 'SWAT', 'WPDB', 'BASF', 'EXTI', 'FRAG', 'FEND', 'TWIN',
     4 'SPEC', 'MERG', 'SUMP', 'SHEL', 'MORE', 'TIME', 'CGLS', 'ACTA',
     5 'DAMP', 'DISP', 'SLIM', 'EQIV', 'EXYZ', 'EADP', 'BOND', 'FREE',
     6 'BIND', 'SAME', 'CONN', 'LAUE', 'BUMP', 'TEMP', 'XXXX', 'ABS ',
     7 'FACE', 'EMPI', 'LAMB', 'HOPE', 'DMAT', 'SKIP', 'ANIS', 'WGHT',
     8 'EXOR', 'ISOR', 'RADN', 'ENDS', 'ZERR', 'DELU', 'NOMO', 'RESD',
     9 'NOSO', 'DEFS', 'HALL', 'FLAT', 'HTAB', 'EXIT', 'MPLA', 'PORT',
     * 'FSUM', 'SCAL', 'CRYS', 'CALC', 'REN ', 'LAB ', 'DEL ', 'CONF',
     1 'VIE ', 'SOL ', 'STI ', 'UNL ', 'INC ', 'EXC ', 'UNI ', 'PAC ',
     2 'SCAT', 'FIT ', 'ABIN', 'ANSC', 'ANSR', 'NEUT', 'PRIG', 'RIGU',
     3 'STIR', 'TWST', 'WIGL', 'XNPD', 'DANG', 'PAIR', 'BEDE', 'LONE',
     4 'TEXT', '    ', '    ', '    ', '    ', '    ', '    ', '    '/)
      END MODULE chdat
 
      MODULE crystal
      SAVE
      INTEGER,          PARAMETER :: NXT1 = 100
      INTEGER,          PARAMETER :: NXT2 = 200
      INTEGER,          PARAMETER :: NXT3 = 100
      INTEGER,          PARAMETER :: NXT4 = 200
      INTEGER                     :: NVER
      INTEGER                     :: NVRR
      INTEGER                     :: NEDGE
      INTEGER                     :: NFACES
      INTEGER, DIMENSION(NXT4, 4) :: IDG
      INTEGER, DIMENSION(21)      :: IHLP
      INTEGER, DIMENSION(NXT3)    :: IEDGE
      REAL,    DIMENSION(7, NXT2) :: XTLV
      REAL,    DIMENSION(NXT1, 5) :: PMILL
      REAL,    DIMENSION(3, NXT2) :: XYZPL
      REAL,    DIMENSION(5, NXT2) :: CFACE
      END MODULE crystal
 
      MODULE spgrdata
      SAVE
      CHARACTER(len=5), DIMENSION(14)  :: NLAUE = (/
     1 '   -1', '  2/m', '  mmm', '  4/m', '4/mmm', '   -3', ' -3m1',
     2 ' -31m', '  6/m', '6/mmm', '  m-3', ' m-3m', '     ', '  -3m'/)
      CHARACTER(len=12), DIMENSION(8)  :: XSYST = (/
     1 '   Triclinic', '  Monoclinic', 'Orthorhombic', '  Tetragonal',
     2 '    Trigonal', '   Hexagonal', '       Cubic', '            '/)
      CHARACTER(len=1),  DIMENSION(8)  :: IBVL = (/
     1 'a', 'm', 'o', 't', 'r', 'h', 'c', ' '/)
      CHARACTER(len=5),  DIMENSION(12) :: LGR = (/
     1 '   -1', '  2/m', '  mmm', '  4/m', '4/mmm', '   -3', '  -3m',
     2 '  6/m', '6/mmm', '  m-3', ' m-3m', '     '/)
      CHARACTER(len=1),  DIMENSION(7)  :: LAT = (/
     1 'P', 'A', 'B', 'C', 'F', 'I', 'R'/)
      END MODULE spgrdata
 
      SUBROUTINE PLA002
C * MAIN (INSTRUCTION) INPUT LOOP ROUTINE (LU1 > LU3 > LU5)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE menus
      USE spgrdata
      USE crystal
      USE dfspgr
      USE strain1
      USE chdat
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: JB
      INTEGER          :: JE
      INTEGER          :: N1
      INTEGER          :: IS
      INTEGER          :: NR
      INTEGER          :: NN
      INTEGER          :: K0
      INTEGER          :: KN
      INTEGER          :: IP
      INTEGER          :: ISS
      INTEGER          :: NID
      INTEGER          :: N12
      INTEGER          :: LBB
      INTEGER          :: LBC
      INTEGER          :: LBD
      INTEGER          :: ICT
      INTEGER          :: MODE
      INTEGER          :: NIEN
      INTEGER          :: NTYP
      INTEGER          :: NSMR
      INTEGER          :: NRET
      INTEGER          :: MORT
      INTEGER          :: ITRS
      INTEGER          :: IENM
      INTEGER          :: IDUM2
      INTEGER          :: IEXIT
      INTEGER          :: IFN10
      INTEGER          :: ITRNS
      INTEGER          :: IYUNK
      INTEGER          :: IRETN
      INTEGER          :: INQNR
      INTEGER          :: JNQNR
      INTEGER          :: JNQNR2
      INTEGER          :: INQNR2
      INTEGER          :: IPR220
      INTEGER          :: NRETURN = 0
      INTEGER          :: IUNKNOWN
      REAL             :: ANG
      REAL             :: FNN
      REAL             :: FN1
      REAL             :: FN2
      REAL             :: DET
      REAL             :: DIFF
      REAL             :: GEN016
      CHARACTER(len=3) :: OPT
      CHARACTER(len=9) :: EXTENS1
C * TEST FOR 'CALC' = 'CALC ALL' JOB (i.e. IPR(121) > 0)
  10  IF (IPR(121) == 0) THEN
C * DEFAULT POSITION OF LABEL IN ATOM RECORD
        IPR(473) = 2
C * DATA READ SEQUENCE LU1, LU3, LU5
C * GET NEXT INPUT-LINE AND RECORD TYPE (IN IS)
        CALL PLA006 (0, IS)
C * ERROR CHECK
        IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
          IGBL(1) = 3
          RETURN
        END IF
C * CHECK FOR AND HANDLE SHELX(L) TYPE INPUT RECORDS
        CALL PLA383 (IS)
        DO
          SELECT CASE (IS)
C * IS = -4: SHELXL INSTRUCTION RECORD
            CASE (-4)
              EXIT
C * IS = -3: CIF BOND/ANGLE/TORSION/HBOND
            CASE (-3)
              GO TO 10
C * IS = -1 & IS = -2: HANDLE END-OF-FILE (SWITCH TO LU3 OR LU5 RESP. READING)
            CASE (-1, -2)
              IF (IGBL(5) == LU5) THEN
                GO TO 190
              ELSE IF (IGBL(5) == LU3) THEN
                IGBL(5) = LU5
C * OPEN MAIN X-WINDOW (IGBL(24) = 1)
                IGBL(6)  = 10
                IGBL(24) = 1
                GO TO 10
              ELSE
C * CHECK FOR NO-ATOMS & NO-FACES AND NO-CELL INFO FOUND
                IF (IPR(37) == 0 .AND. IPR(367) == 0 .AND.
     1              PAR(101) == 0.0) GO TO 200
C * CHECK FOR 'ENDS'
                IF (IPR(3) == 1) THEN
                  IPR(3) = -1
                  GO TO 200
                ELSE
                  IGBL(5) = LU3
                END IF
              END IF
              CALL GEN108 (LU3, 0)
              GO TO 10
C * IS = 0: FORMAT/READ - ERROR
            CASE (0)
              IPR(2) = 61
              GO TO 200
C * IS = 1, 28: POTENTIAL ATOM LINE/ATOM
            CASE (1, 28)
              IF (IS == 1) THEN
                IF (IGBL(5) == 5) GO TO 10
                IPR(473) = 1
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) /= 0) THEN
C * UNKNOWN CARD ERROR
                  IPR(2) = 7
                  GO TO 200
                END IF
              END IF
C * ATOMIC COORDS IN FREE-FORMAT INPUT
              IF (IPR(220) < IPR(473) .OR. IPR(221) < 3) THEN
                IPR(471) = IPR(471) + 1
                IF (IGBL(5) == LU5) THEN
C * UNKNOWN CARD ERROR
                  IPR(2) = 7
                  GO TO 200
                END IF
              ELSE
                IF (IGBL(8) /= 2 .OR. IGBL(95) /= 1 .OR.
     1            IFL(1)(1:1) /= 'Q' .OR. FN(7) >= RGBL(26)) THEN
                  CALL PLA022 (INQNR)
C * CHECK FOR ERROR RETURN
                  IF (IPR(2) /= 0) THEN
                    IF (IPR(2) == 10) THEN
                      IGBL(1) = 3
                      RETURN
                    ELSE
                      GO TO 200
                    END IF
                  END IF
                END IF
              END IF
              GO TO 10
C * IS = 3: MESSAGE (ECHO)
            CASE (3)
              WRITE (LU6, 99988, IOSTAT = IOST) ICL(5:80)
              GO TO 10
C * IS = 5: ANGSTROM COORDINATE SCALE
            CASE (5)
              IF (IPR(221) == 1) THEN
                CALL PLA100
                PAR(11) = FN(1)
              END IF
              GO TO 10
C * IS = 6: ROUND ON/OFF OPTION
            CASE (6)
              IF (IPR(221) == 1) THEN
                IPR(68) = MAX (MIN (NINT(FN(1)), 10), 0)
              ELSE
                IPR(68) = 1
              END IF
              IF (IPR(220) > 1) THEN
                IF (IFL(2)(1:3) == 'OFF') THEN
                  IPR(68) = 0
                END IF
              END IF
              IF (IPR(68) > 0) THEN
                CALL GEN040 (IPR(68), NQ1, IP)
                WRITE (LU6, 99990, IOSTAT = IOST) IPR(68) * 10 - 1
              END IF
              GO TO 180
C * IS = 7: FIT MOL1 ON MOL2 (OR INVERTED MOL2)
            CASE (7)
C * SAVE OPTION TEST
              IF (IGBL(45) > 0 .AND. IGBL(5) == LU5) THEN
                IGBL(45) = IGBL(45) + 1
                WRITE (LU3, 99984, IOSTAT = IOST) ICL(1:80)
                WRITE (LU6, 99973, IOSTAT = IOST) ICL(1:70)
              END IF
              IF (IPR(220) == 1 .AND. IPR(221) == 0) THEN
                IPR(1)  = 7
                IPR(81) = -1
                CALL PLA021 (11, NRETURN)
                RETURN
              ELSE
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) == 0) THEN
C * FIT RES-NR1 RES-NR2
                  IF (IPR(221) == 2) THEN
                    FN1      = FN(1)
                    FN2      = FN(2)
                    IPR(221) = 0
C * NO SORTING WHEN NON-ZERO NUMBER OF ALIASES
                    IF (IPR(759) > 0) IGBL(33) = 0
                    WRITE (LU6, 99963)
C * SET UP CONNECTED SET
                    CALL PLA067
                    IF (IPR(2) /= 0) RETURN
                    CALL PLA073 (-1, -1)
                    FN(1)    = FN1
                    FN(2)    = FN2
                    IPR(221) = 2
                    IPR(220) = - IPR(220)
C * FIT ATOM-NAME1 ATOM-NAME2
                  ELSE IF (IPR(220) == 3) THEN
                    IPR220   = IPR(220)
                    IPR(220) = 1
C * SET UP CONNECTED SET
                    CALL PLA067
                    IF (IPR(2) /= 0) RETURN
                    CALL PLA073 (-1, -1)
                    IPR(220) = - IPR220
                  ELSE
                    NTYP = 0
                    GO TO 20
                  END IF
                ELSE
                  IPR(220) = - IPR(220)
                END IF
                GO TO 30
              END IF
              GO TO 10
C * IS = 8: LSPL: EXPLICIT PLANE SPECIFICATION
            CASE (8)
              NTYP = 4
              GO TO 20
C * IS = 9: RING: EXPLICIT RING SPECIFICATION
            CASE (9)
              NTYP = 2
              GO TO 20
C * IS = 10: NOMOVE (OFF)
            CASE (10)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
                IF (IPR(220) > 1 .AND. IFL(2)(1:3) == 'OFF') THEN
                  IGBL(30) = 0
C * MOVE MOLECULES CLOSEST TO FN(1), FN(2), FN(3) FRACTIONAL POSITION
                  IF (IPR(221) == 3) THEN
                    DO I = 1, 3
                      PAR(63 + I) = FN(I)
                    END DO
                  END IF
                ELSE
                  IGBL(30) = 1
                END IF
              END IF
              GO TO 10
C * IS = 11: MolVolume
            CASE (11)
C * RESET DEFAULT GRID STEP
              IF (IPR(221) /= 0) PAR(569) = FN(1)
C * SAVE OPTION TEST
              IF (IGBL(45) > 0 .AND. IGBL(5) == LU5) THEN
                IGBL(45) = IGBL(45) + 1
                WRITE (LU3, 99984, IOSTAT = IOST) ICL(1:80)
                WRITE (LU6, 99973, IOSTAT = IOST) ICL(1:70)
              END IF
C * SET TO NO R/S CALC
              IPR(744) = 1
C * Molecular volume  CALCULATION
              CALL PLA396
              RETURN
C * IS = 12: DONOR/ACCEPTOR TYPES
            CASE (12)
              IPR(480) = 0
              DO I = 1, IPR(220)
                CALL PLA037 (I, N, 2)
C * SKIP ELEMENTS THAT ARE NOT PRESENT
                IF (N > 0) THEN
                  IF (IPR(480) <= NP10) THEN
                    IPR(480)        = IPR(480) + 1
                    IDOAC(IPR(480)) = IEN(N)
                  ELSE
                    WRITE (LU6, 99979, IOSTAT = IOST) NP10
                  END IF
                END IF
              END DO
              GO TO 180
C * IS = 13: SPECIAL LINE MANAGEMENT
            CASE (13)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
                IF (IPR(220) == 3 .AND. IPR(407) < 10) THEN
                  DO I = 2, 3
                    CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD,
     1                           INQNR, JNQNR, NIEN)
                    IF (NIEN < 0) GO TO 10
                    SLN(IPR(407) + 1, I - 1) = INQNR
                  END DO
                  IPR(407) = IPR(407) + 1
                  WRITE (LU6, 99987, IOSTAT = IOST)
                END IF
              END IF
              GO TO 10
C * IS = 14: ENDS
            CASE (14)
              IPR(3)  = 1
              IGBL(8) = - IABS (IGBL(8))
              IGBL(5) = LU3
              CALL GEN108 (LU3, 0)
              GO TO 10
C * IS = 15: PLOT
            CASE (15)
              IPR(14) = 0
              GO TO 80
C * IS = 16: YES
            CASE (16)
              GO TO 210
C * IS = 18: CALC
            CASE (18)
              IF (IPR(220) == 2) THEN
                IF (IFL(2)(1:3) == 'ALL') IPR(220) = 1
              END IF
              GO TO 100
C * IS = 19: END
            CASE (19)
              GO TO 190
C * IS = 20/21: (1/0)IN/EXCLUDE NAMED ELEMENTS IN/FROM CALCULATIONS
            CASE (20, 21)
              IF (IS == 20) THEN
                IPR(70) = 1
              ELSE
                IPR(70) = 0
              END IF
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 1) THEN
C * INSTRUCTION NOT ALLOWED
                IPR(2) = 11
                GO TO 200
              ELSE
                IPR(4) = 0
C * LOOP MAXIMUM IS POTENTIALLY REDEFINED WITHIN THE LOOP
                I = 1
                DO WHILE (I < IPR(220))
                  I = I + 1
C * TEST FOR KEYWORD METAL
                  IF (IFL(I)(1:3) == 'MET') THEN
                    DO J = 1, IAN
                      IF (IATPR(IEN(J)) > 0) THEN
                        IPR(220)           = IPR(220) + 1
                        N                  = IEL(IEN(J))
                        N1                 = N / 100
                        IFL(IPR(220))(1:3) =
     1                      CHAR (ICHAR ('A') - 1 + N1)//'  '
                        N1                 = MOD (N, 100)
                        IF (N1 > 0) THEN
                          IFL(IPR(220))(2:2) =
     1                      CHAR (ICHAR ('A') - 1 + N1)
                        END IF
                      END IF
                    END DO
                    CYCLE
                  END IF
                  CALL PLA037 (I, N, 2)
C * SKIP SPECIFIED ELEMENTS THAT ARE NOT PRESENT
                  IF (N > 0) THEN
                    IF (IPR(4) <= 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, IOSTAT = IOST) NP10
                    END IF
                  ELSE
                    IPR(2) = 16
                    IPR(4) = 0
                    IAN    = IAN - 1
                    GO TO 200
                  END IF
                END DO
                GO TO 180
              END IF
              GO TO 10
C * IS = 22, 45, 53: STOP/QUIT/EXIT - NO FULL END PROCESSING - TERMINATE JOB
            CASE (22, 45, 53)
              WRITE (LU6, 99999, IOSTAT = IOST)
     1          IGBL(49), NAMEFIL(1 : KNMFIL)
              IGBL(1) = 4
              RETURN
C * IS = 23: HELP (SPGR)
            CASE (23)
              IF (IPR(220) > 1) THEN
                OPT = IFL(2)(1:3)
C * LIST KNOWN SPACE GROUP NAMES
                IF (OPT == 'SPG') THEN
                  CALL SGSM (14, ICL, SGY, 0, LU6, IERR)
                  GO TO 10
                END IF
              END IF
C * HELP MANUAL
              IWIN = IGBL(25) * IGBL(32)
              CALL PLA299 (1)
C * GET NEW INSTRUCTION
              RETURN
C * IS = 24: SAVE INSTRUCTION OPTION ON
            CASE (24)
              IGBL(45) = 1
              ISAVEMOD = 1
              CALL GEN108 (LU3, 0)
              GO TO 10
C * IS = 25,26: UIJ/SUIJ
            CASE (25, 26)
C * UIJ DATA & SUIJ DATA
C * INCLUDE A*,B* AND C* INTO U(I, J) BEFORE TRANSFORMATION
              CALL GEN144 (1, FN(1), PAR(135))
C * CHECK FOR SUIJ
              IF (IS == 26) THEN
                ICT = 3
                GO TO 50
              END IF
              GO TO 40
C * IS = 27, 41: U, B DATA (SHOULD INCLUDE ATOM LABEL)
            CASE (27, 41)
              IF (IS == 41) THEN
                IF (IPR(220) == 1) THEN
                  IS = 1
                  CYCLE
                END IF
                FN(1) = FN(1) / RGBL(8)
                FN(2) = FN(2) / RGBL(8)
              END IF
              IF (IPR(220) == 1) THEN
                IS = 1
                CYCLE
              END IF
              ICT = 4
              GO TO 60
C * IS = 29: LIST/INFO
            CASE (29)
C * LIST OPTION(S) ON DISPLAY (ATOMS/BONDS/SYMM/PAR/IPR/IGBL/RADII/CELL)
              IF (IFL(2)(1:3) == 'UIJ') THEN
                IF (IPR(30) == 0) THEN
                  CALL PLA280 ('CALC TMA')
                  GO TO 10
                END IF
              END IF
              IRETN = 0
              CALL PLA382 (IRETN)
              IF (IRETN /= 0) THEN
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) == 0) THEN
                  IGBL(52) = MAX (IGBL(52), IPR(23))
                  IPR(205) = 0
                END IF
                CALL PLA021 (11, NRETURN)
                RETURN
              END IF
              GO TO 10
C * IS = 30: CELL CONSTANTS
            CASE (30)
C * ASSUME A = B = C
              IF (IPR(221) == 1) THEN
                FN(2)    = FN(1)
                FN(3)    = FN(1)
                IPR(221) = 3
              END IF
C * ASSUME 90,90,90
              IF (IPR(221) == 3) THEN
                CALL GEN074 (FN, 4, 6, 90.0)
                IPR(221) = 6
              END IF
              IF (IPR(221) < 6 .OR.
     1           (IPR(221) > 7 .AND. IPR(221) /= 12)) THEN
C * NOT ENOUGH DATA ON CARD
                IPR(2) = 5
                GO TO 200
              END IF
C * TEST FOR SHELX STYLE CELL CARD
              IF (IPR(221) == 7) THEN
C * REGISTER SUPPLIED WAVELENGTH (PAR(16))
                PAR(16) = FN(1)
                PAR(17) = FN(1)
                K = 1
              ELSE
                K = 0
              END IF
              DO I = 1, 12
C * TEST CELL CARD FOR ZERO'S
                IF (I <= 3 .AND. ABS (FN(K + I)) < 2.0) THEN
                  IF (IGBL(5) == LU1) IPR(470) = 1
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                END IF
                PAR(100 + I) = FN(K + I)
              END DO
              IF (K /= 0) CALL PLA293 (FN(1))
              GO TO 10
C * IS = 31: CELL STANDARD DEVIATION (COPY)
            CASE (31)
              CALL GEN113 (FN, PAR(107), 6)
              GO TO 10
C * IS = 32: SYMM (LATT/SPGR/HALL etc.)
            CASE (32)
C * SYMM RECORDS AS (R|T)
              IF (IPR(220) == 1 .AND.
     1           (IPR(221) == 9 .OR. IPR(221) == 12)) THEN
C * SYMM MATRIX R11,R12,..,R33, (T1,T2,T3) INPUT
                IF (IPR(93) == 0) THEN
                  ITRS = 15
                  CALL SGSM (ITRS, ICL, FN,  0,  LU6, IERR)
                  CALL SGSM (18,   ICL, SGZ, 0,    0, IERR)
C * NO SUITABLE SPACE-GROUP
                  IPR(48) = NINT(SGZ(9))
C * CHECK FOR CIF-DATA
                  IF (IGBL(8) == 3) THEN
                    IF (CCIF(7)(1:1) == ' ' .AND.
     1                 CCIF(16)(1:1) == '?') THEN
C * ALERT _121
                      CALL PLA236 (121, 0, 1.0, 1.0, ICL(1:7), ' ')
                      ICL = 'SPGR P1'
                      WRITE (LU6, 99970, IOSTAT = IOST)
                      IS = 32
                      CYCLE
                    END IF
                  END IF
                ELSE
C * NO TRANS ALLOWED WITH SYMM MATRIX INPUT
                  IPR(2) = 27
                  GO TO 200
                END IF
              ELSE
C * OPTIONALLY ADD 'LATT 1' INSTRUCTION FOR COMPATIBILITY
                IF (IGBL(8) == 2) THEN
                  IF (IPR(141) == 0 .AND. IFL(1)(1:4) == 'SYMM')
     1              THEN
                    IDM = 'LATT 1'
                    CALL SGSM (0, IDM, SGY, 0, 0, IERR)
                    IPR(141) = 1
                  END IF
                END IF
C * CHECK FOR CELL TRANSFORMATION OR SHIFT
                IF (IPR(93) == 1 .OR. IPR(139) == 1) THEN
                  ITRS = 16
                ELSE
                  ITRS = 0
                END IF
                CALL SGSM (ITRS, ICL, SGY, 0, LU6, IERR)
                IF (IERR /= 0) THEN
C * PROBLEM WITH CELL TRANSFORMATION
                  IF (IERR == 14) THEN
                    IPR(2) = 66
                    GO TO 200
C * ERROR/PROBLEM IN HALL SYMBOL
                  ELSE IF (IERR == 7) THEN
C * ALERT _126
                    CALL PLA236 (126, 0, 1.0, 1.0, ICL(6:15), ' ')
                      IPR(673) = 1
                    GO TO 10
                  ELSE IF (IERR == 5) THEN
                    CALL GEN047 (ICL, 6, 16)
C * ALERT _129
                    CALL PLA236 (129, 0, 1.0, 1.0, ICL(6:12), ' ')
                    GO TO 10
                  ELSE IF (IERR == 12) THEN
                    GO TO 10
                  ELSE IF (IERR == 2) THEN
C * ALERT _119
                    CALL PLA236 (119, 0, 1.0, 1.0, ICL(6:12), ' ')
                    GO TO 10
                  ELSE
                    IPR(470) = 1
C * NOT ENOUGH DATA ON CARD
                    IPR(2) = 5
                    GO TO 200
                  END IF
                END IF
                CALL SGSM (18, ICL, SGZ, 0, 0, IERR)
                IPR(48) = NINT (SGZ(9))
                IF (IPR(48) == 0) THEN
C * CHECK FOR CIF-DATA
C * ALERT _121
                  IF (IGBL(8) == 3)
     1              CALL PLA236 (121, 0, 1.0, 1.0, ICL(1:7), ' ')
                END IF
              END IF
              IPR(141) = 1
C * HANDLE ERROR CASE
              IF (IPR(48) == 0) THEN
                IF (IGBL(5) == LU1) IPR(470) = 1
C * NOT ENOUGH DATA ON CARD
                IPR(2) = 5
                GO TO 200
              END IF
C * 'LAST-MINUTE SYMM UPDATE'
              IF (IPR(39) == 0) CALL PLA271
              GO TO 10
C * IS = 33: SPGR
            CASE (33)
C * CHECK FOR EXPLICIT SPACE GROUP INFO
              IF (IPR(220) /= 1 .OR. IPR(221) > 2) THEN
                IS = 32
C * DETERMINE SPACE GROUP FROM EXTINCTIONS
              ELSE
C * CHECK FOR REFLECTION DATA
                CALL PLA008
                IF (IGBL(15) >= 0) THEN
                  MODE = 3
                  IF (IPR(221) > 0) THEN
                    MODE = NINT (FN(1))
                    IF (IPR(221) > 1) PAR(141) = FN(2)
                  END IF
                  CALL PLA100
                  IGBL(31) = 5
C * OPEN UNIT #2
                  CALL PLA292
C * OUTPUT CELL HEADER
                  CALL PLA042 (0)
C * DETERMINE SPACEGROUP FROM EXTINCTIONS
                  CALL PLA160 (MODE, TM1)
C * ERROR HANDLING
                  IGBL(1) = 3
                  IF (IPR(3) /= 0) RETURN
                  GO TO 10
                ELSE
C * NO REFL DATA PROBLEM
                  IPR(2) = 55
                  GO TO 200
                END IF
              END IF
              CYCLE
C * IS = 34: LATT
            CASE (34)
C * SUBSTITUTE 'LATT 1' FOR 'LATT' AND 'LATT 0' IN CASE OF SHELX RES
              IF (IGBL(8) == 2) THEN
                IF (FN(1) == 0.0) ICL = 'LATT 1'
              END IF
              IS = 32
              CYCLE
C * IS = 35: DIST
            CASE (35)
              GO TO 30
C * IS = 36: ANGLE
            CASE (36)
              GO TO 30
C * IS = 37: TORSION
            CASE (37)
              GO TO 30
C * IS = 38: HBON: CHANGE H-BOND PARAMETERS FROM ORIGINAL TO NEW DEFAULTS
            CASE (38)
              IF (IPR(220) > 1 .AND. IFL(2)(1:4) == 'NORM') THEN
                IGBL(147) = 1
                IGBL(148) = 1
                IPR(87)   = 1
              ELSE
                IGBL(147) = 0
                IGBL(148) = 0
                IPR(87)   = 0
              END IF
              IF (IPR(221) > 0) THEN
                DO K = 1, IPR(221)
                  RGBL(40 + K) = FN(K)
                  RGBL(43 + K) = FN(K)
                END DO
              END IF
              GO TO 180
C * IS = 39,40: BIJ, SBIJ
            CASE (39, 40)
C * BIJ & SBIJ DATA
C * (BETA-VALUES ARE TRANSFORMED TO U-VALUES AFTER TRANSFORMATION)
              DO I = 1, 6
                FN(I) = FN(I) / RGBL(7)
              END DO
C * CHECK FOR SBIJ
              IF (IS == 40) THEN
                ICT = 3
                GO TO 50
              ELSE
                GO TO 40
              END IF
C * IS = 42: TRNS/TRMX
            CASE (42)
C * STANDARDISE ENTRIES
              CALL GEN074 (SHFT, 1, 3, 0.0)
C * MOVE/FIX ATOM CASE (accept both 3.456 and 3456.01)
              IF (IPR(221) == 1) THEN
                IF (ABS(FN(1)) > 1000.0) THEN
                  ITRNS = INT (FN(1))
                ELSE
                  ITRNS = NINT (FN(1) * 1000.0)
                END IF
C * TEST FOR SYMMETRY NUMBER IN RANGE
                IF (IABS(ITRNS) / 1000 > IPR(48)) THEN
                  IPR(2) = 15
                  GO TO 200
                END IF
                IF (ITRNS <= 0) THEN
                  IPR(95)  = ITRNS
                ELSE IF (ITRNS > 0) THEN
                  IPR(165) = ITRNS
                END IF
                GO TO 10
C * ORIGIN SHIFT ONLY
              ELSE IF (IPR(221) == 3) THEN
                CALL GEN074 (FN, 1, 9, 0.0)
                FN(1)    = 1.0
                FN(5)    = 1.0
                FN(9)    = 1.0
                IPR(139) = 1
                DO I = 1, 3
                  SHFT(I) = - FN(I)
                END DO
              ELSE IF (IPR(221) == 9) THEN
C * GET CRYSTAL SYSTEM
              ELSE IF (IPR(221) == 10 .AND. IPR(220) == 2) THEN
                ILAT0 = IFL(2)(1:1)
                IF (IFL(2)(2:2) /= ' ') ILAT1 = IFL(2)(2:2)
                CALL GEN020 (-1, ILAT0, 1, 1)
                IFN10 = NINT (FN(10))
                IF (IFN10 > 0 .AND. IFN10 < 14) THEN
                  LAUE = NLAUE(NINT(FN(10)))
                ELSE
                  LAUE = ' '
                END IF
C * TRANSLATION COMPONENT (ORIGIN SHIFT)
              ELSE IF (IPR(221) == 12) THEN
                IPR(139) = 1
                DO I = 1, 3
                  SHFT(I) = - FN(9 + I)
                END DO
C * INCORRECT NUMBER OF NUMERIC DATA ON TRMX LINE
              ELSE
                IPR(2) = 63
                GO TO 200
              END IF
C * TRANSFORMATION OF CELL AXES
              IF (IPR(39) > 0) THEN
C * INSTRUCTION NOT ALLOWED
                IPR(2) = 11
                GO TO 200
              END IF
              K = 0
              DO I = 1, 3
                SGY(9 + I) = - SHFT(I)
                DO J = 1, 3
                  K            = K + 1
                  TM1(I, J)    = FN(K)
                  SGY(K)       = FN(K)
C * TRANSFER TO SHELX-HKLF
                  PAR(230 + K) = FN(K)
                END DO
              END DO
C * CALCULATE TRANSPOSED INVERSE TM2 OF TM1
              CALL GEN003 (TM1, DUMV, DET, 0)
              IF (ABS(ABS(DET) - 1.0) > 0.001) THEN
                WRITE (LU6, 99985, IOSTAT = IOST) DET
                PAR(32) = DET
              END IF
              CALL GEN005 (DUMV, TM2)
              IPR(93) = 1
              WRITE (LU6, 99972, IOSTAT = IOST)
     1          ((TM2(I, J), J = 1, 3), SHFT(I), I = 1, 3)
              GO TO 10
C * IS = 44: PARENTHESES ON/OFF OPTION
            CASE (44)
              IPR(71) = 1
              IF (IPR(220) > 1) THEN
                IF (IFL(2)(2:2) == 'F') IPR(71) = 0
              END IF
              GO TO 180
C * IS = 46: SET OPTION(S)
            CASE (46)
C * SET - OPTION(S)
              OPT = IFL(2)(1:3)
C * (RE)SET VAN DER WAALS RADII
              IF (OPT == 'VDW') THEN
                IF (IPR(220) > 2 .AND. IPR(221) == IPR(220) - 2)
     1            THEN
                  DO I = 3, IPR(220)
                    CALL PLA037 (I, NID, 2)
                    IF (NID > 0) RADR(NID, 4) = FN(I - 2)
                  END DO
                END IF
                IF (IGBL(5) == LU5) CALL PLA280 ('LIST RADII')
C * SET RANGE (FOR POLY)
              ELSE IF (OPT == 'RAN') THEN
                IF (IPR(221) == 6) THEN
                  IPR(354) = 0
                  DO I = 1, 6
                    PAR(200 + I) = FN(I)
                  END DO
C * SET OMIT RANGE (POLY)
              ELSE IF (OPT == 'OMI') THEN
                ELSE IF (IPR(221) == 6) THEN
                  IPR(356) = 0
                  DO I = 1, 6
                    PAR(206 + I) = FN(I)
                  END DO
                END IF
C * SET TETR (POLY)
              ELSE IF (OPT == 'TET') THEN
                DO I = 1, 4
                 IF (FN(I) /= 0.0) PAR(213 + I) = FN(I)
                END DO
C * SET OCTA (POLY)
              ELSE IF (OPT == 'OCT') THEN
                DO I = 1, 4
                  IF (FN(I) /= 0.0) PAR(217 + I) = FN(I)
                END DO
C * SET LABEL SIZE
              ELSE IF (OPT == 'LAB') THEN
                IF (IPR(220) == 3 .AND. IFL(3)(1:1) == 'S') THEN
                  WRITE (LU6, 99994, IOSTAT = IOST) PAR(349)
                  IF (IPR(221) == 1) THEN
                    PAR(349) = FN(1)
                    WRITE (LU6, 99993, IOSTAT = IOST) PAR(349)
                  END IF
                END IF
C * SET PRINTER LEVEL (0,1,2,3,4)
              ELSE IF (OPT == 'PRI') THEN
                IF (IPR(220) == 3) THEN
C * LEVEL
                  IF (IFL(3)(1 : 1) == 'L') THEN
                    IF (IPR(221) > 0) THEN
                      IGBL(64) = NINT (FN(1))
                      IGBL(63) = IGBL(64)
                    END IF
                  END IF
                END IF
C * SET REVERSE (IGBL(68) = (0/1) REVERSE TOGGLE
              ELSE IF (OPT == '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/RGBL
              ELSE IF (IPR(221) == 2 .AND. IPR(220) == 2) THEN
                CALL PLA206 (1, OPT)
C * SET PROBABILITY (10 <--> 90 PERCENT)
              ELSE IF (IPR(221) == 1 .AND. IPR(220) == 2) THEN
                IF (OPT == 'PRO') THEN
                  IPR(45)  = MAX (1, MIN (9, NINT (FN(1) / 10)))
C * RESET LABEL POSITIONING STATUS
                  IPR(201) = 0
C * SET WINDOW FRACTION
                ELSE IF (OPT == '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)
                END IF
              ELSE IF (IPR(220) == 3) THEN
                SELECT CASE (OPT)
C * SET BEEP ON/OFF
                  CASE ('BEE')
                    MEDIUM = 0
C * SET DISPLAY TYPE
                  CASE ('DIS')
                    MEDIUM = 1
C * SET META TYPE
                  CASE ('MET')
                    MEDIUM = 2
                END SELECT
                IF (IPR(220) > 2) CALL GGIP (-999.0, 0.0, 0.0, 6)
              END IF
              GO TO 180
C * IS = 48: SFAC CARD (SHELX) OR IS = 172: SCAT
            CASE (48, 172)
C * ADD 'LATT 1' FOR COMPATIBILITY
              IF (IPR(141) == 0 .AND. IGBL(8) == 2) THEN
                IDM = 'LATT 1'
                CALL SGSM (0, IDM, SGY, 0, 0, IERR)
                IPR(141) = 1
C * 'LAST-MINUTE SYMM UPDATE'
                CALL PLA271
              END IF
              M = IPR(221)
C * LOAD SFAC LABEL TYPE DATA INTO IEN
              IF (IPR(220) > 1) THEN
                DO I = 2, IPR(220)
                  N12 = 0
                  CALL GEN105 (1, IFL(I)(1:1), N)
                  IF (N > 0) N12 = (N - ICHAR ('A') + 1) * 100
                  CALL GEN105 (1, IFL(I)(2:2), N)
                  IF (N > 0) N12 = N12 + N - ICHAR ('A') + 1
C * REGISTER FOR ELEMENT 'HO'
                  IF (N12 == 815) IPR(435) = 1
                  IUNKNOWN = 1
                  DO J = 1, NP9
                    IF (IEL(J) == N12) THEN
                      IAN          = IAN + 1
                      IEN(IAN)     = J
                      RADR(IAN, 3) = REL(J)
                      RADR(IAN, 4) = ABS (VDWR(J))
                      IF (IFL(I)(2:2) == ' ') THEN
                        LMT(IAN, 1) = ' '//IFL(I)(1:1)
                      ELSE
                        LMT(IAN, 1) = IFL(I)(1:2)
C * TRANSFORM 2nd CHAR to LC
                        CALL GEN020 (-1, LMT(IAN, 1), 2, 2)
                      END IF
                      LMT(IAN, 2) = JTP(IABS (IATPR(J)))
C * ASSIGN COLORS FOR SHELX
                      IF (J == 3) THEN
                        IACL(IAN) = 2
                      ELSE IF (J == 4) THEN
                        IACL(IAN) = 4
                      ELSE IF (IATPR(J) == -7) THEN
                        IACL(IAN) = 3
                      ELSE IF (J > 2) THEN
                        IF (ICLR < 8) ICLR = ICLR + 1
                        IACL(IAN) = ICLR
                      END IF
                      IUNKNOWN = 0
                    END IF
                  END DO
C * CATCH UNKNOWN ELEMENT TYPE CASE
                  IF (IUNKNOWN == 1) THEN
                    IPR(2) = 41
                    GO TO 200
                  END IF
                END DO
C * CHECK FOR NEUTRON SCATTERING
                IF (IPR(220) == 2 .AND. IPR(221) > 0
     1            .AND. FN(1) == 0.0) IPR(493) = 7
              END IF
              GO TO 10
C * IS = 51: VIEW CARD(S)
            CASE (51)
C * VIEW MIN
              IF (IFL(2)(1:3) == 'MIN') THEN
C * RESET LABEL POSITIONING STATUS
                IPR(201) = 0
                IGBL(67) = 0
              ELSE
C * VIEW (XR xr YR yr ZR zr)
                N = 1
                IF (IPR(220) == 1) THEN
                  CALL PLA226 (0, 0.0)
                ELSE
C * GENERATE UNIT MATRIX (DET = IGBL(87))
                  CALL GEN021 (RMAT, FLOAT (IGBL(87)))
C * RECREATE ORIENTATION MATRIX
                  DO L = 1, 3
                    CALL GEN051 (0, RMAT, - RGBL(27 + L) / RGBL(6), L)
                  END DO
                  DO I = 2, IPR(220)
                    SELECT CASE (IFL(I)(1:3))
C * UNIT
                      CASE ('UNI')
                        CALL PLA226 (0, 0.0)
C * INVERT
                      CASE ('INV')
                        CALL PLA226 (-4, 0.0)
C * XROT
                      CASE ('XR ', 'XRO')
                        CALL PLA226 (-1, - FN(N) / RGBL(6))
                        N = N + 1
C * YROT
                      CASE ('YR ', 'YRO')
                        CALL PLA226 (-2, - FN(N) / RGBL(6))
                        N = N + 1
C * ZROT
                      CASE ('ZR', 'ZRO')
                        CALL PLA226 (-3, - FN(N) / RGBL(6))
                        N = N + 1
                    END SELECT
                  END DO
                END IF
              END IF
              GO TO 180
C * IS = 52: BOX ON/OFF (1/0)
            CASE (52)
              IF (IPR(220) > 1) THEN
                DO I = 2, IPR(220)
                  SELECT CASE (IFL(I)(1:3))
C * BOX OFF
                    CASE ('OFF')
                      IGBL(103) = 0
C * BOX ON
                    CASE ('ON ')
                      IGBL(103) = 1
C * BOX RATIO
                    CASE ('RAT')
                      PAR(50) = FN(1)
                  END SELECT
                END DO
              END IF
              GO TO 180
C * IS = 56: GEOM
            CASE (56)
              GO TO 30
C * IS = 59: INFO
            CASE (59)
              IS = 29
              CYCLE
C * IS = 60: TABLE OPTION
            CASE (60)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) /= 0) THEN
                IPR(2) = 31
                GO TO 200
              END IF
              IPR(430) = 1
C * REPORT NO-ESD STATUS
              IF (IPR(72) == 0) WRITE (LU6, 99966, IOSTAT = IOST)
C * SET NHATOM
              IPR(454) = 1
C * SET RES
              IPR(240) = 1
C * SET PARENTHESES TO NO
              IPR(71) = 0
              IF (IPR(220) > 1) THEN
                DO I = 2, IPR(220)
                  SELECT CASE (IFL(I)(1:3))
C * NO-HATOM
                    CASE ('NHA')
                      IPR(454) = 0
C * RESIDUE SORT/LISTING (NORES)
                    CASE ('NOR')
                      IPR(240) = 0
                    CASE ('SUP')
C * SU  (FULL SUPPLEMENTARY MATERIAL)
                      IPR(431) = 1
                    CASE ('ACC', 'CIF')
C * ACC (ACTA CRYST C - CIF) - NOPARENTHESES
                      IPR(430) =  1
C * ACC-CIF
                      IPR(431) = -1
                      IGBL(31) = 8
C * LOCAL
                    CASE ('LOC')
                      IPR(399) = 1
                  END SELECT
                END DO
              END IF
C * DO A CALC OMEGA CALCULATION WHEN NECESSARY (NO = 0)
              IF (IPR(30) == 0) THEN
                IPR(220)  = 2
                IFL(2)    = 'OMEGA'
                GO TO 100
              ELSE
C * EXECUTE TABLE OPTIONS
                IF (IPR(430) > 0) THEN
                  IPR(31)  = -1
                  IPR(17)  = -1
                  IPR(90)  =  1
                  IGBL(63) =  0
C * SET UP CONNECTED SET
                  CALL PLA067
                  IF (IPR(2) /= 0) RETURN
                  CALL PLA171
                  IPR(1) = 1
                  IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
                  IGBL(1) = 3
                  RETURN
                END IF
                RETURN
              END IF
              GO TO 10
C * IS = 61: RADII BONDS ((LIST/NORMAL/TO H/TO MET/ALL) (#lines (radius)))
            CASE (61)
              JB = 0
              JE = 0
              DO I = 3, IPR(220)
                SELECT CASE (IFL(I)(1:3))
C * RADII BONDS TO H
                  CASE ('H  ')
                    JB = 3
                    JE = 3
C * RADII BONDS TO METAL
                  CASE ('MET')
                    JB = 5
                    JE = 5
C * NORMAL
                  CASE ('NOR')
                    JB = 1
                    JE = 1
                  CASE ('ALL')
                    JB = 1
                    JE = 5
                  CASE DEFAULT
                    CYCLE
                END SELECT
                DO J = JB, JE, 2
                  IF (IPR(221) > 0) THEN
                    IF (ABS (FN(1)) > 5.0) FN(1) = SIGN (5.0, FN(1))
                    PAR(84 + J) = FN(1)
                  END IF
                  IF (IPR(221) > 1) PAR(85 + J) = FN(2)
                END DO
                IF (.TRUE.) EXIT
              END DO
C * LIST BOND RADII
              WRITE (PRBUF, 99977, IOSTAT = IOST)
              IF (IWIN == 1) THEN
                CALL GGIP (HORS, VERT, 0.0, 1)
                VRT = VERT - 3.0
                CALL PLA439 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2,
     1             1.0, VRT)
              ELSE
                WRITE (LU6, 99991, IOSTAT = IOST) PRBUF(1:75)
              END IF
              WRITE (PRBUF, 99976, IOSTAT = IOST)
     1          NINT (PAR(85)), 2**NINT (ABS (PAR(85)) - 1) + 1, PAR(86)
              IF (IWIN == 1) THEN
                VRT = VRT - 1.5
                CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99991, IOSTAT = IOST) PRBUF(1:75)
              END IF
              WRITE (PRBUF, 99975, IOSTAT = IOST)
     1          NINT(PAR(87)), 2**NINT (ABS (PAR(87)) - 1) + 1, PAR(88)
              IF (IWIN == 1) THEN
                VRT = VRT - 1.5
                CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99981, IOSTAT = IOST) PRBUF(1:75)
              END IF
C * TEST FOR METAL CONTAINING COMPOUND
              IF (IPR(155) > 0) THEN
                WRITE (PRBUF, 99974, IOSTAT = IOST) NINT (PAR(89)),
     1            2**NINT (ABS (PAR(89)) - 1) + 1, PAR(90)
                IF (IWIN == 1) THEN
                  VRT = VRT - 1.5
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99981, IOSTAT = IOST) PRBUF(1:75)
                END IF
              END IF
              IF (IWIN == 1) CALL PLA297 (1)
              GO TO 180
C * IS = 63: MENU (ON/OFF)
            CASE (63)
              IF (IPR(220) == 2 .AND. IFL(2)(1:3) == 'OFF') THEN
                IGBL(25) = 0
              ELSE
                IGBL(25) = 1
                IF (IGBL(6) < 10 .OR. IGBL(6) > 12)
     1            CALL PLA280 ('PLOT')
              END IF
              GO TO 10
C * IS = 64: OMIT CARD
            CASE (64)
C * CHECK FOR QUOTE COMMENT
              IF (IGBL(8) == 2) IPR(220) = 1
              N = IPR(220)
              IF (N > 1) THEN
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) == 0) THEN
                  IF (IPR(37) == 0) THEN
                    IPR(2) = 42
                    GO TO 200
                  END IF
                  IGBL(52) = MAX (IGBL(52), IPR(23))
                  CALL PLA287 (0, 1, 0)
                END IF
                DO I = 2, N
                  CALL PLA046 (2, IFL(I), IENM, LBB, LBC, LBD,
     1                            INQNR, JNQNR, NR)
                  IF (NR > 0) THEN
                    CALL GEN048 (1, IFG(1, NR), 30, 1)
                  ELSE
                    WRITE (LU6, 99995) ICL(1:50)
                    CALL PLA015 (0, 28)
                  END IF
                END DO
              ELSE
                M = IPR(221)
C * SHELXL/RES THETA-MAX
                IF (M == 2) THEN
                  PAR(165) = FN(2) / 2.0
                  IGBL(8)  = 2
C * OMIT REFECTIONS + SYMMETRY RELATED ONE'S
                ELSE IF (M == 3) THEN
                  NSMR = IPR(255) * IPR(257)
                  IF (IPR(620) + NSMR  <= NP62) THEN
                    DO J = 1, NSMR
                      DO K = 1, 3
                        SGY(K) = FN(K)
                      END DO
                      CALL SGSM (5, IDM, SGY, J, 0, IERR)
                      IPR(620) = IPR(620) + 1
                      DO I = 1, 3
                        IHKLOMIT(I, IPR(620)) = NINT (SGY(I + 6))
                      END DO
C * AVOID DUPLICATIONS
                      IF (IPR(620) > 1) THEN
                        DO K = 1, IPR(620) - 1
                          IYUNK = 0
                          DO L = 1, 3
                            IYUNK = IYUNK
     1                            + IABS (IHKLOMIT(L, IPR(620))
     2                            -       IHKLOMIT(L, K))
                          END DO
                          IF (IYUNK == 0) THEN
                            IPR(620) = IPR(620) - 1
                            EXIT
                          END IF
                        END DO
                      END IF
                    END DO
                  END IF
                END IF
              END IF
              GO TO 10
C * IS = 67: JOIN ATOMS
            CASE (67)
              IPR(785) = 1
              CALL PLA021 (7, NRETURN)
              IF (NRETURN == 0) THEN
                RETURN
              ELSE IF (NRETURN == 1) THEN
                GO TO 10
              END IF
C * IS = 68: DETACH ATOMS
            CASE (68)
              IPR(785) = -1
              CALL PLA021 (7, NRETURN)
              IF (NRETURN == 0) THEN
                RETURN
              ELSE IF (NRETURN == 1) THEN
                GO TO 10
              END IF
C * IS = 69: DEFINE SUBSTITUTE BOND
            CASE (69)
              IPR(785) = -1
              CALL PLA021 (7, NRETURN)
              IF (NRETURN == 0) THEN
                RETURN
              ELSE IF (NRETURN == 1) THEN
                GO TO 10
              END IF
C * IS = 70: HKLF - LINE
            CASE (70)
              CALL PLA100
              IPR(648) = NINT (FN(1))
              IF (IPR(221) >= 11) THEN
                DO K = 1, 9
                  I        = ((K - 1) / 3)  + 1
                  J        = MOD (K - 1, 3) + 1
                  QQ(I, J) = FN(K + 2)
                END DO
              ELSE
                CALL GEN021 (QQ, 1.0)
              END IF
C * APPLY TRNS/TRMX ON HKLF-TRNS
              CALL GEN004 (TM1, QQ, DUMV)
              K = 0
              DO I = 1, 3
                DO J = 1, 3
                  K = K + 1
                  PAR(230 + K) = DUMV(I, J)
                END DO
              END DO
              WRITE (LU6, 99968, IOSTAT = IOST) (PAR(230 + I), I = 1, 9)
C * GET INVERSE AND DETERMINANT  OF TRANSFORMATION MATRIX
              CALL GEN003 (DUMV, QQ, DET, 0)
              PAR(240) = DET
              IF (ABS (ABS (DET) - 1.0) > 0.001)
     1          WRITE (LU6, 99980, IOSTAT = IOST) DET
              IF (DET < 0.0) THEN
                IPR(2) = 40
                GO TO 200
              END IF
C * APPLY TRANSVERSE AXES TRANSFORMATION
              CALL GEN001 (1, QQ, AA, RAA)
C * GET TRANSFORMED DIRECT AXIS PARAMETERS
              CALL GEN026 (-1, RAA, PAR(241))
C * GET INVERSE TRANSFORMED METRIC
              CALL GEN003 (RAA, RBB, DET, 0)
C * CALL EXIT/STOP
              IF (DET <= 0.0)
     1         CALL GEN127 ('CANNOT INVERT METRICAL MATRIX')
C * GET TRANSFORMED RECIPROCAL AXIS PARAMETERS
              CALL GEN026 (-1, RBB, PAR(135))
              WRITE (LU6, 99969, IOSTAT = IOST) (PAR(100 + I), I = 1, 6)
     1                        ,(PAR(240 + I), I = 1, 6)
              CALL GEN025 (RBB, PAR(391), 1)
C * LOOK FOR REFLECTION DATA
              IF (NINT(FN(1)) == 4) CALL PLA008
              IF (NINT(FN(1)) == 5) CALL PLA008
              GO TO 10
C * IS = 71: RADN LINE
            CASE (71)
              CALL PLA293 (FN(1))
              GO TO 10
C * IS = 72: TRMX
            CASE (72)
              IS = 42
              CYCLE
C * IS = 74: INORG (FORCE INORGANIC MODE)
            CASE (74)
              IGBL(97) = 0
              GO TO 10
C * IS = 75: ORGA (FORCE ORGANIC MODE)
            CASE (75)
              IGBL(97) = 1
              GO TO 10
C * IS = 78: ENTRY (CSD/CIF ETC.-FILE ENTRY)
            CASE (78)
              CALL PLA007
              IF (ICL(1:4) == 'END ') GO TO 190
              GO TO 10
C * IS = 79: ELLIPSOID PARAMETERS
            CASE (79)
              IF (IPR(220) > 1) THEN
                SELECT CASE (IFL(2)(1:3))
                  CASE ('C  ')
                    N = 175
                  CASE ('H  ')
                    N = 177
                  CASE ('OTH')
                    N = 179
                END SELECT
                IF (IPR(221) > 1) THEN
                  IPR(N)     = MAX (0, MIN (1, NINT (ABS (FN(1)))))
                  IPR(N + 1) = NINT (ABS (FN(2)))
                END IF
              END IF
              WRITE (LU6, 99964, IOSTAT = IOST) (IPR(174 + I), I = 1, 6)
              GO TO 10
C * IS = 80: ORMA - CAD4 ORIENTATION MATRIX (Reciprocal Axes)
            CASE (80)
              IF (IPR(221) == 9) THEN
                DO I = 1, 9
                  PAR(180 + I) = FN(I)
                  J = MOD (I - 1, 3) + 1
                  K = ((I - 1) / 3)  + 1
                  DAM(J, K)    = FN(I)
                END DO
                CALL GEN003 (DAM, DUMV, DET, 0)
C * CALL EXIT/STOP
                IF (DET <= 0.0) CALL GEN127 ('CANNOT INVERT ORMA')
                WRITE (LU6, 99965, IOSTAT = IOST) 1.0 / DET
                IPR(16) = 1
              ELSE
C * NOT ENOUGH DATA ON CARD
                IPR(2) = 5
                GO TO 200
              END IF
              GO TO 10
C * IS = 82: SETUP (EXOR.BIN)
            CASE (82)
              IF (IABS (IGBL(8)) == 2) THEN
                CALL PLA151 (0)
                GO TO 210
              ELSE
                GO TO 10
              END IF
C * IS = 83: EXOR
            CASE (83)
              IF (IABS (IGBL(8)) == 2) THEN
                CALL PLA151 (1)
                GO TO 210
              ELSE
                GO TO 10
              END IF
C * IS = 84: ABSG(AUSS)
            CASE (84)
              IPR(78) = 2
              CALL PLA186
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 85: FACE CARD
            CASE (85)
C * TEST FOR DIST >= 0.0
              IF (FN(4) <= 0) THEN
                IPR(2) = 34
                GO TO 210
              END IF
C * TEST FOR PRE-OCCURRENCE
              IF (NFACES > 0) THEN
                DO I = 1, NFACES
                  DIFF = 0.0
                  DO J = 1, 3
                    DIFF = DIFF + ABS (PMILL(I, J) - FN(J))
                  END DO
                  IF (DIFF < 0.001) GO TO 10
                END DO
              END IF
              IPR(367) = IPR(367) + 1
              NFACES   = IPR(367)
              DO J = 1, 4
                PMILL(NFACES, J) = FN(J)
              END DO
              PMILL(NFACES, 5) = FN(4)
              GO TO 10
C * IS = 86: ABST(OMPA) (de MEULENAER-TOMPA)
            CASE (86)
              IPR(78) = 3
              CALL PLA186
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 87: ABSXTAL
            CASE (87)
              PAR(162) = FN(1)
              IPR(78)  = 1
              GO TO 70
C * IS = 88: LEPAGE METRICAL SYMMETRY ANALYSIS
            CASE (88)
              IPR(94) = 2
              IGBL(6) = 20
              IPR(2)  = -1
C * -L1 SWITCH OPTION
              IF (IGBL(3) == 52) THEN
                IPR(504) = 2
                PAR(441) = 0.01
                PAR(439) = 0.01
              ELSE
                IF (IPR(220) > 1) THEN
                  IF (IFL(2) == 'SHELX') IPR(504) = 2
                END IF
                IF (FN(1) /= 0.0) PAR(441) = FN(1)
                IF (FN(2) /= 0.0)
     1            IPR(94)  = MAX (2, MIN (10, NINT(FN(2))))
                IF (FN(3) /= 0.0) PAR(439) = FN(3)
              END IF
C * UNIT CELL CALCULATIONS
              CALL PLA100
C * GET SPACE GROUP INFO
              CALL SGSM (18, ICL, SGY, 0, 0, IERR)
C * CALL LEPAGE
              CALL PLA164 (0, 0, ICL(13:13), TM1, PAR(439), ' ')
              CALL GEN038 (ICL, 1, 80)
C * GET NEW INSTRUCTION
              RETURN
C * IS = 89: ASYM
            CASE (89)
              MODE = 0
              IF (PAR(168) > 0.0) THEN
C * ASYM VALID
                IF (IPR(220) > 1) THEN
                  IF (IFL(2)(1:5) == 'VALID') THEN
                    IFL(4) = IFL(2)
                    MODE   = 2
C * ASYM AVF VALID or ASYM VALID AVF => MODE = 2
                  ELSE IF (IPR(220) == 3) THEN
                    IF (IFL(2)(1:3) == 'AVF' .AND.
     1                  IFL(3)(1:5) == 'VALID') THEN
                      MODE = 2
                    ELSE IF (IFL(2)(1:5) == 'VALID' .AND.
     1                   IFL(3)(1:3) == 'AVF') THEN
                      MODE = 2
                    END IF
C * GET EXPECTED NUMBER OF REFLECTIONS
                  ELSE IF (IFL(2)(1:6) == 'EXPECT') THEN
                    MODE = 1
                  END IF
                END IF
              END IF
              IF (MODE == 3) THEN
                IGBL(22) = -1
                MODE     = 1
                CALL PLA145 (MODE)
                MODE = 3
                REWIND (UNIT = LU13, IOSTAT = IOST)
              END IF
              CALL PLA145 (MODE)
              IF (IPR(2) == 0) IPR(2) = -14
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 90: ABSPSI
            CASE (90)
              CALL PLA008
              IF (IGBL(37) == 0) THEN
                IPR(2)  = 56
C * ERROR HANDLING
                IGBL(1) = 3
                RETURN
              END IF
              PAGET   = 'ABSPSI'
              IPR(78) = 4
              GO TO 70
C * IS = 91: ABSSPHERE
            CASE (91)
              IPR(78) = -1
              GO TO 70
C * IS = 92: CONTOUR-PLOTS
            CASE (92)
              CALL PLA250
              IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
                IGBL(1) = 3
                RETURN
              END IF
              IF (IGGT(1:4) == 'EXIT') THEN
C * ERROR HANDLING
                IGBL(1) = 3
                RETURN
              END IF
              IF (IGBL(3) >= 19 .AND. IGBL(3) <= 22) THEN
C * ERROR HANDLING
                IGBL(1) = 3
                RETURN
              ELSE
C * RESTART
                IGBL(54) = IGBL(54) - 1
                CALL PLA280 ('RESTART')
              END IF
              GO TO 10
C * IS = 93: RESTART
            CASE (93)
              CALL GEN108 (LU1,  0)
              REWIND (UNIT = LU2, IOSTAT = IOST)
              IF (IOST /= 0) CALL GEN148 (LU2, 1)
              CALL GEN108 (LU20, 0)
              IF (IABS (IGBL(8)) == 3) IGBL(8) = 3
              WRITE (LU6, 99967, IOSTAT = IOST)
C * RESTART (FOR NEW) DATASET
              IGBL(1) = 1
              RETURN
C * IS = 94: VALIDATION CHECK MODE (FOR ACTA CRYST ETC)
            CASE (94)
C * CHECK MODE ON  (NOMOVE CASE)
              IF (IGBL(30) == 1) THEN
C * SET FOR ATOM LABELS WITHOUT ()
                IPR(71)  = 0
C * SET IUCR CHECK MODE
                IGBL(36) = 1
                LINE = NAMEFIL(1:KNMFIL)//'.chk'
                WRITE (LU6, 99997, IOSTAT = IOST) LINE
C * PRINTER LEVEL 0
                IGBL(64) = 0
                IGBL(63) = IGBL(64)
C * LIMIT VOID SEARCH
                GO TO 100
              ELSE
                CALL PLA015 (0, 47)
                IGBL(3) = 0
              END IF
              GO TO 10
C * IS = 95: EXPT - CALCULATE EXPECTED NUMBER OF REFLECTIONS
            CASE (95)
              CALL PLA086 (LU6)
              CALL PLA086 (LU7)
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 96: PLUTON
            CASE (96)
C * PLUTON/PLOT - TEST FOR 'PLUTON' OR 'PLUTON/RENAME' SHORTCUT
              IF (IFL(2)(1:3) == 'NAT') IGBL(3) = 8
              IF (IGBL(3) == 8) THEN
                CALL PLUTON (-1)
C * TERMINATE JOB
                IGBL(1) = 4
                RETURN
              END IF
              IFL(2)   = IFL(1)
              IPR(220) = 2
              GO TO 80
C * IS = 146: HALL
            CASE (146)
              IS = 32
              CYCLE
C * IS = 148: MULABS
            CASE (148)
              CALL PLA008
              IF (IPR(220) > 1) THEN
                DO I = 2, IPR(220)
                  IF (IFL(I)(1:5) == 'LIST')    IGBL(57) = 1
                  IF (IFL(I)(1:7) == 'NOCHECK') IPR(363) = 0
                END DO
              END IF
              IF (IGBL(37) == 0) THEN
                IPR(2)  = 56
C * ERROR HANDLING
                IGBL(1) = 3
                RETURN
              END IF
              IPR(78) = -2
              CALL PLA100
              CALL PLA042 (1)
              PAGET = 'MULABS'
              CALL PLA190
              IF (IPR(2) == 0) IPR(2) = -4
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 149: HKLFTRANS
            CASE (149)
              IF (IABS(IGBL(8)) == 2) THEN
                CALL PLA042 (1)
                CALL PLA330
                IF (IPR(2) == 0) IPR(2) = -15
              ELSE
                IPR(2) = 72
              END IF
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 150: XTAL-HABIT PLOT
            CASE (150)
              IPR(78) = 0
              CALL PLA186
C * TERMINATE JOB
              IGBL(1) = 4
              RETURN
C * IS = 151: HINCLUDE (ORTEP)
            CASE (151)
              DO I = 2, IPR(220)
                CALL PLA046 (3, IFL(I), IENM, LBB, LBC, LBD,
     1                          INQNR, JNQNR, N1)
                CALL GEN048 (1, IFG(2, N1), 12, 1)
              END DO
              GO TO 180
C * IS = 152: HEXCLUDE (ORTEP)
            CASE (152)
              DO I = 2, IPR(220)
                CALL PLA046 (3, IFL(I), IENM, LBB, LBC, LBD,
     1                          INQNR, JNQNR, N1)
                CALL GEN048 (1, IFG(2, N1), 12, 0)
              END DO
              GO TO 180
C * IS = 153: FILE
            CASE (153)
              CALL PLA004 (1)
              IGBL(8)  = 0
              IGBL(19) = 1
              M        = 1
              N        = 0
              CALL GEN039 (0, ICL, 5, 80, M, N)
              FILENAMES(1) = ICL(M:N)
              CALL PLA261 (IGBL(19))
C * INIT & FILE OPEN
              IGBL(1) = -1
              RETURN
C * IS = 154: RENAME (RES)
            CASE (154)
              IF (IABS(IGBL(8)) == 2) THEN
C * SET PLUTON/RENAME
                IGBL(3)   = 12
C * SET DISPLAY ALL LABELS
                IGBL(105) = 1
                CALL PLUTON (-1)
C * TERMINATE JOB
                IGBL(1) = 4
                RETURN
              ELSE
                CALL PLA015 (427, 40)
              END IF
              GO TO 10
C STRIP_END
C * IS = 156: DELAUNEY REDUCTION
            CASE (156)
              IF (IPR(221) > 0) THEN
                PAR(382) = FN(1)
                IF (IPR(221) == 2) PAR(381) = FN(2)
              END IF
              CALL PLA100
C * GET SPACE GROUP INFO
              CALL SGSM (18, ICL, SGY, 0, 0, IERR)
              CALL PLA265 (ICL(13:13), LU7)
C * GET NEW INSTRUCTION
              RETURN
C * IS = 157: EXPAND ASYMMETRIC UNIT CONTENTS TO P1
            CASE (157)
              CALL PLA208
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 158: ARU
            CASE (158)
              CALL PLA295
              GO TO 10
C * IS = 159: ANALYSIS OF VARIANCE
            CASE (159)
              IGBL(66) = 1
              CALL PLA410 (0)
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 160: FCF2HKL
            CASE (160)
C * LU25 MIGHT BE OPEN DUE TO EMBEDDED HKL
              IF (IPR(664) /= 0) THEN
                CLOSE (LU25, STATUS = 'DELETE', IOSTAT = IOST)
                IPR(664) = 0
              END IF
              OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sx.hkl',
     1          STATUS = 'UNKNOWN', IOSTAT = IOST)
              CALL PLA139 (LU6, LU16, LU61, IPR(384))
              CLOSE (UNIT = LU61)
              IF (IPR(2) == 0) IPR(2) = -16
C * TERMINATE JOB
              IGBL(1) = 4
              RETURN
C * IS = 161: PORTRAIT
            CASE (161)
              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)
              GO TO 10
C * IS = 162: SIMULATED POWDER-PATTERN
            CASE (162)
              CALL PLA113
C * TERMINATE JOB
              IF (IGBL(3) == 31) IGBL(1) = 4
              RETURN
C * IS = 163: FSUM
            CASE (163)
              GO TO 10
C * IS = 164: SCAL
            CASE (164)
              IS = 1
              CYCLE
C * IS = 165: CRYS
            CASE (165)
              IS = 1
              CYCLE
C * IS = 166: TWINROTMAT
            CASE (166)
              CALL PLA410 (1)
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 167: CAVITY
            CASE (167)
              PAR(571) = 0.025
              IF (IPR(221) > 0) THEN
C * OVERRULE MINIMUM CAVITY RADIUS DEFAULT (1.2)
                PAR(519) = MAX (0.3, FN(1))
                IF (IPR(221) > 1) PAR(520) = MAX (5.0, FN(2))
              END IF
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0) ==> SETUP CONNECTED SET
              IF (IPR(30) == 0) CALL PLA067
C * RUN CAVITY TOOL
              IF (IPR(2)  == 0) CALL PLA207
C * RESTART
              CALL PLA280 ('RESTART')
              GO TO 10
C * IS = 168: SHXABS
            CASE (168)
              IF (IPR(221) > 0) THEN
                PAR(417) = FN(1)
                IF (IPR(221) > 1) THEN
                  PAR(418) = FN(2)
                  IF (IPR(221) > 2) THEN
                    IYUNK = NINT (FN(3))
                    IF (IYUNK <= 8 .AND. MOD (IYUNK, 2) == 0) THEN
                      IPR(523) = IYUNK
                    END IF
                    IF (IPR(221) > 3) THEN
                      IYUNK = NINT (FN(4))
                      IF (IYUNK == 0 .OR.
     1                  (IYUNK < 8 .AND. MOD (IYUNK, 2) == 1)) THEN
                        IPR(524) = IYUNK
                      END IF
                    END IF
                  END IF
                END IF
              END IF
C * SHXABS
              CALL PLA202
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 169: DELETE ATOM (ORTEP/SOLV)
            CASE (169)
              N = IPR(220)
              IF (N > 1) THEN
                DO I = 2, N
                  CALL PLA046 (2, IFL(I), IENM, LBB, LBC, LBD,
     1                         INQNR, JNQNR, NR)
                  IF (NR > 0) THEN
                    CALL GEN048 (1, IFG(2, NR), 27, 1)
                  ELSE
                    CALL PLA015 (0, 28)
                  END IF
                END DO
              END IF
              GO TO 10
C * IS = 170: COLOR TYPE INSTRUCTION
            CASE (170)
              N = IPR(220)
              IF (MOD (N, 2) == 0 .AND. N >= 4) THEN
                DO I = 3, N, 2
                  IEXIT = 0
                  NQ1 = IFL(I)(1:2)
                  NQ2 = IFL(I + 1)(1:3)
                  IF (NQ1(2:2) == ' ') THEN
                    NQ1 = ' '//IFL(I)(1:1)
                  ELSE
                    CALL GEN020 (-1, NQ1, 2, 2)
                  END IF
                  DO J = 1, IAN
                    IF (NQ1(1:2) == LMT(J, 1)) THEN
                      DO K = 1, NP10 + 1
                        IF (NQ2(1:3) == COLR(K)(1:3)) THEN
                          IACL(J) = K
                          IEXIT   = 1
                          EXIT
                        END IF
                      END DO
                    END IF
                    IF (IEXIT /= 0) EXIT
                  END DO
                END DO
              END IF
              GO TO 10
C * IS = 171: RESET
            CASE (171)
              CALL PLA286 (0)
              GO TO 190
C * IS = 173: STIDY (Structure Tidy - Parthe & Gelato)
            CASE (173)
C * RUN STRUCTURE TIDY
              EXTENS1 = EXTENS
              CALL PLA301 (1)
              EXTENS = EXTENS1
              IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 174: BIJVOET PAIR ANALYSIS
            CASE (174)
C * SET DEFAULTS
C * GAUSSIAN PROBABILITY DISTRIBUTION
              IPR(613) = 0
C * NO PROBALILITY DISTRIBUTION CORRECTION
              IPR(593) = 0
C * NO RECYCLE-T
              IPR(617) = 0
C * Fo/Fc BASED ON CIF
              IPR(594) = 1
              PAR(488) = 0.0
              KN = IPR(221)
              IF (KN.GT. 0) THEN
                DO I = 1, IPR(221)
C * Gaussian/Student-t
                  IF (I == 1) THEN
                    IPR(613) = NINT (FN(1))
C * PP Slope Correction
                  ELSE IF (I == 2) THEN
                    IPR(593) = NINT (FN(2))
C * Recycle Student-t
                  ELSE IF (I == 3) THEN
                    IPR(617) = NINT (FN(3))
C * CIF/FCF Based Fcalc
                  ELSE IF (I == 4) THEN
                    IPR(594) = NINT (FN(4))
C * NU VALUE
                  ELSE IF (I == 5) THEN
                    PAR (488) = FN(5)
                  END IF
                END DO
              END IF
              CALL PLA410 (-1)
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 175: FLIPPER (FLIP PATT / FLIP SHOW)
            CASE (175)
              IF (IGBL(80) /= 0) CALL PLA350
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 176: STRUCTURE?
            CASE (176)
              IF (IGBL(80) /= 0) CALL PLA350
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
C * IS = 178: STRAIN
            CASE (178)
              IF (CELAB(1, 1) > 0.0 .AND. TEMPAB(1) /= TEMPAB(2))
     1          THEN
C * DO AN ANALYSIS BASED ON HAZEN ET AL. OR DUNITZ ORTHOGONALIZATION RESP.
                DO I = 1, 2
                  MORT = 3 - I
                  CALL PLA284 (MORT, JID)
                END DO
              ELSE
                WRITE (LU6, 99971, IOSTAT = IOST)
              END IF
              IGBL(1) = 3
              RETURN
C * IS = 179: CELA (STRAIN)
            CASE (179)
              DO I = 1, 6
                CELAB(1, I) = FN(I)
              END DO
              TEMPAB(1) = FN(7)
              IPR(221)  = 6
              IS        = 30
              CYCLE
C * IS = 180: CELB (STRAIN)
            CASE (180)
              DO I = 1, 6
                CELAB(2, I) = FN(I)
              END DO
              TEMPAB(2) = FN(7)
              GO TO 10
C * IS = 181: CSUA (STRAIN)
            CASE (181)
              DO I = 1, 6
                VCAB(1, I) = FN(I)
              END DO
              ICV(1) = 1
              GO TO 10
C * IS = 182: CSUB (STRAIN)
            CASE (182)
              DO I = 1, 6
                VCAB(2, I) = FN(I)
              END DO
              ICV(2) = 1
              GO TO 10
C * IS = 183: CIF2SHELXL
            CASE (183)
              CALL PLA345
              IF (IPR(663) == -2 .OR. IPR(321) > 0) THEN
                IGBL(1) = 4
                RETURN
              END IF
              GO TO 10
C * IS = 184: NOEXPAND
            CASE (184)
              IGBL(136) = 1
              IPR(129)  = 1
              IGBL(30)  = 1
              GO TO 10
C * IS = 186: ANOM
            CASE (186)
              CALL PLA385 (1)
              GO TO 10
C * IS = 187: MU
            CASE (187)
              CALL PLA385 (2)
              GO TO 10
C * IS = 188: XTPLOT (SHELXT + PLOT)
            CASE (188)
C * CHECK FOR SHELXT ACCESS
              IF (IGBL(119) /= 0) THEN
                CALL PLA205
              ELSE
                WRITE (LU6, 99998)
              END IF
              GO TO 10
C * IS = 199: HYBRID, (BYPASS)
            CASE (199, 200)
C * CHECK FOR SHELXL201n WHEN TRUE: IGBL(139) = 1
              CALL PLA428
              IF (IGBL(110) > 0) CALL PLA131 (NINT (FN(1)))
              RETURN
C * IS = 202: ADDSYM (EXPANDED TO CALC ADDSYM)
            CASE (202)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'CALC'
              IPR(220) = IPR(220) + 1
              IS       = 18
              CYCLE
C * IS = 203: NEWSYM (EXPANDED TO CALC NEWSYM)
            CASE (203)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'CALC'
              IPR(220) = IPR(220) + 1
              IS       = 18
              CYCLE
C * IS = 204: SQUEEZE (EXPANDED TO CALC SQUEEZE)
            CASE (204)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'CALC'
              IPR(220) = IPR(220) + 1
              IS       = 18
              CYCLE
C * IS = 205: WILSON PLOT
            CASE (205)
              CALL PLA370 (0)
              GO TO 10
C * IS = 206: CALCULATE FCF FROM SHELXL201x.cif
            CASE (206)
              CALL PLA346
              GO TO 10
C * IS = 210: (SOLVENT) ACCESSIBLE SURFACE AREA (S)ASA
            CASE (210)
C * HANDLE NON-DEFAULT PARAMETER SETTINGS
              IF (IPR(221) > 0) THEN
C * PROBE RADIUS [DEFAULT = 1.84]
                PAR(557) = FN(1)
C * NUMBER OF MonteCarlo PROBES [DEFAULT = 5000]
                IF (IPR(221) > 1) IPR(743) = NINT (FN(2))
              END IF
C * SET TO NO R/S CALC
              IPR(744) = 1
              CALL PLA067
C * (S)ASA CALCULATION
              CALL PLA394
              IPR(2)  = -1
              IGBL(1) = 3
              RETURN
C * IS = 211 -NONSYM (EXPANDED TO CALC NONSYM)
            CASE (211)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'CALC'
              IPR(220) = IPR(220) + 1
              IS       = 18
              CYCLE
C * IS = 212: ADP/ORTEP (EXPANDED TO PLOT ADP)
            CASE (212, 219)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'PLOT'
              IPR(220) = IPR(220) + 1
              IS       = 15
              CYCLE
C * IS = 213: SOLV (EXPANDED TO CALC SOLV)
            CASE (213)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'CALC'
              IPR(220) = IPR(220) + 1
              IS       = 18
              CYCLE
C * IS = 214: NEWMAN (EXPANDED TO PLOT NEWMAN)
            CASE (214)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'PLOT'
              IPR(220) = IPR(220) + 1
              IS       = 15
              CYCLE
C * IS = 215: RADII (EXPANDED TO LIST RADII)
            CASE (215)
              DO I = IPR(220), 1, -1
                IFL(I + 1) = IFL(I)
              END DO
              IFL(1)   = 'LIST'
              IPR(220) = IPR(220) + 1
              IS       = 29
              CYCLE
C * IS = 216: VOLCAL (HAZEN & FINGER)
            CASE (216)
              IFL(1)    = 'CALC'
              IFL(2)    = 'COORDN'
              IGBL(144) = 1
              IPR(220)  = 2
              IS        = 18
              CYCLE
C * IS = 218: CIP (R/S)
            CASE (218)
              IF (IPR(221) /= 0) IPR(492) = MIN (NINT (FN(1)), 10)
              IFL(1) = 'CALC'
              IFL(2) = 'GEOM'
C * R/S OUTPUT DEFAULT
              IPR(777) = 1
              IPR(220) = 2
              IPR(221) = 0
              IS       = 18
              CYCLE
            CASE DEFAULT
              GO TO 10
          END SELECT
        END DO
        GO TO 10
C * TEST FOR TOO MANY SPECIFIED ATOMS
   20   IF (IPR(220) > NP1 + 1) THEN
          IPR(2) = 8
          GO TO 200
        END IF
        IF (NTYP == 4) THEN
          IF (IPR(30) == 0) THEN
            DO I = 2, IPR(220)
C * SET UP CONNECTED SET
              IF (IFL(I)(1:4) == 'DIST') CALL PLA067
            END DO
          END IF
        END IF
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
        IF (IPR(30) == 0) THEN
          NRET = 1
          CALL PLA390 (1, NTYP, NRET)
          IF (NRET == 1) THEN
            GO TO 10
          ELSE IF (NRET == 2) THEN
            GO TO 30
          ELSE IF (NRET == 3) THEN
            GO TO 200
          END IF
C * PREVIOUS GEOM CALCULATION CASE
        ELSE
          IF (NTYP == 4) THEN
            IPR(81) = - IPR(220)
C * INTERACTIVE CALCULATION
            CALL PLA440 (1)
            GO TO 10
          END IF
        END IF
        IPR(220) = - IPR(220)
C * SINGLE DISTANCE, ANGLE OR TORSION ANGLE CALCULATION (+GEOM)
C * ALSO: ANGLE BETWEEN TWO CRYSTAL PLANES
   30   IF (IPR(220) == 1) THEN
          IF (IPR(221) == 6) THEN
            CALL PLA100
            ANG = 180.0 - GEN016 (FN(1), RBB, FN(4))
            WRITE (PRBUF, 99996, IOSTAT = IOST) (NINT (FN(I)), I = 1, 6)
     1        , ANG
            WRITE (LU6, 99981, IOSTAT = IOST) PRBUF(1:50)
            SBCD = PRBUF(1:50)//CHAR (0)
            GO TO 10
          ELSE
C * NOT ENOUGH DATA ON CARD
            IPR(2) = 5
            GO TO 200
          END IF
        ELSE IF (IFL(1)(1:3) == 'FIT' .OR. IPR(220) == -1 .OR.
     1          (IPR(220) > 1 .AND. IPR(220) < 6)) THEN
          IPR(1)  = 7
          IPR(81) = IPR(220)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
          IF (IPR(30) == 0) THEN
            IGBL(52) = MAX (IGBL(52), IPR(23))
            IPR(205) = 0
          END IF
          CALL PLA021 (11, NRETURN)
          RETURN
        ELSE
C * NOT ENOUGH DATA ON CARD
          IPR(2) = 5
          GO TO 200
        END IF
C * CHECK FOR # OF VALUES IN CIF-MODE
   40   IF (IGBL(8) == 3) THEN
          IF (IFL(2)(1:1) == '?') GO TO 10
          IF (IPR(221) /= 12 .OR.
     1        (FN(2) == 0.0 .AND. FN(3) == 0.0 .AND. FN(4) == 0
     2        .AND. FN(5) == 0 .AND. FN(6) == 0)) THEN
            IF (IPR(221) /= 0) THEN
              IF (IGBL(3) == 1) THEN
C * ALERT _217
                CALL PLA236 (217, 0, 1.0, 1.0, IFL(2), ' ')
              ELSE
                IPR(2) = 50
                GO TO 200
              END IF
            ELSE
              GO TO 10
            END IF
          END IF
        END IF
C * LOAD U-MATRIX(6 TO 9 COMPONENTS)
        CALL GEN025 (DUMV, FN, -1)
C * CALCULATE TM2 * UIJ * TR(TM2)
        CALL GEN001 (1, TM2, DUMV, UIJ)
C * EXTRACT FROM TRANSFORMED U-MATRIX (9 TO 6 COMPONENTS)
        CALL GEN025 (UIJ, FN, 1)
        ICT     = 2
        IPR(32) = 2
C * SUIJ DATA
   50   IF (PAR(113) /= 0.0) CALL GEN144 (-1, FN(1), PAR(113))
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
   60   IF (IPR(30) == 1 .OR. IPR(107) == 1) THEN
          IPR(471) = IPR(471) + 1
          IF (IGBL(5) /= LU5) GO TO 10
C * UNKNOWN CARD ERROR
          IPR(2) = 7
          GO TO 200
        ELSE
          NQ2 = IFL(2)
          IF (IGBL(8) == 1) THEN
            IF (NQ4 /= NQ2) THEN
C * LABEL INCONSISTENT
              IPR(2) = 4
              GO TO 200
            END IF
            INQNR2 = INQNR
          ELSE
            MODE = 0
            CALL PLA046 (-2, NQ2, IENM, LBB, LBC, LBD,
     1                       INQNR2, JNQNR2, IDUM2)
          END IF
C * REGISTER (AN)ISO PARAMETER INPUT
          IPR(32) = MAX (IPR(32), 1)
          WRITE (LU4) ICT, INQNR2, (FN(K), K = 1, 8)
C * HANDLE CIF-FILE INPUT
          IF (IGBL(8) == 3) THEN
            IF (IS == 25) THEN
              IS = 26
              DO I = 1, 6
                FN(I) = FN(I + 6)
              END DO
C * UIJ DATA & SUIJ DATA
C * INCLUDE A*,B* AND C* INTO U(I, J) BEFORE TRANSFORMATION
              CALL GEN144 (1, FN(1), PAR(135))
C * CHECK FOR SUIJ
              IF (IS == 26) THEN
                ICT = 3
                GO TO 50
              END IF
              GO TO 40
            END IF
          END IF
          GO TO 10
        END IF
   70   CONTINUE
        CALL PLA186
        IF (IPR(2) == 0) THEN
          SELECT CASE (IPR(78))
            CASE (-1)
              IPR(2) = -5
            CASE (1)
              IPR(2) = -1
            CASE (2)
              IPR(2) = -8
            CASE (3)
              IPR(2) = -7
            CASE (4)
              IPR(2) = -6
          END SELECT
        END IF
C * ERROR HANDLING
        IGBL(1) = 3
        RETURN
C * PLOT INSTRUCTION CARD
C * IPR(14) =  0 : NO PLOTTING
C * IPR(14) = -1 : IPR(55) = -1 NEWMAN
C *              :         =  0
C *              :         =  1 : PLAN
C *              :         =  2 : RING
C *              :         =  3 : RESD
C *              :         =  4 : LSPL
C *         =  4 : ORTEP
C *         =  5 : POLYEDRA PLOT
C *         =  6 : PLUTON
C * SET GOTO SWITCH
   80   IPR(1)   = 5
        IPR(56)  = 0
        IPR(112) = 0
        IPR(205) = 0
        N        = 1
        K0       = 0
C * SAVE OPTION TEST
        IF (IGBL(45) > 0 .AND. IGBL(5) == LU5) THEN
          IGBL(45) = IGBL(45) + 1
          WRITE (LU3, 99984, IOSTAT = IOST) ICL(1:80)
          WRITE (LU6, 99973, IOSTAT = IOST) ICL(1:70)
        END IF
C * MAKE PLOT ADP DEFAULT FOR 'PLOT-AT-START' INSTRUCTION
        IF ((IPR(14) == 0  .OR. IPR(14) == 4) .AND.
     1       IPR(220) == 1) THEN
          IGBL(3)  = 3
          IPR(220) = 2
          IFL(2)   = 'ADP'
          IF (IPR(346) == 1) THEN
            IFL(3) = 'COLOR'
            IPR(220) = 3
          END IF
        END IF
        IF (IPR(220) > 1) THEN
          DO I = 2, IPR(220)
            SELECT CASE (IFL(I)(1:4))
              CASE ('RING')
                IPR(55) = 2
                IPR(14) = -1
              CASE ('PLAN')
                IPR(55) = 1
                IPR(14) = -1
              CASE ('RESD')
                IF (IPR(14) > 0) THEN
                  K0 = K0 + 1
                  IF (K0 <= IPR(221)) IPR(140) = NINT (FN(K0))
C * RESET LABEL POSITIONING STATUS
                  IPR(201) = 0
                ELSE
                  IPR(55) = 3
                  IPR(14) = -1
                END IF
              CASE ('LSPL')
                IPR(55) = 4
                IPR(14) = -1
C * DISPLAY ON
              CASE ('DISP')
                CALL GGIP (-999.0, 0.0, 0.0, -3)
                CALL GGIP (-999.0, 0.0, 0.0, 2)
C * META ON
              CASE ('META')
                CALL GGIP (-999.0, 0.0, 0.0, -2)
              CASE ('NEWM')
                IPR(30)  =  0
                IPR(55)  = -1
                IPR(14)  = -1
                IPR(169) = 0
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) /= 0) CALL GEN108 (LU8, 0)
                IPR(162) = 0
              CASE ('PERP')
                IPR(56) = 0
              CASE ('ALON')
                IPR(56) = 1
              CASE ('ADP ')
                IPR(14) = 4
                IF (IGBL(3) /= 28) IGBL(3) = 3
              CASE ('ORTE')
                IPR(14) = 4
                IF (IGBL(3) /= 28) IGBL(3) = 3
              CASE ('TME ')
                IPR(14) = 4
              CASE ('POLY')
                IPR(14) = 5
C * PLUTON (AUTO)
              CASE ('PLUT')
                IPR(14) = 6
              CASE ('HATO')
                IPR(212) = 1
              CASE ('NOHA')
                IPR(212) = 0
              CASE ('LABE')
                IGBL(75) = 1
              CASE ('NOLA')
                IGBL(75) = 0
              CASE ('ENVE')
                IPR(211) = 1
              CASE ('HETE')
                IPR(211) = 0
              CASE ('OCTA')
                IPR(211) = 2
              CASE ('PARE')
                IPR(350) = 1
              CASE ('NOPA')
                IPR(350) = 0
              CASE ('MARG')
                IF (K0 < IPR(221))  THEN
                  K0 = K0 + 1
                  PAR(44) = FN(K0)
                END IF
              CASE ('TAPE')
                IF (K0 < IPR(221))  THEN
                  K0 = K0 + 1
                  PAR(48) = FN(K0)
                END IF
              CASE ('NET ')
                IPR(112) = 1
              CASE ('MONO')
                IPR(116) = 0
              CASE ('STER')
                IPR(116) = 1
              CASE ('COLO')
                IPR(346) = 1
              CASE DEFAULT
                CALL PLA037 (I, L, 2)
                IF (IPR(2) == 0) THEN
                  IF (L < 0)
     1              IPR(162)  = IPR(162) * (NP1 + 1) + IABS (L)
                ELSE
                  IPR(2) = 0
                  WRITE (LU6, 99986, IOSTAT = IOST) IFL(I)
                END IF
            END SELECT
          END DO
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
          IF (IPR(30) == 0) THEN
            IPR(220) = 2
            IF (IPR(14) < 0) THEN
              WRITE (LU6, 99983, IOSTAT = IOST)
            ELSE
              WRITE (LU6, 99982, IOSTAT = IOST)
            END IF
            GO TO 110
          ELSE
            IF (IPR(14) > 0) GO TO 210
C * TEST FOR CALC INTRA AS PREVIOUS INSTRUCTION
            IF (IPR(136) /= 1) THEN
C * MISPLACED PLOT INSTRUCTION
              IPR(2) = 12
              GO TO 200
            END IF
          END IF
          IF (IPR(86) == 0) GO TO 10
        ELSE
          IF (IPR(14) == 0) THEN
C * NOT ENOUGH DATA ON CARD
            IPR(2) = 5
            GO TO 200
          END IF
        END IF
        GO TO 210
C * CALC CONTROL CARD FOR PLA067. THE SUB-KEYWORDS ARE:
C * INTRA, INTER, COORDN, METAL, GEOM, HBOND, TMA, VOID, LIST, ADDSYM
C * SET PLOTTING DEFAULT NO
  100   IPR(14)  = 0
C * SET UNIQUE DEFAULT zero
        IPR(31)  = 0
C * SET LU2 DEFAULT NO
        IPR(67)  = 0
C * SET VOID/SOLV DEFAULT NO
        IPR(189) = 0
C * SET VOID MAP DEFAULT NO
        IPR(197) = 0
C * SET VOID/SOLV DEFAULT NO
        IPR(200) = 0
C * SET CALC ADDSYM DEFAULT NO
        IPR(205) = 0
        IF (IGBL(45) > 0 .AND. IGBL(5) == LU5) THEN
          IGBL(45) = IGBL(45) + 1
C * INSTRUCTION SAVE AND MESSAGE
          WRITE (LU3, 99984, IOSTAT = IOST) ICL(1:80)
          WRITE (LU6, 99973, IOSTAT = IOST) ICL(1:70)
        END IF
  110   IPR(136) = 0
        IPR(121) = 0
C * HANDLE CALC ( = CALC ALL) CASE
        IF (IPR(220) == 1) THEN
C * NO NUMERICAL PARAMETERS FOR 'CALC ALL'
          IF (IPR(221) > 0) THEN
            IPR(221) = 0
C * UNKNOWN CARD ERROR
            IPR(2) = 7
            GO TO 200
          ELSE
C * CHECK MODE
            IF (IGBL(36) == 0) IGBL(36) = -1
            IPR(121) = 9
            IGBL(22) = 0
            IPR(495) = 1
C * SET 'CALC ALL'
            IPR(123) = 1
            IPR(326) = 1
          END IF
        END IF
      END IF
C * TEST FOR 'UNIQUE CALCULATION DONE'
  120 IF (IPR(30) == 0) THEN
        IPR(1) = 2
      ELSE
        IPR(1) = 6
      END IF
      IPR(57)  = 0
      N        = 0
      IGBL(52) = MAX (IGBL(52), IPR(23))
C * GET DEFAULT COORDINATION RADIUS
      PAR(262) = PAR(7)
      IF (IPR(14) /= 0) THEN
        IPR(121) = 1
        L        = 2
        CALL PLA021 (3, NRETURN)
        IF (NRETURN == 3) GO TO 130
      END IF
      L = 1
C * HANDLE CALC (ALL) CASE
C * (= ADDSYM, INTRA, INTER, COORDN, METAL, SOLV, (ASYM))
      IF (IPR(220) == 1) THEN
  125   SELECT CASE (IPR(121))
C * GET AVERAGE HKL MULTIPLICITY AND MERGED HKL LISTING
          CASE (9)
C * CHECK FOR EMBEDDED *.res AND *.hkl
            IF (IPR(663) /= 0 .AND. IPR(664) /= 0) THEN
C * INCLUDE ASYM - HKL DATA ANALYSIS IN LOOP
              CALL PLA149
            ELSE
              IPR(121) = 8
            END IF
            GO TO 125
C * RUN DEFAULT ADDSYM
          CASE (8)
            CALL PLA021 (2, NRETURN)
            IF (NRETURN == 0) THEN
              RETURN
            ELSE IF (NRETURN == 1) THEN
              GO TO 120
            ELSE IF (NRETURN == 2) THEN
              GO TO 200
            END IF
C * RUN DEFAULT CALC INTRA
          CASE (7)
            CALL PLA021 (3, NRETURN)
            IF (NRETURN == 3) GO TO 130
C * RUN DEFAULT CALC INTER
          CASE (6)
            CALL PLA021 (4, NRETURN)
            IF (NRETURN == 2) THEN
              GO TO 200
            ELSE IF (NRETURN == 3) THEN
              GO TO 210
            ELSE IF (NRETURN == 4) THEN
              GO TO 190
            ENDIF
C * RUN DEFAULT CALC COORDN
          CASE (5)
            CALL PLA021 (5, NRETURN)
            IF (NRETURN == 0) THEN
              RETURN
            ELSE IF (NRETURN == 3) THEN
              GO TO 210
            END IF
C * RUN DEFAULT CALC METAL
          CASE (4)
            CALL PLA021 (8, NRETURN)
            IF (NRETURN == 1) THEN
              GO TO 10
            ELSE IF (NRETURN == 3) THEN
              GO TO 130
            END IF
C * RUN DEFAULT CALC SOLV
          CASE (3)
            IPR(200) = 2
            CALL PLA021 (9, NRETURN)
            IF (NRETURN == 2) THEN
              GO TO 200
            ELSE IF (NRETURN == 3) THEN
              GO TO 210
            END IF
C * RUN DEFAULT IUCR-CHECK (CIF + FCF) (ASYM)
          CASE (2)
            CALL PLA021 (10, NRETURN)
            IF (NRETURN == 0) THEN
              RETURN
            ELSE IF (NRETURN == 4) THEN
              GOTO 190
            END IF
C * RUN END
          CASE (1)
            GO TO 190
        END SELECT
      END IF
C * SUB-KEYWORDS LOOP
      IF (IPR(221) > 0) PAR(262) = 0.0
      IPR(121) = 1
  130 L        = L + 1
      IF (L <= IPR(220)) THEN
        DO ISS = 1, NP22
          NQ1 = IFL(L)(1:7)
          IF (NQ1(1:4) == ISWSS(ISS)) THEN
            SELECT CASE (ISS)
C * ISS = 1: GEOM
              CASE (1)
                GO TO 160
C * ISS = 2: TMA, ATOMIC DISPLACEMENT MOTION CALCULATION
              CASE (2)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) /= 0) THEN
                  IPR(2) = 29
                  GO TO 200
                END IF
                IPR(5)  = -1
                IF (IPR(221) > 0) THEN
                  PAR(34) = FN(1)
                  IF (IPR(221) > 1) IPR(21) = NINT (FN(2))
                END IF
                IF (IPR(220) > 2 .AND. IFL(3)(1:3) == 'CAR')
     1            IPR(347) = 1
                CALL PLA021 (3, NRETURN)
                IF (NRETURN == 3) GO TO 130
C * ISS = 3: INTRA
              CASE (3)
                CALL PLA021 (3, NRETURN)
                IF (NRETURN == 3) GO TO 130
C * ISS = 4: INTER
              CASE (4)
                CALL PLA021 (4, NRETURN)
                IF (NRETURN == 2) THEN
                  GO TO 200
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                ELSE IF (NRETURN == 4) THEN
                  GO TO 190
                ENDIF
C * ISS = 5: NOTM(A)
              CASE (5)
                IPR(5) = 0
C * ISS = 6: NOAN(G)
              CASE (6)
                IPR(7) = 0
C * ISS = 7: NOTO(R)
              CASE (7)
                IPR(8) = 0
C * ISS = 8: NOLS(PL)
              CASE (8)
                IPR(9) = 0
C * ISS = 9: NOST(D)
              CASE (9)
                IPR(72) = 0
C * ISS = 10: NORI(NG)
              CASE (10)
                IPR(10) = 0
C * ISS = 11: NOBOND
              CASE (11)
C * NOBO(ND)/NODI(ST)
                IPR(6) = 0
C * ISS = 12: NOMO(VE) OPTION
              CASE (12)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IPR(30) == 1) THEN
C * INSTRUCTION NOT ALLOWED
                  IPR(2) = 11
                  GO TO 200
                ELSE
C * SET NOMOVE
                  IGBL(30) = 1
                END IF
C * ISS = 13: NOSY(MM) OPTION
              CASE (13)
                IGBL(52) = 1
C * ISS = 14: NOBP(A)
              CASE (14)
                IPR(40) = 0
C * ISS = 15: EWLS
              CASE (15)
C * (E)WLSPL - CALCULATE ESD-WEIGHTED PLANES
                IPR(41) = 2
C * ISS = 16: TOLA
              CASE (16)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(2) = FN(N)
                END IF
C * ISS = 17: CALC COORDINATION
              CASE (17)
                CALL PLA021 (5, NRETURN)
                IF (NRETURN == 0) THEN
                  RETURN
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                END IF
C * ISS = 18: CALC METAL
              CASE (18)
                CALL PLA021 (8, NRETURN)
                IF (NRETURN == 1) THEN
                  GO TO 10
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                END IF
C * ISS = 19: AWLSPL - CALCULATE (ATOM-WEIGHT) WEIGHTED L.S.-PLANES
              CASE (19)
                IPR(41) = 1
C * ISS = 20: CALC HBONDS (p1, p2, p3)
              CASE (20)
C * REGISTER MANUAL CALC HBONDS
                IPR(736) = 1
C * SET COORDINATION MODE
                IPR(31)  = -1
C * COPY DEFAULT HBOND PARAMETERS
                DO K = 1, 3
                  RGBL(43 + K) = RGBL(40 + K)
                END DO
C * GET/SAVE COMMAND LINE PARAMETERS p1, p2, p3
                IF (IPR(221) > 0) THEN
                  DO K = 1, IPR(221)
                    RGBL(43 + K) = FN(K)
                  END DO
                END IF
C * RESET ENTRY
                CALL PLA286 (0)
C * SET 'CALC ALL' LOOP
                IPR(121) = 0
C * TEST FOR PREVIOUS INTER CALC DONE (NO CALC HBONDS AFTER 'CALC INTER')
                IF (IPR(77) == 1) THEN
                  IPR(2) = 11
                  GO TO 200
                END IF
                IPR(77)  = 1
C * ISS = 21: UWLSPL - LSPL - BASED ON UNIT WEIGHTS
              CASE (21)
                IPR(41) = 0
C * ISS = 22: OUTPUT SHELX(L) RES-FILE (CALC SHELX(L) INSTRUCTION)
              CASE (22)
                IF (IGBL(131) == 0) THEN
                  IGBL(31) = -2
                ELSE
                  IGBL(31) = -3
                END IF
C * SET ROUND OFF
                IPR(68) = 0
                WRITE (LU6, 99989, IOSTAT = IOST)
                GO TO 140
C * ISS = 23: OUTPUT OMEGA INPUT-FILE (CALC OMEGA INSTRUCTION)
              CASE (23)
                IF (IPR(438) == 0) THEN
                  IGBL(31) = 1
                END IF
                IF (IPR(220) < 4) THEN
C * BONDS, ANGLES, TORSION-ANGLES
                  IPR(6) = 1
                  IPR(7) = 1
                  IPR(8) = 1
                END IF
                GO TO 140
C * ISS = 24: CHX INCLUDE
              CASE (24)
                IPR(645) = 1
C * ISS = 25: OUTPUT SPF - FILE (CALC SPF INSTRUCTION)
              CASE (25)
                IGBL(31) = 3
C * SET ROUND OFF
                IPR(68) = 0
                WRITE (LU6, 99989, IOSTAT = IOST)
                GO TO 140
C * ISS = 26: FIVE COORDINATION
              CASE (26)
                IPR(122) = 5
                IF (N < IPR(221)) THEN
                  N       = N + 1
                  PAR(35) = FN(N)
                ELSE
                  PAR(35) = 0.0
                END IF
C * ISS = 27: CALC ALL
              CASE (27)
                IPR(121) = 8
                IPR(220) = 1
                GO TO 120
C * ISS = 28: TOLP
              CASE (28)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(49) = FN(N)
                END IF
C * ISS = 29: TOLR
              CASE (29)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(3) = FN(N)
                END IF
C * ISS = 31: VOID
              CASE (31)
                IPR(200) = 1
                CALL PLA021 (9, NRETURN)
                IF (NRETURN == 2) THEN
                  GO TO 200
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                END IF
C * ISS = 32: PROBE RADIUS
              CASE (32)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(84) = FN(N)
                END IF
C * ISS = 33: PSTEP
              CASE (33)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  IPR(214) = NINT (FN(N))
                END IF
C * ISS = 34: LIST
              CASE (34)
                IPR(197) = 1
C * ISS = 35: SUBKEYWORD EXPAND
              CASE (35)
                IPR(67) = 1
C * ISS = 36: CALC DIST
              CASE (36)
                IPR(57)  = -2
                PAR(262) = 3.0
                IPR(7)   = 0
                CALL PLA021 (6, NRETURN)
                IF (NRETURN == 6) GO TO 130
C * ISS = 37: TOLEA
              CASE (37)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(26) = FN(N)
                END IF
C * ISS = 38: MISSYM (= ADDSYM)
              CASE (38)
                CALL PLA021 (2, NRETURN)
                  IF (NRETURN == 0) THEN
                  RETURN
                ELSE IF (NRETURN == 1) THEN
                  GO TO 10
                ELSE IF (NRETURN == 2) THEN
                  GO TO 200
                END IF
C * ISS = 39: SOLV
              CASE (39)
                IPR(326) = 1
                IPR(200) = 2
                CALL PLA021 (9, NRETURN)
                IF (NRETURN == 2) THEN
                  GO TO 200
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                END IF
C * ISS = 40: TOLM
              CASE (40)
                N = N + 1
                IF (N > IPR(121)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(27) = FN(N)
                END IF
C * ISS = 41: NOBO(ND)/NODI(ST)
              CASE (41)
                IPR(6) = 0
C * ISS = 42: BOND
              CASE (42)
                IPR(6) = 1
C * ISS = 43: ANGLE
              CASE (43)
                IPR(7) = 1
C * ISS = 44: TORS(ION)
              CASE (44)
                IPR(8) = 1
C * ISS = 45: CSD-QUE
              CASE (45)
                IGBL(31) = 4
                GO TO 140
C * ISS = 46: SQUEEZE
              CASE (46)
C * CHECK FOR SUITABLE MODEL AND REFLECTION FILE COMBINATIONS (PLA008)
C * CASE: SHELXL201n CIF + FCF (LIST 4) - (UNTWINNED)
                IF (IGBL(29) == 1 .AND. IPR(619) == 0 .AND.
     1            IPR(663) /= 0 .AND. IPR(664) /= 0) THEN
C * CASE: SHELXL201n CIF + FCF (LIST 8) (TWINNING)
                ELSE IF (IGBL(29) == 3 .AND. IPR(619) == 1 .AND.
     1            IPR(663) /= 0 .AND. IPR(664) /= 0) THEN
C * CASE: SHELXL INS/RES + SHELXL HKL
                ELSE IF (IGBL(29) == -1) THEN
C * CASE: SHELXL INS/RES + SHELXL FCF (LIST 4)
                ELSE IF (IGBL(29) == -2) THEN
                ELSE
                  IPR(1) = 1
                  IPR(2) = 68
                  GO TO 200
                END IF
C * SET JOIN EXPAND TO NO
                IPR(110) = 0
C * SET SQUEEZE MODE
                IPR(210) = 1
C * SET SAV-FILE SQUEEZE MODE
                IPR(326) = 1
C * SOLV MODE
                IPR(200) = 2
                CALL PLA021 (9, NRETURN)
                IF (NRETURN == 2) THEN
                  GO TO 200
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                END IF
C * ISS = 47: SAV
              CASE (47)
                IPR(326) = -1
C * ISS = 48: CALC FCF
              CASE (48)
                IPR(210) = - 1
                IF (L == IPR(220)) GO TO 160
C * ISS = 49: CYCL
              CASE (49)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  IPR(142) = MAX (2, NINT (FN(N)))
                END IF
C * ISS = 50: CALC NEWSYM
              CASE (50)
C * CHANGE AXIS CRITERIUM FROM DEFAULT 0.2 VALUE
                IF (FN(1) /= 0.0) PAR(383) = FN(1)
                IPR(210) = -2
                IGBL(31) = 5
                IPR(6)   = 0
C * OPEN UNIT #2
                CALL PLA292
                CALL PLA015 (0, 39)
                GO TO 170
C * ISS = 52: OUTPUT PDB-FORMATTED FILE
              CASE (52)
                IGBL(31) = 7
                GO TO 140
C * ISS = 53: HINCL (TMA)
              CASE (53)
                IPR(497) = 1
C * ISS = 54: NONSYM
              CASE (54)
                IPR(495) = 3
                IF (IPR(221) > 0) PAR(73) = FN(1)
                IF (IPR(221) > 1) PAR(75) = FN(2)
                CALL PLA015 (0, 39)
                GO TO 170
C * ISS = 55: NONA OPTION (HBONDS)
              CASE (55)
                IPR(300) = 0
C * ISS = 56: MAXDEV
              CASE (56)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(76) = FN(N)
                END IF
C * ISS = 57: WLSP
              CASE (57)
C * (E)WLSPL - CALCULATE ESD-WEIGHTED PLANES
                IPR(41) = 2
C * ISS = 58: FCAL (SQUEEZE OPTION)
              CASE (58)
                IPR(132) = 1
C * ISS = 59: ADDSYM
              CASE (59)
                CALL PLA021 (2, NRETURN)
                IF (NRETURN == 0) THEN
                  RETURN
                ELSE IF (NRETURN == 1) THEN
                  GO TO 10
                ELSE IF (NRETURN == 2) THEN
                  GO TO 200
                END IF
C * ISS = 60: DIFFOURIER
              CASE (60)
C * SET CALC DIFFMAP MODE
                IPR(210) = 2
                IPR(326) = 0
                IPR(200) = 0
                CALL PLA021 (9, NRETURN)
                IF (NRETURN == 2) THEN
                  GO TO 200
                ELSE IF (NRETURN == 3) THEN
                  GO TO 130
                END IF
C * ISS = 61: NOSORT ATOMS OPTION
              CASE (61)
                IGBL(33) = 0
C * ISS = 62: DISORDER (MINOR) INCLUDED
              CASE (62)
                IPR(303) = 1
C * ISS = 63: GENERATE (HKL) - IPR(408) = 1
              CASE (63)
                IPR(408) = 1
                IPR(700) = NINT (FN(1))
                IF (IPR(210) == -1) GO TO 160
                GO TO 150
C * ISS = 64: EXPECT
              CASE (64)
                IPR(408) = 2
                GO TO 150
C * ISS = 65: MAXRING
              CASE (65)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  IPR(579) = NINT (FN(N))
                END IF
C * ISS = 66: MOLSYM
              CASE (66)
                IPR(495) = 2
                IF (IPR(221) > 0) PAR(73) = FN(1)
                IF (IPR(221) > 1) PAR(75) = FN(2)
                GO TO 170
C * ISS = 67: RENUM KEYWORD
              CASE (67)
                IPR(501) = 1
C * ISS = 68: SOLV PLOT
              CASE (68)
                IPR(326) = 2
C * ISS = 69: CALC RDF
              CASE (69)
C * SET RADIUS RANGE MAXIMUM
                PAR(262) = PAR(450)
                IF (IPR(221) > 0) THEN
                  PAR(262) = FN(1)
C * (RE)SET SIGMA ASSIGNED TO BOND
                  IF (IPR(221) > 1) PAR(451) = FN(2)
                END IF
                IPR(57)  = 2
                IPR(170) = 0
C * INIT RADIAL DISTRIBUTION FUNCTION
                CALL PLA144 (0, 0)
                CALL PLA015 (0, 39)
                CALL PLA021 (6, NRETURN)
                IF (NRETURN == 6) GO TO 130
C * ISS = 70: SOLV GRID
              CASE (70)
                N = N + 1
                IF (N > IPR(221)) THEN
C * NOT ENOUGH DATA ON CARD
                  IPR(2) = 5
                  GO TO 200
                ELSE
                  PAR(80)  = FN(N)
                  IPR(214) = 0
                END IF
C * ISS = 71: SOLV F3D
              CASE (71)
                IPR(326) = 3
C * ISS = 72: NOSF (NO EXPLICTION SCATTERING FACTORS IN RES)
              CASE (72)
                IPR(595) = 1
C * DEFAULT
              CASE DEFAULT
                CYCLE
            END SELECT
            GO TO 130
          END IF
        END DO
C * CALC CARD HANDLING
      ELSE
C * TEST WHETHER THERE ARE NON-ZERO ATOMS
        IF (IPR(39) > 0) THEN
          GO TO 210
        ELSE
C * MESSAGES
          WRITE (LU6, 99992, IOSTAT = IOST)
          GO TO 190
        END IF
      END IF
C * IF NOT A SUB-KEYWORD THEN ASSUME ELEMENT SYMBOL FOLLOWED BY RADIUS
C * NOTE: INDIVIDUAL ATOM - RADIUS INTERPRETED IN PLA067 FOR IPR(17)=1
      IF (IPR(210) == 0) THEN
C * TEST FOR COORDN MODE
        IF (IPR(31) == 1) THEN
          IF (IPR(221) > 0) THEN
            N = N + 1
            PAR(68) = FN(N)
          ELSE
            PAR(68) = PAR(7)
          END IF
        END IF
        CALL PLA037 (L, NID, 3)
        IF (IPR(31) == 0) IPR(156) = 1
        IF (L > 2) THEN
          IF (NID > 0) THEN
            IF (IPR(31) < 1) N = N + 1
            IF (IPR(57) < 0) THEN
              IPR(57) = - NID
              IF (N == IPR(221)) PAR(262) = FN(N)
            ELSE
              IF (N > IPR(221)) THEN
                FNN = PAR(7)
              ELSE
                FNN = FN(N)
              END IF
              RADR(NID, 1) = FNN
            END IF
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
          ELSE IF (NID == 0 .AND. IPR(30) /= 0) THEN
            IF (IPR(31) == 1) THEN
              GO TO 10
            ELSE
              IPR(2) = 18
              GO TO 200
            END IF
          END IF
        ELSE
          IPR(2) = 18
          GO TO 200
        END IF
      END IF
      GO TO 130
  140 IF (IPR(438) == 0) THEN
C * OPEN UNIT #2
        CALL PLA292
      END IF
      GO TO 170
  150 CALL PLA293 (PAR(17))
      PAR(165) = ASIN (MIN(1.0, PAR(287) * PAR(17))) * RGBL(6)
      GO TO 130
C * SHORT GEOMETRY CALCULATION (GEOM)
  160 IF (IPR(220) == 2 .OR.
     1   (IPR(220) == 3 .AND. IFL(3)(1:3) == 'NOM')) THEN
C * SET FOR BONDS, ANGLES AND TORSION CALCULATION
        CALL PLA015 (0, 39)
C * CALC FCF (-1)
        IPR(6) = 1
        IPR(7) = 1
        IPR(8) = 1
      END IF
C * NO GEOM ETC AFTER PREVIOUS INTRA
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
  170 IF (IPR(30) /= 0) THEN
        IPR(2) = 31
        GO TO 200
      END IF
      IPR(31)  = 0
      IPR(121) = 0
      GO TO 130
C * OPTIONALLY SAVE THIS INSTRUCTION
  180 IF (IGBL(45) > 0 .AND. IGBL(5) == LU5) THEN
        WRITE (LU3, 99984, IOSTAT = IOST) ICL(1:80)
        IGBL(45) = IGBL(45) + 1
        WRITE (LU6, 99973, IOSTAT = IOST) ICL(1:70)
      END IF
      GO TO 10
C * HANDLE END-CARD
  190 IF (IGBL(5) == LU5) THEN
        IF (IABS(IGBL(45)) > 1) THEN
C * WRITE END CARD TO SAVE-FILE
          WRITE (LU3, 99984, IOSTAT = IOST) ICL(1:80)
          IGBL(45) = -1
          CALL GEN108 (LU3, 0)
        END IF
        GO TO 200
      END IF
C * TREAT END-CARD AS END-OF-FILE FOR SHELX-INPUT ON LU1
C * BUT IGNORE WHEN Q-PEAKS ARE REQUESTED
      IF (IGBL(5) == LU1 .AND. IABS (IGBL(8)) == 2) THEN
        IF (IGBL(95) == 0) THEN
          IGBL(5) = LU3
          CALL GEN108 (LU3, 0)
        END IF
        GO TO 10
      END IF
      IF (IPR(3) /= 0) THEN
C * GIVE SUMMARY
        IPR(1) = 3
        GO TO 210
      END IF
C * GOTO HANDLING
  200 IF (IGBL(138) == 0) THEN
        IPR(1) = 1
      ELSE
        IPR(1) = 8
      END IF
      IPR(121) = 0
  210 SELECT CASE (IPR(1))
C * 1 - ERROR HANDLING
        CASE (1)
          IF (IPR(2) == 0) IPR(2) = -1
          IGBL(1) = 3
          RETURN
C * 2 - SET UP CONNECTED SET ETC. (INCLUDING VOID MAP)
        CASE (2)
          CALL PLA067
          IF (IPR(2) /= 0) RETURN
C * PRINT COORDINATES
          CALL PLA073 (-1, 1)
C * ERROR TEST
          IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
            IGBL(1) = 3
            RETURN
          END IF
C * CHECK BONDS ETC IN CIF
          IF (IABS (IGBL(8)) == 3 .AND. IPR(14) /= 4) CALL PLA272
          GO TO 220
C * 3 - GIVE SUMMARY
        CASE (3)
          IPR(2)  = -1
          IGBL(5) = LU1
          IGBL(8) = IABS (IGBL(8))
C * ERROR HANDLING
          IGBL(1) = 3
          RETURN
C * 5 - EXECUTE PLOT & TABLE OPTION(S)
        CASE (5)
          IF (IPR(14) < 0) THEN
C * NEWMAN, RING, PLAN, LSPL, RESD PLOT
            CALL GEN108 (LU8, 0)
            CALL PLA111
          ELSE IF (IPR(14) == 4) THEN
C * DISPLACEMENT MOTION ELLIPSOID-PLOT
            IF (IPR(85) == 0) THEN
              IPR(5) = 0
              CALL PLA024
            END IF
C * TEST FOR RESIDUE NR OUT OF RANGE
            IF (IPR(140) > IPR(75)) THEN
              IPR(2)  = 13
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
            END IF
C * SWITCH TO LSPL CALC
            IF (IPR(460) < 3) THEN
              IGBL(6)  = 9
              LMOD     = 1
              IFL(1)   = 'LSPL'
              CALL PLA015 (476, 1)
              IPR(453) = 0
              IPR(448) = 0
            END IF
C * SWITCH TO ANGLE BETWEEN LINES
            IF (IPR(341) == 5) THEN
              IGBL(6) = 9
            END IF
C * SWITCH TO DIHEDRAL PLANE CALC
            IF (IPR(551) < 3) THEN
              IGBL(6)  = 9
              LMOD     = 1
              IFL(1)   = 'LSPL'
              IPR(551) = 1
              CALL PLA015 (552, 1)
              IPR(453) = 0
              IPR(448) = 0
            END IF
C * CALL ORTEP
            CALL PLA106
            IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
              IGBL(1) = 3
            END IF
C * POLY PLOT
          ELSE IF (IPR(14) == 5) THEN
            MNH(6) = 1
            CALL PLA101
C * PLUTON PLOT
          ELSE IF (IPR(14) == 6) THEN
C * TEST FOR PLA024 'DONE'
            IF (IPR(85) == 0) THEN
              IPR(5) = 0
              CALL PLA024
            END IF
            IF (IGBL(3) /= 13 .AND. IGBL(3) /= 26) THEN
              CALL PLUTON (1)
C * MANAGE LU1
              IGBL(1) = 0
            ELSE
C * EXPLICIT PLUTON
C * HFIX IGBL(3) = 13
C * ANIS IGBL(3) = 26
              CALL PLUTON (-1)
C * TERMINATE JOB
              IGBL(1) = 4
            END IF
            RETURN
          END IF
C * TABL OPTIONS
          IF (IPR(430) > 0) THEN
            IPR(31)  = -1
            IPR(17)  = -1
            IPR(90)  =  1
            IGBL(63) =  0
C * SET UP CONNECTED SET
            CALL PLA067
            IF (IPR(2) == 0) THEN
              CALL PLA171
              IPR(1) = 1
              IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
              IGBL(1) = 3
            END IF
          END IF
          RETURN
C * 6 - CALLS TO PLUTON ETC.
        CASE (6)
          GO TO 220
C * 7 - LIST ON DISPLAY OPTION(S)
        CASE (7)
          CALL PLA021 (11, NRETURN)
          RETURN
C * 8 - SHELXT - XTPLOT
        CASE (8)
C * HANDLE XTPLOT
          CALL PLA205
          RETURN
        CASE DEFAULT
C * ERROR HANDLING
          IGBL(1) = 3
          RETURN
      END SELECT
C * CALC INTRA MODE
  220 IF (IPR(31) == 0) THEN
        CALL PLA021 (0, NRETURN)
        IF (NRETURN == 0) RETURN
C * CALC INTER, VOID, SQUEEZE, NEWSYM AND COORDINATION MODE
      ELSE
        CALL PLA021 (1, NRETURN)
        IF (NRETURN == 0) RETURN
      END IF
      IPR(1) = 5
      GO TO 210
      RETURN
99999 FORMAT (/, ':: Escape EXIT from PLATON - ', I4, ' Pages',
     1 ' on FILES ', A, '.lis', /)
99998 FORMAT (/,'SHELXT not Accessible !!', /)
99997 FORMAT (/, ' >> CIF-Validation-Check Result on ', A)
99996 FORMAT ('ANGLE (', 3I3, ') (', 3I3, ') =', F10.2, ' Deg.')
99995 FORMAT ('ERROR IN RECORD: ', 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 (/, ':: ', 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 =', F6.3, /)
99984 FORMAT (A)
99983 FORMAT (':: AUTO EXEC: Calc Intra',/)
99982 FORMAT (/, ':: Automatic JOIN Instruction (in PLATON section)')
99981 FORMAT (':: ', A)
99980 FORMAT (/, ':: Determinant TM = ', F10.5)
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 (/, ':: No CELA & CELB Data given for STRAIN Analysis')
99970 FORMAT (':: SPGR P1 Substituted', /)
99969 FORMAT (':: Coord. Cell:', 3F10.3, 3F10.2, /,
     1        ':: Refln. Cell:', 3F10.3, 3F10.2, /)
99968 FORMAT (':: SHELXL HKLF Matrix:', 9F6.2, /)
99967 FORMAT (//, '>> RESTART <<')
99966 FORMAT (/, 'W: No SU''s on parameters supplied on input', /)
99965 FORMAT (/, ':: Volume From ORMA =', F10.1, ', Please Check')
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 (/, '** NO ATOM LIST SORTING WITH ALIASED LABELS **', /)
      END SUBROUTINE PLA002
 
      SUBROUTINE PLA003
C * ERROR REPORT AND HANDLING
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE mentry
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: LU
      INTEGER          :: IUCR
      INTEGER          :: NPAGE
      INTEGER          :: NLINE
      CHARACTER(len=2) :: DTP
      IGBL(1) = 4
C * CHECK FOR PRINTER LEVEL
      IF (IGBL(63) > 0) THEN
        LU = LU7
        CALL PLA262 (1)
      ELSE
        LU = LU6
      END IF
C * IPR(2) =  0 (NO ERROR)
C * IPR(2) >  0 ERROR NUMBER
C * IPR(2) = -1
C * IPR(2) < -1 : Terminate but do not delete specified file
C * ERROR
   10 IF (IPR(2) > 0) THEN
        SELECT CASE (IPR(2))
C * 1: ATTEMPT TO EXCEED MAX ATOM LIMIT
          CASE (1)
            WRITE (LU, 99984, IOSTAT = IOST) NP1
C * ALERT _807
            CALL PLA236 (807, 0, 1.0, 1.0, ' ', ' ')
            IF (IGBL(3) == 1) THEN
              IF (IGBL(36) /= 0) CALL PLA230 (0)
            END IF
            IGBL(1) = 4
            RETURN
C * 2: LABEL PREOCCURRED
          CASE (2)
            WRITE (LU, 99977, IOSTAT = IOST) NQ1
C * 3: UNSUITABLE ATOM LABEL
          CASE (3)
            WRITE (LU, 99978, IOSTAT = IOST) NQ0
C * ALERT _071
            CALL PLA236 (71, 0, 1.0, 1.0, NQ1, NQ1)
            IF (IGBL(3) == 1) THEN
C * TEST FOR CHECK MODE
              IF (IGBL(36) /= 0) THEN
                CALL PLA230 (0)
                IGBL(1) = 1
              END IF
              GO TO 70
            ELSE
              GO TO 30
            END IF
C * 4: LABEL INCONSISTENT
          CASE (4)
            WRITE (LU, 99983, IOSTAT = IOST) IFL(2), NQ4
C * 5: NOT ENOUGH DATA ON CARD
          CASE (5)
            IF (LU == LU6) THEN
              WRITE (LU, 99982, IOSTAT = IOST) ICL(1:76)
              CALL PLA015 (0, 49)
              IF (IPR(470) == 1) WRITE (LU, 99961, IOSTAT = IOST)
            END IF
C * 6: INVALID ELEMENT SYMBOL
          CASE (6)
            WRITE (LU, 99981, IOSTAT = IOST) NQ1(1:3)
C * 7: UNKNOWN CARD ERROR
          CASE (7)
            IF (LU == LU6) WRITE (LU, 99992, IOSTAT = IOST) ICL(1:30)
C * 8: TOO MANY ATOMS SPECIFIED
          CASE (8)
            WRITE (LU, 99976, IOSTAT = IOST) NP1
C * 9: FVAR ERROR (SHELX INPUT STYLE)
          CASE (9)
            WRITE (LU, 99975, IOSTAT = IOST)
            GO TO 30
C * 10: POPULATION PARAMETER OVERFLOW
          CASE (10)
            IF (IGBL(36) /= 0) THEN
C * _815 ALERT
              CALL PLA236 (815, 0,    1.0, 1.0, ' ', ' ')
C * TEST FOR CHECK MODE
              CALL PLA230 (0)
              IGBL(1) = 4
              GO TO 70
            ELSE
              WRITE (LU6, 99974, IOSTAT = IOST)
              GO TO 30
            END IF
C * 11: INSTRUCTION NOT ALLOWED
          CASE (11)
            WRITE (LU, 99972, IOSTAT = IOST) IFL(1)
C * 12: PLOT INSTRUCTION NOT ALLOWED HERE
          CASE (12)
            IF (LU == LU6) WRITE (LU, 99970, IOSTAT = IOST)
C * 13: SPECIFIED RESIDUE NUMBER NOT PRESENT
          CASE (13)
            IF (LU == LU6) WRITE (LU, 99960, IOSTAT = IOST) IPR(140)
C * 14:
          CASE (14)
C * 15: TRNS (FIX) INSTRUCTION N.O.K.
          CASE (15)
            IF (LU == LU6) WRITE (LU, 99957, IOSTAT = IOST)
C * 16: INVALID ELEMENT SYMBOL
          CASE (16)
            WRITE (LU, 99981, IOSTAT = IOST) NQ3(1:3)
C * 17: TRANSLATION CODE OUT-OF-RANGE
          CASE (17)
            WRITE (LU, 99947, IOSTAT = IOST) (ITR(I), I = 1, 3), NQ1
            GO TO 30
C * 18: INVALID SUB-KEYWORD or ATOM NAME/TYPE
          CASE (18)
            IF (LU == LU6) WRITE (LU, 99949, IOSTAT = IOST)
C * 19: VOID ARRAY OVERFLOW
          CASE (19)
            IF (LU == LU6) WRITE (LU, 99946, IOSTAT = IOST) NVDR
C * 20: Input and Output Files with the same <name.res>
          CASE (20)
            IF (LU == LU6) WRITE (LU, 99944, IOSTAT = IOST)
            GO TO 20
C * 21:
          CASE (21)
C * 22: NOT ENOUGH OVERLAP MEMORY
          CASE (22)
             IF (LU == LU6) WRITE (LU, 99943, IOSTAT = IOST)
C * 23: TOO MANY AXES (ADDSYM) CONDITION
          CASE (23)
            WRITE (LU, 99942, IOSTAT = IOST) PAR(43)
C * 24: TOO MANY SOLVENT AREAS
          CASE (24)
            WRITE (LU, 99940, IOSTAT = IOST)
C * 25: LMX/PLA091 ERROR
          CASE (25)
            WRITE (LU, 99939, IOSTAT = IOST)
            GO TO 30
C * 26: OVERFLOW IN VOID-ROUTINE (NP1)
          CASE (26)
            WRITE (LU, 99938, IOSTAT = IOST)
C * 27: SYMM/TRNS ERROR
          CASE (27)
            WRITE (LU, 99937, IOSTAT = IOST)
C * 28: ARU-OUT OFF RANGE
          CASE (28)
            IPR(600) = IPR(600) + 1
            IF (IGBL(3) == 1) THEN
              IF (IGBL(36) /= 0) CALL PLA230 (0)
              IF (IGBL(3) == 36) THEN
                IGBL(1) = 4
              END IF
              RETURN
            ELSE
              IF (IPR(600) < 10) WRITE (LU, 99935, IOSTAT = IOST)
            END IF
C * 29: TMA-CALCULATION OUT-OF-SEQUENCE
          CASE (29)
            WRITE (LU, 99934, IOSTAT = IOST)
C * 30: TOO MANY FVAR-PARAMETERS
          CASE (30)
            WRITE (LU, 99932, IOSTAT = IOST)
            GO TO 30
C * 31:
          CASE (31)
            WRITE (LU, 99931, IOSTAT = IOST)
C * 32: NON-RECOVERABLE PROBLEM
          CASE (32)
            WRITE (LU, 99929, IOSTAT = IOST) IPR(323)
            IF (LU /= LU6) WRITE (LU6, 99929, IOSTAT = IOST) IPR(323)
            GO TO 70
C * 33: CALC SOLV/VOID NOT ALLOWED IN ANGSTROM MODE
          CASE (33)
            WRITE (LU, 99928, IOSTAT = IOST)
C * 34: FACE DIST < 0
          CASE (34)
            WRITE (LU, 99923, IOSTAT = IOST)
C * 35: NO MU-PROVIDED FOR ABSGAUSS or ABSTOMPA
          CASE (35)
            WRITE (LU, 99921, IOSTAT = IOST)
            GO TO 30
C * 36: UNKNOWN ELEMENT TYPE ON SFAC LINE
          CASE (36)
            WRITE (LU, 99920, IOSTAT = IOST)
            GO TO 30
C * 37: NO VALID DIRCOS
          CASE (37)
            WRITE (LU, 99916, IOSTAT = IOST)
            GO TO 30
C * 38: NO VALID PSI-SCAN DATA
         CASE (38)
            WRITE (LU, 99915, IOSTAT = IOST)
            GO TO 30
C * 39: No Refl Supplied
          CASE (39)
            WRITE (LU, 99914, IOSTAT = IOST)
            GO TO 30
C * 40: NO TRMX WITH NEG DET ON HKLF
          CASE (40)
            WRITE (LU, 99913, IOSTAT = IOST)
            GO TO 30
C * 41: UNKNOWN ELEMENT ON SFAC
          CASE (41)
            WRITE (LU, 99912, IOSTAT = IOST)
            GO TO 30
C * 42: NO VALID ATOMS
          CASE (42)
C * ALERT _011
            IF (IGBL(3) == 1) THEN
              CALL PLA236 (11, 0, 1.0, 1.0, ' ', ' ')
              IGBL(36) = 1
              CALL PLA230 (0)
              IGBL(1) = 4
              RETURN
            ELSE
              WRITE (LU, 99911, IOSTAT = IOST)
              GO TO 30
            END IF
C * 43: NO .hkl or .fcf
          CASE (43)
            WRITE (LU, 99910, IOSTAT = IOST)
     1        NAMEFIL(1:KNMFIL), NAMEFIL(1:KNMFIL)
            GO TO 30
C * 44: NO .hkl file given
          CASE (44)
            WRITE (LU, 99909, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
            GO TO 30
C * 45: SOMETHING WRONG WITH U/UIJ
          CASE (45)
            WRITE (LU, 99907, IOSTAT = IOST) IPR(498)
            GO TO 30
C * 46: NO-SFAC PROBLEM
          CASE (46)
            WRITE (LU, 99906, IOSTAT = IOST) NQ1
            GO TO 30
C * 47: NO LAMBDA GIVEN
          CASE (47)
            WRITE (LU, 99904, IOSTAT = IOST) MAX (0.0, PAR(17))
C * 48: VOID TOO-LARGE
          CASE (48)
            WRITE (LU, 99901, IOSTAT = IOST)
C * 49: SCRATCH OVERRUN IN EXOR/FMAP
          CASE (49)
            WRITE (LU, 99900, IOSTAT = IOST) NP1
            GO TO 30
C * 50: INCOMPLETE UIJ(SUIJ) DATA ON CIF
          CASE (50)
            IF (IGBL(3) == 1) THEN
              IGBL(36) = 1
              LINE     = NAMEFIL(1:KNMFIL)//'.chk'
              WRITE (LU6, 99842, IOSTAT = IOST) LINE
C * ALERT _806
              CALL PLA236 (806, 0, 1.0, 1.0, ' ', ' ')
C * TEST FOR CHECK MODE
              IF (IGBL(36) /= 0) THEN
                CALL PLA230 (0)
                IGBL(1) = 1
              END IF
              GO TO 70
            ELSE
              WRITE (6, 99898, IOSTAT = IOST) IFL(2)
              GO TO 30
            END IF
C * 51: INCOMPLETE ATOM DATA ON CIF
          CASE (51)
            WRITE (6, 99896, IOSTAT = IOST) IFL(2)
C * ALERT _805
            CALL PLA236 (805, 0, 1.0, 1.0, ' ', ' ')
            GO TO 20
C * 52:
          CASE (52)
            WRITE (LU, 99895, IOSTAT = IOST)
            GO TO 30
C * 53:
          CASE (53)
            WRITE (LU, 99894, IOSTAT = IOST)
            GO TO 30
C * 54: SYMM-LABEL PACK PROBLEM
          CASE (54)
            WRITE (LU, 99892, IOSTAT = IOST)
C * 55: NO REFLECTION DATA PROBLEM
          CASE (55)
            WRITE (LU, 99891, IOSTAT = IOST)
C * 56: NO DIR-COS
          CASE (56)
            WRITE (6, 99888, IOSTAT = IOST)
            GO TO 20
C * 57: LABEL ALIAS OVERFLOW
          CASE (57)
            WRITE (6, 99885, IOSTAT = IOST)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
            IF (IGBL(61) == 0 .AND. IPR(30) == 0) THEN
              IGBL(61) = 1
C * RESET INPUT
              CALL PLA286 (1)
              CALL GEN108 (LU20, 0)
              IPR(2) = 0
              GO TO 70
            END IF
C * ALERT _071
            CALL PLA236 (71, 0, 1.0, 1.0, NQ1, NQ1)
C * 58: CELL PROBLEM
          CASE (58)
            IF (IGBL(3) == 1) THEN
              IGBL(36) = 1
              LINE     = NAMEFIL(1:KNMFIL)//'.chk'
              WRITE (LU6, 99842, IOSTAT = IOST) LINE
C * ALERT _801
              CALL PLA236 (801, 0, 1.0, 1.0, ' ', ' ')
C * TEST FOR CHECK MODE
              IF (IGBL(36) /= 0) THEN
                CALL PLA230 (0)
                IGBL(1) = 1
              END IF
            ELSE
C * CELL PROBLEM
              WRITE (6, 99848, IOSTAT = IOST)
            END IF
            GO TO 70
C * 59: CIF-LINE TOO LONG
          CASE (59)
            IF (IGBL(3) == 1) THEN
              IPR(544) = IPR(544) + 1
C * TEST FOR CHECK MODE
              IF (IGBL(36) /= 0) THEN
                CALL PLA230 (0)
                IGBL(1) = 1
              END IF
            ELSE
C * CIF-LINE LONGER THAN 2048 CHARACTERS
              WRITE (6, 99847, IOSTAT = IOST)
            END IF
            GO TO 70
C * 60: CIF-LOOP PROBLEM
          CASE (60)
            IF (IGBL(3) == 1) THEN
C * ALERT _803
              CALL PLA236 (803, 0, 1.0, 1.0, ' ', ' ')
C * TEST FOR CHECK MODE
              IF (IGBL(36) /= 0) THEN
                CALL PLA230 (0)
                IGBL(1) = 1
              END IF
            ELSE
C * CIF-LOOP PROBLEM
              WRITE (6, 99846, IOSTAT = IOST)
            END IF
            GO TO 70
C * 61: READ/FORMAT ERROR
          CASE (61)
            WRITE (6, 99853, IOSTAT = IOST)
            GO TO 20
C * 62: NSP-Problem
          CASE (62)
            WRITE (LU6, 99852, IOSTAT = IOST)
            GO TO 30
C * 63: TRNS/TRMX PROBLEM
          CASE (63)
            WRITE (LU6, 99850, IOSTAT = IOST)
            GO TO 20
C * 64: DATA FORMAT NOT VALID/RECOGNISED
          CASE (64)
            WRITE (LU6, 99849, IOSTAT = IOST)
            IPR(2) = 0
C * 65: HKLF4 Required
          CASE (65)
            WRITE (LU, 99843, IOSTAT = IOST)
C * 66: Obverse Setting Only
          CASE (66)
            GO TO 20
C * 67: Too many ALIASES
          CASE (67)
            WRITE (LU6, 99841, IOSTAT = IOST) NP36
            IF (IGBL(3) == 1) THEN
C * ALERT _812
              CALL PLA236 (812, 0, 1.0, FLOAT (NP36), ' ', ' ')
              IF (IGBL(36) /= 0) CALL PLA230 (0)
            END IF
            IGBL(1) = 4
            RETURN
C * 68: Unsuitable file type combination for SQUEEZE
          CASE (68)
            WRITE (LU6, 99840, IOSTAT = IOST) IGBL(29), IPR(619)
            IF (IPR(619) == 1) WRITE (LU6, 99839, IOSTAT = IOST)
            WRITE (LU6, 99838, IOSTAT = IOST)
            IGBL(1) = 5
            RETURN
C * 69: No Matching Reflection Data Entry found
          CASE (69)
            WRITE (LU6, 99833, IOSTAT = IOST) JID(1:8)
            GO TO 20
C * 70: No Numerical data on HKLF record
          CASE (70)
            IF (IGBL(3) == 1) THEN
C * _813 ALERT
              CALL PLA236 (813, 0, -999.0, 1.0, ' ', ' ')
C * TEST FOR CHECK MODE
              IF (IGBL(36) /= 0) THEN
                CALL PLA230 (0)
                IGBL(1) = 1
              END IF
              GO TO 70
            ELSE
              WRITE (LU6, 99832, IOSTAT = IOST)
              GO TO 30
            END IF
C * 71: Unsuitable file type combination for HYBRID
          CASE (71)
            WRITE (LU6, 99837, IOSTAT = IOST)
            IGBL(1) = 4
            RETURN
C * 72: Unsuitable file type: RES file (.ins or ,res) needed
          CASE (72)
            WRITE (LU6, 99836, IOSTAT = IOST)
            GO TO 20
C * 73: Determinant of the transformation matrix = 0.0
          CASE (73)
            WRITE (LU6, 99835, IOSTAT = IOST)
            GO TO 20
C * 74: General PROBLEM STOP
          CASE (74)
            GO TO 20
C * 75: NO SQUEEZE with EXTI based CIF/FCF
          CASE (75)
            WRITE (LU6, 99834)
            IGBL(1) = 4
            RETURN
C * 76: Inconsistent CIF/FCF
          CASE (76)
            WRITE (LU6, 99936)
            IGBL(1) = 4
            RETURN
        END SELECT
C * NON-FATAL ERROR
        IF (LU == LU7) GO TO 50
        IPR(2) = 0
        CALL GEN038 (IGGT, 1, 80)
        IGBL(6)  = 10
        IGBL(24) = 1
        IF (LU == LU6) WRITE (LU, 99980, IOSTAT = IOST) CHAR (IPR(223))
        GO TO 40
C * FATAL ERROR (EXECUTE EXIT STATEMENT)
   20   FNLU1 = NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT)
        KNMXT = KNMFIL + KXT + 1
        WRITE (6, 99897, IOSTAT = IOST) FNLU1(1:KNMXT)
C * CALL EXIT/STOP
        CALL GEN127 (' ')
C * FATAL ERROR (EXECUTE END STATEMENT)
   30   IF (LU == LU7) GO TO 50
        IPR(2) = 0
        WRITE (LU, 99979, IOSTAT = IOST)
        IF (IGBL(54) < IGBL(100)) THEN
          IGBL(54) = IGBL(54) + 1
          FN(1)    = IGBL(54)
          IPR(220) = 1
          IPR(221) = 1
          CALL PLA007
          IGBL(5)  = LU5
          IGBL(1)  = 1
          IPR(121) = 0
          GO TO 70
        END IF
      END IF
C * TERMINATE ?
   40 IF (IPR(2) /= 0) THEN
        IF (LU == LU7 .OR. IGBL(63) == 0) THEN
C * TEST FOR CHECK-MODE
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
          IUCR = IABS(IGBL(8) * IPR(30))
          IF (IUCR == 3 .OR. IUCR == 4) THEN
            IF (IGBL(36) /= 0 .AND. IPR(734) == 0) CALL PLA230 (0)
          END IF
        END IF
C * TEST FOR NON-ANGSTROM DATA
        IF (IPR(23) == 0) THEN
          PAGET = 'SUMMARY '
          IF (LU == LU7 .AND. IGBL(63) > 3 .AND.
     1        IGBL(7) > 0) THEN
            IF (IPR(2) <= 0 .AND. IPR(3) <= 0) THEN
C * CHECK FOR CIF-DATA
              IF (IABS(IGBL(8)) == 3 .AND. PAR(160) /= 0.0)
     1          CALL PLA172 (0, 1, 1)
              CALL PLA262 (0)
              WRITE (LU, 99962, IOSTAT = IOST) HTTPSERVER
            END IF
          END IF
        END IF
        IF (IPR(3) >= 0 .AND. IPR(37) > 0) THEN
          IF (LU == LU7) THEN
            CALL PLA262 (0)
            CALL PLA262 (-999)
          END IF
          WRITE (LU, 99991, IOSTAT = IOST)
C * FRACTIONAL COORDINATES CASE WARNINGS AND NOTES
          IF (IPR(23) == 0) THEN
            IF (PAR(17)  < 0.001)    WRITE (LU, 99999, IOSTAT = IOST)
            IF (PAR(107) < 0.00001)  WRITE (LU, 99998, IOSTAT = IOST)
            IF (IGBL(30) == 1)       WRITE (LU, 99997, IOSTAT = IOST)
            IF (IGBL(52) == 1)       WRITE (LU, 99996, IOSTAT = IOST)
          END IF
C * MODIFIED RESIDUE-PACKING WARNING
          IF (IPR(129) < 10) WRITE (LU, 99948, IOSTAT = IOST)
C * EXTRA SYMMETRY NOTE
          IF (IPR(209) /= 0)  WRITE (LU, 99951, IOSTAT = IOST)
C * SPECIAL INVERSION SYMMETRY NOTE
          IF (IPR(118) /= 0) WRITE (LU, 99925, IOSTAT = IOST)
C * ADDITIONAL TRANSLATION
          IF (IPR(459) /= 0) WRITE (LU, 99903, IOSTAT = IOST)
C * WARNING NO E.S.D. PARAMETERS
          IF (IPR(72)  == 0) WRITE (LU, 99956, IOSTAT = IOST)
          IF (IPR(130) == 1) WRITE (LU, 99995, IOSTAT = IOST)
          IF (IPR(124) /= 0) WRITE (LU, 99886, IOSTAT = IOST)
          IF (IGBL(8)  == 2) WRITE (LU, 99973, IOSTAT = IOST)
C * NO EXPLICIT SPACE GROUP SPECIFIED
          IF (IPR(23) == 0 .AND. IPR(202) == 0)
     1      WRITE (LU, 99950, IOSTAT = IOST)
C * REDUCED NUMBER OF ALLOWED RESIDUES (CUBIC SYMMETRY)
          IF (PAR(42) < 100.0) WRITE (LU, 99927, IOSTAT = IOST)
C * DISORDERED WARNING
          IF (IPR(44) == 1) WRITE (LU, 99988, IOSTAT = IOST)
C * WARNING NON-INTEGRAL ATOM NUMBER IN UNITCELL
          IF (IPR(215) > 0) WRITE (LU, 99952, IOSTAT = IOST)
C * NO HYDROGEN ATOMS IN STRUCTURE (CRYSTAL)
          IF (IPR(23) == 0 .AND. IPR(484) == 0)
     1      WRITE (LU, 99933, IOSTAT = IOST)
C * WARNING FOR ISOLATED H-ATOMS
          IF (IPR(153) > 0) WRITE (LU, 99959, IOSTAT = IOST) IPR(153)
C * WARNING FOR ISOLATED O-ATOMS
          IF (IPR(161) > 0) WRITE (LU, 99889, IOSTAT = IOST) IPR(161)
C * WARNING SHORT INTRA/INTER CONTACTS
          IF (IPR(160) > 0) WRITE (LU, 99958, IOSTAT = IOST)
     1     IPR(160), PAR(199), PAR(200)
C * WARNING SHORT INTRA/INTER CONTACTS (H-H)
          IF (IPR(403) > 0) WRITE (LU, 99924, IOSTAT = IOST)
     1      IPR(403), PAR(251), PAR(252)
          IF (IPR(404) > 0) WRITE (LU, 99918, IOSTAT = IOST)
     1      IPR(404), PAR(253), PAR(254)
C * NUMBER OF ISOTROPIC NON-H ATOMS
          IF (IPR(489) + IPR(490) > 0) THEN
            WRITE (LU, 99930, IOSTAT = IOST) IPR(489) + IPR(490)
          END IF
          IF (IPR(50)  > 0) WRITE (LU, 99966, IOSTAT = IOST) IPR(50)
          IF (IPR(204) > 0) WRITE (LU, 99965, IOSTAT = IOST) IPR(204)
          IF (IPR(498) > 0) WRITE (LU, 99907, IOSTAT = IOST) IPR(498)
          IF (PAR(387) < 1.0) WRITE (LU, 99887, IOSTAT = IOST)
     1      PAR(387)
          IF (IPR(93)  == 1) WRITE (LU, 99990, IOSTAT = IOST)
     1      ((TM1(I, J), J = 1, 3), I = 1, 3)
          IF (IPR(139) == 1) WRITE (LU, 99968, IOSTAT = IOST)
     1      (SHFT(I), I = 1, 3)
          IF (IPR(100) > 0) WRITE (LU, 99989, IOSTAT = IOST) IPR(100)
          IF (IPR(101) > 0) WRITE (LU, 99987, IOSTAT = IOST) IPR(101)
          IF (IPR(171) > 0) WRITE (LU, 99963, IOSTAT = IOST)
     1      PAR(30), IPR(171)
          IF (IPR(172) > 0) WRITE (LU, 99945, IOSTAT = IOST)
     1      PAR(30), IPR(172)
          IF (IPR(102) > 0) WRITE (LU, 99986, IOSTAT = IOST) IPR(102)
          IF (IPR(103) > 0) WRITE (LU, 99985, IOSTAT = IOST) IPR(103)
          IF (IPR(401) > 0) WRITE (LU, 99922, IOSTAT = IOST) IPR(401)
          IF (IPR(402) > 0) WRITE (LU, 99919, IOSTAT = IOST) IPR(402)
          IF (IPR(471) /= 0) WRITE (LU, 99993, IOSTAT = IOST)
     1      IPR(471), IPR(472)
C * REPORT # ALIASES (WHEN > 0)
          IF (IPR(759) > 0) WRITE (LU, 99994, IOSTAT = IOST) IPR(759)
          IF (IPR(135) > 0) WRITE (LU, 99971, IOSTAT = IOST) IPR(135)
          IF (IPR(138) > 0) WRITE (LU, 99969, IOSTAT = IOST) IPR(138)
          IF (PAR(150) > 0) WRITE (LU, 99941, IOSTAT = IOST)
     1      NINT(PAR(150))
          IF (PAR(354) > 0) WRITE (LU, 99926, IOSTAT = IOST)
     1      NINT(PAR(354))
          IF (IPR(126) > 0) WRITE (LU, 99899, IOSTAT = IOST) IPR(126)
          IF (IPR(429) > 0) WRITE (LU, 99893, IOSTAT = IOST) IPR(429)
C * NUMBER of NON_HBONDED D-H
          IF (IPR(405) > 0) WRITE (LU, 99917, IOSTAT = IOST) IPR(405)
C * OVERFLOW IN INTER MODE
          IF (IPR(149) > 0) WRITE (LU, 99967, IOSTAT = IOST) IPR(149)
C * INTER ARU-Problem
          IF (IPR(494) > 0) WRITE (LU, 99902, IOSTAT = IOST) IPR(494)
          WRITE (LU, 99953, IOSTAT = IOST)
        END IF
C * TEST FOR PRINT LEVEL AND OPEN LU7
        IF (IGBL(63) > 0 .AND. IGBL(7) > 0) THEN
C * CHECK FOR SHELXL201x RES
          IF (IPR(663) /= 0) THEN
            DTP = '14'
          ELSE
            DTP = '  '
          ENDIF
          FNLU1 = NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT)
          KNMXT = KNMFIL + KXT + 1
          IF (FNLU1(1:5) /= 'zz123' .AND. IGBL(8) /= 0) THEN
            WRITE (LU, 99905, IOSTAT = IOST) FNLU1(1:KNMXT),
     1        DTYPE(IABS (IGBL(8)))(1:3)//DTP
            IF (IGBL(9) > 0 .AND. IGBL(9) < 28) THEN
              IF (LU == LU7) CALL PLA262 (2)
              WRITE (LU, 99845, IOSTAT = IOST) FNLU16(1:KNM16),
     1          RDTYP(IGBL(9))
            END IF
          END IF
C * OPEN FILES FOR .ins & .res from .cif & .fcf
C * CHECK FOR 'special .res' and 'xtplot'
          IF (IGBL(131) == 1 .AND. IGBL(138) == 0) THEN
              WRITE (LU, 99844, IOSTAT = IOST)
     1          NAMEFIL(1:KNMFIL)//'_sx.ins',
     1                          NAMEFIL(1:KNMFIL)//'_sx.hkl'
          END IF
          NPAGE = IGBL(49)
          IF (IGBL(7) == 1) THEN
            LINE = NAMEFIL(1:KNMFIL)
            NLINE = KNMFIL
          ELSE IF (IGBL(7) == 2) THEN
            LINE = NAMEFIL(1:KNMFIL)//'_sq'
            NLINE = KNMFIL + 3
          END IF
          IF (IPR(2) < 0) THEN
C * RESET VIEW
            IGBL(67) = 0
            IF (IGBL(70) == 1) THEN
              IF (IGBL(116) /= 0 .AND. IGBL(130) /= 0) THEN
                WRITE (LU, 99955, IOSTAT = IOST) NPAGE, LINE(1:NLINE),
     1            LINE(1:NLINE), LINE(1:NLINE)
              ELSE
                WRITE (LU, 99955, IOSTAT = IOST) NPAGE, LINE(1:NLINE),
     1            LINE(1:NLINE)
              END IF
            ELSE
              WRITE (LU, 99855, IOSTAT = IOST) NPAGE, LINE(1:NLINE)
            END IF
          ELSE
            WRITE (LU, 99954, IOSTAT = IOST) NPAGE, LINE(1:NLINE),
     1        LINE(1:NLINE)
          END IF
        END IF
        IGBL(8) = IABS (IGBL(8))
      END IF
C * SWITCH FROM  LIST-FILE TO ASCII WINDOW
   50 IF (LU == LU7) THEN
        LU = LU6
        GO TO 10
      END IF
C * TEST ERROR-FLAG (IPR(2))
      IF (IPR(1) == 1 .OR.
     1    IPR(1) == 2 .OR.
     2    IPR(1) == 4 .OR.
     3    IPR(1) == 5 .OR.
     4    IPR(1) == 6 .OR.
     5    IPR(1) == 7) THEN
        IF (IPR(2) == 0) IGBL(1) = 1
      ELSE IF (IPR(1) == 3 .AND. IGBL(8) /= 2) THEN
        READ (LU1, 99964, IOSTAT = IOST) ICL(1:80)
        IF (IOST == 0) THEN
          BACKSPACE LU1
          IGBL(1) = 1
        END IF
      END IF
C * ERROR RECOVERY FOR AUTO SEQUENCE
      IF (IPR(3) == 1) THEN
        IGBL(5) = LU1
        IGBL(1) = 1
      END IF
C * TEST FOR KPI MODE
   70 IF (IGBL(3)  ==  36) IGBL(1) = 4
      IF (IPR(2)   == -11) IGBL(1) = 4
C * HANDLE SQUEEZE CASE
      IF (IGBL(31) ==  10) 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.', /, ':: >>> WARNING:',
     1 ' ''CONNECTED INPUT SET'' is assumed to be TRUE', /,
     2 ':: >>> The Network Analysis may be INCORRECT when this',
     3 '  assumption is 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 (/, 80('='), /,
     1 'Summary and Remarks : N = NOTE, W = WARNING, E = ERROR',
     2 /, 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: SHELXL-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 /, 4X, 'according to additive coordinate shift vector: ', /,
     2 20X, 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)
99962 FORMAT (//, 58X, 11('='), /, 57('*'), ' N O T I C E ', 50('*'),
     1 /, 58X, 11('='), //, '- PLATON References : Spek, A.L. (2003). ',
     2 'J. Appl. Cryst. 36, 7-13.', /, 22X, 'Spek, A.L. (2009). ',
     3 'Acta Cryst. D65, 148-155.', /, 22X, 'Spek, A.L. (2015). ',
     4 'Acta Cryst. C71, 9-18.', /, 22X, 'Spek, A.L. (2018). ',
     5 'Inorg. Chim. Acta, 470, 232-237.', /, 22X, 'Spek, A.L. (2020).',
     6 ' Acta Cryst. E76, 1-11.', //, '- Output Values (Esd) may ',
     7 'have been (re)set to 99, 999 or 9999 to Avoid Format Overflow.',
     8 //, '- Derived Parameter SU''s (= Esd''s) may be Incorrect in',
     9 ' Cases where Covariances in the Atom Parameters should have',
     * ' been taken', /, '  into Account (e.g. Those Involving Atoms',
     1 ' That were Refined with Constraints).', //, '- ROUNDING, in',
     2 ' particular of the Input Coordinate Data, may give deviating',
     3 ' values for derived geometry parameters.', /, '  However,',
     4 ' differences should be within the associated esd-range.', //,
     5 '- PLATON is Research Program. The Implementation of',
     6 ' Additional Options is Planned. Some of the More Advanced', /,
     7 2X, 'Features are Experimental and may Contain Loose Ends.',//,
     8 '- The Communication of Glitches Encountered will be',
     9 ' Appreciated: E-mail: a.l.spek@uu.nl', //,
     * '- Recent versions of PLATON may be obtained from',
     1 ' https://www.platonsoft.nl/xraysoft', //, '- More INFO',
     2 ' can be found on http://', A, //)
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)', /,
     3        ':: ', A, '.pdf (PDF        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 (':: Sub-keyword 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 NVDR to value > ', I7)
99945 FORMAT ('N: Number of Unspecified     H Displacement ',
     1        'Parameters set to U =', F5.2, 1X, 3('.'), I5)
99944 FORMAT ('!! Error: Input and Output with the same <name.res>')
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            ' (SOLV-Map Value) ', 3('.'), I6, ' 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')
99936 FORMAT (':: Inconsistent CIF/FCF Data - (ABORT)')
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 Voids / Cell =', I7)
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 Xtal Data from File ', A, ' - Data Type ',
     1        A, /)
99904 FORMAT (':: No proper wavelength (Ag,Mo,Ga,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 PLA153 (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 PLA270', /)
99894 FORMAT (/ )
99893 FORMAT ('N: Number of Unrecognized (CIF) Keywords ', 33('.'), I5)
99892 FORMAT ('E: SYMM-LABEL PACK PROBLEM')
99891 FORMAT ('E: No Reflection Data Available')
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', /)
99853 FORMAT (//, 'E: READ ERROR - FATAL', /)
99852 FORMAT ('E: NSP-Problem in PLA024: Nr species too large')
99850 FORMAT ('W: Incorrect Number of Numerical Arguments on TRNS/TRMX')
99849 FORMAT (/, 'E: Check Data Type (cif,ins,res,spf,pdb,fcf)',
     1       ' of the Input (TITL missing?)')
99848 FORMAT (/, ':: CELL PROBLEM')
99847 FORMAT (/, 'CIF-LINE LONGER THAN 2048 CHARACTERS')
99846 FORMAT (/, 'CIF-LOOP PROBLEM')
99845 FORMAT (':: Input Refl Data from File ', A, ' - Data Type ', A, /)
99844 FORMAT (':: SHELXL.INS (From CIF data) on: ', A, /,
     1        ':: SHELXL.HKL (From FCF data) on: ', A, /)
99843 FORMAT (/, ':: HKLF 4 Style Reflection File Needed', /)
99842 FORMAT (/, ' >> CIF-Validation-Check Result on ', A)
99841 FORMAT (/, ' >> More than', I5, ' Aliases. Aborted')
99840 FORMAT (/, '*** Unsuitable File (Type) Combination Supplied for ',
     1        'a SQUEEZE Calculation ***', /, 4X,
     2        '[IGBL(29) =', I2, ', IPR(619) =', I2, ']', /)
99839 FORMAT (/, '*** A LIST 8 TYPE FCF is Needed for TWINNED',
     1        ' Structures ****', /)
99838 FORMAT (/, 'Valid File Combinations: ', /,
     1        '(Note: The CIF & FCF should be SHELXL Standard  with ',
     2        'Embedded .res & .hkl)', /,
     3        '1 -  SHELXL20nm CIF + FCF (SHELXL LIST 4)', /,
     4        '2 -  SHELXL20nm CIF + FCF (SHELXL LIST 8) (TWINNING)', /,
     5        '3 -  SHELXL INS/RES + SHELXL HKL', /,
     6        '4 -  SHELXL INS/RES + SHELXL FCF (SHELXL LIST 4)', /)
99837 FORMAT (/, '** Unsuitable File Type combination for SQUEEZE',/,
     1        '** HYBRID Requires .ins/.res + .hkl or',
     2        ' SHELXL201n .cif file(s) as input')
99836 FORMAT (/, ':: RES File (.ins or .res) INPUT only !')
99835 FORMAT (/, ':: Determinant for transformation = 0.0', /)
99834 FORMAT (/, ':: SQUEEZE job ABORTED: CIF based on EXTI refinement',
     1        /, '   Please re-refine without EXTI for proper .fcf', /)
99833 FORMAT (/, ':: No Matching Reflection Data Entry found for ', A)
99832 FORMAT (/, ':: No Numerical Data on HKLF (res) RECORD in CIF')
      END SUBROUTINE PLA003
 
      SUBROUTINE PLA004 (MODE)
C * (FILE) CLOSE/TERMINATE ROUTINE
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cggt
      USE xwdw
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: NB
      INTEGER :: NE
      INTEGER :: LU
      INTEGER :: MODE
      INTEGER :: IEND
      INTEGER :: IYUNK
      INTEGER :: FINDEXE
      CHARACTER(len=6) :: PS
      IF (IWIN == 1) THEN
        PS = '.ps'
      ELSE
        PS = '_sq.ps'
      END IF
C * DISPLAY VALIDATION RESULT
      IF (IGBL(36) * IGBL(66) * IGBL(32) /= 0) CALL PLA235 (0)
C * OUTPUT-FILE TYPE
C *  1 - OMEGA,  3 - SPF, 4 - CSD, 7 - PDB
C * 10 - SQUEEZE
C * -2 - SHELXL
      IF (MODE == 0) THEN
C * STOP AND CLOSE GRAPHICS (IF ANY)
        XGGIP = -999.0
        CALL GGIP (XGGIP, 0.0, 0.0, -5)
C * CLOSE 'ALERT' FILE
        CLOSE (UNIT = LU20, STATUS = 'DELETE', IOSTAT = IOST)
        CLOSE (UNIT = LU68, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
      IF (IGBL(3) == 1 .OR. IGBL(22) /= 0)
     1  CLOSE (UNIT = LU2, STATUS = 'DELETE', IOSTAT = IOST)
      LU   = LU6
      IEND = 1
      IF (IGBL(63) > 0) IEND = 2
      DO I = 1, IEND
        IF (I == 2) LU = LU7
        SELECT CASE (IGBL(31))
C * REPORT OME OUTPUT FILE
          CASE (1)
C * SUP/PUB TABLE TEST
            IF (IPR(430) == 0) THEN
              WRITE (LU, 99997, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
            END IF
C * REPORT (SPF/ELD) OUTPUT FILE
          CASE (3)
C * TEST FOR 'FCF CHECK' AND 'CALC FCF'
            IF (IGBL(129) <= 0 .AND. IPR(210) /= -1) THEN
              IF (IPR(2) /= -11) THEN
                IF (LU /= LU20 .AND. IPR(777) /= 1)
     1            WRITE (LU, 99995, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
                END IF
            END IF
C * REPORT CSD-QUE OUTPUT FILE
          CASE (4)
            IF (LU /= LU7 .AND. LU /= LU20)
     1        WRITE (LU, 99994, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * REPORT SPGR PAR OUTPUT FILE
          CASE (5)
            IF (IPR(2) == 0) WRITE (LU, 99985, IOSTAT = IOST)
     1        NAMEFIL(1:KNMFIL)
C * REPORT SHELXL RES FILE OUTPUT
          CASE (-2, 6)
            CLOSE (LU2, IOSTAT = IOST)
            WRITE (LU, 99988, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * REPORT PDB OUTPUT FILE
          CASE (7)
            WRITE (LU, 99977, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * REPORT SQUEEZE RESULT FILES
          CASE (10)
            IF (IPR(2) <= 0) THEN
              WRITE (LU, 99976, IOSTAT = IOST)
     1          NAMEFIL(1:KNMFIL)//'_sq.ins',
     2          NAMEFIL(1:KNMFIL)//'_sq.hkl',
     3          NAMEFIL(1:KNMFIL)//'_sq.fab',
     4          NAMEFIL(1:KNMFIL)//'_sq.sqf',
     5          NAMEFIL(1:KNMFIL)//'_sq.sqz',
     6          NAMEFIL(1:KNMFIL)//'_sq.lis',
     7          NAMEFIL(1:KNMFIL)//PS
              IF (ABS (IGBL(8)) == 2) THEN
                WRITE (LU, 99975, IOSTAT = IOST)
     1            NAMEFIL(1:KNMFIL), NAMEFIL(1:KNMFIL),
     2            NAMEFIL(1:KNMFIL), NAMEFIL(1:KNMFIL)
              END IF
            END IF
        END SELECT
      END DO
 
C * DELETE ? _sx.ins & _sx.hkl & _sx.fab FROM SHELX20xy CIF
      LU6 = 6
C * .ins CASE
      IF (IPR(663) == -2) THEN
        WRITE (LU6, 99952, IOSTAT = IOST)
     1    NAMEFIL(1:KNMFIL)//'_sx.ins'
      ELSE IF (IPR(663) == -1) THEN
        CLOSE (UNIT = LU24, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
C * .hkl CASE
      IF (IPR(664) == -3) THEN
        WRITE (LU6, 99947, IOSTAT = IOST)
     1    NAMEFIL(1:KNMFIL)//'_sx.hkl'
      ELSE IF (IPR(664) == -2 .OR. IPR(321) /= 0) THEN
C * CHECK FOR IUCr VALIDATION
        IF (IGBL(3) /= 1) THEN
          WRITE (LU6, 99951, IOSTAT = IOST)
     1      NAMEFIL(1:KNMFIL)//'_sx.hkl'
        ELSE
          CLOSE (UNIT = LU25, STATUS = 'DELETE', IOSTAT = IOST)
        END IF
      ELSE IF (IPR(664) == -1) THEN
        CLOSE (UNIT = LU25, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
C * .fab CASE
      IF (IPR(665) == -2) THEN
        WRITE (LU6, 99950, IOSTAT = IOST)
     1    NAMEFIL(1:KNMFIL)//'_sx.fab'
      ELSE IF (IPR(665) == -1) THEN
        CLOSE (UNIT = LU26, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
C * CIF & SUP OUTPUT FILES
      IF (IPR(431) == 1) THEN
        WRITE (LU6, 99992, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      ELSE IF (IPR(431) == -1) THEN
        WRITE (LU6, 99990, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      ENDIF
      CLOSE (UNIT = LU14, STATUS = 'DELETE', IOSTAT = IOST)
C * CHECK SUMMARY FILE
      IF (IGBL(36) > 0) THEN
C * APPEND FCF CREATION LOG TO .ckf file
        INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'_sx.log',
     1    EXIST = EXST)
        IF (EXST) THEN
          WRITE (LU13, 99940)
          OPEN (UNIT = LU60, FILE = NAMEFIL(1:KNMFIL)//
     1      '_sx.log', STATUS = 'UNKNOWN')
          DO
            READ  (LU60, 99953, IOSTAT = IOST) ICL(1:80)
            IF (IOST /= 0) EXIT
            WRITE (LU13, 99953) ICL(1:80)
          END DO
          CLOSE (UNIT = LU60, STATUS = 'DELETE',
     1      IOSTAT = IOST)
        END IF
*
C * APPEND ASYM HKL AVERAGING LISTING TO .ckf file
        INQUIRE (FILE = 'lasym.lis', EXIST = EXST)
        IF (EXST) THEN
          WRITE (LU13, 99939)
          OPEN (UNIT = LU60, FILE = 'lasym.lis',
     1      STATUS = 'UNKNOWN')
          NB = 0
          NE = 0
          DO
            READ  (LU60, 99953, IOSTAT = IOST) ICL(1:132)
            IF (IOST /= 0) EXIT
            IF (ICL(1:1) == CHAR (12)) THEN
              WRITE (LU13, 99938)
              CYCLE
            END IF
            CALL GEN039 (1, ICL, 80, 132, NB, NE)
            WRITE (LU13, 99953) ICL(1:NE)
            IF (ICL(1:7) == 'Average') EXIT
          END DO
          CLOSE (UNIT = LU60, STATUS = 'DELETE',
     1      IOSTAT = IOST)
        END IF
        LU6 = 6
        CALL PLA230 (1)
        WRITE (LU6, 99971, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      ELSE
        CLOSE (UNIT = LU10, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
C * CHECK FCF- SUMMARY FILE
      IF (IGBL(129) /= 0) THEN
        LU6 = 6
        WRITE (LU6, 99962, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      END IF
C * CHECK VRF
      IF (IGBL(141) > 0) THEN
        WRITE (LU66, 99945)
        WRITE (LU6,  99944, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      END IF
C * CHECK PS
      IF (IGBL(66) == 0 .AND. NPLOT > 0 .AND. IGBL(3) == 1) THEN
        WRITE (LINE, 99942, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
        WRITE (LINE(71:80), 99941, IOSTAT = IOST) NPLOT
        WRITE (LU6, 99953, IOSTAT = IOST) LINE
      END IF
C * BIN-FILE
      IF (IGBL(16) == 0)
     1    CLOSE (UNIT = LU19, STATUS = 'DELETE', IOSTAT = IOST)
C * SAV - FILE CLOSE/DELETE
      IF (IPR(326) == -1 .AND. IPR(198) > 0 .AND.
     1    IPR(189) ==  2 .AND. IPR(210) <= 0) THEN
        WRITE (LU6, 99989, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      ELSE
        CLOSE (UNIT = LU15, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
C * HKS/CPI - FILE
      IF (IGBL(18) == 1 .AND. IPR(408) < 1
     1    .AND. IGBL(3) /= 34 .AND. IGBL(3) /= 1 .AND.
     2     IGBL(129) <= 0) THEN
        WRITE (LU6, 99966, IOSTAT = IOST) NAMEFIL(1:KNMFIL), IPR(378)
      ELSE IF (IGBL(18) == 2) THEN
        WRITE (LU6, 99965, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      END IF
C * HKP - FILE
      IF (IPR(210) == -1) THEN
        WRITE (LU6, 99987, IOSTAT = IOST) NAMEFIL(1:KNMFIL),
     1                     NAMEFIL(1:KNMFIL)
C * MULABS
      ELSE IF (IPR(2) == -4) THEN
        WRITE (LU6, 99972, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * ABSSPHERE
      ELSE IF (IPR(2) == -5) THEN
        WRITE (LU6, 99979, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * ABSPSI
      ELSE IF (IPR(2) == -6 .AND. IPR(432) > 0) THEN
        WRITE (LU6, 99980, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * ABSTOMPA
      ELSE IF (IPR(2) == -7 .AND. IPR(432) > 0) THEN
        WRITE (LU6, 99982, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * ABSGAUSS
      ELSE IF (IPR(2) == -8 .AND. IPR(432) > 0) THEN
        WRITE (LU6, 99983, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * SHXABS-HKP
      ELSE IF (IPR(2) == -10) THEN
        WRITE (LU6, 99963, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * HKLF5 - FILE
      ELSE IF (IPR(2) == -11) THEN
        WRITE (LU6, 99943, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
        WRITE (LU6, 99964, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * RP1 - FILE
      ELSE IF (IPR(2) == -12) THEN
        WRITE (LU6, 99961, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
        IF (IPR(373) /= 0) WRITE (LU6, 99960, IOSTAT = IOST)
     1    NAMEFIL(1:KNMFIL)
C * SHELX.BIN
      ELSE IF (IPR(2) == -13 .AND. IPR(525) == 0 .AND.
     1   IPR(409) == 0) THEN
        WRITE (LU6, 99984, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
C * ASYM hkp
      ELSE IF (((IPR(2) == -14 .AND. IPR(408) /= 2) .OR.
     1          IGBL(17) == 1) .AND. IGBL(22) == 0) THEN
        IYUNK = IPR(377)
        IF (IGBL(18) == 0) IYUNK = IYUNK + IPR(378)
        IF (IPR(408) == 1) THEN
          WRITE (LU6, 99946, IOSTAT = IOST) NAMEFIL(1:KNMFIL), IYUNK
        ELSE
          WRITE (LU6, 99981, IOSTAT = IOST) NAMEFIL(1:KNMFIL), IYUNK
        END IF
C * HKLF-TRANS
      ELSE IF (IPR(2) == -15) THEN
        WRITE (LU6, 99970, IOSTAT = IOST) NAMEFIL(1:KNMFIL),
     1  NAMEFIL(1:KNMFIL)
      ELSE
        CLOSE (UNIT = LU17, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
C * HKLF4.HKL FROM FCF
      IF (IPR(2) == -16 .AND. IPR(384) > 0) THEN
        WRITE (LU6, 99948, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      END IF
      CLOSE (UNIT = LU1)
C * DEF-FILE
      IF (IGBL(23) == 0)
     1  CLOSE (UNIT = LU23, STATUS = 'DELETE', IOSTAT = IOST)
C * NON-S MODE, NEW-RES
      IF (IGBL(92) == 0) THEN
        IF (IGBL(26) == 0 .OR. IABS (IGBL(8)) /= 2) THEN
          CLOSE (UNIT = LU21, STATUS = 'DELETE', IOSTAT = IOST)
        ELSE
          CALL PLUT29 (-1, ICL, NQ1, 0, LU21)
          WRITE (LU6, 99949, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
        END IF
      END IF
C * POVRAY-OUT
      IF (IGBL(98) /= 0) WRITE (LU6, 99999, IOSTAT = IOST)
     1  NAMEFIL(1:KNMFIL)
C * PBD-RASMOL-OUT
      IF (IGBL(11) /= 0) WRITE (LU6, 99969, IOSTAT = IOST)
     1  NAMEFIL(1:KNMFIL)
C * LIS
      IF ((IGBL(7) > 0 .AND. IGBL(3) == 1) .OR.
     1   (IPR(123) == 0 .AND. ((IGBL(7) > 0 .AND. IGBL(3) == 8)
     1  .OR. IGBL(63) == 0 .OR. IGBL(6) == 17
     2  .OR. IGBL(6) == 18 .OR. IGBL(6) == 19))) THEN
        CLOSE (UNIT = LU7, STATUS = 'DELETE', IOSTAT = IOST)
C * CHECK FOR .lps
      ELSE IF (MODE == 0) THEN
C * TEST WHETHER LU7 IS OPEN
        IF (IGBL(7) > 0) THEN
          CALL GEN108 (LU7, 0)
          CLOSE (UNIT = LU1)
C * CREATE PostScript Listing Output
          IF (IGBL(70) == 1) THEN
            READ (LU7, 99953, IOSTAT = IOST) PRBUF
            IF (IOST == 0) THEN
              CALL GEN108 (LU7, 0)
              IF (IGBL(7) == 1) THEN
                FNLU1  = NAMEFIL(1:KNMFIL) //'.lps'
              ELSE IF (IGBL(7) == 2) THEN
                FNLU1  = NAMEFIL(1:KNMFIL) //'_sq.lps'
              END IF
              OPEN (UNIT = LU1,  FILE = FNLU1, STATUS = 'UNKNOWN')
              CALL GEN089 (LU7, LU1, IGBL(49), IGBL(102))
              IF (IGBL(116) /= 1 .AND. IGBL(130) /= 0) THEN
                CLOSE (UNIT = LU1)
                NE = FINDEXE ('PS2PDF', CGETENV, 'ps2pdf')
                IF (IGBL(7) == 1) THEN
                  CGETENV(NE+1:) =
     1 ' '//NAMEFIL(1:KNMFIL)//'.lps '//NAMEFIL(1:KNMFIL)//'.pdf'
                ELSE IF (IGBL(7) == 2) THEN
                  CGETENV(NE+1:) =
     1 ' '//NAMEFIL(1:KNMFIL)//'_sq.lps '//NAMEFIL(1:KNMFIL)//'_sq.pdf'
                END IF
                KERR = 0
                CALL SPAWN (CGETENV, LU6, .true., KERR)
              END IF
            ELSE
              CLOSE (UNIT = LU7, STATUS = 'DELETE', IOSTAT = IOST)
              IGBL(7) = 0
            END IF
          END IF
        END IF
      END IF
C * PJN
      IF (IGBL(27) == 1) THEN
        WRITE (LU6, 99973, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
      ELSE
        CLOSE (UNIT = LU22, STATUS = 'DELETE', IOSTAT = IOST)
      END IF
      IF (IPR(580) < 0)  THEN
        IF (IPR(580) == -1) THEN
          WRITE (LU6, 99959, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
        ELSE
          WRITE (LU6, 99958, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
        END IF
      END IF
      IF (IPR(409) == 1) THEN
C * REPORT ON FLIP FILES
        WRITE (LU6, 99957, IOSTAT = IOST) NAMEFIL(1:KNMFIL),
     1    NAMEFIL(1:KNMFIL), NAMEFIL(1:KNMFIL)
C * TEST FOR UPDATED .res
        WRITE (LINE, 99953, IOSTAT = IOST) NAMEFIL(1:KNMFIL)//'_res.new'
        INQUIRE (FILE = LINE, EXIST = EXST)
        IF (EXST) WRITE (LU6, 99955, IOSTAT = IOST)
     1    NAMEFIL(1:KNMFIL), NAMEFIL (1:KNMFIL)
      END IF
      IF (MODE /= 0) THEN
        CLOSE (UNIT = LU7, STATUS = 'DELETE', IOSTAT = IOST)
        LU1     = 1
        LINE    = ICL(5:80)
        IGBL(7) = 0
        IGBL(8) = 0
      ELSE
        IGBL(1) = 5
C * DELETE check.def WHEN ITS DATE IS EARLIER OR EQUAL ENBEDDED VERSION (20)
        IF (IGBL(20) >= IGBL(21)) THEN
          CLOSE (UNIT = LU12, STATUS = 'DELETE', IOSTAT = IOST)
        END IF
      END IF
C * CLOSE OTHER POTENTIALLY OPEN FILES
      CLOSE (UNIT = LU1,  IOSTAT = IOST)
      CLOSE (UNIT = LU2,  IOSTAT = IOST)
      CLOSE (UNIT = LU3,  IOSTAT = IOST)
      CLOSE (UNIT = LU4,  IOSTAT = IOST)
      CLOSE (UNIT = LU7,  IOSTAT = IOST)
      CLOSE (UNIT = LU8,  IOSTAT = IOST)
      CLOSE (UNIT = LU9,  IOSTAT = IOST)
      CLOSE (UNIT = LU10, IOSTAT = IOST)
      CLOSE (UNIT = LU11, IOSTAT = IOST)
      CLOSE (UNIT = LU12, IOSTAT = IOST)
      CLOSE (UNIT = LU13, IOSTAT = IOST)
      CLOSE (UNIT = LU14, IOSTAT = IOST)
      CLOSE (UNIT = LU15, IOSTAT = IOST)
      CLOSE (UNIT = LU16, IOSTAT = IOST)
      CLOSE (UNIT = LU17, IOSTAT = IOST)
      CLOSE (UNIT = LU18, IOSTAT = IOST)
      CLOSE (UNIT = LU19, IOSTAT = IOST)
      CLOSE (UNIT = LU20, IOSTAT = IOST)
      CLOSE (UNIT = LU21, IOSTAT = IOST)
      CLOSE (UNIT = LU22, IOSTAT = IOST)
      CLOSE (UNIT = LU23, IOSTAT = IOST)
      CLOSE (UNIT = LU24, IOSTAT = IOST)
      CLOSE (UNIT = LU25, IOSTAT = IOST)
      CLOSE (UNIT = LU26, IOSTAT = IOST)
      CLOSE (UNIT = LU27, IOSTAT = IOST)
      CLOSE (UNIT = LU60, IOSTAT = IOST)
      CLOSE (UNIT = LU61, IOSTAT = IOST)
      CLOSE (UNIT = LU62, IOSTAT = IOST)
      CLOSE (UNIT = LU63, IOSTAT = IOST)
      CLOSE (UNIT = LU64, IOSTAT = IOST)
      CLOSE (UNIT = LU65, IOSTAT = IOST)
      CLOSE (UNIT = LU66, IOSTAT = IOST)
      CLOSE (UNIT = LU67, IOSTAT = IOST)
      CLOSE (UNIT = LU68, IOSTAT = IOST)
      RETURN
99999 FORMAT (/,
     1        ':: POV-Ray File on :', A, '.pov')
99997 FORMAT (':: OMEGA File   on :', A, '.ome')
99995 FORMAT (':: SPF File spf on :', A, '_pl.spf')
99994 FORMAT (':: CSD-QUE      on :', A, '.que')
99992 FORMAT (':: SUPP. Mat.   on :', A, '.sup')
99990 FORMAT (':: CIF/ACC-File on :', A, '_acc.cif')
99989 FORMAT (':: SAV-File     on :', A, '.sav')
99988 FORMAT (':: SHELXL   res on :', A, '_pl.res')
99987 FORMAT (':: FCF-CIF  cif on :', A, '_pl.cif', /,
     1        ':: FCF-CIF  fcf on :', A, '_pl.fcf', /)
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')
99977 FORMAT (':: PDB-FILE out on :', A, '_pl.pdb')
99976 FORMAT (':: Files for Final Refinement with SHELXL201n', //,
     1        ':: SQUEEZE  ins on :', A, /,
     2        ':: SQUEEZE  hkl on :', A, /,
     3        ':: SQUEEZE  fab on :', A, //,
     4        ':: Additional INFO on the SQUEEZE Job',//,
     5        ':: SQUEEZE  sqf on :', A, /,
     6        ':: SQUEEZE  xyz on :', A, /,
     7        ':: SQUEEZE  lis on :', A, /,
     8        ':: SQUEEZE  ps  on :', A, /)
99975 FORMAT (/,
     1        ':: Files for Final Refinement with CRYSTALS ', //,
     2        ':: SQUEEZE  ins on :', A, '_sqd.ins', /,
     3        ':: SQUEEZE  hkl on :', A, '_sqd.hkl', /,
     4        ':: SQUEEZE  cif on :', A, '_sqd.sqf', /,
     5        ':: SQUEEZE  xyz on :', A, '_sqd.sqz', /)
99973 FORMAT (/,
     1        ':: Journal File on :', A, '.pjn', //,
     2        ':: Normal End of PLATON/PLUTON RUN.')
99972 FORMAT (':: MULABS   hkl on :', A, '.hkp')
99971 FORMAT (':: CheckCIF out on :', A, '.chk')
99970 FORMAT (':: HKLTRANS hkl on :', A, '_trans.hkl', /,
     1        ':: HKLTRANS ins on :', A, '_trans.ins')
99969 FORMAT (':: RASMOL(pdb)  on :', A, '.ras')
99966 FORMAT (':: ASYM    -hkl on :', A, '.hks (# refl. =', I7, ')')
99965 FORMAT (':: POWDER   cpi on :', A, '.cpi')
99964 FORMAT (':: HKLF5.HKL    on :', A, '_tw.hkl')
99963 FORMAT (':: SHXABS   hkl on :', A, '.hkp')
99962 FORMAT (':: CheckFCF out on :', A, '.ckf')
99961 FORMAT (':: Expanded Coordinate Set (shelx-style) on: ', A,
     1        '_exp.ins')
99960 FORMAT (':: Expanded Reflection Set (SHELX-Style) on: ', A,
     1        '_exp.hkl')
99959 FORMAT (':: Fourier3D    on :', A, '.fou')
99958 FORMAT (':: Solv3D       on :', A, '.slv')
99957 FORMAT (':: Flip Results on: ', A, '_flp.res',
     1        ' - Concatenation of Flip-maps', /, 20X,
     2        A, '_sol.res - Concatenation of Solutions', /, 20X,
     3        A, '_res.res - Best Solution')
99955 FORMAT (20X, A, '_res.new - Updated version of ', A, '_res.res')
99953 FORMAT (A)
99952 FORMAT (':: SHELXL.INS (From .res in CIF) on :', A)
99951 FORMAT (':: SHELXL.HKL (From .hkl in CIF) on :', A)
99950 FORMAT (':: SHELXL.FAB (From .fab in CIF) on :', A)
99949 FORMAT (/, ':: Modified SHELX-File on ', A, '_pl.res')
99948 FORMAT (':: HKLF4.HKL    on :', A, '_sx.hkl')
99947 FORMAT (':: SHELXL.HKL (From .hkl in FCF) on :', A, /)
99946 FORMAT (':: GENERATE hkl on :', A, '_gener.hkl(# refl. =',
     1  I7, ')')
99945 FORMAT ('# end Validation Reply Form')
99944 FORMAT (':: CheckVRF out on :', A, '.vrf')
99943 FORMAT (':: HKLF5.INS    on :', A, '_tw.ins')
99942 FORMAT (':: CheckPlots   on :', A, '.ps')
99941 FORMAT ('[', I2, ' Plots]')
 
99940 FORMAT (/, 'Section 11: FCF Creation Job with SHELXL Logfile',
     1        /, 80('='))
99939 FORMAT (/, 'Section 12: ASYM Reflection Averaging Listing',
     1        ' (Embedded hkl Data)', /, 80('='))
99938 FORMAT (1X)
      END SUBROUTINE PLA004
 
      SUBROUTINE PLA005 (MODE, ISWVAL)
C * HANDLE COMMAND LINE SWITCHES
      USE files
      USE parameters
      USE cchar
      USE strain1
      IMPLICIT NONE
      INTEGER       :: J
      INTEGER       :: JARG
      INTEGER       :: MODE
      INTEGER       :: IVERS
      INTEGER       :: ISWVAL
      INTEGER, SAVE :: NCYCLE
C * MODE = -1 - DIRECT ACCESS TO PLATON FOR ALIAS LINKED TOOLS
C * MODE =  0 - PLATON
C * MODE =  1 - PLUTON
C * GET ARGUMENTS & FLAGS
      IF (MODE < 0) THEN
C * FIRST CHECK FOR SUB-PROGRAM NAMES SIM-LINKED TO THE PLATON EXECUTABLE)
        JARG = COMMAND_ARGUMENT_COUNT()
        DO J = 0, JARG
          CALL GET_COMMAND_ARGUMENT(J, IDM)
          IF (J == 0) THEN
            IF (INDEX (IDM, 'platon') /= 0) THEN
              CYCLE
C * SIMULATE -p option when called as 'pluton'
            ELSE IF (INDEX (IDM, 'pluton') /= 0) THEN
              IDM = '-p'
C * SIMULATE -u option when called as 'cifchk' or 'checkcif'
            ELSE IF (INDEX (IDM, 'cifchk') /= 0 .OR.
     1               INDEX (IDM, 'checkcif') /= 0) THEN
              IDM = '-u'
C * SIMULATE -s option when called as 's'
            ELSE IF (INDEX (IDM, 's ') /= 0) THEN
              IDM = '-s'
C * SIMULATE -k option when called as 'helena'
            ELSE IF (INDEX (IDM, 'helena ') /= 0) THEN
              IDM = '-k'
C * SIMULATE -Y option when called as 'stidy'
            ELSE IF (INDEX (IDM, 'stidy ') /= 0) THEN
              IDM = '-Y'
C * SIMULATE -Z option when called as 'flipper'
            ELSE IF (INDEX (IDM, 'flipper ') /= 0) THEN
              IDM = '-Z'
            ELSE
              CYCLE
            END IF
          END IF
C * LOOP OVER SWITCHES - GET NUMERICAL EXTENSION
C * SET DEFAULT WAVELENGTH
          IF (IDM(1:1) == '-') THEN
            IF (IDM(2:3) == 'Cu') THEN
              IGBL(143) = 1
            ELSE IF (IDM(2:3) == 'Ga') THEN
              IGBL(143) = 2
            ELSE IF (IDM(2:3) == 'Mo') THEN
              IGBL(143) = 3
            ELSE IF (IDM(2:3) == 'Ag') THEN
              IGBL(143) = 4
            ELSE IF (IDM(2:3) == 'In') THEN
              IGBL(143) = 5
            ELSE
              ISWVAL = 0
              READ (IDM(3:6), *, IOSTAT = IOST) ISWVAL
              IF (IOST /= 0) ISWVAL = 0
              SELECT CASE (IDM(2:2))
C * ADP-ORTEP MODE
                CASE ('a')
                  IGBL(3) = 3
C * SET FOR THE DISPLAY OF ALL LABELS
                  IF (ISWVAL == 1) IGBL(105) = 1
C * CALC GEOM CSD  (b1 = BMFIT), b2 = MP)
                CASE ('b')
                  IGBL(3) = 11
C * CALC MODE
                CASE ('c')
                  IGBL(3)   = 2
                  IGBL(150) = ISWVAL
C * COMPARE REFL FILES
                CASE ('d')
                  IGBL(3) = 6
C * MULABS - MODE
                CASE ('e')
                  IGBL(3) = 18
C * HFIX
                CASE ('f')
                  IGBL(3)  = 13
                  IGBL(50) = 1
C * CALC GEOM SHELX NOSF
                CASE ('g')
                  IGBL(3) = 24
C * HKL CALC
                CASE ('h')
                  IGBL(3) = 10
C * PATTERSON PLOT
                CASE ('i')
                  IGBL(3) = 22
C * CALC GEOM SPF
                CASE ('j')
                  IGBL(3)  = 23
                  IGBL(25) = 0
C * HELENA - MODE
                CASE ('k')
                  IGBL(3) = 15
                  NAMEFIL = 'helena'
                  KNMFIL  = 6
                  EXTENS  = 'cad'
                  KXT     = 3
C * ASYM (AVF) (VIEW)
                CASE ('l')
                  IGBL(3)  = 17
C * VIEW
                  IGBL(22) = 1
                  IF (ISWVAL == 1) THEN
                    IGBL(22) = 0
                  ELSE IF (ISWVAL == 2) THEN
                    IGBL(22) = 2
                  END IF
C * ADDSYM - MODE
                CASE ('m')
C * SET MENU OFF
                  IGBL(25) = 0
                  IF (ISWVAL > 0) RGBL(40) = FLOAT (100 - ISWVAL)
                  IGBL(3) = 4
C * ADDSYM SHELX - MODE
                CASE ('n')
                  IGBL(3) = 16
C * SET MINIMAL ATOM FIT PERCENTAGE
                  IF (ISWVAL > 0) RGBL(40) = FLOAT (100 - ISWVAL)
C * SET MENU OFF
                CASE ('o')
                  IGBL(25) = 0
C * PLUTON MODE
                CASE ('p')
                  IGBL(3) = 8
C * SQUEEZE/HYBRID - MODE
                CASE ('q')
                  IF (ISWVAL == 0) THEN
                    IGBL(3) = 5
                  ELSE
                    NCYCLE   = ISWVAL
                    IPR(682) = ISWVAL
                    IGBL(3)  = 48
                  END IF
C * RENAME MODE
                CASE ('r')
                  IGBL(3) = 12
C * SYSTEM-S - MODE
                CASE ('s')
                  IGBL(3) = 14
                  NAMEFIL = 's'
                  KNMFIL  = 1
                  RETURN
C * TABLE  - MODE
                CASE ('t')
                  IGBL(3) = 7
C * IUCR CHECKCIF MODE
                CASE ('u')
                  IGBL(3)  = 1
                  IGBL(36) = 1
                  IGBL(83) = 1
                  IPR(71)  = 0
C * NON DEFAULT # OF L.S. CYCLES FOR SHELXL201n FCF CREATION
                  IF (ISWVAL > 0) IGBL(93) = ISWVAL
C * SOLV MODE
                CASE ('v')
                  IGBL(3) = 9
C * DIFFERENCE MAP
                CASE ('w')
                  IGBL(3) = 19
C * FO MAP
                CASE ('x')
                  IGBL(3) = 20
C * SQUEEZE MAP
                CASE ('y')
                  IGBL(3) = 21
C * WRITE IDENT ETC.
                CASE ('z')
                  IF (ISWVAL == 0) THEN
                    WRITE (LU6, 99998, IOSTAT = IOST) IGBL(4)
                    CLOSE (UNIT = LU6, IOSTAT = IOST)
C * CALL EXIT/STOP
                    IF (IOST == 0 .OR. IOST /= 0) CALL GEN127 (' ')
C * PACK check.def into check.f
                  ELSE IF (ISWVAL == 1) THEN
                    CALL PLA275
C * EXIT/STOP
                    CALL GEN127 (' ')
C * UNPACK check.f into check.def
                  ELSE IF (ISWVAL == 2) THEN
                    IVERS = 0
                    CALL CHECK (1, IVERS)
C * EXIT/STOP
                    CALL GEN127 (' ')
C * CREATE stripped platon_special.f from platon.f
                  ELSE IF (ISWVAL == 4) THEN
                    CALL PLA278
C * RECOVER ORIGINAL HKLF4 FILE FROM HKLF5 FILE
                  ELSE IF (ISWVAL == 8) THEN
                    CALL PLA343
C * EXIT/STOP
                    CALL GEN127 (' ')
C * RECOVER ORIGINAL HKL FILE FROM OLD-STYLE SOLVENT FREE HKL FILE
                  ELSE IF (ISWVAL == 9) THEN
                    CALL PLA344
C * EXIT/STOP
                    CALL GEN127 (' ')
                  END IF
C * PLUTON ANIS
                CASE ('A')
                  IGBL(3) = 26
C * BIJVOET ANALYSIS
                CASE ('B')
                  IGBL(3) = 46
C * TABL ACC
                CASE ('C')
                  IGBL(3) = 35
C * DIFF-FOURIER
                CASE ('D')
                  IGBL(3) = 44
C * EXOR
                CASE ('E')
                  IGBL(25) = 0
                  IGBL(3)  = 42
C * SILENT SYSTEM-S NQA - MODE
                CASE ('F')
                  IGBL(50) = 2
                  IGBL(3)  = 14
                  NAMEFIL  = 's'
                  KNMFIL   = 1
                  RETURN
C * CHEM-MODE CHECKCIF (I MARKED ALERTS IGNORED)
                CASE ('G')
                  IGBL(132) = 1
                  IPR(71)   = 0
                  IGBL(3)   = 1
C * CREATE .ins & .hkl + SHELXL refinement
                CASE ('H')
                  IGBL(3)  = 45
                  IGBL(25) = 0
C * AUTOMOLFIT
                CASE ('I')
                  IGBL(3)  = 41
                  IGBL(25) = 0
                  IGBL(32) = 0
C * COMPARE PS
                CASE ('J')
                  IGBL(25) = 0
                  IGBL(3)  = 47
C * CALC KPI (PACKING INDEX)
                CASE ('K')
                  IGBL(3)  = 36
                  IGBL(25) = 0
C * LEPAGE
                CASE ('L')
C * LEPAGE (-L)
                  IF (ISWVAL == 0) THEN
                    IGBL(3) = 51
C * LEPAGE (-L1)
                  ELSE IF (ISWVAL == 1) THEN
                    IGBL(3) = 52
                  END IF
                CASE ('M')
C * ADDSYM EQUAL SHELX - MODE
                CASE ('N')
                  IGBL(3)  = 38
C * PLOT ADP PS
                CASE ('O')
                  IGBL(3)  = 28
C * SET FOR THE DISPLAY OF ALL LABELS
                  IF (ISWVAL == 1) IGBL(105) = 1
C * HKL2POWDER IOBS
                CASE ('P')
                  IGBL(3)  = 29
                  RGBL(23) = FLOAT (ISWVAL)
C * POWDER ICALC (POSTSCRIPT + CPI)
                CASE ('Q')
                  IGBL(3)  = 31
                  RGBL(23) = FLOAT (ISWVAL)
C * RENUM ==> SHELX
                CASE ('R')
                  IGBL(3) = 27
C * ShelxtPlot
                CASE ('S')
                  IGBL(3) = 53
C * TWINROTMAT OPTIONS
                CASE ('T')
C * TWINROTMAT (INTERACTIVE)
                  IF (ISWVAL == 0) THEN
                    IGBL(3) = 40
C * TWINROTMAT (FILTER MODE)
                  ELSE IF (ISWVAL == 1) THEN
                    IGBL(3) = 37
C * TWINROTMAT (RL-PLOT)
                  ELSE IF (ISWVAL == 2) THEN
                    IGBL(3) = 30
                END IF
C * IUCR CHECKCIF MODE (without VALIDATION DOC)
                CASE ('U')
                  IGBL(3)  = 1
                  IGBL(36) = 1
                  IGBL(83) = 0
                  IPR(71)  = 0
                  IF (ISWVAL > 0) IGBL(93) = ISWVAL
C * FCF-VALIDATION (LAUE)
                CASE ('V')
                  IGBL(3) = 33
C * FCF-VALIDATION (BIJVOET)
                CASE ('W')
                  IGBL(3) = 34
C * SHX86
                CASE ('X')
                  IGBL(3) = 32
C * STIDY
                CASE ('Y')
                  IGBL(3) = 39
C * ULTRA FLIPPER
                CASE ('Z')
                  IGBL(3) = 43
C * DEFAULT
                CASE DEFAULT
                  IGBL(8)      = 1
                  IGBL(19)     = 1
                  FILENAMES(1) = 'zz12345.zzz'
              END SELECT
            END IF
          ELSE IF (IDM(1:1) /= '+') THEN
            IF (IGBL(19) < 2) THEN
              IGBL(19)            = IGBL(19) + 1
              FILENAMES(IGBL(19)) = IDM
            END IF
          END IF
        END DO
C * ANALYZE/STORE FILENAME - DETERMINE FILE EXTENSION
        CALL PLA261 (IGBL(19))
      ELSE
        IPR(599) = 0
C * CHECK/IMPLEMENT FOR SHORTCUTS
        IF (IGBL(3) /= 0) CALL GEN038 (ICL, 1, 80)
        SELECT CASE (IGBL(3))
C * CHECK FOR CIF-VALIDATION-RUN
          CASE (1)
            IF (IABS(IGBL(8)) == 3) THEN
              ICL      = 'VALID'
              IGBL(45) = 1
              CALL GEN108 (LU3, 0)
            ELSE
              WRITE (6,
     1   '(/, '' **  Cannot do -u !!! - CIF not Recognized **'', /)',
     2        IOSTAT = IOST)
              IF (IABS (IGBL(3)) == 1) STOP
            END IF
C * CALC RUN
          CASE (2)
            IF (IGBL(150) == 0) THEN
              ICL      = 'CALC'
              IGBL(45) = 1
            ELSE IF (IGBL(150) == 1) THEN
              ICL      = 'CALC INTRA'
            ELSE IF (IGBL(150) == 2) THEN
              ICL      = 'CALC INTER'
              IGBL(25) = 0
            ELSE IF (IGBL(150) == 3) THEN
              ICL      = 'CALC COORDN'
            ELSE IF (IGBL(150) == 4) THEN
              ICL      = 'CALC METAL'
            ELSE IF (IGBL(150) == 5) THEN
              ICL      = 'CALC HBONDS'
              IGBL(45) = 0
            END IF
            CALL GEN108 (LU3, 0)
C * ADP RUN
          CASE (3)
C * SET FOR PORTRAIT
            IGBL(45) = 1
C * SET CR ->> END & EXIT
            IPR(308) = 2
C * NO R/S CALC
            IPR(324) = 0
            CALL GEN108 (LU3, 0)
            ICL      = 'PLOT ADP COLOR'
C * ADDSYM RUN
          CASE (4)
C * NO R/S CALC
            IPR(324)  = 0
C * NO EXPAND
            IGBL(136) = 1
            ICL       = 'ADDSYM'
C * SQUEEZE RUN
          CASE (5)
            ICL = 'SQUEEZE'
C * TABLE RUN
          CASE (7)
            ICL = 'TABLE SUP'
C * SOLVE RUN
          CASE (9)
            ICL = 'CALC SOLV'
C * HKL GENERATE
          CASE (10)
            ICL = 'ASYM GENERATE'
C * CALC GEOM CSD
          CASE (11)
            ICL = 'CALC GEOM CSD'
C * ADDSYM SHELX
          CASE (16)
            ICL       = 'ADDSYM SHELX NOSF'
C * NO R/S CALC
            IPR(324)  = 0
C * NO EXPAND
            IGBL(136) = 1
C * ASYM (AVF) (VIEW)
          CASE (17)
            IF (IGBL(22) == 0) THEN
              ICL = 'ASYM AVF LIST 0 '
            ELSE IF (IGBL(22) == 1) THEN
              ICL = 'ASYM AVF VIEW '
            ELSE IF (IGBL(22) == 2) THEN
              ICL = 'ASYM AVF LIST 1 '
            END IF
C * MULABS
          CASE (18)
            ICL = 'MULABS'
C * CONTOUR DIFF-MAP
          CASE (19)
            ICL = 'CONTOUR DI'
C * CONTOUR FO-MAP
          CASE (20)
            ICL = 'CONTOUR FO'
C * CONTOUR SQUEEZE-MAP
          CASE (21)
            ICL = 'CONTOUR SQ'
C * CONTOUR PATTERSON-MAP
          CASE (22)
            ICL = 'CONTOUR PT'
C * CALC GEOM SPF
          CASE (23)
            ICL = 'CALC GEOM SPF'
C * CALC GEOM SHELX
          CASE (24)
            ICL = 'CALC SHELX'
            IGBL(25) = 0
            IPR(595) = 1
C * CALC GEOM RENUM SHELX
          CASE (27)
            ICL = 'CALC GEOM RENUM SHELX'
C * ADP RUN (PS ONLY)
          CASE (28)
C * SET MENU OFF
            IGBL(25) = 0
C * SET FOR PORTRAIT
            IGBL(45) = 1
C * NO R/S CALC
            IPR(324) = 0
            ICL      = 'PLOT ADP COLOR'
C * POWDER IOBS
          CASE (29)
            ICL = 'POWDER IOBS'
C * TWINROTMAT (-T2)
          CASE (30)
            ICL = 'ROTMAT'
C * POWDER ICALC
          CASE (31)
            ICL = 'POWDER'
C * FCF-VALIDATION  (LAUE)
          CASE (33)
            ICL = 'ASYM AVF VALID'
C * FCF-VALIDATION (BIJVOET)
          CASE (34)
            ICL = 'ASYM VALID'
C * TABL ACC
          CASE (35)
            ICL = 'TABL ACC'
C * CALC VOID (KPI)
          CASE (36)
            ICL = 'CALC VOID'
C * TWINROTMAT (-T1)
          CASE (37)
            ICL      = 'ROTMAT'
            IGBL(25) = 0
C * ADDSYM EQUAL
          CASE (38)
            ICL = 'CALC ADDSYM EQUAL SHELX NOSF'
C * TWINROTMAT (-T)
          CASE (40)
            ICL = 'ROTMAT'
C * AUTOMOLFIT
          CASE (41)
            ICL = 'FIT'
C * EXOR
          CASE (42)
            ICL = 'EXOR'
C * ULTRA FLIPPER
          CASE (43)
            ICL = 'FLIP'
C * DIFFFOURIER
          CASE (44)
            ICL = 'CALC DIFF'
C * CIF2SHELXL
          CASE (45)
            ICL = 'CIF2SHELXL'
C * BIJVOET ANALYSIS
          CASE (46)
            ICL = 'BIJVOET'
C * HYBRID (SQUEEZE) LOOP
          CASE (48)
            WRITE (ICL, '(''HYBRID'', I3)') NCYCLE
C * Z
          CASE (49)
C * LEPAGE (-L) - WITH GRAPHICAL OUTPUT
          CASE (51)
            ICL = 'LEPAGE'
C * LEPAGE (-L1) - WITHOUT GRAPHICAL OUTPUT (TRAILER + LIS) ONLY
          CASE (52)
            ICL      = 'LEPAGE'
            IGBL(25) = 0
C * ShelxtPlot
          CASE (53)
            ICL = 'XTPLOT'
          CASE DEFAULT
C * INTERACTIVE OUTPUT PROGRAM HEADER (PLATON)
            IF (MODE == 0) THEN
C * PLATON HEADER ON TRAILER LISTING
              IF (IGBL(72) == 0) THEN
                WRITE (LU6, 99999, IOSTAT = IOST)
     1            IGBL(4), NVDR / 250000
                IGBL(72) = 1
              END IF
C * LIST ATOM LABEL ALIASES
              CALL PLA282 (-1, IDM(1:NP64), IDM(1:NP64), LU6)
              IF (IPR(39) == 0) THEN
C * END FOR EMPTY GLOBAL BLOCK
                IF (IABS (IGBL(8)) == 3) THEN
                  ICL = 'END'
                  RETURN
                ELSE
C * REPORT NO ATOMS (EXCEPT FOR STRAIN ANALYSIS)
 
                  IF (TEMPAB(1) == 0.0)
     1              WRITE (LU6, 99997, IOSTAT = IOST)
                END IF
              END IF
            END IF
            IPR(599) = 1
        END SELECT
      END IF
      RETURN
99999 FORMAT (/, '::', 25X,
     1        '*** S.e.l.e.c.t.e.d  I.n.s.t.r.u.c.t.i.o.n.s ***', /,
     2        ':: ', 24('*'), 1X,
     3        'CALC ALL   - for an exhaustive geometry calculation', /,
     4        ':: ', '*        PLATON        *', 1X,
     5        'ORTEP      - for default labeled ORTEP-look-alike', /,
     6        ':: ', '*        ======        *', 1X,
     7        'VALID      - for a PLATON/checkCIF validation run', /,
     8        ':: ', '*    A Multipurpose    *', 1X,
     9        'LEPAGE     - to  check for higher metrical symmetry', /,
     *        ':: ', '*   Crystallographic   *', 1X,
     1        'ADDSYM     - for a check for MISsed SYMmetry', /,
     2        ':: ', '*         Tool         *', 1X,
     3        'NONSYM     - for a non-cryst. symm. check', /,
     4        ':: ', '*          --          *', 1X,
     5        'SOLV       - to  search for missed solvent areas', /,
     6        ':: ', '*(C) 1980-2025 A.L.Spek*', 1X,
     7        'SQUEEZE    - to  handle disordered solvents', /,
     8        ':: ', '*          --          *', 1X,
     9        'NEWMAN     - for NEWMAN-Projection Plots', /,
     *        ':: ', '*   version :', I7, '   *', 1X,
     1        'LIST RADII - for current atomic radii list', /,
     2        ':: ', '*   scratch :', I5, 'MB   *', 1X,
     3        'HELP       - for Available Instruction Information', /,
     4        ':: ', 24('*'), 1X,
     5        'PLUTON     - to  enter the PLUTON sub-program', /, ':: ')
99998 FORMAT ('PLATON-Version=', I10)
99997 FORMAT (/, ':: Warning: no ATOMS given yet')
      END SUBROUTINE PLA005
 
      SUBROUTINE PLA006 (NMODE, IS)
C * FREE FORMAT READ ROUTINE FOR PLATON, SYSTEM-S & PLUTON
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cif
      USE cggt
      USE chdat
      USE mentry
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: N
      INTEGER :: IS
      INTEGER :: KL
      INTEGER :: KN
      INTEGER :: NP
      INTEGER :: IER
      INTEGER :: MODE
      INTEGER :: NCARD
      INTEGER :: ICONT
      INTEGER :: IENDS
      INTEGER :: IGOTO
      INTEGER :: NMODE
      INTEGER :: ISWVAL
      INTEGER :: LRETPDB
      REAL    :: A
      REAL    :: S
      MODE = NMODE
C * MODE    = 0 - PLATON/SYSTEM-S
C * MODE    = 1 - PLUTON
C * INPUT STYLES:
C * IGBL(8) = 1 - SPF
C *         = 2 - RES
C *         = 3 - CIF
C *         = 4 - PDB
      NP    = 0
      S     = 0.0
      IGOTO = 0
   10 J     = 0
      ICONT = 0
      A     = 0.0
   20 KN    =  0
      KL    =  0
      IS    = -1
C * INITIALIZE LITERAL AND NUMBER ARRAYS (IFL & FN)
      CALL GEN074 (FN, 1, NP17, 0.0)
      DO I = 1, NP17
        CALL GEN038 (IFL(I), 1, NP64)
      END DO
C * AUTO-PLOT INSTRUCTION
C * IGBL(5)  = READ CHANNEL (1, 3, 5)
C * IGBL(6)  = MENU #
C * IGBL(24) = PLOT-AS-DEFAULT
C * IGBL(25) = MENU ON/OFF
C * CONSIDER INTERACTIVE GRAPHICS INPUT OR AUTO 'PLOT'
      IF (IGGT(1:1) == ' ') THEN
        IF (IGBL(6) > 0) THEN
C * CHECK FOR PLATON MAIN MENU'S
          IF (IGBL(6) < 10 .OR. IGBL(6) > 12) THEN
            IF (IGBL(5) * IGBL(24) * IGBL(25) == LU5) THEN
              ICL = 'PLOT'
              GO TO 50
            END IF
          END IF
        END IF
C * CHECK FOR ALTERNATE INPUT/OUTPUT FROM/TO GRAPHICS ROUTINE
      ELSE
        ICL = IGGT
        CALL GEN038 (IGGT, 1, 80)
        GO TO 50
      END IF
C * CHECK FOR SPECIAL SHORTCUTS-GENERATE CORRESPONDING INSTRUCTIONS
   30 IF (IGBL(5) == LU5) THEN
        CALL PLA005 (MODE, ISWVAL)
        IF (IPR(599) == 0) GO TO 50
      END IF
C * READ CARD-IMAGE IN CHARACTER BUFFER ICL
   40 CALL PLA019 (0, IER)
      IF (IER /= 0) THEN
        IGBL(8) = - IABS (IGBL(8))
        GO TO 70
      END IF
C * CHECK FOR PLUTON MODE
      IF (MODE == 1 .AND. IGBL(5) == LU1) THEN
        CALL GEN038 (NQ1, 1, NP64)
        CALL PLUT29 (1, ICL, NQ1, 0, 0)
      END IF
C * CHECK/FIND-OUT DATA TYPE (= IGBL(8))
   50 IF (IGBL(8) == 0) THEN
C * CHECK FOR 'FIRST LINE(S)' FOR CIF/PDB
C * BUT IGNORE BLANK AND # IN COLUMN 1 LINES
        DO
C * LOOK FOR CIF-STYLE STRUCTURED DATA (TRIGGERED BY data_) (IGBL(8) = 3)
          N = INDEX (ICL, 'data_')
          IF (N > 0 .AND. ICL(1:4) /= 'TITL' .AND.
     1      INDEX (ICL, '_data_') == 0) THEN
C * CIF-standard !!
            IGBL(8) = 3
            ISEMCOL = 0
            IVOID   = 0
            ILOOP   = 0
            NL      = 0
            LRETCIF = 0
C * CHECK FOR CSD-CIF VARIETY
            IF (ICL(N + 5:N + 11) == 'CSD_CIF') IGBL(104) = 1
C * GET NUMBER OF DATASET ENTRIES
            IPR(220) = 1
            IPR(221) = 0
C * SET NOMOVE DEFAULT FOR CIF
            IGBL(30) = 1
            WRITE (LU6, 99999, IOSTAT = IOST)
C * CREATE MULTIPLE CIF ENTRY DIRECTORY (=> IGBL(100) ENTRIES)
            CALL PLA007
C * REPORT NUMBER OF VALID CIF DATA ENTRIES
            WRITE (LU6, 99998) IGBL(100)
C * FIND REFLECTIONS (fcf or hkl STYLE) PLATON MODE
            IF (MODE == 0) CALL PLA008
C * SKIP TO FIRST REAL ENTRY
            IF (IGBL(100) > 0) THEN
              CALL GEN108 (LU1, 0)
              NCARD = IENTRY(1, 2)
              DO I = 1, NCARD
                READ (LU1, 99997, IOSTAT = IOST) ICL
                IF (IOST /= 0) CYCLE
              END DO
            END IF
            GO TO 40
          END IF
          IF (LRETCIF == -2) THEN
            IGBL(8) = - IABS (IGBL(8))
            RETURN
          END IF
C * ASSUME SPF = 1 (OR RES = 2, BASED ON SFAC)
          IF (IGBL(8) == 0) THEN
            N = INDEX (ICL, 'TITL')
            IF (N > 0) THEN
              IGBL(8) = 1
C * CHECK FOR REFLECTION FILE
              CALL PLA008
              GO TO 50
            END IF
          END IF
C * CHECK FOR PDB-FILE-STRUCTURE  (IGBL(8) = 4)
          IF (IGBL(8) == 0) THEN
            LRETPDB = -1
            CALL PLA381 (MODE, LRETPDB)
            IF (IGBL(8) /= 0) EXIT
          END IF
C * CATCH INSTRUCTIONS
          IF (IGBL(8) == 0) THEN
            NQ1 = ICL(1:4)
            CALL GEN020 (1, NQ1, 1, 4)
            IF (NQ1(1:4) == '    ') THEN
              GO TO 40
            ELSE IF (NQ1(1:4) == 'EXIT') THEN
              RETURN
            ELSE IF (NQ1(1:4) == 'FILE') THEN
              IGBL(8) = 1
              GO TO 50
            ELSE IF (NQ1(1:4) == 'TITL') THEN
              IGBL(8) = 1
              GO TO 50
            ELSE IF (NQ1(1:4) == 'HELP') THEN
              GO TO 50
            END IF
          ELSE
            IPR(2) = 64
            RETURN
          END IF
          GO TO 40
        END DO
C * RESTRICTED CIF - FORMAT (COMPATIBLE WITH SHELXL)
      ELSE IF (IGBL(8) == 3) THEN
        CALL PLA176 (MODE)
        KL = IPR(220)
        KN = IPR(221)
        SELECT CASE (LRETCIF)
C * NORMAL RETURN
          CASE (0)
            GO TO 60
C * TITL, CELL etc. RECORD
          CASE (1)
            GO TO 60
C * ERROR RETURN
          CASE (2)
            IGBL(8) = - IABS (IGBL(8))
            GO TO 70
C * SYSTEM S RETURN
          CASE (3)
            IS      = -2
            IPR(3)  = 1
            IGBL(8) = - IABS (IGBL(8))
            GO TO 70
C * CIF BOND/ANGLE/TORSION/HBOND
          CASE (4)
            IS = -3
            RETURN
        END SELECT
C * PDB-FILE STRUCTURE
      ELSE IF (IGBL(8) == 4) THEN
        LRETPDB = 0
        CALL PLA381 (MODE, LRETPDB)
C * CHECK RETURN CODE
        IF (LRETPDB == 0) THEN
          GO TO 60
C * END-OF-FILE
        ELSE IF (LRETPDB == 1) THEN
          IGBL(8) = - IABS (IGBL(8))
          GO TO 70
C * ERROR IN READ
        ELSE IF (LRETCIF == 2) THEN
          IS      = 0
          IPR(3)  = 1
          IGBL(8) = - IABS (IGBL(8))
          GO TO 70
        END IF
C * SPF or RES  & Instructions
      ELSE
        CALL PLA017 (MODE, IGOTO, ICONT, KL, KN, IS, A, J, NP, S)
        SELECT CASE (IGOTO)
          CASE (1)
            GO TO 20
          CASE (2)
            GO TO 60
          CASE (3)
            GO TO 70
        END SELECT
      END IF
C * TEST FOR CONTINUATION OR FINISHED
   60 IF (IS < 0) THEN
        IF (IFL(1)(1:4) == 'TEXT') THEN
          LMOD = 0
          CALL PLA109 (1, 1, 0.0, 0.0)
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          GO TO 10
        END IF
C * PLATON
        IF (MODE == 0) THEN
C * TRANSFORM KEYWORD TO ENTRYPOINT NUMBER IN ARRAY
          CALL GEN102 (IS, IFL(1)(1:4), ISWS, NP24)
C * PLUTON
        ELSE
C * TRANSFORM KEYWORD TO ENTRYPOINT NUMBER IN ARRAY
          CALL GEN102 (IS, IFL(1)(1:4), CRD,  NP37)
        END IF
      END IF
C * DO NOT INTERPRETE TITL, REM OR MESS CARD (ADD 1 TO IS SERIAL NR)
      IF (ICONT == 1) THEN
        IF (IS < 2 .OR. IS > 4) GO TO 30
      END IF
C * HANDLE TERMINATING ENDS - LINE
      IENDS = 0
      IF (MODE == 0) THEN
        IF (IS == 14)  IENDS = 1
      ELSE
        IF (IS == 140) IENDS = 1
      END IF
      IF (IENDS == 1) THEN
        CALL PLA019 (0, IER)
          IF (IER >= 0) THEN
          BACKSPACE IGBL(5)
        ELSE
          IS = -1
        END IF
      END IF
   70 IPR(220) = KL
      IPR(221) = KN
      IF (MODE == 1) THEN
C * TRNS = TRMX
        IF (IS == 93) THEN
          IS = 65
C * ARU  = MOLES
        ELSE IF (IS == 71) THEN
          IS = 26
C * BWC  > COLOR
        ELSE IF (IS == 64) THEN
          IS = 40
C * MONO > STEREO
        ELSE IF (IS == 32) THEN
          IS = 31
C * CALC = JOIN
        ELSE IF (IS == 156) THEN
          IS = 13
        END IF
      END IF
      RETURN
99999 FORMAT (':: Restricted CIF-File Format assumed',
     1           ' (Automatic NOMOVE effective) ', /)
99998 FORMAT (/, ':: Number of Valid CIF data_ ENTRIES =', I6, /)
99997 FORMAT (A)
      END SUBROUTINE PLA006
 
      SUBROUTINE PLA007
C * HANDLING OF MULTIPLE ENTRY FILES - CREATE VALID ENTRY DIRECTORY
      USE files
      USE parameters
      USE mentry
      USE xwdw
      USE cggt
      USE cchar
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: N
      INTEGER                :: M
      INTEGER                :: NPC
      INTEGER                :: NPD
      INTEGER                :: NCRD
      INTEGER                :: ILST
      INTEGER                :: NCARD
      INTEGER                :: ISKIP
      INTEGER                :: NDATA
      INTEGER                :: NENTRY
      INTEGER                :: IVALID
      REAL                   :: XH
      REAL                   :: XV
      CHARACTER(len=1)       :: CYN
      CHARACTER(len=80)      :: LIN
      CHARACTER(len=8), SAVE :: RCODE = '        '
      CHARACTER(len=75)      :: CDATA
      CHARACTER(len=8)       :: REFCOD
C * RECOGNIZED STRUCTURE PARAMETER INPUT FILE TYPES
C * IGBL(8) = 1 - spf
C *         = 2 - res (ins)
C *         = 3 - cif
C *         = 4 - pdb
      PRBUF = ' '
C * CHECK FOR THE CASE OF NO-DATA ON THE INPUT FILE LU1  (All interactive mode)
      IF (LU1 == LU5) THEN
        WRITE (LU6, 99999, IOSTAT = IOST)
      ELSE
C * OPTIONS: NUMBER, REFCODE OR BLANK (= LIST)
        IF (IPR(220) > 1) THEN
          REFCOD = IFL(2)(1:8)
          NENTRY = 0
        ELSE
          REFCOD = ' '
          IF (IPR(221) > 0) THEN
            NENTRY = NINT(FN(1))
C * CHECK # OF ENTRIES IN FILE (CIF)
            IF (IGBL(100) /= 0) GO TO 30
          ELSE
C * LIST ENTRY DETAILS (CIF & FCF)
            NENTRY = 0
            IF (IGBL(100) /= 0 .AND. IGBL(94) == 0) THEN
              IPR(462) = 1
              N = MIN (IGBL(100), NP54)
              DO I = 1, N
                IF (I == 1) WRITE (LU6, 99993)
                WRITE (LU6, 99996) I, CENTRY(I)(1:57),
     1           (IABS (IENTRY(I, J)), J = 1, 4)
              END DO
            END IF
          END IF
        END IF
C * GET DIRECTORY FOR CIF_FILE OR ELD_FILE
        IF (NENTRY == 0 .OR. IGBL(100) == 0) THEN
          IF (IGBL(8) /= 0 .AND. IABS (IGBL(8)) <= 4) THEN
            ILST      = 1
            NCARD     = 0
            NDATA     = 0
            ISKIP     = 0
            IVALID    = -1
            XH        = 0.0
            XV        = VERT
            IGBL(100) = 0
            IGBL(86)  = NVDR - 6
C * REWIND
            CALL GEN108 (LU1, 0)
C * READ DATA ENTRIES LOOP
            DO
              READ (LU1, 99994, IOSTAT = IOST) ICL
              IF (IOST /= 0) EXIT
C * COUNT READ LINES
              NCARD = NCARD + 1
              IF (ICL(1:1) == '#') CYCLE
              NCRD  = 1
C * SPF - SEQUENCE
              IF (ABS(IGBL(8)) == 1) THEN
                CALL GEN020 (1, ICL(1:4), 1, 4)
                IF (ICL(1:4) == 'TITL') THEN
                  CDATA = ICL(6:13)
                  NDATA = NCARD - 1
                  GO TO 10
                 ELSE
                   CYCLE
                 END IF
C * RES - SEQUENCE
              ELSE IF (ABS (IGBL(8)) == 2) THEN
                IF (ICL(1:4) == 'TITL') THEN
                  NDATA = NCARD - 1
                  CDATA = ICL(6:13)
                  GO TO 10
                ELSE
                  CYCLE
                END IF
C * CIF - SEQUENCE
              ELSE IF (ABS (IGBL(8)) == 3) THEN
                NPD = INDEX (ICL(1:80), '#')
                IF (NPD == 0) NPD = 80
                NPC = INDEX (ICL(1:NPD), '_publ_requested_category')
                IF (NPC /= 0) THEN
                  IF (INDEX (ICL(NPC + 24: NPD), 'I') /= 0) THEN
                    IGBL(99) = 1
                  ELSE IF (INDEX (ICL(NPC + 24: NPD), 'M') /= 0) THEN
                    IGBL(99) = 2
                  ELSE IF (INDEX (ICL(NPC + 24: NPD), 'O') /= 0) THEN
                    IGBL(99) = 3
                  END IF
                ELSE IF (INDEX (ICL(1:40), 'data_') /= 0 .AND.
     1                   INDEX (ICL(1:40), '_data_') == 0 .AND.
     2                   ICL(1:4) /= 'TITL' .AND.
     3                   ICL(1:3) /= 'REM') THEN
C * REPORT ON NON-VALID CIF DATA SECTIONS
                  IF (IVALID == 0) THEN
                    WRITE (LU6, 99992) CDATA(1:50)
                  END IF
                  IVALID = 0
                  N = INDEX (ICL(1:40), 'data')
C * PREPARE TO RECEIVE AUDIT SOFTWARE TOOL NAME TO BE USED AS DEFAULT
                  IF (INDEX (ICL(1:80), 'global') /= 0) NCIF23 = 0
                  CALL GEN151 (ICL, N + 5)
                  CDATA = ICL(N + 5:80)
C * HANDLE CSD CREATED CIF DATASET NAME CASE
                  IF (CDATA(1:7) == 'CSD_CIF') THEN
                    IF (ICL(N + 13:N + 16) == 'MIF_') THEN
                      CDATA = ICL(N + 17:N + 24)
                    ELSE
                      CDATA = ICL(N + 13:80)
                    END IF
                  END IF
                  NDATA = NCARD - 1
                ELSE IF (INDEX (ICL(1:80), '_cell_length_a') /= 0) THEN
                  IVALID = 1
                  GO TO 10
                ELSE IF (INDEX (ICL(1:80), '_audit_creation_method')
     1            /= 0) THEN
                  I = INDEX (ICL(1:80), '_audit_creation_method')
                  K = 0
                  L = 0
                  DO J = I + 22, 80
                    IF (ICL(J:J) == ' ') THEN
                      CYCLE
                    ELSE IF (ICL(J:J) == '''' .OR.
     1                       ICL(J:J) == '"') THEN
                      K = J
                      L = INDEX (ICL(K + 1:80), '''')
                      IF (L == 0) L = INDEX (ICL(K + 1:80), '"')
                      IF (L == 0) L = 60 - K
                      EXIT
                    ELSE
                      K = J - 1
                      L = INDEX (ICL(K + 1:80), ' ')
                      EXIT
                    END IF
                  END DO
                  IF (K == 0 .AND. L == 0) THEN
                    READ (LU1, 99994, IOSTAT = IOST) ICL
                    IF (IOST /= 0) EXIT
C * COUNT READ LINES
                    NCARD = NCARD + 1
                    IF (ICL(1:1) == ';') THEN
                      READ (LU1, 99994, IOSTAT = IOST) ICL
                      IF (IOST /= 0) EXIT
C * COUNT READ LINES
                      NCARD = NCARD + 1
                      CALL GEN039 (0, ICL, 1, 80, K, L)
                    END IF
                    NCIF23 = L - K + 1
                    CCIF23 = ICL(K:L)
                  ELSE
                    NCIF23 = L - 1
                    CCIF23 = ICL(K + 1: K + L - 1)
                  END IF
                  WRITE (LU6, 99991) CCIF23(1:NCIF23)
                END IF
                CYCLE
C * PDB SEQUENCE
              ELSE IF (IABS (IGBL(8)) == 4 .AND.
     1                 ICL(1:6) == 'HEADER') THEN
              ELSE
                CYCLE
              END IF
C * SAVE DATA ENTRY NAMES
   10         IF (IGBL(86) > 1) THEN
                IGBL(100) = IGBL(100) + 1
                IF (IPR(462) /= 1) THEN
                  IF (ABS (IGBL(8)) == 3) THEN
C * SHOW PROGRESS IN READING ENTRIES IN FILE
                    IF (MOD (IGBL(100), 1000) == 0) THEN
                      IF (IGBL(25) * IGBL(32) == 1) THEN
                        IF (IGBL(100) == 1000) THEN
                          CALL GGIP (HORS, VERT, 0.0, 1)
                        END IF
                        CALL PLA439 (0.0, PRBUF, 80, 0.35, 0, 2, 0.5,
     1                     0.5)
                        WRITE (PRBUF, 99995, IOSTAT = IOST) IGBL(100)
                        CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 0.5,
     1                     0.5)
                        CALL GGIP (0.0, 0.0, 0.0, 6)
                      END IF
                    END IF
                  END IF
                END IF
                IGBL(86) = IGBL(86) - 1
C * SPF - STYLE
                IF (ABS (IGBL(8)) == 1) THEN
                  VOID(NVDR - 6 - IGBL(100)) = NDATA
                  IF (IGBL(100) <= NP54) THEN
                    CENTRY(IGBL(100))    = CDATA
                    IENTRY(IGBL(100), 1) = IGBL(8)
                    IENTRY(IGBL(100), 2) = NDATA
                  END IF
C * RES - STYLE
                ELSE IF (ABS (IGBL(8)) == 2) THEN
                  VOID(NVDR - 6 - IGBL(100)) = NDATA
                  IF (IGBL(100) <= NP54) THEN
                    CENTRY(IGBL(100))    = CDATA
                    IENTRY(IGBL(100), 1) = IGBL(8)
                    IENTRY(IGBL(100), 2) = NDATA
                  END IF
C * CIF - STYLE
                ELSE IF (ABS (IGBL(8)) == 3) THEN
                  VOID(NVDR - 6 - IGBL(100)) = NDATA
C * SPECIAL SAVE
                  IF (IGBL(100) <= NP54) THEN
                    CENTRY(IGBL(100))    = CDATA
                    IENTRY(IGBL(100), 1) = IGBL(8)
                    IENTRY(IGBL(100), 2) = NDATA
                  END IF
                ELSE
                  VOID(NVDR - 6 - IGBL(100)) = NCARD - NCRD
C * SPECIAL SAVE
                  IF (IGBL(100) <= NP54)
     1              IENTRY(IGBL(100), 1) = NCARD - NCRD
                END IF
C * LIST ENTRIES
                IF (IPR(220) == 1 .AND. IPR(221) == 0) THEN
                  IF (ILST * IPR(462) == 1) THEN
                    IF (ILST == 1) THEN
                      IF (IGBL(25) * IGBL(32) == 1 .AND.
     1                    IGBL(100) == 1)
     2                    CALL GGIP (HORS, VERT, 0.0, 1)
C * SPF ENTRY
                      IF (ABS (IGBL(8)) == 1) THEN
                        WRITE (LIN, 99997, IOSTAT = IOST)
     1                    IGBL(100), ICL(6:10)
                        M = 4
C * RES ENTRY
                      ELSE IF (ABS (IGBL(8)) == 2) THEN
                        WRITE (LIN, 99997, IOSTAT = IOST)
     1                    IGBL(100), ICL(6:10)
                        M = 4
C * CIF ENTRY
                      ELSE IF (IABS (IGBL(8)) == 3) THEN
C * CHECK FOR FULL OR CSD-CIF TYPE
                        IF (IGBL(94) == 0) THEN
                          M = 74
                        ELSE
                          M = 8
                        END IF
                        WRITE (LIN, 99997, IOSTAT = IOST)
     1                    IGBL(100), CDATA(1:M)
C * PDB ENTRY
                      ELSE IF (IABS (IGBL(8)) == 4) THEN
                        IF (ICL(63:66) /= '    ') THEN
                          WRITE (LIN, 99997, IOSTAT = IOST)
     1                      IGBL(100), ICL(63:70)
                          M = 8
                        ELSE
                          WRITE (LIN, 99997, IOSTAT = IOST)
     1                      IGBL(100), ICL(11:18)
                          M = 8
                        END IF
                      END IF
                      XV = XV - 0.45
                      CALL PLA439 (0.0, LIN, 6 + M, 0.34, 1, 2, XH, XV)
                    END IF
                    IF (MOD (IGBL(100), 43) == 0) THEN
                      XH = XH + 4.3
                      XV = VERT
                      IF (XH + 4.3 >= HORS) THEN
                        IF (IGBL(25) * IGBL(32) == 1) THEN
C * WHAT NEXT ?
   20                     CALL PLA012 (3, 1)
                          SELECT CASE (IGGT(1:4))
                            CASE ('PLOT')
                              GO TO 20
                            CASE ('EXIT')
                              CALL GEN038 (IGGT, 1, 80)
                              RETURN
                            CASE ('N   ', 'NO  ')
                              CALL GEN038 (IGGT, 1, 80)
                              RETURN
                          END SELECT
                          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) > 0) THEN
                            NENTRY = NINT (FN(1))
                            GO TO 30
                          END IF
                        ELSE
                          CALL GEN125 (1, LU6,
     1                      'Continue Listing (Y/N[Y])')
                          READ  (LU5, 99994) CYN
                        END IF
                        CALL GEN020 (1, CYN, 1, 1)
                        IF (CYN == 'N') THEN
                          ILST = 0
                        ELSE
                          CALL GGIP (HORS, VERT, 0.0, 1)
                          XH = 0.0
                          XV = VERT
                        END IF
                      END IF
                    END IF
                  END IF
                ELSE
                  IF (IABS (IGBL(8)) == 4) THEN
                    IF (RCODE == REFCOD) THEN
                      NENTRY   = IGBL(100)
                      IPR(221) = 1
                    END IF
                  ELSE IF (IABS (IGBL(8)) == 3) THEN
                    IF (ICL(6:13) == REFCOD) THEN
                      NENTRY   = IGBL(100)
                      IPR(221) = 1
                    END IF
                  ELSE IF (IABS (IGBL(8)) == 1) THEN
                    IF (ICL(6:13) == REFCOD) THEN
                      NENTRY   = IGBL(100)
                      IPR(221) = 1
                    END IF
                  END IF
                END IF
              END IF
            END DO
            IF (IPR(462) == 1) THEN
              DO
C * WHAT NEXT ?
                CALL PLA012 (3, 1)
                IF (IGGT(1:4) /= 'PLOT') THEN
                  CALL GEN072 (IGGT, IFL, FN, IPR(220), IPR(221), 0,
     1               LU6, 1, 1, 80, 7, NP17)
                  CYN = IGGT(1:1)
                  CALL GEN038 (IGGT, 1, 80)
                  IF (IPR(221) > 0) NENTRY = NINT (FN(1))
                  EXIT
                END IF
              END DO
            END IF
            IPR(462) = 0
            IF (ICL(1:1) == ';') CALL GEN038 (ICL, 1, 80)
            CALL GEN108 (LU1, 0)
          END IF
        END IF
C * FIND ENTRY STARTING POINT
   30   IF (NENTRY > 0) THEN
          IF (IABS(IGBL(8)) <= 4) THEN
            IF (NENTRY <= IGBL(100)) THEN
              IGBL(54) = NENTRY - 1
C * READ UNTIL (BUT NOT INCLUDING) FIRST LINE OF REQUESTED ENTRY
              IF (NENTRY <= NP54) THEN
                NCARD   = IENTRY(NENTRY, 2)
                IGBL(9) = IENTRY(NENTRY, 3)
              ELSE
                NCARD = NINT (VOID(NVDR - 6 - NENTRY))
              END IF
              CALL GEN108 (LU1, 0)
              IF (NCARD > 0) THEN
                DO I = 1, NCARD
                  READ (LU1, 99994, IOSTAT = IOST) ICL
                  IF (IOST /= 0) CYCLE
                END DO
              END IF
C * READ UNIT = 5
              ICL    = 'END'
              IPR(3) = 1
            ELSE
C * REPORT ENTRY NOT FOUND ....
              WRITE (LU6, 99998, IOSTAT = IOST)
     1          REFCOD, NENTRY, IGBL(100)
              ICL    = 'END'
              IPR(3) = 1
            END IF
          END IF
        ELSE
C * REPORT ENTRY NOT FOUND ....
          IF (IPR(220) > 1) THEN
            WRITE (LU6, 99998, IOSTAT = IOST) REFCOD, NENTRY, IGBL(100)
            CALL PLA015 (427, 50)
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (':: No Entries in File LU1 (Instruction Ignored)')
99998 FORMAT (/, ':: Entry not found (', A, 2I10,')')
99997 FORMAT (I5, 1X, A)
99996 FORMAT (I2, 1X, A, 2(I3, I7))
99995 FORMAT ('Count Number of Entries on Input:', I6)
99994 FORMAT (A)
99993 FORMAT (/,'Nr Dataset Name', 42X, 'CIFtyp   Rec RFLtyp Rec')
99992 FORMAT (':: Skipped CIF-data Section: ', A)
99991 FORMAT (':: Default global AUDIT TOOL Name: ', A, /)
      END SUBROUTINE PLA007
 
      SUBROUTINE PLA008
C * SEARCH FOR ASSOCIATED REFLECTION FILE FOR SUPPLIED CIF/RES/SPF
C * STEP 1 - DETERMINE COORDINATE - REFLECTION FILE PAIRING
C * STEP 2 - DETERMINE REFLECTION STYLE IN PLA009 (AND IN CASE OF
C *          IGBL(15) = 1 - WITH PLA010
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
C * IGBL(15) =  1 - fcf/FCF
C *          =  0 - hkl/HKL
C *          = -1 - no hkl or fcf reflection file association found
C * CIF MODEL PARAMETER FILE CASE
      IGBL(29) = 0
      KNM16    = KNMFIL + 4
      IF (ABS(IGBL(8)) == 3) THEN
        IGBL(15) = 1
C * SEARCH FOR .fcf .OR. .FCF first in case of .cif EXTENSION
        FNLU16 = NAMEFIL(1:KNMFIL)//'.fcf'
        INQUIRE (FILE = FNLU16, EXIST = EXST16)
        IF (.NOT. EXST16) THEN
          FNLU16   = NAMEFIL(1:KNMFIL)//'.FCF'
          INQUIRE (FILE = FNLU16, EXIST = EXST16)
          IF (.NOT. EXST16) THEN
            IGBL(15) = 0
            FNLU16 = NAMEFIL(1:KNMFIL)//'.hkl'
            INQUIRE (FILE = FNLU16, EXIST = EXST16)
            IF (.NOT. EXST16) THEN
              FNLU16 = NAMEFIL(1:KNMFIL)//'.HKL'
              INQUIRE (FILE = FNLU16, EXIST = EXST16)
              IF (.NOT. EXST16) THEN
C * NO REFLECTION DATA FOUND
                IGBL(15) = -1
              END IF
            END IF
          END IF
        END IF
C * SPF/RES MODEL PARAMETER FILE
      ELSE IF (ABS(IGBL(8)) == 2 .OR.
     1         ABS(IGBL(8)) == 1) THEN
        IGBL(15) = -1
        FNLU16 = NAMEFIL(1:KNMFIL) //'.hkl'
        INQUIRE (FILE = FNLU16, EXIST = EXST16)
        IF (.NOT. EXST16) THEN
          FNLU16 = NAMEFIL(1:KNMFIL) //'.HKL'
          INQUIRE (FILE = FNLU16, EXIST = EXST16)
          IF (.NOT. EXST16) THEN
            FNLU16 = NAMEFIL(1:KNMFIL) //'.fcf'
            INQUIRE (FILE = FNLU16, EXIST = EXST16)
            IF (.NOT. EXST16) THEN
              FNLU16 = NAMEFIL(1:KNMFIL) //'.FCF'
              INQUIRE (FILE = FNLU16, EXIST = EXST16)
              IF (.NOT. EXST16) THEN
C * NO REFLECTION DATA FOUND
                IGBL(15) = -1
              ELSE
                IGBL(15) = 1
              END IF
            ELSE
              IGBL(15) = 1
            END IF
          ELSE
            IGBL(15) = 0
          END IF
        ELSE
          IGBL(15) = 0
        END IF
      ELSE
        IGBL(15) = -1
      END IF
C * OPEN & DETERMINE REFLECTION FILE TYPE
      IF (IGBL(15) >= 0) THEN
        OPEN (UNIT = LU16, FILE = FNLU16, STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST == 0) THEN
          WRITE (LU6, 99999) FNLU16
C * DETERMINE
          CALL PLA009
C * DETERMINE MODEL & REFLECTION DATA COMBINATIONS
 
C * RES FILE
          IF (IABS (IGBL(8)) == 2) THEN
C * HKL FILE
            IF (IABS (IGBL(9)) == 0) THEN
              IGBL(29) = -1
C * FCF FILE (LIST 4)
            ELSE IF (IABS (IGBL(9)) == 1) THEN
              IGBL(29) = -2
            END IF
C * CIF FILE
          ELSE IF (IABS (IGBL(8)) == 3) THEN
C * FCF FILE (LIST 4)
            IF (IABS (IGBL(9)) == 1) THEN
              IGBL(29) = 1
C * FCF FILE (LIST 6)
            ELSE IF (IABS (IGBL(9)) == 23) THEN
              IGBL(29) = 2
C * FCF FILE (LIST 8)
            ELSE IF (IABS (IGBL(9)) == 25) THEN
              IGBL(29) = 3
            END IF
          END IF
        ELSE
          IGBL(15) = -1
        END IF
      END IF
      RETURN
99999 FORMAT (':: Reflection Data from: ', A)
      END SUBROUTINE PLA008
 
      SUBROUTINE PLA009
C * DETERMINE REFLECTION FILE TYPE (2)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE mentry
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      INTEGER :: N
      INTEGER :: M
      INTEGER :: IH = 0
      INTEGER :: IK = 0
      INTEGER :: IL = 0
      INTEGER :: NC
      INTEGER :: IER
      INTEGER :: NCR
      INTEGER :: NHASH
      INTEGER :: ILMAX
      INTEGER :: IRTYPE
      INTEGER :: NENTRY
C * IGBL(9)  = -1 : HKL-EXT (CONTAINING SQUEEZE AND ORIGINAL Iobs)
C *          =  0 : HKL              (SHELXL HKLF 4 STYLE)
      IF (IGBL(15) == 0) THEN
C * HANDLE NAG COMPILER ISSUE WITH DUMMY USE OF IH,IK,IL
        N = IH + IK + IL
        N = 0
        DO I = 1, 10
          READ (LU16, 99999, IOSTAT = IOST) PRBUF
          READ (PRBUF, 99998, IOSTAT = IOST) IH, IK, IL
          IF (IOST /= 0) THEN
            IF (INDEX (PRBUF, 'CRYSTALS') > 0) THEN
              IGBL(15) = 0
              N        = -2
              EXIT
            END IF
            IGBL(15) = 1
          END IF
        END DO
      END IF
      REWIND (LU16)
      READ (LU16, 99999, IOSTAT = IOST) PRBUF
      IF (IGBL(15) == 0) THEN
C * DETERMINE SHORT/LONG HKLF RECORD
        IF (PRBUF(88:88) /= ' ') N = -1
        IENTRY(1, 3) = N
        IRTYPE       = N
C * FIND OUT ABOUT DIRECTION COSINES, ABS PSI or NONE
        IGBL(37) = 0
        DO K = 1, 48
          IF (PRBUF(81 - K:81 - K) /= ' ' .AND.
     1        PRBUF(81 - K:81 - K) /= CHAR (13)) THEN
            IF (K < 10) THEN
              IGBL(37) = 1
              RETURN
            ELSE
              IGBL(37) = 2
              RETURN
            END IF
          END IF
        END DO
      END IF
C * FCF
      IF (IGBL(15) == 1) THEN
C * Determine Reflection File type
        IER    = 0
        IRTYPE = 0
        NENTRY = 0
        CALL GEN108 (LU16, 0)
C * COUNT NUMBER OF ENTRIES IN FCF-FILE
        OPEN (UNIT = LU63, STATUS = 'SCRATCH', FORM = 'FORMATTED',
     1    IOSTAT = IOST)
C * COUNT RECORDS
        M  = 0
        NC = 0
        DO
          READ (LU16, 99999, IOSTAT = IOST) PRBUF
          IF (IOST /= 0) EXIT
          M  = M  + 1
          NC = NC + 1
          IF (NC == 100) THEN
            IF (NENTRY > 0) THEN
              REWIND LU63
              CALL PLA010 (LU63, IRTYPE, IER)
              IENTRY(NENTRY, 3) = IRTYPE
            END IF
          END IF
          WRITE (LU63, 99999, IOSTAT = IOST) PRBUF
          N = INDEX (PRBUF, 'data_')
          IF (N /= 0) THEN
            REWIND (UNIT = LU63, IOSTAT = IOST)
            NC = 0
C * REMOVE CHAR(13)
            NCR = INDEX (PRBUF, CHAR (13))
            IF (NCR /= 0) PRBUF(NCR:NCR) = CHAR (32)
C * CHECK FOR COMMENT #
            NHASH = INDEX (PRBUF, '#')
            IF (NHASH == 0 .OR. NHASH > N + 15) THEN
              IGBL(126) = IGBL(126) + 1
              IF (IABS (IGBL(8)) == 3) THEN
                ILMAX = MIN (IGBL(100), NP54)
                DO I = 1, ILMAX
C * SUBSTITUTE FORWARD SLASH FOR A BACKWARD SLASH
                  CALL GEN151 (PRBUF, N + 5)
                  IF (CENTRY(I)(1:75) == PRBUF(N + 5:N + 79)) THEN
                    NENTRY            = I
                    IENTRY(NENTRY, 4) = M
                  END IF
                END DO
              ELSE IF (IGBL(100) == 1) THEN
                NENTRY       = 1
                IENTRY(1, 4) = M
              END IF
            END IF
          END IF
        END DO
        CLOSE (UNIT = LU63, IOSTAT = IOST)
      END IF
      CALL GEN108 (LU16, 0)
      IGBL(9) = IENTRY(1, 3)
      RETURN
99999 FORMAT (A)
99998 FORMAT (3I4)
      END SUBROUTINE PLA009
 
      SUBROUTINE PLA010 (LU, IRTYPE, IER)
C * Determine Reflection File type
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: LU
      INTEGER :: IER
      INTEGER :: NSQ
      INTEGER :: IOST
      INTEGER :: IRTYPE
C * TRY 'SHELXL', 'CRYSTALS', 'NRCVAX', TEXSAN AND 'MOLEN' FCF VARIETIES
C *
C * IGBL(9)  = -1 : HKL-EXT
C *          =  0 : HKL              (SHELXL HKLF 4 STYLE)
C *          =  1 : SHELXL LIST 4
C *          =  2 : XTAL-F
C *          =  3 : NRCVAX
C *          =  4 : MOLEN
C *          =  5 : CRYSTALS(F)  [CRYSTL1]
C *          =  6 : TEXSAN1
C *          =  7 : MOLEN1
C *          =  8 : CRYSTALS(I)
C *          =  9 : JANA2 (F**2)
C *          = 10 : TEXSAN2
C *          = 11 : XD
C *          = 12 : RAELS
C *          = 13 : TEXSAN3
C *          = 14 : JANA1 (F)
C *          = 15 : CrystalStructure (RIGAKU)
C *          = 16 : JANA3 (F**2)
C *          = 17 : CRYSTALS(I,TWIN)
C *          = 18 : CRYSTALS (I) Incl/excl
C *          = 21 : SHELXL LIST3
C *          = 22 : SHELXL LIST5
C *          = 23 : SHELXL LIST6
C *          = 24 : SHELXL LIST7
C *          = 25 : SHELXL LIST8
C *          = 26 : REALS(F)
C *          = 27 : JANA-TWIN
C *
C * LOOK IN FIRST 100 RECORDS TO DETECT FCF VARIETY
      DO I = 1, 100
        READ (LU, 99999, IOSTAT = IOST) PRBUF
        IF (IOST == 0) THEN
C * SHELXL STYLE FCF
          IF (INDEX (PRBUF, '_shelx_refln_list_code') /= 0) THEN
C * LIST 3
            IF (INDEX (PRBUF, '3') /= 0) THEN
              IRTYPE  = 21
              EXIT
C * LIST 4
            ELSE IF (INDEX (PRBUF, '4') /= 0) THEN
              IRTYPE   =  1
              IGBL(37) = -1
              DO J = 1, 25
                READ (LU, 99999, IOSTAT = IOST) PRBUF
                IF (IOST /= 0) EXIT
C * LIST 4, JANA-TWIN
                IF (INDEX (PRBUF, '_twin_refln_datum_id') /= 0) THEN
                  IRTYPE  = 27
                  EXIT
                END IF
              END DO
              EXIT
C * LIST 5
            ELSE IF (INDEX (PRBUF, '5') /= 0) THEN
              IRTYPE  = 22
              EXIT
C * LIST 6
            ELSE IF (INDEX (PRBUF, '6') /= 0) THEN
              IRTYPE  = 23
              EXIT
C * LIST 8
            ELSE IF (INDEX (PRBUF, '8') /= 0) THEN
              IRTYPE  = 25
              EXIT
            END IF
C * JANA2 (F^2) - SEMI LIST 4
          ELSE IF (INDEX (PRBUF, '_cell_length_a') /= 0) THEN
            IF (IRTYPE /= 5) THEN
              IRTYPE   =  1
              IGBL(37) = -1
            END IF
C * SHELXL - LIST 7
          ELSE IF (INDEX (PRBUF, '_refln_F_squared_calc_comp1')
     1      /= 0) THEN
            IRTYPE  = 24
C * TEST FOR NRCVAX
          ELSE IF (PRBUF(1:11) == '# h,k,l, Fo') THEN
            IRTYPE   = 3
            IGBL(37) = -1
C * TEST FOR MOLEN
          ELSE IF (PRBUF(1:13) == '# h,k,l, 10*F') THEN
            IRTYPE   = 4
            IGBL(37) = -1
C * TEST FOR CRYSTALS(F)
          ELSE IF (INDEX (PRBUF, 'CRYSTALS') /= 0) THEN
            IRTYPE   = 5
            IGBL(37) = -1
C * TEST FOR TEXSAN1 & TEXSAN3
          ELSE IF (PRBUF(1:11) == '# h,k,l, Fc') THEN
            IF (PRBUF(12:19) == '-squared') THEN
              IRTYPE   = 13
              IGBL(37) = -1
C * TEXSAN1
            ELSE
              IRTYPE  = 6
              IGBL(37) = -1
            END IF
C * JANA3
          ELSE IF (INDEX (PRBUF, 'STRUCTURE-FACTOR') /= 0) THEN
            IRTYPE   = 16
            IGBL(37) = -1
            EXIT
C * TEST FOR JANA (F**2)
          ELSE IF (INDEX (PRBUF, '_refln_intensity_meas') /= 0) THEN
            IRTYPE  = 9
            IGBL(37) = -1
C * TEST FOR XD
          ELSE IF (INDEX (PRBUF, '_refln_XD_refine_code') /= 0) THEN
            IRTYPE   = 11
            IGBL(37) = -1
            PAR(498) = 0.3333
C * TEST FOR CRYSTALSTRUCTURE (RIGAKU)
          ELSE IF (INDEX (PRBUF, 'CrystalStructure') /= 0) THEN
            IRTYPE   = 15
            IGBL(37) = -1
C * TEST FOR CRYSTALS(I)
          ELSE IF (INDEX (PRBUF, '_refln_F_squared') /= 0) THEN
            IF (IRTYPE == 5) THEN
               IRTYPE   = 8
               IGBL(37) = -1
            END IF
C * TEST FOR CRYSTALS (I) TWIN
          ELSE IF (INDEX (PRBUF, '_twin_refln_') /= 0) THEN
            IF (IRTYPE == 5 .OR. IRTYPE == 8) THEN
              IRTYPE = 17
              IGBL(37) = -1
            END IF
C * TEST FOR CRYSTALS(I) + INCL/EXCL
          ELSE IF (INDEX (PRBUF, '_refln_refinement_status')
     1      /= 0) THEN
            IF (IRTYPE == 8) THEN
              IRTYPE   = 18
              IGBL(37) = -1
            ELSE IF (IRTYPE == 5) THEN
              IPR(769) = 1
            END IF
          END IF
        END IF
      END DO
C * NEW ATTEMPT
      IF (IRTYPE == 0) THEN
        CALL GEN108 (LU, 0)
        DO
          READ (LU, 99999, IOSTAT = IOST) PRBUF
          IF (IOST /= 0) THEN
            IER = 1
            RETURN
          END IF
          IF (PRBUF(1:5) == '     ') CYCLE
          IF (PRBUF(1:5) == 'data_') CYCLE
C * TRY TEXSAN1, 2  & 3, MOLEN1, XTAL-F & RAELS
          IF (INDEX(PRBUF, 'loop_') /= 0)  THEN
            NSQ = 0
            DO I = 1, 25
              READ (LU, 99999, IOSTAT = IOST) PRBUF
              IF (IOST /= 0) THEN
                IER = 1
                RETURN
              END IF
              IF (INDEX (PRBUF, 'squared') /= 0) NSQ = 1
              IF (PRBUF(23:23) == '.') THEN
C * TEXSAN3
                IF (NSQ == 1) THEN
                  IRTYPE = 13
                  RETURN
C * TEXSAN1
                ELSE
                  IRTYPE = 6
                  RETURN
                END IF
C * TEXSAN2
              ELSE IF (PRBUF(22:22) == '.') THEN
                IRTYPE = 10
                RETURN
              ELSE IF (PRBUF(18:18) == '.') THEN
C * REALS
                IF (PRBUF(34:34) == '.') THEN
                  IRTYPE = 12
                  RETURN
C * MOLEN1
                ELSE
                  IRTYPE = 7
                  RETURN
                END IF
C * TEST FOR JANA1 (3I4,3F10.2)
              ELSE IF (PRBUF(20:20) == '.') THEN
                IRTYPE = 14
                RETURN
              END IF
            END DO
            IRTYPE = 2
          END IF
        END DO
      END IF
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA010
 
      SUBROUTINE PLA011 (X, Y, Z)
C * MAIN MENU DATA ENTRY  (NH, NV)
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE cchar
      USE menus
      IMPLICIT NONE
      INTEGER :: NH
      INTEGER :: NV
      REAL    :: X
      REAL    :: Y
      REAL    :: Z
      REAL    :: SIZ
      REAL    :: XHORS
      REAL    :: YVERT
C * CHECK FOR NEW PLATON SOURCE/EXECUTABLE
      CALL PLA210 (X, Y)
C * MAIN MENU (NH & NV)
      SIZ = HORS / 63.0
C * NO ENTRY LISTING
      IF (IPR(462) == 0) THEN
C * CHECK FOR NO-ATOMS & NO-FACES AND NO-CELL
        IF (IPR(37) /= 0 .OR. IPR(367) /= 0 .OR.
     1      PAR(101) > 1.0) THEN
          NH = INT (7.0 * X / HORS) + 1
          IF (NH < 1 .OR. NH > 7) THEN
            LRET = -1
            RETURN
          ENDIF
          NV = INT ((Y - 5.0) * NP46 / 11.0)
          IF (NV < 0 .OR. NV > NP46) THEN
            NH = 7
            NV = NP46 + 1
          END IF
        ELSE
          NH = 7
          NV = NP46 + 1
        END IF
C * HELP
        IF (NV == NP46 + 1) THEN
          IF ((VERT - Y) < 1.0) THEN
            IF (X < 10.0) THEN
              CALL PLA300 (1, 1, NV)
            ELSE IF (X > 10.0 .AND. X < 20.0) THEN
              CALL PLA300 (1, 2, NV)
            ELSE
              CALL PLA300 (1, 0, NV)
            END IF
          END IF
          LRET = -1
          RETURN
C * RIGHT-BUTTON (#3) MOUSE CLICK
        ELSE IF (NINT (Z) == 3) THEN
          CALL PLA300 (1, NH, NV)
          LRET = -1
          RETURN
        END IF
C * CHECK FOR REFLECTION DATA REQUIRED & PRESENT
        IF (NV > 0 .AND. NV <= NP46) THEN
C * CIF2SHELX
          IF (NV == 15 .AND. NH == 7 .AND.
     1      (IPR(664) /= 0 .OR. IPR(321) /= 0)) THEN
C * HYBRID:
          ELSE IF (NV == 4 .AND. NH == 3 .AND. IGBL(110) > 0
     1       .AND. IPR(663) /= 0 .AND. IPR(664) /= 0 .AND.
     2       IGBL(29) /= 0) THEN
          ELSE
            IF ((IOPT(NH, NV) > 1 .AND. IGBL(15) < 0) .OR.
     1         (IOPT(NH, NV) == 3 .AND. IGBL(15) == 0 .AND.
     2          IGBL(9) == 0)) THEN
              CALL PLA015 (427, 7)
              LRET = -1
              RETURN
            END IF
          END IF
        ELSE
          LRET = -1
          RETURN
        END IF
        YVERT = VERT - NV * 11.0 / NP46 - 5.7
        XHORS = 9 * SIZ * (NH - 1) + 0.1
        CALL PLA439 (0.0,  OPTS(NH, NV), 10, SIZ, 2, 2, XHORS, YVERT)
C * SELECT FROM MAIN MENU
C * NH = 1 - GRAPHICS TOOLS
        SELECT CASE (NH)
          CASE (1)
            SELECT CASE (NV)
C * NV = 1 - PLUTON (VIA PLATON)
              CASE (1)
C * SET MENU #
                IGBL(6)  = 1
C * SET PLOT AS DEFAULT
                IGBL(24) = 1
C * DO NOT ROUND
                IPR(68)  = 0
C * NO R/S DETERMINATION
                IPR(324) = 0
C * NO NONSYM
                IPR(495) = 0
                CALL PLA280 ('PLUTON')
C * NV = 2 - ORTEP
              CASE (2)
                IGBL(3) = 3
                IGBL(6) = 1
C * NO R/S DETERMINATION
                IPR(324) = 0
                CALL PLA280 ('PLOT ADP COLOR')
C * NV = 3 - NEWMAN
              CASE (3)
                CALL PLA280 ('PLOT NEWMAN COLOR')
C * NV = 4 - PLOT-RING
              CASE (4)
                CALL PLA280 ('PLOT RING COLOR')
                IGBL(6) = 13
C * NV = 5 - PLOT PLAN/RING/LSPL/RESD
              CASE (5)
                CALL PLA280 ('PLOT PLAN COLOR')
                IGBL(6) = 13
C * NV = 6
              CASE (6)
                IGBL(6) = 30
                CALL PLA280 ('PLOT POLY')
C * NV = 7
              CASE (7)
                IGBL(6) = 9
                CALL PLA280 ('CONTOUR DI')
C * NV = 8
              CASE (8)
                IGBL(6) = 9
                CALL PLA280 ('CONTOUR FO')
C * NV = 9 - AUTOMOLFIT
              CASE (9)
                CALL PLA280 ('FIT')
C * NV = 10 - HKL2Powder Plot
              CASE (10)
                CALL PLA280 ('POWDER IOBS')
C * NV = 11 - SimPowder Plot
              CASE (11)
                CALL PLA280 ('POWDER')
C * NV = 12 - CALC RDF
              CASE (12)
                CALL PLA280 ('CALC RDF')
C * NV = 13 - PATTERSON
              CASE (13)
                CALL PLA280 ('SETUP PATT')
C * NV = 14 - SHELXT/PLUTON-PLOT RUN
              CASE (14)
                CALL PLA280 ('XTPLOT')
C * NV = 15 -
              CASE (15)
C * NV = 16 -
              CASE (16)
                CALL PLA280 ('WILSON')
C * NV = 17 - To PLUTON
              CASE (17)
                IGBL(3)  = 8
                IGBL(6)  = 2
                IGBL(24) = 1
                IGBL(75) = 0
                CALL PLA280 ('PLUTON NATIVE')
                LRET = 3
            END SELECT
C * NH = 2 - GEOM TOOLS
          CASE (2)
              SELECT CASE (NV)
C * NV = 1
              CASE (1)
                IGBL(70) = 1
                CALL PLA280 ('CALC')
C * NV = 2
              CASE (2)
                CALL PLA280 ('CALC INTRA')
C * NV = 3
              CASE (3)
                CALL PLA280 ('CALC INTER')
C * NV = 4
              CASE (4)
                CALL PLA280 ('CALC COORDN')
C * NV = 5
              CASE (5)
                CALL PLA280 ('CALC METAL')
C * NV = 6
              CASE (6)
                CALL PLA280 ('CALC GEOM')
C * NV = 7
              CASE (7)
                CALL PLA280 ('CALC HBONDS')
C * NV = 8
              CASE (8)
                CALL PLA280 ('CALC TMA')
C * NV = 9 - LSPL
              CASE (9)
                IPR(460) = 1
                CALL PLA280 ('PLOT ADP COLOR')
C * NV = 10 - DIHEDRAL ANGLE
              CASE (10)
                IPR(551) = 1
                CALL PLA280 ('PLOT ADP COLOR')
C * NV = 11 - ANGLE BETWEEN 2 LINES
              CASE (11)
                IPR(341) = 5
                CALL PLA280 ('PLOT ADP COLOR')
C * NV = 12 - ANGLE BETWEEN LSPL AND LINE
              CASE (12)
                IPR(551) = 1
                CALL PLA280 ('PLOT ADP COLOR')
C * NV = 13 - RING CREMER & POPLE
              CASE (13)
                CALL PLA280 ('PLOT RING COLOR')
                IGBL(6) = 13
C * NV = 14 - BondValence
              CASE (14)
                IGBL(121) = 1
                CALL PLA280 ('CALC COORDN NOANG 4.0')
C * NV = 15 - Volcal
              CASE (15)
                IGBL(144) = 1
                CALL PLA280 ('CALC COORDN')
C * NV = 16 - R/S-CIP
              CASE (16)
                CALL PLA280 ('CIP')
C * NV = 17 - MolVolume
              CASE (17)
                CALL PLA280 ('MOLV')
            END SELECT
C * NH = 3
          CASE (3)
            SELECT CASE (NV)
C * NV = 1 - REPORT SOLVENT ACCESSIBLE VOIDS
              CASE (1)
                CALL PLA280 ('CALC SOLV')
C * NV = 2 - MORE DETAILED SOLVENT ACCESSIBLE VOID CALCULATION (+ PACKING INDEX)
              CASE (2)
                CALL PLA280 ('CALC VOID')
C * NV = 3 - RUN SQUEEZE
              CASE (3)
                CALL PLA280 ('CALC SQUEEZE')
C * NV = 4
              CASE (4)
                CALL PLA280 ('HYBRID')
C * NV = 5 - GENERATE FCF-CIF FROM COORDINATE DATA
              CASE (5)
                IF (IGBL(9) == -1) THEN
                  CALL PLA280 ('CALC FCF')
                ELSE
                  LRET = -1
                  RETURN
                END IF
C * NV = 6 - CONTOURED SQUEEZE MAP
              CASE (6)
                IF (IGBL(9) == -1 .OR. IPR(665) /= 0) THEN
                  IGBL(6)  = 9
                  IPR(515) = 0
                  CALL PLA280 ('CONTOUR SQ')
                ELSE
                  LRET = -1
                  RETURN
                END IF
C * NV = 7 - Solve F3D
              CASE (7)
                CALL PLA280 ('CALC SOLV GRID 0.35 F3D')
C * NV = 8
              CASE (8)
                CALL PLA280 ('CALC SOLV PLOT')
C * NV = 9
              CASE (9)
                CALL PLA280 ('CAVITY')
C * NV = 10 - (Solvent) Accessible Surface Area Calculation
              CASE (10)
                CALL PLA280 ('SASA')
C * NV = 11
              CASE (11)
                CALL PLA280 ('FLIP MENU')
C * NV = 12
              CASE (12)
                CALL PLA280 ('FLIP PATT SHOW')
C * NV = 13 - CHARGE FLIPPING FROM ZERO PHASES
              CASE (13)
                CALL PLA280 ('FLIP 1 5000')
C * NV = 14 - CHARGE FLIPPING
              CASE (14)
                CALL PLA280 ('FLIP')
C * NV = 15 - STRUCTURE?
              CASE (15)
                CALL PLA280 ('STRUCTURE')
C * NV = 16 -
              CASE (16)
C * NV = 17 -
              CASE (17)
            END SELECT
C * NH = 4
          CASE (4)
              SELECT CASE (NV)
C * NV = 1 - ADDSYM
              CASE (1)
                IPR(324)  = 0
C * NO EXPAND
                IGBL(136) = 1
                CALL PLA280 ('CALC ADDSYM')
C * NV = 2 - ADDSYM EQUAL
              CASE (2)
C * NO R/S CALC
                IPR(324)  = 0
C * NO EXPAND
                IGBL(136) = 1
                CALL PLA280 ('CALC ADDSYM EQUAL')
C * NV = 3 - ADDSYM EXACT
              CASE (3)
C * NO R/S CALC
                IPR(324)  = 0
C * NO EXPAND
                IGBL(136) = 1
                CALL PLA280 ('CALC ADDSYM EXACT')
C * NV = 4 - ADDSYM PLOT
              CASE (4)
C * NO R/S CALC
                IPR(324) = 0
                CALL PLA280 ('CALC ADDSYM PLOT')
C * NV = 5 - ADDSYM SHELX
              CASE (5)
C * NO R/S CALC
                IPR(324)  = 0
C * NO EXPAND
                IGBL(136) = 1
                CALL PLA280 ('CALC ADDSYM SHELX NOSF')
C * NV = 6 - NEWSYM
              CASE (6)
                CALL PLA280 ('CALC NEWSYM')
C * NV = 7 - NONSYM
              CASE (7)
                CALL PLA280 ('CALC NONSYM')
C * NV = 8 - LEPAGE
              CASE (8)
                CALL PLA280 ('LEPAGE')
C * NV = 9 - DELRED
              CASE (9)
                CALL PLA280 ('DELRED')
C * NV = 10 - MOLSYM
              CASE (10)
                CALL PLA280 ('CALC MOLSYM')
C * NV = 11 - DETERMINE SPGR FROM EXTINCTIONS
              CASE (11)
                CALL PLA280 ('SPGR')
C * NV = 12 - ASYM
              CASE (12)
                CALL PLA280 ('ASYM')
C * NV = 13 - ASYM AVF
              CASE (13)
                CALL PLA280 ('ASYM AVF')
C * NV = 14 - LEPAGE-TWIN
              CASE (14)
                CALL PLA280 ('LEPAGE 0.0 6')
C * NV = 15
              CASE (15)
C * NV = 16
              CASE (16)
C * NV = 17 - TWINROTMAT FROM (CIF+)FCF
              CASE (17)
                CALL PLA280 ('ROTMAT')
            END SELECT
C * NH = 5
          CASE (5)
            SELECT CASE (NV)
C * NV = 1 - MULABS
              CASE (1)
                CALL PLA280 ('MULABS')
                IGBL(6) = 16
C * NV = 2 - ABS-PSI
              CASE (2)
                CALL PLA280 ('ABSP')
C * NV = 3 - ABS-TOMPA
              CASE(3)
                CALL PLA280 ('ABST')
C * NV = 4 - ABS-GAUSS
              CASE (4)
                CALL PLA280 ('ABSG')
C * NV = 5
              CASE (5)
                CALL PLA280 ('ABSX')
C * NV = 6
              CASE (6)
                CALL PLA280 ('ABSS')
C * NV = 7
              CASE (7)
                CALL PLA280 ('SHXABS')
C * NV = 8 - Calculate Anomalous Dispersion f' and f''
              CASE (8)
                BCD = 'ENTER: ''ANOM ElementName Wavelength'' or '//
     1           '''ANOM wavelength'' or ''ANOM ElementName'''//CHAR (0)
                CALL GGIP (-999.0, 2.0, 85.0, 111)
C * NV = 9 - Anom Disp Plot
              CASE (9)
                CALL PLA280 ('ANOM')
C * NV = 10 - Mu-Plot
              CASE (10)
                CALL PLA280 ('MU')
C * NV = 11
              CASE (11)
C * NV = 12
              CASE (12)
C * NV = 13
              CASE (13)
C * NV = 14 - ANGLE BETWEEN CRYSTAL PLANES
              CASE (14)
                BCD = 'ENTER: ANGLE h1 k1 l1 h2 k2 l2'//CHAR (0)
                CALL GGIP (-999.0, 2.0, 80.0, 111)
C * NV = 15 - XTAL HABIT DISPLAY
              CASE (15)
                CALL PLA280 ('XTAL')
C * NV = 16 -
              CASE (16)
C * NV = 17 -
              CASE (17)
            END SELECT
C * NH = 6
          CASE (6)
            SELECT CASE (NV)
C * NV = 1 - CIF/FCF-VALIDATION
              CASE (1)
                IF (IABS (IGBL(8)) /= 3 .OR. IPR(30) /= 0) THEN
                  LRET = -1
                  RETURN
                END IF
                IGBL(83) = -1
                IGBL(66) = 1
                IGBL(3)  = 1
                LU6      = LU20
                CALL PLA280 ('VALI')
C * NV = 2
              CASE (2)
                CALL PLA280 ('ASYM AVF VIEW')
                IGBL(6) = 14
C * NV = 3 - FCF - VALIDATION
              CASE (3)
C * SET CHECK MODE
                IGBL(36) = 1
C * SET FCF VALID
                IPR(734) = 1
                CALL PLA280 ('ASYM AVF VALID')
C * NV = 4 - CALCULATE/ ANALYSE DIFFERENCE MAP
              CASE (4)
                CALL PLA280 ('CALC DIFF')
C * NV = 5 - ANALYSIS-OF-VARIANCE
              CASE (5)
                IF (IGBL(9) >= 1 .AND. IGBL(9) < 28) THEN
C * SET SIDE MENU NUMBER
                  IGBL(6) = 32
                  CALL PLA280 ('VARIANCE')
                ELSE
                  LRET = -1
                  RETURN
                END IF
C * NV = 6 - BIJVOET-PAIR ANALYSIS
              CASE (6)
                CALL PLA280 ('BIJVOET 1 1 1 1 0.0')
C * NV = 7 - FIND EXPECTED NUMBER OF REFLECTIONS FOR GIVEN THETAMAX
              CASE (7)
                CALL PLA280 ('ASYM EXPECT')
C * NV = 8
              CASE (8)
                CALL PLA280 ('ASYM VALID')
C * NV = 9 - SUPPLEMENTARY MATERIAL
              CASE (9)
                CALL PLA280 ('TABLE SUP')
C * NV = 10 - EXPECT
              CASE (10)
                CALL PLA280 ('EXPT')
C * NV = 11 - CSD-CELL
              CASE (11)
                CALL PLA294 (1)
                CALL PLA280 ('RESTART')
                LRET = -1
                RETURN
C * NV = 12 - CSD-QUEST
              CASE (12)
                CALL PLA280 ('CALC GEOM CSD')
C * NV = 13 - STIDY
              CASE (13)
                CALL PLA280 ('STIDY')
C * NV = 14 - CALC STRAIN
              CASE (14)
                CALL PLA280 ('STRAIN')
C * NV = 15 -
              CASE (15)
C * NV = 15 - CIF-LOCAL
C * NV = 16 -
              CASE (16)
C * NV = 17 -
              CASE (17)
            END SELECT
C * NH = 7 - MISC-TOOLS
          CASE (7)
            SELECT CASE (NV)
C * NV = 1 -SYSTEM-S
              CASE (1)
                IF (.NOT. DOS) THEN
                  CALL PLA280 ('SYST')
                ELSE
                  WRITE (LINE, 99997)
                  CALL PRINTX (LU6, LINE, 1, 0)
                END IF
C * NV = 2 - EXPAND TO P1
              CASE (2)
                CALL PLA280 ('FCF2HKL')
C * NV = 3 - Expand coordinate set to P1
              CASE (3)
                CALL PLA280 ('EXP1')
C * NV = 4
              CASE (4)
                CALL PLA280 ('CALC FCF GENER')
C * NV = 5
              CASE (5)
                CALL PLA280 ('ASYM GENERATE')
C * NV = 6
              CASE (6)
                CALL PLA280 ('HKLTRANS')
C * NV = 7
              CASE (7)
                CALL PLA280 ('EXOR')
C * NV = 8 - SELECTIVE ANIS /RES
              CASE (8)
C * CHECK FOR RES STYLE DATA
                IF (IABS(IGBL(8)) == 2) THEN
                  IGBL(3) = 26
                  CALL PLA280 ('PLUTON')
                END IF
C * NV = 9 - RENAME - RES ONLY
              CASE (9)
                CALL PLA280 ('RENAME')
C * NV = 10 - AUTO-RENUMBER
              CASE (10)
                IGBL(3) = 27
                CALL PLA280 ('CALC GEOM RENUM SHELX NOSF')
C * NV = 11 - CREATE SPF
              CASE (11)
                IPR(675) = 1
                CALL PLA280 ('CALC SPF')
C * NV = 12 - CREATE SHELXL-res
              CASE (12)
                IPR(675) = 1
                CALL PLA280 ('CALC SHELX NOSF')
C * NV = 13 - CREATE CIF-ACC
              CASE (13)
                CALL PLA280 ('TABL ACC')
C * NV = 14 - CREATE PDB-pdb
              CASE (14)
                IPR(675) = 1
                CALL PLA280 ('CALC PDB EXPAND')
C * NV = 15 - HFIX
              CASE (15)
C * CHECK FOR RES STYLE FILE
                IF (IABS (IGBL(8)) == 2) THEN
                  IGBL(3) = 13
                  CALL PLA280 ('PLUTON')
                ELSE
                  CALL PLA015 (427, 30)
                  LRET = -1
                  RETURN
                END IF
C * NV = 16 - CREATE FCF FROM SHELXL201x CIF
              CASE (16)
                CALL PLA280 ('FCF')
C * NV = 17 - CIF2SHELXL
              CASE (17)
                CALL PLA280 ('CIF2SHELXL')
            END SELECT
        END SELECT
        IF (IGGT(1:1) == ' ') THEN
          LRET = -1
          RETURN
        END IF
        LRET = 2
        RETURN
C * ENTRY LIST
      ELSE IF (IPR(462) == 1) THEN
        NH = INT (6 * X / (RGBL(1) * RGBL(2)))
        NV = INT (43 * Y / RGBL(1)) + 1
        WRITE (IGGT, 99999, IOSTAT = IOST)
     1    INT((IGBL(100) - 1) / 258) * 258 + NH * 43 + NV
      END IF
      RETURN
99999 FORMAT (I6.6)
99997 FORMAT ('** Sorry, System S is not available in the ',
     1  'MS-Windows version **')
      END SUBROUTINE PLA011
 
      SUBROUTINE PLA012 (MSBCD, MUPCASE)
C * MENU - WHAT NEXT ?
      USE files
      USE parameters
      USE xwdw
      USE cggt
      IMPLICIT NONE
      INTEGER :: IVENT
      INTEGER :: MMODE
      INTEGER :: MSBCD       ! SUGGESTED CONTINUE MESSAGE
      INTEGER :: MUPCASE
      REAL    :: X
      REAL    :: Y
      REAL    :: Z
      REAL    :: ZZ
      MMODE = 0
      LRET  = 0
C * TEST FOR MENU = ON
      IF (IGBL(25) == 1) THEN
        IF (MSBCD == -1) THEN
          SBCD = 'Implement new Sublattice ? (y/n[N])'//CHAR (0)
        ELSE IF (MSBCD == -2) THEN
          SBCD = 'Implement CALC ADDSYM EXACT Mode ? (y/n[Y])'//CHAR (0)
C * SPECIAL DEFAULT ANSWERS FOR PLUTON/S-MODE
        ELSE IF (MSBCD == 1) THEN
          SBCD = 'Continue (Y/N[Y])'//CHAR (0)
        ELSE IF (MSBCD == 2) THEN
          SBCD = 'Hit RETURN to Continue'//CHAR (0)
        ELSE IF (MSBCD == 3) THEN
          SBCD = 'Enter # of ENTRY or Continue (Y/N[Y])'//CHAR (0)
        ELSE IF (MSBCD == 4) THEN
          SBCD = '[NEXT]'//CHAR (0)
        ELSE IF (MSBCD == 5) THEN
          SBCD = '[CALC]'//CHAR (0)
        END IF
C * IPR(308) - CR
C * IPR(332) - HFIX   (PLUTON)
C * IPR(335) - RENAME (PLUTON)
C * IPR(351) - DELETE (PLUTON)
C * IPR(352) - ANIS   (PLUTON)
C * IGBL(3)  - Shortcuts 12=RENAME,13=HFIX,26=ANIS
        IF (IPR(308) ==  1 .AND. IPR(332) ==  0 .AND.
     1      IPR(335) ==  0 .AND. IPR(351) ==  0 .AND.
     2      IPR(352) ==  0 .AND. IGBL(3)  /= 12 .AND.
     3      IGBL(3)  /= 13 .AND. IGBL(3)  /= 26) THEN
          SBCD = '[END]'//CHAR (0)
C * SPECIAL FOR PLATON/ADP
        ELSE IF (IPR(308) == 2) THEN
          SBCD = '[EXIT]'//CHAR (0)
        END IF
      END IF
C * CHECK FOR CONTROL-C
      ZZ   = 0.0
      LRET = 3
      IF (CC) THEN
        ZZ    = 1.0
        IVENT = 5
      ELSE
C * 'END' Status
        IF (IPR(460) == 3 .AND. IPR(551) == 3) THEN
          LMOD  = 0
          CALL PLA015 (-1, 0)
        END IF
C * MAIN EVENT LOOP
        DO
          X = 0.0
          Y = 0.0
          Z = 0.0
C * TEST FOR MENU-ON MODE (IGBL(25) = 1) and X11 (IGBL(32) = 1)
          IF (IGBL(25) * IGBL(32) == 1) THEN
C * SHOW MENU
            MMODE = IGBL(6)
            CALL PLA013
C * TEST FOR SPECIAL HYBRID
            IF (IGBL(48) == 0) THEN
C * WAIT FOR AND NEXT GET EVENT
              IVENT = 5
              CALL GGIP (X, Y, Z, IVENT)
            ELSE
C * SIMULATE EVENT (X = HOR OPTION, Y = VERT OPTION)
              X = 1
              Z = 1
C * RENAME
              IF (IGBL(3) == 12) THEN
                Y = 9
C * HFIX
              ELSE IF (IGBL(3) == 13) THEN
                Y = 15
C * ANIS
              ELSE IF (IGBL(3) == 26) THEN
                X = 2
                Y = 15
              END IF
              IVENT    = 2
              IGBL(48) = 0
            END IF
          ELSE
            IVENT = -1
          END IF
          LRET = 1
C * 'IVENT' VALUE ON RETURN FROM GGIP CAN BE:
C * -1 - NO MOUSE/MENU EVENT
C *  0 - EXPOSE
C *  1 - BOX # 1 - CANVAS       - Tool Listing
C *  2 - BOX # 2 - SIDE-MENU    - Options
C *  3 - BOX # 3 - LOWER LEFT   - Messages, (suggested) instructions)
C *  4 - BOX # 4 - LOWER RIGHT  - Exit & Status display
C *  5 - KEYPRESS
 
          IF (IVENT >= 0) THEN
C * SET META FILE OFF IN MENU-ON MODE
            IF (IGBL(81) == 0) THEN
              MEDIUM      = 2
              IGGT(16:22) = 'OFF    '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
            END IF
C * GENERAL EXPOSE EVENT (TYPE # 0)
          IF (IVENT == 0) IVENT = 2
C * HANDLE KEYPRESS EVENT (# 5)
            IF (IVENT == 5) THEN
C * HANDLE CARRIAGE RETURN REFRESH INSTRUCTIONS
   10         IF (IPR(733) == 1) THEN
                CALL PLA280 ('RESTART')
                IPR(733) = 0
              END IF
              IF (BCD(1:1) == CHAR (13)) THEN
                IF (NCNT == 0) THEN
                  IF (IPR(733) == 1) THEN
                    IPR(733) = 0
                    STRING = 'RESTART'
                    NCNT   = 7
                  ELSE IF (IPR(335) /= 0) THEN
                    STRING = 'RENAME'
                    NCNT   = 6
                  ELSE IF (IPR(332) /= 0) THEN
                    STRING = 'HFIX'
                    NCNT   = 4
                  ELSE IF (IPR(352) /= 0) THEN
                    STRING = 'ANIS'
                    NCNT   = 4
                  ELSE IF (IPR(308) == 1) THEN
                    STRING = 'END '
                    NCNT   = 4
                  ELSE IF (IPR(308) == 2) THEN
                    STRING = 'EXIT'
                    NCNT   = 4
                  ELSE IF (IPR(209) > 0) THEN
                    STRING = 'CALC GEOM SPF'
                    NCNT   = 16
C * ADDSYM/CR
                  ELSE IF (IPR(205) == 1) THEN
                    STRING = 'Y'
                    NCNT   = 1
                  ELSE
                    STRING(1:1) = '!'
                    NCNT = 1
                   END IF
                END IF
                IGBL(5) = LU5
                IF (IPR(308) == 2) THEN
                  CALL GEN020 (1, STRING, 1, 4)
                  IF (STRING(1:3) == 'END') THEN
                    STRING(1:4) = 'EXIT'
                    NCNT = 4
                  END IF
                  IF (STRING(1:4) == 'EXIT') LRET = 7
                END IF
                CALL PLA280 (STRING(1:NCNT))
                NCNT     = 0
                IGBL(24) = 1
                IF (STRING(1:1) /= '!') THEN
                  IF (MMODE == 10 .OR. MMODE == 11 .OR.
     1                MMODE == 12) LRET = 2
                ELSE
                  IF (MMODE == 1) LRET = 3
                END IF
 
C * DELETE CHAR
              ELSE IF (BCD(1:1) == CHAR (8) .OR.
     1                 BCD(1:1) == CHAR (127)) THEN
                IF (NCNT > 0) THEN
                  NCNT = NCNT - 1
                  IF (NCNT == 0) THEN
                    BCD = CHAR(0)
                  ELSE
                    BCD = STRING(1:NCNT)//CHAR (0)
                  END IF
                  SBCD = BCD
                END IF
                LRET = -1
C * CNTR-L, CONVERT TO CR
              ELSE IF (BCD(1:1) == CHAR (12)) THEN
                IF (MMODE == 1) THEN
                  CALL PLA280 ('PLOT')
                ELSE
                  IF (MMODE == 3 .OR. MMODE == 22
     1               .OR. MMODE == 15 .OR. MMODE == 17) LRET = 2
                  BCD(1:1) = CHAR (13)
                  GO TO 10
                END IF
              ELSE IF (BCD(1:1) == CHAR (0)) THEN
                LRET = -1
              ELSE
                IF (NCNT < 80) THEN
                  NCNT = NCNT + 1
                  IF (NCNT >= 75)
     1              WRITE (LU6, 99997, IOSTAT = IOST) NCNT, CHAR (7)
                  STRING(NCNT:NCNT) = BCD(1:1)
                  BCD = STRING(1:NCNT)//CHAR (0)
                  SBCD = BCD
                END IF
                LRET = -1
              END IF
C * GENERAL EXIT BUTTON BOX # 4
            ELSE IF (IVENT == 4) THEN
              CALL PLA280 ('EXIT')
              IF (IGBL(3) == 4) IGBL(3) = 0
C * ORTEP/EXIT
              IF (IGBL(45) == 0 .OR. IGBL(3) == 3) THEN
                IF (MMODE == 1 .OR. MMODE == 8 .OR.
     1              MMODE == 9) LRET = 7
              ELSE
C * EXIT FROM 'SAVE'-LOOP
                IGBL(45) = 0
                CALL PLA280 ('REM')
                IGBL(6) = 10
                CALL GEN108 (LU3, 0)
                WRITE (LU3, 99998, IOSTAT = IOST)
                ENDFILE (LU3, IOSTAT = IOST)
              END IF
C * CONTOUR/EXIT
              IF (MMODE == 22) LRET = 1
              IF (MMODE == 10 .OR. MMODE == 11 .OR.
     1            MMODE == 12 .OR. MMODE == 14) LRET = 2
C * CLICK IN AREA THREE (TYPE # 3)
            ELSE IF (IVENT == 3) THEN
              IF (NINT (Z) == 3) CALL PLA300 (3, 0, 0)
              LRET = -1
C * CLICK IN MENU AREA (TYPE # 2)
            ELSE IF (IVENT == 2) THEN
              IF (NINT (Z) == 3) THEN
                CALL PLA300 (2, 1, NINT (Y))
                LRET = -1
              ELSE
                IGBL(5) = LU5
                CALL PLA016 (NINT (Y), NINT (X))
              END IF
C * GRAPHICS CANVAS EVENT (TYPE # 1)
            ELSE IF (IVENT == 1) THEN
              CALL PLA020 (X, Y, Z)
            END IF
C * NO MOUSE/MENU CASE - RETURN
          ELSE IF (IVENT == -1) THEN
            IGBL(25) = 0
            IF (IGBL(3) == 28 .OR. IGBL(3) == 29 .OR.
     1          IGBL(3) == 31) THEN
              CALL PLA280 ('END')
              LRET = 7
              IGBL(31) = 0
            END IF
          END IF
          IF (LRET /= -1 .OR. IGGT(1:1) == CHAR (12)) EXIT
        END DO
      END IF
      SBCD = CHAR (0)
C * ISSUE AN END OF PICTURE
      XGGIP = 0.0
      YGGIP = 0.0
      CALL GGIP (XGGIP, YGGIP, ZZ, -1)
      IF (IGBL(74) == 1)
     1  WRITE (LU6, 99999, IOSTAT = IOST) LRET, IGGT(1:65)
C * UPPERCASE FOR NON-TEXT INPUT
      IF (MUPCASE > 0) CALL GEN020 (1, IGGT, 1, MUPCASE)
      RETURN
99999 FORMAT ('>> LRET =', I2, ', >>', A)
99998 FORMAT (80X, /)
99997 FORMAT ('Position', I3, A)
      END SUBROUTINE PLA012
 
      SUBROUTINE PLA013
C * MENU - SET SUBMENU OPTIONS
      USE parameters
      USE atomdata
      USE menus
      USE cggt
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: K
      INTEGER             :: L
      INTEGER             :: IWL
      INTEGER             :: MODE
      INTEGER             :: MNS1
      INTEGER             :: MNS2
      REAL                :: CKLEUR
      REAL, DIMENSION(25) :: COLOR
      REAL, DIMENSION(25) :: XMNS
C * MMODE = 1 - PLATON/ORTEP   MAIN MENU
C * MMODE = 2 - PLUTON         MAIN MENU
C * MMODE = 3 - PLUTON/SUP1    MENU
C * MMODE = 4 - PLUTON/SUP2    MENU
C * MMODE = 5 - PLUTON/SUP3    MENU
C * MMODE = 6 - PLUTON/SUP4    MENU
C * MMODE = 7 - PLUTON/SUP5    MENU
C * MMODE = 8 - PLATON/ORTSUP1 MENU
C * MMODE = 9 - PLATON/ORTSUP2 MENU
C * MMODE = 10- PLATON/MAIN    MENU
C * MMODE = 11- PLATON/SUP1    MENU
C * MMODE = 12- PLATON/SUP2    MENU
C * MMODE = 13- GEOM           MENU
C * MMODE = 14- ASYM           MENU
C * MMODE = 15- HELENA         MENU
C * MMODE = 16- ABSCOR         MENU
C * MMODE = 17- SYSTEM-S       MENU
C * MMODE = 18- S/SUB1         MENU
C * MMODE = 19- S/SHELXL       MENU
C * MMODE = 20- LEPAGE         MENU
C * MMODE = 21- POWDER         MENU
C * MMODE = 22- CONTOUR        MENU
C * MMODE = 23- CONTOUR-SUP    MENU
C * MMODE = 24- SOLV           MENU
C * MMODE = 25- TwRtMt         MENU
C * MMODE = 26- ADDSYM         MENU
C * MMODE = 27- EXOR           MENU
C * MMODE = 28- RDF            MENU
C * MMODE = 29- BIJVOET        MENU
C * MMODE = 30- POLYHEDRON     MENU
C * MMODE = 31- FLIPPER        MENU
C * MMODE = 32- ANAL-OF-VAR    MENU
C * MMODE = 33- ANOM.DISP.     MENU
C * MMODE = 34- FCF-Compare    MENU
C * MMODE = 35- WILSON-PLOT    MENU
C * MMODE = 36- SQUEEZE        MENU
C * MMODE = 37- SPGRfromEX     MENU
C * GET GRAPHICS STATUS INFO
      CALL GGIP (-999.0, YGGIP, ZGGIP, 8)
      MNH(12) = NINT (ZGGIP)
      CALL PLA293 (PAR(17))
      IF (MNH(12) == 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) == 2) THEN
        CMEN(24)(1:3)  = 'HGL'
        CMEN(44)(1:3)  = 'HGL'
        CMEN(104)(1:3) = 'HGL'
        CMEN(148)(5:7) = 'HGL'
      END IF
C * GET SUB-MENU
      MODE = IGBL(6)
C * HELENA
      IF (MODE == 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
C * SYSTEM-S
      ELSE IF (MODE == 17) THEN
        MNH(40) = IABS (IGBL(6)) - 16
C * POWDER
      ELSE IF (MODE == 21) THEN
        MNH(45) = 3 - NINT (LOG (PAR(371)) / LOG (10.0))
        IF (PAR(372) >= 1.0) THEN
          MNH(46) = NINT (LOG (PAR(372)) / LOG (2.0)) + 1
        END IF
      ELSE
        MNH(1)  = IPR(140) + 1
        IF (IPR(478) == 0) THEN
          MNH(2) = 1
C * BWC SETTING (ATOMTYPE/RESD/ARU)
        ELSE IF (IPR(478) == -1) THEN
          MNH(2) = 2
        ELSE
          MNH(2) = 3
        END IF
C * COLOR SETTING (ATOMTYPE/RESD/ARU)
        IF (IPR(477) == 0) THEN
          MNH(3) = 1
        ELSE IF (IPR(477) == -1) THEN
          MNH(3) = 2
        ELSE
          MNH(3) = 3
        END IF
        MNH(5)  = NINT (PAR(349) / 0.05) - 4
        MNH(8)  = IPR(139) + 1
        IF (IPR(111) /= 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(6)) - 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) == 0) IPR(419) = 10
        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) / RGBL(6)) * 20.0 / PAR(17))
     1    - 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) == MNH(29) .AND. MNH(29) == MNH(30)) THEN
          MNH(27) = MNH(28)
        ELSE
          MNH(27) = 0
        END IF
        IF (PAR(44) > 0.0) THEN
          MNH(33) = MIN (NINT (LOG(PAR(44) * 2.0) / LOG (2.0) + 4), 6)
        ELSE
          MNH(33) = 1
        END IF
        MNH(34) = NINT (PAR(48) / 0.125) + 1
        IF (IPR(341) > 1 .AND. IPR(341) < 5) THEN
          MNH(35) = IPR(341) - 1
        ELSE
          MNH(35) = 0
        END IF
        MNH(36) = IPR(311)
        MNH(37) = IPR(33)  + 1
        MNH(38) = IPR(177) + 1
        MNH(39) = IPR(460)
        MNH(40) = IABS(IGBL(6)) - 16
        IF (IPR(389) == 1) THEN
          MNH(41) = 1
        ELSE IF (IPR(389) == -1) THEN
          MNH(41) = 2
        ELSE
          MNH(41) = 0
        END IF
        MNH(42) = NINT (PAR(58) / 0.05) + 1
        IF (PAR(439) > 0.0) THEN
          MNH(43) = NINT (LOG (PAR(439) / 0.125) / LOG (2.0)) + 1
        END IF
        MNH(44) = IPR(117)
        IF (IABS (IGBL(6)) == 1) THEN
          MNH(48) = 1
        ELSE
          MNH(48) = MAX (0, IABS (IGBL(6)) - 6)
        END IF
      END IF
C * SET WAVELENGTH TYPE
      IF (IABS(IPR(493)) < 7) THEN
        IWL = IABS (IPR(493))
        IF (IWL == 2) THEN
          MNH(49) = 1
        ELSE IF (IWL == 3) THEN
          MNH(49) = 2
        ELSE IF (IWL == 5) THEN
          MNH(49) = 3
        ELSE
          MNH(49) = 4
        END IF
      END IF
      MNH(50) = IPR(500)
      MNH(51) = IPR(461) + 1
      MNH(52) = IPR(41)  + 1
      MNH(53) = IPR(87) + 1
      MNH(54) = IGBL(62)
      IF (IPR(182) == 0) THEN
        MNH(55) = IPR(515) + 1
      ELSE
        MNH(55) = IPR(505)
      END IF
      MNH(56) = IPR(507)
      IF (IPR(132) >= 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) * 6.0), 5)
      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)
C * DelCrit
      MNH(70) = MIN (5, 1 + MAX (0, NINT (RGBL(25) / 0.25)))
C * COORD Rad Default
      MNH(71) = MIN (4, MAX (1, NINT (PAR(7)) - 2))
      MNH(72) = MAX (1, IPR(536))
C * PLUTON/ZOOM
      MNH(73) = MIN (8, MAX (1, NINT ((PAR(13) - 0.4) * 2.0)))
C * DIHEDRAL ANGLE CLICK STATUS
      MNH(75) = IPR(551)
C * LEPAGE ROUND
      IF (PAR(440) /= 0.0) THEN
        MNH(74) = NINT (LOG (PAR(440)) / LOG (10.0))
      END IF
      MNH(76) = IGBL(101) + 1
      MNH(77) = NINT (PAR(407) / 10.0) + 1
      MNH(78) = NINT (PAR(43) / 0.2)
      MNH(79) = NINT ((PAR(401) + 0.05) / 0.1)
      MNH(80) = NINT ((PAR(402) + 0.05) / 0.1)
      MNH(81) = NINT ((PAR(403) + 0.05) / 0.1)
      IF (MODE == 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
      END IF
C * PLATON (SUP) MENU'S
      MNH(86) = MAX (0, IGBL(6) - 9)
C * Q-PEAK-H
      MNH(87) = MIN (4, MAX (1, NINT (RGBL(26) / 0.20)))
C * DelCrit
      MNH(88) = MIN (5, 1 + MAX (0, NINT (RGBL(27) / 0.25)))
C * ADDSYM/ELEMENT
      MNH(89) = IPR(206) + 1
C * HFIX BOX (SUB-MENU 3)
      IF (IPR(332) == 1) THEN
        MNH(90) = 1
C * ANIS BOX (SUB-MENU 3)
      ELSE IF (IPR(352) == 1) THEN
        MNH(90) = 2
C * (SUB-MENU 3)
      ELSE
        MNH(90) = 0
      END IF
      IF (MODE == 7) THEN
        IF (ABS(PAR(18)) > 1.0) THEN
          MNH(91) = 2
        ELSE
          MNH(91) = 1
        END IF
      END IF
      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) <= 0.54) THEN
        MNH(100) = 1
      ELSE IF (PAR(453) <= 0.60) THEN
        MNH(100) = 2
      ELSE IF (PAR(453) <= 0.65) THEN
        MNH(100) = 3
      ELSE
        MNH(100) = 4
      END IF
      MNH(101) = IPR(394)
      MNH(102) = IGBL(124) + 1
      MNH(103) = IPR(354)  + 1
      IF (MODE == 29) THEN
        IF (PAR(452) < 0.01) THEN
          MNH(100) = 1
        ELSE
          MNH(100) = NINT (LOG (PAR(452) / 0.25) / LOG (2.0)) + 2
        END IF
        MNH(104) = MAX (MIN (IPR(611) + 1, 10), 1)
        MNH(105) = MAX (MIN (NINT (PAR(487)) / 5, 10), 1)
      END IF
C * hkl2powder (IOBS/ICAL)
      MNH(106) = IPR(511)
C * SOLV MENU BARS
      MENS(12, 24) = INT (MENS(12, 24) / 100) * 100 + IPR(530) + 1
C * ORTEP-RESD MODES
      IF (MODE == 1 .OR. MODE == 8 .OR. MODE == 9) THEN
C * CALCULATE # RESD BARS
        MENS(17, MODE) = INT (MENS(17, MODE) / 100) * 100 + IPR(75) + 1
        MNH(4)      = IPR(45)
C * PLUTON-RESD MODES
      ELSE IF (MODE == 2 .OR. MODE == 3 .OR. MODE == 5 .OR.
     1         MODE == 6) THEN
C * CALCULATE # RESD BARS
        MENS(14, MODE) = INT (MENS(14, MODE) / 100) * 100 + IPR(75) + 1
C * SOLV/RESD  MODES
      ELSE IF (MODE == 24) THEN
C * CALCULATE # RESD BARS
        MENS(10, MODE) = INT (MENS(10, MODE) / 100) * 100 + IPR(75) + 1
C * ADDSYM-MODE
      ELSE IF (MODE == 26) THEN
        MENS(21, MODE) = INT (MENS(21, MODE) / 100) * 100 + IAN + 1
      ELSE IF (MODE == 10) THEN
        IF (IPR(44) == 0) IGBL(59) = 1
      END IF
C * TEST FOR MONO
      IF (IPR(116) == 0) THEN
        MENS(2, 2) = 4
        MENS(2, 1) = 2
C * STEREO
      ELSE
        MENS(2, 2) = 1
        MENS(2, 1) = 1
      END IF
      IF (MODE == 0) THEN
        BCD(1:12) = '           '//CHAR (0)
      ELSE
        BCD(1:12) = MENX(IABS (MODE))//CHAR (0)
      END IF
      CKLEUR = 5.0 + IGBL(68)
      CALL GGIP (-999.0, CKLEUR, 1.0, 10)
C * SHOW MENU
      CALL GEN074 (COLOR, 1, 25, 0.0)
      CALL GEN074 (XMNS,  1, 25, 0.0)
      DO I = 1, 25
        MENUSUB(I) = ' '
      END DO
C * CHECK FOR NO-ATOMS & NO-FACES AND NO-CELL
      IF (IPR(37) /= 0 .OR. IPR(367) /= 0 .OR.
     1    PAR(101) > 1.0 .OR. MODE == 15 .OR.
     2    MODE == 17 .OR. MODE == 18 .OR. MODE == 19 .OR.
     3    (MODE >= 32 .AND. MODE <= 35)) THEN
        DO I = 1, 25
          IF (MODE /= 0) THEN
            J = MENA(I, IABS (MODE))
C * DEPEND ON IPR VALUE
            IF (J > 0) THEN
              L = J / 1000
              J = MOD (J, 1000)
              K = I
              IF (L > 0) THEN
                IF (IABS (IPR(J)) == L) K = K + 25
              ELSE
                IF (IPR(J) /= 0) K = K + 25
              END IF
C * DEPEND ON IGBL VALUE
            ELSE IF (J < 0) THEN
              K = MAX (MIN (IABS (IGBL(IABS (J))), 1), 0) * 25 + I
            ELSE
              K = I
            END IF
            MENUSUB(I) = CMEN(MOD (MENU(K, IABS (MODE)), 500))
            IF (MENU(K, IABS (MODE)) > 500) THEN
              COLOR(I) = 2.0
            ELSE
              COLOR(I) = 1.0
            END IF
C * BLUE SUB-MENU OPTION ENTRIES
            IF (MODE == 25) THEN
              IF (IPR(771) < 4) THEN
                DO L = IPR(771) + 1, 4
                  COLOR(L +  6) = 4.0
                  COLOR(L + 17) = 4.0
                END DO
              END IF
            END IF
            MNS1 = MENS(I, IABS (MODE)) / 100
            MNS2 = MOD (MENS(I, IABS (MODE)), 100)
            IF (MNS1 > 0) THEN
              XMNS(I) = MNH(MNS1) * 100 + MNS2
            ELSE
              XMNS(I) = MNS2
            END IF
C * SPECIAL BLANKING OF SUB-MENU OPTIONS
            IF (IABS(MODE) == 16) THEN
              IF (IPR(78) /= -2) THEN
                IF (I < 5) THEN
                  MENUSUB(I) = ' '
                END IF
              END IF
            ELSE IF (IPR(772) == 1) THEN
              MENUSUB(I) = ' '
            END IF
          END IF
        END DO
      END IF
      DO I = 1, 25
        BCD(1:12) = MENUSUB(I)//CHAR (0)
C * SHOW SUBMENU
        CALL GGIP (-999.0, COLOR(I), XMNS(I), 10 + I)
      END DO
      IF (IPR(182) == 0) THEN
        BCD = SBCD
      ELSE
        BCD = 'Click on Unique Atoms to be Omitted'//CHAR (0)
      END IF
      CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68) * IGBL(82)), 70.0, 110)
      RETURN
      END SUBROUTINE PLA013
 
      MODULE tpos
      SAVE
      INTEGER                     :: KMX
      INTEGER                     :: IMIN
      INTEGER,  DIMENSION(25)     :: NTK
      REAL,     DIMENSION(250, 3) :: XTK
      END MODULE tpos
 
      SUBROUTINE PLA014 (MODE, NTYP, X, Y, ITEM, IASU)
C * MENU - GET NEAREST ITEM TO CLICK POSITION
      USE parameters
      USE tpos
      IMPLICIT NONE
      INTEGER, PARAMETER :: NP0  = 6
      INTEGER :: I
      INTEGER :: IB
      INTEGER :: IBEG
      INTEGER :: IEND
      INTEGER :: MODE
      INTEGER :: NTYP
      INTEGER :: ITEM
      INTEGER :: IASU
      REAL    :: X
      REAL    :: Y
      REAL    :: Y1
      REAL    :: X1
      REAL    :: DIST
      REAL    :: DELMIN
      IBEG = 0
      IEND = 0
C * NTYP = 1 : PLUTON
C * NTYP = 2 : PLATON
      IF (NTYP == 1) THEN
        X1 =   X + PAR(61)
        Y1 = - Y - PAR(62)
      ELSE
        X1 = X
        Y1 = PAR(38) - Y
      END IF
C * GET NEAREST ITEM
      ITEM   = 0
      DELMIN = 1000.0
      IMIN   = 0
      IASU   = 0
      IF (IABS (MODE) <= 2) THEN
        IB = IPR(158)
C * ATOMS
        IF (MODE > 0) THEN
          IB = IB + IPR(69) * NP0
          IBEG = IPR(69) + 1
          IF (IPR(341) == 2) THEN
            IEND = IPR(62)
          ELSE
            IEND = IPR(37)
          END IF
C * LABELS
        ELSE IF (MODE == -1) THEN
          IB   = IB + IPR(62) * NP0
          IBEG = IPR(62) + 1
          IEND = IPR(62) + IPR(37)
C * ARU
        ELSE IF (MODE == -2) THEN
          IB   = IB + (IPR(62) + IPR(37)) * NP0
          IBEG = IPR(62) + IPR(37) + 1
          IEND = IPR(62) + IPR(37) + IPR(42)
        END IF
C * GET NEAREST ITEM
        CALL PLUT43 (IB, IBEG, IEND, X1, Y1, DELMIN, IASU, IMIN)
C * PLATON TEXT-ITEM
      ELSE IF (MODE == 3) THEN
        DO I = 1, IPR(447)
          DIST = SQRT ((XTK(I, 1) - X1)**2 +
     1        (XTK(I, 2) - Y1)**2)
          IF (DIST < DELMIN) THEN
            DELMIN = DIST
            IMIN = I
          END IF
        END DO
      END IF
C * MARK SELECTED ATOM
      IF (DELMIN < PAR(24) / 4) THEN
        ITEM = IMIN
        IF (MODE == 1) THEN
          IB = IPR(158) + (IMIN - 1) * NP0
C * PUT DIAMOND
          CALL PLUT31 (IB, 2.0)
          IF (IASU /= 0) THEN
            ITEM = IASU / 1000
            IASU = MOD (IASU, 1000)
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA014
 
      SUBROUTINE PLA015 (NR, IVAL)
C * NOTIFICATION MESSAGES
      USE parameters
      USE atomdata
      USE cggt
      USE chdat
      IMPLICIT NONE
      INTEGER :: NR
      INTEGER :: IVAL
      INTEGER :: IDUM
      INTEGER :: MODE
      INTEGER :: IPRNR
      T111 = ' '
C * CHECK FOR -F MODE
      IF (IGBL(50) == 2) RETURN
      MODE = IABS (IGBL(6))
      IF (IPR(427) /= 0) THEN
        IF (IGBL(6) > 0) THEN
          CALL GEN038 (T111, 1, 79)
          BCD = T111//CHAR (0)
          CALL GGIP (-999.0, 0.0, 80.0, 111)
        END IF
        IPR(427) = 0
      END IF
C * HANDLE STATUS TEXT ON INPUT/OUTPUT WINDOW
      IF (NR == 0) THEN
C * ONE LINE NOTIFICATION MESSAGES
        SELECT CASE (IVAL)
          CASE (1)
            T111 = 'No Classic Hydrogen Bonds Found'
          CASE (2)
            T111 =
     1        'Classic Hydrogen Bonds Found (See Listing for Details)'
           CASE (3)
            T111 = 'No Solvent Accessible Void Found'
          CASE (4)
            T111 =
     1      'Solvent Accessible Void Found (See Listing for Details)'
          CASE (5)
            T111 = 'No Obvious Additional Symmetry'
          CASE (6)
            T111 =
     1     'Additional (Pseudo)Symmetry Found (See Listing for details)'
          CASE (7)
            T111 = 'No Proper Reflection Data Available !'
          CASE (8)
            T111 = 'Label Conflict, No Substitution !'
          CASE (9)
            T111 = 'Requested Program not Accessible !'
          CASE (10)
            T111 = 'Instruction Ignored'
          CASE (11)
            T111 = 'DIRDIF PATTY for HEAVY ATOM STRUCTURES ONLY !'
          CASE (12)
            T111 = 'No Model-data found for DIRDIF/ORIENT-run'
          CASE (13)
            T111 =
     1      'Problem in DIRDIF (See tm/sg/dirdif08/lis1 for details)'
          CASE (14)
            T111 = 'DIRDIF not Available (or accessible) !'
          CASE (15)
            T111 = '                                      '
          CASE (16)
            T111 = 'SIR nor Available (or accessible) !'
          CASE (17)
            T111 = 'SHELXS   not Available (or accessible) !'
          CASE (18)
            T111 = 'No (more) NEWMAN, RING or PLANE data (Rewind)? '
          CASE (19)
            T111 = 'No Crystal Description Available !'
          CASE (20)
            T111 = 'No Cell data yet !'
          CASE (21)
            T111 = 'Automatic Invert to enantiomeric space group'
          CASE (22)
            T111 = 'Spacegroup not acceptable, try again'
          CASE (23)
            T111 = 'SPGR # Out of Range [0:NP42], try again'
          CASE (24)
            T111 = 'TRMX nor acceptable, try again'
          CASE (25)
            T111 =
     1      'SPGR-Routine cannot identify appropriate space group'
          CASE (26)
            T111 = 'Formula Requires more Element-number pairs - retry'
          CASE (27)
            T111 = 'No Quest for Network structures'
          CASE (28)
            T111 = 'Unsuitable Instruction. Ignored'
          CASE (29)
            T111 = 'SHELXL not Available (or accessible) !'
          CASE (30)
            T111 = 'HFIX-Instruction Valid for RES-files ONLY'
          CASE (31)
            T111 = 'AutoMolFit not possible for this residue pair'
          CASE (32)
            T111 =
     1      'Unresolved problem in SIR97 (see tm/sg/sir for details)'
          CASE (33)
            T111 = 'Missing Element(s) in Formula (Enter New Formula)'
          CASE (34)
            T111 = 'No Coordinate Data found in Current Input File'
          CASE (35)
            T111 = 'No Direction Cosines found'
          CASE (36)
            T111 = 'An Editor will be invoked prior to the SHELX launch'
          CASE (37)
            T111 = 'Twin[Matrix NOT Acceptable (Determinant = 0)'
          CASE (38)
            T111 = 'SHELXL-Problem, No Suitable Res-file '
          CASE (39)
            T111 = 'Result of Calculation on .lis & .lps Files'
          CASE (40)
            T111 = 'RENAME-function valid for RES-files Only !!'
          CASE (41)
            T111 = '                        '
          CASE (42)
            T111 = 'Incorrect Plane Definition. Try Again.'
          CASE (43)
            T111 =
     1      'No TLS-Analysis for Polymeric or Disordered Structures'
          CASE (44)
            T111 = 'ANIS-Instruction Valid for RES-files ONLY'
          CASE (45)
            T111 = 'Click on ARU-Code to ADD ARU to ORTEP PLOT'
          CASE (46)
            T111 = 'No Mu-value given !!'
          CASE (47)
            T111 = 'Validation requires NOMOVE mode !!'
          CASE (48)
            T111 = 'Problem/Error in JOIN Instruction !!'
          CASE (49)
            T111 = 'Error - Not Enough Data Items on Input Line !!'
          CASE (50)
            T111 = 'Error: Requested Data Entry not Found. Try Again.'
          CASE (51)
            T111 =
     1      'No Matching Reflection Data Set Found on Reflection FCF'
          CASE (52)
            T111 = 'No CAVITY''S Found in this Structure'
          CASE (53)
            T111 = 'Label Conflict, Special Substitution !'
          CASE (54)
            T111 = 'SIR2004 nor Available (or accessible) !'
          CASE (55)
            T111 = 'SHELXD nor Available (or accessible) !'
          CASE (56)
            T111 = 'Insufficient Space for Coordinate Expansion'
          CASE (57)
            T111 = 'Requested SIR version not found !'
          CASE (58)
            T111 = 'No Bijvoet Pairs found !'
          CASE (59)
            T111 = 'SHELXT not Available (or accessible) !'
          CASE (60)
            T111 = 'SIR2011 not Available (or accessible) !'
        END SELECT
      ELSE IF (NR > 0) THEN
C * EVICT GEOM-LIST
        IF (IPR(341) == 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 == 0 .OR. IPRNR /= IVAL) THEN
          IPR(NR) = IVAL
        ELSE
          IPR(NR) = 0
        END IF
C * WARNING TEXTS
        IF (IPR(311) == 1) THEN
          T111 = 'Click on 2 ATOMS to JOIN'
        ELSE IF (IPR(311) == 2) THEN
          T111 = 'Click on 2 ATOMS to JOIN DASH'
        ELSE IF (IPR(311) == 3) THEN
          T111 = 'Click on 2 ATOMS to DETACH '
        ELSE IF (IPR(312) == 1) THEN
          T111 = 'Click on at least 5 Atom Pairs to FIT'
        ELSE IF (IPR(348) == 1) THEN
          T111 = 'Click on Atom to SELECT Pattern'
        ELSE IF (IPR(327) == 1) THEN
          IF (MODE == 1) THEN
            T111 = 'Click on LABEL [Lower Left Corner] to be DELETED'
          END IF
        ELSE IF (IPR(328) == 1) THEN
          IF (MODE == 1) THEN
            T111 = 'Click on (RED) LABEL to INCLUDE LABEL again'
          END IF
        ELSE IF (IPR(349) == 1) THEN
          IF (MODE == 1) THEN
            T111 = 'Click on LABEL [Lower Left Corner] to REPOSITION'
          ELSE
            T111 = 'Click on LABEL [Center] to REPOSITION'
          END IF
        ELSE IF (IPR(335) == 1) THEN
          T111 = 'Click on ATOM to be RENAMED (or RETURN for ATOM loop)'
        ELSE IF (IPR(351) == 1) THEN
          T111 = 'Click on ATOM to be DELETED [or enter instruction]'
        ELSE IF (IPR(448) == 1) THEN
          T111 = 'Click on TEXT [Lower Left Corner] to REPOSITION'
        ELSE IF (IPR(344) == 1) THEN
          T111 = 'Click on Text [Lower Left Corner] to be DELETED'
        ELSE IF (IPR(343) == 1) THEN
          T111 = 'Click on ATOM as ZOOM CENTRE'
        ELSE IF (IPR(341) == 1) THEN
          T111 = 'Click on Atom for GEOM Calculation'
        ELSE IF (IPR(341) == 2) THEN
          T111 = 'Click on 2 ATOMS for DISTANCE'
        ELSE IF (IPR(341) == 3) THEN
          T111 = 'Click on 3 ATOMS for ANGLE'
        ELSE IF (IPR(341) == 4) THEN
          T111 = 'Click on 4 ATOMS for TORSION ANGLE'
        ELSE IF (IPR(341) == 5) THEN
          T111 = 'Click on 2 ATOMS for LINE 1 and 2 ATOMS FOR LINE 2'
        ELSE IF (IPR(329) == 1) THEN
          T111 = 'Click on 2 ATOMS for VIEW LINE'
        ELSE IF (IPR(329) == 2) THEN
          T111 = 'Click on 3 ATOMS for VIEW PERP'
        ELSE IF (IPR(329) == 3) THEN
          T111 = 'Click on 3 ATOMS for VIEW BISECT'
        ELSE IF (IPR(476) /= 0) THEN
          T111 = 'Click on Atoms Defining Plane (or Dist/End)'
        ELSE IF (IPR(552) /= 0) THEN
          T111 = 'Click on Atoms Defining Planes (or With/End)'
        ELSE IF (IPR(508) == 1) THEN
          T111 = 'Click on FROM Atom Followed by TO Atoms and END'
        ELSE IF (IPR(508) == 2) THEN
          T111 = 'Click on Atoms Defining Cg Terminated with END'
        ELSE IF (IPR(338) == 1) THEN
          T111 = 'Click on ATOM to Select Color'
        ELSE IF (IPR(334) == 1) THEN
          WRITE (T111, 99999)
     1         'Click on TEXT [Lower Left Corner] to Change Size',
     2          PAR(350)
        ELSE IF (IPR(352) == 1) THEN
          T111 = 'Click on ATOM for ANIS [or EXIT] '
        ELSE IF (IPR(332) == 1) THEN
          T111 =
     1    'Click on ATOM for HFIX (or RETURN for loop over ATOMs)'
        ELSE IF (IPR(440) == 1) THEN
          T111 = 'Click on ATOM for ''CALC COORDINATION atom'''
        ELSE IF (IPR(213) == 1) THEN
          T111 = 'Click on ARU-Label for ARU to be Excluded'
        ELSE IF (IPR(536) > 0) THEN
          T111 = 'Click on ATOM to change Atom-Type-Color to '//
     1          COLR(IPR(536))
        END IF
        IF (IGBL(45) /= 0 .AND. IGBL(3) /= 1) THEN
          IF (IPR(20) == 0) THEN
            IF (IGBL(3) == 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)
            END IF
          ELSE
            BCD = 'Click on END to return to System-S'//CHAR (0)
          END IF
          CALL GGIP (-999.0, 3.0, 80.0, 112)
        END IF
 
      END IF
C * NOT FOR -u OR -U  Modes
      IF (IGBL(3) /= 1) THEN
        BCD = T112//CHAR (0)
        CALL GGIP (-999.0, 2.0, 80.0, 112)
        IF (IGBL(6) > 0) THEN
          BCD = T111//CHAR (0)
          CALL GGIP (-999.0, 2.0, 80.0, 111)
        END IF
      END IF
      IF (NR /= 0) IPR(427) = 1
      IGBL(6) = IABS (IGBL(6))
      RETURN
99999 FORMAT (A, '[', F4.2, ']')
      END SUBROUTINE PLA015
 
      SUBROUTINE PLA016 (MENUV, MENUH)
C * SIDE MENU OPTIONS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE menus
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: M
      INTEGER          :: IANG
      INTEGER          :: NEXIT
      INTEGER          :: MENUV
      INTEGER          :: MENUH
      INTEGER          :: MMODE
      INTEGER          :: NASUP
      REAL             :: DX
      REAL             :: WL
      REAL             :: VAL
      REAL             :: ZROT
      REAL             :: ANGC
      REAL             :: DELTA
      REAL             :: PAR351
      CHARACTER(len=5) :: BWC
      CHARACTER(len=5) :: COLOR
C * MMODE = 1 - PLATON/ORTEP   MAIN MENU
C * MMODE = 2 - PLUTON         MAIN MENU
C * MMODE = 3 - PLUTON/SUB1    MENU
C * MMODE = 4 - PLUTON/SUB2    MENU
C * MMODE = 5 - PLUTON/SUB3    MENU
C * MMODE = 6 - PLUTON/SUB4    MENU
C * MMODE = 7 - PLUTON/SUB5    MENU
C * MMODE = 8 - PLATON/ORTSUB1 MENU
C * MMODE = 9 - PLATON/ORTSUB2 MENU
C * MMODE = 10- PLATON/OPENING MENU
C * MMODE = 11- PLATON/SUP     MENU
C * MMODE = 12- GEOM           MENU
C * MMODE = 13- POLYEDRA       MENU
C * MMODE = 14- ASYM           MENU
C * MMODE = 15- HELENA         MENU
C * MMODE = 16- ABSCOR         MENU
C * MMODE = 17- SYSTEM-S       MENU
C * MMODE = 18- S/SUB1         MENU
C * MMODE = 19- S/SHELXL       MENU
C * MMODE = 20- LEPAGE         MENU
C * MMODE = 21- POWDER         MENU
C * MMODE = 22- CONTOUR        MENU
C * MMODE = 23- CONTOUR-SUP    MENU
C * MMODE = 24- SOLV           MENU
C * MMODE = 25- TwinRotMat     MENU
C * MMODE = 26- ADDSYM         MENU
C * MMODE = 27- EXOR           MENU
C * MMODE = 28- RDF            MENU
C * MMODE = 29- BIJVOET        MENU
C * MMODE = 30- POLYHEDRON     MENU
C * MMODE = 31- FLIPPER        MENU
C * MMODE = 32- Anal_of_Var    MENU
C * MMODE = 33- Anomalous Disp MENU
C * MMODE = 34- FCF-Compare    MENU
C * MMODE = 35- WILSON-PLOT    MENU
C * MMODE = 36- SQUEEZE        MENU
C * MMODE = 37- SPGRfromEX     MENU
C * LRET = -1 - GET NEW INSTRUCTION
C * LRET =  1 - DEFAULT RETURN
C * LRET =  2
C * LRET =  3
C * LRET =  4
C * LRET =  5
C * LRET =  6 - Recalculate Label Position
C * LRET =  7
      DX    = 0.0
      NEXIT = 0
C * DEFAULT RETURN FROM SIDE NENU OPTIONS
      LRET = 1
C * SET PLOT AS DEFAULT
      IGBL(24) = 1
C * (0/1) AUTOPLOT
      IF (IGBL(35) == 1) THEN
        IF (IPR(504) == 0) CALL PLA280 ('PLOT')
      ELSE
        CALL GEN038 (IGGT, 1, 80)
      END IF
      IF (IPR(346) > 0) THEN
        COLOR = 'COLOR'
      ELSE
        COLOR = ' '
      END IF
      IF (IPR(345) > 0) THEN
        BWC   = 'BWC'
      ELSE
        BWC   = ' '
      END IF
      MMODE = IGBL(6)
      IF (MMODE == 1 .OR. MMODE == 9 .OR. MMODE == 16) THEN
        PAR(389) = 0.0
        IPR(478) = 0
        ANGC     = 2.0 ** (MENUH - 5)
      END IF
      IF (MMODE == 2 .OR. MMODE == 3) THEN
        ANGC = 2.0 ** (MENUH - 5)
        DX   = (MENUH - 1) * 0.25
      END IF
C * LOOP OVER MENU BOXES
      SELECT CASE (MENUV)
C * MENU BOX # 0 & EXPOSE EVENT
        CASE (0)
C * PLATON / ORTEP
        IF (MMODE == 1 .OR. MMODE == 8 .OR. MMODE == 9) THEN
          IPR(201) = 1
          LRET     = 3
C * REFRESH MAIN-MENU
        ELSE IF (MMODE == 10) THEN
          LRET = 1
C * REFRESH NEWMAN
        ELSE IF (MMODE == 12) THEN
          CALL PLA280 ('REF')
C * REFRESH CONTOUR PLOT
        ELSE IF (MMODE == 22) THEN
          LRET = 2
        END IF
C * MENU BOX # 1
        CASE (1)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * ORTEP OPTIONS
            CASE (1)
              IF (MENUH == 1) THEN
                IGBL(6) = 1
              ELSE
                IGBL(6) = MENUH + 6
              END IF
              LRET = -1
C * PLUTON OPTIONS
            CASE (2)
              IGBL(6) = MENUH + 1
              LRET    = -1
C * PLUTON/SUP
            CASE (3)
              IGBL(6) = MENUH + 1
              LRET    = -1
C * PLUTON/SUP
            CASE (4)
              IGBL(6) = MENUH + 1
              LRET    = -1
C * PLUTON/SUP
            CASE (5)
              IGBL(6) = MENUH + 1
              LRET    = -1
C * PLUTON/SUP
            CASE (6)
              IGBL(6) = MENUH + 1
              LRET    = -1
C * PLUTON/SUP
            CASE (7)
              IGBL(6) = MENUH + 1
              LRET    = -1
C * ORTEP/SUP1
            CASE (8)
              IF (MENUH == 1) THEN
                IGBL(6) = 1
              ELSE
                IGBL(6) = MENUH + 6
              END IF
              IPR(453) = 0
              IPR(448) = 0
              LRET     = -1
C * ORTEP/SUP2
            CASE (9)
              IF (MENUH == 1) THEN
                IGBL(6) = 1
              ELSE
                IGBL(6) = MENUH + 6
              END IF
              IPR(453) = 0
              IPR(448) = 0
              LRET     = -1
C * PLATON/OPTIONS
            CASE (10)
              IGBL(6) = MENUH + 9
              LRET    = -1
C * PLATON/SUP1
            CASE (11)
              IGBL(6) = MENUH + 9
              LRET    = -1
C * PLATON/SUP2
            CASE (12)
              IGBL(6) = MENUH + 9
              LRET    = -1
C * HELENA
            CASE (15)
C * L0MAX
            CASE (16)
              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
C * S MENU
            CASE (17)
              IGBL(6) = 16 + MENUH
              LRET    = -1
C * S/SUB MENU
            CASE (18)
              IGBL(6) = 16 + MENUH
              LRET    = -1
C * S/SHELXL
            CASE (19)
              IGBL(6) = 16 + MENUH
              LRET    = -1
C * DOT-MAX
            CASE (20)
              IPR(94) = MENUH + 1
              CALL PLA280 ('RESTART')
C * POWDER WAVEL
            CASE (21)
              IF (MENUH == 4) THEN
                WL = PAR(16)
                IPR(493) = 6
              ELSE IF (MENUH == 3) THEN
                WL = 1.54178
                IPR(493) = 5
              ELSE IF (MENUH == 2) THEN
                WL = 0.71073
                IPR(493) = 3
              ELSE IF (MENUH == 1) THEN
                WL = 0.56086
                IPR(493) = 2
              END IF
              CALL PLA293 (WL)
              IPR(500) = 0
              LRET     = 4
C * CONTOUR/OPTION
            CASE (22)
              IGBL(6)  = 23
              LRET     = -1
C * CONTOUR/OPTION
            CASE (23)
              IGBL(6)  = 22
              LRET     = -1
C * TwinRotMat
            CASE (25)
              IPR(550) = MENUH * 25
              CALL PLA280 ('CALC')
C * ADDSYM/PERC
            CASE (26)
              PAR(407) = (MENUH - 1) * 10.0
              IPR(699) = 1
              CALL PLA280 ('CALC ADDSYM')
C * RDF - NORMALIZE
            CASE (28)
              IPR(581) = MOD (IPR(581) + 1, 2)
              LRET     = 2
C * TOGGLE ICALC (FROMFCF/FROMCIF)
            CASE (29)
              IPR(594) = MOD (IPR(594) + 1, 2)
              CALL PLA280 ('FROM')
C * FLIPPER/PLATON
            CASE (31)
              CALL PLA280 ('PLATON')
C * ANAL-OF-VARIANCE - NPP
            CASE (32)
              CALL PLA280 ('NPP')
C * ANOM f' & F''
            CASE (33)
              CALL PLA280 ('ANOM')
C * FCF-COMPARE - NPP
            CASE (34)
              CALL PLA280 ('NPP')
C * WILSON-PLOT
            CASE (35)
              CALL PLA280 ('PLOT')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 2
        CASE (2)
C * LOOP OVER MENU OPTIONS
          SELECT CASE (MMODE)
C * STEREO/MONO
            CASE (1)
              IPR(116) = MOD (IPR(116) + 1, 2)
C * TO STEREO
              IF (IPR(116) == 1) THEN
                IPR(479) = 2
                IF (IGBL(75) == 1) IPR(201) = 0
C * SELECT RG OR RB STEREO
                IF (MENUH == 1) THEN
                  IPR(144) = 3
                ELSE
                  IPR(144) = 4
                END IF
C * TO MONO - ROTATE BACK
              ELSE
                IPR(479) = 2
                PAR(389) = 0.0
                IPR(201) = 0
              END IF
              LRET = 2
C * MONO/STEREO MENU-OPTION
            CASE (2)
              IF (IPR(116) == 0) THEN
                IF (MENUH == 1) THEN
                  CALL PLA280 ('STEREO RG')
                ELSE IF (MENUH == 2) THEN
                  CALL PLA280 ('STEREO RB')
                ELSE IF (MENUH == 3) THEN
                  CALL PLA280 ('STEREO')
                ELSE
                  CALL PLA280 ('STEREO  S')
                END IF
              ELSE
                CALL PLA280 ('MONO')
              END IF
C * TEXT ON/OFF
            CASE (3)
              IPR(173) = MOD (IPR(173) + 1, 2)
              CALL PLA280 ('PLOT')
C * SELECT BWC-TYPE
            CASE (4)
              CALL PLA015 (348, 1)
              IF (IPR(348) == 1) IPR(345) = 1
              IPR(461) = MENUH - 1
              LRET     = -1
            CASE (5)
              CALL PLA280 ('VIEW UNIT')
C * CALC DIST
            CASE (6)
              CALL PLA015 (341, 2)
              LRET = -1
C * MENU ON/OFF
            CASE (7)
              CALL PLA280 ('MENU OFF')
C * ORTEP TEXT ON/OFF
            CASE (8)
              IPR(173) = MOD (IPR(173) + 1, 2)
              LRET     =  4
C * X-LineWidth
            CASE (9)
              IGBL(69) = MOD (IGBL(69) + 1, 2)
              YGGIP    = - 100 * (IGBL(69) + 1)
              CALL GGIP (0.0, YGGIP, 0.0, 0)
C * NOMOVE
            CASE (10)
              IF (IPR(30) == 0) IGBL(30) = MOD (IGBL(30) + 1, 2)
              LRET = -1
C * MaxRingSiz = IPR(216) TOGGLE
            CASE (11)
              IPR(29)  = MOD (IPR(29) + 1, 2)
              IF (IPR(29) == 0) THEN
                IPR(579) = IPR(219)
              ELSE
                IPR(579) = IPR(216)
              END IF
              LRET = -1
C * SET PRINTER LEVEL
            CASE (12)
              IGBL(64) = MENUH - 1
              IGBL(63) = IGBL(64)
              LRET     = -1
C * ASYM H
            CASE (14)
              IPR(394) = 1
              LRET     = 3
C * L1MAX
            CASE (16)
              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
C * SYSTEM-S
            CASE (17, 18)
              IF (MENUH == 1) THEN
                CALL PLA280 ('LOG')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('RELINK BACK')
              ELSE
                CALL PLA280 ('RELINK FORWARD')
              END IF
C * EDIT-INS
            CASE (19)
              IGBL(44) = MOD (IGBL(44) + 1, 2)
              IF (IGBL(44) == 1) CALL PLA015 (0, 36)
              LRET = -1
            CASE (20)
              PAR(441) = (MENUH - 1) * 0.1
              CALL PLA280 ('RESTART')
C * POWDER LAMBDA
            CASE (21)
              CALL PLA015 (549, 1)
              IF (IPR(549) == 1) THEN
                STRING   = 'RADN '
                NCNT     = 5
                SBCD     = STRING(1:NCNT)//CHAR (0)
                IPR(493) = 6
              ELSE
                STRING = ' '
                NCNT   = 0
              END IF
              LRET = -1
C * FO-MAP (CONTOUR)
            CASE (22)
              CALL PLA280 ('FO')
              M = MIN (NINT (PAR(412) * 6.0), 5)
              IF (MENUH /= M) THEN
                IF (MENUH < 5) THEN
                  PAR(412) = MENUH * 0.15
                ELSE
                  PAR(412) = 99.0
                END IF
                IPR(414) = 1
                LRET     = 3
              ELSE
                IF (IPR(414) /= 1) THEN
                  IPR(414)  = 1
                ELSE
                  LRET = -1
                END IF
              END IF
C * PATT-MAP (CONTOUR)
            CASE (23)
              CALL PLA280 ('PT')
              M = MIN (NINT (PAR(412) * 6.0), 5)
              IF (MENUH /= M) THEN
                IF (MENUH < 5) THEN
                  PAR(412) = MENUH * 0.15
                ELSE
                  PAR(412) = 99.0
                END IF
                IPR(414) = 5
                LRET     = 3
              ELSE
                IF (IPR(414) /= 5) THEN
                  IPR(414) = 5
                ELSE
                  LRET = -1
                END IF
              END IF
C * STEREO/MONO SOLV
            CASE (24)
              IF (IPR(533) == MENUH) THEN
                IPR(116) = MOD (IPR(116) + 1, 2)
                IPR(533) = 1
              ELSE
                IF (MENUH == 2 .AND. IPR(116) == 0) IPR(116) = 1
                IPR(533) = MENUH
              END IF
C * TwinRotMat
            CASE (25)
              PAR(413) = 2 ** (MENUH - 1)
              CALL PLA280 ('CALC')
C * ADDSYM/Tol-Metric
            CASE (26)
              PAR(43) = MENUH * 0.2
              CALL PLA280 ('CALC ADDSYM')
C * CALC RDF (NEW RADIUS)
            CASE (28)
              PAR(450) = MENUH * 2.5
              CALL PLA280 ('CALC RDF')
C * InclWghtPar
            CASE (29)
              IF (PAR(493) > 0.0) THEN
                IPR(629) = MOD (IPR(629) + 1, 2)
                CALL PLA280 ('WGHT')
              END IF
            CASE (30)
C * COLOR (ON/OFF)
              IPR(346) = MOD (IPR(346) + 1, 2)
              LRET     = 3
C * ADDSYM PLOT
            CASE (31)
              CALL PLA280 ('CALL ADDSYM PLOT')
C * I/SIGMA VERSUS LOG10(I) PLOT
            CASE (32)
              CALL PLA280 ('IOSLI')
C * MU
            CASE (33)
              CALL PLA280 ('MU')
C * N(Z) - STATISTICS
            CASE (35)
              CALL PLA280 ('NZSTAT')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 3
        CASE (3)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * H-ATOMS
            CASE (1)
              IPR(212) = MOD (IPR(212) + 1, 2)
              IPR(201) = 0
              LRET = 4
            CASE (2)
              IF (MENUH == 1) THEN
C * INCLUDE/EXCLUDE H-ATOMS
                IF (IPR(212) == 1) THEN
                  CALL PLA280 ('EXCLUDE H')
                  IPR(212) = 0
                ELSE
                  CALL PLA280 ('INCLUDE H')
                  IPR(212) = 1
                END IF
              ELSE IF (MENUH == 2) THEN
C * INCLUDE/EXCLUDE CH-ATOMS
                IF (IPR(212) == 1) THEN
                  CALL PLA280 ('EXCLUDE CH')
                  IPR(212) = 0
                ELSE
                  CALL PLA280 ('INCLUDE CH')
                  IPR(212) = 1
               END IF
              ELSE IF (MENUH == 3) THEN
C * INCLUDE/EXCLUDE DH-ATOMS
                IF (IPR(212) == 1) THEN
                  CALL PLA280 ('EXCLUDE DH')
                  IPR(212) = 0
                ELSE
                  CALL PLA280 ('INCLUDE DH')
                  IPR(212) = 1
                END IF
              END IF
C * PLUTON/TEXT ON/OFF
            CASE (3)
              IPR(173) = 1
              IPR(344) = 0
              IPR(453) = MOD (IPR(453) + 1, 2)
              IF (IPR(453) == 1) THEN
                CALL PLA280 ('TEXT')
                IPR(448)  = 0
              ELSE
                IPR(448) = 1
              END IF
C * SELECT COLOR
            CASE (4)
              CALL PLA015 (338, 1)
              IF (IPR(338) == 1) THEN
                IPR(346) = 1
              END IF
              LRET = -1
C * PLUTON VIEW MIN
            CASE (5)
              CALL PLA280 ('VIEW MIN')
C * CALC ANGLE
            CASE (6)
              CALL PLA015 (341, 3)
              LRET = -1
C * PERSPECTIVE
            CASE (7)
              PAR(48) = (MENUH - 1) * 10.0
C * PLATON ORTEP/ TEXT
            CASE (8)
              IPR(173) = 1
              IPR(453) = MOD (IPR(453) + 1, 2)
              LRET     = 5
C * COLOR (ON/OFF)
            CASE (9)
              IPR(346) = MOD (IPR(346) + 1, 2)
              IF (IPR(116) == 0) THEN
                LRET = 3
              ELSE
                IPR(116) = 0
                IPR(479) = 2
                PAR(389) = 0.0
                IPR(201) = 0
                LRET     = 2
              END IF
C * JOIN-EXPAND
            CASE (10)
              IPR(110) = MOD (IPR(110) + 1, 2)
              LRET     = -1
C * MAXNUMRING
            CASE (11)
              IPR(592) = MOD (IPR(592) + 1, 2)
              LRET     = -1
C * LPS (ON/OFF)
            CASE (12)
              IGBL(70) = MOD (IGBL(70) + 1, 2)
              IF (IGBL(70) == 0) IGBL(130) = 0
              LRET = -1
C * ASYM K
            CASE (14)
              IPR(394) = 2
              LRET     = 3
            CASE (15)
              IPR(446) = MENUH - 1
              IF (IPR(446) == 0) IPR(428) = 1
C * Tmin
            CASE (16)
              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
C * SYSTEM-S MULABS
            CASE (17)
              CALL PLA280 ('MULABS')
C * SYSTEM-S /SUB
            CASE (18)
              IF (MENUH == 1) THEN
                CALL PLA280 ('TREE')
              ELSE
                CALL PLA280 ('LIST')
              END IF
C * EDIT-s.res
            CASE (19)
              CALL PLA280 ('EDITRES')
C * 2-Axis Crit
            CASE (20)
              PAR(439) = 0.125 * 2 ** (MENUH - 1)
C * VERTICAL SCALE
            CASE (21)
              PAR(372) = 2 ** (MENUH - 1)
              LRET     = 3
C * 2FO-FC-MAP (CONTOUR)
            CASE (22)
              CALL PLA280 ('FS')
              M = MIN (NINT (PAR(412) * 6.0), 5)
              IF (MENUH /= M) THEN
                IF (MENUH < 5) THEN
                  PAR(412) = MENUH * 0.15
                ELSE
                  PAR(412) = 99.0
                END IF
                IPR(414) = 2
                LRET     = 3
              ELSE
                IF (IPR(414) /= 2) THEN
                  IPR(414) = 2
                ELSE
                  LRET = -1
                END IF
              END IF
C * SOLV DOTS/CONTOUR
            CASE (24)
              IPR(534) = MENUH
C * TwinRotMat
            CASE (25)
              IPR(567) = MENUH * 5
              CALL PLA280 ('CALC')
C * ADDSYM/Tol-Rotation
            CASE (26)
              PAR(401) = MENUH * 0.1  - 0.05
              IPR(699) = 1
              CALL PLA280 ('CALC ADDSYM')
C * CALC RDF (NEW WIDTH)
            CASE (28)
              PAR(451) = MENUH * 2.5
              CALL PLA280 ('CALC RDF')
C * POLY (0/1) PERSPECTIVE
            CASE (30)
              IPR(355) = MOD (IPR(355) + 1, 2)
              LRET     = 3
C * ADDSYM SHELX
            CASE (31)
              CALL PLA280 ('ADDSYM SHELX')
C * I/SIGMAW VERSUS LOG10(I) PLOT
            CASE (32)
              CALL PLA280 ('IOSWLI')
C * ANOM CUKA
            CASE (33)
              CALL PLA280 ('ANOM 1.5418')
C * N(Z) - PLOT
            CASE (35)
              CALL PLA280 ('NZPLOT')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 4
        CASE (4)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * ORTEP/ATOM DELETE (OMIT)
            CASE (1)
              CALL PLA015 (351, 1)
              IPR(349) = 0
              LRET     = -1
C * SOLID
            CASE (2, 4)
              PAR351 = (6 - MENUH) * 0.1
              IF (IABS(IPR(4)) /= 1 .OR. PAR(351) /= PAR351) THEN
                PAR(351) = PAR351
                IPR(4)   = 0
                CALL PLA280 ('SOLID '//BWC//COLOR)
              ELSE
                CALL PLA280 ('STICK '//COLOR)
              END IF
C * NEW TEXT POSITION
            CASE (3)
              CALL PLA015 (448, 1)
              IF (IPR(448) == 1) IPR(453) = 0
              LRET = -1
            CASE (5)
              CALL PLA280 ('VIEW XO')
C * CALC TORSION
            CASE (6)
              CALL PLA015 (341, 4)
              LRET = -1
C * ORGANIC/INORGANIC - (PLUTON)
            CASE (7)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
                IGBL(97) = MOD (IGBL(97) + 1, 2)
              END IF
              LRET = -1
C * NEW TEXT POSITION
            CASE (8)
              CALL PLA015 (448, 1)
              IF (IPR(448) == 1) IPR(453) = 0
              LRET = -1
C * LABEL HETERO ATOMS ONLY
            CASE (9)
              IPR(618) = MOD (IPR(618) + 1, 2)
              LRET = 2
C * ORGANIC/INORGANIC (PLATON)
            CASE (10)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
                IGBL(97) = MOD (IGBL(97) + 1, 2)
              END IF
              LRET = -1
C * DI-HYDROGEN BONDS
            CASE (11)
              IGBL(56) = MOD (IGBL(56) + 1, 2)
              LRET     = -1
C * PDF (ON/OFF)
            CASE (12)
              IF (IGBL(116) > 0) THEN
                IGBL(130) = MOD (IGBL(130) + 1, 2)
                IF (IGBL(130) == 1) IGBL(70) = 1
              END IF
              LRET = -1
C * ASYM L
            CASE (14)
              IPR(394) = 3
              LRET     = 3
C * Tmax
            CASE (16)
              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
C * S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('ABSTOMPA')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('ABSPSI')
              ELSE IF (MENUH == 3) THEN
                CALL PLA280 ('ABSNONE')
              END IF
C * SYSTEM-S ABST/XTAL
            CASE (18)
              CALL PLA280 ('REMOVE')
C * ASYM MAX2AXIS
            CASE (20)
              IPR(514) = 2 * MENUH - 1
              CALL PLA280 ('RESTART')
C * POWDER/HORS-SCALE
            CASE (21)
              IPR(500) = MENUH
              RGBL(23) = 0.0
              LRET = 3
C * DIFFERENCE MAP - CONTOUR
            CASE (22)
              CALL PLA280 ('DI')
              M = MIN (NINT (PAR(412) * 6.0), 5)
              IF (MENUH /= M) THEN
                IF (MENUH < 5) THEN
                  PAR(412) = MENUH * 0.15
                ELSE
                  PAR(412) = 99.0
                END IF
                IPR(414) = 3
                LRET     = 3
              ELSE
                IF (IPR(414) /= 3) THEN
                  IPR(414) =  3
                ELSE
                  LRET = -1
                END IF
              END IF
C * SOLV VIEW XO
            CASE (24)
              IPR(526) = 1
C * TwinRotMat (DELTATHETA)
            CASE (25)
              PAR(414) = MENUH * 0.05
              CALL PLA280 ('CALC')
C * ADDSYM/Tol-Inversion
            CASE (26)
              PAR(402) = MENUH * 0.1 -0.05
              IPR(699) = 1
              CALL PLA280 ('CALC ADDSYM')
C * POLY - INCL H-ATOMS
            CASE (30)
              IPR(212) = MOD (IPR(212) + 1, 2)
              LRET     = 3
C * ADDSYM EQUAL
            CASE (31)
              CALL PLA280 ('ADDSYM EQUAL')
C * SIGMA VERSUS LOG10(I) PLOT
            CASE (32)
              CALL PLA280 ('SIGLI')
C * ANOM GaKa
            CASE (33)
              CALL PLA280 ('ANOM 1.3414')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 5
        CASE (5)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * ORTEP PROBABILITY LEVEL
            CASE (1)
              IPR(45)  = MENUH
              IPR(201) = 0
              LRET     = 2
            CASE (2)
              IF (IABS(IPR(4)) /= 2) THEN
                CALL PLA280 ('ROD   '//BWC//COLOR)
              ELSE
                CALL PLA280 ('STICK '//COLOR)
              END IF
C * LABEL TEXT SIZE
            CASE (3, 8)
              PAR(350) =  0.20 + 0.05 * MENUH
              LRET     = -1
            CASE (4)
              IF (IABS (IPR(4)) /= 2) THEN
                CALL PLA280 ('ROD   '//BWC//COLOR)
              ELSE
                CALL PLA280 ('STICK '//COLOR)
              END IF
            CASE (5)
              CALL PLA280 ('VIEW YO')
C * CALC GEOM
            CASE (6)
              CALL PLA015 (341, 1)
              LRET = -1
C * PLUTON/DisplAllLab
            CASE (7)
              IGBL(105) = MOD (IGBL(105) + 1, 2)
C * ORTEP/DisplAllLab
            CASE (9)
              IGBL(105) = MOD (IGBL(105) + 1, 2)
              IPR(201)  = 0
              LRET      = 2
C * ROUND
            CASE (10)
              IPR(68) = MENUH - 1
              LRET = -1
C * AutoRenum
            CASE (11)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
                IPR(501) = MOD (IPR(501) + 1, 2)
                IPR(71)  = 0
              END IF
              LRET = -1
C * PAGE HEADER TOGGLE
            CASE (12)
              IGBL(137) = MOD (IGBL(137) + 1, 2)
C * HELENA
            CASE (15)
              IPR(320) = MOD (IPR(320) + 1, 2)
C * MU MM
            CASE (16)
              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) == 1) THEN
                STRING = 'MU'
                NCNT = 3
                SBCD  = STRING(1:NCNT)//CHAR (0)
              ELSE
                NCNT = 0
                STRING = ' '
              END IF
              LRET = -1
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('TRMX')
              ELSE
                CALL PLA280 ('SPGR')
              END IF
C * XTAL
            CASE (18)
              CALL PLA280 ('XTAL')
C * SUB/SUPER-CELL
            CASE (20)
              IPR(117) = MENUH
C * POWDER/HORS-STEP
            CASE (21)
              PAR(411) = MENUH / 100.0
              LRET = 3
C * SQ-MAP
            CASE (22)
              IF (IGBL(9) < 0) THEN
                CALL PLA280 ('SQ')
                M = MIN (NINT (PAR(412) * 5.0), 4)
                IF (MENUH /= M) THEN
                  IF (MENUH < 4) THEN
                    PAR(412) = MENUH * 0.2
                  ELSE
                    PAR(412) = 99.0
                  END IF
                  IPR(414) = 4
                  LRET     = 3
                ELSE
                  IF (IPR(414) /= 4) THEN
                    IPR(414)  = 4
                  ELSE
                    LRET = -1
                  END IF
                END IF
              ELSE
                CALL PLA015 (427, 7)
                LRET = -1
              END IF
C * SOLV VIEW YO
            CASE (24)
              IPR(526) = 2
C * TWIN ListFull
            CASE (25)
              IPR(469) = MOD (IPR(469) + 1, 2)
              CALL PLA280 ('CALC')
C * ADDSYM/Tol-Translation
            CASE (26)
              PAR(403) = MENUH * 0.1 - 0.05
              IPR(699) = 1
              CALL PLA280 ('CALC ADDSYM')
C * EXOR
            CASE (31)
              CALL PLA280 ('EXOR')
C * LOG10(SIGMA) & LOG10(SIGMAW) VERSUS LOG10(I) PLOT
            CASE (32)
              CALL PLA280 ('LSLI')
C * ANOM MoKA
            CASE (33)
              CALL PLA280 ('ANOM 0.71073')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 6
        CASE (6)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * COORDN
            CASE (1)
              CALL PLA015 (440, 1)
              IPR(311) = 0
              IPR(351) = 0
              IPR(349) = 0
              IPR(327) = 0
              IPR(328) = 0
              LRET = -1
            CASE (2, 4)
              IF (IABS (IPR(4)) /= 3) THEN
                IF (MENUH == 1) THEN
                  CALL PLA280 ('CPK '//BWC//COLOR)
                ELSE IF (MENUH == 2) THEN
                  CALL PLA280 ('CPK STICK '//BWC//COLOR)
                END IF
              ELSE
                CALL PLA280 ('STICK '//COLOR)
              END IF
C * DELETE TEXT MODE
            CASE (3)
              CALL PLA015 (344, 1)
              LRET = -1
            CASE (5)
              CALL PLA280 ('VIEW ZO')
C * LIST TYPES
            CASE (6)
              IPR(90) = 256
              CALL PLUT12
C * LABEL FULL/NUM
            CASE (7)
              IPR(14)  = MOD (IPR(14) + 1, 2)
C * DELETE TEXT MODE
            CASE (8)
              IPR(453) = 0
              CALL PLA015 (344, 1)
              LRET = -1
C * LabelCg
            CASE (9)
              IPR(506) = MOD (IPR(506) + 1, 2)
              IPR(201) = 0
              LRET     = 2
C * PARENTHESES
            CASE (10)
              IF (IGBL(71) == 0) IPR(71) = MOD (IPR(71) + 1, 2)
              LRET = -1
C * INCLDISCONT
            CASE (11)
              IPR(502) = MOD (IPR(502) + 1, 2)
              LRET = -1
C * ASYM RESUME
            CASE (14)
              IPR(406) = MOD (IPR(406) + 1, 2)
              IPR(389) = 0
              LRET     = 4
C * HELENA SCALE/NOSCALE
            CASE (15)
              IPR(428) = MOD (IPR(428) + 1, 2)
              IF (IPR(428) == 0) IPR(446) = 1
C * ABSCOR/Radius
            CASE (16)
              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) == 1) THEN
                STRING = 'RADIUS'
                NCNT   = 7
                SBCD   = STRING(1:NCNT)//CHAR (0)
              ELSE
                STRING = ' '
                NCNT   = 0
              END IF
              LRET = -1
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('FORMULA')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('Z')
              ELSE
                CALL PLA280 ('SHELXS86')
              END IF
C * SYSTEM-S / SUB
            CASE (18)
              IF (MENUH == 1) THEN
                CALL PLA280 ('CELL')
              ELSE
                CALL PLA280 ('HELENA')
              END IF
C * SYSTEM-S/SHELXL TWIN
            CASE (19)
              CALL PLA280 ('TWIN')
C * LEPAGE ROUND/CELL
            CASE (20)
              PAR(440) = 10 ** MENUH
C * POWDER LINEWIDTH
            CASE (21)
              IF (MENUH < 3) THEN
                PAR(371) = 10 ** (3 - MENUH)
              ELSE
                PAR(371) = 1.0 / 10 ** (MENUH - 3)
              END IF
              LRET = 3
C * CONTOUR PLANE-HORIZ
            CASE (22)
              CALL PLA280 ('PLAN')
              IPR(416)  = 0
              IPR(420)  = 0
C * SOLV VIEW ZO
            CASE (24)
              IPR(526) = 3
C * EPS-TwinLaw
            CASE (25)
              MEDIUM      = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('PLOT')
C * ADDSYM NFRPercImpl
            CASE (26)
              IPR(568) = MOD (IPR(568) + 1, 2)
              LRET = -1
C * Hooft Select Crit
            CASE (29)
              IPR(611) = MENUH - 1
              CALL PLA280 ('SELECT')
C * SIGMA(I) VERSUS SQRT(I) PLOT
            CASE (32)
              CALL PLA280 ('SIRI')
C * ANOM AgKA
            CASE (33)
              CALL PLA280 ('ANOM 0.56086')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 7
        CASE (7)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * INTERACTIVE DIST/ANGLE/TORSION
            CASE (1)
              CALL PLA015 (341, MENUH + 1)
              LRET = -1
C * STICK/STRAW/ROD/BWC
            CASE (2, 4)
              IF (IABS(IPR(4)) /= 4) THEN
                CALL PLA280 ('STRAW '//BWC//COLOR)
              ELSE
                CALL PLA280 ('STICK '//COLOR)
              END IF
C * CHANGE TEXT SIZE
            CASE (3, 8)
              CALL PLA015 (334, 1)
              LRET = -1
            CASE (5)
              CALL PLA280 ('VIEW AFACE')
C * LIST LINES
            CASE (6)
              IPR(90) =  16
              CALL PLUT12
C * Label-Alias (PLUTON)
            CASE (7)
              IGBL(55) = MOD (IGBL(55) + 1, 2)
C * Label-Alias (ORTEP)
            CASE (9)
              IGBL(55) = MOD (IGBL(55) + 1, 2)
C * Label-Alias
            CASE (10)
              IGBL(55) = MOD (IGBL(55) + 1, 2)
              LRET = -1
C * TMA-HIncl
            CASE (11)
              IPR(497) = MOD(IPR(497) + 1, 2)
              LRET = -1
C * ASYM RESOLUTION
            CASE (14)
              IPR(387) = MOD (IPR(387) + 1, 2)
              IPR(389) = 0
              LRET     = 4
C * HELENA BETA/PERP/PAR
            CASE (15)
              IF (IPR(370) == 0) IPR(424) = MENUH - 1
C * MUR
            CASE (16)
              CALL PLA015 (443, 1)
              IPR(441) = 0
              IPR(442) = 0
              IPR(444) = 0
              IPR(451) = 0
              IF (IPR(443) == 1) THEN
                STRING = 'MUR'
                NCNT   = 4
                SBCD   = STRING(1:NCNT)//CHAR (0)
             ELSE
               STRING = ' '
               NCNT   = 0
              END IF
              LRET = -1
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('SHELXS97 TREF')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('SHELXS97 PATT')
              ELSE IF (MENUH == 3) THEN
                CALL PLA280 ('SHELXD')
              ELSE
                CALL PLA280 ('SHELXT')
              END IF
C * SYSTEM-S/FLIPPER
            CASE (18)
              CALL PLA280 ('FLIPPER')
C * IOBS/ICAL
            CASE (21)
C * SHELXL LIST 4n ONLY
              IF (IGBL(9) == 1) IPR(511) = MENUH
C * RECALCULATE
              LRET     = 5
C * CONTOUR PLANE-ABCD
            CASE (22)
              CALL PLA280 ('PLAN')
              IPR(416)  = 1
              IPR(420)  = 0
C * REVERSE
            CASE (24)
              CALL PLA280 ('REVERSE')
C * TwinRotMat1
            CASE (25)
              IF (IPR(543) == 1) THEN
                IPR(543) = 0
              ELSE
                IPR(543) = 1
                CALL PLA280 ('TWIN')
                IPR(576) = 0
              END IF
C * BIJVOET/PARSONS DIFF TOGGLE
            CASE (29)
              IPR(635) = MOD (IPR(635) + 1, 2)
C * AV(I/SIG) VERSUS SIN(THETA)/LAMBDA
            CASE (32)
              CALL PLA280 ('ISST')
C * ANOM InKa
            CASE (33)
              CALL PLA280 ('ANOM 0.51359')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 8
        CASE (8)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * JOIN/DASH/DETACH
            CASE (1)
              CALL PLA015 (311, MENUH)
              LRET = -1
C * STICK/STRAW/ROD/BWC
            CASE (2, 4)
              IF (IABS(IPR(4)) /= 0) THEN
                CALL PLA280 ('STICK '//COLOR)
              ELSE
                CALL PLA280 ('STRAW '//BWC//COLOR)
              END IF
C * PLUTON DELETE
            CASE (3)
              CALL PLA015 (351, 1)
              IF (IPR(335) == 1) CALL PLA015 (335, 1)
              IF (IPR(349) == 1) CALL PLA015 (349, 1)
              IF (IGBL(75) == 0) THEN
                CALL PLA280 ('LABEL ON')
              ELSE
                LRET = -1
              END IF
            CASE (5)
              CALL PLA280 ('VIEW BFACE')
C * LIST ARU
            CASE (6)
              IPR(90) =  32
              CALL PLUT12
C * UISO TOGGLE
            CASE (7)
              IPR(231) = MOD (IPR(231) + 1, 2)
C * DEF COORDN RADIUS
            CASE (8)
              PAR(7) = 2.0 + MENUH
              LRET = -1
C * FIT BY CLICKING
            CASE (9)
              LRET = -1
              IF (IPR(75) > 1) THEN
                CALL PLA015 (312, 1)
                IFL(1)  = 'FIT'
                IPR(33) = MENUH - 1
                IF (IPR(312) == 0) THEN
                  IPR(81) = - LMOD - 1
                  NASUP   = IPR(39) + IPR(64)
                  CALL PLA269 (-1, NASUP)
                  CALL PLA440 (1)
                  LMOD = 0
                  IGBL(6) = IABS (IGBL(6))
                  LRET = 4
                END IF
              END IF
C * R/S-DET
            CASE (10)
              IPR(324) = MOD (IPR(324) + 1, 2)
              LRET = -1
C * ALTLABPACK
            CASE (11)
              IGBL(61) = MOD (IGBL(61) + 1, 2)
              LRET = -1
C * LIST FLAGS & RADII
            CASE (12)
              IF (MENUH == 1) THEN
                CALL PLA280 ('LIST FLAGS')
              ELSE
                CALL PLA280 ('LIST RADII')
              END IF
              LRET = 2
C * ASYM AXES
            CASE (14)
              IPR(388) = MOD (IPR(388) + 1, 2)
              IPR(389) = 0
              LRET     = 4
C * HELENA LSR/MSM/MSA
            CASE (15)
              IF (IPR(370) == 0) IPR(425) = MENUH -1
C * GAUSSIAN GRID
            CASE (16)
              CALL PLA015 (444, 1)
              IPR(441) = 0
              IPR(442) = 0
              IPR(443) = 0
              IPR(451) = 0
              IF (IPR(444) == 1) THEN
                STRING = 'GRID'
                NCNT   = 5
                SBCD   = STRING(1:NCNT)//CHAR (0)
              ELSE
                STRING = ' '
                NCNT   = 0
              END IF
              LRET = -1
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('DIRDIF PATTY')
              ELSE
                CALL PLA280 ('DIRDIF ORIENT')
              END IF
C * SYSTEM-S STLM
            CASE (18)
              VAL = 1.0
              IF (MENUH == 1) THEN
                VAL = 0.54
              ELSE IF (MENUH == 2) THEN
                VAL = 0.60
              ELSE IF (MENUH == 3) THEN
                VAL = 0.65
              END IF
              WRITE (IGGT, 99994, IOSTAT = IOST) VAL
              PAR(453) = VAL
C * SYSTEM-S/SHELXL MERG 4
            CASE (19)
              IGBL(91) = MOD (IGBL(91) + 1, 2)
              LRET = -1
C * CONTOUR PLANE-BISECT
            CASE (22)
              CALL PLA280 ('PLAN')
              IPR(416)  = 2
              IPR(420)  = 0
C * NR-Sections
            CASE (23)
              IPR(577) = (MENUH * 2) - 1
              LRET = -1
C * VOID AXES PLOT TOGGLE
            CASE (24)
              IPR(598) = MOD (IPR(598) + 1, 2)
C * TwinRotMat2
            CASE (25)
              IF (IPR(543) == 2) THEN
                IPR(543) = 0
              ELSE
                IPR(543) = 2
                CALL PLA280 ('TWIN')
                IPR(576) = 0
              END IF
C * NOINVERT (LEPAGE)
            CASE (26)
              IPR(708) = MOD (IPR(708) + 1, 2)
              IPR(699) = 1
              CALL PLA280 ('CALC ADDSYM')
C * BIJVOET SIGMA CRIT
            CASE (29)
              IF (MENUH == 1) THEN
                PAR(452) = 0.0
              ELSE
                PAR(452) = 0.25 * 2 ** (MENUH - 2)
              END IF
              CALL PLA280 ('SIGMA')
C * ANALYSIS OF VARIANCE
            CASE (32)
              CALL PLA280 ('VARIANCE')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 9
        CASE (9)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * DEFINE ATOM TO CG OF ATOMS
            CASE (1)
C * SET LABEL CG ON
              IPR(506) = 1
C * RESET LABEL POSITIONING
              IPR(201) = 0
              IF (MENUH == 1) THEN
                LMOD     = 1
                IFL(1)   = 'DEFINE'
                IPR(507) = 1
                CALL PLA015 (508, 1)
                LRET = -1
              ELSE IF (MENUH == 3) THEN
                IF (IPR(508) == 1) THEN
                  IPR(507) = 3
                  IPR(508) = 0
                  WRITE (IGGT, 99995, IOSTAT = IOST) IFL(1)(1:6),
     1              IFL(2)(1:7), IFL(3)(1:2), (IFL(I)(1:7), I = 4, LMOD)
                  IGBL(6) = IABS (IGBL(6))
                  LRET = 7
                END IF
              END IF
C * BWC (ON/OFF)
            CASE (2, 4)
C * BWC-SWITCH
              DO
                IPR(345) = MOD (IPR(345) + 1, 2)
                IF (IPR(345) == 1) THEN
C * BWC ATOM-TYPE
                  IF (MENUH == 1) THEN
                    IPR(478) = 0
C * BWC RESD
                  ELSE IF (MENUH == 2) THEN
                    IPR(478) = -1
C * BWC ARU
                  ELSE
                    IPR(478) = 1
                  END IF
                ELSE
                  IF (MENUH * IPR(478) == -2 .OR.
     1                MENUH * IPR(478) ==  3 .OR.
     2                (MENUH == 1 .AND. IPR(478) == 0)) THEN
                    IPR(478) = 0
                  ELSE
                    IPR(478) = 0
                    CYCLE
                  END IF
                END IF
C * TEST for AUTOPLOT
                IF (IGBL(35) == 1) THEN
                  CALL PLA280 ('PLOT')
                ELSE
                  LRET = -1
                END IF
                IF (NEXIT == 0) EXIT
              END DO
C * PLUTON RENAME
            CASE (3)
              IF (IPR(351) == 1) CALL PLA015 (351, 1)
              IF (IPR(349) == 1) CALL PLA015 (349, 1)
              IF (IGBL(3) /= 0) THEN
                CALL PLA015 (335, 1)
                IF (IGBL(75) == 0) THEN
                  CALL PLA280 ('LABEL ON')
                ELSE
                  LRET = -1
                END IF
              ELSE
                CALL PLA015 (427, 40)
                LRET = -1
              END IF
            CASE (5)
              CALL PLA280 ('VIEW CFACE')
C * LIST FLAGS
            CASE (6)
              IPR(90) = 512
              CALL PLUT12
C * NOMOVE
            CASE (7)
              IF (IPR(17) == 0) IGBL(30) = MOD (IGBL(30) + 1, 2)
              LRET = -1
C * NO-SYMM
            CASE (8)
              IGBL(52) = MOD (IGBL(52) + 1, 2)
              LRET = -1
C * FIT RESD 1 on 2
            CASE (9)
              IF (IPR(75) > 1) THEN
                IPR(33) = MENUH - 1
                CALL PLA280 ('FIT 1 2')
              ELSE
                LRET = -1
              END IF
C * HBOND-NORM
            CASE (10)
              IGBL(148) = MOD (IGBL(148) + 1, 2)
              IPR(87)   = IGBL(148)
              LRET = -1
C * SHELXL-ATOM WEIGHT
            CASE (11)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) IPR(181) = MOD(IPR(181) + 1, 2)
              LRET = -1
C * NO INVERT TOGGLE
            CASE (12)
              IF (IPR(33) == 1) THEN
                IPR(33) = 0
              ELSE
                IPR(33) = 1
              END IF
              LRET = -1
C * HELENA DIRCOS/ABSPSI
            CASE (15)
              IF (IPR(370) == 0) IPR(426) = MENUH - 1
C * FACE
            CASE (16)
              CALL PLA015 (451, 1)
              IPR(441) = 0
              IPR(442) = 0
              IPR(443) = 0
              IPR(444) = 0
              IF (IPR(451) == 1) THEN
                STRING = 'FACE'
                NCNT   = 5
                SBCD   = STRING(1:NCNT)//CHAR (0)
              ELSE
                STRING = ' '
                NCNT   = 0
              END IF
              LRET = -1
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('SIR97')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('SIR2004')
              ELSE IF (MENUH == 3) THEN
                CALL PLA280 ('SIR2011')
              END IF
C * ORGANIC/INORGANIC
            CASE (18)
              IGBL(97) = MOD (IGBL(97) + 1, 2)
C * SYSTEM-S/SHELXL OMIT-OUTLIER
            CASE (19)
              IGBL(51) = MOD (IGBL(51) + 1, 2)
              LRET = -1
C * CONTOUR PLANE-PERP
            CASE (22)
              CALL PLA280 ('PLAN')
              IPR(416) = 3
              IPR(420) = 0
C * NR+Sections
            CASE (23)
              IPR(578) = (MENUH * 2) - 1
              LRET = -1
C * UnitSymPack
            CASE (24)
              IPR(537) = MOD (IPR(537) + 1, 2)
C * TwinRotMat3
            CASE (25)
              IF (IPR(543) == 3) THEN
                IPR(543) = 0
              ELSE
                IPR(543) = 3
                CALL PLA280 ('TWIN')
                IPR(576) = 0
              END IF
C * NOSUBCELL
            CASE (26)
              IPR(503) = MOD (IPR(503) + 1, 2)
              IPR(699) = 1
              CALL PLA280 ('CALL ADDSYM')
C * Bijvoet Difference - Theta Plot
            CASE (29)
              CALL PLA280 ('SET IPR 656 1')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 10
        CASE (10)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * VIEW OPTIONS
            CASE (1)
C * VIEW UNIT
              IF (MENUH == 1) THEN
                CALL PLA226 (0, 0.0)
C * VIEW MIN
 
              ELSE IF (MENUH == 2) THEN
                IGBL(67) = 0
                IPR(201) = 0
C * VIEW XO
              ELSE IF (MENUH == 3) THEN
                CALL PLA226 ( 1, -90.0 / RGBL(6))
                CALL PLA226 (-2, -90.0 / RGBL(6))
C * VIEW YO
              ELSE IF (MENUH == 4) THEN
                CALL PLA226 ( 1, 90.0 / RGBL(6))
                CALL PLA226 (-3, 90.0 / RGBL(6))
C * VIEW ZO
              ELSE IF (MENUH == 5) THEN
                CALL PLA226 (3, 0.0)
              END IF
              MNH(6) = MENUH
              LRET = 4
C * VIEW MIN MENU-OPTION (PLUTON)
            CASE (2)
              IF (MENUH == 1) THEN
                CALL PLA280 ('VIEW UNIT')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('VIEW MIN')
              ELSE IF (MENUH == 3) THEN
                CALL PLA280 ('VIEW XO')
              ELSE IF (MENUH == 4) THEN
                CALL PLA280 ('VIEW YO')
              ELSE IF (MENUH == 5) THEN
                CALL PLA280 ('VIEW ZO')
              END IF
              MNH(6) = MENUH
C * PLUTON MOVE LABEL
            CASE (3)
              CALL PLA015 (349, 1)
              IF (IPR(351) == 1) CALL PLA015 (351, 1)
              IF (IPR(335) == 1) CALL PLA015 (335, 1)
              IF (IGBL(75) == 0) THEN
                CALL PLA280 ('LABEL ON')
              ELSE
                LRET = -1
              END IF
C * (RE)SET GLOBAL PATTERN
            CASE (4)
              IPR(345) = 0
              IPR(139) = MENUH - 1
C * VIEW INVERT
            CASE (5)
              CALL PLA280 ('VIEW INVERT')
C * LIST CELL
            CASE (6)
              CALL PLA280 ('LIST CELL')
C * KEYBOARD INSTRUCTION HELP
            CASE (7)
              CALL PLA280 ('HELP')
C * VIEW INVERT
            CASE (8)
              CALL PLA226 (-4, 0.0)
C * (U/A/E)WLSPL
            CASE (9)
              IPR(41) = MENUH - 1
              LRET = -1
C * NO-SYMM
            CASE (10)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) IGBL(52) = MOD (IGBL(52) + 1, 2)
              LRET = -1
C * (U/A/E)WLSPL
            CASE (11)
              IPR(41) = MENUH - 1
              LRET = -1
C * KeepMonI-n Toggle
            CASE (12)
              IGBL(106) = MOD (IGBL(106) + 1, 2)
C * ASYM SINT/L-MAX
            CASE (14)
              PAR(165) =
     1          ASIN ((0.45 + MENUH * 0.05) * PAR(17)) * RGBL(6)
          LRET = 3
C * DELFACE
            CASE (16)
              STRING(1:5) = 'DELF '
              NCNT = 5
              SBCD = STRING(1:NCNT)//CHAR (0)
              LRET = -1
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('EXOR')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('EXORS')
              ELSE IF (MENUH == 3) THEN
                CALL PLA280 ('EXORD')
              END IF
C * SYSTEM-S/SUB SOLVE CHECK
            CASE (18)
              IGBL(40) = MOD (IGBL(40) + 1, 2)
C * AUTO-EXTI-REF
            CASE (19)
              IGBL(96) = MOD (IGBL(96) + 1, 2)
              LRET     = -1
C * KeepMonI-n Toggle
            CASE (20)
              IGBL(106) = MOD (IGBL(106) + 1, 2)
C * CONTOUR PLANE-PERP (XY/YZ/XZ)
            CASE (22)
              CALL PLA280 ('PLAN')
              IPR(416) = 4
              IPR(420) = MENUH
              MNH(16)  = MENUH
C * GET AXIAL LENGTHS
              IF (MENUH == 1) THEN
                PAR(272) = PAR(101)
                PAR(273) = PAR(102)
              ELSE IF (MENUH == 2) THEN
                PAR(272) = PAR(101)
                PAR(273) = PAR(103)
              ELSE
                PAR(272) = PAR(102)
                PAR(273) = PAR(103)
              END IF
C * OPTIMIZE ORIENTATION
              IF (PAR(272) < PAR(273)) THEN
                PAR(276) = 90.0
                CALL GEN018 (PAR(272), PAR(273))
              ELSE
                PAR(276) = 0.0
              END IF
C * FIT TO RATIO PAR(50)
              IF (PAR(273) * PAR(50) < PAR(272)) THEN
                PAR(273) = PAR(272) / PAR(50)
              END IF
              PAR(273) = PAR(273) + 3.0
              PAR(272) = PAR(273) * PAR(50)
C * Fourier3D
            CASE (23)
              CALL PLA280 ('F3D')
C * SOLV/PLOT RESD
            CASE (24)
              IPR(140) = MENUH - 1
C * TwinRotMat4
            CASE (25)
              IF (IPR(543) == 4) THEN
                IPR(543) = 0
              ELSE
                IPR(543) = 4
                CALL PLA280 ('TWIN')
                IPR(576) = 0
              END IF
C * KeepMonI-n Toggle
            CASE (26)
              IGBL(106) = MOD (IGBL(106) + 1, 2)
C * Bijvoet Difference versus FoK Plot
            CASE (29)
              CALL PLA280 ('SET IPR 656 2')
C * POLY VIEW OPTIONS
            CASE (30)
C * VIEW UNIT
              IF (MENUH == 1) THEN
                CALL PLA226 (0, 0.0)
C * VIEW XO
              ELSE IF (MENUH == 2) THEN
                CALL PLA226 (2, 90.0 / RGBL(6))
C * VIEW YO
              ELSE IF (MENUH == 3) THEN
                CALL PLA226 (1, -90.0 / RGBL(6))
C * VIEW ZO
              ELSE IF (MENUH == 4) THEN
                CALL PLA226 (3, 90.0 / RGBL(6))
              END IF
              MNH(6) = MENUH
              LRET = 3
C * NTRY
            CASE (31)
              WRITE (IGGT, 99975, IOSTAT = IOST) MENUH
C * MU CuKa
            CASE (33)
              CALL PLA280 ('MU 1.5418')
C * KeepMonI-n Toggle
            CASE (37)
              IGBL(106) = MOD (IGBL(106) + 1, 2)
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 11
        CASE (11)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * DISORDER TOGGLE
            CASE (1)
              IF (IPR(44) /= 0) THEN
                IF (MENUH - 1 /= IGBL(88)) THEN
                  IF (IGBL(59) == 1) THEN
                    IGBL(88) = MENUH - 1
                  ELSE
                    IGBL(59) = MOD (IGBL(59) + 1, 2)
                  END IF
                ELSE
                  IGBL(59) = MOD (IGBL(59) + 1, 2)
                  IGBL(88) = MENUH - 1
                END IF
              END IF
              IPR(201) = 0
              LRET = 4
C * NODISORDER TOGGLE
            CASE (2)
              IF (MENUH - 1 /= IGBL(88)) THEN
                IF (IGBL(59) == 1) THEN
                  IGBL(88) = MENUH - 1
                ELSE
                  IGBL(59) = MOD (IGBL(59) + 1, 2)
                END IF
              ELSE
                IGBL(59) = MOD (IGBL(59) + 1, 2)
                IGBL(88) = MENUH - 1
              END IF
C * CALC GEOM
            CASE (3)
              IPR(351) = 0
              CALL PLA015 (341, 1)
              LRET = -1
C * RADII BONDS TAPER
            CASE (4)
              IF (MENUH > 1) THEN
                PAR(44) = 0.5 * 2.0 ** (MENUH - 4)
              ELSE
                PAR(44) = 0.0
              END IF
C * VIEW LINE
            CASE (5)
              IFL(1) = 'VIEW '
              IFL(2) = 'LINE '
              CALL PLA015 (329, 1)
              LRET = -1
C * LIST SYMM
            CASE (6)
              CALL PLA274
              CALL PLA280 ('PLOT')
C * Auto-Plot
            CASE (7)
              IGBL(35) = MOD (IGBL(35) + 1, 2)
              LRET = -1
C * COLOR TYPE (ORTEP)
            CASE (8)
              CALL PLA015 (536, MENUH)
              LRET = -1
C * ANGLE BETWEEN LINES
            CASE (9)
              CALL PLA015 (341, 5)
              LRET = -1
C * DISORDER TOGGLE
            CASE (10)
              IF (IPR(44) /= 0) THEN
                IF (MENUH - 1 /= IGBL(88)) THEN
                  IF (IGBL(59) == 1) THEN
                    IGBL(88) = MENUH - 1
                  ELSE
                    IGBL(59) = MOD (IGBL(59) + 1, 2)
                  END IF
                ELSE
                  IGBL(59) = MOD (IGBL(59) + 1, 2)
                  IGBL(88) = MENUH - 1
                END IF
              END IF
              LRET = -1
C * ExclDisOper
            CASE (11)
              IPR(154) = MOD (IPR(154) + 1, 2)
              LRET = -1
C * NOEXPAND
            CASE (12)
              IF (IGBL(136) == 0) THEN
                CALL PLA280 ('NOEXPAND')
                LRET = 2
              ELSE
                IGBL(136) = 0
              END IF
 
C * OMIT SIGMA - ASYM
            CASE (14)
              PAR(284) = (MENUH - 1) * 0.5
              LRET = 3
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 1')
C * Refl.List
            CASE (16)
              IGBL(57) = MOD (IGBL(57) + 1, 2)
C * SYSTEM-S
            CASE (17)
              WRITE(IGGT(1:14), 99993, IOSTAT = IOST) MENUH - 1
C * SYSTEM-S/SUB ADDSYM CHECK
            CASE (18)
              IGBL(41) = MOD (IGBL(41) + 1, 2)
            CASE (19)
              IGBL(125) = MOD (IGBL(125) + 1, 2)
              LRET = -1
C * CONTOUR WINDOW-VERTICAL
            CASE (22)
              PAR(279) = - 1.5 + MENUH
              LRET = 2
C * Unit-Fill
            CASE (24)
              IPR(535) = MOD (IPR(535) + 1, 2)
C * EPS-TwinLat
            CASE (25)
              IPR(543) = MENUH
              MEDIUM      = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('TWIN')
C * Bijvoet Dif Dif/Sig versus Theta
            CASE (29)
              CALL PLA280 ('SET IPR 656 -1')
C * POLY (0/1) DRAW POLYEDRA
            CASE (30)
              IPR(353) = MOD (IPR(353) + 1, 2)
              LRET = 3
C * NSOLVE
            CASE (31)
              WRITE (IGGT, 99974, IOSTAT = IOST) MENUH * 250
C * MU GaKa
            CASE (33)
              CALL PLA280 ('MU 1.3414')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 12
        CASE (12)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * LABELS (ON/OFF)
            CASE (1)
              IF (MENUH == IPR(232) + 1)
     1             IGBL(75) = MOD (IGBL(75) + 1, 2)
              IF (MENUH == 2) THEN
                IPR(232) = 1
                IPR(201) = 0
              ELSE
                IPR(232) = 0
              END IF
              IF (IGBL(75) == 1) WRITE (LU6, 99999, IOSTAT = IOST)
              IF (IGBL(35) == 1) THEN
                LRET = 2
              ELSE
                LRET = -1
              END IF
C * LABEL SIZE
            CASE (2)
              PAR(349) = 0.20 + 0.05 * MENUH
C * SELECT ZOOM CENTRE
            CASE(3)
              CALL PLA015 (343, 1)
              LRET = -1
C * OVERLAP MARGIN
            CASE (4)
              PAR(36) = (MENUH - 1) * 0.05
C * VIEW PERP
            CASE (5)
              IFL(1) = 'VIEW '
              IFL(2) = 'PERP '
              CALL PLA015 (329, 2)
              LRET = -1
C * LIST ATOMS
            CASE (6)
              IPR(90)  = 4
              IPR(220) = 2
              CALL PLUT12
C * OVERLAP MARGIN
            CASE (7)
              PAR(58) = (MENUH - 1) * 0.05
C * RASTER-3D
            CASE (8)
              IPR(108) = 1
              IPR(148) = MENUH - 1
              LRET = 2
C * LIST RADII BONDS
            CASE (9)
              CALL PLA280 ('RADII BONDS')
C * LIST ARU (PLATON)
            CASE (10)
              IF (MENUH == 1) THEN
                CALL PLA280 ('LIST ARU')
                LRET = 2
              ELSE
                WRITE (BCD, 99997, IOSTAT = IOST)
     1            (PAR(J), J = 113, 115),
     2            (ACOS (PAR(J)) * RGBL(6), J = 116, 118), PAR(17),
     3            CHAR (0)
                CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
                LRET = -1
              END IF
C * SET FCF-CALC FOR BIJVOET ETC
            CASE (12)
              IPR(594) = MOD (IPR(594) + 1, 2)
              LRET = -1
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 2')
C * WRITE DIRECTION COSINES
            CASE (11, 16)
              IPR(445) = MOD (IPR(445) + 1, 2)
              LRET = -1
C * SYSTEM-S
            CASE (17)
              WRITE (IGGT(1:16), 99992, IOSTAT = IOST) MENUH - 1
C * SYSTEM-S/SUB VALID CHECK
            CASE (18)
              IGBL(34) = MOD (IGBL(34) + 1, 2)
C * VERT-ANG-SIZE
            CASE (22)
              PAR(273) = MENUH * 5.0
              PAR(272) = 4.0 * PAR(273) / 3.0
              CALL PLA280 ('SCAL')
C * SELECT VOID
            CASE (24)
              IPR(531) = MENUH - 1
C * TwinPLOT Resolution
            CASE (25)
              PAR(449) = MENUH * 0.1
              CALL PLA280 ('RESOLUTION')
C * Bijvoet Dif Dif/Sig versus FOK
            CASE (29)
              CALL PLA280 ('SET IPR 656 -2')
C * POLY/SHADE
            CASE (30)
              IPR(358) = MOD (IPR(358) + 1, 2)
              LRET = 3
C * NSOLVE
            CASE (31)
              WRITE (IGGT, 99973, IOSTAT = IOST) MENUH
C * MU MoKa
            CASE (33)
              CALL PLA280 ('MU 0.71073')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 13
        CASE (13)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * LABPOS ON/OFF
            CASE (1)
              CALL PLA015 (349, 1)
              IPR(311) = 0
              IPR(327) = 0
              IPR(328) = 0
              IPR(351) = 0
              LRET     = -1
C * UNIT ON/OFF
            CASE (2)
              IF (IPR(46) == 0) THEN
                CALL PLA280 ('UNIT ON')
              ELSE
                CALL PLA280 ('UNIT OFF')
              END IF
C * PLUTON - ZOOM FACTOR
            CASE (3)
              IPR(130) = 0
              PAR(13)  = 0.4 + MENUH * 0.5
              CALL PLA280 ('PLOT')
C * RESOLUTION
            CASE (4)
              IPR(111) = 2 ** (4 - MENUH)
              PAR(5)   = 1.0 / (3.33333 ** MENUH)
C * VIEW BISECT
            CASE (5)
              IFL(1) = 'VIEW '
              IFL(2) = 'BISECT '
              CALL PLA015 (329, 3)
              LRET = -1
C * LIST BONDS
            CASE (6)
              IPR(90) = 8
              CALL PLUT12
C * POVRAY RESOLUTION
            CASE (7)
              IGBL(123) = MENUH - 1
C * ELLIPS
            CASE (8)
              IPR(177) = MENUH - 1
              IPR(211) = 0
              LRET     = 3
C * LIST CELL/SYMM/ORTEP-SUP2
            CASE (9)
              IF (MENUH == 1) THEN
                WRITE (BCD, 99998, IOSTAT = IOST) PAR(17),
     1           (PAR(J), J = 101, 106), PAR(98), CHAR (0)
                CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
                LRET = -1
              ELSE
                CALL PLA274
                CALL GEN038 (ICL, 1, 80)
                LRET = 4
              END IF
C * LIST CELL/SYMM
            CASE (10)
              IF (MENUH == 1) THEN
                IF (PAR(98) == 1.0) CALL PLA100
                WRITE (BCD, 99998, IOSTAT = IOST) PAR(17),
     1            (PAR(J), J = 101, 106), 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
             END IF
C * NO-CHECK DIRECTION COSINES
            CASE (11)
              IPR(363) = MOD (IPR(363) + 1, 2)
              LRET = -1
C * TIFF/PNG TOGGLE
            CASE (12)
              IGBL(109) = MOD (IGBL(109) + 1, 2)
              LRET = -1
C * ASYM MISSED REFL
            CASE (14)
              IPR(369) = MOD (IPR(369) + 1, 2)
              IPR(389) = 0
              LRET     = 4
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 3')
C * NO-CHECK DIRECTION COSINES
            CASE (16)
              IPR(363) = MOD (IPR(363) + 1, 2)
              LRET = -1
C * SYSTEM-S TWINROTMAT
            CASE (17)
              CALL PLA280 ('TWINMAT')
C * SEARCH CSD
            CASE (18)
              CALL PLA280 ('PLATON CSD')
C * VERT-SHIFT
            CASE (22)
              IF (MENUH > 3) THEN
                DELTA = (MENUH - 3) * 0.5
              ELSE
                DELTA = (MENUH - 4) * 0.5
              END IF
              PAR(274) = PAR(274) + DELTA * COS (PAR(276) / RGBL(6))
              PAR(275) = PAR(275) + DELTA * SIN (PAR(276) / RGBL(6))
              CALL PLA280 ('SCAL')
C * UNITCELL SOLV PLOT
            CASE (24)
              IPR(527) = MOD (IPR(527) + 1, 2)
C * TOGGLE ICALC (FROMCIF/FROMFCF)
            CASE (25)
              IPR(608) = MOD (IPR(608) + 1, 2)
              CALL PLA280 ('FROM')
C * PP-BIJVOET
            CASE (29)
              IPR(652) = MENUH - 1
              CALL PLA280 ('NPP')
C * POLY UNITCELL ON/OFF
            CASE (30)
              IPR(357) = MOD (IPR(357) + 1, 2)
              LRET = 3
C * DELTA
            CASE (31)
              WRITE (IGGT, 99972, IOSTAT = IOST) MENUH * 0.01
C * MU AgKa
            CASE (33)
              CALL PLA280 ('MU 0.56086')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 14
        CASE (14)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * SET LABEL SIZE
            CASE (1)
              PAR(349) = 0.20 + MENUH * 0.05
              IPR(201) = 0
              LRET = 3
C * ARU NONE # (PLOT RESIDUE #)
            CASE (2, 3, 5, 6)
              IF (MENUH == 1) THEN
                CALL PLA280 ('ARU RESTORE')
              ELSE
                WRITE (IGGT(1:14), 99971, IOSTAT = IOST) MENUH - 1
              END IF
              IPR(140) = MENUH - 1
            CASE (4)
              IF (IPR(63) == 0) THEN
                CALL PLA280 ('LABEL ARU')
              ELSE
                CALL PLA280 ('UNLABEL ARU')
              END IF
C * PLUTON BOX RATIO
            CASE (7)
              IF (MENUH == 1) THEN
                PAR(18) = SIGN (1.0, PAR(18))
              ELSE
                PAR(18) = SIGN (1.333, PAR(18))
              END IF
C * ENVELOPE
            CASE (8)
              IPR(211) = 1
              LRET     = 3
C * LIST ATOMS/UIJ
            CASE (9)
              IF (MENUH == 1) THEN
                CALL PLA280 ('LIST ATOMS')
              ELSE
                CALL PLA280 ('LIST UEQ')
              END IF
C * LIST ATOMS
            CASE (10)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
C * SET UP CONNECTED SET
                CALL PLA067
                IF (IPR(2) /= 0) RETURN
              END IF
              IPR(220) = 2
              IPR(221) = 0
              CALL PLA073 (1, 1)
C * NOSORT
            CASE (11)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) IGBL(33) = MOD (IGBL(33) + 1, 2)
              LRET = -1
C * Refl List
            CASE (12)
              IGBL(57) = MOD (IGBL(57) + 1, 2)
              LRET = -1
C * (0/1) DISPLAY 'E' IN ASYM VIEW
            CASE (14)
              IPR(776) = MOD (IPR(776) + 1, 2)
              LRET = 4
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 4')
C * CELL DIMENSION PLOT (ABSORB)
            CASE (16)
              IPR(331) = MOD (IPR(331) + 1, 2)
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('HDIF')
              ELSE
                CALL PLA280 ('HFIX')
                IF (IPR(351) == 1) CALL PLA015 (351, 1)
              END IF
C * RPLUTO
            CASE (18)
              CALL PLA280 ('RPLUTO')
C * HORIZONTAL SHIFT
            CASE (22)
              IF (MENUH > 3) THEN
                DELTA = (MENUH - 3) * 0.5
              ELSE
                DELTA = (MENUH - 4) * 0.5
              END IF
              PAR(275) = PAR(275) + DELTA * COS (PAR(276) / RGBL(6))
              PAR(274) = PAR(274) - DELTA * SIN (PAR(276) / RGBL(6))
              CALL PLA280 ('SCAL')
C * SOLV SHOW MOL PLOT
            CASE (24)
              IPR(528) = MOD (IPR(528) + 1, 2)
            CASE (25)
C * Poly: InclAtoms
            CASE (30)
              IPR(359) = MOD (IPR(359) + 1, 2)
              LRET     = 3
C * PERC
            CASE (31)
              WRITE (IGGT, 99970, IOSTAT = IOST) MENUH * 0.05
C * I-OR-F
            CASE (32)
              IPR(711) = MOD (IPR(711) + 1, 2)
C * MU InKa
            CASE (33)
              CALL PLA280 ('MU 0.51359')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 15
        CASE (15)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * DELETE LABEL (ON/OFF)
            CASE (1)
              CALL PLA015 (327, 1)
              IPR(440) = 0
              IPR(349) = 0
              IPR(328) = 0
              LRET = -1
C * JOIN HBONDS
            CASE (2)
              IF (MENUH == 1) THEN
                CALL PLA280 ('JOIN RADII INTER HBONDS')
              ELSE
                CALL PLA280 ('JOIN RADII INTER XBONDS')
              END IF
C * HFIX - ANIS
            CASE (3)
C * TEST FOR TYPE RES FILE
              IF (IABS(IGBL(8)) == 2) THEN
C * CASE HFIX
                IF (MENUH == 1) THEN
                  IF (IPR(351) == 1) CALL PLA015 (351, 1)
                  IF (IPR(335) == 1) CALL PLA015 (335, 1)
                  CALL PLA015 (332, 1)
                  IF (IGBL(75) == 0) THEN
                    CALL PLA280 ('LABEL ON')
                  ELSE
                    LRET = -1
                  END IF
C * CASE ANIS
                ELSE IF (MENUH == 2) THEN
                  CALL PLA015 (352, 1)
                  IF (IGBL(3) == 26) LRET = -1
                END IF
              ELSE
                IF (MENUH == 1) THEN
                  CALL PLA015 (427, 30)
                ELSE
                  CALL PLA015 (427, 44)
                END IF
                LRET = -1
              END IF
C * (UN)LABEL UNITCELL
            CASE (4)
              IF (IPR(339) == 0) THEN
                CALL PLA280 ('LABEL UNIT')
                IPR(46) = 1
              ELSE
                CALL PLA280 ('UNLABEL UNIT')
              END IF
C * POVRAY-STYLE
            CASE (7)
              IGBL(101) = MENUH - 1
              CALL PLA280 ('PLOT POV')
              IPR (340) = 1
              IGBL(98)  = 0
C * OCTANT
            CASE (8)
              IPR(177) = MENUH - 1
              IPR(211) = 2
              LRET = 3
C * LIST FLAGS/RADII
            CASE (9)
              IF (MENUH == 1) THEN
                CALL PLA280 ('LIST FLAGS')
              ELSE
                CALL PLA280 ('LIST RADII')
              END IF
C * LIST BONDS
            CASE (10)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
C * SET UP CONNECTED SET
                CALL PLA067
                IF (IPR(2) /= 0) RETURN
              END IF
              IPR(220) = 2
              IPR(221) = 0
              CALL PLA074 (2, 1)
C * BOND-VALENCE
            CASE (11)
              IGBL(121) = MOD (IGBL(121) + 1, 2)
              LRET = -1
C * DEBUG TOGGLE
            CASE (12)
              IGBL(74) = MOD (IGBL(74) + 1, 2)
              LRET = -1
C * ASYM MULTISCAN
            CASE (14)
              IPR(468) = MOD (IPR(468) + 1, 2)
              LRET     = 3
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 5')
C * XTAL AXES PLOT
            CASE (16)
              IPR(388) = MOD (IPR(388) + 1, 2)
C * SYSTEM-S
            CASE (17)
              WRITE (IGGT(1:16), 99991, IOSTAT = IOST) MENUH - 1
C * SYSTEM-S/SUB1
            CASE (18)
              CALL PLA280 ('CONTOUR PT')
C * DEBUG TOGGLE
            CASE (19)
              IGBL(74) = MOD (IGBL(74) + 1, 2)
              LRET = -1
C * +/- ROTATION
            CASE (22)
              IF (MENUH > 3) THEN
                ZROT = (MENUH - 3) * 30.0
              ELSE
                ZROT = (MENUH - 4) * 30.0
              END IF
              WRITE (IGGT, 99990, IOSTAT = IOST) ZROT
C * SOLV OHASHI VOLUME PLOT
            CASE (24)
              IPR(529) = MOD (IPR(529) + 1, 2)
              LRET     = 4
C * TWINROTMAT ZONE-H,K,L
            CASE (25)
              IPR(394) = MENUH
              CALL PLA280 ('ZONE')
C * APPLY SLOPE
            CASE (29)
              IPR(593) = MOD (IPR(593) + 1, 2)
              CALL PLA280 ('SLOPE')
C * UNIT LABEL (ON/OFF)
            CASE (30)
              IPR(339) = MOD (IPR(339) + 1, 2)
              LRET = 3
C * UISO
            CASE (31)
              WRITE (IGGT, 99976, IOSTAT = IOST) (MENUH - 1) * 0.01
C * ANAL-OF-VAR - SCATTER PLOT
            CASE (32)
              CALL PLA280 ('SCATTER')
C * FCF-COMPARE  - SCATTER PLOT
            CASE (34)
              CALL PLA280 ('SCATTER')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 16
        CASE (16)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * INCLUDE LABEL
            CASE (1)
              CALL PLA015 (328, 1)
              IGBL(75) = 1
              IPR(440) = 0
              IPR(349) = 0
              IPR(327) = 0
            CASE (2)
C * ARU-UNIQUE/PACKRANGE
              MNH(7) = MENUH
              IF (MENUH == 1) THEN
                CALL PLA280 ('ARU NONE 1555')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('ARU UNIQUE')
              ELSE
                WRITE (IGGT(1:46), 99969, IOSTAT = IOST)
     1            0.45 - DX, 0.55 + DX, 0.45 - DX, 0.55 + DX,
     2            0.45 - DX, 0.55 + DX
              END IF
C * VIEW MIN MENU-OPTION (PLUTON)
            CASE (3)
              IF (MENUH == 1) THEN
                CALL PLA280 ('VIEW UNIT')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('VIEW MIN')
              ELSE IF (MENUH == 3) THEN
                CALL PLA280 ('VIEW XO')
              ELSE IF (MENUH == 4) THEN
                CALL PLA280 ('VIEW YO')
              ELSE IF (MENUH == 5) THEN
                CALL PLA280 ('VIEW ZO')
              END IF
              MNH(6) = MENUH
C * (UN)LABEL ATOM
            CASE (4)
              IF (IPR(452) == 0) THEN
                CALL PLA280 ('LABEL ATOM')
              ELSE
                CALL PLA280 ('UNLABEL ATOM')
              END IF
C * PLUTON PARENTHESES
            CASE (7)
              IPR(71) = MOD (IPR(71) + 1, 2)
C * ORTEP/PARENTHESES
            CASE (8)
              IF (IPR(759) == 0) THEN
                IPR(350) = MOD (IPR(350) + 1, 2)
                IPR(201) = 0
                LRET     = 4
              ELSE
                LRET = -1
              END IF
C * LIST ARU
            CASE (9)
              LRET = 1
              CALL PLA280 ('LIST ARU')
C * LIST UIJ
            CASE (10)
              LRET = 2
              CALL PLA280 ('LIST UIJ')
C * RESD SORT TOGGLE
            CASE (11)
              IPR(597) = MOD (IPR(597) + 1, 2)
C * SET WINDOW SIZE
            CASE (12)
              IGBL(62) = MENUH
              WRITE (IGGT, 99988, IOSTAT = IOST) IGBL(62) / 4.0
              LRET = 2
C * ASYM OBS/CALC/DELTA
            CASE (14)
              IPR(132) = MENUH - 1
              LRET = 3
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 6')
C * XTAL VERTEX LABELS  PLOT
            CASE (16)
              IGBL(75) = MOD (IGBL(75) + 1, 2)
C * SYSTEM-S
            CASE (17)
              WRITE (IGGT(1:17), 99989, IOSTAT = IOST)  MENUH - 1
C * SYSTEM-S/SUB1
            CASE (18)
              CALL PLA280 ('CONTOUR DF')
C * BONDS IN CONTOUR
            CASE (22)
              CALL PLA015 (458, 1)
              LRET = 2
C * SOLV LABEL UNITCELL
            CASE (24)
              IPR(532) = MOD (IPR(532) + 1, 2)
C * TWINROTMAT UP/DOWN
            CASE (25)
              IF (MENUH == 1) THEN
                IPR(389) = 1
              ELSE
                IPR(389) = -1
              END IF
              CALL PLA280 ('NEXT')
C * POLY PACK RANGE
            CASE (30)
              IF (MENUH > 1) THEN
                IPR(354) = MENUH - 1
              ELSE
                IPR(354) = -1
              END IF
              LRET = 3
C * LOGLOG/LINEAR PLOT
            CASE (32)
              IF (IPR(633) == 0) THEN
                CALL PLA280 ('LOGLOG')
              ELSE IF (IPR(633) == 1) THEN
                CALL PLA280 ('LINEAR')
              END IF
C * FCF-COMPARE, LOGLOG/LINEAR PLOT
            CASE (34)
              IF (IPR(633) == 0) THEN
                CALL PLA280 ('LOGLOG')
              ELSE IF (IPR(633) == 1) THEN
                CALL PLA280 ('LINEAR')
              END IF
            CASE DEFAULT
             LRET = -1
          END SELECT
C * MENU BOX # 17
        CASE (17)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * PLOT ADP RESD (0,1,2...)
            CASE (1, 8, 9)
              IPR(140) = MENUH - 1
              IPR(201) = 0
              LRET     = 4
C * LABEL ON/OFF
            CASE (2, 3, 4, 5, 6)
              IF (IGBL(75) == 1) THEN
                IF (MENUH /= IPR(232) + 1) IGBL(75) = 0
              END IF
              IF (MENUH == 2) THEN
                IPR(232) = 1
              ELSE
                IPR(232) = 0
              END IF
              IF (IGBL(75) == 0) THEN
                CALL PLA280 ('LABEL ON')
              ELSE
                CALL PLA280 ('LABEL OFF')
              END IF
C * PORTRAIT MODE
            CASE (7)
              CALL PLA280 ('PORTRAIT')
C * EXCLUDE H (TO BE REQUESTED PRIOR TO CALC INTRA)
            CASE (10)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) THEN
                IPR(605) = 1
                CALL PLA280 ('EXCLUDE H')
                LRET = 2
              END IF
C * DEF COORDN RADIUS
            CASE (11)
              PAR(7) = 2.0 + MENUH
              WRITE (BCD, 99977, IOSTAT = IOST) PAR(7), CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
              LRET = -1
C * RATIO/PORTRAIT
            CASE (12)
              CALL PLA280 ('PORTRAIT')
              LRET = 2
C * CREMER&POPLE
            CASE (13)
              CALL PLA280 ('CANDP')
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 7')
C * XTAL PLOT-SCALE
            CASE (16)
              PAR(325) = 1.0 + (MENUH - 1) * 0.25
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('PLUTON')
              ELSE
                CALL PLA280 ('RENAME')
              END IF
C * SYSTEM-S/SUP1
            CASE (18)
              CALL PLA280 ('CONTOUR FO')
C *SIRWINDOW
            CASE (19)
              IGBL(122) = MOD (IGBL(122) + 1, 2)
              LRET = -1
C * CONTOUR
            CASE (22)
              IF (MENUH == IPR(232) + 1)
     1          IGBL(75) = MOD (IGBL(75) + 1, 2)
              IF (MENUH == 2) THEN
                IPR(232) = 1
                IPR(201) = 0
              ELSE
                IPR(232) = 0
              END IF
              LRET = 2
C * SOLV LABELS (ON/OFF)
            CASE (24)
              IF (MENUH == IPR(232) + 1)
     1          IGBL(75) = MOD (IGBL(75) + 1, 2)
              IF (MENUH == 2) THEN
                IPR(232) = 1
              ELSE
                IPR(232) = 0
              END IF
C * RacemicTwin
            CASE (25)
              IPR(575) = MOD (IPR(575) + 1, 2)
              LRET = -1
C * STUDENT-T
            CASE (29)
              IPR(613) = 1
              PAR(488) = 0.0
              IPR(617) = 1
              CALL PLA280 ('SWITCH')
C * POPY OMIT OUTSIDE
            CASE (30)
              IPR(356) = MOD (IPR(356) + 1, 2)
              LRET = 2
C * STANDARD DEVIATION TOGGLE
            CASE (32)
              IPR(634) = MOD (IPR(634) + 1, 2)
               CALL PLA280 ('STANDARD')
            CASE DEFAULT
             LRET = -1
          END SELECT
C * MENU BOX # 18
        CASE (18)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
            CASE (1)
C * CROTY
              IPR(479) = 2
C * ROTATION ANGLE STEP
              PAR(389) = ANGC
C * RECALCULATE LABEL POSITION
              IPR(201) = 0
              LRET     = 6
            CASE (2, 3)
              WRITE (IGGT(1:20), 99986, IOSTAT = IOST) ANGC
C * DEFINE (PLUTON)
            CASE (4)
              IF (MENUH == 1) THEN
                IFL(1) = 'DEFINE'
                IFL(2) = 'CG'
                LMOD   = 2
C * SET DEFINE STATUS
                IPR(507) = 1
C * ISSUE INFO MESSAGE
                CALL PLA015 (508, 2)
                LRET = -1
              ELSE IF (MENUH == 2) THEN
                IF (IPR(508) == 2) THEN
C * SET DEFINE STATUS
                  IPR(507) = 2
                  IPR(508) = 0
                  WRITE (IGGT, 99995, IOSTAT = IOST)
     1              (IFL(I)(1:7), I = 1, LMOD)
                  IGBL(6) = IABS (IGBL(6))
                END IF
              END IF
C * ENTRY
            CASE (6)
              CALL PLA280 ('ENTRY')
C * REVERSE B&W
            CASE (7)
              WRITE (IGGT, 99987, IOSTAT = IOST)
C * RADII BONDS Normal (LINES)
            CASE (8)
              PAR(85) = MENUH
              LRET    = 4
C * REVERSE B&W
            CASE (9)
              WRITE (IGGT, 99987, IOSTAT = IOST)
C * Min-Q-Peak Height
            CASE (10)
              IF (IABS(IGBL(8)) == 2) THEN
                RGBL(26) = MENUH  * 0.20
                WRITE (BCD, 99979, IOSTAT = IOST)
     1            RGBL(26), RGBL(27), CHAR (0)
                CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
              END IF
              LRET = -1
C * UisoHRadius toggle
            CASE (11)
              IPR(603) = MOD (IPR(603) + 1, 2)
              LRET     = -1
C * GenerSthlMx
            CASE (12)
              IWIN = 1
              PAR(540) = 0.45 + MENUH * 0.05
              IPR(221) = 1
              FN(1)    = 540
              CALL PLA206 (-1, 'PAR')
              LRET = -1
C * PLOT ADP COLOR
            CASE (13)
              IGBL(6) = 1
              CALL PLA280 ('PLOT ADP COLOR')
C * ASYM UP/DOWN
            CASE (14)
              IF (MENUH == 1) THEN
                IPR(389) = 1
              ELSE
                IPR(389) = -1
              END IF
              LRET = 4
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 8')
C * ABSCOR/XTAL
            CASE (16)
              WRITE (IGGT(1:20), 99985, IOSTAT = IOST) ANGC
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('PLATON')
              ELSE
                CALL PLA280 ('PLATON ADP')
              END IF
C * SYSTEM-S/SUB1
            CASE (18)
              CALL PLA280 ('CONTOUR SQ')
C * REVERSE B&W
            CASE (19)
              WRITE (IGGT, 99987, IOSTAT = IOST)
C * CPI-FILE
            CASE (21)
              IPR(650) = MOD (IPR(650) + 1, 2)
              LRET     = 3
C * CONTOUR GRID STEP
            CASE (22)
              PAR(278)  = 0.1 * MENUH
              LRET = 2
C * CONTOUR GRID STEP
            CASE (23)
              PAR(278) = 0.1 * MENUH
              LRET = 2
C * SET LABEL SIZE
            CASE (24)
              PAR(349) = 0.20 + MENUH * 0.05
C * SelectTwinMatrix#1
            CASE (25)
              IPR(571) = MOD (IPR(571) + 1, 2)
              LRET = -1
C * ListDetails
            CASE (26)
              IPR(566) = MOD (IPR(566) + 1, 2)
              LRET     = -1
C * GAUSSIAN
            CASE (29)
              IPR(613) = 0
              PAR(488) = 0.0
              IPR(617) = 1
              CALL PLA280 ('SWITCH')
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 19
        CASE (19)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * ROTZ
            CASE (1, 9)
              IPR(479) = 3
              IF (MENUH > 5) THEN
                PAR(389)  = 2 ** (MENUH - 6)
              ELSE
                PAR(389)  =  - 2 ** (5 - MENUH)
              END IF
              IPR(201) = 0
              LRET     = 2
C * X-LineWidth
            CASE (7)
              IGBL(69) = MOD (IGBL(69) + 1, 2)
              YGGIP    = - 100 * (IGBL(69) + 1)
              CALL GGIP (0.0, YGGIP, 0.0, 0)
C * RADII BONDS to Metal (LINES)
            CASE (8)
              PAR(89) = MENUH
              LRET    = 4
C * Min-Q-Peak Dis
            CASE (10)
              IF (IABS (IGBL(8)) == 2) THEN
                RGBL(27) = (MENUH - 1) * 0.25
                WRITE (BCD, 99979, IOSTAT = IOST)
     1            RGBL(26), RGBL(27), CHAR (0)
                CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
              END IF
              LRET = -1
C * INCL C-H ..X
            CASE (11)
              IPR(645) = MOD (IPR(645) + 1, 2)
C * GenerRandom
            CASE (12)
              IPR(647) = MOD (IPR(647) + 1, 2)
C * NEWMAN PLOT
            CASE (13)
              IPR(55) = -1
              CALL PLA280 ('YES')
C * HELENA-RR#
            CASE (15)
              CALL PLA280 ('RR 9')
C * ROTZ
            CASE (16)
              IF (MENUH > 5) THEN
                IANG  = 2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:9), 99996, IOSTAT = IOST) 'Z', IANG
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('INVERT')
              ELSE
                CALL PLA280 ('HFREE')
              END IF
C * ANIS
            CASE (19)
              IF (MENUH == 1) THEN
                CALL PLA280 ('ANIS')
              ELSE IF (MENUH == 2) THEN
 
              END IF
C * LISTREFL (POWDER)
            CASE (21)
              CALL PLA280 ('LIST')
C * CONTOUR STEP
            CASE (22)
              IPR(419)  = NINT (2.5 * 2 ** MENUH)
              LRET = 2
C * SOLV ROTZ
            CASE (24)
              IPR(479) = 3
              IF (MENUH > 5) THEN
                PAR(389) = 2 ** (MENUH - 6)
              ELSE
                PAR(389) =  - 2 ** (5 - MENUH)
              END IF
              LRET = 3
C * SelectTwinMatrix#2
            CASE (25)
              IPR(572)  = MOD (IPR(572) + 1, 2)
              LRET      = -1
C * ADDSYM PART#
            CASE (26)
              IF (MENUH == 1) THEN
                CALL PLA280 ('CALC ADDSYM PART 1')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('CALC ADDSYM PART 2')
              END IF
C * Hooft NU VALUE (Manual)
            CASE (29)
              IPR(613) = 1
              IPR(617) = 0
              PAR(488) = MENUH * 5
              CALL PLA280 ('NUVAL')
C * POLY ROTZ
            CASE (30)
              IF (MENUH > 5) THEN
                IANG  = 2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:9), 99996, IOSTAT = IOST) 'Z', IANG
            CASE DEFAULT
              IF (MENUH > 5) THEN
                IANG  = 2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:18), 99984, IOSTAT = IOST) IANG
          END SELECT
C * MENU BOX # 20
        CASE (20)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * ROTY
            CASE (1, 9)
              IPR(479) = 2
              IF (MENUH > 5) THEN
                PAR(389)  = 2 ** (MENUH - 6)
              ELSE
                PAR(389)  =  - 2 ** (5 - MENUH)
              END IF
              IPR(201) = 0
              LRET     = 2
C * SET Q-PEAK DELETE CRIT (PLUTON)
            CASE (7)
              RGBL(25) = (MENUH - 1) * 0.25
              CALL PLA280 ('RESET')
C * RADII BONDS ALL
            CASE (8)
              PAR(86) = MENUH * 0.01
              PAR(88) = MENUH * 0.01
              PAR(90) = MENUH * 0.01
              LRET = 4
C * Q-Peak-Include
            CASE (10)
              IF (MENUH == 1) THEN
                IGBL(95) = MOD (IGBL(95) + 1, 2)
                RGBL(25) = RGBL(27)
              ELSE IF (MENUH == 2) THEN
                IGBL(95) = 1
              END IF
              CALL PLA280 ('RESTART')
              LRET = 2
C * SET Q-PEAK DELETE CRIT
            CASE (11)
              IF (IABS(IGBL(8)) == 2) THEN
                RGBL(25) = (MENUH - 1) * 0.25
                CALL PLA280 ('RESTART')
                LRET = 2
              ELSE
                LRET = -1
              END IF
C * SET META ...
            CASE (12)
              MNH(12) = MENUH
              IF (MENUH == 1) THEN
                CALL PLA280 ('SET META PS')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('SET META HPGL')
              END IF
              LRET = 2
C * RING PLOT
            CASE (13)
              IPR(55) = 2
              CALL PLA280 ('YES')
C * ROTY
            CASE (16)
              IF (MENUH > 5) THEN
                IANG  = 2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:9), 99996, IOSTAT = IOST) 'Y', IANG
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('ASYM')
              ELSE
                CALL PLA280 ('ASYM VIEW')
              END IF
            CASE (18)
              CALL PLA280 ('BROWSE PS')
            CASE (19)
              LRET = -1
C * POWDER DISPL Q-VALUES
            CASE (21)
              IPR(649) = MOD (IPR(649) + 1, 2)
              IPR(569) = 0
              IPR(570) = 0
              LRET     = 3
C * DEFINE CONTOUR LEVEL STEP
            CASE (22)
              STRING(1:3) = 'CL '
              NCNT = 3
              SBCD = STRING(1:NCNT)//CHAR (0)
              LRET = -1
C * SOLV ROTY
            CASE (24)
              IPR(479) = 2
              IF (MENUH > 5) THEN
                PAR(389) = 2 ** (MENUH - 6)
              ELSE
                PAR(389) =  - 2 ** (5 - MENUH)
              END IF
              LRET = 3
C * SelectTwinMatrix#3
            CASE (25)
              IPR(573)  = MOD (IPR(573) + 1, 2)
              LRET = -1
C * ADDSYM EQUAL
            CASE (26)
              CALL PLA280 ('CALC ADDSYM EQUAL')
C * ROTY
            CASE (30)
              IF (MENUH > 5) THEN
                IANG  = 2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:9), 99996, IOSTAT = IOST) 'Y', IANG
C * REDUCED CELL TOGGLE
            CASE (34)
              CALL PLA280 ('REDUCED')
            CASE DEFAULT
              IF (MENUH > 5) THEN
                IANG  = 2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:18), 99983, IOSTAT = IOST) IANG
          END SELECT
C * MENU BOX # 21
        CASE (21)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * ROTX
            CASE (1, 9)
              IPR(479) = 1
              IF (MENUH > 5) THEN
                PAR(389)  = 2 ** (MENUH - 6)
              ELSE
                PAR(389)  =  - 2 ** (5 - MENUH)
              END IF
              IPR(201) = 0
              LRET     = 2
C * INCL ZOMBIE (DANGLING BONDS)
            CASE (7)
              IPR(166) = MOD (IPR(166) + 1, 2)
              IPR(130) = 0
              CALL PLA280 ('PLOT')
C * RADII BONDS NORMAL
            CASE (8)
              PAR(86) = MENUH * 0.01
              LRET = 4
C * KEYBOARD INSTRUCTION HELP
          CASE (10)
              CALL PLA280 ('HELP')
              LRET = 2
C * Auto-Plot
            CASE (12)
              IGBL(35) = MOD (IGBL(35) + 1, 2)
              LRET = -1
C * PLAN PLOT
            CASE (13)
              IPR(55) = 1
              CALL PLA280 ('YES')
C * ROTX
            CASE (16)
              IF (MENUH > 5) THEN
                IANG =   2 ** (MENUH - 6)
              ELSE
                IANG = - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:9), 99996, IOSTAT = IOST) 'X', IANG
C * SYSTEM-S (SQUEEZE/FCF)
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('SQUEEZE')
              ELSE
                CALL PLA280 ('FCF')
             END IF
C * SYSTEM-S/SUB LASER
            CASE (18)
              CALL PLA280 ('LASER')
C * NPEAKFMAP
            CASE (19)
              IGBL(124) = MENUH - 1
C * POWDER DISPL D-VALUES
            CASE (21)
              IPR(569) = MOD (IPR(569) + 1, 2)
              IPR(570) = 0
              IPR(649) = 0
              LRET     = 3
C * XR/YR/ZR ORTEP / OMIT SIG (0/1/2)
            CASE (22)
              IF (IPR(182) == 0) THEN
                CALL PLA280 ('OMIT')
                IPR(515) = MENUH - 1
              ELSE
                IPR(505) = MENUH
                IF (MENUH == 1) THEN
                  CALL PLA280 ('XROT 10')
                ELSE IF (MENUH == 2) THEN
                  CALL PLA280 ('YROT 10')
                ELSE
                  CALL PLA280 ('ZROT 10')
                END IF
              END IF
C * SOLV ROTX
            CASE (24)
              IPR(479) = 1
              IF (MENUH > 5) THEN
                PAR(389) = 2 ** (MENUH - 6)
              ELSE
                PAR(389) =  - 2 ** (5 - MENUH)
              END IF
              LRET = 3
C * SelectTwinMatrix#4
            CASE (25)
              IPR(574)  = MOD (IPR(574) + 1, 2)
              LRET = -1
C * ADDSYM ELEMENT
            CASE (26)
              IF (MENUH == 1) THEN
                NQ1 = ' '
              ELSE
                NQ1 = LMT(MENUH - 1, 1)
              END IF
              CALL PLA280 ('CALC ADDSYM '//NQ1)
C * POLY ROTX
            CASE (30)
              IF (MENUH > 5) THEN
                IANG =   2 ** (MENUH - 6)
              ELSE
                IANG = - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:9), 99996, IOSTAT = IOST) 'X', IANG
C * STRUCTURE
            CASE (31)
              IPR(640) = MOD (IPR(640) + 1, 2)
            CASE DEFAULT
              IF (MENUH > 5) THEN
                IANG  =   2 ** (MENUH - 6)
              ELSE
                IANG  =  - 2 ** (5 - MENUH)
              END IF
              WRITE (IGGT(1:18), 99982, IOSTAT = IOST) IANG
          END SELECT
C * MENU BOX # 22
        CASE (22)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * LOOP OVER MENUS
C * ORTEP PREV/NEXT
            CASE (1)
              IGBL(58) = 0
              REWIND (UNIT = LU2, IOSTAT = IOST)
              IF (MENUH == 1) THEN
                IGBL(54) = MAX (1, IGBL(54) - 1)
                IF (IGBL(54) > 1) IGBL(58) = 1
                WRITE (IGGT, 99981, IOSTAT = IOST) IGBL(54)
              ELSE
                IF (IGBL(54) < IGBL(100)) THEN
                  IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100)))
                  WRITE (IGGT, 99981, IOSTAT = IOST) IGBL(54)
                ELSE
C * EXIT FROM 'SAVE'-LOOP
                  IGBL(45) = 0
                  CALL PLA280 ('REM')
                  IGBL(6) = 10
                  CALL GEN108 (LU3, 0)
                  WRITE (LU3, 99980, IOSTAT = IOST)
                  ENDFILE (LU3, IOSTAT = IOST)
                END IF
              END IF
C * EXCLUDE ARU
            CASE (3)
              CALL PLA015 (213, 1)
              IF (IPR(213) == 1) THEN
                IF (IPR(63) == 0) THEN
                  CALL PLA280 ('LABEL ARU')
                ELSE
                  LRET = -1
                END IF
              ELSE
                CALL PLA280 ('UNLABEL ARU')
              END IF
              IF (IGBL(35) == 0) LRET = -1
C * LRETCOLOR (ATOM-TYPE/RESD/ARU)
            CASE (2, 4, 5, 6)
              DO
                IPR(346) = MOD (IPR(346) + 1, 2)
                IF (IPR(346) == 1) THEN
                  IF (MENUH == 1) THEN
                    IPR(477) = 0
                  ELSE IF (MENUH == 2) THEN
                    IPR(477) = -1
                  ELSE
                    IPR(477) = 1
                  END IF
                ELSE
                  IF (MENUH * IPR(477) == -2 .OR.
     1              MENUH * IPR(477) == 3 .OR.
     2               (MENUH  == 1 .AND. IPR(477) == 0)) THEN
                    IPR(477) = 0
                  ELSE
                    CYCLE
                  END IF
                END IF
                IF (IGBL(35) == 1) THEN
                  CALL PLA280 ('PLOT')
                ELSE
                  LRET = -1
                END IF
                IF (NEXIT == 0) EXIT
              END DO
C * MolExpand  (On/OFF)
            CASE (7)
              IGBL(127) = MOD (IGBL(127) + 1, 2)
C * RADII BONDS To METAL
            CASE (8)
              PAR(90) = MENUH * 0.01
              LRET = 4
C * DISPLAY CSD-CIF LITERATURE REFERENCE
            CASE (9)
                IGBL(104) = MOD (IGBL(104) + 1, 2)
C * PREV/NEXT
            CASE (10)
              IGBL(58) = 0
              IF (MENUH == 1) THEN
                IGBL(54) = MAX (1, IGBL(54) - 1)
                IF (IGBL(54) > 1) IGBL(58) = 1
              ELSE IF (MENUH == 2) THEN
                IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100)))
              END IF
              IPR(220) = 0
              IPR(221) = 1
              FN(1) = IGBL(54)
              CALL PLA007
              IGBL(24) = 0
              CALL PLA280 ('END')
              LRET = 3
C * TOLM
            CASE (11)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) PAR(27) = (MENUH - 3) * 0.2
              WRITE (BCD, 99978, IOSTAT = IOST) PAR(2), PAR(27),
     1          CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
              LRET = -1
C * X-LineWidth
            CASE (12)
              IGBL(69) = MOD (IGBL(69) + 1, 2)
              YGGIP = - 100 * (IGBL(69) + 1)
              CALL GGIP (0.0, YGGIP, 0.0, 0)
C * PLAN/NEWMAN/COLOR
            CASE (13)
              IPR(346) = MOD (IPR(346) + 1, 2)
              CALL PLA280 ('REF')
C * NEXT
            CASE (16)
              CALL PLA280 ('NEXT')
C * SYSTEM-S - ADDSYM-SHELX
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('PLATON ADDSYM')
              ELSE
                CALL PLA280 ('PLATON SOLV')
              END IF
C * S/SUB-BROWSE
            CASE (18)
              IF (IGBL(43) == 1) IGBL(42) = 1
              IGBL(42) = MOD (IGBL(42) + 1, 2)
              IGBL(43) = 0
              CALL PLA280 ('BROWSE LPS')
C * S/SHELXL (CGLS)
            CASE (19)
              CALL PLA280 ('CGLS')
C * POWDER DISPL THETA-VALUES
            CASE (21)
              IPR(570) = MOD (IPR(570) + 1, 2)
              IPR(569) = 0
              IPR(649) = 0
              LRET     = 3
C * CONTOUR OMIT FROM SFC
            CASE (22)
              IF (IPR(415) > 0) THEN
                IPR(182) = MOD (IPR(182) + 1, 2)
                IF (IGBL(25) * IGBL(32) == 1) THEN
                  IF (IPR(182) /= 0) THEN
                    BCD =
     1               '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
                  END IF
                END IF
              ELSE
                LRET = -1
              END IF
C * SOLV COLOR
            CASE (24)
              IPR(346) = MOD (IPR(346) + 1, 2)
C * TwinRotMat - CRIT-INT
            CASE (25)
              PAR(415) = MENUH * 0.1
              CALL PLA280 ('CALC')
C * ADDSYM EXACT
            CASE (26)
              CALL PLA280 ('CALC ADDSYM EXACT')
C * HKL-Display
            CASE (29)
              IPR(636) = MOD (IPR(636) + 1, 2)
            CASE DEFAULT
              LRET = -1
C * FLIP SHOW
            CASE (31)
              CALL PLA280 ('SHOW')
          END SELECT
C * MENU BOX # 23
        CASE (23)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * SET BOX ON/OFF
            CASE (1)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
              LRET = 3
C * BOX ON/OFF
            CASE (2, 5, 6)
              IF (IGBL(103) == 1) THEN
                CALL PLA280 ('BOX OFF')
              ELSE
                CALL PLA280 ('BOX ON')
              END IF
C * PLUTON OMIT OUTSIDE
            CASE (3)
              CALL GEN038 (IGGT, 1, 80)
              IPR(141) = MOD (IPR(141) + 1, 2)
              IF (IPR(141) == 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')
              END IF
C * DEFINE (PLUTON)
            CASE (4)
              IF (MENUH == 1) THEN
                LMOD     = 1
                IFL(1)   = 'DEFINE'
                IPR(507) = 1
                CALL PLA015 (508, 1)
                LRET     = -1
              ELSE IF (MENUH == 3) THEN
                IF (IPR(508) /= 0) THEN
                  IPR(507) = 3
                  IPR(508) = 0
                  WRITE (IGGT, 99995, IOSTAT = IOST)
     1              (IFL(I)(1:7), I = 1, LMOD)
                  IGBL(6) = IABS (IGBL(6))
                END IF
              END IF
C * PREV/NEXT
            CASE (7)
              IGBL(58) = 0
              IF (MENUH == 1) THEN
                IGBL(54) = MAX (1, IGBL(54))
                IF (IGBL(54) > 1) IGBL(58) = 1
              ELSE
                IGBL(54) = IGBL(54) + 1
                IF (IGBL(54) < IGBL(100)) THEN
                  IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100)))
                END IF
              END IF
              WRITE (IGGT, 99981, IOSTAT = IOST) IGBL(54)
              IGBL(67) = 0
              LRET = 3
C * RADII BONDS TO H-Atoms
            CASE (8)
              PAR(88) = MENUH * 0.01
              LRET = 4
C * LSPL / DIHEDRAL
            CASE (9)
              IF (MENUH == 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 == 2) THEN
                IF (IPR(552) /= 0 .AND. LMOD > 3) THEN
                  LMOD      = LMOD + 1
                  IPR(551)  = 2
                  IFL(LMOD) = 'WITH'
                END IF
                LRET = -1
              ELSE IF (MENUH == 3) THEN
                IF (IPR(552) /= 0) THEN
                  IPR(551) = 3
                  CALL PLA015 (552, 1)
                  IPR(81)  = - LMOD
                  CALL PLA440 (1)
                  LMOD     = 0
                  IGBL(6) = IABS (IGBL(6))
                ELSE
                  IGBL(6) = 10
                  IF (IABS (IGBL(45)) /= 0) THEN
                    CALL PLA280 ('END')
                  ELSE
                    CALL PLA280 ('REM')
                  END IF
                END IF
              END IF
C * SAVE OPTION
            CASE (10)
              IGBL(45) = MOD (IGBL(45) + 1, 2)
              ISAVEMOD = 1
              CALL GEN108 (LU3, 0)
              LRET = -1
C * TOLA
            CASE (11)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
              IF (IPR(30) == 0) PAR(2) = (MENUH - 1) * 0.2
              WRITE (BCD, 99978, IOSTAT = IOST) PAR(2), PAR(27),
     1          CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
              LRET = -1
C * REVERSE B&W
            CASE (12)
              CALL PLA280 ('SET REVERSE')
              LRET = 2
            CASE (13)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
              CALL PLA280 ('REF')
C * DECORATION ON/OFF
            CASE (14)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
              IPR(389) = 0
              LRET     = 4
            CASE (16)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
C * SYSTEM-S
            CASE (17)
              IF (MENUH == 1) THEN
                CALL PLA280 ('VALID')
              ELSE
                CALL PLA280 ('REPORT')
              END IF
C * S/SUB-BROWSE
            CASE (18)
              IF (IGBL(42) == 1) IGBL(43) = 1
              IGBL(43) = MOD (IGBL(43) + 1, 2)
              IGBL(42) = 0
              CALL PLA280 ('BROWSE LIS')
C * S/SHELXL (LS)
            CASE (19)
              CALL PLA280 ('SHELXL')
C * POWDER - DECORATION
            CASE (21)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
C * BOX ON/OFF
            CASE (22)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
              LRET = 2
C * SOLV - DECORATION
            CASE (24)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
C * TWINROTMAT HKLF5 DELTH-MAX
            CASE (25)
              PAR(420) = MENUH * 0.05
              CALL PLA280 ('CALC')
C * ADDSYM PLOT
            CASE (26)
              CALL PLA280 ('CALC ADDSYM PLOT')
C * RDF - DECORATION
            CASE (28)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
C * BIJVOET - s.u.-bar
            CASE (29)
              IPR(634) = MOD (IPR(634) + 1, 2)
C * SET BOX ON/OFF
            CASE (30)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
              LRET = 3
C * FLIP - CONTINUE
            CASE (31)
              CALL PLA280 ('CONTINUE')
C * K-ANALYZE
            CASE (32)
              IPR(778) = MOD (IPR(778) + 1, 2)
              CALL PLA280 ('VARIANCE')
C * ANOM - DECORATION
            CASE (33)
              IGBL(103) = MOD (IGBL(103) + 1, 2)
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 24
        CASE (24)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
C * SET META FILE ON
            CASE (1)
              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
C * ASYM-RESIDUE
            CASE (3)
              IGBL(128) = MOD (IGBL(128) + 1, 2)
              IPR(130) = 0
              CALL PLA280 ('PLOT')
C * META PLOT
            CASE (2, 5, 6)
              IF (MENUH == 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 == 2) THEN
                CALL PLA280 ('PLOT POV')
                IPR (340) = 1
                IGBL(98)  = 0
              ELSE IF (MENUH == 3) THEN
                IPR (340) = 1
                CALL PLA280 ('PLOT PDB')
              END IF
C * JOIN (DASH)/DETACH
            CASE (4)
              CALL PLA015 (311, MENUH)
              LRET = -1
C * ENTRY LIST
            CASE (7)
              CALL PLA015 (462, 1)
              IF (IPR(462) == 1) THEN
                CALL PLA280 ('ENTRY')
              ELSE
                WRITE (IGGT, 99981, IOSTAT = IOST) IGBL(54)
              END IF
C * BOND-TAPER
            CASE (8)
              PAR(48) = (MENUH - 1) * 0.125
              LRET    = 4
C * LSPL / DIST
            CASE (9)
              IF (MENUH == 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 == 2) THEN
                IF (IPR(476) /= 0 .AND. LMOD > 3) THEN
                  LMOD      = LMOD + 1
                  IPR(460)  = 2
                  IFL(LMOD) = 'DIST'
                END IF
                LRET = -1
              ELSE IF (MENUH == 3) THEN
                IF (IPR(476) /= 0) THEN
                  IPR(460) = 3
                  CALL PLA015 (476, 1)
                  IPR(81)  = - LMOD
                  CALL PLA440 (1)
                  LMOD     = 0
                  IGBL(6) = IABS (IGBL(6))
                ELSE
                  IGBL(6) = 10
                  IF (IABS (IGBL(45)) /= 0) THEN
                    CALL PLA280 ('END')
                  ELSE
                    CALL PLA280 ('REM')
                  END IF
                END IF
              END IF
C * ENTRY LIST
            CASE (10)
              CALL PLA015 (462, 1)
              IF (IPR(462) == 1) THEN
                CALL PLA280 ('ENTRY')
              ELSE
                WRITE (IGGT, 99981, IOSTAT = IOST) IGBL(54)
              END IF
              LRET = 2
C * REM
            CASE (12)
              IGBL(47) = - IGBL(47)
              IPR(590) = MOD (IPR(590) + 1, 2)
              CALL PLA280 ('REM')
              IGBL(6) = 10
              LRET = 2
C * NEWMAN/RING/PLANE PLOT
            CASE (13)
              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')
C * CALC
            CASE (16)
              CALL PLA280 ('CALC')
C * SYSTEM-S AutoRenum
            CASE (17)
              CALL PLA280 ('RENUM')
C * SYSTEM-S/SUB - PRUNE
            CASE (18)
              CALL PLA280 ('PRUNE')
C * SYSTEM-S
            CASE (19)
              IF (MENUH == 1) THEN
                CALL PLA280 ('LRES')
              ELSE
                CALL PLA280 ('SHXLPS')
              END IF
C * LEPAGE - NEXT
            CASE (20)
              CALL PLA280 ('NEXT')
C * POWDER - EPS
            CASE (21)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
C * CONTOUR
            CASE (22)
              IF (MENUH == 1) THEN
                CALL PLA280 ('UP')
              ELSE
                CALL PLA280 ('DOWN')
              END IF
C * SOLV HARD COPY
            CASE (24)
              MEDIUM      = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
C * TwRtMt - HKLF5
            CASE (25)
              CALL PLA280 ('HKLF')
C * ADDSYM SHELX
            CASE (26)
              CALL PLA280 ('CALC ADDSYM SHELX NOSF')
C * RDF - EPS
            CASE (28)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
C * BIJVOET - PLOT CAL
            CASE (29)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              IF (IPR(621) == 1) THEN
                CALL PLA280 ('NPP')
                IPR(621) = -1
              END IF
C * SET META FILE ON
            CASE (30)
              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
C * CONVERGE
            CASE (31)
              CALL PLA280 ('CONVERGE')
C * Anal-of-Variance - EPS
            CASE (32)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('PLOT')
              LRET = 2
C * ANOM - EPS
            CASE (33)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('PLOT')
C * FCF-COMPARE - EPS
            CASE (34)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('PLOT')
              LRET = 2
C * WILSON PLOT - EPS
            CASE (35)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('PLOT')
              LRET = 2
C * SQUEEZE SUMMARY PLOT
            CASE (36)
              MEDIUM = 2
              IGGT(16:22) = 'ON     '
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              CALL PLA280 ('PLOT')
              LRET = 2
            CASE DEFAULT
              LRET = -1
          END SELECT
C * MENU BOX # 25
        CASE (25)
C * LOOP OVER MENUS
          SELECT CASE (MMODE)
            CASE (1, 8, 9)
C * ToPLUTON
              IF (MENUH == 1) THEN
                LRET = 1
                CALL PLA280 ('PLUTON')
                IPR(327) = 0
                IPR(328) = 0
                IPR(349) = 0
                IPR(440) = 0
              ELSE IF (MENUH == 2) THEN
                LRET = 1
                IF (IABS (IGBL(45)) /= 0) THEN
                  IF (IPR(308) == 2) THEN
                    CALL PLA280 ('EXIT')
                    LRET = 7
                  ELSE
                    CALL PLA280 ('END')
                  END IF
                  IPR(351) = 0
                ELSE
                  CALL PLA280 ('REM')
                END IF
              END IF
C *PLUTON
            CASE (2, 3, 4, 5, 6, 7)
              IF (MENUH == 1) THEN
                CALL PLA280 ('RESET')
              ELSE IF (MENUH == 2) THEN
                IGBL(24) = 0
                CALL PLA280 ('END')
                IGBL(67) = 0
                LRET     = 3
              END IF
C * PLATON MAIN & SUP1 & 2-MENU
            CASE (10, 11, 12)
              IF (MENUH == 1) THEN
C * RESET INPUT
                CALL PLA286 (0)
                LRET = 2
              ELSE IF (MENUH == 2) THEN
                IGBL(24) = 0
                CALL PLA280 ('END')
                LRET = 3
              END IF
C * GEOM
            CASE (13)
              IF (MENUH == 1) THEN
                CALL PLA280 ('PLUTON')
              ELSE IF (MENUH == 2) THEN
                CALL PLA280 ('NO')
              END IF
C * ASYM EPS & END
            CASE (14)
              IF (MENUH == 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
              END IF
C * HELENA CALC/NEXT-STEP
            CASE (15)
              CALL PLA280 ('CALC')
C * ABSORB
            CASE (16)
              IF (MENUH == 1) THEN
                MEDIUM      = 2
                IGGT(16:22) = 'ON     '
                CALL GGIP (-999.0, 0.0, 0.0, 6)
                CALL PLA280 ('PLOT')
              ELSE
                CALL PLA280 ('END')
              END IF
C * SYSTEM S - ACCEPT DEFAULT
            CASE (17, 18, 19)
              IF (MENUH == 1) THEN
                CALL PLA280 ('SKIP')
              ELSE
                CALL PLA280 ('!')
              END IF
            CASE (20)
              CALL PLA280 ('END')
C * POWDER (END)
            CASE (21)
              IGBL(6) = 10
C * RESET INPUT
              CALL PLA286 (0)
              LRET = 2
C * CONTOUR
            CASE (22)
              IF (MENUH == 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')
              END IF
C *SOLV
            CASE (24)
              LRET = 2
C *TWINROTMAT - END
            CASE (25)
              CALL PLA280 ('END')
C *ADDSYM
            CASE (26)
              CALL PLA280 ('END')
C *EXOR - ACCEPT DEFAULT
            CASE (27)
              IF (MENUH == 1) THEN
               CALL PLA280 ('SKIP')
              ELSE
                CALL PLA280 ('!')
              END IF
C * RDF (END)
            CASE (28)
              CALL PLA280 ('END')
C * BIJVOET (END)
            CASE (29)
              CALL PLA280 ('END')
C * POLYHEDRON END
            CASE (30)
              CALL PLA280 ('END')
C * FLIPPER END
            CASE (31)
              CALL PLA280 ('END')
C * ANAL-OF-VARIANCE
            CASE (32)
              CALL PLA280 ('END')
C * ANOM (END)
            CASE (33)
              IGBL(6) = 10
C * RESET INPUT
              CALL PLA286 (0)
              LRET = 2
C * FCF-CAMPARE END
            CASE (34)
              CALL PLA280 ('END')
C * WILSON PLOT END
            CASE (35)
              CALL PLA280 ('END')
C * SQUEEZE SUMMARY PLOT
            CASE (36)
              CALL PLA280 ('END')
C *SPGRfromEX
            CASE (37)
              CALL PLA280 ('END')
              LRET = 1
            CASE DEFAULT
              LRET = -1
          END SELECT
      END SELECT
      RETURN
99999 FORMAT (/, '>> Labels may be moved by ''clicking'' on them',
     1        ' (When in MoveLabel On - 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))
99994 FORMAT ('STLM', F10.2, 5X)
99993 FORMAT ('SHELXL ISO', I3, 1X)
99992 FORMAT ('SHELXL ANISO', I3, 1X)
99991 FORMAT ('SHELXL HATOM', I3, 1X)
99990 FORMAT ('ZROT ', F10.2)
99989 FORMAT ('SHELXL WEIGHT', I3, 1X)
99988 FORMAT ('SET WINDOW', F8.2)
99987 FORMAT ('SET REVERSE')
99986 FORMAT ('CROTY COLOR', F8.2)
99985 FORMAT ('CROTY ', F8.2)
99984 FORMAT ('VIEW CUR ZROT', I5)
99983 FORMAT ('VIEW CUR YROT', I5)
99982 FORMAT ('VIEW CUR XROT', I5)
99981 FORMAT ('ENTRY', I6)
99980 FORMAT (80X, /)
99979 FORMAT ('Min. QPeak Height', F6.2, ', Min. QPeak Dist.', F6.2, A)
99978 FORMAT ('TolA =', F6.2, ', TolM =', F6.2, A)
99977 FORMAT ('Coordination Radius =', F6.1, A)
99976 FORMAT ('UISO', F10.3)
99975 FORMAT ('NTRY', I10)
99974 FORMAT ('NLOOP', I10)
99973 FORMAT ('NSOLVE', I10)
99972 FORMAT ('DELTA', F10.3)
99971 FORMAT ('ARU NONE ', I5)
99970 FORMAT ('PERC', F12.3)
99969 FORMAT ('PACK RANGE', 6F6.2)
      END SUBROUTINE PLA016
 
      SUBROUTINE PLA017 (MODE, IGOTO, ICONT, KL, KN, IS, A, J, NP, S)
C * SPF or RES  & Instructions
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cggt
      USE chdat
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: IS
      INTEGER          :: NP
      INTEGER          :: KL
      INTEGER          :: KN
      INTEGER          :: IP
      INTEGER          :: IMAX
      INTEGER          :: MODE
      INTEGER          :: NCHAR
      INTEGER          :: IGOTO
      INTEGER          :: ICONT
      INTEGER          :: IGGTN
      REAL             :: A
      REAL             :: S
      CHARACTER(len=1) :: ICH
C * CHECK FOR INCLUDE FILE / SAVE FILENAME
      IF (ICL(1:1) == '+') THEN
        INCLUDEFILE = ICL(2:80)
        IPR(738)    = -1
      END IF
      N = INDEX (ICL(1:80), CHAR (13))
      IF (N /= 0) ICL(N:N) = CHAR (32)
C * CHANGE TO UPPER CASE
      CALL GEN020 (1, ICL, 1, 4)
C * CONVERT NON-TITL,REM,MESS & FILE LINE TO UPPER-CASE LETTERS
      IF (ICL(1:4) /= 'TITL' .AND. ICL(1:3) /= 'REM' .AND.
     1    ICL(1:4) /= 'MESS' .AND. ICL(1:4) /= 'FILE') THEN
        IF (ICL(1:4) == 'ENTR') THEN
          N = 5
        ELSE
          N = 80
        END IF
C * CHANGE TO UPPER CASE
        CALL GEN020 (1, ICL, 5, N)
      END IF
C * SKIP CARDS ON LU1
      IF (IPR(470) == 1) THEN
        IF (IGBL(5) == LU1) THEN
          IF (ICL(1:3) /= 'END') THEN
            IPR(471) = IPR(471) + 1
            IGOTO    = 1
            RETURN
          END IF
        END IF
        IPR(470) = 0
      END IF
C * SKIP NON-CONTINUATION CARD WITH FIRST CHAR. BLANK (BLANK CARD), + OR #
      ICH = ICL(1:1)
      IF (KL == 0 .AND. KN == 0 .AND.
     1      (ICH == ' ' .OR. ICH == '#' .OR. ICH == '+')) THEN
C * PLATON MODE
        IF (MODE == 0) THEN
          IF (IGBL(5) == LU5) THEN
            IGOTO = 3
          ELSE
            IGOTO = 1
          END IF
          RETURN
        END IF
      END IF
      IF (IGBL(5) == LU2 .AND. MODE /= 0)
     1  WRITE (LU6, 99998, IOSTAT = IOST) ICL(1:80)
      IF (IGBL(5) == LU3)
     1  WRITE (LU6, 99999, IOSTAT = IOST) ICL(1:80)
C * ANALYSE CONTENTS FROM COLUMN IMIN THROUGH IMAX
      IMAX  = 80
      ICONT = 0
C * SEARCH FOR CONTINUATION MARK = (ALL REMAINDER CHARACTERS SKIPPED)
      DO I = 1, IMAX
        IF (ICL(I:I) == '!') THEN
          IMAX = I - 1
          EXIT
        ELSE IF (ICL(I:I) == '=') THEN
          IMAX  = I - 1
          ICONT = 1
          EXIT
        END IF
      END DO
C * MAXIMUM SIZE LITERAL FIELD : NCHAR
      NCHAR = 8
      I     = 0
      GO TO 20
C * END OF NUMERIC FIELD
   10 IF (KN < NP17) THEN
        KN     = KN + 1
        FN(KN) = S * A / 10.0**NP
      END IF
      IF (ICH == '+' .OR. ICH == '-') I = I - 1
C * START OF A NEW FIELD
   20 A     = 0.0
      IP    = 0
      NP    = 0
      L     = 0
      S     = 1.0
C * LOOK FOR A NON-BLANK COLUMN
   30 I     = I + 1
      IF (I <= IMAX) THEN
        ICH   = ICL(I:I)
C * SUBSTITUTE BLANK FOR <TAB>
        IF (ICH == CHAR (9)) THEN
          ICH = CHAR (32)
          ICL(I:I) = ICH
        END IF
        IF (L == 0 .AND. ICH == ' ') GO TO 30
C * START OF A FIELD
        L = L + 1
        DO J = 1, 10
          IF (ICH == CHAR(ICHAR('0') + J - 1)) THEN
C * START OF A LITERAL FIELD BY A CHARACTER WHICH IS OTHER THAN 0-9+-.
C * NUMERIC FIELD FOUND
            IF (IGBL(5) /= LU5 .AND. KL == 0) THEN
              IGOTO = 1
              RETURN
            END IF
            NP = NP + IP
            A  = 10.0 * A + J - 1
            GO TO 30
          END IF
        END DO
        IF (ICH == '.') THEN
          IP = 1
        ELSE IF (ICH == '+') THEN
          IF (L > 1) GO TO 10
          S = 1.0
        ELSE IF (ICH == '-') THEN
          IF (L > 1) GO TO 10
          S = -1.0
        ELSE IF (ICH == ']') THEN
          GO TO 10
        ELSE IF (ICH == ')') THEN
          GO TO 10
        ELSE
          IF (L <= 1) THEN
C * START NEW LITERAL FIELD
            IF (KL < NP17) KL = KL + 1
            IF (KL > 1 .AND. IS < 0) THEN
C * PLATON
              IF (MODE == 0) THEN
C * TRANSFORM KEYWORD TO ENTRYPOINT NUMBER IN ARRAY
                CALL GEN102 (IS, IFL(1)(1:4), ISWS, NP24)
              ELSE
C * PLUTON
C * TRANSFORM KEYWORD TO ENTRYPOINT NUMBER IN ARRAY
                CALL GEN102 (IS, IFL(1)(1:4), CRD,  NP37)
              END IF
C * DO NOT INTERPRETE TITL, REM AND MESS LINES
              IF (IS > 1 .AND. IS < 5) THEN
                IGOTO = 3
                RETURN
              END IF
            END IF
            DO
              IFL(KL)(L:L) = ICH
              L            = L + 1
              IGGTN        = (KL - 1) * NCHAR + L
C * COPY INTO IGGT (FOR TRANSFER TO GGIP) (AVOID OVERFLOW)
              IF (IGGTN <= 80) IGGT(IGGTN:IGGTN) = ICH
              IF (IGGTN == 2) CALL GEN038 (IGGT, 3, 80)
              DO
                I = I + 1
                IF (I > IMAX) GO TO 20
                ICH = ICL(I:I)
C * BREAK LITERAL MODE ON SPACE, COMMA (OR CONDITIONAL LEFT PARENTHESIS)
                IF (ICH == ' ' .OR. ICH == ',') GO TO 20
C * CATCH PAR[ ] CASE (BUT SKIP FOR LABELS)
                IF ((ICH == '[' .OR. ICH == '(') .AND.
     1            L > 3) GO TO 20
C * PLUS, MINUS OR DOT START NUMERICAL FIELD
                IF (ICH == '.') THEN
                  I = I - 1
                  GO TO 20
                END IF
                IF (ICH == '+' .OR. ICH == '-') THEN
                  IF (IGBL(8) /= 2 .OR. I > 3) THEN
                    I = I - 1
                    GO TO 20
                  END IF
                END IF
                IF (L <= NCHAR) EXIT
              END DO
            END DO
C * END OF LITERAL FIELD
            IGOTO = 2
            RETURN
          ELSE
            GO TO 10
          END IF
        END IF
        GO TO 30
      END IF
      IF (L > 0) GO TO 10
      IGOTO = 2
      RETURN
99999 FORMAT (':: SEx:', A)
99998 FORMAT (':: Def:', A)
      END SUBROUTINE PLA017
 
      SUBROUTINE PLA018 (MODE, X, Y, NQ)
C * NEAREST ATOM POS TO CLICK POS
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: NAT
      INTEGER             :: IMN
      INTEGER             :: IPP
      INTEGER             :: IMIN
      INTEGER             :: IRES
      INTEGER             :: MODE
      INTEGER             :: ISKP
      INTEGER             :: IDUM
      INTEGER             :: JDUM
      INTEGER             :: NPOP
      INTEGER             :: IRESI
      REAL                :: X
      REAL                :: Y
      REAL                :: XX
      REAL                :: YY
      REAL                :: DEL
      REAL                :: DSH
      REAL                :: DELMIN
      CHARACTER(len=NP64) :: NQ
      CHARACTER(len=NP64) :: NQL
      IMIN   = 1
      DELMIN = 100000.0
      NQ     = '*******'
      NAT    = IPR(39) + IPR(64)
C * SEARCH NEAREST ATOM CENTER
      DO I = 1, NAT
        J = IATC(I)
        IF (J /= 0) THEN
C * CHECK FOR SELECTED RESIDUE
          IRESI = IPR(140)
          IF (IRESI /= 0) THEN
            CALL GEN048 (-6, IFG(1, J), 9, IRES)
            IF (IRES /= IRESI) CYCLE
          END IF
          CALL GEN048 (-1, IFG(2, J), 27, ISKP)
          IF (ISKP == 0) THEN
C * IGNORE MINOR/MAJOR DISORDER FORMS WHERE APPROPRIATE
            IF (IGBL(59) /= 0) THEN
C * GET POPULATION PARAMETER
              CALL GEN048 (-8, IFG(2, J), 1, IPP)
              NPOP = IPPR(IPP + 1, 1)
              IF (NPOP < 10000) THEN
                IF (IGBL(88) == 0) THEN
                  IF (NPOP < 5000) CYCLE
                ELSE
                  IF (NPOP > 5000) CYCLE
                END IF
              END IF
            END IF
            CALL PLA047 (LABA(IATC(I)), NQL, IDUM, JDUM, 1,
     1        IGBL(55), 0, 0)
            IF (NQL(1:2) /= 'Cg' .OR. IPR(506) == 1) THEN
              DEL = (XXO(I, 1) - X) ** 2 + (XXO(I, 2) - Y) ** 2
              IF (DEL < DELMIN) THEN
                DELMIN = DEL
                IMIN   = I
              END IF
            END IF
          END IF
        END IF
      END DO
      IF (DELMIN < 0.5) THEN
        IF (MODE <= 0) THEN
          IMN = IATC(IMIN)
          CALL PLA047 (LABA(IMN), NQ, IDUM, JDUM, 1, 1, 0, 0)
          IF (MODE == -1 ) THEN
            IF (IMN <= IPR(37)) THEN
              CALL GEN048 (1, IFG(1, IMN), 30, 1)
            ELSE
              CALL PLA015 (427, 28)
              RETURN
            END IF
          END IF
          DSH = 0.15
          XX  = XXO(IMIN, 1)
          YY  = XXO(IMIN, 2)
C * PLOT MARKER
          CALL PLA411 (XX, YY, DSH, 2.0)
C * FLUSH
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ELSE
          IMIN = IATC(IMIN)
          CALL GEN048 (1, IFG(2, IMIN), 27, 1)
          IPR(201) = 0
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA018
 
      SUBROUTINE PLA019 (MODE, IER)
C * MAIN MENU - NEAREST ATOM + READ/ANSWER
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE mentry
      USE xwdw
      USE cggt
      USE menus
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: IP
      INTEGER          :: LU
      INTEGER          :: IER
      INTEGER          :: MODE
      INTEGER          :: NKNM16
      INTEGER          :: NKNMXT
      REAL             :: XB
      REAL             :: YB
      REAL             :: XBS
      REAL             :: SIZ
      REAL             :: XHORS
      REAL             :: YVERT
      CHARACTER(len=7) :: DIRC
      LU  = 0
      IER = 0
C * MODE = 0 - NORMAL READ REQUEST
C * MODE = 1 - Yes/No READ REQUEST
      IF (MODE == 0) THEN
        LU = IGBL(5)
        IF (LU == LU5) THEN
C * CHECK FOR X-WINDOW MODE [IGBL(32) = 1]
C * CHECK FOR MENU-ON       [IGBL(25) = 1]
C * CHECK FOR IUCR-OFF      [IGBL(3)  = 0]
          IF (IGBL(3) == 0 .AND. IGBL(25) * IGBL(32) == 1) THEN
C * CHECK FOR PLATON OPENING WINDOW [IGBL(6) = 10]
            IF (IABS(IGBL(6)) >= 10 .AND.
     1          IABS(IGBL(6)) <= 12) THEN
C * SKIP REFRESH OPENING WINDOW
              IF (IGBL(6) < 0) THEN
C * GET NEW DATA
                CALL PLA012 (0, 1)
                IF (LRET /= 1) THEN
                  ICL = IGGT
                  CALL GEN038 (IGGT, 1, 80)
                  RETURN
                END IF
              ELSE
C * OPEN MAIN X-WINDOW, GET INPUT FROM MENU/KEYPRESS
C * SET INTERACTIVE OUTPUT PROGRAM HEADER OFF
                IGBL(72) = 1
              END IF
C * OPEN MAIN WINDOW (X11-ONLY)
              DO
                BCD(1:12) = 'P.L.A.T.O.N'//CHAR (0)
                VERT = RGBL(1)
                HORS = VERT * RGBL(2)
                SIZ  = HORS / 63.0
                CALL GGIP (HORS, VERT, 0.0, 1)
C * GENERATE/DISPLAY PLATON HEADER
                LINE = 'P L A T O N'
                CALL PLA439 (0.0, LINE, 11, 2.0, 4, 15, 3.7, VERT - 2.4)
                CALL PLA439 (0.0, LINE, 11, 2.0, 2, 15, 3.5, VERT - 2.5)
                LINE = 'A Multipurpose Crystallographic Tool'
                CALL PLA439 (0.0, LINE, 36, 0.6, 1,  3, 3.9, VERT - 3.5)
                CALL GEN040 (IGBL(4), NQ1, IP)
                LINE = '(C) 1980-2025 A.L.Spek - Version: '//NQ1
                CALL PLA439 (0.0,  LINE, 50, 0.4, 3, 2, 5.8, VERT - 4.5)
C * GET PLATON UPDATE INFO
                IF (IGBL(142) == 0) CALL PLA430 (UPDATE)
                IF (IGBL(13) > 0) THEN
                  CALL PLA439 (0.0,  '[WEB:'//UPDATE//']', 18, 0.4,
     1              IGBL(14), 2, HORS - 6.1, VERT - 4.5)
                ELSE
                  CALL PLA439 (0.0,  '[NO INTERNET]', 13, 0.4,
     1              4, 2, HORS - 6.1, VERT - 4.5)
                END IF
C * CHECK FOR NO-ATOMS & NO-FACES AND NO-CELL
                IF (IPR(37) /= 0 .OR. IPR(367) /= 0 .OR.
     1            PAR(101) > 1.0) THEN
C * REPORT ON PARAMETER INPUT FILE
                  FNLU1  = NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT)
                  KNMXT  = KNMFIL + KXT + 1
                  NKNMXT = MIN (KNMXT, 25)
                  WRITE (PRBUF, 99999, IOSTAT = IOST)
     1              DTYPE(IABS(IGBL(8)))(1:3)//XLDTP, FNLU1(1:NKNMXT),
     2              IGBL(54), MAX (1, IGBL(100)), JID(1:8)
                  CALL PLA439 (0.0,  PRBUF, 80, SIZ, 3, 2,
     1                   0.1, VERT - 17.5)
C * REPORT ON REFLECTION DATA FILE
                  NKNM16 = MIN (KNM16, 25)
                  IF (IGBL(15) >= 0) THEN
                    IF (IGBL(37) == -1) THEN
                      DIRC = 'FCF'
                    ELSE IF (IGBL(37) == 1) THEN
                      DIRC = 'DIR-COS'
                    ELSE IF (IGBL(37) == 2) THEN
                      DIRC = 'ABS-PSI'
                    ELSE
                      DIRC = 'NO-DIRC'
                    END IF
                    CALL GGIP (0.0, 3.0, 0.0, 0)
                    WRITE (PRBUF, 99998, IOSTAT = IOST) RDTYP(IGBL(9)),
     1                FNLU16(1:NKNM16), DIRC, IGBL(126), JID(1:8)
                      KNMXT = KNM16 + 60
                  ELSE
                    CALL GGIP (0.0, 4.0, 0.0, 0)
                    WRITE (PRBUF, 99997, IOSTAT = IOST) FNLU16(1:NKNM16)
                    KNMXT = KNM16 + 40
                  END IF
                  CALL PLA439 (0.0,  PRBUF, KNMXT, SIZ, -1, 2, 0.1,
     1              VERT - 18.2)
                  WRITE (PRBUF, 99993, IOSTAT = IOST)
     1              HTTPSERVER(1:IGBL(135))
                  CALL PLA439 (0.0, PRBUF, 49, 0.25, 1, 1, 0.1,
     1              VERT - 19.3)
                  WRITE (PRBUF, 99994, IOSTAT = IOST)
     1              HTTPSERVER(1:IGBL(135))
                  CALL PLA439 (0.0, PRBUF, 49, 0.25, 1, 1, 11.0,
     1              VERT - 19.3)
                  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)
                  PRBUF(1:41)  =
     1              ' GRAPHICS  GEOM-CALC VOIDS FLIP SYMMETRY '
                  PRBUF(42:73) = ' ABSORPTION   REPORT  MISC-TOOLS'
                  CALL PLA439 (0.0,  PRBUF, 73, SIZ, 5 + IGBL(68), 2,
     1              0.1, VERT - 5.6)
                  DO I = 1, NP46
                    DO J = 1, 7
C * CHECK FOR .RES DEPENDENCY
                      IF (IOPT(J, I) == 9 .AND. IGBL(8) /= -2) THEN
                        IF (IGBL(145) == 0) CALL GGIP (0.0, 4.0, 0.0, 0)
C * F3D     - Check for available
                      ELSE IF (I == 7 .AND. J == 3) THEN
 
                        CALL GGIP (0.0, 4.0, 0.0, 0)
C * SQUEEZE - Check for ELECTRON
                      ELSE IF (I == 3 .AND. J == 3 .AND.
     1                  IGBL(29) == 0) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
C * BIJVOET - Check for ELECTRON
                      ELSE IF (I == 6 .AND. J == 6
     1                  .AND. IPR(493) == 8) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
C * CIF2SHELX: CHECK FOR SHELXL201n CIF
                      ELSE IF (I == 17 .AND. J == 7 .AND.
     1                   IPR(663) /= 0 .AND.
     2                  (IPR(664) /= 0 .OR. IPR(321) /= 0)) THEN
C * HYBRID: CHECK FOR SHELXL201n CIF AND ELECTRON
                      ELSE IF (I == 4 .AND. J == 3) THEN
                        IF (IGBL(29) == 0) THEN
                          CALL GGIP (0.0, 4.0, 0.0, 0)
                        ELSE
                          IF (IGBL(110) > 0 .AND.
     1                      IPR(663) /= 0 .AND. IPR(664) /= 0) THEN
                            IF (IGBL(29) == 0) THEN
                              CALL GGIP (0.0, 4.0, 0.0, 0)
                            ELSE
                              CALL GGIP (0.0, 1.0, 0.0, 0)
                            END IF
                          END IF
                        END IF
                      ELSE IF ((IGBL(15) < 0 .AND. IOPT(J, I) > 1)
     1                 .OR. (IOPT(J, I) == 5 .AND.
     2                   (IGBL(9) < 1 .OR. IGBL(9) > 27))) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
                      ELSE IF (IGBL(15) >= 0 .AND. IGBL(9) == 0
     1                  .AND. IOPT(J, I) == 3) THEN
C * CHECK FOR 'UNIQUE CALCULATION DONE (NO = 0)'
                      ELSE IF (IOPT(J, I) == -2 .AND. (IPR(30) /= 0
     1                  .OR. IPR(37) == 0))
     1                  THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
C * CHECK FOR 'NON-UNIQUE CALCULATION' (i.e INTER or COORD)
                      ELSE IF (IOPT(J, I) == -3 .AND. IPR(17) /= 0)
     1                  THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
                      ELSE IF (IOPT(J, I) == -4 .AND. IPR(30) /= 0
     1                  .AND.  IPR(136) == 0) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
C * CHECK FOR COORDINATES GIVEN
                      ELSE IF (IOPT(J, I) == -5 .AND. IPR(37) == 0)
     1                  THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
C * CHECK FOR FRACTIONAL COORDINATES
                      ELSE IF (IOPT(J, I) == -8 .AND. (IPR(23) == 1
     1                  .OR. IPR(30) /= 0 .OR. IPR(37) == 0)) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
                      ELSE IF (IOPT(J, I) == -9) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
                      ELSE
                        CALL GGIP (0.0, 1.0, 0.0, 0)
                      END IF
                      IF (IOPT(J, I) == -1) THEN
                        IF (IPR(30) /= 0 .OR. IABS (IGBL(8)) < 3 .OR.
     1                      IABS (IGBL(8)) > 3) THEN
                          CALL GGIP (0.0, 4.0, 0.0, 0)
                        ELSE
                          CALL GGIP (0.0, 1.0, 0.0, 0)
                        END IF
                      END IF
C * .INS/.RES INPUT ONLY FOR PATTERSON
                      IF (I == 13 .AND. J == 1 .AND.
     1                  IABS(IGBL(8)) /= 2) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
                      END IF
C * HANDLE CalcFCFsqd
                      IF (IGBL(9) /= -1) THEN
                        IF (J == 3 .AND. I == 5) THEN
                          CALL GGIP (0.0, 4.0, 0.0, 0)
                        END IF
                      END IF
C * HANDLE ContourSol
                      IF (IGBL(9) /= -1 .AND. IPR(665) == 0) THEN
                        IF (J == 3 .AND. I == 6) THEN
                          CALL GGIP (0.0, 4.0, 0.0, 0)
                        END IF
                      END IF
C * CHECK FOR SHELXT (XT) PRESENT
                      IF (IGBL(119) == 0) THEN
                        IF (I == 14 .AND. J == 1)
     1                    CALL GGIP (0.0, 4.0, 0.0, 0)
                      END IF
C * CHECK FOR DOS MODE
                      IF (DOS) THEN
                        IF (I == 1 .AND. J .EQ. 7) THEN
                          CALL GGIP (0.0, 4.0, 0.0, 0)
                        END IF
                      END IF
C * CHECK CSD
                      IF (IGBL(76) == 0) THEN
                        IF ((I == 11 .AND. J == 6) .OR.
     1                    (I == 12 .AND. J == 6))
     2                    CALL GGIP (0.0, 4.0, 0.0, 0)
                      END IF
                      IF (IPR(75) == 1) THEN
                        IF (J == 1 .AND. I == 9)
     1                    CALL GGIP (0.0, 4.0, 0.0, 0)
                      END IF
                      YVERT = VERT - I * 11.0 / NP46 - 5.7
                      XHORS = 9 * SIZ * (J - 1) + 0.1
                      CALL PLA439 (0.0,  OPTS(J, I), 10, SIZ, -1, 2,
     1                  XHORS, YVERT)
                    END DO
                  END DO
                  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 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)
                  END DO
                  CALL GGIP (0.0, -1.0, 0.0, 0)
C * NO PROPER DATA FOUND
                ELSE
                  IF (IABS(IGBL(3)) == 1) THEN
                    WRITE (LU6, 99996)
                    CALL PLA004 (0)
                  ELSE
                    LINE(1:26)  = 'NO PROPER INPUT FILE FOUND'
                    CALL PLA439 (0.0,  LINE, 26, 0.7, 2, 3, 4.8,
     1                VERT - 7.0)
                    LINE(1:33)  = 'NO ATOM DATA, FACES OR CELL FOUND'
                    CALL PLA439 (0.0,  LINE, 33, 0.7, 2, 3, 2.7,
     1                VERT - 8.5)
                    LINE(1:34)  = 'TO PROCEED'
                    CALL PLA439 (0.0,  LINE, 34, 0.7, 1, 3, 2.7,
     1                VERT - 11.0)
                    LINE(1:35)  = 'Enter ''FILE filename'' via Keyboard'
                    CALL PLA439 (0.0,  LINE, 35, 0.5, 1, 2, 2.7,
     1                VERT - 12.5)
                    LINE(1:32)  = 'or Enter Input Data via Keyboard'
                    CALL PLA439 (0.0,  LINE, 32, 0.5, 1, 2, 2.7,
     1                 VERT - 14.0)
                    LINE(1:25)  = 'or Click on HELP for INFO'
                    CALL PLA439 (0.0,  LINE, 25, 0.5, 1, 2, 2.7,
     1                VERT - 15.5)
                  END IF
                END IF
                IF (IGBL(47) > 0) THEN
C * BLANK 'Browser STARTUP'
                  LINE = 'Browser STARTUP'
                  CALL PLA439 (0.0,  LINE, 15, 0.5, 0, 3, HORS - 8.8,
     1              0.7)
C * WHITE 'Browser-mediated HELP'
                  LINE = 'Browser -'
                  CALL PLA439 (0.0,  LINE,  9, 0.5, 1, 3, HORS - 8.8,
     1              0.7)
                  LINE = 'HELP'
                  CALL PLA439 (0.0,  LINE,  4, 1.0, 1, 4, HORS - 3.5,
     1              0.3)
C * FLUSH
                  CALL GGIP (0.0, 0.0, 0.0, 6)
                END IF
C * PLATON MAIN MENU
C * GET NEW DATA
                CALL PLA012 (0, 1)
                IF (LRET /= 1) EXIT
              END DO
              ICL = IGGT
              CALL GEN038 (IGGT, 1, 80)
              RETURN
            END IF
          ELSE
            IF (IGBL(50) == 0) THEN
              CALL GEN125 (0, LU6, '>>')
            ELSE
              ICL = 'END'
              CALL GEN038 (IGGT, 1, 80)
              RETURN
            END IF
          END IF
        END IF
      ELSE IF (MODE == 1) THEN
        LU = LU5
C * CHECK FOR CONTINUE
        CALL GEN125 (1, LU6, ' ..... more (Y/N[Y])?')
      END IF
C * ACTUAL FILE READ
      IF (MODE == 1) THEN
        READ (LU, 99995, IOSTAT = IOST) ICL(1:80)
        IF (IOST == 0) THEN
          IF (ICL(1:1) == 'N' .OR. ICL(1:1) == 'n') THEN
            IER = 1
            RETURN
          END IF
        ELSE
C * READ FAILURE
          IER = -1
          RETURN
        END IF
      ELSE
        READ (LU, 99995, IOSTAT = IOST) ICL
        IF (IOST /= 0) THEN
C * READ FAILURE
          IER = -1
          RETURN
        END IF
      END IF
      RETURN
99999 FORMAT ('Xtal Data (', A, '  ) ', A, '- Set', I5, '(', I5, '): ',
     1        A)
99998 FORMAT ('Refl Data (', A, ') ', A,  ' [ ', A, ']', 2X,
     1       '(', I2, '): ', A)
99997 FORMAT ('No Refl_Data on     ', A, ', .FCF, .fcf or .hkl')
99996 FORMAT (/, ' ** No Recognizable CIF Data Found **', /)
99995 FORMAT (A)
99994 FORMAT (A, 'PLATON_HOW_TO.pdf')
99993 FORMAT (A, 'PLATON-MANUAL.pdf')
      END SUBROUTINE PLA019
 
      SUBROUTINE PLA020 (X, Y, Z)
C * HANDLE EVENTS ON CANVAS (AREA #1)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE tpos
      USE chdat
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: M
      INTEGER          :: N1
      INTEGER          :: N2
      INTEGER          :: NE
      INTEGER          :: NB
      INTEGER          :: NV
      INTEGER          :: NET
      INTEGER, SAVE    :: IAT
      INTEGER          :: JAT
      INTEGER          :: LBB
      INTEGER          :: LBC
      INTEGER          :: LBD
      INTEGER          :: IPP
      INTEGER          :: IASU
      INTEGER          :: IVAL
      INTEGER, SAVE    :: ITEM
      INTEGER, SAVE    :: IATK
      INTEGER          :: JATK
      INTEGER          :: IHAT
      INTEGER          :: IENM
      INTEGER          :: NPOP
      INTEGER          :: IDUM
      INTEGER          :: JDUM
      INTEGER          :: NRCOL
      INTEGER          :: MMODE
      INTEGER          :: INQNR
      INTEGER          :: JNQNR
      REAL             :: X
      REAL             :: Y
      REAL             :: Z
      REAL             :: XL
      REAL             :: YL
      REAL             :: ZL
      REAL             :: RL
      REAL             :: YY
      REAL             :: DEL
      REAL             :: DIS
      REAL             :: DISM
      REAL             :: DIST
      REAL             :: XHORS
      REAL             :: YHORS
      REAL             :: DELMIN
      CHARACTER(len=4) :: NTYP
      CHARACTER(len=7) :: TADD
      YY    = VERT - Y
      MMODE = IGBL(6)
      JATK  = 0
      IASU  = 0
      LRET  = 1
C * DELETE TEXT
      IF (IPR(344) == 1) THEN
        IF (IPR(447) > 0) THEN
C * PLUTON SUB1-MENU
          IF (MMODE == 3) THEN
            LMOD = 0
            CALL PLA109 (3, 1, X, Y)
          ELSE IF (MMODE == 8) THEN
            LMOD = 0
            CALL PLA109 (3, 0, X, Y)
          END IF
          LRET = -1
          RETURN
        END IF
C * CHANGE TEXT SIZE
      ELSE IF (IPR(334) == 1) THEN
        IF (IPR(447) > 0) THEN
          IF (MMODE == 3) THEN
            LMOD = 0
            CALL PLA109 (4, 1, X, Y)
          ELSE
            LMOD = 0
            CALL PLA109 (4, 0, X, Y)
          END IF
        END IF
        LRET = -1
        RETURN
      ELSE IF (IPR(343) == 1) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IPR(342) = ITEM
C * CLICKABLE VIEW LINE/PERP/BISECT
      ELSE IF (IPR(329) > 0) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IF (ITEM == 0) THEN
          LRET = -1
          RETURN
        END IF
        LMOD = LMOD + 1
        CALL PLUT25 (1, ITEM, IDUM)
        IFL(LMOD + 2) = NQ1
        IF (IPR(329) == 1) THEN
          IF (LMOD < 2) THEN
            LRET = -1
            RETURN
          END IF
        ELSE
          IF (LMOD < 3) THEN
            LRET = -1
            RETURN
          END IF
        END IF
        IPR(220) = LMOD + 2
        CALL PLUT06
        IPR(329) = 0
        LMOD     = 0
        RETURN
C * CONTOUR OMIT FROM SFC (TEST PRIOR TO IPR(415))
      ELSE IF (IPR(182) == 1) THEN
        CALL PLA018 (-1, X, YY, NQ1)
        LRET = -1
        RETURN
C * CONTOUR/ORTEP
      ELSE IF (IPR(415) > 0) THEN
        CALL PLA018 (0, X, YY, NQ1)
        CALL PLA280 (NQ1)
        RETURN
 
C * FIT BY CLICKING
      ELSE IF (IPR(312) > 0) THEN
        CALL PLA018 (0, X, YY, NQ1)
        IF (NQ1(1:1) /= '*') THEN
          LMOD = LMOD + 1
          IF (MOD(LMOD, 2) == 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
          END IF
          CALL PLA439 (0.0, NQ1, 6, 0.3, 5 + IGBL(68), 1,
     1                 XHORS, YHORS)
          IFL(LMOD + 1) = NQ1
        END IF
        LRET = -1
        RETURN
C * ORTEP COLOR-TYPE
      ELSE IF (IPR(536) > 0) THEN
        CALL PLA018 (0, X, YY, NQ1)
        CALL PLA046 (3, NQ1, IENM, LBB, LBC, LBD, INQNR, JNQNR, N1)
        CALL PLA280 ('COLOR TYPE '//LMT(IENM, 1)//' '//COLR(IPR(536)))
        IPR(536) = 0
        RETURN
C * CLICKABLE GEOM/DIST/ANGLE/TORSION
      ELSE IF (IPR(341) > 0) THEN
C * ORTEP MODE
        IF (IABS(MMODE) == 1 .OR. IABS (MMODE) == 8 .OR.
     1      IABS(MMODE) == 9) THEN
          CALL PLA018 (0, X, YY, NQ1)
          LMOD = LMOD + 1
          IFL(LMOD + 1) = NQ1
          WRITE (SBCD, 99999, IOSTAT = IOST) (IFL(I), I = 1, LMOD + 1)
          IF (LMOD >= MIN (4,IPR(341))) THEN
            IPR(81) = LMOD + 1
            CALL PLA440 (1)
            LMOD     = 0
            IGBL(6) = IABS (IGBL(6))
          END IF
          LRET = -1
          RETURN
C * PLUTON MODE
        ELSE
          CALL PLA014 (1, 1, X, Y, ITEM, IASU)
          IF (ITEM == 0) THEN
            LRET = -1
            RETURN
          END IF
          IF (IPR(341) == 1) THEN
            IFL(1) = 'GEOM'
C * DIST
          ELSE IF (IPR(341) == 2) THEN
            IFL(1) = 'DIST '
            IF (IASU > 1) THEN
              IF (LMOD == 0) THEN
                LRET = -1
                RETURN
              ELSE IF (LMOD == 1) THEN
                FN(1)    = - IASU
                IPR(221) = 1
              END IF
            END IF
C * ANGLE
          ELSE IF (IPR(341) == 3) THEN
            IFL(1) = 'ANGLE'
C * TORSION
          ELSE IF (IPR(341) == 4) THEN
            IFL(1) = 'TORSION'
          END IF
          LMOD = LMOD + 1
C * RECOVER ATOM LABEL
          CALL PLUT25 (1, ITEM, IDUM)
          IFL(LMOD + 1) = NQ1
          WRITE (SBCD, 99999, IOSTAT = IOST) (IFL(I), I = 1, LMOD + 1),
     1      CHAR(0)
          IF (LMOD < IPR(341)) THEN
            LRET = -1
            RETURN
          END IF
          IPR(220) = LMOD + 1
          IPR(163) = 0
C * GEOMETRY CALCULATION
          CALL PLUT24 (LMOD, IPR(38), IDUM)
          LMOD = 0
          IF (IPR(130) == 0) RETURN
        END IF
C * CLICKABLE LSPL
      ELSE IF ((IPR(476) /= 0 .OR. IPR(552) /= 0)
     1         .AND. MMODE == 9) THEN
        CALL PLA018 (0, X, YY, NQ1)
        LMOD      = LMOD + 1
        IFL(LMOD) = NQ1
        LRET = -1
        RETURN
C * DEFINE ORTEP MODE
      ELSE IF (IPR(508) /= 0 .AND. MMODE == 1) THEN
        CALL PLA018 (0, X, YY, NQ1)
        LMOD      = LMOD + 1
        IFL(LMOD) = NQ1
        IF (LMOD == 2) THEN
          LMOD      = LMOD + 1
          IFL(LMOD) = 'TO'
          IPR(507)  = 2
        END IF
        LRET = -1
        RETURN
C * DEFINE (PLUTON)
      ELSE IF (IPR(508) /= 0 .AND. MMODE == 4) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IF (ITEM == 0) THEN
          LMOD = 0
          LRET = -1
          RETURN
        END IF
        CALL PLUT25 (1, ITEM, IDUM)
        LMOD = LMOD + 1
        IFL(LMOD) = NQ1
        IF (LMOD == 2) THEN
          LMOD      = LMOD + 1
          IFL(LMOD) = 'TO'
          IPR(507)  = 2
        END IF
        LRET = -1
        RETURN
C * JOIN/DETACH
      ELSE IF (IPR(311) /= 0) THEN
C * ORTEP
        IF (IABS (MMODE) == 1 .OR. IABS (MMODE) == 8) THEN
          LMOD = LMOD + 1
          IF (LMOD == 1) THEN
            CALL PLA018 (0, X, YY, NQ1)
            LRET = -1
            RETURN
          ELSE
            CALL PLA018 (0, X, YY, NQ2)
            IF (IPR(311) == 1) THEN
              CALL PLA280 ('JOIN '//NQ1//NQ2)
            ELSE IF (IPR(311) == 2) THEN
              CALL PLA280 ('JOIN DASH '//NQ1//NQ2)
            ELSE
              CALL PLA280 ('DETACH '//NQ1//NQ2)
            END IF
            RETURN
          END IF
C * PLUTON
        ELSE IF (MMODE == 4) THEN
          CALL PLA014 (1, 1, X, Y, ITEM, IASU)
          IF (ITEM == 0) THEN
            LMOD = 0
            LRET = -1
            RETURN
          END IF
          LMOD = LMOD + 1
          CALL PLUT25 (LMOD, ITEM, IDUM)
          IF (LMOD == 1) THEN
            IAT  = ITEM
            IATK = IDUM
          ELSE
            JAT  = ITEM
            JATK = IDUM
          END IF
          IF (LMOD < 2) THEN
            LRET = -1
            RETURN
          END IF
          IF (IPR(221) == 0) THEN
            CALL PLUT22 (IAT, JAT, DIST)
            IF (DIST > RADR(IATK, 3) + RADR(JATK, 3) + 0.8) THEN
              TADD = ' 0.05 2'
            ELSE
              TADD = '       '
            END IF
          END IF
          IF (IPR(311) == 1) THEN
            CALL PLA280 ('JOIN '//NQ1//NQ2//TADD)
          ELSE IF (IPR(311) == 2) THEN
            CALL PLA280 ('JOIN DASH '//NQ1//NQ2//TADD)
          ELSE
            CALL PLA280 ('DETACH '//NQ1//NQ2)
          END IF
          RETURN
        END IF
C * CONTOUR POS-CLICK
      ELSE IF (IPR(439) == 1) THEN
        WRITE (IGGT, '(''CPS'', 2F10.3)') X, PAR(38) - Y
        RETURN
      END IF
      SELECT CASE (MMODE)
C * MMODE = 1 - PLATON / ORTEP
        CASE (1)
          IPR(478) = 0
          IF (IPR(351) == 1) THEN
            CALL PLA018 (1, X, YY, NQ1)
          ELSE IF (IPR(440) == 1) THEN
            CALL PLA018 (0, X, YY, NQ1)
            CALL GEN020 (1, NQ1, 1, 7)
            IF (NQ1(2:2) == ' ') THEN
              NQ1(2:3) = '()'
            ELSE
              DO J = ICHAR ('A'), ICHAR ('Z')
                IF (NQ1(2:2) == CHAR(J)) THEN
                  IF (NQ1(3:3) == ' ') THEN
                    NQ1(3:4) = '()'
                  END IF
                END IF
              END DO
            END IF
            CALL PLA280 ('CALC COORDN '//NQ1)
C * CLICK FOR ARU ADD
          ELSE IF (IPR(440) == -1) THEN
            IF (X < PAR(37) / 2) THEN
              IMIN = 0
              DISM = 1000.0
              DO J = 1, 100
                DIS = ABS (YY - YMOL(1, J))
                IF (DIS < DISM) THEN
                  IMIN = J
                  DISM = DIS
                END IF
              END DO
              IF (IMIN /= 0) THEN
                FN(1)    = YMOL(2, IMIN)
                IPR(221) = 1
                CALL PLA295
              END IF
            END IF
C * MOVE/DELETE/INCLUDE LABEL
          ELSE IF (IPR(349) /= 0 .OR. IPR(327) /= 0
     1                 .OR. IPR(328) /= 0) THEN
            IF (LMOD == 0) THEN
C * GET NEAREST LABEL (PLATON)
              DELMIN = 1000.0
              IMIN = 1
              DO I = 1, IPR(39) + IPR(64)
                J   = I * NP71
                DEL = (VOID(J - 2) - X)**2 + (VOID(J - 1) - YY)**2
C * IGNORE MAJOR/MINOR FORMS WHERE RELEVANT
                IF (IGBL(59) /= 0) THEN
C * GET POPULATION PARAMETER
                  CALL GEN048 (-8, IFG(2, I), 1, IPP)
                  NPOP = IPPR(IPP + 1, 1)
                  IF (NPOP < 10000) THEN
                    IF (IGBL(88) == 0) THEN
                      IF (NPOP < 5000) CYCLE
                    ELSE
                      IF (NPOP > 5000) CYCLE
                    END IF
                  END IF
                END IF
                IF (IPR(328) == 1) THEN
                  IVAL = 1
                ELSE
                  CALL GEN048 (-1, IFG(2, I), 11, IVAL)
                END IF
                IF (IVAL == 1 .AND. DEL < DELMIN) THEN
                  CALL GEN048 (-1, IFG(1, I), 7, IHAT)
                  IF (IHAT /= 1 .OR. IPR(212) * IPR(232) /= 0)
     1               THEN
                    IMIN   = I
                    DELMIN = DEL
                  END IF
                END IF
              END DO
              CALL PLA047 (LABA(IMIN), NQ1, IDUM, JDUM,
     1                     IPR(350) * 2 - 1, IGBL(55), 0, 0)
              LMOD = 1
              X    = VOID(IMIN * NP71 - 2)
              YY   = VOID(IMIN * NP71 - 1)
            ELSE
              LMOD = 0
              VOID(IMIN * NP71 - 2) = X
              VOID(IMIN * NP71 - 1) = YY
            END IF
            IF (IPR(328) == 1) THEN
              CALL GEN048 (1, IFG(2, IMIN), 11, 1)
              LMOD = 0
            END IF
            YGGIP = FLOAT (1 - LMOD)
            CALL PLA439 (0.0, NQ1, 6, PAR(349), NINT (YGGIP), 1, X, YY)
            IF (IPR(327) == 1) THEN
              CALL GEN048 (1, IFG(2, IMIN), 11, 0)
              LMOD = 0
            END IF
            LRET = -1
            RETURN
          ELSE
            LRET = -1
            RETURN
          END IF
C * MMODE = 2 - PLUTON MODE
        CASE (2)
          LRET = -1
          RETURN
C * MMODE = 3 - PLUTON SUB1
        CASE (3)
C * PLUTON LABEL REPOSITION
          IF (IPR(349) == 1) THEN
            IF (LMOD == 0) THEN
              CALL PLA014 (-1, 1, X, Y, ITEM, IASU)
              NRCOL = 0
              CALL PLUT14 (-1, ITEM, IASU, NRCOL, XL, YL, ZL, RL)
              IF (ITEM /= 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
              END IF
            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
            END IF
            LRET = -1
            RETURN
C * EXLUDE ARU
          ELSE IF (IPR(213) == 1) THEN
            CALL PLA014 (-2, 1, X, Y, ITEM, IASU)
            ITEM = ITEM - IPR(62) - IPR(37)
            IF (ITEM > 0) THEN
              CALL PLUT17 (FLOAT (ITEM), 1005, M, LU6)
            ELSE
              LRET = -1
              RETURN
            END IF
          ELSE IF (IPR(332) == 1 .OR. IPR(335) == 1 .OR.
     1      IPR(351) == 1 .OR. IPR(352) == 1) THEN
            CALL PLA014 (1, 1, X, Y, ITEM, IASU)
            IF (ITEM /= 0) THEN
              CALL PLUT25 (1, ITEM, IATK)
C * DELETE
              IF (IPR(351) == 1) THEN
                WRITE (IGGT(1:), '(''DELETE '', A)', IOSTAT = IOST) NQ1
C * ANIS
              ELSE IF (IPR(352) == 1) THEN
                WRITE (IGGT(1:), '(''ANIS '', A)', IOSTAT = IOST) NQ1
                CALL PLUT15 (1, ITEM, 41, 1)
C * HFIX
              ELSE IF (IPR(332) == 1) THEN
                IF (IGBL(25) == 0) THEN
                  WRITE (LU6, 99992, ADVANCE = 'NO', IOSTAT = IOST) NQ1
                  READ (LU5, 99995) NQ2
                  WRITE (IGGT(1:), 99993, IOSTAT = IOST) NQ1, NQ2
                ELSE
                  IF (NCNT == 0) THEN
                    STRING(1:4) = 'HFIX'
                    NCNT = 4
                  END IF
                  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
                  RETURN
                END IF
C * RENAME
              ELSE IF (IPR(335) == 1) THEN
C * TEST FOR MENU ON/OFF
                IF (IGBL(25) == 0) THEN
                  READ (LU5, 99995) NQ2
                  WRITE (IGGT(1:), 99994, IOSTAT = IOST) NQ1, NQ2
                ELSE
                  IF (NCNT == 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
                  END IF
                  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
                  RETURN
                END IF
              ELSE
                LRET = -1
                RETURN
              END IF
            ELSE
              LRET = -1
              RETURN
            END IF
          ELSE
C * OPTIONS MODE
            CALL PLA109 (5, 1, X, Y)
            LRET = -1
            RETURN
          END IF
C * MMODE = 4 - PLUTON SUB2
        CASE (4)
          CALL PLA014 (1, 1, X, Y, ITEM, IASU)
          IF (ITEM /= 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 /= 0) NTYP(3:3) = CHAR (ICHAR ('a') + N2 - 1)
            IF (IPR(348) == 1) THEN
C * CHECK FOR BWC-SWITCH ON/OFF)
              IF (IPR(461) == 0) THEN
C * CHECK FOR BWC-TYPE (BWC/RES/ARU)
                IF (IPR(478) == 0) THEN
                  IPR(340) = IPR(340) + 1
                  IF (IPR(340) > 17) IPR(340) = 1
                  CALL PLA280 ('BWC TYPE'//NTYP//BWCT(IPR(340)))
                END IF
              ELSE
                IPR(139) = IPR(139) + 1
                IF (IPR(139) > 17) IPR(139) = 1
                CALL PLA280 ('PLOT')
              END IF
            ELSE IF (IPR(338) == 1) THEN
              IPR(337) = IPR(337) + 1
              IF (IPR(337) > 9) IPR(337) = 1
              CALL PLA280 ('COLOR TYPE'//NTYP//COLR(IPR(337)))
            END IF
          ELSE
            LRET = -1
            RETURN
          END IF
C * MMODE = 5 & 6
        CASE (5, 6)
          LRET = -1
          RETURN
C * MMODE 8 & 9 - ORTEP/SUP
        CASE (8, 9)
          CALL PLA109 (5, 0, X, Y)
          LRET = -1
          RETURN
C * MMODE 7, 10, 11, 12
C * PLATON MAIN MENU & PLATON SUP1&2-MENU (PLUTON/SUP5)
        CASE (7, 10, 11, 12)
          CALL PLA011 (X, Y, Z)
C * MMODE = 17 - SYSTEM S
        CASE (17)
C * RESET CANVAS INPUT
          IF (IGBL(28) > 0) THEN
            NV =  NINT ((Y - RGBL(1) + PAR(360) + PAR(361) / 2.0)
     1             / PAR(361))
            IF (NV <= 0) THEN
              CALL PLA280 ('PLOT')
            ELSE
              IF (IGBL(28) == 1) THEN
                 IF (NV < 10) THEN
                  WRITE (IGGT, 99998, IOSTAT = IOST) NV
                ELSE
                  WRITE (IGGT, 99997, IOSTAT = IOST) NV
                END IF
              ELSE IF (IGBL(28) == 2) THEN
                NV = - NV
                IF (NV < 10) THEN
                  WRITE (IGGT, 99997, IOSTAT = IOST) NV
                ELSE
                  WRITE (IGGT, 99996, IOSTAT = IOST) NV
                END IF
              END IF
            END IF
          ELSE
            CALL PLA280 ('PLOT')
          END IF
C * MMODE = 18 - SYSTEM S/SUB1
        CASE (18)
          IF (IGBL(28) == 1) THEN
            NV = MIN (17, MAX (0, INT (Y - 1.5)))
            IF (NV < 10) THEN
              WRITE (IGGT, 99998, IOSTAT = IOST) NV
            ELSE
              WRITE (IGGT, 99997, IOSTAT = IOST) NV
            END IF
          ELSE
            CALL PLA280 ('PLOT')
          END IF
C * MMODE 19 & 22
        CASE (19, 22)
          LRET = -1
          RETURN
      END SELECT
      RETURN
99999 FORMAT (6(A, 1X))
99998 FORMAT (I1)
99997 FORMAT (I2)
99996 FORMAT (I3)
99995 FORMAT (A)
99994 FORMAT ('REN ', A, A)
99993 FORMAT ('HFIX ', A, A)
99992 FORMAT ('HFIX ', A, 1X)
      END SUBROUTINE PLA020
 
      SUBROUTINE PLA021 (MODE, NRETURN)
C * CALLED FROM PLA002 INPUT ROUTINE
      USE files
      USE parameters
      USE plato
      USE xwdw
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: MODE
      INTEGER             :: IPR17
      INTEGER             :: IGBL63
      INTEGER             :: NRETURN
      REAL, DIMENSION(16) :: SAV
      NRETURN = 0
C * NRETURN = 0 - (RETURN)
C * NRETURN = 1 - (GO TO 010)
C * NRETURN = 2 - (GO TO 200)
C * NRETURN = 3 - (GO TO 130)
C * NRETURN = 4 - (GO TO 190)
C * CALC INTRA MODE
      IF (MODE == 0) THEN
        NRETURN = -1
C * TEST FOR NONSYM/MOLSYM
        IF (IPR(495) <= 1) THEN
C * HANDLE DISPLACEMENT PARAMETERS
          CALL PLA024
          IF (IGBL(131) == 1) THEN
            CALL PLA074 (-2, 0)
C * ERROR HANDLING
            IGBL(1) = 3
            NRETURN = 0
            RETURN
          END IF
C * CLOSE FOR CREATE PDB, SPF & RES
          IF (IPR(675) == 1) THEN
            CALL PLA074 (-2, 0)
            IF(IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
            IGBL(1) = 3
            NRETURN = 0
            RETURN
          END IF
C * HANDLE -g, -R & -j MODE
          IF (IGBL(3) == 23 .OR. IGBL(3) == 24 .OR.
     1        IGBL(3) == 27) THEN
            IPR(1)  = 3
            IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
            IGBL(1) = 3
            NRETURN = 0
            RETURN
C * HANDLE -S mode CIF2RES & FCF2HKL
          ELSE IF (IGBL(3) == 25) THEN
            CALL PLA139 (LU6, LU16, LU17, IPR(384))
C * TERMINATE JOB
            IGBL(1) = 4
            NRETURN = 0
            RETURN
          ELSE
C * HANDLE ADDSYM/PLUTON
            IF (IPR(504) == 1) THEN
              CALL PLUTON (2)
C * MANAGE LU1
              IGBL(1) = 0
              NRETURN = 0
              RETURN
            END IF
C * OUTPUT CONNECTION TABLES
            CALL PLA074 (-2, 0)
            IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
              IGBL(1) = 3
              NRETURN = 0
              RETURN
            END IF
C * HANDLE -b OPTION
            IF (IGBL(3) == 11) THEN
              IPR(1) = 3
              IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
              IGBL(1) = 3
              NRETURN = 0
              RETURN
            ELSE
C * GEOM LISTING IN 'NON PLUTON' MODE
              IF (IPR(14) /= 6) THEN
C * SKIP IN CASE OF ORTEP PLOT
                IF (IPR(14) /= 4) THEN
C * LIST INTRA GEOMETRY
                  CALL PLA077
                  IF (IGBL(31) == 1 .AND. IPR(430) == 0) IPR(2) = -1
C * SEARCH/GENERATE RINGS AND PLANES
                  CALL PLA078
                  IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
                    IGBL(1) = 3
                    NRETURN = 0
                    RETURN
                  END IF
C * LIST LEAST-SQUARES PLANES
                  CALL PLA075
C * RING PUCKERING ANALYSIS
                  CALL PLA076
C * DEFAULT ORTEP PLOT SETTINGS
                ELSE
C * INCLUDE RINGS
                  IPR(10)  = 1
C * LIMIT TO UP TO 6-MEMBERED RINGS
                  IPR(579) = 6
                  CALL PLA078
                  CALL PLA076
                END IF
C * FCF/NEWSYM
                IF (IPR(210) < 0) THEN
C * CHECK FOR RECOGNISED WAVELENGTH
                  IF (IPR(493) == 0) THEN
                    IF (IPR(210) == -2) THEN
                      IPR(493) = -3
                    ELSE
                      IPR(2)  = 47
C * ERROR HANDLING
                      IGBL(1) = 3
                      NRETURN = 0
                      RETURN
                    END IF
                  END IF
                  IF (IPR(498) > 0) THEN
                    IPR(2)  = 45
C * ERROR HANDLING
                    IGBL(1) = 3
                    NRETURN = 0
                    RETURN
                  END IF
C * CHECK FOR NEWSYM CASE
                  IF (IPR(210) == -2) THEN
                    CALL PLA160 (-3, TM1)
C * CALC FCF ETC
                  ELSE
                    CALL PLA135
                  END IF
                  IPR(1) = 1
                  IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
                  IGBL(1) = 3
                  NRETURN = 0
                  RETURN
                END IF
              END IF
            END IF
          END IF
        END IF
        RETURN
C * CALC INTER, VOID, SQUEEZE, NEWSYM AND COORDINATION MODE
      ELSE IF (MODE == 1) THEN
        IPR(17)  = IPR(31)
        IPR(189) = IPR(200)
        NRETURN  = -1
C * CHECK FOR SQUEEZE CALCULATION
        IF (IPR(210) == 1) THEN
          IF (IPR(2) == 0) THEN
C * CHECK FOR NON-ZERO U/UIJ ERROR COUNT
            IF (IPR(498) /= 0) THEN
C * SET UIJ ERROR MESSAGE
              IPR(2) = 45
C * TEST FOR CIF BASED ON EXTI REFINEMENT
            ELSE IF (PAR(229) > 0.0 .OR. PAR(226) > 0.0) THEN
              IF (IGBL(29) == -1) THEN
                PAR(229) = -999999.0
              ELSE
                IPR(2) = 75
              END IF
            END IF
            IF (IPR(2) == 0) THEN
C * SET UP CONNECTED SET
              CALL PLA067
C * SQUEEZE CALCULATION FOR NON-ZERO VOID VOLUME
              IF (PAR(150) > 0) CALL PLA125
            ENDIF
          END IF
          IGBL(1) = 3
          IF (IPR(2) == 0) IPR(2) = -1
C * CHECK FOR DIFFERENCE MAP CALCULATION (FFT - PATH)
        ELSE IF (IPR(210) == 2) THEN
C * CHECK FOR NO UIJ ERRORS
          IF (IPR(498) == 0) THEN
            CALL PLA360
            IF (IPR(2) == 0) IPR(2) = -1
          END IF
          IGBL(1) = 3
        ELSE
C * DO CALC INTER ETC.
          CALL PLA067
          IF (IWIN == 1 .AND. IGBL(6) == 0) IGBL(6) = 10
C * TEST FOR ERROR
          IF (IPR(2) == 0) THEN
C * RDF-PLOT
            IF (IPR(57) == 2) THEN
              CALL PLA144 (-1, 0)
C * HANDLE -v OPTION (CALC SOLV)
            ELSE IF (IGBL(3) == 9) THEN
              IPR(1)  = 3
              IGBL(1) = 3
              IF (IPR(2) == 0) IPR(2) = -1
C * HANDLE -q OPTION (SQUEEZE - NO CALC VOID)
            ELSE IF (IGBL(3) == 5 .AND. IPR(210) == 0) THEN
              IF (IGBL(31) /= 0) THEN
                CLOSE (UNIT = LU2, IOSTAT = IOST)
                IF (IOST == 0) IGBL(31) = 0
              END IF
              IPR(1) = 3
              IF (IPR(2) == 0) IPR(2) = -1
              IGBL(1) = 3
C * HANDLE -K OPTION (K.P.I.)
            ELSE IF (IGBL(3) == 36) THEN
              IF (IPR(2) == 0) IPR(2) = -1
              IGBL(1) = 3
            END IF
          END IF
        END IF
        NRETURN = 0
        RETURN
C * CALC ADDSYM
      ELSE IF (MODE == 2) THEN
        IPR(121) = IPR(121) - 1
        IF (IPR(37) /= 0) THEN
C * RUN ADDSYM
          CALL PLA060
C * ERROR TEST
          IF (IPR(2) == 0) THEN
C * HANDLE -m OPTION (ADDSYM MODE)
            IF (IGBL(3) == 4) THEN
              IPR(1) = 3
              IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
              IGBL(1) = 3
              RETURN
            END IF
            NRETURN = 1
            RETURN
          END IF
        END IF
        NRETURN = 2
C * CALC INTRA (UNIQUE MOLECULE CALCULATION)
      ELSE IF (MODE == 3) THEN
        IPR(31)  = 0
        IPR(430) = -1
C * NO INTRA AFTER PREVIOUS INTRA
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
        IF (IPR(30) /= 0) THEN
          IPR(2) = 31
          NRETURN = 2
          RETURN
        END IF
C * SET ALL INTRA OPTIONS ON
        IF (IPR(5) == -1) THEN
          IPR(5) = 1
        ELSE
          CALL GEN097 (IPR, 5, 11, 1)
        END IF
        IPR(495) = 1
C * LOWER THE NUMBER OF STILL TO BE EXECUTED TASKS
        IPR(121) = IPR(121) - 1
C * SET FOR CALC INTRA AS LAST INSTRUCTION
        IF (IPR(121) == 0) IPR(136) = 1
        CALL PLA015 (0, 39)
        NRETURN = 3
C * CALC INTER
      ELSE IF (MODE == 4) THEN
        IF (IPR(23) > 0) THEN
          NRETURN = 4
          RETURN
        END IF
        IPR(200) = 0
        IPR(104) = 0
        CALL GEN097 (IPR, 5, 10, 0)
C * TEST FOR PREVIOUS INTER CALC
        IF (IPR(77) == 1) THEN
          IPR(2) = 11
          NRETURN = 2
          RETURN
        END IF
        IPR(77)  = 1
        IPR(31)  = -1
        IPR(90)  = 1
        IPR(121) = IPR(121) - 1
        NRETURN   = 3
C * CALC COORDN
      ELSE IF (MODE == 5) THEN
        IPR(5)  = 0
        IPR(6)  = 1
        IPR(7)  = 16
        IPR(8)  = 0
        IPR(9)  = 0
        IPR(10) = 0
        IPR(1)  = 6
C * BOND VALENCE ANALYSIS - INIT
        CALL PLA096 (0, '        ', -1.0, 0)
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
        IF (IPR(30) == 0) THEN
C * SAVE PARAMETERS TEMPORARILY
          DO I = 1, 16
            SAV(I) = FN(I)
          END DO
C * SET UP CONNECTED SET
          CALL PLA067
          IF (IPR(2) /= 0) THEN
            NRETURN = 0
            RETURN
          END IF
C * RESTORE SAVED PARAMETERS
          DO I = 1, 16
            FN(I) = SAV(I)
          END DO
        END IF
        IPR(31) = 1
        IF (IPR(221) == 1) THEN
          IF ((IPR(220) == 3 .AND. IFL(3)(1:3) == 'NOA') .OR.
     1      IPR(220) == 2) THEN
            IF (IPR(57) == 1) IPR(170) = 1
            PAR(262) = FN(1)
          END IF
        END IF
        IPR(121) = IPR(121) - 1
        IPR(122) = 0
        CALL PLA015 (0, 39)
        NRETURN = 3
C *
      ELSE IF (MODE == 6) THEN
        IPR(31) = 1
        IF (IPR(221) == 1) THEN
          IF ((IPR(220) == 3 .AND. IFL(3)(1:3) == 'NOA') .OR.
     1      IPR(220) == 2) THEN
            IF (IPR(57) == 1) IPR(170) = 1
            PAR(262) = FN(1)
          END IF
        END IF
        IPR(121) = IPR(121) - 1
        IPR(122) = 0
        CALL PLA015 (0, 39)
        NRETURN = 3
C *
      ELSE IF (MODE == 7) THEN
C * TRANSFORM LABELS TO SEQUENCE NUMBERS
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
          IF (IPR(30) == 0) THEN
          CALL PLA280 (ICL)
          IGBL(52) = MAX (IGBL(52), IPR(23))
C * SET UP CONNECTED SET
          CALL PLA067
          IF (IPR(2) /= 0) THEN
            NRETURN = 0
            RETURN
          END IF
          CALL PLA073 (-1, 1)
C * TEST FOR PLA024 DONE
          IF (IPR(85) == 0) THEN
            IPR(5) = 0
            CALL PLA024
          END IF
        ELSE
          CALL PLA288 (IPR(785))
        END IF
        NRETURN = 1
C * CALC METAL (WHEN METAL PRESENT)
      ELSE IF (MODE == 8) THEN
        IF (IPR(155) > 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
          IPR(31)  = 1
          IF (IPR(221) == 1) THEN
            IF ((IPR(220) == 3 .AND. IFL(3)(1:3) == 'NOA') .OR.
     1        IPR(220) == 2) THEN
              IF (IPR(57) == 1) IPR(170) = 1
              PAR(262) = FN(1)
            END IF
          END IF
          IPR(121) = IPR(121) - 1
          IPR(122) = 0
          CALL PLA015 (0, 39)
          NRETURN = 3
        ELSE
          IPR(121) = IPR(121) - 1
          NRETURN = 1
        END IF
C *  CALC SOLV/VOID
      ELSE IF (MODE == 9) THEN
C * ERROR CHECK FOR ANGSTROM/FRACTIONAL DATA
        IF (IPR(23) == 1) THEN
          IPR(2) = 33
          NRETURN = 2
        ELSE
          CALL GEN097 (IPR, 5, 10, 0)
          IPR(31)  = -1
          IPR(90)  = 1
          IPR(121) = IPR(121) - 1
          NRETURN  = 3
        END IF
C * RUN DEFAULT IUCR-CHECK (CIF + FCF) (ASYM)
      ELSE IF (MODE == 10) THEN
C * TEST FOR CIF (BUT NOT CSD-CIF (i.e. IGBL(94) /= 0)
C * CURRENTLY SKIPPED FOR ELECTRON DIFFRACTION
        IF (IABS(IGBL(8)) == 3 .AND. IGBL(94) == 0) THEN
          IPR(121) = IPR(121) - 1
C * TEST FOR ABSENT WAVELENGTH
C * ALERT _091
          IF (IPR(493) == -3)
     1      CALL PLA236 (91, 0, 1.0, 1.0, ' ', ' ')
C * TEST FOR NON In/Ag/Mo/Ga/Cu KA radiation AND NON XKB, 'SYNCHROTRON',
C * OR 'NEUTRON' OR 'ELECTRON'
C * ALERT _092
          IF (IPR(493) > 5 .AND. IPR(630) == 0)
     1      CALL PLA236 (92, 5, -999.0, PAR(17), ' ', ' ')
C * SET FOR EXPECT MODE - CHECK FOR THETA(MAX) VALUE
          IF (PAR(168) > 0.0) THEN
            CALL PLA145 (1)
          END IF
C * CHECK FOR FCF-PRESENT (TYPE SHELXL etc, or LIST 3))
          IF (IGBL(9) > 0 .AND. IGBL(9) < 28) THEN
            IPR(200) = 0
C * SAVE/INIT PARAMETER VALUES
C * PRINT LEVEL
            IGBL63   = IGBL(63)
            IGBL(63) = 0
C * JOIN
            IPR17    = IPR(17)
            IPR(17)  = 0
C * NMOL
            IPR(13)  = 0
C * VALIDATION MODE (AVF)
            CALL PLA145 (2)
C * RESTORE PARAMETER VALUES
C * PRINT LEVEL
            IGBL(63) = IGBL63
C * JOIN
            IPR(17)  = IPR17
C * HKS FILE
            IGBL(18) = 0
C * ANALYSE DIFFERENCE MAP (STRUCTURE FACTORS CALCULATED FROM CIF)
C * CURRENTLY FOR SHELXL-97 & SHELXL-20xy ONLY
            IF ((IPR(725) > 0 .AND. IPR(725) < 5)
     1        .OR. IGBL(9) == 1) THEN
              IPR(210) = 2
              CALL PLA360
            END IF
          END IF
C * IUCR-CHECK (TAKING INTO ACCOUNT FCF ANALYSIS
          IF (IABS(IGBL(8)) == 3) CALL PLA233
          IPR(2) = -1
C * ERROR HANDLING
          IGBL(1) = 3
          NRETURN = 0
          RETURN
        ELSE
          IPR(121) = IPR(121) - 2
          NRETURN = 4
          RETURN
        END IF
C * EXECUTE LIST ON DISPLAY OPTIONS
      ELSE IF (MODE == 11) THEN
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
        IF (IPR(30) == 0) THEN
C * SET UP CONNECTED SET
          CALL PLA067
          IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
            IGBL(1) = 3
            NRETURN = 0
            RETURN
          END IF
C * GET NEW INSTRUCTION
          IF (IPR(205) /= 0) RETURN
          CALL PLA073 (-1, -1)
          IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
            IGBL(1) = 3
            NRETURN = 0
            RETURN
          END IF
        END IF
        IF (IPR(1) == 4) THEN
          IF (IPR(84) == 1) THEN
            CALL PLA073 (1, -1)
          ELSE
            CALL PLA074 (2, -1)
          END IF
          IF (IPR(2) /= 0) THEN
C * ERROR HANDLING
            IGBL(1) = 3
            NRETURN = 0
            RETURN
          END IF
        ELSE IF (IPR(1) == 7) THEN
C * INTERACTIVE DIST, ANGLE, TORSION AND LSPL CALCULATION
          CALL PLA440 (1)
        END IF
C * CHECK FOR '-I' MODE FIT
        IF (IGBL(3) == 41) THEN
          IPR(2) = -1
C * ERROR HANDLING
          IGBL(1) = 3
          NRETURN = 0
          RETURN
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA021
 
      SUBROUTINE PLA022 (INQNR)
C * INVESTIGATE THE PARAMETERS OF A (POTENTIALLY) NEW ATOM RECORD
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: KN
      INTEGER :: KL
      INTEGER :: MN
      INTEGER :: KNS
      INTEGER :: LOP
      INTEGER :: NCY
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: IVL
      INTEGER :: ISU
      INTEGER :: NAT
      INTEGER :: IHAT
      INTEGER :: JHAT
      INTEGER :: JSYM
      INTEGER :: KNP1
      INTEGER :: NSYM
      INTEGER :: NPOP
      INTEGER :: NIEN
      INTEGER :: IENM
      INTEGER :: IHYD
      INTEGER :: IENR
      INTEGER :: MODE
      INTEGER :: IPOP
      INTEGER :: JDUM
      INTEGER :: MULT
      INTEGER :: MULTX
      INTEGER :: NATP1
      INTEGER, SAVE :: IATYC
      INTEGER, SAVE :: IATYO
      INTEGER, SAVE :: IATYN
      INTEGER :: IENM1
      INTEGER :: INQNR
      INTEGER :: JNQNR
      INTEGER :: ITRNS
      INTEGER :: INTPOP
      INTEGER :: IPOPRES
      REAL    :: YY
      REAL    :: SJ
      REAL    :: RPI
      REAL    :: VERS
      REAL    :: XLNG
      REAL    :: FNK4
      REAL    :: RGBL25
      REAL    :: POPPARX
C * GET NUMBER OF CURRENTLY ACCEPTED ATOMS
      NAT = IPR(39)
C * CATCH ATTEMPT TO EXCEED MAX NUMBER OF ATOM LIMIT
      IF (NAT < NP1) THEN
        IENR = 0
        ISU  = 0
C * GET NUMBER OF SYMMETRY OPERATIONS
        NSYM = IPR(48)
C * ZERO SKIP-TEST
        IPR(107) = 0
C * SET PACKING PARAMETERS FOR INTERNAL NUMERICAL LABEL REPRESENTATION
        IF (NAT == 0) THEN
          IPR(463) = 128
          IPR(464) = 51200000
          IPR(465) = 400000
          IPR(466) = IPR(465) * 2
        END IF
        NATP1  = NAT + 1
C * GET NUMBER OF NUMERICAL ENTRIES ON INPUT LINE
        KL     = IPR(220)
        KN     = IPR(221)
        MODE   = 100
C * DELETE FROM INPUT CRITERIUM
        RGBL25 = MAX (0.05, RGBL(25))
C * GET ATOM LABEL AT POSITION IPR(473) IN RECORD
        NQ1    = IFL(IPR(473))
C * CHECK FOR AND HANDLE CIF STYLE INPUT
        IF (IGBL(8) == 3) THEN
C * CHECK FOR INCOMPLETE CIF-DATA
          IF (KN /= 10) THEN
C * CHECK FOR VALIDATION
            IF (IGBL(3) == 1) THEN
C * ALERT _170 - INSUFFICIENT DATA
              CALL PLA236 (170, 0, 1.0, 1.0, IFL(2), ' ')
            ELSE
              IPR(2) = 51
            END IF
            RETURN
          END IF
C * COUNT # OF PART EXTENSIONS ON LABEL
          IF (INDEX (NQ1, '^') > 0) IPR(768) = IPR(768) + 1
          IF (NAT == 0) THEN
C * CHECK FOR PROPER CELL DIMENSIONS
            IF (PAR(101) < 1.1 .AND. IPR(23) == 0) THEN
              IPR(2) = 58
              RETURN
            END IF
            IGBL(59) = 0
            IATYC    = 0
            IATYO    = 0
            IATYN    = 0
C * CHECK FOR ABSENCE OF EXPLICIT SYMMETRY
            IF (IPR(319) == 0) THEN
C * ALERT _124 - PROBLEM WITH EQUIVALENT POSITIONS
              CALL PLA236 (124, 0, 1.0, 1.0, CCIF(7)(1:7), ' ')
              IF (SPGRNM(1)(1:1) == ' ') THEN
C * ALERT _121 - INVALID SPACE GROUP
                CALL PLA236 (121, 0, 1.0, 1.0, CCIF(6), ' ')
C * INIT SPACE GROUP SYMMETRY TO P1
                CALL SGSM (1, IDM, SGY, 0, 0, IERR)
                IPR(48) = 1
              END IF
            END IF
          END IF
C * GET ASSIGNED SCATTERING TYPE TO THIS ATOM (_atom_site_type_symbol)
          IF (KL == 3) THEN
            N = 9
            IF (IFL(3)(3:3) == ' ') N = 2
            IF (IFL(3)(2:2) == ' ') N = 1
C * CHECK
            IF (N <= 2) THEN
              NQ4 = '       '//IFL(3)(1:N)
C * ALERT _017 - SCATTERING TYPE CONSISTENCY (SHELXL-CIF)
              IF (INDEX (IFL(2), IFL(3)(1:N)) == 0) THEN
                CALL PLA236 (17, 0, 1.0, 0.0, IFL(2)(1:9), NQ4(1:9))
              END IF
            END IF
          END IF
C * CHECK FOR AND HANDLE RES STYLE INPUT
        ELSE IF (IGBL(8) == 2) THEN
C * HANDLE SPECIAL L-LABELS (IDEAL)
          IF (NQ1(1:1) == 'L') THEN
            DO I = 1, 10
              IF (NQ1(2:2) == CHAR (ICHAR ('0') + I - 1)) RETURN
            END DO
          END IF
C * FIRST CHECK WHETHER ALPHANUMERIC ITEM IPR(473) IS AN ATOM LABEL
C * ADD RESIDUE NUMBER TO LABEL
          IF (IPR(538) /= 0) THEN
            N = INDEX (NQ1, ' ')
            IF (N /= 0) THEN
              IF (IPR(538) < 10) THEN
                WRITE (NQ1(N:N + 1), 99997, IOSTAT = IOST) IPR(538)
              ELSE
                WRITE (NQ1(N:N + 2), 99996, IOSTAT = IOST) IPR(538)
              END IF
            END IF
            IFL(IPR(473)) = NQ1
          END IF
        END IF
C * GET NUMERICAL REPRESENTATION FOR THE LABEL IN NQ1
        NQ2 = NQ1
        NQ4 = NQ1
        LOP = 0
        NCY = 0
        DO
          CALL PLA046 (MODE, NQ1, IENM1, LBB, LBC, LBD, INQNR, JNQNR,
     1                 NIEN)
C * ALERT FOR LABEL WITHOUT NUMERICAL PART
          IF (LBB == 0 .AND. NIEN >= 0) THEN
            IF (NQ1(2:2) /= '0') THEN
              CALL GEN020 (-1, NQ1, 2, 2)
C * ALERT _069
              IF (IPR(105) == 0)
     1          CALL PLA236 (69, 0, -999.0, 1.0, NQ1, ' ')
            END IF
          END IF
C * CHECK & ATTEMPT TO CORRECT LABEL PROBLEM
          IF (NIEN < 0) THEN
            IF (NIEN == -7) THEN
              IPR(2) = 67
              RETURN
            ELSE IF (NIEN == -12) THEN
              NQ1    = NQ2
              IPR(2) = 57
              RETURN
            END IF
C * HANDLE CIF-STYLE DATA LABEL
            IF (IABS (IGBL(8)) == 3) THEN
              IF (KL == 3) THEN
                LOP = LOP + 1
                IF (LOP == 1) THEN
                  NQ1 = IFL(3)
                ELSE
C * HANDLE 'Ox' case (avoid infinite loop
                  MODE     = 100
                  NQ1      = IFL(2)
                  IPR(220) = 2
                  KL       = 2
                END IF
              ELSE
                LOP = LOP + 1
C * NUMBER CHARACTER OR LEFT PARENTHESIS IN POSITION 2 ?
                IF (((ICHAR (IFL(2)(2:2)) >= 48 .AND.
     1              ICHAR (IFL(2)(2:2)) <= 57) .OR.
     2              IFL(2)(2:2) == '(')  .AND. LOP < 3) THEN
                  NQ1 = IFL(2)(1:1)//'      '
                ELSE
C * UNSUITABLE ATOM LABEL
                  NQ0    = NQ1
                  IPR(2) = 3
                  RETURN
                END IF
              END IF
C * HANDLE SHELXL/RES STYLE DATA LABEL
            ELSE IF (IABS (IGBL(8)) == 2) THEN
              IF (IAN > 0 .AND. NINT (FN(1)) <= IAN) THEN
C * SUBSTITUTE LEGAL LABEL
                NQ1 = LMT(NINT(FN(1)), 1)//'     '
              ELSE
C * SHELX/SFAC PROBLEM
                IPR(2) = 46
                RETURN
              END IF
C * HANDLE SPF STYLE DATA LABEL
            ELSE IF (IABS (IGBL(8)) == 1) THEN
              IF (KL == 3) THEN
                NQ1 = IFL(3)
              END IF
              CALL GEN020 (1, NQ1, 1, 2)
              IF (NQ1(1:2) == 'HN') NQ1 = 'H'
              IF (NQ1(1:2) == 'HO') NQ1 = 'H'
              IF (ICHAR (NQ1(2:2)) >= 48 .AND.
     1            ICHAR (NQ1(2:2)) <= 57) THEN
                NQ1(2:) = '      '
              ELSE
                NQ1(3:) = '     '
              END IF
            ELSE
C * UNSUITABLE ATOM LABEL
              NQ0    = NQ1
              IPR(2) = 3
              RETURN
            END IF
C * CREATE ACCEPTABLE LABEL
            IF (NQ1(1:1) == ' ') THEN
              NQ1(1:1) = NQ1(2:2)
              NQ1(2:4) = '999'
            ELSE IF (NQ1(2:2) == ' ') THEN
              NQ1(2:4) = '999'
            ELSE
              NQ1(3:4) = '99'
            END IF
            MODE = 99
            NCY  = NCY + 1
            IF (NCY < 2) THEN
              CYCLE
            ELSE
              WRITE (LU6, 99995) IFL(1), IFL(2),IFL(3)
              RETURN
            END IF
          END IF
          IF (MODE == 100) THEN
C * CHECK FOR PRE-OCCURRENCE OF THIS LABEL
            DO K = 1, NAT
              IF (LABA(K) == INQNR) THEN
C * ALERT _070 - DUPLICATE LABEL
                CALL PLA236 (70, 0, 1.0, 1.0, NQ2, ' ')
C * LABEL PRE-OCCURRED, GENERATE NEW LABEL WITH #
                MODE = 99
                EXIT
              END IF
            END DO
          ELSE IF (MODE == 99) THEN
            EXIT
          END IF
          IF (MODE /= 99) EXIT
        END DO
C * HANDLE SPECIAL CASE OF SHELX INPUT STYLE (AS PRODUCED BY SHELX)
        IF (IABS (IGBL(8)) == 2) THEN
          IPR(32) = MAX (IPR(32), 1)
C * SKIP DENSITY
          IF (KN == 7) KN = 6
          IF (KN == 20) THEN
            DO K = 12, 20
              FN(9 + K) = FN(K)
              FN(K)     = 0.0
            END DO
            KN  = 11
            KNS = 9
          ELSE IF (KN == 10) THEN
            DO K = 7, 10
              FN(14 + K) = FN(K)
              FN(K)      = 0.0
            END DO
            KN  = 6
            KNS = 4
          ELSE
            KNS = 0
          END IF
C * COMPLETE WHEN NO(OR INCOMPLETE) POPULATION AND/OR U/UIJ GIVEN
          IF (KN /= 6  .AND. KN /= 11) THEN
            IPR(498) = IPR(498) + 1
            IF (KN == 4) FN(5) = 11.0
            FN(6) = PAR(30)
            KN    = 6
          END IF
          IENR = NINT (FN(1))
C * IMPLEMENT FREE-VARIABLE VALUES
          DO K = 2, KN
            YY = FN(K)
            IF (ABS (YY) > 5.0) THEN
              I  = NINT (ABS (YY) * 0.1)
              IF (I == 1) THEN
                RPI = 1.0
              ELSE
                RPI = RP(I)
              END IF
              SJ = SIGN (0.5, YY)
              IF (I /= 1 .AND. I > IPR(109)) THEN
C * FVAR ERROR
                IPR(2) = 9
                RETURN
              END IF
              YY = (YY - I * SJ * 20.0) * (RPI + SJ - 0.5)
            END IF
            FN(K - 1) = YY
          END DO
          KN = KN - 1
C * X, Y, Z, POP,U  - CASE
          IF (KN == 5) THEN
            FN(9)  = FN(5)
            FN(10) = 0.0
            KN     = 10
          ELSE
            IPR(32) = 2
C * X, Y, Z, POP, U11, U22, U33, U23, U13, U12 - CASE
            DO K = 1, 6
              FN(15 - K) = FN(11 - K)
            END DO
            CALL GEN074 (FN, 15, 20, 0.0)
            KN = 20
          END IF
          CALL GEN074 (FN, 5, 8, 0.0)
C * SKIP (DUMMY) ATOMS WITH POPULATION 0.0
          IF (FN(4) < 0.0001) THEN
            IPR(100) = IPR(100) + 1
            IPR(471) = IPR(471) + 1
            IPR(2)   = 0
            RETURN
          END IF
          IF (KNS > 0) THEN
            DO K = 1, 3
              FN(K + 4) = FN(20 + K)
            END DO
            IF (KNS == 4) THEN
              FN(10) = FN(24)
            ELSE
              DO K = 1, 6
                FN(14 + K) = FN(23 + K)
              END DO
            END IF
          END IF
        ELSE
          IF (KN == 5) KN = 3
C * COMPLETE WITH ZERO'S
          KNP1 = KN + 1
          CALL GEN074 (FN, KNP1, 9, 0.0)
          IF (KN == 6) THEN
C * SHIFT ESD'S
            DO K = 1, 4
              FN(9 - K) = FN(8 - K)
            END DO
            FN(4) = 0.0
          END IF
C * HANDLE ANGSTROM SCALING (DEFAULT 1.0)
          IF (IPR(23) /= 0) THEN
            ISU = 0
            DO K = 1, 3
              FN(K)     = FN(K)     * PAR(11)
              FN(K + 4) = FN(K + 4) * PAR(11)
              IF (FN(K + 4) > 0) ISU = 1
            END DO
          END IF
        END IF
C * HANDLE SHELXL/CIF ISSUE
        IF (FN(24) == 1 .AND. FN(8) == 0.0) THEN
          IF (FN(4) == 0.330) FN(4) = 0.33333
          IF (FN(4) == 0.670) FN(4) = 0.66667
        END IF
C * DO CELL PARAMETER CALCULATION BEFORE FIRST ATOM INSTRUCTION
        IF (IPR(23) == 0) CALL PLA100
C * APPLY CELL TRANSFORMATION
        CALL GEN002 (1, TM2, FN, SGY, XLNG)
        DO K = 1, 3
          DUMA(K) = 0.0
          FNK4    = FN(K + 4)
          IF (FNK4 > 0.0) IPR(72) = 1
          IF (FNK4 < 0.0) FNK4    = 0.0
          FN(K + 4) = FNK4**2
        END DO
        DO K = 1, 3
          IF (IPR(23) == 0) THEN
            DO L = 1, 3
              DUMA(K) = DUMA(K) + TM2(K, L)**2 * FN(L + 4)
            END DO
          ELSE
            DUMA(K) = FN(K + 4)
          END IF
        END DO
        DO K = 1, 3
C * ADD SHIFT VECTOR
          SGY(K)              = SGY(K) + SHFT(K)
          FN(K)               = SGY(K)
          FN(K + 4)           = SQRT (DUMA(K))
          SGY(K + 3)          = 0.0
          CON(NATP1, K + 2)   = FN(K)
          CON(NATP1, K + 5)   = DUMA(K)
          CON(NAT + 2, K + 2) = 0.0
          MULTX               = 0
        END DO
        IHYD = 0
C * TEST FOR HYDROGENS (H, D OR Hw)
        IF (IEN(NIEN + 1) == 1 .OR. IEN(NIEN + 1) == 33 .OR.
     1      IEN(NIEN + 1) == 113) THEN
          IHYD = 1
        END IF
C * SKIP THIS SECTION FOR ANGSTROM DATA (IPR(23) = 1)
        MULT = IPR(23)
        IF (MULT == 0) THEN
          SGY(10) = 0.0
          CALL SGSM (19, IDM, SGY, 0, LU6, IERR)
C * HANDLE MULTIPLICITY ARTIFACT (CIF/PDB..)
          IF (IGBL(8) == 3 .AND. IPR(23) == 0) THEN
            IF (SGY(10) /= 1.0 .AND. IPR(612) >= 0) THEN
              FN(4) = FN(4) * SGY(10)
              IF (FN(8) > 0.0) FN(8) = FN(8) * SGY(10)
            ELSE
C * CHECK FOR SU
              IF (IHYD == 0 .AND. IGBL(94) == 0) THEN
C * ALERT _161
C * ALERT _162
C * ALERT _163
              END IF
            END IF
          END IF
C * MARK (H)ATOMS IN GENERAL POSITIONS WITHOUT SU
          IF (IHYD == 0) THEN
            IF (SGY(10) == 1.0) THEN
              ISU = 1
              IF (FN(5) <= 0.0 .AND. FN(6) <= 0.0 .AND.
     1            FN(7) <= 0.0) ISU = 0
            ELSE
              ISU = 0
              IF (FN(5) > 0.0 .OR. FN(6) > 0.0 .OR. FN(7) > 0)
     1          ISU = 1
            END IF
          ELSE
            ISU = 0
            IF (FN(5) > 0.0 .OR. FN(6) > 0.0 .OR. FN(7) > 0)
     1        ISU = 1
          END IF
C * TAKE PART -N INTO ACCOUNT
          IF (IGBL(8) == 3 .AND. IPR(612) < 0) THEN
            IPR(696) = IPR(696) + 1
            MULT = 1
          ELSE
            IF (ABS(FN(4) / SGY(10) - 0.5) > 0.4998) THEN
C * LOOP OVER ALL SYMMETRY OPERATIONS
              DO J = 1, NSYM
                JSYM = J
                CALL SGSM (3, ICL, SGY, JSYM, LU7, IERR)
C * LOOP OVER CURRENT SET OF ACCEPTED ATOMS + TENTATIVE NEW ONE
                DO I = 1, NATP1
                  VERS = 0.0
                  DO K = 1, 3
                    DUMA(K) = CON(I, K + 2) - SGY(K + 6)
                    DO WHILE (DUMA(K) > 0.5)
                      SGY(K + 6) = SGY(K + 6) + 1.0
                      DUMA(K)    = DUMA(K)    - 1.0
                    END DO
                    DO WHILE (DUMA(K) <= - 0.5)
                      SGY(K + 6) = SGY(K + 6) - 1.0
                      DUMA(K)    = DUMA(K)    + 1.0
                    END DO
                  END DO
                  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))
C * CONSIDER/DELETE CLOSE CONTACT ATOM (Q-ATOMS ...)
                  IF (VERS < RGBL25) THEN
C * CONSIDER X-H
                    CALL GEN048 (-1, IFG(1, I), 7, IHAT)
                    IF (IHAT == 1 .OR. IHYD == 1) THEN
                      IF (VERS > PAR(22)) CYCLE
                    END IF
                    IF (NQ2(1:1) /= 'Q' .AND. VERS > PAR(22))
     1                CYCLE
                    IF (I /= NATP1) THEN
                      CALL PLA047 (LABA(I), NQ2, IENM, JDUM,
     1                  IPR(71), IGBL(55), 0, 0)
C * BUT DO NOT ELIMINATE EXPLICITLY DISORDERED ATOMS
                      IPR(100) = IPR(100) + 1
                      WRITE (LU6, 99999, IOSTAT = IOST)
     1                  NQ1(1:7), VERS, NQ2(1:7)
C * AVERAGE POSITIONS (FOR SAME ATOM TYPES)
                      IF (VERS < PAR(22)) THEN
                        IF (IEN(IENM1) == JDUM) THEN
                          DO K = 1, 3
                            FN(K) = (CON(I, K + 2) + SGY(K + 6)) / 2.0
                            CON(I, K + 2) = FN(K)
                          END DO
                          FN(4) = - 1.0
C * WRITE CORRECTION
                          WRITE (LU4) 11, CON(I, 2), (FN(K), K = 1, 8)
                        END IF
                        WRITE (LU6, 99998, IOSTAT = IOST)
     1                    NQ1(1:7), VERS, NQ2(1:7), (FN(K), K = 1, 3)
                      END IF
C * ALERT _310
                      CALL PLA236 (310, 3, VERS, VERS, NQ1, NQ2)
                      IPR(471) = IPR(471) + 1
                      IPR(107) = 1
                      IPR(2)   = 0
                      RETURN
                    ELSE
                      IF (MULT == 0 .OR. IABS (IGBL(8)) /= 2 .OR.
     1                               IABS (IGBL(8)) /= 3) THEN
                        MULTX = MULTX + 1
                        MULT  = MULT + 1
                        DO K = 1, 3
                          CON(NAT + 2, K + 2) = CON(NAT + 2, K + 2)
     1                                        + SGY(K + 6)
                        END DO
                      END IF
                    END IF
                  END IF
                END DO
              END DO
            ELSE
              MULT = NINT (1.0 / SGY(10))
            END IF
          END IF
        END IF
        IF (IGBL(8) == 3 .AND. FN(35) == 1.0 .AND. MULT /= 1) THEN
          FN(4) = FN(4) * MULT
          FN(8) = FN(8) * MULT
        END IF
        CALL PLA047 (INQNR, NQ2, MN, JDUM, 0, IGBL(55), 0, 0)
        DO K = 1, NP64
          IF (NQ2(K : K) == '#') THEN
            IF (IPR(759) == 1) THEN
              IPR(71)  = 0
              IPR(350) = 0
            END IF
            CALL PLA282 (1, IFL(IPR(473)), NQ2, LU6)
            EXIT
          END IF
        END DO
        IF (IPR(39) == 0) IPPR(1, 3) = NSYM
        IPR(39)       = IPR(39) + 1
        IPR(37)       = IPR(39)
        LABA(IPR(39)) = INQNR
C * SHELX(L)/RES
        IF (IABS (IGBL(8)) == 2) THEN
          CON(IPR(39), 8) = IENR
          CON(IPR(39), 9) = FN(4)
        END IF
        IF (IPR(37) == 1) THEN
C * CHECK FOR CIF-DATA
          IF (IABS (IGBL(8)) == 3) THEN
            IF (IGBL(94) == 0) THEN
              IF (CCIF(7)(1:11) /= CCIF(8)(1:11) .AND.
     1            IPR(319) * IPR(318) == 1) THEN
                IDM = CCIF(8)
C * ELIMINATE BLANKS
                CALL GEN047 (IDM, 1, 20)
                NQ2 = IDM(1:7)
                CALL GEN020 (-1, NQ2, 2, 7)
                IF (NQ2(1:1) == ' ') NQ2(1:1) = '?'
                J = INDEX (NQ2(2:7), 'r')
                IF (J /= 0) NQ2(J+1:J+1) = 'R'
                IF (J == 0 .OR. IPR(606) /= 8) THEN
                  IDM = CCIF(6)
                  CALL GEN047 (IDM, 1, 20)
C * ALERT _120
                  IF (IDM(1:1) /= '?') THEN
                    NQ3 = '  '//NQ2(1:7)
                    CALL PLA236 (120, 0, -999.0, 1.0, IDM(1:7), NQ3)
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
C * INIT FLAG ARRAY ENTRIES
        DO I = 1, 3
          IFG(I, IPR(39)) = 0
        END DO
        IF (IABS (IGBL(8)) == 3) THEN
C * 'd'
          IF (FN(21) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 1, 1)
C * 'c'
          IF (FN(22) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 2, 1)
C * 'dum'
          IF (FN(23) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 3, 1)
 
          IF (FN(22) == 1.0) THEN
C * ALERT _166
            IF ((FN(5) > 0.0 .OR. FN(6) > 0.0 .OR.
     1          FN(7) > 0.0) .AND. FN(30) /= 1.0 .AND.
     2          FN(26) /= 1.0) THEN
                  CALL PLA236 (166, 0, 1.0, 1.0, IFL(IPR(473)), ' ')
            END IF
          END IF
C * 'S'
          IF (FN(24) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 4, 1)
C * 'G'
          IF (FN(25) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 5, 1)
C * 'R'
          IF (FN(26) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 6, 1)
C * 'D'
          IF (FN(27) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 7, 1)
C * 'T'
          IF (FN(28) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 8, 1)
C * 'U'
          IF (FN(29) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 9, 1)
C * 'P'
          IF (FN(30) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 10, 1)
C * COUNT NON-H R-Status
          IF (IHYD == 0 .AND. FN(26) == 1.0) THEN
            IPR(164) = IPR(164) + 1
          END IF
C * DISORDER ASSEMBLY
C * 'A'
          IF (FN(31) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 11, 1)
C * 'B'
          IF (FN(32) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 12, 1)
C * 'S'
          IF (FN(33) == 1.0) CALL GEN048 (1, IFG(3, IPR(39)), 13, 1)
C * DISORDER GROUP
        END IF
C * SET SHELXL PART #
        IVL = IPR(612) + 16
        CALL GEN048 (5, IFG(3, IPR(39)), 14, IVL)
C * SET SPECIAL POSITION BIT (6)
        IF (MULT > 1) CALL GEN048 (1, IFG(1, IPR(39)), 6 , 1)
C * SET ATOM TYPE NUMBER REFERENCE
        CALL GEN048 (4, IFG(1, IPR(39)), 15, NIEN)
C * HANDLE EXPLICIT MOVE/FIX INSTRUCTION FOR THIS ATOM
        IF (IPR(165) > 0) THEN
          ITRNS    = IPR(165)
          IPR(165) = 0
        ELSE
          ITRNS    = IPR(95)
        END IF
        IATP(IPR(39)) = ITRNS
C * SET SHELXL POPULATION RESTRAINT
        CALL GEN048 (-1, IFG(3, IPR(39)), 10, IPOPRES)
C * REGISTER H-ATOM STATUS
        CALL GEN048 (1, IFG(1, IPR(39)), 7, IHYD)
C * TEST FOR ELEMENT TYPE  (METAL) - SET METAL BIT
        IF (IATPR(IEN(NIEN + 1)) > 0) THEN
          CALL GEN048 (1, IFG(1, IPR(39)), 19, 1)
C * REGISTER METAL CONTAINING COMPOUND
          IPR(155) = 1
C * RESET FROM ORGANIC DEFAULT BOND RADII TO METAL STRUCTURE RADII
          PAR(85)  = 2
          PAR(87)  = 1
        END IF
        NPOP    = IPR(65)
        POPPARX = FN(4) * MULT
C * CHECK POPULATION PARAMETER RANGE (FOR NON-CSD DATA)
        IF (IABS (IGBL(8)) == 3) THEN
C * ALERT _075 - IMPOSSIBLE POPULATION PARAMETER VALUE > 1.0
          IF (POPPARX > 1.001 .AND. IGBL(94) == 0)
     1        CALL PLA236 (75, 3, 1.0, POPPARX, IFL(IPR(473)), ' ')
C * ALERT _076
          IF (POPPARX < 1.0 .AND. MULT /= 1
     1        .AND. ABS (MULT * POPPARX - 1.0) < 0.01
     2        .AND. IPOPRES == 0) THEN
              CALL PLA236 (76, 3, 0.5, POPPARX, IFL(IPR(473)), ' ')
          END IF
        END IF
C * CHECK LABEL ORDER IN CIF
        IF (IGBL(8) == 3) THEN
          IF (MOD (JNQNR, 40) == 0) THEN
            N   = IEN(IENM1)
C * CHECK CARBON ORDER
            IF (N == 2) THEN
              IF (JNQNR > IATYC) THEN
                IATYC = JNQNR
              ELSE
                IPR(545) = IPR(545) + 1
                IF (IPR(545) == 1 .AND. IPR(105) == 0) THEN
C * ALERT _795
                  CALL PLA236 (795, 0, -999.0, 1.0, NQ1, ' ')
                END IF
              END IF
C * CHECK OXYGEN ORDER
            ELSE IF (N == 3) THEN
              IF (JNQNR > IATYO) THEN
                IATYO = JNQNR
              ELSE
                IPR(546) = IPR(546) + 1
                IF (IPR(546) == 1 .AND. IPR(105) == 0) THEN
C * ALERT _796
                  CALL PLA236 (796, 0, -999.0, 1.0, NQ1, ' ')
                END IF
              END IF
C * CHECK NITROGEN ORDER
            ELSE IF (N == 4) THEN
              IF (JNQNR > IATYN) THEN
                IATYN = JNQNR
              ELSE
                IPR(547) = IPR(547) + 1
                IF (IPR(547) == 1 .AND. IPR(5) == 0) THEN
C * ALERT _797
                  CALL PLA236 (797, 0, -999.0, 1.0, NQ1, ' ')
                END IF
              END IF
            END IF
          END IF
        END IF
C * HANDLE POPULATION > 1 FOR NON-CIF
        IF (IABS(IGBL(8)) == 3 .AND. IPR(23) == 0) THEN
          FN(4) = POPPARX
        ELSE
          FN(4) = MIN (1.0, POPPARX)
        END IF
        FN(8) = FN(8) * MULT
C * SET DEFAULT PP TO 1.0 AND ESD TO 0
        IF (IGBL(8) /= 3) THEN
          IF (FN(4) < PAR(12)) FN(4) = 1.0
        END IF
        IF (FN(8) < 0.0) FN(8) = 0.0
        IF (FN(4) < 0.5) JNQNR = JNQNR + 150 * 4000
        JR(IPR(39)) = JNQNR
        INTPOP      = NINT (FN(4) * 10000.0)
        IF (INTPOP == 5000) THEN
          IF (FN(4) > 0.5) INTPOP = 5001
          IF (FN(4) < 0.5) INTPOP = 4999
        END IF
        IPPR(NPOP + 1, 1) = INTPOP
        IPPR(NPOP + 1, 2) = NINT (FN(8) * 10000.0)
        IPPR(NPOP + 1, 3) = NSYM  / MULT
        FN(4)             = FN(4) / MULT
        FN(8)             = FN(8) / MULT
C * PROVISIONAL CALCULATION OF THE DENSITY
        IF (IHYD == 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)
C * RESET COORDINATES TO SPECIAL POSITION
        IF (MULTX > 1 .AND. INTPOP == 10000) THEN
          DO K = 1, 3
            CON(NAT + 1, K + 2) = CON(NAT + 2, K + 2) / MULTX
            FN(K) = CON(NAT + 1, K + 2)
          END DO
        END IF
        MULT = NSYM / MULT
        IF (MOD (IPPR(NPOP + 1, 1), 10000) /= 0) THEN
          IPR(44) = 1
          IF (IHYD == 0) IPR(43) = 1
        END IF
C * SET POPULATION PARAMETERS
        DO I = 1, NPOP
          IF (IPPR(I, 3) == IPPR(NPOP + 1, 3) .AND.
     1        IPPR(I, 1) == IPPR(NPOP + 1, 1)) THEN
            IPOP = I - 1
            GO TO 50
          END IF
        END DO
        IPOP = NPOP
        IF (IPOP > MP7) THEN
C * POPULATION PARAMETER OVERFLOW
          IPR(92) = IPR(92) + 1
          IPR(2) = 10
          RETURN
        ELSE
          IPR(65) = IPR(65) + 1
        END IF
C * SET POPULATION NUMBER
   50   CALL GEN048 (8, IFG(2, IPR(39)), 1, IPOP)
C * SET ISU (0/1) - I.E. STANDARD UNCERTAINTY
        CALL GEN048 (1,  IFG(2, IPR(39)), 10, ISU)
        IF (FN(8) > 0.0)
     1    CALL GEN048 (1, IFG(2, IPR(39)), 29, 1)
        CALL GEN048 (-1, IFG(1, IPR(39)), 7, JHAT)
        IF (JHAT == 1) IPR(564) = IPR(564) + ISU
C * SET LABEL ON
        CALL GEN048 (1, IFG(2, IPR(39)), 11, 1)
C * COUNT # ATOMS WITH SU
        IF (FN(5) + FN(6) + FN(7) > 0.0001) IPR(745) = IPR(745) + 1
        WRITE (LU4) 1, INQNR, (FN(K), K = 1, 8)
C * HANDLE MULTIPLICATIVE UEQ TRANSFER TO U-HATOMS (SHELXL)
        IF (IABS (IGBL(8)) == 2) THEN
          IF (FN(9) < 0.0) THEN
            FN(9) = - FN(9) * PAR(61)
          ELSE
            IF (IHYD == 0) PAR(61) = FN(9)
          END IF
        END IF
        IF (KN == 10) WRITE (LU4) 4, INQNR, (FN(K), K = 9, 16)
        IF (KN == 20) THEN
C * SET ANISO-FLAG
          CALL GEN048 (1, IFG(1, IPR(39)), 4, 1)
          CALL GEN144 (1, FN(9), PAR(135))
C * LOAD U-MATRIX(6 TO 9 COMPONENTS)
          CALL GEN025 (DUMV, FN(9), -1)
C * CALCULATE TM2 * UIJ * TR(TM2)
          CALL GEN001 (1, TM2, DUMV, UIJ)
C * EXTRACT FROM TRANSFORMED U-MATRIX (9 TO 6 COMPONENTS)
          CALL GEN025 (UIJ, FN(9), 1)
          CALL GEN144 (-1, FN(9), PAR(113))
C * SAVE UEQ FOR SHELXL H-ATOMS WITH ASSOCIATED NEGATIVE U'S
          IF (IABS(IGBL(8)) == 2 .AND. IHYD == 0) THEN
            CALL GEN025 (UIJ, FN(9), -1)
C * UIJ - MAIN AXES & VALUES & UEQ
            CALL GEN114 (PAR, OR, UIJ, UIJC, DUMA, DUMV, PAR(61))
          END IF
C * WRITE UIJ AND SUIJ
          WRITE (LU4) 2, INQNR, (FN(K), K =  9, 16)
          WRITE (LU4) 3, INQNR, (FN(K), K = 15, 22)
        END IF
      ELSE
        IPR(2) = 1
      END IF
      RETURN
99999 FORMAT (':: ATOM ', A, ' DELETED from INPUT STREAM, ',
     1          F5.2, ' Ang. From ', A)
99998 FORMAT (':: ATOM ', A, ' at', F5.2, ' Ang. from ', A,
     1        ' - New Av Pos:', 3F8.4)
99997 FORMAT ('_', I1)
99996 FORMAT ('_', I2)
99995 FORMAT (':: Label Problem in PLA022', 2X, 3A)
      END SUBROUTINE PLA022
 
      SUBROUTINE PLA023 (MBRAV)
C * LOAD AND EXPAND DISCRETE ATOM COORDINATE SET TO PRIMITIVE TRICLINIC
C * (OPTIONALLY (i.e. NBRAV = 0; EXCL. BRAVAIS LATTICE CENTERING)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: MN
      INTEGER :: IAT
      INTEGER :: KAT
      INTEGER :: ICT
      INTEGER :: IBV
      INTEGER :: NAT
      INTEGER :: NO1
      INTEGER :: IVAL
      INTEGER :: NUEQ
      INTEGER :: NPDS
      INTEGER :: IENR
      INTEGER :: INQNR
      INTEGER :: NSYMR
      INTEGER :: NSYMI
      INTEGER :: NSYML
      INTEGER :: MBRAV
C * GET NUMBER OF UNIQUE ATOMS
      NAT   = IPR(37)
C * GET NUMBER OF SYMM. OPER. EXCLUDING INVERSION & BRAVAIS CENTERING
      NSYMR = IPR(255)
C * GET DATA ON INVERSION CENTER
      NSYMI = IPR(257)
C * GET DATA ON LATTICE CENTERING
      IF (MBRAV /= 0) THEN
        IBV = IPR(256)
      ELSE
        IBV = 1
      END IF
      NSYML = NSYMR * NSYMI * IBV
C * CHECK FOR ARRAY OVERFLOW
      IF (NAT * NSYML > NP1) THEN
        WRITE (LU6, 99997, IOSTAT = IOST) NP1
        IPR(589) = -1
        RETURN
      END IF
      CALL GEN021 (UKL, 0.0)
C * GET ATOM PARAMETERS FROM (SAVE-)FILE LU4
      NUEQ = 0
      NPDS = 0
      CALL GEN108 (LU4, 0)
      DO
        READ (LU4, IOSTAT = IOST) ICT, INQNR, (FN(K), K = 1, 8)
        IF (IOST /= 0 .OR. ICT == 6) EXIT
        DO I = 1, NAT
          IF (LABA(I) == INQNR) THEN
            K = I
            SELECT CASE (ICT)
C * LOAD COORDINATES AND POPULATION
              CASE (1)
                CALL GEN048 (-1, IFG(1, K), 30, IVAL)
                IF (IVAL == 1) THEN
                  FN(4) = 0.0
                  CALL PLA047 (INQNR, NQ1, MN, IENR, 1, IGBL(55), 0, 0)
                  WRITE (LU6, 99996, IOSTAT = IOST) NQ1
                  WRITE (LU7, 99996, IOSTAT = IOST) NQ1
                END IF
                DO J = 1, 4
                  XXO(K, J) = FN(J)
                END DO
C * LOCATE AND LOAD SCATTERING FACTOR DATA FOR THIS ATOM
                CALL GEN048 (-4, IFG(1, K), 15, NO1)
C * TEST FOR XRAY + SYNCHROTRON
                M = IEN (NO1 + 1)
C * CHECK FOR INTERNAL/EXTERNALLY PROVIDED SCATTERING FACTORS
                IF (IPR(762) == 0) THEN
C * LOAD INTERNALLLY STORED NEUTRAL XRAY SCATTERING FACTORS
                  IF (IABS (IPR(493)) < 7) THEN
                    M = (M - 1) * 19
                    DO J = 1, 9
                      CON(K, J) = SFAC(M + J)
                    END DO
C * LOAD INTERNALLY STORED NEUTRON SCATTERING LENGTH
                  ELSE IF (IABS (IPR(493)) == 7) THEN
                    DO J = 1, 8
                      CON(K, J) = 0.0
                    END DO
                    CON(K, 9) = RNSCL(M)
                  ELSE IF (IABS (IPR(493)) == 8) THEN
                    M = (M - 1) * 8
                    DO J = 1, 8
                      CON(K, J) = PENG(M + J)
                    END DO
                    CON(K, 9) = 0.0
                  END IF
                ELSE
C * SUBSTITUTE CIF PROVIDED SCATTERING FACTORS
                  IF (IGBL(8) == -3) THEN
                    N = 0
                    DO J = 1, IPR(761)
                      IF (DISPTYPE(J) == LMT(NO1 + 1, 1)) THEN
                        N = J
                        EXIT
                      END IF
                    END DO
                    DO J = 1, 9
                      IF (N > 0) THEN
                        CON(K, J) = CIFSF(N, J)
                      ELSE
                        CON(K, J) = 0.0
                      END IF
                    END DO
                  END IF
                END IF
C * STORE REFERENCE TO F' AND F"
                IATP(K) = NO1 + 1
C * LOAD UIJ OR UEQ
              CASE (2)
                DO J = 1, 6
                  XSD(K, J) = FN(J)
                END DO
C * LOAD ISOTROPIC U (ADD 100.0 TO MARK AS UISO)
              CASE (4)
                XSD(K, 1) = FN(1) + 100.0
            END SELECT
            EXIT
          END IF
        END DO
      END DO
C * EXPAND BY SYMMETRY TO UNIT CELL FILL (EXCLUDING BRAVAIS CENTERING)
C * TEST FOR NEWSYM MODE (=> SET TO ISOTROPIC VALUE)
      IF (IPR(210) == -2) THEN
        DO K = 1, NAT
          XSD(K, 1) = PAR(247) + 100.0
          CALL GEN048 (1, IFG(1, K), 4, 0)
        END DO
      END IF
      KAT = NAT
      IF (NSYML > 1) THEN
        DO L = 2, NSYML
          DO IAT = 1, NAT
            CALL GEN048 (-1, IFG(1, IAT), 4, IVAL)
C * TRANSFORM COORDINATES
            DO M = 1, 3
              SGY(M)     = XXO(IAT, M)
              SGY(M + 3) = 0.0
            END DO
            CALL SGSM (3, ICL, SGY, L, LU7, IERR)
            KAT = KAT + 1
            DO M = 1, 3
              XXO(KAT, M) = SGY(M + 6)
            END DO
C * COPY LABEL, POPULATION, FLAGS & SCATTERING FACTORS.
            LABA(KAT)   = LABA(IAT)
            XXO(KAT, 4) = XXO(IAT, 4)
            DO M = 1, 3
              IFG(M, KAT) = IFG(M, IAT)
            END DO
            DO M = 1, 9
              CON(KAT, M) = CON(IAT, M)
            END DO
            IATP(KAT) = IATP(IAT)
C * TRANSFORM UIJ
            IF (IVAL == 1) THEN
              CALL SGSM (6, ICL, SGY, L, LU7, IERR)
              DO M = 1, 9
                J = MOD (M - 1, 3) + 1
                K = ((M - 1) / 3)  + 1
                RIK(K, J) = SGY(M)
              END DO
              DO J = 1, 6
                DUMA(J) = XSD(IAT, J)
              END DO
              CALL GEN025 (UKL, DUMA, -1)
              CALL GEN001 (1, RIK, UKL, UIJ)
              CALL GEN025 (UIJ, DUMA, 1)
              DO J = 1, 6
                XSD(KAT, J) = DUMA(J)
              END DO
            ELSE
              XSD(KAT, 1) = XSD(IAT, 1)
            END IF
          END DO
        END DO
      END IF
      IF (NUEQ > 0) WRITE (LU6, 99999, IOSTAT = IOST) NUEQ
      IF (NPDS > 0) WRITE (LU6, 99998, IOSTAT = IOST) NPDS
C * SAVE NATO
      IPR(589) = KAT
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 PLA023
 
      SUBROUTINE PLA024
C * ANALYSES OF AN. TEMP. AND OUTPUT OF CONNECTED SET
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: N
      INTEGER          :: K0
      INTEGER          :: K1
      INTEGER          :: JM
      INTEGER          :: NSU
      INTEGER          :: NAT
      INTEGER          :: MT1
      INTEGER          :: MT2
      INTEGER          :: MT3
      INTEGER          :: MR1
      INTEGER          :: ICT
      INTEGER          :: MNM
      INTEGER          :: LBB
      INTEGER          :: LBC
      INTEGER          :: LBD
      INTEGER          :: IHAT
      INTEGER          :: IENM
      INTEGER          :: NATB
      INTEGER          :: NANG
      INTEGER          :: JDUM
      INTEGER          :: IVAL
      INTEGER          :: ILMP
      INTEGER          :: ILABA
      INTEGER          :: ISPEC
      INTEGER          :: INQNR
      INTEGER          :: JNQNR
      REAL             :: T1
      REAL             :: T2
      REAL             :: DUM1
      REAL             :: DUM2
      REAL             :: DUM3
      REAL             :: YUNK
      CHARACTER(len=1) :: NOTE1
C * GET NUMBER OF INPUT ATOMS
      NAT  = IPR(37)
C * GET TOTAL NUMBER OF ATOMS
      NATB = IPR(39)
C * GET ATOM CHARACTERISTICS (HYBRIDYSATION ETC.)
      DO I = 1, NATB
        CALL PLA099 (1, I, NANG, DUM1, DUM2, DUM3, NOTE1)
      END DO
C * SAVE CURRENT CONTENTS OF XXO, XSD, CON TEMPORARILY TO VOID ARRAY
      CALL PLA269 (1, NATB)
C * VOID - SCRATCH LAYOUT FOR TEMPORARY STORAGE OF DATA LISTED BELOW
C * 1 ==> IPR(297)  = XXO, XSD, CON, XSD(4:6)=LABEL POS SAVE AREA
      IPR(297) = NP1 * NP71
C * IPR(297) + 1 ==> IPR(298) = ADP
C * BONDS FROM IPR(298)
      IPR(298) = IPR(297) + NP1 * 21
C * WRITE TERMINATOR TO LU4 AND REWIND
      WRITE (LU4) 6, (FN(K), K = 1, 9)
      CALL GEN108 (LU4, 0)
C * ZERO ARRAYS
      CALL GEN074 (DATC, 1, NAT, 0.0)
      CALL GEN074 (UIJC, 1, 9, 0.0)
C * GET COORDINATES, (AN)ISOTROPIC DISPLACEMENT PARAMETERS ETC. FROM LU4
      DO
        READ (LU4) ICT, INQNR, (FN(K), K = 1, 8)
        IF (ICT == 6) EXIT
        DO I = 1, NAT
          IF (LABA(I) == INQNR) THEN
C * ATOM RECORD - COORDINATE AND SOF (11 = UPDATE)
            IF (MOD (ICT, 10) == 1) THEN
              IF (FN(4) > 0.0) THEN
                JM = 4
              ELSE
                JM = 3
              END IF
              DO J = 1, JM
                CON(I, J) = FN(J)
                YUNK      = FN(J + 4)
                IF (YUNK < 0.0) YUNK = 0.0
                CON(I, J + 4) = YUNK
              END DO
              IF (ICT == 1) THEN
                ANIS(I, 1) = 0.0
                SUAN(I, 1) = 0.0
              END IF
C * UIJ - RECORD
            ELSE IF (ICT == 2) THEN
              DO J = 1, 6
                ANIS(I, J) = FN(J)
                SUAN(I, J) = 0.0
              END DO
              CALL GEN048 (1, IFG(1, I), 4, 1)
C * SUIJ - RECORD
            ELSE IF (ICT == 3) THEN
              NSU = 0
              DO J = 1, 6
                IF (FN(J) > 0.0) THEN
                  SUAN(I, J) = FN(J)
                ELSE
                  NSU = NSU + 1
                END IF
              END DO
              IF (NSU > 0) THEN
                IF (IGBL(94) == 0 .AND. ABS (IGBL(8)) == 3) THEN
                  CALL GEN048 (-1, IFG(1, I), 6, ISPEC)
                  IF (ISPEC == 0) THEN
                    ILABA = - LABA(I)
                    CALL PLA047 (ILABA, NQ1, MNM, JDUM, IPR(71),
     1                IGBL(55), 0, 0)
C * ALERT _218
                    CALL PLA236 (218, 0, 1.0, FLOAT (NSU), NQ1, ' ')
                  END IF
                END IF
              END IF
C * IFU - RECORD
            ELSE IF (ICT == 4) THEN
              ANIS(I, 1) = FN(1)
              DATC(I)    = FN(1)
              IF (FN(2) <= 0.0) FN(2) = 0.0
              SUAN(I, 1) = FN(2)
C * MOVE - RECORD
            ELSE
              N = NINT (FN(1))
              CALL PLA025 (I, N)
              CYCLE
            END IF
            CYCLE
          END IF
        END DO
      END DO
C * END - COMPLETE WITH SYMMETRY EXPANDED ATOMS
      DO I = NAT + 1, NATB
C * GET SYMMETRY OPERATION
        ILABA = - LABA(I)
        CALL PLA047 (ILABA, NQ1, MNM, JDUM, IPR(71), 1, 0, 0)
        CALL GEN098 (MOL(MNM), PAR(42), N, MT1, MT2, MT3, MR1)
        FN(2) = MT1
        FN(3) = MT2
        FN(4) = MT3
C * GET SERIAL NUMBER OF NQ1 IN PRIMARY ATOM LIST AND RETURN RESULT IN J
        CALL PLA046 (2, NQ1, IENM, LBB, LBC, LBD, ILMP, JNQNR, J)
        IF (J < 0) THEN
          WRITE (LU6, 99999, IOSTAT = IOST) J, NQ1
          CALL PLA004 (0)
          EXIT
        ELSE
          DO K = 1, 9
            CON(I, K) = CON(J, K)
          END DO
          DO K = 1, 6
            ANIS(I, K) = ANIS(J, K)
            SUAN(I, K) = SUAN(J, K)
          END DO
          CALL GEN048 (-1, IFG(1, J), 4, IVAL)
          CALL GEN048 ( 1, IFG(1, I), 4, IVAL)
C * MOVE
          CALL PLA025 (I, N)
        END IF
      END DO
C * GENERATE DATA IN FORMAT SUITABLE FOR ADP (ORTEP-LOOK ALIKE)
C * ? + 100 NEEDED FOR 'DEFINE INSTRUCTION
      DO I = 1, NATB + 100
C * TEST FOR H-ATOM
        CALL GEN048 (-1, IFG(1, I), 7, IHAT)
C * TEST FOR ISO/ANISOTROPIC
        CALL GEN048 (-1, IFG(1, I), 4, IVAL)
        IF (I <= NATB) THEN
          IF (ANIS(I, 1) <= 0.0 .AND. IVAL == 0) THEN
            IF (IHAT == 0) THEN
              ANIS(I, 1) = PAR(30)
              IPR(171)  = IPR(171) + 1
            ELSE
              ANIS(I, 1) = PAR(30)
              IPR(172)  = IPR(172) + 1
            END IF
          END IF
          IF (IVAL /= 0) THEN
            DO K = 1, 6
              DUMA(K) = ANIS(I, K)
            END DO
            CALL GEN025 (UIJ, DUMA, -1)
          ELSE
            UIJ(1, 1) = ANIS(I, 1)
          END IF
C * CONVERT TEMP FACTOR COEFFICIENTS TO STANDARD TYPE B(I, J)
C * TEST FOR ISO/ANISOTROPIC
        ELSE
          IVAL      = 0
          IHAT      = 0
          UIJ(1, 1) = - 0.1
        END IF
C * ISOTROPIC CASE
        IF (IVAL == 0) THEN
          T1 = SQRT (MAX (0.0, UIJ(1, 1)))
          IF (IPR(32) == 0 .OR. T1 <= 0 .OR. IHAT == 1) THEN
            IF (IHAT == 1) THEN
              IF (IPR(603) == 0) T1 = PAR(265)
            ELSE
              T1 = PAR(266)
            END IF
          END IF
C * DUMMY SPHERE AND REFERENCE VECTORS FOR SPHERE
          DO J = 1, 3
            DUMA(J) = T1
            DO K = 1, 3
              DAM(J, K) = ROR(J, K)
              IF (J == K) THEN
                UIJC(J, K) = T1
              ELSE
                UIJC(J, K) = 0.0
              END IF
            END DO
          END DO
        ELSE
C * UIJ - Main Axes & VALUES & UEQ
          CALL GEN114 (PAR, OR, UIJ, UIJC, DUMA, PAT, T1)
C * MAKE EIGENVECTORS 1 ANGSTROM LONG
          CALL GEN019 (AA, BB, PAT(1, 1), PAT(1, 3), DAM(1, 1), -1)
C * SQRT EIGENVALUE = RMS DISPLACEMENT
          DO J = 1, 3
            T2      = DUMA(J)
            DUMA(J) = SIGN (SQRT (ABS(T2)), T2)
          END DO
        END IF
C * SAVE MAIN-AXES, MAIN-COMPONENTS AND ORTHOGONALIZED UIJ
        DO 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)
        END DO
        DO J = 1, 3
          VOID(IPR(297) + I * 21 + J - 12) = DUMA(J)
        END DO
      END DO
C * TEST FOR NO-PLOTTING, ORTEP or PLUTON
      IF (IPR(14) == 0 .OR. IPR(14) == 4 .OR.
     1    IPR(14) == 6) THEN
C * LIST DISPLACEMENT PARAMETERS (NOT FOR RS-CIP)
        IF (IPR(777) == 0) CALL PLA026
        IF (IPR(504) == 0 .AND. IGBL(22) /= -1) THEN
C * DO TLS-ANALYSIS (NOT IN PLUTON OR ORTEP MODES) -  ORGANIC ONLY
          IF (IPR(14) /= 6 .AND. IPR(14) /= 4 .AND.
     1      IGBL(97) == 1) THEN
            CALL PLA027
          ELSE
            IPR(5) = 0
          END IF
        END IF
      END IF
C * RESTORE SAVED ARRAYS FROM TEMPORARY STORAGE IN VOID SCRATCH
      CALL PLA269 (-1, NATB)
C * SET PLA024 ROUTINE DONE
      IPR(85) = 1
      RETURN
99999 FORMAT (//, 'Label Problem #', I3, ' for ', A)
      END SUBROUTINE PLA024
 
      SUBROUTINE PLA025 (I, N)
C * SUPPORT PLA024
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: N
      INTEGER           :: LU
      INTEGER           :: K0
      INTEGER           :: K1
      INTEGER           :: IVAL
      CHARACTER(len=80) :: LINE
      LU = 0
      DO J = 1, 3
        SGY(J)     = CON(I, J)
        SGY(J + 3) = FN(J + 1)
      END DO
      CALL SGSM (3, LINE, SGY, N, LU, IERR)
      DO J = 1, 3
        CON(I, J)  = SGY(J + 6)
        SGY(J)     = CON(I, J + 4)
        SGY(J + 3) = 0.0
      END DO
      CALL SGSM (3, LINE, SGY, -N, LU, IERR)
      DO J = 1, 3
        CON(I, J + 4) = SGY(J + 6)
      END DO
C * TEST FOR (ISO/ANISO)TROPIC
      CALL GEN048 (-1, IFG(1, I), 4, IVAL)
      IF (IVAL > 0) THEN
        IF (N > 0) THEN
C * GET TRANSFORMATION MATRIX
          CALL SGSM (6, LINE, SGY, N, LU, IERR)
          DO K = 1, 9
            K0 = MOD (K - 1, 3) + 1
            K1 = ((K - 1) / 3)  + 1
            RIK(K1, K0) = SGY(K)
          END DO
          DO K = 1, 6
            DUMA(K) = ANIS(I, K)
          END DO
          CALL GEN025 (UKL, DUMA, -1)
          CALL GEN001 (1, RIK, UKL, UIJ)
          CALL GEN025 (UIJ, DUMA, 1)
          DO K = 1, 6
            ANIS(I, K) = DUMA(K)
          END DO
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA025
 
      SUBROUTINE PLA026
C * LISTING OF (AN)ISOTROPIC THERMAL PARAMETERS + SHELX
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE spgrdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: K
      INTEGER             :: L
      INTEGER             :: N
      INTEGER             :: JM
      INTEGER             :: NM
      INTEGER             :: NB
      INTEGER             :: NE
      INTEGER             :: NLN
      INTEGER             :: NAT
      INTEGER             :: NOH
      INTEGER             :: NCH
      INTEGER             :: KCG
      INTEGER             :: ISW
      INTEGER             :: IHA
      INTEGER             :: IFT
      INTEGER             :: IHYB
      INTEGER             :: IMET
      INTEGER             :: IVAL
      INTEGER             :: IZET
      INTEGER             :: JUNK
      INTEGER             :: NCOD
      INTEGER             :: NDEC
      INTEGER             :: NIEN
      INTEGER             :: NRES
      INTEGER             :: NATB
      INTEGER             :: NATC
      INTEGER             :: NADD
      INTEGER             :: NFVR
      INTEGER             :: NDEV
      INTEGER             :: NHAT
      INTEGER             :: NRAT
      INTEGER             :: JHAT
      INTEGER             :: JDUM
      INTEGER             :: IDUM
      INTEGER             :: IATF
      INTEGER             :: IAN0
      INTEGER             :: IDISD
      INTEGER             :: IDUM1
      INTEGER             :: IDUM2
      INTEGER             :: IRESI
      INTEGER             :: JPART
      INTEGER             :: ISCFT
      INTEGER             :: JSCFT
      INTEGER             :: NRESD
      INTEGER             :: ISUEQ
      INTEGER             :: IPART
      INTEGER             :: IAFIX
      INTEGER             :: IALIAS
      INTEGER             :: IPARTO
      INTEGER             :: IPARTN
      INTEGER             :: IPARTI
      INTEGER             :: IPARTJ
      INTEGER             :: IPR493
      INTEGER             :: GEN135
      REAL                :: XI
      REAL                :: YI
      REAL                :: ZI
      REAL                :: XJ
      REAL                :: YJ
      REAL                :: ZJ
      REAL                :: D13
      REAL                :: D21
      REAL                :: D32
      REAL                :: FAC
      REAL                :: FDC
      REAL                :: YNK
      REAL                :: UEQ
      REAL                :: RMU
      REAL                :: DIST
      REAL                :: SUEQ
      REAL                :: XLNG
      REAL                :: XDUM
      REAL                :: YUNK
      REAL                :: POPL
      REAL                :: SQD13
      REAL                :: RATIO
      REAL                :: GEN009
      REAL                :: WAVELTH
      REAL                :: DISTMAX
      CHARACTER(len=1)    :: LSB
      CHARACTER(len=1)    :: RSB
      CHARACTER(len=1)    :: ND13
      CHARACTER(len=1)    :: DISOR
      CHARACTER(len=2)    :: RESI
      CHARACTER(len=2)    :: RESI0
      CHARACTER(len=9)    :: STRA
      CHARACTER(len=NP64) :: KDUM
      CHARACTER(len=136)  :: FORMA
      CHARACTER(len=47)   :: FORMB
      CHARACTER(len=57)   :: FORMC
C * SETUP PRINT FORMATS
      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,F6.2,A)'
      FORMB(1:27)    = '(I4,1X, A ,F8.4,''('',I2,'')'','
      FORMB(28:47)   = '65X,F9.4,''('',I2,'')'')'
      FORMC(1:37)    = '(''HKLF 4 1'',F7.4,F7.4,F7.4,F7.4,F7.4,'
      FORMC(38:57)   = 'F7.4,F7.4,F7.4,F7.4)'
C * INIT
      PAGET = 'ADP-Anal'
      RESI  = '  '
      RESI0 = '  '
      XI    = 0.0
      YI    = 0.0
      ZI    = 0.0
C * ADAPT HKLF 4 FORMAT TO FIT 79 CHARACTER RECORD
      DO I = 1, 9
        N = I * 5 + 9
        IF (PAR(230 + I) < 0.0) FORMC(N:N) = '8'
      END DO
C * SETUP FOR TRACKING AVERAGE U/UEQ VALUES
      DO I = 1, IAN + 1
        BOK(I, 1) = 0.0
        BOK(I, 2) = 9999.0
        BOK(I, 3) = 0.0
        KBO(I, 1) = 0
      END DO
C * HANDLE WAVELENGTH
      IPR493  = IABS (IPR(493))
C * DEFAULT MoKa
      IF (IPR493 == 0) THEN
        IPR493  = 3
        WAVELTH = STWL(6 - IPR493)
        WRITE (LU6, 99958, IOSTAT = IOST)
      ELSE
        WAVELTH = PAR(17)
      END IF
C * GET NUMBER OF UNIQUE (INPUT) ATOMS
      NAT  = IPR(37)
C * GET TOTAL NUMBER OF ATOMS (SYMMETRY EXPANDED)
      NATB = IPR(39)
C * GET NUMBER OF RESIDUES
      NRES = IPR(75)
C * (0/1) FULL LU2
      IF (IPR(67) == 0) THEN
        NATC = NAT
      ELSE
        NATC = NATB
      END IF
C * TEST PARAMETER FILE OUTPUT TYPE
      IF (IGBL(31) == 0) THEN
        IGBL(31) = 3
C * OPEN UNIT #2
        CALL PLA292
      END IF
C * INITIALIZE # FVAR PARAMETERS
      IF (IGBL(31) < 0) IPR(109) = 1
C * PDB - FILE OUTPUT
      IF (IGBL(31) == 7) THEN
        WRITE (LU2, 99963, IOSTAT = IOST) JID(1:73),
     1    (PAR(100 + I), I = 1, 6), SPGRNM(4),
     2    ((ROR(I, J), J = 1, 3), 0.0, I = 1, 3)
      END IF
C * OUTPUT (LU2) TITL, CELL
      IF (IGBL(31) /= 0 .AND. IGBL(31) /= 2 .AND.
     1    IGBL(31) /= 4 .AND. IGBL(31) /= 7) THEN
        REWIND (UNIT = LU2, IOSTAT = IOST)
        WRITE (LU2, 99982, IOSTAT = IOST) JID(1:74)
C * OUTPUT (LU2) TRNS - ADDITIONAL SYMMETRY FOR IPR(209) > 0
        IF (IGBL(31) == 3 .AND.
     1     (IPR(209) > 0 .OR. IPR(504) > 0)) THEN
          WRITE (LU2, 99973, IOSTAT = IOST)
     1      ((ROTM2(I, J), J = 1, 3), I = 1, 3), (ORG(J), J = 1, 3)
C * RESET 'CLOSENESS' CRITERIUM (FROM ADDSYM)
          WRITE (LU2, 99960, IOSTAT = IOST) 0.7
          IF (IPR(261) > -999999) WRITE (LU2, 99998) IPR(261) - 273
          IF (IPR(502) == 2) WRITE (LU2, 99947)
        END IF
C * 'NORMALIZE' CELL FOR '.res'
        IF (IGBL(31) == -2) THEN
C * APPLY SYMMETRY CONSTRAINTS ON CELL DIMENSIONS
          CALL GEN066 (2, PAR(101), PAR(107), SPGRNM(1)(12:12),
     1      IPR(783))
        END IF
        IF (IPR(23) == 0) THEN
          WRITE (LU2, 99974, IOSTAT = IOST)
     1      WAVELTH, (PAR(100 + I), I = 1, 6)
        END IF
C * OUTPUT (LU2) CESD (OMEGA, SPF) OR ZERR FOR SHELXL
        IF (IPR(438) == 1 .OR. IGBL(31) == 3) THEN
          IF (IPR(23) == 0) THEN
            WRITE (LU2, 99979, IOSTAT = IOST) (PAR(106 + I), I = 1, 6)
          END IF
          IF (PAR(2) /= 0.4) WRITE (LU2, 99951, IOSTAT = IOST) PAR(2)
C * OUTPUT VOLUME (OMEGA)
          IF (IPR(438) == 1)
     1      WRITE (LU2, 99990, IOSTAT = IOST) PAR(98), PAR(21)
        ELSE IF (IGBL(31) == -2 .OR. IGBL(31) == -3) THEN
          IF (IPR(276) > 0) THEN
            IZET = IPR(276)
          ELSE IF (IPR(260) > 0) THEN
            IZET = IPR(260)
          ELSE
            IZET = 1
          END IF
          WRITE (LU2, 99971, IOSTAT = IOST)
     1      IZET, (PAR(106 + I), I = 1, 6)
        END IF
C * OUTPUT (LU2) SYMMETRY
C * EXPLICIT OUTPUT OF LATT/SYMM
        IF (IPR(256) == 0 .OR. IGBL(31) < 0) THEN
C * TEST FOR 'WRITE .res'
          IF (IGBL(31) < 0) THEN
C * LATT SHELX STYLE
            WRITE (LU2, 99975) IPR(242)
            ISW = 17
          ELSE
C * TEST FOR NON-ANGSTROM DATA
            IF (IPR(23) == 0) THEN
C * LATT SPF STYLE
              WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14),
     1          IPR(783)
            END IF
            ISW = 2
          END IF
          IF (IPR(23) == 0) THEN
            CALL SGSM (2, ICL, SGY, 0, LU6, IERR)
            DO I = 2, IPR(255)
              CALL SGSM (ISW, ICL, SGY, I, 0, IERR)
              WRITE (LU2, 99977) ICL(1:60)
            END DO
          END IF
        ELSE
          IF (IGBL(31) == 3 .AND. IPR(67) /= 0) THEN
            WRITE (LU2, 99989)
          ELSE
C * OUTPUT EITHER EXPLICIT SYMMETRY OR SPACEGROUP NAME (IF KNOWN)
            IF (SPGRNM(1)(1:3) == '   ' .AND. IPR(209) == 0
     1          .AND. IPR(504) == 0) THEN
              IF (IPR(23) == 0) THEN
                WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14)
                ISW = 2
                DO I = 2, IPR(255)
                  CALL SGSM (ISW, ICL, SGY, I, 0, IERR)
                  WRITE (LU2, 99977) ICL(1:60)
                END DO
              END IF
            ELSE
              IF (SPGRNM(2)(1:1) /= '?' .AND. SPGRNM(2)(1:1) /= ' '
     1            .AND. IGBL(31) == 3) THEN
                J   = 2
                LSB = '['
                RSB = ']'
              ELSE
                J   = 1
                LSB = ' '
                RSB = ' '
              END IF
              IF (INDEX (SPGRNM(J)(1:11), ':') /= 0) THEN
                WRITE (LU2, 99976) LSB, SPGRNM(J)(1:11),RSB
              ELSE
                IF (SPGRNM(J)(8:11) == '    ') THEN
                  I = ICHAR (' ')
                ELSE
                  I = ICHAR ('.')
                END IF
                WRITE (LU2, 99976)
     1               LSB, SPGRNM(J)(1:7), CHAR (I), SPGRNM(J)(8:11), RSB
              END IF
            END IF
          END IF
        END IF
C * COPY SCATTERING TYPES FOR SHELX.INS
        IF (IPR(504) == 2) THEN
          WRITE (LU2, 99994) (LMT(IENS(K), 1), K = 1, IAN)
        END IF
        IF ((IGBL(31) == 3 .OR. IGBL(3) < 0)
     1    .AND. IPR(310) > 0) WRITE (LU2, 99998) IPR(310) - 273
      END IF
C * OUTPUT (LU2) SHELXL - SFAC, UNIT, FVAR
      IF (IGBL(31) < 0) THEN
        IAN0 = 0
        NOH  = 1
        DO K = 1, IAN
          IF (LMT(K, 1) == ' H') NOH = 0
          IF (LMT(IENS(K), 1) /= 'Cg') THEN
            IAN0 = IAN0 + 1
            IENS(IAN0) = IENS(K)
          ELSE
            KCG = IENS(K)
          END IF
        END DO
        IF (IAN0 < IAN) IENS(IAN) = KCG
        NFVR = IPR(109)
C * OUTPUT SFAC IN C, H, ALPHABETIC ORDER (CU AG MO GA IN - RADIATION)
        IF (IPR(595) == 0) THEN
          DO K = 1, IAN0
            L = IEN(IENS(K))
C * XRAY SCATTERING + SYNCHROTRON
            IF (IPR493 < 7) THEN
              J   = (L - 1) * 19
              FAC = ANOM(IENS(K), 1)
              FDC = ANOM(IENS(K), 2)
              RMU = ANOM(IENS(K), 3)
              WRITE (LU2, 99981) LMT(IENS(K), 1),
     1          (SFAC(J + I), I = 1, 9), FAC, FDC, RMU, REL(L),
     2           SATWT(IENS(K))
              WRITE (LU6, 99981) LMT(IENS(K), 1),
     1          (SFAC(J + I), I = 1, 9), FAC, FDC, RMU, REL(L),
     2           SATWT(IENS(K))
            ELSE
C * NEUTRON SCATTERING
              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))
            END IF
          END DO
        ELSE
          IF (IPR493 == 7) WRITE (LU2, 99933)
C * FOR .res: INPUT ORDER
          IF (IGBL(8) /= 2) THEN
            WRITE (LU2, 99941) (LMT(IENS(K), 1), K = 1, IAN0)
C * INCLUDE DISP RECORDS FOR NON In,Ag,Mo,Ga,Cu WAVELENGTH
            IF (IABS (IPR(493)) == 6) THEN
              DO K = 1, IAN0
                WRITE (LU2, 99936)
     1            LMT(IENS(K), 1), (ANOM(IENS(K), L), L = 1, 3)
              END DO
            END IF
          ELSE
            WRITE (LU2, 99941) (LMT(K, 1), K = 1, IAN)
          END IF
        END IF
C * FOR .res: INPUT ORDER
        IF (IGBL(8) /= 2) THEN
          WRITE (LU2, 99980) (NINT (CONT(IENS(L), 2)), L = 1, IAN0)
        ELSE
          WRITE (LU2, 99980) (NINT (CONT(L, 2)), L = 1, IAN)
        END IF
        IF (IPR(310) > 0) WRITE (LU2, 99998) IPR(310) - 273
C * ADD REFINEMENT INSTRUCTIONS
        IF (IPR(261) > -999999 .AND. IPR(310) == -999999)
     1    WRITE (LU2, 99998) IPR(261) - 273
        IF (PAR(302) * PAR(303) * PAR(304) > 0.0)
     1    WRITE (LU2, 99932) PAR(304), PAR(303), PAR(302)
        WRITE (LU2, 99942)
        IF (NOH == 0) WRITE (LU2, 99949)
C * ADD TWIN/BASF FOR NON-CENTRO STRUCTURES
        IF (IPR(275) == 1) THEN
          IF (PAR(433) < 999999.0) THEN
            YUNK = PAR(433)
          ELSE
            YUNK = 0.0
          END IF
          WRITE (LU2, 99937) YUNK
        END IF
C * EXTI LINE
        IF (PAR(229) > 0.0 .AND. PAR(229) < 1.0)
     1    WRITE (LU2, 99935) PAR(229)
C * HANDLE WEIGHT PARAMETERS
        IF (PAR(493) < 0.0 .OR. PAR(494) < 0.0) THEN
          WRITE (LU2, 99939) 0.1
        ELSE
          WRITE (LU2, 99939) PAR(493), PAR(494)
        END IF
        WRITE (LU2, 99999) PAR(74), (RP(L), L = 2, NFVR)
      ELSE IF (IGBL(31) == 3 .AND. IPR(209) == 0) THEN
        WRITE (LU2, 99970)
      END IF
C * (NO)TEMP FACTOR
      IF (IPR(32) /= 0 .AND. IGBL(63) > 2) THEN
C * START ON NEW-PAGE WITH HEADER
         CALL PLA262 (-2)
         WRITE (LU7, 99984) CHAR(ICHAR('#'))
      END IF
C * LOOP OVER RESIDUE SPECIES
      DO N = 1, NRES
        CALL GEN074 (XPV, 1, 4, 0.0)
        DO I = 1, IAN + 1
          BOK(I, 5) = 9999.0
          BOK(I, 6) = 0.0
        END DO
        CALL GEN074 (DEV, 1, 6, 0.0)
        NDEV = 0
C * TEST FOR MAJOR RESIDUE(S) = 0, ANION/SOLVENT = 1
        NADD = 0
        IF (N > 1) THEN
          IF (RCONT(N) < RCONT(1)) NADD = 1
        END IF
        IF (IPR(32) /= 0) THEN
          NLN = 5
          IF (NRES > 1) NLN = NLN + 5
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (NLN)
            IF (NRES /= 1) WRITE (LU7, 99993) N
            WRITE (LU7, 99991)
          END IF
        END IF
        IF (IPR(438) == 1 .OR. IGBL(31) == 3) WRITE (LU2, 99992) N
        NRAT   = 0
        IPARTO = 0
        IATF   = 0
        DO I = 1, NATB
C * TEST RESIDUE NUMBER BITS
          CALL GEN048 (-6, IFG(1, I), 9, IRESI)
          IF (N == IRESI) THEN
            CALL GEN048 (-1, IFG(1, I), 7, NHAT)
C * REGISTER FIRST NON-H ATOM IN RESIDUE
            IF (NHAT == 0) THEN
              IF (IATF == 0) IATF = I
            END IF
            IF (IGBL(31) < 0) THEN
              IF (NHAT == 0) THEN
                XI = VOID((I - 1) * NP71 + 4)
                YI = VOID((I - 1) * NP71 + 5)
                ZI = VOID((I - 1) * NP71 + 6)
              ELSE
                CYCLE
              END IF
            END IF
C * METAL ?
            CALL GEN048 (-1, IFG(1, I), 19, IMET)
C * GET ATOM TYPE
            CALL GEN048 (-4, IFG(1, I), 15, NIEN)
            NIEN = NIEN + 1
            IF (IGBL(31) == 3 .AND. IPR(501) == 0) THEN
              IALIAS = 1
            ELSE
              IALIAS = IGBL(55)
            END IF
            CALL PLA036 (-I, 1, 1, IDISD, IDUM1, IDUM2, 0, IALIAS)
            CALL PLA036 (-I, 1, 2, IDISD, IDUM1, IDUM2, 0, IGBL(55))
            IF (NHAT == 0) THEN
              XPV(1 + NADD) = XPV(1 + NADD) + IDISD
              IF (IDISD < 10000)
     1          XPV(3 + NADD) = XPV(3 + NADD) + IDISD
            END IF
C * TEST ISO/ANISO BIT
            CALL GEN048 (-1, IFG(1, I), 4, IVAL)
            IF (IVAL > 0) THEN
              JM = 6
            ELSE
              JM = 1
              CALL GEN048 (-1, IFG(1, I), 7, IHA)
C * COUNT ISOTROPIC NON-H ATOMS (MAJOR - ANION/SOLVENT) (IPR(489)/IPR(490))
              IF (IHA == 0 .AND. I <= NAT .AND. IDISD > 5000)
     1          THEN
                IPR(489 + NADD) = IPR(489 + NADD) + 1
C * STORE LABELS OF ISOTROPIC NON-HYDROGEN ATOMS
                IF (IPR(489 + NADD) <= NP77 ) THEN
                  CALL PLA047 (LABA(I), KDUM, IDUM, JDUM, 0, IGBL(55),
     1            0, 1)
                  CISO(IPR(489 + NADD), NADD + 1) = KDUM(1:8)
                END IF
              END IF
            END IF
C * ROUND DISPLACEMENT PARAMETERS FOR OUTPUT
            DO J = 1, JM
              CALL GEN041 (ANIS(I, J), SUAN(I, J), ISDV(J), 5, NDEC,
     1                    IPR(68))
              ISDV(J) = MIN (99, ISDV(J))
              IF (ISDV(J) <= 0) SUAN(I, J) = -1.0
              IF (JM == 1) THEN
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
                FORMB(15:15) = CHAR (ICHAR ('0') + NDEC)
                FORMB(35:35) = CHAR (ICHAR ('0') + NDEC)
              ELSE
                IFT = -1 + J * 16
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
                FORMA(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
              END IF
            END DO
C * ROUND COORDINATES FOR OUTPUT
            DO 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) < 1.0 / 10 ** IPR(183))
     1           CON(I, K + 4) = -1.0
            END DO
c             IPDB = 1
              K = INDEX (NAMS(1, 2), '_')
              IF (K == 0) THEN
                RESI = '0 '
                NQ2  = NAMS(1, 2)(2:8)
              ELSE
                NQ2  = NAMS(1, 2)(2:K - 1)
                RESI = NAMS(1, 2)(K + 1:K + 2)
              END IF
C * PDB ANGSTROM COORDINATES
            IF (IGBL(31) == 7) THEN
              DO K = 1, 3
                V1(K) = CON(I, K)
              END DO
              CALL GEN002 (1, OR, V1, V3, XLNG)
              IF (NQ2(1:1) == CHAR (32)) THEN
                NB = 2
                NE = 5
              ELSE
                NB = 1
                NE = 4
              END IF
              WRITE (LU2, 99962) I, NQ2(NB:NE), 0, (V3(K), K = 1, 3),
     1                           1.0, 0.0, NQ2(1:2)
            END IF
            IF (I <= NATC) THEN
              IF (IGBL(31) < 0) THEN
C * TAKE CARE OF ELEMENT RESHUFLING
                DO L = 1, IAN0
                  IF (IENS(L) == NIEN) THEN
                    ISCFT = L
                    EXIT
                  END IF
                END DO
                POPL = 10.0 + CON(I, 4)
                SGY(10) = PAR(547) / MAX(PAR(101), PAR(102), PAR(103))
C * MAKE SURE OF PROPER COORDINATE CONSTRAINTS FOR SHELXL
                IF (CON(I, 4) < 0.99) THEN
                  DO K = 1, 3
                    SGY(K) = CON(I, K)
                  END DO
                  CALL SGSM (19, ICL, SGY, 0, LU6, IERR)
                  DO K = 1, 3
                    CON(I, K) = SGY(6 + K)
                  END DO
                END IF
C * CHECK OMEGA FILE STATUS AND TEST FOR SPF OUTPUT
              ELSE IF (IPR(438) == 1 .OR. IGBL(31) == 3) THEN
                DISOR = NAMS(1, 1)(1:1)
                IF (DISOR /= ' ') DISOR = 'X'
C * HANDLE SHELXL PART #
                CALL GEN048 (-5, IFG(3, I), 14, IPART)
                IPARTN = IPART - 16
                IF (IPARTN /= IPARTO) THEN
                  WRITE (LU2, 99934 ) IPARTN
                  IPARTO = IPARTN
                END IF
C * TEST FOR ANGSTROM DATA
C * ATOM LINE (ELD)
                  WRITE (LU2, 99987) NAMS(1, 2)(2:NP64), ELB(IEN(NIEN)),
     1              (CON(I, K), K = 1, 8)
              END IF
            END IF
C * ANISOTROPIC
            IF (JM > 1) THEN
C * RECOVER UIJ-MATRIX FROM 6 COMPONENTS
              DO K = 1, 6
                DUMA(K) = ANIS(I, K)
              END DO
              CALL GEN025 (UIJ, DUMA, -1)
C * UIJ - MAIN AXES & VALUES & UEQ
              CALL GEN114 (PAR, OR, UIJ, UIJC, DUMA, DUMV, UEQ)
              NRESD = 0
              SUEQ  = 0.0
              DO J = 1, 3
                IF (SUAN(I, J) > 0.0) THEN
                  NRESD = NRESD + 1
                  SUEQ = SUEQ + SUAN(I, J) ** 2
                END IF
              END DO
              IF (NRESD > 0) SUEQ = SQRT (SUEQ) / NRESD
              CALL GEN041 (UEQ, SUEQ, ISUEQ, 5, NDEC, IPR(68))
              ISUEQ = MIN (99, ISUEQ)
              IF (I <= NAT) THEN
                DO K = 1, 6
                  DEV(K) = DEV(K) + ANIS(I, K)
                END DO
                NDEV = NDEV + 1
                IF (IPR(85) == 0 .AND. DATC(I) > 0.0) THEN
                  YUNK = DATC(I) - UEQ
                  WRITE (NQ3, 99938) YUNK
C * ALERT _224
                  IF ((SUEQ <= 0.0 .AND. ABS (YUNK) > 0.001) .OR.
     1                (SUEQ >  0.0 .AND. ABS (YUNK) > SUEQ)) THEN
                    NQ4 = NAMS(1, 2)(2:10)
                    CALL GEN156 (NQ4)
                    CALL PLA236 (224, 3, ABS (YUNK), 1.0, NQ3, NQ4)
                  END IF
                END IF
              END IF
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
              FORMA(111:111) = CHAR (ICHAR ('0') + NDEC)
              IF (ISUEQ <= 0) SUEQ = -1
              IF (DUMA(1) < PAR(12)) THEN
                D13 = -1.0
                IF (DUMA(1) < 0) THEN
                  NQ3 = 'N.P.D. '
                ELSE
                  NQ3 = '2Dimens'
                END IF
              ELSE
                D13 = DUMA(3) / DUMA(1)
                D21 = DUMA(2) - DUMA(1)
                D32 = DUMA(3) - DUMA(2)
                IF (D32 < D21) THEN
                  NQ3 = 'oblate '
                ELSE
                  NQ3 = 'prolate'
                END IF
              END IF
              DATC(I) = UEQ
              IF (I <= NAT) THEN
C * GENERAL AVERAGE
                IF (NHAT == 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
                END IF
C * AVERAGE PER ATOM TYPE
                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 > 0.0) SQD13 = SQRT (D13)
C * NAMS(1,1) = ALIAS, NAMS(1,2) = ORIGINAL LABEL
                ND13     = ' '
                IF (D13 <= 0.0 .OR. SQD13 > 2.0) THEN
                  IF (D13 > 9.0 .OR. D13 < 0.0) THEN
                    WRITE (LU6, 99959)
     1              NAMS(1, 2), (DUMA(J), J = 1, 3), D13, NQ3
                    ND13     = '#'
                    IPR(135) = IPR(135) + 1
                  END IF
                  IF (D13 < 0) THEN
                    NCOD = 211 + NADD
C * ALERT _211 +
                    IF (IGBL(22) /= -1) CALL PLA236 (
     1                     NCOD, 1, 1.0, 1.0, NAMS(1, 2)(2:10), ' ')
                  ELSE
                    IF (NAMS(1, 1)(1:1) == '*') THEN
                      NCOD = 215 + NADD
                      IF (IGBL(22) /= -1) CALL PLA236 (
     1                  NCOD, 1, SQD13, SQD13, NAMS(1, 1)(2:10), ' ')
                    ELSE
C * ALERT _213 - Oblate/Prolate UIJ
                      IF (NHAT == 0) THEN
                        NCOD = 213 + NADD
                        IF (IGBL(22) /= -1) CALL PLA236 (
     1                    NCOD, 1, SQD13, SQD13, NAMS(1, 2)(2:10), NQ3)
                      END IF
                    END IF
                  END IF
                END IF
                IF (IPR(32) /= 0) THEN
                  NRAT = NRAT + 1
                  IF (IGBL(63) > 2) THEN
                    WRITE (PRBUF, FORMA) NRAT, NAMS(1, 2)(2:10),
     1                (ANIS(I, J), ISDV(J), J = 1, 6), UEQ, ISUEQ,
     2                (DUMA(J), J = 1, 3), D13, ND13
                    CALL PLA263 (LU7, PRBUF, 132, 1, 9)
                    CALL GEN025 (UIJC, DUMA, 1)
C * LIST CARTESIAN AXES UIJ VALUES
                    IF (IPR(347) > 0) THEN
                      CALL PLA262 (1)
                      WRITE (LU7, 99972) (DUMA(J), J = 1, 6)
                    END IF
                  END IF
                END IF
              END IF
              IF (I <= NATC) THEN
C * SHELXL ATOM RECORD ANIS
                IF (IGBL(31) < 0) THEN
C * HANDLE SHELXL PART #
                  CALL GEN048 (-5, IFG(3, I), 14, IPART)
                  IPARTI = IPART - 16
                  IF (IPARTI /= IPARTO) THEN
                    WRITE (LU2, 99934 ) IPARTI
                    IPARTO = IPARTI
                  END IF
                  IF (RESI /= RESI0) THEN
                    RESI0 = RESI
                    WRITE (LU2, 99931) RESI
                  ENDIF
                  WRITE (LU2, 99997) NQ2(1:4), ISCFT,
     1            (CON(I, K), K = 1, 3), CHAR (ICHAR ('=')),
     2             POPL, (ANIS(I, K), K = 1, 6)
C * TEST FOR OMEGA FILE AND SPF MODE (= IGBL(31)= 3)
                ELSE IF (IPR(438) == 1 .OR. IGBL(31) == 3) THEN
                  WRITE (LU2, 99986) NAMS(1, 2)(2:NP64), ELB(IEN(NIEN)),
     1                               (ANIS(I, K), K = 1, 6), UEQ
                  WRITE (LU2, 99985) NAMS(1, 2)(2:NP64), ELB(IEN(NIEN)),
     1                               (SUAN(I, K), K = 1, 6), SUEQ
                END IF
              END IF
C * ISOTROPIC TEMPERATURE FACTOR
            ELSE IF (JM == 1) THEN
              DATC(I) = ANIS(I, 1)
              IF (I <= NATC) THEN
C * SHELXL ATOM RECORD ISO
                IF (IGBL(31) < 0) THEN
C * HANDLE SHELXL PART #
                  CALL GEN048 (-5, IFG(3, I), 14, IPART)
                  IPARTI = IPART - 16
                  IF (IPARTI /= IPARTO) THEN
                    WRITE (LU2, 99934) IPARTI
                    IPARTO = IPARTI
                  END IF
                  IF (RESI0 /= RESI) THEN
                    RESI0 = RESI
                    WRITE (LU2, 99931) RESI
                  END IF
                  WRITE (LU2, 99996) NQ2(1:4), ISCFT,
     1            (CON(I, K), K = 1, 3), POPL, ANIS(I, 1)
                ELSE IF (IPR(438) == 1 .OR. IGBL(31) == 3) THEN
                  WRITE (LU2, 99988) NAMS(1, 2)(2:NP64), ELB(IEN(NIEN)),
     1                                ANIS(I, 1), SUAN(I, 1)
                END IF
              END IF
              IF (IPR(32) /= 0 .AND. I <= NAT) THEN
                NRAT = NRAT + 1
C * GENERAL AVERAGE
                IF (NHAT == 0) THEN
                  BOK(1, 1) = BOK(1, 1)     + ANIS(I, 1)
                  BOK(1, 2) = MIN (BOK(1, 2), ANIS (I, 1))
                  BOK(1, 3) = MAX (BOK(1, 3), ANIS(I, 1))
                  KBO(1, 1) = KBO(1, 1) + 1
                END IF
                BOK(NIEN + 1, 1) = BOK(NIEN + 1, 1)     + ANIS(I, 1)
                BOK(NIEN + 1, 2) = MIN (BOK(NIEN + 1, 2), ANIS(I, 1))
                BOK(NIEN + 1, 3) = MAX (BOK(NIEN + 1, 3), ANIS(I, 1))
                KBO(NIEN + 1, 1) = KBO(NIEN + 1, 1) + 1
                BOK(NIEN + 1, 5) = MIN (BOK(NIEN + 1, 5), ANIS(I, 1))
                BOK(NIEN + 1, 6) = MAX (BOK(NIEN + 1, 6), ANIS(I, 1))
                IF (IGBL(63) > 2) THEN
                  WRITE (PRBUF, FORMB) NRAT, NAMS(1, 2)(2:10),
     1              ANIS(I, 1), ISDV(1), ANIS(I, 1), ISDV(1)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                END IF
              END IF
            END IF
C * ADD H-ATOMS BELONGING TO THIS ATOM
            IF (IGBL(31) < 0) THEN
C * GET POSITION OF H IN SFAC RECORD
              JSCFT = 0
              DO J = 1, IAN
                IF (IEN(IENS(J)) == 1) JSCFT = J
              END DO
              NCH = 0
              NM  = 3
              CALL GEN048 (-3, IFG(2, I), 24,  NCH)
              CALL GEN048 (-3, IFG(3, I), 25,  NHAT)
C * CHECK FOR/HANDLE CARBON
              IF (NCH > 0) THEN
                IF (IEN(NIEN) == 2) THEN
                  CALL GEN048 (-4, IFG(1, I), 24, IHYB)
                  IF (NCH == 1) THEN
                    IF (IHYB == 1) THEN
                      NM = 163
                    ELSE IF (IHYB == 2) THEN
                      NM = 43
                    ELSE IF (IHYB == 3) THEN
                      NM = 13
                    END IF
                  ELSE IF (NCH == 2) THEN
                    IF (IHYB == 2) THEN
                      NM = 93
                    ELSE IF (IHYB == 3) THEN
                      NM = 23
                    END IF
                  ELSE IF (NCH == 3) THEN
                    IF (IHYB == 3) THEN
                      IF (NHAT == 6) THEN
                        NM = 127
                      ELSE
                        NM = 137
                      END IF
                    END IF
                  END IF
                END IF
                IAFIX = 0
                IF (IMET == 1) THEN
                  DISTMAX = 1.8
                ELSE
                  DISTMAX = 1.2
                END IF
C * SEARCH H-ATOM LOOP
                DO J = 1, NATC
C * GET H-ATOM INFO
                  CALL GEN048 (-1, IFG(1, J), 7, JHAT)
                  IF (JHAT /= 0) THEN
                    CALL GEN048 (-5, IFG(3, J), 14, JPART)
                    IPARTJ = JPART - 16
                    JUNK   = 0
                    IF (IPARTI == IPARTJ) THEN
                      JUNK = 1
                    ELSE IF (IPARTI == 0 .OR. IPARTJ == 0) THEN
                      JUNK = 1
                    END IF
                    IF (JUNK == 1) THEN
                      XJ = VOID((J - 1) * NP71 + 4)
                      YJ = VOID((J - 1) * NP71 + 5)
                      ZJ = VOID((J - 1) * NP71 + 6)
                      DIST = SQRT ((XI - XJ)**2 + (YI - YJ)**2
     1                     +       (ZI - ZJ)**2)
                      IF (DIST < DISTMAX) THEN
C * TEST FOR NEUTRON
                        IF (IPR493 == 7) THEN
                          YNK = ANIS(I, 1)
                        ELSE
C * ADD PROPER UISO FIX
                          YNK = -1.2
                          IF (NM == 127 .OR. NM == 137 .OR.
     1                      (NM == 3 .AND. IEN(IENS(ISCFT)) == 3))
     2                      YNK = -1.5
                        END IF
C * HANDLE SHELXL PART #
                        JUNK = 0
                        IF (IPARTO /= IPARTJ) THEN
                          WRITE (LU2, 99934) IPARTJ
                          IPARTO = IPARTJ
                        ENDIF
                        IAFIX = IAFIX + 1
                        IF (IAFIX == 1) WRITE (LU2, 99961) NM
 
                          CALL PLA036 (-J, 1, 2, IDISD, IDUM1, IDUM2,
     1                    0, IGBL(55))
                          K = INDEX (NAMS(1, 2), '_')
                          IF (K == 0) THEN
                            RESI = '0 '
                            NQ3  = NAMS(1, 2)(2:8)
                          ELSE
                            NQ3  = NAMS(1, 2)(2:K - 1)
                            RESI = NAMS(1, 2)(K + 1:K + 2)
                          END IF
 
                        WRITE (LU2, 99953) NQ3(1:4), JSCFT,
     1                    (CON(J, K), K = 1, 3), 10.0 + CON(J, 4), YNK
                      END IF
                    END IF
                  END IF
                END DO
                IF (IAFIX > 0) WRITE (LU2, 99961) 0
              END IF
            END IF
            IF (JM > 1) THEN
              J = IPR(297) + (I - 1) * 21
              DO K = 1, 3
                V8(K) = VOID(J + K + 6)
              END DO
              XDUM = SQRT (GEN009 (V8, V8))
              DO K = 1, 3
                V8(K) = V8(K) * (VOID(J + 12) - MAX (VOID(J + 10), 0.0))
     1                / XDUM
              END DO
              CALL GEN002 (1, ROR, V8, V6, XLNG)
              J = (I - 1) * NP71
              DO K = 1, 3
                V5(K) = VOID(J + K) - V6(K)
                V8(K) = VOID(J + K) + V6(K)
              END DO
              IF (I <= NATC .AND. IGBL(63) > 2) THEN
                CALL PLA262 (1)
                WRITE (LU7, 99952) (V5(K), K = 1, 3), (V8(K), K = 1, 3)
              END IF
            END IF
          END IF
        END DO
C * NON-H DISORDER CHECK
        IF (IPR(43) > 0 .AND. IGBL(22) /= -1) THEN
          WRITE (NQ4, 99930) N
C * ALERT _301
          IF (XPV(3) > 0.0)
     1      CALL PLA236 (301, 0, -999.0,
     2                   XPV(3) * 100.0 / XPV(1), NQ4, ' ')
C * ALERT _302
          IF (XPV(4) > 0.0)
     1      CALL PLA236 (302, 0, -999.0,
     2                   XPV(4) * 100.0 / XPV(2), NQ4, ' ')
        END IF
        IF (IPR(32) /= 0) THEN
          DO I = 2, IAN + 1
            IF (BOK(I, 5) > 0.0) THEN
              BOK(I, 4) = MIN (9.9999, BOK(I, 6) / BOK(I, 5))
            ELSE
              BOK(I, 4) = 0.0
            END IF
            IF (BOK(I, 5) > 1000.0) BOK(I, 5) = 0.0
          END DO
          DO I = 1, IAN
            J = IENS(I)
            IF (BOK(J + 1, 4) > 1.5) THEN
              IF (LMT(J, 1) == ' H' .OR. LMT(J, 1) == ' D') THEN
                K = 2 + NADD
              ELSE
                K = NADD
              END IF
C * ALERT _220 +
              STRA = '   '//LMT(J, 1)//'   U'
              WRITE (STRA(1:3), '(I2, 1X)') N
              IF (IGBL(22) /= -1) CALL PLA236 (
     1         220 + K, 1, BOK(J + 1, 4), BOK(J + 1, 4), STRA, ' ')
            END IF
          END DO
        END IF
        IF (NDEV > 0) THEN
          DO I = 1, 6
            DEV(I) = DEV(I) / NDEV
          END DO
          CALL GEN025 (UIJ, DEV, -1)
C * UIJ - Main AXES & VALUES & UEQ
          CALL GEN114 (PAR, OR, UIJ, UIJC, DUMA, DUMV, UEQ)
          CALL PLA262 (3)
          RATIO = DUMA(3) / DUMA(1)
          CALL PLA047 (LABA(IATF), NQ2, IDUM, JDUM, 0, IGBL(55),
     1         0, 1)
 
C * ALERT _260 - REPORT LARGE AVERAGE Ueq FOR RESIDUE
          CALL PLA236 (260, 3, UEQ, UEQ, NQ2, ' ')
          IF (IGBL(63) > 2) WRITE (LU7, 99948) (DEV(K), K = 1, 6),
     1            UEQ, (DUMA(K), K = 1, 3), RATIO
          WRITE (NQ4, 99930) N
C * ALERT _250
          IF (NDEV > 5 .AND. IGBL(22) /= -1)
     1      CALL PLA236 (250, 1, RATIO, RATIO, NQ4, ' ')
        END IF
      END DO
C * OUTPUT TEMPERATURE PARAMETER EXPLANATION
      IF (IPR(32) /= 0) THEN
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (15)
          WRITE (LU7, 99983)
C * OUTPUT U/UEQ AVERAGES
          CALL PLA262 (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)
        END IF
        DO I = 1, IAN + 1
          IF (BOK(I, 2) > 0.0) THEN
            BOK(I, 1) = MIN (9.9999, BOK(I, 3) / BOK(I, 2))
          ELSE
            BOK(I, 1) = 0.0
          END IF
          IF (BOK(I, 2) > 1000.0) BOK(I, 2) = 0.0
        END DO
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (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)
        END IF
      END IF
      IF (IGBL(31) == -2 .OR. IGBL(31) == -3) THEN
C * TEST FOR UNIT MATRIX
        IF (GEN135 (PAR(231)) == 0) THEN
          WRITE (LU2, FORMC) (PAR(I), I = 231, 239)
        ELSE
          WRITE (LU2, 99940)
        END IF
        IF (IPR(209) > 0) THEN
          DO J = 1, 12
            IF (LAUEGR == NLAUE(J)) EXIT
          END DO
          WRITE (LU2, 99954) (PAR(230 + I), I = 1, 9),
     1      SPGRNM(1)(12:13), J, SPGRNM(1)(1:7), IGBL(4)
        END IF
      END IF
      IF (IGBL(31) <  0) WRITE (LU2, 99995)
C * ENDS (SPF)
      IF (IGBL(31) == 3 .AND. IPR(504) /= 2) THEN
C * TEST FOR UNIT MATRIX
        IF (GEN135 (PAR(231)) == 0) THEN
          WRITE (LU2, FORMC) (PAR(I), I = 231, 239)
        ELSE
          WRITE (LU2, 99940)
        END IF
        IF (IGBL(97) == 0) THEN
          WRITE (LU2, 99944)
        ELSE
          WRITE (LU2, 99943)
        END IF
      END IF
C * TEST FOR .RES FILE
      IF (IPR(504) == 2) THEN
C * TEST FOR UNIT MATRIX
        IF (GEN135 (PAR(231)) == 0) THEN
          WRITE (LU2, FORMC) (PAR(I), I = 231, 239)
        ELSE
          WRITE (LU2, 99940)
        END IF
        IF (IPR(595) == 0) THEN
          WRITE (LU2, 99956) IPR(209), ' '
        ELSE
          WRITE (LU2, 99956) IPR(209), 'NOSF'
        END IF
        CLOSE (UNIT = LU1, IOSTAT = IOST)
        CLOSE (UNIT = LU2, IOSTAT = IOST)
        IF (IOST == 0 .OR. IOST /= 0) CALL PLA280 ('END')
        KXT    = 3
        EXTENS = 'spf'
        FNLU1 = NAMEFIL(1:KNMFIL)//'_pl.'//EXTENS(1:KXT)
        OPEN (UNIT = LU1, FILE = FNLU1, FORM = 'FORMATTED',
     1         STATUS = 'OLD')
        IPR(3)  = 1
        IGBL(8) = 1
      END IF
C * NUMBER OF ISOTROPIC NON-H ATOMS
      IF (IGBL(94) == 0) THEN
        IF (IPR(489) + IPR(490) > 0) THEN
          IF (IGBL(22) /= -1) THEN
C * ALERT _201 - Main residue isotropic non-hydrogen atoms
            IF (IPR(489) > 0) THEN
C * CHECK FOR POWDER
              IF (IPR(105) == 0) THEN
C * CHECK FOR ANHARMONIC DISPLACEMENT PARAMETERS
                IF (IPR(756) == 0) THEN
                  CALL PLA236 (-201, 0, FLOAT (IPR(489)),
     1               FLOAT (IPR(489)), ' ', ' ')
                  L = MIN (NP77, IPR(489))
                  DO I = 1, L, 8
                    K = MIN (7, L - I)
                    WRITE (PRBUF, 99969) (CISO(I + J, 1), J = 0, K)
                    WRITE (LU68, 99950)  PRBUF(1:79)
                  END DO
                END IF
              ELSE
                CALL PLA236 (201, 0, -999.0, FLOAT (IPR(489)), ' ', ' ')
              END IF
            END IF
C * ALERT _202 - Anion/Solvent isotropic non-hydrogen atoms
            IF (IPR(490) > 0) THEN
C * CHECK FOR POWDER STUDY
              IF (IPR(105) == 0) THEN
                CALL PLA236 (-202, 0, FLOAT (IPR(490)), FLOAT (IPR(490))
     1                    , ' ', ' ')
                L = MIN (NP77, IPR(490))
                DO I = 1, L, 8
                  K = MIN (7, L - I)
                  WRITE (PRBUF, 99969) (CISO(I + J, 2), J = 0, K)
                    WRITE (LU68, 99950) PRBUF(1:79)
                END DO
              ELSE
                CALL PLA236 (202, 0, -999.0, FLOAT (IPR(490)), ' ', ' ')
              END IF
            END IF
          END IF
        END IF
C * ALERT _210
        IF (IPR(32) == 0 .AND. IGBL(22) /= -1) THEN
C * CHECK FOR POWDER STUDY
          IF (IPR(105) == 0) THEN
C * SUPPRESS FOR ANHARMONIC
            IF (IPR(756) == 0) THEN
              CALL PLA236 (210, 0, 1.0, 1.0, ' ', ' ')
            END IF
          ELSE
            CALL PLA236 (210, 0, -999.0, 1.0, ' ', ' ')
          END IF
        END IF
      END IF
      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', 4X, 'U11 or Uiso', 6X, 'U22',
     1 10X, 'U33', 10X, 'U23', 10X, 'U13', 10X, 'U12', 8X, 'Ueq(sUeq)',
     2 5X, 'U1', 5X, 'U2', 5X, 'U3', 1X, 'U3/U1', /, 132('-'))
99990 FORMAT ('VOLU ', 2F10.3)
99989 FORMAT ('SPGR P1')
99988 FORMAT ('U    ', A, 1X, A, 2X, 2F12.5)
99987 FORMAT ('ATOM ', A, 1X, A, 2X, 3F12.6, F7.4, ' =', /,
     1        16X, 3F9.6, F7.4)
99986 FORMAT ('UIJ  ', A, 1X, A, ' =', /,
     1        16X, 7F9.5)
99985 FORMAT ('SUIJ ', A, 1X, A, ' =', /,
     1        16X, 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 ', 6F9.5, ' = ', /, 5X, 6F9.5)
99972 FORMAT (13X, 6(F13.4))
99971 FORMAT ('ZERR', I9, 3F10.4, 3F10.3)
99970 FORMAT ('NOMOVE')
99969 FORMAT (14X, 8A)
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', I4)
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')
99954 FORMAT ('REM TRMX', 9F7.3, 1X, A, I3, /, 'REM SPGR ', A, /,
     1        'REM PLATON VERSION', I7)
99953 FORMAT (A, I3, 3F9.5, 2F10.5, F9.3)
99952 FORMAT (15X, '[', F9.4, 2F13.4, '] & [', F8.4, 2F13.4,']')
99951 FORMAT ('SET PAR 2', F6.2)
99950 FORMAT (A)
99949 FORMAT ('BOND $H')
99948 FORMAT (/, 'U(i,j)-Average', F11.4, 5F13.4, 6X, 4F7.4, F7.2, /)
99947 FORMAT ('REM SET NO EXPAND OPTION', /, 'SET IGBL 136 1')
99944 FORMAT ('INORGANIC')
99943 FORMAT ('ORGANIC')
99942 FORMAT ('L.S. 5', /, 'FMAP 2', /, 'PLAN -20', /, 'ACTA', /,
     1  'CONF')
99941 FORMAT ('SFAC', 16(1X, A))
99940 FORMAT ('HKLF 4')
99939 FORMAT ('WGHT', 2F10.5)
99938 FORMAT (F7.3)
99937 FORMAT ('BASF', F10.3, /, 'TWIN')
99936 FORMAT ('DISP', 1X, A, 2F10.3, F10.1)
99935 FORMAT ('EXTI', F11.4)
99934 FORMAT ('PART', I4)
99933 FORMAT ('NEUT')
99932 FORMAT ('SIZE', 3F10.4)
99931 FORMAT ('RESI', 1X, A)
99930 FORMAT ('Resd', I5)
      END SUBROUTINE PLA026
 
      MODULE tlsanal
      SAVE
      REAL, DIMENSION(3, 3) :: D
      REAL, DIMENSION(3, 3) :: R
      REAL, DIMENSION(3, 3) :: UC
      REAL, DIMENSION(3, 3) :: UI
      REAL, DIMENSION(3, 3) :: SL
      REAL, DIMENSION(3, 3) :: SO
      REAL, DIMENSION(3, 3) :: TO
      REAL, DIMENSION(3)    :: W3
      REAL, DIMENSION(3)    :: T3
      REAL, DIMENSION(20)   :: AO
      REAL, DIMENSION(25)   :: BN
      REAL, DIMENSION(250)  :: AN
      REAL, DIMENSION(3, 3) :: VI
      REAL, DIMENSION(3, 3) :: VT
      REAL, DIMENSION(3, 3) :: TL
      REAL, DIMENSION(3, 3) :: W1
      REAL, DIMENSION(3, 3) :: W2
      REAL, DIMENSION(3, 3) :: S1
      REAL, DIMENSION(3, 3) :: T1
      REAL, DIMENSION(3, 3) :: T2
      REAL, DIMENSION(3, 3) :: AMC
      REAL, DIMENSION(3, 3) :: ALC
      REAL, DIMENSION(3, 3) :: ATC
      REAL, DIMENSION(3, 3) :: ALM
      REAL, DIMENSION(3, 3) :: ATM
      REAL, DIMENSION(3)    :: XCG
      REAL, DIMENSION(3)    :: ROL
      REAL, DIMENSION(3)    :: W3D
      REAL, DIMENSION(3, 3) :: TW2
      REAL, DIMENSION(3, 3) :: TT2
      REAL, DIMENSION(3, 3) :: SOM
      REAL, DIMENSION(3, 3) :: TOM
      REAL, DIMENSION(3, 3) :: TOM2
      REAL, DIMENSION(3)    :: VALI
      REAL, DIMENSION(3)    :: XOCG
      REAL, DIMENSION(3)    :: TOM3
      REAL, DIMENSION(3, 3) :: HCTI
      REAL, DIMENSION(3, 3) :: HITC
      REAL, DIMENSION(3, 3) :: TTOM2
      END MODULE tlsanal
 
      SUBROUTINE PLA027
C * TLS - ANALYSIS (1)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE tlsanal
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: NN
      INTEGER          :: IVL
      INTEGER          :: NRS
      INTEGER          :: NNA
      INTEGER          :: NMAX
      INTEGER          :: NRES
      INTEGER          :: IVAL
      INTEGER          :: NATR
      INTEGER          :: IDUM
      INTEGER          :: JDUM
      INTEGER          :: JLOOP
      REAL             :: Y
      REAL             :: DET
      REAL             :: SIG
      REAL             :: SUMX
      REAL             :: DELM
      REAL             :: RMSD
      REAL             :: SUM1
      REAL             :: UEQC
      REAL             :: UEQO
      REAL             :: RIND
      REAL             :: SUMN
      REAL             :: SUMN1
      REAL             :: RIND1
      CHARACTER(len=1) :: ITLS
C * TMA - ANALYSIS
      RIND  = 0.0
      RIND1 = 0.0
      IF (IPR(32) /= 0 .AND. IPR(5) /= 0) THEN
C * GET NUMBER OF ATOMS IN ATOM LIST
        NMAX = IPR(39)
        NRES = IPR(75)
        DO I = 1, NMAX
          DO J = 1, 6
            CON(I, J) = ANIS(I, J)
          END DO
          CALL GEN048 (-4, IFG(1, I), 15, IVL)
          CON(I, 7)  = SATWT(IVL + 1)
          CON(I, 8)  = (SUAN(I, 1) + SUAN(I, 2) + SUAN(I, 3)) / 3
          SUAN(I, 7) = CON(I, 8)
        END DO
        DO NRS = 1, NRES
          NATR    = 0
          IPR(73) = 1
          IPR(74) = 1
          ITLS    = 'S'
          DO I = 1, NMAX
            IVL = NP1 + I
C * GET AND TEST FOR RESIDUE NUMBER
            CALL GEN048 (-6, IFG(1, I), 9, IVAL)
            IF (IVAL == NRS) THEN
C * GET (AN)ISO FLAG
              CALL GEN048 (-1, IFG(1, I), 4, IVAL)
              IF (IVAL /= 0) THEN
                IF (IPR(497) /= 0) THEN
                  IVAL = 0
                ELSE
C * H-IDENTIFICATION
                  CALL GEN048 (-1, IFG(1, I), 7, IVAL)
                END IF
C * THIS SECTION IS CORRECT ONLY FOR 1 or -1 STRUCTURES
                IF (IVAL == 0) THEN
                  IVL  = I
                  NATR = NATR + 1
                  CALL PLA047 (LABA(I), NQ1, IVAL, JDUM, IPR(71),
     1                         IGBL(55), 0, 0)
                END IF
              END IF
            END IF
            IATP(I) = IVL
          END DO
          IF (IPR(32) /= 0) THEN
            RMSD = 0.0
            IF (NATR >= IPR(21)) THEN
C * CALCULATE LEAST-SQUARES PLANE
              CALL PLA054 (1)
              M = 0
C * CHECK FOR NON-PLANARITY
              DO N = 1, NMAX
                I = IATP(N)
                IF (I <= NP1) THEN
                  M    = M + 1
                  RMSD = RMSD +
     1                   (XPV(1) * XXO(I, 4) + XPV(2) * XXO(I, 5) +
     2                    XPV(3) * XXO(I, 6) - XPV(4)) ** 2
                END IF
              END DO
              RMSD = SQRT (RMSD / M)
            END IF
            IF (RMSD < 0.005) THEN
              WRITE (LU6, 99998, IOSTAT = IOST) NRS, IPR(21)
            ELSE
C * ORDER EIGENVECTORS BASED ON SMALL TO LARGE EIGENVALUES
              DO I = 1, 3
                VALI(I)  =  DUMA(I)
                XOCG(I)  =  V7(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)
              END DO
              CALL GEN018 (VALI(1), VALI(3))
              DO K = 1, NMAX
                IF (IATP(K) <= NP1) THEN
                  DO I = 1, 3
                    XXO(K, I) = 0.0
                    DO J = 1, 3
                      XXO(K, I) = XXO(K, I) + (XXO(K, J + 3)
     1                          - XOCG(J)) * VI(J, I)
                    END DO
                  END DO
                END IF
              END DO
C * SAVE TRANSFORMED ORTHOGONAL COORDINATES IN VOID SCRATCH
              CALL PLA269 (2, NMAX)
              DO I = 1, 3
                DO J = 1, 3
                  IF (I == J) THEN
                    D(I, I) = PAR(112 + I)
                  ELSE
                    D(I, J) = 0.0
                  END IF
                END DO
              END DO
 
C * MATRIX PRODUCTS - CRYSTAL TO INERTIAL
              CALL GEN132 (VT, OR, D, HCTI)
C * GET INVERSE
              CALL GEN003 (HCTI, HITC, DET, 0)
              DO N = 1, NMAX
                IF (IATP(N) <= NP1) THEN
                  DO I = 1, 6
                    DUMA(I) = CON(N, I)
                  END DO
C * COPY 6-ELEMENT VECTOR INTO SYMMETRICAL MATRIX
                  CALL GEN025 (UC, DUMA, -1)
C * CALCULATE UI = HCTI * UC * HCTI~
                  CALL GEN001 (1, HCTI,  UC,   UI)
                  SUAN(N, 1) = UI(1, 1)
                  SUAN(N, 2) = UI(1, 2)
                  SUAN(N, 3) = UI(1, 3)
                  SUAN(N, 4) = UI(2, 2)
                  SUAN(N, 5) = UI(2, 3)
                  SUAN(N, 6) = UI(3, 3)
                END IF
              END DO
C * ZERO AN & BN
              CALL GEN074 (BN, 1, 25,  0.0)
              CALL GEN074 (AN, 1, 250, 0.0)
              NN = 12 + IPR(74) * 8
              DO I = 1, NMAX
                IF (IATP(I) <= NP1) THEN
                  DO JLOOP = 1, 6
                    J = JLOOP
                    CALL GEN100 (AO, J, XXO(I, 1), XXO(I, 2), XXO(I, 3))
                    M = NN + 1
                    DO N = 1, NN
                      Y     = AO(N)
                      L     = M
                      M     = M + NN - N + 1
                      BN(N) = BN(N) + Y * SUAN(I, J)
                      IF (ABS (Y) > 1.0E-15) THEN
                        AN(N) = AN(N) + Y**2
                      END IF
                      DO K = N, NN
                        IF (ABS (Y) > 1.0E-15 .AND.
     1                      ABS (AO(K)) > 1.0E-15) THEN
                          AN(L) = AN(L) + Y * AO(K)
                        END IF
                        L = L + 1
                      END DO
                    END DO
                  END DO
                END IF
              END DO
              IF (IGBL(63) > 2) THEN
C * CHECK FOR INTRA POLYMER
                IF (IPR(739) == 0) THEN
C * NEWPAGE + HEADER Schomaker and Trueblood Analysis
                  CALL PLA262 (-2)
                  WRITE (LU7, 99999, IOSTAT = IOST)
                END IF
                IF (NRES /= 1) THEN
                  CALL PLA262 (5)
                  WRITE (LU7, 99997, IOSTAT = IOST) NRS
                END IF
              END IF
C * CHECK FOR INTRA POLYMER
              IF (IPR(739) == 0) THEN
                CALL GEN012 (AN, BN, NN, 0.0, PAR(410), 1.0)
                IF (IGBL(63) > 2) THEN
C * PRINT U(IJ) COMPARISON TABLE HEADER
                  CALL PLA262 (5)
                  WRITE (LU7, 99996, IOSTAT = IOST)
                END IF
                NNA   = 0
                SUMX  = 0.0
                SUM1  = 0.0
                SUMN  = 0.0
                SUMN1 = 0.0
                DELM  = 0.0
C * ACCUMULATE  DATA FOR R1, R2 & S
                DO I = 1, NMAX
                  IF (IATP(I) <= NP1) THEN
                    DO JLOOP = 1, 6
                      J       = JLOOP
C * GET AND ACCUMULATE OBSERVED VALUES
                      DUMA(J) = - SUAN(I, J)
                      SUMN    = SUMN  + DUMA(J)**2
                      SUMN1   = SUMN1 + ABS (DUMA(J))
C * GET CALCULATED VALUES
                      CALL GEN100 (AO, J, XXO(I, 1), XXO(I, 2),
     1                             XXO(I, 3))
                      DO K = 1, NN
                        DUMA(J) = DUMA(J) + AO(K) * AN(K)
                      END DO
                      SUMX  = SUMX  + DUMA(J)**2
                      SUM1 = SUM1 + ABS (DUMA(J))
                      IF (ABS(DUMA(J)) > DELM) DELM = ABS (DUMA(J))
                    END DO
                    NNA = NNA + 6
                    IF (IGBL(63) > 2) THEN
                      CALL PLA047 (LABA(I), NQ1, IDUM, JDUM,
     1                  IPR(71), IGBL(55), 0, 1 - IGBL(55))
                      CALL PLA262 (2)
                      UEQO = (SUAN(I, 1) + SUAN(I, 4) + SUAN(I, 6))
     1                     / 3.0
                      UEQC = UEQO + (DUMA(1) + DUMA(4) + DUMA(6)) / 3.0
                      WRITE (LU7, 99995, IOSTAT = IOST) NQ1(1:7),
     1                  (SUAN(I, K), DUMA(K), K = 1, 6), UEQO, UEQC
                      UI(1, 1) = DUMA(1)
                      UI(1, 2) = DUMA(2)
                      UI(1, 3) = DUMA(3)
                      UI(2, 1) = UI(1, 2)
                      UI(2, 2) = DUMA(4)
                      UI(2, 3) = DUMA(5)
                      UI(3, 1) = UI(1, 3)
                      UI(3, 2) = UI(2, 3)
                      UI(3, 3) = DUMA(6)
                      CALL GEN001 (1, HITC, UI, UC)
                      WRITE (LU7, 99993, IOSTAT = IOST)
     1                  CON(I, 1), UC(1, 1), CON(I, 6), UC(1, 2),
     2                  CON(I, 5), UC(1, 3), CON(I, 2), UC(2, 2),
     3                  CON(I, 4), UC(2, 3), CON(I, 3), UC(3, 3)
                    END IF
                  END IF
                END DO
C * GET R1 & R2
                SIG   = SQRT (SUMX / (NNA - IPR(73) * NN))
                RIND1 = SUM1 / SUMN1
                RIND  = SQRT (SUMX / SUMN)
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (17)
                  WRITE (LU7, 99994, IOSTAT = IOST)
     1              RIND1, RIND, SIG, NATR, IPR(73), NN, DELM, ITLS
                END IF
                DO I = 1, NN
                  BN(I) = BN(I) * SIG
                END DO
                CALL PLA043 (0, 1, LU7, 0)
              END IF
C * SKIP SUBSEQUENT TLS - ANALYSIS FOR RIND > PAR(34) .OR. POLYMERS
              IF (RIND > PAR(34) .OR. IPR(739) > 0) THEN
                CALL PLA029 (0, W1, W2, NRS)
              ELSE
                CALL PLA029 (1, W1, W2, NRS)
              END IF
            END IF
          END IF
        END DO
      END IF
      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('='))
99998 FORMAT (':: No TLS-Analysis for Resd Nr:', I3,
     1 ', # non-H atoms <', I3, ' and/or Planar Molecule', /)
99997 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='), /)
99996 FORMAT ('Observed Vibration Tensor in Inertial System ',
     1 'I(1) = L, I(2) = M',
     2 ', I(3) = N (Difference U(calc) - U(obs) in Parentheses)', /,
     3 132('='), /, 'Label     U(L,L)', 12X, 'U(L,M)', 12X, 'U(L,N)',
     4 12X, 'U(M,M)', 12X, 'U(M,N)', 12X, 'U(N,N)', 9X,
     5 'Ueq(obs) Ueq(cal)', /, 12X, 'U11', 15X, 'U12', 15X, 'U13',
     6 15X, 'U22', 15X, 'U23', 15X, 'U33', /, 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 (7X, 6(F9.5, '[', F7.5, ']'))
       END SUBROUTINE PLA027
 
      SUBROUTINE PLA028
C * TMA ANALYSIS (2)
      USE files
      USE parameters
      USE plato
      USE tlsanal
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      REAL    :: TRSN
      REAL    :: TRSO
      REAL    :: XLNG
      REAL    :: ATCIJ
      REAL    :: ALCIJ
      REAL    :: AMCIJ
      K = 0
      DO I = 1, 3
        DO 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
        END DO
      END DO
      BN(21) = 0.0
      IF (IPR(74) /= 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)
      END IF
      CALL GEN024 (W1, W2, W3, TW2)
      CALL GEN024 (T1, T2, T3, TT2)
      CALL GEN004 (VT, OR, AMC)
      CALL GEN132 (W2, VT, 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 N = 1, 3
        DO I = 1, 3
          SO(N, I) = R(I, N) * W3(N) + SL(N, I)
        END DO
      END DO
      DO I = 1, 3
        DO L = 1, 3
          TO(I, L) = 0.0
          DO 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)
          END DO
          TO(I, L) = TO(I, L) + TL(I, L)
        END DO
      END DO
      CALL GEN001 (1, TW2, TO, TOM)
      CALL GEN001 (1, TW2, SO, SOM)
      CALL GEN024 (TOM, TOM2, TOM3, TTOM2)
      CALL GEN132 (TOM2, VT, OR, ATC)
      DO I = 1, 3
        W3D(I) = W3(I) * RGBL(6)**2
        DO J = 1, 3
          AMCIJ = AMC(I, J) / PAR(100 + J)
          IF (ABS (AMCIJ) > 1.0) AMCIJ = SIGN (1.0, AMCIJ)
          AMC(I, J) = ACOS (AMCIJ) * RGBL(6)
          ALCIJ     = ALC(I, J) / PAR(100 + J)
          IF (ABS (ALCIJ) > 1.0) ALCIJ = SIGN (1.0, ALCIJ)
          ALC(I, J) = ACOS(ALCIJ) * RGBL(6)
          ATCIJ     = ATC(I, J) / PAR(100 + J)
          IF (ABS (ATCIJ) > 1.0) ATCIJ = SIGN (1.0, ATCIJ)
          ATC(I, J) = ACOS (ATCIJ)      * RGBL(6)
          ALM(I, J) = ACOS (W2(I, J))   * RGBL(6)
          ATM(I, J) = ACOS (TOM2(I, J)) * RGBL(6)
        END DO
      END DO
      TRSO = T3(1)   + T3(2)   + T3(3)
      TRSN = TOM3(1) + TOM3(2) + TOM3(3)
C * LIMIT ESD'S TO MAX 0.99999 TO MEET PRINTING FORMAT
      DO I = 1, 21
        IF (ABS(BN(I)) > 0.99999) BN(I) = 0.999989
      END DO
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (0)
        WRITE (LU7, 99999, IOSTAT = IOST)
     1    (I, (VT(I, J), J = 1, 3), VALI(I),
     2    (AMC(I, J), J = 1, 3), CHAR (ICHAR ('W') + I),
     3     XCG(I), I = 1, 3)
        WRITE (LU7, 99998, IOSTAT = IOST)
     1   (W1(1, J), NINT (BN(J) * 1.0E+5), J = 1, 3),
     2   (W2(1, J), J = 1, 3), W3(1), W3D(1), SQRT (MAX (0.0, W3D(1))),
     3   (W1(2, J), NINT (BN(J + 2) * 1.0E+5), J = 2, 3),
     4   (W2(2, J), J = 1, 3), W3(2), W3D(2), SQRT (MAX (0.0, W3D(2))),
     5    W1(3, 3), NINT (BN(6) * 1.0E+5),
     6   (W2(3, J), J = 1, 3), W3(3), W3D(3), SQRT (MAX (0.0, W3D(3)))
        WRITE (LU7, 99997, IOSTAT = IOST)
     1    (T1(1, J), NINT (BN(J + 6) * 1.0E+5), J = 1, 3),
     2    (T2(1, J), J = 1, 3), T3(1), SQRT (T3(1)),
     3    (T1(2, J), NINT (BN(J + 8) * 1.0E+5), J = 2, 3),
     4    (T2(2, J), J = 1, 3), T3(2), SQRT (MAX (0.0, T3(2))),
     5    T1(3, 3), NINT (BN(12) * 1.0E+5),
     6    (T2(3, J), J = 1, 3), T3(3), SQRT (MAX (0.0, T3(3)))
        IF (IPR(74) /= 0) THEN
          WRITE (LU7, 99996, IOSTAT = IOST)
     1      (S1(1, J), NINT (BN(J + 12) * 1.0E+5), J = 1, 3),
     2      (S1(2, J), NINT (BN(J + 15) * 1.0E+5), J = 1, 3),
     3      (S1(3, J), NINT (BN(J + 18) * 1.0E+5), J = 1, 3)
          WRITE (LU7, 99995, IOSTAT = IOST) TRSO, TRSN
          WRITE (LU7, 99994, IOSTAT = IOST)
     1      (I, ROL(I), (SOM(I, J), J = 1, 3),
     2      (TOM(I, J), J = 1, 3), I, (TOM2(I, J), J = 1, 3),
     3      TOM3(I), I = 1, 3)
        END IF
        WRITE (LU7, 99993, IOSTAT = IOST)
        WRITE (LU7, 99992, IOSTAT = IOST)
     1    (I, (ALM(I, J), J = 1, 3), (ALC(I, J), J = 1, 3),
     2     I, (ATM(I, J), J = 1, 3), (ATC(I, J), J = 1, 3), I = 1, 3)
      END IF
      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', 7X, 'Deg', /, 132('-'), /, F8.5, '(', I3, ')', F11.5,
     4 '(', I3, ')', F11.5, '(', I3, ')', 9X, 'L(1)', 3F10.5, 5X,
     5 F10.5, 2F10.2, /, 16X, F8.5, '(', I3, ')', F11.5, '(', I3,
     6 ')', 9X, 'L(2)', 3F10.5, 5X, F10.5, 2F10.2, /, 32X, F8.5, '(',
     7 I3, ')', 9X, 'L(3)', 3F10.5, 5X, F10.5, 2F10.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', 10X, 'Ang^2', 12X,
     3 'Ang', /, 132('-'), /, F8.5, '(', I3, ')', F11.5, '(', I3,
     4 ')', F11.5, '(', I3, ')', 9X, 'T(1)', 3F10.5, 2F15.5, /, 16X,
     5 F8.5, '(', I3, ')', F11.5, '(', I3, ')', 9X, 'T(2)', 3F10.5,
     6 2F15.5, /, 32X, F8.5, '(', I3, ')', 9X, 'T(3)', 3F10.5,
     7 2F15.5)
99996 FORMAT ('Cross Tensor, S(rad*Ang)', /, 132('-'),
     1 3(/, F8.5, '(', I3, ')', 2(F11.5, '(', I3, ')')), /)
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 (/43X, 'Angular Relationships (Degrees)', /, 43X, 31('='))
99992 FORMAT ('Libration Axes  -  Inertial  Axes  ',
     1 'Libration Axes - Crystal Axes  ',
     2 'Translation Axes - Inertial  Axes  ',
     3 'Translation Axes - Crystal Axes', /, 64('-'), 2X, 67('-'), /,
     4 15X, 'XI', 6X, 'YI', 6X, 'ZI', 14X, 'X', 7X, 'Y', 7X, 'Z',
     5 18X, 'XI', 6X, 'YI', 6X, 'ZI', 15X, 'X', 7X, 'Y', 7X, 'Z', /,
     6 3('L(', I1, ')', 5X, 3F8.2, 7X, 3F8.2,
     7 2X, 'New T(', I1, ')', 2X, 3F8.2, 8X, 3F8.2, /))
      END SUBROUTINE PLA028
 
      SUBROUTINE PLA029 (MODE, W, W2, NRS)
C * TMA-ANALYSIS (3) (GEOM)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: N0
      INTEGER               :: NR1
      INTEGER               :: NR2
      INTEGER               :: NRB
      INTEGER               :: NRS
      INTEGER               :: NAD
      INTEGER               :: IDS
      INTEGER               :: JDS
      INTEGER               :: IER
      INTEGER               :: IENI
      INTEGER               :: IENJ
      INTEGER               :: IDIJ
      INTEGER               :: IDUM
      INTEGER               :: NADD
      INTEGER               :: NDEC
      INTEGER               :: NDIJ
      INTEGER               :: NATR
      INTEGER               :: MODE
      INTEGER               :: NMAX
      INTEGER               :: NSVI
      INTEGER               :: NSVJ
      INTEGER               :: JHYB
      INTEGER               :: JUNK
      INTEGER               :: IVLJ
      INTEGER               :: IVAL
      INTEGER               :: ISVI
      INTEGER               :: ISVJ
      INTEGER               :: ISSU
      INTEGER               :: IHYB
      INTEGER               :: IGEN
      INTEGER               :: IVALI
      INTEGER               :: IVALJ
      INTEGER               :: IATPRI
      INTEGER               :: IATPRJ
      REAL                  :: V
      REAL                  :: S
      REAL                  :: SC
      REAL                  :: VJ
      REAL                  :: VI
      REAL                  :: ANG
      REAL                  :: SVI
      REAL                  :: SVJ
      REAL                  :: SSU
      REAL                  :: DIJ
      REAL                  :: RVLI
      REAL                  :: SDIJ
      REAL                  :: TADD
      REAL                  :: XLNG
      REAL                  :: DMAX
      REAL                  :: TRACE
      REAL                  :: DELIJ
      REAL                  :: THIRSH
      REAL                  :: THIRSH0
      REAL                  :: DISTMAX
      REAL, DIMENSION(3, 3) :: W
      REAL, DIMENSION(3, 3) :: W2
      REAL, DIMENSION(3, 3) :: WO
      REAL, DIMENSION(3)    :: DY
      REAL, DIMENSION(3)    :: Z
      REAL, DIMENSION(3)    :: ANGL
      CHARACTER(len=1)      :: XMRK
      CHARACTER(len=114)    :: FORMX
      FORMX(1:41)   = '(A,''- '',A,F6.0,''('',I3,'')'',F11.4,3F8.4,1X,'
      FORMX(42:79)  = 'F7.0,''('',I2,'')'',1X,F7.0,''('',I2,'')'',1X,'
      FORMX(80:114) = 'F7.0,''('',I2,'')'',1X,A,F9.4,2X,3F7.2)'
C * MODE = 0 - NO TLS ANALYSIS
C * MODE = 1 -    TLS ANALYSIS
      IER = 0
C * GET NUMBER OF ATOMS IN ATOM LIST
      NMAX = IPR(39)
      IF (MODE /= 0) THEN
        CALL PLA028
        TRACE = W(1, 1) + W(2, 2) + W(3, 3)
        DO I = 1, 3
          DO J = 1, 3
            IF (I == J) THEN
              TADD = TRACE
            ELSE
              TADD = 0.0
            END IF
            WO(I, J) = (TADD - W(I, J)) / 2
          END DO
        END DO
      ELSE
C * TEST FOR NON-POLYMER AND NO-DISORDER
        IF (IPR(739) /= 0 .OR. IPR(43) /= 0) THEN
          CALL PLA015 (0, 43)
          WRITE (LU6, 99993, IOSTAT = IOST)
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99993, IOSTAT = IOST)
          END IF
        ELSE
          WRITE (LU6, 99990, IOSTAT = IOST) NRS, PAR(34)
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99990, IOSTAT = IOST) NRS, PAR(34)
          END IF
        END IF
        CALL GEN074 (ANGL, 1, 3, 0.0)
        CALL GEN074 (DY,   1, 3, 0.0)
      END IF
      IF (NMAX < 500) THEN
        IF (IGBL(63) > 2) THEN
C * NEWPAGE
          CALL PLA262 (-7)
          WRITE (LU7, 99995, IOSTAT = IOST)
          WRITE (LU7, 99994, IOSTAT = IOST)
        END IF
        DELIJ = 0
        NRB   = 0
        NATR  = 0
        DO I = 1, NMAX
C * GET DISORDER INFO
          CALL GEN048 (-8, IFG(2, I), 1, IDS)
          IDS = IPPR(IDS + 1, 1)
          CALL GEN048 (-4, IFG(1, I), 24, IHYB)
C * TEST FOR MAJOR RESIDUE(S) = 0, ANION/SOLVENT = 1
          CALL GEN048 (-6, IFG(1, I), 9, IVAL)
          NADD = 0
          IF (RCONT(IVAL) < IPR(487) .AND. IPR(75) > 1) NADD = 1
          CALL GEN048 (-1, IFG(1, I), 19, IVALI)
          IF (IATP(I) <= NP1) THEN
            CALL PLA047 (LABA(I), NQ1, IDUM, IENI, IPR(71),
     1         IGBL(55), 0, 1 - IGBL(55))
            RVLI   = REL(IENI)
            IATPRI = IATPR(IENI)
            NR1    = IATNR(IENI)
            NATR   = NATR + 1
            DO J = I, NMAX
              IF (I /= J .AND. IATP(J) <= NP1) THEN
C * GET DISORDER INFO
                CALL GEN048 (-8, IFG(2, J), 1, JDS)
                JDS = IPPR(JDS + 1, 1)
                CALL GEN048 (-4, IFG(1, J), 24, JHYB)
                CALL PLA047 (LABA(J), NQ2, IDUM, IENJ, IPR(71),
     1                       IGBL(55), 0, 1 - IGBL(55))
                IATPRJ = IATPR(IENJ)
                CALL GEN048 (-1, IFG(1, J), 31, IVAL)
C * AVOID METAL N(O3) ETC. 'BONDS'
                IF (IATPRI * IVAL <= 0) THEN
                NR2  = IATNR(IENJ)
C * AVOID METAL-METAL
                  IF (IATPRI > 0 .AND. IATPRJ > 0) THEN
                    DMAX = 2.0
                  ELSE
                    DMAX = RVLI + REL(IENJ) + PAR(2)
                  END IF
                  DO K = 1, 3
                    V7(K) = XXO(I, K) - XXO(J, K)
                  END DO
                  CALL PLA053 (I, J, 0, 0, S, SSU, ISSU, NDEC, IER)
                  IF (S > 0.001 .AND. S < DMAX) THEN
                    SC = 0.0
                    IF (MODE /= 0) CALL GEN002 (1, WO, V7, DY, XLNG)
                    DO K = 1, 3
                      IF (MODE /= 0) THEN
                        Z(K) = V7(K) + DY(K)
                        SC   = SC + Z(K)**2
                      END IF
                      V7(K) = V7(K) / S
                    END DO
                    IF (MODE /= 0) THEN
                      CALL GEN002 (1, W2, V7, ANGL, XLNG)
                      DO K = 1, 3
                        ANG = MAX (-1.0, MIN (1.0, ANGL(K)))
                        ANGL(K) = ACOS(ANG) * RGBL(6)
                      END DO
                      SC = SQRT(SC)
                    END IF
C * GET COMPONENTS OF DISPLACEMENT ELLIPSOIDS ALONG BOND I-J
                    VI = 0.0
                    VJ = 0.0
                    DO K = 1, 3
                      DO L = 1, 3
                        M = K * L
                        IF (M == 6) M = 5
                        IF (M == 9) M = 6
                        VI = VI + V7(K) * SUAN(I, M) * V7(L)
                        VJ = VJ + V7(K) * SUAN(J, M) * V7(L)
                      END DO
                    END DO
                    SVI = CON(I, 8)
                    CALL GEN041 (VI, SVI, ISVI, 5, NSVI, IPR(68))
                    SVJ = CON(J, 8)
                    CALL GEN041 (VJ, SVJ, ISVJ, 5, NSVJ, IPR(68))
                    ISVI = MAX (0, MIN (99, ISVI))
                    ISVJ = MAX (0, MIN (99, ISVJ))
                    DIJ  = ABS(VI - VJ)
                    XMRK = ' '
                    NDIJ = 5
                    IF (ISVI > 0 .AND. ISVJ > 0) THEN
                      SDIJ = SQRT(CON(I, 8)**2 + CON(J, 8)**2)
                      CALL GEN041 (DIJ, SDIJ, IDIJ, 5, NDIJ, IPR(68))
                      IDIJ   = MIN (99, IDIJ)
                      THIRSH = DIJ / SDIJ
                      IF (THIRSH > PAR(421)) XMRK = '#'
                    ELSE
                      IDIJ = 0
                    END IF
                    DELIJ = DELIJ + DIJ**2
                    NRB   = NRB + 1
                    SDIJ  = SQRT(DIJ)
                    IF (I <= IPR(37)) THEN
                      CALL GEN048 (-1, IFG(1, I), 6, IGEN)
                      IF (IGEN == 1) THEN
                        JUNK = IPR(37)
                      ELSE
                        JUNK = IPR(39)
                      END IF
C * ALLOW FOR MAJOR DISORDER FORM BONDS AND
C * BONDS BETWEEN FULLY AND PARTIALLY OCCUPIED ATOMS
                      IF ((IDS == JDS  .AND. IDS > 5000)  .OR.
     1                    (IDS < 10000 .AND. JDS == 10000) .OR.
     2                    (IDS == 10000 .AND. JDS < 10000)) THEN
                        IF (J <= JUNK .AND. NR2 <= NR1) THEN
C * CHECK PRINT LEVEL
                          IF (IGBL(63) > 2) THEN
                            ISSU = MIN (999, ISSU)
                            FORMX(14:14) = CHAR (ICHAR ('0') + NDEC)
                            FORMX(45:45) = CHAR (ICHAR ('0') + NSVI)
                            FORMX(64:64) = CHAR (ICHAR ('0') + NSVJ)
                            FORMX(83:83) = CHAR (ICHAR ('0') + NDIJ)
                            WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1                        NQ1(1:7), NQ2(1:7), S, ISSU, SC, DY, VI,
     2                        ISVI, VJ, ISVJ, DIJ, IDIJ, XMRK, SDIJ,
     3                        ANGL
                            CALL PLA263 (LU7, PRBUF, 132, 1, 3)
                          END IF
                          IF (IDIJ /= 0) THEN
                            IF (THIRSH > PAR(421))
     1                        WRITE (LU6, 99991, IOSTAT = IOST)
     2                        NQ1, NQ2, THIRSH
                            IF (THIRSH > 2.0 .AND. DIJ > 0.001)
     1                        THEN
                              CALL GEN048 (-1, IFG(1, J), 19, IVALJ)
                              NAD = NADD + 2 * MAX (IVALI, IVALJ)
C * ALERT _234
                              IF (THIRSH <= 5.0) THEN
                                CALL PLA236 (234, 2, SDIJ, SDIJ, NQ1,
     1                             NQ2)
                              ELSE
C * ALERT _23x : Hirshfeld
                                THIRSH0 = THIRSH
C * HANDLE LONG BONDS
                                IF (NR2 == 8) THEN
C * HANDLE LARGE ZN-O 'BOND DISTANCES
                                  IF (NR1 == 30) THEN
                                    DISTMAX = 2.3
                                  ELSE IF (NR1 > 36) THEN
                                    DISTMAX = 2.6
                                  ELSE
                                    DISTMAX = 10.0
                                  ENDIF
                                  IF (S > DISTMAX) THIRSH0 = -999.0
                                END IF
C * CHECK FOR DISORDER BOND
                                IF (IDS < 10000 .OR. JDS < 10000)
     1                            THIRSH0 = -999.0
C * CHECK FOR sp1 ATOMS
                                IF (IHYB == 1 .OR. JHYB == 1)
     1                            THIRSH0 = -999.0
C * NO METAL - HALOGEN A,B,C ALERTS -> G-ALERT
                                IF ((IATPRI > 0 .AND. IATPRJ == -7)
     1                            .OR.
     2                             (IATPRI == -7 .AND. IATPRJ > 0))
     3                            THIRSH0 = -999.0
C * NO SI - HALOGEN A,B,C ALERTS -> G-ALERT
                                IF ((NR1 == 14 .AND. IATPRJ == -7)
     1                            .OR.
     2                             (IATPRI == -7 .AND. NR2 == 14))
     3                            THIRSH0 = -999.0
C * HIGH RESOLUTION CASE
                                IF (NAD /= 0) THEN
C * TEST SINTH/Lambda-max value
                                  IF ((PAR(287) > 0.65 .AND.
     1                                 THIRSH <= 15.0) .OR.
     2                                (PAR(287) > 0.6 .AND.
     3                                 THIRSH < 10.0) .OR.
     4                                 (PAR(173) < 2.0 .AND.
     5                                  PAR(168) > 27.45))
     6                                   THIRSH0 = -999.0
                                END IF
                                CALL PLA236 (230 + NAD, 1, THIRSH0,
     1                            THIRSH, NQ1, NQ2)
                              END IF
                            END IF
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END IF
        END DO
        IF (NRB > 0) DELIJ = SQRT (DELIJ / NRB)
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (5)
          WRITE (LU7, 99992, IOSTAT = IOST) DELIJ, PAR(421)
        END IF
C * SETUP NON-BONDING 'RIGID-BOND' TEST MATRIX
        IF (NATR <= 40) THEN
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (0)
            CALL PLA262 (5)
            WRITE (LU7, 99999, IOSTAT = IOST) (J, J = 1, NATR)
            WRITE (LU7, 99998, IOSTAT = IOST)
          END IF
          N0 = 0
          DO I = 1, NMAX
            IF (IATP(I) <= NP1) THEN
              CALL PLA047 (LABA(I), NQ1, IDUM, IENI, IPR(71),
     1          IGBL(55), 0, 0)
              RVLI = REL(IENI)
              N0 = N0 + 1
              N  = 0
              DO J = 1, NMAX
                IF (IATP(J) <= NP1) THEN
                  CALL GEN048 (-4, IFG(1, J), 15, IVLJ)
                  DMAX = RVLI + REL(IEN(IVLJ + 1)) + PAR(2)
                  S = 0
                  V = 0
                  IF (I /= J) THEN
                    DO K = 1, 3
                      V7(K) = XXO(I, K) - XXO(J, K)
                      S     = S + V7(K)**2
                    END DO
                    S = SQRT (S)
                    V = S
                    IF (I < J .AND. S > 0.001) THEN
                      DO K = 1, 3
                        V7(K) = V7(K) / S
                      END DO
                      V = 0
                      DO K = 1, 3
                        DO L = 1, 3
                          M = K * L
                          IF (M == 6) M = 5
                          IF (M == 9) M = 6
                          V = V + V7(K) * SUAN(I, M) * V7(L)
     1                    - V7(K) * SUAN(J, M) * V7(L)
                        END DO
                      END DO
                      V = V * 1000.0
                    END IF
                  END IF
                  N = N + 1
                  IATC(N) = MIN (99, NINT (ABS (V)))
                  IF (S < DMAX) IATC(N) = -IATC(N)
                END IF
              END DO
              IF (IGBL(63) > 2) THEN
                CALL PLA262 (1)
                WRITE (LU7, 99997, IOSTAT = IOST)
     1            N0, NQ1(1:6), (IATC(K), K = 1, N)
              END IF
            END IF
          END DO
          IF (IGBL(63) > 2) THEN
            CALL PLA262(8)
            WRITE (LU7, 99996, IOSTAT = IOST)
          END IF
        END IF
      END IF
      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 (75X, 'MSDA from U(obs)', /, 5X, 'Bond', 11X,
     1 'Bond Distance   Components of the Correction  Vibration Along',
     2 ' the Interatomic Bond', 8X, 'Angle with Lib. Axes', //,
     3 'Atom(I)  Atom(J)', 7X, 'Obsd', 6X, 'Calcd', 2X,
     4 'Del(L)  Del(M)  Del(N)', 4X, 'I to J', 6X,  'J to I', 4X,
     5 'Difference', 2X, 'Sqrt(Diff)    L(1)   L(2)   L(3)', /,
     6  132('-'))
99993 FORMAT (/,
     1 ':: No TLS-Analysis for Polymeric or Disordered Structures')
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 (/, ':: No TLS-Analysis for Residue Nr:', I3,
     1 ', Because R >', F6.2)
      END SUBROUTINE PLA029
 
      SUBROUTINE PLA030 (LABA, XXO, CON, NT, IFG, IPPR, BOND)
C * DETERMINE R/S CHIRALITY FOR FOUR COORDINATED ATOMS.
C * THE HYBRIDISATION OF THE ATOMS AND THE BOND ORDER ARE DETERMINED
C * AUTOMATICALLY FROM THE SUPPLIED GEOMETRY PARAMETERS
C *
C * THIS ROUTINE IS INSPIRED BY, BUT DEVIATES SIGNIFICANTLY FROM, THE CODE
C * OF THE PROGRAM 'CHIRAL' BY J.G.VINTER, A.DAVIS & P.M. WILLIAMS
C * VERSION 06-06-2024
      USE files
      USE parameters
      USE atomdata
      USE cggt
      IMPLICIT NONE
      INTEGER, PARAMETER         :: NP1  = 20000
      INTEGER, PARAMETER         :: MP7  = 256
      INTEGER                    :: I
      INTEGER                    :: J
      INTEGER                    :: K
      INTEGER                    :: L
      INTEGER                    :: N
      INTEGER                    :: KP
      INTEGER                    :: NC
      INTEGER                    :: NO1
      INTEGER                    :: MSD       ! Maximum Search Depth (def 6)
      INTEGER                    :: LCH       ! Chain Length
      INTEGER                    :: NAT
      INTEGER                    :: NBD       ! Number of Bonds
      INTEGER                    :: NPK
      INTEGER                    :: ILO
      INTEGER                    :: IHP
      INTEGER                    :: NHP
      INTEGER                    :: IHI
      INTEGER                    :: IHYA
      INTEGER                    :: IHYB
      INTEGER                    :: IDUM
      INTEGER                    :: JDUM
      INTEGER                    :: NANG
      INTEGER                    :: NATO
      INTEGER                    :: NOIP
      INTEGER                    :: NOIQ
      INTEGER                    :: ISHL
      INTEGER                    :: IPQ1
      INTEGER                    :: IPQ2
      INTEGER                    :: IMET
      INTEGER                    :: IHINP
      INTEGER                    :: IPNTR
      INTEGER                    :: ISAME
      INTEGER                    :: JSAME
      INTEGER                    :: NSAME
      INTEGER                    :: NCMAX = 4
      INTEGER                    :: NOIPX
      INTEGER                    :: NOIQX
      INTEGER                    :: KCENT     ! Serial # of Chiral? Atom
      INTEGER                    :: ITMP1
      INTEGER                    :: ITMP2
      INTEGER                    :: IBNDO
      INTEGER                    :: ISHLS
      INTEGER                    :: NFOUND
      INTEGER                    :: MAXPAD
      INTEGER                    :: NRCHAIN
      INTEGER                    :: ICHIRAL
      INTEGER                    :: ILOWEST
      INTEGER                    :: ISMPNTR
      INTEGER                    :: IPADMIN
      INTEGER                    :: IPADNUM
      INTEGER                    :: IPADNUMX
      INTEGER                    :: IHIGHEST
      INTEGER, DIMENSION(NP1)    :: NT        ! Relative Weight of Atoms
      INTEGER, DIMENSION(100)    :: JR
      INTEGER, DIMENSION(4)      :: IRP
      INTEGER, DIMENSION(4)      :: IPS
      INTEGER, DIMENSION(9)      :: JRS
      INTEGER, DIMENSION(3, NP1) :: IFG
      INTEGER, DIMENSION(NP10)   :: ITC
      INTEGER, DIMENSION(100)    :: JLN
      INTEGER, DIMENSION(100)    :: NCN
      INTEGER, DIMENSION(NP1)    :: LABA
      INTEGER, DIMENSION(MP7, 3) :: IPPR
      INTEGER, DIMENSION(4)      :: IFTM
      INTEGER, DIMENSION(4)      :: ITMPL
      INTEGER, DIMENSION(5)      :: ISMLST
      INTEGER, DIMENSION(4)      :: IPRIOR
      INTEGER, DIMENSION(4)      :: INPRIOR
      INTEGER, DIMENSION(4)      :: IWPRIOR
      INTEGER, DIMENSION(4)      :: ISHLPRI
      INTEGER, DIMENSION(4)      :: IPATHFOUND
      REAL                       :: D
      REAL                       :: DUM1
      REAL                       :: DUM2
      REAL                       :: DUM3
      REAL                       :: DIST
      REAL                       :: GEN009
      REAL,    DIMENSION(3)      :: V1
      REAL,    DIMENSION(3)      :: V2
      REAL,    DIMENSION(3)      :: V3
      REAL,    DIMENSION(3)      :: V4
      REAL,    DIMENSION(3)      :: V5
      REAL,    DIMENSION(3)      :: V6
      REAL,    DIMENSION(3)      :: V7
      REAL,    DIMENSION(*)      :: BOND
      REAL,    DIMENSION(NP10)   :: DTC
      REAL,    DIMENSION(NP1, 6) :: XXO
      REAL,    DIMENSION(NP1, 9) :: CON
      CHARACTER(len=1)           :: NOTE1
      INTEGER,          ALLOCATABLE, DIMENSION(:) :: NCHAIN
      INTEGER,          ALLOCATABLE, DIMENSION(:) :: NWGT
      CHARACTER(len=6), ALLOCATABLE, DIMENSION(:) :: NQY
      ALLOCATE (NCHAIN(NP67), NWGT(NP1), NQY(NP1))
C * GET NUMBER OF ATOMS IN EXPANDED ATOM LIST
      NAT = IPR(39)
C * COUNTER OF ATOMS INCLUDING PSEUDO ATOMS ADDED BELOW
      NATO = IPR(39)
C * GET NUMBER OF BONDS
      NBD = IPR(131)
C * NCMAX = UP TO NCMAX 'CONNECTIONS' FOR R/S
      NCMAX = 4
C * MSD = MAX SEARCH DEPTH
      MSD = IPR(492)
C * REPORT MAXIMUM SEARCH DEPTH
      IF (IPR(777) == 1) WRITE (LU6, 99988) MSD
C * SAVE XXO, XSD & CON FOR LATER RECOVERY - ARRAYS USED FOR SCRATCH
      CALL PLA269 (1, NAT)
C * GET THE RELATIVE WEIGHTS FOR ORDERING ATOM TYPES ON ATOMIC WEIGHT
      DO I = 1, IAN
        DTC(I) = ATWT(IEN(I))
        ITC(I) = I
      END DO
C * SORT ON ATOMIC WEIGHT (DTC: SMALL TO LARGE)
      CALL GEN036 (DTC, ITC, 1, IAN)
C * LIST ATOM TYPE RELATIVE WEIGHT ENCODING
      IF (IPR(777) == 1) THEN
        WRITE (LU6, 99985)
        DO I = 1, IAN
          WRITE(LU6, 99984) ELB(IEN(ITC(I))), I, DTC(I)
        END DO
C * LIST ATOM SITE WEIGHT ENCODING SCHEME
        WRITE (LU6, 99983)
      END IF
      DO I = 1, IAN
        DTC(I) = ITC(I)
        ITC(I) = I
      END DO
      CALL GEN036 (DTC, ITC, 1, IAN)
C * KEEP MAJOR DISORDER FORM ONLY FOR R/S - ANALYSIS
C * (I.E. POP > 5000 /10000) ELIMINATE MINOR DISORDER FORM
      DO I = 1, NAT
        NC = - NINT (CON(I, 9))
        IF (NC > 0 .AND. NC < 9) THEN
          L = 0
          DO J = 1, NC
            K = NINT (CON(I, J))
C * GET POPULATION PARAMETER
            CALL GEN048 (-8, IFG(2, K), 1, KP)
            KP = IPPR(KP + 1, 1)
            IF (KP > 5000) THEN
              L = L + 1
              CON(I, L) = CON(I, J)
            END IF
          END DO
          NC = L
          CON(I, 9) = - NC
C * ZERO CON(I, J) ENTRIES BETWEEN NC & 9
          IF (NC < 8) THEN
            DO J = NC + 1, 8
              CON(I, J) = 0.0
            END DO
          END IF
        END IF
C * DETERMINE HYBRIDYSATION FOR MAJOR DISORDER FORM
        CALL PLA099 (0, I, NANG, DUM1, DUM2, DUM3, NOTE1)
C * GET RELATIVE WEIGHT FOR ATOM I
        CALL GEN048 (-4, IFG(1, I), 15, IDUM)
C * REGISTER RELATIVE ATOMWEIGHT (1 = lowest)
        NT(I) = ITC(IDUM + 1)
      END DO
C * LOAD BONDS FROM SCRATCH AND ADD DUMMY ATOMS AND CONNECTIONS
C * TO MOLECULE ACCORDING TO BOND ORDER.
C *
C *          |    |                     |    |
C * E.G.   - C == C -     ------>     - C -- C -
C *                                     |    |
C *         IPQ1 IPQ2                   C    C
      N = 0
C * ADD BLANC LINE
      IF (IPR(777) == 1) WRITE (LU6, 99997)
C * LOOP OVER BOND-TYPES
      DO K = 1, 4
C * CARBON-CARBON BONDS
        IF (K == 1) THEN
          NOIPX = 2
          NOIQX = 2
C * OXYGEN CARBON BOND
        ELSE IF (K == 2) THEN
          NOIPX = 3
          NOIQX = 2
C * NITROGEN CARBON BOND
        ELSE IF (K == 3) THEN
          NOIPX = 4
          NOIQX = 2
C * NITROGEN-NITROGEN BOND
        ELSE IF (K == 4) THEN
          NOIPX = 4
          NOIQX = 4
        END IF
        DO I = 1, NBD
          IPQ1 = NINT (BOND(I * 3 - 2))
          IPQ2 = NINT (BOND(I * 3 - 1))
C * GET ELEMENT TYPE OF BONDED ATOMS
          CALL GEN048 (-4, IFG(1, IPQ1), 15, NOIP)
          CALL GEN048 (-4, IFG(1, IPQ2), 15, NOIQ)
          NOIP = IEN(NOIP + 1)
          NOIQ = IEN(NOIQ + 1)
C * GET ATOM LABELS FOR THIS BOND
          IF (NOIP == NOIPX .AND. NOIQ == NOIQX) THEN
            CALL PLA047 (LABA(IPQ1), NQ1, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
            CALL PLA047 (LABA(IPQ2), NQ2, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
C * GET DISTANCE OF BONDED ATOMS
            CALL PLA050 (IPQ1, IPQ2, 0, 0, DIST)
C * GET HYBRIDISATION OF BONDED ATOMS
            CALL GEN048 (-4, IFG(1, IPQ1), 24, IHYA)
            CALL GEN048 (-4, IFG(1, IPQ2), 24, IHYB)
C * TRIPLE BOND
            IF (IHYA == 1 .AND. IHYB == 1) THEN
              IBNDO = 3
C * SP2-SP
            ELSE IF (IHYA * IHYB == 2) THEN
              IBNDO = 2
C * SP2-SP2
            ELSE IF (IHYA == 2 .AND. IHYB == 2) THEN
              IBNDO = 2
C * CHECK C-C BOND DISTANCE
              IF (NOIP == 2 .AND. NOIQ == 2) THEN
                IF (DIST > PAR(384)) IBNDO = 1
C * CHECK N-C BOND DISTANCE
              ELSE IF (NOIP == 4 .AND. NOIQ == 2) THEN
                IF (DIST > 1.35) IBNDO = 1
              END IF
            ELSE
              IBNDO = 1
            END IF
            IF (IBNDO > 1) THEN
              DO J = 2, IBNDO
                ITMP1 = - NINT (CON(IPQ1, 9)) + 1
                ITMP2 = - NINT (CON(IPQ2, 9)) + 1
                IF (ITMP1 <= 4 .AND. ITMP2 <= 4) THEN
                  NATO             = NATO + 1
                  DO L = 1, 8
                    CON(NATO, L) = 0.0
                  END DO
C * ADD ATOM TYPES
                  NT(NATO)         = NT(IPQ2)
                  CON(NATO, 1)     = IPQ1
                  CON(NATO, 9)     = - 1
                  CON(IPQ1, ITMP1) = NATO
                  CON(IPQ1, 9)     = - ITMP1
                  LABA(NATO)       = LABA(IPQ2)
                  NATO             = NATO + 1
C * ADD ATOM TYPES
                  NT(NATO)         = NT(IPQ1)
                  CON(NATO, 1)     = IPQ2
                  CON(NATO, 9)     = - 1
                  CON(IPQ2, ITMP2) = NATO
                  CON(IPQ2, 9)     = - ITMP2
                  LABA(NATO)       = LABA(IPQ1)
C * REPORT ADDED PSEUDO-BOND FOR DOUBLE & TRIPLE BONDS
                  IF (IPR(777) == 1) THEN
                    WRITE (LU6, 99998) NQ1(1:7), NQ2(1:7)
                    N = N + 1
                  END IF
                END IF
              END DO
            END IF
          END IF
        END DO
      END DO
C * ADD BLANC LINE
      IF (N > 0) WRITE (LU6, 99997)
C * GET ATOM NODE WEIGHTS
      DO I = 1, NATO
        NC = - NINT (CON(I, 9))
        IF (NC < 0 ) NC = 9
        NC = MIN (NC, NCMAX)
C * GET PRIORITIES OF BONDED ATOMS
        DO J = 1, NC
          JRS(J) = NT(NINT (CON(I, J)))
        END DO
C * SORT BONDED ATOMS ON THEIR RELATIVE WEIGHT (LARGE TO SMALL)
        CALL GEN022 (JRS, 1, NC, -1)
C * INIT WEIGHT ON RELATIVE WEIGHT OF THE CENTRAL ATOM
        NWGT(I) = NT(I) * 10 ** NCMAX
C * PACK RELATIVE PRIORITIES OF UP TO 4 BONDED ATOMS INTO A SINGLE NUMBER
        DO J = 1, NC
          NWGT(I) = NWGT(I) + JRS(J) * 10 ** (NCMAX - J)
        END DO
        CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, IPR(71), IGBL(55), 0, 0)
        NQY(I) = ' '//NQ1(1:5)
        IF (I > NAT) NQY(I)(1:1) = '*'
      END DO
C * LIST ATOM NODE WEIGHTS
      IF (IPR(777) == 1) THEN
        WRITE (LU6, 99989)
        J = 0
        L = 5
        DO
          WRITE (LU6, 99990) (J + I, NQY(J + I), NWGT(J + I), I = 1, L)
          J = J + 5
          IF (J + 5 > NATO) THEN
            L = NATO - J
            IF (L < 1) EXIT
          END IF
        END DO
      END IF
C * FIND CHIRALITY OF ALL FOUR-COORDINATED ATOMS.
C * KCENT IS THE ATOM WHOS CHIRALITY IS TO BE TESTED
C * MARK ATOMS FOR R/S CANDIDATES
C * ORDER BONDS AROUND ATOM I ON PRIORITY AND SELECT POTENTIAL CHIRAL ATOMS
      DO I = 1, NAT
C * PRESET FOR ACHIRAL
        ICHIRAL = 0
C * GET HYBRIDIZATION
        CALL GEN048 (-4, IFG(1, I), 24, IHYA)
C * TEST FOR METAL
        CALL GEN048 (-1, IFG(1, I), 19, IMET)
C * TEST FOR P & S
        CALL GEN048 (-4, IFG(1, I), 15, NO1)
        NO1 = IEN(NO1 + 1)
C * CONSIDER C, N, Si ONLY
        NC  = - NINT (CON(I, 9))
        IF (NC == 4 .AND. IMET == 0 .AND. IHYA == 3 .and.
     1    NO1 /= 6 .AND. NO1 /= 8) THEN
          N = 0
          DO J = 1, 4
            K = NINT (CON(I, J))
C * CHECK FOR H-ATOM
            CALL GEN048 (-1, IFG(1, K), 7, L)
            N = N + L
          END DO
          IF (N < 2) ICHIRAL = 2
        END IF
        CALL GEN048 (2, IFG(1, I), 28, ICHIRAL)
      END DO
 
      IF (IPR(777) == 1) WRITE (LU6, 99993) MSD
C * MAIN LOOP OVER POTENTIALLY 'CHIRAL' ATOMS
      DO 70 KCENT = 1, NAT
        CALL GEN048 (-2, IFG(1, KCENT), 28, ICHIRAL)
        IF (ICHIRAL == 2) THEN
          CALL PLA047 (LABA(KCENT), NQ1, IDUM, JDUM,
     1      IPR(71), IGBL(55), 0, 0)
 
C * ASSIGN INITIAL PRIORITIES TO THE DIRECTLY CONNECTED ATOMS
          DO I = 1, 4
            J          = NINT (CON(KCENT, I))
            INPRIOR(I) = J
            IWPRIOR(I) = NWGT(J)
          END DO
C * SORT PRIORITIES (LOW TO HIGH WEIGHT) AND FIND THOSE THAT ARE SAME
C * IWPRIOR = 1,2,3,or 4; INPRIOR = SEQUENCE NUMBER IN ATOM LIST
          CALL GEN033 (IWPRIOR, INPRIOR, 1, 4)
          IF (IPR(777) == 1) WRITE (LU6, 99994) NQY(KCENT),
     1      (I, INPRIOR(I), NQY(INPRIOR(I)), NWGT(INPRIOR(I)), I = 1, 4)
C * DECIDE ORDER FOR ATOMS WITH SAME PRIORITY
C * ISMLST REGISTERS NSAME ATOM LIST SEQUENCE NUMBERS
 
C * ZERO ARRAY
          CALL GEN097 (ISMLST, 1, 5, 0)
          ISMPNTR = 1
          ISHLS   = 1
C * MAIN PRIORITY LOOP FOR THIS POTENTIALLY CHIRAL ATOM
C * FIND SAME PRIORITIES CASES IN PRIORITY LIST
          DO
            NSAME     = 1
            ISMLST(1) = INPRIOR(ISMPNTR)
            IF (ISMPNTR < 4) THEN
              DO I = 1, 4 - ISMPNTR
                IF (IWPRIOR(ISMPNTR + I) /= IWPRIOR(ISMPNTR)) EXIT
                ISMLST(I + 1) = INPRIOR(ISMPNTR + I)
                NSAME         = NSAME + 1
              END DO
            END IF
            IF (NSAME > 1) THEN
C * REPORT SAME LIST ATOM LABELS
              IF (IPR(777) == 1)
     1          WRITE (LU6, 99996) (NQY(ISMLST(I)), I = 1, NSAME)
C * SET THE PACKING SIZE, NPK, IN THE LINEAR NCHAIN ARRAY, FOR THE SET OF
C *   CHAINS TO BE COMPARED FOR PRECEDENCE.
C * MSD = MAXIMUM CHAIN DEPTH, NSAME = NUMBER OF CHAINS TO BE COMPARED
              NPK    = (MSD + 1) * NSAME
              MAXPAD = NP67 / NPK
              CALL GEN097 (NCHAIN, 1, NP67, 0)
C * EACH PATH IS STORED SEQUENTIALLY IN A BLOCK OF (MSD + 1) * NSAME ENTRIES
C *   REFERENCES TO ATOMS IN THE ATOM LIST. MSD = Maximum Search Depth
C * AN ADDITIONAL BLOCK OF LENGTH NSAME STORES THE CHAIN LENGTH (EXCLUDING
C * BLOCKS CONTAINS UP TO 4 REFERENCES TO BE COMPARED.
C * |path1|path2|path3|....|pathK|                 K = Number of path's
C *    I                                               for NSAME ATOM
C *    V
C * |shell1|shell2|shell3|....|shell-msd|L|        msd = Max Search Depths
C *    I                              I
C *    V                              V
C * |atom1|..|atom-nsame|     |l1|..|l-nsame|      lN = ChainLength
C * ASSIGN PRIORITIES TO ATOMS OF SIMILAR PRIORITY USING PATHS
C * FROM THESE ATOMS AS PER IUPAC CHIRAL RULES.
C * FIND ALL PATHS FROM ATOMS IN ISMLST.
C * THIS IS THE SLOW BIT AS ALL PATHS MUST BE FOUND FIRST SO THAT
C * THEY CAN BE ORDERED AND TRAVERSED IN DESCENDING ORDER OR PRIORITY.
C * ZERO ARRAY
              IPADMIN = 99
C * BEGIN ISAME LOOP
              DO ISAME = 1, NSAME
                IHINP = 0
C * MARK OUTGOING AND CLOSING BONDS IN TETRAEDER AS TRAVERSED
C * INCLUDE BASE-ATOM
                ISMLST(NSAME + 1) = KCENT
                IPRIOR(ISAME)     = 0
C * SEQUENCE NUMBER OF PATH
                IPADNUM           = 0
                JR(1)             = KCENT
                JR(2)             = ISMLST(ISAME)
                LCH               = 1
                DO
                  LCH = LCH + 1
C * LCH = CHAIN LENGTH, MSD = MAX SEARCH DEPTH/CHAIN LENGTH (IPR(492)
                  IF (LCH <= MSD) THEN
C * HANDLE CLOSURE
                    IF (LCH > 3) THEN
                      DO K = LCH - 3, 1, -1
                          IF (JR(LCH) == JR(K)) GO TO 10
                      END DO
                    END IF
                    NC = - NINT (CON(JR(LCH), 9))
                    IF (NC < 0) NC = 9
C * CHECK FOR/HANDLE TERMINAL H-ATOM
                    IF (NC /= 1) THEN
                      NCN(LCH) = NC
                      JLN(LCH) = 0
                      GO TO 20
                    END IF
                  END IF
C * END-OF-CHAIN REACHED COPY/STORE THIS CHAIN (JR)
   10             DO I = 2, LCH
                    NCHAIN(IPADNUM * NPK + (I - 2) * NSAME + ISAME) =
     1                JR(I)
                  END DO
C * STORE PATH-LENGTH
                  LCH = LCH - 1
                  NCHAIN(IPADNUM * NPK + MSD * NSAME + ISAME) = LCH
                  IPADNUM = IPADNUM + 1
C * NO NEXT ATOM FOUND - START A NEW PATH. FIND LAST BRANCH POINT IN
C * LAST PATH WHERE THE NEW PATH CAN DIVERT FROM.
C * REGISTER GLOBAL MAXIMUM PATH_LENGTH
                  IHINP = MAX (IHINP, LCH)
                  IF (IPADNUM == MAXPAD) THEN
                    IPR(126) = IPR(126) + 1
                    WRITE (LU6, 99999, IOSTAT = IOST) MAXPAD
                    ISMLST(1) = -1
                    GO TO 60
                  END IF
C * RETRACE
   20             IF (LCH <= 1) EXIT
                  JLN(LCH) = JLN(LCH) + 1
                  IF (JLN(LCH) > NCN(LCH)) THEN
                    LCH = LCH - 1
                    GO TO 20
                  END IF
                  JR(LCH + 1) = NINT (CON(JR(LCH), JLN(LCH)))
C * AVOID BACK-LOOP
                  IF (JR(LCH + 1) == JR(LCH - 1)) GO TO 20
                  IF (LCH <= 0) EXIT
                END DO
C * NO MORE PATHS FROM THIS START ATOM. FIND LENGTH OF LONGEST
C * PATH AND SORT PATHS INTO DECREASING ORDER OR PRIORITY.
C * ORDER ATOM SHELLS IN REVERSE DIRECTION.
                IPADMIN  = MIN (IPADMIN, IPADNUM)
                IPADNUMX = IPADNUM
C * BEGIN ISHL LOOP
                DO ISHL = IHINP, 2, -1
C * SORT ONE SHELL
                  CALL PLA031 (NQY, IPADNUMX, NWGT, NPK, ISAME, IHINP,
     1              NSAME, MSD, IPADNUM, ISHL, NCHAIN, JR, ISMLST)
                END DO
C * END ISHL LOOP
              END DO
C * END ISAME LOOP
C * NOW THAT WE HAVE FOUND ALL THE PATHS FROM THE NSAME ATOMS, LET'S START
C * GOING OUT THROUGH THE PATHS IN PRIORITY ORDER UNTIL WE FIND A DIFFERENCE ..
C * AND HENCE ASSIGN PRIORITY.
C * BEGIN NRCHAIN LOOP
              DO NRCHAIN = -1, IPADMIN - 2
C * ZERO ARRAY IPATHFOUND & IPS
                CALL GEN097 (IPATHFOUND, 1, NSAME, 0)
                CALL GEN097 (IPS,        1, NSAME, 0)
                CALL GEN097 (IPRIOR,     1, NSAME, 0)
C * FIND MAXIMUM LENGTH OF PATH FOR THE NSAME PRIORITIES
                IHP = 0
C * BEGIN ISAME LOOP
                DO ISAME = 1, NSAME
                  IPS(ISAME) = IPS(ISAME) + 1
                  NHP = NCHAIN((IPS(ISAME) + NRCHAIN) * NPK
     1                + MSD * NSAME + ISAME)
                  IHP = MAX (IHP, NHP)
                END DO
C * END ISAME LOOP
C * EXIT FOR THIS ATOM WHEN MAX CHAINLENGTH LESS 2
                IF (IHP < 2) GO TO 70
C * LOOP OVER SHELLS OUTWARDS TO MAX LENGTH
                DO ISHL = 2, IHP
                  ISHLS = ISHL
C * DETERMINE MAXIMUM NUMBER OF CONNECTIONS
   30             NCMAX = 0
C * BEGIN ISAME LOOP
                  DO ISAME = 1, NSAME
                    IPNTR = NCHAIN((IPS(ISAME) + NRCHAIN) * NPK
     1                    + (ISHL - 1) * NSAME + ISAME)
C * GET/SAVE POINTER TO ATOM
                    IRP(ISAME) = IPNTR
                    IF (ISAME == NSAME) THEN
                      IF (IPR(777) == 1) WRITE (LU6, 99986) NRCHAIN + 2,
     1                ISHL, (NQY(IRP(I)), NWGT(IRP(I)), I = 1, NSAME)
                      IF (IRP(2) == IRP(1)) THEN
                        IF (IRP(1) <= 0) GO TO 60
                        CALL PLA047 (LABA(IRP(1)), NQ1, IDUM, JDUM,
     1                    IPR(71),IGBL(55), 0, 0)
C * Closure Message
                        IF (IPR(777) == 1) WRITE (LU6, 99995) NQ1
                        GO TO 45
                        DO I = 1, NSAME
                          DO
                            IPS(I) = IPS(I) + 1
                            N = NCHAIN(IPS(I) * NPK + (ISHL - 1)
     1                        * NSAME + I)
                            IF (N == 0) GO TO 70
                            IF (N /= IRP(1)) EXIT
                          END DO
                        END DO
                        GOTO 30
                      ELSE
                        IF (IRP(1) <= 0) THEN
                          IF (IPR(777) == 1)
     1                      WRITE (LU6,'(''Problem 2'')')
                          GO TO 60
                        END IF
                        CALL PLA047 (LABA(IRP(1)), NQ1, IDUM, JDUM,
     1                    IPR(71),IGBL(55), 0, 0)
                        IF (IRP(2) <= 0) THEN
                          IF (IPR(777) == 1)
     1                      WRITE (LU6,'(''Problem 3'')')
                          GO TO 60
                        END IF
                        CALL PLA047 (LABA(IRP(2)), NQ2, IDUM, JDUM,
     1                    IPR(71),IGBL(55), 0, 0)
                      END IF
                    END IF
                    IF (IPNTR > 0) THEN
                      IF (NINT (CON(IPNTR, 9)) < - NCMAX) THEN
                        NCMAX = - NINT (CON(IPNTR, 9))
C * ESCAPE TO ? ASSIGNMENT
                        IF (NCMAX > 4) THEN
                          IF (IPR(777) == 1)
     1                      WRITE (LU6, 99982) NQY(IPNTR)
                          GO TO 60
                        END IF
                      END IF
                    END IF
                  END DO
C * END OF ISAME LOOP
                  DO ISAME = 1, NSAME
                    IF (IPATHFOUND(ISAME) == 0) THEN
                      ISHLPRI(ISAME) = 0
                      IPNTR = NCHAIN((IPS(ISAME) + NRCHAIN) * NPK
     1                      + (ISHL - 1) * NSAME + ISAME)
                      IF (IPNTR > 0) ISHLPRI(ISAME) = NWGT(IPNTR)
                    END IF
                  END DO
C * END ISAME LOOP
C * FIND WHICH ATOMS IN THE PATHS AT THE CURRENT SHELL LEVEL HAVE
C * A UNIQUE PRIORITY AND FLAG THEM.
                  NFOUND = 0
C * BEGIN ISAME LOOP
                  DO 40 ISAME = 1, NSAME
                    IF (IPATHFOUND(ISAME) == 1) THEN
                      NFOUND = NFOUND + 1
                    ELSE
C * BEGIN JSAME LOOP
                      DO JSAME = 1, NSAME
                        IF (ISAME /= JSAME) THEN
                          IF (ISHLPRI(ISAME) == ISHLPRI(JSAME)
     1                      .AND. IPATHFOUND(JSAME) == 0) GO TO 40
                        END IF
                      END DO
C * END JSAME LOOP
                      IPATHFOUND(ISAME) = 1
                      NFOUND            = NFOUND + 1
                      IFTM(ISAME)       = ISHL
                    END IF
   40             CONTINUE
C * END ISAME LOOP
C * INSERT UNIQUE PATHS IN PRIORITY LIST FOR CHIRAL ATOM.
C * BEGIN ISAME LOOP
                  DO ISAME = 1, NSAME
                    ILOWEST  = ISHLPRI(1) + 1
                    IHIGHEST = 0
                    IHI      = 1
                    ILO      = 1
C * BEGIN JSAME LOOP
                    DO JSAME = 1, NSAME
                      IF (ISHLPRI(JSAME) > IHIGHEST) THEN
                        IHI      = JSAME
                        IHIGHEST = ISHLPRI(JSAME)
                      END IF
                      IF (ISHLPRI(JSAME) < ILOWEST .AND.
     1                    ISHLPRI(JSAME) /= -1) THEN
                        ILO     = JSAME
                        ILOWEST = ISHLPRI(JSAME)
                      END IF
                    END DO
C * END JSAME LOOP
                    IF (IHIGHEST /= 0 .AND. IPATHFOUND(IHI) == 1 .AND.
     1                IFTM(IHI) == ISHL) THEN
C * BEGIN JSAME LOOP
                      DO JSAME = 1, NSAME
                        IF (IPRIOR(JSAME) == 0) THEN
                          IPRIOR(JSAME) = IHI
                          ISHLPRI(IHI)  = -1
                          EXIT
                        END IF
                      END DO
C * END  JSAME LOOP
                    END IF
                    IF (ILOWEST /= 0 .AND. IPATHFOUND(ILO) == 1 .AND.
     1                IFTM(ILO) == ISHL) THEN
C * BEGIN JSAME LOOP
                      DO JSAME = NSAME, 1, -1
                        IF (IPRIOR(JSAME) == 0) THEN
                          IPRIOR(JSAME) = ILO
                          ISHLPRI(ILO)  = - 1
                          EXIT
                        END IF
                      END DO
C * END JSAME LOOP
                    END IF
                  END DO
C * END ISAME LOOP
                  IF (IPR(777) == 1 .AND. NFOUND == NSAME)
     1              WRITE (LU6, 99987)
     2              NFOUND, (NQY(ISMLST(IPRIOR(I))), I = 1, NSAME)
C * HAVE WE ASSIGNED A PRIORITY TO ALL THE PATHS.
                  IF (NFOUND == NSAME) THEN
C * SORT ISMLST INTO PRIORITY ORDER AND RETURN.
                    DO ISAME = 1, NSAME
C * TEMP FIX FOR ILL UNDERSTOOD PROBLEM
                      IF (IPRIOR(ISAME) < 1 .OR. IPRIOR(ISAME) > 4) THEN
                        WRITE (LU6, '(''R/S DET PROBLEM'')')
                        GO TO 60
                      END IF
                      ITMPL(ISAME) = ISMLST(IPRIOR(ISAME))
                    END DO
                    DO ISAME = 1, NSAME
                      ISMLST(ISAME) = ITMPL(ISAME)
                    END DO
                    DO ISAME = 1, NSAME
                      IF (ISMLST(ISAME) < 0) GO TO 70
                    END DO
                    GO TO 50
                  END IF
C * NO, WE HAVEN'T, SO INCREASE SHELL AND DO AGAIN.
                END DO
C * END OF ISHL LOOP
C * IF WE GET HERE THEN TWO PATHS ARE IDENTICAL SO GO ON TO
C * NEXT SET OF PATHS FROM START ATOM.
   45           CONTINUE
              END DO
C * END OF NRCHAIN LOOP
C * NO DIFFERENCES FOUND IN ANY OF THE PATHS FROM TWO OR MORE ATOMS
C * SO RETURN NO CHIRALITY.
              IF (IPR(777) == 1) WRITE (LU6, 99992)
              GO TO 70
            END IF
C * ADD THE NEXT NSAME PRIORITY ENTRIES TO THE PRIORITY LIST
   50       DO I = 1, NSAME
              INPRIOR(ISMPNTR + I - 1) = ISMLST(NSAME    - I + 1)
              IWPRIOR(ISMPNTR + I - 1) = NT(ISMLST(NSAME - I + 1))
            END DO
            ISMPNTR = ISMPNTR + NSAME
            IF (ISMPNTR > 4) EXIT
          END DO
C * END MAIN POTENTIALLY CHIRAL ATOM LOOP
C * WE HAVE A CHIRAL CENTRE.  CLOCKWISE OR ANTI-CLOCKWISE ?
          DO I = 1, 3
            V1(I) = XXO(INPRIOR(4), I + 3)
            V2(I) = XXO(INPRIOR(3), I + 3)
            V3(I) = XXO(INPRIOR(2), I + 3)
            V4(I) = XXO(INPRIOR(1), I + 3)
          END DO
C * CALCULATE THE EQUATION OF THE PLANE PASSING THROUGH
C * THE THREE HIGHEST PRIORITY ATOMS DEFINE IN DECREASING ORDER.
          CALL GEN008 (V2, V3, V5, 0)
          D =  GEN009 (V1, V5)
          CALL GEN008 (V1, V2, V6, 0)
          CALL GEN015 (V5, V6, V7, 1.0)
          CALL GEN008 (V3, V1, V6, 0)
          CALL GEN015 (V6, V7, V5, 1.0)
C * V5 AND D DEFINE THE PLANE.  NOW CALCULATE THE DISTANCE OF THE FOURTH
C * (LOWEST PRIORITY) ATOM FROM THIS PLANE.
C * THE LENGTH, D,  OF THIS LINE IS IRRELEVANT, BUT, THE SIGN INDICATES
C * CHIRALITY.  - EQUALS S, + EQUALS R
          IF (GEN009 (V4, V5) < D) THEN
            ICHIRAL = 1
            NQ2     = 'S'
          ELSE
            ICHIRAL = 3
            NQ2     = 'R'
          END IF
          IF (IABS (2 - ICHIRAL) == 1) IPR(583) = IPR(583) + 1
C * LIST CHIRAL SEQUENCE
          IF (IPR(777) == 1) WRITE (LU6, 99991) ISHLS + 1, NQ2(1:1),
     1      NQY(KCENT), (NQY(INPRIOR(5 - J)), J = 1, 4)
        END IF
C * ICHIRAL 1 = S, 2 = ?, 3 = R
   60   CALL GEN048 (2, IFG(1, KCENT), 28, ICHIRAL)
   70 CONTINUE
C * ADD BLANC LINE
      IF (IPR(777) == 1) WRITE (LU6, 99997)
      DEALLOCATE (NCHAIN, NWGT, NQY)
C * GET LABUTE ATOM TOPOLOGY NUMBERS
      CALL PLA032 (NAT, NATO, NT, IFG, CON)
C * RECOVER XXO, XSD, CON FROM SCRATCH
      CALL PLA269 (-1, NAT)
C * SET RETURN VALUE WHEN IN R/S OPTION MODE
      IF (IPR(777) == 1) IGBL(1) = 4
      RETURN
99999 FORMAT (':: MAXPATH = ', I4, ' EXCEEDED')
99998 FORMAT (':: PSEUDO-BOND(S) AND ATOMS ADDED TO: ', A, '& ', A,
     1        'FOR R/S DETERMINATION')
99997 FORMAT (1X)
99996 FORMAT (/, 'SAME LIST: ', 4A)
99995 FORMAT (/, 'Closure on ', A, '(No RS)')
99994 FORMAT (/, 80('='), /,
     1        'SORTED (SMALL TO LARGE) INITIAL PRIORITY FOR ', A,
     2        /, 80('='), /, ' I PRIOR  LABEL WPRIOR', /,
     3        22('='), 4(/,I2, I6, 1X, A, I7), /, 80('='))
99993 FORMAT (/, 'Shell 1 to', I3, ' R/S Tests', /, 23('='))
99992 FORMAT (/, 'Insufficient Differences')
99991 FORMAT (/, 'Chiral Shell =', I2, ' - (', A,') ', A, ': ',
     1        3(A, ' >> '), A, /)
99990 FORMAT (5(I4, A, I5, ','))
99989 FORMAT ('Atom_Node_Weights (# in atom list, Label, Weight)')
99988 FORMAT (/, ':: R/S - Assignment - Maximum Search Depth =', I3,
     1        ' shells', //, '   *** Use Keyboard Instruction, CIP n,',
     2        ' for Search Depth up to n Shells ***')
99987 FORMAT (/, 'NFOUND =', I2, ', FINAL SAME LIST ORDER = ', 4A)
99986 FORMAT (/, 'Compare Chain(', I2, ') - Shell(', I2, ') ',
     1        4(A, I6, ','))
99985 FORMAT (/, 'Relative Atom_Type_Weight Encoding')
99984 FORMAT (A, ' =', I3, F10.2)
99983 FORMAT (/, 'Atom_Node_Weight Encoding: nijkl, Where n = Atom_',
     1       'Type_Weight of the Node Atom', /, 'and i,j,k,l Those of ',
     2       'the Atom_type_Weight Sorted Node Coordinating Atoms')
99982 FORMAT (/, 'ABORT! ', A, 'has more than 4 connections')
      END SUBROUTINE PLA030
 
      SUBROUTINE PLA031 (NQY, IPADNUMX, NWGT, NPK, ISAME, IHINP, NSAME,
     1  MSD, IPADNUM, ISHL, NCHAIN, JR, ISMLST)
 
C * ROUTINE TO SORT ONE SHELL OF ALL THE PATHS INTO DECREASING ORDER
C * OF PRIORITY AT THE CURRENT ISHL LEVEL.
C * SORT PRIORITES OF NSAME PATHS AT SHELL ISHL STARTING AT ISMPNTR.
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER, PARAMETER                 :: NP1 = 20000
      INTEGER                            :: I
      INTEGER                            :: J
      INTEGER                            :: K
      INTEGER                            :: L
      INTEGER                            :: M
      INTEGER                            :: I1
      INTEGER                            :: I2
      INTEGER                            :: I3
      INTEGER                            :: I4
      INTEGER                            :: I5
      INTEGER                            :: MSD
      INTEGER                            :: NPK
      INTEGER                            :: ISHL
      INTEGER                            :: IHINP
      INTEGER                            :: ISAME
      INTEGER                            :: NSAME
      INTEGER                            :: IPADNUM
      INTEGER                            :: IPADNUMX
      INTEGER, DIMENSION(100)            :: JR
      INTEGER, DIMENSION(*)              :: NWGT
      INTEGER, DIMENSION(*)              :: NCHAIN
      INTEGER, DIMENSION(5)              :: ISMLST
      CHARACTER(len=6), DIMENSION(NP1)   :: NQY
      DO J = 2, IPADNUMX
C * GET SERIAL NUMBER IN ATOM LIST
        I1 = NCHAIN((J - 1) * NPK + (ISHL - 1) * NSAME + ISAME)
C * GET THE LENGTH OF CHAIN # J
        I2 = NCHAIN((J - 1) * NPK +        MSD * NSAME + ISAME)
        I3 = 0
        IF (I1 > 0) I3 = NWGT(I1)
C * COPY CHAIN #J
        DO K = 1, IHINP
          JR(K) = NCHAIN((J - 1) * NPK + (K - 1) * NSAME + ISAME)
        END DO
        DO I = J - 1, 1, -1
          I4 = NCHAIN((I - 1) * NPK + (ISHL - 1) * NSAME + ISAME)
          I5 = 0
          IF (I4 > 0) I5 = NWGT(I4)
C * CHECK WHETHER PREVIOUS CHAIN HAS A >= TYPE VALUE
          IF (I5 >= I3) GO TO 30
          DO K = 1, IHINP
            NCHAIN(I       * NPK + (K - 1) * NSAME + ISAME) =
     1      NCHAIN((I - 1) * NPK + (K - 1) * NSAME + ISAME)
          END DO
          NCHAIN(I       * NPK + MSD * NSAME + ISAME) =
     1    NCHAIN((I - 1) * NPK + MSD * NSAME + ISAME)
        END DO
        I = 0
   30   NCHAIN(I * NPK + (ISHL - 1) * NSAME + ISAME) = I1
        DO K = 1, IHINP
          NCHAIN(I * NPK  + (K - 1) * NSAME + ISAME) = JR(K)
        END DO
        NCHAIN(I * NPK + MSD * NSAME + ISAME) = I2
      END DO
      M = NCHAIN((ISHL - 1) * NSAME + ISAME)
      IF (M > 0) M = NWGT(M)
C * LIST CHAINS FOR THIS ATOM, HIGHEST PRIORITY FIRST
      IF (IPR(777) == 1 .AND. ISHL == 2) THEN
        WRITE (LU6, 99999) NQY(ISMLST(ISAME))
        DO K = 0, IPADNUM - 1
          M = NCHAIN(K * NPK + MSD * NSAME + ISAME)
          DO L = 1, M
            JR(L) = NCHAIN(K * NPK + (L - 1) * NSAME + ISAME)
          END DO
          WRITE (LU6, 99998) K + 1, (NQY(JR(I)), NWGT(JR(I)), I = 1, M)
        END DO
      END IF
      RETURN
99999 FORMAT (/, 'SORTED CHAINS for ', A, /, 5X, 'I', 11X, 'II', 10X,
     1        'III', 9X, 'IV', 10X, 'V', 11X, 'VI', 10X, 'VII')
99998 FORMAT (I2, ': ', 10(A, I5, ','))
      END SUBROUTINE PLA031
 
      SUBROUTINE PLA032 (NAT, NATO, NT, IFG, CON)
C * LABUTE ALGORITHM FOR THE ASSIGNMENT OF A TOPOLOGY NUMBER TO ATOMS
      USE parameters
      IMPLICIT NONE
      INTEGER, PARAMETER         :: NP1  = 20000
      INTEGER                    :: I
      INTEGER                    :: J
      INTEGER                    :: K
      INTEGER                    :: M
      INTEGER                    :: N
      INTEGER                    :: NC
      INTEGER                    :: NVX
      INTEGER                    :: NAT
      INTEGER                    :: MPG
      INTEGER                    :: NVB
      INTEGER                    :: MPRI
      INTEGER                    :: IPTM
      INTEGER                    :: NATO
      INTEGER                    :: IVAL
      INTEGER                    :: ISORT
      INTEGER, DIMENSION(NP1)    :: NT        ! Relative Weight of Atoms
      INTEGER, DIMENSION(9)      :: INL
      INTEGER, DIMENSION(9)      :: LST
      INTEGER, DIMENSION(3, NP1) :: IFG
      INTEGER, DIMENSION(9)      :: INB
      INTEGER, DIMENSION(9)      :: INE
      REAL,    DIMENSION(NP1, 9) :: CON
      INTEGER, ALLOCATABLE, DIMENSION(:)   :: NCHAIN
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPTR
      ALLOCATE (NCHAIN(NP67), IPTR(2, NP1))
 
      IF (IGBL(3) /= 33 .AND. IGBL(3) /= 34 .AND.
     1  NATO * 8 <= NP67) THEN
C * ZERO
        CALL GEN097 (NCHAIN, 1, NP67, 0)
C * INIT SORTING
        INB(1) = 1
        INE(1) = NATO
        DO I = INB(1), INE(1)
          NCHAIN ((I - 1) * 8 + 1) = NT(I)
          IPTR (1, I) = NT(I)
          IPTR (2, I) = I
        END DO
C * PRELIMINARY SORT ON ATOM TYPE
        CALL GEN037 (IPTR, INB(1), INE(1))
C * LOAD WEIGHTS OF NC CONNECTED ATOMS (IN POS 2 - NC + 1)
        MPG = 0
   10   DO I = INB(1), INE(1)
          NC = - NINT (CON(I, 9))
          IF (NC < 0 .OR. NC > 6) NC = 6
          IF (NC > 0) THEN
            DO J = 1, NC
              LST(J) = NT(NINT (CON(I, J)))
            END DO
            CALL GEN022 (LST, 1, NC, 1)
            DO K = 1, NC
              NCHAIN((I - 1) * 8 + K + 1) = LST (NC + 1 - K)
            END DO
          END IF
        END DO
C * SORT PRIORITIES
        M          = 1
        MPRI       = 1
   20   INL(M)     = INB(M) - 1
        INB(M + 1) = INB(M)
        N          = NCHAIN((IPTR(2, INB(M)) - 1) * 8 + M)
        NVB        = NCHAIN((IPTR(2, INB(M)) - 1) * 8 + M + 1)
        ISORT      = 0
C * LOAD SORT ITEM
   30   INL(M) = INL(M)  + 1
        IF (INL(M) <= INE(M)) THEN
          IPTM = IPTR(2, INL(M))
          IF (NCHAIN((IPTM - 1) * 8 + M) == N) THEN
            NVX             = NCHAIN ((IPTM - 1) * 8 + M + 1)
            IPTR(1, INL(M)) = NVX
            IF (NVX /= NVB) ISORT = 1
            NT(IPTM) = MPRI
            GO TO 30
          END IF
        END IF
        INE(M + 1) = INL(M) - 1
C * SORT
        IF (ISORT == 1) THEN
          CALL GEN037 (IPTR, INB(M + 1), INE(M + 1))
        ELSE
          IF (NVB == 0) GO TO 40
        END IF
C * ??????  (EXIT LOOP)
        DO K = 1, NATO
          I = IPTR(2, K)
          DO J = 1, 6
            IF (NCHAIN((I - 1) * 8 + J) == 0) EXIT
          END DO
        END DO
        IF (M < 8) THEN
          M = M + 1
          GO TO 20
        END IF
   40   INB(M + 1) = INL(M)
        IF (INB(M + 1) <= INE(M)) THEN
          N      = NCHAIN((IPTR(2, INB(M + 1)) - 1) * 8 + M)
          NVB    = NCHAIN((IPTR(2, INB(M + 1)) - 1) * 8 + M + 1)
          ISORT  = 0
          MPRI   = MPRI + 1
          INL(M) = INL(M) - 1
          GO TO 30
        ELSE
          M = M - 1
          IF (M /= 0) GO TO 40
          IF (MPRI > MPG) THEN
            MPG = MPRI
            GO TO 10
          END IF
          DO K = 1, NAT
            IVAL = NT(K)
            CALL GEN048 (10, IFG(2, K), 14, IVAL)
          END DO
        END IF
      END IF
      DO I = 1, NAT
        CALL GEN048 (-2, IFG(1, I), 28, K)
        IF (K == 2) K = 0
        CALL GEN048 ( 2, IFG(1, I), 28, K)
      END DO
      DEALLOCATE (NCHAIN, IPTR)
      RETURN
      END SUBROUTINE PLA032
 
      SUBROUTINE PLA033 (NJ, NK)
C *   SUPPORT ROUTINE FOR NEWMAN PROJECTIONS
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: NJ
      INTEGER               :: NK
      INTEGER               :: ISH
      INTEGER               :: NTYP
      REAL                  :: XR
      REAL                  :: YR
      REAL                  :: ZR
      REAL                  :: XR0
      REAL                  :: YR0
      REAL                  :: ZR0
      REAL                  :: DEN
      REAL                  :: DELX
      REAL                  :: DELY
      REAL, DIMENSION(3, 3) :: YUNK
      NTYP = -1
      IF (NJ /= 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 < 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
        END IF
        RMAT(3, 2) = 0.0
        CALL GEN008 (RMAT(1, 2), RMAT(1, 3), RMAT(1, 1), 1)
C * TRANSPOSE
        CALL GEN005 (RMAT, YUNK)
C * COPY MATRIX
        CALL GEN052 (YUNK, RMAT)
        M = 0
        DO I = 1, NJ
          N = NINT (CON(J, I))
          IF (N /= K) THEN
            M = M + 1
            IATC(M) = N + NP1
          END IF
        END DO
        DO I = 1, NK
          N = NINT (CON(K, I))
          IF (N /= J) THEN
            M = M + 1
            IATC(M) = N
          END IF
        END DO
C * ROTATION
        CALL PLA044 (RMAT, J, XR0, YR0, ZR0, 0.0, 0.0, 0.0, 1.0, 0.0)
        DO I = 1, M
          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) > 0.00001) THEN
            DATC(I) = ATAN2 (YR, XR) * RGBL(6)
            IF (DATC(I) < 0.0) DATC(I) = DATC(I) + 360.0
          END IF
        END DO
        CALL GEN036 (DATC, IATC, 1, M)
        ISH           = (IPR(60) - 1) * 60
        IATP(1 + ISH) = M
        IATP(2 + ISH) = J
        IATP(3 + ISH) = K
        DO I = 1, M
          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)))
        END DO
        DO I = 2, M
          DO J = 1, 6
            DELX = PAR(24) * ABS (COS (IATP(I + 38 + ISH) / RGBL(6))
     1       - COS (IATP(I + 37 + ISH) / RGBL(6)))
            DELY = PAR(24) * ABS (SIN (IATP(I + 38 + ISH) / RGBL(6))
     1       - SIN (IATP(I + 37 + ISH) / RGBL(6)))
            IF (4.5 * DELX > 6.0 * PAR(25) .OR.
     1          4.5 * DELY > PAR(25)) EXIT
            IATP(I + 38 + ISH) = IATP(I + 38 + ISH) + 1
            IATP(I + 37 + ISH) = IATP(I + 37 + ISH) - 1
          END DO
        END DO
        IATP(M + 4  + ISH) = IATC(1)
        IATP(M + 21 + ISH) = IATP(21 + ISH) + 36000
        IF (IPR(60) /= 4) RETURN
      END IF
      WRITE (LU8) NTYP, IPR(60), JR, RMAT
      WRITE (LU8) (IATP(L), L = 1, 240)
      IPR(60) = 0
      RETURN
      END SUBROUTINE PLA033
 
      SUBROUTINE PLA034 (NRSD)
C * GENERATE TORSION ANGLES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: M
      INTEGER           :: KB
      INTEGER           :: NJ
      INTEGER           :: NK
      INTEGER           :: KB1
      INTEGER           :: LAT
      INTEGER           :: NCJ
      INTEGER           :: NCK
      INTEGER           :: ISA
      INTEGER           :: NHB
      INTEGER           :: IHB
      INTEGER           :: NAT
      INTEGER           :: MTL
      INTEGER           :: IER
      INTEGER           :: IFT
      INTEGER           :: IHA
      INTEGER           :: IHI
      INTEGER           :: IHJ
      INTEGER           :: IHK
      INTEGER           :: IHL
      INTEGER           :: IAT
      INTEGER           :: JAT
      INTEGER           :: KAT
      INTEGER           :: JATL
      INTEGER           :: KATL
      INTEGER           :: IVAL
      INTEGER           :: IVLT
      INTEGER           :: JHYB
      INTEGER           :: JMET
      INTEGER           :: KHYB
      INTEGER           :: KMET
      INTEGER           :: NRSD
      INTEGER           :: NTOR
      INTEGER           :: IDS1
      INTEGER           :: IDS2
      INTEGER           :: IDS3
      INTEGER           :: IDS4
      INTEGER           :: ISP1
      INTEGER           :: ISP2
      INTEGER           :: ISP3
      INTEGER           :: ISP4
      INTEGER           :: NDEC
      INTEGER           :: IRESJ
      INTEGER           :: ITEST
      INTEGER           :: MNUM1
      INTEGER           :: MNUM2
      INTEGER           :: MNUM3
      INTEGER           :: MNUM4
      REAL              :: A
      REAL              :: SA
      CHARACTER(len=73) :: FORMX
      SA   = 0.0
      ISA  = 0
      IER  = 0
      NDEC = 0
      IF (IPR(8) > 0) THEN
        IPR(60) = 0
        NAT     = IPR(37)
        MTL     = 3
        NTOR    = 0
        KB      = 0
C * PREPARE PRINT FORMAT
        FORMX(1 :4)  = '(1X,'
        FORMX(5:24)  = '4(A),F8.2,''('',I3,'')'''
        FORMX(25:48) = ',4X,'//FORMX(5:24)
        FORMX(49:73) = FORMX(25:48)//')'
C * H & NON-H ATOM LOOP
        DO NHB = 1, 2
          IHB = NHB - 1
C * GENERATE BLANK LINE TO SEPARATE OUT H-ATOM ENTRIES
          IF (IHB == 1 .AND. IGBL(63) > 2) THEN
            CALL PLA262 (1)
            WRITE (LU7, '( )', IOSTAT = IOST)
          END IF
          DO 30 JAT = 1, NAT
            JR(2) = JAT
C * TRUNCATE
            JATL  = LABA(JAT) / IPR(463)
C * TEST RESIDUE NUMBER
            CALL GEN048 (-6, IFG(1, JAT), 9, IRESJ)
            IF (IRESJ /= NRSD) GO TO 30
C * GET H(,D)-ATOM BIT
            CALL GEN048 (-1, IFG(1, JAT), 7, IHJ)
            NJ = - NINT (CON(JAT, 9))
            IF (NJ < 0) THEN
              NJ = 9
              CALL GEN048 (-1, IFG(1, JAT), 8, IVAL)
              IF (IVAL > 0) NJ = NJ + IPR(76)
            END IF
            IF (NJ <= 1) GO TO 30
            DO 20 J = 1, NJ
              IF (J <= 9) THEN
                KAT = NINT (CON(JAT, J))
              ELSE
                IF (IBON(J - 9, 1) /= JAT) GO TO 20
                KAT = IBON(J - 9, 2)
              END IF
              JR(3) = KAT
C * TRUNCATE
              KATL = LABA(KAT) / IPR(463)
              IF (JATL > KATL) GO TO 20
              NK = - NINT (CON(KAT, 9))
              IF (NK < 0) THEN
                NK = 9
                CALL GEN048 (-1, IFG(1, KAT), 8, IVAL)
                IF (IVAL > 0) NK = NK + IPR(76)
              END IF
              IF (NK <= 1) GO TO 20
              CALL GEN048 (-1, IFG(1, KAT), 7,  IHK)
C * GENERATE NEWMAN-PROJECTION DATA FOR THIS BOND WITH COORDN LE IPR(163)
              IF (NJ <= IPR(163) .AND. NK <= IPR(163))
     1           CALL PLA033 (NJ, NK)
              DO 10 I = 1, NJ
                IF (I <= 9) THEN
                  IAT = NINT (CON(JAT, I))
                ELSE
                  IF (IBON(I - 9, 1) /= JAT) GO TO 10
                  IAT = IBON(I - 9, 2)
                END IF
                JR(1) = IAT
                IF (IAT == KAT) GO TO 10
                CALL GEN048 (-1, IFG(1, IAT), 7,  IHI)
                DO K = 1, NK
                  IF (K <= 9) THEN
                    LAT = NINT (CON(KAT, K))
                  ELSE
                    IF (IBON(K - 9, 1) /= KAT) CYCLE
                    LAT = IBON(K - 9, 2)
                  END IF
                  JR(4) = LAT
                  IF (LAT == JAT) CYCLE
                  IF (IAT == LAT) CYCLE
                  CALL GEN048 (-1, IFG(1, LAT), 7, IHL)
                  IHA = IHI + IHJ + IHK + IHL
                  IF (IHB == 0) THEN
                    IF (IHA > 0) CYCLE
                  ELSE
                    IF (IHA == 0) CYCLE
                  END IF
                  KB1 = KB + 1
                  CALL PLA036 (IAT, KB1, 1, IDS1, MNUM1, ISP1,
     1                         IPR(71), IGBL(55))
C * SKIP MINOR DISORDER ATOMS
                  IF (IDS1 < 5000) GO TO 10
                  CALL PLA036 (JAT, KB1, 2, IDS2, MNUM2, ISP2,
     1                         IPR(71), IGBL(55))
C * SKIP MINOR DISORDER ATOMS
                  IF (IDS2 < 5000) GO TO 30
                  CALL PLA036 (KAT, KB1, 3, IDS3, MNUM3, ISP3,
     1                         IPR(71), IGBL(55))
C * SKIP MINOR DISORDER ATOMS
                  IF (IDS3 < 5000) GO TO 20
                  CALL PLA036 (LAT, KB1, 4, IDS4, MNUM4, ISP4,
     1                         IPR(71), IGBL(55))
C * SKIP MINOR DISORDER ATOMS
                  IF (IDS4 < 5000) CYCLE
                  IVLT = 0
                  IF (MNUM1 > 1) THEN
                    IVLT = IVLT + 1
                  END IF
                  IF (MNUM2 > 1) THEN
                    IVLT = IVLT + 1
                  END IF
                  IF (MNUM3 > 1) THEN
                    IVLT = IVLT + 1
                  END IF
                  IF (MNUM4 > 1) THEN
                    IVLT = IVLT + 1
                  END IF
                  ITEST = (4 - ISP1 - ISP2 - ISP3 - ISP4) / 2
                  IF (IVLT > ITEST) CYCLE
C * SKIP PSEUDO-LINEAR I,J,K,L = ANGLES I,J,K AND J,K,L > PAR(15) DEG.
                  CALL PLA050 (IAT, JAT, KAT, 0, A)
                  IF (A > PAR(15)) CYCLE
                  CALL PLA050 (JAT, KAT, LAT, 0, A)
                  IF (A > PAR(15)) CYCLE
C * AVOID SPECIAL DISORDER CASES
                  CALL PLA053 (IAT, JAT, KAT, LAT, A, SA, ISA,
     1                         NDEC, IER)
                  IF (IER /= 0) CYCLE
C * SAVE IN LINE BUFFER - WE PRINT MTL TORSION ANGLES PER LINE
                  KB        = KB + 1
                  NTOR      = NTOR + 1
                  DBUF(KB)  = A
                  IDBUF(KB) = ISA
                  IFT       = -11 + KB * 24
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
                  FORMX(IFT : IFT) = CHAR (ICHAR ('0') + NDEC)
C * CHECK FOR OMEGA-FILE WRITE
                  IF (IPR(438) == 1) THEN
                    IF(IPR(430) <= 0 .OR. IHA == 0) THEN
                      IPR(253) = IPR(253) + 1
                      WRITE (LU2, 99998, IOSTAT = IOST)
     1                  (NAMS(KB, M)(2:8), M = 1, 4), A, SA
                    END IF
                  END IF
C * VALIDATE TORSION ANGLE FOR X-C-C-H (METHYL)
                  CALL GEN048 (-3, IFG(2, KAT), 24, KMET)
                  CALL GEN048 (-4, IFG(1, KAT), 24, KHYB)
                  NCK = NINT (CON(KAT, 9))
                  CALL GEN048 (-3, IFG(2, JAT), 24, JMET)
                  CALL GEN048 (-4, IFG(1, JAT), 24, JHYB)
                  NCJ = NINT (CON(JAT, 9))
                  IF (NCK == -4) THEN
                    IF (KMET == 3 .AND. JHYB == 2) THEN
                      IF (180.0 - ABS (A) < 0.15) THEN
C * ALERT _380
                        CALL PLA236 (380, 2, -999.0, 1.0,
     1                    NAMS(KB, 3)(2:10), ' ')
                      END IF
                    END IF
                  END IF
                  IF (NCJ == -4) THEN
                    IF (JMET == 3 .AND. KHYB == 2) THEN
                      IF (180.0 - ABS (A) < 0.15) THEN
C * ALERT _380
                        CALL PLA236 (380, 2, -999.0, 1.0,
     1                    NAMS(KB, 2)(2:10), ' ')
                      END IF
                    END IF
                  END IF
C * TEST FOR PRINTING OF RESIDUE AND TORSION ANGLE HEADER
                  IF (NTOR == 1) THEN
                    IF (IPR(134) == 1) THEN
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99999, IOSTAT = IOST) NRSD
                      END IF
                      IPR(134) = 0
                    END IF
                    IF (IGBL(63) > 2) THEN
                      CALL PLA262 (3)
                      WRITE (LU7, 99997, IOSTAT = IOST) '>', PAR(15)
                    END IF
                  END IF
                  IF (KB < MTL) CYCLE
                  IF (IGBL(63) > 2) THEN
                    WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1                ((NAMS(L, M)(2:8), M = 1, 4),
     2                DBUF(L), IDBUF(L), L = 1, MTL)
                    CALL PLA263 (LU7, PRBUF, 132, 1, 3)
                  END IF
                  KB = 0
                END DO
   10         CONTINUE
   20       CONTINUE
   30     CONTINUE
C * CLEAR BUFFER
          IF (KB > 0) THEN
            IF (IGBL(63) > 2) THEN
              WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1          ((NAMS(L, M)(2:8), M = 1, 4),
     2          DBUF(L), IDBUF(L), L = 1, KB)
              CALL PLA263 (LU7, PRBUF, 132, 1, 3)
            END IF
            KB = 0
          END IF
        END DO
C * SUPPORT NEWMAN - PROJECTIONS
        IF (IPR(60) /= 0) CALL PLA033 (0, 0)
      END IF
      RETURN
99999 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='))
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('='))
      END SUBROUTINE PLA034
 
      SUBROUTINE PLA035
C * ANALYSE METAL - RING GEOMETRY
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: IP
      INTEGER                  :: IR
      INTEGER                  :: NM
      INTEGER                  :: MN
      INTEGER                  :: MM
      INTEGER                  :: IER
      INTEGER                  :: IFT
      INTEGER                  :: LBB
      INTEGER                  :: LBC
      INTEGER                  :: LBD
      INTEGER                  :: MET
      INTEGER                  :: NAT
      INTEGER                  :: KRC
      INTEGER                  :: NRT
      INTEGER                  :: NDC
      INTEGER                  :: KAT
      INTEGER                  :: KAT1
      INTEGER                  :: IENM
      INTEGER                  :: NRAT
      INTEGER                  :: NRES
      INTEGER                  :: NIEN
      INTEGER                  :: NDCJ
      INTEGER                  :: NDEC
      INTEGER                  :: JDUM
      INTEGER                  :: IDUM
      INTEGER                  :: IDUM1
      INTEGER                  :: IDUM2
      INTEGER                  :: NDECJ
      INTEGER                  :: INQNR
      INTEGER                  :: JNQNR
      INTEGER                  :: KMETAL
      INTEGER, DIMENSION(9)    :: IXMD
      INTEGER, DIMENSION(6)    :: ICSD
      REAL                     :: DSH
      REAL                     :: YUNK
      REAL                     :: DCEN
      REAL                     :: DIST
      REAL                     :: DPERP
      REAL,    DIMENSION(9, 2) :: XMD
      CHARACTER(len=160)       :: FORMX
      CHARACTER(len=79)        :: FORMI
      CHARACTER(len=68)        :: FORMJ
C * PREPARE PRINT FORMAT
      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)
      FORMX(  1: 15) = '('' From: '',A   '
      FORMX( 16: 31) = ',F8.4,''('',I3,'')'''
      FORMX( 32: 79) = FORMX(16:31)//FORMX(16:31)//FORMX(16:31)
      FORMX( 80:127) = FORMX(32:79)
      FORMX(128:160) = FORMX(16:31)//FORMX(16:31)//')'
      NRAT     = IPR(12)
      NAT      = IPR(39)
      IPR(64)  = IPR(64) + 1
C * NEW CG# ATOM DATA POINTER
      KRC      = NAT + IPR(64)
C * COPY FLAGS FOR Cg# FROM ATOM JR(1) = FIRST RING ATOM
      DO I = 1, 3
        IFG(I, KRC) = IFG(I, JR(1))
      END DO
C * COPY TRNS CODE
      NTRNS(KRC) = NTRNS(JR(1))
C * GET RESIDUE NUMBER
      CALL GEN048 (-6, IFG(1, KRC), 9, NRES)
C * GENERATE NEW LABEL CGnm (CORRESPONDING TO PLANE NUMBER)
      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             INQNR, JNQNR, NIEN)
C * STORE ELEMENT TYPE IN FLAG ARRAY
      CALL GEN048 (6, IFG(1, KRC), 15, NIEN)
C * STORE Cg# LABEL
      LABA(KRC) = INQNR
C * UNPACK LABEL-CODE CLEANLY
      CALL PLA047 (INQNR, NQ1, MN, JDUM, IPR(71), IGBL(55), 0, 0)
C * ROUND AND PRINT CENTROID COORDINATES
      DO 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
C * MODIFY NUMBER OF DECIMAL DIGITS
        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))
      END DO
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (1)
        WRITE (LU7, '(/)', IOSTAT = IOST)
        WRITE (PRBUF, FORMI, IOSTAT = IOST)
     1    NQ1(1:6), (XXO(KRC, K), ICSD(K), K = 1, 3)
        CALL PLA263 (LU7, PRBUF, 132, 1, 3)
        WRITE (PRBUF, FORMJ, IOSTAT = IOST)
     1    (XXO(KRC, K), ICSD(K), K = 4, 6)
        CALL PLA263 (LU7, PRBUF, 132, 1, 3)
      END IF
      IF (NRAT <= 7) THEN
C * STORE CG# FOR PRINTING AS LAST ENTRY(NRAT)
        NRAT          = NRAT + 1
        NAMS(NRAT, 1) = ' '//NQ1(1:NP64-1)
        NRT           = NRAT + 1
        NAMS(NRT, 1)  = '  RING '
        NM = 0
C * LOOP OVER ALL ATOMS TO FIND SHORT METAL-RING INTERACTIONS
        DO 120 I = 1, NAT
          CALL GEN048 (-1, IFG(1, I), 19, MET)
          IF (MET == 0) GO TO 120
          JR(NRAT)    = KRC
C * TEST DISTANCE TO RING-CENTROID
          CALL PLA050 (I, KRC, 0, 0, DCEN)
          IF (DCEN > PAR(422)) GO TO 120
C * GET LABEL OF METAL ATOM
          CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, IPR(71),
     1      IGBL(55), 0, 0)
C * CALCULATE LEAST-SQUARES PLANE TROUGH RING
          CALL PLA055
C * CALCULATE PERPENDICULAR METAL-RING DISTANCE
          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.0 * XMD(NRT, 2)))
C * GET METAL TO RING-ATOM DISTANCES (INCLUDING CG#)
          DO J = 1, NRAT
            CALL PLA053 (I, JR(J), 0, 0, XMD(J, 1), XMD(J, 2),
     1                  IXMD(J), NDEC, IER)
            IF (IER == 0) THEN
C * SKIP THIS CALCULATION WHEN METAL IS PART OF THE RING
              IF (XMD(J, 1) < PAR(12)) GO TO 120
              IFT = 4 + J * 16
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
              FORMX(IFT : IFT) = CHAR (ICHAR ('0') + NDEC)
            END IF
          END DO
C * CALCULATE AND ANALYSE RING-SLIPPAGE PARAMETER
          DPERP = - XPV(4)
          DO J = 1, 3
            DPERP = DPERP + XPV(J) * XXO(I, J + 3)
          END DO
          DSH = SQRT (MAX (0.0, DCEN**2 - ABS (DPERP)**2))
C * SKIP UNINTERESTING CASES
          IF (DSH > PAR(423) .OR. ABS (DPERP) < PAR(424)) GO TO 120
C * LIST RING SLIPPAGE RESULTS
          IF (IGBL(63) > 2) THEN
            NM = NM + 1
C * PRINT HEADER LINE
            IF (NM == 1) THEN
              WRITE (LU7, 99998, IOSTAT = IOST)
     1          PAR(422), PAR(424), PAR(423)
              WRITE (LU7, 99997, IOSTAT = IOST)
     1          (NAMS(J, 1)(2:7), J = 1, NRT)
              WRITE (LU7, 99996, IOSTAT = IOST)
            END IF
C * PRINT DISTANCE LINE
            WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1         NQ1(1:7), (XMD(J, 1), IXMD(J), J = 1, NRT)
            CALL PLA263 (LU7, PRBUF, 132, 1, 3)
C * PRINT RING SLIPPAGE SHIFT
            WRITE (LU7, 99999, IOSTAT = IOST) DSH
          END IF
C * REPLACE Me-Ring ATOM BONDS BY ONE DASHED LINE TO CENTRE OF GRAVITY
          IF (DSH < PAR(70)) THEN
C * CG-ATOM REFERENCE IS 'KRC' AND TRANSFORMED IN 'KAT'
C * LOAD METAL AS LAST ENTRY FOR SYMMETRY TRANSFORMATION
            JR(NRAT) = I
            DO MM = 1, IPR(51)
              IF (MM == 1) THEN
                DO J = 2, NRAT
                  CALL PLA268 (JR(NRAT), JR(J - 1), -1, -1.0)
                END DO
C * ADD METAL-CG BOND
                CALL PLA268 (JR(NRAT), KRC, 1, -1.0)
              ELSE
                CALL GEN098 (MOL(MM), PAR(42), IPR(54),
     1               ITR(1), ITR(2), ITR(3), IR)
                IF (NRES == IR) THEN
                  KAT       = IPR(39) + IPR(64) + 1
                  IF (MN > IPR(463)) THEN
                    IPR(2) = 54
                    GO TO 130
                  END IF
                  LABA(KAT) = LABA(KRC) + MM - 1
C * IS THIS A NEW CG ?
                  DO J = 1, IPR(64)
                    IF (LABA(KAT) == LABA(IPR(39) + J)) THEN
                      KAT = IPR(39) + J
                      GO TO 70
                    END IF
                  END DO
                  IPR(64) = IPR(64) + 1
                  CALL PLA059 (KRC, KAT)
C * COPY FLAGS
                  DO J = 1, 3
                    IFG(J, KAT) = IFG(J, KRC)
                  END DO
C * STORE COORDINATES (AND ESD'S) ALSO IN BACKING STORE 'VOID'
                  DO J = 1, 6
                    VOID((KAT - 1) * NP71 + J)     = XXO(KAT, J)
                    VOID((KAT - 1) * NP71 + J + 6) = XSD(KAT, J)
                  END DO
C * SET RESIDUE NUMBER OF TRANSFORMED CG EQUAL TO CURRENT
                  CALL GEN048 (6, IFG(1, KAT), 9, IR)
C * FIND TRANSFORMED ATOMS (RING + METAL)
   70             DO 100 J = 1, NRAT
C * GET TRANSFORMATION CODE
                    KAT1 = KAT + 1
                    CALL PLA059 (JR(NRAT + 1 - J), KAT1)
                    DO K = 1, NAT
                      CALL PLA050 (K, KAT1, 0, 0, DIST)
                      IF (DIST < 0.05) THEN
                        IF (J == 1) THEN
                          KMETAL = K
C * ADD METAL-CG BOND
                          CALL PLA268 (KMETAL, KAT, 1, -1.0)
                        ELSE
C * DELETE INDIVIDUAL METAL-C BOND
                          CALL PLA268 (KMETAL, K, -1, -1.0)
                        END IF
                        GO TO 100
                      ENDIF
                    END DO
  100             CONTINUE
                END IF
              END IF
            END DO
          END IF
  120   CONTINUE
      END IF
  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) < ',
     1 F5.1, ' Ang., d(perp) > ', F5.1, ' Ang., Slippage < ',
     2 F6.3, ' Ang.]', /, 10X, 102('='), /)
99997 FORMAT ('Distance (Ang) to:', 1X, A, 8(7X, A))
99996 FORMAT (132('-'))
      END SUBROUTINE PLA035
 
      SUBROUTINE PLA036 (IAT, KB, NA, IDS, MNUM, ISPOS, IPAR, IALIAS)
C * GET DISORDER INFORMATION IN NAMS(,,)
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: NA
      INTEGER             :: KB
      INTEGER             :: IAT
      INTEGER             :: IDS
      INTEGER             :: IPAR
      INTEGER             :: MNUM
      INTEGER             :: JDUM
      INTEGER             :: ILABI
      INTEGER             :: ISPOS
      INTEGER             :: IALIAS
      INTEGER             :: NAMDIS
      CHARACTER(len=NP64) :: NQ
      I = IABS(IAT)
      IF (IAT > 0) THEN
        ILABI =   LABA(I)
      ELSE
        ILABI = - LABA(I)
      END IF
C * GET SPECIAL POSITION FLAG
      CALL GEN048 (-1, IFG(1, I), 6, ISPOS)
C * GET DISORDER INFORMATION
      CALL GEN048 (-8, IFG(2, I), 1, IDS)
      IDS = IPPR(IDS + 1, 1)
      IF (IDS == 10000) THEN
        NAMDIS = ICHAR (' ')
      ELSE IF (IDS > 5000) THEN
        NAMDIS = ICHAR ('>')
      ELSE IF (IDS == 5000) THEN
        NAMDIS = ICHAR ('*')
      ELSE
        NAMDIS = ICHAR ('<')
      END IF
      CALL PLA047 (ILABI, NQ, MNUM, JDUM, IPAR, IALIAS, 0,
     1  1 - IALIAS)
      NAMS(KB, NA) = CHAR (NAMDIS)//NQ(1:NP64-1)
      RETURN
      END SUBROUTINE PLA036
 
      SUBROUTINE PLA037 (K, N, M)
C * ANALYSIS OF ATOM LABEL FOR ATOM TYPE/SERIAL NUMBER
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: M
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: NIEN
      INTEGER :: IENM
      INTEGER :: INQNR
      INTEGER :: JNQNR
C * RETURN VALUE N > 0 : ELEMENT
C *              N < 0 : ATOM NR
C *              N = 0 : ERROR
C *              M = 2 : SEARCH IN PRIMARY ATOM ARRAY
C *              M = 3 : SEARCH IN EXPANDED ARRAY
      NQ0 = IFL(K)(1:7)
C * IS THIS AN ELEMENT LABEL ?
      IF (NQ0(3:3) == ' ') THEN
C * TRANSFORM ATOM TYPE FROM ASCII TO NUMBER n * 100 + m
        DO I = 1, 26
          IF (NQ0(1:1) == CHAR (ICHAR ('A') + I - 1)) THEN
            N = I * 100
            IF (NQ0(2:2) == ' ') GO TO 10
            DO J = 1, 26
              IF (NQ0(2:2) == CHAR (ICHAR ('A') + J - 1)) THEN
                N =  N + J
                GO TO 10
              END IF
            END DO
            GO TO 20
          END IF
        END DO
C * GET ELEMENT NUMBER (POINTER IN ARRAY IEN)
   10   DO J = 1, IAN
          IF (N == IEL(IEN(J))) THEN
            N = J
            RETURN
          END IF
        END DO
      END IF
C * NO ELEMENT NAME, NOW LOOK FOR POSSIBLE ATOM LABEL
   20 N = 0
C * GET NUMBER OF UNIQUE ATOMS
      CALL PLA046 (M, NQ0, IENM, LBB, LBC, LBD,
     1             INQNR, JNQNR, NIEN)
      IF (NIEN < 0) THEN
C * UNSUITABLE ATOM LABEL
        IPR(2) = 3
      ELSE
        N = - NIEN
      END IF
      RETURN
      END SUBROUTINE PLA037
 
      SUBROUTINE PLA038 (IAT, JAT, IFIN)
C * SUBROUTINE GENERATES SEQUENCE OF UNIQUE BONDS (IAT, JAT)
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER       :: K
      INTEGER       :: KJ
      INTEGER, SAVE :: NC
      INTEGER, SAVE :: KI
      INTEGER, SAVE :: IX
      INTEGER, SAVE :: NAT
      INTEGER       :: IAT
      INTEGER       :: JAT
      INTEGER       :: KAT
      INTEGER       :: NEL
      INTEGER       :: NCI
      INTEGER       :: NCJ
      INTEGER       :: IHA
      INTEGER       :: IVAL
      INTEGER       :: JUNK
      INTEGER       :: IFIN
      INTEGER       :: LABJ
      INTEGER       :: IENJ
      INTEGER       :: IDUM
      INTEGER, SAVE :: IENI
      INTEGER, SAVE :: LABI
      INTEGER, SAVE :: IMET
      INTEGER, SAVE :: JMET
      INTEGER       :: NDIST
      INTEGER, SAVE :: IATNRI
      REAL          :: DIST
C * INITIALIZED BY IFIN = -3, -2, -1 ; END SIGNAL WITH IFIN = 1 ON RETURN
C * NON-INIT MODE
      IF (IFIN == 0) THEN
        GO TO 20
C * INIT MODE IFIN = -3 (ALL ATOMS, BOND-LABELS)
      ELSE IF (IFIN == -3) THEN
        NAT = IPR(39)
        IX  = 0
C * INIT MODE IFIN = -2 (ALL ATOMS)
      ELSE IF (IFIN == -2) THEN
        NAT = IPR(39)
        IX  = 1
C * INIT MODE IFIN = -1 (UNIQUE ATOMS, BOND-LABELS)
      ELSE
        NAT = IPR(37)
        IX  = 0
      END IF
      IFIN = 0
      IMET = 0
      JMET = 0
      IENI = 0
      IAT  = 0
   10 IAT  = IAT + 1
      IF (IAT > NAT) THEN
        IFIN = 1
        RETURN
      END IF
C * TEST FOR H-ATOM IDENTIFICATION BIT
      CALL GEN048 (-1, IFG(1, IAT), 7, IHA)
      IF (IHA == 1) GO TO 10
      CALL GEN048 (-1, IFG(1, IAT), 19, IMET)
C * GET ELEMENT TYPE FOR ATOM IAT
      CALL PLA047 (LABA(IAT), NQ1, IDUM, IENI, IPR(71), IGBL(55),
     1  0, 1 - IGBL(55))
      IF (IX == 0) THEN
        IATNRI = IATNR(IENI)
        LABI   = LABA(IAT) / IPR(463)
      END IF
      NC = - NINT (CON(IAT, 9))
      IF (NC == 0) THEN
        GO TO 10
      ELSE IF (NC < 0) THEN
        NC = 9
C * TEST FOR MORE THAN 9 CONNECTIONS
        CALL GEN048 (-1, IFG(1, IAT), 8, IVAL)
        IF (IVAL > 0) NC = NC + IPR(76)
      END IF
C * LOOP OVER CONNECTIONS
      KI = 0
   20 KI = KI + 1
      IF (KI > NC) GO TO 10
      IF (KI <= 9) THEN
        JAT = NINT (CON(IAT, KI))
      ELSE
        IF (IBON(KI - 9, 1) == IAT) THEN
          JAT = IBON(KI - 9, 2)
        ELSE
          GO TO 20
        END IF
      END IF
C * TEST HYDROGEN ATOM IDENTIFICATION BIT ATOM JAT
      IF (IPR(133) >= 0) THEN
        IF (JAT == 0) GO TO 20
        CALL GEN048 (-1, IFG(1, JAT), 7, IHA)
        IF (IHA /= IPR(133)) GO TO 20
      END IF
C * GET ATOM TYPE FOR ATOM JAT
      CALL PLA047 (LABA(JAT), NQ2, IDUM, IENJ, IPR(71), IGBL(55),
     1     0, 1 - IGBL(55))
      CALL GEN048 (-1, IFG(1, JAT), 19, JMET)
C * HANDLE X-C-O2 .. Metal Bonds
      IF (IMET == 1 .AND. IENJ == 2 .OR.
     1    JMET == 1 .AND. IENI == 2) THEN
        NDIST = 0
C * CHECK FOR C
        IF (IENJ == 2) THEN
          NCJ   = - NINT (CON(JAT, 9))
          DO KJ = 1, NCJ
            KAT = NINT (CON(JAT, KJ))
            CALL GEN048 (-4, IFG(1, KAT), 15, NEL)
            NEL = IEN(NEL + 1)
C * TEST FOR O
            IF (NEL == 3) THEN
              CALL PLA050 (IAT, KAT, 0, 0, DIST)
              IF (IENI > 0) THEN
                IF (DIST < REL(IENI) + 1.10) NDIST = NDIST + 1
              END IF
            END IF
          END DO
          IF (NDIST >= 2) GO TO 20
        ELSE
          NCI = - NINT (CON(IAT, 9))
          DO K = 1, NCI
            KAT = NINT (CON(IAT, K))
            CALL GEN048 (-4, IFG(1, KAT), 15, NEL)
            NEL = IEN(NEL + 1)
C * TEST FOR O
            IF (NEL == 3) THEN
              CALL PLA050 (JAT, KAT, 0, 0, DIST)
              IF (DIST < REL(IENJ) + 1.20) NDIST = NDIST + 1
            END IF
          END DO
          IF (NDIST >= 2) GO TO 20
        END IF
      END IF
      IF (IX == 0) THEN
        JUNK = IATNRI - IATNR(IENJ)
        IF (JUNK < 0) THEN
          GO TO 20
        ELSE IF (JUNK == 0) THEN
          LABJ = LABA(JAT) / IPR(463)
          IF (LABI > LABJ) GO TO 20
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA038
 
      SUBROUTINE PLA039 (IAT, JAT, KAT, NRSD, A, SA, ISA, ND, KB, IFIN)
C * GENERATE ANGLES FROM CONN ARRAY
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER, SAVE :: NC
      INTEGER, SAVE :: KI
      INTEGER, SAVE :: KJ
      INTEGER       :: ND
      INTEGER       :: KB
      INTEGER       :: KB1
      INTEGER       :: IER
      INTEGER       :: IHA
      INTEGER       :: IAT
      INTEGER       :: JAT
      INTEGER       :: KAT
      INTEGER       :: ISA
      INTEGER, SAVE :: IHI
      INTEGER, SAVE :: IHJ
      INTEGER, SAVE :: IHK
      INTEGER, SAVE :: NAT
      INTEGER       :: ISP1
      INTEGER       :: ISP2
      INTEGER       :: ISP3
      INTEGER       :: IVAL
      INTEGER       :: NRSD
      INTEGER       :: IFIN
      INTEGER       :: IDS1
      INTEGER       :: IDS2
      INTEGER       :: IDS3
      INTEGER       :: IRESJ
      INTEGER       :: MNUM1
      INTEGER       :: MNUM2
      INTEGER       :: MNUM3
      REAL          :: A
      REAL          :: SA
      REAL          :: A1
      ND  = 0
      ISA = 0
      IER = 0
      A   = 0.0
      SA  = 0.0
      IF (IFIN == 0) THEN
        GO TO 30
      ELSE IF (IFIN == -1) THEN
        NAT = IPR(37)
      END IF
      IFIN = 0
      JAT  = 0
   10 JAT  = JAT + 1
      IF (JAT > NAT) THEN
        IFIN = 1
        RETURN
      END IF
C * GET H-ATOM BIT
      CALL GEN048 (-1, IFG(1, JAT), 7,  IHJ)
      IF (IHJ == 1) GO TO 10
C * GET RESIDUE NUMBER AND CHECK WITH CURRENT RESIDUE NUMBER
      CALL GEN048 (-6, IFG(1, JAT), 9, IRESJ)
      IF (IRESJ /= NRSD) GO TO 10
C * GET AND CHECK FOR > 1 NUMBER OF CONNECTIONS FOR THIS JAT ATOM
      NC = - NINT(CON(JAT, 9))
      IF (NC < 0) THEN
        NC = 9
C * TEST FOR MORE THAN 9 CONNECTIONS
        CALL GEN048 (-1, IFG(1, JAT), 8, IVAL)
        IF (IVAL > 0) NC = NC + IPR(76)
      END IF
      IF (NC <= 1) GO TO 10
      KI = 0
   20 KI = KI + 1
      IF (KI >= NC) GO TO 10
      IF (KI <= 9) THEN
        IAT = NINT (CON(JAT, KI))
      ELSE
        IF (IBON(KI - 9, 1) /= JAT) GO TO 20
        IAT = IBON(KI - 9, 2)
      END IF
      KJ = KI
C * GET H-ATOM BIT
      CALL GEN048 (-1, IFG(1, IAT), 7,  IHI)
   30 KJ = KJ + 1
      IF (KJ > NC) GO TO 20
      IF (KJ <= 9) THEN
        KAT = NINT (CON(JAT, KJ))
      ELSE
        IF (IBON(KJ - 9, 1) /= JAT) GO TO 30
        KAT = IBON(KJ - 9, 2)
      END IF
C * GET H-ATOM FLAG
      CALL GEN048 (-1, IFG(1, KAT), 7,  IHK)
      IHA  = IHI + IHJ + IHK
      IF (IPR(133) == 0) THEN
        IF (IHA > 0) GO TO 30
      ELSE
        IF (IHA == 0) GO TO 30
      END IF
      KB1 = KB + 1
C * GET LABEL/DISORDER/SYMMETRY-FLAG INFORMATION
      CALL PLA036 (IAT, KB1, 1, IDS1, MNUM1, ISP1, IPR(71), IGBL(55))
      CALL PLA036 (JAT, KB1, 2, IDS2, MNUM2, ISP2, IPR(71), IGBL(55))
      CALL PLA036 (KAT, KB1, 3, IDS3, MNUM3, ISP3, IPR(71), IGBL(55))
C * ELIMINATE CERTAIN DISORDER-DATA
      IF (IDS1 < 10000 .AND. IDS3 < 10000) THEN
        IF (IDS1 /= IDS3) GO TO 30
        IF (IDS2 < 10000) THEN
          IF (IDS1 /= IDS2 .OR. IDS2 /= IDS3) GO TO 30
        END IF
      END IF
      CALL PLA053 (IAT, JAT, KAT, 0, A, SA, ISA, ND, IER)
      IF (IER /= 0) GO TO 30
C * HANDLE SPECIAL CASE OF 180 DEGREES (INVERSION/ MIRROR)
      IF (ISP2 == 1 .AND. MNUM3 > 1) THEN
        CALL PLA050 (IAT, JAT, KAT, 0, A1)
        IF (ABS (A1) > 179.9) THEN
          A  = 180.0
          SA = 0.0
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA039
 
      SUBROUTINE PLA040 (MODE, IAT, IVAL, KAT)
C * MANAGE CONN ARRAY
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: K
      INTEGER :: L
      INTEGER :: NC
      INTEGER :: IVL
      INTEGER :: IAT
      INTEGER :: KAT
      INTEGER :: MODE
      INTEGER :: IVAL
C * BRANCH FOR GET, INITIALIZE OR STORAGE OF CONNECTION
      IF (MODE < 0) THEN
C * GET CONNECTION
        NC = - NINT (CON(IAT, 9))
C * BRANCH FOR >= 9, 0, < 9 BONDS FOR ATOM IAT
        IF (NC /= 0) THEN
          IF (NC < 0) THEN
            NC = 9
            CALL GEN048 (-1, IFG(1, IAT), 8, IVL)
            IF (IVL > 0) NC = NC + IPR(76)
          END IF
          DO L = 1, NC
            IF (L > 9) THEN
              IF (IBON(L - 9, 1) /= IAT) CYCLE
              IF (IBON(L - 9, 2) == KAT) THEN
                IVAL = L
                RETURN
              END IF
            ELSE
              IF (NINT (CON(IAT, L)) == KAT) THEN
                IVAL = L
                RETURN
              END IF
            END IF
          END DO
        END IF
        IVAL = 0
      ELSE IF (MODE == 0) THEN
C * RESET CONNECTIVITY
        DO K = IAT, IVAL
          CON(K, 9) = KAT
        END DO
      ELSE
C * STORE CONNECTION (INCREASE # BONDS IPR(147)
        IVAL = 0
        IPR(147) = IPR(147) + 1
        IF (CON(IAT, 9) > 0) THEN
          CALL GEN048 (1, IFG(1, IAT), 8, 1)
          IF (IPR(76) /= IPR(96)) THEN
            IPR(76)          = IPR(76) + 1
            IBON(IPR(76), 1) = IAT
            IBON(IPR(76), 2) = KAT
            IVAL             = 9 + IPR(76)
          END IF
        ELSE
          CON(IAT, 9)  =   CON(IAT, 9) - 1
          IVAL           = - NINT (CON(IAT, 9))
          CON(IAT, IVAL) =   KAT
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA040
 
      SUBROUTINE PLA041 (IATPR, N)
C * SPECIAL ME..O,N ETC. TEST
      USE parameters
 
      IMPLICIT NONE
      INTEGER :: N
      INTEGER :: IATPR
      INTEGER :: IPRM
      INTEGER :: IPRN
      INTEGER :: ITST
      IPRN = IPR(509 + N)
C * CHECK FOR CU, AG, CR, CO, MN, TI, NI, ZN, TL
      IF (IPRN == 10 .OR. IPRN == 11 .OR.
     1    IPRN == 13 .OR. IPRN == 30 .OR.
     2    IPRN == 31 .OR. IPRN == 59 .OR.
     3    IPRN == 94 .OR. IPRN == 95 .OR.
     4    IPRN == 103) THEN
            IPRM = IPRN
C * (EARTH)ALKALI
      ELSE IF (IATPR == 5 .OR. IATPR == 6) THEN
            IPRM = 1
      ELSE IF (IPR(325) == 1 .AND. IATPR < 0) THEN
        IF (IPRN == 3 .OR. IPRN == 4) THEN
          IPRM = - IPRN
        ELSE
          IPRM = -1
        END IF
C * NON-METAL (ORGANIC) CASE
      ELSE IF (IPR(325) == 0 .AND. IATPR < 0) THEN
C * CHECK FOR O, N, Cl
        IF (IPRN >= 3 .AND. IPRN <= 5) THEN
          IPRM = - IPRN
        ELSE
          IPRM = -1
        END IF
C * NON-METAL - NON- HALOGEN (ORGANIC) CASE
      ELSE IF (IPR(325) == -1 .AND. IATPR == -1) THEN
C * TEST FOR O, N
        IF (IPRN == 3 .OR. IPRN == 4) THEN
          IPRM = - IPRN
        ELSE
          IPRM = -1
        END IF
      ELSE
        IPRM = 0
      END IF
      IPR(157 + N) = IPRM
C * METAL/NON-METAL
      IPR(191 + N) = ISIGN (1, IATPR)
      IF (N > 0) THEN
        PAR(293) = 0.0
C * ADD ADDITIONAL TOLERANCE FOR (EARTH)ALKALI TO O, C, N,  ..
C * TEST FOR AUTO RADII
        IF (IPR(156) == 0) THEN
          ITST = IPR(157) * IPR(158)
C * ZN..O,N
          IF (ITST == -309 .OR. ITST == -412) THEN
            PAR(293) = PAR(541)
C * Cu..O,N,Cl
          ELSE IF (ITST == -30 .OR. ITST ==  -40 .OR.
     1      ITST == -50 .OR. ITST == -120) THEN
            PAR(293) = PAR(542)
C * MN..O,N
          ELSE IF (ITST == -177 .OR. ITST == -236) THEN
            PAR(293) = PAR(543)
C * AG..O,N
          ELSE IF (ITST == -39 .OR. ITST == -52) THEN
            PAR(293) = PAR(544)
C * CR..O,N
          ELSE IF (ITST == -93 .OR. ITST == -124) THEN
            PAR(293) = PAR(545)
C * TL..O,N
          ELSE IF (ITST == -285 .OR. ITST == -380) THEN
            PAR(293) = PAR(546)
C * O,N,Cl - Alkali
          ELSE IF (ITST == -1 .OR. ITST == -3 .OR.
     1      ITST == -4 .OR. ITST == -5) THEN
            PAR(293) = IGBL(97) * PAR(26)
          END IF
C * AVOID SOME METAL - METAL BONDS
          IF (IPR(191) + IPR(192) == 2) PAR(293) = PAR(27)
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA041
 
      SUBROUTINE PLA042 (MODE)
C * LATTICE/SP:GR HEADER
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: MODE
      INTEGER            :: NRXX
      REAL               :: WAVL
      CHARACTER(len=120) :: FCELA
      CHARACTER(len=89)  :: FCELB
      CHARACTER(len=89)  :: FCELC
      CHARACTER(len=95)  :: FCELV
C * HEADER, CELL, SYMM LISTING
C * TEST FOR PREVIOUS CALL
      IF (IPR(680) == 0) THEN
        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: 64) = '10X,''d(100) ='',F12.4,3X,'
        FCELV( 65: 95) = '''Angstrom'',24X,''Niggli Values'')'
C * CHECK FOR REDUCED CELL IN TRICLINIC
        IF (MODE == 0 .OR. MODE == 1) THEN
C * ALERT _155
          IF (SPGRNM(1)(12:12) == 'a') THEN
            IF (ABS (PAR(101) - PAR(123)) > 0.01 .OR.
     1          ABS (PAR(102) - PAR(124)) > 0.01 .OR.
     2          ABS (PAR(103) - PAR(125)) > 0.01 .OR.
     3          ABS (PAR(104) - PAR(126)) > 0.1  .OR.
     4          ABS (PAR(105) - PAR(127)) > 0.1  .OR.
     5          ABS (PAR(106) - PAR(128)) > 0.1)
     6          CALL PLA236 (155, 0, 1.0, 1.0, ' ', ' ')
          END IF
        END IF
        IF (IGBL(63) > 2) THEN
C * NEWPAGE
          CALL PLA262 (-5)
          WRITE (LU7, 99999, IOSTAT = IOST)
     1      IGBL(4), JID(1:71), DATIJD
        END IF
        IF (IPR(23) /= 0) THEN
          WRITE (LU6, 99995, IOSTAT = IOST) PAR(11)
        ELSE
          WRITE (LU6, 99998, IOSTAT = IOST)
     1      JID(1:70), MAX (PAR(17), 0.0), (PAR(100 + I), I = 1, 6),
     2      PAR(98), SPGRNM(1)(15:26), CHSG
          IPR(83) = 34
          IF (IGBL(63) > 2) THEN
            WRITE (LU7, 99993, IOSTAT = IOST)
     1        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, IOSTAT = IOST)
     1        PAR(101), IPR(281), PAR(104), IPR(284), PAR(123),
     2        PAR(126), PAR(99)
            CALL GEN065 (LU7, PRBUF, 1, 132, 3)
            FCELB(12 : 12) = CHAR (ICHAR ('0') + IPR(288))
            FCELB(42 : 42) = CHAR (ICHAR ('0') + IPR(291))
            WRITE (PRBUF, FCELB, IOSTAT = IOST)
     1        PAR(102), IPR(282), PAR(105), IPR(285), PAR(124),
     2        PAR(127)
            CALL GEN065 (LU7, PRBUF, 1, 132, 3)
            FCELC(12 : 12) = CHAR (ICHAR ('0') + IPR(289))
            FCELC(42 : 42) = CHAR (ICHAR ('0') + IPR(292))
            WRITE (PRBUF, FCELC, IOSTAT = IOST)
     1        PAR(103), IPR(283), PAR(106), IPR(286), PAR(125),
     2        PAR(128)
            CALL GEN065 (LU7, PRBUF, 1, 132, 3)
            WRITE (LU7, 99991, IOSTAT = IOST)
            FCELV(12 : 12) = CHAR (ICHAR ('0') + IPR(294))
            WRITE (PRBUF, FCELV, IOSTAT = IOST)
     1       PAR(98), IPR(293), 1.0 / PAR(113)
            CALL GEN065 (LU7, PRBUF, 1, 132, 3)
            WAVL = MAX (0.0, PAR(17))
C * LIST REDUCED CELL NIGGLI VALUES
            WRITE (LU7, 99990, IOSTAT = IOST)
     1        1.0 / PAR(114), (PAR(150 + J), J = 1, 3), KRAD,
     2        WAVL, 1.0 / PAR(115), (PAR(150 + J), J = 4, 6)
            CALL PLA262 (1)
            WRITE (LU7, 99997, IOSTAT = IOST)
            WRITE (LU7, 99994, IOSTAT = IOST)
            WRITE (PRBUF, 99989, IOSTAT = IOST) (OR(1, J), J = 1, 3),
     1                           (ROR(1, K), K = 1, 3)
            CALL GEN065 (LU7, PRBUF, 1, 132, 2)
            WRITE (PRBUF, 99988, IOSTAT = IOST) (OR(2, J), J = 1, 3),
     1                           (ROR(2, K), K = 1, 3)
            CALL GEN065 (LU7, PRBUF, 1, 132, 2)
            WRITE (PRBUF, 99987, IOSTAT = IOST) (OR(3, J), J = 1, 3),
     1                           (ROR(3, K), K = 1, 3)
            CALL GEN065 (LU7, PRBUF, 1, 132, 2)
C * OUTPUT SYMMETRY
            IF (MODE == 1 .OR. MODE == 2)  THEN
              WRITE (LU7, 99996, IOSTAT = IOST)
C * FOR CIF2SHELXL ?
C * RELOAD SPACE-GROUP BY NAME FOR CONSISTENCY
              IF (SPGRNM(1)(1:1) /= ' ') THEN
                NRXX = 0
                IF (INDEX (SPGRNM(1)(1:11), ':') /= 0) THEN
                  WRITE (ICL, 99986, IOSTAT = IOST) SPGRNM(1)(1:11)
                ELSE
                  WRITE (ICL, 99985, IOSTAT = IOST)
     1            SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11)
                  IF (SPGRNM(1)(13:13) /= ' ') ICL(13:13) = '.'
                END IF
                CALL SGSM (0, ICL, SGY, NRXX, LU6, IERR)
              END IF
C * HANDLE NEWPAGE
              CALL SGSM (2, ICL, SGY, 0, LU7, IERR)
              IF (ABS (IGBL(8)) == 3) CALL PLA058 (LU11)
            END IF
          END IF
          IPPR(1, 3) = IPR(48)
        END IF
        IPR(680) = 1
      END IF
      RETURN
99999 FORMAT ('PLATON(V-', I6, ')-Run for: ', A, 9X, 'TIME: ', A, /,
     1 132('='), /, 110X, '(C) 1980-2025 A.L.Spek')
99998 FORMAT (/, ':: TITL ', A, /, ':: LAMBDA', F10.5, /,
     1        ':: CELL ', 3F10.4, 3F10.3, F10.1, /,
     2        ':: SPGR ', A, 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('-'))
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')
99986 FORMAT ('SPGR ', A, 64X)
99985 FORMAT ('SPGR ', A, 63X)
      END SUBROUTINE PLA042
 
      SUBROUTINE PLA043 (MODE, ITYPE, LU, NWIN)
C * SYMMETRY CODE LISTING
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: LU
      INTEGER           :: N0
      INTEGER           :: N1
      INTEGER           :: N2
      INTEGER           :: N3
      INTEGER           :: ML
      INTEGER           :: IER
      INTEGER           :: IHOR
      INTEGER           :: IRS0
      INTEGER           :: MOL1
      INTEGER           :: MOL2
      INTEGER           :: MOL3
      INTEGER           :: MOL4
      INTEGER           :: MODE
      INTEGER           :: NWIN
      INTEGER           :: NMOL
      INTEGER           :: ITYPE
      INTEGER           :: NPRNT
      REAL              :: XML
      REAL              :: YML
      REAL              :: HOR
      CHARACTER(len=3)  :: ILTR
      CHARACTER(len=46) :: FORMA
      CHARACTER(len=13) :: CFXML
      FORMA(1:33)  = '(A,''['',F9.2,''] = '',A,'' = [ '',5I3,'
      FORMA(34:46) = ''' ] '',3F11.3)'
      IHOR  = -1
      IF (IWIN == 1) THEN
        IF (NWIN == 1) CALL GGIP (HORS, VERT, 0.0, 1)
        IF (ITYPE /= 0) VRT = VERT - 0.6
      END IF
      IF (ITYPE == 0) THEN
        FORMA(8:11) = 'F7.0'
      ELSE
        IF (PAR(42) < 100.0) FORMA(11:11) = '1'
      END IF
C * ITYPE =  1 - INTER PRINT MODE
C * ITYPE =  0 - HBOND-TYPE
C * ITYPE = -1 - PUB-TYPE MODE
C * ITYPE = -2 -     ,,   SHORT PRINT
C * PRINT Asymmetric Residue Unit CODE LIST
      IF (MODE >= 0) THEN
        NMOL = IPR(13)
        IF (NMOL > 1) THEN
          NPRNT = 0
          DO 10 I = 1, NMOL
            IF (ITYPE == 0) THEN
              IF (MP(I) == 0) GO TO 10
            END IF
            ML = MOL(I)
C * NO ML = 0
            IF (ML /= 0) THEN
              XML = ML / PAR(42)
C * ELIMINATE DUPLICATES FOR TYPE <= 0
              IF (I > 1 .AND. ITYPE <= 0) THEN
                XML = INT (XML)
                DO J = 1, I - 1
                  IF (MP(J) == 1) THEN
                    YML = INT (MOL(J) / PAR(42))
                    IF (XML == YML) GO TO 10
                  END IF
                END DO
              END IF
              CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRS0)
              IF (IRS0 > 0) THEN
                IF (MOL1 > IPR(48)) THEN
                  IF (I == (IPR(13) - IPR(101) + 1) .AND.
     1                      IGBL(63) > 2) THEN
                    IF (LU == LU7) CALL PLA262 (4)
                    WRITE (LU, 99996, IOSTAT = IOST)
                  END IF
                  MOL1 = MOL1 - IPR(48)
                  ILTR = '* ='
                  XML  = XML - IPR(48) * 1000
                END IF
                IF (I > 1) THEN
                  IF (IPR(17) == 0 .OR. ITYPE < 0) THEN
                    IF (I <= 27) THEN
                      ILTR = CHAR (ICHAR ('a') + I - 2)//' ='
                    ELSE
                      ILTR = '* ='
                    END IF
                  ELSE
                    ILTR = '   '
                  END IF
                  CALL SGSM (2, ICL, SGY, 0, 0, IERR)
                  SGY(4) = MOL2
                  SGY(5) = MOL3
                  SGY(6) = MOL4
C * GET SYMMETRY CODE STRING
                  CALL SGSM (20, ICL, SGY, MOL1, 0, IERR)
                  DO K = 1, 3
                    SGY(K) = RCG(K, IRS0)
                  END DO
                  CALL SGSM (3, ICL, SGY, MOL1, LU, IERR)
                  IF (IGBL(63) > 2) THEN
                    IF (NPRNT == 0 .AND. LU > 0) THEN
                      IF (ITYPE == 1) THEN
                        IF (LU == LU7) CALL PLA262 (7)
                        WRITE (LU, 99998, IOSTAT = IOST)
                      ELSE IF (ITYPE == 0) THEN
                        IF (LU == LU7) CALL PLA262 (3)
                        WRITE (LU, 99997, IOSTAT = IOST)
                      END IF
                      NPRNT = 1
                    END IF
                  END IF
                  IF (IGBL(63) > 2 .OR. LU /= LU7) THEN
                    CALL GEN020 (-1, ICL, 1, 33)
C * GET CIF-SYMMETRY CODE
                    IF (IABS (IGBL(8)) == 3) THEN
                      CALL PLA273 (1, XML, N0, N1, N2, N3, IER)
                      WRITE (CFXML, 99994, IOSTAT = IOST)
     1                  N0,N1+5,N2+5,N3+5
                    ELSE
                      CFXML = ' '
                    END IF
                    WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1                ILTR, XML, CFXML//ICL(1:33), MOL1, MOL2, MOL3,
     2                MOL4, IRS0, (SGY(K), K = 7, 9)
                    CALL GEN065 (0, PRBUF, 1, 132, 7)
                    IF (LU == LU7) CALL PLA262 (1)
                    IF (ITYPE == 1) THEN
                      WRITE (LU, 99995, IOSTAT = IOST) PRBUF
                    ELSE
                      IF (LU > 0) THEN
                        WRITE (LU, 99995, IOSTAT = IOST) PRBUF(1:49)
                        IF (IWIN == 1 .AND. ITYPE /= 0) THEN
                          VRT = VRT - 0.45
                          CALL PLA439 (0.0, PRBUF, 50, 0.30,
     1                                 5 + IGBL(68), 2, 1.0, VRT)
                        END IF
                      ELSE
C * HBOND-TYPE
                        IF (IWIN == 1) THEN
                          IHOR = MOD (IHOR + 1, 2)
                          IF (IHOR == 0) VRT  = VRT - 0.45
                          HOR = IHOR * HORS / 2 + 0.35
                          CALL PLA439 (0.0, PRBUF, 49, 0.28, 1, 2,
     1                                 HOR, VRT)
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END IF
   10     CONTINUE
          IF (LU == 0 .AND. NMOL > 0) VRT = VRT - 0.5
          IF (ITYPE == 1 .AND. IGBL(63) > 2) THEN
            IF (LU == LU7) CALL PLA262 (7)
            WRITE (LU, 99999, IOSTAT = IOST)
          END IF
C * OUTPUT NETWORK ANALYSIS RESULT
          IF (MODE /= 0) CALL PLA094 (0, 0, 0, 0, 0, 0)
        END IF
      END IF
      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', 4X, 'CIF-sym-Code', 2X,
     2 'Symmetry-Code', 24X, 'sym TX TY TZ', ' Ires', 6X, 'x(cen)',
     3  5X, 'y(cen)', 5X, 'z(cen)', /, 132('-'))
99997 FORMAT (/, 'Translation of ARU-Code to CIF and Equivalent ',
     1        'Position Code', /, 59('='))
99996 FORMAT (/, 37X, 'Detected and Excluded Disorder Asymmetric ',
     1 'Residue Units', /, 37X, 55('='), /)
99995 FORMAT (A)
99994 FORMAT ('[',I4,'_',3I1,  '] = ')
      END SUBROUTINE PLA043
 
      SUBROUTINE PLA044 (R, IAT, XR, YR, ZR, SX, SY, SZ, SC, SXY)
C * ROTATION SUPPORT
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: N
      INTEGER               :: IAT
      REAL                  :: XR
      REAL                  :: YR
      REAL                  :: ZR
      REAL                  :: SX
      REAL                  :: SY
      REAL                  :: SZ
      REAL                  :: SC
      REAL                  :: SXY
      REAL                  :: XOR
      REAL                  :: YOR
      REAL                  :: ZOR
      REAL, DIMENSION(3, 3) :: R
C * FIND PROJECTION OF ORIGIN ON THE L.S.-PLANE AND ROTATE
      IF (IAT < 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)
      END IF
      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 PLA044
 
      SUBROUTINE PLA045 (NTYP)
C * LS-PLANE HANDLING
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L4
      INTEGER :: NTYP
      INTEGER :: NMAX
      INTEGER :: IPR52
      INTEGER :: IYUNK
      REAL    :: DET
      REAL    :: DMIN
      REAL    :: TEMP
C * TEST WHETHER THIS IS A NEW LS-PLANE
      IF (IPR(52) < NP2) THEN
        NMAX  = IPR(39)
        IPR52 = IPR(52)
        CALL PLA054 (0)
        DO I = 1, 4
          XLS(I, IPR52 + 1) = XPV(I)
        END DO
        IF (NTYP == 1) THEN
          IF (IPR52 > 0) THEN
            DO J = 1, IPR52
              DMIN = 0
              DO K = 1, 4
                DMIN = DMIN + ABS (XLS(K, IPR52 + 1) - XLS(K, J))
              END DO
              IF (DMIN < 0.00001) RETURN
            END DO
          END IF
        END IF
        CALL GEN022 (IATP, 1, NMAX, 1)
        IPR(52) = IPR(52) + 1
        IF (NTYP == 3) THEN
          CALL GEN004 (ROR, DUMV, ORRES)
          CALL GEN003 (ORRES, RMAT, DET, 0)
        END IF
        CALL GEN005 (DUMV, RMAT)
        DO K = 1, 3
          TEMP = RMAT(1, K)
          RMAT(1, K) = - RMAT(3, K)
          RMAT(3, K) = TEMP
        END DO
C * COUNT NUMBER OF RINGS
        IF (NTYP == 2) THEN
          IPR(69)  = IPR(69) + 1
          IF (IPR(12) > 4 .AND. IPR(12) < 8) THEN
            IYUNK = 2 * (IPR(12) - 5)
            IPR(496) = IPR(496) + 10 ** IYUNK
          END IF
        END IF
        WRITE (LU8) NTYP, IPR(12), JR, RMAT
        WRITE (LU8) (IATP(L4), L4 = 1, IPR(39))
      END IF
      RETURN
      END SUBROUTINE PLA045
 
      SUBROUTINE PLA046 (MODUS, NQ, IENM, LBB, LBC, LBD, INQNR, JNQNR,
     1                   NIEN)
C * PACK ATOMLABEL INTO UNIQUE INTEGER VALUE: NQ ----> INQNR
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: KL
      INTEGER          :: NB
      INTEGER          :: NE
      INTEGER          :: NR
      INTEGER          :: NQX
      INTEGER          :: NCH
      INTEGER          :: NAT
      INTEGER          :: LBA
      INTEGER          :: LBB
      INTEGER          :: LBC
      INTEGER          :: LBD
      INTEGER          :: LEV
      INTEGER          :: LBB1
      INTEGER          :: ITEL
      INTEGER          :: NIEN
      INTEGER          :: MODE
      INTEGER          :: MODX
      INTEGER          :: IENM
      INTEGER          :: MODUS
      INTEGER          :: INQNR
      INTEGER          :: JNQNR
      INTEGER          :: MSUBST
      CHARACTER(len=*) :: NQ
      CHARACTER(len=1) :: ICH = ' '
      CHARACTER(len=2) :: NQJ = '  '
C * MODE = 10 : PLUTON/PACK-MODE
C * MODE =  9 : PLUTON/PACK-MODE
C * MODE =  8 : PLUTON/SPLIT-MODE
C * MODE =  4 : GIVE SERIAL NUMBER IN EXP+CG'S ATOM ARRAY FOR NQ IN NIEN
C * MODE =  3 : GIVE SERIAL NUMBER IN EXPANDED ATOM ARRAY FOR NQ IN NIEN
C * MODE =  2 : GIVE SERIAL NUMBER IN PRIMARY  ATOM ARRAY FOR NQ IN NIEN
C * MODE =  1 : ONE SYMMETRY CHARACTER EXTENSION ALLOWED
C * MODE =  0 :  ,,    ,,       ,,         ,,    NOT ALLOWED
C * MODE = -1 : GENERATE UNIQUE LABEL
C * MODE = -2 : SAME AS 2 WITHOUT DETACH OF _nr
C * SPLIT ATOM LABEL INTO THE FOUR COMPONENTS
C * IENM         - ELEMENT NUMBER (IN IEN(1:IAN) ARRAY)
C * LBB          - NUMERICAL PART (NEGATIVE FOR ELEMENT NAME ONLY)
C * LBC          - SEMI-NUMERICAL PART
C * LBD          - SYMMETRY CHARACTER NUMBER
C * NIEN         - SERIAL NUMBER IN ATOM ARRAY (NEGATIVE = ERROR)
C * IEN(1:NP10)  - SFAC POINTER ARRAY INTO IEL & ELB
C * IENS(1:NP10) - SFAC POINTER ARRAY INTO LMT
C * IEL(1:NP9)   - NUMERICAL CODE FOR UPPERCASE ELEMENT LABELS (e.g. 119)
C * ELB(1:NP9)   - TWo LETTER ELEMENT LABELS (e.g. As)
C * LMT(1:NP9)   - SFAC LABELS
C * ERROR CODES
C * NIEN =  -1 - UNKNOWN ELEMENT TYPE
C * NIEN =  -2 - TOO MANY ATOM TYPES FOR PLUTON
C * NIEN =  -3 -
C * NIEN =  -4 -
C * NIEN =  -5 -
C * NIEN =  -6 -
C * NIEN =  -7 -
C * NIEN =  -8 - ATOM TYPE NOT HO
C * NIEN =  -9 - QUOTE IN LABEL
C * NIEN = -10 -
C * NIEN = -11 - UNDERSCORE IN LABEL
C * NIEN = -12 -
C * NIEN = -13
C * NIEN = -14 - '*' CHARACTER IN LABEL
C * NIEN = -15 - TOO MANY CHARACTER IN LABEL
      MODE = MODUS
      MODX = 0
      NAT  = 0
      K    = 0
      IF (MODUS > 98) THEN
        IF (MODUS == 100) THEN
          IF (INDEX (NQ, '#') /= 0) THEN
            NIEN = -8
            RETURN
          END IF
        END IF
        MODE = MODUS - 100
        MODX = 1
      END IF
      IF (MODE /= -1) THEN
C * HANDLE '_nr' NOT DETACH/DETACH
        IF (MODE == -2) THEN
          N    = 0
          MODE = 2
        ELSE
          N = INDEX (NQ, '_')
C * HANDLE DOUBLE UNDERSCORE CASE (e.g. C7_1_A)
          IF (N < NP64 - 2) THEN
            M = INDEX (NQ(N + 1 : NP64), '_')
            N = N + M
          END IF
          IF (N < NP64) THEN
            IF (N > 0) THEN
              ICH = NQ(N + 1 : N + 1)
              DO I = 1, 10
                IF (ICH == CHAR (ICHAR ('0') + I - 1)) THEN
                  N = 0
                  GO TO 10
                END IF
              END DO
C * SEPARATE AND STORE SYMMETRY PART FROM THE LABEL ROOT
              NQJ    = NQ(N : N + 1)
              NQ(N:) = ' '
            END IF
          ELSE
            NIEN = -15
            RETURN
          END IF
        END IF
C * SUBSTITUTE PREVIOUSLY GENERATED & STORED  ALIASES
C * CHECK FOR NON-ZERO NUMBER OF ALIASES
   10   IF (IPR(759) > 0) THEN
          MSUBST = 0
          CALL PLA281 (1, NQ, MSUBST)
          IF (N > 0) THEN
            M = INDEX (NQ, ' ')
            NQ(M:) = NQJ
          END IF
          IF (MSUBST > 0) GO TO 30
        END IF
        IF (N > 0) NQ(N:) = NQJ
      END IF
 
C * CHECK/ALIAS CIF FOR HO & HN for H on O or H on N (NOT FOR ELD+GEOMFILE)
      IF (MODX == 1 .AND.
     1  (IABS(IGBL(8)) == 1 .OR. IABS(IGBL(8)) == 3)) THEN
C * UPPER CASE SECOND CHARACTER IN LABEL
        CALL GEN020 (1, NQ, 2, 2)
        KL = IPR(220)
C * FIND OUT ABOUT ONE OR TWO LETTER ATOM TYPE
        IF (KL == 3) THEN
          IF (IFL(3)(2:2) == ' ') THEN
            N = 1
          ELSE
            N = 2
          END IF
C * UPPER CASE SECOND CHARACTER IN LABEL
          CALL GEN020 (1, IFL(3), 2, 2)
          IF (NQ(1:N) == IFL(3)(1:N)) THEN
C * CHECK FOR UPPERCASE CHARACTER
            IF (N == 1) THEN
              IF (ICHAR (NQ(2:2)) >= 65 .AND. ICHAR (NQ(2:2)) <= 90)
     1          GO TO 20
            END IF
          ELSE
            GO TO 20
          END IF
        END IF
        IF (NQ(1:2) == 'HO' .AND. IPR(435) == 0) THEN
          GO TO 20
        ELSE IF (NQ(1:2) == 'HN') THEN
          GO TO 20
        ELSE IF (NQ(2:2) == '0') THEN
          GO TO 20
        ELSE IF (NQ(2:3) == '00') THEN
          GO TO 20
        ELSE
          GO TO 30
        END IF
   20   IF (KL == 3) THEN
          IF (IFL(3)(1:2) /= 'HO') THEN
            NIEN = -8
            RETURN
          ELSE
            IPR(435) = 1
          END IF
        END IF
      END IF
   30 NR    = 0
      LBA   = 0
      LBC   = 0
      NCH   = 0
      ITEL  = 0
      NIEN  = 0
      INQNR = 0
      JNQNR = 0
C * CHECK FOR PLUTON/SPLIT MODE
      IF (MODE == 8)  THEN
        LBB = -1
        LBD = 27
      ELSE
        LBB = 0
        LBD = 0
      END IF
C * LABEL PHASE 1(2)3
      LEV = 1
      NB  = 1
      NE  = NP64
      CALL GEN039 (1, NQ, 1, NP64, NB, NE)
C * LOOP OVER CHARACTERS IN LABEL
      DO 40 I = 1, NE
        ICH = NQ(I : I)
C * IDENTIFY SPECIAL *, (, ), _, ' , " , \, AND # SYMBOLS
C * CHECK FOR \
        IF (ICH == '*') THEN
          NIEN = -14
          RETURN
        ELSE IF (ICH == CHAR (92)) THEN
          NIEN = -10
          RETURN
        ELSE IF (ICH == '(')  THEN
          LBB = 0
          LEV = 2
        ELSE IF (ICH == ')') THEN
          LEV = 4
        ELSE IF (ICH == '_') THEN
          IF (MODE /= 0) THEN
            LEV = 4
          ELSE
            NIEN = -11
            RETURN
          END IF
        ELSE IF (ICH == '''') THEN
          IF (LBC == 0) THEN
            LBC = 1
            LEV = 3
          ELSE
            NIEN = -9
            RETURN
          END IF
        ELSE IF (ICH == '"') THEN
          IF (LBC == 0) THEN
            LBC = 2
            LEV = 3
          ELSE
            NIEN = -9
            RETURN
          END IF
        ELSE IF (ICH == '#') THEN
          IF (MODE > 0) THEN
            LBC = 3
            LEV = 3
          ELSE
            GO TO 50
          END IF
        ELSE
C * IS THIS AN ALPHABETIC CHARACTER ?
          DO J = 1, 26
            IF (ICH == CHAR (ICHAR ('A') + J - 1) .OR.
     1          ICH == CHAR (ICHAR ('a') + J - 1)) THEN
C * EL-TYPE SYMBOL LEVEL
              IF (LEV == 1) THEN
                NR = NR + 1
                IF (NR == 1) THEN
                  NQJ = ' '//CHAR (ICHAR ('A') + J - 1)
                  LBA = J * 100
                ELSE IF (NR == 2) THEN
                  NQJ(1:1) = NQJ(2:2)
                  NQJ(2:2) = CHAR (ICHAR ('a') + J - 1)
                  LBA      = LBA + J
                ELSE
                  LBA = -1
                  GO TO 50
                END IF
                GO TO 40
C * NUM LEVEL (CHAR)
              ELSE IF (LEV == 2) THEN
                IF (NCH == 0 .AND. LBC == 0 .AND.
     1              IGBL(61) == 0) THEN
                  NCH = NCH + 1
                  LBC = 3 + J
                  LEV = 3
                ELSE
                  NIEN = -8
                  RETURN
                END IF
              ELSE IF (LEV == 3) THEN
                NIEN = -8
                RETURN
              ELSE
                IF (MODE <= 0) THEN
                  GO TO 50
                ELSE
                  LBD = J
                  GO TO 40
                END IF
              END IF
            END IF
          END DO
C * LOOK FOR NUMERIC CHARACTERS
          DO J = 1, 10
            IF (ICH == CHAR (ICHAR ('0') + J - 1)) THEN
              IF (LEV <= 2) THEN
                IF (MODE == 8 .AND. LBB == -1) LBB = 0
                LBB  = LBB * 10 + J - 1
                IF (LBB == 0) THEN
                  NIEN = -13
                  NQ(I:) = ' '
                  RETURN
                END IF
                ITEL = ITEL + 1
                LEV  = 2
                GO TO 40
              ELSE
                NIEN = -8
                RETURN
              END IF
            END IF
          END DO
        END IF
   40 CONTINUE
C * COUNT # OF CHARACTERS
   50 ITEL = ITEL + NR
      IF (LBC > 0)  ITEL = ITEL + 1
      IENM = 0
C * FIRST LOOP OVER CURRENT ATOM-TYPE LIST
      IF (IAN > 0) THEN
        DO I = 1, IAN
          IF (LBA == IEL(IEN(I))) THEN
            IENM = I
            EXIT
          END IF
        END DO
      END IF
      IF (IENM == 0) THEN
        K = 0
        DO I = 1, NP9
          IF (LBA == IEL(I)) THEN
            K = I
            EXIT
          END IF
        END DO
      END IF
      IF (IABS (IGBL(8)) == 1) THEN
        IF (MODE == 9) K = 0
        KL = IPR(220)
      END IF
      IF (MODE == 8) THEN
        IF (IENM > 0) RETURN
        IF (K >= NP9 - 3 .AND. K <= NP9) IENM = K
      ELSE IF (MODE < 8) THEN
        IF (IENM == 0) THEN
C * TEST FOR IGBL(8) = 2 (SHELX-RES-FORMAT)
          IF (IABS (IGBL(8)) /= 2 .OR. NQJ == 'Cg' .OR.
     1      NQJ == ' Q') THEN
            IF (K > 0) THEN
              IAN = IAN + 1
              IF (IAN > NP10) THEN
                NIEN = -2
                RETURN
              END IF
              IEN(IAN)    = K
              L           = IABS (IATPR(K))
              LMT(IAN, 2) = JTP(L)
C * SECOND CHARACTER OF ATOM TYPE (IF ANY) IS MODIFIED TO LOWER CASE
              LMT(IAN,  1) = NQJ
              RADR(IAN, 3) = REL(K)
              RADR(IAN, 4) = ABS (VDWR(K))
              IF (K == 3) THEN
                IACL(IAN) = 2
              ELSE IF (K == 4) THEN
                IACL(IAN) = 4
              ELSE IF (IATPR(K) == -7) THEN
                IACL(IAN) = 3
              ELSE IF (K > 2) THEN
                IF (ICLR < 8) ICLR = ICLR + 1
                IACL(IAN) = ICLR
              END IF
              IENM = IAN
            END IF
          ELSE
            NIEN = -3
            RETURN
          END IF
        END IF
        IF (IENM <= 0) THEN
          NIEN = -5
          RETURN
        END IF
        IF (MODE < 0 .OR. (MODE == 0 .AND. ITEL > 4)) THEN
C * ADD HASH (#) CHARACTER TO LABEL
          LBC  = 3
          ITEL = 3
          IF (MOD(LBA, 100) /= 0) ITEL = ITEL + 1
C * CHECK AGAINST MAXIMUM NUMBER OF DIMENSIONED ALIASES
          IF (IPR(759) >= NP36) THEN
            NIEN = -7
            RETURN
          END IF
C * COUNT PER ELEMENT
          IENLB(IENM) = IENLB(IENM) + 1
          LBB         = IENLB(IENM)
          IF (LBB >= 10)   ITEL = ITEL + 1
          IF (LBB >= 100)  ITEL = ITEL + 1
          IF (LBB >= 1000) ITEL = ITEL + 1
          IF (LBB > 9999 .AND. IGBL(61) == 0) THEN
            NIEN = -12
            RETURN
          END IF
C * SET PARENTHESES OFF
          IF (ITEL > 4) IPR(71) = 0
        END IF
C * LABEL PACKING CONSTANTS
        JNQNR = ((120 - IATNR(IEN(IENM))) * 10000  + LBB) * 40 + LBC
        IF (IGBL(61) == 0) THEN
          IF (LBC > 0) LBC = LBC + 10
C * NR = 1 OR 2 (= # ELEMENT CHARACTERS)
          IF (LBB >= 10 ** (5 - NR) .AND. LBC == 0) THEN
            LBB1 = LBB / 10
            LBC  = LBB - LBB1 * 10 + 1
            LBB  = LBB1
          END IF
          NQX = LBB * 40 + LBC
        ELSE
          NQX = LBB * 4 + LBC
        END IF
        IF (LBD >= 128) THEN
          NIEN = -6
          RETURN
        END IF
        INQNR = (IENM * 400000 + NQX) * 128 + LBD
C * RETURN ELEMENT TYPE, ATOM # OR ERROR CODE
        IF (MODE > 1) THEN
          IF (MODE == 2) THEN
            NAT = IPR(37)
          ELSE IF (MODE == 3) THEN
            NAT = IPR(39)
          ELSE IF (MODE == 4) THEN
            NAT = IPR(39) + IPR(64)
          END IF
          DO I = 1, NAT
            IF (INQNR == LABA(I)) THEN
              NIEN = I
              RETURN
            END IF
          END DO
          NIEN = - 4
        ELSE
          NIEN = IENM - 1
        END IF
C * PLUTON PACK MODE
      ELSE IF (MODE == 9 .OR. MODE == 10) THEN
        IF (IENM == 0) THEN
          IF (K == 0) THEN
            NIEN = -1
            RETURN
          ELSE
            IAN = IAN + 1
            IF (IAN > NP10) THEN
              NIEN = -2
              RETURN
            END IF
            RADR(IAN, 3) = REL(K)
            RADR(IAN, 4) = ABS (VDWR(K))
            IEN(IAN) = K
            IENM     = IAN
          END IF
        END IF
        IF (ITEL > 4 .OR. MODE == 10) THEN
          LBC         = 3
          IENLB(IENM) = IENLB(IENM) + 1
          LBB         = IENLB(IENM)
        END IF
        NQX   = LBB * 32 + LBC
        INQNR = (IENM - 1) * 64000 + NQX
        JNQNR = (120 - IATNR(IEN(IENM))) * 64000 + NQX
      END IF
      RETURN
      END SUBROUTINE PLA046
 
      SUBROUTINE PLA047 (INQNR, NQ, MN, IENR, IPAR, IALIAS, IPDB, IMU)
C * RECOVER ATOMLABEL : INQNR ----> NQ (IN-/EXCLUDING PARENTHESES)
      USE parameters
      USE atomdata
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K = 0
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: J1
      INTEGER               :: J2
      INTEGER               :: MN
      INTEGER               :: J3
      INTEGER               :: IMU
      INTEGER               :: JX1
      INTEGER               :: JX2
      INTEGER               :: JX3
      INTEGER               :: JX4
      INTEGER               :: IENR
      INTEGER               :: IPAR
      INTEGER               :: JPAR
      INTEGER               :: IPDB
      INTEGER               :: IALIAS
      INTEGER               :: INQNR
      INTEGER, DIMENSION(4) :: NUM
      CHARACTER(len=*)      :: NQ
      CHARACTER(len=NP64)   :: NQL1
      CHARACTER(len=NP64)   :: NQL2
      CHARACTER(len=NP64)   :: NQL3
C * THE MOLECULE NUMBER IS IN MN
C * NO SYMMETRY CHARACTER IN CASE OF INQNR < 0
C * IPAR =  0 : NO PARENTHESES
C * IPAR =  1 :    PARENTHESES
C * IPAR = -1 : NO PARENTHESES & NO UNDERSCORE
C * IPDB =  0 : NO SPECIAL HANDLING
      JPAR = IPAR
      IF (IGBL(71) > 0 .AND. IALIAS == 0 .AND. JPAR == 1) JPAR = 0
      NQ   = ' '
      NQL3 = ' '
      IENR = 0
      MN   = 0
C * LABEL PACKING CONSTANTS
C * SPLIT INQNR INTO JX1, JX2, JX3, JX4
      JX3 = ABS(INQNR)
      IF (JX3 > 0) THEN
        JX1 = JX3 / 51200000
        JX3 = MOD (JX3, 51200000)
        JX2 = JX3 / 128
        JX3 = MOD (JX3, 128)
        IF (IGBL(61) == 0) THEN
          JX4 = MOD (JX2, 40)
          JX2 = JX2 / 40
          IF (JX4 > 0 .AND. JX4 < 11) THEN
            JX2 = JX2 * 10 + JX4 - 1
            JX4 = 0
          ELSE
            JX4 = JX4 - 10
          END IF
        ELSE
          JX4 = MOD (JX2, 4)
          JX2 = JX2 / 4
        END IF
        MN = JX3 + 1
        IF (JX2 == 0) JPAR = MIN (JPAR, 0)
        IF (INQNR  < 0) JX3  = 0
        IENR = IEN(JX1)
        JX1  = IEL(IENR)
        J1   = JX1 / 100
        J2   = MOD (JX1, 100)
        K    = 1
        IF (IPDB == 1 .AND. J2 == 0) K = 2
        NQL3(K : K) = CHAR (ICHAR ('A') + J1 - 1)
        K = K + 1
        IF (J2 > 0) THEN
          IF (IPDB <= 0) THEN
            NQL3(K : K) = CHAR (ICHAR ('a') + J2 - 1)
          ELSE
            NQL3(K : K) = CHAR (ICHAR ('A') + J2 - 1)
          END IF
          K = K + 1
        END IF
        IF (JPAR > 0) THEN
          NQL3(K : K) = '('
          K = K + 1
        END IF
C * NUMBER JX2 MAY BE IN THE RANGE 0:9999 : GENERATE UP TO 3 CHARACTERS
        J2     = JX2 / 10
        NUM(4) = MOD (JX2, 10)
        J3     = J2 / 10
        NUM(3) = MOD (J2, 10)
        NUM(1) = J3 / 10
        NUM(2) = MOD (J3, 10)
        J2     = 0
        DO J = 1,  4
          IF (NUM(J) > 0 .OR. J2 > 0) THEN
            NQL3(K : K) = CHAR (ICHAR ('0') + NUM(J))
            K  = K  + 1
            J2 = J2 + 1
          END IF
        END DO
        IF (JX4 > 0) THEN
C * OPTIONALLY ADD ' AND " etc.
          IF (JX4 == 1) THEN
            NQL3(K : K) = ''''
          ELSE IF (JX4 == 2) THEN
            NQL3(K : K) = '"'
          ELSE IF (JX4 == 3) THEN
            NQL3(K : K) = '#'
          ELSE IF (JX4 > 3) THEN
            NQL3(K : K) = CHAR (ICHAR ('A') + JX4 - 4)
          END IF
          K = K  + 1
        END IF
C * ADD CLOSE PARENTHESIS
        IF (JPAR > 0) THEN
          NQL3(K : K) = ')'
          K = K + 1
        END IF
C * HANDLE SYMMETRY CHARACTER
        IF (JX3 > 0) THEN
C * ADD UNDERSCORE BETWEEN ELEMENT AND SYMMETRY SYMBOL WHEN APPLICABLE
          IF (JPAR == 0) THEN
            NQL3(K : K) = '_'
            K          = K + 1
          END IF
          IF (JX3 < 27) THEN
            NQL3(K : K) = CHAR (ICHAR ('a') + JX3 - 1)
          ELSE
            NQL3(K : K) = '*'
          END IF
          K = K + 1
        END IF
        NQL3(K : K) = ' '
      END IF
C * SUBSTITUTE ALIASES BY ORIGINALS
      IF (K > 1 .AND. IPR(759) > 0 .AND. IALIAS == 0) THEN
        NQL1 = NQL3(1:K)
        L  = K
        IF (JX3 > 0) THEN
          L = L - 1
          NQL3(L:L) = ' '
          IF (JPAR == 0) L = L - 1
          NQL3(L:L) = ' '
        END IF
        DO I = 1, IPR(759)
C * TEST FOR AUTORENUM
          IF (IPR(501) == 0) THEN
            N = INDEX (BLAB(I), '#')
          ELSE
            N = INDEX (BLAB(I), ' ')
          END IF
          IF (N > 0) THEN
            IF (NQL3(1:N) == BLAB(I)(1:N)) THEN
              M  = INDEX (ALAB(I), ' ')
              IF (M == 0) THEN
                M = NP64
              ELSE
                M = M - 1
              END IF
              IF (IMU == 0) THEN
                IF (INDEX (ALAB(I), '_') /= 0) THEN
                  NQ = NQL1
                  RETURN
                END IF
              END IF
              IF (M < 1 .OR. M > (NP64 + L - K)) THEN
                NQ = NQL1
              ELSE
                NQL2 = ALAB(I)(1:M)//NQL1(L:K)
                CALL GEN020 (-1, NQL3, 1, 2)
                IF (NQL2(1:2) == NQL3(1:2)) NQL2(1:2) = BLAB(I)(1:2)
                NQ = NQL2
              END IF
              RETURN
            END IF
          END IF
        END DO
        NQ = NQL1
      ELSE
        NQ = NQL3
      END IF
      RETURN
      END SUBROUTINE PLA047
 
      SUBROUTINE PLA048
C * ANALYSE RING INTERACTIONS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: I1
      INTEGER               :: J1
      INTEGER               :: NC
      INTEGER               :: NR
      INTEGER               :: NS
      INTEGER               :: MET
      INTEGER               :: IER
      INTEGER               :: NDC
      INTEGER               :: NPL
      INTEGER               :: NSM
      INTEGER               :: NSYM
      INTEGER               :: NTMP
      INTEGER               :: NDCJ
      INTEGER               :: NDEC
      INTEGER               :: MODE
      INTEGER               :: IDUM
      INTEGER               :: IRES
      INTEGER               :: IVAL
      INTEGER               :: NBEG
      INTEGER               :: JBEG
      INTEGER               :: JDUM
      INTEGER               :: JEND
      INTEGER               :: JRES
      INTEGER               :: NEND
      INTEGER               :: NHAT
      INTEGER               :: NMAX
      INTEGER               :: NPL5
      INTEGER               :: NPL8
      INTEGER               :: NPRT
      INTEGER               :: NTMPC
      INTEGER               :: NRING
      INTEGER               :: NDEC0
      INTEGER               :: NDEC1
      INTEGER               :: NDEC2
      INTEGER               :: NDEC3
      INTEGER               :: IRMST
      INTEGER               :: NDECJ
      INTEGER               :: NEWTMP
      INTEGER               :: NDECA1
      INTEGER               :: ISANG1
      INTEGER               :: IDIST2
      INTEGER               :: IDIST3
      INTEGER               :: ISDIST1
      INTEGER               :: ISDIST3
      INTEGER, DIMENSION(6) :: ICSD
      REAL                  :: DUM
      REAL                  :: ANG1
      REAL                  :: ANG2
      REAL                  :: ANG3
      REAL                  :: ANG4
      REAL                  :: ARUJ
      REAL                  :: DMIN
      REAL                  :: DMAX
      REAL                  :: YUNK
      REAL                  :: ANG2M
      REAL                  :: ANG3M
      REAL                  :: SANG1
      REAL                  :: DIST1
      REAL                  :: DIST2
      REAL                  :: DIST3
      REAL                  :: DIST4
      REAL                  :: SDIST1
      REAL                  :: SDIST2
      REAL                  :: SDIST3
      REAL                  :: GEN009
      REAL                  :: GEN027
      REAL, DIMENSION(3, 3) :: B
      REAL, DIMENSION(3, 3) :: C
      REAL, DIMENSION(3)    :: UVIJ
      CHARACTER(len=119)    :: FORMI
      CHARACTER(len=116)    :: FORMJ
      CHARACTER(len=120)    :: FORMK
      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:70)   = 'F7.4,''('',I3,'') '',3F7.4,F9.4,F6.2,''('','
      FORMK(71:108)  = 'I2,'')'',2F6.1,F7.4,''('',I3,'')'',F7.4,''('','
      FORMK(109:120) = 'I3,'')'',F8.3)'
      DMIN  = 0.0
      ANG2M = 0.0
      NTMP  = 0
      NPRT  = 0
C * SUBROUTINE ANALYZES FOR SHORT Y-X/METAL/RING - RING INTERACTIONS:
C * MODE = 1 : CG-CG
C * MODE = 2 : CG-METAL
C * MODE = 3 : METAL-GG COORDINATION
C * MODE = 4 : X-H..CG INTERACTIONS
C * MODE = 5 : Y-X..CG INTERACTIONS
      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
C * LOOP OVER RING INTERACTION TYPES
      DO MODE = 1, 5
        CALL PLA097 (0, 0.0)
C * FIND SHORT DISTANCES BETWEEN CG's - ROLLETT, COMP. METH. IN CRYST. 1965
        IF (MODE == 1) THEN
          DMAX = PAR(36)
          DMIN = 2.5
        ELSE IF (MODE == 2) THEN
          DMAX = PAR(69)
          DMIN = 2.0
          ANG2M = 45.0
        ELSE IF (MODE == 3) THEN
          DMAX = 3.0
          DMIN = 1.5
C * C-H..Pi
        ELSE IF (MODE == 4) THEN
          DMAX  = PAR(263)
          DMIN  = 2.0
          ANG3M = PAR(264)
        ELSE IF (MODE == 5) THEN
          DMAX = PAR(447)
          DMIN = 2.5
          ANG3M = PAR(448)
        END IF
        DO I = 1, 3
          V3(I) = DMAX * PAR(112 + I)
        END DO
C * FIRST (N)-LOOP
C * MODE < 3 : LOOP OVER RINGS
C * MODE > 2 : LOOP OVER ATOMS
        IF (MODE > 2) THEN
          NBEG = 1
          NEND = IPR(37)
          NTMP = 0
          NPRT = 0
        ELSE
C * RING COORDINATES FOLLOW LAST REGULAR ATOM
          NBEG = NMAX + 1
          NEND = NMAX + NRING
        END IF
        NR = 0
C * N-LOOP
        DO 80 N = NBEG, NEND
          NEWTMP = NMAX + NRING
C * TEST FOR METAL
          CALL GEN048 (-1, IFG(1, N), 19, MET)
C * TEST FOR H-ATOM
          CALL GEN048 (-1, IFG(1, N), 7, NHAT)
C * METAL
          IF (MODE == 3) THEN
            IF (MET == 0) GO TO 80
            NTMP = 0
C * X-H
          ELSE IF (MODE == 4) THEN
            IF (NHAT == 0) GO TO 80
            NTMP = 0
C * Y-X
          ELSE IF (MODE == 5) THEN
            IF (NINT (CON(N, 9)) /= -1 .OR.
     1          MET /= 0 .OR. NHAT /= 0) GO TO 80
            NTMP = 0
          END IF
C * GET ARU FOR THIS HATOM/METAL/RING/OTHER SINGLE BONDED ATOM
          CALL GEN048 (-6, IFG(1, N), 9, IRES)
C * GET LABEL FOR THIS HATOM/METAL/RING CG
          CALL PLA047 (LABA(N), NQ1, IDUM, JDUM, IPR(71),
     1      IGBL(55), 0, 1 - IGBL(55))
C * SECOND (J)-LOOP
C * MODE /= 2 : LOOP OVER RINGS
C * MODE == 2 : LOOP OVER ATOMS
          IF (MODE == 2) THEN
            JBEG = 1
            JEND = IPR(37)
          ELSE
            JBEG = NMAX + 1
            JEND = NMAX + NRING
          END IF
C * J-LOOP
          DO 60 J = JBEG, JEND
            IF (MODE == 2) THEN
C * TEST FOR METAL
              CALL GEN048 (-1, IFG(1, J), 19, MET)
              IF (MET == 0) GO TO 60
            END IF
C * GET RESIDUE NUMBER
            CALL GEN048 (-6, IFG(1, J), 9, JRES)
            DO 50 NSM = 1, NSYM
              DO I = 1, 3
                SGX(I)     = XXO(J, I)
                SGX(I + 3) = 0.0
                V4(I)      = 0.0
              END DO
              NS = NSM
              CALL SGSM (3, LINE, SGX, NS, 6, IERR)
              IF (MODE == 3 .AND. NSM == 1) THEN
                K = 3
                GO TO 40
              ELSE
                K = 1
              END IF
C * TRANSLATE SGX ON AXIS K TO A POINT BELOW LOWER LIMIT
   10         IF ((XXO(N, K) - SGX(6 + K)) > V3(K)) GO TO 30
              SGX(6 + K) = SGX(6 + K) - 1.0
              V4(K)      = V4(K) - 1.0
              GO TO 10
   20         K = K - 1
C * ADVANCE ONE UNIT ON AXIS KAX
   30         SGX(6 + K) = SGX(6 + K) + 1.0
              V4(K)      = V4(K) + 1.0
              IF ((XXO(N, K)  - SGX(6 + K)) >= V3(K)) GO TO 30
              IF ((SGX(6 + K) - XXO(N, K))  <= V3(K)) GO TO 40
C * TEST GIVES ATOM OUT OF RANGE - REDUCE AXIS K BY ONE
              K = K - 1
C * K = 0 SIGNALS END OF TRANSLATION SEARCH
              IF (K > 0) THEN
                GO TO 30
              ELSE
                GO TO 50
              END IF
C * IF SGX WAS WITHIN RANGE ON AXIS K THEN WE ADVANCE K BY 1
   40         K = K + 1
              IF (K > 3) THEN
                DO L = 1, 3
                  V5(L) = SGX(6 + L) - XXO(N, L)
                END DO
                CALL GEN002 (1, OR, V5, V6, DUM)
C * GET UNIT-VECTOR ALONG Cg-Cg/Me
                CALL GEN002 (2, OR, V5, V7, DIST1)
C * TEMP FIX
                IF (IATP(N) <= 0) THEN
                  WRITE (LU6, 99993, IOSTAT = IOST) IATP(N)
                  RETURN
                END IF
                IF (DIST1 < DMAX .AND. DIST1 > DMIN) THEN
C * STORE COORDINATES NEW POSITIONS TEMPORARILY
                  NEWTMP = NEWTMP + 1
C * TEMP FIX
                  IF (NEWTMP == 0) GO TO 20
                  IPR(54) = NS
                  DO I = 1, 3
                    ITR(I) = NINT (V4(I))
                  END DO
                  CALL PLA059 (J, NEWTMP)
                  DO I = 1, 3
                    IFG(I, NEWTMP) = IFG(I, J)
                  END DO
                  IF (MODE < 3) THEN
                    NPL = IPR(19) + IATP(N)
C * TEMP FIX
                    IF (NPL > NP2) THEN
                      WRITE (LU6, 99993, IOSTAT = IOST) IATP(N)
                      RETURN
                    END IF
                    CALL PLA056 (XLS(1, NPL), NEWTMP, DIST3, SDIST3,
     1                IDIST3, 4, NDEC3)
                  END IF
C * AVOID 'FLAT' COORDINATION CASES (TEST DIST ATOM N TO PLANE J
                  IF (MODE == 3) THEN
                    IF (IATP(J) > 0) THEN
                      NPL = IPR(19) + IATP(J)
C * TEMP FIX
                      IF (NPL > NP2) THEN
                        WRITE (LU6, 99993, IOSTAT = IOST) IATP(J)
                        RETURN
                      END IF
                      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) < DMIN) THEN
                        NEWTMP = NEWTMP -1
                        GO TO 60
                      END IF
                    END IF
                  END IF
C * GENERATE ARU
                  ARUJ = NS * 1000.0 + V4(1) * 100 + V4(2) * 10 + V4(3)
     1                 + 555 + JRES / PAR(42)
C * GET LABEL
                  CALL PLA047 (LABA(J), NQ2, IDUM, JDUM, IPR(71),
     1                         IGBL(55), 0, 0)
                  LABA(NEWTMP) = LABA(J)
                  IF (MODE < 3) THEN
C * NORMAL TO PLANE N
                    NPL8 = IPR(19) + IATP(N)
                    V8(1) = XLS(1, NPL8)
                    V8(2) = XLS(2, NPL8)
                    V8(3) = XLS(3, NPL8)
C * CALCULATE BETA = ANGLE BETWEEN NORMAL AND CG-Cg(Me)
                    ANG2  = GEN027 (V8, V7, RGBL(6))
                    IF (ANG2 > 90.0) ANG2 = 180.0 - ANG2
                  END IF
                  IF (MODE == 1 .OR. MODE == 4
     1                            .OR. MODE == 5) THEN
C * TEMPERARY PROBLEM FIX
                    IF (IATP(J) <= 0 .OR. IATP(J) > NP2) THEN
                      WRITE (LU6, 99993, IOSTAT = IOST) IATP(J)
                      RETURN
                    END IF
                    NPL5  = IPR(19) + IATP(J)
                    V5(1) = XLS(1, NPL5)
                    V5(2) = XLS(2, NPL5)
                    V5(3) = XLS(3, NPL5)
                    V1(4) = XLS(4, NPL5)
C * GET SYMMETRY MATRIX
                    CALL SGSM (6, LINE, SGZ, NS, 6, IERR)
                    M = 0
                    DO I1 = 1, 3
                      V2(I1) = V4(I1) + SGZ(I1 + 9)
                      DO J1 = 1, 3
                        M           = M + 1
                        UIJ(I1, J1) = SGZ(M)
                      END DO
                    END DO
C * CALCULATE P' = P O R-1 O-1 = TR(TR(O-1) R TR(O) p)
                    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)
C * CALCULATE R'
                    CALL GEN002 (-1, OR, V1, V6, DUM)
                    V1(4) = V1(4) + GEN009(V6, V2)
                    ANG3  = GEN027 (V1, V7, RGBL(6))
                    IF (ANG3 > 90.0) ANG3 = 180.0 - ANG3
                    CALL PLA056 (V1, N, DIST2, SDIST2, IDIST2, 4, NDEC2)
C * HANDLE ALPHA
                    ANG1  = GEN027 (V8, V1, RGBL(6))
                    IF (ANG1 > 90.0) ANG1 = 180.0 - ANG1
                    SANG1 = 0.0
                    IF (MODE == 1) THEN
                      SANG1 = XLS(5, NPL8)**2 + XLS(5, NPL5)**2
     1                      + XLS(6, NPL8)**2 + XLS(6, NPL5)**2
     2                      + XLS(7, NPL8)**2 + XLS(7, NPL5)**2
                      SANG1 = RGBL(6) * SQRT (SANG1)
                      IF (SANG1 > 0.0001 .AND. SANG1 < 0.9) THEN
                        CALL GEN041 (ANG1, SANG1, ISANG1, 2,
     1                    NDECA1, IPR(68))
                      ELSE
                        SANG1  = 0.0
                        ISANG1 = 0
                        NDECA1 = 0
                      END IF
                      IF (ANG2 < PAR(62)) THEN
                        NR = NR + 1
                        IF (NR == 1) THEN
                          CALL PLA262 (-14)
                          WRITE (LU7, 99999, IOSTAT = IOST)
     1                      PAR(36), PAR(427), PAR(62)
                          CALL GEN074 (DUMA, 1, 6, 99999.0)
                          DUMA(4) = 0.0
                        END IF
                        CALL PLA053 (N, NEWTMP, 0, 0, DIST1, SDIST1,
     1                               ISDIST1, NDEC1, IER)
                        IF (IER /= 0) DIST1 = 0.0
                        FORMK(37:37)   = CHAR (ICHAR ('0') + NDEC1)
                        FORMK(65:65)   = CHAR (ICHAR ('0') + NDECA1)
                        FORMK(87:87)   = CHAR (ICHAR ('0') + NDEC2)
                        FORMK(103:103) = CHAR (ICHAR ('0') + NDEC3)
C * Cg-Cg Interaction Geometry
                        IF (ANG1 < PAR(427)) THEN
                          DIST4 = DIST1 * SIN (ANG2 / RGBL(6))
                          WRITE (PRBUF, FORMK, IOSTAT = IOST)
     1                      NQ1(1:7), IRES, NQ2(1:7), ARUJ, DIST1,
     2                      ISDIST1, (V1(L), L = 1, 4), ANG1, ISANG1,
     3                      ANG2, ANG3, ABS (DIST2), IDIST2, ABS (DIST3)
     4                      , IDIST3, DIST4
                        ELSE
                          WRITE (PRBUF, FORMK, IOSTAT = IOST)
     1                      NQ1(1:7), IRES, NQ2(1:7), ARUJ, DIST1,
     2                      ISDIST1, (V1(L), L = 1, 4), ANG1, ISANG1,
     3                      ANG2, ANG3, ABS (DIST2), IDIST2,
     4                      ABS (DIST3), IDIST3
                        END IF
                        CALL PLA263 (LU7, PRBUF, 132, 1, 3)
                        CALL PLA097 (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)
                      END IF
                    ELSE
C * MODE = 4 & MODE = 5
                      IF (ANG3 < ANG3M) THEN
C * DETERMINE X ON H (Y on X)
                        IF (NINT (CON(N, 9)) == -1) THEN
                          I = NINT (CON(N, 1))
                          CALL PLA047 (LABA(I), NQ3, IDUM, JDUM,
     1                      IPR(71), IGBL(55), 0, 1 - IGBL(55))
C * UNIT VECTOR ALONG I-N
                          CALL PLA227 (I, N, UVIJ)
                          ANG4  = GEN027 (V1, UVIJ, RGBL(6))
                          IF (ANG4 > 90.0) ANG4 = 180.0 - ANG4
                          ANG4 = 90.0 - ANG4
                          IF (MODE == 4) ANG4 = NINT (ANG4)
C * X-H..Cg Angle
                          CALL PLA053 (I, N, NEWTMP, 0, ANG1, SANG1,
     1                                 ISANG1, NDEC0, IER)
                          IF (IER /= 0) ANG1 = 0
                          IF (ISANG1 == 0) THEN
                            NDEC0 = 0
                            ANG1  = NINT (ANG1)
                          END IF
                          FORMJ(83:83) = CHAR (ICHAR ('0') + NDEC0)
C * H..Cg Dist
                          CALL PLA053 (N, NEWTMP, 0, 0, DIST1, SDIST1,
     1                                 ISDIST1, NDEC1, IER)
                          IF (IER /= 0) DIST1 = 0.0
                          FORMJ(43:43) = CHAR (ICHAR ('0') + NDEC1)
C * X..Cg Dist
                          CALL PLA053 (I, NEWTMP, 0, 0, DIST3, SDIST3,
     1                                 ISDIST3, NDEC3, IER)
                          IF (IER /= 0) DIST3 = 0.0
                          FORMJ(99:99) = CHAR (ICHAR ('0') + NDEC3)
                          NR = NR + 1
                          IF (NR == 1) THEN
                            CALL PLA262 (-12)
                            IF (MODE == 4) THEN
                              WRITE (LU7, 99992, IOSTAT = IOST)
     1                          DMAX, ANG3M
                              WRITE (LU6, 99988, IOSTAT = IOST)
                            ELSE
                              WRITE (LU7, 99998, IOSTAT = IOST)
     1                          DMAX, ANG3M
                              WRITE (LU6, 99986, IOSTAT = IOST)
                            END IF
                            CALL GEN074 (DUMA, 1, 5, 99999.0)
                            DUMA(4) = 0.0
                            DUMA(6) = 0.0
                          END IF
                          IF (MODE == 5) THEN
                            FORMJ(73:73)   = '3'
                            FORMJ(112:115) = 'F7.2'
                            WRITE (PRBUF, FORMJ, IOSTAT = IOST)
     1                        NQ3(1:7), NQ1(1:7), IRES, NQ2(1:7), ARUJ,
     2                        DIST1, ISDIST1, (V1(L), L = 1, 4), DIST2,
     3                        ANG3, ANG1, ISANG1, DIST3, ISDIST3, ANG4
                          ELSE
                            FORMJ(73:73)   = '2'
                            FORMJ(112:115) = 'I7  '
                            WRITE (PRBUF, FORMJ, IOSTAT = IOST)
     1                        NQ3(1:7), NQ1(1:7), IRES, NQ2(1:7), ARUJ,
     2                        DIST1, ISDIST1, (V1(L), L = 1, 4), DIST2,
     3                        ANG3, ANG1, ISANG1, DIST3, ISDIST3,
     4                        NINT (ANG4)
                          END IF
                          CALL PLA263 (LU7, PRBUF, 132, 1, 3)
                          WRITE (LU6, 99987) PRBUF(1:54), ANG3
                          CALL PLA097 (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)
                        END IF
                      END IF
                    END IF
                  ELSE IF (MODE == 2) THEN
                    IF (ANG2 < ANG2M) THEN
                      NR = NR + 1
                      IF (NR == 1) THEN
                         CALL PLA262 (8)
                         WRITE (LU7, 99997, IOSTAT = IOST) DMAX
                      END IF
                      CALL PLA262 (1)
                      WRITE (LU7, 99996, IOSTAT = IOST)
     1                  NQ1(1:7), IRES, NQ2(1:7), ARUJ, DIST1, DIST3,
     2                  ANG2
                      CALL PLA097 (1, ARUJ)
                    END IF
                  ELSE IF (MODE == 3) THEN
                    IF (NTMP < 8) THEN
                      NTMP       = NTMP + 1
                      IATC(NTMP) = NEWTMP
                    ELSE
                      IRMST = IRMST + 1
                    END IF
                  END IF
                END IF
                GO TO 20
              END IF
              GO TO 10
   50       CONTINUE
   60     CONTINUE
          IF (MODE == 3) THEN
            IF (NTMP > 0) THEN
C * SAVE TEMPORARILY
              DO I = 1, 9
                DATC(I) = CON(N, I)
              END DO
              NC = - NINT (CON(N, 9))
              IF (NC < 0) THEN
                NC = 9
                CALL GEN048 (-1, IFG(1, N), 8, IVAL)
                IF (IVAL > 0) NC = NC + IPR(76)
              END IF
              DO I = 1, NTMP
                CON(N, I) = IATC(I)
              END DO
              NTMPC = NTMP
              DO 70 I = 1, NC
                IF (I <= 9) THEN
                  K = NINT (DATC(I))
                ELSE
                  IF (IBON(I - 9, 1) /= N) GO TO 70
                  K = IBON(I - 9, 2)
                END IF
                DO L = 1, NTMPC
                  CALL PLA050 (IATC(L), K, 0, 0, DIST2)
                  IF (DIST2 < 1.5) GO TO 70
                END DO
                IF (NTMP < 9 - 1) THEN
                  NTMP = NTMP + 1
                  CON(N, NTMP) = K
                ELSE
                  IRMST = IRMST + 1
                END IF
   70         CONTINUE
              CON(N, 9) = - NTMP
              IF (NPRT == 0) THEN
                CALL PLA262 (0)
                NPRT = 1
                CALL PLA262 (3)
                WRITE (LU7, 99995, IOSTAT = IOST)
              END IF
              IPR(81) = 2
              IFL(2)  = NQ1
              CALL PLA440 (0)
              DO I = 1, 9
                CON(N, I) = DATC(I)
              END DO
            END IF
          END IF
   80   CONTINUE
C * LIST EXTREMA
        IF (MODE == 1 .AND. NR > 0) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99989, IOSTAT = IOST) (DUMA(L), L = 1, 6)
        ELSE IF ((MODE == 4 .OR. MODE == 5) .AND. NR > 0) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99990, IOSTAT = IOST) (DUMA(L), L = 1, 6)
        END IF
        CALL PLA097 (-1, 0.0)
      END DO
C * LIST CG(I)
      CALL PLA262 (5)
      WRITE (LU7, 99991, IOSTAT = IOST)
      DO I = NMAX + 1, NMAX + NRING
        CALL PLA262 (1)
C * ROUND AND PRINT CENTROID COORDINATES
        DO 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))
C * MODIFY NUMBER OF DECIMAL DIGITS
          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))
        END DO
        CALL PLA047 (LABA(I), NQ2, IDUM, JDUM, IPR(71),
     1                         IGBL(55), 0, 0)
        WRITE (PRBUF, FORMI, IOSTAT = IOST)
     1    NQ2(1:6), (XXO(I, K), ICSD(K), K = 1, 6)
        CALL PLA263 (LU7, PRBUF, 132, 1, 3)
      END DO
      IF (IRMST > 0) THEN
        WRITE (LU6, 99994, IOSTAT = IOST)
        WRITE (LU7, 99994, IOSTAT = IOST)
      END IF
      RETURN
99999 FORMAT ('Analysis of Short Ring-Interactions with Cg-Cg ',
     1 'Distances < ', F5.1, ' Ang., Alpha <', F8.3, ' Deg. and Beta <',
     2 F5.1, ' 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 ',
     6 'Cg(I)-->Me vector and 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', 1X,
     9 'Transformed J-Plane P, Q, R, S', 5X, 'Alpha', 2X,
     * 'Beta', 1X, 'Gamma', 4X, 'CgI_Perp    CgJ_Perp  Slippage', /)
99998 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', /)
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('='), /,
     3 '- Cg(J)   = Center of gravity of ring J (Plane number above)', /
     4 , '- H-Perp  = Perpendicular distance of H to ring plane J', /,
     5 '- Gamma   = Angle between Cg-H vector and ring J normal', /,
     6 '- X-H..Cg = X-H-Cg angle (degrees)', /,
     7 '- X..Cg   = Distance of X to Cg (Angstrom)', /,
     8 '- X-H, Pi = Angle of the X-H bond with the Pi-plane (i.e.',
     9 ' Perpendicular = 90 degrees, Parallel = 0 degrees)', //,
     * '   X--H(I)    Res(I)', 3X,
     1 'Cg(J)  [', 3X, 'ARU(J)]', 7X, 'H..Cg', 2X,
     2 'Transformed J-Plane P, Q, R, S  H-Perp Gamma', 6X,
     3 'X-H..Cg', 8X, 'X..Cg X-H,Pi', /)
99991 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', /)
99990 FORMAT (43X, 10('-'), 33X, 46('-'), /, 36X, 'Min or Max',
     1        F7.3, 32X, F7.3, F7.1, 5X, F8.2, 5X, F8.3, F7.2)
99989 FORMAT (35X, 10('-'), 33X, 44('-'), /, 28X, 'Min or Max',
     1        F7.3, 35X, 3F6.1, 2F12.3, F8.3)
99988 FORMAT (/, '   X--H(I)    Res(I)', 3X, 'Cg(J)  [', 3X, 'ARU(J)]',
     1       7X, 'H..Cg', 2X, 'Gamma')
99987 FORMAT (A, F6.1)
99986 FORMAT (/, '   Y--X(I)    Res(I)', 3X, 'Cg(J)  [', 3X, 'ARU(J)]',
     1       7X, 'X..Cg', 2X, 'Gamma')
      END SUBROUTINE PLA048
 
      SUBROUTINE PLA049 (IFUN, D)
C * DETERMINE DERIVED PARAMETER ERROR BY ERROR PROPAGATION
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: KM
      INTEGER            :: ITP
      INTEGER            :: IFUN
      INTEGER            :: ITEK
      REAL               :: D
      REAL               :: SINC
      REAL               :: GEN009
      REAL, DIMENSION(8) :: DSV
      REAL, DIMENSION(3) :: VECIJK
      REAL, DIMENSION(3) :: VECIJKD
      KM     = 1
      DSV(1) = D
      DSV(2) = XPV(1)
      IF (IFUN == 2) THEN
        CALL GEN008 (VECIJ, VECJK, VECIJK, 0)
      ELSE IF (IFUN == 4) THEN
C * SAVE XPV TEMPORARILY IN DSV
        DO I = 1, 8
          DSV(I) = XPV(I)
        END DO
        KM = 4
      END IF
      DO I = 1, NDERIV
        ITP = IDIR(I)
        DO J = 1, 3
          ITEK = 1
          SINC = SQRT (XSD(ITP, J + 3))
          XXO(ITP, J + 3) = XXO(ITP, J + 3) + SINC
C * BOND
          IF (IFUN == 1) THEN
            CALL PLA050 (IDIR(1), IDIR(2), 0, 0, XPV(1))
C * ANGLE
          ELSE IF (IFUN == 2) THEN
            CALL PLA050 (IDIR(1), IDIR(2), IDIR(3), 0, XPV(1))
            CALL GEN008 (VECIJ, VECJK, VECIJKD, 0)
            IF (GEN009 (VECIJK, VECIJKD) < 0.0)
     1        XPV(1) = 360.0 - XPV(1)
C * TORSION
          ELSE IF (IFUN == 3) THEN
            CALL PLA050 (IDIR(1), IDIR(2), IDIR(3), IDIR(4), XPV(1))
            IF ((DSV(1) - XPV(1)) > 180.0)  THEN
              XPV(1) = XPV(1) + 360.0
            ELSE IF ((DSV(1) - XPV(1)) < -180.0) THEN
              XPV(1) = XPV(1) - 360.0
            END IF
C * PLANE
          ELSE IF (IFUN == 4) THEN
            CALL PLA054 (0)
            ITEK = NINT(GEN009(XPV, DSV))
          END IF
          XXO(ITP, J + 3) = XXO(ITP, J + 3) - SINC
C * MAKE SURE THAT PLANES ARE ORIENTED SIMILARLY
          DO K = 1, KM
            XDIR(I, J, K) = ITEK * XPV(K) - DSV(K)
          END DO
        END DO
      END DO
      D      = DSV(1)
      XPV(1) = DSV(2)
      IF (IFUN == 4) THEN
        DO I = 1, 8
          XPV(I) = DSV(I)
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA049
 
      SUBROUTINE PLA050 (I, J, K, L, D)
C * DISTANCE, BOND-ANGLE and TORSION ANGLE CALCULATION ROUTINE
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      REAL               :: D
      REAL               :: C
      REAL               :: DK
      REAL               :: DAB
      REAL               :: DAK
      REAL               :: DBK
      REAL               :: GEN009
      REAL, DIMENSION(3) :: R
      REAL, DIMENSION(3) :: S
      REAL, DIMENSION(3) :: T
      D = 0
      IF ((I > 0 .AND. I <= NP1) .AND.
     1    (J > 0 .AND. J <= NP1)) THEN
        IF (K == 0) THEN
C * CHECK FOR DISTANCE CALCULATION
          DO M = 1, 3
            DK = XXO(I, M + 3) - XXO(J, M + 3)
            D = D + DK**2
          END DO
          D = SQRT(D)
          RETURN
C * CHECK FOR BOND ANGLE CALCULATION
        ELSE IF ((K > 0 .AND. K <= NP1) .AND. L == 0) THEN
          DAK = 0
          DBK = 0
          DAB = 0
          DO M = 1, 3
            VECIJ(M)  = XXO(I, M + 3) - XXO(J, M + 3)
            VECJK(M)  = XXO(K, M + 3) - XXO(J, M + 3)
            DAK       = DAK + VECIJ(M)**2
            DBK       = DBK + VECJK(M)**2
            DAB       = DAB + VECIJ(M)*VECJK(M)
          END DO
          IF (DAK > 0.0 .AND. DBK > 0.0) THEN
            C = DAB / SQRT (DAK * DBK)
            C = MAX (-1.0, MIN (1.0, C))
            D = ACOS(C) * RGBL(6)
          END IF
          RETURN
C * CHECK FOR TORSION ANGLE CALCULATION
        ELSE IF (L > 0 .AND. L <= NP1) THEN
          DO N = 1, 3
            VECIJ(N) = XXO(J, N + 3) - XXO(I, N + 3)
            VECJK(N) = XXO(K, N + 3) - XXO(J, N + 3)
            VECKL(N) = XXO(L, N + 3) - XXO(K, N + 3)
          END DO
          CALL GEN008 (VECIJ, VECJK, R, 1)
          CALL GEN008 (VECJK, VECKL, S, 1)
          CALL GEN008 (R, S, T, 1)
          D = MAX (-1.0, MIN (1.0, GEN009(R, S)))
          D = ACOS (D) * RGBL(6)
          IF (GEN009 (VECJK, T) < 0.0) D = - D
          RETURN
        END IF
      END IF
      WRITE (LU6, 99999, IOSTAT = IOST) I, J, K, L
      WRITE (LU7, 99999, IOSTAT = IOST) I, J, K, L
      RETURN
99999 FORMAT (/, 'F: Invalid arg(s) in call to PLA050 ', 4I8, /)
      END SUBROUTINE PLA050
 
      SUBROUTINE PLA051 (IAT)
C * SET PARAMETERS FOR S.U. CALCULATION
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: IAT
      NDERIV       = NDERIV + 1
      IDIR(NDERIV) = IAT
      DO I = 1, 3
        DO J = 1, 4
          XDIR(NDERIV, I, J) = 0.0
        END DO
      END DO
      RETURN
      END SUBROUTINE PLA051
 
      SUBROUTINE PLA052 (IFUN, SD)
C * SET PARAMETERS FOR ESD CALCULATION (LS-PLANE)
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: KM
      INTEGER            :: IFUN
      REAL               :: YUNK
      REAL, DIMENSION(*) :: SD
      IF (IFUN == 4) THEN
        KM = 4
        DO K = 1, KM
          SD(K) = 0.0
        END DO
      ELSE
        KM    = 1
        SD(1) = 0.0
      END IF
      DO I = 1, NDERIV
        DO J = 1, 3
          DO K = 1, KM
            YUNK = XDIR(I, J, K)
            IF (ABS (YUNK) > 1.0E-15) SD(K) = SD(K) + YUNK**2
          END DO
        END DO
      END DO
      DO K = 1, KM
        SD(K) = SQRT (SD(K))
      END DO
      RETURN
      END SUBROUTINE PLA052
 
      SUBROUTINE PLA053 (I0, J0, K0, L0, D, SD, ISD, NDEC, IER)
C * CALCULATE DISTANCE (MODE = 1 - K0 = 0 & L0 = 0),
C *           ANGLE    (MODE = 2 - L0 = 0) OR
C *           TORSION  (MODE = 3) WITH S.U. (E.S.D.)
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: I0
      INTEGER            :: J0
      INTEGER            :: K0
      INTEGER            :: L0
      INTEGER            :: ISD
      INTEGER            :: NDEC
      INTEGER            :: IER
      INTEGER            :: JHAT
      INTEGER            :: KHAT
      INTEGER            :: LHAT
      INTEGER            :: IDUM
      INTEGER            :: IHAT
      INTEGER            :: IVAL
      INTEGER            :: JVAL
      INTEGER            :: KVAL
      INTEGER            :: MODE
      INTEGER            :: NDCD
      INTEGER            :: NHAT
      INTEGER            :: NRND
      INTEGER            :: NOESD
      INTEGER            :: IPR68
      INTEGER            :: NESDI
      INTEGER            :: NESDJ
      INTEGER            :: NESDK
      INTEGER            :: NESDL
      REAL               :: D
      REAL               :: SD
      REAL               :: D1
      REAL               :: SDADD
      REAL               :: GEN158
      REAL, DIMENSION(2) :: SDD
      REAL, DIMENSION(3) :: X1
      REAL, DIMENSION(3) :: X2
      REAL, DIMENSION(3) :: X3
      I    = I0
      J    = J0
      K    = K0
      L    = L0
      IHAT = 0
      JHAT = 0
      KHAT = 0
      LHAT = 0
      IER  = 0
C * DEFAULT WITH ESD
      NOESD = 1
      SD    = 0.0
      IF (L < 0) THEN
        L    = -L
        NRND = 1
      ELSE
        NRND = 0
      END IF
      CALL PLA050 (I, J, K, L, D)
C * ATOM I COORDINATE SU'S (ISU) (NO = 0)
      CALL GEN048 (-1, IFG(2, I), 10, NESDI)
      CALL GEN048 (-1, IFG(1, I), 7,  IHAT)
      IF (IHAT == 1) NOESD = MIN (NOESD, NESDI)
C * CHECK WHETHER ATOM IS OMITTED
      IF (NESDI == 1) THEN
        CALL GEN048 (-1, IFG(2, I), 30, IVAL)
        IF (IVAL == 1) NESDI = 0
      END IF
C * ATOM J COORDINATE SU
      CALL GEN048 (-1, IFG(2, J), 10, NESDJ)
      CALL GEN048 (-1, IFG(1, J), 7,  JHAT)
      IF (JHAT == 1) NOESD = MIN (NOESD, NESDJ)
C * CHECK WHETHER ATOM IS OMITTED
      IF (NESDJ == 1) THEN
        CALL GEN048 (-1, IFG(2, J), 30, IVAL)
        IF (IVAL == 1) NESDJ = 0
      END IF
C * CHECK FOR BONDS
      IF (K == 0) THEN
        MODE  = 1
        NDCD  = 4
        NESDK = 0
        NESDL = 0
C * CHECK FOR ANGLES
      ELSE
        CALL GEN048 (-1, IFG(2, K), 10, NESDK)
        CALL GEN048 (-1, IFG(1, K), 7,  KHAT)
        IF (KHAT == 1) NOESD = MIN (NOESD, NESDK)
C * CHECK WHETHER ATOM IS OMITTED
        IF (NESDK == 1) THEN
          CALL GEN048 (-1, IFG(2, K), 30, IVAL)
          IF (IVAL == 1) NESDK = 0
        END IF
        NDCD = 2
        IF (L == 0) THEN
          MODE  = 2
          NESDL = 0
          IF (D < 1.0)  IER = - 1
          CALL GEN048 (-1, IFG(1, I), 5, IVAL)
          CALL GEN048 (-1, IFG(1, J), 6, JVAL)
          CALL GEN048 (-1, IFG(1, K), 5, KVAL)
          IF (ABS (180.0 - D) < 0.05) THEN
            IF (JVAL == 1 .AND. IVAL + KVAL == 1) NOESD = 0
          ELSE IF (ABS (120.0 - D) < 0.05 .OR.
     1             ABS (60.0  - D) < 0.05) THEN
            CALL GEN048 (-1, IFG(1, J), 6, IVAL)
            IF (JVAL == 1 .AND. IVAL + KVAL == 1) THEN
              IF (IPR(259) == 5 .OR. IPR(259) == 6) NOESD = 0
            END IF
          END IF
C * CHECK FOR TORSIONS
        ELSE
          CALL GEN048 (-1, IFG(2, L), 10, NESDL)
          CALL GEN048 (-1, IFG(1, L), 7, LHAT)
          IF (LHAT == 1) NOESD = MIN (NOESD, NESDL)
C * CHECK WHETHER ATOM IS OMITTED
          IF (NESDL == 1) THEN
            CALL GEN048 (-1, IFG(2, L), 30, IVAL)
            IF (IVAL == 1) NESDL = 0
          END IF
          MODE = 3
          CALL PLA050 (I, J, 0, 0, D1)
          IF (D1 < 0.1) IER = - 1
          CALL PLA050 (K, L, 0, 0, D1)
          IF (D1 < 0.1) IER = - 1
          CALL PLA050 (I, K, 0, 0, D1)
          IF (D1 < 0.1) IER = - 1
          CALL PLA050 (J, L, 0, 0, D1)
          IF (D1 < 0.1) IER = - 1
        END IF
      END IF
      IF (NOESD == 1) THEN
        IF (NESDI + NESDJ + NESDK + NESDL /= 0) THEN
          NDERIV = 0
          CALL PLA051 (I)
          CALL PLA051 (J)
          IF (K > 0) CALL PLA051 (K)
          IF (L > 0) CALL PLA051 (L)
          CALL PLA049 (MODE, D)
          CALL PLA052 (MODE, SDD)
        ELSE
          SDD = 0.0
        END IF
C * ADD CELL ERROR CONTRIBUTION TO BOND SU
        IF (K == 0) THEN
          SD = SQRT(SDD(1)**2 + (PAR(13) * D)**2)
C * ADD CELL ERROR CONTRIBUTION TO BOND ANGLE
        ELSE IF (L == 0) THEN
          DO N = 1, 3
             X1(N) = XXO(I, N)
             X2(N) = XXO(J, N)
             X3(N) = XXO(K, N)
          END DO
          SDADD = GEN158(PAR(101), PAR(107), X1, X2, X3)
          IF (SDADD > 0.0) THEN
            SD = SQRT (SDD(1)**2 + SDADD)
          ELSE
            SD = SDD(1)
          END IF
C * ADD CELL ERROR CONTRIBUTION TO TORSION ANGLE
        ELSE
          SD = SQRT (SDD(1)**2 + PAR(14)**2)
        END IF
      END IF
      IDUM = NDCD
      DO
        CALL GEN041 (D, SD, ISD, IDUM, NDEC, IPR(68))
        IF (IPR(68) == 0) THEN
          IF (ISD > 99 .AND. IDUM > 0) THEN
            IDUM = IDUM - 1
            CYCLE
          END IF
          IPR68 = 10
          EXIT
        ELSE
          IPR68 = IPR(68)
          EXIT
        END IF
      END DO
      IF (ISD > IPR68 * 10 - 1) THEN
        ISD  = -1
        NDEC = 0
        SD   = -1.0
      END IF
      IF (ISD == 0 .AND. NRND == 0) THEN
        NHAT = IHAT + JHAT + KHAT + LHAT
        IF (NHAT /= 0) THEN
          IF (MODE == 1) THEN
            NDEC = 2
            D = NINT (D * 100.0) / 100.0
          ELSE
            NDEC = 0
            D    = NINT (D)
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA053
 
      SUBROUTINE PLA054 (MODE)
C * CALCULATE THE L.S. PLANE THROUGH NATP ATOMS GIVEN IN IATP
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: KP
      INTEGER               :: IVL
      INTEGER               :: MODE
      INTEGER               :: NMAX
      INTEGER               :: IWHT
      REAL                  :: WM
      REAL                  :: WHT
      REAL                  :: GEN009
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3)    :: B
      REAL, DIMENSION(3, 3) :: C
      NMAX = IPR(39)
C * THE METHOD IS TO CALCULATE THE PRINCIPLE AXES OF INERTIA -
C * THE L.S.-PLANE IS NORMAL TO THE AXIS OF GREATEST INERTIA.
      WHT = 1.0
      IF (MODE == 1) THEN
        IWHT = 1
      ELSE
        IWHT = IPR(41)
      END IF
C * GET THE MASS CENTRE
      CALL GEN074 (V7, 1, 3, 0.0)
      KP = 0
      WM = 0
      DO N = 1, NMAX
        I = IATP(N)
        IF (I <= NP1) THEN
          IF (IWHT == 1) THEN
            CALL GEN048 (-4, IFG(1, I), 15, IVL)
            WHT = SATWT(IVL + 1)
          ELSE IF (IWHT == 2) THEN
            WHT = 3.0 / (XSD(I, 4) + XSD(I, 5) + XSD(I, 6))
          END IF
          KP = KP + 1
          WM = WM + WHT
          DO J = 1, 3
            V7(J) = V7(J) + WHT * XXO(I, J + 3)
          END DO
        END IF
      END DO
C * WEIGHTED CENTER OF GRAVITY
      DO I = 1, 3
        V7(I) = V7(I) / WM
        DO J = 1, 3
          C(I, J) = 0.0
        END DO
      END DO
C * SET UP THE INERTIAL MATRIX (= C)
      DO N = 1, NMAX
        I = IATP(N)
        IF (I <= NP1) THEN
          IF (IWHT == 1) THEN
            CALL GEN048 (-4, IFG(1, I), 15, IVL)
            WHT = SATWT(IVL + 1)
          ELSE IF (IWHT == 2) THEN
            WHT = 3.0 / (XSD(I, 4) + XSD(I, 5) + XSD(I, 6))
          END IF
          DO J = 1, 3
            B(J) = XXO(I, J + 3) - V7(J)
          END DO
          C(1, 1) = C(1, 1) + WHT * (B(2)**2 + B(3)**2)
          C(1, 2) = C(1, 2) - WHT *  B(1) * B(2)
          C(1, 3) = C(1, 3) - WHT *  B(1) * B(3)
          C(2, 2) = C(2, 2) + WHT * (B(1)**2 + B(3)**2)
          C(2, 3) = C(2, 3) - WHT *  B(2) * B(3)
          C(3, 3) = C(3, 3) + WHT * (B(1)**2 + B(2)**2)
        END IF
      END DO
      CALL GEN024 (C, A, B, DUMV)
C * ARRAY DUMV CONTAINS EIGENVECTORS AS COLUMNS, C  CONTAINS EIGENVALUES
      DO I = 1, 3
        XPV(I)  = DUMV(I, 1)
        DUMA(I) = B(I)
      END DO
C * THE EQUATION OF THE PLANE IS  PV . X = D
C * THE MASS CENTRE LIES ON THE P, SO WE CAN CALCULATE D
      XPV(4) = GEN009(XPV, V7)
      XPV(8) = XPV(4)
      RETURN
      END SUBROUTINE PLA054
 
      SUBROUTINE PLA055
C * LEAST-SQUARES PLANE CALCULATION (WITH S.U.)
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: NMAX
      INTEGER :: IATPI
      REAL    :: D
      REAL    :: XLNG
      REAL    :: YUNK
      NMAX = IPR(39)
      CALL PLA054 (0)
      CALL GEN002 (-1, OR, XPV(1), XPV(5), XLNG)
      CALL GEN074 (XSPV, 1, 8, 0.0)
      IF (IPR(72) > 0) THEN
        NDERIV = 0
        N    = 0
        DO I = 1, NMAX
          IATPI = IATP(I)
          IF (IATPI <= NP1) THEN
            N = N + 1
C * DO NOT CALC. PLANE ESD FOR L.S. PLANES THROUGH MORE THAN NP7 ATOMS
            IF (N > NP7) RETURN
            CALL PLA051 (IATPI)
          END IF
        END DO
        D = 0.0
        CALL PLA049 (4, D)
        CALL PLA052 (4, XSPV)
        DO J = 1, 3
          XSPV(4 + J) = 0.0
          DO K = 1, 3
            YUNK = XSPV(K) * OR(K, J)
            IF (ABS (YUNK) > 1.0E-15) THEN
              XSPV(4 + J) = XSPV(4 + J) + YUNK**2
            END IF
          END DO
        END DO
        DO K = 5, 7
          XSPV(K) = SQRT (XSPV(K))
        END DO
        XSPV(8) = XSPV(4)
      END IF
      RETURN
      END SUBROUTINE PLA055
 
      SUBROUTINE PLA056 (PV, IAT, D, SD, ISD, NDECD, NDEC)
C * ROUTINE TO CALCULATE DISTANCE + S.U. OF AN ATOM (IAT) TO A PLANE (PV)
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: IAT
      INTEGER            :: ISD
      INTEGER            :: NDECD
      INTEGER            :: NDEC
      REAL               :: D
      REAL               :: SD
      REAL               :: DAC
      REAL               :: DACD
      REAL               :: SINC
      REAL, DIMENSION(*) :: PV
      ISD  = 0
      NDEC = NDECD
      SD   = 0.0
C * CALCULATE DISTANCE
      D = - PV(4)
      DO I = 1, 3
        D = D + PV(I) * XXO(IAT, I + 3)
      END DO
C * NUMERICAL PROPAGATION OF ERROR CALCULATION OF S.U.
      IF (IPR(72) /= 0) THEN
        DO I = 1, 3
C * SET INCREMENT AT 1/2 S.U.
          SINC = SQRT (XSD(IAT, I + 3)) / 2.0
          IF (SINC > 0.0) THEN
            XXO(IAT, I + 3) = XXO(IAT, I + 3) + SINC
            DAC = - PV(4)
            DO J = 1, 3
              DAC = DAC + PV(J) * XXO(IAT, J + 3)
            END DO
            XXO(IAT, I + 3) = XXO(IAT, I + 3) - SINC
            DACD = ABS (DAC - D)
            IF (DACD > 0.1E-10) THEN
              SD = SD + (DACD**2) * 4.0
            END IF
          END IF
        END DO
        SD = SQRT (SD)
C * ROUND
        CALL GEN041 (D, SD, ISD, NDECD, NDEC, IPR(68))
      END IF
      RETURN
      END SUBROUTINE PLA056
 
      SUBROUTINE PLA057 (IAT, JAT, KAT)
C * OUTPUT SHORT INTRA/INTER MOLECULAR CONTACTS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: N
      INTEGER           :: NC
      INTEGER           :: MN
      INTEGER           :: IAT
      INTEGER           :: JAT
      INTEGER           :: KAT
      INTEGER           :: NCI
      INTEGER           :: NCJ
      INTEGER           :: IHA
      INTEGER           :: IER
      INTEGER           :: IAN0
      INTEGER           :: IARU
      INTEGER           :: IDOA
      INTEGER           :: IDOH
      INTEGER           :: KDOA
      INTEGER           :: KDOH
      INTEGER           :: MOL2
      INTEGER           :: JNCX
      INTEGER           :: INCX
      INTEGER           :: IDUM1
      INTEGER           :: IDUM2
      INTEGER           :: IDUM3
      INTEGER           :: IKDOH
      INTEGER           :: IPOPI
      INTEGER           :: IPR20
      INTEGER           :: ISDIJ
      INTEGER           :: ISKIP
      INTEGER           :: KATHA
      INTEGER           :: NATHX
      INTEGER           :: NATHY
      INTEGER           :: IANGL
      INTEGER           :: NDEC1
      INTEGER           :: NDEC2
      INTEGER           :: NLINE
      INTEGER           :: IPOPK
      INTEGER           :: IDSORD
      REAL              :: X1
      REAL              :: X2
      REAL              :: X3
      REAL              :: X4
      REAL              :: SA
      REAL              :: DIJ
      REAL              :: ANGL
      REAL              :: DELT
      REAL              :: DMX0
      REAL              :: SDIJ
      REAL              :: XMOL2
      REAL              :: ANGLE
      REAL              :: DIJ29
      REAL              :: TESTVAL
      CHARACTER(len=2)  :: MARK
      CHARACTER(len=5)  :: IMRK1
      CHARACTER(len=98) :: FORMI
      CHARACTER(len=24) :: FORMJ
      CHARACTER(len=6)  :: FORMK
      CHARACTER(len=9)  :: CXMOL2
      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) < 100.0) FORMK(5:5) = '1'
C * OUTPUT OF SHORT CONTACTS
      IF (IPR(90) == 1) THEN
C * HEADER PRINT TEST
        IF (IPR(15) <= 0) THEN
          IF (IPR(15) == 0 .AND. IGBL(63) > 2) THEN
C * NEWPAGE
            CALL PLA262 (-6)
C * LIST CONTACT RADII USED FOR INTER ANALYSES
C * BUT DO NOT INCLUDE 'CG' ENTRY IN LISTING
            IF (LMT(IENS(IAN), 1) == 'Cg') THEN
              IAN0 = IAN - 1
            ELSE
              IAN0 = IAN
            END IF
            WRITE (LU7, 99997, IOSTAT = IOST) PAR(1), PAR(33),
     1        (LMT(IENS(K), 1), K = 1, IAN0)
            WRITE (LU7, 99996, IOSTAT = IOST)
     1       (RADR(IENS(K), 2), K = 1, IAN0)
            IF (IGBL(63) > 3) THEN
              CALL PLA262 (6)
              WRITE (LU7, 99998, IOSTAT = IOST)
            END IF
          END IF
          CALL PLA066 (0, 0, 0, 0, 0.0, 0.0, 0.0, 0.0, 0.0)
C * CALL EXIT/STOP
          IF (IPR(2) /= 0) CALL GEN127 ('302')
C * ARU HEADER PRINT
          PAR(67) = 1555.0 + IPR(61) / PAR(42)
          IF (IPR(75) /= 1 .AND. IGBL(63) > 2) THEN
            CALL PLA262 (6)
            WRITE (LU7, 99999, IOSTAT = IOST) PAR(67)
          END IF
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (3)
            WRITE (LU7, 99995, IOSTAT = IOST) PAR(67)
          END IF
          IPR(15) = 1
        END IF
C * GET LABEL AND DISORDER INFORMATION ON IAT
        CALL PLA036 (IAT, 1, 1, IPOPI, IDUM1, IDUM2, IPR(71), IGBL(55))
        IDSORD = 0
        IF (IPR(67) /= 0) IPOPI = 10000
        IF (IPOPI < 10000) THEN
          IDSORD = IDSORD + 10
          X1 = - IAT
        ELSE
          X1 = IAT
        END IF
        X3  = 0.0
        NCI = - NINT (CON(IAT, 9))
        IF (NCI < 0) NCI = 9
        IF (NCI > 0) THEN
          INCX = NINT (CON(IAT, 1))
          IF (INCX > 0 .AND. INCX <= NP1) THEN
            X3 = INCX
C * GET NUMBER OF ATTACHED H-ATOMS
            CALL GEN048 (-3, IFG(2, INCX), 24, NATHX)
          ELSE
            RETURN
          END IF
        END IF
C * GET LABEL AND DISORDER INFORMATION ON KAT
        CALL PLA036 ( KAT, 1, 4, IPOPK, MN, IDUM2, IPR(71), IGBL(55))
        CALL PLA036 (-KAT, 1, 2, IPOPK, MN, IDUM2, IPR(71), IGBL(55))
        IF (IPOPK < 10000) THEN
          IDSORD = IDSORD + 1
          X2 = - JAT
        ELSE
          X2 = JAT
        END IF
        X4  = 0.0
        NCJ = - NINT (CON(JAT, 9))
        IF (NCJ < 0) NCJ = 9
        IF (NCJ > 0) THEN
          JNCX = NINT (CON(JAT, 1))
          IF (JNCX > 0 .AND. JNCX <= NP1) THEN
            X4 = JNCX
C * GET NUMBER OF ATTACHED H-ATOMS
            CALL GEN048 (-3, IFG(2, JNCX), 24, NATHY)
          ELSE
            RETURN
          END IF
        END IF
        MOL2 = MOL(MN)
        IARU = NINT (PAR(42))
        IF (MOL2 == 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 < 0) THEN
          DIJ29 = DIJ29 + 100.0
          MARK  = ' <'
          IF (DELT + PAR(1) < 0.0) THEN
C * TEST FOR H-(,D) ATOM
            CALL GEN048 (-1, IFG(1, IAT), 7, IHA)
            CALL GEN048 (-1, IFG(1, KAT), 7, KATHA)
C * TEST FOR D-H(D) ATOM
            CALL GEN048 (-1, IFG(1, IAT), 20, IDOH)
            CALL GEN048 (-1, IFG(1, KAT), 20, KDOH)
C * TEST FOR POTENTIAL ACCEPTOR
            CALL GEN048 (-1, IFG(2, IAT), 28, IDOA)
            CALL GEN048 (-1, IFG(2, KAT), 28, KDOA)
C * REGISTER EXTREME SHORT INTER CONTACTS
            IF (DELT < PAR(199) .AND. IAT < KAT) THEN
              IF ((IDOH == 1 .OR. KDOA == 1) .AND.
     1            (IDOA == 1 .OR. KDOH == 1)) THEN
                IPR(160) = IPR(160) + 1
              END IF
              PAR(200) = MIN (DELT, PAR(200))
            END IF
C * HANDLE SHORT CONTACT
            IF (DELT < PAR(251 + 2 * IPR(20))
     1          .AND. IAT <= JAT) THEN
              IF (IHA == 1 .AND. KATHA == 1 .AND.
     1            (IPOPI == 10000 .OR. IPOPK == 10000)) THEN
C * HANDLE SPECIAL H-X-H CASE WITH NCI OR NCJ > 1)
                ISKIP = 0
                IF (KAT == JAT) THEN
                  DO I = 1, NCI
                    DO J = 1, NCJ
                      IF (NINT (CON(IAT, I)) == NINT (CON(JAT, J)))
     1                  ISKIP = 1
                    END DO
                  END DO
                END IF
                IF (ISKIP == 0) 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 == 0) THEN
                    IF (NATHX == 3 .OR. NATHY == 3)
     1                IPR20 = IPR20 + 2
                  ELSE IF (IKDOH == 1) THEN
                    IPR20 = IPR(20) + 4
                  ELSE IF (IKDOH == 2) THEN
                    IPR20 = IPR(20) + 6
                  END IF
C * ALERT _41x
                  CALL PLA393 (MOL2, PAR(42), IDM)
                  IF (IPOPI < 10000 .OR. IPOPK < 10000) THEN
                    TESTVAL = -999.0
                  ELSE
                    TESTVAL = - DELT
                  ENDIF
                  IF (KDOA > 0) TESTVAL = - 999.0
                  CALL PLA236 (-(410 + IPR20), 2,
     1              TESTVAL, DIJ, NAMS(1, 1)(2:10), NAMS(1, 2)(2:10))
                  CALL PLA236 (0, 0, 0.0, 0.0, IDM, ' ')
                END IF
              END IF
            END IF
            DIJ29 = DIJ29 + 100.0
            MARK = '<<'
C * STORE SHORT INTER CONTACT FOR CLUSTER/NETWORK ANALYSIS
C * BUT EXCLUDE THE MINOR DISORDER CONTACTS
            IF (IPOPI >= 5000 .AND. IPOPK >= 5000) THEN
              IF (IHA /= 1 .AND. KATHA /= 1 .AND. IPR(20) == 1)
     1          THEN
                  IF (IPR(88) < NP2) THEN
                    IPR(88)         = IPR(88) + 1
                    XLS(1, IPR(88)) = IAT
                    XLS(2, IPR(88)) = PAR(67)
                    XLS(3, IPR(88)) = JAT
                    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
C * OVERFLOW
                    IPR(149) = IPR(149) + 100
                  END IF
              END IF
            END IF
          END IF
        END IF
        IF (IPR(20) == 1) THEN
          CALL PLA066 (1, MOL2, NATHX, NATHY, X1, X2, X3, X4, DIJ29)
C * CALL EXIT/STOP
          IF (IPR(2) /= 0) CALL GEN127 ('303')
        END IF
        IF (IPR(20) == 0) THEN
          IMRK1 = 'Intra'
        ELSE
          IMRK1 = '     '
        END IF
        ANGL  = -1.0
        SA    = 0.0
        IANGL = 0
        NC    = - NINT (CON(IAT, 9))
        N     = 0
        NLINE = 0
        DO
          N = N + 1
          IF (N > NC) THEN
            IF (NLINE /= 0) RETURN
          ELSE
            K = NINT (CON(IAT, N))
            IF (K > IPR(37)) CYCLE
            CALL PLA053 (K, IAT, KAT, 0, ANGLE, SA, IANGL, NDEC2, IER)
            IF (IER /= 0) CYCLE
            IF (ANGLE < PAR(33)) CYCLE
C * GET LABEL AND DISORDER INFO ON K
            CALL PLA036 (K, 1, 3, IDUM1, IDUM2, IDUM3, IPR(71),
     1        IGBL(55))
            ANGL  = ANGLE
            IANGL = MIN (999, IANGL)
          END IF
          IF (NLINE == 0) THEN
            WRITE (CXMOL2, FORMK, IOSTAT = IOST) XMOL2
            IF (INT (XMOL2) == 1555) CXMOL2 = '         '
            FORMI(36 : 36) = CHAR (ICHAR ('0') + NDEC1)
            IF (ANGL < 0) THEN
              WRITE (PRBUF, FORMI, IOSTAT = IOST)
     1          (NAMS(1, L)(1:8), L = 1, 2), CXMOL2, DIJ, ISDIJ, MARK,
     2          DMX0, DELT, IMRK1, (XXO(IAT, L), L = 1, 3),
     3          (XXO(KAT, L), L = 1, 3)
            ELSE
              FORMI(86 : 86) = CHAR (ICHAR ('0') + NDEC2)
              WRITE (PRBUF, FORMI, IOSTAT = IOST)
     1         (NAMS(1, L)(1:8), L = 1, 2), CXMOL2, DIJ, ISDIJ, MARK,
     2         DMX0, DELT, IMRK1, (XXO(IAT, L), L = 1, 3),
     3         (XXO(KAT, L), L = 1, 3), NAMS(1, 3)(1:8), ANGL, IANGL
            END IF
C * GENERATE TABLE/CIF DATA
            IF (MN < 28) THEN
              IF (IPR(438) * IGBL(97) == 1) THEN
                IPR(254) = IPR(254) + 1
                WRITE (LU2, 99994, IOSTAT = IOST)
     1            NAMS(1, 1)(2:8), NAMS(1, 4)(2:8), DIJ, SDIJ
              END IF
            END IF
          ELSE
            FORMJ(12 : 12) = CHAR (ICHAR ('0') + NDEC2)
            WRITE (PRBUF, FORMJ, IOSTAT = IOST) NAMS(1, 3)(1:8),
     1      ANGL, IANGL
          END IF
          IF (IGBL(63) > 2) CALL PLA263 (LU7, PRBUF, 132, 1, 11)
          NLINE = NLINE + 1
        END DO
      END IF
      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)
      END SUBROUTINE PLA057
 
      SUBROUTINE PLA058 (LU)
C * SAVE SYMMETRY OPERARATIONS FROM CIF
      USE pl273
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: LU
      INTEGER           :: IOST
      CHARACTER(len=80) :: LINE
      NSCF = 0
      CALL GEN108 (LU, 0)
      DO
        READ (LU, IOSTAT = IOST) LINE
        IF (IOST /= 0) EXIT
        IERR  = 0
        SELECT CASE (LINE(1:4))
C * SYMM FROM SAVED FROM CIF
          CASE ('SYMM')
            CALL SGSM (22, LINE, SGX, 0, 0, IERR)
            NSCF = NSCF + 1
            DO I = 1, 4
              NSCIF(I, NSCF) = NINT (SGX(I + 8))
            END DO
            IF (NSID(NSCF) == 0) NSID(NSCF) = NSCF
          CASE ('BOND')
            EXIT
        END SELECT
      END DO
      RETURN
      END SUBROUTINE PLA058
 
      SUBROUTINE PLA059 (JAT, KAT)
C * ORTHOGONALISE - SYMMETRY INFO TRANSFERRED THROUGH ITR & IPR(54)
 
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: L
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: JP3
      INTEGER :: NSMM
      REAL    :: ORJK
      IF (JAT > NP1 .OR. JAT <= 0) THEN
        WRITE (LU6, 99999, IOSTAT = IOST) JAT, KAT
C * CALL EXIT/STOP
        CALL GEN127 ('Report problem to Author')
      ELSE
        IF (JAT /= KAT) THEN
C * APPLY SYMMETRY TRANSFORMATION
          DO I = 1, 3
            SGY(I + 3) = 0.0
            SGY(I)     = XXO(JAT, I)
          END DO
          CALL SGSM (3, ICL, SGY, IPR(54), LU7, IERR)
          DO I = 4, 6
            SGZ(I)           = SGY(I + 3) + ITR(I - 3)
            SGZ(IPR(30 + I)) = SGZ(I)
          END DO
C * TRANSFORM ESD FOR SYMMETRY TRANSFORMATION (NOT FOR SOLV & VOID)
          IF (IPR(189) == 0) THEN
            DO I = 1, 3
              SGY(I) = XSD(JAT, I)
            END DO
            NSMM = -IPR(54)
            CALL SGSM (3, ICL, SGY, NSMM, LU7, IERR)
          END IF
        END IF
        DO I = 1, 3
          J   = 4 - I
          JP3 = J + 3
          IF (JAT /= KAT) THEN
            XXO(KAT, J) = SGZ(JP3)
            XSD(KAT, J) = SGY(J + 6)
          END IF
          XXO(KAT, JP3) = 0.0
          XSD(KAT, JP3) = 0.0
          DO L = J, 3
            ORJK = OR(J, L)
            XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * ORJK
C * NOT FOR SOLV & VOID CALCULATIONS
            IF (IPR(189) == 0) THEN
C * S.U. REQUESTED
              IF (IPR(72) /= 0) THEN
                XSD(KAT, JP3) = XSD(KAT, JP3) + XSD(KAT, L) * ORJK**2
              END IF
            END IF
          END DO
        END DO
      END IF
      RETURN
99999 FORMAT (/, 'Problem in PLA059; JAT & KAT =', 2I12, /)
      END SUBROUTINE PLA059
 
      MODULE latice
      SAVE
C * THE ROTATIONS AND TRANSLATIONS IN TWELFTHS FOR SYMMETRY ELEMENTS,
C * IN THE ORDER 6, 3, 4, 2, 1.
      REAL, DIMENSION(3, 5, 5)   :: ROT = RESHAPE ((/
     1  -1.0,-1.0, 0.0,  1.0, 0.0, 0.0,  0.0, 0.0,-1.0,  0.0, 0.0, 0.0,
     2   0.0, 0.0, 2.0,  0.0,-1.0, 0.0,  1.0, 1.0, 0.0,  0.0, 0.0,-1.0,
     3   0.0, 0.0, 0.0,  0.0, 0.0, 4.0,  0.0,-1.0, 0.0,  1.0, 0.0, 0.0,
     4   0.0, 0.0,-1.0,  0.0, 0.0, 0.0,  0.0, 0.0, 3.0, -1.0, 0.0, 0.0,
     5   0.0,-1.0, 0.0,  0.0, 0.0, 1.0,  0.0, 0.0, 6.0,  6.0, 6.0, 0.0,
     6  -1.0, 0.0, 0.0,  0.0,-1.0, 0.0,  0.0, 0.0,-1.0,  0.0, 0.0, 0.0,
     7   0.0, 0.0, 0.0/), (/3, 5, 5/))
      REAL, DIMENSION(3, 3, 8)   :: TRDAT = RESHAPE ((/
     1  1.0,  0.0,  0.0,   0.0,  1.0,  0.0,   0.0,  0.0,  1.0,
     2  0.0,  1.0,  0.0,   1.0,  0.0,  0.0,   0.0,  0.0, -1.0,
     3  0.0,  0.0,  1.0,   1.0,  0.0,  0.0,   0.0,  1.0,  0.0,
     4  0.0,  0.0, -1.0,   0.0,  1.0,  0.0,   1.0,  0.0,  0.0,
     5  0.0,  1.0,  0.0,   0.0,  0.0,  1.0,   1.0,  0.0,  0.0,
     6  1.0,  0.0,  0.0,   0.0,  0.0, -1.0,   0.0,  1.0,  0.0,
     7  0.0,  0.0,  1.0,   0.0, -1.0,  0.0,   1.0,  0.0,  0.0,
     8  1.0,  0.0, -1.0,   0.0, -1.0,  0.0,   0.0,  0.0, -1.0/),
     9 (/3, 3, 8/))
C * CELL-TO-PRIMITIVE CELL TRANSFORMATION FOR THE VARIOUS LATTICE TYPES
C * P, A, B, C, F, I, R
      REAL, DIMENSION(3, 3, 128) :: TRNSX = RESHAPE ((/
     1  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     2  1.0,  0.0,  0.0,  0.0,  1.0,  0.5,  0.0,  0.0,  0.5,
     3  0.5,  0.0,  0.0,  0.0,  1.0,  0.0,  0.5,  0.0,  1.0,
     4  1.0,  0.5,  0.0,  0.0,  0.5,  0.0,  0.0,  0.0,  1.0,
     5  0.5,  0.5,  0.0,  0.0,  0.5,  0.5,  0.5,  0.0,  0.5,
     6  1.0,  0.0,  0.5,  0.0,  1.0,  0.5,  0.0,  0.0,  0.5,
     7  0.666667, -0.333333, -0.333333, 0.333333, 0.333333, -0.666667,
     8  0.333333,  0.333333,  0.333333,
     9  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  0.0, -1.0,
     * -1.0,  0.0,  0.0,  0.0,  0.0,  1.0,  0.0,  1.0,  0.0,
     1  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,
     2  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,
     3  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     4  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     5  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     6  1.0,  0.0,  1.0,  0.0,  1.0,  1.0,  0.0,  0.0,  1.0,
C * SUPERLAT1:
     7  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
C * SUPERLAT2: SANTORO & MIGHELL, ACTA CRYST. (1972),A28,284-287
     8  2.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     9  1.0,  0.0,  0.0,  0.0,  2.0,  0.0,  0.0,  0.0,  1.0,
     *  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  2.0,
     1  2.0,  1.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     2  2.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     3  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  1.0,  2.0,
     4  1.0,  0.0,  1.0,  1.0,  1.0,  0.0,  0.0,  1.0,  1.0,
C * SUPERLAT3:
     5  3.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     6  1.0,  0.0,  0.0,  0.0,  3.0,  0.0,  0.0,  0.0,  1.0,
     7  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  3.0,
     8  1.0,  2.0,  0.0, -1.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     9  1.0, -2.0,  0.0,  1.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     * -1.0,  2.0,  0.0,  0.0,  0.0,  1.0,  1.0,  1.0,  0.0,
     1  1.0,  2.0,  0.0,  0.0,  0.0,  1.0,  1.0, -1.0,  0.0,
     2  0.0,  0.0,  1.0,  1.0,  2.0,  0.0, -1.0,  1.0,  0.0,
     3  0.0,  0.0,  1.0,  1.0, -2.0,  0.0,  1.0,  1.0,  0.0,
     4  2.0,  1.0,  0.0,  1.0,  1.0,  2.0,  1.0,  0.0,  1.0,
     5  1.0, -1.0,  2.0,  2.0, -1.0,  0.0,  1.0,  0.0,  1.0,
     6  1.0,  1.0,  2.0,  1.0,  0.0,  1.0,  2.0,  1.0,  0.0,
     7  1.0,  1.0,  0.0,  1.0,  2.0,  2.0,  1.0,  0.0,  1.0,
C * SUPERLAT4:
     8  4.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     9  1.0,  0.0,  0.0,  0.0,  4.0,  0.0,  0.0,  0.0,  1.0,
     *  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  4.0,
     1  4.0,  3.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     2  4.0,  1.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     3  4.0,  0.0,  3.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     4  4.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     5  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  3.0,  4.0,
     6  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  1.0,  4.0,
     7  4.0,  2.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     8  4.0,  0.0,  2.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     9  1.0,  0.0,  0.0,  0.0,  2.0,  0.0,  0.0,  1.0,  2.0,
     *  2.0,  1.0,  0.0,  0.0,  2.0,  0.0,  0.0,  0.0,  1.0,
     1  2.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  2.0,
     2  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  2.0,  4.0,
     3  2.0,  0.0,  1.0,  2.0,  1.0,  0.0,  0.0,  1.0,  1.0,
     4  1.0,  0.0,  2.0,  1.0,  1.0,  0.0,  0.0,  1.0,  2.0,
     5  1.0,  0.0,  1.0,  1.0,  2.0,  0.0,  0.0,  2.0,  1.0,
     6  1.0,  1.0,  2.0,  2.0,  1.0,  1.0,  1.0,  2.0,  1.0,
     7  3.0,  1.0,  2.0,  1.0,  1.0,  0.0,  0.0,  1.0,  1.0,
     8  4.0,  1.0,  2.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     9  2.0,  1.0,  3.0,  1.0,  1.0,  0.0,  0.0,  1.0,  1.0,
     *  4.0,  2.0,  1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     1  1.0,  0.0,  1.0,  1.0,  1.0,  0.0,  1.0,  3.0,  2.0,
     2  2.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  1.0,  2.0,
     3  2.0,  0.0,  2.0,  1.0,  1.0,  0.0,  0.0,  1.0,  1.0,
     4  1.0,  0.0,  1.0,  2.0,  2.0,  0.0,  0.0,  1.0,  1.0,
     5  1.0,  0.0,  1.0,  1.0,  1.0,  0.0,  0.0,  2.0,  2.0,
     6  2.0,  0.0,  0.0,  0.0,  2.0,  0.0,  0.0,  0.0,  1.0,
     7  2.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  2.0,
     8  1.0,  0.0,  0.0,  0.0,  2.0,  0.0,  0.0,  0.0,  2.0,
     9  2.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  1.0,  2.0,
     *  2.0,  0.0,  1.0,  0.0,  2.0,  0.0,  0.0,  0.0,  1.0,
     1  2.0,  1.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  2.0,
     2  2.0,  1.0,  0.0,  0.0,  1.0,  0.0,  0.0,  1.0,  2.0,
C * SUBLAT1:
     3  1.0,  0.0,  0.0,  0.0,  0.1,  0.0,  0.0,  0.0,  0.1,
C * SUBLAT2:
 
     4  0.5,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     5  1.0,  0.0,  0.0,  0.0,  0.5,  0.0,  0.0,  0.0,  1.0,
     6  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  0.5,
     7  0.5,  0.0,  0.0, -0.5,  1.0,  0.0,  0.0,  0.0,  1.0,
     8  0.5,  0.0,  0.0,  0.0,  1.0,  0.0, -0.5,  0.0,  1.0,
     9  1.0,  0.0,  0.0,  0.0,  1.0, -0.5,  0.0,  0.0,  0.5,
     *  0.5, -0.5,  0.5,  0.5,  0.5, -0.5, -0.5,  0.5,  0.5,
C * SUBLAT3:
     1  0.33333, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     2  1.0, 0.0, 0.0, 0.0, 0.33333, 0.0, 0.0, 0.0, 1.0,
     3  1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.33333,
     4  0.33333, 0.33333, 0.0,-0.66667, 0.33333, 0.0, 0.0, 0.0, 1.0,
     5  0.33333,-0.33333, 0.0, 0.66667, 0.33333, 0.0, 0.0, 0.0, 1.0,
     6 -0.33333, 0.33333, 0.0, 0.0, 0.0, 1.0, 0.66667, 0.33333, 0.0,
     7  0.33333, 0.33333, 0.0, 0.0, 0.0, 1.0, 0.66667,-0.33333, 0.0,
     8  0.0, 0.0, 1.0, 0.33333, 0.33333, 0.0,-0.66667, 0.33333, 0.0,
     9  0.0, 0.0, 1.0, 0.33333,-0.33333, 0.0, 0.66667, 0.33333, 0.0,
     *  0.33333, 0.33333,-0.33333,-0.33333, 0.66667, 0.33333, 0.66667,
     1 -1.33333, 0.33333,
     2 -0.33333,-0.66667, 0.33333, 0.33333,-0.33333,-0.33333, 0.66667,
     3  1.33333, 0.33333,
     4 -0.33333, 0.66667, 0.33333, 0.66667,-1.33333, 0.33333, 0.33333,
     5  0.33333,-0.33333,
     6  0.66667, 0.33333,-0.66667,-0.33333, 0.33333, 0.33333, 0.66667,
     7 -0.66667, 0.33333,
C * SUBLAT4:
     8  0.25, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00,
     9  1.00, 0.00, 0.00, 0.00, 0.25, 0.00, 0.00, 0.00, 1.00,
     *  1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25,
     1  0.25, 0.00, 0.00,-0.75, 1.00, 0.00, 0.00, 0.00, 1.00,
     2  0.25, 0.00, 0.00,-0.25, 1.00, 0.00, 0.00, 0.00, 1.00,
     3  0.25, 0.00, 0.00, 0.00, 1.00, 0.00,-0.75, 0.00, 1.00,
     4  0.25, 0.00, 0.00, 0.00, 1.00, 0.00,-0.25, 0.00, 1.00,
     5  1.00, 0.00, 0.00, 0.00, 1.00,-0.75, 0.00, 0.00, 0.25,
     6  1.00, 0.00, 0.00, 0.00, 1.00,-0.25, 0.00, 0.00, 0.25,
     7  0.25, 0.00, 0.00,-0.50, 1.00, 0.00, 0.00, 0.00, 1.00,
     8  0.25, 0.00, 0.00, 0.00, 1.00, 0.00,-0.50, 0.00, 1.00,
     9  1.00, 0.00, 0.00, 0.00, 0.50,-0.25, 0.00, 0.00, 0.50,
     *  0.50, 0.00, 0.00,-0.25, 0.50, 0.00, 0.00, 0.00, 1.00,
     1  0.50, 0.00, 0.00, 0.00, 1.00, 0.00,-0.25, 0.00, 0.50,
     2  1.00, 0.00, 0.00, 0.00, 1.00,-0.50, 0.00, 0.00, 0.25,
     3  0.25,-0.50, 0.50, 0.25, 0.50,-0.50,-0.25, 0.50, 0.50,
     4  0.50,-0.50,-0.50, 0.50, 0.50, 0.50,-0.50,-0.25, 0.25,
     5  0.50,-0.25, 0.50, 0.50, 0.25,-0.50,-0.50, 0.25, 0.50,
     6 -0.25,-0.25, 0.75, 0.75,-0.25,-0.25,-0.25, 0.75,-0.25,
     7  0.25,-0.25, 0.25, 0.25, 0.75,-0.75,-0.50, 0.50, 0.50,
     8  0.25, 0.00, 0.00,-0.25, 1.00, 0.00,-0.50, 0.00, 1.00,
     9  0.25,-0.25, 0.25, 0.50, 0.50,-0.50,-0.75, 0.75, 0.25,
     *  0.25, 0.00, 0.00,-0.50, 1.00, 0.00,-0.25, 0.00, 1.00,
     1  0.50,-0.50, 0.50, 0.75, 0.25,-0.75,-0.25, 0.25, 0.25,
     2  0.50, 0.00, 0.00, 0.25, 1.00,-0.50,-0.25, 0.00, 0.50,
     3  0.25,-0.25, 0.25, 0.50, 0.50,-0.50,-0.50, 0.50, 0.50,
     4  0.50,-0.50, 0.50, 0.25, 0.25,-0.25,-0.50, 0.50, 0.50,
     5  0.50, 0.50,-0.25,-0.50, 0.50, 0.25, 0.50,-0.50, 0.25,
     6  0.50, 0.00, 0.00, 0.00, 0.50, 0.00, 0.00, 0.00, 1.00,
     7  0.50, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.50,
     8  1.00, 0.00, 0.00, 0.00, 0.50, 0.00, 0.00, 0.00, 0.50,
     9  0.50, 0.00, 0.00, 0.00, 1.00,-0.50, 0.00, 0.00, 0.50,
     *  0.50, 0.00, 0.00, 0.00, 0.50, 0.00,-0.50, 0.00, 1.00,
     1  0.50, 0.00, 0.00,-0.50, 1.00, 0.00, 0.00, 0.00, 0.50,
     2  0.50, 0.00, 0.00,-0.50, 1.00,-0.50, 0.00, 0.00, 0.50,
     3  0.50, 0.00, 0.00, 0.00, 0.50, 0.00, 0.00, 0.00, 0.50/),
     4  (/3, 3, 128/))
      CHARACTER(len=5), DIMENSION(8) :: TRTYP = (/'ABC  ', 'BA-C ',
     1  'CAB  ', '-CBA ', 'BCA  ', 'A-CB ', 'C-BA ', 'A-B-N'/)
      END MODULE latice
 
      MODULE addsym
      SAVE
      INTEGER,             PARAMETER :: NP20 = 20
      INTEGER                        :: LU   = 0
      INTEGER                        :: NFT
      INTEGER                        :: NSV
      INTEGER                        :: NFTX
      INTEGER                        :: NEWS
      INTEGER                        :: JERR
      INTEGER                        :: NORG
      INTEGER                        :: NSYM
      INTEGER                        :: MSYM
      INTEGER                        :: NINC
      INTEGER                        :: NPIV
      INTEGER                        :: NSKIP
      INTEGER                        :: NCHIR
      INTEGER                        :: NSGTR
      INTEGER                        :: LOOPR
      INTEGER                        :: NLCLP
      INTEGER                        :: NNFIT
      INTEGER                        :: NNDIS
      INTEGER                        :: INVST
      INTEGER                        :: NORGM
      INTEGER                        :: NOINV
      INTEGER                        :: NEWLT
      INTEGER                        :: NATOMS
      INTEGER                        :: NNNFIT
      INTEGER                        :: NNNDIS
      INTEGER                        :: NCHIRF
      INTEGER                        :: NAL110
      INTEGER                        :: NNF111
      INTEGER                        :: NRET61
      INTEGER                        :: IMETRIC
      INTEGER                        :: NAL112S
      INTEGER, DIMENSION(3)          :: NA
      INTEGER, DIMENSION(15)         :: NMIS
      INTEGER, DIMENSION(64)         :: IMPROP
      REAL                           :: DSMAX
      REAL,    DIMENSION(4, NP20)    :: HH
      REAL,    DIMENSION(3, NP20)    :: PH
      REAL,    DIMENSION(3, 3, NP20) :: RH
      REAL,    DIMENSION(4, 37)      :: HX
      REAL,    DIMENSION(3, 37)      :: DHX
      REAL,    DIMENSION(4, 4)       :: SHRT
      REAL,    DIMENSION(NP20)       :: AANG
      REAL,    DIMENSION(3)          :: ORGM
      REAL,    DIMENSION(3)          :: OADD
      REAL,    DIMENSION(3, 3, 15)   :: XMISR
      REAL,    DIMENSION(3, 15)      :: XMISL
      REAL,    DIMENSION(3, 15)      :: XMISG
      REAL,    DIMENSION(3)          :: OSHFT
      REAL,    DIMENSION(10)         :: FRACT = (/
     1  0.0, 0.2, 0.25, 0.33333, 0.4, 0.5, 0.6, 0.66667, 0.75, 0.8/)
      REAL,    DIMENSION(3)          :: GLIDE
      REAL,    DIMENSION(NP20)       :: PERPAX
      CHARACTER(len=1)               :: XSUB
      CHARACTER(len=1)               :: CENT
      CHARACTER(len=1)               :: LATT
      CHARACTER(len=3)               :: FSYM
      END MODULE addsym
 
      SUBROUTINE PLA060
C * ADDSYM - CHECKING ROUTINE FOR MISSED HIGHER/PSEUDO SYMMETRY
C * A loosely based on and extended version of the MISSYM algorithm
C * See: Y. Le Page (1987), J. Appl. Cryst., 20, 264-269.
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE addsym
      USE latice
      USE sgxyz
C * DECLARE ALLOCATED LOCAL ARRAYS
      IMPLICIT NONE
      INTEGER, ALLOCATABLE, DIMENSION(:)   :: LCOR ! LABA
      INTEGER, ALLOCATABLE, DIMENSION(:)   :: NCOR ! NONFITS
      INTEGER, ALLOCATABLE, DIMENSION(:)   :: MCOR ! CHEM TYPE
      REAL,    ALLOCATABLE, DIMENSION(:,:) :: XCOR ! REDCEL/NATCEL COORD
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IT
      INTEGER :: NX
      INTEGER :: NY
      INTEGER :: N2
      INTEGER :: NO1
      INTEGER :: NMX
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: IDUM
      INTEGER :: JDUM
      INTEGER :: IDSO
      INTEGER :: IMET
      INTEGER :: JCAI
      INTEGER :: JUMP
      INTEGER :: MULT
      INTEGER :: NRXX
      INTEGER :: NLTX
      INTEGER :: KMAX
      INTEGER :: IENM
      INTEGER :: INQNR
      INTEGER :: JNQNR
      INTEGER :: INCGO
      INTEGER :: IPNUM
      INTEGER :: NATOMB
      INTEGER :: ISWTCH
      REAL    :: SGN
      REAL    :: SMD
      REAL    :: SMR
      REAL    :: YUNK
      REAL    :: XLNG
      REAL    :: XLEN
      REAL    :: SGN0
      REAL    :: AIMAX
      REAL    :: AJMAX
      REAL    :: GEN009
      REAL    :: GEN130
      CHARACTER(len=8) :: PARTNUM
C *
C * ADDSYM IPR(504) = 0: A <name>_pl.spf written with revised space group name
C *                 = 1: The <name>_pl.spf file is used for a PLUTON plot
C *                 = 2: The <name>_pl.spf used to create <name>_pl.res
C * NO ADDSYM CHECK FOR ANGSTROM DATA
      IF (IPR(23) == 1) THEN
        WRITE (LU6, 99995)
        RETURN
      END IF
C * NO ADDSYM CHECK FOR NO LATTICE TYPE GIVEN
      IF (IPR(241) == 0) THEN
        WRITE (LU6, 99996)
        RETURN
      END IF
C * ALLOCATE LOCAL ARRAYS
      ALLOCATE (LCOR(NP1), NCOR(NP1), MCOR(NP1), XCOR(6, NP1))
C * LCOR                 - LABA
C * NCOR                 - (NON)FITS
C * MCOR                 - CHEM TYPE
C * XCOR(I, J), I = 1, 3 - COORDINATES IN REDUCED CELL
C * XCOR(I, J), I = 4, 6 - COORDINATES IN NATURAL SYSTEM
C * HX                   -
C * DHX                  - 37 ROW-INDEX COMBINATIONS OF 0, +/- 1 OR 2
C * IFNT                 - CHIRALITY (WHEN DETERMINED IN PRIOR CALC GEOM/INTRA)
C * INITIALISATIONS
      IPR(30)  = 0
      IPR(205) = 1
      PAGET    = 'ADDSYM'
C * PREPARE ATOM SET (PART1)
      CALL PLA088
C * SET SUB-MENU NUMBER
      IGBL(6) = 26
C * DETERMINE ORG/INORG STRUCTURE TYPE
      CALL PLA384
C * EQUAL ATOM TYPE DEFAULT = NO
      IPR(207) = 1
C * SET NOSF OPTION VALUE
      IPR(595) = 0
C * LOAD TEST CRITERIA DEFAULTS FOR (IN)ORGANIC COMPOUNDS
      IF (IPR(699) == 0) THEN
        DO I = 1, 3
          PAR(400 + I) = RGBL(33 + I - IGBL(97) * 3)
        END DO
C * VALIDATION TEST CRITERIA
        DO I = 1, 3
          PAR(403 + I) = RGBL(36 + I)
        END DO
C * SET ADDSYM APPROX FIT MINIMUM PERCENTAGE BASED ON VOLUME
        IF (PAR(98) < 10000) THEN
          PAR(407) = RGBL(40)
        ELSE
C * SET DEFAULT TO 'EXACT' FOR VOLUME GREATER THAN 10000
          PAR(407) = 0.0
        END IF
      END IF
C * SAVE CURRENT SET OF SYMMETRY OPERATIONS (TO BE RECOVERED LATER)
      IF (SPGRNM(1)(1:1) == ' ') CALL SGSM (25, ICL, SGY, 0, 0, IERR)
C * RESTART POINT
      LBB      = 0
      LBC      = 0
      LBD      = 0
      IENM     = 0
      LOOPR    = 1
      INQNR    = 0
      JNQNR    = 0
   10 JERR     = 0
      INVST    = 0
      NCHIR    = 0
      NOINV    = 0
      NNF111   = 0
      NAL110   = 0
      NAL112S  = 0
      IPR(206) = 0
C * ADDSYM (0/1/2) -/PLOT/SHX
      IPR(410) = 0
      IPR(504) = 0
C * ANALYSE ADDSYM INSTRUCTION RECORD
      IF (IPR(220) > 2) THEN
        DO I = 3, IPR(220)
C * NO ADDSYM FOR H ATOMS
          IF (IFL(I) == 'H ') CYCLE
C * CHECK FOR OPTIONS
          SELECT CASE (IFL(I)(1:4))
C * TEST FOR EQUAL KEYWORD
            CASE ('EQUA')
              IPR(207) = 0
C * TEST FOR PLOT KEYWORD
            CASE ('PLOT')
              IPR(504) = 1
C * TEST FOR SHELX KEYWORD
            CASE ('SHEL')
              IPR(504) = 2
C * TEST FOR EXACT KEYWORD
            CASE ('EXAC')
              PAR(407) = 0.00
              IF (IPR(221) == 0) THEN
                FN(1)   = 0.80
                IF (LOOPR < 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
                END IF
                IPR(221) = 4
               END IF
C * NO 'LONG SFAC'
            CASE ('NOSF')
              IPR(595) = 1
C * TEST FOR ELD KEYWORD
            CASE ('ELD ')
              IGBL(65) = 1
C * DO NOT CHANGE CERTAIN MONOCLINIC SPACE GROUPS TO STANDARD SETTING
            CASE ('KEEP')
              IGBL(106) = 1
C * DO SPECIFIED PART ONLY
            CASE ('PART')
              IPR(410) = NINT (FN(1))
C * TEST FOR ATOM TYPE ONLY
            CASE DEFAULT
              CALL PLA037 (I, N, 2)
              IF (N > 0)  THEN
                IPR(206) = N
              ELSE
C * CHECK FOR SUPPLIED PIVOT ATOM
                CALL PLA046 (0, IFL(I), IENM, LBB, LBC, LBD, INQNR,
     1            JNQNR, JDUM)
              END IF
          END SELECT
        END DO
      END IF
C * RESET MAX ANGLE DIFFERENCE TEST VALUE
      IF (IPR(221) > 0) THEN
        PAR(43) = FN(1)
C * RESET MAX DISTANCE TEST VALUE
        IF (IPR(221) > 1) THEN
          PAR(401) = FN(2)
C * RESET MAX DISTANCE DIFFERENCE TEST VALUE FOR INVERSION
          IF (IPR(221) > 2) THEN
            PAR(402) = FN(3)
C * RESET MAX DISTANCE DIFFERENCE TEST VALUE FOR TRANSLATION
            IF (IPR(221) > 3) THEN
              PAR(403) = FN(4)
C * RESET MAX NON-FIT PERCENTAGE VALUE
              IF (IPR(221) > 4) THEN
                IF (FN(5) > 0.0) PAR(407) = FN(5)
              END IF
            END IF
          END IF
        END IF
      END IF
C * DETERMINE (NON)WINDOW MODE
      IWIN = 0
      IF (IGBL(25) * IGBL(32) == 1 .AND. IPR(504) == 0 .AND.
     1    IPR(121) == 0) IWIN = 1
C * INIT COUNTER FOR NUMBER OF ADDITIONAL SYMMETRY ELEMENTS
      IPR(209) = 0
C * LOAD THE 37 ACCEPTABLE ROW-INDEX COMBINATIONS OF 0, +/- 1 OR 2
      N = 0
      CALL GEN101 (2, N, DHX)
      XSUB  = CHAR (32)
      NLCLP = 0
      NLTX  = 1
C * MISSED TRANSLATION SYMMETRY (RESTART) LOOP
   20 NLCLP = NLCLP + 1
C * GET NIGGLI REDUCED CELL
      CALL PLA266 (NLTX)
      NRXX  = 0
      NSGTR = 0
      NEWLT = 0
C * REPORT ON ATOMS DELETED FROM THE INPUT STREAM
      IF (IPR(100) > 0) WRITE (LU6, 99987, IOSTAT = IOST) IPR(100)
C * PRINT HEADER (TEST PRINTLEVEL)
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (-2)
        WRITE (LU7, 99999, IOSTAT = IOST)
      END IF
C * SEARCH ON ONLY ONE ATOM TYPE?
      IF (IPR(206) == 0) THEN
C * REPORT SEARCH TYPE AND MAXIMUM NON-FIT PERCENTAGE
        IF (IPR(207) /= 0) THEN
          IF (IPR(410) == 0) THEN
            PARTNUM = ' '
          ELSE
            WRITE (PARTNUM, 99988, IOSTAT = IOST) IPR(410)
          END IF
          WRITE (PRBUF, 99993, IOSTAT = IOST) NINT (PAR(407)), PARTNUM
       ELSE
          WRITE (PRBUF, 99992) NINT (PAR(407))
        END IF
      ELSE
        CALL GEN020 (-1, NQ0, 2, 2)
        WRITE (PRBUF, 99994, IOSTAT = IOST) NQ0, NINT (PAR(407))
      END IF
      WRITE (LU6, 99976, IOSTAT = IOST)
      WRITE (LU6, 99990, IOSTAT = IOST) PRBUF
      IF (IPR(206) == 0 .AND. IPR(207) /= 0)
     1   WRITE (LU6, 99983, IOSTAT = IOST)
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (2)
        WRITE (LU7, 99990, IOSTAT = IOST) PRBUF
      END IF
C * GRAPHICS OUTPUT SETTING
      IF (IWIN == 1) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 1.0
        CALL PLA439 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT)
      END IF
      NEWS = 0
C * DETERMINE PROPER/IMPROPER SYMMETRY ELEMENT TYPE (+1/-1)
C * NSYM = NUMBER OF SYMMETRY OPERATIONS EXCLUDING BRAVAIS CENTERING
      NSYM = IPR(255) * IPR(257)
      DO I = 1, NSYM
        CALL SGSM (6, ICL, SGY, I, LU6, IERR)
        IMPROP(I) = NINT (GEN130(SGY))
      END DO
C * TRANSFORM ALL THE ATOMIC COORDINATES TO THE REDUCED CELL AXIAL SYSTEM
C * AND GET/ADD THOSE FOR THE SYMMETRY-RELATED ATOMS.
C * DUPLICATIONS, HYDROGEN & DISORDERED ATOMS ARE ELIMINATED)
      NATOMB = 0
      NATOMS = 0
C * SKIPPED DISORDERED ATOM COUNTER
      NSKIP  = 0
C * COUNT NUMBER OF INCLUDED ATOMS
      NINC   = 0
C * DEFAULT PIVOT ATOM
      NPIV   = 1
C * LOOP OVER THE SET OF INPUT ATOMS
      DO I = 1, IPR(37)
C * GET ELEMENT TYPE
        CALL GEN048 (-4, IFG(1, I), 15, NO1)
        NO1 = NO1 + 1
C * CHECK CHIRALITY FOR SELECTED ATOM-TYPE ONLY
        IF (IPR(206) == 0 .OR. NO1 == IPR(206)) THEN
C * CHECK/STORE R/S CHIRALITY TYPE
          CALL GEN048 (-2, IFG(1, I), 28, JCAI)
          IF (JCAI > 0) THEN
            JR(I) = JCAI - 2
            NCHIR = NCHIR + 1
          ELSE
            JR(I) = 0
          END IF
C * SKIP HYDROGEN ATOMS, THEY ARE OFTEN TOO IMPRECISE OR PARTIALLY MISSING
          IF (IEN(NO1) /= 1 .AND. IEN(NO1) /= 33 .AND.
     1      IEN(NO1) /= 133) THEN
            INCGO = 1
C * SKIP DISORDERED ATOMS
            CALL GEN048 (-8, IFG(2, I), 1, IDSO)
            IF (IPPR(IDSO + 1, 1) < 10000) INCGO = 0
            IF (IPR(410) /= 0) THEN
              INCGO = 1
C * GET PART NUMBER
              CALL GEN048 (-5, IFG(3, I), 14, IPNUM)
              IF (IPNUM - 16 /= IPR(410)) INCGO = 0
            END IF
C * ACCEPTED ATOM FOR ADDSYM TEST
            IF (INCGO == 1) THEN
C * CHECK FOR METAL
              CALL GEN048 (-1, IFG(1, I), 19, IMET)
C * COPY SELECTED ATOMS IN CON-ARRAY
              DO L = 1, 3
                SGY(L)     = XXO(I, L)
                SGY(L + 3) = 0.0
              END DO
              NATOMB = NATOMS
              NINC   = NINC + 1
C * GENERATE & STORE SYMMETRY-RELATED ATOM
              DO J  = 1, NSYM
                CALL SGSM (3, ICL, SGY, J, LU6, IERR)
C * TRANSFORM TO REDUCED CELL
                CALL GEN002 (1, TRNSM1, SGY(7), V2, XLNG)
C * TEMPORARILY STORE THOSE REDUCED CELL ATOMIC COORDINATES
                DO K = 1, 3
                  XCOR(K, NATOMS + 1) = MOD (V2(K) + 10.0, 1.0)
                END DO
                IF (J > 1) THEN
                  DO L = NATOMB + 1, NATOMS
                    M = 0
                    DO K = 1, 3
                      IF (ABS (MOD (10.5 + XCOR(K, NATOMS + 1)
     1                - XCOR(K, L), 1.0) - 0.5) < 0.001) M = M + 1
                    END DO
C * THIS ATOM IS ALREADY IN THE REDUCED CELL ATOM LIST
                    IF (M == 3) EXIT
                  END DO
C * SKIP TO NEXT SYMMETRY RELATED ATOM
                  IF (M == 3) CYCLE
                END IF
C * CHECK FOR TOO MANY ATOMS FOR checkCIF/ADDSYM TEST
                IF (IGBL(3) == 1) THEN
                  IF (NATOMS >= IPR(737)) THEN
                    CALL PLA236 (608, 0, -999.0, 0.0, ' ', ' ')
                    GO TO 30
                  END IF
                END IF
C * THIS IS A NEW ATOM, KEEP IT
                IF (NATOMS < NP1) THEN
                  NATOMS       = NATOMS + 1
C * (RE)SET PIVOT ATOM
                  IF (INQNR == LABA(I)  .AND. J == 1) NPIV = NATOMS
C * SAVE LABEL
                  LCOR(NATOMS) = LABA(I)
C * SAVE (NON)METAL TYPE
                  JCA(NATOMS)  = IMET
C * SAVE CHIRALITY
                  IFNT(NATOMS) = JR(I) * IMPROP(J)
C * GIVE THE SAME ATOM TYPE TO ALL ATOMS WHEN THE CHEMICAL TYPE IS NOT
C * ESTABLISHED FOR SURE (IPR(207) = 0)
                  MCOR(NATOMS) = (IEN(NO1) - 1) * IPR(207) + 1
                ELSE
                  WRITE (LU6, 99978, IOSTAT = IOST) NP1
                  JERR = 1
                  GO TO 30
                END IF
              END DO
            ELSE
              NSKIP = NSKIP + 1
              IF (NSKIP == 1) THEN
                IF (IGBL(63) > 0) THEN
                  CALL PLA262 (2)
                  WRITE (LU6, 99976)
                  WRITE (LU6, 99991, IOSTAT = IOST)
                  WRITE (LU7, 99976)
                  WRITE (LU7, 99991, IOSTAT = IOST)
                END IF
              END IF
              CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, 0, IGBL(55),
     1          0, 0)
              IF (IGBL(63) > 0) THEN
                IF (MOD (NSKIP, 8) /= 0) THEN
                  WRITE (LU6, 99977, ADVANCE = 'NO', IOSTAT = IOST)
     1              NQ1(1:7)
                  WRITE (LU7, 99977, ADVANCE = 'NO', IOSTAT = IOST)
     1              NQ1(1:7)
                ELSE
                  WRITE (LU6, 99982, ADVANCE = 'NO', IOSTAT = IOST)
                  WRITE (LU7, 99982, ADVANCE = 'NO', IOSTAT = IOST)
     1              NQ1(1:7)
                  CALL PLA262 (1)
                END IF
              END IF
            END IF
          END IF
        END IF
      END DO
      IF (IWIN == 1) THEN
        CALL PLA047 (LCOR(NPIV), NQ1, IDUM, JDUM, 0, IGBL(55),
     1          0, 0)
        WRITE (PRBUF, 99986, IOSTAT = IOST) NQ1(1:7), JID(1:30)
        CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0,
     1    VERT - 0.5)
      END IF
C * TESTSET OF ATOMS IS NOW COMPLETE
      NCHIRF = NCHIR
      IF (NATOMS == 0) THEN
        WRITE (PRBUF, 99980, IOSTAT = IOST)
        WRITE (LU6, 99989, IOSTAT = IOST) PRBUF(1:80)
        IF (IWIN == 1) THEN
          VRT = VRT - 0.5
          CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
        END IF
      ELSE IF (IPR(206) == 0 .AND. IPR(410) == 0 .AND.
     1         NSKIP / 2  > (NSKIP / 2 + NINC) / 4) THEN
C * ALERT _811 - TOO MANY EXCLUDED ATOMS, NO ADDSYM ANALYSIS
        CALL PLA236 (811, 0, -999.0, 1.0, ' ', ' ')
        WRITE (PRBUF, 99997, IOSTAT = IOST)
        WRITE (LU6, 99989, IOSTAT = IOST) PRBUF(1:80)
        IF (IGBL(63) > 0)
     1    WRITE (LU7, 99989, IOSTAT = IOST) PRBUF(1:80)
        IF (IWIN == 1) THEN
          VRT = VRT - 0.5
          CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
        END IF
      ELSE
        IF (NSKIP > 0) THEN
          WRITE (PRBUF, 99975) NSKIP
          WRITE (LU6, 99976)
          WRITE (LU6, 99979, IOSTAT = IOST) PRBUF
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (1)
            WRITE (LU7, 99976)
            WRITE (LU7, 99979, IOSTAT = IOST) PRBUF
          END IF
          IF (IWIN == 1) THEN
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF(3:80), 77, 0.35, 2, 2, 1.0, VRT)
          END IF
        END IF
        IF (PAR(386) /= 0.0) THEN
          YUNK = PAR(98) / PAR(386)
        ELSE
          YUNK = 0.0
        END IF
        WRITE (PRBUF, 99985, IOSTAT = IOST) PAR(387), YUNK
        WRITE (LU6, 99998, IOSTAT = IOST) NINC, NATOMS
        WRITE (LU6, 99990, IOSTAT = IOST) PRBUF(1:80)
        IF (IGBL(63) > 0) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99998, IOSTAT = IOST) NINC, NATOMS
          WRITE (LU7, 99990, IOSTAT = IOST) PRBUF(1:80)
        END IF
        IF (IWIN == 1) THEN
          IF (PAR(387) < 1.0) THEN
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
          END IF
        END IF
C * NOW FIND THE ROW INDICES FOR METRICAL SYMMETRY ELEMENTS
C * FROM INPUT CELL DATA. SEE: LE PAGE, Y. (1982).J.APPL.CRYST.,15,255.
        NSV      = 0
        N2       = 0
        IMETRIC  = 0
        IPR(118) = 0
        IPR(459) = 0
        NNFIT    = 100
        NNNFIT   = 100
        NFT      = 100
C * GET MAXIMUM ANGULAR TOLERANCE (DIRECT-RECIPROCAL LATTICE VECTORS)
C * FIND THE 2-AXES
C * ADIR & AINV ARE DIRECT AND INVERS REDUCED CELL ORTHOGONAL MATRICES
C * AND GET THE DIRECTION COSINES [HX] OF THE POSSIBLE ROWS [DHX]
        DO I = 1, 37
          CALL GEN002 (2, ADIR, DHX(1, I), HX(1, I), HX(4, I))
        END DO
C * GET THE DIR. COSINES [V1] OF THE NORMAL TO THE POSSIBLE PLANES (DHX)
C * IN TURN (LOOP OVER PLANES)
        DO I = 1, 37
          CALL GEN002 (-2, AINV, DHX(1, I), V1, XLNG)
C * SELECT THE ROWS IN TURN (LOOP OVER ROWS)
          DO J = 1, 37
C * CALCULATE THE MULTIPLICITY OF THE CELL DEFINED BY THE MESH ON THE
C * PLANE AND THE TRANSLATION ALONG THE ROW
            MULT = NINT (ABS (GEN009 (DHX(1, I), DHX(1, J))))
            IF (MULT == 1 .OR. MULT == 2) THEN
C * CALCULATE THE ANGLE BETWEEN THE ROW AND THE NORMAL TO THE PLANE
              CALL GEN008 (V1, HX(1, J), V5, -1)
              IF (V5(1) < SIN (PAR(43) / RGBL(6))) THEN
C * TEST FOR TOO MANY AXIS FOUND CONDITION
                IF (N2 >= NP20) THEN
                  IPR(2) = 23
                  GO TO 30
                END IF
C * STORE DATA FOR THIS 2-AXIS
                N2 = N2 + 1
                DO K = 1, 3
                  PH(K, N2)    = DHX(K, I)
                  HH(K, N2)    = HX (K, J)
                  RH(K, 3, N2) = DHX(K, J)
                END DO
                AANG(N2)   = ASIN (V5(1)) * RGBL(6)
                PERPAX(N2) = 2.0
                HH(4, N2)  = HX(4, J)
              END IF
            END IF
          END DO
        END DO
        MSYM = N2
        IF (N2 > 0) THEN
          IF (N2 > 2) THEN
C * FIND THE KIND OF AXIS: FIND A FAMILY OF COPLANAR TWOFOLD AXES
            DO I = 1, N2 - 2
              DO J = I + 1, N2 - 1
                NMX   = 2
                CALL GEN008 (HH(1, I), HH(1, J), V6 , 0)
                DO K = J + 1, N2
                  IF (ABS (GEN009 (V6, HH(1, K))) <= 0.01)
     1                NMX = NMX + 1
                END DO
C * NOW FIND A TWOFOLD AXIS PERPENDICULAR TO THIS PLANE
                JUMP = 0
                DO K = 1, N2
                  IF (ABS (GEN009(PH(1, K), RH(1, 3, I))) <= 0.01) THEN
                    IF (ABS (GEN009(PH(1, K), RH(1, 3, J))) <= 0.01)
     1                THEN
C * FOUND ONE: ITS MAXIMUM ORDER IS NMX, THE NUMBER OF PERP. AXES.
                      IF (NMX > PERPAX(K)) PERPAX(K) = NMX
                      JUMP = 1
                      EXIT
                    END IF
                  END IF
                END DO
                IF (JUMP == 0 .AND. NMX > 2) THEN
C * THREE COPLANAR AXES WERE FOUND, BUT NO PERPENDICULAR ONE:
C * THIS IS LIKELY TO BE A THREEFOLD AXIS. (V3=RECIP, V4=DIRECT)
                  CALL GEN002 ( 2, AINV, V6, V4, XLEN)
                  CALL GEN002 (-2, ADIR, V6, V3, XLNG)
C * MAKE COPRIME INTEGERS (THE SMALLEST NON-ZERO INTEGER WILL BE 1)
                  SMR = 2.0
                  SMD = 2.0
                  DO K = 1, 3
                    IF (ABS (V3(K)) > 0.1 .AND. ABS (V3(K)) < SMR)
     1                      SMR = ABS (V3(K))
                    IF (ABS (V4(K)) > 0.1 .AND. ABS (V4(K)) < SMD)
     1                      SMD = ABS(V4(K))
                  END DO
                  DO K = 1, 3
                    V3(K) = NINT (V3(K) / SMR)
                    V4(K) = NINT (V4(K) / SMD)
                  END DO
                  CALL GEN002 (-2, AINV, V3, V1, XLNG)
                  CALL GEN002 ( 2, ADIR, V4, V2, XLEN)
                  CALL GEN008 (V1, V2, V5, -1)
                  IF (V5(1) < SIN (PAR(43) / RGBL(6))) THEN
C * ALL SEEMS TO BE OK, SAVE THE RESULTS
                    MSYM = MSYM + 1
                    DO K = 1, 3
                      PH(K,    MSYM) = V3(K)
                      RH(K, 3, MSYM) = V4(K)
                      HH(K,    MSYM) = V2(K)
                    END DO
                    AANG(MSYM)   = ASIN (V5(1)) * RGBL(6)
                    PERPAX(MSYM) = NMX
                    HH(4, MSYM)  = XLEN
                  END IF
                END IF
              END DO
            END DO
C * ORDER THE AXES ON TYPE AND THE ANGLE WITH THE PLANE
            DO I = 1, MSYM - 1
              AIMAX = PERPAX(I) - AANG(I)
              KMAX  = I
              DO J = I + 1, MSYM
                AJMAX = PERPAX(J) - AANG(J)
                IF (AJMAX > AIMAX) THEN
                  AIMAX = AJMAX
                  KMAX  = J
                END IF
              END DO
              CALL GEN018 (PERPAX(I), PERPAX(KMAX))
              DO 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))
              END DO
              CALL GEN018 (AANG(I), AANG(KMAX))
              CALL GEN018 (HH(4, I), HH(4, KMAX))
            END DO
          END IF
C * GET 2 PRIMITIVE TRANSLATIONS FOR THE PERPENDICULAR PLANE
          DO IT = 1, MSYM
            J = 0
            DO I = 1, 37
              IF (ABS (GEN009 (DHX(1, I), PH(1, IT))) < 0.01) THEN
                J = J + 1
                DO K = 1, 3
                  SHRT(K, J) = DHX(K, I)
                END DO
                IF (J == 2) EXIT
              END IF
            END DO
C * GET THE 2 SHORTEST TRANSLATIONS IN THE PLANE: GENERATE MESH DIAGONALS
            ISWTCH = 1
            DO WHILE (ISWTCH == 1)
              ISWTCH = 0
              DO I = 1, 3
                SHRT (I, 3) = SHRT (I, 1) + SHRT (I, 2)
                SHRT (I, 4) = SHRT (I, 1) - SHRT (I, 2)
              END DO
              DO I = 1, 4
                CALL GEN002 (2, ADIR, SHRT(1, I), V5, SHRT(4, I))
              END DO
C * RANK THEIR LENGTHS
              DO I = 1, 2
                DO J = 2, 4
                  IF (SHRT(4, J) < SHRT(4, I)) THEN
                    DO K = 1, 4
                      CALL GEN018 (SHRT(K, I), SHRT(K, J))
                    END DO
                    ISWTCH = 1
                  END IF
                END DO
              END DO
            END DO
C * FINISHED WHEN NO MORE INTERCHANGE
C * MAKE SURE THE ANGLE IS NOT ACUTE
            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)) > 0.000001) THEN
              DO NX = 1, 3
                SHRT(NX, 2) = - SHRT(NX, 2)
              END DO
            END IF
C * MAKE SURE THE REFERENCE SYSTEM IS RIGHT-HANDED
            SGN0 = SIGN (1.0, GEN009 (RH(1, 3, IT), PH(1, IT)))
C * CALCULATE THE DET. OF THE VECTORS SHRT(I,1), SHRT(J,2), RH(K,3,IT)
            CALL GEN008 (SHRT(1, 1), SHRT(1, 2), V3, 0)
            SGN = SIGN (1.0, GEN009 (V3, RH(1, 3, IT)))
C * THIS IS A POTENTIAL SYMMETRY AXIS, WE SAVE THE VALUES
            DO NX = 1, 3
              RH(NX, 3, IT) = SGN * RH(NX, 3, IT)
              PH(NX, IT)    = SGN * PH(NX, IT) * SGN0
              DO NY = 1, 2
                RH(NX, NY, IT) = SGN * SHRT(NX, NY)
              END DO
            END DO
          END DO
        END IF
C * FILL THE NEXT SLOT (USED FOR INVERSION CENTERS AND TRANSLATIONS)
C * 1 0 0, 0 1 0, 0 0 1
        MSYM        = MSYM + 1
        PH(1, MSYM) = 0.0
        PH(2, MSYM) = 0.0
        PH(3, MSYM) = 1.0
        CALL GEN021 (RH(1, 1, MSYM), 1.0)
C * FIND THE MISSING SYMMETRY, IF ANY.
        CALL PLA061 (LCOR, NCOR, MCOR, XCOR, NLTX)
        IF (NRET61 == 1) GO TO 20
C * ANALYSE SYMMETRY OPERATIONS INTO STANDARD SPACE GROUP
        CALL PLA062
C * RELOAD ORIGINAL SPACE-GROUP
        IF (SPGRNM(1)(1:1) /= ' ') THEN
          IF (INDEX (SPGRNM(1)(1:11), ':') /= 0) THEN
            WRITE (ICL, 99974, IOSTAT = IOST) SPGRNM(1)(1:11)
          ELSE
            WRITE (ICL, 99974, IOSTAT = IOST)
     1        SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11)
            IF (SPGRNM(1)(13:13) /= ' ') ICL(13:13) = '.'
          END IF
          CALL SGSM (0, ICL, SGY, NRXX, LU6, IERR)
        ELSE
C * RELOAD SYMMETRY FROM SAVE FILE
          CALL SGSM (26, ICL, SGY, 0, 0, IERR)
        END IF
        IF (LOOPR < 3 .AND. JERR > 0) THEN
C * ALERT _115 - Non-crystallographic Inversion
          IF (NNF111 /= 0)
     1      CALL PLA236 (115, 0, -999.0, FLOAT (NNF111), ' ', ' ')
          PRBUF = 'Local/Non-Crystallographic Inversion Center Detected'
          IF (IWIN == 1) THEN
            VRT = VRT - 1.5
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 4.0, VRT)
          END IF
          WRITE (LU6, 99989, IOSTAT = IOST) PRBUF(1:80)
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (3)
            WRITE (LU7, 99989, IOSTAT = IOST) PRBUF(1:80)
          END IF
C * RESET TO NO-INVERSION
          NNF111   = 0
          IPR(209) = 0
C * ASK TO RERUN WITH 'EXACT' MODE
          IF (IWIN == 1) THEN
C * WHAT NEXT ?
            CALL PLA012 (-2, 1)
          ELSE
            IGGT = 'Y'
          END IF
          IF (IGGT(1:1) /= 'N') THEN
            LOOPR         = LOOPR + 1
            IPR(220)      = IPR(220) + 1
            IFL(IPR(220)) = 'EXACT'
            IPR(221)      = 0
            NOINV         = 1
            IF (LU == 0) LU = LU6
            WRITE (LU, 99984, IOSTAT = IOST)
            GO TO 10
          END IF
        ELSE
C * ALERT _111 - ADDITIONAL (Pseudo) Centre of Symmetry found
          IF (NNF111 /= 0) THEN
            IF (NNF111 == 100 .AND. IPR(773) == 0) THEN
                YUNK = 100.0
            ELSE
              YUNK = -999.0
            END IF
            CALL PLA236 (111, 0, YUNK, FLOAT (NNF111), ' ', ' ')
          END IF
        END IF
C * SAVE THIS ENTRY AND DISPLAY (IF REQUESTED)
        IF (ISAVEMOD == 0 .OR. IGBL(65) == 1) THEN
          IF (IPR(209) > 0 .OR. IPR(504) > 0) THEN
            IF (SPGRNM(2)(1:1) == '?') THEN
              SPGRNM(2) = SPGRNM(1)
              CALL GEN074 (ORG, 1, 3, 0.0)
              WRITE (LU6, 99981, IOSTAT = IOST)
              IF (IGBL(63) > 0) THEN
                CALL PLA262 (2)
                WRITE (LU7, 99981, IOSTAT = IOST)
              END IF
            END IF
            CALL PLA280 ('CALC GEOM SPF')
            JID(40:50) = 'New:'//SPGRNM(2)(1:7)
C * SET VIEW MIN
            IGBL(67) = 0
          END IF
        END IF
      END IF
C * WHAT NEXT ?
   30 IF (IWIN == 1) CALL PLA012 (0, 1)
      SELECT CASE (IGGT(1:4))
        CASE ('PLOT')
          CALL PLA280 ('CALC ADDSYM')
        CASE ('!   ')
          CALL PLA280 ('CALC ADDSYM')
        CASE ('END ')
          CALL PLA280 ('!')
          IGBL(30) = 0
          CALL PLA280 ('CALC GEOM SPF')
      END SELECT
      IF (LOOPR > 0) THEN
        IF (IPR(121) > 0) IPR(220) = 1
      END IF
C * RETURN TO MAIN PLATON MENU
      IGBL(6) = 10
C * RELEASE LOCAL ARRAYS
      DEALLOCATE (LCOR, NCOR, MCOR, XCOR)
      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 ('- Number of Input Atoms Included in Search', I5,
     1        ' (Unitcell', I5, ')')
99997 FORMAT (':: No ADDSYM Analysis: Too many Excluded Atoms')
99996 FORMAT (/, ':: No ADDSYM for No Lattice Type Given', /)
99995 FORMAT (/, ':: No ADDSYM for Angstrom Data', /)
99994 FORMAT ('ADDSYM Search on Atom Type ', A, 'ONLY',
     1        ' [Max Allowed NonFit', I3, ' % ]')
99993 FORMAT ('ADDSYM Search on ALL NON-H Atom Types',
     1        ' [Max Allowed NonFit', I3, ' % ]', A)
99992 FORMAT ('ADDSYM Search on ALL NON-H Atom Types (Treated EQUAL)',
     1        ' [Max Allowed NonFit', I3, ' % ]')
99991 FORMAT (':: Excluded Disorder Atoms From ADDSYM Analysis:')
99990 FORMAT ('- ', A)
99989 FORMAT (/, A, /)
99988 FORMAT (' PART', I3)
99987 FORMAT (/, ':: Note:', I5, ' Atoms deleted from input !')
99986 FORMAT ('Pivot Atom ',  A, 7X, 'PLATON/ADDSYM for ', A)
99985 FORMAT ('Density based on Input Atom Set =', F6.3,
     1        ' g.cm-3 - Vol / Non-H atom =', F5.1, ' Ang^3')
99984 FORMAT (/, ':: Restart with CALC ADDSYM EXACT')
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 (3X, A)
99981 FORMAT (/, ':: Higher (pseudo)symmetry not compatible,',
     1           '(current symmetry retained)')
99980 FORMAT (':: No Fully Occ. Atoms found in list ...',
     1        ' ADDSYM request aborted!')
99979 FORMAT (A)
99978 FORMAT (':: Over', I7, 'atoms in the Primitive Cell',
     1        ' (ADDSYM request aborted!)')
99977 FORMAT (3X, A)
99976 FORMAT (1X)
99975 FORMAT ('- Warning: Number of Excluded Disordered Input Atoms =',
     1       I3, ' from ADDSYM Analysis')
99974 FORMAT ('SPGR ', A, 64X)
      END SUBROUTINE PLA060
 
      SUBROUTINE PLA061 (LCOR, NCOR, MCOR, XCOR, NLTX)
C * FIND THE MISSING SYMMETRY, IF ANY.
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE addsym
      USE latice
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: N
      INTEGER                  :: IK
      INTEGER                  :: IL
      INTEGER                  :: IR
      INTEGER                  :: JG
      INTEGER                  :: LUX
      INTEGER                  :: NRT
      INTEGER                  :: IAT1
      INTEGER                  :: IAT2
      INTEGER                  :: IAT3
      INTEGER                  :: IAT4
      INTEGER                  :: IDUM = 0
      INTEGER                  :: JDUM = 0
      INTEGER                  :: JROT
      INTEGER                  :: ISYM
      INTEGER                  :: ISIG
      INTEGER                  :: ISTR
      INTEGER                  :: ITEL
      INTEGER                  :: ITRY
      INTEGER                  :: ITYP
      INTEGER                  :: NTYP
      INTEGER                  :: MULT
      INTEGER                  :: NLTX
      INTEGER                  :: NCHR
      INTEGER                  :: NFIT
      INTEGER                  :: NROT
      INTEGER                  :: MIAT1
      INTEGER                  :: MIAT3
      INTEGER                  :: ITRI0
      INTEGER                  :: ITYPB
      INTEGER                  :: ITYPE
      INTEGER                  :: IFNT1
      INTEGER                  :: IFNT2
      INTEGER                  :: IFNT3
      INTEGER                  :: IFNT4
      INTEGER                  :: IMULT
      INTEGER                  :: IPERP
      INTEGER                  :: IPRMX
      INTEGER                  :: IRCTR
      INTEGER                  :: NLOOP
      INTEGER                  :: NSAVR
      INTEGER                  :: IGLIDE
      INTEGER                  :: ISHIFT
      INTEGER, DIMENSION(*)    :: LCOR
      INTEGER, DIMENSION(*)    :: NCOR
      INTEGER, DIMENSION(*)    :: MCOR
      INTEGER, DIMENSION(3)    :: IROW
      INTEGER, DIMENSION(3)    :: IROW0
      REAL                     :: ANG
      REAL                     :: DET
      REAL                     :: DIS
      REAL                     :: DLE
      REAL                     :: FIT
      REAL                     :: GLI
      REAL                     :: ORI
      REAL                     :: P407
      REAL                     :: XDUM
      REAL                     :: DLIM
      REAL                     :: TEMP
      REAL                     :: XLNG
      REAL                     :: YUNK
      REAL                     :: DSAVR
      REAL                     :: DELTA
      REAL                     :: DSCENT
      REAL                     :: GEN009
      REAL,    DIMENSION(6, *) :: XCOR
      REAL,    DIMENSION(3)    :: DEL
      REAL,    DIMENSION(3)    :: ROW
      REAL,    DIMENSION(3)    :: GLY
      REAL,    DIMENSION(3)    :: ORIG
      REAL,    DIMENSION(3)    :: RATOM
      REAL,    DIMENSION(3, 2) :: ATOM2
      REAL,    DIMENSION(3, 2) :: GLIDO
      REAL,    DIMENSION(3, 4) :: ROTAX
      REAL,    DIMENSION(3, 3) :: TTRM1
      REAL,    DIMENSION(3, 3) :: BTRM1
      REAL,    DIMENSION(3)    :: TRANSL
      REAL,    DIMENSION(3, 3) :: TTRANS
      REAL,    DIMENSION(3, 3) :: BTRANS
      REAL,    DIMENSION(2)    :: GLITOT
      CHARACTER(len=1)         :: STAR
      CHARACTER(len=7)         :: TEXT1
      NROT     = 0
      DSCENT   = 999.0
      NRET61   = 0
C * FIRST USE DISTANCE APPROPRIATE FOR AXES AND PLANES
      DLIM     = PAR(401)
      PAR(291) = 0.0
C * OUTPUT A TITLE
      WRITE (LINE, 99989, IOSTAT = IOST)
      WRITE (IDM,  99981, IOSTAT = IOST)
     1  PAR(43), PAR(401), PAR(402), PAR(403)
      DO I = 1, 2 + IWIN
        IF (I == 1) THEN
          IF (IGBL(63) <= 2) CYCLE
          LUX = LU7
          CALL PLA262 (6)
        ELSE IF (I == 2) THEN
          LUX = LU6
        ELSE
          VRT = VRT - 0.5
          CALL PLA439 (0.0, IDM, 80, 0.35, 3, 2, 1.0, VRT)
          WRITE (PRBUF, 99984, IOSTAT = IOST)
          VRT = VRT - 0.5
          CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0,
     1                 VRT)
          WRITE (PRBUF, 99985, IOSTAT = IOST)
          VRT = VRT - 0.5
          CALL PLA439 (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
          CALL GGIP (0.0, 0.0, 0.0, 6)
          CYCLE
        ENDIF
        WRITE (LUX, 99990, IOSTAT = IOST) LINE(1:78)
        WRITE (LUX, 99990, IOSTAT = IOST) IDM
        CALL PLA047 (LCOR(NPIV), NQ6, IDUM, JDUM, 0,
     1                IGBL(55), 0, 0)
        WRITE (LUX, 99980, IOSTAT = IOST) NQ6
        WRITE (LUX, 99988, IOSTAT = IOST)
        WRITE (LUX, 99984, IOSTAT = IOST)
        WRITE (LUX, 99985, IOSTAT = IOST)
        WRITE (LUX, 99986, IOSTAT = IOST)
      END DO
C * TEST LOOP OF THE METRICAL SYMMETRY OPERATION SET FOR SUPPORT IN
C * THE PRIMITIVE TRICLINIC COORDINATE SET
      DO 100  ISYM = 1, MSYM
C * SELECT A SYMMETRY DIRECTION AND BUILD THE NATURAL CELL
        DO I = 1, 3
          DO J = 1, 3
            BTRANS(I, J) = RH(I, J, ISYM)
          END DO
          IROW0(I) = NINT (RH(I, 3, ISYM))
        END DO
C * INVERT
        CALL GEN003 (BTRANS, BTRM1, DET, 0)
C * FLAG A REDUCED CELL TRANSLATION WHICH DOES NOT PROJECT ON A NET NODE
        IRCTR = 0
        DO I = 1, 3
          IF (ABS (ABS (BTRM1(3, I)) - 0.5) < 0.48) IRCTR = I
        END DO
C * TRANSFORM COORDINATES ACCORDINGLY (BTRM1) INTO 'NATURAL SYSTEM'
        DO I = 1, NATOMS
          DO J = 1, 3
            V1(J) = XCOR(J, I)
          END DO
          CALL GEN002 (1, BTRM1, V1, V2, XLNG)
          DO J = 1, 3
            XCOR(J + 3, I) = V2(J)
          END DO
        END DO
C * TEST FIRST PLANES & AXES
        IF (ISYM < MSYM) THEN
          IPERP = NINT (PERPAX(ISYM))
          ANG   = AANG(ISYM)
          MULT  = NINT (GEN009 (RH(1, 3, ISYM), PH(1, ISYM)))
          DLE   = HH(4, ISYM)
C * SIXFOLD AXIS, ALL TYPES OF AXES SHOULD BE TRIED (2, 3, 6)
          IF (IPERP >= 6) THEN
            ITYPB = 1
            ITYPE = 4
C * THREE-FOLD AXIS, DO NOT EXAMINE ANY OTHER POSSIBILITY (3)
          ELSE IF (IPERP == 3) THEN
            ITYPB = 2
            ITYPE = 2
C * FOURFOLD AXIS, EXAMINE 4 AND 2
          ELSE IF (IPERP >= 4) THEN
            ITYPB = 3
            ITYPE = 4
C * TWOFOLD AXIS, CANNOT BE ANYTHING ELSE
          ELSE
            ITYPB = 4
            ITYPE = 4
          END IF
        ELSE
C * LAST POSSIBILITY, A SYMMETRY CENTER. USE CORRESPONDING DISTANCE LIMIT
C * ITRY = -5 : SEARCH FOR TRANSLATIONS
C * ITRY =  5 : SEARCH FOR INVERSION CENTERS
          ITYPB = 5
          ITYPE = 5
          INVST = 0
        END IF
C * SEARCH SUPPORT FOR POSSIBLE SYMMETRY ELEMENTS
        DO ITYP = ITYPB, ITYPE
          IF (ITYP == 1) THEN
            NROT = 6
          ELSE IF (ITYP == 2) THEN
            NROT = 3
          ELSE IF (ITYP == 3 .AND. ITYPB /= 1) THEN
            NROT = 4
          ELSE IF (ITYP == 4) THEN
            NROT = 2
          END IF
C * LOOP OVER IMPROPER = 1/PROPER = 2
          DO NTYP = 1, 2
            ITRY  = ITYP * (-1) ** NTYP
            IF (ITRY == 5 .AND. NOINV == 1) CYCLE
            JROT  = 6 - NTYP
            DSMAX = -1.0
            NCHR  = 0
C * INVERSION
            IF (ITRY == 5) THEN
              IF (IPR(708) /= 0) CYCLE
              DLIM = PAR(402)
C * TRANSLATION
            ELSE IF (ITRY == -5) THEN
              DLIM = PAR(403)
            END IF
C * COPY THE ROTATION AND TRANSLATION PARTS OF THE CONSIDERED OPERATION
            DO I = 1, 3
              ROTAX(I, 4) = 0.0
              TRANSL(I)   = ROT(I, JROT, ITYP)
              DO J = 1, 3
                TEMP = ROT(I, J, ITYP)
                IF (ITRY < 0) TEMP = - TEMP
                ROTAX(I, J) = TEMP
                IF (I == J) TEMP = TEMP - 1.0
                ROTM1(I, J) = TEMP
              END DO
            END DO
C * GET (R - I) ** -1.0 AVOID SINGULARITIES
            DO 10 I = 1, 3
              V6(I) = 1.0
              DO J = 1, 3
                IF (ROTM1(I, J) /= 0.0) GO TO 10
                IF (ROTM1(J, I) /= 0.0) GO TO 10
              END DO
              V6(I)       = 0.0
              ROTM1(I, I) = 1.0
   10       CONTINUE
C * INVERT
            CALL GEN003 (ROTM1, ROTM2, DET, 0)
            DO I = 1, 3
              ROTM2(I, I) = ROTM2(I, I) * V6(I)
            END DO
C * SELECT FIRST ATOM = IAT1 AS PIVOT ATOM (PLACED IN THE NATURAL SYSTEM)
            IAT1  = NPIV
C * GET ATOM TYPE MIAT1 FOR ATOM IAT1
            MIAT1 = MCOR(IAT1)
C * GET  R/S TYPE IFNT1 FOR ATOM IAT1
            IFNT1 = IFNT(IAT1)
C * GET THE TO BE TESTED SYMMETRY-EQUIVALENT OF ATOM IAT1
            DO I = 1, 3
              RATOM(I) = 0.0
              DO J = 1, 3
                RATOM(I) = RATOM(I) + ROTAX(I, J) * XCOR(J + 3, IAT1)
              END DO
            END DO
C * FIND ATOM IAT2 (WHERE APPLICAL, WITH SIMILAR TYPE AND CHIRALITY)
C *  AND PLACE IT IN THE NATURAL SYSTEM
            DO 90 IAT2 = 1, NATOMS
C * GET CHIRALITY OF IFNT2 FOR ATOM IAT2
              IFNT2 = IFNT(IAT2)
C * CHECK CHIRALITY (WHERE APPROPRIATE)
              IF (NCHIR > 0) THEN
                IF (NTYP == 1 .OR. ITRY == 5) THEN
                  IF ((IFNT1 + IFNT2) /= 0) GO TO 90
                ELSE IF (NTYP == 2 .OR. ITRY == -5) THEN
                  IF ((IFNT1 - IFNT2) /= 0) GO TO 90
                END IF
              END IF
              NCHR  = IABS(IFNT1)
              DSMAX = -1.0
              DSAVR = 0.0
              NSAVR = 1
C * COMPARE ATOM TYPES OF ATOM IAT1 & ATOM IAT2
              IF (MCOR(IAT2) == MIAT1) THEN
C * GET COORDINATES OF ATOM IAT2
                DO I = 1, 3
                  ATOM2(I, 1) = XCOR(I + 3, IAT2)
                END DO
                IF (IRCTR /= 0) THEN
                  DO I = 1, 3
                    ATOM2(I, 2) = ATOM2(I, 1) + BTRM1(I, IRCTR)
                  END DO
                END IF
C * FIND THE GLIDE, IF ANY. SKIP THE SECONDARY ELEMENT
                DO J = 1, 2
                  IF (J /= 2 .OR. IRCTR /= 0) THEN
                    GLITOT(J) = 0.0
                    DO I = 1, 3
                      GLIDO(I, J) = 0.0
C * ALL FOR PURE TRANSLATIONS: ITRY = -5
                      IF (TRANSL(I) >= 0.1 .OR. ITRY == -5) THEN
                        GLIDO(I, J) = ATOM2(I, J) - XCOR(I + 3, IAT1)
                        GLITOT(J)   = GLITOT(J)   + GLIDO(I, J)**2
                        GLITOT(J)   = GLITOT(J)   - INT (GLITOT(J)
     1                                + 0.1)
                        IF (ITRY /= - 5) THEN
C * INAPPROPRIATE GLIDE, NEXT ATOM
                          XDUM = MOD (12.0 * GLIDO(I, J) /
     1                                       TRANSL(I), 1.0)
                          IF (XDUM >= 0.05 .AND. XDUM <= 0.95)
     1                      GO TO 90
                        END IF
                      END IF
                    END DO
                  END IF
                END DO
C * THE GLIDE IS CREDIBLE, PICK THE SMALLER ONE
                JG = 1
                IF (IRCTR /= 0) THEN
                  IF (ABS (GLITOT(2)) < ABS (GLITOT(1))) JG = 2
                END IF
C * FIND FIXED COORDINATES FOR THE OPERATION
                DO I = 1, 3
                  ROTAX(I, 4) = GLIDO(I, JG) * 12.0
                  V1(I) = RATOM(I) - ATOM2(I, JG) + GLIDO(I, JG)
                END DO
                CALL GEN002 (1, ROTM2, V1, ORIG, XLNG)
C * THE OPERATION IS NOW CHARACTERIZED BY ITS ROTATION, ITS GLIDE AND ITS
C * FIXED COORDINATES. TEST IT FOR ALL ATOMS, ATOM IAT1 ALREADY PASSED IT
                P407  = PAR(407)
   20           NFIT  = 0
                NNFIT = 100
                NLOOP = 0
                DO I = 1, NATOMS
                  NCOR(I) = 0
                END DO
                NCOR(IAT1) = 2
                NCOR(IAT2) = 2
C * FIND SUPPORT FOR THIS SYMMETRY BY OTHER PAIRS
C * ATOM IAT3 LOOP
                DO 40 IAT3 = 1, NATOMS
C * GET LABEL OF ATOM IAT3
                  CALL PLA047 (LCOR(IAT3), NQ5, IDUM, JDUM, 0,
     1              IGBL(55), 0, 0)
C * GET R/S-INFO IFNT3 FOR ATOM IAT3
                  IFNT3 = IFNT(IAT3)
C * BRING THE ATOM IN THE NATURAL CELL AND
C * CALCULATE THE COORDINATES OF THE ATOM RELATED BY THE OPERATION
                  DO K = 1, 3
                    V1(K) = XCOR(K + 3, IAT3) - ORIG(K)
                  END DO
                  DO K = 1, 3
                    V2(K) = ROTAX(K, 4) / 12.0 + ORIG(K)
                    DO J = 1, 3
                      V2(K) = V2(K) + ROTAX(K, J) * V1(J)
                    END DO
                  END DO
C * BRING IT BACK TO THE REDUCED CELL AND SEE IF IT BELONGS TO THE LIST
                  CALL GEN002 (1, BTRANS, V2, V3, XLNG)
C * GET ATOM TYPE OF ATOM IAT3
                  MIAT3 = MCOR(IAT3)
C * ATOM IAT4 LOOP
                  DO 30 IAT4 = 1, NATOMS
                    CALL PLA047 (LCOR(IAT4), NQ5, IDUM, JDUM, 0,
     1                IGBL(55), 0, 0)
C * GET R/S-INFO IFNT4 FOR ATOM IAT4
                    IFNT4 = IFNT(IAT4)
C * CHECK CHIRALITY (WHERE APPLICABLE)
                    IF (NCHIR > 0) THEN
                      IF (NTYP == 1 .OR. ITRY == 5) THEN
                        IF ((IFNT3 + IFNT4) /= 0) CYCLE
                      ELSE IF (NTYP == 2 .OR. ITRY == -5) THEN
                        IF ((IFNT3 - IFNT4) /= 0) CYCLE
                      END IF
                    END IF
C * COMPARE ATOM TYPES ATOM 3 & ATOM 4
                    IF (MCOR(IAT4) == MIAT3) THEN
C * AVOID ZERO TRANSLATION
                      IF (ITRY /= -5 .OR. IAT3 /= IAT4) THEN
C * CHECK THAT ALL THREE COORDINATES FIT
                        DO K = 1, 3
                          DELTA = MOD (V3(K) - XCOR(K, IAT4), 1.0)
                          IF (ABS (DELTA) > 0.5)
     1                      DELTA = DELTA - SIGN (1.0, DELTA)
                          IF (ABS (DELTA) > 0.2) THEN
                            GO TO 30
                          END IF
                          DEL(K) = DELTA
                        END DO
                        CALL GEN002 (2, ADIR, DEL, V4, DIS)
                        DIS = DIS / 2
                        IF (DIS <= DLIM) THEN
C * REGISTER MAXIMUM DEVIATION WITHIN ALLOWED TOLERANCE 'DLIM'
                          IF (DIS > DSMAX) THEN
                            DSMAX = DIS
                            DSAVR = DSAVR + DIS
                            NSAVR = NSAVR + 1
                            CALL PLA047 (LCOR(IAT3), NQ3,
     1                        IDUM, JDUM, 0, IGBL(55), 0,
     2                        1 - IGBL(55))
                            CALL PLA047 (LCOR(IAT4), NQ4,
     1                        IDUM, JDUM, 0, IGBL(55), 0,
     2                        1 - IGBL(55))
                            NQ3(6 : 6) = '-'
                          END IF
                          NCOR(IAT3) = NCOR(IAT3) + 1
C * THIS ATOM IAT3 PASSED THE TEST, NEXT ATOM IAT3
                          NCHR = NCHR + IABS (IFNT3)
                          GO TO 40
                        END IF
                      END IF
                    END IF
   30             CONTINUE
C * END OF ATOM IAT4 LOOP
C * FAILURE, THIS ATOM HAS NO EQUIVALENT (COUNT FAILURE)
                  NFIT = NFIT + 1
                  IF (NFIT * 100.0 / NATOMS > P407) THEN
                    GO TO 90
                  END IF
   40           CONTINUE
C * END OF ATOM IAT3 LOOP
C * (ALL) ATOMS PASSED THE TEST CRITERIUM, THIS IS AN (APPROXIMATE) SYMMETRY ELE
C * SPECIAL TREATMENT INVERSION SYMMETRY IN NON_CENTRO STRUCTURES
                IF (ITRY == 5) THEN
                  IF (IPR(257) == 1) THEN
                    IF (NFIT /= 0) IPR(118) = 1
                  END IF
                END IF
                NQ1  = ' '
                NFTX = 0
                CALL GEN038 (LINE, 1, 80)
                DO N = 1, NATOMS
                  IF (NCOR(N) < 1) THEN
                    CALL PLA047 (LCOR(N), NQ2, IDUM, JDUM, 0,
     1                           IGBL(55), 0, 0)
                    IF (NQ2 /= NQ1) THEN
                      NQ1 = NQ2
C * NO < 100 % METAL NON-FIT
                      IF (JCA(N) == 1 .AND. ITRY == 5) THEN
                        IF (NFTX /= 0) THEN
                          WRITE (LU6, 99988, IOSTAT = IOST)
                          IF (IGBL(63) > 0) THEN
                            CALL PLA262 (1)
                            WRITE (LU7, 99988, IOSTAT = IOST)
                          END IF
                        END IF
                        GO TO 90
                      END IF
                      NFTX = NFTX + 1
                      IF (NFTX < 12) THEN
                        LINE((NFTX - 1) * 5 + 1:) = NQ1
                      END IF
                    END IF
                  END IF
                END DO
                FIT = NFTX * 100.0 / NINC
                IF (FIT > P407) THEN
                  IPR(118) = 0
                  GO TO 90
                END IF
                IF (NFTX == 0) THEN
                  NNFIT = 100
                ELSE
                  NNFIT = INT (100.0 - FIT)
                END IF
C * FOUND ONE GENERATOR, TRANSFORM IT TO THE INPUT CELL
                CALL GEN004 (TRNS,   BTRANS, TTRANS)
                CALL GEN003 (TTRANS, TTRM1,  DET, 0)
                CALL GEN132 (TTRANS, ROTAX, TTRM1, ROTM1)
C * COMPARE ITS ROTATIONAL PART WITH THOSE OF THE INPUT SPACE GROUP
C * FLAG THE NEW ELEMENTS WITH AN ASTERISK
                ISTR   = 1
                NNNDIS = MAX (NNNDIS, ISTR)
                STAR   = '*'
                IF (ITRY /= -5) THEN
                  DO 50 I = 1, NSYM
                    CALL SGSM (6, ICL, SGY, I, LU6, IERR)
                    ITEL = 0
                    DO IR = 1, 3
                      DO IL = 1, 3
                        ITEL = ITEL + 1
                        IF (ABS (ROTM1(IR, IL) - SGY(ITEL))
     1                      > 0.01) GO TO 50
                      END DO
                    END DO
                    ISTR = 0
                    STAR = ' '
C * MAKE SURE THAT UN-STARRED SYMMETRY ELEMENT HAVE 100 % FIT
                    IF (NFIT > 0 .AND. NLCLP == 1) THEN
                      P407  = 0.0
                      NLOOP = NLOOP + 1
                      IF (NLOOP < 10) GO TO 20
                    END IF
                    GO TO 60
   50             CONTINUE
                  IPR(209) = 1
                END IF
C * NOW PREPARE THE OUTPUT LINE.
   60           FSYM = ' '
                NRT  = NROT
                IF (ITRY > 0 .AND. ITYP /= 4) THEN
                  FSYM(1 : 1) = '-'
                  IF (NRT == 4) NRT = 5
                END IF
                FSYM(2 : 2) = CHAR (ICHAR ('0') + NROT)
                IF (ITRY == -4) THEN
                  FSYM(2 : 2) = 'm'
                  NRT         = 0
                END IF
C * BRING AN EVENTUAL GLIDE COMPONENT BETWEEN 0 AND 1
                IGLIDE = 0
                DO I = 1, 3
                  ORI = MOD (ORIG(I), 1.0)
                  IF (ORI < -0.45) ORI = ORI + 1.0
                  IF (ORI >   0.6) ORI = ORI - 1.0
                  ORIG(I) = ORI
                  GLI     = MOD (GLIDO(I, JG), 1.0)
                  IF (GLI < -0.45) GLI = GLI + 1.0
                  IF (GLI >  0.6)  GLI = GLI - 1.0
                  GLIDE(I) = GLI
                  IF (ABS (GLI) >= 0.05) IGLIDE = 1
                END DO
C * TRANSFORM THE ROW INDICES, THE ORIGIN OF THE ELEMENT AND
C * THE GLIDE TO THE INPUT CELL
                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 I = 1, 3
                  IF (ISYM >= MSYM) THEN
                    ORIG(I) = MOD (1.0 + ORIG(I), 0.5)
                  ELSE
                    IF (ORIG(I) < - 0.1) ORIG(I) = ORIG(I) + 1.0
                  END IF
                END DO
C * MAKE THE ROW INDICES INTEGER, FIRST NON-ZERO INDEX POSITIVE
                IF (DSMAX < 0.0001) THEN
                  NQ3 = ' '
                  NQ4 = ' '
                END IF
C * ITYP /= 5 (I.E. ROTATIONS)
                IF (ITYP /= 5) THEN
                  ISIG  = 0
                  DO I = 1, 3
                    IF (ISIG == 0 .AND. ROW(I) < -0.01)
     1                  ISIG = -1
                    IF (ISIG == 0 .AND. ROW(I) >  0.01)
     1                  ISIG = 1
                  END DO
                  IMULT = 0
   70             IMULT = IMULT + ISIG
                  DO I = 1, 3
                    IROW(I) = NINT (IMULT * ROW(I))
                    IF (ABS (ABS (ROW(I) * IMULT) - IABS (IROW(I)))
     1                  > 0.01) GO TO 70
                  END DO
C * IF THE SENSE OF THE ROW WAS CHANGED FOR OUTPUT, A POSITIVE ROTATION
C * IS NOW ACCOMPANIED BY AN OPPOSITE GLIDE
                  IF (ITRY < 0) THEN
                    DO I = 1, 3
                      GLIDE(I) = ISIG * GLIDE(I)
                      GLY(I)   = GLIDE(I)
                    END DO
                  END IF
                  IF (IGLIDE == 1) THEN
                    TEXT1 = 'Screw  '
                    DO I = 1, 3
                      ITR(I)   = MOD (NINT (12.0 * GLIDE(I)) + 12, 12)
                      GLIDE(I) = ITR(I) / 12.0
                      ISHIFT    = ITR(I) * IROW(I)
                      ITRI0    = ITR(I)
                      IF (ISHIFT /= 0) THEN
                        IF (NROT == 3) THEN
                          IF (ITRI0 == 2) THEN
                            ITRI0 = 4
                          ELSE IF (ITRI0 == 10) THEN
                            ITRI0 = 8
                          END IF
                        END IF
                        FSYM(3:3) =
     1                    CHAR (ICHAR ('0') + ITRI0 * NROT / 12)
                      END IF
                    END DO
                    IF (ITRY == - 4) THEN
                      NRT   = 0
                      FSYM(3:3) = ' '
                      TEXT1 = 'Glide  '
C * TEST FOR c, b, a, d or n - PLANE
                      IF (ITR(1) == 0 .AND. ITR(2) == 0) THEN
                        FSYM(2 : 2) = 'c'
                      ELSE IF (ITR(1) == 0 .AND. ITR(3) == 0) THEN
                        FSYM(2 : 2) = 'b'
                      ELSE IF (ITR(2) == 0 .AND. ITR(3) == 0) THEN
                        FSYM(2 : 2) = 'a'
                      ELSE IF (MOD (ITR(1), 6) == 3 .OR.
     1                         MOD (ITR(2), 6) == 3) THEN
                        FSYM(2 : 2) = 'd'
                      ELSE
                        FSYM(2 : 2) = 'n'
                      END IF
                    END IF
                    IPRMX = 80
                  ELSE
                    IPRMX = 55
                  END IF
C * SAVE SYMMETRY
                  NEWS = NEWS + 1
                  NMIS(NEWS) = (6 - NRT) * 100 + NEWS
                  DO IR = 1, 3
                    DO IK = 1, 3
                      XMISR(IR, IK, NEWS) = ROTM1(IR, IK)
                    END DO
                    XMISL(IR, NEWS) = ORIG(IR)
                    XMISG(IR, NEWS) = GLY(IR) * ISIG
                  END DO
C * NOW OUTPUT THE RESULTS IN THE PROPER FORM
                  IF (NFTX > 0) THEN
                    WRITE (LU6, 99996, IOSTAT = IOST)
                    WRITE (LU6, 99983, IOSTAT = IOST) LINE(1:75)
                    WRITE (LU6, 99988, IOSTAT = IOST)
                    WRITE (LU6, 99988, IOSTAT = IOST)
C * CHECK PRINTLEVEL
                    IF (IGBL(63) > 0) THEN
                      CALL PLA262 (4)
                      WRITE (LU7, 99996, IOSTAT = IOST)
                      WRITE (LU7, 99983, IOSTAT = IOST) LINE(1:75)
                      WRITE (LU7, 99988, IOSTAT = IOST)
                    END IF
                  END IF
                  DSAVR = DSAVR / NSAVR
C * LIST SYMMETRY ELEMENT INFO
                  WRITE (PRBUF, 99995, IOSTAT = IOST)
     1              FSYM(1:2), STAR, IROW, IROW0, DLE, IPERP, MULT,
     2              ANG, NNFIT, DSAVR, ORIG
                  NNNFIT = MIN (NNNFIT, NNFIT)
                  CALL GEN065 (0, PRBUF, 1, 81, 23)
                  WRITE (LU6, 99983, IOSTAT = IOST) PRBUF(1:80)
                  IF ((NNFIT < 100 .OR. DSMAX > PAR(404)) .AND.
     1              ISTR == 1) THEN
                    ISTR   = 5
                    NNNDIS = ISTR
                    NNDIS  = ISTR
                  END IF
                  IF (STAR == '*') THEN
C * ALERT _112 - Additional (Pseudo) Symmetry Element Found
                    YUNK = -999.0
                    IF (NNFIT == 100 .AND. IPR(773) == 0) THEN
                      YUNK = 100.0
                    END IF
                    CALL PLA236 (112, 0, YUNK, FLOAT (NNFIT), FSYM, ' ')
                  END IF
                  IF (IWIN == 1) THEN
                    VRT = VRT - 0.5
                    CALL PLA439 (0.0, PRBUF, 80, 0.35, 1 + ISTR,
     1                           2, 1.0, VRT)
                  END IF
                  IF (IGBL(63) > 2) THEN
                    CALL PLA262 (1)
                    WRITE (LU7, 99983, IOSTAT = IOST) PRBUF(1:80)
                  END IF
                  IF (DSMAX > -1.0) THEN
                    WRITE (PRBUF, 99991, IOSTAT = IOST) FSYM(3:3),
     1                NQ3(1:6), NQ4(1:6), DSMAX, TEXT1, GLIDE
                    CALL GEN065 (0, PRBUF, 1, IPRMX + 1, 7)
                    WRITE (LU6, 99983, IOSTAT = IOST) PRBUF(1:IPRMX)
                    IF (IWIN == 1) THEN
                      DO I = 1, IPRMX
                        IF (PRBUF(I:I) /= ' ') THEN
                          VRT = VRT - 0.5
                          CALL PLA439 (0.0, PRBUF, IPRMX, 0.35,
     1                       1 + ISTR, 2,  1.0, VRT)
                          GO TO 80
                        END IF
                      END DO
                    END IF
   80               IF (IWIN == 1) CALL GGIP (0.0, 0.0, 0.0, 6)
                    IF (IGBL(63) > 2) THEN
                      CALL PLA262 (1)
                      WRITE (LU7, 99983, IOSTAT = IOST) PRBUF(1:IPRMX)
                    END IF
                  END IF
                  IF (DSMAX > PAR(291)) PAR(291) = DSMAX
                  NSV         = NSV + 1
                  KBO(NSV, 1) = NROT
                  KBO(NSV, 2) = ISYM
                  KBO(NSV, 3) = ISTR
                  KBO(NSV, 4) = NINT (DLE * 10000.0)
C * ITYP = 5 (I.E. Lattice Translations and Inversions)
                ELSE
                  IF (ITRY < 0) THEN
C * HANDLE LATTICE TRANSLATION
                    CALL PLA065
                    GO TO 90
                  ELSE
                    IF (IPR(257) == 1) INVST = 1
                    IF (STAR == '*') THEN
                      IF (LOOPR == 1) NNF111 = NNFIT
                    END IF
                    DSAVR = DSAVR / NSAVR
                    WRITE (PRBUF, 99987, IOSTAT = IOST)
     1                STAR, NNFIT, DSAVR, ORIG
C * TEMP SAVE BEST ORIGIN
                    IF (DSMAX < DSCENT) THEN
                      NFT     = NNFIT
                      DSCENT  = DSMAX
                      ORGM(1) = ORIG(1)
                      ORGM(2) = ORIG(2)
                      ORGM(3) = ORIG(3)
                    END IF
                    CALL GEN065 (0, PRBUF, 1, 81, 7)
                    WRITE (LU6, 99983, IOSTAT = IOST) PRBUF(1:80)
                    IF (IGBL(63) > 2) THEN
                      CALL PLA262 (1)
                      WRITE (LU7, 99983, IOSTAT = IOST) PRBUF(1:80)
                    END IF
                    IF ((NNFIT < 100 .OR. DSMAX > PAR(405))
     1                .AND. ISTR == 1) THEN
                      ISTR  = 5
                      NNDIS = 5
                    END IF
                    IF (IWIN == 1) THEN
                      VRT = VRT - 0.5
                      CALL PLA439 (0.0, PRBUF, 80, 0.35, 1 + ISTR,
     1                             2, 1.0, VRT)
                    END IF
                    IF (STAR == '*' .AND. DSMAX > -1.0) THEN
                      WRITE (PRBUF, 99992, IOSTAT = IOST)
     1                  NQ3(1:6), NQ4(1:6), DSMAX
                        CALL GEN065 (0, PRBUF, 1, 81, 7)
                      WRITE (LU6, 99983, IOSTAT = IOST) PRBUF(1:80)
                      IF (IWIN == 1) THEN
                        VRT = VRT - 0.5
                        CALL PLA439 (0.0, PRBUF, 80, 0.35, 1 + ISTR,
     1                               2, 1.0, VRT)
                      END IF
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99983, IOSTAT = IOST) PRBUF(1:80)
                      END IF
                    END IF
                  END IF
                END IF
                IF (ITYP /= 5 .OR. STAR == '  ') GO TO 100
              END IF
C * NEXT POSSIBLE OPERATOR
   90       CONTINUE
C * FIRST IMPLEMENT LATTICE CENTERING
          END DO
        END DO
C * ALL SYMMETRY ELEMENTS EXHAUSTED - REPORT AS METRIC SYMMETRY
        IF (ISYM < MSYM) THEN
          IMETRIC = IMETRIC + 1
          WRITE (PRBUF, 99993, IOSTAT = IOST)
     1      IROW0, DLE, IPERP, MULT, ANG
          CALL GEN065 (0, PRBUF, 1, 61, 20)
          WRITE (LU6, 99998, IOSTAT = IOST) PRBUF(1:61)
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99998, IOSTAT = IOST) PRBUF(1:61)
          END IF
        END IF
  100 CONTINUE
C * CHECK FOR NEW LATTICE TRANSLATIONS AND (NO) SUBCELL OPTION (IPR(503) = 0)
      IF (IPR(503) == 0) THEN
        IF (NEWLT > 0) THEN
C * FIND TRANSFORMATION MATRIX TO SUBLATTICE
          NLTX = 0
          CALL PLA064 (NEWLT, IPR(241), NLTX)
          IF (NLTX > 0) THEN
            IF (IWIN == 1) THEN
              IF (NNFIT == 100) THEN
                XSUB = 'S'
                WRITE (LU6, 99999)
                NRET61 = 1
                RETURN
              ELSE
C * WHAT NEXT ?
                CALL PLA012 (-1, 1)
              END IF
            ELSE
              IGGT  = 'Y'
            END IF
            IF (IGGT(1:1) == 'Y') THEN
              CALL PLA236 (116, 0, -999.0, 1.0, ' ', ' ')
              WRITE (PRBUF, 99982, IOSTAT = IOST) JID(1:21)
              WRITE (LU6, 99994, IOSTAT = IOST) PRBUF
              IF (IWIN == 1) THEN
                VRT = VRT - 1.5
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 4.0, VRT)
                CALL PLA297 (0)
              END IF
              IF (IGBL(63) > 2) THEN
                CALL PLA262 (3)
                WRITE (LU7, 99997, IOSTAT = IOST) PRBUF
              END IF
              XSUB   = 'S'
              NRET61 = 1
              RETURN
            ELSE
              IPR(459) = 0
              IPR(209) = 0
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (/, 'Implement Suggested Subcell and Restart ADDSYM', /)
99998 FORMAT (A, /)
99997 FORMAT (/, A, /)
99996 FORMAT (/, ':: NonFits (i.e. Atoms with no symmetry related',
     1           ' counterpart):')
99995 FORMAT (A, 1X, A, ' [', 3I2, '] [', 3I2, ']', F6.2, 2I3, F6.2,
     1        I5, F8.3, '  Through', 3F6.3)
99994 FORMAT (/, ':: ', A, /)
99993 FORMAT (14X, '[', 3I2, ']', F6.2, 2I3, F6.2, 14X, ' Metric')
99992 FORMAT (36X, 2A, F5.3)
99991 FORMAT (2X, A, 33X, 2A, F5.3, 2X, A, 3F6.3)
99990 FORMAT ('- ', A)
99989 FORMAT ('The Structure Implies the Following Symmetry ',
     1        'Elements Subject to the Criteria:')
99988 FORMAT (1X)
99987 FORMAT ('-1 ', A, 1X, 35('='), 2X, I3, F8.3, 2X, 'at', 5X,
     1         3F6.3, 1X)
99986 FORMAT (80('-'))
99985 FORMAT ('Elem', 1X, 'Cell_Row', 1X, 'Cell_Row', 3X,
     1        'd  Typ Dot Angle Fit  MaxDev.', 13X,
     2        'x     y     z')
99984 FORMAT ('Symm.  Input  Reduced  (Ang)', 8X, '(Deg)', 2X,
     1        '%', 3X, 'AvrDev.(Ang)', 10X, 'Input Cell')
99983 FORMAT (A)
99982 FORMAT ('Forced RESTART of ADDSYM to Implement TRANSLATION for ',
     1        A)
99981 FORMAT ('Criteria', F5.2, ' Deg (Metric),', F5.2, ' Ang (Rot),'
     1        , F5.2, ' Ang (Inv),', F5.2, ' Ang (Transl)')
99980 FORMAT ('- Pivot Atom ', A)
      END SUBROUTINE PLA061
 
      SUBROUTINE PLA062
C * ADDSYM-SYMMETRY CHECK (2)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE spgrdata
      USE addsym
      USE latice
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: N
      INTEGER               :: N0
      INTEGER               :: NB
      INTEGER               :: JN
      INTEGER               :: IR
      INTEGER               :: INZ
      INTEGER               :: IN1
      INTEGER               :: JMX
      INTEGER               :: NRT
      INTEGER               :: NSP
      INTEGER               :: NRT1
      INTEGER               :: NRXX
      INTEGER               :: NROT
      INTEGER               :: NNRT
      INTEGER               :: NCOL
      INTEGER               :: LAT0
      INTEGER               :: LAT1
      INTEGER               :: IDET
      INTEGER               :: IDUM
      INTEGER               :: ISYM
      INTEGER               :: JMAX
      INTEGER               :: MLAUE
      INTEGER               :: ISYST
      INTEGER               :: ISGNR
      INTEGER               :: JPRLP
      INTEGER               :: GEN135
      INTEGER               :: UNITMAT
      REAL                  :: DET
      REAL                  :: YUNK
      REAL                  :: XLNG
      REAL                  :: DANG
      REAL                  :: DDIS
      REAL                  :: DUM433
      REAL, DIMENSION(3, 3) :: DUMMY
      REAL, DIMENSION(3, 3) :: DUM1
      REAL, DIMENSION(3, 3) :: DUM2
      REAL, DIMENSION(3, 3) :: DUM3
      REAL, DIMENSION(3, 3) :: DUM4
      REAL, DIMENSION(3, 3) :: TR1
      REAL, DIMENSION(3, 3) :: TTRM1
      CHARACTER(len=7)      :: ZSPG0
      CHARACTER(len=9)      :: ZSPG2
      CHARACTER(len=9)      :: ZSPG3
C * ANALYZE THE 'NSV' SYMMETRY ELEMENTS INTO A (STANDARD/NEW) SPACE GROUP
C * KBO(I, 1) = NROT
C * KBO(I, 2) = ISYM
C * KBO(I, 3) = ISTR - STARRED =
C * KBO(I, 4) = D
C * PAT(3, 3) = Reduced to Convential Cell Transformation
      IN1   = 0
      ISYST = 8
      MLAUE = 12
      NRXX  = 0
C * ELIMINATE NEW (STARRED) OPERATION (NSV = 2 NOT POSSIBLE)
      IF (NSV == 2) THEN
        DO I = 1, 2
          IF (KBO(I, 3) == 1) THEN
            KBO(I, 1) = 0
            EXIT
          END IF
        END DO
      END IF
C * BUBBLE-SORT ON VALUE OF 'NROT' (LARGE TO SMALL)
      IF (NSV > 1) THEN
        JMX = NSV - 1
        NB  = 1
        DO WHILE (NB /= 0)
          NB  = 0
          DO J = 1, JMX
            IF (KBO(J, 1) < KBO(J + 1, 1)) THEN
              DO K = 1, 3
                CALL GEN014 (KBO(J, K), KBO(J + 1, K))
              END DO
              NB = 1
            END IF
          END DO
        END DO
      END IF
      IF (NSV == 2) NSV = 1
C * GET NEW LATTICE TYPE AND TRANSFORMATION
      IF (NSV == 0) THEN
C * TRICLINIC
        CALL GEN021 (PAT, 1.0)
        ISYST = 1
        MLAUE = 1
      ELSE
        NROT = KBO(1, 1)
        IF (NSV == 7 .AND. NROT /= 6) THEN
          K = 4
        ELSE
          K = 0
        END IF
        IF (K == 4 .OR. NSV == 3 .OR. NSV == 13) THEN
C * BUBBLE-SORT ON VALUE OF 'D' (SMALL to LARGE))
          IF (NSV == 3) THEN
            NB  = 1
            DO WHILE (NB /= 0)
              NB  = 0
              DO I = 1, 2
                IF (KBO(I, 4) > KBO(I + 1, 4)) THEN
                  DO J = 1, 4
                    CALL GEN014 (KBO(I, J), KBO(I + 1, J))
                  END DO
                  NB = 1
                END IF
              END DO
            END DO
          END IF
          DO I = 1, 3
            DO J = 1, 3
              PAT(I, J) = RH(J, 3, KBO(K + I, 2))
            END DO
          END DO
          IF (NSV == 3) THEN
C * ORTHORHOMBIC
            ISYST = 3
            MLAUE = 3
          ELSE IF (NSV == 7) THEN
C * LOW-CUBIC
            ISYST = 7
            MLAUE = 10
          ELSE
C * HIGH-CUBIC
            ISYST = 7
            MLAUE = 11
          END IF
        ELSE
          ISYM = KBO(1, 2)
          DO J = 1, 3
            DO K = 1, 3
              PAT(K, J) = RH(J, K, ISYM)
            END DO
          END DO
          IF (NSV == 1) THEN
            IF (NROT == 2) THEN
C * MONOCLINIC
              ISYST = 2
              MLAUE = 2
              DO J = 1, 3
                CALL GEN018 (PAT(2, J), PAT(3, J))
              END DO
            ELSE IF (NROT == 3) THEN
C * LOW-TRIGONAL
              ISYST = 5
              MLAUE = 6
            ELSE IF (NROT == 4) THEN
C * LOW-TETRAGONAL
              ISYST = 4
              MLAUE = 4
            ELSE
C * LOW-HEXAGONAL
              ISYST = 6
              MLAUE = 8
            END IF
          ELSE IF (NSV == 4) THEN
            IF (NROT /= 4) THEN
C * HIGH-TRIGONAL
              ISYST = 5
              MLAUE = 7
            ELSE
C * HIGH-TETRAGONAL
              ISYST = 4
              MLAUE = 5
            END IF
          ELSE IF (NSV == 5) THEN
C * HIGH-TETRAGONAL
            ISYST = 4
            MLAUE = 5
          ELSE IF (NSV == 7) THEN
C * HIGH-HEXAGONAL
            ISYST = 6
            MLAUE = 9
          END IF
        END IF
      END IF
      CALL GEN010 (PAT, IDET, 0)
      IF (IDET < 0) THEN
        DO J = 1, 3
          PAT(2, J) = - PAT(2, J)
        END DO
      END IF
      CALL GEN003 (PAT, ROTM1, DET, 0)
      IDET = NINT (DET)
      IF (IDET == 4) THEN
        LATT = 'F'
      ELSE IF (IDET == 3) THEN
        LATT = 'R'
C * TEST FOR OBVERSE/REVERSE
        V1(1) = 2.0
        V1(2) = 1.0
        V1(3) = 1.0
        CALL GEN094 (PAT, V1, 3, IDUM)
        IF (IDUM /= 0) THEN
          CALL GEN021 (DAM, 1.0)
          DAM(1, 2) =  1.0
          DAM(2, 1) = -1.0
          DAM(2, 2) =  0.0
          CALL GEN004 (DAM, PAT, PAT)
        END IF
      ELSE IF (IDET == 2) THEN
        V1(1) = 0.0
        V1(2) = 1.0
        V1(3) = 1.0
        N     = 0
C * TEST LATTICE TYPE A
        CALL GEN094 (PAT, V1, 2, IDUM)
        IF (IDUM == 0) THEN
          LATT = 'A'
          N    = 1
        ELSE
C * TEST LATTICE TYPE B
          CALL GEN018 (V1(1), V1(2))
          CALL GEN094 (PAT, V1, 2, IDUM)
          IF (IDUM == 0) THEN
            LATT = 'B'
            N    = 2
          ELSE
C * TEST LATTICE TYPE C
            CALL GEN018 (V1(2), V1(3))
            CALL GEN094 (PAT, V1, 2, IDUM)
            IF (IDUM == 0) THEN
              LATT = 'C'
            ELSE
C * TEST LATTICE TYPE I
              V1(3) = 1.0
              CALL GEN094 (PAT, V1, 2, IDUM)
              IF (IDUM == 0) THEN
                LATT = 'I'
              ELSE
                LATT = ' '
              END IF
            END IF
          END IF
        END IF
C * TRANSFORM LATT A & B TO C
        IF (N /= 0) THEN
          DO I = 1, 3
            PAT(2, I) = - PAT(2, I)
            CALL GEN018 (PAT(N, I), PAT(3, I))
          END DO
          LATT = 'C'
        END IF
      ELSE
        LATT = 'P'
      END IF
      IF (ISYST == 5) THEN
        LAT0 = 6
      ELSE
        LAT0 = ISYST
      END IF
C * TRANSFORM mI to mC
      IF (LAT0 == 2 .AND. LATT == 'I' .AND. IGBL(106) == 0) THEN
        LATT = 'C'
        CALL GEN021 (DAM, 1.0)
        DAM(1, 3) =  1.0
        DAM(3, 1) = -1.0
        DAM(3, 3) =  0.0
        CALL GEN004 (DAM, PAT, PAT)
      END IF
C * TRANSPOSE
      CALL GEN005 (TRNS, QM)
C * MULTIPLY MATRICES
      CALL GEN004 (PAT, QM, ROTM2)
C * CHECK FOR AND AVOID TRIVIAL TRANSFORMATIONS (VOIDED TEMP)
      IF (LAT0 < 4) THEN
        CALL GEN104 (LAT0, ROTM2, DUM4)
      ELSE
        CALL GEN021 (DUM4, 1.0)
      ENDIF
      CALL GEN004 (DUM4, PAT, PAT)
      CALL GEN004 (PAT, QM, ROTM2)
C * GET T-TRANSPOSE AND T-TRANSPOSE-INVERTED
      CALL GEN005 (ROTM2, TR1)
      CALL GEN003 (TR1, ROTM1, DET, 0)
C * TRY TO FIND NEW SPACEGROUP SETTING/NAME
C * BLANK SPACE GROUP NAME
      CALL GEN038 (SPGRNM(2), 1, 11)
C * SHIFT TO NEWLY FOUND INVERSION CENTRE (INVST = 1)
      IF (INVST == 1) THEN
        CALL GEN002 (1, ROTM1, ORGM, ORG, XLNG)
      ELSE
C * INIT ORG SHIFT TO ZERO
        CALL GEN074 (ORG, 1, 3, 0.0)
      END IF
      IF (INVST == 1 .OR. IPR(257) == 2) THEN
        CENT = 'C'
      ELSE
        CENT = 'A'
      END IF
C * SPECIAL PREPARATION FOR CUBIC (MOVE 3-FOLD AXIS TO HIGHEST PRIORITY)
      IF (LAT0 == 7) THEN
        DO JN = 1, NEWS
          INZ = NMIS(JN) / 100
          IF (INZ == 3) NMIS(JN) = NMIS(JN) + 300
        END DO
      END IF
C * SORT SMALL TO LARGE
      CALL GEN022 (NMIS, 1, NEWS, 1)
C * TRANSFORM SYMMETRY OPERATIONS TO NEW SETTING
      NRT1 = 0
      NNRT = 0
      DO I = 1, 3
        OADD(I) = 0.25
      END DO
C * XMISR - ROTATION MATRIX
C * XMISL - LOCATION VECTOR OF SYMMETRY ELEMENT
C * XMISG - SHIFT VECTOR (SCREW OR GLIDE)
C * LOOP OVER DETECTED SYMMETRY ELEMENTS
      DO JN = 1, NEWS
        INZ = MOD (NMIS(JN), 100)
        NRT = 6 - NMIS(JN) / 100
        IF (NRT == 5) THEN
          NRT  = 4
          NNRT = 1
        END IF
C * TRANSFORM SYMMETRY OPERATION TO CRYSTAL SYSTEM SETTING
        CALL GEN004 (ROTM1, XMISR(1, 1, INZ), XMISR(1, 1, INZ))
        CALL GEN004 (XMISR(1, 1, INZ), TR1, XMISR(1, 1, INZ))
        CALL GEN002 (1, ROTM1, XMISL(1, INZ), XMISL(1, INZ), XLNG)
        CALL GEN002 (1, ROTM1, XMISG(1, INZ), XMISG(1, INZ), XLNG)
C * DETERMINE ORIGIN SHIFT TO SUITABLE STARTING ORIGIN
        IF (JN == 1) THEN
          IF (INVST == 0 .AND. IPR(257) == 1) THEN
            IN1 = INZ
            DO I = 1, 3
              ORG(I) = XMISL(I, INZ)
            END DO
            NRT1   = NRT
C * SET PROPER ORIGIN SEARCH STEP FOR TETRAGONAL
            IF (LAT0 == 4) THEN
              OADD(3) = 0.125
C * SET PROPER ORIGIN SEARCH STEP FOR TRIGONAL & HEXAGONAL LATTICE
            ELSE IF (LAT0 == 6) THEN
              OADD(1) = 0.3333
              OADD(2) = 0.3333
              OADD(3) = 0.5 / NRT1
            ELSE IF (LAT0 == 7) THEN
              DO I = 1, 3
                OADD(I) = 0.125
              END DO
            END IF
          ELSE
C * SHIFT ORIGIN
C * TRIGONAL
            IF (NRT == 3 .OR. NRT == 6) THEN
C * SHIFT OVER HALF FOR DIFFERENCE = ODD * 1/6
              ORG(1) = ORG(1) +
     1           0.5 * MOD (NINT ((XMISL(1, INZ) - ORG(1)) * 6), 2)
              ORG(2) = ORG(2) +
     1           0.5 * MOD (NINT ((XMISL(2, INZ) - ORG(2)) * 6), 2)
            END IF
          END IF
        ELSE IF (JN == 2 .AND. NNRT == 0) THEN
          IF (INVST == 0 .AND. IPR(257) == 1) THEN
C * C-AXIS UNIQUE FOR NON-TRICLINIC,MONOCLINIC OR ORTHORHOMBIC
            IF (NRT1 > 2) THEN
C * DETERMINE 4-AXIS ALONG A,B or C
              IF (NRT == 4) THEN
                IF (XMISR(1, 1, IN1) == 1) THEN
                  ORG(1) = XMISL(1, INZ)
                ELSE IF (XMISR(2, 2, IN1) == 1) THEN
                  ORG(2) = XMISL(2, INZ)
                ELSE IF (XMISR(3, 3, IN1) == 1) THEN
                  ORG(3) = XMISL(3, INZ)
                END IF
              ELSE
                ORG(3) = XMISL(3, INZ)
              END IF
            ELSE
              IF (NINT (XMISR(1, 1, IN1)) ==  1 .AND.
     1            NINT (XMISR(2, 2, IN1)) == -1 .AND.
     2            NINT (XMISR(3, 3, IN1)) == -1) THEN
                ORG(1) = XMISL(1, INZ)
              ELSE IF (NINT (XMISR(1, 1, IN1)) == -1 .AND.
     1                 NINT (XMISR(2, 2, IN1)) ==  1 .AND.
     2                 NINT (XMISR(3, 3, IN1)) == -1) THEN
                ORG(2) = XMISL(2, INZ)
              ELSE IF (NINT (XMISR(1, 1, IN1)) == -1 .AND.
     1                 NINT (XMISR(2, 2, IN1)) == -1 .AND.
     2                 NINT (XMISR(3, 3, IN1)) ==  1) THEN
                ORG(3) = XMISL(3, INZ)
              END IF
            END IF
          END IF
        END IF
        DO IR = 1, 3
          XMISL(IR, INZ) = XMISL(IR, INZ) - ORG(IR)
        END DO
      END DO
C * SETUP NEW SYMMETRY
      NORG  = -1
      NORGM =  1
C * FIND CONVENTIONAL ORIGIN
      DO
        IF (NORG < NORGM) THEN
          CALL PLA063
C * INITIALIZE WITH (CENTRO) LATTICE
          WRITE (ICL, 99958,IOSTAT = IOST) LATT, CENT
          CALL SGSM (0, ICL, FN, 0, LU6, IERR)
C * LOOP OVER AND LOAD THE TRANSFORMED SYMMETRY OPERATIONS
          DO JN = 1, NEWS
            INZ = MOD (NMIS(JN), 100)
            DO J = 1, 3
              V5(J) = - XMISL(J, INZ) + OSHFT(J)
            END DO
            CALL GEN002 (1, XMISR(1, 1, INZ), V5, V6, XLNG)
            K = 0
            DO I = 1, 3
C * ROUND TO REASONABLE FRACTIONS
              FN(9 + I) = NINT (24.0 * MOD (XMISL(I, INZ) - OSHFT(I) +
     1                     V6(I) + XMISG(I, INZ) + 10.0, 1.0)) / 24.0
              DO J = 1, 3
                K     = K + 1
                FN(K) = XMISR(I, J, INZ)
              END DO
            END DO
C * INPUT SYMMETRY OPERATION TO SGSM ROUTINE AS (R|T) MATRIX
            CALL SGSM (15, ICL, FN, 0, 0, IERR)
C * ERROR HANDLING
            IF (IERR /= 0) THEN
              IF (LOOPR == 1) THEN
                JERR = JERR + 10
                RETURN
              ELSE
                EXIT
              END IF
            END IF
          END DO
C * GET SPACE GROUP INFO
          IF (IERR == 0) THEN
            IF (IBVL(LAT0)//LATT == 'mI' .AND. IGBL(106) == 1) THEN
              CALL SGSM (18, ICL, FN, 0, 0, IERR)
            ELSE
              CALL SGSM (24, ICL, FN, 0, 0, IERR)
            END IF
            SPGRNM(2) = ICL(1:26)
C * CHECK FOR SAME LATTICE TYPE
            IF (IBVL(LAT0)//LATT == ICL(12:13)) THEN
              IF (SPGRNM(2)(1:5) /= 'C2/n') THEN
                IF (SPGRNM(2)(1:2) /= '  ') GO TO 20
              END IF
            END IF
          END IF
        ELSE
          SPGRNM(2)(1:1) = ' '
          JERR = JERR + 100
          RETURN
        END IF
      END DO
C * ADD ADDITIONAL SHIFT
   20 DO J = 1, 3
        ORG(J)   = ORG(J) + OSHFT(J)
        OSHFT(J) = 0.0
      END DO
      IF (SPGRNM(2)(1:1) == ' ') THEN
        SPGRNM(2)(1:1) = '?'
C * GET SPACE GROUP INFO
        CALL SGSM (18, ICL, FN, 0, 0, IERR)
        SPGRNM(2) = ICL(1:26)
        ISGNR     = NINT (FN(1))
        LAT0      = NINT (FN(2))
        LATT      = SPGRNM(2)(13:13)
      ELSE
C * TRANSFORM TO STANDARD SETTING
        IF (SPGRNM(2)(12:12) == 'm') THEN
          IF (SPGRNM(2)(1:7) == 'Pa     ') THEN
            SPGRNM(2)(1:11) = 'Pc     C-BA'
          ELSE IF (SPGRNM(2)(1:7) == 'P2/a   ') THEN
            SPGRNM(2)(1:11) = 'P2/c   C-BA'
          ELSE IF (SPGRNM(2)(1:7) == 'P21/a  ') THEN
            SPGRNM(2)(1:11) = 'P21/c  C-BA'
C * TRANSFORM P21/n TO P21/c etc. BY DEFAULT
          ELSE IF (IGBL(106) == 0) THEN
            IF (SPGRNM(2)(1:7) == 'Pn     ') THEN
              SPGRNM(2)(1:11) = 'Pc     A-B-'
            ELSE IF (SPGRNM(2)(1:7) == 'P2/n   ') THEN
              SPGRNM(2)(1:11) = 'P2/c   A-B-'
            ELSE IF (SPGRNM(2)(1:7) == 'P21/n  ') THEN
              SPGRNM(2)(1:11) = 'P21/c  A-B-'
            END IF
          END IF
        ELSE IF (SPGRNM(2)(12:12) == 'c') THEN
          IF (SPGRNM(2)(1:7) == 'Pb-3   ') THEN
            SPGRNM(2)(1:11) = 'Pa-3   BA-C'
            OSHFT(2) = 0.5
          END IF
        END IF
C * UPPERCASE THE SETTING SYMBOL
        CALL GEN020 (1, SPGRNM(2), 8, 11)
        N = 0
C * NON-STANDARD ORTHORHOMBIC TRANSFORMATIONS
        IF (.FALSE.) THEN
          DUM433 = 0.0
C * OBTAIN LIST OF EQUIVALENT TRANSFORMATIONS TO STANDARD SPACE GROUP
          CALL SGSM (23, ICL, FN, 0, 0, IERR)
          DO K = 1, 6
            IF (FN(K) /= 0) THEN
C * COPY MATRIX
              CALL GEN052 (TRDAT(1, 1, K), DUM1)
              CALL GEN004 (DUM1, PAT, DUM2)
              CALL GEN004 (DUM2, QM,  DUM3)
              CALL GEN004 (DUM3, AA,  DUM4)
C * TRANSPOSE
              CALL GEN005 (DUM3, DUM3)
              CALL GEN004 (DUM4, DUM3, DUM4)
              IF (DUM4(3, 3) > DUM433) THEN
                DUM433 = DUM4(3, 3)
                N      = K
              ELSE IF (DUM4(3, 3) == DUM433) THEN
                IF (DUM4(1, 1) < DUM4(2, 2)) THEN
                  N = K
                END IF
              END IF
              IF (DUM4(1, 1) < DUM4(2, 2) .AND.
     1            DUM4(2, 2) < DUM4(3, 3)) THEN
                 N = K
                 GO TO 30
              END IF
            END IF
          END DO
        ELSE
          DO K = 1, 8
            IF (SPGRNM(2)(8:11) == TRTYP(K)(1:4)) THEN
              N = K
              GO TO 30
            END IF
          END DO
        END IF
   30   WRITE (ICL, 99968, IOSTAT = IOST) SPGRNM(2)(1:7)
        CALL SGSM (0, ICL, SGY, NRXX, LU6, IERR)
C * GET SPACE GROUP INFO
        CALL SGSM (18, ICL, FN, 0, 0, IERR)
        SPGRNM(2) = ICL(1:26)
        ISGNR     = NINT (FN(1))
        LAT0      = NINT (FN(2))
        LATT      = SPGRNM(2)(13:13)
C * IMPLEMENT TRANSFORMATION TO STANDARD SETTING
        IF (N /= 0) THEN
          CALL GEN052 (TRDAT(1, 1, N), DUM1)
        ELSE
          CALL GEN021 (DUM1, 1.0)
        END IF
C * COPY PAT MATRIX
        CALL GEN052 (PAT, DUM2)
        CALL GEN004 (DUM1, DUM2, DUM3)
        CALL GEN004 (DUM3, QM, ROTM2)
        CALL GEN021 (DUM4, 1.0)
        CALL GEN004 (DUM4, DUM3, PAT)
C * GET T-TRANSPOSE AND T-TRANSPOSE-INVERTED (TO TRANSFORM ORIGIN)
C * MULTIPLY
        CALL GEN004 (DUM4, DUM1, DUM1)
C * TRANSPOSE
        CALL GEN005 (DUM1, TR1)
C * INVERT
        CALL GEN003 (TR1, TTRM1, DET, 0)
C * MATRIX - VECTOR TRANSFORMATION
        CALL GEN002 (1, TTRM1, ORG, ORG, XLNG)
      END IF
      DO J = 1, 3
        ORG(J) = ORG(J) + OSHFT(J)
        IF (ORG(J) < - 0.5) ORG(J) = ORG(J) + 1.0
        IF (ORG(J) >   0.5) ORG(J) = ORG(J) - 1.0
      END DO
      LU = LU6
      IF (LU > 0) THEN
        WRITE (LU6, 99997, IOSTAT = IOST)
        IF (IWIN == 1 .AND. LU /= 0) THEN
          IF (VRT < 7.0) THEN
C * WHAT NEXT ?
            CALL PLA012 (0, 1)
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT - 2.0
          END IF
          WRITE (PRBUF, 99987, IOSTAT = IOST)
          VRT = VRT - 0.7
          CALL PLA439 (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
        END IF
      END IF
      CALL GEN003 (ROTM2, DUMMY, DET, 0)
      UNITMAT = GEN135 (ROTM2)
      CALL GEN005 (DUMMY, DUMMY)
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (8)
        WRITE (LU7, 99997, IOSTAT = IOST)
      END IF
      WRITE (PRBUF, 99996, IOSTAT = IOST) (PAT(1, J), J = 1, 3),
     1    (QM(1, J), J = 1, 3), (ROTM2(1, J), J = 1, 3)
      CALL GEN065 (LU, PRBUF, 1, 80, 16)
      IF (IWIN == 1 .AND. LU /= 0) THEN
        VRT = VRT - 0.5
        CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
      END IF
      IF (IGBL(63) > 2) WRITE (LU7, 99960, IOSTAT = IOST) PRBUF
      WRITE (PRBUF, 99995, IOSTAT = IOST) (PAT(2, J), J = 1, 3),
     1    (QM(2, J), J = 1, 3), (ROTM2(2, J), J = 1, 3)
      CALL GEN065 (LU, PRBUF, 1, 80, 16)
      IF (IWIN == 1 .AND. LU /= 0) THEN
        VRT = VRT - 0.5
        CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
      END IF
      IF (IGBL(63) > 2)  WRITE (LU7, 99960, IOSTAT = IOST) PRBUF
      WRITE (PRBUF, 99994, IOSTAT = IOST) (PAT(3, J), J = 1, 3),
     1    (QM(3, J), J = 1, 3), (ROTM2(3, J), J = 1, 3), DET
      CALL GEN065 (LU, PRBUF, 1, 80, 16)
      IF (IWIN == 1 .AND. LU /= 0) THEN
        VRT = VRT - 0.5
        CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
      END IF
      IF (IGBL(63) > 0) WRITE (LU7, 99960, IOSTAT = IOST) PRBUF
      CALL GEN004 (ROTM2, AA, DUMV)
C * TRANSPOSE
      CALL GEN005 (ROTM2, ROTM1)
      CALL GEN004 (DUMV, ROTM1, DUMV)
      CALL GEN026 (-1, DUMV, PAR(143))
      CALL GEN003 (DUMV, ROTM1, DET, 0)
      PAR(100) = SQRT (DET)
      DDIS     = 0.0
      DANG     = 0.0
C * MONOCLINIC
      IF (ISYST == 2) THEN
        DANG = MAX (ABS (PAR(146) - 90.0), DANG)
        DANG = MAX (ABS (PAR(148) - 90.0), DANG)
C * ORTHORHOMBIC
      ELSE IF (ISYST == 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)
C * TETRAGONAL
      ELSE IF (ISYST == 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)
C * TRIGONAL/HEXAGONAL
      ELSE IF (ISYST == 5 .OR. ISYST == 6) THEN
        DDIS = MAX (ABS (PAR(143) - PAR(144)), DDIS)
        DANG = MAX (ABS (PAR(148) - 120.0), DANG)
C *n CUBIC
      ELSE IF (ISYST == 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)
      END IF
C * PRINT CELL PARAMETERS A, B, C, ALPHA, BETA, GAMMA AND LATTICE TYPE
C * PRINT INPUT, REDUCED AND CONVENTIONAL CELL PARAMETERS
      IF (IGBL(63) > 2) THEN
        JMAX = 2
      ELSE
        JMAX = 1
      END IF
      DO JPRLP = 1, JMAX
        IF (JPRLP == 2) THEN
          LU = LU7
          CALL PLA262 (6)
        ELSE
          LU = LU6
        END IF
        WRITE (LU, 99969, IOSTAT = IOST)
        WRITE (LU, 99998, IOSTAT = IOST)
        WRITE (LU, 99964, IOSTAT = IOST)
        WRITE (LU, 99993, IOSTAT = IOST)
     1    SPGRNM(1)(12:13), (PAR(100 + I), I = 1, 6),
     2    NINT (PAR(98)), KRSYST(2),  LAUEGR
        WRITE (LU, 99992, IOSTAT = IOST)
     1   (PAR(122 + I), I = 1, 6), NINT (PAR(99))
        LAT1 = LAT0
        IF (LAT1 == 5) LAT1 = 6
        KRSYST(3) = XSYST(ISYST)
        CALL GEN020 (-1, KRSYST(3), 1, 12)
        WRITE (LU, 99991, IOSTAT = IOST)
     1    IBVL(LAT1), LATT, (PAR(142 + I), I = 1, 6),
     2    NINT (PAR(100)), KRSYST(3), LGR(MLAUE)
        IF (JPRLP == 1) THEN
          IF (IWIN == 1) THEN
            WRITE (PRBUF, 99998, IOSTAT = IOST)
            VRT = VRT - 0.8
            CALL PLA439 (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, 99993, IOSTAT = IOST)
     1             SPGRNM(1)(12:13), (PAR(100 + I), I = 1, 6),
     2                    NINT (PAR(98)), KRSYST(2),  LAUEGR
            VRT = VRT - 0.8
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
            WRITE (PRBUF, 99992, IOSTAT = IOST)
     1            (PAR(122 + I), I = 1, 6), NINT (PAR(99))
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
            LAT1 = LAT0
            IF (LAT1 == 5) LAT1 = 6
            WRITE (PRBUF, 99991, IOSTAT = IOST)
     1        IBVL(LAT1), LATT, (PAR(142 + I), I = 1, 6),
     2        NINT (PAR(100)), KRSYST(3), LGR(MLAUE)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
          END IF
          IF (NLCLP == 1) THEN
            N0 = INDEX (ZSPG, ':')
            IF (N0 /= 0) THEN
              ZSPG0 = ZSPG(1:N0-1)
            ELSE
              ZSPG0 = ZSPG
            END IF
C * REPORT ON NON-STANDARD SETTINGS
            IF (ZSPG0 == SPGRNM(2)(1:7)) THEN
              IF (ABS (PAR(101) - PAR(143)) > 0.01 .OR.
     1            ABS (PAR(102) - PAR(144)) > 0.01 .OR.
     2            ABS (PAR(103) - PAR(145)) > 0.01 .OR.
     3            ABS (PAR(104) - PAR(146)) > 0.1  .OR.
     4            ABS (PAR(105) - PAR(147)) > 0.1  .OR.
     5            ABS (PAR(106) - PAR(148)) > 0.1) THEN
C * TEMPORARY TEST
                IF (SPGRNM(2)(12:12) /= 'o' .AND.
     1              SPGRNM(2)(12:12) /= 'a') THEN
C * ALERT _158
                  CALL PLA236 (158, 0, -999.0, 1.0, ' ', ' ')
                  WRITE (PRBUF, 99983, IOSTAT = IOST)
                  IF (IWIN == 1) THEN
                    VRT = VRT - 0.9
                    CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                  END IF
                  WRITE (LU, 99972, IOSTAT = IOST) PRBUF(1:60)
                END IF
              END IF
              IF (SPGRNM(1)(1:1) == ' ') THEN
                NSP = 2
              ELSE
                NSP = 1
              END IF
              WRITE (LU, 99984, IOSTAT = IOST) SPGRNM(NSP)(1:11)
              IF (IWIN == 1) THEN
                IF (ABS (ORG(1)) + ABS (ORG(2)) + ABS (ORG(3)) .GT.
     1              0.001) THEN
                  WRITE (PRBUF, 99988, IOSTAT = IOST)
     1              ORG(1), ORG(2), ORG(3)
                  VRT = VRT - 0.7
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                END IF
                VRT = VRT - 0.9
                IF (NSGTR == 0) THEN
                  WRITE (PRBUF, 99963, IOSTAT = IOST) SPGRNM(NSP)(1:11)
                  NCOL = 3
                ELSE
                  WRITE (PRBUF, 99971, IOSTAT = IOST) SPGRNM(NSP)(1:11)
                  NCOL = 2
                END IF
                CALL PLA439 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1.0,
     1                       VRT)
              END IF
            ELSE
              IF (INDEX (SPGRNM(2), '?') /= 0) THEN
                IF (LOOPR < 3) THEN
                  JERR = JERR + 1000
                  RETURN
                END IF
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.9
                  WRITE (PRBUF, 99973, IOSTAT = IOST)
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                END IF
                WRITE (LU, 99972, IOSTAT = IOST) PRBUF
C * ALERT _114
                CALL PLA236 (114, 0, 1.0, 1.0, ' ', ' ')
              END IF
            END IF
          END IF
        END IF
        IF (DDIS > 0.0001) WRITE (LU, 99967, IOSTAT = IOST) DDIS
        IF (DANG > 0.001)  WRITE (LU, 99966, IOSTAT = IOST) DANG
      END DO
C * REPORT (NEW) SPGR (ZSPG = INPUT, SPGRNM(2)(1:7) = NEW
      IF ((ZSPG /= SPGRNM(2)(1:7) .AND.
     1     SPGRNM(2)(1:1) /= '?') .OR. NLCLP /= 1) THEN
C * REPORT ON CONVENTIONAL SYMMETRY
        WRITE (LU6, 99975, IOSTAT = IOST)
        IF (IGBL(63) > 0) THEN
          CALL PLA262 (-4)
 
          WRITE (LU7, 99975, IOSTAT = IOST)
        END IF
        CALL SGSM (2, ICL, FN, 0, LU6, IERR)
        IF (IGBL(63) > 0) CALL SGSM (2, ICL, FN, 0, LU7, IERR)
        IF (IPR(209) == 0 .AND. IPR(118) == 0 .AND.
     1      IPR(459) == 0) THEN
C * CHECK FOR CSD-CIF
          IF (IGBL(94) == 0) THEN
            IF (SPGRNM(2)(3:7) == '     ') THEN
              ZSPG3 = '       '//SPGRNM(2)(1:2)
            ELSE IF (SPGRNM(2)(4:7) == '    ') THEN
              ZSPG3 = '      '//SPGRNM(2)(1:3)
            ELSE IF (SPGRNM(2)(5:7) == '   ') THEN
              ZSPG3 = '     '//SPGRNM(2)(1:4)
            ELSE IF (SPGRNM(2)(6:7) == '  ') THEN
              ZSPG3 = '    '//SPGRNM(2)(1:5)
            ELSE IF (SPGRNM(2)(7:7) == ' ') THEN
              ZSPG3 = '   '//SPGRNM(2)(1:6)
            ELSE
              ZSPG3 = '  '//SPGRNM(2)(1:7)
            END IF
            IF (ZSPG(1:7) == 'P21/n  ') THEN
              ZSPG2 = '    '//ZSPG(1:5)
            ELSE IF (ZSPG(1:7) == 'I2/n   ') THEN
              ZSPG2 = '     '//ZSPG(1:4)
            ELSE IF (ZSPG(1:7) == 'C2/m   ') THEN
              ZSPG2 = '     '//ZSPG(1:4)
            ELSE IF (ZSPG(1:7) == 'C2/c   ') THEN
              ZSPG2 = '     '//ZSPG(1:4)
            ELSE
              ZSPG2 = '  '//ZSPG
            END IF
C * ALERT _128
            CALL PLA236 (128, 0, -999.0, 1.0, ZSPG2, ZSPG3)
          END IF
          WRITE (PRBUF, 99989, IOSTAT = IOST) ZSPG, SPGRNM(2)(1:7)
          WRITE (LU6, 99961, IOSTAT = IOST) PRBUF(1:80)
          IF (IWIN == 1) THEN
            VRT = VRT - 0.8
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT)
          END IF
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99961, IOSTAT = IOST) PRBUF(1:80)
          END IF
        END IF
      END IF
C * REPORT ON HIGHER STRUCTURE SYMMETRY
      DO JPRLP = 1, JMAX
        IF (JPRLP == 2) THEN
          LU = LU7
        ELSE
          LU = LU6
        END IF
        IF (IMETRIC > 0) THEN
          IF (JPRLP == 2) CALL PLA262 (2)
          WRITE (LU, 99979, IOSTAT = IOST)
        END IF
 
C * CHECK FOR ADDITIONAL SYMMETRY ELEMENTS(EXCLUDING INVERSION)
        IF (IPR(209) == 0) THEN
C * TEST FOR PSEUDO-SYMMETRY, ADDITIONAL TRANSL.SYMM
          IF (IPR(118) == 0 .AND. IPR(459) == 0
     1      .AND. NSGTR == 0) THEN
            IF (JPRLP == 1) THEN
              CALL PLA015 (0, 5)
            ELSE IF (JPRLP == 2) THEN
              CALL PLA262 (3)
              WRITE (LU, 99985, IOSTAT = IOST)
              IF (IPR(207) /= 0) THEN
                CALL PLA262 (1)
                WRITE (LU, 99970, IOSTAT = IOST)
              END IF
            END IF
          ELSE
C * REPORT POSSIBLE PSEUDO TRANSLATION TO BE CHECKED
            IF (IPR(459) /= 0) THEN
              WRITE (PRBUF, 99977, IOSTAT = IOST)
              IF (JPRLP == 1) THEN
                IF (IWIN == 1) THEN
                  VRT = VRT - 1.0
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                END IF
              END IF
              IF (JPRLP == 2) CALL PLA262 (1)
              WRITE (LU, 99974, IOSTAT = IOST) PRBUF
            END IF
C * REPORT POSSIBLE PSEUDO INVERSION TO BE CHECKED
            IF (IPR(118) /= 0) THEN
              WRITE (PRBUF, 99978, IOSTAT = IOST)
              IF (JPRLP == 1) THEN
                IF (IWIN == 1) THEN
                  VRT = VRT - 1.0
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                END IF
              END IF
              IF (JPRLP == 2) CALL PLA262 (1)
              WRITE (LU, 99974, IOSTAT = IOST) PRBUF
              CALL PLA262 (1)
              WRITE (LU, 99976, IOSTAT = IOST)
            END IF
          END IF
        ELSE
          IF (JPRLP == 2) CALL PLA262 (12)
          WRITE (LU, 99965, IOSTAT = IOST) ORG(1), ORG(2), ORG(3),
     1          ((DUMMY(I, J), J = 1, 3), -ORG(I), I = 1, 3)
          IF (IGBL(45) > 0) IGBL(45) = - 1
          NNNFIT = MIN (NNNFIT, NFT)
          WRITE (LU, 99999, IOSTAT = IOST)
          IF (SPGRNM(1)(1:11) /= SPGRNM(2)(1:11) .OR.
     1      XSUB == 'S') THEN
            IF (SPGRNM(2)(1:11) /= '?' .OR. NNNFIT == 100) THEN
              IF (JPRLP == 2) CALL PLA262 (3)
            LAT1 = LAT0
            IF (LAT1 == 5) LAT1 = 6
            WRITE (LU, 99959, IOSTAT = IOST)
     1        JID(1:9), JID(18:27), SPGRNM(1)(12:13), IBVL(LAT1), LATT,
     2        FLOAT (IPR(260)) / IPR(48), DDIS, DANG, PAR(291),
     3        PAR(98) / PAR(100), XSUB, NNNFIT, SPGRNM(2)(1:11),
     4        CHAR (IPR(223))
          END IF
C * ALERT _113 - REPORT NEW SPACE GROUP
          IF (SPGRNM(2)(1:11) /= '?' .AND.
     1        SPGRNM(2)(1:11) /= ' ') THEN
C * TEST FOR ORGANIC/INORGANIC
 
            YUNK = FLOAT (NNNFIT)
            IF (NNNFIT == 100 .AND. IPR(773) == 0) THEN
              YUNK = 100.0
            ELSE
              YUNK = -999.0
            END IF
 
            CALL PLA236 (-113, 0, YUNK, FLOAT (NNNFIT),
     1           SPGRNM(2)(1:10), ' ')
            IF (NSKIP > 0) THEN
              CALL PLA236 (0, 0, 0.0, 0.0, '              '//
     1          'WARNING: Disordered Atoms Excluded from Analysis', ' ')
            END IF
            CALL PLA236 (0, 0, 0.0, 0.0, '              '//
     1        'Check Model Parameter Symmetry for '//
     2        'Reflection Data Support', ' ')
            END IF
          END IF
          IF (JPRLP == 1) THEN
            IF (IWIN == 1) THEN
              IF (ABS (ORG(1)) + ABS (ORG(2)) + ABS (ORG(3)) > 0.001)
     1          THEN
                  IF (UNITMAT == 1) THEN
                    WRITE (PRBUF, 99957, IOSTAT = IOST)
     1                ORG(1), ORG(2), ORG(3)
                  ELSE
                    WRITE (PRBUF, 99988, IOSTAT = IOST)
     1                ORG(1), ORG(2), ORG(3)
                  END IF
                VRT = VRT - 0.7
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 1 + NNNDIS, 2, 1.0,
     1            VRT)
              END IF
              IF (SPGRNM(2)(1:11) /= '?') THEN
                VRT = VRT - 0.5
                IF (NNNFIT == 100) THEN
                  WRITE (PRBUF, 99990, IOSTAT = IOST)
     1              SPGRNM(2)(1:11), ISGNR
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 1 + NNNDIS, 2, 1.0,
     1              VRT)
                ELSE
                  WRITE (PRBUF, 99986, IOSTAT = IOST)
     1              SPGRNM(2)(1:11), ISGNR
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 6, 2, 1.0, VRT)
                  WRITE (PRBUF, 99962, IOSTAT = IOST)
                  VRT = VRT - 0.7
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 6, 2, 1.0, VRT)
                END IF
              END IF
            END IF
            CALL PLA015 (0, 6)
          END IF
          IF (ISYST > IPR(259)) THEN
            IF (JPRLP == 2) CALL PLA262 (1)
            WRITE (LU, 99982, IOSTAT = IOST) PAR(291)
          ELSE IF (IPR(259) /= 8) THEN
            IF (MLAUE /= IPR(258)) THEN
              IF (JPRLP == 2) CALL PLA262 (1)
              WRITE (LU, 99981, IOSTAT = IOST) DSMAX
            END IF
          END IF
          IF (INVST == 1) THEN
            IPR(457) = 1
            PAR(291) = MAX (PAR(291), 2.0 * MAX (0.25, DSMAX))
            IF (DSMAX > 0.0) THEN
              IF (JPRLP == 2) CALL PLA262 (1)
              WRITE (LU, 99980, IOSTAT = IOST) DSMAX
            END IF
          END IF
        END IF
      END DO
      RETURN
99999 FORMAT (/, ':: - Symmetry Elements Preceded by an Asterisk are ',
     1        'New and Indicate', /, '::   Missed/Pseudosymmetry.', /,
     2        ':: - Proposed Inversion or (Glide) Planes do NOT Apply',
     3        /, '::   for Chiral Molecules.', /,
     4        ':: - Glide Plane Codes are with Reference ',
     5        'to the Input Cell !!')
99998 FORMAT ('Cell Lattice', 2X, 'a', 7X, 'b', 7X, 'c', 4X,
     1        'Alpha', 3X, 'Beta', 2X, 'Gamma Volume', 1X,
     2        'CrystalSystem Laue')
99997 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('-'))
99996 FORMAT ('(', 3F6.2, ' )   (', 3F6.2, ' )   (', 3F6.2, ' )',
     1         5X, 'Det(T)')
99995 FORMAT ('(', 3F6.2, ' ) X (', 3F6.2, ' ) = (', 3F6.2, ' )',
     1         7X, '=')
99994 FORMAT ('(', 3F6.2, ' )   (', 3F6.2, ' )   (', 3F6.2, ' )',
     1         F10.3)
99993 FORMAT ('Input   ',  A,  F7.3, 2F8.3, 3F7.2, I7, 1X, A, 1X, A)
99992 FORMAT ('Reduced ',' P', F7.3, 2F8.3, 3F7.2, I7)
99991 FORMAT ('Convent ', 2A,  F7.3, 2F8.3, 3F7.2, I7, 1X, A, 1X, A)
99990 FORMAT ('Missed/Additional Symmetry : Suggested SPGR = ', A,
     1        '(No', I4,')')
99989 FORMAT (':: Input ', A, ' Non-Standard Setting is ',
     1        'Alternate for Standard ', A, ' Setting')
99988 FORMAT (':: Origin Shifted to:', F6.3, ',', F6.3, ',', F6.3,
     1        ' after Cell Transformation')
99987 FORMAT ('  Reduced-to-Convent', 7X, 'Input-to-Reduced', 5X,
     3          'T = Input-to-Convent:   a'' = T a')
99986 FORMAT ('Missed/Additional Symmetry (Ignore NonFit):',
     1        ' Suggested SPGR = ', A, '(No', I4,')')
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 (':: Input Cell is not Standard/Reduced')
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 (/, ':: Lattice Features Additional Metrical Symmetry ',
     1           'not Supported by Contents.')
99978 FORMAT (':: Check for (Approximate/Pseudo) Inversion Symmetry.')
99977 FORMAT (':: Check for (Approximate/Pseudo) Translat. Symmetry.')
99976 FORMAT ('   See e.g. R.E. Marsh, Acta Cryst. (1994). C50,',
     1        ' 1713-1715', /)
99975 FORMAT (/, 10X, 'Conventional, New or Pseudo Symmetry', /,
     1        80('='), /)
99974 FORMAT (A, /)
99973 FORMAT (':: ADDSYM Could Not (Re)Construct Proper Spacegroup')
99972 FORMAT (/, A)
99971 FORMAT (':: Spacegroup: ', A, ' Not Changed but Check ',
     1        'Pseudo-Translations')
99970 FORMAT (':: Note: Rerun in EQUAL Atom Type Mode for more Checks')
99969 FORMAT (1X)
99968 FORMAT ('SPGR ' , A, 68X)
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 (80('-'))
99963 FORMAT (':: SpaceGroup = ', A,
     1        ' - No Obvious Spacegroup Change Needed/Suggested')
99962 FORMAT (' *** PLEASE COMPARE with ''CALC ADDSYM EXACT'' ')
 
99961 FORMAT (/, A, /)
99960 FORMAT (A)
99959 FORMAT (/, 'P! ', 2A, 1X, A, '=>', 2A, F4.1, F6.3, F5.2,
     1        F6.3, F5.2, 1X,  A, I4, '% ', A, /, A, //,
     2        ':: An SPF-style file is written',
     3        ' to be used for the cell transformation.', /)
99958 FORMAT ('LATT ', A, 1X, A, 72X)
99957 FORMAT (':: Origin Shifted to:', F6.3, ',', F6.3, ',', F6.3)
      END SUBROUTINE PLA062
 
      SUBROUTINE PLA063
C * FIND CONVENTIONAL ORIGIN
      USE parameters
      USE addsym
      IMPLICIT NONE
      NORG = NORG + 1
      IF (NORG /= 0) THEN
C * ACENTRIC CASE
        IF (CENT == 'A') THEN
          OSHFT(3) = OSHFT(3) + OADD(3)
          IF (OSHFT(3) > 0.99) THEN
            OSHFT(3) = 0.0
            OSHFT(2) = OSHFT(2) + OADD(2)
            IF (OSHFT(2) > 0.99) THEN
              OSHFT(2) = 0.0
              OSHFT(1) = OSHFT(1) + OADD(1)
            END IF
          END IF
          IF (OSHFT(1) < 1.0) NORGM = NORG + 1
C * CENTRIC CASE
        ELSE
          IF (LATT == 'P') THEN
            NORGM = 3
            CALL GEN074 (OSHFT, 1, 3, 0.0)
            OSHFT(NORG) = 0.50
          ELSE IF (LATT == 'A') THEN
            OSHFT(2) = 0.25
            OSHFT(3) = 0.25
            NORGM    = 1
          ELSE IF (LATT == 'B') THEN
            OSHFT(1) = 0.25
            OSHFT(3) = 0.25
            NORGM    = 1
          ELSE IF (LATT == 'C') THEN
            OSHFT(1) = 0.25
            OSHFT(2) = 0.25
            NORGM    = 1
          ELSE IF (LATT == 'F') THEN
            NORGM = 3
            CALL GEN074 (OSHFT, 1, 3, 0.25)
            OSHFT(NORG) = 0.00
          ELSE IF (LATT == 'I') THEN
            NORGM = 7
            IF (NORG == 1) THEN
              CALL GEN074 (OSHFT, 1, 3, 0.25)
            ELSE IF (NORG >= 2 .AND. NORG <= 4) THEN
C * I41/a (43 --> 41)
              CALL GEN074 (OSHFT, 1, 3, 0.0)
              OSHFT(NORG - 1) = 0.50
            ELSE IF (NORG >= 5 .AND. NORG <= 7) THEN
              CALL GEN074 (OSHFT, 1, 3, 0.25)
              OSHFT(NORG - 4) = 0.75
            END IF
          ELSE IF (LATT == 'R') THEN
            IF (NORG == 1) THEN
              OSHFT(1) = 0.33333
              OSHFT(2) = 0.16667
              OSHFT(3) = 0.16667
              NORGM    = 2
            ELSE
              OSHFT(1) = 0.16667
              OSHFT(2) = 0.33333
              OSHFT(3) = 0.33333
            END IF
          END IF
        END IF
      ELSE
        CALL GEN074 (OSHFT, 1, 3, 0.0)
      END IF
      RETURN
      END SUBROUTINE PLA063
 
      SUBROUTINE PLA064 (NLT, NBRAV, NLTX)
C * ADDSYM-NEWLAT SUPPORT - FIND TRANSFORMATION TO SUBLATTICE
      USE parameters
      USE plato
      USE addsym
      USE latice
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: M
      INTEGER                :: N
      INTEGER                :: IS
      INTEGER                :: NLT
      INTEGER                :: NLTX
      INTEGER                :: NBRAV
      REAL                   :: DET
      REAL                   :: DETMIN
      REAL, DIMENSION(3, 20) :: A
      REAL, DIMENSION(3, 3)  :: B
      REAL, DIMENSION(3, 3)  :: C
C * NLT    - NUMBER OF LATTICE POINTS                   (INPUT)
C * NBRAV  - BRAVAIS LATTICE NUMBER                     (INPUT)
C * NLTX   - TRANSFORMATION MATRIX TO PRIMITIVE LATTICE (OUTPUT)
C * NEWLAT - ARRAY WITH (NEW) LATTICE POINTS
      IF (NLT <= NP47 - 3) THEN
C * SORT
C * UNPACK TRANSLATION CODES
        DO I = 1, NLT
          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 J = 1, 3
            IF (NA(J) <= 6) THEN
              A(J, I) = FRACT(NA(J))
            ELSE
              A(J, I) = FRACT(NA(J)) - 1.0
            END IF
          END DO
        END DO
        L = NLT
C * ADD BRAVAIS LATTICE
        DO I = 1, 3
          L = L + 1
          DO J = 1, 3
            A(J, L) = TRNSX(I, J, NBRAV)
          END DO
        END DO
C * FIND 3 THREE VECTORS THAT SPAN A LATTICE WITH SMALLEST DETERMINANT
        DETMIN = 1.0
        DO I = 1, L - 2
          DO N = 1, 3
            B(1, N) = A(N, I)
          END DO
          DO J = I + 1, L - 1
            DO N = 1, 3
              B(2, N) = A(N, J)
            END DO
            DO K = J + 1, L
              DO N = 1, 3
                B(3, N) = A(N, K)
              END DO
              CALL GEN003 (B, C, DET, 0)
              IF (DET /= 0.0) THEN
                IF (ABS (DET) < DETMIN) THEN
                  DETMIN = ABS (DET)
                  NLTX = 128
                  DO N = 1, 3
                    IF (N == 1 .AND. DET < 0.0) THEN
                      IS = -1
                    ELSE
                      IS = 1
                    END IF
                    DO M = 1, 3
                      TRNSX(N, M, NLTX) = B(N, M) * IS
                    END DO
                  END DO
                END IF
              END IF
            END DO
          END DO
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA064
 
      SUBROUTINE PLA065
C * HANDLE LATTICE TRANSLATION FOR ADDSYM
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE addsym
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: NCOL
      INTEGER :: NLCP
      INTEGER :: NLCP1
      REAL    :: YUNK
      DO I = 1, 3
        GLIDE(I) = MOD (GLIDE(I), 1.0)
        IF (GLIDE(I) < -0.05) GLIDE(I) = GLIDE(I) + 1.0
        YUNK  = 99.0
        NA(I) = -1
        DO J = 1, 10
          IF (ABS (GLIDE(I) - FRACT(J)) < YUNK) THEN
            YUNK   = ABS (GLIDE(I) - FRACT(J))
            NA(I) = J
          END IF
        END DO
      END DO
      IF (NA(1) == 10) NA(1) = 1
      NLCP  = NA(1) * 10000 + NA(2) * 100 + NA(3)
      NLCP1 = MAX (1, MOD (12 - NA(1), 11)) * 10000 +
     1        MAX (1, MOD (12 - NA(2), 11)) * 100   +
     2        MAX (1, MOD (12 - NA(3), 11))
      IF (NEWLT > 0) THEN
        DO J = 1, NEWLT
          IF (NEWLAT(J) == NLCP .OR. NEWLAT(J) == NLCP1) RETURN
        END DO
      END IF
      IF (NLCP == 10101) THEN
        FSYM = ' P '
      ELSE
C * A TYPE LATTICE CENTERING
        IF (NLCP == 10606) THEN
          FSYM = ' A '
C * B TYPE LATTICE CENTERING
        ELSE IF (NLCP == 60106) THEN
          FSYM = ' B '
C * C TYPE LATTICE CENTERING
        ELSE IF (NLCP == 60601) THEN
          FSYM = ' C '
C * I TYPE LATTICE CENTERING
        ELSE IF (NLCP == 60606) THEN
          FSYM = ' I '
C * R(obv) on HEXAGONAL AXES TYPE LATTICE CENTERING
        ELSE IF (NLCP == 40808) THEN
          FSYM = ' R '
C * A-AXIS HALVING
        ELSE IF (NLCP == 60101) THEN
          FSYM = 'a/2'
C * B-AXIS HALVING
        ELSE IF (NLCP == 10601) THEN
          FSYM = 'b/2'
C * C-AXIS HALVING
        ELSE IF (NLCP == 10106) THEN
          FSYM = 'c/2'
C * 1/3 A-AXIS
        ELSE IF (NLCP == 40101) THEN
          FSYM = 'a/3'
C * 1/3 B-AXIS
        ELSE IF (NLCP == 10401) THEN
          FSYM = 'b/3'
C * 1/3 C-AXIS
        ELSE IF (NLCP == 10104) THEN
          FSYM = 'c/3'
C * OTHER TYPE LATTICE TRANSLATION
        ELSE
          IF (NA(1) <= 6 .AND. NA(2) <= 6 .AND. NA(3) <= 6) THEN
            FSYM = CHAR(48 + NA(1))//CHAR(48 + NA(2))//CHAR(48 + NA(3))
          ELSE
            FSYM = 'sub'
            NAL112S = NAL112S + 1
          END IF
        END IF
        NSGTR = 1
        IF (NFTX > 0) THEN
          WRITE (LU6, 99998, IOSTAT = IOST)
          WRITE (LU6, 99996, IOSTAT = IOST) LINE(1:75)
          WRITE (LU6, 99995, IOSTAT = IOST)
          WRITE (LU6, 99995, IOSTAT = IOST)
C * CHECK PRINTLEVEL
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (4)
            WRITE (LU7, 99998, IOSTAT = IOST)
            WRITE (LU7, 99996, IOSTAT = IOST) LINE(1:75)
            WRITE (LU7, 99995, IOSTAT = IOST)
          END IF
        END IF
        IF (FSYM /= 'sub') THEN
C * ALERT _112 - Additional (Pseudo) Symmetry Element Found
C * TEST FOR ORGANIC/INORGANIC
          IF (IPR(325) >= 0 .AND. IPR(773) == 0) THEN
            CALL PLA236 (112, 0, FLOAT (NNFIT),
     1        FLOAT (NNFIT), FSYM, ' ')
          ELSE
            CALL PLA236 (112, 0, -999.0,
     1        FLOAT (NNFIT), FSYM, ' ')
          END IF
        ELSE IF (NAL112S == 1) THEN
          CALL PLA236 (112, 0, -999.0,
     1      FLOAT (NNFIT), FSYM, ' ')
        END IF
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    FSYM, NNFIT, DSMAX, GLIDE
        CALL GEN065 (0, PRBUF, 1, 81, 7)
        WRITE (LU6, 99996, IOSTAT = IOST) PRBUF(1:80)
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99996, IOSTAT = IOST) PRBUF(1:80)
        END IF
        IF (IWIN == 1) THEN
          VRT = VRT - 0.5
          IF (NNFIT == 100) THEN
            NCOL = 2
          ELSE
            NCOL = 6
          END IF
          CALL PLA439 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1.0, VRT)
        END IF
        WRITE (PRBUF, 99997, IOSTAT = IOST)
     1    NQ3(1:6), NQ4(1:6), DSMAX
        CALL GEN065 (0, PRBUF, 1, 81, 7)
        WRITE (LU6, 99996, IOSTAT = IOST) PRBUF(1:80)
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99996, IOSTAT = IOST) PRBUF(1:80)
        END IF
        IF (IWIN == 1) THEN
          VRT = VRT - 0.5
          CALL PLA439 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1.0, VRT)
        END IF
        IF (NLCLP == 1 .AND. FSYM /= 'sub') THEN
          IF (NNFIT >= (100 - IPR(568) * NINT (PAR(407)))) THEN
            NAL110 = NAL110 + 1
C * ALERT _110 - Report Potential Lattice Centering or Halving
            IF (NAL110 == 1) THEN
C * TEST FOR ORGANIC/INORGANIC
              IF (IPR(325) >= 0) THEN
                CALL PLA236 (110, 0, 1.0, 1.0, ' ', ' ')
              ELSE
                CALL PLA236 (110, 0, -999.0, 1.0, ' ', ' ')
              END IF
            END IF
C * CHECK FOR 'NO-SUBCELL MODE
            IF (IPR(503) == 0) THEN
C * IGBL(3) =  1 - VALIDATION RUN
C *         =  4 - ADDSYM
C *         = 16 - ADDSYM SHELX
              IF (((IGBL(3) == 1 .OR. IGBL(3) == 4 .OR. IGBL(3) == 16)
     1          .AND. NNFIT == 100) .OR. (IGBL(3) == 0)) THEN
                NEWLT         = NEWLT + 1
                NEWLAT(NEWLT) = NLCP
                IPR(209)      = 1
                IPR(459)      = 1
                NNFIT         = 100
              END IF
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (A, '*', 3X,  '(NonSpacegroup) Translation', 8X, I3,
     1        F8.3, 9X, 3F6.3)
99998 FORMAT (/, ':: NonFits (i.e. Atoms with no symmetry related',
     1           ' counterpart):')
99997 FORMAT (36X, 2A, F5.3)
99996 FORMAT (A)
99995 FORMAT (1X)
      END SUBROUTINE PLA065
 
      SUBROUTINE PLA066 (MODE, MOLX, NATHX, NATHY, X1, X2, X3, X4, DIST)
C * SHORT INTERMOLECULAR CONTACT SUMMARY
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: K
      INTEGER             :: L
      INTEGER             :: N
      INTEGER             :: I1
      INTEGER             :: J1
      INTEGER             :: K1
      INTEGER             :: L1
      INTEGER             :: L2
      INTEGER             :: L3
      INTEGER             :: L4
      INTEGER             :: M1
      INTEGER             :: M2
      INTEGER             :: M3
      INTEGER             :: M4
      INTEGER             :: ML
      INTEGER             :: NI
      INTEGER             :: NRES
      INTEGER             :: MRES
      INTEGER             :: NSML
      INTEGER             :: IDUM
      INTEGER             :: IENI
      INTEGER             :: IENJ
      INTEGER             :: IENK
      INTEGER             :: IENL
      INTEGER             :: ISML
      INTEGER             :: MODE
      INTEGER             :: MOLX
      INTEGER             :: NSMLX
      INTEGER             :: NSMOL
      INTEGER             :: MLRES
      INTEGER             :: LABN1
      INTEGER             :: LABN2
      INTEGER             :: LABN3
      INTEGER             :: LABN4
      INTEGER             :: NATHX
      INTEGER             :: NATHY
      REAL                :: X1
      REAL                :: X2
      REAL                :: X3
      REAL                :: X4
      REAL                :: DEL
      REAL                :: DIJ
      REAL                :: DIST
      REAL                :: RMOL
      REAL                :: VMOL
      REAL                :: XMOLX
      REAL                :: YMOLX
      REAL                :: SUMRAD
      CHARACTER(len=2)    :: MARK
      CHARACTER(len=1)    :: IDS1
      CHARACTER(len=1)    :: IDS2
      CHARACTER(len=81)   :: FORMI
      REAL,DIMENSION(12)  :: ZMOLX
      REAL, DIMENSION(51) :: AMOLX
      FORMI( 1:43) = '(I4,'' ['',F9.2,'']'',I8,F11.4,F7.2,4X,I1,1X,A,'
      FORMI(44:81) = '''-'',2A,''... '',2A,''-'',A,I2,3X,A,4F10.2)'
      IF (PAR(42) < 100.0) THEN
        FORMI(13:13) = '1'
        FORMI(80:80) = '1'
      END IF
      N = IPR(49)
C * INIT MODE
      IF (MODE == 0) THEN
        IPR(49) = 0
C * LIST MODE
      ELSE IF (MODE < 0) THEN
        IF (N > 0 .AND. IPR(149) <= 0) THEN
          NSMOL  = IPR(51)
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (8)
            WRITE (LU7, 99999, IOSTAT = IOST) PAR(3), IPR(104)
          END IF
C * LOOP OVER ARU'S IN THIS RESIDUE
          NI = 0
          DO K = 1, NSMOL
            ML = MOL(K)
            CALL GEN098 (ML, PAR(42), M1, M2, M3, M4, NRES)
            IF (NRES == 0) THEN
              NRES = IPR(104)
              ML = ML + NRES
            END IF
            IF (NRES == IPR(104)) THEN
              RMOL = ML / PAR(42)
              DO 10 I = 1, N
                LABN1 = NINT (ABS (BOK(I, 2)))
                LABN2 = NINT (ABS (BOK(I, 3)))
                LABN3 = NINT (ABS (BOK(I, 4)))
                LABN4 = NINT (ABS (BOK(I, 5)))
                MARK  = '  '
                DIJ   = MOD (BOK(I, 1), 100.0)
                ISML  = INT (BOK(I, 1) / 100.0)
                IF (ISML > 0) MARK = ' <'
                IF (ISML > 1) MARK = '<<'
C * GET RESIDUE NUMBER OF CONTACT ARU
                CALL GEN098 (KBO(I, 1), PAR(42), M1, M2, M3, M4, MRES)
                VMOL = KBO(I, 1) / PAR(42)
                CALL PLA270 (RMOL, VMOL, XMOLX)
                IF (IPR(2) /= 0) GO TO 30
                ZMOLX(1) = XMOLX
                IF (BOK(I, 2) < 0) THEN
                  IDS1 = '*'
                ELSE
                  IDS1 = ' '
                END IF
                IF (BOK(I, 3) < 0) THEN
                  IDS2 = '*'
                ELSE
                  IDS2 = ' '
                END IF
                NQ1 = '       '
                NQ2 = '       '
                NQ3 = '       '
                NQ4 = '       '
                LABN1 = - LABA(LABN1)
                CALL PLA047 (LABN1, NQ1, IDUM, IENI, IPR(71),
     1                       IGBL(55), 0, 1 - IGBL(55))
                LABN2 = - LABA(LABN2)
                CALL PLA047 (LABN2, NQ2, IDUM, IENJ, IPR(71),
     1                       IGBL(55), 0, 1 - IGBL(55))
                IF (LABN3 > 0) THEN
                  LABN3 = - LABA(LABN3)
                  CALL PLA047 (LABN3, NQ3, IDUM, IENK, IPR(71),
     1                         IGBL(55), 0, 1 - IGBL(55))
                END IF
                IF (LABN4 > 0) THEN
                  LABN4 = - LABA(LABN4)
                  CALL PLA047 (LABN4, NQ4, IDUM, IENL, IPR(71),
     1                         IGBL(55), 0, 1 - IGBL(55))
                END IF
                SUMRAD = ABS (VDWR(IENI)) + ABS (VDWR(IENJ))
                DEL    = DIJ - SUMRAD
C * HANDLE CASE WHERE MOLECULES OF MORE THAN ONE ARU
                NSML   = 1
                IF (NSMOL > 1) THEN
                  DO L = 2, NSMOL
                    ML = MOL(L)
                    CALL GEN098 (ML, PAR(42), L1, L2, L3, L4, MLRES)
                    IF (IPR(2) /= 0) GO TO 30
                    IF (MLRES == MRES .AND. NSML < 6) THEN
                      YMOLX = ML / PAR(42)
                      CALL PLA270 (XMOLX, YMOLX, ZMOLX(NSML + 1))
                      IF (IPR(2) == 52) GO TO 30
                      IF (IPR(2) == 28) THEN
                        IPR(2) = 0
                      ELSE
                        NSML = NSML + 1
                      END IF
                    END IF
                  END DO
                END IF
C * BUBBLE_SORT ZMOLX
                IF (NSML > 1) THEN
                  DO I1 = 1, NSML
                    K1 = NSML + 1
                    DO J1 = I1 + 1, NSML
                      K1 =  K1 - 1
                      IF (ZMOLX(K1) < ZMOLX(K1 - 1))
     1                  CALL GEN018 (ZMOLX(K1), ZMOLX(K1 - 1))
                    END DO
                  END DO
                END IF
                AMOLX(NI + 1) = ZMOLX(1)
                IF (NI > 0) THEN
                  DO I1 = 1, NI
                    IF (AMOLX(I1) == ZMOLX(1)) GO TO 10
                  END DO
                END IF
                IF (NI < 50) NI = NI + 1
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (1)
                  NSMLX = MIN (NSML, 4)
                  WRITE (LU7, FORMI, IOSTAT = IOST)
     1              NI, XMOLX, KBO(I, 2), DIJ, DEL, KBO(I, 3), NQ3(1:7),
     2              IDS1, NQ1(1:7), IDS2, NQ2(1:7), NQ4(1:7),
     3              KBO(I, 4), MARK, (ZMOLX(L), L = 1, NSMLX)
                  IF (NSML > 4) THEN
                    CALL PLA262 (1)
                    NSMLX = MIN (NSML, 8)
                    WRITE (LU7, 99998) (ZMOLX(L), L = 5, NSMLX)
                  END IF
                END IF
   10         CONTINUE
            END IF
          END DO
          IPR(49) = 0
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (4)
            WRITE (LU7, 99997, IOSTAT = IOST) PAR(3)
          END IF
        END IF
C * ACCUMULATE MODE
      ELSE
        IF (N > 0) THEN
          DO I = 1, N
            IF (KBO(I, 1) == MOLX) THEN
              KBO(I, 2) = KBO(I, 2) + 1
              IF (MOD (DIST, 100.0) > MOD (BOK(I, 1), 100.0)) THEN
                GO TO 30
              ELSE
                GO TO 20
              END IF
            END IF
          END DO
        END IF
        I = N + 1
C * OVERFLOW HANDLING
        IF (I > NP8) THEN
          IPR(149) = IPR(149) + 1
          GO TO 30
        END IF
        KBO(I, 1) = MOLX
        KBO(I, 2) = 1
        IPR(49)   = IPR(49) + 1
   20   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
      END IF
   30 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('-'))
99998 FORMAT (91X, 4F10.2)
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 PLA066
 
      SUBROUTINE PLA067
C * SETUP OF CONNECTED SETS, INTER AND COORDN. SCANS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: L2
      INTEGER :: ML
      INTEGER :: NAT
      INTEGER :: IAT
      INTEGER :: ICG
      INTEGER :: IPP
      INTEGER :: IVL
      INTEGER :: KAT
      INTEGER :: MOL0
      INTEGER :: MOL1
      INTEGER :: MOL2
      INTEGER :: MOL3
      INTEGER :: MOL4
      INTEGER :: MNAT
      INTEGER :: KAT1
      INTEGER :: IDUM
      INTEGER :: JDUM
      INTEGER :: ICG1
      INTEGER :: INXT
      INTEGER :: IVAL
      INTEGER :: NNAT
      INTEGER :: NSYM
      INTEGER :: NCONS
      INTEGER :: JJRES
      INTEGER :: IYUNK
      INTEGER :: ITRNS
      INTEGER :: IPART
      INTEGER :: IATHF
      INTEGER :: IATNF
      INTEGER :: IATPRI
      INTEGER :: IATPRP
      INTEGER :: IATINC
      REAL    :: YM1
      REAL    :: YM2
      REAL    :: YM3
      REAL    :: YMM1
      REAL    :: DUM1
      REAL    :: DUM4
      REAL    :: DUM5
C * CONNECTIVITY: THERE ARE THREE DIFFERENT EXECUTION PATHS THROUGH THIS ROUTINE
C * IPR(17) =  0   - CALC INTRA (UNIQUE MOLECULE(S) - SEARCH)
C *         = -1   - CALC INTER (INTERMOLECULAR CONTACT SEARCH) & VOID
C *         =  1   - COORDINATION CALCULATION & METAL-METAL SCAN
C * POPULATION PARAMETER (IPR(92)) OVERFLOW CHECK
      IF (IPR(92) == 0) THEN
C * (RE)SET TO NO DISPLAY GRAPHICS
        IWIN = 0
C * CHECK WAVELENGTH VALUE
        CALL PLA293 (PAR(17))
C * EXECUTE INIT AND (IN/EXCLUDE) OPERATIONS
        CALL PLA087
C * SKIP THE FOLLOWING IN CASE OF ERROR IN PLA087
        IF (IPR(2) == 0) THEN
C * GET NUMBER OF SYMMETRY OPERATIONS
          NSYM = IPR(48)
C * GET NUMBER OF UNIQUE ATOMS ON INPUT
          NAT  = IPR(37)
C * INTRA MODE INITIALIZATION
          IF (IPR(17) == 0) THEN
            CALL PLA384
C * HANDLE SEVERE PART -n  DISORDER
            IF (FLOAT(IPR(696)) / FLOAT(IPR(37)) > 0.8) THEN
              IPR(697)  = 1
C * NO EXPAND
              IGBL(136) = 1
              IPR(129)  = 1
              IGBL(30)  = 1
            END IF
            PAGET = 'INTRA'
C * KEEP TRACK (TOP DOWN) OF 'FIXED AND READY' ATOMS
            NNAT = 1
C * INITIALIZE CG-ARRAY OF RESIDUES (USED TO BRING THEM WITHIN RANGE 0-1)
            CALL GEN074 (RCG, 1, NP29 * 4, 0.0)
C * NON-INTRA MODE
          ELSE
            NNAT = 0
          END IF
   10     IAT    = 0
          IATNF  = 0
          IATHF  = 0
          IATINC = 0
C * BRANCH FOR INTRA (0), INTER/VOID (-1) OR COORDINATION CALCULATIONS (1)
C * INTRA (UNIQUE) MODE: FIND CONNECTED SETS OF ATOMS (RESIDUES)
C * ATOMS HAVE BEEN ORDERED (PLA087) BASED ON ATOM TYPE AND NUMBER
          IF (IPR(17) == 0) THEN
C * KEEP TRACK OF FIRST NON-FIXED ATOM IN THE LIST (TOP DOWN)
            MNAT = NNAT
C * KEEP TRACK OF POTENTIAL ATOM TO START NEW RESIDUE
            INXT = 0
C * FIND NEXT ATOM "IAT" FOR CONNECTIVITY CALCULATION
            DO N = MNAT, NAT
C * GET DONE(BIT1), FIX(BIT2) AND NEXT(BIT3) FLAGS
              CALL GEN048 (-3, IFG(1, N), 1, IVAL)
C * CYCLE FOR 'DONE' ATOMS
              IF (MOD(IVAL, 2) == 1) CYCLE
C * GET PART #, IF ANY
              CALL GEN048 (-5, IFG(3, N), 14, IPART)
              IPART = IPART - 16
C * GET ATOM/ELEMENT TYPE AND PROPERTY
              CALL GEN048 (-4, IFG(1, N), 15, IYUNK)
              IATPRP = IATPR(IEN(IYUNK + 1))
C * NEXT-BIT3 UP ?
              IF (IVAL > 3) THEN
C * GET SPECIAL FIX BIT VALUE
                CALL GEN048 (-1, IFG(2, N), 9, NCONS)
C * FETCH NON-METAL ATOMS (IATPRP = NEGATIVE) IN PREFERENCE TO MINIMIZE
C * THE PROBLEM OF 'SYMMETRY FRAGMENTED' ORGANIC MOIETIES.
                IF (IATPRP < 0) THEN
C * CHECK SPECIAL FIX-BIT
                  IF (NCONS == 1) THEN
                    IAT = N
C * SET NEXT FLAG
                    CALL GEN048 (1, IFG(1, IAT), 3, 1)
C * SPECIAL FIX BIT
                    CALL GEN048 (1, IFG(2, IAT), 9, 1)
                    IATINC = 0
                    GO TO 20
                  ELSE
                    IF (IATNF == 0) IATNF = N
                  END IF
C * METAL ATOM TYPE (IATPRP > 0)
                ELSE
C * CHECK SPECIAL FIX-BIT
                  IF (NCONS == 1) THEN
                    IF (IATHF <= 0) IATHF = N
                  ELSE
                    IF (IATHF == 0) IATHF = - N
                  END IF
                END IF
C * KEEP TRACK OF FIRST NON-FIXED/DONE ATOM IN THE LIST (TOP DOWN)
              ELSE IF (IVAL == 3 .AND. IPART == IPR(661)) THEN
                IF (N == NNAT) NNAT = NNAT + 1
              ELSE
C * NOTICE POTENTIALLY NON-BONDED (AND PREFERABLY NON-METAL) ATOM
C * AS A STARTING POINT OF A NEW RESIDUE
                IF (INXT <= 0) THEN
                  IF (IATPRP < 0) THEN
                    INXT = N
C * GET POPULATION PARAMETER
                    CALL GEN048 (-8, IFG(2, N), 1, IPP)
                    IPR(184) = IPPR(IPP + 1, 1)
                  ELSE
                    IF (INXT == 0) THEN
                      INXT = - N
                    END IF
C * GET POPULATION PARAMETER
                    CALL GEN048 (-8, IFG(2, N), 1, IPP)
                    IPR(184) = IPPR(IPP + 1, 1)
                  END IF
                END IF
              END IF
            END DO
C * BOTTOM OF IAT-ATOM LOOP (INTRA MODE)
            IF (IAT == 0) THEN
              IF (IATHF > 0) THEN
                IAT = IATHF
C * SET NEXT FLAG
                CALL GEN048 (1, IFG(1, IAT), 3, 1)
C * SPECIAL FIX BIT
                CALL GEN048 (1, IFG(2, IAT), 9, 1)
                IATINC = 0
                GO TO 20
              ELSE IF (IATHF < 0) THEN
                IF (IATNF /= 0) THEN
                  IAT = IATNF
                ELSE
                  IAT = - IATHF
                END IF
C * REGISTER NON-CONNECTED SET
                CALL GEN048 (-8, IFG(2, IABS (IAT)), 1, IPP)
                IF (IPPR(IPP + 1, 1) == 10000) THEN
                  IF (IPR(124) == 0) THEN
C * GET ATOM/ELEMENT TYPE AND PROPERTY
                    CALL GEN048 (-4, IFG(1, IABS (IAT)), 15, IVAL)
 
                    IF (IATPR(IEN(IVAL + 1)) /= 5) THEN
                      IPR(124) = 1
                    ELSE
                      IPR(124) = -1
                    END IF
                  END IF
                ELSE
                  IPR(124) = -1
                END IF
C * SET NEXT FLAG
                CALL GEN048 (1, IFG(1, IAT), 3, 1)
C * SPECIAL FIX BIT
                CALL GEN048 (1, IFG(2, IAT), 9, 1)
                IATINC = 0
                GO TO 20
              ELSE
                IF (IATNF /= 0) THEN
                  IAT = IATNF
C * REGISTER NON-CONNECTED SET
                  CALL GEN048 (-8, IFG(2, IAT), 1, IPP)
                  IF (IPPR(IPP + 1, 1) == 10000) THEN
                    IF (IPR(124) == 0) THEN
C * GET ATOM/ELEMENT TYPE AND PROPERTY
                      CALL GEN048 (-4, IFG(1, IABS (IAT)), 15, IVAL)
                      IF (IATPR(IEN(IVAL + 1)) /= 5) THEN
                        IPR(124) = 1
                      ELSE
                        IPR(124) = -1
                      END IF
                    END IF
                  ELSE
                    IPR(124) = -1
                  END IF
C * SET NEXT FLAG
                  CALL GEN048 (1, IFG(1, IAT), 3, 1)
C * SPECIAL FIX BIT
                  CALL GEN048 (1, IFG(2, IAT), 9, 1)
                  IATINC = 0
                  GO TO 20
                END IF
              END IF
C * CALCULATE RESIDUE C.G.
              IF (IPR(75) > 0) THEN
                ICG  = IPR(39) + IPR(24) + 1
                KAT1 = ICG  + 1
                ICG1 = KAT1 + 1
                DO J = 1, 3
                  IF (RCG(4, IPR(75)) /= 0.0)
     1              RCG(J, IPR(75)) = RCG(J, IPR(75)) / RCG(4, IPR(75))
                  XXO(ICG,  J) = RCG(J, IPR(75))
                  XXO(KAT1, J) = PAR(63 + J)
                  XSD(ICG,  J) = 0.0
                  XSD(KAT1, J) = 0.0
                END DO
                IATP(ICG) = 1555
                IF (IGBL(30) == 0) THEN
C * BRING CENTRE OF GRAVITY IN RANGE 0 TO 1
C * (CLOSEST TO PAR(64), PAR(65), PAR(66))
                  DUM5 = 99999.0
C * ORTHOGONALIZE
                  CALL PLA059 (KAT1, KAT1)
                  DO J = 1, NSYM
                    IPR(54) = J
                    DO L = 1, 3
                      ITR(L) = 0
                    END DO
                    CALL PLA059 (ICG, ICG1)
                    DO L = 1, 3
                      DUM1 = MOD (XXO(ICG1, L), 1.0)
                      IF (DUM1 < 0.0) DUM1 = DUM1 + 1.0
                      ITR(L)       = NINT (DUM1 - XXO(ICG1, L))
                      XXO(ICG1, L) = DUM1
                    END DO
C * ORTHOGONALISE
                    CALL PLA059 (ICG1, ICG1)
                    CALL PLA050 (ICG1, KAT1, 0, 0, DUM4)
                    IF (DUM4 < DUM5) THEN
                      DUM5  = DUM4
C * SAVE MINIMUM TRANSFORMATION
                      FN(1) = J
                      DO L = 1, 3
                        FN(L + 1) = ITR(L)
                      END DO
                    END IF
                  END DO
                  YM1  = FN(1) * 1000 + FN(2) * 100.0 + FN(3) * 10.0 +
     1                   FN(4) + 555 + IPR(75) / PAR(42)
                  CALL PLA270 (YM1, 0.0, YMM1)
C * APPLY TRANSFORMATIONS
                  DO I = 1, ICG
                    CALL GEN048 (-6, IFG(1, I), 9, JJRES)
                    IF (IPR(75) == JJRES) THEN
                      ITRNS = NINT (FN(1) * 1000 + 555)
                      DO 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)) > 4) THEN
                          CALL PLA047 (LABA(KAT1), NQ1, IDUM,
     1                      JDUM, 0, IGBL(55), 0, 0)
                          IPR(2) = 17
                          GO TO 30
                        END IF
                        ITRNS = ITRNS + ITR(L) * 10**(3 - L)
                      END DO
                      IF (ITRNS /= 1555) THEN
                        IF (I < ICG) WRITE (LU4) 5, LABA(I),
     1                     (FN(L), L = 1, 8)
                        IPR(54) = NINT (FN(1))
                        CALL PLA059 (KAT1, I)
                      END IF
                      YM2 = IATP(I)
                      CALL PLA270 (YM1, YM2, YM3)
                      IATP(I) = NINT (YM3)
                      CALL GEN048 (1, IFG(1, I), 2, 1)
                    END IF
                  END DO
C * MODIFY ARU [ T R T-1 ]
                  L2 = IPR(13)
                  DO L = 1, L2
                    ML = MOL(L)
                    CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4,
     1                           JJRES)
                    IF (IPR(75) == JJRES) THEN
                      IF (MOL1 > IPR(48)) THEN
                        MOL0 = NINT (IPR(48) * 1000.0 * PAR(42))
                      ELSE
                        MOL0 = 0
                      END IF
                      ML  = ML - MOL0
                      YM3 = ML / PAR(42)
                      CALL PLA270 (YM1, YM3, YM2)
                      CALL PLA270 (YM2, YMM1, YM3)
                      MOL(L) = NINT (YM3 * PAR(42)) + MOL0
                    END IF
                  END DO
                END IF
              END IF
C * BEGIN A NEW RESIDUE ?
              IF (INXT /= 0) THEN
C * NO CONNECTED ATOM IS LEFT TO EXPAND ON, THEREFORE WE BEGIN A NEW RESIDUE
C * SET IAT FOR THE FIRST ATOM IN A NEW RESIDUE
                IAT     = IABS (INXT)
                CALL GEN048 (-5, IFG(3, IAT), 14, IPART)
                IPR(661) = IPART - 16
                IPR(75)  = IPR(75) + 1
C * HANDLE TOO MANY RESIDUE CASE
                IF (IPR(75) > IPR(129)) THEN
                  IPR(75)  = IPR(129)
                  IPR(130) = 1
                END IF
C * SET RESIDUE NUMBER FOR THIS ATOM
                CALL GEN048 (6, IFG(1, IAT), 9, IPR(75))
C * DO TRANS/FIX OPERATION (CALC INTRA MODE)
                CALL PLA071 (IAT)
C * TEST FOR ERROR
                IF (IPR(2) /= 0) THEN
                  CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM,
     1              IPR(71), IGBL(55), 0, 0)
                  GO TO 30
                ELSE
C * STORE TRANSFORMATION OF FIRST ATOM IN RESIDUE
                  IPR(166) = IABS (IATP(IAT))
C * START LOOP ON ATOM IAT
C * SET NEXT FLAG
                  CALL GEN048 (1, IFG(1, IAT), 3, 1)
C * SPECIAL FIX BIT
                  CALL GEN048 (1, IFG(2, IAT), 9, 1)
                  IATINC = 0
                  GO TO 20
                END IF
              ELSE
C * INXT = 0: NO ATOM LEFT TO CONNECT TO
C * EXPAND PRIMARY MOLECULE/ATOM LIST
                CALL PLA072 (IPR(110))
                IF (IPR(2) /= 0) RETURN
C * SAVE PRIMARY ARU LIST
                DO I = 1, IPR(13)
                  MOLS(I) = MOL(I)
                END DO
                IPR(53) = IPR(13)
                GO TO 30
              END IF
            END IF
C * SET NEXT FLAG
            CALL GEN048 (1, IFG(1, IAT), 3, 1)
C * SPECIAL FIX BIT
            CALL GEN048 (1, IFG(2, IAT), 9, 1)
            IATINC = 0
            GO TO 20
C * INTER/VOID MODE
          ELSE IF (IPR(17) < 0) THEN
C * SET SYMM GEN. MOL. LIST TO THE STARTING MOLECULE (X,Y,Z)
            IPR(13) = IPR(51)
C * TEST FOR VOID/SOLV MODE
            IF (IPR(189) /= 0) THEN
              IF (IPR(210) == 0 .OR. IPR(210) == 1) CALL PLA118
              GO TO 30
            END IF
C * COORDINATION MODE
          ELSE IF (IPR(17) > 0) THEN
            IF (IPR(168) > 0) THEN
              IAT    = IPR(168)
              IATINC = 0
              GO TO 20
            ELSE
C * SET SYMM GEN. MOL. LIST TO THE STARTING MOLECULE (X,Y,Z)
              IPR(13) = IPR(51)
              IATINC  = 1
              GO TO 20
            END IF
          END IF
          IATINC = 1
   20     DO
C * ADVANCE IAT TO IAT + 1 IF NOT UNIQUE MODE
            IF (IATINC /= 0) THEN
              IAT = IAT + 1
              IF (IAT > NAT) THEN
                IF (IGBL(144) == 1) THEN
                  IGBL(1) = 4
                  RETURN
                ELSE
                  EXIT
                END IF
              END IF
            END IF
C * GET AND STORE ATOM TYPE NUMBER FOR ATOM IAT
            CALL GEN048 (-4, IFG(1, IAT), 15, IPR(58))
            IPR(509) = IEN(IPR(58) + 1)
C * GET POPULATION PARAMETER NUMBER FOR ATOM IAT
            CALL GEN048 (-8, IFG(2, IAT), 1, IPP)
C * STORE POPULATION PARAMETER FOR IAT
            IPR(128) = IPPR(IPP + 1, 1) * IPPR(IPP + 1, 3) / NSYM
            IPR(119) = IPPR(IPP + 1, 1)
            IF (IPR(119) < 10000) THEN
              IPR(98) = 1 - IPR(502) * IABS (IPR(17))
C * GET PART #, IF ANY
              CALL GEN048 (-5, IFG(3, IAT), 14, IVL)
              IPR(661) = IVL - 16
            ELSE
              IPR(98)  = 0
              IPR(661) = 0
            END IF
C * GET AND STORE RESIDUE NUMBER FOR ATOM IAT
            CALL GEN048 (-6, IFG(1, IAT), 9, IPR(61))
            PAR(19) = RADR(IPR(58) + 1, 2) + PAR(1)
C * BRANCH FOR INTRA(= 0), INTER(= -1) OR COORDN(= 1)
            IF (IPR(17) == 0) THEN
              IATPRI = IATPR(IPR(509))
              CALL PLA041 (IATPRI, 0)
C * CALC INTER CASE
            ELSE IF (IPR(17) < 0) THEN
              IF (IPR(104) /= IPR(61)) THEN
                IATINC = 1
                GO TO 20
              END IF
C * CALC COORDN CASE
            ELSE IF (IPR(17) > 0) THEN
C * TEST FOR SPECIAL SINGLE ATOM COORDINATION CASE
              IF (IPR(168) == 0) THEN
                IF (RADR(IPR(58) + 1, 2) < 0.001) THEN
                  IATINC = 1
                  GO TO 20
                END IF
              ELSE IF (IPR(168) == IAT) THEN
                PAR(19) = PAR(68)
              ELSE
                IATINC = 1
                GO TO 20
              END IF
              IPR(13) = IPR(51)
              IPR(24) = 0
              IPR(79) = 0
            END IF
C * START LOOP OVER JAT-(AND SYMMETRY RELATED) ATOMS
            CALL PLA068 (IAT, KAT)
C * TEST FOR ERROR MESSAGE
            IF (IPR(2) /= 0) GO TO 30
C * END OF LOOP ON ATOMS JAT
C * BRANCH FOR INTER, INTRA OR COORDN CALCULATION
            IF (IPR(17) == 0) THEN
C * CHECK FOR SPECIAL BREAK
              IF (IPR(203) == 0) THEN
C * COLLECT DATA FOR C.G. OF RESIDUE (ASYMMETRIC UNIT)
                DO K = 1, 3
                  RCG(K, IPR(75)) = RCG(K, IPR(75)) + XXO(IAT, K)
                END DO
                RCG(4, IPR(75)) = RCG(4, IPR(75)) + 1
              END IF
              GO TO 10
C * DO COORDINATION CALCULATION FOR ATOM IAT
            ELSE IF (IPR(17) > 0) THEN
C * TEST FOR MOL_LIST OVERFLOW
              IF (IPR(138) == 0) THEN
                IF (IPR(57) /= 2) THEN
C * ANALYSE COORDN GEOMETRY
                  CALL PLA079 (IAT)
                ELSE
C * CALCULATE AND DISPLAY RADIAL DISTRIBUTION FUNCTION
                  CALL PLA144 (1, IAT)
                END IF
              ELSE
                WRITE (LU6, 99999, IOSTAT = IOST) NP11
C * ARU-LIST OVERFLOW
                IPR(138) = 0
                IF (IPR(168) == 0) THEN
C * TRY A RADIUS THAT IS 1.0 ANGSTROM SHORTER
                  RADR(IPR(58) + 1, 2) = RADR(IPR(58) + 1, 2) - 1.0
                ELSE
                  PAR(68) = PAR(68) - 1.0
                END IF
                IAT = IAT - 1
              END IF
C * TEST FOR INDIVIDUAL COORDINATION
              IF (IPR(168) > 0) EXIT
            END IF
          END DO
C * END OF LOOP ON IAT, ALL ATOMS PROCESSED
          IF (IPR(17) < 0) THEN
C * HANDLE INTER MODE
            IF (IPR(90) == 1) THEN
              CALL PLA066 (-1, 0, 0, 0, 0.0, 0.0, 0.0, 0.0, 0.0)
              IF (IPR(2) /= 0) GO TO 30
            END IF
            IPR(104) = IPR(104) + 1
            IF (IPR(104) <= IPR(75)) THEN
              IAT     = 0
              IPR(15) = - IABS (IPR(15))
              IATINC  = 1
              GO TO 20
            END IF
C * PRINT SYMMETRY CODE LIST IN INTER PRINT MODE
            IF (IPR(90) > 0) CALL PLA043 (0, 1, LU7, 0)
C * ANALYSE SHORT CONTACTS FOR INTERMOLECULAR CLUSTERS  AND NETWORKS
            IF (IPR(149) == 0) THEN
              CALL PLA091 (-2)
              IF (IPR(2) /= 0) GO TO 30
            END IF
C * ANALYSE FOR HYDROGEN BONDS
            CALL PLA089
C * NETWORK ANALYSIS (NO OVERFLOW, YES ANALYSIS)
            IF (IPR(149) == 0 .AND. IPR(300) > 0) THEN
              CALL PLA091 (-3)
              IF (IPR(2) /= 0) GO TO 30
              CALL PLA092
            END IF
          END IF
        END IF
      ELSE
        IPR(2) = 10
      END IF
C * CHECK FOR CONTINUE
   30 IF (IWIN == 1) THEN
C * TEST FOR INDIV CALC COORDN & SAV FILE
        IF (IPR(168) == 0 .AND. IPR(326) < 2) CALL PLA297 (0)
        IF (IPR(189) /= 0 .AND. IPR(121) == 0 .AND.
     1      IABS(IPR(326)) /= 1) CALL PLA280 ('RESTART')
      END IF
C * SET DEFAULT LABEL PLOT TO ZERO FOR LARGE STRUCTURES
      IF (IPR(17) == 0 .AND. IPR(37) > 100) IGBL(75) = 0
      RETURN
99999 FORMAT (/, ':: ARU-LIST Overflow (', I3, '), Radius Reduced', /)
      END SUBROUTINE PLA067
 
      SUBROUTINE PLA068 (IAT, KAT)
C * SUBROUTINE HANDLES ATOM_J_LOOP OF THE BOND SEARCH LOOP (I-LOOP IN PLA067)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: IVL
      INTEGER          :: JAT
      INTEGER          :: JP3
      INTEGER          :: JPP
      INTEGER          :: JSP
      INTEGER          :: KAX
      INTEGER          :: N51
      INTEGER          :: IAT
      INTEGER          :: KAT
      INTEGER          :: NAT
      INTEGER          :: MOLL
      INTEGER          :: NPOW
      INTEGER          :: IBT1
      INTEGER          :: IBT2
      INTEGER          :: IARU
      INTEGER          :: NSYM
      INTEGER          :: IVAL
      INTEGER          :: NITJ
      INTEGER          :: NSMM
      INTEGER          :: IHLP0
      INTEGER          :: IVAL1
      INTEGER          :: IATPRJ
      INTEGER          :: NSYMMAX
      INTEGER          :: IPOPTEST
      REAL             :: DIJ
      REAL             :: DST
      REAL             :: DIJK
      REAL             :: YUNK
      REAL             :: ORJK
      REAL             :: P23K
      REAL             :: PAR26
      REAL             :: PLA395
      CHARACTER(len=1) :: CSCRAT
      P23K = 0.0
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
C * GET NUMBER OF UNIQUE ATOMS
      NAT  = IPR(37)
C * COPY AND ORDER ATOM IAT COORDINATES, SETUP DLIM
      DO K = 1, 3
        V7(K)       = XXO(IAT, K)
        DUMA(K + 3) = PAR(112 + K)
      END DO
C * SPECIAL CONNECTIVITY SEARCH BREAK FOR METALS
      IPR(203) = 0
   10 KAX      = -1
      IPR(80)  = 0
   20 DO
        IF (KAX == 0) THEN
          GO TO 40
        ELSE IF (KAX > 0) THEN
          KAX = KAX - 1
          GO TO 60
        END IF
        NSYMMAX = NSYM
C * HANDLE NEGATIVE PART NUMBERS
        IF (IPR(17) == 0) THEN
          IF (IPR(661) < 0) NSYMMAX = 1
        END IF
C * SYMMETRY ELEMENT LOOP
        IPR(54) = 0
   30   IPR(54) = IPR(54) + 1
        KAX     = -1
        IF (IPR(54) > NSYMMAX) THEN
          IF (IPR(17) == 0) THEN
            IF (IPR(80) /= 0) GO TO 10
C * INTRA MODE, SET DONE AND FIX BIT TO 1
            CALL GEN048 (3, IFG(1, IAT), 1, 3)
          END IF
          RETURN
        END IF
C * ATOM J LOOP
        JAT = 0
   40   JAT = JAT + 1
        IF (JAT > NAT) GO TO 30
C * GET POPULATION PARAMETER FOR ATOM JAT
        CALL GEN048 (-8, IFG(2, JAT), 1, JPP)
        IPR(120) = IPPR(JPP + 1, 1)
C * GET PART #, IF ANY
        CALL GEN048 (-5, IFG(3, JAT), 14, IVL)
        IPR(662) = IVL - 16
C * GET BIT 9-18   (IPR(59), IPR(62))
        CALL GEN048 (-10, IFG(1, JAT), 9, IHLP0)
C * RETRIEVE EL.TYPE (BIT 15 - 18) AND RESD NUMB (BIT 9-14) FOR ATOM JAT
        IPR(59)  = IHLP0 / 64
        IPR(62)  = MOD (IHLP0, 64)
        PAR(23)  = PAR(19)
        PAR(293) = 0.0
C * GET ELEMENT TYPE (E.G. 1 = H)
        IPR(510) = IEN(IPR(59) + 1)
C * INTRA MODE
        IF (IPR(17) == 0) THEN
C * IGNORE H-H
          IF (IPR(509) * IPR(510) == 1) GO TO 40
          IATPRJ = IATPR(IPR(510))
C * AVOID DISORDER HALOGEN-HALOGEN CONTACTS
          IF (IPR(119) < 10000 .AND. IPR(120) < 10000) THEN
            IF (IATPR(IPR(509)) == -7 .AND. IATPRJ == -7) GO TO 40
          END IF
C * TEST FOR (EARTH)ALKALI - O,N ETC. CONTACTS TO ADD ADDITIONAL TOL.
          CALL PLA041 (IATPRJ, 1)
          IF (IPR(62) /= 0) THEN
            IF (IPR(62) /= IPR(61)) THEN
              GO TO 40
            END IF
          END IF
C * SPECIAL FOR GE-I BONDS
          IF (IPR(509) == 9 .AND. IPR(510) == 44)
     1      PAR(23) = PAR(23) + 2.0
          IF (IPR(509) == 1 .AND. IPR(510) == 3) THEN
            PAR(23) = PAR(23) - 0.15
          END IF
          IF (IPR(510) == 1) THEN
C * SPECIAL FOR ACID O-H..O H-BONDS
            IF (IPR(509) == 3) THEN
              PAR(23) = PAR(23) - 0.15
C * SPECIAL H..I
            ELSE IF (IPR(509) == 9) THEN
              PAR(23) = PAR(23) - 0.15
            END IF
          END IF
C * COORDN MODE
        ELSE IF (IPR(17) > 0) THEN
          IF (IPR(57) /= 0) THEN
            IF (RADR(IPR(59) + 1, 2) < 0.001) GO TO 40
          END IF
        END IF
C * INTRA & INTER MODE ONLY
        IF (IPR(17) <= 0) THEN
          PAR(23) = PAR(23) + RADR(IPR(59) + 1, 2) + PAR(293)
C * CHECK FOR SOLV/VOID
          YUNK    = PLA395 (IPR(509), IPR(510))
          IF (YUNK < -9.0) THEN
            PAR(23) = 2.0
          ELSE
            PAR(23) = PAR(23) + YUNK
          END IF
        END IF
        P23K = PAR(23)**2
C * SET D-LIMITS ON EACH AXIS AND ZERO INITIAL SHIFTS
        DO I = 1, 3
          DUMA(I) = DUMA(I + 3) * PAR(23)
          ITR(I)  = 0
        END DO
C * HANDLE NOSYMM CASE
        IF (IPR(27) == 1) THEN
          IPR(26) = 1555
          KAT     = JAT
          KAX     = 0
          GO TO 70
        END IF
        DO I = 1, 3
          SGZ(I + 3) = 0.0
          SGZ(I)     = XXO(JAT, I)
        END DO
        CALL SGSM (3, CSCRAT, SGZ, IPR(54), LU7, IERR)
        DO I = 1, 3
          SGZ(I) = SGZ(I + 6)
        END DO
C * BEGIN TRANSLATIONAL SEARCH ROUTINE (SEE ROLLETT)
        KAX = 1
C * TRANSLATE SGZ ON AXIS KAX TO A POINT BELOW LOWER LIMIT
   50   IF (V7(KAX) - SGZ(KAX) <= DUMA(KAX)) THEN
          SGZ(KAX) = SGZ(KAX) - 1.0
          GO TO 50
        END IF
   60   DO
C * ADVANCE 1 UNIT ON AXIS KAX
          SGZ(KAX) = SGZ(KAX) + 1.0
          IF (V7(KAX) - SGZ(KAX) < DUMA(KAX)) THEN
            IF (SGZ(KAX) - V7(KAX) <= DUMA(KAX)) EXIT
C * TEST GIVES ATOM OUT OF RANGE. REDUCE AXIS KAX BY 1
            KAX = KAX - 1
            IF (KAX <= 0) GO TO 40
          END IF
        END DO
C * KAX = 0 SIGNALS THE END OF THE TRANSLATION SEARCH
C * IF SGZ WAS WITHIN RANGE ON AXIS KAX THEN WE ADVANCE KAX BY 1
        KAX = KAX + 1
        IF (KAX < 4) GO TO 50
C * CALCULATE ITR  AND IPR(26)
        NPOW    = 1000
        IPR(26) = IPR(54) * NPOW + 555
        DO J = 1, 3
          NPOW       = NPOW / 10
          ITR(J)     = ITR(J) + NINT (SGZ(J) - SGZ(J + 6))
          SGZ(J + 6) = SGZ(J)
          IF (IABS(ITR(J)) > 4) THEN
C * OUT OF +/- 4 TRANSLATION RANGE
            IPR(494) = IPR(494) + 1
            GO TO 20
          END IF
          IPR(26) = IPR(26) + ITR(J) * NPOW
        END DO
        KAT = IPR(39) + IPR(24) + 1
        IF (KAT > NP1 - IPR(75)) THEN
C * ATTEMPT TO EXCEED MAX ATOM LIMIT
          IPR(2) = 1
          RETURN
        END IF
C * TRANSFORM ESD (IN NON-SOLV/VOID MODE)
        DO I = 1, 3
          SGY(I) = XSD(JAT, I)
        END DO
        NSMM = - IPR(54)
        CALL SGSM (3, CSCRAT, SGY, NSMM, LU7, IERR)
        DO N = 1, 3
          J   = 4 - N
          JP3 = J + 3
          IF (JAT /= KAT) THEN
            XXO(KAT, J) = SGZ(J + 6)
            XSD(KAT, J) = SGY(J + 6)
          END IF
          XXO(KAT, JP3) = 0
          XSD(KAT, JP3) = 0
          DO L = J, 3
            ORJK = OR(J, L)
            XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * ORJK
            IF (IPR(72) /= 0) THEN
              XSD(KAT, JP3) = XSD(KAT, JP3)
     1                      + XSD(KAT, L) * ORJK**2
            END IF
          END DO
        END DO
C * ATOM IN RANGE FOR ALL 3 AXES. NOW CALCULATE EXACT DISTANCE AND TEST
   70   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 <= P23K) THEN
          DIJ = SQRT (DIJK)
C * ELIMINATE DISTANCE OF ATOM FROM ITSELF
          IF (IPR(26) == 1555 .AND. IAT == JAT) GO TO 20
          CALL GEN048 (-1, IFG(1, JAT), 23, IVAL)
          CALL GEN048 (-1, IFG(2, JAT), 28, IVAL1)
          IPR(63) = IVAL + IVAL1 * IGBL(56)
          IF (IPR(17) == 0) THEN
            IPOPTEST = 10000
          ELSE
            IPOPTEST = 5000
          END IF
          IF (IPR(120) < IPOPTEST) THEN
            IPR(99) = 1 - IPR(502) * IABS (IPR(17))
          ELSE
            IPR(99) = 0
          END IF
C * SHELXL/PART STYLE HANDLING OF DISORDER
          IF (IPR(661) /= 0 .OR. IPR(662) /= 0) THEN
            IF (IPR(17) == 0) THEN
              IF (IPR(661) /= IPR(662)) THEN
                IF (IPR(661) /= 0 .AND. IPR(662) /= 0) GO TO 20
              END IF
C * HANDLE DISORDER OVER SYMMETRY ELEMENT (NEGATIVE PART)
              IF (IPR(661) < 0 .AND. IPR(662) /= 0) THEN
                IF (IPR(54) > 1) GO TO 20
              END IF
C * SET RESIDUE NUMBER FOR JAT TO CURRENT RESIDUE NUMBER
              CALL GEN048 (6, IFG(1, JAT), 9, IPR(75))
C * TEST DONE FLAG
              CALL GEN048 (-1, IFG(1, JAT), 1, IBT1)
C * TEST FIX(ED) FLAG
              CALL GEN048 (-1, IFG(1, JAT), 2, IBT2)
              IF (IBT2 == 0 .AND. IBT1 == 0) THEN
              ELSE IF (IPR(26) == 1555) THEN
                CALL GEN048 (1, IFG(2, JAT), 9, 1)
C * SET NEXT FLAG FOR ATOM JAT IF NOT DONE
                IF (IBT1 == 0) CALL GEN048 (1, IFG(1, JAT), 3, 1)
              END IF
            END IF
C * CHECK FOR DISORDER/POPULATION LESS 1.0 FOR IAT & JAT
          ELSE IF (IPR(98) + IPR(99) == 2) THEN
            IF (IPR(17) == 0) THEN
C * (BALL) - POPULATIONS IAT & JAT
              IF (ABS(IPR(119) - IPR(120)) > 1) THEN
                IF (2 * IPR(120) /= IPR(119)) GO TO 20
              END IF
              IF (IPR(119) == 5000 .AND. IPR(120) == 5000) THEN
                IF (IPR(54) /= 1) GO TO 20
              END IF
C * SET RESIDUE NUMBER FOR JAT TO CURRENT RESIDUE NUMBER
              CALL GEN048 (6, IFG(1, JAT), 9, IPR(75))
C * TEST DONE FLAG
              CALL GEN048 (-1, IFG(1, JAT), 1, IBT1)
C * TEST FIX(ED) FLAG
              CALL GEN048 (-1, IFG(1, JAT), 2, IBT2)
              IF (IBT2 == 0 .AND. IBT1 == 0) THEN
                IF (ABS (IPR(119) - IPR(120)) > 1) THEN
                  CALL GEN048 (3, IFG(1, JAT), 1, 6)
                END IF
              ELSE IF (IPR(26) == 1555) THEN
                CALL GEN048 (1, IFG(2, JAT), 9, 1)
C * SET NEXT FLAG FOR ATOM JAT IF NOT DONE
                IF (IBT1 == 0) CALL GEN048 (1, IFG(1, JAT), 3, 1)
              END IF
            END IF
            IF (ABS (IPR(119) - IPR(120)) > 1) THEN
              IF (IPR(119) < 5000 .AND. IPR(120) < 5000) THEN
                IF (IABS (2 * IPR(119) - IPR(120)) > 1 .AND.
     1          IABS (2 * IPR(120) - IPR(119)) > 1) GO TO 20
              ELSE IF (IPR(119) + IPR(120) >= 999) THEN
                GO TO 20
              END IF
            END IF
C * HANDLE DISORDER OVER SYMMETRY ELEMENT
            IF (IPR(154) == 0) THEN
              IF (IPR(128) == 5000 .AND. IPR(54) > 1) GO TO 20
            END IF
          END IF
C * DETERMINE INTRA/INTER BOND STATUS IN NON-INTRA MODE
          IF (IPR(17) /= 0) THEN
            IPR(20) = 1
            IARU    = NINT (PAR(42))
C * CHECK FOR IATRES == JATRES
            IF (IPR(61) == IPR(62)) THEN
              IF (IPR(26) /= 1555) THEN
C * HANDLE ATOMS ON SPECIAL POSITION
                CALL GEN048 (-1, IFG(1, JAT), 6, JSP)
                IF (JSP == 1) THEN
                  IF (IPR(17) < 0) THEN
                    DO L = 1, IPR(37)
                      CALL PLA050 (L, KAT, 0, 0, DST)
                      IF (DST < 0.001) GO TO 20
                    END DO
                  END IF
                END IF
              END IF
              NITJ = IPR(26) * IARU
              IF (NITJ /= 1555 * IARU) NITJ = NITJ + IPR(62)
              N51 = IPR(51)
              DO L = 1, N51
                MOLL = MOL(L)
                IF (L + IPR(101) > N51)
     1            MOLL = MOLL - NSYM * 1000 * IARU
                IF (MOLL == NITJ) THEN
                  IF (L + IPR(101) > N51) GO TO 20
                  IPR(20) = 0
                  EXIT
                END IF
              END DO
            END IF
          END IF
C * HANDLE THIS BOND/CONTACT
          IF (IPR(17) < 0) THEN
            PAR26 = REL(IPR(509)) + REL(IPR(510))
C * TAKE CARE OF 'ACID' O-H..O SHORT H-BOND
            IF (IPR(510) == 3 .AND. IPR(509) == 1) THEN
              PAR26 = PAR26 + 0.25
            ELSE IF (IPR(509) * IPR(510) == 1) THEN
              PAR26 = 0.1
            ELSE
              PAR26 = PAR26 + PAR(2)
            END IF
          ELSE
            PAR26 = PAR(18)
          END IF
C * DMIN-TEST SHORTCUT FOR NOSYMM MODE CASE
          IF (IPR(27) /= 0 .OR. DIJ > PAR26) THEN
            CALL PLA069 (IAT, JAT, KAT, DIJ)
          END IF
C * CHECK FOR ERROR
          IF (IPR(2) /= 0) RETURN
        END IF
      END DO
      END SUBROUTINE PLA068
 
      SUBROUTINE PLA069 (IAT, JAT, KAT, DIATKAT)
C * SUBROUTINE HANDLES SHORT INTRA, INTER AND COORDINATION DISTANCES FOUND
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: MM
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: NAT
      INTEGER :: KAL
      INTEGER :: IDS
      INTEGER :: IYK
      INTEGER :: N51
      INTEGER :: NCX
      INTEGER :: N511
      INTEGER :: KATX
      INTEGER :: IARU
      INTEGER :: IAUX
      INTEGER :: IBT1
      INTEGER :: IBT2
      INTEGER :: IBT3
      INTEGER :: IESD
      INTEGER :: IRES
      INTEGER :: IVAL
      INTEGER :: JHAT
      INTEGER :: LIAT
      INTEGER :: LKAT
      INTEGER :: MIAT
      INTEGER :: MKAT
      INTEGER :: MOLK
      INTEGER :: NMOL
      INTEGER :: NOLI
      INTEGER :: NOLK
      INTEGER :: NTOT
      INTEGER :: NCIAT
      INTEGER :: NCKAT
      INTEGER :: MLKAT
      INTEGER :: LLKAT
      INTEGER :: LIMET
      INTEGER :: ITRNS
      INTEGER :: IYUNK
      INTEGER :: NCLKAT
      INTEGER :: MOL511
      INTEGER :: JATDOAC
      REAL    :: D
      REAL    :: DIATKAT
      REAL    :: DIATJAT
      REAL    :: DJATKAT
      IDS  = 0
      IAUX = 0
C * GET NUMBER OF ATOMS IN ATOM LIST
      NAT  = IPR(39)
C * GET MOL-PACK CONSTANT (100 OR 10)
      IARU = NINT(PAR(42))
C * DECIDE WHAT TO DO WITH THIS CONNECTION (INTRA, INTER, COORDN)
C * INTRA MODE
      IF (IPR(17) == 0) THEN
C * CHECK FOR E.G. Cu-H > PAR(461))
        IF (IPR(509) == 1 .OR. IPR(510) == 1) THEN
        END IF
C * EXCLUDE LONG I..I+ CONTACTS AS BOND
        IF (IPR(509) == 9 .AND. IPR(510) == 9) THEN
          IF (DIATKAT > 3.0) RETURN
        END IF
C * DECIDE TO MOVE ATOM JAT OR NOT
C * GET HAT-BIT (REGISTER C-H REFINED)
        CALL GEN048 (-1, IFG(1, JAT), 7, JHAT)
        IF (JHAT == 1) THEN
C * CHECK FOR CARBON
          IF (IPR(509) == 2) THEN
C * CHECK FOR RIDING
            CALL GEN048 (-1, IFG(3, JAT), 6, IVAL)
            IF (IVAL == 0) THEN
              CALL GEN048 (-6, IFG(1, JAT), 9, IYK)
              IF (IYK == 0) THEN
                CALL GEN048 (-1, IFG(2, JAT), 10, IESD)
                IPR(474) = IPR(474) + IESD
              END IF
            END IF
          END IF
        END IF
C * SET RESIDUE NUMBER FOR JAT TO CURRENT RESIDUE NUMBER
        CALL GEN048 (-6, IFG(1, JAT), 9, IYUNK)
        IF (IYUNK == 0) THEN
          CALL GEN048 (6, IFG(1, JAT), 9, IPR(75))
        END IF
C * TEST DONE FLAG
        CALL GEN048 (-1, IFG(1, JAT), 1, IBT1)
C * TEST FIX(ED) FLAG
        CALL GEN048 (-1, IFG(1, JAT), 2, IBT2)
        IF (IBT2 == 1 .AND. IPR(26) == 1555) THEN
          CALL GEN048 (1, IFG(2, JAT), 9, 1)
        END IF
C * SET NEXT FLAG FOR ATOM JAT IF NOT DONE
        IF (IBT1 == 0) CALL GEN048 (1, IFG(1, JAT), 3, 1)
        CALL GEN048 (-1, IFG(1, JAT), 3, IBT3)
C * CASE OF NOT YET FIXED ATOM
        IF (IBT2 == 0) THEN
C * SPECIAL DISORDER CASE HANDLING
          IF (IPR(99) /= 0) THEN
            IF (IPR(26) /= IPR(166)) THEN
              IF (IBT1 == 0) CALL GEN048 (1, IFG(1, JAT), 3, 0)
              RETURN
            END IF
          END IF
C * MOVE ATOM JAT - RESET THE COORDS BUT DO NOT ADD SUFFIX TO NAME
C * SET ATOMIC POSITION FIXED FLAG
          CALL GEN048 (1, IFG(1, JAT), 2, 1)
          CALL GEN048 (1, IFG(2, JAT), 9, 1)
C * SET SPECIAL BREAK (BASED ON ATOMIC PROPERTIES)
          IF (IPR(157) >= 0 .AND. IPR(158) < 0) IPR(203) = 1
          IF (IATP(JAT) <= 0) IATP(JAT) = 1555
          IF (IPR(26) /= 1555) THEN
C * COPY MOVED COORDINATES, KEEP TRACK OF AND SAVE TRANSFORMATION
            DO L = 1, 6
              XXO(JAT, L) = XXO(KAT, L)
              XSD(JAT, L) = XSD(KAT, L)
            END DO
            FN(1) = IPR(54)
            ITRNS = IPR(54) * 1000 + 555
            DO L = 2, 4
              FN(L) = ITR(L - 1)
              ITRNS = ITRNS + ITR(L - 1) * 10**(4 - L)
            END DO
            IATP(JAT) = ITRNS
            WRITE (LU4) 5, LABA(JAT), (FN(L), L = 1, 8)
          END IF
          KAT     = JAT
          IPR(80) = 1
          RETURN
        END IF
C * INTER MODE: LOOK FOR SHORT INTRA- OR INTER-MOLECULAR CONTACTS
      ELSE IF (IPR(17) < 0) THEN
C * AVOID INTERNAL DISORDER CONTACTS (CHECK POPULATION KAT
        IF (IPR(120) < 10000) THEN
          CALL PLA050 (IAT, JAT, 0, 0, DIATJAT)
          CALL PLA050 (JAT, KAT, 0, 0, DJATKAT)
          IF (DIATJAT < 1.8) THEN
            IF (DJATKAT > 0.0001 .AND. DJATKAT < 1.8) RETURN
          END IF
        END IF
C * GET NUMBER OF 'UNIQUE MOLES'(=155500 + EXPAND CONNECTED)
        N51    = IPR(51)
C * GET NUMBER OF ORDERED 'UNIQUE MOLES'
        N511   = N51 - IPR(101)
        MOL511 = (IPR(48) * 1000 + IPR(26)) * IARU + IPR(62)
        DO K = 1, N51
C * SKIP DISORDER CONTACTS
          IF (K > N511) THEN
            IF (MOL(K) == MOL511) RETURN
          END IF
          MOLK = MOL(K) / IARU
          IRES = MOL(K) - MOLK * IARU
C * CHECK FOR INTRA (NEGLECTING RESIDUE NUMBER) CONTACT
          IF (MOLK == IPR(26)) THEN
            IF (IRES == 0 .OR. IPR(62) == IRES) THEN
C * WE HAVE AN 'INTRA-INTER' CASE, IDENTIFY KAT
              DO N = 1, NAT
                CALL PLA050 (N, KAT, 0, 0, D)
                IF (D < PAR(18)) THEN
                  KAT = N
C * COMPARE RESIDUE NUMBERS
                  IF (IPR(61) /= IPR(62)) THEN
                    CALL PLA070 (IAT, JAT, KAT, NAT, IAUX, DIATKAT)
                    RETURN
                  ELSE
C * EXCLUDE CONTACTS BETWEEN ATOMS THAT ARE CONNECTED BY < 4 BONDS
C * EXCEPT FOR POTENTIAL 1-4 D/A INTRA CONTACTS AND EARTH ALKALI CONTACTS
                    CALL GEN048 (-1, IFG(1, JAT), 23, JATDOAC)
C * GET NUMBER OF CONNECTIONS TO IAT (= NCIAT)
                    NCIAT = - NINT (CON(IAT, 9))
                    IF (NCIAT < 0) NCIAT = 9
C * GET NR OF CONNECTIONS TO KAT (= NCKAT)
                    NCKAT = - NINT (CON(KAT, 9))
                    IF (NCKAT < 0) NCKAT = 9
C * LOOP OVER CONNECTIONS FROM ATOM IAT
                    DO MIAT = 1, NCIAT
                      LIAT = NINT (CON(IAT, MIAT))
                      IF (LIAT <= NP1) THEN
                        CALL GEN048 (-1, IFG(1, LIAT), 19, LIMET)
C * SKIP 1-BOND CONTACTS
                        IF (LIAT == KAT) RETURN
C * TEST FOR (EARTH)-ALKALI (AVOID O...CA...O TYPE LINKS)
C * GET ATOM TYPE PROPERTY (NO (EARTH) ALKALI)
                        CALL GEN048 (-4, IFG(1, LIAT), 15, NOLI)
                        IF (MOD(IATPR(IEN(NOLI + 1)), 7) < 5) THEN
C * LOOP OVER CONNECTIONS FROM ATOM KAT
                          DO MKAT = 1, NCKAT
                            LKAT = NINT (CON(KAT, MKAT))
                            IF (LKAT <= NP1) THEN
C * GET ATOM TYPE PROPERTY (NO (EARTH) ALKALI)
                              CALL GEN048 (-4, IFG(1, LKAT), 15, NOLK)
                              KAL = MOD(IATPR(IEN(NOLK + 1)), 7)
C * SKIP 2-BOND CONTACTS (1-3 CONTACTS NOT INVOLVING C,N etc)
                              IF (LIAT == LKAT) THEN
C * CHECK FOR METAL-H
                                IF (LIMET /= 0) CALL PLA070 (IAT, JAT,
     1                            KAT, NAT, IAUX, DIATKAT)
                                RETURN
                              ELSE
                                NCLKAT = - NINT (CON(LKAT, 9))
                                IF (NCLKAT < 0) NCLKAT = 9
                                DO MLKAT = 1, NCLKAT
                                  LLKAT = NINT (CON(LKAT, MLKAT))
C * SKIP 3-BOND CONTACTS
                                  IF (LLKAT == LIAT) THEN
                                    IF ((KAL < 5 .AND. LIMET == 0)
     1                                .OR. JATDOAC == 1) THEN
                                      CALL PLA070 (IAT, JAT, KAT, NAT,
     1                                  IAUX, DIATKAT)
                                    END IF
                                    RETURN
                                  END IF
                                END DO
                              END IF
                            END IF
                          END DO
                        END IF
                      END IF
                    END DO
                    CALL PLA070 (IAT, JAT, KAT, NAT, IAUX, DIATKAT)
                    RETURN
                  END IF
                END IF
              END DO
              RETURN
            END IF
          END IF
        END DO
      END IF
      IF (IPR(17) >= 0) THEN
C * TEST SYMM GENERATED ATOM FOR OVERLAP WITH AN ATOM ALREADY IN LIST
        NTOT = IPR(39) + IPR(24)
        DO I = 1, NTOT
          CALL PLA050 (I, KAT, 0, 0, D)
C * DISTANCE LESS THAN PAR(18) IS TAKEN AS  ATOM(I) = ATOM(KAT)
          IF (D < PAR(18)) THEN
C * OVERLAP OF I BY JAT - DO NOT ADD TO LIST
            KAT = I
C * CHECK WHETHER THIS CONNECTION IS ALREADY IN THE LIST FOR ATOM IAT
            IF (IPR(17) > 0) THEN
              NCX  = IPR(79)
              KATX = KAT + IPR(20) * NP1
              DO L = 1, NCX
                IF (KATX == IATC(L)) RETURN
              END DO
            END IF
            CALL PLA070 (IAT, JAT, KAT, NAT, IAUX, DIATKAT)
            RETURN
          END IF
        END DO
C * INTRA MODE
        IF (IPR(17) == 0) THEN
          IF (IPR(98) + IPR(99) > 0) THEN
C * NOTE DISORDED OPERATION WHEN IPR(154) = 1
            IF (DIATKAT + 2 * PAR(2) <= PAR(23))
     1         IDS = IPR(154) * IPR(48) * 1000 * IARU
          END IF
          GO TO 10
        END IF
      END IF
C * THIS IS AN ATOM CONNECTED BY SYMMETRY TO THE BASIC FRAGMENT
C * THE SYMMETRY OPERATION IS NOTED AND SAVED FOR GENERATING THE UNIQUE
C * SET OF MOLECULAR COORDINATES FOR THE INTRA MODE LATER.
C * ALL INTER-MOLECULAR CONNECTIONS ARE SET UP HERE ALSO
C * ADD THIS ATOM TO THE LIST, IT WILL HAVE SUFFIX LETTER ADDED TO THE
C * NAME FOR INTER AND COORDN
      IPR(24) = IPR(24) + 1
      IAUX    = 1
      DO I = 1, 3
        IFG(I, KAT) = IFG(I, JAT)
      END DO
      CALL GEN048 (1, IFG(1, KAT), 5, 1)
C * ADD ARU TO LIST, REDUNDANT ARU'S ARE NOT ENTERED
   10 NMOL = IPR(13)
      IF (IPR(26) /= 1555) THEN
        IF (IPR(62) == 0) IPR(62) = IPR(61)
        MOL(NMOL + 1) = IPR(26) * IARU + IPR(62) + IDS
        IF (NMOL > 1) THEN
          DO MM = 2, NMOL
            IF (MOL(MM) == MOL(NMOL + 1)) GO TO 20
            IF (MOL(MM) - IPR(48) * 1000 * IARU .EQ.
     1          MOL(NMOL + 1)) THEN
              IPR(24) = IPR(24) - IAUX
              RETURN
            END IF
            IF (MOL(MM) + IDS == MOL(NMOL + 1)) THEN
              MOL(MM) = MOL(NMOL + 1)
              GO TO 20
            END IF
          END DO
        END IF
        IF (IPR(13) + 3 < 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
          RETURN
        END IF
C * SET SUFFIX TO ATOM NAME
   20   IF (IPR(17) /= 0) THEN
          IF (MM > IPR(463) - 1) THEN
            IPR(2) = 54
            RETURN
          END IF
          LABA(KAT) = LABA(JAT) + MM - 1
        END IF
      END IF
      CALL PLA070 (IAT, JAT, KAT, NAT, IAUX, DIATKAT)
      RETURN
      END SUBROUTINE PLA069
 
      SUBROUTINE PLA070 (IAT, JAT, KAT, NAT, IAUX, DIATKAT)
C * STORAGE CONNECTIONS
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: NAT
      INTEGER :: IHA
      INTEGER :: IDOA
      INTEGER :: IVAL
      INTEGER :: IAUX
      REAL    :: DIATKAT
C * INTRA MODE
      IF (IPR(17) == 0) THEN
C * HANDLE STORAGE OF INTRA CONNECTIONS LATER (PLA072)
C * STORE DONOR - H BOND BIT (IPR(17) = 0)
        IF (KAT <= IPR(37)) THEN
C * SET DONOR/ACCEPTOR ATOM BIT
          CALL GEN048 (-1, IFG(1, IAT), 23, IDOA)
C * SET HYDROGEN ATOM IDENTIFICATION BIT
          CALL GEN048 (-1, IFG(1, KAT), 7,  IHA)
          IF (IDOA == 1 .AND. IHA == 1) THEN
C * SET POTENTIAL DONOR ATOM BIT
            CALL GEN048 (1, IFG(1, IAT), 21, 1)
C * SET POTENTIAL H-BOND H-ATOM BIT
            CALL GEN048 (1, IFG(1, KAT), 20, 1)
          END IF
        END IF
C * INTER MODE
      ELSE IF (IPR(17) < 0) THEN
C * PRINT THIS DISTANCE IN CASE OF CALC INTER
        CALL PLA057 (IAT, JAT, KAT)
C * (WITH GENERATED ACCEPTOR ATOM)
        CALL GEN048 (-1, IFG(1, IAT), 7, IHA)
        IF (IHA == 1 .AND. IPR(63) == 1) THEN
          IF (DIATKAT <= (PAR(23) - PAR(1) + RGBL(45))) THEN
C * ADD NP1 FOR INTER BOND
            KAT = KAT + NP1
C * CHECK FOR PRE-OCCURRENCE
            CALL PLA040 (-1, IAT, IVAL, KAT)
            IF (IVAL == 0) THEN
C * MANAGE CONNECTION ARRAY
              CALL PLA040 (1, IAT, IVAL, KAT)
              IF (KAT > NAT) IAUX = 0
            END IF
          END IF
        END IF
        IPR(24) = IPR(24) - IAUX
C * COORDN: STORE THIS CONNECTION IAT TO JAT IN ARRAY IATC (MAX = NP1)
      ELSE
        IPR(79)       = IPR(79) + 1
        IATC(IPR(79)) = KAT + IPR(20) * NP1
        DATC(IPR(79)) = DIATKAT
        IF (IPR(79) >= NP1) THEN
          CALL GEN036 (DATC, IATC, 1, IPR(79))
          IPR(79) = NP1 - 5
          PAR(23) = DATC(IPR(79))
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA070
 
      SUBROUTINE PLA071 (I)
C * SUPPORT PLA067 (FIX/MOVE) - ATOMIC COORDINATES TRANSFORMATION
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: KAT
      INTEGER :: IVAL
      INTEGER :: ITRNS
C * GET PREVIOUS FIX INFORMATION
      CALL GEN048 (-1, IFG(1, I), 2, IVAL)
C * TEST FOR NOMOVE
      IF (IGBL(30) == 1) THEN
        ITRNS = 1555
      ELSE IF (IVAL == 1) THEN
        ITRNS = IATP(I)
      ELSE
        KAT  = IPR(39) + IPR(24) + 1
C * TEST FOR ATTEMPT TO EXCEED MAX ATOM LIMIT
        IF (KAT >= NP1) THEN
          IPR(2) = 1
          ITRNS  = 1555
        ELSE
          ITRNS = IABS(IATP(I))
C * APPLY SUPPLIED TRANSFORMATION
          IF (ITRNS /= 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 J = 1, 3
              FN(J + 1) = ITR(J) - 5
            END DO
          ELSE
            FN(1) = 1.0
            CALL GEN074 (FN, 2, 4, 0.0)
          END IF
          ITRNS = NINT (FN(1) * 1000 + 555)
          DO J = 1, 3
            XXO(KAT, J) = XXO(I, J)
            XSD(KAT, J) = XSD(I, J)
            ITR(J)      = NINT (FN(J + 1))
            ITRNS       = ITRNS + ITR(J) * 10**(3 - J)
            IF (IABS(ITR(J)) > 4) IPR(2) = 17
          END DO
          IF (ITRNS /= 1555) THEN
            WRITE (LU4) 5, LABA(I), (FN(J), J = 1, 8)
            IPR(54) = NINT (FN(1))
C * APPLY SYMMETRY OPERATION AND ORTHOGONALISE
            CALL PLA059 (KAT, I)
          END IF
        END IF
      END IF
      IATP(I) = ITRNS
C * SET IFIX BIT = 1
      CALL GEN048 (1, IFG(1, I), 2, 1)
      RETURN
      END SUBROUTINE PLA071
 
      SUBROUTINE PLA072 (MODE)
C * EXPAND PRIMARY ATOM/MOLECULE LIST
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: M1
      INTEGER                  :: M2
      INTEGER                  :: N2
      INTEGER                  :: JJ
      INTEGER                  :: KK
      INTEGER                  :: MM
      INTEGER                  :: IR
      INTEGER                  :: MN
      INTEGER                  :: NC
      INTEGER                  :: NAT
      INTEGER                  :: MM1
      INTEGER                  :: MM2
      INTEGER                  :: MNI
      INTEGER                  :: MNJ
      INTEGER                  :: IR1
      INTEGER                  :: IR2
      INTEGER                  :: IR3
      INTEGER                  :: IR4
      INTEGER                  :: IS1
      INTEGER                  :: IS2
      INTEGER                  :: IS3
      INTEGER                  :: IS4
      INTEGER                  :: IX1
      INTEGER                  :: IX2
      INTEGER                  :: IX3
      INTEGER                  :: IX4
      INTEGER                  :: IX5
      INTEGER                  :: IY1
      INTEGER                  :: IY2
      INTEGER                  :: IY3
      INTEGER                  :: IY4
      INTEGER                  :: IY5
      INTEGER                  :: IZ1
      INTEGER                  :: IZ2
      INTEGER                  :: IZ3
      INTEGER                  :: IZ4
      INTEGER                  :: IZ5
      INTEGER                  :: IAT
      INTEGER                  :: KAT
      INTEGER                  :: MMO
      INTEGER                  :: IPP
      INTEGER                  :: IVL
      INTEGER                  :: NO1
      INTEGER                  :: NO2
      INTEGER                  :: NUMB
      INTEGER                  :: NUMC
      INTEGER                  :: NUMH
      INTEGER                  :: NUMO
      INTEGER                  :: NUMS
      INTEGER                  :: NRES
      INTEGER                  :: NSYM
      INTEGER                  :: NRBO
      INTEGER                  :: NDEC
      INTEGER                  :: NATC
      INTEGER                  :: MOLN
      INTEGER                  :: KHAT
      INTEGER                  :: JHAT
      INTEGER                  :: JDUM
      INTEGER                  :: IVAL
      INTEGER                  :: NMOL
      INTEGER                  :: MODE
      INTEGER                  :: IARU
      INTEGER                  :: IDAC
      INTEGER                  :: IDS1
      INTEGER                  :: IDS2
      INTEGER                  :: IDS3
      INTEGER                  :: IDUM
      INTEGER                  :: IENI
      INTEGER                  :: IENJ
      INTEGER                  :: IENK
      INTEGER                  :: IFIN
      INTEGER                  :: IHAT
      INTEGER                  :: JUNK
      INTEGER                  :: IRESI
      INTEGER                  :: IRESJ
      INTEGER                  :: IPRT1
      INTEGER                  :: IPRT2
      INTEGER                  :: IPRT3
      INTEGER                  :: IPR13
      INTEGER                  :: IATPRI
      INTEGER                  :: IATPRJ
      INTEGER                  :: IBREAK
      INTEGER                  :: JSPPOS
      INTEGER                  :: IGNORE
      INTEGER                  :: ICHIRAL
      INTEGER, DIMENSION(NP11) :: MOLSV
      INTEGER, DIMENSION(NP29) :: IRCONT
      INTEGER, DIMENSION(NP29) :: JRCONT
      INTEGER, DIMENSION(NP29) :: MLTISV
      INTEGER, DIMENSION(NP29) :: NPOLSV
      REAL                     :: XM1
      REAL                     :: XM2
      REAL                     :: XM3
      REAL                     :: DIJ
      REAL                     :: DMX
      REAL                     :: YUNK
      REAL                     :: DIST
      REAL                     :: FSDV
      REAL                     :: ANGLE
      REAL                     :: DISTIJ
      REAL                     :: PLA395
C * MODE = 1: EXPAND
C *        0: NO EXPAND
C *       -1: Generate atoms for symmetry related unit(s) only (ORTEP link)
C * SET-UP ATOMS FOR SYMMETRY RELATED UNITS
C * SET UNIQUE CALCULATION TO THE VALUE 'DONE'
      IPR(30) =  1
C * INIT TYPE 1 NETWORK (= COVALENT NETWORK)
      CALL PLA094 (-1, 0, 0, 0, 0, 0)
C * GET NUMBER OF UNIQUE (= INPUT) ATOMS
      NATC = IPR(37)
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
C * GET NUMBER OF RESIDUES
      NRES = IPR(75)
C * RESIDUE # PACKING FACTOR
      IARU = NINT(PAR(42))
C * COUNT NUMBER OF MOVED PRIMARY ATOMS
      IGBL(60) = 0
      DO I = 1, NATC
        IF (IATP(I) /= 1555) IGBL(60) = IGBL(60) + 1
      END DO
C * EXPAND MOLECULES (UNLESS NOEXPAND = IPR(136) = 1)
      NMOL = IPR(13)
      MMO  = IPR(13)
C * TEST FOR GLOBAL NOEXPAND: IGBL(136) = 1
      IF (NMOL > 1 .AND. IGBL(136) == 0) THEN
C * TEST FOR EXPAND MODE
        IF (MODE == 1) THEN
C * CHECK FOR NETWORK TRANSLATIONS IN STARTING LIST
          DO I = NMOL, 2, -1
            CALL GEN098 (MOL(I), PAR(42), IS1, IX1, IY1, IZ1, IR1)
            DO J = I - 1, 1, -1
              CALL GEN098 (MOL(J), PAR(42), IS2, IX2, IY2, IZ2, IR2)
              IF (IS1 == IS2) THEN
                IF (IR2 == 0) IR2 = IR1
                IF (IR1 == IR2) THEN
                  IX3 = IX2 - IX1
                  IY3 = IY2 - IY1
                  IZ3 = IZ2 - IZ1
                  IF (IABS (IX3) + IABS (IY3) + IABS (IZ3) /= 0) THEN
C * ADD NEW NETWORK TRANSLATION VECTOR
                    CALL PLA094 (1, IX3, IY3, IZ3, IR2, 0)
                  END IF
                END IF
              END IF
            END DO
          END DO
C * SORT MOLECULE LIST (EXCLUDING 1555)
          CALL GEN022 (MOL, 2, NMOL, 1)
          IPR13 = NMOL
C * COPY
          CALL GEN133 (MOL,  MOLSV,  NP11)
          CALL GEN133 (MLTI, MLTISV, NP29)
C * EXPAND LOOP
          DO
            MMO = IPR(13)
C * TEST FOR (IN)ORGANIC TOGGLE
            IF (IGBL(97) /= 0) THEN
              DO I = MMO, 1, -1
                IF (MOL(I) / (1000 * IARU) <= NSYM) THEN
C * GET NUMBER OF DISORDER OPERATIONS
                  IPR(101) = IPR(13) - I
                  MMO      = I
                  EXIT
                END IF
              END DO
C * COMPLETE MOLECULES
              MM1 = MMO + 1
   10         MM1 = MM1 - 1
              IF (MM1 > 1) THEN
                CALL GEN098 (MOL(MM1), PAR(42), IS1, IX1, IY1, IZ1, IR1)
                XM1 = MOL(MM1) / PAR(42)
                MM2 = MMO + 1
   20           MM2 = MM2 - 1
                IF (MM2 == 1) GO TO 10
                CALL GEN098 (MOL(MM2), PAR(42), IS2, IX2, IY2, IZ2, IR2)
                XM2  = MOL(MM2) / PAR(42)
                IF (IR2 /= IR1) GO TO 20
C * MULTIPLY SYMMETRY CODES
                CALL PLA270 (XM1, XM2, XM3)
C * ARU REPRESENTABLE ?
                IF (XM3 == 0.0) THEN
C * COPY
                    CALL GEN133 (MOLSV,  MOL,  NP11)
                    CALL GEN133 (MLTISV, MLTI, NP29)
                    IPR(13) = IPR13
                    MMO     = IPR13
                    GO TO 30
                END IF
                MOLN = NINT (XM3 * PAR(42))
                CALL GEN098 (MOLN, PAR(42), IS3, IX3, IY3, IZ3, IR3)
                IF (IS3 == 1) THEN
                  IF (IABS (IX3) + IABS (IY3) + IABS (IZ3) /= 0) THEN
                    MLTI(IR3) = -1
C * ADD NEW NETWORK TRANSLATION VECTOR
                    CALL PLA094 (1, IX3, IY3, IZ3, IR3, 0)
                  END IF
                  GO TO 20
                END IF
                DO I = 1, MMO
                  CALL GEN098 (MOL(I), PAR(42), IS4, IX4, IY4, IZ4, IR4)
                  IF (I == 1) IR4 = IR3
                  IF (IR3 == IR4 .AND. IS3 == IS4) THEN
                    IX5 = IX4 - IX3
                    IY5 = IY4 - IY3
                    IZ5 = IZ4 - IZ3
                    IF (IABS (IX5) + IABS (IY5) + IABS (IZ5) /= 0) THEN
C * ADD NEW NETWORK TRANSLATION VECTOR
                      CALL PLA094 (1, IX5, IY5, IZ5, IR3, 0)
                    END IF
                    GO TO 20
                  END IF
                END DO
                IF (IPR(13) + 3 < NP11) THEN
                  IPR(13)      = IPR(13) + 1
                  MOL(IPR(13)) = MOLN
                  IF (MLTI(IR3) > 0) MLTI(IR3) = MLTI(IR3) + 1
C * SORT MOLECULE LIST (EXCLUDING 1555)
                  CALL GEN022 (MOL, 2, IPR(13), 1)
                  CYCLE
                ELSE
C * MOL-LIST DIMENSION EXCEEDED
                  IPR(138) = IPR(138) + 1
                END IF
              END IF
            END IF
            IF (.TRUE.) EXIT
          END DO
C * NOW SORT MOLECULES ON RESIDUE NUMBER
   30     DO MM = 2, MMO
            M1 = MOD (MOL(MM), IARU)
            M2 = MOL(MM) / IARU
            MOL(MM) = M1 * 1000000 + M2
          END DO
          CALL GEN022 (MOL, 2, MMO, 1)
          DO MM = 2, MMO
            M1 = MOL(MM) / 1000000
            M2 = MOD (MOL(MM), 1000000)
            MOL(MM) = M2 * IARU + M1
          END DO
        END IF
C * END OF MODE = 1 SECTION (EXPAND)
C * EXPAND THE COORDINATE LIST USING THE SYMMETRY OPERATIONS SAVED
C * IN ARRAY MOL(M)
        DO MM = 2, MMO
          CALL GEN098 (MOL(MM), PAR(42), IPR(54), ITR(1), ITR(2),
     1         ITR(3), IR)
          IF (MM > IPR(463) - 1) THEN
            IPR(2) = 54
            RETURN
          END IF
          MN = MM - 1
C * RUN THROUGH THE CURRENT ATOM LIST GENERATING NEW ATOMS BY THE
C * SYMM OPERATION DEFINED FOR THE MOL(MM)
          DO I = 1, NATC
            CALL GEN048 (-6, IFG(1, I), 9, IRESI)
            IF (IRESI == IR) THEN
              CALL GEN048 (-8, IFG(2, I), 1, IPP)
              IPR(128) = IPPR(IPP + 1, 1) * IPPR(IPP + 1, 3) / NSYM
              IPR(119) = IPPR(IPP + 1, 1)
              IF (IPR(119) < 10000) THEN
                IPR(98) = 1
              ELSE
                IPR(98) = 0
              END IF
              KAT = IPR(39) + 1
              IF (KAT >= NP1) THEN
C * ATTEMPT TO EXCEED MAX ATOM LIMIT
                IPR(2) = 1
                GO TO 60
              END IF
C * TRANSFORM & ORTHOGONALISE
              CALL PLA059 (I, KAT)
C * TEST FOR THIS SYMM GENERATED ATOM OVERLAPPING AN ATOM ALREADY IN THE
C * LIST
              NAT    = IPR(39)
              IGNORE = 0
              DO J = 1, NAT
                CALL PLA050 (J, KAT, 0, 0, DIJ)
                IF (DIJ < PAR(18)) THEN
                  CALL GEN048 (-8, IFG(2, J), 1, IPP)
                  IF (IPPR(IPP + 1, 1) == 10000) THEN
                    IGNORE = 1
                    EXIT
                  END IF
                END IF
              END DO
              IF (IGNORE == 0) THEN
C * THE ATOM KAT DOES NOT OVERLAP ANY IN LIST - ADD TO THE LIST.
                IPR(39) = IPR(39) + 1
C * COPY THE ATOM NAME LABEL WITH AN ALPHABETIC CHARACTER ADDED
C * TO IDENTIFY THE SYMM OPERATION WHICH GENERATED IT.
                IF (MN > IPR(463) - 1) THEN
                  IPR(2) = 54
                RETURN
                END IF
                LABA(KAT) = LABA(I) + MN
C * COPY FLAGS
                DO K = 1, 3
                  IFG(K, KAT) = IFG(K, I)
                END DO
                CALL GEN048 (1, IFG(1, KAT), 5, 1)
                CON(KAT, 9) = 0.0
                IF (MODE == 1) THEN
                  XM1 = (MOL(MM) - IR) / PAR(42)
                  XM2 = IABS (IATP(I))
                  CALL PLA270 (XM1, XM2, XM3)
                  IF (IPR(2) /= 0) GO TO 60
                  IATP(KAT) = INT (XM3)
                END IF
              END IF
            END IF
          END DO
C * END OF LOOP ON  ATOMS I
C * END OF LOOP ON SYMM OPRS MM
        END DO
C * END OF LOOP ON SYMM OPRS MM
      END IF
C * INITIALISE RESIDUE ATOM CONTENT COUNT
      DO I = 1, NRES
        IRCONT(I) = (NP1 * 100 + I) * 1000 + MLTI(I) + 1
      END DO
C * THIS IS NOW THE EXPANDED MOLECULE SET OF COORDINATES
C * GENERATE THE CONNECTIVITY ON THE BASIS OF THIS LIST.
C * DO AN INTRA-MOL DISTANCE CALCULATION FROM SCRATCH
      NAT = IPR(39)
      DO I = 1, NAT
C * GET RESIDUE NUMBER
        CALL GEN048 (-6, IFG(1, I), 9, IRESI)
C * CHECK FOR HYDROGEN ATOM (DO NOT COUNT H-ATOMS)
        CALL GEN048 (-1, IFG(1, I), 7, IHAT)
        IRCONT(IRESI) = IRCONT(IRESI) - 100000 * (1 - IHAT)
        IF (I > 1) THEN
          N2  = I - 1
C * GET ATOM-TYPE
          CALL GEN048 (-4, IFG(1, I), 15, NO1)
          IENI     = IEN(NO1 + 1)
          DMX      = RADR(NO1 + 1, 2) + PAR(1)
          IATPRI   = IATPR(IENI)
          IPR(191) = ISIGN (1, IATPRI)
C * GET PART NUMBER
          CALL GEN048 (-5, IFG(3, I), 14, IVL)
          IPRT1 = IVL - 16
C * SPECIAL TREATMENT OF COORDINATED NITRATE,SULPHATE & PERCHLORATE
C * PHOSPHATE
          NUMO = 0
          NUMS = 0
          NUMC = 0
          NUMH = 0
C * CHECK FOR C, N, Cl, S, Br, P, B
          IF (IENI == 2 .OR. IENI >= 4 .AND. IENI <= 8 .OR.
     1        IENI == 20) THEN
            DO J = 1, NAT
              IF (I /= J) THEN
                CALL PLA050 (I, J, 0, 0, DIST)
                IF (DIST < 2.1) THEN
C * GET PART NUMBER ATOM J
                  CALL GEN048 (-5, IFG(3, J), 14, IVL)
                  IPRT3 = IVL - 16
                  CALL GEN048 (-4, IFG(1, J), 15, IVAL)
                  IVAL = IEN(IVAL + 1)
C * COUNT NUMBER OF ATTACHED H-ATOMS
                  CALL GEN048 (-1, IFG(1, J), 7, JHAT)
                  IF (JHAT == 1) THEN
                    IF (IVAL == 1) THEN
                       NUMH = NUMH + 1
                      CYCLE
                    END IF
                  END IF
                  IF (DIST < 1.7) THEN
C * COUNT NUMBER OF ATTACHED OXYGEN ATOMS
                    IF (IVAL == 3) THEN
                      IF (IPRT1 == IPRT3) NUMO = NUMO + 1
                      CYCLE
                    END IF
                  END IF
C * COUNT NUMBER OF ATTACHED CARBON ATOMS
                  IF (IVAL == 2) THEN
                    NUMC = NUMC + 1
                    CYCLE
C * COUNT NUMBER OF ATTACHED SULPHUR ATOMS
                  ELSE IF (IVAL == 6) THEN
                    NUMS = NUMS + 1
                  END IF
                END IF
              END IF
            END DO
C * B (BH2XY)
            IF (IENI == 20 .AND. NUMH >= 3) NUMH = -1
C * C  (CO2)
            IF (IENI == 2  .AND. NUMO == 2) NUMO = -1
C * N  (NO3)
            IF (IENI == 4  .AND. NUMO == 3) NUMO = -1
C * CL (ClO4)
            IF (IENI == 5  .AND. NUMO == 4) NUMO = -1
            IF (IENI == 6) THEN
C * S  (SO4)
              IF (NUMO == 4) THEN
                NUMO = -1
C * S  (C-SO3)
              ELSE IF (NUMO == 3 .AND. NUMC == 1) THEN
                NUMO = -1
              END IF
            END IF
C * P  (PO4)
            IF (IENI == 8 .AND. (NUMO + NUMS) == 4) NUMO = -1
            IF (NUMO < 0) CALL GEN048 (1, IFG(1, I), 31, 1)
          END IF
          IPR(509) = IENI
          CALL PLA041 (IATPRI, 0)
C * GET POPULATION PARAMETER
          CALL GEN048 (-8, IFG(2, I), 1, IDS1)
          IDS1 = IPPR(IDS1 + 1, 1)
C * LOOP ON ATOM-J
          DO J = 1, N2
C * SELECT ON DISTANCE
            CALL PLA050 (I, J, 0, 0, DISTIJ)
            IF (DISTIJ < 3.5) THEN
C * SELECT ON RESIDUE NUMBER
              CALL GEN048 (-6, IFG(1, J), 9, IRESJ)
              IF (IRESI == IRESJ) THEN
C * SELECT ON NON-HYDROGEN
                CALL GEN048 (-1, IFG(1, J), 7, JHAT)
                IF (IHAT == 0 .OR. JHAT == 0) THEN
C * CHECK FOR NON CENTRAL ATOM IN CO2,NO3,SO4,ClO4,PO4 bit
                  CALL GEN048 (-1, IFG(1, J), 31, JUNK)
                  IF (IATPRI <= 0 .OR. JUNK == 0) THEN
C * GET ATOM-TYPE
                    CALL GEN048 (-4, IFG(1, J), 15, NO2)
                    IENJ   = IEN(NO2 + 1)
                    IATPRJ = IATPR(IENJ)
                    IF (IATPRJ <= 0 .OR. NUMO >= 0) THEN
                      IPR(510) = IENJ
C * SPECIAL METAL..O,N,B TEST
                      CALL PLA041 (IATPRJ, 1)
                      IF (IPR(191) * IENJ == 20 .OR.
     1                  IPR(192) * IENI == 20) THEN
                        IF (NUMH < 0) THEN
                          PAR(23) = 0.0
                        ELSE
                          PAR(23) = RADR(NO1 + 1, 2) + RADR(NO2 + 1, 2)
     1                            + 0.05
                        END IF
                      ELSE
                        PAR(23) = DMX + RADR(NO2 + 1, 2) + PAR(293)
                      END IF
                      IF (IENI == 1 .OR. IENJ == 1) THEN
                      END IF
C * SPECIAL SI-ND
                      IF ((IENI == 63 .AND. IENJ == 85) .OR.
     1                    (IENI == 85 .AND. IENJ == 63)) THEN
                        IF (DISTIJ > 3.1) PAR(23) = 0.0
                      END IF
C * AVOID CU-CU, NI-NI, CO-CO, MN-MN, TI-TI, ZN-ZN, CU-NI ETC
                      YUNK = PLA395 (IENI, IENJ)
                      IF (YUNK < -9.0) THEN
                        PAR(23) = 2.0
                      ELSE
                        PAR(23) = PAR(23) + YUNK
                      END IF
                      CALL GEN048 (-8, IFG(2, J), 1, IDS2)
                      IDS2 = IPPR(IDS2 + 1, 1)
                      CALL GEN048 (-5, IFG(3, J), 14, IVL)
                      IPRT2 = IVL - 16
C * CHECK FOR NON-CONTACTS BASED ON PART NUMBERS
                      JUNK = 0
                      IF (IPRT1 /= IPRT2) THEN
                        IF (IPRT1 == 0 .OR. IPRT2 == 0) JUNK = 1
                      ELSE IF (IPRT1 == IPRT2) THEN
                        JUNK = 1
                      END IF
                      IF (JUNK == 1) THEN
C * AVOID DISORDER-DISORDER CONNECTIONS
                        IF (IDS1 < 10000 .AND. IDS2 < 10000) THEN
C * CHECK FOR PART # (IF ANY)
                          IF (IDS1 == 5000 .AND. IDS2 == 5000) THEN
                            IF (ABS (IPRT1) > 0 .AND.
     1                          ABS (IPRT2) > 0) THEN
                              IF (IPRT1 /= IPRT2) CYCLE
                            END IF
                          END IF
                          IF (ABS (IDS1 - IDS2) > 1) THEN
                            IF (IABS (2 * IDS1 - IDS2) > 1 .AND.
     1                          IABS (2 * IDS2 - IDS1) > 1) THEN
                              IF (IPRT1 /= IPRT2 .OR.
     1                        (IPRT1 == 0 .AND. IPRT2 == 0)) CYCLE
                            END IF
                          END IF
C * HANDLE SPECIAL DISORDER FORMS
                          IF (IPR(154) == 0) THEN
                            MNI = MOD (LABA(I), IPR(463))
                            MNJ = MOD (LABA(J), IPR(463))
                            IF (IPRT1 < 0 .AND. IPRT2 < 0) THEN
                              IF (IPRT1 == IPRT2 .AND. MNI /= MNJ)
     1                          CYCLE
                            END IF
                            CALL GEN048 (-1, IFG(1, J), 6, JSPPOS)
                            IF (IDS1 == 5000 .AND. MNI /= MNJ
     1                       .AND. JSPPOS == 0) CYCLE
                          END IF
                        END IF
                        IF (DISTIJ <= PAR(23) .AND. DISTIJ > 0.1)
     1                    THEN
C * AVOID SOME LONG METAL-N,P,B BONDS WHEN SHORTER ONE PRESENT
                          IF (IATPRJ > 0) THEN
                            IF (IENI == 4 .OR. IENI == 8 .OR.
     1                        IENI == 20) THEN
                              NUMB = 0
                              IBREAK = 0
                              DO K = 1, NAT
                                IF (K /= I .AND. K /= J) THEN
C * H-ATOM ?
                                  CALL GEN048 (-1, IFG(1, K), 7, KHAT)
C * POPULATION PARAMETER
                                  CALL GEN048 (-8, IFG(2, K), 1, IDS3)
                                  IDS3 = IPPR(IDS3 + 1, 1)
                                  IF (IDS3 == 10000) THEN
C * LOOK FOR ATOMS BONDED COVALENTLY TO I
                                    CALL PLA050 (K, I, 0, 0, DIST)
                                    IF (IENI == 8) THEN
                                      IF (KHAT == 1) THEN
                                        IF (DIST < 1.7)
     1                                    NUMB = NUMB + 1
                                      ELSE
                                        IF (DIST < 1.9)
     1                                    NUMB = NUMB + 1
                                      END IF
                                    END IF
                                    IF (DIST < 1.7) THEN
                                      CALL PLA050 (J, I, K, 0, ANGLE)
                                      IF (ANGLE < 45.0) THEN
                                        IBREAK = 1
                                      END IF
                                    END IF
                                  END IF
                                END IF
                              END DO
                              IF (IBREAK /= 0) CYCLE
                              IF (IENI == 8 .AND. NUMB == 4)
     1                          CYCLE
                            END IF
                          ELSE IF (IATPRI > 0) THEN
                            IF (IENJ == 4 .OR. IENJ == 8
     1                          .OR. IENJ == 20) THEN
                              NUMB   = 0
                              IBREAK = 0
                              DO K = 1, NAT
                                IF (K /= I .AND. K /= J) THEN
C * H-ATOM ?
                                  CALL GEN048 (-1, IFG(1, K), 7, KHAT)
C * LOOK FOR ATOMS BONDED COVALENTLY TO J
                                  CALL GEN048 (-8, IFG(2, K), 1, IDS3)
                                  IDS3 = IPPR(IDS3 + 1, 1)
                                  IF (IDS3 == 10000) THEN
                                    CALL PLA050 (K, J, 0, 0, DIST)
                                    IF (IENI == 8) THEN
                                      IF (KHAT == 1) THEN
                                        IF (DIST < 1.7)
     1                                    NUMB = NUMB + 1
                                      ELSE
                                        IF (DIST < 1.9)
     1                                    NUMB = NUMB + 1
                                      END IF
                                    END IF
                                    IF (DIST < 1.7) THEN
                                      CALL PLA050 (I, J, K, 0, ANGLE)
                                      IF (ANGLE < 45.0) THEN
                                        IBREAK = 1
                                        EXIT
                                      END IF
                                    END IF
                                  END IF
                                END IF
                              END DO
                              IF (IBREAK /= 0) CYCLE
                              IF (IENJ == 8 .AND. NUMB == 4)
     1                          CYCLE
                            END IF
                          END IF
                          IVAL = 0
                          CALL PLA040 ( 1, I, IVAL, J)
                          CALL PLA040 (-1, J, IVAL, I)
                          IF (IVAL <= 0) CALL PLA040 (1, J, IVAL, I)
                        END IF
C * DISTIJ TEST
                      END IF
C * END JUNK TEST
                    END IF
C * END IATPRJ/NUMO TEST
                  END IF
C * CHECK FOR IATPRI &CO2,NO3,SO4,ClO4,PO4 bit
                END IF
C * END NON-HYDROGEN TEST
              END IF
C * END IRES(I/J) TEST
            END IF
C * END DIST TEST
          END DO
C * END OF LOOP ON ATOM-J
        END IF
      END DO
C * ORDER RESIDUES (MODIFY MLTI)
      IF (NRES > 1) THEN
        IF (IPR(597) == 1) CALL GEN022 (IRCONT, 1, NRES, 1)
        DO I = 1, NRES
          MLTI(I)   = MOD (IRCONT(I), 1000) - 1
          IRCONT(I) = IRCONT(I) / 1000
          J         = MOD (IRCONT(I), 100)
          JRCONT(J) = I
        END DO
        NMOL = IPR(13)
C * MODIFY RESIDUE NUMBERS IN MOL-LIST
        IF (NMOL > 1) THEN
          DO J = 2, NMOL
            CALL GEN098 (MOL(J), PAR(42), IS1, IX1, IY1, IZ1, IR1)
C * WHY IR1 = 0 ? TEMPORARY FIX
            IF (IR1 > 0) THEN
              MOL(J) = (IS1 * 1000 + IX1 * 100 + IY1 * 10 + IZ1 + 555) *
     1                IARU + JRCONT(IR1)
            END IF
          END DO
        END IF
C * CORRECT POLYMER DATA FOR RESIDUE NUMBER CHANGE
        IF (MXNW > 0) THEN
          DO J = 1, MXNW
            JUNK = NETW(J, 1)
            NETW(J, 1) = JRCONT(JUNK)
            MPOL(JRCONT(JUNK)) = NETW(J, 2)
          END DO
        END IF
C * CORRECT POLYMER INFO
C * COPY NPOL TO NPOLSV
        CALL GEN133 (NPOL, NPOLSV, NP29)
        DO J = 1, NRES
          NPOL(J) = NPOLSV(JRCONT(J))
        END DO
      END IF
      I = 0
      DO WHILE (I < NAT)
        I = I + 1
C * COPY (ATP/TRNS)
        NTRNS(I) = IATP(I)
C * MODIFY RESIDUE NUMBER
        IF (NRES > 1) THEN
          CALL GEN048 (-6, IFG(1, I), 9, IVAL)
          IF (IVAL /= JRCONT(IVAL)) THEN
            CALL GEN048 ( 6, IFG(1, I), 9, JRCONT(IVAL))
          END IF
        END IF
C * ROUND COORDINATES
        IF (IPR(72) == 1) THEN
          DO 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
          END DO
C * ORTHOGONALIZE
          CALL PLA059 (I, I)
        END IF
      END DO
      IPR(51) = IPR(13)
C * RESET DO/AC FOR S/N WITH O COORDN
   60 DO IAT = 1, IPR(39)
C * IS THIS A DONOR/ACCEPTOR ATOM
        CALL GEN048 (-1, IFG(1, IAT), 23, IDAC)
        IF (IDAC == 1) THEN
C * GET ELEMENT TYPE
          CALL GEN048 (-4, IFG(1, IAT), 15, NO1)
          IENI = IEN(NO1 + 1)
          IF (IENI == 4 .OR. IENI == 6) THEN
            NC = - NINT (CON(IAT, 9))
            IF (NC > 0) THEN
              NRBO = 0
              DO JJ = 1, NC
                KK = NINT (CON(IAT, JJ))
                CALL GEN048 (-4, IFG(1, KK), 15, NO2)
                IENK = IEN(NO2 + 1)
                IF (IENK == 3) NRBO = NRBO + 1
              END DO
              IF (NRBO > 2) THEN
                CALL GEN048 (1, IFG(1, IAT), 23, 0)
              END IF
            END IF
          END IF
        END IF
      END DO
C * VOID - SCRATCH LAYOUT FOR TEMP STORAGE OF DATA LISTED BELOW
C * 1 ==> IPR(297)  = XXO, XSD, CON, XSD(4:6)=LABEL POS SAVE AREA
      IPR(297) = NP1 * NP71
C * IPR(297) + 1 ==> IPR(298) = ADP
C * FROM IPR(298) = BONDS
      IPR(298) = IPR(297) + NP1 * 21
C * GENERATE AND WRITE BONDS TO SCRATCH (FOR PLA077,114 AND PLA106-**)
      IPR(131) = 0
C * FIRST NON-H BONDS (IPR(133) = 0), WITH H-ATOMS NEXT (IPR(133)=1)
      IPR(133) = -1
      DO
        IPR(133) = IPR(133) + 1
        IF (IPR(133) > 1) EXIT
        IFIN = -2
        DO
          CALL PLA038 (I, J, IFIN)
          IF (IFIN == 1) EXIT
C * ADD BOND TO LIST
          CALL PLA268 (I, J, 1, 1.0)
        END DO
      END DO
C * R/S DETERMINATION (AFTER HEAVILY MODIFIED A. VINTER CODE)
C * NO POLYMERS, ORGANIC/ORGANOMETALLIC
      IF (MODE >= 0 .AND. IPR(324) == 1 .AND. IPR(739) == 0 .AND.
     1  IPR(431) == 0 .AND. IGBL(129) <= 0 .AND. IGBL(3) /= 3 .AND.
     2  IGBL(97) == 1 .AND. IPR(744) == 0 .AND. IGBL(144) == 0) THEN
        CALL PLA030 (LABA, XXO, CON, JATC, IFG, IPPR,
     1  VOID(IPR(298) + 1))
C * R/S ALERTS (IGNORE IN CASE OF GEOMETRY ALERTS)
C * TEMPORARILY SUPPRESSED
        IF (IPR(749) == 0) THEN
          DO I = 1, IPR(37)
            CALL GEN048 (-2, IFG(1, I), 28, ICHIRAL)
            IF (IABS (2 - ICHIRAL) == 1) THEN
              CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, IPR(71),
     1                    IGBL(55), 0, 1 - IGBL(55))
              IF (ICHIRAL == 1) THEN
                NQ2 = '        S'
              ELSE
                NQ2 = '        R'
              END IF
              IF (CHSG(1:1) == 'C') THEN
C * ALERT _791 - CHIRAL ATOM IN CHIRAL SPACE GROUP
                CALL PLA236 (791, 0, -999.0, 0.0, NQ1, NQ2)
              ELSE
                IF (IPR(275) == 1) THEN
C * ALERT _792 - CHIRAL ATOM IN POLAR SPACE GROUP
                  CALL PLA236 (792, 0, -999.0, 0.0, NQ1, NQ2)
                ELSE
C * ALERT _793 - CHIRAL ATOM IN CENTRO SPACE GROUP
                  CALL PLA236 (793, 0, -999.0, 0.0, NQ1, NQ2)
                END IF
              END IF
            END IF
          END DO
        END IF
C * GENERAL AUTO-RENUMBERING
        IF (IPR(501) == 1) CALL PLA228
      END IF
      RETURN
      END SUBROUTINE PLA072
 
      SUBROUTINE PLA073 (LIST, NSMPR)
C * OUTPUT OF ATOM TABLES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER :: NMA = 550
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: KL
      INTEGER            :: KN
      INTEGER            :: N0
      INTEGER            :: IP
      INTEGER            :: NO1
      INTEGER            :: NO2
      INTEGER            :: NDC
      INTEGER            :: IPP
      INTEGER            :: NAT
      INTEGER            :: ISU
      INTEGER            :: NDEC
      INTEGER            :: NRAT
      INTEGER            :: NDEF
      INTEGER            :: NDIS
      INTEGER            :: MULT
      INTEGER            :: NDLP
      INTEGER            :: LIST
      INTEGER            :: IAH0
      INTEGER            :: IDA0
      INTEGER            :: IDH0
      INTEGER            :: IDUM
      INTEGER            :: JDUM
      INTEGER            :: NATX
      INTEGER            :: NRES
      INTEGER            :: NSYM
      INTEGER            :: LRES
      INTEGER            :: NHAT
      INTEGER            :: IHAT
      INTEGER            :: IMET
      INTEGER            :: ISP1
      INTEGER            :: NRES0
      INTEGER            :: NDLPM
      INTEGER            :: IVLAG
      INTEGER            :: IYUNK
      INTEGER            :: IRESI
      INTEGER            :: IPPAR
      INTEGER            :: IDIS1
      INTEGER            :: LTYPE
      INTEGER            :: NSMPR
      INTEGER            :: GEN152
      REAL               :: SOF
      REAL               :: SPAR
      REAL               :: PPAR
      REAL               :: YUNK
      REAL               :: ATTRS
      REAL               :: ATWTL
      REAL               :: XSIGMA
      CHARACTER(len=109) :: FORMX
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=1)   :: IYSP1
      CHARACTER(len=4)   :: NRND
      CHARACTER(len=4)   :: VLAG
      CHARACTER(len=3)   :: KTYPE
      CHARACTER(len=6)   :: SPSITE
      CHARACTER(len=8)   :: MOVE
      IWIN = IGBL(25) * IGBL(32)
C * LIST =  1 : LIST  ATOMS ON DISPLAY
C * LIST = -1 : PRINT ATOMS
      KL   = IPR(220)
      KN   = IPR(221)
C * GET NUMBER OF PRIMARY ATOMS
      NATX = IPR(37)
C * GET NUMBER OF ATOMS IN EXPANDED ATOM LIST
      NAT  = IPR(39)
C * GET NUMBER OF RESIDUES
      NRES = IPR(75)
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
C * SELECT CRITERIA FOR DISPLAY LIST (0 = ALL)
      LTYPE = 0
      LRES  = 0
      NHAT  = 0
C * LIST ATOMS
      IF (LIST > 0) THEN
        IF (IWIN == 1) CALL GGIP (HORS, VERT, 0.0, 1)
        IF (LIST == 1) NAT = NAT + IPR(64)
        IF (KN > 0) LRES = NINT (FN(1))
        IF (KL > 2) CALL PLA037 (3, LTYPE, 2)
        NDLPM = 1
        IF (IPR(23) == 0) THEN
          WRITE (PRBUF, 99979, IOSTAT = IOST) 'Fractional'
        ELSE
          WRITE (PRBUF, 99979, IOSTAT = IOST) 'Angstrom  '
        END IF
        IF (IWIN == 1) THEN
          VRT = VERT - 0.4
          CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                 1.0, VRT)
          VRT = VRT - 0.2
        ELSE
          WRITE (LU6, 99983, IOSTAT = IOST) PRBUF(1:80)
        END IF
      ELSE
        NDLPM = 2
        PAGET = 'GEOMETRY'
        IF (IPR(113) /= 0) GO TO 30
        IPR(113) = 1
        IF (IGBL(63) > 1) THEN
          IF (IPR(23) == 0) THEN
            CALL PLA262 (0)
          ELSE
C * PRINT ANGSTROM SCALE
            CALL PLA262 (3)
            WRITE (LU7, 99977,IOSTAT = IOST) PAR(11)
          END IF
        END IF
        IF (IPR(72) == 0 .OR. IPR(68) == 0) THEN
          NRND = ' Not'
        ELSE
          CALL GEN040 (IPR(68) * 10 - 1, NQ1, IP)
          NRND = '1:'//NQ1(1:2)
        END IF
C * GET SHELDRICK TYPE ROUNDED ATOM WEIGHTS
        DO I = 1, IAN
          K = IENS(I)
          L = IEN(K)
          IF (IPR(181) == 1) THEN
            IF (L == 1) THEN
              YUNK = 1000.0
            ELSE
              YUNK = 100.0
            END IF
C * HANDLE 106.42/106.40 INCONSISTENCY FOR PD/SHELXL97
            ATWTL = ATWT(L)
            IF (ATWTL == 106.42) ATWTL = 106.40
            SATWT(K) = NINT (ATWTL * YUNK) / YUNK
          ELSE
            SATWT(K) = ATWT(L)
          END IF
        END DO
        DO I = 1, IAN
          J = IEN(IENS(I))
          IF (IABS (IPR(493)) /= 7) THEN
            J     = (J - 1) * 19
            FN(I) = 0.0
            DO K = 1, 9, 2
              FN(I) = FN(I) + SFAC(J + K)
            END DO
          ELSE
            FN(I) = RNSCL(J)
          END IF
C * GET Z-MAX
          IPR(22) = MAX (IPR(22), IATNR(IEN(IENS(I))))
        END DO
C * TEST FOR PRINT LEVEL
        IF (IGBL(63) > 3) THEN
          CALL PLA262 (16)
          WRITE (LU7, 99997, IOSTAT = IOST) NRND
          WRITE (LU7, 99991, IOSTAT = IOST)
     1      (LMT(IENS(I), 1), I = 1, IAN)
          WRITE (LU7, 99994, IOSTAT = IOST)
     1      (RADR(IENS(I), 2),    I = 1, IAN)
          WRITE (LU7, 99984, IOSTAT = IOST)
     1      (ATVOL(IEN(IENS(I))), I = 1, IAN)
          WRITE (LU7, 99992, IOSTAT = IOST)
     1      (IATNR(IEN(IENS(I))), I = 1, IAN)
          WRITE (LU7, 99993, IOSTAT = IOST)
     1      (SATWT(IENS(I)),      I = 1, IAN)
          IF (IABS (IPR(493)) < 7) THEN
            WRITE (LU7, 99987, IOSTAT = IOST) (FN(I), I = 1, IAN)
          ELSE IF (IABS (IPR(493)) == 7) THEN
            WRITE (LU7, 99988, IOSTAT = IOST) (FN(I), I = 1, IAN)
          ELSE IF (IABS (IPR(493)) == 8) THEN
          END IF
        END IF
C * ANOMALOUS SCATTERING AND ABSORPTION CONTRIBUTIONS
        CALL PLA340
C * REPORT ON THE SOURCE OF THE ATOMIC WEIGHTS
        IF (IGBL(63) > 3) THEN
          IF (IPR(181) == 1) THEN
            NQ2 = 'SHELXL '
            NQ3 = ' '
          ELSE
            NQ2 = 'IUPAC 1'
            NQ3 = '993'
          END IF
          CALL PLA262 (6)
          IF (IGBL(30) == 1) THEN
            NQ1 = 'NOMOVE'
          ELSE
            NQ1 = ' '
          END IF
          WRITE (LU7, 99995, IOSTAT = IOST) NQ2(1:7), NQ3(1:7), NQ1(1:7)
        END IF
C * ATOM LIST OUTPUT FORMAT
        IF (IPR(23) == 0) THEN
          FORMX(1:8)    = '(A,1X,A,'
          FORMX(9:47)   = ' F9.0,A,I2,A,F11.0,A,I2,A,F11.0,A,I2,A,'
          FORMX(48:88)  = 'F8.0,A,I2,A,F8.0,A,I2,A,F8.0,A,I2,A,A,I3,'
          FORMX(89:109) = '2F6.3,A,I3,A,A,1X,A3)'
        ELSE
          FORMX(1:37)   = '(I4,1X,A,42X,F9.0,A,I2,A,F9.0,A,I2,A,'
          FORMX(38:56)  = 'F9.0,A,I2,A,35X,A3)'
        END IF
      END IF
C * LOOP OVER RESIDUES
      IF (NRES == 0) THEN
        NRES0 = 0
      ELSE
        NRES0 = 1
      END IF
      DO N = NRES0, NRES
        IF (LIST > 0) THEN
          IF (IWIN == 0) THEN
            IF (NRES > 1) WRITE (LU6, 99982, IOSTAT = IOST) N
          END IF
        ELSE
          IF (IGBL(63) > 2) THEN
            IF (NRES > 1) THEN
              CALL PLA262 (5)
              WRITE (LU7, 99981, IOSTAT = IOST) N
            END IF
            CALL PLA262 (3)
            WRITE (LU7, 99989, IOSTAT = IOST)
          END IF
        END IF
        NHAT = 0
        NDIS = 0
        DO NDLP = 1, NDLPM
          NRAT = 0
          DO 20 I = 1, NAT
C * GET  RESIDUE NUMBER
            CALL GEN048 (-6, IFG(1, I), 9, IRESI)
            IF (N == IRESI) THEN
C * LOAD LABEL+DISORDER INFO
              CALL PLA036 (I, 1, 1, IDIS1, IDUM, ISP1, IPR(71),
     1                     IGBL(55))
C * GET DONOR/ACCEPTOR BIT
              CALL GEN048 (-1, IFG(1, I), 23, IDA0)
C * GET POTENTIAL H-BOND H-ATOM
              CALL GEN048 (-1, IFG(1, I), 20, IDH0)
C * GET METAL BIT
              CALL GEN048 (-1, IFG(1, I), 19, IMET)
C * HATOM
              CALL GEN048 (-1, IFG(1, I), 7,  IHAT)
C * SU OF H
              CALL GEN048 (-1, IFG(2, I), 10, ISU)
C * COUNT NUMBER OF NOT REFINED D-H ATOMS
              IF (I <= IPR(37) .AND. NDLP == 1) THEN
                IF (IDH0 /= 0 .AND. ISU == 0) THEN
                  IPR(658) = IPR(658) + 1
                  IF (IPR(658) <= NP85) THEN
                    CALL PLA047 (LABA(I), NQ2, IDUM, JDUM,
     1                IPR(71), IGBL(55), 0, 0)
                    CNRH(IPR(658)) = NQ2(1:6)
                  END IF
                END IF
              END IF
C * VLAG
              VLAG = '-   '
              IF (IABS(IGBL(8)) == 3) THEN
                CALL GEN048 (-1, IFG(3, I), 1, IVLAG)
                IF (IVLAG == 1) VLAG(1:1) = 'd'
                CALL GEN048 (-1, IFG(3, I), 2, IVLAG)
                IF (IVLAG == 1) VLAG(1:1) = 'c'
                K = 1
                DO J = 4, 10
                  CALL GEN048 (-1, IFG(3, I), J, IVLAG)
                  IF (IVLAG == 1) THEN
                    IF (K < 4) THEN
                      K = K + 1
                      VLAG(K:K) = CVLAG(J - 3)
                    END IF
                  END IF
                END DO
              END IF
C * TEST FOR 'PRINT-MODE'
              IF (LIST < 0) THEN
C * ROUND
                DO J = 1, 3
                  XSIGMA = SQRT (XSD(I, J))
                  IF (IHAT == 1) THEN
                    NDEF = 5
                  ELSE IF (INT (XSIGMA * 100000.0)  == 0 .AND.
     1                     INT (XSIGMA * 1000000.0) > 0) THEN
                    NDEF = 6
                  ELSE
                    NDEF = 5
                  END IF
                  CALL GEN041 (XXO(I, J), XSIGMA, IXSD(J),
     1                         NDEF, NDEC, IPR(68))
                  XSD(I, J) = XSIGMA ** 2
                  IF (IPR(23) == 0) THEN
                    NDC           = J * 13
C * MODIFY NUMBER OF DECIMAL DIGITS
                    FORMX(NDC:NDC) = CHAR(ICHAR('0') + NDEC)
                  END IF
                  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, IPR(68))
                  IF (IPR(23) == 0) THEN
                    NDC = J * 12 + 39
                  ELSE
                    NDC = J * 12 + 5
                  END IF
                  FORMX(NDC:NDC) = CHAR (ICHAR ('0') + NDEC)
                  IXSD(J + 3)   = MIN (99, IYUNK)
                END DO
              END IF
C * GET ELEMENT TYPE
              CALL GEN048 (-4, IFG(1, I), 15, NO1)
              NO1 = NO1 + 1
C * TEST FOR CL,S,P TYPE AND RESET DOAC FLAG FOR 4-COORDINATED CL,S,P
              IF (IEN(NO1) == 5 .OR. IEN(NO1) == 6 .OR.
     1            IEN(NO1) == 8) THEN
                IF (NINT (CON(I, 9)) < -3) THEN
                  IDA0 = 0
                  CALL GEN048 (1, IFG(1, I), 23, IDA0)
                END IF
              END IF
C * REGISTER B-H
              IAH0 = 0
              IF (IHAT == 1) THEN
                IF (NINT (CON(I, 9)) == -1) THEN
                  J = NINT (CON(I, 1))
                  CALL GEN048 (-4, IFG(1, J), 15, NO2)
                  IF (IEN(NO2 + 1) == 20) THEN
                    IAH0 = 1
                    CALL GEN048 (1, IFG(2, I), 28, 1)
                  END IF
                END IF
              END IF
C * GENERATE BLANK LINE BETWEEN NON-H AND H-ATOMS
              IF (NDLP == 1) THEN
                IF (LIST < 0) THEN
                  IF (IHAT == 1) THEN
                    IF (NHAT == 0) THEN
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99976, IOSTAT = IOST)
                      END IF
                      NHAT = 1
                    END IF
                  ELSE
                    IF (NHAT == 1) THEN
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99976, IOSTAT = IOST)
                      END IF
                      NHAT = 0
                    END IF
                  END IF
                END IF
              END IF
              IF (ISP1 == 1) THEN
                IYSP1   = 'S'
                SGY(1)  = XXO(I, 1)
                SGY(2)  = XXO(I, 2)
                SGY(3)  = XXO(I, 3)
                SGY(10) = 0.0
                CALL SGSM (19, LINE, SGY, 0, LU6, IERR)
                SPSITE = ' '//LINE(1:5)
              ELSE
                IYSP1  = ' '
                SPSITE = '      '
              END IF
              KTYPE = ' - '
              IF (IAH0 == 1) KTYPE = 'A-H'
              IF (IDA0 == 1) KTYPE = 'D/A'
              IF (IDH0 == 1) KTYPE = 'D-H'
              IF (IMET == 1) KTYPE = 'Met'
C * GET POPULATION PARAMETER
              CALL GEN048 (-8, IFG(2, I), 1, IPP)
              IPP  = IPP + 1
              PPAR = IPPR(IPP, 1) / 10000.0
              SPAR = IPPR(IPP, 2) / 10000.0
              IF (IPPR(IPP, 1) < 10000) THEN
C * GET FIXED POPULATION PARAMETER FLAG
                CALL GEN048 (-1, IFG(2, I), 29, IYUNK)
C * ALERT _300 - FIXED OCCUPANCY
                IF (IYUNK == 0 .AND. LIST < 0 .AND. NDLP == 1
     1            .AND. I <= IPR(37)) THEN
                  IF (PPAR == 0.0) THEN
                    N0 = 1
                  ELSE
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
                    N0 = GEN152 (PPAR)
                  END IF
                  IF (PPAR == 0.5 .AND. IPR(784) < NP86) THEN
                    IPR(784) = IPR(784) + 1
                    PLAB(IPR(784)) = NAMS(1, 1)(2:10)
                  ELSE
                    CALL PLA236 (300, N0, -999.0, PPAR,
     1                NAMS(1, 1)(2:10), ' ')
                  END IF
                END IF
              END IF
              CALL GEN041 (PPAR, SPAR, IPPAR, 3, NDEC, IPR(68))
              IF (IPR(23) == 0) FORMX(93:93) =
     1          CHAR (ICHAR ('0') + NDEC)
              MULT  = NSYM / IPPR(IPP, 3)
              SOF   = PPAR / MULT
              ATTRS = NTRNS(I) / 1000.0
              IF (LIST > 0) THEN
                IF (LTYPE == 0   .AND. LRES == 0 .OR.
     1              LTYPE == 0   .AND. LRES == N .OR.
     2              LTYPE == NO1 .AND. LRES == 0 .OR.
     3              LTYPE == NO1 .AND. LRES == N) THEN
                  IF (IPR(23) == 0) THEN
                    WRITE (PRBUF, 99978, IOSTAT = IOST)
     1                I, NAMS(1, 1)(1:10), (XXO(I, K), K = 1, 3),
     2              RADR(NO1, 2), IYSP1, MULT, PPAR, ATTRS, KTYPE
                  ELSE
                    WRITE (PRBUF, 99996, IOSTAT = IOST)
     1                I, NAMS(1, 1)(1:10), (XXO(I, K), K = 1, 3),
     2              RADR(NO1, 2), IYSP1, MULT, PPAR, ATTRS, KTYPE
                  END IF
                  K = INDEX (PRBUF, ' 1.000 ')
                  IF (K > 0) PRBUF(K:K+5) = '   -  '
                  K = INDEX (PRBUF, ' 1.555 ')
                  IF (K > 0) PRBUF(K:K+5) = '   -  '
                  IF (IWIN == 1) THEN
                    IF (VRT - 0.4 < 0) THEN
C * WHAT NEXT ?
                      CALL PLA012 (1, 1)
                      ICH = IGGT(1:1)
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      IF (ICH /= 'Y' .AND. ICH /= '!') GO TO 40
                      VRT = VERT
                    END IF
                    VRT = VRT - 0.4
                    CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                  ELSE
                    WRITE (LU6, 99980, IOSTAT = IOST) PRBUF(1:80)
                  END IF
                END IF
              ELSE
                IF (PPAR < 0.5) THEN
                  IF (NDLP == 1) GO TO 20
                  NDIS = NDIS + 1
                  IF (NDIS < 2) THEN
                    IF (IGBL(63) > 2) THEN
                      CALL PLA262 (4)
                      WRITE (LU7, 99999, IOSTAT = IOST) '<'
                    END IF
                  END IF
                  GO TO 10
                END IF
                IF (NDLP == 2) GO TO 20
   10           NRAT = NRAT + 1
                MOVE = '    -   '
                IF (NINT(ATTRS * 1000.0) /=  1555)
     1              WRITE (MOVE, 99974, IOSTAT = IOST) ATTRS
C * TEST FOR ANGSTROM/FRACTIONAL COORDINATES
                IF (IPR(23) == 0) THEN
C * COUNT MOVED PRIMARY ATOMS
                  IF (IATP(I) /= 1555 .AND. I <= NATX) THEN
                      IPR(204) = IPR(204) + 1
                  END IF
                  WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1              VLAG, NAMS(1, 1)(1:10), (XXO(I, K),
     2              '(', IXSD(K), ')', K = 1, 6), SPSITE, MULT, SOF,
     3              PPAR, '(', IPPAR, ')', MOVE, KTYPE
                ELSE
                  WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1              NRAT, NAMS(1, 1)(1:10), (XXO(I, K),
     1              '(', IXSD(K), ')', K = 4, 6), KTYPE
                END IF
                IF (IGBL(63) > 2)
     1            CALL PLA263 (LU7, PRBUF, 132, 1, 7)
              END IF
            END IF
   20     CONTINUE
        END DO
      END DO
C * CHECK FOR PRINT MODE
      IF (LIST <= 0) THEN
C * OUTPUT SYMMETRY CODE LIST
        IF (IPR(23) == 0 .AND. IPR(13) > 1) THEN
          CALL PLA262 (0)
          CALL PLA043 (NSMPR, 1, LU7, 0)
        END IF
C * LIST UNITCELL CONTENT
        CALL PLA080
C * SKIP IN CASE OF VALIDATION OR ORTEP
        IF (IGBL(3) /= 1 .AND. IGBL(3) /= 3) THEN
C * NONSYM  (MOLSYM)
C * CHECK FOR NON-EXPAND MODE, NON PLUTON-AUTO AND NO SOLV/VOID/SQUEEZE
          IF (IPR(495) /= 0 .AND. IPR(200) == 0 .AND.
     1      IPR(14) /= 6) THEN
C * CHECK FOR NON-POLYMER AND NON-ORTEP MODE
            IF (IPR(739) == 0 .AND. IGBL(3) /= 28) THEN
              IF (IGBL(3) /= 1 .AND. IPR(39) < NMA) THEN
                IF (IPR(23) == 0 .OR. IPR(495) == 3) THEN
                  CALL PLA211 (JID, 1)
                  CALL PLA211 (JID, 2)
                END IF
              ELSE
                WRITE (LU6, 99975, IOSTAT = IOST)
              END IF
              IF (IPR(495) == 1 .OR. IPR(495) == 3) CALL PLA085
            END IF
          END IF
        END IF
      END IF
   30 IF (IWIN == 1 .AND. LIST > 0) CALL PLA297 (0)
   40 RETURN
99999 FORMAT (/, 'Disordered Atoms with S.O.F ', A, ' 0.5', /)
99997 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('-'))
99996 FORMAT (I4, 1X, A, F8.4, 2F9.4, F7.2, 2X, A, I4, F7.3, F8.3,
     1 2X, A3)
99995 FORMAT (132('-'), /, 'Sources - Cov. Radii : Manual Cambridge',
     1  ' Crystallographic Data Base', /, 8X,
     2  '- Atom Volume: D.W.M. Hofmann (2002). Acta Cryst. B58,',
     3  ' 489-493', /, 8X,
     4  '- Atomic Wt. : ', 2A, 89X, A, /, 8X,
     5  '- Scat. Fact.: SHELXL (International Tables)', /, 8X,
     6  '- mu/rho     : International Tables C, Table 4.2.4.2, 193-199',
     7 ' - [Multiply by Atom Weight and 1.66054 for Barns/atom values]')
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))
99989 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('-'))
99988 FORMAT ('NScat.Length:', 16F7.3)
99987 FORMAT ('Scat.Fact.f0:', 16F7.3)
99984 FORMAT ('Atom Volume :', 16F7.2)
99983 FORMAT (/, A, /)
99982 FORMAT (/, 34X, 'Residue =', I4, /)
99981 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='), /)
99980 FORMAT (A)
99979 FORMAT ('Atom  Label', 7X, A,' 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 ('Angstrom coordinates. - Input data multiplied by:',
     1         F15.5, //)
99976 FORMAT (1X)
99975 FORMAT (':: Too Many Atoms for MOLSYM')
99974 FORMAT (F8.3)
      END SUBROUTINE PLA073
 
      SUBROUTINE PLA074 (LIST, NSMPR)
C * OUTPUT OF CONNECTION TABLES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: J1
      INTEGER            :: J2
      INTEGER            :: JJ
      INTEGER            :: KK
      INTEGER            :: LL
      INTEGER            :: KL
      INTEGER            :: KN
      INTEGER            :: IP
      INTEGER            :: NC
      INTEGER            :: MRS
      INTEGER            :: NC0
      INTEGER            :: NC1
      INTEGER            :: NCK
      INTEGER            :: LNR
      INTEGER            :: KMT
      INTEGER            :: JX1
      INTEGER            :: IAT
      INTEGER            :: KAT
      INTEGER            :: LAT
      INTEGER            :: NAT
      INTEGER            :: IDH
      INTEGER            :: JBN
      INTEGER            :: NC2
      INTEGER            :: INC
      INTEGER            :: NCL
      INTEGER            :: NO1
      INTEGER            :: NO2
      INTEGER            :: NO3
      INTEGER            :: NOK
      INTEGER            :: NOL
      INTEGER            :: NRS
      INTEGER            :: NUEQ
      INTEGER            :: NRAT
      INTEGER            :: NDIS
      INTEGER            :: NADD
      INTEGER            :: MNUM
      INTEGER            :: NDLP
      INTEGER            :: METK
      INTEGER            :: METL
      INTEGER            :: KAT1
      INTEGER            :: KAT2
      INTEGER            :: KAT3
      INTEGER            :: KATS
      INTEGER            :: JCAI
      INTEGER            :: KMET
      INTEGER            :: JDUM
      INTEGER            :: JHAT
      INTEGER            :: IPOP
      INTEGER            :: IDS1
      INTEGER            :: IDS2
      INTEGER            :: IDUM
      INTEGER            :: IDIS
      INTEGER            :: IAT1
      INTEGER            :: IAT2
      INTEGER            :: NATX
      INTEGER            :: NRES
      INTEGER            :: LRES
      INTEGER            :: LIST
      INTEGER            :: IENH
      INTEGER            :: IHAT
      INTEGER            :: IHYB
      INTEGER            :: IMET
      INTEGER            :: NANG
      INTEGER            :: NATH
      INTEGER            :: NRFL
      INTEGER            :: NROX
      INTEGER            :: IVAL
      INTEGER            :: IATAK
      INTEGER            :: NROX0
      INTEGER            :: NRMET
      INTEGER            :: NRCAR
      INTEGER            :: NHRAT
      INTEGER            :: NDLPM
      INTEGER            :: NCSUM
      INTEGER            :: NCKAT
      INTEGER            :: NBNDS
      INTEGER            :: NADD1
      INTEGER            :: NADD2
      INTEGER            :: KAT3H
      INTEGER            :: KAT2H
      INTEGER            :: KAT1M
      INTEGER            :: IVLAG
      INTEGER            :: ISPOS
      INTEGER            :: IRESI
      INTEGER            :: IHAT2
      INTEGER            :: IDUM1
      INTEGER            :: IDUM2
      INTEGER            :: IDISO
      INTEGER            :: NHATX
      INTEGER            :: NCEFF
      INTEGER            :: LTYPE
      INTEGER            :: NSMPR
      INTEGER            :: IENNO1
      INTEGER            :: IENNOK
      INTEGER            :: IENNOL
      INTEGER            :: IATALK
      INTEGER            :: IATMET
      INTEGER            :: IATCAR
      INTEGER            :: KATCAR
      INTEGER            :: KATMET
      REAL               :: HJ
      REAL               :: PNC
      REAL               :: DMN
      REAL               :: DMX
      REAL               :: ANG1
      REAL               :: ANG2
      REAL               :: ANG3
      REAL               :: DUEQ
      REAL               :: YUNK
      REAL               :: DIST
      REAL               :: PIO3
      REAL               :: VDWRI
      REAL               :: VDWRJ
      REAL               :: DISTM
      REAL               :: ANGH1
      REAL               :: ANGH2
      REAL               :: DMNNH
      REAL               :: VOLAT
      REAL               :: HJSUM
      REAL               :: VOLMOL
      REAL               :: UEQAVR
      REAL               :: DISTSUM
      REAL, DIMENSION(3) :: CORDN
      CHARACTER(len=9)   :: NQX
      CHARACTER(len=9)   :: NQY
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=1)   :: CRS
      CHARACTER(len=1)   :: NOTE
      CHARACTER(len=1)   :: NOTE1
      CHARACTER(len=3)   :: CHYB
      CHARACTER(len=4)   :: VLAG
      IWIN   = IGBL(25) * IGBL(32)
      JBN    = 0
      IATCAR = 0
      NC2    = 0
      PIO3   = 3.141592 / 3
C * LIST = 2 : LIST BONDS   (NEG - PRINT, POS - DISPLAY)
      KL    = IPR(220)
      KN    = IPR(221)
C * GET NUMBER OF PRIMARY ATOMS
      NATX  = IPR(37)
C * GET NUMBER OF ATOMS IN EXPANDED ATOM LIST
      NAT   = IPR(39)
C * GET NUMBER OF RESIDUES
      NRES  = IPR(75)
C * SELECT CRITERIA FOR DISPLAY LIST (0 = ALL)
      CRS   = ' '
      LTYPE = 0
      LRES  = 0
      NHATX = 0
      NCEFF = 0
      IF (LIST > 0) THEN
        IF (IWIN == 1) CALL GGIP (HORS, VERT, 0.0, 1)
        IF (KN > 0) LRES = NINT (FN(1))
        IF (KL > 2) CALL PLA037 (3, LTYPE, 2)
        NDLPM = 1
      ELSE
        NDLPM = 2
        PAGET = 'GEOMETRY'
      END IF
      IF (IPR(147) /= 0) THEN
C * CSD-QUE START
        IF (IGBL(31) == 4) THEN
          REWIND (UNIT = LU2, IOSTAT = IOST)
          IF (IOST /= 0) CALL GEN148 (LU2, 1)
        END IF
        VRT = 0.0
C * LOOP OVER RESIDUES
        DO N = 1, NRES
          VOLMOL = 0.0
          NRS    = N
C * TEST FOR MAJOR RESIDUE(S) = 0, ANION/SOLVENT = 1
          NADD = 0
          IF (RCONT(NRS) < IPR(487)) NADD = 1
C * CSD-QUE
          IF (IGBL(31) == 4 .AND. RCONT(NRS) > IPR(735)) THEN
            CALL GEN040 (NRS, NQ1, IP)
            WRITE (LU2, 99983, IOSTAT = IOST) NQ1(1:IP)
            JBN = NP1
          END IF
          IF (LIST < 0) THEN
C * LISTING OUTPUT
            IF (IGBL(63) > 2) THEN
              IF (NRS == 1) THEN
C * NEWPAGE
                CALL PLA262 (-11)
                WRITE (LU7, 99998, IOSTAT = IOST)
              END IF
              IF (NRES > 1) THEN
                CALL PLA262 (-5)
                WRITE (LU7, 99994, IOSTAT = IOST) NRS
              END IF
              CALL PLA262 (3)
              WRITE (LU7, 99997, IOSTAT = IOST)
            END IF
          ELSE
C * DISPLAY OUTPUT
            IF (IWIN == 0) THEN
              IF (NRES > 1) WRITE (LU6, 99995, IOSTAT = IOST) N
              WRITE (LU6, 99985, IOSTAT = IOST) PRBUF(1:80)
            END IF
          END IF
          NDIS = 0
          DO NDLP = 1, NDLPM
            NRAT  = 0
            NHRAT = 0
            MRS   = 0
            DO I = 1, NAT
              IAT    = I
              UEQAVR = 0.0
              NUEQ   = 0
              NROX   = 0
              NROX0  = 0
              NRFL   = 0
              NRCAR  = 0
C * GET RESIDUE NUMBER
              CALL GEN048 (-6, IFG(1, IAT), 9, IRESI)
              IF (NRS == IRESI) THEN
C * HATOM
                CALL GEN048 (-1, IFG(1, IAT), 7,  IHAT)
C * GET LABEL INFO
                CALL PLA036 (IAT, 1, 2, IDS1, IDUM1, IDUM2, IPR(71),
     1                       IGBL(55))
                IF (IDS1 >= 5000) THEN
                  IF (NDLP == 2) CYCLE
                ELSE
                  IF (NDLP == 1) CYCLE
                  NDIS = NDIS + 1
                  IF (NDIS == 1 .AND. IGBL(63) > 2) THEN
                    CALL PLA262 (3)
                    WRITE (LU7, 99999, IOSTAT = IOST) '<'
                  END IF
                END IF
C * GET ELEMENT TYPE
                CALL GEN048 (-4, IFG(1, IAT), 15, NO1)
                NO1 = NO1 + 1
                IATAK = IATPR(IEN(NO1))
                IF (IATAK == 5 .OR. IATAK == 6) THEN
                  IATALK = 1
                ELSE
                  IATALK = 0
                END IF
C * GET VAN DER WAALS RADIUS FOR THIS ATOM
                VDWRI = VDWR(IEN(NO1))
C * SETUP POINTER TABLE ENTRIES FOR THIS RESIDUE (CSD OPTION)
                IF (IGBL(31) == 4) THEN
                  IF (IEN(NO1) == 2) THEN
                    IATCAR = 1
                  ELSE
                    IATCAR = 0
                  END IF
                  IF (NDLP == 1 .AND. IHAT /= 1) THEN
                    NHRAT = NHRAT + 1
                    JNSC(1, IAT) = NHRAT
                  END IF
                END IF
                CALL GEN048 (-1, IFG(1, IAT), 19, IMET)
                IATMET = IMET
C * GENERATE BLANK LINE BETWEEN NON-H AND H-ATOMS
                IF (LIST < 0) THEN
                  IF (IHAT == 1) THEN
                    IF (NHATX == 0) THEN
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99986, IOSTAT = IOST)
                      END IF
                      NHATX = 1
                    END IF
                  ELSE
                    IF (NHATX == 1) THEN
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99986, IOSTAT = IOST)
                      END IF
                      NHATX = 0
                    END IF
                  END IF
                END IF
                NOTE  = ' '
                NOTE1 = ' '
                KMT   = 0
                DMX   = 0.0
                DMN   = 999.0
                DMNNH = 0.0
C * ENUMERATE ATOMS IN RESIDUE
                NRAT  = NRAT + 1
                NBNDS = 0
                NC    = - NINT (CON(IAT, 9))
                IF (NC < 0) THEN
                  NC = 9
                  CALL GEN048 (-1, IFG(1, IAT), 8, IVAL)
                  IF (IVAL > 0) NC = NC + IPR(76)
                END IF
                PNC   = 0
                NRMET = 0
                KATS  = 0
                IDISO = 0
                NCSUM = 0
                HJSUM = 0.0
C * LIMIT THE NUMBER OF THIS LOOP TO 9 (NOT NC)
                DO J = 1, 9
                  IF (J > NC) THEN
C * SET DEFAULT LABEL FIELD TO -------
                    NAMS(J, 1) = ' -------'
                  ELSE
                    IF (J <= 9) THEN
                      KAT = NINT (CON(IAT, J))
                    ELSE
                      IF (IBON(J - 9, 1) /= IAT) CYCLE
                      KAT = IBON(J - 9, 2)
                    END IF
                    KAT = MOD (KAT, NP1)
                    CALL PLA050 (IAT, KAT, 0, 0, DIST)
C * GET H-ATOM INFO
                    CALL GEN048 (-1, IFG(1, KAT), 7, JHAT)
C * GET ATOM-TYPE
                    CALL GEN048 (-4, IFG(1, KAT), 15, NO3)
                    NO3 = NO3 + 1
C * GET VAN DER WAALS RADIUS FOR THIS ATOM
                    VDWRJ = VDWR(IEN(NO3))
C * OVERLAP CORRECTION OF Van der WAALS RADII SPHERES FOR OVERLAP FOR
C * MOLVOL CALCULATION (FORMULA BIJ KITAIGORODSKII, 1973)
                    HJ = VDWRI - (VDWRI**2 + DIST**2 - VDWRJ**2) /
     1                (2.0 * DIST)
                    HJSUM = HJSUM + HJ**2 * (3 * VDWRI - HJ)
C * TEST FOR CARBON
                    IF (IEN(NO3) == 2) NRCAR = NRCAR + 1
                    IF (NRCAR == 1) THEN
                      CORDN(1) = DIST
                    ENDIF
C * TEST FOR OXYGEN
                    IF (IEN(NO3) == 3) THEN
                      NROX = NROX + 1
                      IF (NROX < 3) THEN
                        NCKAT = - NINT (CON(KAT, 9))
                        IHAT2 = -1
                        IF (NCKAT == 2) THEN
                          IAT1 = NINT (CON(KAT, 1))
                          IAT2 = NINT (CON(KAT, 2))
                          IF (IAT2 == IAT) CALL GEN014 (IAT1, IAT2)
                          CALL GEN048 (-1, IFG(1, IAT2), 7, IHAT2)
                        ENDIF
                        IF (IHAT2 /= 0) THEN
                          NROX0 = NROX0 + 1
                          CORDN(NROX0 + 1) = DIST
                          CALL GEN048 (-8, IFG(2, KAT), 1, IPOP)
                          IDISO = IDISO + IPPR (IPOP + 1, 1)
                        ENDIF
                      ENDIF
                    ELSE IF (IEN(NO3) == 38) THEN
                      NRFL = NRFL + 1
                    ENDIF
                    IF (LIST == -2 .AND. KAT <= NATX) THEN
                      IF (JHAT == 0) THEN
                        NUEQ   = NUEQ   + 1
                        UEQAVR = UEQAVR + DATC(KAT)
                        KATS   = KAT
                      END IF
                    END IF
C * GET METAL INFO
                    CALL GEN048 (-1, IFG(1, KAT), 19, KATMET)
                    NRMET = NRMET + KATMET
C * GET ELEMENT TYPE
                    CALL GEN048 (-4, IFG(1, KAT), 15, NOK)
                    NOK = NOK + 1
C * SAVE RESIDUE BONDS FOR CSD USE
                    IF (IGBL(31) == 4) THEN
                      IF (JHAT == 0 .AND. NDLP == 1) THEN
                        IF (IEN(NOK) == 2) THEN
                          KATCAR = 1
                        ELSE
                          KATCAR = 0
                        END IF
C * AVOID PI-PROBLEMS
                        IF ((IATMET /= 1 .OR. KATCAR /= 1) .AND.
     1                    (KATMET /= 1 .OR. IATCAR /= 1)) THEN
                          CALL PLA036 (KAT, 1, 2, IDS2, IDUM1, IDUM2,
     1                                 IPR(71), IGBL(55))
                          IF (IDS2 > 5000) THEN
                            NBNDS = NBNDS + 1
                            IF (KAT > IAT) THEN
                              JBN = JBN + 1
                              JNSC(1, JBN) = IAT
                              JNSC(2, JBN) = KAT
                            END IF
                          END IF
                        END IF
                      END IF
                    END IF
C * GET LABEL-INFO
                    CALL PLA036 (KAT, J, 1, IDS2, MNUM, ISPOS,
     1                           IPR(71), IGBL(55))
                    NCSUM = NCSUM + IDS2
                    CALL GEN048 (-1, IFG(1, KAT), 19, KMET)
                    KMT = KMT + 1
                    IF (IDS1 /= 0) THEN
                      PNC = PNC + MIN (1.0, FLOAT(IDS2) / FLOAT (IDS1))
                    ELSE
                      PNC = PNC + 1.0
                    END IF
                    IF (LIST < 0) THEN
                      DMX = MAX (DMX, DIST)
                      DMN = MIN (DMN, DIST)
                      IF (JHAT == 0) THEN
                        DMNNH = DMNNH + DIST
                      END IF
                      IF (KMET == 1) IMET = IMET + 1
                    END IF
                  END IF
                END DO
C * END LOOP OVER CONNECTIONS FOR CURRENT ATOM
                VOLAT = PIO3 * (4.0 * VDWRI **3 - HJSUM)
                VOLMOL = VOLMOL + VOLAT
                IF (LIST > 0) THEN
                  WRITE (PRBUF, 99992, IOSTAT = IOST)
                  IF (IWIN == 1 .AND. VRT == 0.0) THEN
                    VRT = VERT - 0.4
                    CALL PLA439 (0.0, PRBUF, 80, 0.3, 5 + IGBL(68), 2,
     1                           1.0, VRT)
                    VRT = VRT - 0.2
                  END IF
                  IF (LTYPE == 0   .AND. LRES == 0   .OR.
     1                LTYPE == 0   .AND. LRES == NRS .OR.
     2                LTYPE == NO1 .AND. LRES == 0   .OR.
     3                LTYPE == NO1 .AND. LRES == NRS) THEN
                        WRITE (PRBUF, 99991, IOSTAT = IOST) NRAT,
     1                    NAMS(1, 2)(1:8), (NAMS(L, 1)(1:8), L = 1, 8)
                    IF (IWIN == 1) THEN
                      IF (VRT - 0.4 < 0.0) THEN
C * WHAT NEXT ?
                        CALL PLA012 (1, 1)
                        ICH = IGGT(1:1)
                        CALL GGIP (HORS, VERT, 0.0, 1)
                        IF (ICH /= 'Y' .AND. ICH /= '!') RETURN
                        VRT = VERT
                      END IF
                      VRT = VRT - 0.4
                      CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0,
     1                             VRT)
                    ELSE
                      WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:80)
                    END IF
                  END IF
                  GO TO 10
                END IF
                INC = NINT (PNC)
C * TEST FOR ISOLATED METAL
                IF (IATMET == 1) THEN
C * TEST FOR INORGANIC/ORGANIC
                  IF (IGBL(97) /= 0 .AND. IATALK == 0) THEN
                    IF (NAMS(1, 2)(2:3) /= 'Cg') THEN
                      IF (IAT <= NATX) THEN
                        IF (INC == 0) THEN
C * ALERT _307 - ZERO BONDED METAL ATOM
                          CALL PLA236 (307, 1, 1.0, 1.0,
     1                      NAMS(1, 2)(2:10), ' ')
                        ELSE IF (INC == 1 .AND. IGBL(136) == 0) THEN
C * ALERT _308 - SINGLE BONDED METAL ATOM
                          CALL PLA236 (308, 1, 1.0, 1.0,
     1                      NAMS(1, 2)(2:10), ' ')
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
C * TEST FOR JUST ONE CONNECTION FROM H-ATOM
                IENH = IEN(NO1)
                IF (IENH == 1 .OR. IENH == 33 .OR. IENH == 113)
     1            THEN
                  IF (INC /= 1 .AND. IMET == 0) NOTE = 'V'
                  IF (IAT <= NATX .AND. IDS1 == 10000) THEN
C * REPORT H ATOMS WITH MORE THAN ONE CONNECTION
                    IF (NCSUM > 10001 .AND. IGBL(94) == 0) THEN
                      YUNK = NCSUM / 10000.0
C * ALERT _303
                      IF (IMET == 0) THEN
                        IF (NC == 2) THEN
                          J1 = NINT (CON(I, 1))
                          J2 = NINT (CON(I, 2))
                          CALL PLA050 (J1, J2, 0, 0, DIST)
                          CALL GEN048 (-1, IFG(1, J1), 23, JJ)
                          CALL GEN048 (-1, IFG(1, J2), 23, KK)
C * TEST FOR ACID BRIDGE
                          IF (DIST < 2.5 .AND. JJ + KK == 2) THEN
                            CALL PLA236 (303, 2, -999.0, YUNK,
     1                        NAMS(1, 2)(2:10), ' ')
                          ELSE
                            CALL PLA236 (303, 2, YUNK, YUNK,
     1                      NAMS(1, 2)(2:10), ' ')
                          END IF
                        ELSE
                          CALL PLA236 (303, 2, YUNK, YUNK,
     1                    NAMS(1, 2)(2:10), ' ')
                        ENDIF
                      ELSE
                        CALL PLA236 (303, 2, -999.0, YUNK,
     1                    NAMS(1, 2)(2:10), ' ')
                      END IF
                    END IF
C * NOTE ISOLATED H-ATOMS
                    IF (INC == 0) THEN
                      IPR(153) = IPR(153) + 1
C * ALERT _305
                      CALL PLA236 (305, 1, 1.0, 1.0,
     1                  NAMS(1, 2)(2:10), ' ')
                    END IF
                  END IF
                END IF
C * ALERT _315 - NOTE C-ATOM WITH ONLY ONE CONNECTION
                IF (IEN(NO1) == 2 .AND. INC == 1 .AND.
     1            I < NATX .AND. IPR(484) > 0) THEN
                  IPR(749) = IPR(749) + 1
                  IF (IDS1 .LT. 10000) THEN
                    CALL PLA236 (315, 1, -999.0, 1.0, NAMS(1, 2)(2:10),
     1                ' ')
                  ELSE
                    CALL PLA236 (315, 1, 1.0, 1.0, NAMS(1, 2)(2:10),
     1                ' ')
                  END IF
                END IF
C * NOTE C-ATOM VALENCY > 4
                IF (IEN(NO1) == 2 .AND. KMT <= 1 .AND.
     1             (INC == 0 .OR. INC > 4)) NOTE = 'V'
                IF (NC == 0) DMN = 0.0
C * NOTE BARE O-ATOMS or LONG SINGLE BONDED O or C=O-H
                IF (IEN(NO1) == 3 .AND. IAT <= NATX) THEN
                  IF (INC == 0) THEN
                    NOTE = 'V'
                    IPR(161) = IPR(161) + 1
                    IF (IDS1 == 10000) THEN
C * ALERT _306
                      CALL PLA236 (306, 1, 1.0, 1.0,
     1                  NAMS(1, 2)(2:10), ' ')
                    ELSE
C * ALERT _311
                      CALL PLA236 (311, 1, -999.0, 1.0,
     1                  NAMS(1, 2)(2:10), ' ')
                    END IF
                  ELSE IF (INC == 1 .AND. PNC < 1.3) THEN
                    KAT = NINT (CON(IAT, 1))
                    CALL GEN048 (-4, IFG(1, KAT), 15, NO2)
                    IF (IEN(NO2 + 1) == 2) THEN
                      CALL PLA050 (IAT, KAT, 0, 0, DIST)
                      IF (DIST > 1.3) THEN
C * CHECK FOR INTRA (ZWITTERIONIC) H-BONDS
                        YUNK = 1.0
                        DO LAT = 1, NATX
                          CALL GEN048 (-1, IFG(1, LAT), 20, IDH)
                          IF (IDH == 1) THEN
                            CALL PLA050 (IAT, LAT, 0, 0, DIST)
                            IF (DIST < 2.0) THEN
                              YUNK = -999.0
                              EXIT
                            END IF
                          END IF
                        END DO
                        CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM,
     1                               0, IGBL(55), 0, 1)
C * ALERT _309
                        CALL PLA236 (309, 1, YUNK, 1.0, ' '//NQ1, ' ')
                      END IF
                    END IF
                  ELSE IF (INC == 2) THEN
                    KAT = NINT (CON(IAT, 1))
                    LAT = NINT (CON(IAT, 2))
                    CALL GEN048 (-1, IFG(1, KAT), 19, METK)
                    CALL GEN048 (-1, IFG(1, LAT), 19, METL)
                    CALL GEN048 (-4, IFG(1, KAT), 15, NO2)
                    IF (IEN(NO2 + 1) == 2) THEN
                      CALL GEN048 (-4, IFG(1, LAT), 15, NO2)
                      IF (IEN(NO2 + 1) == 1) THEN
                        CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM,
     1                               IPR(71), IGBL(55), 0, 0)
                        CALL PLA050 (IAT, KAT, 0, 0, DIST)
                        IF (DIST < 1.25) THEN
C * ALERT _312
                          CALL PLA236 (
     1                       312, 1, 1.25 - DIST, 1.0, ' '//NQ1, ' ')
                        ELSE IF (DIST >= 1.45) THEN
C * ALERT _375
                          CALL PLA236 (
     1                       375, 1, DIST - 1.45, 1.0, ' '//NQ1, ' ')
                        END IF
                      END IF
                    END IF
C * CHECK X-O-Y ANGLE
                    IF (METK == 0 .AND. METL == 0) THEN
                      CALL GEN048 (-4, IFG(1, KAT), 15, NOK)
                      CALL GEN048 (-4, IFG(1, LAT), 15, NOL)
                      CALL PLA050 (KAT, IAT, LAT, 0, ANG3)
                      IF (ANG3 > 0.01) THEN
                        IENNOK = IEN(NOK + 1)
                        IENNOL = IEN(NOL + 1)
C * Si-O-Si ANGLE TEST
                        IF (IENNOK == 85 .AND. IENNOL == 85) THEN
C * ALERT _396
                          IF (ABS (ANG3 - 150.0) > 10.0) CALL PLA236
     1                      (396, 1, -999.9, ANG3, NAMS(1, 2)(2:10),
     2                      'Si-O-Si')
C * B-O-B ANGLE TEST
                        ELSE IF (IENNOK == 20 .AND. IENNOL == 20)
     1                    THEN
C * ALERT _397
                          IF (ABS (ANG3 - 120.0) > 10.0) CALL PLA236
     1                      (397, 1, -999.9, ANG3, NAMS(1, 2)(2:10),
     2                      ' B-O-B ')
C * C-O-C ANGLE TEST
                        ELSE IF (IENNOK == 2 .AND. IENNOL == 2) THEN
C * ALERT _398
                          IF (ABS (ANG3 - 120.0) > 10.0) CALL PLA236
     1                      (398, 1, -999.0, ANG3, NAMS(1, 2)(2:10),
     2                        ' C-O-C ')
                        ELSE IF (IENNOK /= 1 .AND. IENNOL /= 1) THEN
C * ALERT _395 - GENERAL X-O-Y ANGLE
                          IF (ABS (ANG3 - 120.0) > 10.0) CALL PLA236
     1                       (395, 1, -999.9, ANG3,
     2                        NAMS(1, 2)(2:10), ' X-O-Y ')
                        END IF
                      END IF
                    END IF
C * THREE BONDS TO O
                  ELSE IF (INC == 3) THEN
                    KAT1 = NINT (CON(IAT, 1))
                    KAT2 = NINT (CON(IAT, 2))
                    KAT3 = NINT (CON(IAT, 3))
                    CALL GEN048 (-1, IFG(1, KAT1), 19, KAT1M)
                    CALL GEN048 (-1, IFG(1, KAT2),  7, KAT2H)
                    CALL GEN048 (-1, IFG(1, KAT3),  7, KAT3H)
C * CHECK FOR METAL-O-H ANGLES
                    IF (KAT1M * KAT2H * KAT3H /= 0) THEN
                      CALL PLA050 (KAT1, IAT, KAT2, 0, ANGH1)
                      CALL PLA050 (KAT1, IAT, KAT3, 0, ANGH2)
                      CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM,
     1                             IPR(71), IGBL(55), 0, 0)
                        CALL PLA047 (LABA(KAT2), NQ2, IDUM, JDUM,
     1                               IPR(71), IGBL(55), 0, 0)
                        CALL PLA047 (LABA(KAT3), NQ3, IDUM, JDUM,
     1                               IPR(71), IGBL(55), 0, 0)
                      IF (ANGH1 < 95.0) THEN
                        CALL PLA236 (314, 2, 1.0, ANGH1, NQ1, NQ2)
                      END IF
                      IF (ANGH2 < 95.0) THEN
                        CALL PLA236 (314, 2, 1.0, ANGH2, NQ1, NQ3)
                      END IF
                    ELSE
                      DISTM = 0.0
                      NC = - NINT (CON(IAT, 9))
                      DO LL = 1, NC
                        KAT = NINT (CON(IAT, LL))
                        CALL PLA050 (IAT, KAT, 0, 0, DIST)
                        DISTM = MAX (DISTM, DIST)
                      END DO
                      IF (DISTM < 1.6 .AND. IDS1 == 10000) THEN
                        CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM,
     1                               IPR(71), IGBL(55), 0, 0)
C * ALERT _313
                        CALL PLA236 (313, 0, 1.0, 1.0, NQ1, ' ')
                      END IF
                    END IF
                  END IF
                END IF
C * GET HYBRIDISATION
                CALL PLA099 (1, IAT, NANG, ANG1, ANG2, ANG3, NOTE1)
                CALL GEN048 ( -4, IFG(1, IAT), 24, IHYB)
                CALL GEN048 ( -3, IFG(2, IAT), 24, NATH)
                CALL GEN048 ( -4, IFG(3, IAT), 28, NCEFF)
                CALL GEN048 (-10, IFG(2, IAT), 14, LNR)
C * CHECK FOR NON-POLYMER
                IF (IAT <= NATX .OR. IPR(322) == 0) THEN
                  IF (IHYB == 1) THEN
                    CHYB = 'sp '
                  ELSE IF (IHYB == 2) THEN
                    CHYB = 'sp2'
                  ELSE IF (IHYB == 3) THEN
                    CHYB = 'sp3'
                  ELSE
                    CHYB = '   '
                  END IF
                END IF
C * GET R/S CONFIGURATION
                IF (IPR(324) == 1) THEN
                  CRS = ' '
                  IF (IHYB == 3) THEN
                    CALL GEN048 (-2, IFG(1, IAT), 28, JCAI)
                    IF (JCAI == 1) THEN
                      CRS = 'S'
                    ELSE IF (JCAI == 2) THEN
                      CRS = '?'
                    ELSE IF (JCAI == 3) THEN
                      CRS = 'R'
                    END IF
                  END IF
                END IF
C * VLAG
                VLAG = '-   '
                IF (IABS (IGBL(8)) == 3) THEN
                  CALL GEN048 (-1, IFG(3, IAT), 1, IVLAG)
                  IF (IVLAG == 1) VLAG(1:1) = 'd'
                  CALL GEN048 (-1, IFG(3, IAT), 2, IVLAG)
                  IF (IVLAG == 1) VLAG(1:1) = 'c'
                  KK = 1
                  DO JJ = 4, 10
                    CALL GEN048 (-1, IFG(3, IAT), JJ, IVLAG)
                    IF (IVLAG == 1) THEN
                      IF (KK < 4) THEN
                        KK = KK + 1
                        VLAG(KK:KK) = CVLAG(JJ - 3)
                      END IF
                    END IF
                  END DO
                END IF
C * CSD.QUE
                IF (IGBL(31) == 4 .AND. IEN(NO1) /= 1 .AND.
     1            RCONT(NRS) > IPR(735)) THEN
                  IF (NDLP == 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 /= 0) THEN
                      NQ1(6 : 6) = CHAR (ICHAR ('A') + J2 - 1)
                    ELSE
                      NQ1(6 : 6) = ' '
                    END IF
                    WRITE (LU2, 99982, IOSTAT = IOST)
     1                NQ1(1:IP), NQ1(5:6), NBNDS
                  END IF
                END IF
                IF (IAT <= NATX) THEN
C * CHECK FOR MISSING H ON Me-N-(X)2
                  IF (IEN(NO1) == 4) THEN
                    IF (NRMET > 0 .AND. NCEFF == 3 .AND.
     1                DMN > 1.45 .AND. ANG3 < 114.0) THEN
C * ALERT _324 +
                      CALL PLA236 (
     1                  324 + NADD, 1, 1.0, 1.0, NAMS(1, 2)(2:10), ' ')
                      NOTE = '?'
                    END IF
                    IF (IHYB  == 0 .AND. NRMET. EQ. 0 .AND.
     1                  NCEFF == 3 .AND. DMN < 1.1 .AND.
     2                  DMNNH > 2.8 .AND. ANG3 == 120.0) THEN
C * ALERT _318 + _319
                      CALL PLA236 (
     1                  318 + NADD, 1, -999.0, 1.0,
     2                  NAMS(1, 2)(2:10), ' ')
                    END IF
C * CHECK FOR MISSING H ON SP3? CARBON
                  ELSE IF (IEN(NO1) == 2) THEN
                    IF (NCEFF == 3 .AND. NRMET == 0) THEN
                      IF (IHYB /= 0) THEN
                        IF (DMN > 1.45 .AND. ANG3 < 112.0) THEN
C * ALERT _326 +
                          CALL PLA236 (
     1                      326 + NADD, 1, 1.0, 1.0,
     2                      NAMS(1, 2)(2:10), ' ')
                          NOTE = '?'
                        END IF
                      ELSE IF (IHYB == 0) THEN
                        IF (DMN < 1.1 .AND. DMX > 1.45 .AND.
     1                    ANG3 < 112.0) THEN
C * ALERT _329
                          CALL PLA236 (
     1                      329, 1, 1.0, 1.0, NAMS(1, 2)(2:10), ' ')
                          NOTE = '?'
                        END IF
                      END IF
                    END IF
C * CHECK FOR MISSING H ON COORDINATING SP3? P
                  ELSE IF (IEN(NO1) == 8) THEN
                    IF (NCEFF == 3 .AND. NRMET > 0) THEN
C * ALERT _328
                      IF (ANG3 < 115.0) THEN
                        CALL PLA236 (
     1                   328, 1, -999.0, 1.0,
     2                   NAMS(1, 2)(2:10), ' ')
                      END IF
                    END IF
                  END IF
                END IF
C * NO V & A NOTE FOR DISORDERED ATOM(S)
                IF (NAMS(1, 2)(1:1) == CHAR(32)) THEN
                  DO LL = 1, 9
                    IF (NAMS(LL, 1)(1:1) /= CHAR (32)) THEN
                      NOTE  = ' '
                      NOTE1 = ' '
                      EXIT
                    END IF
                  END DO
 
                  IF (NOTE  == 'V') IPR(102) = IPR(102) + 1
                  IF (NOTE1 == 'A') IPR(103) = IPR(103) + 1
                ELSE
                  NOTE  = ' '
                  NOTE1 = ' '
                END IF
                IF (IPR(483) > 0 .AND. IPR(484) > 0) THEN
                  NADD1 = NADD
                  IF (IEN(NO1) /= 2) THEN
                    IF (NADD1 == 0) THEN
                      NADD1 = 2
                    ELSE IF (NADD1 == 1) THEN
                      NADD1 = 3
                    END IF
                  END IF
                  IF (IAT < NATX) THEN
                    NQY = NAMS(1, 2)(2:10)
C * MOVE LABEL CONTENT RIGHT
                    CALL GEN156 (NQY)
C * ALERT _343 +
                    IF (NOTE1 == 'A') THEN
                      CALL PLA236 (343 + NADD1, 1, -999.0, 0.0,
     1                             CHYB, NQY)
                    ELSE IF (NOTE1 == '?') THEN
C * ALERT _343 +
                      NQX = 'sp?'
                      CALL PLA236 (343 + NADD1, 1, -999.0, 0.0,
     1                             NQX, NQY)
                    ELSE IF (NOTE1 == 'H') THEN
C * ALERT _316 +
                      CALL PLA236 (316 + NADD1, 1, 1.0, 1.0,
     1                             NQY, ' ')
                    END IF
                  END IF
                END IF
                IF (NOTE /= ' ' .OR. NOTE1 /= ' ') THEN
                  WRITE (LU6, 99996, IOSTAT = IOST) NAMS(1, 2)(1:8),
     1              (NAMS(LL, 1)(1:8), LL = 1, 7), NOTE, NOTE1
                END IF
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (1)
                  WRITE (LU7, 99993, IOSTAT = IOST) VLAG,
     1              NAMS(1, 2)(1:8), (NAMS(LL, 1)(1:8), LL = 1, 9),
     2              NANG, NINT (ANG1), NINT (ANG2), ANG3, DMN, DMX,
     3              NCEFF, LNR, CHYB, CRS, NOTE, NOTE1
                END IF
                IF (CRS /= ' ' .AND. I <= NATX) THEN
                  MRS = MRS + 1
                  IF (MRS == 1) WRITE (LU6, 99986)
                  WRITE (LU6, 99990, IOSTAT = IOST) NAMS(1, 2)(1:8),
     1              NRS, LNR, CRS
                END IF
                IF (LIST == -2 .AND. IAT <= NATX) THEN
                  NQ4  = NAMS(1, 2)(2 : 8)
                  IF (NC == 3 .AND. NRCAR == 1 .AND. NROX0 == 2
     1              .AND. IDISO == 2000) THEN
                    DISTSUM = CORDN(2) + CORDN(3)
C * ALERT _782 - TEST FOR C-CO2
                    IF (IEN(NO1) == 2) THEN
                      IF (DISTSUM < 2.48 .AND. CORDN(1) < 1.48)
     1                  THEN
                        IF (DISTSUM < 2.45) THEN
                          YUNK = 1.5
                        ELSE
                          YUNK = 0.5
                        END IF
                        CALL PLA236 (782, 0, YUNK, YUNK, 'C-CO2', NQ4)
                      END IF
C * ALERT _782 - TEST FOR C-NO2
                    ELSE IF (IEN(NO1) == 4) THEN
                      IF (DISTSUM > 2.48 .AND. CORDN(1) > 1.48)
     1                  CALL PLA236 (782, 0, 1.5, 1.5, 'C-NO2', NQ4)
                ENDIF
                  ENDIF
                  IF (IHAT == 0) THEN
                    IF (NUEQ > 1) THEN
                      UEQAVR = UEQAVR / NUEQ
                      DUEQ   = DATC(IAT) - UEQAVR
                      NADD2  = 0
                      IF (RCONT(NRS) < IPR(487) .AND. NRES > 1)
     1                  NADD2 = 2
C * ALERT _241 & _243 - TEST HIGH Ueq
 
                      IF (IDS1 == 10000) THEN
                        IF (DUEQ > 0.005) THEN
                          CALL PLA236 (241 + NADD2, 3, DUEQ, DUEQ,
     1                      NQ4, ' ')
                        ELSE IF (- DUEQ > 0.005) THEN
C * ALERT _242 & _244
C * HANDLE CLO4, -CF3, BF4 & PF6 - TEST LOW UEQ
                          IENNO1 = IEN(NO1)
                          IF ((IENNO1 == 5  .AND. NROX == 4) .OR.
     1                        (IENNO1 == 2  .AND. NRFL >= 3) .OR.
     1                        (IENNO1 == 20 .AND. NRFL == 4) .OR.
     2                        (IENNO1 == 8  .AND. NRFL >= 6)) THEN
                            IF (DATC(IAT) < 0.025) THEN
                              CALL PLA236 (242 + NADD2, 3, - DUEQ,
     1                          - DUEQ, NQ4, ' ')
                            ELSE
                              CALL PLA236 (242 + NADD2, 3, -999.0,
     1                          - DUEQ, NQ4, ' ')
                            END IF
                          ELSE
                            CALL PLA236 (242 + NADD2, 3, - DUEQ,
     1                        - DUEQ, NQ4, ' ')
                          END IF
                        END IF
                      END IF
                    END IF
                  ELSE
                    IF (KATS > 0) THEN
                      DUEQ = DATC(IAT) - DATC(KATS)
                      CALL PLA047 (LABA(KATS), NQ3, IDUM, JDUM,
     1                  IPR(71), IGBL(55), 0, 1 - IGBL(55))
C * ALERT _245
                      IF (DUEQ < 0.0) CALL PLA236 (245, 3,
     1                  -DUEQ, -DUEQ, NQ4, NQ3)
                    END IF
                  END IF
                END IF
C * OUTPUT THE OVER-NINE CONNECTIONS
   10           NC1 = 9
                DO
                  NC1 = NC1 + 1
                  IF (NC1 > NC) GO TO 20
                  NCL = 0
                  DO NC0 = NC1, NC
                    NC2 = NC0
                    IF (IBON(NC0 - 9, 1) == IAT) THEN
                      NCK = MOD (IBON(NC0 - 9, 2), NP1)
                      NCL = NCL + 1
C * GET LABEL INFO
                      CALL PLA036 (NCK, NCL, 1, IDIS, MNUM, ISPOS,
     1                             IPR(71), IGBL(55))
                      IF (NCL == 9) EXIT
                    END IF
                  END DO
                  IF (NCL > 0) THEN
                    IF (LIST > 0) THEN
                      WRITE (LU6, 99988, IOSTAT = IOST)
     1                  (NAMS(LL, 1)(2:7), LL = 1, NCL)
                    ELSE
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99987, IOSTAT = IOST)
     1                    (NAMS(LL, 1)(1:8), LL = 1, NCL)
                      END IF
                    END IF
                  END IF
                  NC1 = NC2
                END DO
              END IF
   20         CONTINUE
            END DO
C * END NAT LOOP
          END DO
C * CSD-QUE BOND OUTPUT
          IF (RCONT(NRS) > IPR(735)) THEN
            IF (IGBL(31) == 4) THEN
              DO K = NP1 + 1, JBN
                WRITE (LU2, 99981, IOSTAT = IOST) JNSC(1, JNSC(1, K)),
     1                             JNSC(1, JNSC(2, K))
              END DO
              WRITE (LU2, 99980, IOSTAT = IOST)
            END IF
          END IF
          IF (N == 1) WRITE (LU6, 99989)
          WRITE (LU6, 99979) N, VOLMOL, RFORM(N)
        END DO
C * END LOOP OVER RESIDUES
        IF (IGBL(31) == 4) THEN
C * CHECK FOR POLYMER TYPE (0,1,2,3)
          IF (IPR(322) == 0) THEN
            CALL PLA294 (0)
          ELSE
C * NO QUEST SEARCH DONE FOR POLYMERS
            CALL PLA015 (0, 27)
          END IF
        END IF
C * PRINT SYMMETRY CODES
        CALL PLA043 (NSMPR, 1, LU7, 0)
      END IF
      IF (IWIN == 1 .AND. LIST > 0) CALL PLA297 (0)
      RETURN
99999 FORMAT (/, 'Disordered Atoms with S.O.F ', A, ' 0.5', /)
99998 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', /)
99997 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('-'))
99996 FORMAT ('N: ', A, ' : ', 7(A), 1X, 2A)
99995 FORMAT (/, 34X, 'Residue =', I4, /)
99994 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='), /)
99993 FORMAT (A, A, '-', 9(A), I2, 2I4, F6.1, 2F6.3, I3, I4, 1X,
     1 A3, 2X, A, 2X, 2A)
99992 FORMAT ('Atom  Label  - Bonded to ')
99991 FORMAT (I4, 1X, A, ' : ', 9(A))
99990 FORMAT ('::', A, ' RES =', I5, ' LNR =', I5, ' Chiral: ', A)
99989 FORMAT (/, ':: Resd  MolVol', 5X, 'Formula', 10X,
     1 ' - (Kitaigorodskii Analytical Formula)')
99988 FORMAT (15X, 9(A, 1X))
99987 FORMAT (13X, 9(A))
99986 FORMAT (1X)
99985 FORMAT (//, A, /, 80('-'))
99984 FORMAT (A)
99983 FORMAT ('T', A, ' *CONNSER')
99982 FORMAT ('AT', A, 2X, A, I5)
99981 FORMAT ('BO', 2I6, ' 99')
99980 FORMAT ('END')
99979 FORMAT ('!K', I5, F8.1, ' A^3 ', A)
      END SUBROUTINE PLA074
 
      SUBROUTINE PLA075
C * LIST LEAST-SQUARES PLANES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: K0
      INTEGER                  :: KB
      INTEGER                  :: L4
      INTEGER                  :: IP
      INTEGER                  :: MLL
      INTEGER                  :: IER
      INTEGER                  :: IFT
      INTEGER                  :: ISX
      INTEGER                  :: NEXB
      INTEGER                  :: NDEC
      INTEGER                  :: NATP
      INTEGER                  :: IVAL
      INTEGER                  :: MARK
      INTEGER                  :: IFIN
      INTEGER                  :: NMAX
      INTEGER                  :: IDOF
      INTEGER                  :: JDUM
      INTEGER                  :: IDUM
      INTEGER                  :: NLSPL
      INTEGER                  :: IDUM1
      INTEGER                  :: IDUM2
      INTEGER                  :: IRES1
      INTEGER                  :: IATPI
      INTEGER                  :: ISIGA
      INTEGER                  :: IRESII
      INTEGER                  :: ISDVML
      REAL                     :: A
      REAL                     :: D
      REAL                     :: SD
      REAL                     :: SDK
      REAL                     :: CHIK
      REAL                     :: SGREF
      REAL                     :: SIGPL
      REAL                     :: SDVMLL
      REAL                     :: DEVMLL
      CHARACTER(len=4)         :: IE3
      CHARACTER(len=1)         :: CPLM
      CHARACTER(len=4)         :: ISRT
      CHARACTER(len=1)         :: CDUM
      CHARACTER(len=4)         :: IPROB
      CHARACTER(len=73)        :: FORMA
      CHARACTER(len=73)        :: FORMB
      CHARACTER(len=73)        :: FORMC
      CHARACTER(len=157)       :: FORMD
      CHARACTER(len=218)       :: FORME
      CHARACTER(len=188)       :: FORMF
      INTEGER, DIMENSION(8)    :: ISPV
      INTEGER, DIMENSION(7, 2) :: IPLA
      IDUM1 = 0
      IDUM2 = 0
      IRES1 = 0
C * SETUP PRINT FORMAT(S)
      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) > 0) THEN
        CALL GEN108 (LU8, 0)
        SD    = 0.0
        NMAX  = IPR(39)
        NLSPL = 0
C * LOOP OVER PLANES
        DO
          READ (LU8, IOSTAT = IOST) MARK, IPR(12), JR, RMAT
          IF (IOST /= 0) RETURN
          IF (MARK < 0) THEN
C * CHECK FOR FILE-END MARK
            IF (MARK == -100) EXIT
C * SKIP/DUMMY READ NON-PLANE DATA (LENGTH DIFFERS FROM NMAX)
            READ (LU8)
          ELSE
            READ (LU8) (IATP(L4), L4 = 1, NMAX)
            NLSPL = NLSPL + 1
            IF (NLSPL == 1) THEN
              IF (IPR(41) == 0) THEN
                IE3 = 'UNIT'
              ELSE IF (IPR(41) == 1) THEN
                IE3 = 'ATWT'
              ELSE
                IE3 = 'ESD '
              END IF
C * LEAST SQUARES PLANE HEADER TEXT ( NEW PAGE)
              IF (IGBL(63) > 2) THEN
                CALL PLA262 (- 15 - IPR(155) * 3)
                WRITE (LU7, 99998, IOSTAT = IOST)
     1            IPR(579), PAR(49), PAR(76), IE3
C * TEST FOR METAL CONTAINING COMPOUND
                IF (IPR(155) > 0)
     1            WRITE (LU7, 99995, IOSTAT = IOST) IPR(217), IPR(159)
                WRITE (LU7, 99997, IOSTAT = IOST)
              END IF
            END IF
            IF (NLSPL > NP2) RETURN
            CALL PLA055
            DO 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)
            END DO
            CPLM = '#'
            IF (MARK == 1) THEN
              ISRT = 'Plan'
            ELSE IF (MARK == 2) THEN
              ISRT = 'Ring'
            ELSE IF (MARK == 3) THEN
              ISRT = 'Resd'
            ELSE IF (MARK == 4) THEN
              ISRT = 'Lspl'
              IPR(19) = IPR(19) + 1
            ELSE IF (MARK == 5) THEN
              ISRT = 'Crdn'
            END IF
            DO I = 1, 8
              ISPV(I) = MIN (99, ISPV(I))
            END DO
            SGREF = 0
            SDK   = 0
            NATP  = IPR(12)
            DO J = 1, NATP
              IP = IATP(J)
              SGREF = SGREF + XSD(IP, 4) + XSD(IP, 5) + XSD(IP, 6)
              D = - XPV(4)
              DO I = 1, 3
                D = D + XPV(I) * XXO(IP, I + 3)
              END DO
              SDK = SDK + D**2
            END DO
            SIGPL = 0
            IF (NATP > 3) SIGPL = SQRT (SDK / (NATP - 3))
            SGREF = SQRT (SGREF / (NATP * 3))
            CHIK  = 0.0
            IF (SGREF > PAR(12))
     1        CHIK = MIN (999999.9, SDK / SGREF**2)
              IDOF  = NATP - 3
              IF (IPR(72) /= 0) THEN
              CALL GEN093 (IDOF, CHIK, IPROB)
            ELSE
              IPROB = '    '
            END IF
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (3)
              WRITE (LU7, 99999, IOSTAT = IOST)
     1          NLSPL, SGREF, SIGPL, CHIK, IPROB
            END IF
            MLL = 0
            ISX = 0
C * CALCULATE PLANE DEVIATIONS
            DO I = 1, NMAX
              IATPI = MOD (IATP(I), NP1)
C * TEST H-ATOM BIT (SKIP DISTANCES FOR NOT-INCLUDED ATOMS)
              CALL GEN048 (-1, IFG(1, IATPI), 7, IVAL)
              IF (IVAL == 1 .AND. I > NATP) THEN
                IF (I == NMAX) GO TO 10
                CYCLE
              END IF
C * GET RESIDUE NUMBER (SKIP DISTANCES FOR NON-RESIDUE ATOMS)
              CALL GEN048 (-6, IFG(1, IATPI), 9, IRESII)
              IF (I == 1) THEN
                IRES1 = IRESII
              ELSE IF (I > NATP) THEN
                IF (IRES1 /= IRESII .AND. I > 8) THEN
                  IF (I == NMAX) GO TO 10
                  CYCLE
                END IF
              END IF
C * DO NOT PRINT TOO-LARGE PLANE DEVIATIONS
C * USE NOT-ROUNDED PLANE-PARAMETERS
              CALL PLA056 (XLS(1, NLSPL), IATPI, DEVMLL, SDVMLL,
     1                     ISDVML, 3, NDEC)
              IF (ABS (DEVMLL) > PAR(76) .AND. I > NATP) THEN
                IF (I == NMAX) GO TO 10
                CYCLE
              END IF
              CALL PLA047 (LABA(IATPI), NQ1, IDUM, JDUM, IPR(71),
     1          IGBL(55), 0, 1 - IGBL(55))
              MLL              = MLL + 1
              IF (I > NATP) CPLM = ' '
              NAMS(MLL, 1)     = CPLM//NQ1(1:NP64 - 1)
              DEV(MLL)         = DEVMLL
              SDV(MLL)         = SDVMLL
              ISDV(MLL)        = MIN (99, ISDVML)
              IFT              = 61 + MLL * 21
C * ADAPT NUMBER OF DECIMAL DIGITS
              FORMD(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
              IF (I /= NMAX) THEN
                IF (MLL < 4) CYCLE
              END IF
   10         IF (ISX == 4) THEN
                FORMD(1 : 73) = FORMB
                IF (IGBL(63) > 2) THEN
                  WRITE (PRBUF, FORMD, IOSTAT = IOST) IPR(12),
     1            (XPV(J + ISX), ISPV(J + ISX), J = 1, 4),
     2             (NAMS(J, 1)(1:7), DEV(J), ISDV(J), J = 1, MLL)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                END IF
                ISX = ISX + 4
              ELSE IF (ISX > 4) THEN
                IF (MLL == 0) CYCLE
                FORMD(1 : 73) = FORMC
                IF (IGBL(63) > 2) THEN
                  WRITE (PRBUF, FORMD, IOSTAT = IOST) (NAMS(J, 1)(1:7),
     1              DEV(J), ISDV(J), J = 1, MLL)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                END IF
              ELSE
                FORMD(1 : 73) = FORMA
                IF (IGBL(63) > 2) THEN
                  WRITE (PRBUF, FORMD, IOSTAT = IOST) ISRT,
     1             (XPV(J + ISX), ISPV(J + ISX), J = 1, 4),
     2             (NAMS(J, 1)(1:7), DEV(J), ISDV(J), J = 1, MLL)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                END IF
                NAMS(1, 1) = '        '
                ISX = ISX + 4
              END IF
              MLL = 0
            END DO
          END IF
        END DO
C * INTERPLANE ANGLES AND BOND/PLANE ANGLES
        IF (NLSPL > 1 .AND. IGBL(63) > 0) THEN
          KB = 0
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (3)
            WRITE (LU7, 99996, IOSTAT = IOST)
          END IF
          DO I = 1, NLSPL - 1
            DO J = I + 1, NLSPL
              KB = KB + 1
              DBUF(KB) = RGBL(6) * 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 K = 5, 7
                A = A + XLS(K, I)**2 + XLS(K, J)**2
              END DO
              A = RGBL(6) * 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 >= 7) THEN
                IF (IGBL(63) > 2) THEN
                 WRITE (PRBUF, FORME, IOSTAT = IOST)
     1             ((IPLA(L, M), M = 1, 2),
     2             DBUF(L), IDBUF(L), L = 1, 7)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                END IF
                KB = 0
              END IF
            END DO
          END DO
          IF (KB > 0 .AND. IGBL(63) > 2) THEN
            WRITE (PRBUF, FORME, IOSTAT = IOST)
     1        ((IPLA(L, M), M = 1, 2), DBUF(L),
     2        IDBUF(L), L = 1, KB)
              CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          END IF
        END IF
C * CALCULATE ANGLES BETWEEN AXES/LINES/BONDS AND L.S.-PLANES
        IF (NLSPL > 0 .AND. IGBL(63) > 0) THEN
          IF (IPR(40) > 0) THEN
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (7)
              WRITE (LU7, 99994, IOSTAT = IOST) '>', (I, I = 1, 10)
            END IF
            KB       = 0
C * SET FOR NON-H ONLY OR NON-H + H BONDS
            IPR(133) = - IPR(368)
            IFIN     = -3
            N        = 0
            NEXB     = IPR(407) + 6
            NQ1(1:6) = 'Axes O'
            NQ2(1:6) = '--->a '
            DO
              IF (N >= 6) THEN
                N = N + 1
                IF (N > NEXB) THEN
C * CALL FOR A SEQUENCE OF CELL AXES AND UNIQUE BONDS
                  CALL PLA038 (I, J, IFIN)
                  IF (IFIN == 1) RETURN
                  CDUM = '-'
                ELSE
C * SPECIAL LINES
                  I = NINT (SLN(N - 6, 1))
                  J = NINT (SLN(N - 6, 2))
                  CALL PLA047 (LABA(I), NQ1, IDUM1, IDUM2, IPR(71),
     1                         IGBL(55), 0, 1 - IGBL(55))
                  CALL PLA047 (LABA(J), NQ2, IDUM1, IDUM2, IPR(71),
     1                         IGBL(55), 0, 1 - IGBL(55))
                  CDUM = '.'
                END IF
C * GET UNIT VECTOR FROM I TO J
                CALL PLA227 (I, J, VECN)
C * GET DISTANCE (+ ESD) FOR BOND I - J
                CALL PLA053 (I, J, 0, 0, D, SD, IDUM1, IDUM2, IER)
                IF (IER /= 0) CYCLE
              ELSE
C * GET DIRECTION COSINES FOR CELL AXES
                N = N + 1
                IF (N < 4) THEN
                  NQ2(5:5) = CHAR (ICHAR ('a') - 1 + N)
                  D        = PAR(100 + N)
                  SD       = 0.0
                  DO K = 1, 3
                    VECN(K) = OR(K, N) / D
                  END DO
                ELSE
C * GET DIRECTION COSINES FOR RECIPROCAL AXES
                  NQ2(5:6) = CHAR (ICHAR ('a') - 4 + N)//'*'
                  D        = PAR(109 + N)
                  SD       = 0.0
                  DO K = 1, 3
                    VECN(K) = ROR(N - 3, K) / D
                  END DO
                END IF
                CDUM = ' '
              END IF
C * LOOP OVER ALL PLANES
              IF (D /= 0.0) THEN
                DO 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              * RGBL(6)
                  A = 0.0
                  DO L = 1, 3
                    A = A + XLS(L + 4, K)**2 + (VECN(L) * SD / D)**2
                  END DO
                  A = RGBL(6) * 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 >= 10) THEN
                    K0 = K / 10 - 1
                    IF (IGBL(63) > 2) THEN
                      IF (K0 == 0) THEN
                        NQ1(7:7) = CDUM
                        NQ2(7:7) = ' '
                        CPLM     = '/'
                      END IF
                      WRITE (PRBUF, FORMF, IOSTAT = IOST) NQ1(1:7),
     1                  NQ2(1:7), CPLM, K0, (DBUF(L), IDBUF(L),
     2                  L = 1, 10)
                        CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                      NQ1  = ' '
                      NQ2  = ' '
                      CPLM = ' '
                    END IF
                    KB = 0
                  END IF
                END DO
              END IF
              IF (KB > 0) THEN
                K0 = NLSPL / 10
                IF (IGBL(63) > 2) THEN
                  IF (K0 == 0) THEN
                    NQ1(7:7) = CDUM
                    NQ2(7:7) = ' '
                    CPLM     = '/'
                  END IF
                  WRITE (PRBUF, FORMF, IOSTAT = IOST) NQ1(1:7),
     1              NQ2(1:7), CPLM, K0, (DBUF(L), IDBUF(L), L = 1, KB)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                  NQ1  = '       '
                  NQ2  = '       '
                  CPLM = ' '
                END IF
                KB = 0
              END IF
            END DO
          END IF
        END IF
      END IF
      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 #',
     2     /, 48X, '- DISTANCES TO PLANES ROUNDED TO 3 DECIMALS !!',
     3        '(Use Graphical Interface for more)')
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 ' and Bonds with L.S.-Planes', /, 132('-'), /, 1X,
     2 'Bond  /  Plane NM --', A, ' M', I7, 9(I11), /, 132('-'))
      END SUBROUTINE PLA075
 
      SUBROUTINE PLA076
C * CREMER & POPLE, JACS, 97, 1354 (1975)
C * SUBROUTINE DERIVED FROM THE PROGRAM PUCK (J.C.A.BOEYENS)
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: L
      INTEGER :: MARK
      INTEGER :: NRING
      INTEGER :: NHEAD
C * SKIP IN NO-RING CASE OR PLOT NEWMAN,RING ETC
      IF (IPR(69) /= 0 .AND. IPR(55) == 0) THEN
        CALL GEN108 (LU8, 0)
        NRING = 0
        NHEAD = 0
C * LOOP OVER RINGS AND PLANES
        DO
          READ (LU8, IOSTAT = IOST) MARK, IPR(12), JR, RMAT
          IF (IOST /= 0) EXIT
          IF (MARK /= -100) THEN
C * IS THIS A RING ?
            IF (MARK /= 2) THEN
C * DUMMY READ RECORD (LENGTH DIFFERS FROM NMAX)
              READ (LU8)
              CYCLE
            END IF
            READ (LU8) (IATP(L), L = 1, IPR(39))
C * COUNT RING NUMBER
            NRING = NRING + 1
            IF (IPR(12) > 3) CALL PLA095 (NRING, NHEAD, 0)
            CYCLE
          ELSE
            EXIT
          END IF
        END DO
      END IF
      CALL GEN108 (LU8, 0)
C * GENERATE LIST OF RING-RING INTERACTIONS ETC (IF ANY)
C * SKIP FOR INORGANIC STRUCTURES
      IF (IPR(23) == 0 .AND. IPR(64) > 0 .AND. IGBL(97) == 1
     1    .AND. IGBL(63) > 1) CALL PLA048
      RETURN
      END SUBROUTINE PLA076
 
      SUBROUTINE PLA077
C * PRODUCE LISTS OF BOND LENGTHS, BOND ANGLES AND TORSION ANGLES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: NC
      INTEGER            :: NCB
      INTEGER            :: MAL
      INTEGER            :: MBL
      INTEGER            :: ISA
      INTEGER            :: ISD
      INTEGER            :: IAT
      INTEGER            :: JAT
      INTEGER            :: KAT
      INTEGER            :: IFT
      INTEGER            :: IER
      INTEGER            :: IHJ
      INTEGER            :: IHB
      INTEGER            :: NDIS
      INTEGER            :: IHAT
      INTEGER            :: KHAT
      INTEGER            :: IFIN
      INTEGER            :: IDS1
      INTEGER            :: IDS2
      INTEGER            :: IDUM
      INTEGER            :: JDUM
      INTEGER            :: JMET
      INTEGER            :: NDEC
      INTEGER            :: NRES
      INTEGER            :: NMAX
      INTEGER            :: NRSD
      INTEGER            :: NANG
      INTEGER            :: NLINE
      INTEGER            :: NDISO
      INTEGER            :: IRESI
      INTEGER            :: IDUM1
      INTEGER            :: IDUM2
      INTEGER            :: IDS12
      REAL               :: A
      REAL               :: D
      REAL               :: SA
      REAL               :: SD
      REAL               :: FLI
      REAL               :: FLJ
      REAL               :: DANG
      REAL               :: DIFF
      CHARACTER(len=126) :: FORMA
      CHARACTER(len=129) :: FORMB
      A    = 0.0
      D    = 0.0
      SA   = 0.0
      SD   = 0.0
      ISA  = 0
      ISD  = 0
      IER  = 0
      NDEC = 0
      CALL GEN108 (LU8, 0)
      IPR(52) = 0
C * TEST FOR NO-BONDS CASE
      IF (IPR(147) == 0) THEN
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99985, IOSTAT = IOST) '<', PAR(1)
        END IF
        WRITE (LU6, 99985, IOSTAT = IOST) '<', PAR(1)
        GO TO 30
      END IF
C * GET NUMBER OF ATOMS IN EXPANDED ATOM LIST
      NMAX = IPR(39)
      NRES = IPR(75)
      NCB  = IPR(131)
C * SET MAX NO OF BONDS/ANGLES/TORSIONS PER LINE OF PRINTOUT
      MBL  = 4
      MAL  = 3
C * OUTPUT ANGSTROM COORDINATES FOR PS300 - MOGLI
      IF (IGBL(31) == 2) THEN
        DO I = 1, NMAX
          CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, 0, IGBL(55),
     1    0, 0)
          WRITE (LU2, 99999, IOSTAT = IOST)
     1      NQ1(1:4), (XXO(I, J), J = 4, 6)
        END DO
        WRITE (LU2, 99998, IOSTAT = IOST)
        DO N = 1, NCB
          FLI = VOID(IPR(298) + N * 3 - 2)
          FLJ = VOID(IPR(298) + N * 3 - 1)
          WRITE (LU2, 99997, IOSTAT = IOST) NINT (FLI), NINT (FLJ)
        END DO
        WRITE (LU2, 99996, IOSTAT = IOST)
      END IF
C * INIT BOND STATISTICS
      CALL PLA098 (0, 0, 0, 0.0, 0.0, 0.0, 0, 0)
      IF (IPR(6) + IPR(7) + IPR(8) == 0) GO TO 30
C * PRINT INTRA-MOL GEOM HEADER
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (0)
        WRITE (LU7, 99993, IOSTAT = IOST)
        WRITE (LU7, 99989, IOSTAT = IOST)
     1    PAR(1), IGBL(97) * PAR(26), PAR(27)
        IF (IPR(44) == 1) WRITE (LU7, 99984, IOSTAT = IOST) '>', '<'
        NLINE = 3 + IPR(44)
      END IF
      IF (PAR(107) > 0.0 .AND. IGBL(63) > 2) THEN
        NLINE = NLINE + 4
        WRITE (LU7, 99983, IOSTAT = IOST) PAR(13), PAR(14)
        WRITE (LU7, 99986, IOSTAT = IOST)
      END IF
      IF (IGBL(63) > 2) CALL PLA262 (NLINE)
C * GENERATE FORMAT MASK FOR BONDS, BOND ANGLES AND TORSION ANGLES
      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)//')'
C * LOOP OVER RESIDUES
      DO NRSD = 1, NRES
        NDIS = 0
        K    = 0
        IHB  = 0
C * TEST FOR PRINT OF RESIDUE HEADER
        IF (NRES > 1) THEN
           IPR(134) = 1
        ELSE
           IPR(134) = 0
        END IF
        IF (IPR(438) == 1) WRITE (LU2, 99995, IOSTAT = IOST) NRSD
C * LOOP OVER BONDS AND TABULATE (MBL - BONDS PER LINE)
        IF (IPR(6) /= 0) THEN
          IPR(133) = -1
   10     IPR(133) = IPR(133) + 1
          IF (IPR(133) < 2) THEN
            IFIN = -1
C * GET NEXT BOND
            DO
              CALL PLA038 (I, J, IFIN)
              IF (IFIN == 1) GO TO 10
              CALL GEN048 (-6, IFG(1, I), 9, IRESI)
              IF (IRESI == NRSD) THEN
C * GET H-ATOM BIT AND PREAMPT BUFFER ON FIRST OCCURRENCE
                CALL GEN048 (-1, IFG(1, J), 7, IHJ)
                IF (IHJ /= IHB) THEN
                  IHB = 1
C * CLEAR BUFFER IF NECESSARY
                  IF (K > 0) THEN
                    IF (IGBL(63) > 2) THEN
                      WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1                  ((NAMS(L, M)(1:8), M = 1, 2),
     2                  DBUF(L), IDBUF(L), L = 1, K)
                      CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                    END IF
                    K = 0
                  END IF
                  IF (IGBL(63) > 2) THEN
                    CALL PLA262 (1)
                    WRITE (LU7, 99992, IOSTAT = IOST)
                  END IF
                END IF
C * CALCULATE DISTANCE WITH ESD, ADD TO BOND STATISTICS
                CALL PLA053 (I, J, 0, 0, D, SD, ISD, NDEC, IER)
                IF (IER == 0) THEN
C * GET LABEL/DISORDER INFORMATION
                  K   = K + 1
                  NDIS = NDIS + 1
                  CALL PLA036 (I, K, 1, IDS1, IDUM1, IDUM2, IPR(71),
     1              IGBL(55))
                  CALL PLA036 (J, K, 2, IDS2, IDUM1, IDUM2, IPR(71),
     1              IGBL(55))
                  DIFF  = 0.0
                  IDS12 = IDS1 + IDS2
                  CALL PLA098 (I, J, K, D, SD, DIFF, IDS12, 1)
                  DBUF(K)  = D
                  IDBUF(K) = MIN (99, ISD)
                  IFT      = 32 * K - 11
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
                  FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
                  IFT = 32 * K - 22
                  FORMB(IFT : IFT) = '-'
                  IF (DIFF >   PAR(280)) FORMB(IFT : IFT) = '>'
                  IF (DIFF < - PAR(280)) FORMB(IFT : IFT) = '<'
C * PRINT LINE
                  IF (IPR(438) == 1) THEN
                    IPR(251) = IPR(251) + 1
                    WRITE (LU2, 99991, IOSTAT = IOST)
     1                (NAMS(K, M)(2:8), M = 1, 2), D, SD
                  END IF
C * PRINT RESIDUE HEADER WHEN APPROPRIATE
                  IF (NDIS == 1) THEN
                    IF (IPR(134) == 1) THEN
                      IF (IGBL(63) > 2) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99994, IOSTAT = IOST) NRSD
                      END IF
                      IPR(134) = 0
                    END IF
                    IF (IGBL(63) > 2) THEN
                      CALL PLA262 (3)
                      WRITE (LU7, 99990, IOSTAT = IOST)
                    END IF
                  END IF
                  IF (K >= MBL) THEN
                    IF (IGBL(63) > 2) THEN
                      WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1                  ((NAMS(L, M)(1:8), M = 1, 2),
     2                  DBUF(L), IDBUF(L), L = 1, MBL)
                      CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                    END IF
                    K = 0
                  END IF
                END IF
              END IF
            END DO
          END IF
C * CLEAR BUFFER IF NECESSARY
          IF (K > 0 .AND. IGBL(63) > 2) THEN
            WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1        ((NAMS(L, M)(1:8), M = 1, 2),
     2        DBUF(L), IDBUF(L), L = 1, K)
            CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          END IF
        END IF
C * TABULATE BOND ANGLES
        IF (IPR(7) /= 0) THEN
          NANG = 0
          K    = 0
          IPR(133) = -1
   20     IPR(133) = IPR(133) + 1
          IF (IPR(133) < 2) THEN
            IF (IPR(133) == 1 .AND. IGBL(63) > 2) THEN
C * CLEAR BUFFER
              IF (K > 0) THEN
                IF (IGBL(63) > 2) THEN
                  WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1              ((NAMS(L, M)(1:8), M = 1, 3),
     2              DBUF(L), IDBUF(L), L = 1, K)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 3)
                END IF
                K = 0
              END IF
              CALL PLA262 (1)
              WRITE (LU7, 99992, IOSTAT = IOST)
            END IF
            IFIN = -1
            DO
              CALL PLA039 (IAT, JAT, KAT, NRSD, A, SA, ISA, NDEC,
     1          K, IFIN)
              IF (IFIN == 1) GO TO 20
C * SAVE IN LINE BUFFER - WE PRINT MAL ANGLES PER LINE
              NANG     = NANG + 1
              K        = K + 1
              DBUF(K)  = A
              IDBUF(K) = MIN (999, ISA)
              IFT      = 42 * K - 12
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
              FORMA(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
C * CHECK FOR OMEGA-FILE WRITE
              IF (IPR(438) == 1) THEN
                IPR(252) = IPR(252) + 1
                WRITE (LU2, 99988, IOSTAT = IOST)
     1             (NAMS(K, M)(2:8), M = 1, 3), A, SA
              END IF
C * VALIDATE METHYL MOIETY BOND ANGLES
              IF (NAMS(K, 2)(2:3) == 'C ') THEN
C * GET NUMBER OF CONNECTIONS TO C
                NC = - NINT(CON(JAT, 9))
                CALL GEN048 (-3, IFG(2, JAT), 24, JMET)
                IF (JMET == 3 .AND. NC == 4) THEN
                  DANG = ABS (109.5 - A)
                  IF (DANG > 0.1) THEN
                    CALL GEN048 (-1, IFG(1, IAT), 7, IHAT)
                    CALL GEN048 (-1, IFG(1, KAT), 7, KHAT)
                    NDISO = 0
                    IF (NAMS(K, 1)(1:1) /= ' ') NDISO = NDISO + 1
                    IF (NAMS(K, 2)(1:1) /= ' ') NDISO = NDISO + 1
                    IF (NAMS(K, 3)(1:1) /= ' ') NDISO = NDISO + 1
C * ALERT _389,_390,_391 +
                    IF (NDISO < 2) CALL PLA236 (389 + IHAT + KHAT,
     1               0, DANG, A, NAMS(K, 2)(2:10), ' ')
                  END IF
                END IF
              END IF
C * TEST FOR PRINTING OF RESIDUE AND BOND ANGLE HEADERS
              IF (NANG == 1) THEN
                IF (IPR(134) == 1) THEN
                  IF (IGBL(63) > 2) THEN
                    CALL PLA262 (4)
                    WRITE (LU7, 99994, IOSTAT = IOST) NRSD
                  END IF
                  IPR(134) = 0
                END IF
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (3)
                  WRITE (LU7, 99987, IOSTAT = IOST)
                END IF
              END IF
              IF (K >= MAL) THEN
                IF (IGBL(63) > 2) THEN
                  WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1              ((NAMS(L, M)(1:8), M = 1, 3),
     2              DBUF(L), IDBUF(L), L = 1, MAL)
                  CALL PLA263 (LU7, PRBUF, 132, 1, 3)
                END IF
                K = 0
              END IF
            END DO
          END IF
C * CLEAR BUFFER
          IF (K > 0) THEN
            IF (IGBL(63) > 2) THEN
              WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1          ((NAMS(L, M)(1:8), M = 1, 3),
     2          DBUF(L), IDBUF(L), L = 1, K)
              CALL PLA263 (LU7, PRBUF, 132, 1, 3)
            END IF
            K = 0
          END IF
        END IF
C * GENERATE TORSION ANGLE LIST
        CALL PLA034 (NRSD)
      END DO
C * LIST BOND STATISTICS
   30 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('='))
99986 FORMAT ('-- Bonds below with ''>'' or ''<'' Substituted for',
     1 ' ''-'' have Distances that Deviate from Expected Values',
     2 '(Based on the hybridisations).', /, 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.)')
      END SUBROUTINE PLA077
 
      SUBROUTINE PLA078
C * GENERATE RINGS AND PLANES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: NC
      INTEGER :: J1
      INTEGER :: KI
      INTEGER :: KJ
      INTEGER :: IJ
      INTEGER :: NR
      INTEGER :: NO1
      INTEGER :: NCI
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: NAT
      INTEGER :: IPP
      INTEGER :: NRS
      INTEGER :: NRT
      INTEGER :: LRT
      INTEGER :: NHAT
      INTEGER :: IPOP
      INTEGER :: IPAR
      INTEGER :: NRTM
      INTEGER :: NMAX
      INTEGER :: NRES
      INTEGER :: NEXB
      INTEGER :: NRET
      INTEGER :: NTYP
      INTEGER :: IVAL
      INTEGER :: NRTM2
      INTEGER :: NRMET
      INTEGER :: IVAL1
      INTEGER :: IVAL2
      INTEGER :: IRESI
      INTEGER :: IRESJ
      INTEGER :: IATPI
      INTEGER :: NRING
      REAL    :: UITW
C * NUMBER OF ASYMMETRIC ATOMS
      NAT  = IPR(37)
C * NUMBER OF ATOMS IN SYMMETRY EXPANDED LIST
      NMAX = IPR(39)
C * GET NUMBER OF RESIDUES
      NRES = IPR(75)
C * CONVERT (IF ANY - I.E. IPR(407) > 0) SPECIAL LINE CODES
      NEXB = 0
      IF (IPR(407) > 0) THEN
        DO 20 I = 1, IPR(407)
          NEXB = NEXB + 1
          DO 10 J = 1, 2
            DO K = 1, NMAX
              IF (NINT(SLN(I, J)) == LABA(K)) THEN
                SLN(NEXB, J) = K
                GO TO 10
              END IF
            END DO
C * LABEL NOT FOUND
            NEXB = NEXB - 1
            GO TO 20
   10     CONTINUE
   20   CONTINUE
        IPR(407) = NEXB
      END IF
C * SKIP IN NO-BOND CASE
      IF (IPR(147) /= 0) THEN
C * LOAD USER SPECIFIED FITS, RINGS AND PLANES FROM XLS-SCRATCH
        NRET = 0
        NTYP = 0
        CALL PLA390 (-1, NTYP, NRET)
C * SEARCH 3 TO N MEMBERED RINGS AND ANALYSE PUCKERING OF 4-N M-RINGS
C * TEST FOR RING-SEARCH REQUESTED (ORGANIC-MODE ONLY)
        IF (IPR(10) /= 0 .AND. IGBL(97) /= 0) THEN
C * LIMIT MAXIMUM RINGSIZE FOR LARGE STRUCTURES AND/OR DISORDERED STRUCTURES
          IF (NMAX > 250 .OR. IPR(44) == 1) THEN
            IPR(579) = MIN (IPR(219), IPR(216))
            WRITE (LU6, 99999, IOSTAT = IOST) IPR(579)
          END IF
C * GENERATE RINGS FOR EACH RESIDUE
          DO 60 NR = 1, NRES
C * COUNT # RINGS PER RESIDUE
            NRING = 0
C * GENERATE RINGS IN INCREASING RING-SIZE ORDER
            DO 50 K = 3, IPR(579)
C * MAX RING-SIZE = NRTM - 1
              NRTM = K + 1
              DO J = 1, NAT
C * GET RESIDUE NUMBER ATOM J
                CALL GEN048 (-6, IFG(1, J), 9, IRESJ)
                IF (IRESJ == NR) THEN
C * CHECK 'DISORDERED MOLECULE' FLAG
                  IF (IPR(44) > 0) THEN
C * GET POPULATION PARAMETER AND OMIT DISORDER-DISORDER RINGS
                    CALL GEN048 (-8, IFG(2, J), 1, IPP)
                    IF (IPPR(IPP + 1, 1) <= IPR(222)) CYCLE
                  END IF
C * GET NUMBER OF NON-HYDROGEN ATOMS IN THIS RESIDUE
                  NHAT = NINT(RCONT(IRESJ))
C * NO RING-SEARCH FOR RESIDUES WITH LESS THAN 5 NON-HYDROGEN ATOMS
C * OR RING-SIZE LARGER THAN NUMBER OF ATOMS IN RESIDUE
                  IF (NHAT < 5 .OR. NHAT < K) CYCLE
                  LRT   = 2
                  NRT   = 1
                  JR(1) = J
C * TEST FOR H OR B-ATOM(IN BORANES) (EXCLUDED FROM RINGS)
   30             CALL GEN048 (-1, IFG(1, JR(NRT)),  7, IVAL1)
                  CALL GEN048 (-1, IFG(2, JR(NRT)), 13, IVAL2)
                  IF (IVAL1 == 1 .OR. IVAL2 == 1) THEN
                    IF (LRT == 1) THEN
                      GO TO 40
                    ELSE IF (LRT == 2) THEN
                      CYCLE
                    END IF
                  END IF
C * DO NOT INCLUDE ATOMS WITH MORE THAN 9 CONNECTIONS IN RING SEARCH
                  CALL GEN048 (-1, IFG(1, JR(NRT)), 8, IVAL)
                  IF (IVAL == 1) THEN
                    IF (LRT == 1) THEN
                      GO TO 40
                    ELSE IF (LRT == 2) THEN
                      CYCLE
                    END IF
                  END IF
                  NCN(NRT) = - NINT(CON(JR(NRT), 9))
                  IF (NCN(NRT) < 0) NCN(NRT) = 9
                  IF (NCN(NRT) < 2) THEN
                    IF (LRT == 1) THEN
                      GO TO 40
                    ELSE IF (LRT == 2) THEN
                      CYCLE
                    END IF
                  END IF
C * TEST FOR METAL
                  CALL GEN048 (-1, IFG(1, JR(NRT)), 19, IVAL)
                  IF (IVAL == 1) THEN
C * SKIP METALS WITH MORE THAN IPR(159) CONNECTIONS
                    IF (NCN(NRT) > IPR(159)) THEN
                      IF (LRT == 1) THEN
                        GO TO 40
                      ELSE IF (LRT == 2) THEN
                        CYCLE
                      END IF
                    END IF
C * SKIP (EARTH-)ALKALI METALS
                    CALL GEN048 (-4, IFG(1, JR(NRT)), 15, NO1)
                    IF (IATPR(IEN(NO1 + 1)) > 4) THEN
                      IF (LRT == 1) THEN
                        GO TO 40
                      ELSE IF (LRT == 2) THEN
                        CYCLE
                      END IF
                    END IF
                  END IF
                  LRT      = 1
                  NRT      = NRT + 1
                  JLN(NRT) = 0
   40             JLN(NRT) = JLN(NRT) + 1
                  IF (JLN(NRT) > NCN(NRT - 1)) THEN
                    NRT = NRT - 1
                    IF (NRT > 1) GO TO 40
                    CYCLE
                  END IF
                  JR(NRT) = NINT(CON(JR(NRT - 1), JLN(NRT)))
C * RESTRICTION FOR RING DUPLICATION
                  IF (JR(NRT) >= JR(1)) THEN
C * EXCLUDE SHORT-CUT CLOSURES
                    IF (NRT > 3) THEN
                      IF (NRT == NRTM) THEN
                        NRTM2 = 1
                        ELSE
                            NRTM2 = NRT - 2
                        END IF
                        DO I = 2, NRTM2
                          IF (JR(NRT) == JR(I)) GO TO 40
                        END DO
                      END IF
C * HANDLE RING FOUND CASE
                      IF (JR(NRT) == JR(1)) THEN
                        IF (NRT < NRTM) GO TO 40
C * LIMIT RING-SIZE FOR METAL CONTAINING RINGS
                        NRMET = 0
                        DO I = 2, NRT
                          CALL GEN048 (-1, IFG(1, JR(I)), 19, IVAL)
                        NRMET = NRMET + IVAL
                        IF (IVAL * (NRT - 1) > IPR(217)) GO TO 40
                      END DO
C * AVOID ALL METAL RINGS
                      IF (NRMET == NRT - 1) GO TO 40
                      IF (JR(2) <= JR(NRT - 1)) THEN
                        DO I = 1, NMAX
                          IATP(I) = NP1 + I
                        END DO
                        IPR(12) = NRT - 1
                        IPOP = 10000
                        DO I = 1, IPR(12)
C * CHECK 'DISORDERED MOLECULE' FLAG
                          IF (IPR(44) > 0) THEN
C * GET POPULATION PARAMETER AND OMIT DISORDER-DISORDER RINGS
                            CALL GEN048 (-8, IFG(2, JR(I)), 1, IPP)
                            IPAR = IPPR(IPP + 1, 1)
                            IF (IPAR /= IPOP) THEN
                              IF (IPOP < 10000 .AND. IPAR < 10000
     1                          .OR. IPOP <= IPR(222)
     2                          .OR. IPAR <= IPR(222)) THEN
                                GO TO 40
                              ELSE
                                IF (IPOP == 10000) IPOP = IPAR
                              END IF
                            END IF
                          END IF
                          IATP(JR(I)) = JR(I)
                        END DO
                        IF (K > 3 .OR.
     1                     (K == 3 .AND. IPR(69) <= 10)) THEN
                          CALL PLA045 (2)
                          NRING = NRING + 1
C * CHECK MAXIMUM NUMBER OF RING PER RESIDUE TO BE EXCEEDED
                          IF (NRING >= IPR(302) + IPR(592) * 1000) THEN
                            IPR(579) = K
                            WRITE (LU6, 99999, IOSTAT = IOST) K
                          GO TO 60
                          END IF
                        ELSE
                          GO TO 50
                        END IF
                      END IF
                      IF (NRT == NRTM) NRT = NRT - 1
                      GO TO 40
                    END IF
                    IF (NRT < NRTM) GO TO 30
                  END IF
                  GO TO 40
                END IF
              END DO
   50       CONTINUE
   60     CONTINUE
        ELSE
          IF (IGBL(99) == 1) WRITE (LU6, 99998, IOSTAT = IOST)
        END IF
C * GENERATE LEAST SQUARES PLANES LIST
C * TEST FOR PLANE-GENERATION REQUESTED
        IF (ABS(IGBL(3)) /= 1 .AND. IPR(11) /= 0 .AND.
     1    IGBL(97) /= 0) THEN
C * FIRST GENERATE PLANES FOR 4-COORDINATED METALS
          DO JAT = 1, NAT
C * TEST FOR METAL
            CALL GEN048 (-1, IFG(1, JAT), 19, IVAL)
            IF (IVAL == 1) THEN
              IF (NINT (CON(JAT, 9)) == -4) THEN
                DO I = 1, NMAX
                  IATP(I) = NP1 + I
                END DO
                DO I = 1, 4
                  IATP(I) = NINT (CON(JAT, I))
                END DO
                IPR(12) = 4
                CALL PLA045 (5)
              END IF
            END IF
          END DO
C * GENERATE PLANES FOR EACH RESIDUE
          DO NRS = 1, NRES
            IPR(12) = 0
            DO I = 1, NMAX
              IATPI = NP1 + I
              CALL GEN048 (-6, IFG(1, I), 9, IVAL)
              IF (IVAL == NRS) THEN
C * TEST FOR HYDROGEN
                CALL GEN048 (-1, IFG(1, I), 7, IVAL)
                IF (IVAL == 0) THEN
                  IPR(12) = IPR(12) + 1
                  IATPI   = I
                END IF
              END IF
              IATP(I) = IATPI
            END DO
            IF (IPR(12) > 5) CALL PLA045 (3)
          END DO
        END IF
C * AUTOMATIC SEARCH FOR PLANES
        IF (IPR(9) /= 0) THEN
          DO 100 JAT = 1, NMAX
C * CHECK 'DISORDERED MOLECULE' FLAG
            IF (IPR(44) > 0) THEN
C * EXCLUDE DISORDER
              CALL GEN048 (-8, IFG(2, JAT), 1, IPP)
              IF (IPPR(IPP + 1, 1) < 10000) GO TO 100
            END IF
C * TEST FOR H-ATOM
            CALL GEN048 (-1, IFG(1, JAT), 7, IVAL)
            IF (IVAL > 0) GO TO 100
            CALL GEN048 (-1, IFG(1, JAT), 5, IVAL)
            IF (IVAL > 0) GO TO 100
            CALL GEN048(-6, IFG(1, JAT), 9, IRESJ)
            NC = - NINT (CON(JAT, 9))
            IF (NC < 0) NC = 9
            IF (NC > 1) THEN
              N = NC - 1
              DO 90 KI = 1, N
                IAT = NINT(CON(JAT, KI))
C * CHECK 'DISORDERED MOLECULE' FLAG
                IF (IPR(44) > 0) THEN
C * EXCLUDE DISORDER
                  CALL GEN048 (-8, IFG(2, IAT), 1, IPP)
                  IF (IPPR(IPP + 1, 1) < 10000) GO TO 90
                END IF
C * TEST FOR H-ATOM
                CALL GEN048 (-1, IFG(1, IAT), 7, IVAL)
                IF (IVAL == 0) THEN
                  J1 = KI + 1
                  DO KJ = J1, NC
                    KAT = NINT (CON(JAT, KJ))
C * TEST FOR NON-H ATOM
                    CALL GEN048 (-1, IFG(1, KAT), 7, IVAL)
                    IF (IVAL == 0) THEN
C * LOAD ALL ATOMS IN IATP ( > NP1 : NOT IN PLANE )
                      DO I = 1, NMAX
                        IATP(I) = NP1 + I
                      END DO
C * LOAD THREE BASE ATOMS  IN IATP
                      IATP(IAT) = IAT
                      IATP(JAT) = JAT
                      IATP(KAT) = KAT
                      IPR(12)   = 3
   80                 CALL PLA054 (0)
C * SEARCH FOR ATOMS THAT ARE IN-PLANE
                      DO I = 1, NMAX
C * CHECK 'DISORDERED MOLECULE' FLAG
                        IF (IPR(44) > 0) THEN
C * EXCLUDE DISORDER
                          CALL GEN048 (-8, IFG(2, I), 1, IPP)
                          IF (IPPR(IPP + 1, 1) < 10000) CYCLE
                        END IF
                        IF (IATP(I) >= NP1) THEN
                          CALL GEN048 (-6, IFG(1, I), 9, IRESI)
                          IF (IRESI == IRESJ) THEN
                            CALL GEN048 (-1, IFG(1, I), 7, IVAL)
                            IF (IVAL == 0) THEN
                              NCI = - NINT (CON(I, 9))
                              IF (NCI < 0) NCI = 9
                              IF (NCI /= 0) THEN
                                UITW = - XPV(4)
                                DO J = 1, 3
                                  UITW = UITW + XPV(J) * XXO(I, J + 3)
                                END DO
                                IF (ABS (UITW) <= PAR(49)) THEN
C * TEST WHETHER THIS NEW IN-PLANE ATOM IS CONNECTED TO ONE OF THE
C * PLANE DEFINING ATOMS.
                                  DO J = 1, NMAX
                                    IF (IATP(J) <=  NP1) THEN
                                      DO IJ = 1, NCI
                                        IF (NINT (CON(I, IJ)) == J)THEN
                                          IPR(12) = IPR(12) + 1
                                          IATP(I) = I
                                          GO TO 80
                                        END IF
                                      END DO
                                    END IF
                                  END DO
                                END IF
                              END IF
                            END IF
                          END IF
                        END IF
                      END DO
                      IF (IPR(12) > 3) CALL PLA045 (1)
                    END IF
                  END DO
                END IF
   90         CONTINUE
            END IF
  100     CONTINUE
        END IF
      END IF
      WRITE (LU8) -100, 0, JR, RMAT
      IPR(86) = 1
      RETURN
99999 FORMAT (/, ':: Maximum Ring-size has been Reset to:', I3, /)
99998 FORMAT (/, ':: Note: Ring-search Suppressed in Inorganic Mode.',
     1        /)
      END SUBROUTINE PLA078
 
      SUBROUTINE PLA079 (IAT)
C * COORDINATION ANALYSIS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: J0
      INTEGER            :: J1
      INTEGER            :: J2
      INTEGER            :: J3
      INTEGER            :: J4
      INTEGER            :: II
      INTEGER            :: IP
      INTEGER            :: JJ
      INTEGER            :: JX
      INTEGER            :: JY
      INTEGER            :: JZ
      INTEGER            :: KB
      INTEGER            :: MM
      INTEGER            :: NC
      INTEGER            :: NN
      INTEGER            :: NCI
      INTEGER            :: LBB
      INTEGER            :: LBC
      INTEGER            :: LBD
      INTEGER            :: KAT
      INTEGER            :: JPR
      INTEGER            :: JB1
      INTEGER            :: JB2
      INTEGER            :: JB3
      INTEGER            :: JB4
      INTEGER            :: IAT
      INTEGER            :: IB1
      INTEGER            :: IB2
      INTEGER            :: IDO
      INTEGER            :: IER
      INTEGER            :: IFT
      INTEGER            :: IHA
      INTEGER            :: IVL
      INTEGER            :: KDO
      INTEGER            :: KPC
      INTEGER            :: KPP
      INTEGER            :: MNI
      INTEGER            :: MNJ
      INTEGER            :: MNY
      INTEGER            :: MNX
      INTEGER            :: NDB
      INTEGER            :: NRLN
      INTEGER            :: NEFI
      INTEGER            :: NEFK
      INTEGER            :: NMAX
      INTEGER            :: NANG
      INTEGER            :: NADD
      INTEGER            :: MOL0
      INTEGER            :: MOL1
      INTEGER            :: MOL2
      INTEGER            :: MOL3
      INTEGER            :: MKAT
      INTEGER            :: KHAT
      INTEGER            :: KMET
      INTEGER            :: KDOA
      INTEGER            :: KATP
      INTEGER            :: JDUM
      INTEGER            :: IHAT
      INTEGER            :: IFT0
      INTEGER            :: IDOA
      INTEGER            :: IDUB
      INTEGER            :: IDUM
      INTEGER            :: ICOL
      INTEGER            :: NDEC
      INTEGER            :: INUM
      INTEGER            :: IDIS
      INTEGER            :: IENI
      INTEGER            :: IENK
      INTEGER            :: IMET
      INTEGER            :: ILMP
      INTEGER            :: KYUNK
      INTEGER            :: KPART
      INTEGER            :: JNQNR
      INTEGER            :: JATCI
      INTEGER            :: IYUNK
      INTEGER            :: IPART
      INTEGER            :: ILABX
      INTEGER            :: IDUM1
      INTEGER            :: IDUM2
      INTEGER            :: IDUM3
      INTEGER            :: ICOL0
      INTEGER            :: IDIS1
      INTEGER            :: IDIS2
      INTEGER            :: NDEC1
      INTEGER            :: NDEC2
      INTEGER            :: ISANG
      INTEGER            :: ISDIJ
      INTEGER            :: IATPI
      INTEGER            :: IRESI
      INTEGER            :: IRESJ
      INTEGER            :: MOLMNJ
      INTEGER            :: IPART0
      INTEGER            :: KPART0
      INTEGER            :: ISANGL
      INTEGER            :: IHEADER
      INTEGER            :: NCISAVE
      REAL               :: PHI
      REAL               :: OME
      REAL               :: DIJ
      REAL               :: ANG
      REAL               :: PHC
      REAL               :: DTP
      REAL               :: SGN
      REAL               :: PHS
      REAL               :: SP1
      REAL               :: SP2
      REAL               :: SP3
      REAL               :: TP1
      REAL               :: TBA
      REAL               :: XMU
      REAL               :: XSIG
      REAL               :: XMOL
      REAL               :: VDWI
      REAL               :: TPA1
      REAL               :: TPA2
      REAL               :: TH00
      REAL               :: TH11
      REAL               :: TH21
      REAL               :: TH31
      REAL               :: SPA1
      REAL               :: SPA2
      REAL               :: SSP1
      REAL               :: SSP2
      REAL               :: SSP3
      REAL               :: STP1
      REAL               :: QSP1
      REAL               :: QSP2
      REAL               :: QSP3
      REAL               :: QXOR
      REAL               :: QYOR
      REAL               :: PXOR
      REAL               :: PYOR
      REAL               :: PADD
      REAL               :: ANG1
      REAL               :: ANG2
      REAL               :: SDIJ
      REAL               :: SOME
      REAL               :: PSCL
      REAL               :: BDIF
      REAL               :: DIJN
      REAL               :: DIJT
      REAL               :: DLP1
      REAL               :: DLP2
      REAL               :: DLP3
      REAL               :: DMAX
      REAL               :: YUNK
      REAL               :: XMOL1
      REAL               :: VDWIK
      REAL               :: PSTP1
      REAL               :: DELTA
      REAL               :: BAVER
      REAL               :: ANGLE
      REAL               :: SANGL
      CHARACTER(len=4)   :: IMRK0
      CHARACTER(len=4)   :: IMRK2
      CHARACTER(len=4)   :: POLY
      CHARACTER(len=6)   :: IMRK1
      CHARACTER(len=58)  :: FORMA
      CHARACTER(len=133) :: FORMB
      CHARACTER(len=96)  :: FORMC
      CHARACTER(len=76)  :: FORMD
      CHARACTER(len=156) :: FORME
      CHARACTER(len=132) :: FORMF
      CHARACTER(len=6)   :: FORMK
      CHARACTER(len=9)   :: CXMOL
C * IPR(57) =  0 - CALC COORDN
C * IPR(57) =  1 - CALC METAL
C * IPR(57) =  2 - CALC RDF
C * IPR(57) <  0 - DSCAN
      IPR(440) = - IABS (IPR(440))
      DO I = 1, 100
        YMOL(1, I) = -1000.0
      END DO
   10 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
C * SETUP PRINT FORMATS
      FORMA( 1: 23) = '(I2,F8.4,''('',I2,'')'',3A,'
      FORMA(24: 54) = '''='',2A,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.1,''('',I3,'')''),2(2X,A))'
      FORME( 1: 29) = '(''Dist. '',A,'' - Polyh_C.G.:'','
      FORME(30: 57) = 'F7.3,''('',I3,'') Ang,  C.G.:'','
      FORME(58: 73) = 'F9.5,''('',I2,'')'','
      FORME(74:108) = FORME(58:73)//FORME(58:73)//'4X,'
      FORME(109:124)= 'F9.4,''('',I2,'')'','
      FORME(125:156)= FORME(109:124)//FORME(109:123)//')'
      FORMK(1:6)    = '(F9.2)'
      FORMF(1:  23) = '(1X,A,F8.4,''('',I3,''),'','
      FORMF(24: 89) = FORMF(2:23)//FORMF(2:23)//FORMF(2:23)
      FORMF(90:132) = FORMF(2:23)//FORMF(2:20)//''')'
      IF (PAR(42) < 100.0) THEN
        FORMK(5:5)   = '1'
        FORMC(73:73) = '1'
      END IF
      CALL PLA047 (LABA(IAT), NQ3, MNX, IENI, 0, IGBL(55), 0,
     1     1 - IGBL(55))
C * GET NUMBER OF ATOMS IN COORDN ARRAYS (IATC AND DATC)
      NC = IPR(79)
      IF (NC == 0) THEN
        IF (IPR(57) == 0) THEN
          WRITE (T112, 99995, IOSTAT = IOST) PAR(262), NQ3
 
        ELSE IF (IPR(57) == 1) THEN
          WRITE (T112, 99996, IOSTAT = IOST) PAR(262), NQ3
        END IF
        IF (IGBL(25) * IGBL(32) == 1) THEN
          BCD = T112(1:79)//CHAR(0)
          CALL GGIP (-999.0, 5.0, 80.0, 112)
          IGGT = ' '
        ELSE
          WRITE (LU6, 99978) T112
        END IF
        GO TO 50
      END IF
      CALL GEN048 (-1, IFG(1, IAT), 23, IDOA)
      NMAX = IPR(39)
      KPC  = NMAX + IPR(24) + 1
C * TEST FOR PSEUDO ATOM STACK OVERFLOW
      IF (KPC + NC > NP1 - IPR(75)) THEN
C * ATTEMPT TO EXCEED MAX ATOM LIMIT
        IPR(2) = 1
        GO TO 50
      END IF
C * PRINT HEADER (COORDINATION, DIST OR METAL: IPR(57) = 0,-1,1)
      IF (IPR(15) == 0) THEN
        IF (IGBL(63) > 2) THEN
C * NEWPAGE
          IF (IPR(57) == 0) THEN
            PAGET  = 'COORDN'
            CALL PLA262 (0)
            WRITE (LU7, 99990, IOSTAT = IOST)
          ELSE IF (IPR(57) < 0) THEN
            PAGET  = 'DSCAN'
            CALL PLA262 (0)
            WRITE (LU7, 99986, IOSTAT = IOST) LMT(- IPR(57), 1)
          ELSE
            PAGET  = 'METAL'
            CALL PLA262 (0)
            WRITE (LU7, 99989, IOSTAT = IOST)
          END IF
          WRITE (LU7, 99988, IOSTAT = IOST)
        END IF
        IPR(15) = 1
      END IF
      VDWI = ABS (VDWR(IENI))
      CALL GEN048 (-6, IFG(1, IAT),  9, IRESI)
      CALL GEN048 (-5, IFG(3, IAT), 14, IPART)
      IPART0 = IPART - 16
C * GET LABEL ETC. IAT
      CALL PLA036 (IAT, 1, 1, IDUM1, MNI, IDUM3, IPR(71), IGBL(55))
C * DETERMINE NUMBER OF BONDED ATOMS
      NCI = 0
      NDB = 0
      DO J = 1, NC
        KAT  = IATC(J)
        MKAT = MOD (KAT, NP1)
C * ELIMINATE SOME REDUNDANCY
        IDUB = 0
        IF (J > 1) THEN
          DO K = 2, J
            IF (MKAT == MOD(IATC(K - 1), NP1)) THEN
              IDUB = 2
              NDB  = NDB + 1
            END IF
          END DO
        END IF
C * CHECK FOR H
        CALL GEN048 (-1, IFG(1, MKAT), 7, IHA)
C * MAKE NON-BOND TO SORT DOWNWARDS IN THE BOND-LIST
        PADD = (IDUB + IHA + 1) * PAR(23)
        IF (KAT <= NP1) THEN
C * CHECK WHETHER THIS CONNECTION IS IN THE BOND ARRAY
          CALL PLA040 (-1, IAT, JJ, KAT)
          IF (JJ > 0) THEN
            NCI  = NCI + 1
            PADD = 0
          END IF
        END IF
        DATC(J) = PADD + DATC(J)
      END DO
C * SORT COORDINATION BONDS IN IATC ACCORDING TO DISTANCE IN DATC
      CALL GEN036 (DATC, IATC, 1, NC)
      NC = NC - NDB
C * OUTPUT COORDINATION DISTANCES
      XMOL1 = (1555 * PAR(42) + IRESI) / PAR(42)
C * CHECK FOR CARBON
      IF (IENI /= 2 .OR. IPR(168) > 0) THEN
C * BOND VALENCE ANALYSIS
        CALL PLA096 (0, NAMS(1, 1)(1:8), FLOAT(IAT), NCI)
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (-4)
          WRITE (PRBUF, FORMC, IOSTAT = IOST)
     1      PAR(23), NAMS(1, 1)(2:8), XMOL1,
     2      (XXO(IAT, L), L = 1, 6)
          CALL PLA263 (LU7, PRBUF, 132, 1, 10)
          WRITE (LU7, 99981, IOSTAT = IOST)
          WRITE (LU7, 99987, IOSTAT = IOST)
        END IF
      END IF
      IF (IPR(168) /= 0 .OR. IPR(170) /= 0) THEN
        WRITE (PRBUF, 99980, IOSTAT = IOST) PAR(23), NAMS(1, 1)(2:8)
        WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:46)
        IWIN = 0
        IF (IGBL(25) * IGBL(32) == 1 .AND. IPR(121) == 0) THEN
          IWIN = 1
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 0.6
          CALL PLA439 (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)
        END IF
      END IF
      DMAX = 0
C * LOOP OVER CONTACTS
      DO J = 1, NC
        ICOL    = 1
        KAT     = IATC(J)
        IPR(20) = 0
        IF (KAT > NP1) THEN
          KAT     = KAT - NP1
          IATC(J) = KAT
          IPR(20) = 1
        END IF
        CALL GEN048 (-6, IFG(1, KAT),  9, IRESJ)
        CALL GEN048 (-5, IFG(3, KAT), 14, KPART)
        KPART0 = KPART - 16
C * GET LABEL ETC. INFORMATION KAT
        CALL PLA036 (KAT, 1, 2, IDUM1, MNJ, IDUM3, IPR(71), IGBL(55))
        IF (MNJ > 1) THEN
          MOLMNJ = MOL(MNJ)
        ELSE
          MOLMNJ = NINT (1555 * PAR(42) + IRESJ)
        END IF
        XMOL = MOLMNJ / PAR(42)
        IF (ABS (XMOL1 - XMOL) < 0.005) IPR(20) = 0
        CALL GEN048 (-1, IFG(1, KAT), 23, KDOA)
C * FIRST GET SEQUENCE # IN PRIMARY LIST
        ILABX = - LABA(KAT)
        CALL PLA047 (ILABX, NQ4, MNY, IENK, IPR(71), IGBL(55), 0,
     1               1 - IGBL(55))
        NQ5 = NQ4
        CALL PLA046 (2, NQ4, IDUM, LBB, LBC, LBD, ILMP, JNQNR, KATP)
        CALL PLA047 (LABA(KAT), NQ3, MNY, IENK, IPR(71), 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 == 0) THEN
          IF (DIJ < DMAX .AND. IGBL(63) > 2
     1        .AND. (IENI /= 2 .OR. IPR(168) > 0)) THEN
            CALL PLA262 (1)
            WRITE (LU7, 99999, IOSTAT = IOST)
          END IF
          IF (J > NCI) THEN
            DELTA = DIJ - VDWIK
            IF (DELTA > 0.0) THEN
              IMRK0 = ' .. '
              ICOL  = 3
            ELSE
              IF (DELTA < - 0.2) THEN
                IMRK0 = ' << '
                ICOL  = 2
              ELSE
                IMRK0 = ' .< '
                ICOL  = 6
              END IF
              IF (IPR(20) /= 0 .AND. IAT <= KATP) THEN
                CALL GEN048 (-1, IFG(1, IAT), 19, IMET)
                CALL GEN048 (-1, IFG(1, KAT), 19, KMET)
                CALL GEN048 (-8, IFG(2, KAT),  1, KPP)
                IPR(120) = IPPR(KPP + 1, 1)
C * CHECK FOR INTRA POLYMER
                IF (IRESI /= IRESJ .OR. MPOL(IRESI) == 0 .OR.
     1            MPOL(IRESJ) == 0) THEN
                  IF (IDOA + KDOA == 2) THEN
C * CHECK FOR DONOR ATOM
                    CALL GEN048 (-1, IFG(1, IAT), 21, IDO)
                    CALL GEN048 (-1, IFG(1, KAT), 21, KDO)
                    CALL GEN048 (-4, IFG(3, IAT), 28, NEFI)
                    CALL GEN048 (-4, IFG(3, KAT), 28, NEFK)
                    IF (IMET + KMET == 0) THEN
                      IF (IATPR(IENI) /= -7 .AND.
     1                    IATPR(IENK) /= -7 .AND. DIJ < 2.9) THEN
                        IF (IPART0 == 0 .OR. KPART0 == 0) THEN
                          IF (IDO + KDO == 0 .AND. IPR(484) > 0) THEN
                            IF (IENI == 4 .AND. IENK == 4 .AND.
     1                          NEFI == 4 .AND. NEFK == 4) THEN
                              YUNK = -999.0
                            ELSE
                              YUNK = - DELTA
                            END IF
C * AVOID ARU OVERFLOW CASE
                            IF (IPR(600) == 0) THEN
                              CALL PLA393 (MOLMNJ, PAR(42), IDM)
C * ALERT _430
                              CALL PLA236 (-430, 2,
     1                        YUNK, DIJ, NAMS(1, 1)(2:10), NQ5)
                              CALL PLA236 (0, 0, 0.0, 0.0, IDM, ' ')
                            END IF
                          END IF
                        END IF
                      ELSE IF (IATPR(IENI) == -7) THEN
                        IF ((IPR(119) == 10000 .OR.
     1                  IPR(128) == 10000) .AND. KDO == 0) THEN
                          DIJT = 10.0
                          NADD = 0
C * F  .. F  CONTACTS
                          IF (IENI == 38 .AND. IENK == 38) THEN
                            DIJT = 2.6
                            NADD = 3
                          END IF
C * Cl .. Cl CONTACTS
                          IF (IENI == 5) THEN
                            IF (IENK == 5) THEN
                              DIJT = 2.60
                              NADD = 3
C * Cl .. O  CONTACTS
                            ELSE IF (IENK == 3) THEN
                              DIJT =  2.85
C * Cl .. F  CONTACTS
                            ELSE IF (IENK == 38) THEN
                              DIJT = 2.60
                              NADD = 3
                            END IF
                          END IF
                          IF (IENI == 7) THEN
C * Br .. Br CONTACTS
                            IF (IENK == 7) THEN
                              DIJT = 3.35
                              NADD = 3
C * Br .. Cl CONTACTS
                            ELSE IF (IENK == 5) THEN
                              DIJT = 2.6
                              NADD = 3
C * Br .. F  CONTACTS
                            ELSE IF (IENK == 38) THEN
                              DIJT = 2.6
                              NADD = 3
C * Br .. N  CONTACTS
                            ELSE IF (IENK == 4) THEN
                              DIJT = 2.75
                            END IF
                          END IF
                          IF (IENI == 9) THEN
C * I .. I   CONTACTS
                            IF (IENK == 9) THEN
                              DIJT = 3.5
                              NADD = 3
C * I .. Br  CONTACTS
                            ELSE IF (IENK == 7) THEN
                              DIJT = 2.8
                              NADD = 3
C * I .. Cl  CONTACTS
                            ELSE IF (IENK == 5) THEN
                              DIJT = 2.8
                              NADD = 3
C * I .. F   CONTACTS
                            ELSE IF (IENK == 38) THEN
                              DIJT = 2.8
                              NADD = 3
C * I .. O   CONTACTS
                            ELSE IF (IENK == 3) THEN
                              CALL GEN048 (-4, IFG(3, IAT), 28, IYUNK)
                              CALL GEN048 (-4, IFG(3, KAT), 28, KYUNK)
                              IF (IYUNK == 1) THEN
                                IF (KYUNK == 1) THEN
                                  DIJT = 2.7
                                ELSE
                                  DIJT = 3.0
                                END IF
                              ELSE
                                DIJT = 2.5
                              END IF
C * I .. N   CONTACTS
                            ELSE IF (IENK == 4) THEN
                              DIJT = 2.65
                            END IF
                          END IF
C * NOTE: SUPPRESS '*' SYMMETRY CODES
                          IF (DIJ < DIJT .AND.
     1                      IPR(120) == 10000 .AND. MNY < 27) THEN
C * ALERT _431 & _434
                            CALL PLA393 (MOLMNJ, PAR(42), IDM)
                            CALL PLA236 (-(431 + NADD), 2, -DELTA,
     1                        DIJ, NAMS(1, 1)(2:10), NQ5(1:7))
                            CALL PLA236 (0, 0, 0.0, 0.0, IDM, ' ')
                          ELSE IF (DELTA < -0.1) THEN
                            CALL PLA393 (MOLMNJ, PAR(42), IDM)
                            CALL PLA236 (-(431 + NADD), 2, -999.0, DIJ,
     1                        NAMS(1, 1)(2:10), NQ5)
                            CALL PLA236 (0, 0, 0.0, 0.0, IDM, ' ')
                          END IF
                        END IF
                      END IF
                    END IF
                  ELSE
                    CALL GEN048 (-1, IFG(1, IAT), 7, IHAT)
                    CALL GEN048 (-1, IFG(1, KAT), 7, KHAT)
                    IF (IHAT + KHAT + IMET + KMET == 0) THEN
C * ALERT _432 & _433 : HANDLE MINOR-MINOR DISORDER
                      IF (IPR(119) > 150 .OR. IPR(120) > 150) THEN
                        N = 432
                      ELSE
                        N = 433
                      END IF
C * AVOID ARU-O
                      IF (IPR(600) == 0) THEN
                        IF (IPART0 == 0 .OR. KPART0 == 0) THEN
                          IF (DELTA < -0.2) THEN
                            CALL PLA393 (MOLMNJ, PAR(42), IDM)
                            CALL PLA236 (-N, 2, -999.0, DIJ,
     1                        NAMS(1, 1)(2:10), NQ5)
                            CALL PLA236 (0, 0, 0.0, 0.0, IDM, ' ')
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END IF
          ELSE
            IMRK0 = ' -- '
          END IF
          DMAX  = DIJ
          ISDIJ = MIN (99, ISDIJ)
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
          FORMA(8 : 8) = CHAR(ICHAR('0') + NDEC)
          CALL PLA050 (IAT, KAT, 0, 0, DIJN)
          DO JJ = 4, 6
            XXO(KPC, JJ) = (XXO(KAT, JJ) - XXO(IAT, JJ)) / DIJN
C * COPY TENTATIVE ESD'S
            XSD(KPC, JJ) = XSD(IAT, JJ)
          END DO
C * GENERATE COORDINATES OF UNIT LENGTH VERTICES
          DO JJ = 4, 6
            XXO(KPC + J, JJ) = XXO(IAT, JJ) + XXO(KPC, JJ)
C * COPY TENTATIVE ESD'S
            XSD(KPC + J, JJ) = XSD(IAT, JJ)
          END DO
          LABA(KPC + J) = LABA(KAT)
C * SAVE ADDRESS OF UNNORMALIZED COORDINATES IN JATC
          JATC(J) = IATC(J)
C * CALCULATE SPHERICAL COORDINATES MU & PHI FOR DIRECTION OF THIS BOND
          IF (ABS (XXO(KPC, 6)) < 0.999) THEN
            XMU = 90.0 - RGBL(6) * ACOS(XXO(KPC, 6))
            PHI = RGBL(6) * ATAN2 (XXO(KPC, 5), XXO(KPC, 4))
          ELSE
            XMU = SIGN (90.0, XXO(KPC, 6))
            PHI = 0.0
          END IF
          IF (IPR(20) == 0) THEN
            IMRK1 = ' Intra'
          ELSE
            IMRK1 = '      '
          END IF
C * GET SYMMETRY OPERATION
          CALL GEN098 (MOLMNJ, PAR(42), MOL0, MOL1, MOL2, MOL3, IDUM)
          SGY(4) = MOL1
          SGY(5) = MOL2
          SGY(6) = MOL3
          CALL SGSM (20, IDM, SGY, MOL0, 0, IERR)
C * LOWER CASE X, Y, Z
          CALL GEN020 (-1, IDM, 1, 22)
          IF (IDM(1 : 6) == 'x,y,z ') IDM(1:5) = '     '
          WRITE (CXMOL, FORMK, IOSTAT = IOST) XMOL
C * HANDLE (BLANK) INTRA CODES
          IF (XMOL == XMOL1) CXMOL = '         '
          IF (INT(XMOL) == 1555) CXMOL(1:7) = '       '
          IF (IMRK2 /= IMRK0) THEN
            VRT = VRT - 0.2
            IMRK2 = IMRK0
          END IF
C * HANDLE FORMAT OVERFLOW
          JPR = MIN (J, 99)
C * BOND VALENCE ANALYSIS - STORE CONTACT
          CALL PLA096 (1, NAMS(1, 2)(1:8), DIJ, NCI)
          WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1      JPR, DIJ, ISDIJ, IMRK0, NAMS(1, 2)(1:8),
     2      IDM(1:22), CXMOL, IMRK1, PHI, XMU, (XXO(KAT, L), L = 1, 6)
C * BLANK FOR INTRA CODE
          IF (CXMOL == '         ') CALL GEN038 (PRBUF, 27, 58)
          IF (IGBL(63) > 2 .AND.
     1       (IENI /= 2 .OR. IPR(168) > 0)) THEN
            CALL PLA263 (LU7, PRBUF, 132, 1, 3)
            IF (J == NCI .AND. NCI > 0 .AND. NC > NCI) THEN
              CALL PLA262 (1)
              WRITE (LU7, 99999, IOSTAT = IOST)
            END IF
          END IF
C * INTERACTIVE OUTPUT FOR SPECIFIED ATOM
          IF (IPR(168) /= 0 .OR. IPR(170) /= 0) THEN
            CALL PLA263 (LU6, PRBUF, 58, 1, 3)
            IF (IWIN == 1) THEN
              VRT = VRT - 0.5
              YMOL(1, JPR) = VRT + 0.175
              YMOL(2, JPR) = XMOL
              IF (ICOL == 2) THEN
                NRLN = 2 + KDOA
              ELSE
                NRLN = 2
              END IF
              IF (J < 36) THEN
                LINE = PRBUF(1:26)//' '//PRBUF(50:58)//' = '//
     1                 PRBUF(27:48)
                CALL PLA439 (0.0, LINE, 61, 0.35, ICOL, NRLN, 0.1, VRT)
              ELSE IF (J == 36) THEN
                CALL PLA439 (0.0, '.. etc ..', 9, 0.35, ICOL, NRLN, 8.0,
     1            VRT)
              END IF
              DO L = 1, 3
                V1(L) = (XXO(KAT, L + 3) - XXO(IAT, L + 3)) * PSCL
              END DO
              CALL GEN002 (-1, RMAT, V1, V2, YUNK)
              IF (ICOL /= 3) THEN
                CALL PLA439 (0.0, PRBUF, 2, 0.4, ICOL, NRLN,
     1               PXOR + V2(1) - 0.4, PYOR + V2(2) - 0.20)
                IF (V2(3) >= 0) THEN
                  ICOL0 = 3
                ELSE
                  ICOL0 = 4
                END IF
                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)
              END IF
            END IF
          END IF
          IF (IGBL(31) == 3) WRITE (LU2, 99994, IOSTAT = IOST)
     1      NQ3, (XXO(KAT, L), L = 4, 6), (XSD(KAT, L), L = 4, 6)
        END IF
      END DO
C * BOND VALENCE ANALYSIS
      IF (IENI /= 2 .OR. IPR(168) > 0)
     1  CALL PLA096 (-1, NAMS(1, 1)(1:8), 0.0, NCI)
      IF (IGBL(31) == 3) THEN
        WRITE (LU2, 99993, IOSTAT = IOST)
        IF (IOST /= 0) STOP 'LU2 - 78'
      END IF
C * ANALYSE DISTORTION OF COORDINATION POLYHEDRA (VOLCAL/FINGER)
      NCISAVE = NCI
      IF (IGBL(63) > 2 .AND.
     1   (IENI /= 2 .OR. IPR(168) > 0)) THEN
        IF (NCI >= 4 .AND. NCI <= 12) THEN
          CALL PLA279 (IAT, NCI)
        END IF
      END IF
      NCI = NCISAVE
C * OUTPUT COORDINATION ANGLES, EXIT WHEN NO ANGLE CALCULATION IS REQUESTED
      IF (IPR(7) /= 0) THEN
        IF (IPR(122) < 0) IPR(122) = 0
        IF (IPR(122) == 0 .AND. NCI == 5 .AND. IPR(7) > 0)
     1      IPR(122) = -5
        IHEADER = 0
        KB = 0
        NN = NC - 1
        DO J1 = 1, NN
          JB1 = JATC(J1)
          CALL GEN048 (-1, IFG(1, JB1), 7, IVL)
          IF (IVL == 0 .OR. IPR(521) /= 0) THEN
            MM  = MAX (J1, IABS (IPR(122))) + 1
            DO 20 J2 = MM, NC
              JB2 = JATC(J2)
              CALL GEN048 (-1, IFG(1, JB2), 7, IVL)
              IF (IVL == 0 .OR. IPR(521) /= 0) THEN
                CALL PLA053 (JB1, IAT, JB2, 0, ANGLE, SANGL, ISANGL,
     1                       NDEC, IER)
                IF (IER /= 0) GO TO 20
                KB  = KB + 1
                CALL PLA036 (JB1, KB, 2, IDUM1, IDUM2, IDUM3, IPR(71),
     1                       IGBL(55))
                CALL PLA036 (JB2, KB, 3, IDUM1, IDUM2, IDUM3, IPR(71),
     1                       IGBL(55))
                DBUF(KB)  = ANGLE
                IDBUF(KB) = MIN (999, ISANGL)
                IFT       = -11 + KB * 33
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
                FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
                IF (KB >= 4) THEN
                  IF (IGBL(63) > 2 .AND.
     1               (IENI /= 2 .OR. IPR(168) > 0)) THEN
                    IF (IHEADER == 0) THEN
                      IHEADER = 1
                      CALL PLA262 (3)
                      WRITE (LU7, 99998, IOSTAT = IOST) NAMS(1, 1)(1:7)
                    END IF
                    WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1                ((NAMS(L, M)(1:8), M = 2, 3), DBUF(L), IDBUF(L),
     2                  L = 1, KB)
                    CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                  END IF
                  KB = 0
                END IF
              END IF
   20       CONTINUE
          END IF
        END DO
C * CLEAR BUFFER
        IF (KB > 0 .AND. IGBL(63) > 2 .AND.
     1     (IENI /= 2 .OR. IPR(168) > 0)) THEN
          IF (IHEADER == 0) THEN
            IHEADER = 1
            CALL PLA262 (3)
            WRITE (LU7, 99998, IOSTAT = IOST) NAMS(1, 1)(1:7)
          END IF
          WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1      ((NAMS(L, M)(1:8), M = 2, 3), DBUF(L), IDBUF(L), L = 1, KB)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
        END IF
C * ANALYSE COORDINATION POLYHEDRON
        NC = MIN (NC, IABS(IPR(122)))
        IF (NC == 0 .OR. NC < IABS(IPR(122))) GO TO 50
C * PREPARE FOR LS.PLANE CALCULATION
        DO I = 1, NMAX
          IATP(I) = I + 2 * NP1
        END DO
        DO I = 1, 5
          IATP(JATC(I)) = JATC(I)
        END DO
        IATP(IAT) = IAT + NP1
        NANG      = 0
        ANG1      = 0.0
        ANG2      = 0.0
C * CALCULATE CENTRE OF GRAVITY OF COORDINATION POLYHEDRON
C * NO OVERFLOW TEST AS YET FOR NC + 1 NEW ITEMS
        DO JJ = 1, 6
          XXO(KPC, JJ) = 0.0
          XSD(KPC, JJ) = 0.0
        END DO
        DO I = 1, NC
          IP = IATC(I)
          DO 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)
          END DO
          DATC(I) = 0.0
          IF (IPR(125) == 1 .AND. IABS (IPR(122)) > 0)
     1        IATC(I) = KPC + I
        END DO
        YUNK = 0.0
        DO 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)
          YUNK             = YUNK + XSD(KPC, JJ)
        END DO
        IF (YUNK > 0.0) CALL GEN048 (1, IFG(2, KPC), 10, 1)
        CALL PLA262 (2)
        IF (IPR(125) == 0) THEN
          POLY = 'Real'
        ELSE
          POLY = 'Unit'
        END IF
C * CALCULATE DISTANCE OF COORDINATED ATOM TO C.G. POLYHEDRON
        CALL PLA053 (IAT, KPC, 0, 0, DBUF(1), SDIJ, IDIS, INUM, IER)
        IF (IER == 0) THEN
          IF (IGBL(63) > 2 .AND.
     1       (IENI /= 2 .OR. IPR(168) > 0)) THEN
            CALL PLA262 (3)
            IDBUF(1) = MIN (999, IDIS)
            FORME(33:33) = CHAR (ICHAR ('0') + INUM)
            IFT0 = 45
            DO JJ = 1, 6
              IF (JJ == 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)
            END DO
            WRITE (LU7, 99999, IOSTAT = IOST)
            WRITE (PRBUF, FORME, IOSTAT = IOST) NAMS(1, 1)(2:7),
     1                          (DBUF(JJ), IDBUF(JJ), JJ = 1, 7)
            CALL PLA263 (LU7, PRBUF, 132, 1, 3)
            WRITE (LU7, 99985, IOSTAT = IOST) NAMS(1, 1)(1:7), POLY
          END IF
        END IF
        NN = NC - 1
C * IB1 & IB2 ARE POINTERS TO REAL POLYHEDRON COORDINATES(FOR DIST&ANGLE)
C * JB1 & JB2 ARE POINTERS TO UNIT POLYHEDRON COORDINATES(FOR COORDN.)
        DO J1 = 1, NN
          JB1 = IATC(J1)
          IF (JB1 > KPC) THEN
            IB1 = JATC(JB1 - KPC)
          ELSE
            IB1 = JB1
          END IF
          MM = J1 + 1
          DO J2 = MM, NC
            JB2 = IATC(J2)
            IF (JB2 > KPC) THEN
              IB2 = JATC(JB2 - KPC)
            ELSE
              IB2 = JB2
            END IF
            IF (NC == IABS (IPR(122))) THEN
              ANG = 0.0
              JX  = 0
              JY  = 0
              DO J3 = 1, NC
                IF (J3 /= J1 .AND. J3 /= J2) THEN
                  JB3 = IATC(J3)
                  DO J4 = 1, NC
                    IF (J4 /= J1 .AND. J4 /= J2 .AND. J4 /= J3)
     1                THEN
                      JB4 = IATC(J4)
                      CALL PLA050 (JB3, JB1, JB2, JB4, OME)
                      IF (ABS (OME) > ANG) THEN
                        JX  = JB3
                        JY  = JB4
                        ANG = ABS (OME)
                      END IF
                    END IF
                  END DO
                END IF
              END DO
C * CATCH AND WARN FOR PROBLEM
              IF (JX == 0 .OR. JY == 0) THEN
                WRITE (LU6, 99982, IOSTAT = IOST)
                GO TO 50
              END IF
              DO I = 1, NC
                JZ = IATC(I)
                IF (JZ /= JB1 .AND. JZ /= JB2 .AND.
     1              JZ /= JX  .AND. JZ /= JY) EXIT
              END DO
              SOME = 0.0
              CALL PLA053 (JX, JB1, JB2, -JY, DBUF(3), SOME, IDUM1,
     1                    IDUM2, IER)
              IF (IER /= 0) CYCLE
              IDBUF(3) = MIN (999, NINT (SOME * 100.0))
              CALL PLA053 (JX, JB1, JB2, -JZ, DBUF(4), SOME, IDUM1,
     1                     IDUM2, IER)
              IF (IER /= 0) CYCLE
              IDBUF(4) = MIN (999, NINT (SOME * 100.0))
              CALL PLA053 (JZ, JB1, JB2, -JY, DBUF(5), SOME, IDUM1,
     1                     IDUM2, IER)
              IF (IER /= 0) CYCLE
              IDBUF(5) = MIN (999, NINT (SOME * 100.0))
              DBUF(6)  = 180.0 - ABS (DBUF(4) + DBUF(5))
              IDBUF(6) = (IDBUF(4) + IDBUF(5)) / 2
C * POTENTIAL PROBLEM ('C' UNDONE)
              IF (DBUF(6) > 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
              END IF
            END IF
            CALL PLA053 (IB1, IAT, IB2, 0, DBUF(1), SANGL, ISANG,
     1                   NDEC1, IER)
            IF (IER /= 0) CYCLE
            CALL PLA053 (IB1, IB2,   0, 0, DBUF(2),  SDIJ, IDIS,
     1                   NDEC2, IER)
            IF (IER == 0) THEN
              IDBUF(1) = MIN (999, ISANG)
              IDBUF(2) = MIN (999, IDIS)
C * MODIFY NUMBER OF DECIMAL DIGITS IN OUTPUT FORMAT
              FORMD(15 : 15) = CHAR (ICHAR ('0') + NDEC1)
              FORMD(34 : 34) = CHAR (ICHAR ('0') + NDEC2)
              CALL PLA036 (IB1, 1, 1, IDIS1, IDUM1, IDUM2, IPR(71),
     1                     IGBL(55))
              CALL PLA036 (IB2, 1, 2, IDIS2, IDUM1, IDUM2, IPR(71),
     1                     IGBL(55))
              CALL PLA047 (LABA(JX), NQ2, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 1 - IGBL(55))
              CALL PLA047 (LABA(JY), NQ3, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 1 - IGBL(55))
C * REGISTER LARGEST ANGLES
              IF (DBUF(1) > ANG1) THEN
                ANG2 = ANG1
                ANG1 = DBUF(1)
              ELSE IF (DBUF(1) > ANG2) THEN
                ANG2 = DBUF(1)
              END IF
              IF (IGBL(63) > 2 .AND.
     1           (IENI /= 2 .OR. IPR(168) > 0)) THEN
                WRITE (PRBUF, FORMD, IOSTAT = IOST)
     1            (NAMS(1, M)(1:7), M = 1, 2),
     2            (DBUF(L), IDBUF(L), L = 1, 6), NQ2, NQ3
                CALL PLA263 (LU7, PRBUF, 132, 1, 3)
              END IF
            END IF
          END DO
        END DO
C * CHECK FOR N-COORDINATION
        IF (IPR(122) /= 0) THEN
C * 5-COORDINATION
          IF (NC == 5) THEN
            IF (PAR(35) > 0.0) THEN
              TBA = PAR(35)
C * TBA ZN - H.Vahrenkamp (1999) Acc. Chem. Res. 32, 589-596.
            ELSE IF (IENI == 103) THEN
              TBA = 158
            ELSE
              TBA  = PAR(31)
            END IF
            PHC  = COS (TBA / (2 * RGBL(6)))
            PHS  = SIN (TBA / (2 * RGBL(6)))
            SPA1 = 180.0 - RGBL(6) * ATAN ((1.0 + PHC) * SQRT (2.0) /
     1             PHS)
            SPA2 = 180.0 - 2.0 * RGBL(6) * ATAN (SQRT (2.0 / (1.0
     1           + PHC)))
            TPA1 = 180.0 - 2.0 * RGBL(6) * ATAN (2.0 / SQRT (6.0))
            TPA2 = 180.0 - 2.0 * RGBL(6) * ATAN (2.0)
            DTP  = 4.0 * ABS (TPA1 - SPA1) + 2.0 * ABS (TPA1 - SPA2) +
     1             2.0 * ABS (TPA2 - SPA2) + TPA2
            IF (IGBL(63) > 2 .AND.
     1         (IENI /= 2 .OR. IPR(168) > 0)) THEN
              CALL PLA262 (4)
              WRITE (LU7, 99979, IOSTAT = IOST)
              WRITE (PRBUF, 99977, IOSTAT = IOST)
     1           ANG1, ANG2, (ANG1 - ANG2) / 60.0
              WRITE (LU7, 99978, IOSTAT = IOST) PRBUF
              IF (IWIN == 1) THEN
                VRT = VRT - 0.6
                CALL PLA439 (0.0, PRBUF, 132, 0.25, 5 + IGBL(68),
     1            2, 0.2, VRT)
              END IF
              CALL PLA262 (8)
              WRITE (LU7, 99983, IOSTAT = IOST)
     1          TBA, TPA1, TPA2, SPA1, SPA2, DTP
            END IF
            CALL GEN036 (DATC, IATC, 1, NC)
            CALL GEN036 (DATC, JATC, 1, NC)
            STP1 = 0.0
            SSP1 = 0.0
            SSP2 = 0.0
            SSP3 = 0.0
            DO II = 1, NANG
              JB1 = KBO(II, 1)
              JB2 = KBO(II, 2)
              ANG = BOK(II, 1)
              DO JJ = 1, NC
                IF (IATC(JJ) == JB1) J1 = JJ
                IF (IATC(JJ) == JB2) J2 = JJ
              END DO
              IF (J1 > J2) THEN
                J0 = J1
                J1 = J2
                J2 = J0
              END IF
              IF (J1 > 2) THEN
                TP1 = TPA2
              ELSE
                TP1 = TPA1
              END IF
              STP1 = STP1 + ABS (TP1 - ANG)
              SP1  = SPA1
              SP2  = SPA1
              SP3  = SPA1
              IF (J1 == 4 .AND. J2 == 5) SP1 = 0.0
              IF (J1 == 3 .AND. J2 == 5) SP2 = 0.0
              IF (J1 == 3 .AND. J2 == 4) SP3 = 0.0
              IF (J1 == 3 .OR.  J2 == 3) SP1 = SPA2
              IF (J1 == 4 .OR.  J2 == 4) SP2 = SPA2
              IF (J1 == 5 .OR.  J2 == 5) SP3 = SPA2
              SSP1 = SSP1 + ABS (SP1 - ANG)
              SSP2 = SSP2 + ABS (SP2 - ANG)
              SSP3 = SSP3 + ABS (SP3 - ANG)
            END DO
            QSP1 = DTP - SSP1
            QSP2 = DTP - SSP2
            QSP3 = DTP - SSP3
            CALL PLA047 (LABA(IATC(3)), NQ1, IDUM, JDUM, IPR(71),
     1                   IGBL(55), 0, 1 - IGBL(55))
            CALL PLA047 (LABA(IATC(4)), NQ2, IDUM, JDUM, IPR(71),
     1                   IGBL(55), 0, 1 - IGBL(55))
            CALL PLA047 (LABA(IATC(5)), NQ3, IDUM, JDUM, IPR(71),
     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 PLA262 (6)
            BDIF = STP1 - QSP1
            IF (IGBL(63) > 2 .AND.
     1         (IENI /= 2 .OR. IPR(168) > 0)) THEN
              WRITE (LU7, 99991, IOSTAT = IOST)
     1          DTP, NQ1, STP1, SSP1, QSP1, DLP1, TH11, TH00, NQ2, STP1,
     2          SSP2, QSP2, DLP2, TH21, TH00, NQ3, STP1, SSP3, QSP3,
     3          DLP3, TH31, TH00
            END IF
            IF (STP1 - QSP2 < BDIF) THEN
              NQ1   = NQ2
              QSP1  = QSP2
              BDIF  = STP1 - QSP1
            END IF
            IF (STP1 - QSP3 < BDIF) THEN
              NQ1   = NQ3
              QSP1  = QSP3
              BDIF  = STP1 - QSP3
            END IF
            BAVER = (STP1 + QSP1) / 2.0
            PSTP1 = BAVER * 100.0 / DTP
            DO JATCI = 1, 5
              CALL PLA047 (LABA(JATC(JATCI)), NQ2, IDUM, JDUM,
     1          IPR(71), IGBL(55), 0, 1 - IGBL(55))
              IF (NQ2(1:6) == NQ1(1:6)) THEN
                IATP(JATC(JATCI)) = JATC(JATCI) + NP1
              END IF
            END DO
            IF (IGBL(63) > 2 .AND.
     1         (IENI /= 2 .OR. IPR(168) > 0)) THEN
              CALL PLA262 (7)
              WRITE (LU7, 99999, IOSTAT = IOST)
              WRITE (PRBUF, 99992, IOSTAT = IOST) PSTP1, '>', '>'
              IF (IWIN == 1) THEN
                VRT = VRT - 0.5
                CALL PLA439 (0.0, PRBUF, 132, 0.23, 5 + IGBL(68),
     1            2, 0.2, VRT)
              END IF
              WRITE (LU7, 99978, IOSTAT = IOST) PRBUF
              WRITE (LU7, 99976, IOSTAT = IOST) NQ1(1:6), BAVER, BDIF
            END IF
          END IF
C * CALCULATE DISTANCE METAL TO SP-PLANE
          IF (PSTP1 > 50) THEN
            IPR(12) = 4
C * SORT IATP
            CALL GEN022 (IATP, 1, NMAX, 1)
C * CALCULATE PLANE
            CALL PLA055
            SGN = 1
            DO I = 1, 6
              IATPI = MOD (IATP(I), NP1)
              CALL PLA036 (IATPI, I, 1, IDUM1, IDUM2, IDUM3, IPR(71),
     1                     IGBL(55))
              CALL PLA056 (XPV(1), IATPI, DEV(I), SDV(I), ISDV(I),
     1                     5, NDEC)
              ISDV(I) = MIN (99, ISDV(I))
              IFT           = -12 + I * 22
              FORMF(IFT:IFT) = CHAR (ICHAR('0') + NDEC)
            END DO
            IF (DEV(4) < 0.0) SGN = -1.0
            IF (IGBL(63) > 2 .AND.
     1         (IENI /= 2 .OR. IPR(168) > 0)) THEN
              CALL PLA262 (3)
              WRITE (LU7, 99999, IOSTAT = IOST)
              WRITE (PRBUF, 99997, IOSTAT = IOST)
     1          (NAMS(I, 1)(2:8), I = 1, 4)
              WRITE (LU7, 99978, IOSTAT = IOST) PRBUF
              IF (IWIN == 1) THEN
                VRT = VRT - 0.5
                CALL PLA439 (0.0, PRBUF, 80, 0.25, 5 + IGBL(68),
     1            2, 0.0, VRT)
              END IF
              WRITE (PRBUF, FORMF, IOSTAT = IOST)
     1          (NAMS(I, 1)(2:8), DEV(I) * SGN, ISDV(I), I = 1, 6)
                CALL PLA263 (LU7, PRBUF, 132, 1, 3)
              IF (IWIN == 1) THEN
                VRT = VRT - 0.5
                CALL PLA439 (0.0, PRBUF, 132, 0.23, 5 + IGBL(68),
     1            2, 0.0, VRT)
              END IF
            END IF
          END IF
        END IF
      END IF
   50 IF (IWIN == 1) THEN
        IF (IABS (IGBL(6)) == 1) THEN
          CALL PLA015 (0, 45)
        END IF
        CALL PLA297 (2)
        IF (IGGT(1:4) == 'CALC') GO TO 10
      END IF
      IPR(440) = IABS (IPR(440))
      RETURN
99999 FORMAT (1X)
99998 FORMAT (/, 'Angles (Degrees)  At1...V...At2 with Vertex V = ',
     1  A, /, 132('-'))
99997 FORMAT (
     1 ' Distance (Ang) to SP Square Base Plane Defined by:', 4(1X, A))
99996 FORMAT (':: No Metal-Metal Distances within ', F5.1,
     1        ' Ang. for ', A)
99995 FORMAT (':: No Atoms within ', F5.1, ' Ang. for ', A)
99994 FORMAT ('ATOM ', A, 1X, 6F8.4)
99993 FORMAT ('ENDS')
99992 FORMAT ('Trigonal Bipyramid (TP) to Square Pyramid (SP)',
     1 ' ::: Perc. Along Berry Pseudorotation Coordinate:', F6.1, 2X,
     2 ':::  D3h  ---', A, ' C2v ---', A, ' C4v')
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 ' ''<<'' = < sum vdW-radii - 0.2, ''.<'' = < sum vdW',
     6 '-radii, ''..'' = > 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, /)
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('-'))
99978 FORMAT (A)
99977 FORMAT ('Tau = (Beta - Alpha) / 60 = (', F6.2, '-', F6.2,
     1        ') / 60 =', F5.2,
     2        '  :  (Extreme Forms: Tau = 0.00 for SP and 1.00 for TP)')
99976 FORMAT (/, 'NOTE: This Analysis Depends on the Value of the',
     1 ' Trans Basal Angle that is used (Default Value = 150 Deg.).', /,
     2 6X, 'The Pivot Atom that Best Describes a Berry Pseudo',
     3 ' Rotation is: ', A, /, 6X, 'The Percentage has been',
     4 ' Calculated for the Average value,', F7.1, ' Deg., of the',
     5 ' Second and Fourth Table Entry.', /, 5X, ' The Difference,',
     6 F7.1, ' Deg., Between the Second and Fourth Table Entry',
     7 ' (for pivot) should be Zero for a True',
     * ' Berry Rotation.')
      END SUBROUTINE PLA079
 
      SUBROUTINE PLA080
C * COMPOSE & CHECK COMPOSITION STRINGS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE sgxyz
      IMPLICIT NONE
      INTEGER                            :: I
      INTEGER                            :: J
      INTEGER                            :: K
      INTEGER                            :: L
      INTEGER                            :: M
      INTEGER                            :: N
      INTEGER                            :: N1
      INTEGER                            :: L9
      INTEGER                            :: JM
      INTEGER                            :: NN
      INTEGER                            :: ML
      INTEGER                            :: NO1
      INTEGER                            :: MM0
      INTEGER                            :: IC1
      INTEGER                            :: NAT
      INTEGER                            :: KMX
      INTEGER                            :: NPP
      INTEGER                            :: NSP
      INTEGER                            :: NWL
      INTEGER                            :: MOL1
      INTEGER                            :: MOL2
      INTEGER                            :: MOL3
      INTEGER                            :: MOL4
      INTEGER                            :: MULT
      INTEGER                            :: JUNK
      INTEGER                            :: IENL
      INTEGER                            :: IZET
      INTEGER                            :: JZET
      INTEGER                            :: IRES
      INTEGER                            :: IGGD
      INTEGER                            :: NATX
      INTEGER                            :: NMOL
      INTEGER                            :: NRES
      INTEGER                            :: NSYM
      INTEGER                            :: KEXIT
      INTEGER                            :: IRES0
      INTEGER                            :: IRESJ
      INTEGER                            :: ITEMP
      INTEGER                            :: NCOUNT
      INTEGER                            :: NONINT
      INTEGER                            :: NHEAVY
      INTEGER                            :: INSIDE
      INTEGER                            :: ISPECIAL
      INTEGER,           DIMENSION(48)   :: ISOF
      REAL                               :: C1
      REAL                               :: WT
      REAL                               :: PPM
      REAL                               :: DIF
      REAL                               :: DOM
      REAL                               :: XML
      REAL                               :: YMR
      REAL                               :: YUNK
      REAL                               :: XDIF
      REAL                               :: SIGD
      REAL                               :: XDIF1
      REAL                               :: DXREP
      REAL                               :: RATIO
      REAL                               :: F000A
      REAL                               :: F000B
      REAL                               :: FDELA
      REAL                               :: FDELB
      REAL                               :: SUMWT
      REAL                               :: FDELBM
      REAL                               :: ACOUNT
      REAL                               :: FZEROL
      REAL                               :: FZEROM
      REAL                               :: RESSCAN
      REAL                               :: RESSCAT
      REAL                               :: FRIEDIFN
      REAL                               :: FRIEDIFT
      REAL,              DIMENSION(NP10) :: PERC
      CHARACTER(len=7)                   :: RAT
      CHARACTER(len=82)                  :: FORMA
      CHARACTER(len=4)                   :: ISORD
      CHARACTER(len=42), DIMENSION(2)    :: WNOTE
      CHARACTER(len=6)                   :: SPSITE
      ISOF = (/
     1 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0,
     2 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
     3 0, 0, 0, 0, 0, 1/)
      IWIN = IGBL(25) * IGBL(32)
      WNOTE(1) = ' '
      WNOTE(2) = '[Note: Based on SHELXL2019 Atomic Weights]'
      FORMA( 1:40) = '( 6X,''Calculated Density ='',F8.4,''('',I2,'
      FORMA(41:82) = ''') g cm-3 [= Mg m-3]'',30x,''** WARNING **'')'
C * ROUTINE DETERMINES & CHECKS THE MOIETY FORMULA
C * GET NUMBER OF PRIMARY ATOMS
      NATX = IPR(37)
C * GET NUMBER OF ATOMS IN EXPANDED ATOM LIST
      NAT  = IPR(39)
C * GET NUMBER OF RESIDUES
      NRES = IPR(75)
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
C * INIT # OF SPECIES
      IPR(488) = 3
C * INIT MOL WEIGHT
      PAR(163) = 0.0
C * INIT FOOO
      PAR(157) = 0.0
C * INIT CONTENTS
      DO J = 1, NP10
        CONT(J, 2) = 0.0
      END DO
C * LIST UNITCELL CONTENTS PER RESIDUE
      IF (IGBL(63) > 2) THEN
C * CHECK FOR/REPORT (DIS)ORDERED STRUCTURE
        IF (IPR(44) == 1) THEN
          CALL PLA262 (3)
          WRITE (LU7, 99986, IOSTAT = IOST)
          ISORD = 'Diso'
        ELSE
          ISORD = '   O'
        END IF
C * CHECK FOR/REPORT NUMBER OF ALIASES
        IF (IPR(759) > 0) THEN
          CALL PLA262 (3)
          WRITE (LU7, 99982, IOSTAT = IOST)
        END IF
        NWL = 34 + NRES - IPR(23) * 15
        CALL PLA262 (NWL)
        WRITE (LU7, 99999, IOSTAT = IOST)
     1    ISORD, (LMT(IENS(K), 1), K = 1, IAN)
        WRITE (LU7, 99985, IOSTAT = IOST)
      END IF
C * LOOP OVER RESIDUES, COUNT NUMBER OF NON-HYDROGEN ATOMS PER RESIDUE
      DO IRES = 1, NRES
        MULT = MLTI(IRES)
        IF (MULT <= 0) MULT = 1
        NN = NP1 + 1 - IRES
C * INIT COUNTERS FOR THIS RESIDUE
        DO J = 1, 5
          XXO(NN, J) = 0.0
          XSD(NN, J) = 0.0
        END DO
        XXO(NN, 6) = 1.0
        DO J = 1, NP10
          CONT(J, 1) = 0.0
        END DO
        SUMWT    = 0.0
        ISPECIAL = 0
        ACOUNT   = 0.0
        DO 10 J = 1, NAT
C * GET RESIDUE NUMBER
          CALL GEN048 (-6, IFG(1, J), 9, IRESJ)
          IF (IRESJ == IRES) THEN
C * AVOID DUPLICATIONS
            IF (J > NATX) THEN
              KMX = J - 1
              DO K = 1, KMX
                KEXIT = 0
                DO L = 1, 3
                  DIF = ABS (XXO(J, L) - XXO(K, L))
                  IF (ABS (MOD (DIF, 1.0)) > 0.0001) THEN
                    KEXIT = 1
                    EXIT
                  END IF
                END DO
                IF (KEXIT == 0) GO TO 10
              END DO
            END IF
C * GET SPECIAL POSITION FLAG
            CALL GEN048 (-1, IFG(1, J), 6, JUNK)
            ISPECIAL = ISPECIAL + JUNK
C * GET POPULATION
            CALL GEN048 (-8, IFG(2, J), 1, NPP)
            NPP = NPP + 1
            PPM = MULT * IPPR(NPP, 3) * IPPR(NPP, 1) / (NSYM * 10000.0)
C * GET ELEMENT TYPE
            CALL GEN048 (-4, IFG(1, J), 15, NO1)
            NO1 = NO1 + 1
            WT  = SATWT(NO1)
C * HANDLE SPECIAL CASE WT = 0.0
            IF (NINT(WT) == 0) WT = 1.0
            SUMWT = SUMWT + WT
            DO L = 1, 3
              XXO(NN, L) = XXO(NN, L) + XXO(J, L) * WT
            END DO
            IF (J <= NATX) THEN
              ACOUNT       = ACOUNT + PPM
              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) / 10000.0)
              XXO(NN, 6)   = MIN (XXO(NN, 6), IPPR(NPP, 1) / 10000.0)
            END IF
          END IF
   10   CONTINUE
        IF (XXO(NN, 5) /= XXO(NN, 6)) XXO(NN, 5) = 1.000
C * PROVISIONARY ERROR HANDLING
        IF (SUMWT == 0.0) THEN
          IPR(2)   = 32
          IPR(323) = 8
          RETURN
        END IF
C * TAKE CARE OF EXCLUDED DISORDER OPERATIONS
        DOM = 1
        DO J = 1, 3
          SGY(J)     = XXO(NN, J) / SUMWT
          XXO(NN, J) = SGY(J)
        END DO
        SPSITE = '      '
C * HANDLE DETECTED DISORDER OPERATIONS
        IF (IPR(101) > 0) THEN
          NMOL = IPR(13)
          DO K = 2, NMOL
            ML  = MOL(K)
            XML = ML / PAR(42)
            CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRES0)
            IF (IRES0 == IRES) THEN
              IF (MOL1 > IPR(48)) THEN
                MOL1   = MOL1 - IPR(48)
                XML    = XML  - IPR(48) * 1000
                SGY(4) = MOL2
                SGY(5) = MOL3
                SGY(6) = MOL4
                CALL SGSM (3, ICL, SGY, MOL1, LU6, IERR)
                DO J = 1, 3
                  XXO(NN, J) = XXO(NN, J) + SGY(J + 6)
                END DO
                DOM = DOM + 1
              END IF
            END IF
          END DO
          DO K = 1, 3
            XXO(NN, K) = XXO(NN, K) / DOM
          END DO
        END IF
        DO K = 1, 3
          SGY(K) = XXO(NN, K)
        END DO
        SGY(10)  = 0.0
        CALL SGSM (19, LINE, SGY, 0, LU6, IERR)
        SPSITE   = ' '//LINE(1:5)
        PAR(163) = PAR(163) + XXO(NN, 4) * NSYM / MULT
        RCONT(IRES) = 0.0
C * FIND/APPLY LCD
        IF (NPOL(IRES) > 0) THEN
          MM0 = IPR(255) * IPR(257)
          DO I = 1, IAN
            C1  = CONT(I, 1) * MM0
            IC1 = NINT (C1)
            IF (ABS (C1 - IC1) > 0.01) GO TO 20
            IATC(I) = IC1
          END DO
          MULT          = MULT * MM0
          IATC(IAN + 1) = MULT
C * REDUCE VECTOR
          CALL GEN107 (IATC, IAN + 1, IGGD)
          MULT       = MULT / IGGD
          XXO(NN, 4) = XXO(NN, 4) * MM0 / IGGD
          DO I = 1, IAN
            CONT(I, 1) = CONT(I, 1) * MM0 / IGGD
          END DO
        END IF
C * AVOID '0.5000, 0.3333,0.2500,0.1667' (on 2,3,4,6,8,12,24-fold site)
   20   IF (ISPECIAL > 0) THEN
          DO I = 2, 48
            IF (ISOF(I) == 1) THEN
              DO L = 1, IAN
                IF (XXO(NN, 5) /= 0.0) THEN
                  IF (ABS (MOD (CONT(L, 1) / XXO(NN, 5), 1.0) - 1.0 /
     1              FLOAT (I)) < 0.001) THEN
                    IF (MOD (NSYM, I) == 0) THEN
                      DO L9 = 1, IAN
                        CONT(L9, 1) = CONT(L9, 1) * FLOAT (I)
                      END DO
                      MULT = MULT * I
                      XXO(NN, 4) = XXO(NN, 4) * FLOAT (I)
                    END IF
                    GO TO 30
                  END IF
                END IF
              END DO
            END IF
          END DO
        END IF
C * TEST FOR NON-INTEGER NUMBER OF ATOMS IN RESIDUE
   30   IF (ABS (NINT (ACOUNT) - ACOUNT) > 0.01) THEN
C * CHECK FOR NON-POLYMER
          IF (IPR(600) == 0 .AND. IPR(322) == 0) THEN
            WRITE (NQ1, 99995) IRES
C * ALERT _304
            CALL PLA236 (304, 2, -999.0, ACOUNT, ' ' , NQ1)
          END IF
        END IF
C * IS THIS A NEW SPECIES ?
        NSP = IPR(488)
        NONINT = 0
        IF (NSP > 3) THEN
          DO 40 K = 4, NSP
            DO L = 1, IAN
              IF (ABS (CONT(L, K) - CONT(L, 1) / XXO(NN, 5)) > 0.03)
     1          GO TO 40
            END DO
            NSP = K
            GO TO 50
   40     CONTINUE
        END IF
        NSP      = NSP + 1
        IPR(488) = NSP
C * CHECK FOR TOO MANY RESIDUES
        IF (NSP > 99) THEN
          IPR(2) = 62
          RETURN
        END IF
        CONT(NP10 + 1, NSP) = 0.0
   50   IZET = NSYM / MULT
        IF (IZET * MULT /= NSYM) THEN
          DO L = 1, IAN
            CONT(L, 1) = CONT(L, 1) * NSYM / MULT
          END DO
          XXO(NN, 4) = XXO(NN, 4) * NSYM / MULT
          IZET = 1
          DO L = 1, IAN
            IF (ABS (NINT (CONT(L, 1) / 2.0) - CONT(L, 1) / 2.0)
     1        > 0.01) GO TO 60
          END DO
          DO L = 1, IAN
            CONT(L, 1) = CONT(L, 1) / 2.0
          END DO
          XXO(NN, 4) = XXO(NN, 4) / 2.0
          IZET = 2
        END IF
   60   IF (XXO(NN, 5) /= 0.0) THEN
          YUNK = 1.0 / XXO(NN, 5)
        ELSE
          YUNK = 0.0
        END IF
        JZET = IZET
C * CHECK FOR NON-POLYMER
        IF (IPR(322) /= 0) THEN
          IF (ABS (YUNK - NINT (YUNK)) < 0.0001) THEN
            IZET = IZET * NINT (YUNK)
            YUNK = 1.0
          END IF
        END IF
        DO L = 1, IAN
          CONT(L, 2) = CONT(L, 2) + CONT(L, 1) * JZET
          CONT(L, 1) = CONT(L, 1) * YUNK
          NCOUNT     = NINT (CONT(L, 1))
          IF (ABS (CONT(L, 1) - NCOUNT) > PAR(331)) NONINT = 1
          CONT(L, NSP) = CONT(L, 1)
C * COUNT NUMBER OF NON-H ATOMS PER RESIDUE
          IF (IEN(L) /= 1) RCONT(IRES) = RCONT(IRES) + CONT(L, 1)
        END DO
        CONT(NP10 + 1, NSP) = CONT(NP10 + 1, NSP)
     1                      + IZET * XXO(NN, 5)
        N = 0
C * RESIDUE FORMULA (CALCULATED)
        CALL PLA283 (1, 1.0, N, CFORM)
        IF (N > 0 .AND. N < NP52 + 1)
     1    WRITE (LU6, 99983, IOSTAT = IOST)
     2      IRES, XXO(NN, 5), IZET, CFORM(N:NP52)
          RFORM(IRES) = CFORM(N:NP52)
C * CHECK WHETHER RESIDUE C.G. IS IN UNITCELL BOX
        INSIDE = 1
        DO K = 1, 3
          IF (XXO(NN, K) > 1.1  .OR. XXO(NN, K) < -0.1) THEN
            INSIDE = 0
          END IF
        END DO
C * CHECK FOR INSIDE
        IF (INSIDE == 0) THEN
          IF (N > 0 .AND. N < NP52 + 1 .AND. IGBL(94) == 0) THEN
C * ALERT _790
            IF (IRES == 1) THEN
              YUNK = 1.0
            ELSE
              YUNK = -999.0
            END IF
            CALL PLA236 (-790, 0, YUNK, FLOAT (IRES), ' ', ' ')
            CALL PLA236 (0, 0, 0.0, 0.0,
     1                   '              '//CFORM(N:NP52), ' ')
          END IF
        END IF
        IF (NONINT > 0) THEN
          WRITE (PRBUF, 99984, IOSTAT = IOST)
     1      IRES, SPSITE, (XXO(NN, K), K = 1, 5),
     2      IZET, (CONT(IENS(L), 1), L = 1, IAN)
        ELSE
          IF (IRES == 1 .AND. NRES == 1) IPR(260) = IZET
          WRITE (PRBUF, 99981, IOSTAT = IOST)
     1      IRES, SPSITE, (XXO(NN, K), K = 1, 5),
     2      IZET, (NINT(CONT(IENS(L), 1)), L = 1, IAN)
C * SUBSTITUTE - FOR ZERO IN FORMULA COUNT
          DO K = 51, 128
            IF (PRBUF(K : K + 4) == '    0') PRBUF(K+4:K+4) = '-'
          END DO
        END IF
        IF (IGBL(63) > 2) CALL GEN065 (LU7, PRBUF, 1, 130, 7)
      END DO
C * SORT OUT MOIETY FORMULA
      CALL PLA081
      PAR(162) = 0.0
      PAR(462) = 0.0
      PAR(463) = 0.0
      IPR(215) = 0
      F000A    = 0.0
      F000B    = 0.0
      NHEAVY   = 0
      RESSCAT  = 0.0
      RESSCAN  = 0.0
      FRIEDIFT = 0.0
      FRIEDIFN = 0.0
C * CORRECT PREDICTED VOLUME FOR TEMP EFFECT
      IF (IPR(261) > 0) THEN
        ITEMP = IPR(261)
      ELSE
        ITEMP = 298
      END IF
      DO L = 1, IAN
        IENL     = IEN(L)
        PAR(462) = PAR(462) + CONT(L, 2) * ATVOL(IENL)
        PAR(463) = PAR(463) + CONT(L, 2) * ATVOL(IENL) *
     1             (1.0 + 0.000095 * (ITEMP - 298))
        NHEAVY   = MAX (NHEAVY, IATNR(IENL))
        J        = (IENL - 1) * 19
        YMR      = 0.0
        FDELA    = 0.0
        FDELB    = 0.0
        IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7) THEN
          FDELA = ANOM(L, 1)
          FDELB = ANOM(L, 2)
          YMR   = ANOM(L, 3)
        END IF
C * CALCULATE ALTERNATIVE F000 FROM SCATTERING FACTORS
        FZEROL = FDELA
        DO K = 1, 9, 2
          F000A  = F000A + CONT(L, 2) * SFAC(J + K)
          FZEROL = FZEROL + SFAC(J + K)
        END DO
C * ANOMALOUS DISPERSION CONTRIBUTION
        F000A = F000A + CONT(L, 2) * FDELA
        F000B = F000B + CONT(L, 2) * FDELB
C * FRIEDIF (FLACK) CALCULATION (Flack & Shmueli, 2007, Eq #8)
        DO M = 1, IAN
          JM     = (IEN(M) - 1) * 19
          FDELBM = 0.0
          IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7) THEN
            FDELBM = ANOM(M, 2)
          END IF
          FZEROM = ANOM(M, 1)
          DO K = 1, 9, 2
            FZEROM = FZEROM + SFAC(JM + K)
          END DO
          FRIEDIFT = FRIEDIFT + CONT(L, 2) * CONT(M, 2) *
     1               (FZEROL * FDELBM - FZEROM * FDELB) **2
        END DO
        FRIEDIFN = FRIEDIFN + CONT(L, 2) * (FZEROL**2 + FDELB**2)
C * RESONANT SCATTERING
        RESSCAT = RESSCAT + CONT(L, 2) * FDELB**2
        RESSCAN = RESSCAN + CONT(L, 2) * FZEROL**2
        IF (IABS (IPR(493)) < 7) THEN
          PAR(157) = PAR(157) + CONT(L, 2) * IATNR(IENL)
         ELSE IF (IABS (IPR(493)) == 7) THEN
          PAR(157) = PAR(157) + CONT(L, 2) * RNSCL(IENL)
        END IF
        PERC(L)    = CONT(L, 2) * SATWT(L) * 100.0 / PAR(163)
        PAR(162)   = PAR(162) + CONT(L, 2) * YMR * 0.1
        NCOUNT     = NINT (CONT(L, 2))
        CONT(L, 3) = CONT(L, 2) - NCOUNT
        IF (ABS (CONT(L, 3)) > NCOUNT * PAR(331))
     1          IPR(215) = IPR(215) + 1
      END DO
C * FRIEDIF (Flack & Shmueli (2007) A63, 257-265), EQUATION #8
      PAR(474) = 2.0 * SQRT (FRIEDIFT) / FRIEDIFN
C * RES SCAT (Girard et al. (2003) Acta Cryst. D59, 1914-1922))
      PAR(425) = SQRT (2.0 * RESSCAT / RESSCAN)
      PAR(426) = SQRT (F000A**2 + F000B**2)
      PAR(160) = PAR(163) / (PAR(98) * 0.60221)
      DXREP    = PAR(568) * PAR(308) / (PAR(98) * 0.60221)
C * CHECK DENSITY CALCULATED FROM Z * MW (REP)
      IF (PAR(267) > 0.0 .AND. IGBL(94) == 0) THEN
        XDIF = 100 * ABS (PAR(267) - DXREP) / PAR(267)
C * ALERT _046
        IF (XDIF > 0.5) CALL PLA236 (46, 3, XDIF, DXREP, ' ', ' ')
      END IF
      PAR(162) = PAR(162) / PAR(98)
      SIGD     = (PAR(160) / PAR(98)) * PAR(21)
C * ROUND D
      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
C * CHECK/COMPARE MOIETY FORMULA
      CALL PLA082 (1, N)
C * CHECK REPORTED VERSUS CALCULATED MOLECULAR WEIGHT
      XDIF  = 100 * ABS (PAR(163) - PAR(308) * PAR(568)) / PAR(163)
      XDIF1 = ABS((PAR(163) - PAR(308) * PAR(568)) / IPR(260))
C * IGNORE/SUPPRESS IN CASE OF SQUEEZE/MASK BASED REFINEMENT
      IF (IPR(651) == 0) THEN
C * ALERT _043
C * CHECK FOR NO-CSD CIF AND NO SQUEEZE
        IF (XDIF > 0.1 .AND. IGBL(94) == 0)
     1     CALL PLA236 (43, 2, XDIF, XDIF1, ' ', ' ')
C * CHECK DENSITY
        XDIF1 = ABS (PAR(160) - PAR(267))
        XDIF  = 100.0 * XDIF1 / PAR(160)
C * ALERT _044
        IF (XDIF > 0.5 .AND. IGBL(94) == 0) THEN
          IF (IPR(651) == 0) THEN
            CALL PLA236 (44, 4, XDIF, XDIF1, ' ', ' ')
          ELSE
            CALL PLA236 (44, 4, -999.0, XDIF1, ' ', ' ')
          END IF
        END IF
C * CHECK DENSITY > 1.0  (IGNORE IN CASE OF SQUEEZE)
C * ALERT _049 (includes squeeze test)
        IF (PAR(160) < 1.0) THEN
          IF (IPR(601) > 0) THEN
            CALL PLA236 (49, 4, 0.5, PAR(160), ' ', ' ')
          ELSE
            CALL PLA236 (49, 4, -999.0, PAR(160), ' ', ' ')
          END IF
        END IF
      END IF
C * CHECK Z (FOR NON-CSD CIF)
      IF (IGBL(94) == 0) THEN
        IF (ABS (PAR(568) - IPR(260)) > 0.001) THEN
          IF (PAR(568) /= 0.0) THEN
            RATIO = FLOAT (IPR(260)) / PAR(568)
          ELSE
            RATIO = 0.0
          END IF
          IF (ABS (RATIO - NINT (RATIO)) > 0.0001) THEN
            WRITE (RAT, 99976) RATIO
          ELSE
            WRITE (RAT, 99975) NINT (RATIO)
          END IF
C * ALERT _045
          CALL PLA236 (45, 0, -999.0, RATIO, RAT, ' ')
        END IF
      END IF
C * CHECK/COMPARE SUM-FORMULA
      CALL PLA082 (2, N1)
C * USE CALCULATED Z VALUE
      CALL PLA283 (0, 1.0, N, CFORM)
      CALL PLA283 (2, FLOAT (IPR(260)), N1, ICL(1:NP52))
      WRITE (LU6, 99998, IOSTAT = IOST) CFORM(N:NP52), ICL(N1:NP52),
     1       PAR(163) / IPR(260), WNOTE(IPR(181) + 1), IPR(260)
C * CHECK FOR (0/1) ANGSTROM DATA
      IF (IPR(23) == 0) THEN
C * CALCULATE NON-HATOM VOLUME (VOL/NONH)
        PAR(548) = 0.0
        DO K = 1, IAN
          IF (LMT(K, 1) /= ' H' .AND. LMT(K, 1) /= ' D' .AND.
     1        LMT(K, 1) /= 'Cg') THEN
            PAR(548) = PAR(548) + CONT(K, 2)
          END IF
        END DO
C * REPORT CONTENT
        WRITE (LU6, 99992, IOSTAT = IOST) IPR(48), PAR(142)
        IF (IGBL(63) > 2) THEN
          WRITE (LU7, 99989, IOSTAT = IOST)
     1      PAR(163), (NINT (CONT(IENS(L), 2)), L = 1, IAN)
          IF (IPR(215) > 0) THEN
            WRITE (LU7,  99990, IOSTAT = IOST)
     1        (CONT(IENS(L), 3), L = 1, IAN)
          END IF
          WRITE (LU7, 99988, IOSTAT = IOST)
     1      (PERC(IENS(L)), L = 1, IAN)
          WRITE (LU7, 99996, IOSTAT = IOST) CFORM(N:NP52), ICL(N1:NP52),
     1      PAR(163) / IPR(260), WNOTE(IPR(181) + 1), IPR(260),
     2      IPR(48), IPR(260), IPR(48), PAR(142)
          WRITE (LU7, 99979, IOSTAT = IOST)
          WRITE (PRBUF, FORMA, IOSTAT = IOST) PAR(160), IPR(295)
          CALL GEN065 (LU7, PRBUF, 1, 130, 1)
          WRITE (LU7, 99987, IOSTAT = IOST) PAR(157), PAR(426)
        END IF
C * REPORT ON UNUSUAL LABELS BUT IGNORE SHELXL STYLE RESD EXTENSIONS
C * ALERT _720
        IF (IPR(759) > 0) THEN
          N = 0
          DO I = 1, IPR(759)
            M = INDEX (ALAB(I), '_')
            IF (M /= 0) THEN
              CALL GEN105 (3, ALAB(I)(M + 1:M + 1), K)
              IF (K < 0) M = 0
            END IF
            IF (M == 0) THEN
              N = N + 1
              CLAB(I) = ALAB(I)
            END IF
          END DO
          IF (N > 0) THEN
            CALL PLA236 (-720, 0, -999.0, FLOAT (N), ' ', ' ')
            DO I = 1, N, 8
              K = MIN (7, N - I)
              WRITE (PRBUF, 99974) (CLAB(I + J)(1:8), J = 0, K)
              WRITE (LU68, 99973) PRBUF(1:79)
            END DO
          END IF
        END IF
C * ALERT _299 - LIST ATOMS WITH POPULATION 0.5
        N = IPR(784)
        IF (N > 0) THEN
          CALL PLA236 (-299, 1, -999.0, 0.5, ' ', ' ')
          DO I = 1, N, 8
            K = MIN (7, N - I)
            WRITE (PRBUF, 99974) (PLAB(I + J)(1:8), J = 0, K)
            WRITE (LU68, 99973) PRBUF(1:79)
          END DO
        END IF
C * CHECK FOR REFINED C-H ATOMS IN HEAVY ATOM STRUCTURE
C * ALERT _164
        IF (IPR(474) > 0 .AND. NHEAVY > 18 .AND.
     1    IGBL(94) == 0)
     2    CALL PLA236 (164, 0, -999.0, FLOAT(IPR(474)), ' ', ' ')
C * REPORT ON # NON-H ATOMS with R-FLAG
C * ALERT _165
        IF (IPR(164) > 0)
     1    CALL PLA236 (165, 0, 1.0, FLOAT(IPR(164)), ' ', ' ')
        IF (KRAD(1:2) /= '??') THEN
          IF (IGBL(63) > 2) THEN
            WRITE (LU7, 99991, IOSTAT = IOST)
     1        KRAD, PAR(162) * 10.0, PAR(162)
            WRITE (LU6, 99997, IOSTAT = IOST)
     1        KRAD, PAR(162) * 10.0, PAR(162)
C * CHECK FOR NON-CENTRO
            IF (IPR(257) == 1) THEN
               WRITE (LU7, 99978, IOSTAT = IOST)
     1           NINT (PAR(425) * 10000.0), NINT (PAR(474) * 10000.0)
               WRITE (LU6, 99977, IOSTAT = IOST)
     1           NINT (PAR(425) * 10000.0), NINT (PAR(474) * 10000.0)
            END IF
          END IF
        END IF
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (4)
          WRITE (LU7, 99993, IOSTAT = IOST) PAR(462), PAR(463), ITEMP
          WRITE (LU7, 99994, IOSTAT = IOST)
          WRITE (LU6, 99980, IOSTAT = IOST) PAR(462), PAR(463), ITEMP
        END IF
      END IF
C * REGISTER C/NON-C &  H/NON-H STATUS
      IPR(483) = 0
      IPR(484) = 0
      DO L = 1, IAN
        IENL = IEN(L)
        IF (IENL == 1 .OR. IENL == 33 .OR. IENL == 113) THEN
          IF (CONT(L, 2) > 0) IPR(484) = 1
        ELSE IF (IENL == 2) THEN
          IF (CONT(L, 2) > 0) IPR(483) = 1
        END IF
      END DO
C * ALERT _034 - CHECK FOR FLACK PARAMETER (XRAY ONLY)
      IF (IPR(493) < 7) THEN
        IF (PAR(433) == 999999.0 .AND. IPR(22) > 14 .AND.
     1    IPR(275) == 1 .AND. IGBL(94) == 0 .AND. IPR(105) == 0)
     2      CALL PLA236 (34, 0, 1.0, 1.0, ' ', ' ')
      END IF
C * TEST (A/C), CSD_CIF, CHIRAL SPGR
      IF (IPR(275) /= 2 .AND. IGBL(94) == 0
     1                    .AND. IPR(583) > 0) THEN
        N = INDEX (CCIF(17), '?')
C * ALERT _035
        IF (N /= 0 .AND. IABS (IGBL(8)) == 3 .AND.
     1    CHSG(1:1) == 'C' .AND. IPR(493) .NE. 8) THEN
C * CHECK FOR POWDER STUDY
          IF (IPR(105) == 0) THEN
            CALL PLA236 (35, 0, 1.0, 1.0, ' ', ' ')
          ELSE
            CALL PLA236 (35, 0, -999.0, 1.0, ' ', ' ')
          END IF
        END IF
      END IF
      RETURN
99999 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))
99998 FORMAT (':: Moiety_Formula = ', A, /,
     1        ':: Sum_Formula    = ', A, /,
     2        ':: Formula_Weight = ', F11.2, 1X, A, /,
     3        ':: Formula_Z      = ', I11)
99997 FORMAT (':: mu(', A, ')       =', F12.2, ' cm-1 = ', F7.3,
     1        ' mm-1')
99996 FORMAT (/, 10X, 'Moiety_Formula = ', A, //,
     1        13X, 'Sum_Formula = ', A, //,
     2        10X, 'Formula_Weight =', F12.2, 1X, A, //,
     3        15X, 'Formula_Z =', I12, //,
     4        12X, 'SpaceGroup_Z =', I12,
     5        '  ===>  Z'' =', I3, ' /', I3, ' =',  F8.3)
99995 FORMAT ('Resd', I5)
99994 FORMAT (/,
     1 'Note on F000: The first number is a pure electron count, the ',
     2 'second number between [] is calculated from f,f'' & f"')
99993 FORMAT (/, 8X, 'Predicted Volume =  ', F10.1, '[', F10.1, ']',
     1        ' Ang**3, 298[', I3, ']K - (D.W.M. Hofmann (2002).',
     2        ' Acta Cryst. B58, 489-493)')
99992 FORMAT (
     1        ':: SpaceGroup_Z   = ', I11, /,
     2        ':: Formula_Z''     = ', F11.3)
99991 FORMAT (16X, 'mu(', A, ') =', F12.2, ' cm-1 =', F8.3, ' mm-1', /)
99990 FORMAT (37X, 'Add Non-Int. ', 2F6.2, 14F5.2)
99989 FORMAT (30X, 102('-'), /, 8X, 'Unit Cell Weight =', F13.2,
     1 11X, 2I6, 14I5)
99988 FORMAT (/, 1X, 'Calculated Analysis (%) =',
     1 17X, F13.1, F6.1, 14F5.1)
99987 FORMAT (75X, 'Please Check the Derived Crystal Data.', /,
     1 18X, 'F(000) = ', F11.1, ' [', F11.2, ']', 23X,
     2 'They may be Incorrect for Disordered,', /, 75X,
     3 'Incomplete or Polymeric Structures.')
99986 FORMAT (/, 'NOTE: Atoms preceded by > * or < indicate ',
     1 'disordered positions (SOF : < 50%, 50%, > 50%)', /)
99985 FORMAT (132('='))
99984 FORMAT (I3, A, 3F7.3, F9.2, F6.3, I4, 1X, 2F6.1, 14F5.1)
99983 FORMAT (':: Resd', I3, ', SOF', F6.3, ', Z', I3,  ', ', A)
99982 FORMAT (/, 'NOTE: A # in the Atom Label Indicates a Label that',
     1 ' was Modified to Conform with the Label Convention (A4)', /)
99981 FORMAT (I3, A, 3F7.3, F9.2, F6.3, I4, 1X, 2I6, 14I5)
99980 FORMAT (':: Predicted Vol  =', F12.1, '[', F10.1, ']',
     1        ' Ang**3, 298[', I3, ']K')
99979 FORMAT (1X)
99978 FORMAT (5X, 'Resonant Scattering =  ', I10, ' * 0.0001 - ',
     1  '(E. Girard et al. (2003). Acta Cryst. D59, 1914-1922)',
     2  //, 12X, 'Friedif_stat =', I12, 9X, ' - ',
     3  '(H. Flack & U. Shmueli (2007). Acta Cryst. A63, 257-265)')
99977 FORMAT (':: Res.Scat.      =', I12, ' x 0.0001', /
     1        ':: Friedif_stat   =', I12)
99976 FORMAT (F7.3)
99975 FORMAT (I7)
99974 FORMAT (14X, 8A)
99973 FORMAT (A)
      END SUBROUTINE PLA080
 
      SUBROUTINE PLA081
C * SORT OUT MOIETY FORMULA
      USE parameters
      USE plato
      USE atomdata
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: KZ
      INTEGER :: LZ
      INTEGER :: MZ
      INTEGER :: LCD
      INTEGER :: NSP
      INTEGER :: NRES
      INTEGER :: NSYM
      INTEGER :: NCMX
C * GET NUMBER OF RESIDUES
      NRES = IPR(75)
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
C * GET NUMBER OF DISTICT SPECIES
      NSP  = IPR(488) - 3
 
 
C * DETERMINE RESIDUE WITH THE LARGEST NUMBER OF NON-H ATOMS
      NCMX = 1
      IF (NRES > 1) THEN
        DO I = 1, NRES
          IF (RCONT(I) > RCONT(NCMX)) NCMX = I
        END DO
      END IF
C * SOLVENT/ANION TEST
      IF (RCONT(NCMX) < 15) IPR(487) = 0
C * FIND LARGEST COMMON DEVISOR
      LCD = 0
      DO I = 1, NSP
        LCD = MAX (LCD, NINT(CONT(NP10 + 1, I + 3)))
      END DO
C * LOOP OVER POSSIBLE DEVISORS
      DO 10 I = 1, LCD
        KZ = LCD + 1 - I
C * LOOP OVER DISTINCT SPECIES
        DO J = 1, NSP
          LZ = NINT (CONT(NP10 + 1, J + 3))
          IF (ABS (CONT(NP10 + 1, J + 3) - LZ) < 0.00001) THEN
            IF (MOD (LZ, KZ) /= 0) GO TO 10
          END IF
        END DO
        GO TO 20
   10 CONTINUE
      KZ = NSYM
C * CHECK FOR AVOIDABLE Z' = 0.5
   20 IF (KZ * 2 == NSYM) THEN
        DO I = 1, IAN
          LZ = NINT (CONT(I, 2))
          IF (MOD (LZ, 2) /= 0) GO TO 30
        END DO
        IF (MOD (NINT (CONT(NP10 + 1, 4)), NSYM) == 0) KZ = KZ * 2
      END IF
C * AVOID FRACTIONS (.5)
C * CHECK FOR 'CORRECTABLE' BROKEN SUM-FORMULA
   30 MZ = 1
      IF ((KZ / 2) * 2 == KZ) THEN
        DO I = 1, IAN
   40     LZ = NINT (CONT(I, 2) * MZ)
          IF (ABS (CONT(I, 2) * MZ - LZ) < 0.001) THEN
            IF ((LZ / KZ) * KZ /= LZ) THEN
              IF (MZ == 1) THEN
                MZ = 2
                GO TO 40
              ELSE
                GO TO 50
              END IF
            END IF
          END IF
        END DO
        KZ = KZ / MZ
      END IF
   50 IPR(260) = KZ
      END SUBROUTINE PLA081
 
      SUBROUTINE PLA082 (MODE, NBEG)
C * CHECK/COMPARE MOIETY AND SUM FORMULA
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: L
      INTEGER             :: M
      INTEGER             :: N
      INTEGER             :: M0
      INTEGER             :: M1
      INTEGER             :: NBEG
      INTEGER             :: MODE
      INTEGER             :: NDIF = 0
      INTEGER             :: GEN166
      CHARACTER(len=1)    :: CHI
      CHARACTER(len=1)    :: CHJ
      CHARACTER(len=1)    :: CHK
      CHARACTER(len=NP52) :: A
C *   MODE = 1 : CHECK MOIETY FORMULA (RLWS(4)]
C *   MODE = 2 : CHECK SUM    FORMULA [RLWS(5)]
C * SUPPLIED MOIETY/SUM FORMULA CHECK DONE ONLY FOR NON-CSDCIF
      IF (IGBL(94) == 0) THEN
C * GENERATE MOIETY/SUM STRING FROM MODEL PARAMETERS
        IF (MODE == 1) THEN
          CALL PLA283 (0, 1.0, NBEG, CFORM)
        ELSE IF (MODE == 2) THEN
          IF (IABS(IGBL(8)) == 3 .AND. IPR(276) /= 0) THEN
            CALL PLA283 (2, FLOAT (IPR(260)), NBEG, CFORM)
          ELSE
            RETURN
          ENDIF
        END IF
C * GET SUPPLIED MOIETY/SUM FORMULA STRING
        A = RLWS(MODE + 3)
C * CHECK FOR NON-DEFAULT STRING
        M = INDEX (A, '?')
        IF (M /= 0) M0 = M + 1
        IF (M == 0) THEN
C * GET END OF STRING (I.E. QUOTE CHAR)
          M = INDEX (A, CHAR(39))
C * HANDLE SQUEEZED/MASKED SOLVENT SECTION
          N = INDEX (A(1:M), ' [')
C * RESET CHECK RANGE
          IF (N > 0) THEN
            A(N:N) = CHAR(39)
            M = N
          END IF
          M0 = M
C * ELIMINATE SUPERFLUOUS '1' FROM ELEMENT COUNT (AND OPTIONALLY CHARGES)
          DO J = 2, M - 1
            IF (A(J:J) == '1') THEN
              IF (IABS (GEN166 (A(J - 1:J - 1))) == 1) THEN
                IF (GEN166 (A(J + 1:J + 1)) < -1) THEN
C * CHECK FOR NON-INTEGER AMOUNT
                  IF (A(J + 1:J + 1) /= '.') THEN
                    L = 1
                    IF (IABS (GEN166 (A(J - 2:J - 2))) == 1) L = 2
C * ALERT _787/_788 - NOT FOR POWDER
                    IF (IPR(105) == 0) THEN
                      CALL PLA236 (789 - MODE, 0, 1.0, 1.0,
     1                  A(J - L:J), A(J - L:J - 1))
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END DO
          J    = 0
          NDIF = 0
C * LOOP OVER EXPECTED STRING BASED ON CIF CONTENT
          DO I = NBEG, NP52 + 1
            IF (I > NP52) THEN
              CHI = CHAR(39)
            ELSE
              CHI = CFORM(I:I)
            END IF
C * LOOP OVER REPORTED STRING IN THE CIF
            DO
              IF (J < M) THEN
                J   = J + 1
                CHJ = A(J:J)
                CHK = A(J + 1: J + 1)
                IF (CHI /= CHJ) THEN
                  IF (CHJ == ' ' .OR. CHJ == '+' .OR. CHJ == '-') CYCLE
                  IF (GEN166 (CHJ) == 0 .AND.
     1                (CHK == '+' .OR. CHK == '-')) CYCLE
                  NDIF = 1
                END IF
                EXIT
              ELSE
                EXIT
              END IF
            END DO
            IF (NDIF > 0) EXIT
          END DO
        ELSE
C * ALERT _048,_047 - MOIETY/SUM FORMULA NOT GIVEN
          CALL PLA236 (49 - MODE, 0, 1.0, 1.0, ' ', ' ')
        END IF
C * ALERT _041, _042 - REPORT DIFFERING MOIETY AND/OR SUM STRINGS
        IF (NDIF > 0) THEN
          IF (IPR(651) == 0) THEN
            CALL PLA236 (MODE - 43, 0, 1.0, 1.0, ' ', ' ')
          ELSE
            CALL PLA236 (MODE - 43, 0, -999.0, 1.0, ' ', ' ')
          END IF
C * LIST CALCULATED MOIETY/SUM FORMULA
          M1 = NP52 - NBEG + 1
          L  = MIN (46, M1)
          WRITE (LU68, 99999, IOSTAT = IOST) CFORM(NBEG:NBEG+L-1)
          IF (M1 > 46) THEN
            WRITE (LU68, 99997, IOSTAT = IOST) CFORM(NBEG+46:NP52)
          END IF
C * LIST REPORTED MOIETY/SUM FORMULA (EXCLUDING [] SECTION)
          L = MIN (46, M0 - 1)
          WRITE (LU68, 99998, IOSTAT = IOST)
     1      RLWS(MODE + 3)(1:L)
          IF (M0 - 1 > L) THEN
            WRITE (LU68, 99997, IOSTAT = IOST)
     1        RLWS(MODE + 3)(47:M0 -1)
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (14X, 'Calc: ', A)
99998 FORMAT (14X, 'Rep.: ', A)
99997 FORMAT (20X, A)
      END SUBROUTINE PLA082
 
      SUBROUTINE PLA083 (NR, DUMVX, EWX, VXX, WHTX, NATT, IDETX)
C * CALCULATE THE PRINCIPLE AXES OF INERTIA FOR RESIDUE NR
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: NR
      INTEGER               :: IPP
      INTEGER               :: IVL
      INTEGER               :: NMAX
      INTEGER               :: NATT
      INTEGER               :: IRESN
      INTEGER               :: IDETX
      REAL                  :: XX
      REAL                  :: YY
      REAL                  :: ZZ
      REAL                  :: WM
      REAL                  :: WHT
      REAL                  :: XSQ
      REAL                  :: YSQ
      REAL                  :: ZSQ
      REAL                  :: YUNK
      REAL                  :: WHTX
      REAL, DIMENSION(3)    :: EWX
      REAL, DIMENSION(3)    :: VXX
      REAL, DIMENSION(3, 3) :: DUMW
      REAL, DIMENSION(3, 3) :: EV
      REAL, DIMENSION(3, 3) :: DUMVX
C * GET THE MASS CENTRE
      CALL GEN074 (V1, 1, 3, 0.0)
      CALL GEN074 (V7, 1, 3, 0.0)
      NMAX = IPR(39)
      NATT = 0
      WM   = 0
      DO I = 1, NMAX
C * CHECK FOR RESIDUE NUMBER EQUAL TO THE ONE OF INTEREST
        CALL GEN048 (-6, IFG(1, I), 9, IRESN)
        IF (IRESN == NR) THEN
          CALL GEN048 (-8, IFG(2, I), 1, IPP)
C * NO DISORDERED RESIDUES
          IF (IPPR(IPP + 1, 1) < 10000) THEN
            NATT = 0
            RETURN
          END IF
C * CHECK FOR NON-HYDROGEN ATOM
          CALL GEN048 (-1, IFG(1, I), 7, IVL)
          IF (IVL == 0) THEN
            NATT = NATT + 1
C * WEIGHT BY ATOMIC WEIGHT
            CALL GEN048 (-4, IFG(1, I), 15, IVL)
            WHT  = SATWT(IVL + 1)
            WM   = WM + WHT
            DO J = 1, 3
              V1(J) = V1(J) + WHT * XXO(I, J)
              V7(J) = V7(J) + WHT * XXO(I, J + 3)
            END DO
          END IF
        END IF
      END DO
C * CONSIDER RESIDUES WITH MORE THAN 6 ATOMS ONLY
      IF (NATT <= 6 .OR. WM == 0.0) THEN
        NATT = 0
        RETURN
      END IF
      WHTX = WM
      DO I = 1, 3
        V1(I) = V1(I) / WM
        V7(I) = V7(I) / WM
        XXO(NMAX + NR, I)     = V1(I)
        XXO(NMAX + NR, I + 3) = V7(I)
        DO J = 1, 3
          DUMW(I, J) = 0.0
        END DO
      END DO
C * SET UP THE INERTIAL MATRIX (= DUMW)
      DO N = 1, NMAX
C * CHECK FOR RESIDUE NUMBER
        CALL GEN048 (-6, IFG(1, N), 9, IRESN)
        IF (IRESN == NR) THEN
C * CHECK FOR NON-HYDROGEN ATOM
          CALL GEN048 (-1, IFG(1, N), 7, IVL)
          IF (IVL == 0) THEN
C * GET WEIGHT
            CALL GEN048 (-4, IFG(1, N), 15, IVL)
            WHT = SATWT(IVL + 1)
            XX  = XXO(N, 4) - V7(1)
            YY  = XXO(N, 5) - V7(2)
            ZZ  = XXO(N, 6) - V7(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)
          END IF
        END IF
      END DO
      CALL GEN024 (DUMW, EV, EWX, DUMVX)
      CALL GEN074 (VXX, 1, 3, 0.0)
C * CALCULATE THIRD MOMENT
      DO N = 1, NMAX
C * CHECK RESIDUE NUMBER
        CALL GEN048 (-6, IFG(1, N), 9, IRESN)
        IF (IRESN == NR) THEN
C * CHECK FOR NON-HYDROGEN ATOM
          CALL GEN048 (-1, IFG(1, N), 7, IVL)
          IF (IVL == 0) THEN
C * GET WEIGHT
            CALL GEN048 (-4, IFG(1, N), 15, IVL)
            WHT   = SATWT(IVL + 1)
            DO I = 1, 3
              V3(I) = XXO(N, I + 3) - V7(I)
            END DO
            DO J = 1, 3
              DO I = 1, 3
                YUNK = WHT * DUMVX(I, J) * V3(I)
                IF (ABS (YUNK) > 1.0E-10) THEN
                  VXX(J) = VXX(J) + YUNK**3
                END IF
              END DO
            END DO
          END IF
        END IF
      END DO
C * CHANGE MAIN AXIS DIRECTIONS ACCORDING INTO DIRECTIONS WITH POSITIVE
C * 3RD MOMENT
      DO J = 1, 3
        IF (VXX(J) < 0.0) THEN
          DO I = 1, 3
            DUMVX(I, J) = - DUMVX(I, J)
          END DO
          VXX(J) = - ABS (VXX(J)) ** (1.0 / 3.0)
        ELSE
          VXX(J) =   VXX(J) ** (1.0 / 3.0)
        END IF
      END DO
      CALL GEN010 (DUMVX, IDETX, 0)
      RETURN
      END SUBROUTINE PLA083
 
      SUBROUTINE PLA084 (IRES, JRES)
C * COMPARE BONDS OF RESIDUES
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: M
      INTEGER           :: NV
      INTEGER           :: KB
      INTEGER           :: IAT
      INTEGER           :: JAT
      INTEGER           :: KAT
      INTEGER           :: ND1
      INTEGER           :: ND2
      INTEGER           :: IER
      INTEGER           :: ISA
      INTEGER           :: NDEC
      INTEGER           :: IDUM
      INTEGER           :: JDUM
      INTEGER           :: IFIN
      INTEGER           :: NSIG
      INTEGER           :: IRES
      INTEGER           :: JRES
      INTEGER           :: ISA1
      INTEGER           :: ISD1
      INTEGER           :: ISD2
      INTEGER           :: IRESI
      REAL              :: A
      REAL              :: A1
      REAL              :: D1
      REAL              :: D2
      REAL              :: DS
      REAL              :: SA
      REAL              :: SA1
      REAL              :: SD1
      REAL              :: SD2
      REAL              :: DIF
      REAL              :: VDIF
      REAL              :: VDIS
      CHARACTER(len=74) :: FORMA
      CHARACTER(len=66) :: FORMB
      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 PLA262 (0)
      CALL PLA262 (5)
      WRITE (LU7, 99999, IOSTAT = IOST) IRES, JRES
      IPR(133) = 0
      VDIF     = 0.0
      NV       = 0
      IFIN     = -1
      NSIG     = 1
C * LOOP OVER BONDS
   10 CALL PLA038 (I, J, IFIN)
      IF (IFIN /= 1) THEN
        CALL GEN048 (-6, IFG(1, I), 9, IRESI)
        IF (IRESI == IRES) THEN
          CALL PLA053 (I, J, 0, 0, D1, SD1, ISD1, ND1, IER)
          IF (IER == 0) THEN
            IAT = JCA(I)
            JAT = JCA(J)
            CALL PLA053 (IAT, JAT, 0, 0, D2, SD2, ISD2, ND2, IER)
            IF (IER == 0) THEN
              CALL PLA047 (LABA(I), NQ3, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 0)
              CALL PLA047 (LABA(J), NQ4, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 0)
              CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 0)
              CALL PLA047 (LABA(JAT), NQ2, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 0)
              DIF = D1 - D2
              DS  = SQRT (SD1**2 + SD2**2)
              IF (DS /= 0.0 .AND. IPR(745) > 0) THEN
                DS = DIF / DS
              ELSE
                NSIG = 0
                DS   = 0.0
              END IF
              VDIF = VDIF + DIF**2
              NV   = NV + 1
              FORMB(25:25) = CHAR (ICHAR ('0') + ND1)
              FORMB(42:42) = CHAR (ICHAR ('0') + ND2)
              WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1          NQ3(1:7), NQ4(1:7), NQ1(1:7), NQ2(1:7), D1, ISD1, D2,
     2          ISD2, DIF, DS
              CALL PLA263 (LU7, PRBUF, 132, 1, 3)
              DATC(NV) = ABS (DS)
            END IF
          END IF
        END IF
        GO TO 10
      END IF
      VDIF = SQRT (VDIF / NV)
      CALL PLA262 (2)
      WRITE (LU7, 99997, IOSTAT = IOST) VDIF
C * HALF NORMAL PROBABILITY PLOT
      IF (NV > 5 .AND. NSIG == 1) THEN
        CALL PLA262 (0)
        CALL GEN116 (1, DATC(1), DATC(NV + 1), NV, GRAPH, LU7)
      END IF
C * COMPARE ANGLES OF RESIDUES
      CALL PLA262 (0)
      CALL PLA262 (5)
      WRITE (LU7, 99996, IOSTAT = IOST) IRES, JRES
      IPR(133) = 0
      VDIS     = 0.0
      NV       = 0
      KB       = 0
      IFIN     = -1
      NSIG     = 1
C * LOOP OVER ANGLES
   20 CALL PLA039 (I, J, K, IRES, A, SA, ISA, NDEC, KB, IFIN)
      IF (IFIN /= 1) THEN
        IAT = JCA(I)
        JAT = JCA(J)
        KAT = JCA(K)
        IF (IAT /= 0 .AND. JAT /= 0 .AND. KAT /= 0) THEN
          CALL PLA047 (LABA(IAT), NQ1, IDUM, JDUM,
     1                 IPR(71), IGBL(55), 0, 0)
          CALL PLA047 (LABA(JAT), NQ2, IDUM, JDUM,
     1                 IPR(71), IGBL(55), 0, 0)
          CALL PLA047 (LABA(KAT), NQ3, IDUM, JDUM,
     1                 IPR(71), IGBL(55), 0, 0)
          CALL PLA053 (IAT, JAT, KAT, 0, A1, SA1, ISA1, ND1, IER)
          IF (IER == 0) THEN
            DIF = A - A1
            DS  = SQRT (SA**2 + SA1**2)
            IF (DS /= 0 .AND. IPR(745) > 0) THEN
              DS = DIF / DS
            ELSE
              NSIG = 0
              DS   = 0.0
            END IF
            VDIS = VDIS + DIF**2
            NV   = NV + 1
            FORMA(36:36) = CHAR (ICHAR ('0') + NDEC)
            FORMA(52:52) = CHAR (ICHAR ('0') + ND1)
            WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1        (NAMS(1, M)(2:8), M = 1, 3),
     2        NQ1(1:7), NQ2(1:7), NQ3(1:7), A, ISA, A1, ISA1, DIF, DS
            CALL PLA263 (LU7, PRBUF, 132, 1, 3)
            DATC(NV) = ABS (DS)
          END IF
        END IF
        GO TO 20
      END IF
      VDIS = SQRT (VDIS / NV)
      CALL PLA262 (2)
      WRITE (LU7, 99994, IOSTAT = IOST) VDIS
C * HALF NORMAL PROBABILITY PLOT
      IF (NV > 5 .AND. NSIG == 1) THEN
        CALL PLA262 (0)
        CALL GEN116 (1, DATC(1), DATC(NV + 1), NV, GRAPH, LU7)
      END IF
      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 PLA084
 
      SUBROUTINE PLA085
C * NONSYM : SEARCH FOR (NON)-CRYSTALLOGRAPHIC SYMMETRY
C * NO ANALYSIS FOR ANGSTROM DATA
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                   :: I
      INTEGER                   :: J
      INTEGER                   :: K
      INTEGER                   :: L
      INTEGER                   :: M
      INTEGER                   :: M0
      INTEGER                   :: I0
      INTEGER                   :: I1
      INTEGER                   :: I2
      INTEGER                   :: J0
      INTEGER                   :: J1
      INTEGER                   :: J2
      INTEGER                   :: K1
      INTEGER                   :: L0
      INTEGER                   :: JJ
      INTEGER                   :: NX
      INTEGER                   :: II
      INTEGER                   :: IVL
      INTEGER                   :: LBN1
      INTEGER                   :: LBN2
      INTEGER                   :: IRES
      INTEGER                   :: JRES
      INTEGER                   :: NVEC
      INTEGER                   :: NMAX
      INTEGER                   :: NRES
      INTEGER                   :: NATA
      INTEGER                   :: NATB
      INTEGER                   :: NVAR
      INTEGER                   :: IDUM
      INTEGER                   :: MDIST
      INTEGER                   :: IRESL
      INTEGER                   :: IRESM
      INTEGER                   :: IENR1
      INTEGER                   :: IENR2
      INTEGER                   :: IDETA
      INTEGER                   :: IDETB
      INTEGER                   :: IDETR
      INTEGER, DIMENSION(3, 3)  :: IANG
      REAL                      :: XX
      REAL                      :: YY
      REAL                      :: ZZ
      REAL                      :: ANG
      REAL                      :: DUM
      REAL                      :: XSQ
      REAL                      :: YSQ
      REAL                      :: ZSQ
      REAL                      :: WHTA
      REAL                      :: WHTB
      REAL                      :: DIST
      REAL                      :: V4MX
      REAL                      :: V6MX
      REAL                      :: V8MX
      REAL                      :: XLNG
      REAL                      :: GLIDEA
      REAL                      :: GLIDEB
      REAL                      :: DISTMN
      REAL                      :: ANGMAX
      REAL                      :: UIJSUM
      REAL                      :: GEN009
      REAL                      :: GEN017
      REAL                      :: VARDIST
      REAL                      :: SINANGMAX
      REAL,    DIMENSION(3, 37) :: DHX
      REAL,    DIMENSION(3, 3)  :: DUMVA
      REAL,    DIMENSION(3, 3)  :: DUMVB
      REAL,    DIMENSION(3, 3)  :: YUNK
      REAL,    DIMENSION(3, 3)  :: V11
      REAL,    DIMENSION(3, 3)  :: V12
      REAL,    DIMENSION(3, 3)  :: V14
      REAL,    DIMENSION(3)     :: EWA
      REAL,    DIMENSION(3)     :: EWB
      REAL,    DIMENSION(3)     :: V2A
      REAL,    DIMENSION(3)     :: V2B
      REAL,    DIMENSION(3)     :: HSXYZ
      REAL,    DIMENSION(3)     :: DXYZ
      REAL,    DIMENSION(3)     :: HSXYZA
      REAL,    DIMENSION(3)     :: DXYZA
      REAL,    DIMENSION(3)     :: HSXYZS
      REAL,    DIMENSION(3)     :: DXYZS
      REAL,    DIMENSION(3)     :: V10
      REAL,    DIMENSION(3)     :: V13
      IF (IPR(23) == 0) THEN
        WRITE (LU6, 99982)
        IPR(33) = 0
        NX      = 0
        NVEC    = 0
        NMAX    = IPR(39)
        NRES    = IPR(75)
        WHTA    = 0.0
        NATA    = 0
        IDETA   = 0
        PAGET   = 'NONSYM'
C * GENERATE AN ORDERED LIST OF SHORT LATTICE VECTORS
        CALL GEN101 (2, NVEC, DHX)
        DO I = 1, 3
          EWA(I) = 0.0
          V2A(I) = 0.0
          DO J = 1, 3
            DUMVA(I, J) = 0.0
          END DO
        END DO
C * LIST RESIDUE DATA (MAIN AXES ETC)
        DO I = 1, NRES
          CALL PLA083 (I, DUMVA, EWA, V2A, WHTA, NATA, IDETA)
          IF (NATA > 0) THEN
            NX = NX + 1
            IF (NX == 1) THEN
              IF (IGBL(63) > 0) THEN
                CALL PLA262 (0)
                WRITE (LU7, 99999, IOSTAT = IOST)
                WRITE (LU7, 99991, IOSTAT = IOST)
              END IF
            END IF
            DO J = 1, 3
              DO K = 1, 3
                ANG = 0.0
                DO L = 1, 3
                  ANG = ANG + DUMVA(L, J) * OR(L, K) / PAR(100 + K)
                END DO
                IF (ANG >  1.0) ANG =  1.0
                IF (ANG < -1.0) ANG = -1.0
                IANG(J, K) = NINT (ACOS (ANG) * RGBL(6))
              END DO
            END DO
            II = I * IDETA
            IF (IGBL(63) > 0) THEN
              WRITE (LU7, 99987, IOSTAT = IOST)
     1          II, (XXO(NMAX + I, K), K = 1, 3),
     2          (DUMVA(I0, 1), I0 = 1, 3), NINT (EWA(1)), ABS (V2A(1)),
     3          (IANG(1, I0), I0 = 1, 3)
              WRITE (LU7, 99986, IOSTAT = IOST)
     1          (XXO(NMAX + I, K), K = 4, 6),
     2          (DUMVA(I0, 2), I0 = 1, 3), NINT (EWA(2)), ABS (V2A(2)),
     3          (IANG(2, I0), I0 = 1, 3)
              WRITE (LU7, 99985, IOSTAT = IOST)
     1          WHTA, (DUMVA(I0, 3), I0 = 1, 3),
     2          NINT (EWA(3)), ABS (V2A(3)), (IANG(3, I0), I0 = 1, 3)
            END IF
          END IF
        END DO
        IF (NX > 1) THEN
C * GET DISTANCE TO RESIDUE CENTRE OF GRAVITY
          DO I = 1, NMAX
            CALL GEN048 (-6, IFG(1, I), 9, IRES)
            DIST = 0.0
            DO J = 4, 6
              DIST = DIST + (XXO(NMAX + IRES, J) - XXO(I, J))**2
            END DO
            IATC(I) = I
            DATC(I) = SQRT (DIST)
          END DO
          CALL GEN036 (DATC, IATC, 1, NMAX)
C * ANALYSE PAIRS
          IF (NRES > 1) THEN
            DO 30 IRES = 1, NRES - 1
              CALL PLA083 (IRES, DUMVA, EWA, V2A, WHTA, NATA, IDETA)
              IF (NATA == 0) GO TO 30
              II = IRES * IDETA
              DO 20 JRES = IRES + 1, NRES
                CALL PLA083 (JRES, DUMVB, EWB, V2B, WHTB, NATB, IDETB)
                IF (NATB == 0) GO TO 20
                JJ = JRES * IDETB
                IF (ABS (WHTB - WHTA) < 0.1 .AND.
     1            NATA == NATB) THEN
C * DETERMINE (NON)INVERSE RELATION
                  IDETR = IDETA * IDETB
C * FIND ROTATION AXIS FROM A TO B
C * SYSTEM A AS ROWVECTORS IN DUMVA
C * SYSTEM B AS ROWVECTORS IN DUMVB
C * FIRST GET TRANSFORMATION MATRIX UIJ FROM DUMVB = UIJ * DUMVA
C * THUS UIJ = DUMVB * (DUMVA)^-1 or DUMVB * TRANSPOSE(DUMVA)
C * TRANSPOSE DUMVA
                  CALL GEN005 (DUMVA, QM)
                  CALL GEN004 (DUMVB, QM, UIJ)
                  UIJSUM = (UIJ(1, 1) + UIJ(2, 2) + UIJ(3, 3)) * IDETR
C * V2 = AVERAGE, V3 = DIFFERENCE (ANG) BETWEEN CENTERS
                  DO 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)
                  END DO
                  IF (UIJSUM < 2.999) THEN
C * FIND ROTATION VECTOR V1 FROM ROTATION MATRIX UIJ (IN ORTH SYSTEM)
                    CALL GEN074 (V1, 1, 3, 0.0)
                    DO I1 = 1, 3
                      J1 = MOD (I1, 3) + 1
                      DO K1 = 1, 3
                        V4(K1) = UIJ(K1, I1) * IDETR
                        V5(K1) = UIJ(K1, J1) * IDETR
                      END DO
                      V4(I1) = V4(I1) - 1
                      V5(J1) = V5(J1) - 1
                      CALL GEN008 (V4, V5, V6, 1)
                      IF (GEN009 (V1, V6) >= 0.0) THEN
                        CALL GEN015 (V1, V6, V1, 1.0)
                      ELSE
                        CALL GEN015 (V1, V6, V1, -1.0)
                      END IF
                    END DO
C * NORMALISE ROTATION VECTOR V1
                    XX = GEN017 (V1)
                    SINANGMAX = 99999.0
C * SEARCH FOR COINCIDING DIRECT (V1) AND RECIPROCAL LATTICE VECTORS
C * LOOP OVER PLANES
                    DO I = 1, 37
                      CALL GEN002 (-2, ROR, DHX(1, I), V8, XLNG)
C * CALCULATE THE ANGLE BETWEEN THE ROW AND THE NORMAL TO THE PLANE
                      CALL GEN008 (V8, V1, V5, -1)
                      IF (V5(1) < SINANGMAX) THEN
                        SINANGMAX = V5(1)
                        DO K1 = 1, 3
                          V6(K1) = DHX(K1, I)
                        END DO
                      END IF
                    END DO
                    ANGMAX = ABS (ASIN (SINANGMAX) * RGBL(6))
                    ANGMAX = MIN (ANGMAX, 180.0 - ANGMAX)
                    WRITE (LU6, 99989, IOSTAT = IOST)
     1                (V6(I), I = 1, 3), ANGMAX
                    IF (IGBL(63) > 0) THEN
                      CALL PLA262 (0)
                      CALL PLA262 (3)
                      WRITE (LU7, 99989, IOSTAT = IOST)
     1                  (V6(I), I = 1, 3), ANGMAX
                    END IF
C * TEST FOR TOO MANY AXIS FOUND CONDITION
                    DO I1 = 1, 3
                      PAT(I1, 3) = V1(I1)
                    END DO
                    XX = SQRT (V1(1)**2 + V1(2)**2)
                    IF (XX > 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
                    END IF
                    CALL GEN008 (PAT(1, 3), PAT(1, 1), PAT(1, 2), 1)
C * TRANSPOSE MATRIX
                    CALL GEN005 (PAT, YUNK)
C * COPY MATRIX
                    CALL GEN052 (YUNK, PAT)
C * MULTIPLY MATRICES
                    CALL GEN004 (PAT, UIJ, UIJC)
C * TRANSPOSE MATRIX
                    CALL GEN005 (PAT, YUNK)
C * COPY MATRIX
                    CALL GEN052 (YUNK, PAT)
C * MULTIPLY MATRICES
                    CALL GEN004 (UIJC, PAT, YUNK)
C * COPY MATRIX
                    CALL GEN052 (YUNK, UIJC)
                    V1(4) = (ATAN2 ((UIJC(2, 1) - UIJC(1, 2)) * IDETR,
     1                (UIJC(1, 1) + UIJC(2, 2)) * IDETR)) * RGBL(6)
C * CONVERT TO CRYSTAL SYSTEM (V4 - ROTATION VECTOR IN XTAL SYSTEM)
                    CALL GEN002 (1, ROR, V1, V4, DUM)
                    V4MX = MAX (ABS (V4(1)), ABS (V4(2)), ABS (V4(3)))
                    DO K = 1, 3
                      V4(K) = V4(K) / V4MX
                    END DO
                    IF (IDETR > 0) THEN
                      GLIDEA = GEN009 (V1, V3)
                      WRITE (LU6, 99996, IOSTAT = IOST) II, JJ,
     1                  (V4(I2), I2 = 1, 3), V1(4), GLIDEA
                      IF (IGBL(63) > 0) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99990, IOSTAT = IOST)
                        WRITE (LU7, 99996, IOSTAT = IOST) II, JJ,
     1                      (V4(I2), I2 = 1, 3), V1(4), GLIDEA
                      END IF
                    ELSE
                      WRITE (LU6, 99994, IOSTAT = IOST) II, JJ,
     1                  (V4(I2), I2 = 1, 3), V1(4)
                      IF (IGBL(63) > 0) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99990, IOSTAT = IOST)
                        WRITE (LU7, 99994, IOSTAT = IOST) II, JJ,
     1                    (V4(I2), I2 = 1, 3), V1(4)
                      END IF
                      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 K = 1, 3
                        V6(K) = V6(K) / V6MX
                      END DO
                      WRITE (LU6, 99995, IOSTAT = IOST) II, JJ,
     1                    (V6(I2), I2 = 1, 3), GLIDEB
                      IF (IGBL(63) > 0) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99995, IOSTAT = IOST)
     1                    II, JJ, (V6(I2), I2 = 1, 3), GLIDEB
                      END IF
                    END IF
                  ELSE
C * (PSEUDO)INVERSION
                    IF (IDETR < 0) THEN
C * CONVERT TO CRYSTAL SYSTEM
                      CALL GEN002 (1, ROR, V2, V8, DUM)
                      WRITE (LU6, 99998, IOSTAT = IOST)
     1                  II, JJ, (V8(K), K = 1, 3)
                      IF (IGBL(63) > 0) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99990, IOSTAT = IOST)
                        WRITE (LU7, 99998, IOSTAT = IOST)
     1                    II, JJ, (V8(K), K = 1, 3)
                      END IF
                    ELSE
C * (PSEUDO)TRANSLATION
C * CONVERT TO CRYSTAL SYSTEM
                      CALL GEN002 (1, ROR, V3, V8, DUM)
                      V8MX = MAX (ABS (V8(1)), ABS (V8(2)), ABS (V8(3)))
                      DO K = 1, 3
                        V8(K) = V8(K) / V8MX
                      END DO
                      WRITE (LU6, 99997, IOSTAT = IOST)
     1                  II , JJ, (V8(K), K = 1, 3)
                      IF (IGBL(63) > 0) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99990, IOSTAT = IOST)
                        WRITE (LU7, 99997, IOSTAT = IOST)
     1                    II , JJ, (V8(K), K = 1, 3)
                      END IF
                    END IF
                  END IF
C * COMPARE COORDINATES OF ROTATED RESIDUE I WITH RESIDUE J
                  VARDIST = 0.0
                  NVAR    = 0
                  IPR(12) = 0
                  DO L = 1, NMAX
                    IATC(L) = IABS (IATC(L))
                  END DO
                  CALL GEN074 (HSXYZA, 1, 3, 0.0)
                  CALL GEN074 (DXYZA,  1, 3, 0.0)
                  CALL GEN074 (HSXYZS, 1, 3, 0.0)
                  CALL GEN074 (DXYZS,  1, 3, 0.0)
                  CALL GEN074 (V10,    1, 3, 0.0)
C * LOOP OVER FIRST ATOM IN RES # 1
                  DO 10 L0 = 1, NMAX
                    L = IATC(L0)
                    IF (L > 0) THEN
                      CALL GEN048 (-6, IFG(1, L), 9, IRESL)
                      IF (IRESL == IRES) THEN
C * IGNORE H-ATOMS
                        CALL GEN048 (-1, IFG(1, L), 7, IVL)
                        IF (IVL == 0) THEN
                          DO I = 1, 3
                            V6(I) = XXO(L, I + 3)
     1                            - XXO(NMAX + IRES, I + 3)
                          END DO
                          CALL GEN002 (1, UIJ, V6, V8, DUM)
                          DO I = 1, 3
                            V8(I) = V8(I) + XXO(NMAX + IRES, I + 3)
                          END DO
C * ADD VECTORS V8 = V8 + V3
                          CALL GEN015 (V8, V3, V8, 1.0)
                          DISTMN = 99999.0
                          MDIST  = 0
                          CALL PLA047 (LABA(L), NQ1, IDUM, IENR1,
     1                      0, IGBL(55), 0, 0)
C * GET LABUTE-NUMBER FOR L
                          CALL GEN048 (-10, IFG(2, L), 14, LBN1)
C * LOOK FOR CORRESPONDING ATOM IN RES # 2
                          DO M0 = 1, NMAX
                            M = IATC(M0)
                            IF (M > 0) THEN
                              CALL GEN048 (-6, IFG(1, M), 9, IRESM)
                              IF (IRESM == JRES) THEN
                                CALL PLA047 (LABA(M), NQ2, IDUM,
     1                            IENR2, 0, IGBL(55), 0, 0)
C * CHECK FOR SAME ELEMENT TYPE
                                IF (IENR1 == IENR2) THEN
C * IGNORE H-ATOMS
                                  CALL GEN048 (-1, IFG(1, M), 7, IVL)
                                  IF (IVL == 0) THEN
C * GET LABUTE-NUMBER FOR M
                                    CALL GEN048 (-10, IFG(2, M), 14,
     1                                           LBN2)
                                    IF (LBN2 == LBN1) THEN
                                      DO I = 1, 3
                                        V6(I) = XXO(M, I + 3)
                                      END DO
C * SUBSTRACT VECTORS
                                      CALL GEN015 (V8, V6, V5, -1.0)
                                      DIST = SQRT (GEN009 (V5, V5))
                                      IF (DIST < DISTMN) THEN
                                        DISTMN = DIST
                                        MDIST  = M0
                                      END IF
                                    END IF
                                  END IF
                                END IF
                              END IF
                            END IF
                          END DO
                          M0 = MDIST
                          IF (M0 == 0) GO TO 10
                          MDIST  = IATC(M0)
                          JCA(L) = MDIST
C * MARK OFF THIS ATOM
                          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) > 0) THEN
                            CALL PLA047 (LABA(MDIST), NQ2, IDUM,
     1                        IENR2, 0, IGBL(55), 0, 0)
                            IF (NVAR == 1) THEN
                              CALL PLA262 (5)
                              WRITE (LU7, 99992, IOSTAT = IOST)
                            END IF
                            DO J = 1, 3
                              V10(J)  = V10(J) + (XXO(L, J + 3) +
     1                                  XXO(MDIST, J + 3)) / 2.0
                              HSXYZ(J)  = (XXO(L, J) + XXO(MDIST, J))
     1                        / 2.0
                              HSXYZA(J) = HSXYZA(J)  + HSXYZ(J)
                              DXYZ(J)   = (XXO(L, J) - XXO(MDIST, J))
                              DXYZA(J)  = DXYZA(J)   + ABS (DXYZ(J))
                            END DO
                            CALL PLA262 (1)
                            WRITE (LU7, 99993, IOSTAT = IOST)
     1                        NQ1(1:7), (V8(J), J = 1, 3), DATC(L0),
     2                        NQ2(1:7), (XXO(MDIST, J + 3), J = 1, 3),
     3                        DATC(M0), DISTMN, LBN1,
     4                        (HSXYZ(J), J = 1, 3), (DXYZ(J), J = 1, 3)
                          END IF
                        END IF
                      END IF
                    END IF
   10             CONTINUE
                  IF (IGBL(63) > 0 .AND. NVAR > 0) THEN
                    DO J = 1, 3
                      HSXYZA(J) = HSXYZA(J) / NVAR
                      DXYZA(J)  = DXYZA(J)  / NVAR
                      V10(J)    = V10(J)    / NVAR
                    END DO
                    DO II = 1, 3
                      DO JJ = 1, 3
                        V11(II,JJ) = 0.0
                      END DO
                    END DO
                    CALL PLA262 (4)
                    DO J = 1, IPR(12) -1, 2
                      J1 = JR(J)
                      J2 = JR(J + 1)
                      XX = (XXO(J1, 4) + XXO(J2, 4)) / 2.0 - V10(1)
                      YY = (XXO(J1, 5) + XXO(J2, 5)) / 2.0 - V10(2)
                      ZZ = (XXO(J1, 6) + XXO(J2, 6)) / 2.0 - V10(3)
                      XSQ = XX**2
                      YSQ = YY**2
                      ZSQ = ZZ**2
                      V11(1, 1) = V11(1, 1) + (YSQ + ZSQ)
                      V11(1, 2) = V11(1, 2) - XX * YY
                      V11(1, 3) = V11(1, 3) - XX * ZZ
                      V11(2, 2) = V11(2, 2) + (ZSQ + XSQ)
                      V11(2, 3) = V11(2, 3) - YY * ZZ
                      V11(3, 3) = V11(3, 3) + (XSQ + YSQ)
                      DO J0 = 1, 3
                        HSXYZ(J0)  = (XXO(J1, J0) + XXO(J2, J0))
     1                        / 2.0
                        HSXYZS(J0) = HSXYZS(J0)   +
     1                               (HSXYZ(J0)   - HSXYZA(J0))**2
                        DXYZ(J0)   = XXO(J1, J0)  - XXO(J2, J0)
                        DXYZS(J0)  = DXYZS(J0)    +
     1                               (DXYZA(J0) - ABS (DXYZ(J0)))**2
                      END DO
                    END DO
C * CALCULATE MAIN AXIAL SYSTEM (ANGSTROM COORDINATE SYSTEM)
                    CALL GEN024 (V11, V12, V13, V14)
                    DO J = 1, 3
                      HSXYZS(J) = SQRT (HSXYZS(J) / NVAR)
                      DXYZS(J)  = SQRT (DXYZS(J)  / NVAR)
                    END DO
                    WRITE (LU7, 99981) (V12(1, J), J = 1, 3), V13(1),
     1                (HSXYZA(J), J = 1, 3), (DXYZA(J), J = 1, 3)
                    WRITE (LU7, 99980) (V12(2, J), J = 1, 3), V13(2),
     1                (HSXYZS(J), J = 1, 3), (DXYZS(J), J = 1, 3),
     2                (V12(3, J), J = 1, 3), V13(3)
                  END IF
                  IF (NVAR /= 0) THEN
                    VARDIST = SQRT (VARDIST / NVAR)
                    WRITE (LU6, 99988, IOSTAT = IOST) VARDIST
                    IF (IGBL(63) > 0) THEN
                      CALL PLA262 (2)
                      WRITE (LU7, 99988, IOSTAT = IOST) VARDIST
                    END IF
                  ELSE
                    VARDIST = 999.0
                  END IF
C * QUATERNION-FIT
                  IF (IGBL(63) > 0 .AND. NVAR > 5) THEN
                    CALL PLA442 (0, VARDIST)
                    WRITE (LU6, 99983, IOSTAT = IOST)
                    CALL PLA262 (3)
                    WRITE (LU7, 99983, IOSTAT = IOST)
                    IF (VARDIST < PAR(483)) THEN
                      CALL PLA084 (IRES, JRES)
                    ELSE
                      CALL PLA262 (2)
                      WRITE (LU6, 99984, IOSTAT = IOST) PAR(483)
                      WRITE (LU7, 99984, IOSTAT = IOST) PAR(483)
                    ENDIF
                  END IF
                END IF
   20         CONTINUE
   30       CONTINUE
          END IF
        END IF
      END IF
      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  '- Only residues with more than 6 atoms are analysed', /)
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, 3X,
     1        2(1X, 3F7.3))
99992 FORMAT (/, 'Comparison of Orthogonal Coordinates of Transformed',
     1        ' Residue #I with those of Residue #J', 12X,
     2        'Fractional Untransformed', /, 132('='), /,
     3        'Atom I', 6X, 'XI', 5X, 'YI', 5X, 'ZI', 4X, 'RI', 2X,
     4        'Atom J', 6X, 'XJ', 5X, 'YJ', 5X, 'ZJ', 4X, 'RJ', 1X,
     5        'Dist(Ang)  Tnr', 12X, 'HalfSum', 15x, 'Difference', /,
     6         132('-'))
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, /)
99984 FORMAT (':: RMS-FIT .GT.', F5.2, ' >>>  NO Bond Comparison', /)
99983 FORMAT (/, ':: Warning: The Pairwise Atom Association',
     1           ' is Tentative and may be Erroneous', /)
99982 FORMAT (/, ':: Summary NONSYM Analysis', /)
99981 FORMAT (89X, 43('-'), /,
     1        'EV1 =', 3F8.3, 2X, 'EW1 =', F8.3,
     2        35X, 'Averages: ', 3F7.3, 1X, 3F7.3)
99980 FORMAT ('EV2 =', 3F8.3, 2X, 'EW2 =', F8.3,
     1         38X, 'Sigma: ', 3F7.3, 1X, 3F7.3, /,
     2        'EV3 =', 3F8.3, 2X, 'EW3 =', F8.3)
      END SUBROUTINE PLA085
 
      SUBROUTINE PLA086 (LU)
C * EXPECTED # REFLECTIONS
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: LU
      INTEGER :: NREF1
      INTEGER :: NREF2
      INTEGER :: NREF3
      REAL    :: XJ
      REAL    :: STHL
      REAL    :: CONST
      CALL PLA100
      CONST = 16.0 * RGBL(5) * PAR(98) / 3.0
      IF (LU == LU7) CALL PLA262 (0)
      WRITE (LU, 99999, IOSTAT = IOST) IPR(48)
      DO I = 20, 30
        STHL  = SIN (I / RGBL(6)) / 0.71073
        NREF1 = NINT (CONST * STHL ** 3)
        NREF2 = NREF1 / IPR(48)
        NREF3 = NREF2 / (3 - IPR(275))
        XJ    = ASIN (MIN (1.0, STHL * 1.5418)) * RGBL(6)
        WRITE (LU, 99998, IOSTAT = IOST)
     1    I, NREF1, NREF2, NREF3, XJ , STHL
      END DO
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 PLA086
 
      SUBROUTINE PLA087
C * SETS IN/EXCLUDE AND DO/AC FLAGS AND INIT FOR PLA067
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: NO1
      INTEGER :: NAT
      INTEGER :: NID
      INTEGER :: IKAT
      INTEGER :: IVAL
      INTEGER :: ICARB
      INTEGER :: IELTP
      INTEGER :: NDOAC
      REAL    :: RADJ
      REAL    :: RVAL
 
C * CHECK FOR NONZERO NUMBER OF ATOMS
      IF (IPR(37) == 0) THEN
        IPR(2) = 42
      ELSE
C * TEST FOR PREVIOUS EXECUTION OF A CALC INTRA INSTRUCTION
        IF (IPR(30) == 0) THEN
C * PREPARE ATOM SET (PART1)
          CALL PLA088
          NAT   = IPR(37)
          NDOAC = IPR(480)
C * RESET CONNECTIVITY FOR INTRA MODE CALCULATION
          CALL PLA040 (0, 1, NP1, 0)
C * RESET MOL-LIST
          IPR(13) = 1
          MOL(1)  = NINT (1555 * PAR(42))
          IPR(51) = IPR(13)
C * RESET NR OF RESIDUES
          IPR(75) = 0
          IPR(17) = 0
C * SET APPROPRIATE BITS FOR INTRA/DOAC
          DO I = 1, NAT
C * GET ATOM KIND
            CALL GEN048 (-4, IFG(1, I), 15, NO1)
            NO1 = NO1 + 1
C * INTRA MODE REQUIRES BIT 1 TO 3 INITIALIZED
C * BIT 1 = 'DONE', BIT 2 = 'FIX', BIT 3 = 'NEXT'
            CALL GEN048 (3, IFG(1, I), 1, 0)
            IKAT = I
C * ORTHOGONALISE
            CALL PLA059 (IKAT, IKAT)
C * TEST FOR DO/AC ATOMS AND SET FLAGS
            IVAL = 0
            DO J = 1, NDOAC
              IF (IEN(NO1) == IDOAC(J)) THEN
                IVAL = 1
                EXIT
              END IF
            END DO
C * SET DO/AC FLAG
            CALL GEN048 (1, IFG(1, I), 23, IVAL)
C * TRANSFORM AND FIX INDICATED ATOMS
            IF (IGBL(30) == 1 .OR. IATP(I) > 0)  CALL PLA071 (I)
          END DO
        END IF
C * SET RADII INTRA, INTER OR COORDINATION MODE
C * SET RADII ACCORDING TO DEFAULT VALUES OR AS SUPPLIED ON 'CALC' CARDS
        IF (IPR(17) < 0) THEN
C * LOAD DEFAULT INTER/VOID ( = VAN DER WAALS ) RADII
          DO I = 1, IAN
            RADR(I, 2) = RADR(I, 4)
          END DO
          IF (IPR(189) == 0) THEN
            PAR(1) = PAR(3)
          ELSE
            PAR(1) = 0.0
          END IF
        ELSE IF (IPR(17) == 0) THEN
C * LOAD DEFAULT INTRA (UNIQUE) RADII
          DO I = 1, IAN
            RADR(I, 2) = RADR(I, 3)
          END DO
          PAR(1) = PAR(2)
          IF (IPR(31) /= 0) GO TO 40
        ELSE
          PAR(1) = 0.0
C * SET RADII 'CALC COORDN', 'CALC METAL', 'CALC DIST'
          DO I = 1, IAN
            RVAL = 0.0
            IF (IPR(57) == 1) THEN
C * CALC METAL
              IELTP = IATPR(IEN(I))
              IF (IELTP > 0) RVAL = PAR(262)
C * CALC RDF
            ELSE IF (IPR(57) == 2) THEN
              RVAL = PAR(262)
            ELSE IF (IPR(57) < 0) THEN
C * CALC DIST
              IF (IPR(57) + I == 0) RVAL = PAR(262)
            ELSE
C * CALC COORDN (EXCLUDE C & H, D, Hw) (INCLUDE C FOR IUCR-CHECK)
C * TEST FOR RES OR CIF STYLE DATA
              IF (IABS(IGBL(8)) == 2 .OR. IABS(IGBL(8)) == 3) THEN
                ICARB = 1
              ELSE
                ICARB = 2
              END IF
              IF (IEN(I) > ICARB .AND. IEN(I) /= 33 .AND.
     1            IEN(I) /= 113) RVAL = PAR(262)
            END IF
            RADR(I, 2) = RVAL
          END DO
C * HANDLE SELECTED ATOM COORDINATION
          IPR(168) = 0
          IF (IPR(220) >= 3) THEN
            IF (IFL(3)(1:3) == 'NOA') THEN
              IPR(7) = 0
            ELSE
              CALL PLA037 (3, NID, 3)
              IF (NID < 0) THEN
                IPR(168) = - NID
              ELSE IF (NID == 0) THEN
                IPR(2) = 18
                RETURN
              END IF
            END IF
          END IF
        END IF
C * SET THE RADII ACCORDING TO THOSE EXPLICITELY SPECIFIED
        DO J = 1, IAN
          RADJ       = RADR(J, 1)
          RADR(J, 1) = -1.0
          IF (RADJ >= 0.0) RADR(J, 2) = RADJ
        END DO
C * RESET PARAMETERS (HEADER, CURRENT RESIDUE, SYMM, NSG)
   40   IPR(15)  = 0
        IPR(104) = 1
        IPR(24)  = 0
C * TEST FOR ANGSTROM (IPR(23)=1) OR NOSYMM (IGBL(52)=1)
        IF (IPR(23) == 1 .OR. IGBL(52) == 1) THEN
          IPR(27)  = 1
          IGBL(30) = 1
        ELSE
          IPR(27) = 0
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA087
 
      SUBROUTINE PLA088
C * PREPARE ATOM SET (PART1)
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: ND
      INTEGER :: NO1
      INTEGER :: NAT
      INTEGER :: NIAP
      INTEGER :: KINC
      INTEGER :: IVAL
      INTEGER :: MODE
      INTEGER :: JRSAVE
      INTEGER :: LBSAVE
C * TEST FOR PREVIOUS EXECUTION OF A CALC INTRA INSTRUCTION
      IF (IPR(30) == 0) THEN
        NAT    = IPR(37)
        KINC   = IPR(4)
        IPR(4) = 0
C * CHECK FOR PREVIOUS ATOM SORT
        IF (IPR(208) == 0) THEN
C * WRITE HEADER
          CALL PLA042 (1)
C * SORT FORMULA INTO C H D .. ALPHABETIC ORDER
C * OR ALPHABETICALLY FOR NON-CARBON CONTAINING COMPOUNDS
          MODE = 0
          DO I = 1, IAN
            IF (IEN(I) == 2) THEN
              MODE = 1
              EXIT
            END IF
          END DO
C * SORT FORMULA
          CALL GEN123 (MODE, IEN, IENS, IEL, IAN)
C * EXECUTE INCLUDE/EXCLUDE INSTRUCTION(S), INCLUDE = 1/EXCLUDE = 0
          DO I = 1, NAT
C * GET ATOM TYPE
            CALL GEN048 (-4, IFG(1, I), 15, NO1)
            IF (KINC > 0) THEN
              IVAL = 1 - IPR(70)
              DO J = 1, KINC
                IF (NO1 + 1 == NINT (RADR(J, 2))) THEN
                  IVAL = IPR(70)
                  EXIT
                END IF
              END DO
              JR(I) = JR(I) * IVAL
            END IF
          END DO
C * (NO)SORT ATOMS ON ATOM NUMBER (ELEMENT TYPE AND SEQUENCE NUMBER)
          IF (IGBL(33) /= 0) THEN
            ND = 2**(INT ((ALOG (FLOAT (NAT)) / ALOG (2.0)) + 1.0E-5))
     1         - 1
            DO WHILE (ND > 0)
              I = 1
              DO
                J      = I
                NIAP   = IATP(I + ND)
                JRSAVE = JR(I   + ND)
                LBSAVE = LABA(I + ND)
                DO K = 1, 3
                  IDBUF(K) = IFG(K, I + ND)
                END DO
                DO K = 3, 9
                  DBUF(K) = CON(I + ND, K)
                END DO
   10           IF (JRSAVE < JR(J)) THEN
                  IATP(J + ND) = IATP(J)
                  JR(J   + ND) = JR(J)
                  LABA(J + ND) = LABA(J)
                  DO K = 1, 3
                    IFG(K, J + ND) = IFG(K, J)
                  END DO
                  DO K = 3, 9
                    CON(J + ND, K) = CON(J, K)
                  END DO
                  J = J - ND
                  IF (J > 0) GO TO 10
                END IF
                IATP(J + ND) = NIAP
                JR(J   + ND) = JRSAVE
                LABA(J + ND) = LBSAVE
                DO K = 1, 3
                  IFG(K, J  + ND) = IDBUF(K)
                END DO
                DO K = 3, 9
                  CON(J + ND, K) = DBUF(K)
                END DO
                I = I + 1
                IF (I + ND > NAT) EXIT
              END DO
              ND = (ND - 1) / 2
            END DO
          END IF
C * ORDER/LOAD ASSOCIATED ATOM DATA
          K = 0
          DO I = 1, NAT
            IF (JR(I) /= 0) THEN
              K       = K + 1
              LABA(K) = LABA(I)
              DO J = 1, 3
                IFG(J, K)  = IFG(J, I)
              END DO
              IATP(K) = IATP(I)
              DO J = 1, 3
                XXO(K, J) = CON(I, J + 2)
                IF (IABS (IGBL(8)) /= 2) THEN
                  XSD(K, J) = CON(I, J + 5)
                ELSE
                  XSD(K, J) = 0.0
                END IF
              END DO
            END IF
          END DO
          IPR(37)  = K
          IPR(39)  = K
          IPR(208) = 1
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA088
 
      MODULE hbond
      SAVE
      INTEGER               :: NC
      INTEGER               :: IDC
      INTEGER               :: ITLC
      INTEGER               :: IVLC
      INTEGER               :: NTEL
      INTEGER               :: IRES
      INTEGER               :: IOLD
      INTEGER               :: KOLD
      INTEGER               :: IDISK
      INTEGER               :: INORM
      INTEGER               :: NHEAD
      INTEGER               :: LOOPT
      INTEGER               :: NFOUND
      INTEGER, DIMENSION(3) :: ISA
      INTEGER, DIMENSION(3) :: ISD
      INTEGER, DIMENSION(8) :: IDEC
      REAL                  :: A0
      REAL                  :: SA0
      CHARACTER(len=105)    :: FORMX
      CHARACTER(len=70)     :: FORMA
      CHARACTER(len=43)     :: FORMB
      CHARACTER(len=9)      :: CXMOL3
      END MODULE hbond
 
      SUBROUTINE PLA089
C * H-BOND ANALYSIS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE hbond
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: IHA
      INTEGER          :: IAT
      INTEGER          :: KAT
      INTEGER          :: IDA
      INTEGER          :: NCV
      INTEGER          :: MNM
      INTEGER          :: NAT
      INTEGER          :: IER
      INTEGER          :: IMET
      INTEGER          :: IDS1
      INTEGER          :: INRM
      INTEGER          :: NATM
      INTEGER          :: NCVH
      INTEGER          :: IDOA
      INTEGER          :: IDUM1 = 0
      INTEGER          :: IDUM2 = 0
      INTEGER          :: IPOPK
      INTEGER          :: IPOPI
      INTEGER          :: NSUMH
      INTEGER          :: NSUMT
      REAL             :: W
      REAL             :: XLNG
      REAL             :: YUNK
      CHARACTER(len=1) :: IYH
      CHARACTER(len=1) :: NYH
      CHARACTER(len=4) :: NORM
C * NOTE: SUBROUTINE SCRATCHES ARRAY'S XLS, IATP & IFNT
C * REAL-TIME (EDITABLE) FORMATS
      FORMX(1 :40)  = '(I2,A,I2,   A,''--'',A,''..'',A,''['',A   ,'']'''
      FORMX(41:56)  = ',F7.4,''('',I2,'')'''
      FORMX(57:105) = FORMX(41:56)//FORMX(41:56)//
     1                ',F7.1,''('',I2,'')'')'
      FORMB(1:36)  = '(8X,I2,A,''--'',A,''.. ?'',16X,F7.4,''('','
      FORMB(37:43) = 'I2,'')'')'
C * SET SUB-MENU
      IGBL(6) = 10
      WRITE (PRBUF, 99981, IOSTAT = IOST) (RGBL(I), I = 44, 46)
      IF (PRBUF(48:48) == CHAR(32)) PRBUF(48:48) = '+'
      WRITE (LU6, 99982)
      WRITE (LU6, 99987) PRBUF(1:80)
C * (0/1) X11 DISPLAY
      IF (IGBL(25) * IGBL(32) == 1 .AND. IPR(121) == 0 .AND.
     1    IPR(430) <= 0) THEN
        IWIN    = 1
C * NO SIDE OPTION MENU DISPLAY
        IGBL(6) = 0
        IF (IGBL(148) == 1) THEN
          NORM = 'NORM'
        ELSE
          NORM = '    '
        END IF
C * H-BOND TABLE HEADER LINE
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL PLA439 (0.0, PRBUF(1:80)//NORM, 84, 0.30, 1, 2, 0.1, 0.1)
        CALL PLA439 (0.0, JID, 9, 0.30, 5 + IGBL(68), 2, HORS - 3.0,
     1               0.1)
        IF (IGBL(60) > 0) THEN
          WRITE (PRBUF, 99991, IOSTAT = IOST)
          CALL PLA439 (0.0, PRBUF, 17, 0.3, 2, 1, 0.1, 0.1)
        END IF
        VRT = VERT - 0.6
        WRITE (PRBUF, 99992, IOSTAT = IOST)
        CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
        VRT      = VRT - 0.4
        IPR(733) = 1
      ELSE
        IWIN = 0
      END IF
      NHEAD = 0
      ITLC  = 0
      KOLD  = 0
      IOLD  = 0
      IDC   = 0
      NTEL  = 0
      A0    = 0.0
      SA0   = 0.0
C * (0/1) NORM-BOND
      IF (IGBL(148) /= 0) THEN
        WRITE (LU6, 99994, IOSTAT = IOST)
      ELSE
        WRITE (LU6, 99983, IOSTAT = IOST)
      END IF
C * GET MAXIMUM NUMBER OF PRIMARY ATOMS
      NAT     = IPR(37)
C * GET MAXIMUM NUMBER OF ATOMS
      NATM    = IPR(39)
C * SHORT INTER CONTACT COUNTER
      IPR(88) = 0
C * ZERO DONOR AND ACCEPTOR COUNTS
      CALL GEN097 (IATP, 1, NATM, 0)
      CALL GEN097 (IFNT, 1, NATM, 0)
      CALL GEN097 (JCA,  1, NATM, 0)
      CALL GEN097 (MP,   1, NP11, 0)
      CALL GEN097 (ISA,  1, 3, 0)
      CALL GEN097 (ISD,  1, 3, 0)
      CALL GEN097 (IDEC, 1, 8, 0)
C * LOOP OVER NON-C-H AND C-H ATOMS ALTERNATIVELY
      DO M = 1, 2 - IPR(645)
        LOOPT = M
        INRM  = 0
C * LOOP OVER ALL ATOMS TO FIND HYDROGEN BRIDGED H-ATOMS
        DO 20 IAT = 1, NAT
C * TEST FOR H-ATOM
          CALL GEN048 (-1, IFG(1, IAT), 7, IHA)
          CALL GEN048 (-1, IFG(2, IAT), 28, IDOA)
          IF (IHA /= 0 .AND. IDOA == 0) THEN
C * COPY COORDINATES TO INORM FOR NORMALIZATION
            INRM  = INRM + 1
            INORM = NATM + IPR(24) + INRM
            IF (LOOPT == 1) THEN
              DO J = 1, 6
                XXO(INORM, J) = XXO(IAT, J)
                XSD(INORM, J) = XSD(IAT, J)
              END DO
              LABA(INORM) = LABA(IAT)
C * COPY FLAGS
              DO J = 1, 3
                IFG(J, INORM)  = IFG(J, IAT)
              END DO
            END IF
C * GET DISORDER INFORMATION FOR ATOM IAT
            CALL PLA036 (IAT, 1, 2, IPOPI, IDUM1, IDUM2,
     1        IPR(71), IGBL(55))
C * SKIP MINOR DISORDER FORM
            IF (IPOPI >= 5000) THEN
              NC = - NINT(CON(IAT, 9))
              IF (NC < 0) NC = 9
              IF (NC /= 0) THEN
C * QUIT THIS LOOP WHEN FIRST ATOM NON-BONDING
                KAT = NINT(CON(IAT, 1))
                IF (KAT <= 0) THEN
                  WRITE (LU6, 99989, IOSTAT = IOST) IAT, KAT, NC
                  CALL PLA004 (0)
                ELSE IF (KAT < NP1) THEN
C * GET METAL-HYDRIDES
                  CALL GEN048 (-4, IFG(1, KAT), 19, IMET)
C * GET ATOM-TYPE NUMBER
                  CALL GEN048 (-4, IFG(1, KAT), 15, IVLC)
C * AVOID METAL HYDRIDES AND B-H
                  IF (IMET /= 1 .AND. IVLC /= 20) THEN
C * GET RESIDUE #
                    CALL GEN048 (-6, IFG(1, KAT), 9, IRES)
                    IVLC = IEN(IVLC + 1)
C * GET LABEL AND DISORDER INFORMATION FOR KAT
                    CALL PLA036 (KAT, 1, 1, IPOPK, IDUM1, IDUM2,
     1                         IPR(71), IGBL(55))
C * NON-C - H  / C - H TEST
                    IF (LOOPT == 1) THEN
C * NORMALIZE X-H BOND FOR C,N,O,B,SI
                      IF (IGBL(148) > 0) THEN
                        CALL GEN048 (1, IFG(2, INORM), 10, 0)
                        CALL PLA050 (KAT, INORM, 0, 0, V6(1))
C * CARBON
                        IF (IVLC == 2) THEN
                          V6(1) = PAR(296) / V6(1)
C * NITROGEN
                        ELSE IF (IVLC == 4) THEN
                          V6(1) = PAR(297) / V6(1)
C * OXYGEN
                        ELSE IF (IVLC == 3) THEN
                          V6(1) = PAR(298) / V6(1)
C * BORON
                        ELSE IF (IVLC == 20) THEN
                          V6(1) = PAR(294) / V6(1)
C * SILICON
                        ELSE IF (IVLC == 85) THEN
                          V6(1) = PAR(295) / V6(1)
                        END IF
                        DO L = 4, 6
                          YUNK = (XXO(INORM, L) - XXO(KAT, L)) * V6(1)
                          XXO(INORM, L) = XXO(KAT, L) + YUNK
                          XSD(INORM, L) = 0.0
                        END DO
                      END IF
C * TEST FOR C-H..X INCLUDE
                      IF (IVLC == 2 .AND. IPR(645) == 0) GO TO 20
                      IF (NC < 2) THEN
C * HEADER
                        IF (IGBL(63) > 2) THEN
                          IF (NHEAD /= 1) THEN
                            NHEAD = 1
C * NEWPAGE
                            CALL PLA262 (-7)
                            WRITE (LU7, 99997, IOSTAT = IOST)
     1                        (RGBL(L), L = 44, 46)
                            WRITE (LU7, 99996, IOSTAT = IOST)
                          END IF
                        END IF
                        CALL PLA053 (KAT, INORM, 0, 0, V6(1), V8(1),
     1                               ISD(1), IDEC(1), IER)
                        IF (IER == 0) THEN
                          IF (ISD(1) == 0) THEN
                            IDEC(1) = 2
                            V6(1) = NINT (V6(1) * 100.0) / 100.0
                          END IF
                        END IF
                        GO TO 10
                      END IF
C * CASE LOOPT = 2
                    ELSE IF (LOOPT == 2) THEN
C * THERE SHOULD BE AT LEAST TWO CONNECTIONS
                      IF (NC < 2) GO TO 20
C * TEST FOR CARBON
                      IF (IVLC /= 2 .AND. IPR(645) == 0)
     1                  GO TO 20
                    END IF
                    IF (IPOPK <  501) THEN
C * SKIP MINOR DISORDER FORM
                      IF (IPOPK < 5000) GO TO 20
                      IDISK = 10
                    ELSE
                      IDISK = 0
                    END IF
                    CALL PLA053 (KAT, INORM, 0, 0, V6(1), V8(1), ISD(1),
     1                           IDEC(1), IER)
                    IF (IER /= 0) GO TO 20
                    CALL PLA090 (IAT, KAT)
                    IF (IPR(2) /= 0) RETURN
                    IF (NFOUND == 0) GO TO 10
                  END IF
                END IF
              END IF
            END IF
          END IF
          GO TO 20
C * LIST NON-HBONDING D-H ATOMS (EXCLUDE CARBON)
   10     IF (LOOPT == 1 .AND. IVLC /= 2) THEN
            IF (IGBL(63) > 2) THEN
C * HEADER
              IF (NHEAD /= 1) THEN
                NHEAD = 1
C * NEWPAGE
                CALL PLA262 (-5)
                WRITE (LU7, 99997, IOSTAT = IOST) (RGBL(I), I = 44, 46)
                IF (IGBL(148) > 0) THEN
                  CALL PLA262 (3)
                  WRITE (LU7, 99988, IOSTAT = IOST)
                END IF
                CALL PLA262 (2)
                WRITE (LU7, 99996, IOSTAT = IOST)
                IF (IGBL(60) > 0) WRITE (LU6, 99991, IOSTAT = IOST)
                WRITE (LU6, 99992, IOSTAT = IOST)
              END IF
              ISD(1) = MIN (99, ISD(1))
              FORMB(31:31) = CHAR (ICHAR ('0') + IDEC(1))
              WRITE (PRBUF, FORMB, IOSTAT = IOST) IRES, NAMS(1, 1)(1:7),
     1               NAMS(1, 2)(2:8), V6(1), ISD(1)
              CALL PLA263 (LU7, PRBUF, 132, 1, 3)
              WRITE (LU6, 99987, IOSTAT = IOST) PRBUF(12:79)
              IF (IWIN == 1) THEN
                VRT = VRT - 0.5
                CALL PLA439 (0.0, PRBUF(12:90), 79, 0.35, 2, 2, 1.0,
     1                       VRT)
              END IF
              CALL PLA262 (1)
            END IF
C * NO ALERT FOR B-H & P-H
            IF (NAMS(1, 1)(2:2) /= 'B' .AND.
     1          NAMS(1, 1)(2:2) /= 'P' .AND.
     2          NAMS(1, 1)(2:3) /= 'Cu') THEN
              IF (NAMS(1, 1)(2:2) == 'O') THEN
                W = 2.0
              ELSE
                W = 1.0
              END IF
C * ALERT _420
              CALL PLA236 (420, 0, W, W, NAMS(1, 1)(2:10),
     1          NAMS(1, 2)(2:10))
            END IF
            IPR(405) = IPR(405) + 1
          END IF
   20   CONTINUE
      END DO
C * NO-HBONDS FOUND MESSAGE
      IF (IPR(88) == 0) THEN
        LINE = ':: No Classic Hydrogen Bonds Found'
        IF (LU6 == 6) WRITE (LU6, 99986, IOSTAT = IOST) LINE
        CALL PLA015 (0, 1)
        IF (IWIN == 1) THEN
          VRT = VRT - 2.5
          CALL PLA439 (0.0, LINE, 50, 0.70, 2, 2, 2.5, VRT)
          VRT = VRT - 1.5
        END IF
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99986, IOSTAT = IOST) LINE
        END IF
      ELSE
        CALL PLA015 (0, 2)
      END IF
C * LIST NORMALIZED COORDINATES
      IF (IGBL(148) /= 0 .AND. INRM /= 0) THEN
        CALL PLA262 (5)
        WRITE (LU7, 99985, IOSTAT = IOST)
        DO I = 1, INRM
          J = NATM + IPR(24) + I
          CALL PLA047 (LABA(J), NQ1, MNM, IDUM1, IPR(71), IGBL(55),
     1      0, 0)
          DO K = 1, 3
            V5(K) = XXO(J, K + 3)
          END DO
          CALL GEN002 (1, ROR, V5, V4, XLNG)
          CALL PLA262 (1)
          WRITE (LU7, 99984, IOSTAT = IOST) NQ1, (V4(K), K = 1, 3),
     1                            (V5(K), K = 1, 3)
        END DO
      END IF
C * MORE DETAILS AND NETWORK ANALYSIS
      IF (IPR(300) > 0 .AND. NHEAD /= 0) THEN
        IF (NTEL > 0) THEN
          VRT = VRT - 0.4
          CALL PLA043 (0, 0, 0, 0)
          CALL PLA043 (0, 0, LU6, 0)
        END IF
        CALL PLA043 (0, 0, LU7, 0)
C * C-H .. A REFERENCE
        IF (IDC > 0 .AND. IGBL(63) > 2) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99995, IOSTAT = IOST)
        END IF
C * H-BOND TYPE CLASSIFICATION REFERENCE
        IF (ITLC > 0 .AND. IGBL(63) > 2) THEN
          CALL PLA262 (6)
          WRITE (LU7, 99993, IOSTAT = IOST)
        END IF
        IF (IPR(88) > 0) THEN
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (6)
            WRITE (LU7, 99999, IOSTAT = IOST)
          END IF
          DO I = 1, NAT
            CALL GEN048 (-1, IFG(1, I), 23, IDA)
            IF (IDA == 1) THEN
              CALL PLA036 (I, 1, 1, IDS1, IDUM1, IDUM2, IPR(71),
     1                     IGBL(55))
C * SKIP MINOR DISORDER FORM
              IF (IDS1 >= 5000) THEN
                CALL GEN048 (-1, IFG(1, I), 21, IDUM1)
                IF (IDUM1 == 1) THEN
                  IYH = 'H'
                ELSE
                  IYH = '-'
                END IF
C * COUNT # COVALENTLY BONDED ATOMS
                NC   = - NINT (CON(I, 9))
                NCV  = 0
                NCVH = 0
                DO J = 1, NC
                  K = NINT (CON(I, J))
                  IF (K <= NP1) THEN
                    NCV = NCV + 1
C * TEST FOR H-ATOM
                    CALL GEN048 (-1, IFG(1, K), 7, IHA)
                    NCVH = NCVH + IHA
                  END IF
                END DO
                IF (NCVH == 0) THEN
                  NYH = ' '
                ELSE
                  WRITE (NYH, 99990, IOSTAT = IOST) NCVH
                END IF
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (1)
                  NSUMH = IATP(I) + IFNT(I) + JCA(I)
                  NSUMT = NSUMH   + NCV - NCVH
                  WRITE (LU7, 99998, IOSTAT = IOST)
     1              I, NAMS(1, 1)(1:8), NCV, NYH, IYH,
     2              IATP(I), IFNT(I), JCA(I), NSUMH, NSUMT
                END IF
              END IF
            END IF
          END DO
        END IF
      END IF
      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)+', F4.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 /= 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 (/, ':: X-H Distances have been NORMALIZED')
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, 'D - H', 6X,
     1  'H...A', 6X, 'D...A', 2X, 'D - H...A')
99991 FORMAT ('Input Atoms Moved')
99990 FORMAT (I1)
99989 FORMAT (/, 'Problem in PLA089', 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);',
     3 ' F.H.Allen & I.J. Bruno, Acta Cryst. (2010). B66,380-386',/)
99987 FORMAT (A)
99986 FORMAT (/, A, /)
99985 FORMAT (/, 'Normalized X-H Atom Positions', /, 132('='), /,
     1 'Atom', 15X,  'x', 9X, 'y', 9X, 'z', 9X, 'XO', 8X, 'YO',
     2 8X, 'ZO', /, 132('-'))
99984 FORMAT (A, 6F10.4)
99983 FORMAT (1x)
99982 FORMAT (/, ':: Analysis of Potential Hydrogen Bonds with ')
99981 FORMAT ('d(D...A) < R(D)+R(A)+', F4.2, ', d(H...A) < R(H)+R(A)',
     1 F5.2, ' Ang., D-H...A >', F6.1, ' Deg')
      END SUBROUTINE PLA089
 
      SUBROUTINE PLA090 (IAT, KAT)
C * H-BOND ANALYSIS (SUBR)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE hbond
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: IAT
      INTEGER          :: KAT
      INTEGER          :: MNM
      INTEGER          :: IER
      INTEGER          :: IHB
      INTEGER          :: LBB
      INTEGER          :: LBC
      INTEGER          :: LBD
      INTEGER          :: IENM
      INTEGER          :: ISUM
      INTEGER          :: IVWM
      INTEGER          :: IVAL
      INTEGER          :: NIEN
      INTEGER          :: ILMP
      INTEGER          :: IVWI
      INTEGER          :: IVWK
      INTEGER          :: JDUM
      INTEGER          :: MPRM
      INTEGER          :: MDPRM
      INTEGER          :: IVAL1
      INTEGER          :: IPOPM
      INTEGER          :: ILABM
      INTEGER          :: MPRIM
      INTEGER          :: ISUM4
      INTEGER          :: IRESI
      INTEGER          :: IRESM
      INTEGER          :: IDUM1
      INTEGER          :: IDUM2
      INTEGER          :: JNQNR
      INTEGER          :: IDSORD
      REAL             :: SUMX
      REAL             :: SUM4
      REAL             :: SSUM
      REAL             :: SSUM4
      REAL             :: XMOL2
      REAL             :: XMOL3
      CHARACTER(len=6) :: INTRA
C * TEST FOR POTENTIAL D-H ATOM
      CALL GEN048 (-1, IFG(1, IAT), 20, IHB)
C * GET RESIDUE NUMBER
      CALL GEN048 (-6, IFG(1, IAT), 9, IRESI)
C * TEST FOR CARBON & CARBON INCLUDE
      IF (IVLC == 2 .AND. IPR(645) == 1) IHB = 1
      NFOUND = 0
C * LOOP OVER ALL ACCEPTOR ATOMS
      DO L = 2, NC
        M = NINT (CON(IAT, L))
        M = MOD (M, NP1)
C * TEST WHETHER THIS IS A POSSIBLE DONOR/ACCEPTOR ATOM
        CALL GEN048 (-1, IFG(1, M), 23, IVAL)
C * TEST FOR B-H
        CALL GEN048 (-1, IFG(2, M), 28, IVAL1)
        IF (IVAL /= 0 .OR. IVAL1 /= 0) THEN
C * GET LABEL AND DISORDER INFORMATION FOR M
          CALL PLA036 ( M, 1, 4, IPOPM, IDUM1, IDUM2, IPR(71), IGBL(55))
          CALL PLA036 (-M, 1, 3, IPOPM, IDUM1, IDUM2, IPR(71), IGBL(55))
          IF (IPOPM < 501) THEN
C * SKIP MINOR DISORDER FORM
            IF (IPOPM < 5000 .AND. IPR(303) == 0) CYCLE
            IDSORD = IDISK + 1
          ELSE
            IDSORD = IDISK
          END IF
          ILABM = - LABA(M)
          CALL PLA047 (ILABM, NQ3, MNM, JDUM, IPR(71), IGBL(55),
     1      0, 0)
          CALL PLA046 (-2, NQ3, IENM, LBB, LBC, LBD,
     1                 ILMP, JNQNR, NIEN)
          IF (NIEN < 0) THEN
            NQ0    = NQ3
C * UNSUITABLE ATOM LABEL
            IPR(2) = 3
            RETURN
          END IF
C * AVOID CU
          IF (IEL(IEN(IENM)) /= 321) THEN
            MPRIM = NIEN
            CALL GEN048 (-6, IFG(1, M), 9, IRESM)
            XMOL3 = MOL(MNM) / PAR(42)
            IF (NINT (XMOL3) == 1555)
     1        XMOL3 = XMOL3 + IRESM / PAR(42)
            CALL GEN048 (-4, IFG(1, KAT), 15, IVWK)
            CALL GEN048 (-4, IFG(1, IAT), 15, IVWI)
            CALL GEN048 (-4, IFG(1, M), 15, IVWM)
            CALL PLA053 (M, INORM, 0, 0, V6(2), V8(2), ISD(2),
     1                   IDEC(2), IER)
            IF (IER == 0 .AND. V6(2) <= (RADR(IVWI + 1, 2) +
     1        RADR(IVWM + 1, 2) + RGBL(45))) THEN
              CALL PLA053 (KAT, INORM, M, 0, V2(1), V3(1),
     1                     ISA(1), IDEC(4), IER)
              IF (IER == 0 .AND. V2(1) >= RGBL(46)) THEN
                CALL PLA053 (KAT, M, 0, 0, V6(3), V8(3), ISD(3),
     1                       IDEC(3), IER)
                IF (IER == 0 .AND. V6(3) <= (RADR(IVWK + 1, 2) +
     1            RADR(IVWM + 1, 2) + RGBL(44))) THEN
                  ISD(1) = MIN (99, ISD(1))
                  FORMX(45:45) = CHAR (ICHAR ('0') + IDEC(1))
                  ISD(2) = MIN (99, ISD(2))
                  FORMX(61:61) = CHAR (ICHAR ('0') + IDEC(2))
                  ISD(3) = MIN (99, ISD(3))
                  FORMX(77:77) = CHAR (ICHAR ('0') + IDEC(3))
                  ISA(1) = MIN (99, ISA(1))
                  FORMX(93:93) = CHAR (ICHAR ('0') + IDEC(4))
C * HEADER
                  IF (NHEAD /= 1) THEN
                    NHEAD = 1
                    IF (IGBL(63) > 2) THEN
C * NEWPAGE
                      PAGET = 'H-BONDS'
                      CALL PLA262 (-7)
                      WRITE (LU7, 99999, IOSTAT = IOST)
     1                  (RGBL(I), I = 44, 46)
                      WRITE (LU7, 99998, IOSTAT = IOST)
                      WRITE (LU6, 99994, IOSTAT = IOST)
                      IF (IGBL(60) > 0)
     1                  WRITE (LU6, 99995, IOSTAT = IOST)
                      WRITE (LU6, 99996, IOSTAT = IOST)
                    END IF
                  END IF
C * THERE SHOULD BE AT LEAST TWO CONNECTIONS
                  XMOL2 = (1555 * PAR(42) + IRES) / PAR(42)
                  IF (IHB /= 0) THEN
                    IPR(88) = IPR(88) + 1
                    IF (IPR(88) <= NP2) THEN
                      XLS(1,  IPR(88)) = KAT
                      XLS(2,  IPR(88)) = XMOL2
                      XLS(3,  IPR(88)) = MPRIM
                      XLS(4,  IPR(88)) = XMOL3
                      XLS(8,  IPR(88)) = IDSORD
                      XLS(9,  IPR(88)) = V2(1)
                      XLS(10, IPR(88)) = IAT
                      IATP(KAT)        = IATP(KAT)   + 1
                      IFNT(MPRIM)      = IFNT(MPRIM) + 1
                      CALL GEN048 (1, IFG(1, MPRIM), 22, 1)
                    ELSE
                      IPR(149) = IPR(149) + 10000
                    END IF
                  ELSE
                    JCA(MPRIM) = JCA(MPRIM) + 1
                  END IF
C * TEST FOR INTRA/INTER BRIDGE
                  IF (IRESM == IRES .AND. MNM <= IPR(51)) THEN
                    INTRA = ' Intra'
                  ELSE
                    INTRA = '      '
                  END IF
                  IF (LOOPT == 2) THEN
                    IF (IDC == 0 .AND. IGBL(63) > 2) THEN
                      CALL PLA262 (1)
                      VRT = VRT - 0.3
                      WRITE (LU6, 99994, IOSTAT = IOST)
                      WRITE (LU7, 99994, IOSTAT = IOST)
                    END IF
                    IDC = IDC + 1
                  END IF
                  ITLC    = ITLC + 1
                  MP(MNM) = 1
                  IF (INT (XMOL3) == 1555 .AND. IRESI == IRESM) THEN
                    CXMOL3 = '         '
                  ELSE
                    WRITE (CXMOL3, 99997, IOSTAT = IOST) XMOL3
                  END IF
                  WRITE (PRBUF, FORMX, IOSTAT = IOST) ITLC, INTRA, IRES,
     1              NAMS(1, 1)(1:7), (NAMS(1, I)(2:8), I = 2, 3),
     2              CXMOL3, V6(1), ISD(1), V6(2), ISD(2), V6(3), ISD(3),
     3              V2(1), ISA(1)
                  IF (KAT /= KOLD .OR. IAT /= IOLD) THEN
                    KOLD  = KAT
                    IOLD  = IAT
                    MPRM  = M
                    MDPRM = 0
                    A0    = V2(1)
                    SA0   = V3(1)
                    GO TO 10
                  END IF
                  CALL PLA053 (MPRM, INORM, M, 0, V2(2),
     1                         V3(2), ISA(2), IDEC(5), IER)
                  IF (IER == 0) THEN
                    FORMA(1:21)  = '(A,F6.1,''('',I2,'')'',A,'
                    ISA(2) = MIN (99, ISA(2))
                    FORMA(7:7) = CHAR (ICHAR ('0') + IDEC(5))
                    IF (V2(2) > 0.1) THEN
                      SUMX = A0 + V2(1) + V2(2)
                      SSUM = SQRT (SA0**2 + V3(1)**2 + V3(2)**2)
                      CALL GEN041 (SUMX, SSUM, ISUM, 2, IDEC(7),
     1                             IPR(68))
                      ISUM = MIN (99, ISUM)
                      IF (ISUM == 0) IDEC(7) = 0
                      IF (MDPRM == 0) THEN
                        FORMA(22:41) = '10X,F6.1,''('',I2,'')'')'
                        FORMA(29:29) =  CHAR (ICHAR ('0') + IDEC(7))
                        WRITE (PRBUF(91:132), FORMA(1:41),IOSTAT = IOST)
     1                   CHAR (39), V2(2), ISA(2), CHAR (39), SUMX, ISUM
                        MDPRM = M
                        SUM4  = V2(1)
                        SSUM4 = V3(1)**2
                        GO TO 10
                      END IF
                      FORMA(22:37) = 'F6.1,''('',I2,'')'','
                      FORMA(38:70) = FORMA(22:37)//FORMA(22:37)//')'
                      CALL   PLA053 (MDPRM, INORM, M, 0,
     1                  V2(3), V3(3), ISA(3), IDEC(6), IER)
                      IF (IER /= 0) CYCLE
                      ISA(3) = MIN (99, ISA(3))
                      IF (ISA(3) == 0) IDEC(6) = 0
                      FORMA(25:25) = CHAR (ICHAR ('0') + IDEC(6))
                      FORMA(41:41) = CHAR (ICHAR ('0') + IDEC(7))
                      IF (V2(3) > 0.1) THEN
                        SUM4  = SUM4 + V2(1) + V2(3)
                        SSUM4 = SQRT (SSUM4 + V3(1)**2 + V3(3)**2)
                        CALL GEN041 (SUM4, SSUM4, ISUM4,
     1                    2, IDEC(8), IPR(68))
                        ISUM4 = MIN (99, ISUM4)
                        IF (ISUM4 == 0) IDEC(8) = 0
                        FORMA(57:57) = CHAR (ICHAR ('0') + IDEC(8))
                        WRITE (PRBUF(91:132), FORMA, IOSTAT = IOST)
     1                    CHAR (34), V2(2), ISA(2), CHAR (34), V2(3),
     2                    ISA(3), SUMX, ISUM, SUM4, ISUM4
                        GO TO 10
                      END IF
                    END IF
                    ITLC = ITLC - 1
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
        CYCLE
   10   IF (IGBL(63) > 2) THEN
          CALL PLA263 (LU7, PRBUF, 132, 1, 3)
          IF (IWIN == 1) THEN
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF(12:90), 79, 0.35, 1, 2, 1.0, VRT)
            NTEL = NTEL + 1
          END IF
          WRITE (LU6, 99993, IOSTAT = IOST) PRBUF(12:90)
        END IF
C * TEST FOR OMEGA FILE STATUS
        IF (IPR(438) == 1) THEN
          IPR(452) = IPR(452) + 1
          WRITE (LU2, 99992, IOSTAT = IOST) (NAMS(1, I)(2:8), I = 1, 2),
     1      NAMS(1, 4)(2:8), V6(1), V8(1), V6(2), V8(2), V6(3), V8(3),
     2      V2(1), V3(1), MNM
        END IF
        NFOUND = NFOUND + 1
      END DO
      RETURN
99999 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 /= 1.555)', /, 132('='), /)
99998 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('-'))
99997 FORMAT (F9.2)
99996 FORMAT ('Donor --- H....Acceptor [    ARU  ]', 6X,
     1 'D - H', 6X, 'H...A', 6X, 'D...A', 2X, 'D - H...A')
99995 FORMAT ('Input Atoms Moved')
99994 FORMAT (1X)
99993 FORMAT (A)
99992 FORMAT ('HBON ', 3(A, ' '), 4F8.4, ' = ', /,
     1        5X, 2F10.4, 2F10.2, I12)
      END SUBROUTINE PLA090
 
      SUBROUTINE PLA091 (MODE)
C * (HYDROGEN BOND) CLUSTER/AGGREGATE ANALYSIS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: N
      INTEGER                :: N0
      INTEGER                :: N1
      INTEGER                :: N2
      INTEGER                :: N3
      INTEGER                :: K0
      INTEGER                :: K2
      INTEGER                :: L2
      INTEGER                :: M1
      INTEGER                :: LL
      INTEGER                :: MC
      INTEGER                :: ML
      INTEGER                :: NR
      INTEGER                :: NS2
      INTEGER                :: NRT
      INTEGER                :: NR2
      INTEGER                :: NAD
      INTEGER                :: MLX
      INTEGER                :: LMB
      INTEGER                :: LMX
      INTEGER                :: LMZ
      INTEGER                :: NR1
      INTEGER                :: NS1
      INTEGER                :: ITL
      INTEGER                :: MD1
      INTEGER                :: MD2
      INTEGER                :: MD3
      INTEGER                :: MR0
      INTEGER                :: MR1
      INTEGER                :: MR2
      INTEGER                :: MR3
      INTEGER                :: MS0
      INTEGER                :: MS1
      INTEGER                :: MS2
      INTEGER                :: MS3
      INTEGER                :: MT0
      INTEGER                :: MT1
      INTEGER                :: MT2
      INTEGER                :: MT3
      INTEGER                :: MTD
      INTEGER                :: ND1
      INTEGER                :: ND2
      INTEGER                :: ND3
      INTEGER                :: NTP
      INTEGER                :: KK0
      INTEGER                :: NT21
      INTEGER                :: NT22
      INTEGER                :: NT23
      INTEGER                :: NMOL
      INTEGER                :: NADD
      INTEGER                :: NARU
      INTEGER                :: NCHN
      INTEGER                :: NCIR
      INTEGER                :: NCRA
      INTEGER                :: MTX1
      INTEGER                :: MTX2
      INTEGER                :: MTX3
      INTEGER                :: MTD1
      INTEGER                :: MTD2
      INTEGER                :: MTD3
      INTEGER                :: MT11
      INTEGER                :: MT12
      INTEGER                :: MT13
      INTEGER                :: MT21
      INTEGER                :: MT22
      INTEGER                :: MT23
      INTEGER                :: MT31
      INTEGER                :: MT32
      INTEGER                :: MT33
      INTEGER                :: MSX1
      INTEGER                :: MRX0
      INTEGER                :: MOL1
      INTEGER                :: MOL2
      INTEGER                :: MOLY
      INTEGER                :: MCHN
      INTEGER                :: MCIR
      INTEGER                :: ITL2
      INTEGER                :: NT11
      INTEGER                :: NT12
      INTEGER                :: NT13
      INTEGER                :: IAGG
      INTEGER                :: MODE
      INTEGER                :: NRES
      INTEGER                :: NSYM
      INTEGER                :: NTOP
      INTEGER                :: IARU
      INTEGER                :: IDUM
      INTEGER                :: JDUM
      INTEGER                :: IFIXX
      INTEGER                :: LABN3
      INTEGER                :: NMOL2
      INTEGER                :: ND123
      INTEGER                :: LABN1
      INTEGER                :: IYUNK
      INTEGER                :: IDISO
      INTEGER                :: KDATC
      INTEGER                :: KKMAX
      INTEGER                :: KCYCLE
      INTEGER                :: IDSORD
      INTEGER                :: NINTRES
      INTEGER                :: MDATCNRT
      INTEGER, DIMENSION(64) :: NRESCNT
      REAL                   :: DMOL
      REAL                   :: XMOL
      REAL                   :: XMOL1
      REAL                   :: XMOL2
      REAL                   :: DMOLL
      CHARACTER(len=1)       :: IDS1
      CHARACTER(len=1)       :: IDS2
      CHARACTER(len=58)      :: FORMI
      CHARACTER(len=31)      :: FORMJ
      CHARACTER(len=16)      :: FORMK
      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))'
C * MODE = -2 - SHORT INTER CONTACT CLUSTER ANALYSIS
C * MODE = -3 - HYDROGEN BONDED AGGREGATE ANALYSIS
C * HYDROGEN BONDS/CONTACTS ARE STORED IN SCRATCH ARRAY XLS
C * XLS(1,  I) = NR DONOR ATOM
C * XLS(2,  I) = ARU DONOR
C * XLS(3,  I) = NR ACCEPTOR ATOM
C * XLS(4,  I) = ARU ACCEPTOR
C * XLS(5,  I) = RESIDUE NUMBER OF BASE
C * XLS(6,  I) =
C * XLS(7,  I) =
C * XLS(8,  I) = DISORDER
C * XLS(9,  I) = D-H..A ANGLE
C * XLS(10, I) = IAT
C * GET NUMBER OF CONTACTS/BRIDGES
      ITL = IPR(88)
C * SKIP/RETURN WHEN NO CONTACTS/BRIDGES
      IF (ITL > 0) THEN
        NR1   = 0
        NS1   = 0
        NT11  = 0
        NT12  = 0
        NT13  = 0
C * GET NUMBER OF RESIDUES
        NRES  = IPR(75)
C * GET NR OF INTRA RESIDUES
        NINTRES = IPR(51)
C * GET NUMBER OF SYMMETRY OPERATIONS
        NSYM  = IPR(48)
C * TOP BONDS IN SCRATCH ARRAY VOID - ZERO WORKAREA
        NTOP  = IPR(299)
        CALL GEN074 (VOID, NTOP + 1, 100000, 0.0)
        CALL GEN074 (DATC, 1, NP1, 0.0)
        CALL GEN097 (JR  , 1, NP1, 0)
C * (MAX) RESIDUE NUMBER SCALE IN ARU (=> 1 OR 2 DECIMALS)
        IARU  = NINT(PAR(42))
        IF (IARU < 100) THEN
          FORMI(18:18) = '1'
          FORMI(39:39) = '1'
          FORMJ(11:11) = '1'
          FORMJ(27:27) = '1'
          FORMK(12:12) = '1'
        END IF
C * GENERATE COMPLETE LIST OF ASYMMETRIC RESIDUE UNITS IN THE UNIT CELL
        NARU = 0
        DO J = 1, NRES
          DO I = 1, NSYM
            IF (NARU < NP1) THEN
              NARU       = NARU + 1
              IATP(NARU) = (I * 1000 + 555) * IARU + J
            ELSE
              IF (LU6 /= 0) WRITE (LU6, 99985, IOSTAT = IOST)
              RETURN
            END IF
          END DO
        END DO
C * SHORT INTER CONTACT MODE CASE (MODE = -2)
        IF (MODE == -2) THEN
          ITL2 = ITL
          IF (IGBL(63) > 2) CALL PLA262 (0)
          IF (IGBL(63) > 3) THEN
            CALL PLA262 (5)
            WRITE (LU7, 99992, IOSTAT = IOST)
          END IF
          DO I = 1, ITL
            IDSORD = NINT (XLS(8, I))
            IF (IDSORD / 10 == 1) THEN
              IDS1 = '*'
            ELSE
              IDS1 = ' '
            END IF
            IF (MOD (IDSORD, 10) == 1) THEN
              IDS2 = '*'
            ELSE
              IDS2 = ' '
            END IF
            LABN1 =  LABA(NINT (XLS(1, I)))
            LABN3 = -LABA(NINT (XLS(3, I)))
            CALL PLA047 (LABN1, NQ1, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
            CALL PLA047 (LABN3, NQ2, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (1)
              WRITE (LU7, FORMI, IOSTAT = IOST)
     1          I, IDS1, NQ1(1:6), XLS(2, I), IDS2,
     2          NQ2(1:6), XLS(4, I), XLS(6, I), XLS(7, I)
            END IF
          END DO
C * TEST FOR H-BOND CASE (MODE = -3)
        ELSE IF (MODE == -3) THEN
C * DOUBLE THE NUMBER OF INTERACTIONS (FORWARDS + BACKWARDS)
          ITL2 = ITL * 2
          IF (ITL2 <= NP2) THEN
C * OUTPUT H-BOND NETWORK HEADER
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (0)
              IF (IGBL(63) > 3) THEN
                CALL PLA262 (10)
                WRITE (LU7, 99999, IOSTAT = IOST)
                WRITE (LU7, 99990, IOSTAT = IOST)
              END IF
            END IF
C * COMPLETE LIST OF DIRECTED INTERACTIONS WITH THOSE IN OPPOSITE DIRECTION
            DO I = 1, ITL
              IATC(I)         = 1
C * GET RESIDUE NUMBER OF BASE
              XLS(5, I)       = MOD(NINT(XLS(2, I) * IARU), IARU)
C * GET RESIDUE NUMBER OF TARGET
              MR1             = MOD(NINT(XLS(4, I) * IARU), IARU)
C * STORE RESIDUE NUMBER FOR BASE OF REVERSED BOND
              XLS(5, ITL + I) = MR1
C * COPY DONOR-H..ACCEPTOR ANGLE
              XLS(9, ITL + I) = XLS(9, I)
C * GET INVERSE TARGET
              CALL PLA270 (XLS(4, I), 0.0, XLS(2, ITL + I))
C * NO ERROR ?
              IF (IPR(2) == 0) THEN
C * APPLY INVERSE TO BASE
                CALL PLA270 (XLS(2, ITL + I), XLS(2, I),
     1                       XLS(4, ITL + I))
C * NO ERROR ?
                IF (IPR(2) == 0) THEN
                  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
C * HANDLE DISORDER
                  IDSORD = NINT(XLS(8, I))
                  IF (IDSORD == 10) THEN
                    IDISO = 1
                  ELSE IF (IDSORD == 1) THEN
                    IDISO = 10
                  ELSE
                    IDISO = IDSORD
                  END IF
                  XLS(8, ITL + I) = IDISO
C * LIST DONOR-ACCEPTOR INTERACTION
                  CALL PLA093 (I, J, K, 1)
C * LIST DONOR-ACCEPTOR INTERACTION (REVERSE)
                  CALL PLA093 (ITL + I, K, J, -1)
                ELSE
C * ERROR RETURN
                  IF (LU6 /= 0) WRITE (LU6, 99985, IOSTAT = IOST)
                  RETURN
                ENDIF
              ELSE
C * ERROR RETURN
                IF (LU6 /= 0) WRITE (LU6, 99985, IOSTAT = IOST)
                RETURN
              END IF
            END DO
          ELSE
C * mERROR RETURN
            IF (LU6 /= 0) WRITE (LU6, 99989, IOSTAT = IOST)
            RETURN
          END IF
        END IF
C * FIND CONTACT CLUSTERS/H-BOND AGGREGATES
        IAGG  = 0
        IFIXX = 0
        NADD  = 25
C * LOOP OVER ALL ARU'S IN THE UNITCELL
        DO I = 1, NARU
          IF (IFIXX < I) THEN
            IF (IAGG > 0) CALL PLA094 (0, 0, 0, 0, 0, IAGG)
C * INITIALISE TYPE 2 NETWORK (INTERMOLECULAR)
            CALL PLA094 (MODE, 0, 0, 0, 0, 0)
            IAGG  = IAGG + 1
            IFIXX = IFIXX + 1
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (7)
              IF (MODE == -3) THEN
                WRITE (LU7, 99998, IOSTAT = IOST)
     1          ' Aggregate =', IAGG
                WRITE (LU7, 99997, IOSTAT = IOST)
              ELSE IF (MODE == -2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST)
     1            '  Cluster  =', IAGG
                WRITE (LU7, 99995, IOSTAT = IOST)
              END IF
            END IF
          END IF
          LMX  = 1
C * FIND CONNECTIONS INVOLVING  RESIDUE #I (OUT OF TOTAL NARU)
          DMOL = IATP(I) / PAR(42)
C * STORE THIS ARU
          VOID(NTOP + (I - 1) * NADD + 1) = DMOL
          VOID(NTOP + I * NADD)           = 0.0
C * UNPACK THIS ARU CODE
          CALL GEN098 (IATP(I), PAR(42), MS0, MT0, MT0, MT0,
     1      MR0)
C * HANDLE THE CASE OF ONE OR MORE CONNECTED 'INTRA' RESIDUES
C *  (N-MERS,POLYMERS)
          IF (NINTRES > 1) THEN
            DO 10 K = 2, NINTRES
              ML = MOL(K)
C * CHECK FOR SAME RESIDUE NUMBER
              IF (MOD(ML, IARU) == MR0) THEN
                XMOL1 = ML / PAR(42)
C * MULTIPLY SYMMETRY OPERATIONS
                CALL PLA270 (DMOL, XMOL1, XMOL2)
                IF (IPR(2) == 0) THEN
C * STORE THIS CONNECTION
                  LMX       = LMX + 1
                  IFNT(LMX) = ICHAR ('*')
                  VOID(NTOP + (I - 1) * NADD + LMX) = XMOL2
C * UNPACK THIS CONNECTED ARU
                  MLX = NINT (XMOL2 * PAR(42))
                  CALL GEN098 (MLX, PAR(42), MSX1, MTX1, MTX2, MTX3,
     1              MRX0)
C * CONSTRUCT s555r EQUIVALENT
                  NMOL = (MSX1 * 1000 + 555) * IARU + MRX0
                  DO L = 1, IFIXX
C * UNPACK THIS ARU CODE
                    CALL GEN098 (IATP(L), PAR(42), MS1, MT1, MT2, MT3,
     1                MR0)
C * IDENTICAL SYMMETRY OPERATORS -> TRANSLATION
                    IF (MSX1 == MS1 .AND. MRX0 == MR0) THEN
                      MTD1 = MTX1 - MT1
                      MTD2 = MTX2 - MT2
                      MTD3 = MTX3 - MT3
                      MTD = IABS (MTD1) + IABS (MTD2) + IABS (MTD3)
                      IF (MTD == 0) THEN
                        GO TO 10
                      ELSE
C * ADD (NEW) TRANSLATION TO NETWORK
                        CALL PLA094 (1, MTD1, MTD2, MTD3, 0, 0)
                        IFNT(LMX) = ICHAR ('#')
                        GO TO 10
                      END IF
                    END IF
                  END DO
C * SEARCH FOR BASIC ARU AND REPLACE
                  DO LL = IFIXX + 1, NARU
                    IF (IATP(LL) == NMOL) THEN
                      IFIXX       = IFIXX + 1
                      IATP(LL)    = IATP(IFIXX)
                      IATP(IFIXX) = MLX
                      EXIT
                    END IF
                  END DO
                ELSE
C * ERROR RETURN
                  IF (LU6 /= 0) WRITE (LU6, 99985, IOSTAT = IOST)
                  RETURN
                END IF
              END IF
   10       CONTINUE
          END IF
C * ANALYSE FOR CLUSTERS (MODE=-2) OR AGGREGATES (MODE=-3)
C * FIND ALL INTERACTIONS FOR MOL DMOL (WITH RESIDUE NUMBER MR0)
          N1 = 0
          DO K = 1, ITL2
C * GET RESIDUE NUMBER O BASE
            N = NINT (XLS(5, K))
            IF (MR0 == N) THEN
              CALL PLA270 (DMOL, XLS(4, K), XMOL)
              IF (IPR(2) == 0) THEN
                N1 = N1 + 1
C * AVOID REGISTERING THE SAME ARU MORE THAN ONCE
                KCYCLE = 0
                DO L = 1, LMX
                  DMOLL = VOID(NTOP + (I - 1) * NADD + L)
                  IF (NINT ((DMOLL - XMOL) * PAR(42)) == 0) THEN
                    IF (L == 1) N1 = N1 - 1
                    KCYCLE = 1
                    EXIT
                  END IF
                END DO
                IF (KCYCLE == 0) THEN
C * ADD THIS MOL TO THE INTERACTION LIST
                  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,
     1              MR2)
                  DO L = 1, NARU
                    CALL GEN098 (IATP(L), PAR(42), MS1, MT11, MT12,
     1                 MT13, MR1)
                    IF (MS2 == MS1 .AND. MR2 == MR1) THEN
                      IF (L <= IFIXX) THEN
                        MD1 = MT21 - MT11
                        MD2 = MT22 - MT12
                        MD3 = MT23 - MT13
                        IF (IABS (MD1) + IABS (MD2) + IABS (MD3) > 0)
     1                    THEN
C * ADD (NEW) NETWORK TRANSLATION ENTRY
                          CALL PLA094 (1, MD1, MD2, MD3, 0, 0)
                          IFNT(LMX) = ICHAR ('T')
                        END IF
                      ELSE
                        IFIXX       = IFIXX + 1
                        IATP(L)     = IATP(IFIXX)
                        IATP(IFIXX) = NMOL
C * TRANSFORM AND FIX MOLECULES BONDED TO THIS RESIDUE (NR = MR2)
                        IF (NINTRES > 1) THEN
                          DO K2 = 2, NINTRES
                            ML = MOL(K2)
                            IF (MOD (ML, IARU) == MR2) THEN
                              XMOL1 = ML / PAR(42)
                              CALL PLA270 (XMOL, XMOL1, XMOL2)
                              IF (IPR(2) == 0) THEN
                                MOL2  = INT (XMOL2 / 1000.0)
                                NMOL2 = (MOL2 * 1000 + 555) * IARU + MR2
                                DO L2 = IFIXX + 1, NARU
                                  IF (IATP(L2) == NMOL2) THEN
                                    IFIXX       = IFIXX + 1
                                    IATP(L2)    = IATP(IFIXX)
                                    IATP(IFIXX) = NINT (XMOL2 * PAR(42))
                                    EXIT
                                  END IF
                                END DO
                              ELSE
                                IF (LU6 /= 0)
     1                            WRITE (LU6, 99985, IOSTAT = IOST)
                                RETURN
                              END IF
                            END IF
                          END DO
                        END IF
                      END IF
                    END IF
                  END DO
                END IF
              ELSE
                IF (LU6 /= 0) WRITE (LU6, 99985, IOSTAT = IOST)
                RETURN
              END IF
            END IF
          END DO
C * END K-LOOP
          M1 = LMX - 1
          IF (M1 > 0) THEN
            IF (LMX > 12) THEN
              LMZ = 12
            ELSE
              LMZ = LMX
            END IF
            NTP = NTOP + (I - 1) * NADD
            VOID(NTP + NADD) = LMX
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (1)
              WRITE (LU7, FORMJ, IOSTAT = IOST) N1, M1, VOID(NTP + 1),
     1          (VOID(NTP + L), CHAR (IFNT(L)), L = 2, LMZ)
            END IF
            IF (LMX > 12) THEN
              LMB = 2
              DO
                LMB = LMB + 11
                LMZ = LMB + 10
                IF (LMZ > LMX) LMZ = LMX
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (1)
                NTP = NTOP + (I - 1) * NADD
                  WRITE (LU7, FORMK, IOSTAT = IOST)
     1                  (VOID(NTP + L), CHAR (IFNT(L)), L = LMB, LMZ)
 
                END IF
                IF (LMZ >= LMX) EXIT
              END DO
            END IF
          END IF
        END DO
C * END OF LOOP OVER COMPLETE SET OF UNITCELL ARU'S
C * OUTPUT NETWORK ON DISPLAY
        CALL PLA094 (0, 0, 0, 0, 0, IAGG)
C * SEARCH FOR ARU-CIRCUITS AND CHAINS
        IF (MODE == -3 .AND. IGBL(63) > 2) THEN
          NCIR = 0
          NCHN = 0
          N1   = 1
          N2   = 2
C * GET MAXIMUM CIRCUIT + 1 SIZE
          MCIR = IPR(66)
          IF (MCIR == 0) N1 = 2
C * GET MAXIMUM CHAIN + 1 LENGTH
          MCHN = IPR(82)
          IF (MCHN == 0) N2 = 1
          IF (N2 >= N1) THEN
            DO N3 = N1, N2
              IF (N3 == 1) THEN
                MC   = MCIR
                NCRA = 0
              ELSE
                MC   = MCHN
                NCRA = NCIR + 1
              END IF
C * LOOP OVER RESIDUES
              DO 80 NR = 1, NRES
                DO I = 1, NARU
                  IF (MOD (IATP(I), IARU) == NR) EXIT
                END DO
                NRT       = 1
                IFIXX     = NARU
                KDATC     = I
   20           JR(NRT)   = NTOP + (KDATC - 1) * NADD
                DATC(NRT) = VOID(JR(NRT) + 1)
C * CHECK FOR PREMATURE CLOSURE
                IF (NRT > 2) THEN
                  MDATCNRT = NINT (DATC(NRT) * PAR(42))
                  DO K = 2, NRT - 1
                    IF (MDATCNRT == NINT (DATC(K) * PAR(42))) THEN
                      NRT = NRT - 1
                      GO TO 60
                    END IF
                  END DO
                END IF
                IF (NRT > 1) THEN
                  MOL2 = NINT (DATC(NRT) * PAR(42))
                  CALL GEN098 (MOL2, PAR(42), NS2, NT21, NT22, NT23,
     1                         NR2)
                  IF (NS1 == NS2 .AND. NR1 == NR2) THEN
                    ND1 = NT21 - NT11
                    ND2 = NT22 - NT12
                    ND3 = NT23 - NT13
                    ND123 = IABS (ND1) + IABS (ND2) + IABS (ND3)
                    IF (N3 == 1) THEN
                      IF (ND123 /= 0) GO TO 50
                    ELSE
                      IF (ND123 == 0 .OR. NRT > MCHN) GO TO 50
                    END IF
C * STORE SEQUENCE
                    DO K = 1, NRT
                      JNSX(NCIR * 100 + K) = NINT (DATC(K) * PAR(42))
                    END DO
C * CHECK WHETHER THIS IS A NEW CIRCUIT
                    IF (NCIR > NCRA) THEN
                      DO J = NCRA, NCIR - 1
                        DO 40 K0 = 1, NRT - 1
C * COMPARE FORWARD DIRECTION
                          DO K = 1, NRT - 1
                            KK0 = MOD (K + K0 - 2, NRT - 1) + 1
                            IF (JNSX(NCIR * 100 + KK0) .NE.
     1                          JNSX(J * 100 + K)) GO TO 30
                          END DO
                          NRT = NRT - 1
                          GO TO 60
C * COMPARE BACKWARD DIRECTION
   30                     DO K = 1, NRT - 1
                            KK0 = MOD (K + K0 - 2, NRT - 1) + 1
                            IF (JNSX(NCIR * 100 + NRT - KK0) .NE.
     1                          JNSX(J * 100 + K)) GO TO 40
                          END DO
                          NRT = NRT - 1
                          GO TO 60
   40                   CONTINUE
                      END DO
                    END IF
                    IF (N3 == 1) THEN
                      NCIR = NCIR + 1
                      IF (NCIR == 1) THEN
                        CALL PLA262 (0)
                        CALL PLA262 (2)
                        WRITE (LU7, 99996, IOSTAT = IOST) MCIR - 1
                      ELSE IF ((NCIR + 1) * 100 > NP74
     1                     .OR. NCIR > 29) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99988, IOSTAT = IOST)
                        GO TO 90
                      END IF
                    ELSE IF (N3 == 2) THEN
                      NCHN = NCHN + 1
                      IF (NCHN == 1) THEN
                        CALL PLA262 (0)
                        CALL PLA262 (2)
                        WRITE (LU7, 99986, IOSTAT = IOST) MCHN - 1
                      ELSE IF ((NCHN + 1) * 100 > NP74
     1                     .OR. NCHN > 29) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99988, IOSTAT = IOST)
                        GO TO 90
                      END IF
                    ENDIF
                    CALL PLA262 (3 + NRT / 14)
                    IF (ND123 == 0) THEN
C * COUNT OCCURRENCE NUMBER OF RESIDUE S IN RING
                      CALL GEN097 (NRESCNT, 1, 64, 0)
                      DO K = 1, NRT - 1
                        IYUNK = MOD (NINT (DATC(K) * IARU), IARU)
                        NRESCNT(IYUNK) = NRESCNT(IYUNK) + 1
                      END DO
                      KKMAX = MIN (30, IPR(75))
                      WRITE (LU7, 99993, IOSTAT = IOST) NRT - 1,
     1                  (NRESCNT(K), K = 1, KKMAX)
                      WRITE (LU7, 99991, IOSTAT = IOST)
     1                  (DATC(K), K = 1, NRT)
                    ELSE
                      WRITE (LU7, 99994, IOSTAT = IOST)
     1                  NRT - 1, ND1, ND2, ND3
                      WRITE (LU7, 99991, IOSTAT = IOST)
     1                  (DATC(K), K = 1, NRT)
                    END IF
                    NRT = NRT - 1
                    GO TO 60
                  END IF
                ELSE
                  MOL1 = NINT (DATC(1) * PAR(42))
                  CALL GEN098 (MOL1, PAR(42), NS1, NT11, NT12, NT13,
     1                         NR1)
                END IF
   50           NCN(NRT) = NINT(VOID(JR(NRT) + NADD))
                IF (NRT == 1) THEN
                  IF (NCN(1) < 3) GO TO 80
                END IF
                IF (NRT < MC) THEN
                  NRT       = NRT + 1
                  JLN(NRT)  = 1
                END IF
   60           IF (NRT > 1) THEN
                  JLN(NRT)  = JLN(NRT) + 1
                  IF (JLN(NRT) > NCN(NRT - 1)) THEN
                    NRT = NRT - 1
                    IF (NRT > 1) GO TO 60
                    GO TO 80
                  END IF
                  XMOL = VOID(JR(NRT - 1) + JLN(NRT))
                  IF (NRT > 2) THEN
                    IF (XMOL == DATC(NRT - 2)) GO TO 60
                  END IF
                  NMOL = NINT (XMOL * PAR(42))
                  CALL GEN098 (NMOL, PAR(42), MS2, MT21, MT22, MT23,
     1                         MR2)
                  DO 70 L = 1, NARU
                    CALL GEN098 (IATP(L), PAR(42), MS1, MT11, MT12,
     1                           MT13, MR1)
                    IF (MS2 == MS1 .AND. MR2 == MR1) THEN
                      MD1 = MT21 - MT11
                      MD2 = MT22 - MT12
                      MD3 = MT23 - MT13
                      IF (IABS (MD1) + IABS (MD2) + IABS (MD3) /= 0)
     1                  THEN
                        NAD   = MD1 * 100 + MD2 * 10 + MD3
                        IYUNK = IATP(L) + NAD * 100
C * CHECK FOR PREVIOUSLY RECORDED
                        DO K = 1, IFIXX
                          IF (IATP(K) == IYUNK) THEN
                            KDATC = K
                            GO TO 70
                          END IF
                        END DO
                        IF (IFIXX < NP1) THEN
                          IFIXX      = IFIXX + 1
                          IATP(IFIXX) = IYUNK
                          N0         = INT (VOID(NTOP + L * NADD))
                          VOID(NTOP + IFIXX * NADD) = N0
                          DO N = 1, N0
C * CHECK FOR OUT-OF-RANGE
                            MOLY = NINT (VOID(NTOP + (L  - 1) * NADD
     1                           + N) * PAR(42))
                            CALL GEN098 (MOLY, PAR(42), MS3, MT31, MT32,
     1                                 MT33, MR3)
                            MT31 = MT31 + MD1
                            IF (MT31 < -5 .OR. MT31 > 4) GO TO 60
                            MT32 = MT32 + MD2
                            IF (MT32 < -5 .OR. MT32 > 4) GO TO 60
                            MT33 = MT33 + MD3
                            IF (MT33 < -5 .OR. MT33 > 4) GO TO 60
                            VOID(NTOP + (IFIXX - 1) * NADD + N) =
     1                      VOID(NTOP + (L  - 1) * NADD + N) + NAD
                          END DO
                          KDATC = IFIXX
                        ELSE
C * SEARCH ABORTED (Storage Overflow)
                          WRITE (LU6, 99987, IOSTAT = IOST)
                          GO TO 80
                        END IF
                      ELSE
                        KDATC = L
                      END IF
                    END IF
   70             CONTINUE
                  GO TO 20
                END IF
   80         CONTINUE
   90         CONTINUE
            END DO
          END IF
        END IF
      END IF
      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('-'))
99996 FORMAT ('Search for ARU-Circuits (Max =', I3, ' Membered)', /,
     1 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('-'))
99994 FORMAT (/, I3, '-Membered Infinite ARU-Chain (Translation [',
     1        3I3, '])')
99993 FORMAT (/, I3, '-Membered ARU-Circuit - ResCount - ',
     1        30(I2, ','))
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('-'))
99991 FORMAT (14F9.2)
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 (//, '*** etc, etc, etc ..  ***', /)
99987 FORMAT (/, ':: Search Aborted - Storage Overflow')
99986 FORMAT ('Search for Infinite ARU-Chains (Max =', I3, ')', /,
     1        132('='))
99985 FORMAT ('Error in PLA091')
      END SUBROUTINE PLA091
 
      SUBROUTINE PLA092
C * HYDROGEN BOND NETWORK ANALYSIS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: L0
      INTEGER          :: L1
      INTEGER          :: J0
      INTEGER          :: IA
      INTEGER          :: ML
      INTEGER          :: NH
      INTEGER          :: MR1
      INTEGER          :: MS1
      INTEGER          :: MS2
      INTEGER          :: MD1
      INTEGER          :: MD2
      INTEGER          :: MD3
      INTEGER          :: IML
      INTEGER          :: ITL
      INTEGER          :: JMX
      INTEGER          :: IAT
      INTEGER          :: JAT
      INTEGER          :: KAT
      INTEGER          :: ID1
      INTEGER          :: ID2
      INTEGER          :: ID3
      INTEGER          :: ID4
      INTEGER          :: JRD
      INTEGER          :: NRT
      INTEGER          :: NRTM
      INTEGER          :: JRAT
      INTEGER          :: JMXB
      INTEGER          :: JMX0
      INTEGER          :: IDF1
      INTEGER          :: IDF2
      INTEGER          :: IDFX
      INTEGER          :: IDIF
      INTEGER          :: IDUM
      INTEGER          :: JDUM
      INTEGER          :: IHBD
      INTEGER          :: JRDT
      INTEGER          :: NETWX
      INTEGER          :: NRTM1
      INTEGER          :: NRTM2
      INTEGER          :: MXLSP
      INTEGER          :: LFORW
      INTEGER          :: JRNRT
      INTEGER          :: JRDIF
      INTEGER          :: IXPVJ
      INTEGER          :: IPOPM
      INTEGER          :: IPOPN
      INTEGER          :: IDIS1
      INTEGER          :: IDIS2
      INTEGER          :: IATCK
      INTEGER          :: NRRING
      INTEGER          :: MXRING
      INTEGER          :: IATCL0
      INTEGER          :: IATCTL
      INTEGER          :: JRNRTM1
      REAL             :: YI
      REAL             :: XML
      REAL             :: XLS2
      REAL             :: XLS4
      REAL             :: XLSI2
      REAL             :: XLSI3
      REAL             :: XLSI4
      REAL             :: XLSK2
      REAL             :: XLSK4
      CHARACTER(len=1) :: IDS1
      CHARACTER(len=1) :: IDS2
      CHARACTER(len=1) :: IYA
      CHARACTER(len=5) :: COPT
C * HYDROGEN BONDS ARE STORED IN SCRATCH ARRAY XLS
C * XLS(1,  I) = NR DONOR ATOM
C * XLS(2,  I) = MOL DONOR
C * XLS(3,  I) = NR ACCEPTOR ATOM
C * XLS(4,  I) = MOL ACCEPTOR ATOM
C * XLS(5,  I) = LINK
C * XLS(6,  I) = LINK
C * XLS(7,  I) = LINK
C * XLS(8,  I) = IHBD
C * XLS(9,  I) = D-H..A ANGLE
C * XLS(10, I) = NR DONOR H
C * GET NUMBER OF CONTACTS/BRIDGES
      ITL = IPR(88)
      IF (ITL == 0) GO TO 180
C * GET MAX DIMENSION OF XLS ARRAY
      MXLSP = NP2
C * INITIALISE TRANSLATION NETWORK (H-BONDING)
      CALL PLA094 (-3, 0, 0, 0, 0, 0)
      MXRING = IPR(218)
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (-3)
        WRITE (LU7, 99998, IOSTAT = IOST) MXRING
      END IF
      NETWX = 0
      L0    = 0
      KAT   = IPR(39) + IPR(24) + 1
      JAT   = KAT + 1
      IAT   = JAT + 1
      I     = 0
   10 I     = I + 1
      IF (I > ITL) GO TO 120
      LFORW = 1
      IF (L0 <= I) THEN
        L0 = 0
C * GET STARTING POINT FOR NEW NETWORK
        DO J = I, ITL
          IF (IATC(J) > 0) THEN
            L1 = NINT (XLS(1, J))
C * TEST FOR L1 IS ACCEPTOR, IF NOT THAN START NEW SEQUENCE
            CALL GEN048 (-1, IFG(1, L1), 22, IA)
            IF (IA == 0) GO TO 20
C * REGISTER POSSIBLE ALTERNATIVE START
            IF (L0 == 0) L0 = J
          END IF
        END DO
        IF (L0 == 0) THEN
C * NO H-BONDS LEFT TO HANDLE
          GO TO 120
        ELSE
          J = L0
        END IF
C * OUTPUT TRANSLATION NETWORK
   20   CALL PLA094 (0, 0, 0, 0, 0, 0)
        NETWX = NETWX + 1
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (7)
          WRITE (LU7, 99997, IOSTAT = IOST) NETWX
          WRITE (LU7, 99996, IOSTAT = IOST)
        END IF
        J0    = J
        L0    = I
        XLSI3 = XLS(1, J0)
        XLSI4 = XLS(2, J0)
        JMX   = 99
        GO TO 40
      END IF
   30 IF (XLS(8, I) <= 0) THEN
        J0        = I
        LFORW     = -1
        XLS(8, I) = 1
        XLSI3     = XLS(1, J0)
        XLSI4     = XLS(2, J0)
        JMX       = 99
        GO TO 40
      END IF
      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 (LABA(M),  NQ1, IDUM, JDUM, IPR(71), IGBL(55),
     1  0, 0)
      CALL PLA047 (LABA(N),  NQ2, IDUM, JDUM, IPR(71), IGBL(55),
     1  0, 0)
      CALL PLA047 (LABA(NH), NQ3, IDUM, JDUM, IPR(71), IGBL(55),
     1  0, 0)
C * GET DISORDER INFORMATION
      CALL GEN048 (-8, IFG(2, M), 1, IDIS1)
      IPOPM = IPPR(IDIS1 + 1, 1)
      IF (IPOPM < 10000) THEN
        IDS1 = '*'
      ELSE
        IDS1 = ' '
      END IF
      CALL GEN048 (-8, IFG(2, N), 1, IDIS2)
      IPOPN = IPPR(IDIS2 + 1, 1)
      IF (IPOPN < 10000) THEN
        IDS2 = '*'
      ELSE
        IDS2 = ' '
      END IF
      MS1 = NINT (XLSI2 * PAR(42))
      CALL GEN098 (MS1, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), IML)
C * ORTHOGONALISE
      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)
C * ORTHOGONALISE
      CALL PLA059 (N, JAT)
      CALL GEN048 (-1, IFG(1, M), 22, IA)
      IF (IA == 1) THEN
        IYA = 'A'
      ELSE
        IYA = ' '
      END IF
      JMX = 4
C * LOOK WHETHER CURRENT ACCEPTOR ATOM IS ALSO A DONOR/ACCEPTOR
   40 K = 0
   50 K = K + 1
      IF (K > ITL) GO TO 100
      IF (IATC(K) /= 0) THEN
C *-------------------------------------------------------------------*
C *                                                                   *
C *            Z                                    Z                 *
C *        k /                                  k /                   *
C *        /       JMX = 99                     /  JMX < 7            *
C *      /                                    /                       *
C *     X------>Y                   X------->Y                        *
C *         i                           i                             *
C *                                                                   *
C *-------------------------------------------------------------------*
        IF (XLS(1, K) == XLSI3) THEN
          IHBD = 1
          CALL PLA270 (XLS(2, K), 0.0, XLSK2)
          IF (IPR(2) /= 0) GO TO 180
          CALL PLA270 (XLSK2, XLS(4, K), XLSK4)
          IF (IPR(2) /= 0) GO TO 180
          CALL PLA270 (XLSI4, XLSK4, XLS4)
          IF (IPR(2) /= 0) GO TO 180
          XLS2 = XLSI4
          GO TO 60
        END IF
C *-------------------------------------------------------------------*
C *                                                                   *
C *               i                                i                  *
C *           X------->Y                       X------->Y             *
C *        k /                                        /               *
C *        /   JMX = 99                     JMX < 7  /                *
C *      /                                         /                  *
C *     Z                                         Z                   *
C *                                                                   *
C *-------------------------------------------------------------------*
        IF (K /= I) THEN
          IF (NINT (XLS(3, K)) == NINT (XLSI3)) THEN
            IHBD = -1
            CALL PLA270 (XLS(4, K), 0.0, XLSK4)
            IF (IPR(2) /= 0) GO TO 180
            CALL PLA270 (XLSK4, XLS(2, K), XLSK2)
            IF (IPR(2) /= 0) GO TO 180
            CALL PLA270 (XLSI4, XLSK2, XLS2)
            IF (IPR(2) /= 0) GO TO 180
            XLS4 = XLSI4
            GO TO 60
          END IF
        END IF
      END IF
      GO TO 50
   60 XML = K + 0.555
C * TEST WHETHER THIS IS A NEW LINK, TRANSLATED OR RING CLOSURE
      L = L0
   70 L = L - 1
      IF (L /= 0) THEN
        IF (XLS(1, L) /= XLS(1, K)) GO TO 70
        IF (XLS(3, L) /= XLS(3, K)) GO TO 70
C * TRUNCATE
        ID1 = INT (XLS2)
C * TRUNCATE
        ID2 = INT (XLS(2, L))
        IF (ID1 / 1000 /= ID2 / 1000) GO TO 70
        IDF1 = ID1 - ID2
C * TRUNCATE
        ID3  = INT (XLS4)
C * TRUNCATE
        ID4  = INT (XLS(4, L))
        IF (ID3 / 1000 /= ID4 / 1000) GO TO 70
        IDF2 = ID3 - ID4
        IF (IDF1 /= IDF2) GO TO 70
        XML = L + (IDF1 + 555) / 1000.0
        IF (IDF1 == 0) THEN
C * IDENTIFY RING
          IF (LFORW > 0) THEN
             IXPVJ = 82
          ELSE
             IXPVJ = 32
          END IF
        ELSE
C * IDENTIFY TRANSLATION
          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
C * ADD NEW NETWORK ENTRY
          CALL PLA094 (1, MD1, MD2, MD3, IML, 0)
        END IF
        GO TO 90
      END IF
      IXPVJ  = 32
      IATCK  = IATC(K)
      IATCL0 = 0
      IF (IATCK >= 0) THEN
        IATCL0 = -1
        IATCK  = 0
      END IF
      IATCTL = IATC(L0)
      IF (L0 == K) IATCTL = 0
      IF (ITL == MXLSP) GO TO 50
      ITL = ITL + 1
      DO J = 1, 10
        XLS(J, ITL) = XLS(J, L0)
      END DO
      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 > ITL) GO TO 90
      IF (IATCTL  == 0) GO TO 80
      IF (IATC(K) /= 0) GO TO 90
      DO J = 1, 10
         XLS(J, K) = XLS(J, ITL)
      END DO
      IATC(K) = IATC(ITL)
   80 ITL     = ITL - 1
   90 IF (JMX  > 7) GO TO 50
      IF (IHBD < 0) GO TO 50
      JMX         = JMX + 1
      XLS(JMX, I) = XML
      IXPV(JMX)   = IXPVJ
      GO TO 50
  100 IF (JMX == 99) GO TO 30
      YI   = I + 0.555
      JMX0 = JMX
      IF (JMX0 > 7) JMX0 = 7
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (2)
        WRITE (LU7, 99995, IOSTAT = IOST)
     1    YI, IYA, IDS1, NQ1(1:6), XLSI2,
     2    (XXO(KAT, J), J = 1, 3),  IDS2, NQ2(1:6), XLS(4, I),
     3    (XXO(JAT, J), J = 1, 3),
     4    (XLS(J, I), CHAR (IXPV(J)), J = 5, JMX0)
        WRITE (LU7, 99993, IOSTAT = IOST)
     1    NQ3(1:7), (XXO(IAT, J), J = 1, 3)
      END IF
  110 IF (JMX0 < JMX) THEN
        JMXB = JMX0 + 1
        JMX0 = JMX
        IF (JMX0 > JMXB + 2) JMX0 = JMXB + 2
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99994, IOSTAT = IOST)
     1      (XLS(J, I), CHAR (IXPV(J)), J = JMXB, JMX0)
        END IF
        GO TO 110
      END IF
      GO TO 10
C * OUTPUT NETWORK RESULT
  120 CALL PLA094 (0, 0, 0, 0, 0, 0)
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (9)
        WRITE (LU7, 99999, IOSTAT = IOST)
      END IF
C * SAVE NUMBER OF (SYMMETRY EXPANDED) H-BONDS
      IPR(224) = ITL
C * GENERATE DIRECTED COOPERATIVE H-BOND SEQUENCES (RING SEARCH)
C * BOTTOM OF RING COORDINATE SCRATCH
      NRRING = 0
      KAT    = IPR(39) + IPR(24)
C * GET MAX RING-SIZE + 1
      NRTM     = MXRING + 1
      DO 170 J = 1, ITL
        JAT = NINT(XLS(1, J))
C * SKIP STARTING POINTS THAT ARE NOT ACCEPTOR ATOM, SINCE THEY CANNOT
C * BE PART OF A RING OR HELIX
        CALL GEN048 (-1, IFG(1, JAT), 22, IA)
        IF (IA > 0) THEN
C * STORE DATA ON FIRST BOND JR(1)
          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
C * GET NEW ORTHOGONALIZED COORDINATES FOR DONOR
          CALL PLA059 (JAT, JRAT)
          NRT      = 1
C * GET NUMBER OF LINKS OUTGOING FROM ACCEPTOR
  130     NCN(NRT) = 4
          JRNRT    = JR(NRT) / 1000
          DO I = 5, 7
            IF(XLS(I, JRNRT) /= 0.0) NCN(NRT) = I
          END DO
          NRT      = NRT + 1
          JLN(NRT) = 4
  140     JLN(NRT) = JLN(NRT) + 1
          IF (JLN(NRT) > NCN(NRT - 1)) THEN
            NRT = NRT - 1
            IF (NRT > 1) GO TO 140
            GO TO 170
          END IF
          NRTM1   = NRT - 1
          NRTM2   = NRT - 2
          JRNRTM1 = JR(NRTM1) / 1000
          JRDIF   = MOD (JR(NRTM1), 1000)
          IF (NRT == NRTM) NRTM2 = 1
C * REGISTER BRIDGE CODE
          JR(NRT) = NINT (XLS(JLN(NRT), JRNRTM1) * 1000 - 555 + JRDIF)
C * DETERMINE NEXT RING ATOM COORDINATES
          J0    = JR(NRT) / 1000
          JRDIF = MOD (JR(NRT), 1000)
          IF (J0 <= 0) THEN
            WRITE (LU6, '(''>> J0=0 Problem in PLA092, Loop abort'')',
     1        IOSTAT = IOST)
            GO TO 180
          END IF
          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 <= 0) THEN
            WRITE (LU6, 99989, IOSTAT = IOST) NRT, J0, JAT
            WRITE (LU7, 99989, IOSTAT = IOST) NRT, J0, JAT
            GO TO 180
          END IF
          CALL PLA059 (JAT, JRAT)
          IF (NRT > 3) THEN
C * AVOID PREMATURE CLOSURE LINKS
            DO I = 2, NRTM2
              IF (JR(NRT) == JR(I)) GO TO 140
            END DO
          END IF
C * SELECT RING WITH LOWEST STARTING NUMBER
 
C * FIRST CHECK H-BOND # WITHOUT TRANSLATION CODE
          JRD  = JR(NRT) / 1000
          JRDT = JR(NRT) - JRD * 1000
          IF (JRD == J) THEN
            IF (JRDT == 555) THEN
              COPT = 'Ring '
            ELSE
              COPT = 'Chain'
              GO TO 150
            END IF
          ELSE
            IF (JR(NRT) < JR(1)) THEN
              GO TO 140
            ELSE IF (JR(NRT) > JR(1)) THEN
              GO TO 160
            END IF
          END IF
          IF (NRTM1 < 3) GO TO 140
C * OUTPUT RING
  150     IF (IGBL(63) > 2) THEN
            CALL PLA262 (NRTM1 + 5)
            WRITE (LU7, 99992, IOSTAT = IOST) NRTM1, COPT, JRDT
          END IF
          NRRING = NRRING + 1
          IF (NRRING > 15) THEN
            WRITE (LU6, 99988, IOSTAT = IOST)
            GO TO 180
          END IF
          WRITE (LU6, 99990, IOSTAT = IOST) NRTM1, COPT, JRDT
          DO K = 1, NRTM1
            L    = JR(K) / 1000
            IDIF = JR(K) - L * 1000
C * GET DONOR ATOM LABEL
            M    = NINT(XLS(1, L))
            CALL PLA047 (LABA(M), NQ1, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
            IF (IGBL(63) > 2) WRITE (LU7, 99991, IOSTAT = IOST)
     1        JR(K) / 1000.0, NQ1(1:6), XLS(2, L) - 555 + IDIF,
     2         (XXO(KAT + K, N), N = 1, 6), XLS(9, L)
          END DO
          IF (NRT == NRTM) NRT = NRT - 1
          GO TO 140
  160     IF (NRT == NRTM) GO TO 140
          GO TO 130
        END IF
  170 CONTINUE
  180 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 PLA092
 
      SUBROUTINE PLA093 (I, J, K, IDIRCT)
C * SUPPORT PLA091
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: K0
      INTEGER           :: N0
      INTEGER           :: NC
      INTEGER           :: MT1
      INTEGER           :: MT2
      INTEGER           :: MT3
      INTEGER           :: MR1
      INTEGER           :: MS1
      INTEGER           :: IER
      INTEGER           :: NMOL
      INTEGER           :: NDEC
      INTEGER           :: IDUM
      INTEGER           :: JDUM
      INTEGER           :: ISA3
      INTEGER           :: IPOPM
      INTEGER           :: IDIS3
      INTEGER           :: IDIRCT
      INTEGER           :: IDSORD
      REAL              :: A3
      REAL              :: SA3
      CHARACTER(len=1)  :: IDS
      CHARACTER(len=4)  :: DIRECTX
      CHARACTER(len=27) :: FORMA
      CHARACTER(len=78) :: FORMB
      CHARACTER(len=32) :: FORMC
C * SUPPORT ROUTINE FOR PLA091
C * LISTING & HANDLING OF DONOR-ACCEPTOR/CONTACT INTERACTIONS
      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,'
C * TEST FOR PSEUDO ATOM STACK OVERFLOW
      IF (IDIRCT > 0) THEN
        DIRECTX = ' >> '
      ELSE
        DIRECTX = ' << '
      END IF
      IDSORD = NINT (XLS(8, I))
      CALL PLA047 (LABA(J), NQ1, IDUM, JDUM, IPR(71), IGBL(55),
     1  0, 0)
      IF (IDSORD / 10 == 1) THEN
        IDS = '*'
      ELSE
        IDS = ' '
      END IF
      NAMS(1, 1) = IDS//NQ1(1:NP64 - 1)
      CALL PLA047 (LABA(K), NQ2, IDUM, JDUM, IPR(71), IGBL(55),
     1  0, 0)
      IF (MOD (IDSORD, 10) == 1) THEN
        IDS = '*'
      ELSE
        IDS = ' '
      END IF
      NAMS(1, 2) = IDS//NQ2(1:NP64 - 1)
      NMOL = NINT (XLS(4, I) * PAR(42))
      CALL GEN098 (NMOL, PAR(42), MS1, MT1, MT2, MT3, MR1)
      DO L = 1, 3
         SGY(L) = XXO(K, L)
      END DO
      SGY(4) = MT1
      SGY(5) = MT2
      SGY(6) = MT3
      CALL SGSM (3, ICL, SGY, MS1, LU7, IERR)
      IF (IPR(39) + 2 <= NP1 - IPR(75)) THEN
        K0 = IPR(39) + 1
        DO L = 1, 3
          XXO(K0, L) = SGY(L + 6)
        END DO
C * SPECIAL OUTPUT ON FILE .ELD
        IF (IPR(167) == 1) THEN
          WRITE (LU2, 99999, IOSTAT = IOST)
     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)
        END IF
C * ORTHOGONALISE
        CALL PLA059 (K0, K0)
        NC = - NINT (CON(K, 9))
        IF (NC < 0) NC = 9
        IF (NC > 0) THEN
          DO 10 L = 1, NC
            M = NINT (CON(K, L))
            IF (M <= NP1) THEN
              CALL PLA047 (LABA(M), NQ3, IDUM, JDUM, IPR(71),
     1          IGBL(55), 0, 0)
C * GET DISORDER INFORMATION FOR M
              CALL GEN048 (-8, IFG(2, M), 1, IDIS3)
              IPOPM = IPPR(IDIS3 + 1, 1)
              IF (IPOPM < 10000) THEN
                IDS = '*'
              ELSE
                IDS = ' '
              END IF
              NAMS(1, 3) = IDS//NQ3(1:NP64 - 1)
              DO N = 1, 3
                SGY(N) = XXO(M, N)
              END DO
              CALL SGSM (3, ICL, SGY, MS1, LU7, IERR)
              N0 = IPR(39) + 2
              DO N = 1, 3
                XXO(N0, N) = SGY(N + 6)
              END DO
C * ORTHOGONALIZE
              CALL PLA059 (N0, N0)
              CALL PLA053 (J, K0, N0, 0, A3, SA3, ISA3, NDEC, IER)
              IF (IER /= 0) GO TO 10
              FORMA(15:15) = CHAR (ICHAR ('0') + NDEC)
              IF (IGBL(63) > 3) THEN
                IF (L == 1) THEN
                  FORMB(52:78) = FORMA
                  WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1              NAMS(1, 1)(1:8), XLS(2, I),
     2              (XXO(J,  N), N = 1, 3), DIRECTX, NAMS(1, 2)(1:8),
     3              XLS(4, I), (XXO(K0, N), N = 1, 3), NAMS(1, 3)(1:8),
     4              (XXO(N0, N), N = 1, 3), A3, ISA3
                ELSE
                  FORMC(6:32) = FORMA
                  WRITE (PRBUF, FORMC, IOSTAT = IOST) NAMS(1, 3)(1:8),
     1              (XXO(N0, N), N = 1, 3), A3, ISA3
                END IF
                CALL PLA263 (LU7, PRBUF, 132, 1, 3)
              END IF
            END IF
   10     CONTINUE
        END IF
      END IF
      RETURN
99999 FORMAT ('HBON ', A, '[', F8.2, ']', 3F7.4,
     1        1X, A, '[', F8.2, ']', 3F7.4)
      END SUBROUTINE PLA093
 
      SUBROUTINE PLA094 (MODE, M1, M2, M3, M4, IDISPLAY)
C * ASSEMBLE 1D, 2D, 3D NETWORK INFORMATION
      USE files
      USE parameters
      USE plato
      USE xwdw
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: M1
      INTEGER               :: M2
      INTEGER               :: M3
      INTEGER               :: M4
      INTEGER               :: MD4
      INTEGER               :: NRX
      INTEGER               :: IVL
      INTEGER               :: IVL1
      INTEGER               :: IDET
      INTEGER               :: NDIM
      INTEGER               :: MODE
      INTEGER               :: IDISP
      INTEGER               :: IPRINT
      INTEGER               :: IDISPLAY
      INTEGER, DIMENSION(4) :: KVEC
      INTEGER, DIMENSION(3) :: MD
      CHARACTER(len=80)     :: LINE
      CHARACTER(len=80)     :: LINE1
C * M1, M2, M3 - TRANSLATION VECTOR
C * M4         - RESIDUE NUMBER
C * IDISPLAY   - NUMBER OF THE AGGREGATE (FOR DISPLAY - M1=M2=M3=M4=0)
      MD(1) = M1
      MD(2) = M2
      MD(3) = M3
      MD4   = M4
      IDISP = IDISPLAY
C * MODE = -3 : TYPE 3 NETWORK INITIALIZATION (AGGREGATE - H-BONDING)
C * MODE = -2 : TYPE 2 NETWORK INITIALIZATION (CLUSTER - INTER)
C * MODE = -1 : TYPE 1 NETWORK INITIALIZATION (COVALENT)
C * MODE =  0 : OUTPUT NETWORK/FRAMEWORK RESULT
C * MODE =  1 : NEW TRANSLATION ENTRY
C * NETWORK INFO (L = 1 - MXNW)
C * NETW(L, 1) - RESIDUE NUMBER (MAX IPR(75))
C * NETW(L, 2) - NETWORK DIMENSION (0, 1, 2, 3)
C * NETW(L, 3) - DETERMINANT
C * INITIALISE NETWORK
      IF (MODE < 0) THEN
C * INIT NUMBER OF NETWORKS
        MXNW     = 0
C * SET NETWORK TYPE
        NETTYPE = - MODE
C * INIT COVALENT POLYMER TYPE
        IF (NETTYPE == 1) IPR(322) = 0
C * OUTPUT RESULTS (NO ARU OUT-OF-RANGE CASE)
      ELSE IF (MODE == 0 .AND. IPR(600) == 0) THEN
C * TEST FOR INTRA NETWORK MODE
        IF (NETTYPE == 1) THEN
C * GET NUMBER OF RESIDUES
          NRX = IPR(75)
        ELSE
          NRX = 0
        END IF
        IF (MXNW > 0) THEN
          IPRINT = 0
C * LOOP OVER RESIDUES
          DO N = 0, NRX
C * LOOP OVER NETWORKS
            DO L = 1, MXNW
              IF (NETW(L, 1) == N) THEN
                IF (IGBL(63) > 2) CALL PLA262 (2)
C * 1 = LINEAR NET
                IF (NETW(L, 2) == 1) THEN
                  WRITE (LINE, 99999, IOSTAT = IOST)
     1              NETW(L, 1), NETTYPE, (LHNT(1, J, L), J = 1, 3)
C * TERMINAL WINDOW OUTPUT
                  WRITE (LU6,  99989, IOSTAT = IOST)
                  WRITE (LU6,  99987, IOSTAT = IOST) LINE
                  WRITE (LU6,  99989, IOSTAT = IOST)
C * GRAPHICS WINDOW OUTPUT
                  IF (IWIN * IDISP > 0) THEN
                    IF (IDISP == 1 .AND. L == 1) THEN
                      VRT = VRT - 1.0
                    ELSE
                      VRT = VRT - 0.45
                    END IF
                    CALL PLA439 (0.0, LINE,  80, 0.35, 1, 2, 1.0, VRT)
                  END IF
C * LISTING FILE OUTPUT
                  IF (IGBL(63) > 2) THEN
                    IPRINT = IPRINT + 1
                    IF (IPRINT == 1) THEN
                      IF (IPR(51) > 1) THEN
                        WRITE (LU7, 99995, IOSTAT = IOST)
                        CALL PLA262 (2)
                      END IF
                      CALL PLA262 (2)
                      IF (NETTYPE == 1) THEN
                        WRITE (LU7, 99992, IOSTAT = IOST)
                      ELSE IF (NETTYPE == 2) THEN
                        WRITE (LU7, 99991, IOSTAT = IOST)
                      ELSE IF (NETTYPE == 3) THEN
                        WRITE (LU7, 99990, IOSTAT = IOST)
                      END IF
                    END IF
                    WRITE (LU7, 99989, IOSTAT = IOST)
                    WRITE (LU7, 99999, IOSTAT = IOST)
     1                NETW(L, 1), NETTYPE, (LHNT(1, J, L), J = 1, 3)
                    CALL PLA262 (1)
                  END IF
C * 2 = TWO DIMENSIONAL NET
                ELSE IF (NETW(L, 2) == 2) THEN
C * WORKOUT PLANE-INDICES
                  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)
C * REDUCE NETPLANE INDICES
                  DO 10 I = 1, 3
                    IVL = LHNT(3, I, L)
                    IF (IVL /= 0) THEN
                      DO J = 1, 3
                        IVL1 = LHNT(3, J, L) / IVL
                        IF (IVL1 * IVL /= LHNT(3, J, L)) GO TO 10
                      END DO
                      DO J = 1, 3
                        LHNT(3, J, L) = LHNT(3, J, L) / IVL
                      END DO
                      EXIT
                    END IF
   10             CONTINUE
                  WRITE (LINE,  99994, IOSTAT = IOST)
     1              NETW(L, 1), NETTYPE
                  WRITE (LINE1, 99986, IOSTAT = IOST)
     1               (I, (LHNT(I, J, L), J = 1, 3), I = 1, 2),
     2                              (LHNT(3, J, L), J = 1, 3)
C * TERMINAL WINDOW OUTPUT
                  WRITE (LU6, 99989, IOSTAT = IOST)
                  WRITE (LU6, 99987, IOSTAT = IOST) LINE
                  WRITE (LU6, 99987, IOSTAT = IOST) LINE1
                  WRITE (LU6, 99989, IOSTAT = IOST)
C * GRAPHICS WINDOW OUTPUT
                  IF (IWIN * IDISP > 0) THEN
                    IF (IDISP == 1 .AND. L == 1) THEN
                      VRT = VRT - 1.0
                    ELSE
                      VRT = VRT - 0.45
                    END IF
                    CALL PLA439 (0.0, LINE,  80, 0.35, 1, 2, 1.0, VRT)
                    VRT = VRT - 0.45
                    CALL PLA439 (0.0, LINE1, 80, 0.35, 1, 2, 1.0, VRT)
                  END IF
C * LISTING FILE OUTPUT
                  IF (IGBL(63) > 2) THEN
                    IPRINT = IPRINT + 1
                    IF (IPRINT == 1) THEN
                      IF (IPR(51) > 1) THEN
                        WRITE (LU7, 99995, IOSTAT = IOST)
                        CALL PLA262 (2)
                      END IF
                      CALL PLA262 (2)
                      IF (NETTYPE == 1) THEN
                        WRITE (LU7, 99992, IOSTAT = IOST)
                      ELSE IF (NETTYPE == 2) THEN
                        WRITE (LU7, 99991, IOSTAT = IOST)
                      ELSE IF (NETTYPE == 3) THEN
                        WRITE (LU7, 99990, IOSTAT = IOST)
                      END IF
                    END IF
                    WRITE (LU7, 99989, IOSTAT = IOST)
                    WRITE (LU7, 99998, IOSTAT = IOST)
     1                NETW(L, 1), NETTYPE,
     2                (I, (LHNT(I, J, L), J = 1, 3), I = 1, 2),
     3                (LHNT(3, J, L), J = 1, 3)
                    CALL PLA262 (1)
                  END IF
C * 3 = THREE DIMENSIONAL NET
                ELSE IF (NETW(L, 2) == 3) THEN
                  WRITE (LINE,  99993, IOSTAT = IOST)
     1              NETW(L, 1), NETTYPE, NETW(L, 3)
                  WRITE (LINE1, 99988, IOSTAT = IOST)
     1              (I, (LHNT(I, J, L), J = 1, 3), I = 1, 3)
C * TERMINAL WINDOW OUTPUT
                  WRITE (LU6, 99989, IOSTAT = IOST)
                  WRITE (LU6, 99987, IOSTAT = IOST) LINE
                  WRITE (LU6, 99987, IOSTAT = IOST) LINE1
                  WRITE (LU6, 99989, IOSTAT = IOST)
C * GRAPHICS WINDOW OUTPUT
                  IF (IWIN * IDISP > 0) THEN
                    IF (IDISP == 1 .AND. L == 1) THEN
                      VRT = VRT - 1.0
                    ELSE
                      VRT = VRT - 0.45
                    END IF
                    CALL PLA439 (0.0, LINE,  80, 0.35, 1, 2, 1.0, VRT)
                    VRT = VRT - 0.45
                    CALL PLA439 (0.0, LINE1, 80, 0.35, 1, 2, 1.0, VRT)
                  END IF
C * LISTING FILE OUTPUT
                  IF (IGBL(63) > 2) THEN
                    IPRINT = IPRINT + 1
                    IF (IPRINT == 1) THEN
                      IF (IPR(51) > 1) THEN
                        WRITE (LU7, 99995, IOSTAT = IOST)
                        CALL PLA262 (2)
                      END IF
                      CALL PLA262 (2)
                      IF (NETTYPE == 1) THEN
                        WRITE (LU7, 99992, IOSTAT = IOST)
                      ELSE IF (NETTYPE == 2) THEN
                        WRITE (LU7, 99991, IOSTAT = IOST)
                      ELSE IF (NETTYPE == 3) THEN
                        WRITE (LU7, 99990, IOSTAT = IOST)
                      END IF
                    END IF
                    WRITE (LU7, 99989, IOSTAT = IOST)
                    WRITE (LU7, 99997, IOSTAT = IOST)
     1                NETW(L, 1), NETTYPE, NETW(L, 3),
     1                          (I, (LHNT(I, J, L), J = 1, 3), I = 1, 3)
                    CALL PLA262 (1)
                  END IF
                END IF
                IF (IPR(17) == 0) THEN
C * SAVE POLYMER STATUS
                  IPR(322) = MAX (IPR(322), NETW(L, 2))
                ELSE IF (IPR(17) < 0) THEN
                END IF
              END IF
            END DO
          END DO
C * ALERT _004  - REPORT MAXIMUM DIMENSION OF INTRA NETWORK
          IF (IPR(17) == 0) THEN
            IPR(739) = IPR(322)
            CALL PLA236 (4, 0, -999.0, FLOAT(IPR(739)), ' ', ' ')
          END IF
        END IF
C * MODE = 1,  ADD NEW TRANSLATION
      ELSE
C * CHECK FOR NEGATIVE RESIDUE NUMBER
        IF (MD4 < 0) THEN
C * REPORT PROBLEM
          IF (ABS(IGBL(3)) /= 1) WRITE (6, 99985) MD4
        ELSE
C * GET NETWORK-NUMBER FOR RESIDUE MD4
          L = 0
          IF (MXNW > 0) THEN
            DO I = 1, MXNW
              IF (NETW(I, 1) == MD4) THEN
                L = I
                EXIT
              END IF
            END DO
          END IF
C * CHECK FOR ROOM FOR NEW NETWORK
          IF (MXNW >= 5) THEN
            WRITE (LU6, 99996, IOSTAT = IOST)
          ELSE
            IF (L == 0) THEN
              MXNW          = MXNW + 1
              NPOL(MD4)     = MXNW
              NETW(MXNW, 1) = MD4
              NETW(MXNW, 2) = 0
              NETW(MXNW, 3) = 99999
              L             = MXNW
            END IF
C * STANDARDIZE TRANSLATION
            IF (MD(1) == 0) THEN
              IF (MD(2) < 0) THEN
                MD(2) = - MD(2)
                MD(3) = - MD(3)
              ELSE  IF (MD(2) == 0) THEN
                IF (MD(3) < 0) MD(3) = - MD(3)
              END IF
            ELSE IF (MD(1) < 0) THEN
              DO I = 1, 3
                MD(I)  = - MD(I)
              END DO
            END IF
C * DETECT DUPLICATIONS
            NDIM = NETW(L, 2)
            DO I = 1, 3
              LHNT(NDIM + 1, I, L) = MD(I)
            END DO
C * REDUCE (LHNT() = 1, 2 OR 3 TRANSL. VECTORSi(=NDIM); L = NETWORK NUMBER
            IF (NDIM == 2) THEN
              DO I = 1, 3
                IF (LHNT(1, I, L) == 1) THEN
                  N = LHNT(2, I, L)
                  IF (N /= 0) THEN
                    DO J = 1, 3
                      LHNT(2, J, L) = LHNT(2, J, L) - N * LHNT(1, J, L)
                     END DO
                    EXIT
                  END IF
                END IF
              END DO
            END IF
 
C * TEST FOR LINEAR DEPENDENCE OF SECOND ON FIRST VECTOR
            IF (NDIM == 1) THEN
              IF ((LHNT(1, 1, L) * LHNT(2, 2, L) -
     1             LHNT(2, 1, L) * LHNT(1, 2, L) == 0) .AND.
     2            (LHNT(1, 1, L) * LHNT(2, 3, L) -
     3             LHNT(2, 1, L) * LHNT(1, 3, L) == 0) .AND.
     4            (LHNT(1, 2, L) * LHNT(2, 3, L) -
     5             LHNT(2, 2, L) * LHNT(1, 3, L) == 0)) THEN
C * TAKE SHORTEST VECTOR
                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 K = 1, 3
                    LHNT(1, K, L) = LHNT(2, K, L)
                  END DO
                END IF
                RETURN
              END IF
            ELSE IF (NDIM == 2) THEN
C * GET DETERMINANT
              CALL GEN131 (LHNT, 1, 2, 3, L, IDET)
              NETW(L, 3) = IDET
              IF (NETW(L, 3) == 0) RETURN
            ELSE IF (NDIM == 3) THEN
              IF (NETW(L, 3) > 1) THEN
C * GET DETERMINANT
                CALL GEN131 (LHNT, 1, 2, 4, L, IDET)
                IF (IDET > 0 .AND. IDET < NETW(L, 3)) THEN
                  NETW(L, 3) = IDET
                  DO K = 1, 3
                    LHNT(3, K, L) = LHNT(4, K, L)
                  END DO
                  RETURN
                END IF
                CALL GEN131 (LHNT, 1, 3, 4, L, IDET)
                IF (IDET > 0 .AND. IDET < NETW(L, 3)) THEN
                  NETW(L, 3) = IDET
                  DO K = 1, 3
                    LHNT(2, K, L) = LHNT(4, K, L)
                  END DO
                  RETURN
                END IF
                CALL GEN131 (LHNT, 2, 3, 4, L, IDET)
                IF (IDET > 0 .AND. IDET < NETW(L, 3)) THEN
                  NETW(L, 3) = IDET
                  DO K = 1, 3
                    LHNT(1, K, L) = LHNT(4, K, L)
                  END DO
                  RETURN
                END IF
              END IF
              RETURN
            END IF
C * SAVE NEW NETWORK DIMENSION
            NDIM       = NDIM + 1
            NETW(L, 2) = NDIM
C * REDUCE TRANSLATION VECTORS TO SIMPLE FORMS
            IF (NDIM > 1) THEN
   20         DO K = 1, NDIM
                KVEC(K) = 0
                DO I = 1, 3
                  KVEC(K) = KVEC(K) + 10**(3 - I) * LHNT(K, I, L)
                END DO
                N = IABS (KVEC(K))
                IF (N == 1 .OR. N == 10 .OR. N == 100) THEN
                  IF (KVEC(K) < 0) THEN
                    DO M = 1, 3
                    LHNT(K, M, L) = IABS (LHNT(K, M, L))
                    END DO
                    GO TO 20
                  END IF
                END IF
              END DO
              DO I = 1, NDIM
                N = KVEC(I)
                IF (N == 1) THEN
                  K = 3
                ELSE IF (N == 10) THEN
                  K = 2
                ELSE IF (N == 100) THEN
                  K = 1
                ELSE
                  CYCLE
                END IF
                DO J = 1, NDIM
                  IF (J /= I) THEN
                    IF (LHNT(J, K, L) /= 0) THEN
                      LHNT(J, K, L) = 0
                      GO TO 20
                    END IF
                  END IF
                END DO
              END DO
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (':: Resd', I3, ' - Infinite (Type', I1, ') 1D-Chain   ',
     1 ' - Base Vector: [', 3I3, ']')
99998 FORMAT (':: Resd', I3, ' - Infinite (Type', I1, ') 2D-Network ',
     1 ':: Base Vectors', ':', 2(' #', I1, ' = [', 3I3, '], '),
     2 ' - Plane: (', 3I3, ')')
99997 FORMAT (':: Resd', I3, ' - Infinite (Type', I1, ') 3D-Framework'
     1 , ' :: Det =', I2, ', Base Vectors: ', 3(' #', I1,
     2 ' =[', 3I3, '], '))
99996 FORMAT (/, ':: Maximum number of Polymeric Residues Exceeded')
99995 FORMAT (/, ':: Starred ARUs belong (chemically) to the ',
     1           'previous ARU and',
     2           ' Hashed  ARUs are also in Translation')
99994 FORMAT (':: Resd', I3, ' - Infinite (Type', I1, ') 2D-Network')
99993 FORMAT (':: Resd', I3, ' - Infinite (Type', I1, ') 3D-Framework',
     1 ': Det =', I2)
99992 FORMAT (/, ':: Analysis of Covalent/Coordination ',
     1              '(Type1) Polymeric Structure(s)')
99991 FORMAT (/, ':: Analysis of Short Contact Cluster ',
     1              '(Type2) Network Structure(s)')
99990 FORMAT (/, ':: Analysis of H-Bonded Aggregate ',
     1              '(Type3) Network Structure(s)')
99989 FORMAT (1X)
99988 FORMAT (':: Base Vectors: ', 3(I5, ' : ', 3I3, ' , '))
99987 FORMAT (A)
99986 FORMAT (':: Base Vectors: ', 2(I5, ' : [', 3I3, '], '),
     3   ' Plane: (', 3I3, ')')
99985 FORMAT ('Problem in PLA094: MD4 =', I10, 2X, '(Ignored)')
      END SUBROUTINE PLA094
 
      SUBROUTINE PLA095 (NRING, NHEAD, MODE)
C * CREMER & POPLE, JACS, 97, 1354 (1975)
C * SUBROUTINE DERIVED FROM THE PROGRAM PUCK (J.C.A.BOEYENS)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER         :: NP5 = 250
      INTEGER                    :: I
      INTEGER                    :: J
      INTEGER                    :: K
      INTEGER                    :: L
      INTEGER                    :: M
      INTEGER                    :: N
      INTEGER                    :: N2
      INTEGER                    :: I1
      INTEGER                    :: I2
      INTEGER                    :: I3
      INTEGER                    :: I4
      INTEGER                    :: II
      INTEGER                    :: J2
      INTEGER                    :: J5
      INTEGER                    :: IE
      INTEGER                    :: IP
      INTEGER                    :: JJ
      INTEGER                    :: KK
      INTEGER                    :: NC
      INTEGER                    :: KRC
      INTEGER                    :: KKK
      INTEGER                    :: KTH
      INTEGER                    :: II1
      INTEGER                    :: II2
      INTEGER                    :: IER
      INTEGER                    :: IFT
      INTEGER                    :: I68
      INTEGER                    :: IC2
      INTEGER                    :: IBP
      INTEGER                    :: ISD
      INTEGER                    :: KBQ
      INTEGER                    :: NBQ
      INTEGER                    :: NO1
      INTEGER                    :: NRJ
      INTEGER                    :: NTH
      INTEGER                    :: NSP2
      INTEGER                    :: NSP3
      INTEGER                    :: NRNG
      INTEGER                    :: NRD2
      INTEGER                    :: NRD3
      INTEGER                    :: NRAT
      INTEGER                    :: NBND
      INTEGER                    :: NADD
      INTEGER                    :: KBAV
      INTEGER                    :: ION2
      INTEGER                    :: ION5
      INTEGER                    :: IHAT
      INTEGER                    :: IHYB
      INTEGER                    :: IBP1
      INTEGER                    :: IBP2
      INTEGER                    :: IANG
      INTEGER                    :: IDUM
      INTEGER                    :: JDUM
      INTEGER                    :: MODE
      INTEGER                    :: KTAU
      INTEGER                    :: NMAX
      INTEGER                    :: NHAT
      INTEGER                    :: NDEC
      INTEGER                    :: NCARB
      INTEGER                    :: KTAUE
      INTEGER                    :: KYUNK
      INTEGER                    :: KBAVE
      INTEGER                    :: ITAUM
      INTEGER                    :: ITRA0
      INTEGER                    :: ITRA1
      INTEGER                    :: ITRA2
      INTEGER                    :: ISUGL
      INTEGER                    :: ISUGR
      INTEGER                    :: ISANG
      INTEGER                    :: IPPAR
      INTEGER                    :: IBPAR
      INTEGER                    :: NRING
      INTEGER                    :: NHEAD
      INTEGER, DIMENSION(NP5)    :: NQ
      INTEGER, DIMENSION(NP5)    :: KQ
      INTEGER, DIMENSION(NP5)    :: KZP
      INTEGER, DIMENSION(NP5)    :: KTRA
      INTEGER, DIMENSION(NP5)    :: KPHI
      INTEGER, DIMENSION(NP5)    :: NPHI
      INTEGER, DIMENSION(NP5)    :: KRBO
      INTEGER, DIMENSION(NP5)    :: NTRA
      INTEGER, DIMENSION(NP5)    :: NRBO
      INTEGER, DIMENSION(NP5)    :: NRANG
      INTEGER, DIMENSION(NP5)    :: KDCSV
      INTEGER, DIMENSION(NP5)    :: KDCSB
      INTEGER, DIMENSION(NP5)    :: KDC2V
      INTEGER, DIMENSION(NP5)    :: KDC2B
      INTEGER, DIMENSION(NP5)    :: KRANG
      REAL                       :: A
      REAL                       :: D
      REAL                       :: BQ
      REAL                       :: CQ
      REAL                       :: QC
      REAL                       :: QS
      REAL                       :: TH
      REAL                       :: SX
      REAL                       :: SQ
      REAL                       :: SD
      REAL                       :: SBQ
      REAL                       :: SWT
      REAL                       :: QQN
      REAL                       :: QN2
      REAL                       :: AAZ
      REAL                       :: ANG
      REAL                       :: BAV
      REAL                       :: WBO
      REAL                       :: TAU
      REAL                       :: STH
      REAL                       :: SANG
      REAL                       :: TAUK
      REAL                       :: TAUM
      REAL                       :: TRA0
      REAL                       :: TRA1
      REAL                       :: TRA2
      REAL                       :: QQN2
      REAL                       :: PPAR
      REAL                       :: COSF
      REAL                       :: ATRA
      REAL                       :: DIFF
      REAL                       :: BAVK
      REAL                       :: CSTH
      REAL                       :: WTAU
      REAL                       :: YUNK
      REAL                       :: SZP0
      REAL                       :: SZP2
      REAL                       :: SRBO
      REAL                       :: SNTH
      REAL                       :: SINF
      REAL                       :: SIGJ
      REAL                       :: STWT
      REAL                       :: RMXMN
      REAL                       :: RBOMN
      REAL                       :: RBOMX
      REAL                       :: SIGAK
      REAL                       :: SIGBK
      REAL                       :: SINNF
      REAL                       :: SPPAR
      REAL                       :: SRANG
      REAL                       :: STAUM
      REAL                       :: STRA0
      REAL                       :: STRA1
      REAL                       :: STRA2
      REAL                       :: YUNK1
      REAL                       :: ZP0M2
      REAL                       :: Z0P2S
      REAL                       :: Z0M2S
      REAL                       :: ZP0P2
      REAL                       :: T0M2S
      REAL                       :: T0P2S
      REAL                       :: T1M2S
      REAL                       :: T1P2S
      REAL                       :: COSNF
      REAL                       :: ATERM
      REAL                       :: BTERM
      REAL                       :: BAVDIF
      REAL                       :: BAVEXP
      REAL                       :: SMSIGJ
      REAL,    DIMENSION(NP5)    :: Q
      REAL,    DIMENSION(NP5)    :: ZP
      REAL,    DIMENSION(NP5)    :: FC2
      REAL,    DIMENSION(NP5)    :: PHI
      REAL,    DIMENSION(NP5)    :: SSQ
      REAL,    DIMENSION(NP5)    :: TRA
      REAL,    DIMENSION(NP5)    :: RBO
      REAL,    DIMENSION(NP5)    :: FCS
      REAL,    DIMENSION(NP5)    :: HFCS
      REAL,    DIMENSION(NP5)    :: HFC2
      REAL,    DIMENSION(3)      :: XYZD
      REAL,    DIMENSION(NP5)    :: SPHI
      REAL,    DIMENSION(NP5)    :: DCSV
      REAL,    DIMENSION(NP5)    :: DCSB
      REAL,    DIMENSION(NP5)    :: DC2V
      REAL,    DIMENSION(NP5)    :: DC2B
      REAL,    DIMENSION(NP5)    :: STRA
      REAL,    DIMENSION(NP5, 4) :: XYZR
      REAL,    DIMENSION(NP5)    :: RANG
      REAL,    DIMENSION(NP5)    :: HDCSV
      REAL,    DIMENSION(NP5)    :: HDC2V
      REAL,    DIMENSION(NP5)    :: HDCSB
      REAL,    DIMENSION(NP5)    :: HDC2B
      REAL,    DIMENSION(3)      :: XYZDD
      CHARACTER(len=2)           :: KDES
      CHARACTER(len=5)           :: TXT1
      CHARACTER(len=5)           :: TXT2
      CHARACTER(len=1)           :: ACONF
      CHARACTER(len=158)         :: FORMA
      CHARACTER(len=158)         :: FORMB
      CHARACTER(len=158)         :: FORMC
      CHARACTER(len=158)         :: FORMD
      CHARACTER(len=158)         :: FORME
      CHARACTER(len=158)         :: FORMF
      CHARACTER(len=158)         :: FORMG
      CHARACTER(len=158)         :: FORMH
      CHARACTER(len=56)          :: FORMI
      CHARACTER(len=73)          :: FORMK
      CHARACTER(len=37)          :: FORML
      CHARACTER(len=106)         :: FORMP
      CHARACTER(len=63)          :: FORMQ
      CHARACTER(len=54)          :: FORMX
      CHARACTER(len=3)           :: CHYB
      IF (MODE /= 0) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT
      END IF
      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 (A) from CPplane'',      '
      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.'')'
C * RECALCULATE LSPL THROUGH RING WITH ESD'S.
      CALL PLA055
      KRC = NMAX + IPR(64) + 1
C * ??? STORE POINTER TO LSPL-DATA IN IATP(KRC)
      IATP(KRC) = NRING
      DO 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
      END DO
C * LOOK FOR / ANALYSE FURANOSE RING
      ISUGR  = 0
      IF (NRAT == 5) THEN
        DO J = 1, NRAT
          CALL GEN048 (-4, IFG(1, JR(J)), 15, JDUM)
          JDUM = IEN(JDUM + 1)
          IF (JDUM == 2) THEN
            ISUGR = ISUGR + 1
          ELSE IF (JDUM == 3) THEN
            ISUGR = ISUGR + 100
          END IF
        END DO
        IF (ISUGR == 104) THEN
          KYUNK = 0
          ISUGL = 2
          DO
            ISUGL = ISUGL - 1
            IF (ISUGL < 0) THEN
              ISUGR = 0
              EXIT
            END IF
            IC2  = 0
            ION2 = 0
            J2   = JR(2)
            NC   = - NINT (CON(J2, 9))
            IF (NC < 0) NC = 9
            IF (NC <= 3) THEN
              ISUGR = 0
              EXIT
            END IF
            DO K = 1, NC
              M = NINT (CON(J2, K))
              IF (M /= JR(1) .AND. M /= JR(3)) THEN
                CALL GEN048 (-4, IFG(1, M), 15, JDUM)
                JDUM = IEN(JDUM + 1)
                IF (JDUM == 3 .OR. JDUM == 4) THEN
                  ION2 = 1
                END IF
                IF (JDUM == 2) IC2 = 1
              END IF
            END DO
            ION5 = 0
            J5   = JR(5)
            NC = - NINT (CON(J5, 9))
            IF (NC < 0) NC = 9
            IF (NC <= 3) THEN
              ISUGR = 0
              EXIT
            END IF
            DO K = 1, NC
              M = NINT (CON(J5, K))
              IF (M /= JR(1) .AND. M /= JR(4)) THEN
                CALL GEN048 (-4, IFG(1, M), 15, JDUM)
                JDUM = IEN(JDUM + 1)
                IF (JDUM == 3 .OR. JDUM == 4) ION5 = 1
                IF (JDUM == 2) THEN
C * DETERMINE D/L CONFIGURATIE
                  ACONF = 'L'
                  CALL PLA053 (M, JR(5), JR(1), JR(2),
     1                ANG, SANG, ISANG, NDEC, IER)
                  IF (IER == 0 .AND. ANG > 0.0) ACONF = 'D'
                END IF
              END IF
            END DO
            IF (ION5 == 1) THEN
              CALL GEN014 (JR(2), JR(5))
              CALL GEN014 (JR(3), JR(4))
              CYCLE
            END IF
            IF (KYUNK == 0) EXIT
          END DO
        END IF
      END IF
      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 J = 1, NRAT
        I    = JR(J)
C * COUNT # CARBON ATOMS IN RING
        CALL GEN048 (-4, IFG(1, I), 15, JDUM)
        IF (IEN(JDUM + 1) == 2) THEN
          NCARB = NCARB + 1
C * COUNT # H's ON RING
          NC = - NINT (CON(I, 9))
          IF (NC < 0) NC = 9
          DO K = 1, NC
            M = NINT (CON(I, K))
            CALL GEN048 (-1, IFG(1, M), 7, IHAT)
            NHAT = NHAT + IHAT
          END DO
        END IF
        NRJ = NRAT + J
C * CALCULATE RING BOND DISTANCES,ANGLES AND TORSION ANGLES
        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 /= 0) GO TO 10
        IF (SRBO <= 0.0) THEN
          WBO = 1.0
        ELSE
          WBO = 1.0 / SRBO**2
        END IF
        RBOMX = MAX (RBOMX, RBO(J))
        RBOMN = MIN (RBOMN, RBO(J))
        BAV   = BAV  + WBO * RBO(J)
        BAVK  = BAVK + WBO * RBO(J)**2
        SWT   = SWT  + WBO
C * SKIP SPECIAL DISORDER CASES
        CALL PLA053 (I1, I2, I3, 0, RANG(J), SRANG, KRANG(J),
     1               NRANG(J), IER)
        IF (IER /= 0) GO TO 10
        CALL PLA053 (I1, I2, I3, I4, TRA(J), STRA(J), KTRA(J),
     1               NTRA(J), IER)
        IF (IER /= 0) GO TO 10
        IF (STRA(J) <= 0) THEN
          WTAU  = 1.0
        ELSE
          WTAU  = 1.0 / STRA(J)**2
        END IF
        ATRA = ABS (TRA(J))
        IF (ATRA > 90.0) ATRA = ABS (180.0 - ATRA)
        TAU  = TAU  + WTAU * ATRA
        TAUK = TAUK + WTAU * ATRA**2
        STWT = STWT + WTAU
        IP   = JR(J)
        SIGJ = 0.0
        DO 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)
        END DO
        XYZR(J, 4) = SIGJ / 3
        SMSIGJ     = SMSIGJ + SIGJ / 3
      END DO
      IF (NHEAD == 0 .AND. IGBL(63) > 3) THEN
        NHEAD = 1
        CALL PLA262 (-54)
        WRITE (LU7, 99970, IOSTAT = IOST)
        NRNG = IPR(496)
        IF (MOD (NRNG, 100) > 0) WRITE (LU7, 99969, IOSTAT = IOST)
        NRNG = NRNG / 100
        IF (MOD (NRNG, 100) > 0) WRITE (LU7, 99968, IOSTAT = IOST)
        NRNG = NRNG / 100
        IF (MOD (NRNG, 100) > 0) WRITE (LU7, 99967, IOSTAT = IOST)
        NRNG = NRNG / 100
        IF (NRNG > 0)
     1    WRITE (LU7, 99966, IOSTAT = IOST) '<', '>', '>', '>',
     2      '>', '>'
        WRITE (LU7, 99965, IOSTAT = IOST)
        WRITE (LU7, 99964, IOSTAT = IOST)
        WRITE (LU7, 99982, IOSTAT = IOST)
      END IF
      DO 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
      END DO
C * STORE COORDINATES ALSO IN BACKING STORE 'VOID'
      DO K = 1, 6
        VOID((KRC - 1) * NP71 + K)     = XXO(KRC, K)
        VOID((KRC - 1) * NP71 + K + 6) = XSD(KRC, K)
      END DO
      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 J = 1, NRAT
        DO K = 1, 3
          XYZR(J, K) = XYZR(J, K) - XXO(KRC, K + 3)
        END DO
        XYZR(J, 4) = XYZR(J, 4) + SMSIGJ
        SINF       = SIN (RGBL(5) * (J - 1) / NRAT)
        COSF       = COS (RGBL(5) * (J - 1) / NRAT)
        DO L = 1, 3
          XYZD(L)  = XYZD(L)  + XYZR(J, L) * SINF
          XYZDD(L) = XYZDD(L) + XYZR(J, L) * COSF
        END DO
      END DO
C * ESD CREMER & POPLE PLANE NORMAL APPROXIMATED WITH LS-PLANE ESD
      CALL GEN008 (XYZD, XYZDD, XPV, 1)
      IE  = 0
      BQ  = 0.0
      SBQ = 0.0
      DO J = 1, NRAT
        ZP(J) = XPV(1) * XYZR(J, 1) + XPV(2) * XYZR(J, 2)
     1        + XPV(3) * XYZR(J, 3)
        IF (ABS (ZP(J)) < 1.0E-15) ZP(J) = 0.0
        BQ    = BQ  + ZP(J)**2
        SBQ   = SBQ + ZP(J)**2 * XYZR(J, 4)
      END DO
      BQ  = SQRT (BQ)
      IF (BQ > 0.0) SBQ = SQRT (SBQ) / BQ
      DO 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 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
          SZP0  = SQRT (XYZR(ITRA0, 4))
          SZP2  = SQRT (XYZR(ITRA2, 4))
          T1P2S = (TRA1 + TRA2)**2
          T1M2S = (TRA1 - TRA2)**2
          T0P2S = (TRA0 + TRA2)**2
          T0M2S = (TRA0 - TRA2)**2
          ZP0P2 = ABS (ZP(ITRA0) + ZP(ITRA2))
          ZP0M2 = ABS (ZP(ITRA0) - ZP(ITRA2))
          IF (ZP0P2 < 1.0E-15) THEN
            Z0P2S = 0.0
          ELSE
            Z0P2S = ZP0P2**2
          END IF
          IF (ZP0M2 < 1.0E-15) THEN
            Z0M2S = 0.0
          ELSE
            Z0M2S = ZP0M2**2
          END IF
          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 <= 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)
          END IF
        END DO
        IF (DCSV(J) < 1E-5) THEN
          HDCSV(J) = 0
        ELSE
          HDCSV(J) = SQRT (ABS (HDCSV(J)) / (NRD2 * DCSV(J)))
        END IF
        DCSV(J) = SQRT (ABS (DCSV(J)) / NRD2)
        IF (DC2V(J) < 1E-5) THEN
          HDC2V(J) = 0
        ELSE
          HDC2V(J) = SQRT (ABS (HDC2V(J)) / (NRD2 * DC2V(J)))
        END IF
        DC2V(J)  = SQRT (ABS (DC2V(J)) / NRD2)
        IF (DCSB(J) < 1E-5) THEN
          HDCSB(J) = 0
        ELSE
          HDCSB(J) = SQRT (ABS (HDCSB(J)) / (NRD3 * DCSB(J)))
        END IF
        DCSB(J) = SQRT (ABS (DCSB(J)) / NRD3)
        IF (FCS(J) < 1E-5) THEN
          HFCS(J) = 0.0
        ELSE
          HFCS(J) = SQRT (ABS (HFCS(J)) / (NRD3 * FCS(J)))
        END IF
        FCS(J) = SQRT (ABS (FCS(J)) / NRD3)
        IF (FC2(J) < 1E-5) THEN
          HFC2(J) = 0.0
        ELSE
          HFC2(J) = SQRT (ABS (HFC2(J)) / (NRD3 * FC2(J)))
        END IF
        FC2(J) = SQRT (ABS (FC2(J)) / NRD3)
        IF (DC2B(J) < 1E-5) THEN
          HDC2B(J) = 0.0
        ELSE
          HDC2B(J) = SQRT (ABS (HDC2B(J)) / (NRD3 * DC2B(J)))
        END IF
        DC2B(J) = SQRT (ABS (DC2B(J)) / NRD3)
      END DO
      NSP2 = 0
      NSP3 = 0
      II1  = -7
      DO
        II1  = II1 + 8
        II2  = II1 + 7
        IF (II2 > NRAT) II2 = NRAT
        JJ = 0
        DO II = II1, II2
          JJ = JJ + 1
          IP = JR(II)
          CALL PLA047 (LABA(IP), NQ1, IDUM, JDUM, IPR(71),
     1      IGBL(55), 0, 1 - IGBL(55))
          NAMS(JJ, 1) = ' '//NQ1(1:NP64 - 1)
          CALL GEN048 (-4, IFG(1, IP), 24, IHYB)
          IF (IHYB == 1) THEN
            CHYB = 'sp'
          ELSE IF (IHYB == 2) THEN
            CHYB = 'sp2'
            NSP2 = NSP2 + 1
          ELSE IF (IHYB == 3) THEN
            CHYB = 'sp3'
            NSP3 = NSP3 + 1
          ELSE
            CHYB = ' '
          END IF
          NAMS(JJ, 2) = CHYB
        END DO
        IF (II1 /= 1) THEN
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (5)
            WRITE (LU7, 99996, IOSTAT = IOST)
     1      (NAMS(II, 1)(2:7), II = 1, JJ)
            WRITE (LU7, 99971, IOSTAT = IOST)
            WRITE (LU7, 99962, IOSTAT = IOST)
     1        (NAMS(II, 2)(1:3), II = 1, JJ)
          END IF
        ELSE
          IF (IGBL(63) > 2) THEN
C * NEWPAGE
            CALL PLA262 (-4)
            IF (ISUGR == 104) THEN
              CALL PLA262 (1)
              IF (IC2 == 1) THEN
                WRITE (LU7, 99991, IOSTAT = IOST)
              ELSE
                WRITE (LU7, 99990, IOSTAT = IOST)
              END IF
            END IF
            WRITE (PRBUF, 99997, IOSTAT = IOST) NRAT, IPR(19) + NRING,
     1        (NAMS(II, 1)(2:7), II = 1, JJ)
            WRITE (LU7, 99961, IOSTAT = IOST) PRBUF
            IF (MODE /= 0) THEN
              VRT = VRT - 0.7
              CALL PLA439 (0.0, PRBUF, 132, 0.3, 5 + IGBL(68), 2, 0.1,
     1          VRT)
            END IF
            WRITE (LU7, 99971, IOSTAT = IOST)
            WRITE (PRBUF, 99962, IOSTAT = IOST)
     1        (NAMS(II, 2)(1:3), II = 1, JJ)
            WRITE (LU7, 99961, IOSTAT = IOST) PRBUF
            IF (MODE /= 0) THEN
              VRT = VRT - 0.9
              CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
            END IF
          END IF
        END IF
        IF (IGBL(63) > 2) THEN
C * ROUND DEV, CS & C2 ARRAYS ON THE BASIS OF ESD
          IFT = 18
          I68 = IPR(68)
          DO 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))
          END DO
          WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1      (ZP(II),   KZP(II),   II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1      (DCSV(II), KDCSV(II), II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (PRBUF, FORMC, IOSTAT = IOST)
     1      (DC2V(II), KDC2V(II), II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (PRBUF, FORMD, IOSTAT = IOST)
     1      (RANG(II), KRANG(II), II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (LU7, 99974, IOSTAT = IOST)
          WRITE (PRBUF, FORME, IOSTAT = IOST)
     1      (TRA(II),  KTRA(II),  II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.9
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (PRBUF, FORMF, IOSTAT = IOST)
     1      (DCSB(II), KDCSB(II), II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (PRBUF, FORMG, IOSTAT = IOST)
     1      (DC2B(II), KDC2B(II), II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
          WRITE (PRBUF, FORMH, IOSTAT = IOST)
     1      (RBO(II),  KRBO(II),  II = II1, II2)
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
        END IF
        IF (II2 >= NRAT) EXIT
      END DO
      M = (NRAT - 1) / 2
C * TEST FOR CARBON 6-RING
      IF (NRAT == 6 .AND. NCARB == 6) THEN
        IF (NSP2 == 6) THEN
          IF (NHAT > 4) THEN
            NADD   = 0
            BAVEXP = 1.395
            DIFF   = 0.005
          ELSE
            NADD   = 3
            BAVEXP = 1.410
            DIFF   = 0.01
          END IF
          IF (TAU < 5.0) THEN
            BAVDIF = BAV - BAVEXP
            IF (BAVDIF > DIFF) THEN
              IF (NADD == 3) BAVDIF = -999.0
C * ALERT _330 + : Large Average Phenyl C-C
              CALL PLA236 (330 + NADD, 2, BAVDIF, BAV,
     1               NAMS(1, 1) (2:8), NAMS(6, 1) (2:8))
            ELSE IF (BAVDIF < - DIFF) THEN
C * ALERT _331 + : Small Average Phenyl C-C
              CALL PLA236 (331 + NADD, 2, - BAVDIF, BAV,
     1               NAMS(1, 1) (2:8), NAMS(6, 1) (2:8))
            END IF
          END IF
          IF (TAU < 12.0) THEN
            YUNK  = RBOMX - RBOMN
            YUNK1 = YUNK
            IF (NADD == 3) YUNK = -999.0
            IF (YUNK1 > 0.15) THEN
C * ALERT _332 +
              CALL PLA236 (332 + NADD, 2, YUNK, YUNK1,
     1          NAMS(1, 1) (2:8), NAMS(6, 1) (2:8))
            END IF
          END IF
        ELSE IF (NSP3 == 6) THEN
C * ALERT _338
          CALL PLA236 (338, 2, 60.0 - TAU, TAU, NAMS(1, 1)(2:8),
     1       NAMS(6, 1)(2:8))
        END IF
      END IF
      IF (IGBL(63) > 2) THEN
        CALL PLA262 (5)
        WRITE (LU7, 99974, IOSTAT = IOST)
        WRITE (PRBUF, 99960, IOSTAT = IOST) BAV, KBAV, KBAVE
        WRITE (LU7, 99961, IOSTAT = IOST) PRBUF
        IF (MODE /= 0) THEN
          VRT = VRT - 0.9
          CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        END IF
        WRITE (PRBUF, 99959, IOSTAT = IOST) TAU, KTAU, KTAUE
        WRITE (LU7, 99961, IOSTAT = IOST) PRBUF
        IF (MODE /= 0) THEN
          VRT = VRT - 0.7
          CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        END IF
        WRITE (LU7, 99974, IOSTAT = IOST)
        IF (NRAT == 4) THEN
          CALL PLA053 (JR(1), JR(2), JR(4), JR(3), TRA(5), STRA(5),
     1        KTRA(5), NTRA(5), IER)
          IF (IER == 0) THEN
            FORMQ(43:43) = CHAR (ICHAR ('0') + NTRA(5))
            WRITE (PRBUF, FORMQ, IOSTAT = IOST)
     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 PLA263 (LU7, PRBUF, 132, 1, 1)
          END IF
          CALL PLA053 (JR(2), JR(3), JR(1), JR(4), TRA(6), STRA(6),
     1                 KTRA(6), NTRA(6), IER)
          IF (IER == 0) THEN
            FORMQ(43:43) = CHAR (ICHAR ('0') + NTRA(6))
            WRITE (PRBUF, FORMQ, IOSTAT = IOST)
     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 PLA263 (LU7, PRBUF, 132, 1, 1)
          END IF
          WRITE (LU7, 99974, IOSTAT = IOST)
        END IF
      END IF
C * PUCKERING ANALYSIS FOR RINGS WITH <TAU> > PAR(95) DEGREES
C *                              DISTANCE VARIATION < PAR(328) %
      RMXMN = 100.0 * ABS (RBOMX - RBOMN) / BAV
      IF (TAU > PAR(95)) THEN
        IF (IGBL(63) > 2) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99992, IOSTAT = IOST)
        END IF
        IF (NRAT / 2 > M) IE = 1
        IF (M > 1) THEN
          DO N = 2, M
            QS    = 0.0
            QC    = 0.0
            SQ    = 0.0
            CQ    = 0.0
            ATERM = 0
            BTERM = 0
            SIGAK = 0
            SIGBK = 0
            DO J = 1, NRAT
              COSNF = COS (RGBL(5) * N * (J - 1) / NRAT)
              SINNF = SIN (RGBL(5) * 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 == 5) THEN
                ATERM = ATERM + TRA(J) * COSNF
                BTERM = BTERM + TRA(J) * SINNF
                SIGAK = SIGAK + (STRA(J) * COSNF)**2
                SIGBK = SIGBK + (STRA(J) * SINNF)**2
              END IF
            END DO
            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) > 0.0001) THEN
              SNTH = QS / Q(N)
              CSTH = QC / Q(N)
              IF (CSTH >= 0) THEN
                PHI(N) = ASIN (SNTH) * RGBL(6)
                IF (PHI(N) < 0) PHI(N) = PHI(N) + 360.0
              ELSE
                PHI(N) = ACOS (CSTH) * RGBL(6)
                IF (SNTH < 0) PHI(N) = 360.0 - PHI(N)
              END IF
              SSQ(N)  = SQRT (ABS(CQ * CSTH**2 + SQ * SNTH**2))
              SPHI(N) = SQRT (ABS(CQ * SNTH**2
     1                + SQ * CSTH**2)) * RGBL(6) / Q(N)
            END IF
            IF (IGBL(63) > 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 < 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'
              END IF
              FORMK(20:20) = CHAR (ICHAR('0') + NQ(N))
              FORMK(57:57) = CHAR (ICHAR('0') + NPHI(N))
              WRITE (PRBUF, FORMK, IOSTAT = IOST)
     1          N, QQN , KQ(N), N, PHI(N), KPHI(N)
              CALL PLA263 (LU7, PRBUF, 132, 1, 1)
              IF (MODE /= 0) THEN
                VRT = VRT - 0.9
                CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
              END IF
            END IF
          END DO
        END IF
        IF (IE == 1) THEN
          N2    = NRAT / 2
          Q(N2) = 0.0
          QN2   = 0
          DO J = 1, NRAT
            Q(N2) = (-1)**(J - 1) * ZP(J) + Q(N2)
            QN2   = QN2 + XYZR(J, 4)
          END DO
          SSQ(N2) = SQRT (ABS (QN2 / NRAT))
          Q(N2)   = Q(N2) * SQRT (1.0 / NRAT)
          IF (IGBL(63) > 2) THEN
            QQN2 = Q(N2)
            CALL GEN041 (QQN2, SSQ(N2), KQ(N2), 4, NQ(N2), IPR(68))
            IF (N2 < 10) THEN
              FORML(8:8)   = '1'
              FORML(18:18) = '9'
            ELSE
              FORML(8:8)   = '2'
              FORML(18:18) = '8'
            END IF
            FORML(20:20) = CHAR (ICHAR ('0') + NQ(N2))
            WRITE (PRBUF, FORML, IOSTAT = IOST) N2, QQN2, KQ(N2)
            CALL PLA263 (LU7, PRBUF, 132, 1, 1)
            IF (MODE /= 0) THEN
              VRT = VRT - 0.7
              CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
            END IF
          END IF
          AAZ = Q(N2)
        ELSE
          AAZ = 0
        END IF
C * OUTPUT TOTAL PUCKERING AMPLITUDE
        IF (NRAT > 6 .AND. IGBL(63) > 2) THEN
          WRITE (LU7, 99974, IOSTAT = IOST)
          CALL GEN041 (BQ, SBQ, KBQ, 4, NBQ, IPR(68))
          FORMX(37:37) = CHAR (ICHAR ('0') + NBQ)
          WRITE (PRBUF, FORMX, IOSTAT = IOST) BQ, KBQ
          CALL PLA263 (LU7, PRBUF, 132, 1, 1)
          IF (MODE /= 0) THEN
            VRT = VRT - 1.0
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
        END IF
        IF (RMXMN > PAR(328) .AND. IGBL(63) > 2) THEN
          CALL PLA262 (4)
          WRITE (LU7, 99994, IOSTAT = IOST) RMXMN, PAR(328)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          END IF
        END IF
        IF (NRAT == 8) THEN
            IF (IGBL(63) > 3) THEN
              CALL PLA262 (4)
              WRITE (LU7, 99979, IOSTAT = IOST)
            END IF
C * CALCULATE SPECIAL SIX-MEMBERED RING DESCRIPTORS Q, THETA, PHI
        ELSE IF (NRAT == 6) THEN
          IF (BQ > PAR(12)) THEN
            CSTH = Q(N2) / BQ
          ELSE
            CSTH = 0.0
          END IF
          IF (CSTH >  1.0) CSTH =  1.0
          IF (CSTH < -1.0) CSTH = -1.0
          TH  = ACOS (CSTH) * RGBL(6)
          IF (BQ > PAR(12)) THEN
            STH = SQRT (ABS ((SSQ(2)**2 - SSQ(3)**2)
     1          * CSTH**2 + SSQ(3)**2)) * RGBL(6) / BQ
          ELSE
            STH = 0.0
          END IF
          IF (IGBL(63) > 2) THEN
            CALL GEN041 (TH, STH, KTH, 2, NTH, IPR(68))
            CALL GEN041 (BQ, SBQ, KBQ, 4, NBQ, IPR(68))
            CALL PLA262 (1)
            WRITE (LU7, 99974, IOSTAT = IOST)
            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, IOSTAT = IOST)
     1        BQ, KBQ, TH, KTH, PHI(2), KPHI(2)
            CALL PLA263 (LU7, PRBUF, 132, 1, 1)
            IF (MODE /= 0) THEN
              VRT = VRT - 0.9
              CALL PLA439 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
            END IF
            IF (IGBL(63) > 3) THEN
              CALL PLA262 (5)
              WRITE (LU7, 99981, IOSTAT = IOST)
            END IF
          END IF
C * CALCULATE SPECIAL 5-MEMBERED RING DESCRIPTORS
        ELSE IF (NRAT == 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  * RGBL(6)
          SPPAR = SPPAR * RGBL(6)
          IPPAR = MIN (999, NINT (SPPAR * 10.0))
          ITAUM = MIN (999, NINT (STAUM * 10.0))
          IP    = JR(1)
C * TEST WHETHER AT1 IS AN OXYGEN ATOM, IF SO ADD 2 * 144 DEG TO P
          CALL GEN048 (-4, IFG(1, IP), 15, NO1)
          IF (IEN(NO1 + 1) == 3) THEN
            PPAR = PPAR + 288.0
            KK = 3
          ELSE
            KK = 1
          END IF
          IF (IGBL(63) > 3) THEN
            CALL PLA262 (5)
            WRITE (LU7, 99980, IOSTAT = IOST)
          END IF
          PPAR = MOD (PPAR + 360.0, 360.0)
          IF (IGBL(63) > 2) THEN
            WRITE (LU7, 99999, IOSTAT = IOST)
            WRITE (PRBUF, 99998, IOSTAT = IOST) PPAR, IPPAR, TAUM,
     1        ITAUM, NAMS(KK, 1)(2:7), NAMS(KK + 1, 1)(2:7)
            CALL GEN065 (LU7, PRBUF, 1, 132, 1)
            WRITE (LU7, 99983, IOSTAT = IOST)
            PRBUF = ' '
            WRITE (LU7, 99958)
            WRITE (PRBUF, 99989, IOSTAT = IOST) 2.0 * PPAR, 2 * IPPAR
            CALL GEN065 (LU7, PRBUF, 1, 132, 1)
            CALL PLA262 (7)
C * PSEUDOROTATION PUCKER DESCRIPTOR FOR FURANOSE RING
            IF (ISUGR == 104 .AND. ION2 == 1) THEN
              CALL PLA262(5)
              WRITE (LU7, 99988, IOSTAT = IOST)
              IBPAR = MOD (NINT (PPAR / 18.0), 20)
              IF (MOD(IBPAR, 2) == 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) == 0) THEN
                  TXT1 = '-endo'
                  TXT2 = '-exo '
                END IF
                WRITE (LU7, 99987, IOSTAT = IOST)
     1            NAMS(IBP1, 1)(2:7), TXT1, NAMS(IBP2, 1)(2:7), TXT2,
     2            ACONF
              ELSE
                IBP = (IBPAR - 1) / 2 + 3
                IBP1 = MOD (IBP, 5) + 1
                TXT1 = '-endo'
                IF (MOD (IBP, 2) == 0) TXT1 = '-exo '
                WRITE (LU7, 99986, IOSTAT = IOST)
     1            NAMS(IBP1, 1)(2:7), TXT1, ACONF
              END IF
            ELSE
              IBPAR = MOD (NINT (PHI(2) / 18.0), 20)
              CALL PLA262 (3)
C * TWIST
              IF (MOD(IBPAR, 2) == 1) THEN
                IBP = (IBPAR / 2)
                IBP1 = MOD (IBP,     5) + 1
                IBP2 = MOD (IBP + 1, 5) + 1
                WRITE (LU7, 99985, IOSTAT = IOST) NAMS(IBP1, 1)(2:7),
     1                             NAMS(IBP2, 1)(2:7)
C * ENVELOPE
              ELSE
                IBPAR = IBPAR / 2
                IBP1 = MOD (IBPAR, 5) + 1
                WRITE (LU7, 99984, IOSTAT = IOST) NAMS(IBP1, 1)(2:7)
              END IF
            END IF
            WRITE (LU7, 99974, IOSTAT = IOST)
          END IF
        END IF
C * Evans & Boeyens CONFORMATIONAL ANALYSIS
        IF (IGBL(63) > 2) CALL PLA218 (Q, PHI, AAZ, NRAT, LU7)
      ELSE
        IF (TAU < PAR(95) .AND.
     1      IGBL(63) > 2)  THEN
          CALL PLA262 (3)
          WRITE (LU7, 99974, IOSTAT = IOST)
          WRITE (PRBUF, 99995, IOSTAT = IOST) TAU, PAR(95)
          WRITE (LU7, 99961, IOSTAT = IOST) PRBUF
          WRITE (LU7, 99974, IOSTAT = IOST)
          IF (MODE /= 0) THEN
            VRT = VRT - 0.9
            CALL PLA439 (0.0, PRBUF, 132, 0.3, 2, 1, 0.1, VRT)
          END IF
        END IF
      END IF
C * PLANAR TEST
      IF (TAU < PAR(96)) CALL PLA035
      IF (IPR(2) /= 0) IPR(2) = 0
C * SIGNIFICANT (5&6-RING)-PUCKER TEST
      IF (NRAT == 6 .AND. TAU > PAR(97) .OR.
     1    NRAT == 5 .AND. TAU > PAR(94)) THEN
        NBND = 0
C * ANALYSE RING-SUBSTITUENT GEOMETRY
        NHAT = 0
        DO L = 1, 2
          DO I = 1, NRAT
            J  = JR(I)
            NC = - NINT (CON(J, 9))
            IF (NC < 0) NC = 9
            CALL PLA047 (LABA(J), NQ1, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 1 - IGBL(55))
            DO K = 1, NC
              M = NINT (CON(J, K))
              N = I + NRAT - 2
              IF (M /= JR(MOD (I, NRAT) + 1) .AND.
     1            M /= JR(MOD (N, NRAT) + 1)) THEN
                CALL GEN048 (-1, IFG(1, M), 7, IHAT)
                IF (L + IHAT /= 2) THEN
                  NHAT = NHAT + IHAT
                  CALL PLA047 (LABA(M), NQ2, IDUM, JDUM, IPR(71),
     1              IGBL(55), 0, 1 - IGBL(55))
                  CALL PLA053 (J, M, 0, 0, D, SD, ISD, NDEC, IER)
                  IF (IER == 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 > 1.0) ANG = 1.0
                    IANG = 0
                    ANG  = ACOS (ANG) * RGBL(6)
                    A    = 0
                    IF (D /= 0.0) THEN
                      DO KKK = 1, 3
                        A = A + XSPV(KKK)**2 + (VECN(KKK) * SD / D)**2
                      END DO
                      A = RGBL(6) * SQRT (A)
                    END IF
                    CALL GEN041 (ANG, A, IANG, 2, NDEC, IPR(68))
                    FORMI(39:39) = CHAR (ICHAR ('0') + NDEC)
                    KDES = 'Bi'
                    IF (ANG > 60) KDES = 'Eq'
                    IF (ANG < 30) KDES = 'Ax'
                    NBND = NBND + 1
                    IF (IGBL(63) > 2) THEN
                      IF (NBND == 1) THEN
                        CALL PLA262 (4)
                        WRITE (LU7, 99972, IOSTAT = IOST)
                      END IF
                      IF (NHAT == 1) THEN
                        CALL PLA262 (1)
                        WRITE (LU7, 99974, IOSTAT = IOST)
                      END IF
                      WRITE (PRBUF, FORMI, IOSTAT = IOST)
     1                  NQ1(1:7), NQ2(1:7), D, ISD, ANG, IANG, KDES
                      CALL PLA263 (LU7, PRBUF, 132, 1, 1)
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END DO
        END DO
      END IF
   10 IF (MODE /= 0) THEN
        CALL GGIP (0.0, 0.0, 0.0, 3)
C * WHAT NEXT ?
        CALL PLA012 (1, 1)
      END IF
      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 <Tau> =', 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, '(', I3, ') 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 (AT2).',
     5 /, 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,
     1 '- C&P Analysis is with reference to the Cremer-Pople plane,',
     2 ' not to be confused with the associated LS-plane.', /, 15X,
     3 'See H.Essen & D.Cremer (1984) Acta Cryst. B40, 418-420.',
     4 //, 13X, 'For Correct Usage of C&P Puckering Parameters see ',
     5 'also: D. Cremer (1984) Acta Cryst. B40, 498-500.', /)
99981 FORMAT (//, '* NOTE * ',
     1 '- A Change of the Absolute Configuration Transforms Theta',
     2 ' into 180 - Theta and Phi into 180 + Phi.', /, 9X,
     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 /, 9X,
     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).', /, 9X,
     3 '- A Cyclic Forward Shift of the Pivot Atom from At1 to At2',
     4 ' Transforms Phi(2) into Phi(2) + 144.', /, 9X,
     5 '- A Change of the Sense Transforms Phi(2) into 180 - Phi(2).')
99979 FORMAT (/, '* NOTE * ',
     1 '- A Cyclic Forward Shift of the Pivot Atom from At1 to At2',
     2 ' Transforms Q(4) into - Q(4), Phi(2) into Phi(2) + 90 and', /,
     3 11X, 'Phi(3) into Phi(3) + 135')
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')
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.')
99958 FORMAT (1X)
      END SUBROUTINE PLA095
 
      SUBROUTINE PLA096 (MODE, XNQ, D, NCI)
C * VALENCE BOND ANALYSIS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER,                      PARAMETER :: NP50 = 100
      INTEGER,                      PARAMETER :: NP51 = 100
      INTEGER                                 :: I
      INTEGER                                 :: J
      INTEGER                                 :: K
      INTEGER                                 :: L
      INTEGER                                 :: M
      INTEGER                                 :: N
      INTEGER                                 :: NB
      INTEGER                                 :: NE
      INTEGER                                 :: NT
      INTEGER                                 :: NTV
      INTEGER                                 :: IGN
      INTEGER                                 :: IAT
      INTEGER                                 :: NCI
      INTEGER                                 :: IVL
      INTEGER, SAVE                           :: MAT
      INTEGER, SAVE                           :: NVL
      INTEGER, SAVE                           :: NAT
      INTEGER                                 :: NSUM
      INTEGER                                 :: IMET
      INTEGER                                 :: IVAL
      INTEGER                                 :: MODE
      INTEGER                                 :: NDUB
      INTEGER, SAVE                           :: ISKP
      INTEGER, SAVE                           :: JSKP
      INTEGER                                 :: IVLMX
      INTEGER                                 :: IHTEST
      INTEGER                                 :: IATPRP
      INTEGER, SAVE,          DIMENSION(NP51) :: NVAL
      REAL                                    :: B
      REAL                                    :: D
      REAL                                    :: R
      REAL                                    :: BV
      REAL                                    :: DMX
      REAL                                    :: DIF
      REAL, SAVE                              :: SUMX
      REAL                                    :: VSUM
      REAL                                    :: DIFM
      REAL                                    :: DMAX
      REAL                                    :: CRIT
      REAL, SAVE,             DIMENSION(NP50) :: DIST
      CHARACTER(len=25)                       :: SOURCE
      CHARACTER(len=8)                        :: XNQ
      CHARACTER(len=7)                        :: MQ
      CHARACTER(len=7), SAVE                  :: MQ1
      CHARACTER(len=2), SAVE                  :: MQ3
      CHARACTER(len=2), SAVE                  :: MQ4
      CHARACTER(len=2), SAVE, DIMENSION(9)    :: VL
      CHARACTER(len=7), SAVE, DIMENSION(NP50) :: MQ2
      CHARACTER(len=7), SAVE, DIMENSION(NP51) :: MQ5
C * MODE =  0 : INITIALIZE
C *         1 : STORE CONTACT
C *        -1 : ANALYSE & REPORT
      NB   = 0
      NE   = 0
      NSUM = 0
      VSUM = 0.0
      MQ   = XNQ(2:7)
      CRIT = PAR(454)
C * CHECK FOR COORDINATION MODE (IPR(57) = 0)
      IF (IPR(57) == 0) THEN
C * INITIALISE (GENERAL OR PER-ATOM)
        NSUM = 0
        IF (MODE == 0) THEN
C * GENERAL INIT
          IF (D < 0.0) THEN
            NAT         = 0
            SUMX        = 0.0
            NB          = 0
            NE          = 0
            JSKP        = 0
            T112        = ' '
C * CHECK FOR BOND-VALENCE-ANAL AND NO DISORDER OF NON-H ATOMS
            IF (IGBL(121) > 0) THEN
              ISKP = 0
            ELSE
              ISKP = 1
              IF (JSKP == 0) JSKP = 1
            END IF
C * PER-ATOM INIT
          ELSE
            IAT = NINT (D)
            CALL GEN048 (-1, IFG(1, IAT), 19, IMET)
            CALL GEN048 (-4, IFG(1, IAT), 15, IVAL)
            IATPRP = IATPR(IEN(IVAL + 1))
C * INCLUDE METAL + Te
            IF ((IGBL(121) > 0 .OR.
     1        ((IMET > 0 .OR. IEN(IVAL + 1) == 92) .AND.
     2          IATPRP /= 5 .AND. IATPRP /= 6))
     3        .AND. XNQ(1:1) == ' ') THEN
              ISKP = 0
            ELSE
              ISKP = 1
              IF (JSKP == 0) JSKP = 2
            END IF
            IF (NAT < NP51) THEN
              NAT      = NAT + 1
              MQ1      = MQ
              MQ5(NAT) = MQ
              MAT      = 0
C * DETERMINE WHETHER THIS IS A 1 OR 2 LETTER ATOM TYPE
              CALL GEN105 (2, MQ(2:2), N)
              IF (N < 0) THEN
                MQ3 = MQ(1:1)
              ELSE
                MQ3 = MQ(1:2)
              END IF
C * COLLECT LIST OF VALENCES FOR THIS ELEMENT
              NVL   = 0
              IVLMX = 9
              DO 10 J = 1, NP53
                IF (VALENCE(J)(1:2) == MQ3) THEN
                  IF (NVL == 0) THEN
                    NVL   = 1
                    VL(1) = ' '//VALENCE(J)(3:3)
                  ELSE
                    IF (' '//VALENCE(J)(3:3) /= VL(NVL)) THEN
                      NVL     = NVL + 1
                      VL(NVL) = ' '//VALENCE(J)(3:3)
                    END IF
                  END IF
                ELSE IF (VALENCE(J)(4:5) == MQ3) THEN
                  IF (NVL == 0) THEN
                    NVL   = 1
                    VL(1) = VALENCE(J)(6:7)
                  ELSE
                    DO I = 1, NVL
                      IF (VALENCE(J)(6:7) == VL(I)) GO TO 10
                    END DO
                    NVL     = NVL + 1
                    VL(NVL) = VALENCE(J)(6:7)
                  END IF
                END IF
C * CHECK FOR ORGANIC (LIMIT MAXIMUM ALLOWED VALENCY)
                IF (IPR(325) >= 0 .AND. NVL > 0) THEN
                  READ (VL(NVL), 99995) IVL
                  DO I = 1, NP9
                    IF (MQ3 == ELB(I)) THEN
                      IVLMX = IVALMAX(I)
                      EXIT
                    END IF
                  END DO
                  IF (IVL > IVLMX .OR. IVL < 0) NVL = NVL - 1
                END IF
   10         CONTINUE
            END IF
          END IF
C * STORE CONTACTS (MODE = 1)
        ELSE IF (MODE == 1 .AND. ISKP == 0) THEN
          IF (XNQ(1:1) == ' ') THEN
            IF (MAT < NP50) THEN
              MAT       = MAT + 1
              MQ2(MAT)  = MQ
              DIST(MAT) = D
            END IF
          ELSE
C * IGNORE DISORDERED H-ATOMS
            IF (XNQ(2:3) /= 'H(' .AND. D < 3.5) THEN
              ISKP = 1
              IF (JSKP == 0) JSKP = 3
            END IF
          END IF
C * ANALYSE & REPORT (MODE = -1)
        ELSE IF (MODE == -1) THEN
          IF (ISKP == 0) THEN
            DIFM = 10.0
            DIF  = 10.0
C * LOOP OVER VALENCIES
            DO K = 1, NVL
              READ (VL(K), 99995) IVL
              IF (IGBL(63) > 2) THEN
                CALL PLA262 (0)
                WRITE (LU7, 99998, IOSTAT = IOST) VL(K), CRIT
                WRITE (LU7, 99996, IOSTAT = IOST)
              END IF
              NDUB = 0
              SUMX = 0.0
              DMX  = 0.0
              L    = 0
              IGN  = 0
              IF (MAT > 0) THEN
                DO  30 I = 1, MAT
                  NTV = 0
                  IF (NAT > 0) THEN
                    DO NT = 1, NAT
                      CALL GEN039 (1, MQ5(NT), 1, 7, NB, NE)
                      IF (MQ2(I)(1:NE) == MQ5(NT)(1:NE))
     1                    NTV = NVAL(NT)
                    END DO
                  END IF
                  CALL GEN105 (2, MQ2(I)(2:2), N)
                  IF (N < 0) THEN
                    MQ4 = MQ2(I)(1:1)
                  ELSE
                    MQ4 = MQ2(I)(1:2)
                  END IF
                  IF (MQ3 == MQ4) THEN
                    IF (MQ3 == 'O ' .OR. MQ3 == 'N ') GO TO 30
                  END IF
                  IF (MQ3 == 'N ' .AND. MQ4 == 'C ') GO TO 30
                  DO J = 1, NP53
C * POSITIVE VALENCE
                    IF (VL(K)(1:1) /= '-') THEN
                      IF (VL(K)(2:2) == VALENCE(J)(3:3)) THEN
                        IF (MQ3 == VALENCE(J)(1:2) .AND.
     1                    MQ4 == VALENCE(J)(4:5)) THEN
                          READ (VALENCE(J), 99997) R, B
                          BV = EXP ((R - DIST(I)) / B)
                          IF (BV > IVL * CRIT) THEN
                            SUMX = SUMX + BV
                            DIF  = ABS (IVL - SUMX)
                            L    = L + 1
                            DMX  = MAX (DMX, DIST(I))
                            IF (IGBL(63) > 2) THEN
                              IF (VALENCE(J)(18:18) == '*') THEN
                                SOURCE = 'PLATON'
                              ELSE
                                SOURCE = ' '
                              END IF
                              WRITE (LU7, 99999, IOSTAT = IOST) L, MQ1,
     1                          MQ2(I), DIST(I), R, B, BV, SUMX, DIF,
     2                          SOURCE
                            END IF
                          ELSE
                            IF (IGBL(63) > 0) THEN
                              WRITE (LU7, 99990, IOSTAT = IOST)
     1                          MQ1, MQ2(I), DIST(I), BV, IVL * CRIT
                            END IF
                          END IF
                          GO TO 30
                        END IF
                      END IF
C * NEGATIVE VALENCE
                    ELSE
                      IF (VL(K) == VALENCE(J)(6:7)) THEN
                        IF (MQ3 == VALENCE(J)(4:5) .AND.
     1                      MQ4 == VALENCE(J)(1:2)) THEN
                          IF (NTV > 0) THEN
                            READ (VALENCE(J)(3:3), 99994) M
                            IF (M /= NTV) CYCLE
                          END IF
                          READ (VALENCE(J), 99997) R, B
                          BV  = EXP ((R - DIST(I)) / B)
                          IF (BV > IABS (NTV) * CRIT) THEN
                            SUMX = SUMX + BV
                            DIF  = ABS (IABS (IVL) - SUMX)
                            L    = L + 1
                            DMX  = MAX (DMX, DIST(I))
C * CONTIBUTION TO VALENCE SUMX
                            IF (IGBL(63) > 2) THEN
                              WRITE (LU7, 99999, IOSTAT = IOST) L, MQ1,
     1                          MQ2(I), DIST(I), R, B, BV, SUMX, DIF
                            END IF
                          ELSE
C * CONTRIBUTION BELOW MINIMUM
                            IF (IGBL(63) > 2) THEN
                              WRITE (LU7, 99990, IOSTAT = IOST) MQ1,
     1                          MQ2(I), DIST(I), BV, IABS (NTV) * CRIT
                            END IF
                          END IF
                          EXIT
                        END IF
                      END IF
                    END IF
                  END DO
C * CONTRIBUTION NOT TABULATED
                  IF (IGBL(63) > 2) THEN
                    WRITE (LU7, 99991, IOSTAT = IOST)
     1                MQ1, MQ2(I), DIST(I)
                  END IF
C * CHECK FOR ABSENT DATA (DUBIOUS RESULT)
                  IHTEST = 0
                  IF (MQ2(I)(1:1) == 'H') THEN
C * SEARCH FOR LOWER CASE CHAR
                    CALL GEN105 (2, MQ2(I)(2:2), IHTEST)
                  END IF
                  IF (IHTEST < 0) THEN
                    IF (DIST(I) < 1.0) NDUB = NDUB + 1
                  ELSE
                    IF (I <= NCI) NDUB = NDUB + 1
                    IF (DIST(I) < 2.4) NDUB = NDUB + 1
                  END IF
   30           CONTINUE
                IF (NDUB == 0 .AND. DIF < DIFM .AND. IGN == 0)
     1            THEN
                  NVAL(NAT) = IVL
                  DIFM      = DIF
                  VSUM      = SUMX
                  NSUM      = L
                  DMAX      = DMX
                END IF
              END IF
            END DO
C * END OF LOOP OVER VALENCES
            IF (VSUM > 0.0 .AND. NSUM > 0 .AND.
     1          DIFM < 1.0) THEN
              N = NVAL(NAT)
              IF (N < 1 .OR. N > 9) N = 10
              MQ1 = VALENCES(N)
              IF (MQ5(NAT)(1:2) /= 'Cu' .OR. NSUM /= 4) THEN
                WRITE (T112(1:75), 99993, IOSTAT = IOST)
     1            MQ5(NAT), MQ1, VSUM, DMAX, NSUM
                IF (LU6 /= 0) THEN
                  WRITE (LU6, 99992, IOSTAT = IOST) T112(1:75)
                  T112(76:76) = CHAR (0)
                END IF
                IF (IGBL(63) > 2) THEN
                  WRITE (LU7, 99992, IOSTAT = IOST) T112(1:75)
                END IF
C * ALERT _794
                CALL PLA236 (794, 2, -999.0, VSUM, MQ5(NAT), MQ1)
              END IF
            END IF
            CALL PLA262 (0)
          ELSE
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (I2, 2X, 2A, F10.4, F7.4, F5.2, 3F6.3, ' - ', A)
99998 FORMAT ('Bond Valence Analysis - Assume Valence = ', A,
     1        ' -- Min. BondVal Contribution = ', F5.2,
     2        ' * Cation Val.', /, 100('='), /,
     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 - Source')
99995 FORMAT (I2)
99994 FORMAT (I1)
99993 FORMAT (2A, ' Vsum =', F6.2, ', Dmax =', F8.4, ', Nsum =', I3)
99992 FORMAT (/, ':: ', A)
99991 FORMAT (4X, 2A, F10.4, 33X,
     1       '(Contribution not Tabulated, Result Dubious !)')
99990 FORMAT (4X, 2A, F10.4, 33X, '(Contribution =', F6.3,
     1       'Below Minimum =', F6.3, ', Skipped)')
      END SUBROUTINE PLA096
 
      SUBROUTINE PLA097 (MODE, ARU)
C * TRANSLATE ARU TO SYMMETRY
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: ML
      INTEGER :: MODE
      INTEGER :: MOL1
      INTEGER :: MOL2
      INTEGER :: MOL3
      INTEGER :: MOL4
      INTEGER :: IRS0
      INTEGER :: NEWARU
      REAL    :: ARU
      IF (MODE == 0) THEN
        IPR(25) = 0
      ELSE IF (MODE > 0) THEN
        IF (IPR(13) + IPR(25) + 2 < NP11) THEN
          NEWARU = NINT (ARU * PAR(42))
          IF (IPR(25) > 0) THEN
            DO I = 1, IPR(25)
              IF (NEWARU == MOL(IPR(13) + I)) RETURN
            END DO
          END IF
          IPR(25) = IPR(25) + 1
          MOL(IPR(25) + IPR(13)) = NEWARU
        END IF
C * TRANSLATE ARU TO SYMMETRY CODE
      ELSE IF (MODE < 0) THEN
        IF (IPR(25) > 0) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99998, IOSTAT = IOST)
          DO I = 1, IPR(25)
            ML = MOL(IPR(13) + I)
            CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRS0)
            SGY(4) = MOL2
            SGY(5) = MOL3
            SGY(6) = MOL4
            CALL SGSM (20, ICL, SGY, MOL1, 0, IERR)
            ML = INT (ML / PAR(42))
            CALL PLA262 (1)
            WRITE (LU7, 99999, IOSTAT = IOST) ML, ICL(1:30)
          END DO
        END IF
      END IF
      RETURN
99999 FORMAT ('[', I6, '] = ', A)
99998 FORMAT (1X)
      END SUBROUTINE PLA097
 
      SUBROUTINE PLA098 (N1, N2, KB, DIS, SDIS, DIFF, IDS12, MODE)
C * CALCULATE AVERAGE BOND DISTANCES (+ BP)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: N
      INTEGER                :: N3
      INTEGER                :: I0
      INTEGER                :: J0
      INTEGER                :: M1
      INTEGER                :: M2
      INTEGER                :: N1
      INTEGER                :: N2
      INTEGER                :: KB
      INTEGER                :: NC
      INTEGER                :: IM
      INTEGER                :: MSP
      INTEGER                :: N10
      INTEGER                :: N20
      INTEGER                :: NOA
      INTEGER                :: NOB
      INTEGER                :: NO1
      INTEGER                :: NO2
      INTEGER                :: NO3
      INTEGER                :: INR
      INTEGER                :: NBH
      INTEGER                :: NC1
      INTEGER                :: NC2
      INTEGER                :: NO12
      INTEGER                :: NDIS
      INTEGER                :: IFIN
      INTEGER                :: IAT1
      INTEGER                :: IAT2
      INTEGER                :: IEN1
      INTEGER                :: IEN2
      INTEGER                :: IDUM
      INTEGER                :: JDUM
      INTEGER                :: MODE
      INTEGER                :: IBPR
      INTEGER                :: IDMJ
      INTEGER                :: NROXY
      INTEGER                :: IEN12
      INTEGER                :: IHYB1
      INTEGER                :: IHYB2
      INTEGER                :: IDS12
      INTEGER                :: GEN152
      INTEGER, DIMENSION(71) :: KSM
      REAL                   :: DIS
      REAL                   :: SDIS
      REAL                   :: TDIS
      REAL                   :: DIFF
      REAL                   :: SUMR
      REAL                   :: DIST
      REAL                   :: RATIO
      REAL                   :: BNDPX
      CHARACTER              :: NOTE
      CHARACTER              :: HYB1
      CHARACTER              :: HYB2
      CHARACTER(len=8)       :: BNDPR
      TDIS  = 0.0
      BNDPX = 0.0
      IDUM  = 0
      JDUM  = 0
C * ASSEMBLE BOND LENGTH STATISTICS
      IF (MODE > 0) THEN
        N10 = N1
        N20 = N2
C * STORE BOND FOR AVERAGE
        CALL GEN048 (-4, IFG(1, N1), 24, IHYB1)
        CALL GEN048 (-4, IFG(1, N2), 24, IHYB2)
        CALL GEN048 (-4, IFG(1, N1), 15, NO1)
        CALL GEN048 (-4, IFG(1, N2), 15, NO2)
        IF (IHYB1 == 0) IHYB2 = 0
        IF (IHYB2 == 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 < IAT2) THEN
          CALL GEN014 (NOA,   NOB)
          CALL GEN014 (IEN1, IEN2)
          CALL GEN014 (IAT1, IAT2)
          CALL GEN014 (N10,   N20)
        END IF
C * TEST SELECTED BONDS
        CALL PLA047 (LABA(N10), NQ1, IDUM, JDUM,
     1    IPR(71), IGBL(55), 0, 1 - IGBL(55))
        CALL PLA047 (LABA(N20), NQ2, IDUM, JDUM,
     1    IPR(71), IGBL(55), 0, 1 - IGBL(55))
        IF (IAT2 == 6) THEN
          IF (IAT1 == 17) THEN
C * ALERT _336
            CALL PLA236 (336, 3, DIS - 1.85,  DIS, NQ2(1:7), NQ1(1:7))
          END IF
        END IF
        IF (IAT2 > 1) IPR(315) = IPR(315) + 1
        IF (IDS12 /= 20000) RETURN
        IEN12 = IEN1 * 1000 + IEN2
        IF (IHYB1 < IHYB2) CALL GEN014 (IHYB1, IHYB2)
        INR = 0
C * ALERT _350, _351 : RANGE CHECK C - H (XRAY/NEUTRON)
        IF (IEN12 == 2001) THEN
          IF (IABS (IPR(493)) == 7) THEN
            TDIS = 1.08
          ELSE
            TDIS = 0.96
          END IF
          INR  = 350
C * ALERT _356 - BOND (RANGE) CHECK B - H
        ELSE IF (IEN12 == 20001) THEN
          NC1 =  - NINT (CON (N1, 9))
          NC2 =  - NINT (CON (N2, 9))
          IF (NC1 == 4 .AND. NC2 == 1) THEN
            NBH = 0
            DO I = 1, NC1
              N3 = NINT (CON(N1, I))
              CALL GEN048 (-4, IFG(1, N3), 15, NO3)
              IF (IEN(NO3 + 1) == 1) NBH = NBH + 1
            END DO
C * X-BH3 - ALERTS _356, _357
            IF (NBH == 3) THEN
              TDIS = 1.16
              INR  = 356
C * (X,Y,Z)-B-H - ALERTS _358, _359
            ELSE IF (NBH == 1) THEN
              TDIS = 1.06
              INR  = 358
            ELSE
              INR = 0
            END IF
          END IF
C * RANGE CHECK N - H (XRAY)
        ELSE IF (IEN12 == 4001) THEN
          NC =  - NINT(CON (N2, 9))
C * AVOID ACID BRIDGES N..H ..X
          IF (NC == 1) THEN
            IF (IABS (IPR(493)) == 7) THEN
              TDIS = 1.009
            ELSE
              TDIS = 0.87
            END IF
            INR  = 352
          END IF
C * RANGE CHECK O - H (XRAY)
        ELSE IF (IEN12 == 3001) THEN
          NC =  - NINT(CON (N2, 9))
C * AVOID ACID BRIDGES O..H..O
          IF (NC == 1) THEN
            IF (IABS (IPR(493)) == 7) THEN
              TDIS = 0.983
            ELSE
              TDIS = 0.82
            ENDIF
            INR  = 354
          END IF
C * RANGE CHECK C - C (XRAY)
        ELSE IF (IEN12 == 2002) THEN
C * BOND PRECISION
          IF (SDIS > 0.0001) THEN
            IPR(317) = IPR(317) + 1
            PAR(318) = PAR(318) + SDIS
          END IF
          IF (IPR(483) > 0 .AND. IPR(484) > 0) THEN
            IF (IHYB1 == 3) THEN
C * C(sp3)-C(sp3)
              IF (IHYB2 == 3) THEN
                TDIS = 1.54
                INR  = 360
C * C(sp3)-C(sp2)
              ELSE IF (IHYB2 == 2) THEN
                TDIS = 1.52
                INR  = 362
C * C(sp3)-C(sp)
              ELSE IF (IHYB2 == 1) THEN
                TDIS = 1.46
                INR  = 364
C * C?-C?
              ELSE
                TDIS = 1.50
                INR  = 366
              END IF
            ELSE IF (IHYB1 == 2) THEN
              IF (IHYB2 == 2) THEN
C * C(sp2)-C(sp2)
                NROXY = 0
C * SPECIAL TREATMENT OXALAAT
                DO I = 1, 3
                  M1 = NINT (CON(N1, I))
                  M2 = NINT (CON(N2, I))
                  CALL GEN048 (-4, IFG(1, M1), 15, K)
                  IF (IEN(K + 1) == 3) NROXY = NROXY + 1
                  CALL GEN048 (-4, IFG(1, M2), 15, K)
                  IF (IEN(K + 1) == 3) NROXY = NROXY + 1
                END DO
                IF (NROXY /= 4) THEN
                  TDIS = 1.34
                  INR  = 368
                END IF
C * C(sp2)-C(sp)
              ELSE IF (IHYB2 == 1) THEN
                TDIS = 1.31
                INR  = 370
                MSP  = 0
C * SPECIAL TREATMENT OF C(sp2)-C(sp)-N
                IF (NINT (CON(N1, 9)) == -2) THEN
                  MSP = NINT (CON(N1, 1))
                ELSE IF (NINT (CON(N2, 9)) == -2) THEN
                  MSP = NINT (CON(N2, 1))
                END IF
                IF (MSP /= 0) THEN
                  CALL GEN048 (-4, IFG(1, MSP), 15, K)
                  IF (IEN(K + 1) == 4) TDIS = 1.44
                END IF
              ELSE
C * C?-C? (sp2)
                TDIS = 1.50
                INR  = 366
              END IF
            ELSE IF (IHYB1 == 1) THEN
C * C(sp)-C(sp)
              IF (IHYB2 == 1) THEN
                TDIS = 1.25
                INR  = 372
              ELSE
C * C(?)-C(?)
                TDIS = 1.50
                INR  = 366
              END IF
            ELSE
C * C(?)-C(?)
              TDIS = 1.50
              INR  = 366
            END IF
          END IF
C * CHECK FOR LONG N-N
        ELSE IF (IEN12 == 4004) THEN
          IF (DIS > 1.45) THEN
C * ALERT _374
            CALL PLA236 (374, 2, DIS - 1.45, DIS, NAMS(KB, 1)(1:7),
     1                   NAMS(KB, 2)(1:7))
          END IF
          INR = 0
        END IF
        IF (INR /= 0) THEN
          DIFF = ABS (DIS - TDIS)
          IF (DIFF > 0.001) THEN
            IF (DIS > TDIS) INR = INR + 1
C * ALERT _3xx
            IF (INR == 367) DIFF = -999.0
            IF (INR == 371 .AND. DIFF > 0.1) DIFF = -999.0
            CALL PLA236 (
     1        INR, 2, DIFF, DIS, NAMS(KB, 1)(1:7), NAMS(KB, 2)(1:7))
          END IF
        END IF
        NO12 = NOA * 1000 + NOB
        IM   = IPR(47)
        IF (IM > 0) THEN
          DO I = 1, IM
            IF (NO12 == KBO(I, 1)) THEN
              IF (KBO(I, 2) == 0) BOK(I, 1) = 9999.0
              KBO(I, 2) = KBO(I, 2) + 1
              BOK(I, 3) = BOK(I, 3) + DIS
              IF (SDIS > 0.0) THEN
                KBO(I, 5) = KBO(I, 5) + 1
                BOK(I, 6) = BOK(I, 6) + SDIS
              END IF
              IF (DIS < BOK(I, 1)) BOK(I, 1) = DIS
              IF (DIS > BOK(I, 2)) BOK(I, 2) = DIS
              RETURN
            END IF
          END DO
        END IF
        IF (IPR(47) < 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 > 0.0) THEN
            KBO(I, 5) = 1
            BOK(I, 6) = SDIS
          END IF
        END IF
      ELSE IF (MODE < 0) THEN
C * GET BOND AVERAGE LISTING
        IF (IPR(6) /= 0) THEN
          IF (IPR(317) > 0) THEN
            PAR(318) = PAR(318) / IPR(317)
            IF (IPR(22) < 20) THEN
              IBPR = 340
            ELSE IF (IPR(22) >= 40) THEN
              IBPR = 342
            ELSE
              IBPR = 341
            END IF
C * ALERT _340, _341, _342
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
            N = GEN152 (PAR(318))
            CALL PLA236 (IBPR, N, PAR(318), PAR(318), ' ', ' ')
          END IF
          IM = IPR(47)
          IF (IGBL(63) > 2) THEN
            CALL PLA262 (-6)
            WRITE (LU7, 99999, IOSTAT = IOST)
          END IF
          DO I = 1, IM
            CALL GEN097 (KSM, 1, 71, 0)
            IPR(133) = -1
            DO
              IPR(133) = IPR(133) + 1
              IF (IPR(133) > 1) EXIT
              IFIN = -1
              DO
                CALL PLA038 (I0, J0, IFIN)
                IF (IFIN == 1) EXIT
                CALL GEN048 (-4, IFG(1, I0), 24, IHYB1)
                CALL GEN048 (-4, IFG(1, J0), 24, IHYB2)
                CALL GEN048 (-4, IFG(1, I0), 15, NO1)
                CALL GEN048 (-4, IFG(1, J0), 15, NO2)
                IF (IHYB1 == 0) IHYB2 = 0
                IF (IHYB2 == 0) IHYB1 = 0
                NOA = NO1 * 10 + IHYB1
                NOB = NO2 * 10 + IHYB2
                IF (IATNR(IEN(NO1 + 1)) < IATNR(IEN(NO2 + 1))) THEN
                  CALL GEN014 (NOA, NOB)
                END IF
                NO12 = NOA * 1000 + NOB
                IF (KBO(I, 1) == NO12) THEN
                  CALL PLA050 (I0, J0, 0, 0, DIST)
                  NDIS      = MIN (71, NINT (DIST * 20 + 1))
                  KSM(NDIS) = KSM(NDIS) + 1
                END IF
              END DO
            END DO
            DO J = 1, 71
              IDMJ = KSM(J)
              IF (IDMJ <= 0) THEN
                IDM(J:J) = '.'
              ELSE IF (IDMJ <= 9) THEN
                IDM(J:J) = CHAR (ICHAR ('0') + IDMJ)
              ELSE IF (IDMJ <= 35) THEN
                IDM(J:J) = CHAR (ICHAR ('Z') - 35 + IDMJ)
              ELSE
                IDM(J:J) = '*'
              END IF
            END DO
            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 /= 0) THEN
              IF (IEN(K) == 2 .OR. IEN(K) == 4)
     1            HYB1 = CHAR (IHYB1 + 49)
              IF (IEN(L) == 2 .OR. IEN(K) == 4)
     1            HYB2 = CHAR (IHYB2 + 49)
            END IF
            SUMR = RADR(K, 2) + RADR(L, 2)
            IF (KBO(I, 2) > 0) BOK(I, 3) = BOK(I, 3) / KBO(I, 2)
            IF (KBO(I, 5) > 0) THEN
              BOK(I, 6) = BOK(I, 6) / KBO(I, 5)
              WRITE (BNDPR, 99995, IOSTAT = IOST) BOK(I, 6)
            ELSE
              CALL GEN038 (BNDPR, 1, 8)
            END IF
            IF (BOK(I, 1) + 0.4 < SUMR .AND. KBO(I, 2) > 0)
     1        THEN
              NOTE = 'S'
            ELSE
              NOTE = ' '
            END IF
C * BOND PRECISION SELECTION
            IF (KBO(I, 5) > 0 .AND. BOK(I, 6) > BNDPX) THEN
              IF (LMT(L, 1) /= ' H' .AND. LMT(L, 1) /= ' D' .AND.
     1            LMT(L, 1) /= 'Hw') THEN
                BNDTP(1) = LMT(K, 1)//'-'//LMT(L, 1)
                BNDPX    = BOK(I, 6)
              END IF
            END IF
            IF (IGBL(63) > 2) THEN
              CALL PLA262 (2)
              WRITE (LU7, 99998, IOSTAT = IOST)
     1          LMT(K, 1), HYB1, LMT(L, 1), HYB2, KBO(I, 2), BNDPR,
     2          (BOK(I, J), J = 1, 3), SUMR, NOTE, IDM(1:71)
            END IF
          END DO
          IF (PAR(318) > 0) THEN
            BNDTP(1) = '  C-C'
          ELSE
            PAR(318) = BNDPX
          END IF
          IF (IGBL(63) > 3) THEN
            CALL PLA262 (22)
            WRITE (LU7, 99997, IOSTAT = IOST)
            WRITE (LU7, 99996, IOSTAT = IOST)
          END IF
        END IF
        IF (IPR(315) /= 0) THEN
          RATIO = FLOAT (IPR(316)) / FLOAT (IPR(315))
C * ALERT _763
          IF (RATIO < 1.0 .AND. IGBL(8) == 3)
     1      CALL PLA236 (763, 2, 1.0 - RATIO, RATIO, ' ', ' ')
C * ALERT _764
          IF (RATIO > 1.1)
     1      CALL PLA236 (764, 2, -999.0, RATIO, ' ', ' ')
        END IF
      ELSE
C * INITIALIZE (MODE = 0)
        IPR(47)  = 0
        IPR(317) = 0
        PAR(318) = 0
        DO I = 1, NP8
          DO J = 1, 5
            KBO(I, J) = 0
          END DO
          DO J = 1, 6
            BOK(I, J) = 0.0
          END DO
        END DO
      END IF
      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 (F8.4)
      END SUBROUTINE PLA098
 
      SUBROUTINE PLA099 (MODE, IAT, NANG, ANG1, ANG2, ANG3, NOTE1)
C * GET ATOM CHARACTERISTICS (HYBRIDYSATION ETC.)
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: K1
      INTEGER          :: NC
      INTEGER          :: IAT
      INTEGER          :: JAT
      INTEGER          :: KAT
      INTEGER          :: NAT
      INTEGER          :: NO1
      INTEGER          :: NO2
      INTEGER          :: NC0
      INTEGER          :: IHAT
      INTEGER          :: IHYB
      INTEGER          :: MSKP
      INTEGER          :: MODE
      INTEGER          :: NANG
      INTEGER          :: IMET
      INTEGER          :: NMET
      INTEGER          :: NHAT
      INTEGER          :: NATX
      INTEGER          :: IVL1
      INTEGER          :: IVAL
      INTEGER          :: NATH
      INTEGER          :: JUNK
      INTEGER          :: NCEFF
      INTEGER          :: NBOBO
      INTEGER          :: ISHCN
      INTEGER          :: IPPIAT
      INTEGER          :: IPPJAT
      INTEGER          :: IPPKAT
      INTEGER          :: JATPART
      INTEGER          :: KATPART
      REAL             :: ANG
      REAL             :: EFNC
      REAL             :: ENCH
      REAL             :: DIS0
      REAL             :: DISM
      REAL             :: DIST
      REAL             :: ANG1
      REAL             :: ANG2
      REAL             :: ANG3
      CHARACTER(len=1) :: NOTE1
C * MODE = 0 - MAJOR DISORDER RUN
C * MODE = 1 - FULL RUN
      CALL GEN048 (-1, IFG(1, IAT), 19, IMET)
      NMET = 0
C * GET NUMBER OF PRIMARY ATOMS
      NATX = IPR(37)
C * GET NUMBER OF ATOMS IN EXPANDED ATOM LIST
      NAT  = IPR(39)
C * GET ELEMENT TYPE
      CALL GEN048 (-4, IFG(1, IAT), 15, NO1)
      NO1 = NO1 + 1
C * GET POPULATION PARAMETER ATOM I
      CALL GEN048 (-8, IFG(2, IAT), 1, IPPIAT)
      IPPIAT = IPPR(IPPIAT + 1, 1)
C * GET # OF CONNECTIONS TO ATOM
      NC = - NINT (CON(IAT, 9))
      IF (NC < 0) THEN
        NC = 9
        CALL GEN048 (-1, IFG(1, IAT), 8, IVAL)
        IF (IVAL > 0) NC = NC + IPR(76)
      END IF
      MSKP  = 0
   10 NANG  = 0
      ANG3  = 0.0
      ANG2  = 0.0
      EFNC  = 0.0
      ENCH  = 0.0
      DISM  = 99.0
      ISHCN = 0
      NHAT  = 0
      IF (NC > 0) THEN
        ANG1 = 9999.0
        NMET = 0
C * LOOP OVER NC CONNECTIONS TO ATOM IAT
        DO J = 1, NC
          IF (J <= 9) THEN
            JAT = NINT (CON(IAT, J))
          ELSE
            IF (IBON(J - 9, 1) /= IAT) CYCLE
            JAT = IBON(J - 9, 2)
          END IF
          CALL GEN048 (-5, IFG(3, JAT), 14, JATPART)
          JATPART = JATPART - 16
          CALL GEN048 (-1, IFG(1, JAT), 7, IHAT)
          NHAT = NHAT + IHAT
C * CHECK FOR CARBON
          IF (IEN(NO1) == 2) THEN
C * GET ELEMENT TYPE JAT
            CALL GEN048 (-4, IFG(1, JAT), 15, NO2)
            NO2 = NO2 + 1
C * CHECK FOR NITROGEN
            IF (IEN(NO2) == 4) THEN
              CALL PLA050 (JAT, IAT, 0, 0, DIS0)
              IF (DIS0 < 1.35) ISHCN = 1
            END IF
          END IF
          IF (IHAT == 0) THEN
            CALL PLA050 (JAT, IAT, 0, 0, DIS0)
            DISM = MIN (DISM, DIS0)
          END IF
C * CHECK FOR METAL
          CALL GEN048 (-1, IFG(1, JAT), 19, IVL1)
          IF (MSKP * IVL1 /= 1) THEN
            NMET = NMET + IVL1
C * GET POPULATION PARAMETER
            CALL GEN048 (-8, IFG(2, JAT), 1, IPPJAT)
            IPPJAT = IPPR(IPPJAT + 1, 1)
            IF (IPPJAT == 10000) THEN
              EFNC = EFNC + 1.0
            ELSE
              IF (IPPIAT /= 0) THEN
                EFNC = EFNC + FLOAT (IPPJAT) / FLOAT (IPPIAT)
              END IF
            END IF
C * HANDLE HYDROGEN
            CALL GEN048 (-1, IFG(1, JAT), 7, IHAT)
            IF (IHAT == 1) THEN
              ENCH = ENCH + FLOAT (IPPJAT) / FLOAT (IPPIAT)
            END IF
            IF (J < NC) THEN
              K1 = J + 1
C * JAT-IAT-KAT ANGLE LOOP
              DO K = K1, NC
                IF (K <= 9) THEN
                  KAT = NINT (CON(IAT, K))
                ELSE
                  IF (IBON(K - 9, 1) /= K) CYCLE
                  KAT = IBON(K - 9, 2)
                END IF
                CALL GEN048 (-5, IFG(3, KAT), 14, KATPART)
                KATPART = KATPART - 16
                JUNK = 0
                IF (JATPART == 0 .OR. KATPART == 0) THEN
                  JUNK = 1
                ELSE IF (JATPART == KATPART) THEN
                  JUNK = 1
                END IF
                IF (JUNK == 1) THEN
C * GET POPULATION PARAMETERS
                  CALL GEN048 (-8, IFG(2, KAT), 1, IPPKAT)
                  IPPKAT = IPPR(IPPKAT + 1, 1)
                  IF (IPPJAT > 0 .AND. IPPKAT > 0) THEN
                    IF (IPPJAT == 10000 .OR. IPPJAT == IPPKAT .OR.
     1                MODE == 0) THEN
                      CALL PLA050 (JAT, IAT, KAT, 0, ANG)
                      IF (IEN(NO1) == 2 .AND. IVL1 == 1 .AND.
     1                  ANG <= 85) THEN
                        MSKP = 1
                        GO TO 10
                      END IF
                      NANG = NANG + 1
                      ANG2 = MAX (ANG2, ANG)
                      ANG1 = MIN (ANG1, ANG)
                      ANG3 = ANG3 + ANG
                    END IF
                  END IF
                END IF
              END DO
            END IF
          END IF
        END DO
        IF (NHAT == 0) ISHCN = 0
        IF (NANG > 0) THEN
          ANG3 = ANG3 / NANG
        ELSE
          ANG1 = 0.0
        END IF
      ELSE
        ANG1 = 0.0
      END IF
      IHYB = 0
      IF (MODE == 0) THEN
        NCEFF = NC
      ELSE
        NCEFF = NINT(EFNC + 0.001)
      END IF
C * TEST FOR BORANE
      IF (IEN(NO1) == 20) THEN
        NBOBO = 0
        IF (NC > 0) THEN
          DO J = 1, NC
            IF (J <= 9) THEN
              JAT = NINT (CON(IAT, J))
C * GET ELEMENT TYPE
              CALL GEN048 (-4, IFG(1, JAT), 15, NO2)
              NO2 = NO2 + 1
              IF (IEN(NO2) == 20) NBOBO = NBOBO + 1
              IF (NBOBO == 2) THEN
                CALL GEN048 (1, IFG(2, IAT), 13, 1)
                EXIT
              END IF
            END IF
          END DO
        END IF
      END IF
C * TEST FOR (C, N, SI) HYBRIDISATION (PRINT FOR ASYMMETRIC UNIT ONLY)
      IF (IAT <= NAT) THEN
C * CHECK FOR C & SI
        IF (IEN(NO1) == 2 .OR. IEN(NO1) == 85) THEN
          IF (ANG1 < 35.0) NOTE1 = 'A'
          IF (NCEFF == 4) THEN
            IF (ABS (ANG3 - 108.0) < 2.5) THEN
              IF (NMET == 2) THEN
                IHYB = 2
              ELSE
                IF (ISHCN == 1) NOTE1 = 'H'
                IHYB = 3
              END IF
            END IF
            IF (ANG2 > 125.0 .AND. ANG1 > 61
     1                          .AND. IMET == 0) THEN
              NOTE1    = 'A'
            END IF
C * SP2
          ELSE IF (NCEFF == 3) THEN
            IF (ABS (ANG3 - 120.0) < 4.0) THEN
              IHYB = 2
            END IF
C * SP1
          ELSE IF (NCEFF == 2) THEN
            IF (ABS (ANG3 - 180.0) < 15.0) THEN
              IHYB = 1
            END IF
          ELSE IF (NCEFF == 1) THEN
            IF (MODE == 1 .AND. IAT <= NATX)
     1          IPR(401) = IPR(401) + 1
C * HANDLE TERMINAL C=-N- (TRIPLE BOND)
            IF (IEN(NO1) == 2) THEN
              IF (IEN(NO2) == 4) THEN
                IF (DISM < 1.2) IHYB = 1
                NOTE1 = ' '
              END IF
            ELSE
              NOTE1    = '?'
            END IF
          END IF
          IF (IHYB == 0 .AND. IMET == 0) THEN
            IF (IEN(NO1) == 2) THEN
              IF (MODE == 1 .AND. IAT <= NATX) THEN
                  IF (ABS (NCEFF - EFNC) < 0.002)
     1                IPR(402) = IPR(402) + 1
              END IF
              NOTE1 = '?'
            END IF
          END IF
C * CHECK FOR OXYGEN
        ELSE IF (IEN(NO1) == 3) THEN
          IF (NC == 2) THEN
            IHYB = 3
          ELSE IF (NC == 1) THEN
            CALL PLA050 (NINT (CON(IAT, 1)), IAT, 0, 0, DIST)
            IHYB = 2
          END IF
C * CHECK FOR NITROGEN
        ELSE IF (IEN(NO1) == 4) THEN
          NC0 = NC - NMET
          IF (NC0 == 1) THEN
            CALL PLA050 (NINT (CON(IAT, 1)), IAT, 0, 0, DIST)
            IF (DIST < 1.2) IHYB = 1
          ELSE IF (NC0 == 2 .AND. DISM < 1.35 .AND. DISM > 1.2)
     1      THEN
            IHYB = 2
          ELSE IF (NC0 == 3) THEN
            IF (ABS (ANG3 - 120.0) < 3.0) THEN
C * (CHECK) .AND. DISM < 1.335) IHYB = 2
              IHYB = 2
            ELSE IF (ANG3 < 112) THEN
              IHYB = 3
            END IF
          ELSE IF (NC0 == 4 .AND. ABS (ANG3 - 109.5) < 1.0) THEN
            IHYB = 3
          END IF
C * CHECK FOR P & S
        ELSE IF (IEN(NO1) == 8 .OR. IEN(NO1) == 6) THEN
          IF (NC == 4 .AND. ABS (ANG3 - 109.5) < 1.0) IHYB = 3
        END IF
      END IF
      IF (IAT <= NATX .AND. IHYB == 0) THEN
        IF (ANG1 < 90.0 .AND. ANG1 > 0.1) THEN
          IF (NO1 == 3 .AND. NC == 2) THEN
            NOTE1 = ' '
          ELSE IF (IMET == 0 .AND. NC < 6 .AND.
     1             IEN(NO1) /= 92) THEN
            NOTE1 = 'A'
          END IF
        END IF
      END IF
      NATH = MIN (NINT (ENCH), 7)
      CALL GEN048 (4, IFG(1, IAT), 24, IHYB)
      CALL GEN048 (3, IFG(2, IAT), 24, NATH)
      CALL GEN048 (3, IFG(3, IAT), 25, NHAT)
      CALL GEN048 (4, IFG(3, IAT), 28, NCEFF)
      RETURN
      END SUBROUTINE PLA099
 
      SUBROUTINE PLA100
C * CALCULATE CELL PARAMETERS AND ORTHOGONAL AXIAL SYSTEM
C * REF. SEE DUNITZ, XRAY ANALYSIS ..., P236
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      INTEGER :: N
      INTEGER :: N90
      INTEGER :: MSET
      INTEGER :: NZERO
      INTEGER :: IYUNK
      INTEGER :: IPR293
      INTEGER :: IPR313
      INTEGER :: GEN152
      REAL    :: R
      REAL    :: DET
      REAL    :: XDUM
      REAL    :: YUNK
      REAL    :: YUNK1
      REAL    :: GEN068
      REAL    :: AXISMAX
      REAL    :: AXISMIN
      REAL    :: AXISRAT
C * PAR(101) = A         ; (113) = A*         ; (125) =
C *    (102) = B         ; (114) = B*         ; (126) =
C *    (103) = C         ; (115) = C*         ; (127) =
C *    (104) = ALPHA     ; (116) = COS(ALPHA*); (128) =
C *    (105) = BETA      ; (117) = COS(BETA*) ; (129) = A*A
C *    (106) = GAMMA     ; (118) = COS(GAMMA*); (130) = B*B
C *    (107) = SIG(A)    ; (119) = SIN(ALPHA*); (131) = C*C
C *    (108) = SIG(B)    ; (120) = SIN(BETA*) ; (132) = 2*A*B*COS(GAMMA)
C *    (109) = SIG(C)    ; (121) = SIN(GAMMA*); (133) = 2*A*C*COS(BETA)
C *    (110) = SIG(ALPHA); (122) = SIG(ALFA*) ; (134) = 2*B*C*COS(ALPHA)
C *    (111) = SIG(BETA) ; (123) =
C *    (112) = SIG(GAMMA); (124) =
C * AA  & BB  ARE DIRECT AND RECIPROCAL METRIC FOR COORDINATES CELL
C * RAA & RBB ARE DIRECT AND RECIPROCAL METRIC FOR REFLECTION CELL
C * CHECK FOR PREVIOUS INVOCATION OF THIS ROUTINE
      IF (IPR(786) == 0) THEN
C * NO ATOMS READ YET ?
        IF (IPR(39) == 0) THEN
C * CHECK FOR MAXIMUM ALLOWED RESIDUE NUMBER (ARU = sklm.xx or sklm.y)
          IF (IPR(48) > 48) THEN
            IPR(129) = 9
            PAR(42)  = 10.0
            WRITE (LU6, 99999, IOSTAT = IOST)
          END IF
C * ANGSTROM COORDINATES ? (I.E. NO CELL DATA)
          IF (PAR(101) < 1.1) THEN
            IGBL(52) = 1
            IPR(23)  = 1
            IPR(34)  = 1
            IPR(35)  = 2
            IPR(36)  = 3
            CALL GEN021 (OR, 1.0)
            CALL GEN021 (AA, 1.0)
          ELSE
C * FRACTIONAL COORDINATES : GET SPACE GROUP INFO
            CALL SGSM (-18, ICL, SGY, 0, 0, IERR)
            SPGRNM(1) = ICL(1:26)
            SPGRNM(4) = ICL(15:26)
            IF (IGBL(8) == 3 .AND. IPR(522) == 0) THEN
C * ALERT _123
              IF (SPGRNM(1)(1:1) == ' ')
     1          CALL PLA236 (123, 0, 1.0, 1.0, ' ', ' ')
            END IF
C * GET CRYSTAL SYSTEM
            KRSYST(2) = ICL(27:38)
            LAUEGR    = ICL(39:43)
            CALL GEN020 (-1, KRSYST(2), 1, 12)
            IF (ICL(72:72) == 'C') THEN
              CHSG    = 'Chiral'
C * SET NO INVERT FLAG FOR NON-CENTRO (DEFAULT)
              IPR(33) = 1
            END IF
C * LOWER CASE HANDLING
            CALL GEN020 (-1, SPGRNM(1), 16, 26)
C * ISGNR
            IPR(202) = NINT (SGY(1))
            IPR(241) = NINT (SGY(7))
            IPR(242) = NINT (SGY(8))
C * NSYMP
            IPR(255) = NINT (SGY(4))
C * IBV
            IPR(256) = NINT (SGY(6))
C * ICENTR
            IPR(257) = NINT (SGY(5))
C * LAUE
            IPR(258) = NINT (SGY(3))
C * IKLS
            IPR(259) = NINT (SGY(2))
C * IFLACK
            IPR(137) = NINT (SGY(13))
C * MONOCLINIC SETTING (a/b/c) = (1, 0, 3)
            IPR(783) = NINT (SGY(14))
            IF (ICL(12:12) == 'h') THEN
              PAR(261) = 120.0
            ELSE
              PAR(261) = 90.0
            END IF
          END IF
          IF (PAR(104) == 0.0) PAR(104) = 90.0
          IF (PAR(105) == 0.0) PAR(105) = 90.0
          IF (PAR(106) == 0.0) PAR(106) = PAR(261)
          PAR(13) = 0
          PAR(14) = 0
C * SOLVE TRIGONAL/RHOMBOHEDRAL ISSUE
          IF (INDEX (KRSYST(2), 'trigonal') /= 0) THEN
            IF (ABS (PAR(106) - PAR(105)) < 0.5) THEN
              KRSYST(2) = 'rhombohedral'
            END IF
          END IF
C * TEST IS NOT DONE FOR 'NON-CSD CIF' AND 'CELL-CHECK '
          IF (IGBL(94) == 0 .AND. IPR(522) == 0) THEN
C * TEST SU A-AXIS
            YUNK    = PAR(107) / PAR(101)
            AXISMIN = MIN (PAR(101), PAR(102), PAR(103))
            AXISMAX = MAX (PAR(101), PAR(102), PAR(103))
            AXISRAT = (AXISMAX - AXISMIN) / AXISMIN
            IF (YUNK < 0.000001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _141
              CALL PLA236 (141, 5, YUNK1, PAR(107), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 3, 1.0, PAR(107), '     a ', ' ')
            END IF
C * TRICLINIC CASE
            IF (INDEX (KRSYST(2), 'triclinic') /= 0) THEN
C * TEST SU B-AXIS
              YUNK = PAR(108) / PAR(102)
              IF (YUNK < 0.000001) THEN
                IF (YUNK > 0.0) THEN
                  YUNK1 = -999.0
                ELSE
                  YUNK1 = 1.0
                ENDIF
C * ALERT _142
              CALL PLA236 (142, 5, YUNK1, PAR(108), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 3, 1.0, PAR(108), '     b ', ' ')
            END IF
C * TEST SU C-AXIS
            YUNK = PAR(109) / PAR(103)
            IF (YUNK < 0.000001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _143
              CALL PLA236 (143, 5, YUNK1, PAR(109), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 3, 1.0, PAR(109), '     c ', ' ')
            END IF
C * TEST FOR EQUAL CELL AXES SU's
            IF (PAR(107) > 0.00001 .AND. AXISRAT > 0.5) THEN
C * ALERT _153
              IF (PAR(107) == PAR(108) .AND. PAR(108) == PAR(109))
     1          THEN
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
                N = GEN152 (PAR(107))
                CALL PLA236 (153, N, -999.0, PAR(107), ' ', ' ')
              END IF
            END IF
C * TEST SU ON ALPHA
            IF (PAR(110) < 0.0005) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _144
              CALL PLA236 (144, 4, YUNK1, PAR(110), ' ', ' ')
            ELSE IF (PAR(110) > 0.05) THEN
C * ALERT _149
              CALL PLA236 (149, 2, PAR(110), PAR(110), ' alpha ', ' ')
            END IF
C * TEST SU ON BETA
            IF (PAR(111) < 0.0005) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _145
              CALL PLA236 (145, 4, YUNK1, PAR(111), ' ', ' ')
            ELSE IF (PAR(111) > 0.05) THEN
C * ALERT _149
              CALL PLA236 (149, 2, PAR(111), PAR(111), '  beta ', ' ')
            END IF
C * TEST SU ON GAMMA
            IF (PAR(112) < 0.0005) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _146
              CALL PLA236 (146, 4, YUNK1, PAR(112), ' ', ' ')
            ELSE IF (PAR(112) > 0.05) THEN
C * ALERT _149
              CALL PLA236 (149, 2, PAR(112), PAR(112), ' gamma ', ' ')
            END IF
C * ALERT _154 - TEST FOR EQUAL CELL ANGLE SU's
            IF (PAR(110) == PAR(111) .AND. PAR(111) == PAR(112))
     1        THEN
              IF (PAR(110) > 0.0) THEN
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
                N = GEN152 (PAR(110))
                CALL PLA236 (154, N, -999.0, PAR(110), ' ', ' ')
              END IF
            END IF
C * ALERT _156
C * MONOCLINIC CASE
          ELSE IF (INDEX (KRSYST(2), 'monoclinic') /= 0) THEN
            IYUNK = INDEX (SPGRNM(3), 'y')
C * CHECK FOR ALL ANGLES EXACTLY 90 DEGREES IN MONOCLINIC
            N90  = 0
            MSET = 0
            IF (PAR(104) /= 90.0) THEN
              N90  = N90 + 1
              MSET = 1
            END IF
            IF (PAR(105) /= 90.0) THEN
              N90  = N90 + 1
              MSET = 2
            END IF
            IF (PAR(106) /= 90.0) THEN
              N90  = N90 + 1
              MSET = 3
            END IF
            IF (N90 == 0) THEN
C * ALERT _181
              CALL PLA236 (181, 0, 1.0, 1.0, ' ', ' ')
              IF (PAR(110) + PAR(111) + PAR(112) == 0.0) THEN
C * ALERT _182
                CALL PLA236 (182, 0, 1.0, 1.0, ' ', ' ')
              END IF
            ELSE IF (N90 == 1) THEN
C * ALERT _159
              IF (IYUNK == 0 .AND. PAR(105) /= 90.0)
     1          CALL PLA236 (159, 0, 1.0, 1.0, ' ', ' ')
            ELSE IF (N90 > 1) THEN
C * ALERT _138 - MORE THAN ONE CELL ANGLE /= 90
              CALL PLA236 (138, 0, 1.0, 1.0, ' ', ' ')
            END IF
C * TEST SU B-AXIS
            YUNK = PAR(108) / PAR(102)
            IF (YUNK < 0.00001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _142
              CALL PLA236 (142, 5, YUNK1, PAR(108), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 4, 1.0, PAR(108), '     b ', ' ')
            END IF
C * TEST SU C-AXIS
            YUNK = PAR(109) / PAR(103)
            IF (YUNK < 0.00001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _143
              CALL PLA236 (143, 5, YUNK1, PAR(109), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 3, 1.0, PAR(109), '     c ', ' ')
            END IF
C * TEST FOR EQUAL CELL AXES SU's
            IF (PAR(107) > 0.00001 .AND. AXISRAT > 0.5) THEN
C * ALERT _153
              IF (PAR(107) == PAR(108) .AND. PAR(108) == PAR(109))
     1          THEN
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
                N = GEN152(PAR(107))
                CALL PLA236 (153, N, -999.0, PAR(107), ' ', ' ')
              END IF
            END IF
            IF (MSET == 1) THEN
C * TEST SU ON ALPHA
              IF (PAR(110) < 0.0005) THEN
                IF (YUNK > 0.0) THEN
                  YUNK1 = -999.0
                ELSE
                  YUNK1 = 1.0
                ENDIF
C * ALERT _145
                CALL PLA236 (145, 4, YUNK1, PAR(110), ' ', ' ')
              ELSE IF (PAR(110) > 0.05) THEN
C * ALERT _149
                CALL PLA236 (149, 2, 1.0, PAR(110), ' alpha ', ' ')
              END IF
            ELSE IF (MSET == 2) THEN
C * TEST SU ON BETA
              IF (PAR(111) < 0.0005) THEN
                IF (YUNK > 0.0) THEN
                  YUNK1 = -999.0
                ELSE
                  YUNK1 = 1.0
                ENDIF
C * ALERT _145
                CALL PLA236 (145, 4, YUNK1, PAR(111), ' ', ' ')
              ELSE IF (PAR(111) > 0.05) THEN
C * ALERT _149
                CALL PLA236 (149, 2, 1.0, PAR(111), '  beta ', ' ')
              END IF
            ELSE IF (MSET == 3) THEN
C * TEST SU ON GAMMA
              IF (PAR(112) < 0.0005) THEN
                IF (YUNK > 0.0) THEN
                  YUNK1 = -999.0
                ELSE
                  YUNK1 = 1.0
                ENDIF
C * ALERT _146
                CALL PLA236 (146, 4, YUNK1, PAR(112), ' ', ' ')
              ELSE IF (PAR(112) > 0.05) THEN
C * ALERT _149
                CALL PLA236 (149, 2, 1.0, PAR(112), ' gamma ', ' ')
              END IF
            END IF
C * ALERT _157
            IF (PAR(105) < 90.0)
     1        CALL PLA236 (157, 2, 1.0, PAR(105), ' ', ' ')
            IF (PAR(104) == 90.0 .AND. PAR(105) /= 90.0 .AND.
     1          PAR(106) == 90.0) THEN
C * ALERT _147
              IF (PAR(110) /= 0.0 .OR. PAR(112) /= 0.0)
     1          CALL PLA236 (147, 0, 1.0, 1.0, ' ', ' ')
            END IF
C * ORTHORHOMBIC CASE
C * ALERT _137
          ELSE IF (INDEX (KRSYST(2), 'orthorhombic') /= 0) THEN
            IF (PAR(104) /= 90.0 .OR. PAR(105) /= 90.0 .OR.
     1          PAR(106) /= 90.0) CALL PLA236 (137, 0, 1.0, 1.0,
     2                                           ' ', ' ')
C * TEST SU B-AXIS
            YUNK = PAR(108) / PAR(102)
            IF (YUNK < 0.00001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _142
              CALL PLA236 (142, 5, YUNK1, PAR(108), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 4, 1.0, PAR(108), '     b ', ' ')
            END IF
C * TEST SU C-AXIS
            YUNK = PAR(109) / PAR(103)
            IF (YUNK < 0.00001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _143
              CALL PLA236 (143, 5, YUNK1, PAR(109), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 3, 1.0, PAR(109), '     c ', ' ')
            END IF
C * TEST FOR EQUAL CELL AXES SU's
            IF (PAR(107) > 0.00001 .AND. AXISRAT > 0.5) THEN
C * ALERT _153
              IF (PAR(107) == PAR(108) .AND. PAR(108) == PAR(109))
     1          THEN
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
                N = GEN152 (PAR(107))
                CALL PLA236 (153, N, -999.0, PAR(107), ' ', ' ')
              END IF
            END IF
C * ALERT _147
            IF (PAR(110) /= 0.0 .OR. PAR(111) /= 0.0 .OR.
     1          PAR(112) /= 0.0)
     2            CALL PLA236 (147, 0, 1.0, 1.0, ' ', ' ')
C * TETRAGONAL CASE
          ELSE IF (INDEX (KRSYST(2), 'tetragonal') /= 0) THEN
C * ALERT _135
            IF (PAR(101) /= PAR(102))
     1        CALL PLA236 (135, 0, 1.0, 1.0, ' ', ' ')
C * TEST SU C-AXIS
            YUNK = PAR(109) / PAR(103)
            IF (YUNK < 0.00001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
C * ALERT _143
              CALL PLA236 (143, 5, YUNK1, PAR(109), ' ', ' ')
            ELSE IF (YUNK > 0.001) THEN
C * ALERT _148
              CALL PLA236 (148, 3, 1.0, PAR(109), '     c ', ' ')
            END IF
C * ALERT _136
            IF (PAR(104) /= 90.0 .OR. PAR(105) /= 90.0 .OR.
     1          PAR(106) /= 90.0)
     2            CALL PLA236 (136, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _147
            IF (PAR(110) /= 0.0 .OR. PAR(111) /= 0.0 .OR.
     1          PAR(112) /= 0.0)
     2            CALL PLA236 (147, 0, 1.0, 1.0, ' ', ' ')
C * RHOMBOHEDRAL CASE
          ELSE IF (INDEX (KRSYST(2), 'rhombohedral') /= 0) THEN
C * ALERT _139
            IF (PAR(101) /= PAR(102) .OR. PAR(101) /= PAR(103))
     1        CALL PLA236 (139, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _140
            IF (PAR(104) /= PAR(105) .OR. PAR(104) /= PAR(106))
     1        CALL PLA236 (140, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _144
            IF (PAR(110) < 0.0005) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
              CALL PLA236 (144, 4, YUNK1, PAR(110), ' ', ' ')
            END IF
C * TRIGONAL/HEXAGONAL CASE
          ELSE IF (INDEX (KRSYST(2), 'trigonal') /= 0 .OR.
     1             INDEX (KRSYST(2), 'hexagonal') /= 0) THEN
C * ALERT _132
            IF (PAR(101) /= PAR(102))
     1        CALL PLA236 (132, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _133
            IF (PAR(104) /= 90.0 .OR. PAR(105) /= 90.0)
     1        CALL PLA236 (133, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _134
            IF (PAR(106) /= 120.0)
     1        CALL PLA236 (134, 0, 1.0, 1.0, ' ', ' ')
C * TEST SU C-AXIS
            YUNK = PAR(109) / PAR(103)
C * ALERT _143
            IF (YUNK < 0.00001) THEN
              IF (YUNK > 0.0) THEN
                YUNK1 = -999.0
              ELSE
                YUNK1 = 1.0
              ENDIF
              CALL PLA236 (143, 5, YUNK1, PAR(109), ' ', ' ')
C * ALERT _148
            ELSE IF (YUNK > 0.001) THEN
              CALL PLA236 (148, 3, 1.0, PAR(109), '     c ', ' ')
            END IF
C * CUBIC CASE
          ELSE IF (INDEX (KRSYST(2), 'cubic') /= 0) THEN
C * ALERT _130
            IF (PAR(101) /= PAR(102) .OR. PAR(101) /= PAR(103))
     1        CALL PLA236 (130, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _131
            IF (PAR(104) /= 90.0 .OR. PAR(105) /= 90.0 .OR.
     1        PAR(106) /= 90.0) CALL PLA236 (131, 0, 1.0, 1.0,
     2         ' ', ' ')
C * ALERT _147
            IF (PAR(110) /= 0.0 .OR. PAR(111) /= 0.0 .OR.
     1          PAR(112) /= 0.0)
     2            CALL PLA236 (147, 0, 1.0, 1.0, ' ', ' ')
          END IF
        END IF
        IF (IABS (IGBL(8)) /= 3)
     1    WRITE (LU6, 99998) (PAR(I), I = 101, 106)
C * SET UP METRICAL MATRIX FOR UNTRANSFORMED INPUT CELL
        CALL GEN026 (1, RAA, PAR(101))
C * COPY/STORE UNTRANSFORMED CELL PARAMETERS
        CALL GEN113 (PAR(101), PAR(241), 6)
C * CALCULATE INVERSE MATRIX
        CALL GEN003 (RAA, RBB, DET, 0)
C * CALL EXIT/STOP
        IF (DET < 0.0) CALL GEN127 ('CANNOT INVERT METRICAL MATRIX')
C * GET UNTRANSFORMED RECIPROCAL CELL PARAMETERS (PAR(135) - PAR(140))
        CALL GEN026 (-1, RBB, PAR(135))
        CALL GEN025 (RBB, PAR(391), 1)
C * APPLY AXES TRANSFORMATION
        CALL GEN001 (1, TM1, RAA, AA)
C * CALCULATE INVERSE METRIC AND VOLUME
        CALL GEN003 (AA, BB, DET, 0)
C * CALL EXIT/STOP
          IF (DET < 0.0) CALL GEN127 ('CANNOT INVERT METRICAL MATRIX')
          PAR(98) = SQRT(DET)
          DO I = 1, 3
            PAR(128 + I) = AA(I, I)
            PAR(112 + I) = SQRT(BB(I, I))
            PAR(190 + I) = BB(I, I)
          END DO
          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))
C * TRANSFORM CELL-ESD'S
          CALL GEN067 (TM1, PAR(241), PAR(101), PAR(107), PAR(107))
C * APPLY SYMMETRY CONSTRAINTS ON CELL DIMENSIONS
          CALL GEN066 (1, PAR(101), PAR(107), SPGRNM(1)(12:12),
     1      IPR(783))
C * ROUND CELL PARAMETERS
          NZERO = 0
          DO I = 1, 3
C * A,B,C
            CALL GEN041 (PAR(100 + I), PAR(106 + I), IPR(280 + I), 5,
     1         IPR(286 + I), IPR(68))
            IF (IPR(280 + I) > 0) THEN
              IF (MOD (NINT (PAR(100 + I) * 10 ** IPR(286 + I)), 10)
     1          == 0) THEN
                IF (IPR(280 + I) == 10) THEN
                  IPR(280 + I) = 1
                  IPR(286 + I) = IPR(286 + I) - 1
                ELSE
                  NZERO = NZERO + 1
                END IF
              END IF
            END IF
 
C * ALPHA, BETA, GAMMA
            CALL GEN041 (PAR(103 + I), PAR(109 + I), IPR(283 + I), 4,
     1           IPR(289 + I), IPR(68))
            IF (IPR(283 + I) > 0) THEN
              IF (MOD (NINT (PAR(103 + I) * 10 ** IPR(289 + I)), 10)
     1          == 0) THEN
                IF (IPR(283 + I) == 10) THEN
                  IPR(283 + I) = 1
                  IPR(289 + I) = IPR(289 + I) - 1
                ELSE
                  NZERO = NZERO + 1
                END IF
              END IF
            END IF
          END DO
C * ALERT _180
          IF (NZERO > 2)
     1      CALL PLA236 (180, 0, -999.0, FLOAT (NZERO), ' ', ' ')
          DO I = 1, 3
            R = PAR(106 + I) / PAR(100 + I)
            IF (R > PAR(13)) PAR(13) = R
            IF (PAR(109 + I) > PAR(14)) PAR(14) = PAR(109 + I)
          END DO
          DO I = 1, 3
            V4(I) = COS (PAR(103 + I) / RGBL(6))
            IF (ABS (V4(I)) < 1E-6) V4(I) = 0.0
            V3(I) = SIN(PAR(103 + I) / RGBL(6))
          END DO
C * CALCULATE SU IN CELL VOLUME
          PAR(21) = GEN068 (PAR(101), PAR(107), IPR(606))
C * ROUND VOLUME
          CALL GEN041 (PAR(98), PAR(21), IPR(293), 3, IPR(294), IPR(68))
          IF (PAR(21) > 0.0) THEN
            XDUM = ABS (PAR(164) - PAR(98)) / PAR(21)
            IF (IPR(522) == 0) THEN
C * ALERT _150
              IF (XDUM > 0.01 .AND. IGBL(94) == 0)
     1          CALL PLA236 (150, 2, XDUM, PAR(164), ' ', ' ')
C * ALERT _152
              IF (PAR(327) > 0.0) THEN
                IYUNK = MAX (IPR(294), IPR(314))
                IPR293 = IPR(293) * 10**(IYUNK - IPR(294))
                IPR313 = IPR(313) * 10**(IYUNK - IPR(314))
                YUNK = IPR293 - IPR313
                IF (ABS (YUNK) > 1.0) THEN
                  CALL PLA236 (152, 0, -999.0, YUNK, ' ', ' ')
                END IF
              END IF
            END IF
          END IF
C * CALCULATE COS(ALFA*),COS(BETA*),COS(GAMMA*)
          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))
C * CALCULATE SIN(ALFA*), SIN(BETA*), SIN(GAMMA*)
          DO K = 16, 18
            PAR(103 + K) = SQRT (1.0 - PAR(100 + K)**2)
          END DO
C * ORTHOGONALIZE
          CALL GEN044 (PAR(101), OR, 1)
C * GET INVERSE MATRIX FOR TRANSFORMATION ORTHOGONAL TO FRACTIONAL
          CALL GEN003 (OR, ROR, DET, 0)
C * CALL EXIT/STOP
          IF (DET < 0.0) CALL GEN127 ('CANNOT INVERT MATRIX OR')
          CALL GEN108 (LU4, 0)
          IF (IPR(23) == 0) THEN
            NEWLAT(1) = 0
            CALL PLA266 (1)
          END IF
C * SET FOR VALIDATION CHECK DONE
          IPR(522) = 1
C * SET PLA100 DONE
          IPR(786) = 1
        END IF
        IF (IABS (IGBL(8)) /= 3)
     1    WRITE (LU6, 99997) (PAR(I), I = 101, 106)
      END IF
      RETURN
99999 FORMAT (':: Maximum number of allowed residues reduced:',
     1        ' Round ARU to 0.1 units!', /)
99998 FORMAT (/, ':: PLA100-CELL-IN ', 6F10.4)
99997 FORMAT (':: PLA100-CELL-OUT', 6F10.4, /)
      END SUBROUTINE PLA100
 
      MODULE polyplot
      SAVE
      INTEGER, PARAMETER          :: NP26 = 6000
      INTEGER, PARAMETER          :: NP27 = 1000
      INTEGER, PARAMETER          :: NP28 = 6000
      INTEGER                     :: NATP
      INTEGER                     :: NCIRC
      INTEGER                     :: NPOLY
      INTEGER, DIMENSION(12, 3)   :: NN = RESHAPE ((/
     1 2, 2, 2, 2, 7, 7, 7, 7, 2, 2, 3, 2, 3, 3, 4, 5, 3, 3, 5, 4, 3, 3,
     2 4, 4, 5, 4, 6, 6, 4, 5, 6, 6, 4, 5, 5, 5/), (/12, 3/))
      INTEGER, DIMENSION(12, 2)   :: LO = RESHAPE ((/1, 2, 5, 3, 1,
     1 4, 6, 8, 7, 2, 5, 3, 2, 5, 3, 1, 4, 6, 8, 7, 4, 6, 8, 7/),
     2 (/12, 2/))
      INTEGER, DIMENSION(12, 2)   :: IE
      INTEGER, DIMENSION(NP27, 9) :: IP
      INTEGER, DIMENSION(68)      :: NF
      INTEGER, DIMENSION(6)       :: IF1
      INTEGER, DIMENSION(100)     :: IG1
      INTEGER, DIMENSION(100)     :: IG2
      INTEGER, DIMENSION(NP28)    :: ICIR
      REAL,    DIMENSION(24)      :: B
      REAL,    DIMENSION(NP26, 5) :: A
      REAL,    DIMENSION(200, 4)  :: R
      REAL,    DIMENSION(62)      :: D
      REAL,    DIMENSION(36)      :: CY
      REAL,    DIMENSION(300, 5)  :: DS
      REAL,    DIMENSION(8, 4)    :: BOX = RESHAPE ((/
     1 10, 20, 30, 40, 50, 60, 70, 80, 0, 1, 0, 0, 1, 1, 0, 1,
     2  0,  0,  1,  0,  1,  0,  1,  1, 0, 0, 0, 1, 0, 1, 1, 1/),
     3 (/8, 4/))
      END MODULE polyplot
 
      SUBROUTINE PLA101
C * POLYEDER PLOT (MODELLED ON STRUPLO (R.X. Fischer)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE polyplot
      USE sgxyz
      IMPLICIT NONE
      LOGICAL :: LOGIC
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: II
      INTEGER :: LX
      INTEGER :: NX
      INTEGER :: KL
      INTEGER :: KN
      INTEGER :: M2
      INTEGER :: IER
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: NAT
      INTEGER :: IDUM
      INTEGER :: NSYM
      INTEGER :: IENR
      INTEGER :: NATPS
      REAL    :: X
      REAL    :: X1
      REAL    :: X2
      REAL    :: X3
      REAL    :: X4
      REAL    :: X5
      REAL    :: B24
      REAL    :: CMX
      REAL    :: CY1
      REAL    :: DEL
      REAL    :: DUM
      REAL    :: STEP
      REAL    :: ARCO
C * SET UNITCELL LABEL BY DEFAULT ON
      IPR(339) = 1
      STEP     = 0.0
   10 IER      = 0
      NAT      = IPR(37)
      NSYM     = IPR(48)
C * NR CIRCLES TO BE DRAWN
      NCIRC    = 0
C * NR POLYHEDRON TO BE DRAWN
      NPOLY    = 0
C * NUMBER OF ATOMS (INCLUDING UNITCELL CORNERS)
      NATP     = 8
C * N-OUTSIDE
      NATPS    = 0
C * SCALING FACTOR
      PAR(224) = 1.0
C * PREPARE UNITCELL BOX
      DO I = 1, 8
        DO J = 1, 4
          A(I, J) = BOX(I, J)
        END DO
      END DO
C * CALCULATE RANGE FOR ATOMS OUTSIDE THE UNITCELL
      CMX   = MAX (PAR(216) + PAR(217), PAR(220) + PAR(221))
      V2(1) = ABS (CMX / OR(1, 1))
      V2(2) = ABS (CMX / (V2(1) * OR(1, 2) - OR(2, 2)))
      V2(3) = ABS (CMX / (V2(2) * OR(1, 3) + OR(3, 3)))
C * SET POLY RANGE PARAMETER DEFAULT
      IF (IPR(354) == -1) IPR(354) = 0
      DO I = 1, 5, 2
        J = (I + 1) / 2
        PAR(200 + I) = (1.0 - (IPR(354) + 1)) * 0.5 - V2(J)
        PAR(201 + I) = (1.0 + (IPR(354) + 1)) * 0.5 + V2(J)
      END DO
C * DEFAULT OMIT OUTSIDE RANGE
      IF (IPR(356) < 0) THEN
        DO I = 1, 5, 2
          PAR(206 + I) = -0.01
          PAR(207 + I) =  1.01
        END DO
        IPR(356) = 0
      END IF
C * PREPARE DO LOOP PARAMETERS
      DO I = 1, 6
        ICIR(I) = IFIX (PAR(200 + I) - SIGN (1E-4, PAR(200 + I)) + 10.0)
      END DO
      WRITE (LU6, 99998, IOSTAT = IOST)
     1  (PAR(J), J = 201, 202), (ICIR(J) -10, J = 1, 2),
     2  (PAR(J), J = 203, 204), (ICIR(J) -10, J = 3, 4),
     3  (PAR(J), J = 205, 206), (ICIR(J) -10, J = 5, 6)
C * PROCESS INPUT ATOMIC PARAMETERS
      DO I = 1, NAT
        CALL PLA047 (LABA(I), NQ1, IDUM, IENR, 0, IGBL(55),
     1    0, 0)
C * INCLUDE HATOMS ONLY WHEN IPR(212) = 1
        IF (IENR /= 1 .OR. IPR(212) == 1) THEN
C * LOAD INPUT & ADD GENERATED EQUIVALENT POSITIONS
C * A(I, 1) = CODE, A(I, 2) = X, A(I, 3) = Y, A(I, 4) = Z
C * SPHERE RADIUS CODE = (ELEMENT_NUMBER * 100000 + ATOM_NUMBER * 10
          N = NATP
          DO 20 J = 1, NSYM
            NATP = NATP + 1
            IF (NATP > NP26) THEN
              WRITE (LU6, 99997, IOSTAT = IOST) NP26
              GO TO 100
            END IF
            A(NATP, 1) = (IENR * 10000 + I) * 10
            DO L = 1, 3
              SGY(L)     = XXO(I, L)
              SGY(L + 3) = 0.0
            END DO
            A(NATP, 5) = REL(IENR) * PAR(213)
            CALL SGSM (3, LINE, SGY, J, LU7, IERR)
C * REDUCE COORDINATES TO RANGE OF UNIT CELL
            DO L = 2, 4
              A(NATP, L) = MOD (SGY(L + 5) + 10.0, 1.0)
            END DO
C * CHECK SPECIAL POSITIONS
            IF (J > 1) THEN
              DO L = N, NATP - 1
                IF (ABS (A(L, 2) - A(NATP, 2)) < 0.001) THEN
                  IF (ABS (A(L, 3) - A(NATP, 3)) < 0.001) THEN
                    IF (ABS (A(L, 4) - A(NATP, 4)) < 0.001) THEN
                      NATP = NATP - 1
                      GO TO 20
                    END IF
                  END IF
                END IF
              END DO
            END IF
C * CHECK LIMITS FOR ALL ATOMS
            DO L = 2, 4
              K = (L - 1) * 2
              IF (A(NATP, L) < PAR(199 + K) .OR.
     1            A(NATP, L) > PAR(200 + K)) THEN
                A(NATP, 1) = SIGN (A(NATP, 1), -1.0)
                GO TO 20
              END IF
            END DO
C * CHECK LIMITS FOR CIRCLES
            IF (IPR(356) == 1) THEN
              DO L = 2, 4
                K = (L + 102) * 2
                IF (A(NATP, L) < PAR(K - 1) .OR.
     1            A(NATP, L) > PAR(K)) THEN
                  A(NATP, 1) = FLOAT (IFIX (A(NATP, 1) * 0.1) * 10 + 5)
                  GO TO 20
                END IF
              END DO
            END IF
   20     CONTINUE
        END IF
      END DO
C * GENERATE ATOMS OUTSIDE THE UNIT CELL
      NATPS = NATP
      DO 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 J = ICIR(1), ICIR(2)
          DO K = ICIR(3), ICIR(4)
            DO 30  L = ICIR(5), ICIR(6)
              IF (J /= 10 .OR. K /= 10 .OR. L /= 10) THEN
                NATP = NATP + 1
                IF (NATP > NP26) THEN
                  WRITE (LU6, 99997, IOSTAT = IOST) NP26
                  GO TO 100
                END IF
                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)
C * CHECK LIMITS
                DO M = 2, 4
                  M2 = (M - 1) * 2
                  IF (A(NATP, M) < PAR(199 + M2) .OR.
     1                A(NATP, M) > PAR(200 + M2)) THEN
                    NATP = NATP - 1
                    GO TO 30
                  END IF
                END DO
C * CHECK LIMITS FOR CIRCLES
                IF (IPR(356) == 1) THEN
                  DO M = 2, 4
                    M2 = (M + 102) * 2
                    IF (A(NATP, M) < PAR(M - 1) .OR.
     1                  A(NATP, M) > PAR(M)) THEN
                      A(NATP, 1) = FLOAT (IFIX (A(NATP, 1) * 0.1)
     1                           * 10 + 5)
                      GO TO 30
                    END IF
                  END DO
                END IF
              END IF
   30       CONTINUE
          END DO
        END DO
      END DO
C * CALCULATE ROTATION MATRIX
      CALL GEN021 (RMAT, 1.0)
      DO I = 1, 3
        X = - RGBL(27 + I) / RGBL(6)
        CALL GEN051 (0, RMAT, X, I)
      END DO
C * CALCULATE ORTHOGONAL COORDINATES
      DO I = 1, NATP
        DO J = 1, 3
          V3(J) = A(I, J + 1)
        END DO
        CALL GEN002 (1, OR, V3, V2, DUM)
C * ROTATE AND STORE ANGSTROM COORDINATES
        CALL GEN002 (-1, RMAT, V2, V3, DUM)
        A(I, 2) = V3(1)
        A(I, 3) = V3(2)
        A(I, 4) = V3(3)
      END DO
      PAR(222) = MAX (PAR(216) + PAR(217), PAR(220) + PAR(221))
C * CALCULATE INTERATOMIC DISTANCES AND ANGLES AROUND ATOM IAT
      DO 60 IAT = 9, NATP
        IF (A(IAT, 1) > 0.0) THEN
          LOGIC = IAT > NATPS
          IF (LOGIC .AND. IPR(354) == 0) GO TO 70
          LOGIC = IFIX (A(IAT, 1) * 0.1) ==
     1            IFIX (A(IAT - 1, 1) * 0.1) .OR. LOGIC
C * STORE SHORT DISTANCES (TO_NR, DX, DY, DZ, D)
          L = 0
          DO JAT = 9, NATP
            IF (A(JAT, 1) > 0.0) THEN
              IF (JAT /= IAT) THEN
                DS(L + 1, 1) = FLOAT (JAT)
                DEL          = 0
                DO K = 2, 4
                  DS(L + 1, K) = A(IAT, K) - A(JAT, K)
                  DEL = DEL + DS(L + 1, K)**2
                END DO
                DS(L + 1, 5) = SQRT (DEL)
                IF (DS(L + 1, 5) <= PAR(222)) L = L + 1
              END IF
            END IF
          END DO
C * SORT DISTANCES
          DO I = 1, L - 1
            K  = 0
            B24 = DS(I, 5)
            DO J = I + 1, L
              IF (B24 >= DS(J, 5)) THEN
                B24 = DS(J, 5)
                K  = J
              END IF
            END DO
            IF (K > 0) THEN
              DO J = 1, 5
                CALL GEN018 (DS(I, J), DS(K, J))
              END DO
            END IF
          END DO
C * ANGLE LIST (FOLLOWING DISTANCES IN D): NR1, NR2, ANGLE, D1, D2
C * START STORAGE FROM TOP OF THE BOND LIST
          II = L
          DO J = 1, L - 1
            IF (DS(J, 5) <= PAR(222)) THEN
              DO K = J + 1, L
                IF (DS(K, 5) > PAR(222)) EXIT
                II = II + 1
C * CALL EXIT/STOP
                IF (II > 300) CALL GEN127 ('I')
                DS(II, 1) = DS(J, 1)
                DS(II, 2) = DS(K, 1)
                IF (ABS (DS(J, 5) * DS(K, 5)) >= 1E-8) THEN
                  ARCO = (DS(J, 2) * DS(K, 2)  +  DS(J, 3) * DS(K, 3)
     1                 +  DS(J, 4) * DS(K, 4)) / (DS(J, 5) * DS(K, 5))
                ELSE
                  ARCO = 1.0
                END IF
                IF (ABS (ARCO) > 1.0) ARCO = SIGN (1.0, ARCO)
                DS(II, 3) = ACOS (ARCO) * RGBL(6)
                DS(II, 4) = DS(J, 5)
                DS(II, 5) = DS(K, 5)
              END DO
            END IF
          END DO
C * SEARCH FOR POLYEDRA
          DO N = 1, 2
            LX = 9 - N * 2
            DO J = 1, 4
C * SET OCTAEDER CRITERIA
              IF (N == 1) THEN
                CY(J) = PAR(217 + J)
              ELSE
C * SET TETRAEDER CRITERIA
                CY(J) = PAR(213 + J)
              END IF
            END DO
            CY(5) = 1.414 * (PAR(220) + PAR(221))
C * NEW POLYHEDRON
            IF (NPOLY >= NP27) THEN
              WRITE (LU7, 99996, IOSTAT = IOST) NP27
              IER = 1
              GO TO 80
            END IF
            NX               = 1
            IP(NPOLY + 1, 1) = IAT
            IP(NPOLY + 1, 6) = 0
            IP(NPOLY + 1, 7) = 0
            X1               = 0.0
            X2               = A(IAT, 2)
            X3               = A(IAT, 3)
            DO JAT = L + 1, II
C * TEST ANGLE
              IF (ABS (DS(JAT, 3) - CY(1)) <= CY(2)) THEN
C * TEST DIST1
                IF (ABS (DS(JAT, 4) - CY(3)) <= CY(4)) THEN
C * TEST DIST2
                  IF (ABS (DS(JAT, 5) - CY(3)) <= CY(4)) THEN
                    DO 50 M = 1, 2
                      IF (NX > 1) THEN
                        DO K = 2, NX
                          IF (NINT (DS(JAT, M)) == IP(NPOLY + 1, K))
     1                      GO TO 50
                        END DO
                      END IF
                      IF (NX < 9) THEN
                        NX = NX + 1
                        IP(NPOLY + 1, NX) = NINT (DS(JAT, M))
                        X4 = A(IP(NPOLY + 1, NX), 2)
                        X5 = A(IP(NPOLY + 1, NX), 3)
                        X1 = MAX (X1, SQRT ((X2 - X4)**2
     1                     + (X3 - X5)**2))
                      ELSE
                        WRITE (LU6, 99994)
                      END IF
   50               CONTINUE
                  END IF
                END IF
              END IF
            END DO
            IP(NPOLY + 1, 8) = IFIX (X1 * 1000)
            IP(NPOLY + 1, 9) = LX
            IF (NX == LX) THEN
              NPOLY = NPOLY + 1
              IF (LX == 7) THEN
                DO I = 2, 3
                  DO M = 1, 3
                    XPV(M) = A(IP(NPOLY, I), M + 1)
                  END DO
                  CY(6) = 0.0
                  DO J = I + 1, 9 - I
                    DO M = 1, 3
                      XPV(M + 3)  = A(IP(NPOLY, J), M + 1)
                    END DO
                    CY(5) = SQRT ((XPV(4) - XPV(1))**2
     1                    + (XPV(5) - XPV(2))**2 + (XPV(6) - XPV(3))**2)
                    IF (CY(5) > CY(6)) THEN
                      CY(6) = CY(5)
                      NX    = J
                    END IF
                  END DO
C * SWAP
                  CALL GEN014 (IP(NPOLY, NX), IP(NPOLY, 9 - I))
                END DO
              END IF
              GO TO 60
            END IF
          END DO
C * MARK ATOMS TO BE DRAWN AS CIRCLES
          IF (IPR(359) == 1) THEN
            IF (NCIRC < NP28) THEN
              NCIRC       = NCIRC + 1
              ICIR(NCIRC) = IAT
            ELSE
              WRITE (LU6, 99995) NP28
            END IF
          END IF
        END IF
   60 CONTINUE
      IF (IABS(NCIRC) > 0) THEN
C * SORT CIRCLES ON Z
        DO I = 1, NCIRC - 1
          K   = 0
          CY1 = A(ICIR(I), 4)
          DO J = I + 1, NCIRC
            IF (CY1 <= A(ICIR(J), 4)) THEN
              CY1 = A(ICIR(J), 4)
              K   = J
            END IF
          END DO
          IF (K > 0) THEN
C * SWAP INTEGERS
            CALL GEN014 (ICIR(I), ICIR(K))
          END IF
        END DO
      END IF
C * START PLOT
   70 CALL PLA102 (IER)
   80 IF (IER /= 0) WRITE (LU7, 99999, IOSTAT = IOST) IER
      IF (STEP > 0.0) THEN
        CALL PLA226 (-2, - STEP / RGBL(6))
        GO TO 10
      END IF
C * NEW INSTRUCTION
      CALL PLA012 (0, 1)
      CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
      SELECT CASE (IFL(1)(1:4))
C * EXIT
        CASE ('EXIT')
          GO TO 100
C * END
        CASE ('END ')
          GO TO 100
C * XROT
        CASE ('XR  ', 'XROT')
          CALL PLA226 (-1, - FN(1) / RGBL(6))
          GO TO 10
C * YROT
        CASE ('YR  ', 'YROT')
          CALL PLA226 (-2, - FN(1) / RGBL(6))
          GO TO 10
C * ZROT
        CASE ('ZR  ', 'ZROT')
          CALL PLA226 (-3, - FN(1) / RGBL(6))
          GO TO 10
        CASE ('CYR')
          STEP = FN(1)
          CALL PLA226 (-2, - FN(1) / RGBL(6))
          GO TO 10
      END SELECT
      IF (LRET == 1) THEN
        GO TO 100
C * OMIT OUTSIDE
      ELSE IF (LRET == 2) THEN
        IPR(356) = -1
        GO TO 10
      ELSE IF (LRET == 3) THEN
        GO TO 10
      END IF
C * ENDPLOT
  100 CALL GGIP (0.0, 0.0, 0.0, -1)
      IGGT    = ' '
      IGBL(6) = 10
C * RESET
      CALL PLA286 (0)
      RETURN
99999 FORMAT (':: Error Nr.', I3, ' in POLY')
99998 FORMAT (///, 'Range for Generating Atoms is ',
     1      'X:', F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')',/,
     2 30X, 'Y:', F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')' /,
     3 30X, 'Z:', F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')')
99997 FORMAT ('Maximum Number of Atoms', I5, ' has been reached')
99996 FORMAT ('Maximum Number of Polyhedra', I5, ' has been Exceeded')
99995 FORMAT ('Maximum Number of NCIRC atoms', I5, 'has been Reached')
99994 FORMAT ('Ignored: NX >= 9 in PLA101')
      END SUBROUTINE PLA101
 
      SUBROUTINE PLA102 (IER)
C * POLYHEDRAL PLOT SUPPORT
      USE files
      USE parameters
      USE plato
      USE polyplot
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      LOGICAL :: LOGIC
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: I0
      INTEGER :: I2
      INTEGER :: K0
      INTEGER :: K2
      INTEGER :: J0
      INTEGER :: J1
      INTEGER :: J2
      INTEGER :: J3
      INTEGER :: JX
      INTEGER :: IPA
      INTEGER :: IPB
      INTEGER :: IER
      INTEGER :: NF24
      REAL    :: C1
      REAL    :: DD
      REAL    :: B14
      REAL    :: B15
      REAL    :: PER
      REAL    :: DENO
      REAL    :: DSAVE
      REAL    :: ATEST
      REAL    :: GEN009
C * FIND MINIMUM AND MAXIMUM FOR SCALE CALCULATION
      V1(1) =  1E5
      V1(2) = -1E5
      V1(3) =  1E5
      V1(4) = -1E5
      DO I = 1, NATP
C * PERSPECTIVE VIEW
        IF (IPR(355) > 0) THEN
          PER = 60.0 / (60.0 - A(I, 4))
          A(I, 2) = A(I, 2) * PER
          A(I, 3) = A(I, 3) * PER
        END IF
        IF (A(I, 1) > 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))
        END IF
      END DO
      B14 = ABS (V1(1) - V1(2))
      B15 = ABS (V1(3) - V1(4))
C * DIN-A4 CROSS SIZE
      PAR(224) = MIN (PAR(38) * PAR(50) / B14, PAR(38) / B15)
C * MOVE ORIGIN TO CENTER OF PLOT
      B14 = (V1(1) + V1(2)) / 2
      B15 = (V1(3) + V1(4)) / 2
      DO I = 1, NATP
        A(I, 2) = A(I, 2) - B14
        A(I, 3) = A(I, 3) - B15
      END DO
C * GENERATE PLOT
C * SIZE/INIT
      XGGIP = PAR(38) * PAR(50)
      YGGIP = PAR(38)
      CALL GGIP (XGGIP, YGGIP, 0.0, 1)
C * SELECT PEN
      CALL GGIP (0.0, 1.0, 0.0, 0)
C * DRAW BOX
      CALL PLA110 (XGGIP, YGGIP, 0)
C * SET ORIGIN
      XGGIP = XGGIP / 2.0
      YGGIP = YGGIP / 2.0
      CALL GGIP (XGGIP, YGGIP, 0.0, -3)
C * SET SCALE FACTOR
      DD = PAR(224) * 0.9
      CALL GGIP (0.0, DD, 0.0, 7)
C * START MAIN ROUTINE FOR DRAWING CIRCLES AND POLYHEDRA
C * DRAW UNITCELL OUTLINE
      IF (IPR(357) > 0) THEN
        NF(10) = 1
        DO 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)
        END DO
      END IF
C * PLOT CELL AXES LABELS
      IF (IPR(339) > 0 .AND. IPR(357) > 0) THEN
        CALL PLA439 (0.0, 'O', 1, 0.30, 1, 1, A(1, 2) - 0.4,
     1    A(1, 3) - 0.4)
        CALL PLA439 (0.0, 'a', 1, 0.30, 1, 1, A(2, 2) + 0.4,
     1    A(2, 3))
        CALL PLA439 (0.0, 'b', 1, 0.30, 1, 1, A(3, 2),
     1    A(3, 3) + 0.4)
        CALL PLA439 (0.0, 'c', 1, 0.30, 1, 1, A(4, 2),
     1    A(4, 3) - 0.4)
      END IF
C * NO/YES DRAW POLYHEDRON(S)
      IF (IPR(353) == 0) THEN
        NF(1) = NPOLY
      ELSE
        NF(1) = 0
      END IF
      NF(2) = 0
      D(23) = 0.0
      D(24) = 0.0
      C1    = 0.012 / DD
C * NPOLY = # POLYHEDRA, NCIRC = # OF SPHERES
   10 IF (NF(1) < NPOLY) THEN
        IF (ICIR(NF(2) + 1) > 0) THEN
          ATEST = A(ICIR(NF(2) + 1), 4)
        ELSE
          ATEST = 0.0
        END IF
        IF (NF(2) >= NCIRC .OR. (NF(2) < NCIRC .AND.
     1    A(IP(NF(1) + 1, 1), 4) > ATEST)) THEN
C * DRAW POLYHEDRON
          NF(1) = NF(1) + 1
          DO I = 1, 11
            IE(I, 1) = -1
            IE(I, 2) = -1
          END DO
          CALL GEN097 (IF1, 1, 6, 0)
C * HANDLE YES/NO UNITCELL CASE
          IF (IP(NF(1), 7) <= 0) THEN
            NF(12) = 9
            NF(13) = 12
          ELSE
            NF(12) = 1
            NF(13) = 8
          END IF
C * OBSC
          K = 0
          L = 0
          DO I = 1, 3
            B(I) = A(IP(NF(1), 1), I + 1)
          END DO
          DO I = NF(12), NF(13)
            DO J = 1, 3
              NF(6 + J) = IP(NF(1), NN(I, J))
            END DO
            DO 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)
            END DO
C * GET VOLUME
            CALL GEN008 (B(5), B(8), B(11), 0)
            IF (GEN009 (B(11), B(14)) >= 0.0) B(13) = - B(13)
            IF (B(13) > 0) THEN
              IF (K < 6) THEN
                K      = K + 1
                IF1(K) = I
                DO 20 J0 = 1, 3
                  J1 = 1 + J0 / 3
                  J2 = 2 + (J0 + 1) / 3
                  IF (L > J0 - 1) THEN
                    DO J = 1, L
                      IF (NN(I, J1) == IE(J, 1) .AND.
     1                    NN(I, J2) == IE(J, 2)) GO TO 20
                      IF (NN(I, J2) == IE(J, 1) .AND.
     1                    NN(I, J1) == IE(J, 2)) GO TO 20
                    END DO
                  END IF
                  L        = L + 1
                  IE(L, 1) = NN(I, J1)
                  IE(L, 2) = NN(I, J2)
   20           CONTINUE
              ELSE
                IER = 10
                RETURN
              END IF
            END IF
          END DO
          DO J = 1, L
            DO K = 1, 2
              IE(J, K) = IP(NF(1), IE(J, K))
            END DO
          END DO
C * CHECK OVERLAPS
C * A) WITH OTHER POLYHEDRA
          NF(4) = 0
          NF(5) = 0
          IF (NF(1) < 1) THEN
            GO TO 10
          ELSE IF (NF(1) > 1) THEN
            B(6) = FLOAT (IP(NF(1), 8)) * 1E-3
            DO 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) < 0.0) THEN
                NF(4)      = NF(4) + 1
                IG1(NF(4)) = I
              END IF
            END DO
          END IF
C * B) WITH CIRCLES
          IF (NF(2) > 0) THEN
            DO I = 1, NF(2)
              B(4) = A(ICIR(I), 2)
              B(5) = A(ICIR(I), 3)
              B(7) = A(ICIR(I), 5)
              B(8) = SQRT ((B(1) - B(4))**2 + (B(2) - B(5))**2)
              IF (B(8) - B(6) - B(7) < 0) THEN
                NF(5)      = NF(5) + 1
                IG2(NF(5)) = I
              END IF
            END DO
          END IF
C * SEND LINE PARAMETERS TO INTER
          K = 17
C * COUNT LINES
          M = 11
          DO I = 1, 10
            IF (IE(I + 1, 1) <= 0) THEN
              M = I
              EXIT
            END IF
          END DO
C * SEND LINE PARAMETERS TO INTER AND CHECK OUTLINES
          NF(10) = 3
          DO J = 1, M
            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 L = 1, M
              IF (J /= 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)
                DENO  = D(9) * D(12) - D(10) * D(11)
                IF (ABS (DENO) <= 1E-8) THEN
                  D(5) = 10.0
                ELSE
                  D(5) = (D(10) * (D(17) - D(13))
     1                  - D(9)  * (D(18) - D(14))) / DENO
                  D(6) = (D(12) * (D(17) - D(13))
     1                   -D(11) * (D(18) - D(14))) / DENO
                  D(1) = D(17) + D(5) * D(11)
                  D(2) = D(18) + D(5) * D(12)
                END IF
                IF (ABS (D(5) - 0.5) <= 0.5) THEN
                  IF (D(6) >= 0.0) THEN
                    D(22) = (D(13) - D(1))**2 + (D(14) - D(2))**2
                    IF (D(22) > D(21)) GO TO 25
                  END IF
                END IF
              END IF
            END DO
            K     = K + 1
            NF(K) = J
   25       CALL PLA103
          END DO
          IF (IPR(358) > 0) THEN
C * SHADE POLYHEDRON
            NF(10) = 1
            DO I = 1, 6
              IF (IF1(I) <= 0) EXIT
              DO J = 1, 3
                NF(6 + J) = NN(IF1(I), J)
              END DO
              DO JX = 8, 9
                IF (A(IP(NF(1), NF(7)), 4)
     1            - A(IP(NF(1), NF(JX)), 4) <= 0) THEN
C * SWAP INTEGERS
                  CALL GEN014 (NF(7), NF(JX))
                END IF
              END DO
              DO J = 1, 9
                DO 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
                END DO
                IF (IPR(346) /= 0) THEN
                  IF (IP(NF(1), 9) == 5) THEN
                    CALL GGIP (0.0, 2.0, 0.0, 0)
                  ELSE
                    CALL GGIP (0.0, 3.0, 0.0, 0)
                  END IF
                END IF
                CALL PLA103
                CALL GGIP (0.0, 1.0, 0.0, 0)
              END DO
            END DO
          END IF
C * SORT OUTLINES
          L            = 3
          IP(NF(1), 2) = IE(NF(18), 1)
          IP(NF(1), 3) = IE(NF(18), 2)
   30     DO I = 19, K
            IF (NF(I) > 0) THEN
              IF (IE(NF(I), 1) == IP(NF(1), L)) THEN
                L = L + 1
                IP(NF(1), L) = IE(NF(I), 2)
              ELSE
                IF (IE(NF(I), 2) /= IP(NF(1), L)) CYCLE
                L = L + 1
                IP(NF(1), L) = IE(NF(I), 1)
              END IF
              NF(I) = -1
              IF (L > 7) THEN
                IER = 2
                RETURN
              ELSE IF (L < 7) THEN
                GO TO 30
              ELSE
                IF (IP(NF(1), 2) == IP(NF(1), L)) IP(NF(1), L) = -1
                GO TO 50
              END IF
            END IF
          END DO
          IP(NF(1), L) = -1
          GO TO 50
        END IF
      END IF
C * DRAW CIRCLES
      IF (NF(2) < NCIRC) THEN
        NF(2) = NF(2) + 1
C * GET X, Y AND RADIUS
        B(1)  = A(ICIR(NF(2)), 2)
        B(2)  = A(ICIR(NF(2)), 3)
        B(3)  = A(ICIR(NF(2)), 5)
        NF(4) = 0
C * CHECK OVERLAPS WITH POLYHEDRA
        IF (IPR(353) /= 0 .AND. NF(1) > 0) THEN
          DO I = 1, NF(1)
            B(8)  = FLOAT (IP(I, 8)) * 0.001
C * GET X, Y CENTRE ATOM POLYEDER
            IF (SQRT((B(1) - A(IP(I, 1), 2))**2
     1        + (B(2) - A(IP(I, 1), 3))**2) < B(3) + B(8)) THEN
              NF(4)      = NF(4) + 1
              IG1(NF(4)) = I
            END IF
          END DO
        END IF
C * CHECK OVERLAPS WITH OTHER CIRCLES
        NF(5) = 0
        IF (NF(2) > 1) THEN
          DO I = 1, NF(2) - 1
            B(8)  = A(ICIR(I), 5)
            B(5)  = A(ICIR(I), 2)
            B(6)  = A(ICIR(I), 3)
            D(40) = SQRT ((B(1) - B(5))**2 + (B(2) - B(6))**2)
            IF (D(40) - B(3) - B(8) < 0.0) THEN
              IF (D(40) <= 1E-3) THEN
                IF (D(40) + ABS (B(3) - B(8)) <= 1E-3) THEN
                  GO TO 50
                ELSE
                  CYCLE
                END IF
              END IF
              NF(5)      = NF(5) + 1
              IG2(NF(5)) = I
            END IF
          END DO
        END IF
C * SET STARTING POINT
        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
C * CHECK FOR POLYH INCLUDE
        IF (IPR(353) /= 0 .AND. NF(4) > 0) THEN
C * CALCULATE OVERLAPS WITH POLYHEDRA
          B(19) = B(1)
          B(20) = B(2)
          DO I = 1, NF(4)
            LOGIC = .FALSE.
            NF(16) = 6
            DO J = 2, 7
              IF (IP(IG1(I), J + 1) <= 0) THEN
                NF(16) = J - 1
                LOGIC = .TRUE.
              END IF
              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) >= 0 .AND. D(11) /= 0.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) > 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)
                END IF
              END IF
              IF (ABS (D(5) - 0.5) <= 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))) * RGBL(6)
                IF (D(25) <= 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3)
              END IF
              IF (ABS(D(6) - 0.5) <= 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))) * RGBL(6)
                IF (D(25) <= 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3)
              END IF
              IF (LOGIC) EXIT
            END DO
          END DO
        END IF
        IF (NF(5) > 0) THEN
C * CALCULATE OVERLAPS WITH CIRCLES
          DO I = 1, NF(5)
            B(5) = A(ICIR(IG2(I)), 2)
            B(6) = A(ICIR(IG2(I)), 3)
            B(8) = A(ICIR(IG2(I)), 5)
C * INTCC
            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)
            DSAVE = B(3)**2 * D(11) - (D(13) - D(12))**2
            IF (DSAVE > 0.0 .AND. D(11) /= 0.0) THEN
              D(15) = SQRT (DSAVE) / D(11)
            ELSE
              D(15) = 0.0
            END IF
            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))) * RGBL(6)
            IF (D(25) <= 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))) * RGBL(6)
            IF (D(25) <= 0.0) R(NF(15),3) = 360.0 - R(NF(15),3)
          END DO
        END IF
C * SORT INTERSECTIONS
        DO I2 = 1, NF(15) - 1
          K2 = 0
          B(13) = R(I2, 3)
          DO J2 = I2 + 1, NF(15)
            IF (B(13) >= R(J2, 3)) THEN
              B(13) = R(J2, 3)
              K2    = J2
            END IF
          END DO
          IF (K2 > 0) THEN
            DO J2 = 1, 3
C * SWAP REALS
              CALL GEN018 (R(I2, J2), R(K2, J2))
            END DO
          END IF
        END DO
C * CHECK OBSCURING OF SEGMENTS
        IF (IPR(346) /= 0) CALL GGIP (0.0, 5.0, 0.0, 0)
        DO 40 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) / RGBL(6)) + B(1)
          B(24) = B(3) * COS (B(12) / RGBL(6)) + B(2)
          IF (IPR(353) /= 0) THEN
            IF (NF(4) > 0) THEN
              DO J = 1, NF(4)
                NF(3) = IG1(J)
C * DETERMINE NUMBER OF EDGES
                I0 = 6
                DO M = 3, 6
                  IF (IP(NF(3), M + 2) <= 0) THEN
                    I0 = M
                    EXIT
                  END IF
                END DO
C * CHECK IF B(23), B(24) IS OBSCURED BY POLYHEDRON NO. NF(3)
                K0 = I0 + MOD (I0, 2) - 1
                DO 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 J1 = 13, 16
                    J2  = MOD (J1 + 1, 2) + 2
                    J3  = 13 + (J1 - 12) / 3
                    IPA = IP(NF(3), NF(J3))
                    IPB = IP(NF(3), NF(12))
                    IF (IPA < 0 .OR. IPB < 0) GO TO 40
                    B(J1) = A(IPA, J2) - A(IPB, J2)
                  END DO
                  D(11) = B(23) - A(IP(NF(3), NF(12)), 2)
                  D(12) = B(24) - A(IP(NF(3), NF(12)), 3)
                  DENO  =  B(15) * B(14) - B(16) * B(13)
                  IF (ABS (DENO) < 0.0001) EXIT
                  D(5)  = (D(11) * B(14) - D(12) * B(13)) / DENO
                  DENO  =  B(13) * B(16) - B(14) * B(15)
                  IF (ABS (DENO) < 0.0001) EXIT
                  D(6)  = (D(11) * B(16) - D(12) * B(15)) / DENO
                  D(10) = MIN (D(5), D(6))
                  IF (D(10) <= 0.0) EXIT
                END DO
                IF (IFIX (SIGN (1.0, D(10))) >= 0) GO TO 40
              END DO
            END IF
          END IF
          IF (NF(5) > 0) THEN
            DO J = 1, NF(5)
              IF (SQRT ((B(23) - A(ICIR(IG2(J)), 2))**2
     1               + (B(24) - A(ICIR(IG2(J)), 3))**2)
     2      - A(ICIR(IG2(J)), 5) <= 0) GO TO 40
            END DO
          END IF
C * DRAW SEGMENT
          CALL GGIP (R(I - 1, 1), R(I - 1, 2), 0.0, 3)
          NF24 = NINT (B(11) * B(3) / (3 * C1 * RGBL(6)))
          IF (NF24 > 1) THEN
            D(30) = B(11) / FLOAT (NF24)
            D(31) = R(I - 1, 3)
            DO K = 1, NF24
              D(31) = D(31) + D(30)
              D(32) = B(3) * SIN (D(31) / RGBL(6)) + B(1)
              D(33) = B(3) * COS (D(31) / RGBL(6)) + B(2)
              CALL GGIP (D(32), D(33), 0.0, 2)
            END DO
          END IF
   40   CONTINUE
      END IF
   50 CALL GGIP (0.0, 1.0, 0.0, 0)
      IF (NF(1) < NPOLY .OR. NF(2) < NCIRC) GO TO 10
      RETURN
      END SUBROUTINE PLA102
 
      SUBROUTINE PLA103
C * POLYPLOT SUPPORT ROUTINE
      USE files
      USE parameters
      USE polyplot
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: J2
      INTEGER :: J3
      INTEGER :: IPA
      INTEGER :: IPB
      INTEGER :: JEX
      REAL    :: DENO
      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) > 0) THEN
C * CALCULATE OVERLAPS WITH OTHER POLYHEDRA
        DO I = 9, 12
          D(I + 4) = B(I)
        END DO
        DO I = 1, NF(4)
          NF(16) = IP(IG1(I), 9) - 1
          DO J = 2, NF(16) + 1
            IF (IP(IG1(I), J) < 1) EXIT
            IF (IP(IG1(I), J + 1) <= 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)
            DENO   = D(9) * D(12) - D(10) * D(11)
            IF (ABS (DENO) <= 1E-8) THEN
              D(5) = 10.0
            ELSE
              D(5) = (D(10) * (D(17) - D(13))
     1             -  D(9)  * (D(18) - D(14))) / DENO
              D(6) = (D(12) * (D(17) - D(13))
     1             -  D(11) * (D(18) - D(14))) / DENO
              D(1) =  D(17) + D(5) * D(11)
              D(2) =  D(18) + D(5) * D(12)
            ENDIF
            IF (ABS (D(5) - 0.5) <= 0.5) THEN
              IF (ABS (D(6) - 0.5) <= 0.5) THEN
                B(8) = SQRT ((B(9) - D(1))**2 + (B(10) - D(2))**2)
                IF (B(8) > 1E-3) THEN
                  JEX = 0
                  DO K = 1, NF(15)
                    IF (ABS (B(8) - R(K, 3)) <= 1E-5) THEN
                      JEX = 1
                      EXIT
                    END IF
                  END DO
                  IF (JEX == 0) THEN
                    NF(15)       = NF(15) + 1
                    R(NF(15), 1) = D(1)
                    R(NF(15), 2) = D(2)
                    R(NF(15), 3) = B(8)
                  END IF
                ENDIF
              ENDIF
            ENDIF
          END DO
        END DO
      ENDIF
C * CALCULATE INTERSECTIONS WITH CIRCLES
      IF (NF(5) > 0) THEN
        DO I = 1, NF(5)
          B(3)  = A(ICIR(IG2(I)), 5)
          B(19) = A(ICIR(IG2(I)), 2)
          B(20) = A(ICIR(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) >= 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) > 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) <= 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) <= 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
        END DO
        IF (NF(15) <= 0) GOTO 10
      ENDIF
C * SORT INTERSECTIONS
      DO I = 1, NF(15) - 1
        K = 0
        B(13) = R(I, 3)
        DO J = I + 1, NF(15)
          IF (B(13) >= R(J, 3)) THEN
            B(13) = R(J, 3)
            K     = J
          ENDIF
        END DO
        IF (K > 0) THEN
          DO J = 1, 3
C * SWAP
            CALL GEN018 (R(I, J), R(K, J))
          END DO
        ENDIF
      END DO
C * CHECK OBSCURING OF LINE SEGMENTS
   10 DO 30 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) /= 1 .AND. NF(4) /= 0) THEN
          DO J = 1, NF(4)
            NF(3) = IG1(J)
C * DETERMINE NUMBER OF EDGES
            L = 6
            DO M = 3, 6
              IF (IP(NF(3), M + 2) <= 0) THEN
                L = M
                EXIT
              END IF
            END DO
C * CHECK IF B(23), B(24) IS OBSCURED BY POLYHEDRON NO. NF(3)
            K = L + MOD (L, 2) - 1
            DO M = 1, K, 2
              NF(12) = MOD (M,     L) + 2
              NF(13) = MOD (M + 1, L) + 2
              NF(14) = MOD (M - 1, L) + 2
              DO N = 13, 16
                J2  = MOD (N + 1, 2) + 2
                J3  = 13 + (N - 12) / 3
                IPA = IP(NF(3), NF(J3))
                IPB = IP(NF(3), NF(12))
                IF (IPA < 0 .OR. IPB < 0) GO TO 30
                B(N) = A(IPA, J2) -A(IPB, J2)
              END DO
              D(11) = B(23) - A(IP(NF(3), NF(12)), 2)
              D(12) = B(24) - A(IP(NF(3), NF(12)), 3)
              DENO  = B(15) * B(14) - B(16) * B(13)
              IF (ABS (DENO) < 0.0001) EXIT
              D(5)  = (D(11) * B(14) - D(12) * B(13)) / DENO
              DENO  =  B(13) * B(16) - B(14) * B(15)
              IF (ABS (DENO) < 0.0001) EXIT
              D(6)  = (D(11) * B(16) - D(12) * B(15)) / DENO
              D(10) = MIN (D(5), D(6))
              IF (D(10) <= 0.0) EXIT
            END DO
            IF (IFIX (SIGN (1.0, D(10))) >= 0) GOTO 30
          END DO
        ENDIF
        IF (NF(2) /= 0 .AND. NF(5) /= 0) THEN
          DO J = 1, NF(5)
            B(8)  = A(ICIR(IG2(J)), 5)
            B(19) = A(ICIR(IG2(J)), 2)
            B(20) = A(ICIR(IG2(J)), 3)
            IF (SQRT ((B(23) - B(19))**2 + (B(24) - B(20))**2)
     1        <= B(8)) GOTO 30
          END DO
        ENDIF
C * DRAW LINE
        IF ((D(23) - B(9))**2 + (D(24) - B(10))**2 > 1E-4) THEN
          D(23) = B(9)
          D(24) = B(10)
          CALL GGIP (D(23), D(24), 0.0, 3)
        ENDIF
        IF (NF(10) <= 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)
   30 CONTINUE
      RETURN
      END SUBROUTINE PLA103
 
      SUBROUTINE PLA106
C * ORTEP/ADP MAIN ROUTINE
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER                     :: I
      INTEGER                     :: J
      INTEGER                     :: K
      INTEGER                     :: L
      INTEGER                     :: M
      INTEGER                     :: N
      INTEGER                     :: K0
      INTEGER                     :: K1
      INTEGER                     :: L1
      INTEGER                     :: II
      INTEGER                     :: IJ
      INTEGER                     :: IA
      INTEGER                     :: IB
      INTEGER                     :: ID
      INTEGER                     :: IG
      INTEGER                     :: IQ
      INTEGER                     :: IS
      INTEGER                     :: KA
      INTEGER                     :: KB
      INTEGER                     :: KL
      INTEGER                     :: NB
      INTEGER                     :: NP
      INTEGER                     :: ISW
      INTEGER                     :: II0
      INTEGER                     :: II1
      INTEGER                     :: II2
      INTEGER                     :: KD1
      INTEGER                     :: KD2
      INTEGER                     :: NA1
      INTEGER                     :: NA2
      INTEGER                     :: NB1
      INTEGER                     :: NB2
      INTEGER                     :: NO1
      INTEGER                     :: ID1
      INTEGER                     :: ID2
      INTEGER                     :: IPP
      INTEGER                     :: NIA
      INTEGER                     :: NIB
      INTEGER                     :: NIQ
      INTEGER                     :: IQN
      INTEGER                     :: NRI
      INTEGER                     :: NCB
      INTEGER                     :: NCD
      INTEGER                     :: NQD
      INTEGER                     :: NDG
      INTEGER                     :: MNB
      INTEGER                     :: KAT
      INTEGER                     :: MLP
      INTEGER                     :: NID
      INTEGER                     :: HINC
      INTEGER                     :: IVAL
      INTEGER                     :: NTOM
      INTEGER                     :: ITOM
      INTEGER                     :: IDET
      INTEGER                     :: IPOS
      INTEGER                     :: IRES
      INTEGER                     :: IREF
      INTEGER                     :: IHAT
      INTEGER                     :: JHAT
      INTEGER                     :: ISKP
      INTEGER                     :: IANI
      INTEGER                     :: IBND
      INTEGER                     :: KKKA
      INTEGER                     :: MILP
      INTEGER                     :: META
      INTEGER                     :: NBLP
      INTEGER                     :: NBND
      INTEGER                     :: NPOP
      INTEGER                     :: NPOS
      INTEGER                     :: NSUP
      INTEGER                     :: KDEL
      INTEGER                     :: KSTP
      INTEGER                     :: NBM1
      INTEGER                     :: NBIS
      INTEGER                     :: JEND
      INTEGER                     :: IDUM
      INTEGER                     :: JDUM
      INTEGER                     :: NREF
      INTEGER                     :: LPOS1
      INTEGER                     :: LPOS2
      INTEGER                     :: NRES1
      INTEGER                     :: NFRST
      INTEGER                     :: ITYPE
      INTEGER                     :: IYUNK
      INTEGER                     :: KDEL1
      INTEGER                     :: KDEL2
      INTEGER                     :: IATP1
      INTEGER                     :: IATP2
      INTEGER                     :: IROTX
      INTEGER                     :: IROTY
      INTEGER                     :: IROTZ
      INTEGER                     :: IDASH
      INTEGER                     :: LINES
      INTEGER                     :: NSTEP
      INTEGER                     :: NATOM
      INTEGER                     :: NASUP
      INTEGER                     :: NLOOP
      INTEGER                     :: MLOOP
      INTEGER                     :: NEXIT
      INTEGER                     :: NA1P1
      INTEGER                     :: NASIQ
      INTEGER                     :: LPOS12
      INTEGER                     :: NFIRST
      INTEGER                     :: NSHIFT
      INTEGER                     :: IATCIA
      INTEGER                     :: NRESOL
      INTEGER, DIMENSION(8, 2)    :: LPOS
      REAL                        :: X
      REAL                        :: XG
      REAL                        :: YG
      REAL                        :: ZG
      REAL                        :: T1
      REAL                        :: T2
      REAL                        :: T3
      REAL                        :: T4
      REAL                        :: T5
      REAL                        :: T6
      REAL                        :: T7
      REAL                        :: T8
      REAL                        :: T9
      REAL                        :: TX
      REAL                        :: XB
      REAL                        :: DIF
      REAL                        :: DSX
      REAL                        :: DSY
      REAL                        :: TD2
      REAL                        :: TD3
      REAL                        :: DET
      REAL                        :: PHI
      REAL                        :: YNK
      REAL                        :: QOV2
      REAL                        :: AOV3
      REAL                        :: BOV3
      REAL                        :: POV3
      REAL                        :: COLX
      REAL                        :: BDIR
      REAL                        :: XSFT
      REAL                        :: YSFT
      REAL                        :: DIST
      REAL                        :: PVER
      REAL                        :: PHOR
      REAL                        :: DUMP
      REAL                        :: XLNG
      REAL                        :: XBND
      REAL                        :: DELX
      REAL                        :: DELY
      REAL                        :: OVMR
      REAL                        :: ROOT
      REAL                        :: XSHFT
      REAL                        :: YSHFT
      REAL                        :: SCONX
      REAL                        :: SCONY
      REAL                        :: XCONK
      REAL                        :: YCONK
      REAL                        :: PAR71
      REAL                        :: DUMMY
      REAL                        :: XLPOS
      REAL                        :: YLPOS
      REAL                        :: QOV2SQ
      REAL                        :: AOV3SQ
      REAL                        :: POV3CU
      REAL                        :: PQTEST
      REAL                        :: RADIUS
      REAL                        :: GEN006
      REAL                        :: GEN009
      REAL,    DIMENSION(3, 3)    :: B
      REAL,    DIMENSION(3, 3)    :: S
      REAL,    DIMENSION(4, 2)    :: W
      REAL,    DIMENSION(4, 4)    :: FL
      REAL,    DIMENSION(3, 3, 2) :: QA
      REAL,    DIMENSION(3, 3, 2) :: QC
      REAL,    DIMENSION(3, 3)    :: QD
      REAL,    DIMENSION(2)       :: Y1
      REAL,    DIMENSION(2)       :: Y2
      REAL,    DIMENSION(3, 2)    :: V12
      REAL,    DIMENSION(3, 4)    :: QUA
      REAL,    DIMENSION(3, 3)    :: QCC
      REAL,    DIMENSION(3, 3)    :: TMAT
      REAL,    DIMENSION(2)       :: YMIN
      REAL,    DIMENSION(2)       :: YMAX
      REAL,    DIMENSION(6)       :: POSL
      REAL,    DIMENSION(3, 3)    :: YUNK
      REAL,    DIMENSION(2)       :: DETER
      REAL,    DIMENSION(3, 3)    :: AAREV
      REAL,    DIMENSION(9)       :: PROBA
      LPOS = RESHAPE (
     1 (/ 2, 2, 2, 5, 1, 1, 1, 5, 3, 6, 4, 4, 4, 6, 3, 3 /), (/8, 2/))
      PROBA = (/
     1      0.7644, 1.0026, 1.1932, 1.3672, 1.5382, 1.7164, 1.9144,
     2      2.1544, 2.5003/)
C * MAIN OF DISPLACEMENT MOTION ELLIPSOID PLOT ROUTINES
C * ARRAYS XXO, XSD & CON WILL BE OVERWRITTEN TEMPORARILY AND RESTORED AT
C * THE END OF THIS ROUTINE (FROM SCRATCH ARRAY VOID)
C * TEMPORARILY MEMORY LAYOUT FOR ADP ROUTINES
C ***********************************************************************C
C *          I       XXO        I       XSD        I      CON  I IATC/   C
C *          I  1:3      4:6    I   1:3      4:6   I      1:9  I  DATC   C
C *----------------------------------------------------------------------C
C *          I  CART. I  CART   I  EIGEN  I  CART  I EIGEN     I         C
C *          I   XYZ  I  XYZ    I VALUES  I  ESD   I VECTORS   I(SELECT) C
C *  IPR(39) I(SELECT)I  (ORIG) I(SELECT) I (ORIG) I(SELECTED) I         C
C * +IPR(64) I        I         I         I        I           I         C
C *----------------------------------------------------------------------C
C *          I PROJ     I B I   I PROJ    I BOND   I QUAD      I         C
C *          I CONIC    I D I   I CONIC   I DATA   I           I         C
C *  NQD     I          I   I   I         I        I           I         C
C *----------------------------------------------------------------------C
C *  IPR(174)I COVER            I CQ      I SEGM   I CB        I QL      C
C ***********************************************************************C
C * ARRANGE FOR STRIPPED SPECIAL NON-X-WINDOWS VERSION
      META = 1
C STRIP_END
      IF (META == 1) CALL GGIP (-999.0, 0.0, 0.0, -2)
 10   IWIN = IGBL(25) * IGBL(32)
C * INITIATE OVERLAP ROUTINES
      NCD   = 0
      NQD   = 0
      NBND  = 0
      IDASH = 0
      ID1   = 0
      DIST  = 0.0
      KAT   = 0
      NPOS  = 0
      PVER  = 0.0
      PHOR  = 0.0
      IPOS  = 0
      NB    = 0
      NP    = 0
      NEXIT = 0
C * GET NUMBER OF BONDS (EXPANDED)
      NCB   = IPR(131)
C * GET NUMBER OF ATOMS (EXPANDED)
      NATOM = IPR(39)
C * GET NUMBER OF SUPPORT COORDINATES (CG etc)
      NSUP  = IPR(64)
C * TOTAL NUMBER OF ATOMS (REAL AND SUPPORT)
      NASUP = NATOM + NSUP
C * CALCULATE LOCATION FOR ARRAY COVER
      IPR(174) = NASUP + MAX (NASUP, NCB)
C * TEST FOR OVERFLOW XXO
      IF (IPR(174) + NP15 > NP1) THEN
        IPR(2) = 22
        IF (IGBL(3) == 3) IGBL(3) = 0
        RETURN
      END IF
C * SET FOR PLATON/ORTEP MENU NUMBER
      IF (IGBL(6) /= 8 .AND. IGBL(6) /= 9 .AND.
     1    IGBL(6) /= 22) IGBL(6) = 1
C * SELECT ATOMS FOR PLOTTING (BASED ON INCLUDE/RESIDUE STATUS)
   20 IPR(477) = 0
      DO I = 1, NASUP
C * LOAD ORTHOGONAL COORDINATES [IN XXO(1:3)] FROM BACKUP STORAGE 'VOID'
        DO J = 4, 6
          XXO(I, J) = VOID((I - 1) * NP71 + J)
        END DO
C * REGISTER ATOM FOR LEAST-SQUARES PLANE CALCULATION
        IATP(I) = I + NP1
C * GET H-ATOM BIT
        CALL GEN048 (-1, IFG(1, I), 7,  IHAT)
C * GET H-INCLUDE BIT
        CALL GEN048 (-1, IFG(2, I), 12, HINC)
        IF (IGBL(59) /= 0) THEN
C * GET POPULATION PARAMETER
          CALL GEN048 (-8, IFG(2, I), 1, IPP)
          NPOP = IPPR(IPP + 1, 1)
          IF (NPOP < 10000) THEN
            IF (IGBL(88) == 0) THEN
              IF (IPPR(IPP + 1, 1) < 5000) CYCLE
            ELSE
              IF (IPPR(IPP + 1, 1) > 5000) CYCLE
            END IF
          END IF
        END IF
        IF (IHAT /= 1 .OR. HINC /= 0 .OR. IPR(212) /= 0) THEN
          IF (IPR(140) > 0) THEN
C * GET RESIDUE NUMBER
            CALL GEN048 (-6, IFG(1, I), 9, IRES)
            IF (IRES /= IPR(140)) CYCLE
          END IF
          IPR(477) = IPR(477) + 1
          IATP(I)  = I
        END IF
      END DO
C * GET ORIENTATION MATRIX (IGBL(87) = DETERMINANT)
      IF (IGBL(87) == 0) IGBL(87) = 1
      CALL GEN021 (RMAT, FLOAT(IGBL(87)))
C * SET XROT STEP VALUES
      PAR(389) = 0.0
      IPR(479) = 1
C * CHECK FOR MINIMUM OVERLAP/MATRIX CALCULATIONS-PRELIM ORR MATRIX
      IF (IGBL(67) == 0) THEN
C * CALCULATE MINIMUM OVERLAP VIEW: CALCULATE L.S.-PLANE
        CALL PLA054 (0)
C * MAKE LARGEST COMPONENT Z
        DO I = 1, 3
          YNK        =  DUMV(I, 1)
          DUMV(I, 1) = -DUMV(I, 3)
          DUMV(I, 3) =  YNK
        END DO
C * COPY DUMV INTO RMAT
        CALL GEN004 (DUMV, RMAT, YUNK)
        CALL GEN052 (YUNK, RMAT)
        IGBL(67) = 1
      ELSE
C * SETUP RMAT FROM ROTATIONS
        DO I = 1, 3
          X = - RGBL(27 + I) / RGBL(6)
          CALL GEN051 (0, RMAT, X, I)
        END DO
      END IF
      NLOOP = 2
      GO TO 40
C * INTERRUPT INTERCEPT
   30 IF (LRET == 6 .AND. IWIN == 1) THEN
        XG = 0.0
        YG = 0.0
        ZG = 0.0
        IG = 9
        CALL GGIP (XG, YG, ZG, IG)
        IF (IG == 1) CC = .TRUE.
      END IF
C * RESET LABEL POSITION STATUS
      IPR(201) = 0
C * CHECK FOR STEREO OPTION
      IF (IPR(116) == 0) NLOOP = MOD (NLOOP + 1, 2)
C * MOUSE REORIENT LOOP
   40 IPR(478) = 0
   50 IPR(478) = IPR(478) + 1
      IF (CC) GO TO 210
C * SET PROBABILITY LEVEL
      PAR(46) = PROBA(IPR(45))
C * OPEN FILE FOR RASTER3D
      IF (IPR(108) /= 0) THEN
        OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'.rst',
     1                          STATUS = 'UNKNOWN')
        WRITE (LU65, 99996, IOSTAT = IOST) JID(1:50)
        CALL GEN005 (RMAT, TMAT)
      END IF
C * SETUP RELEVANT TRANSFORMATION MATRICES
C * ORIENTATION MATRIX
      IF (IPR(116) == 1) PAR(389) = PAR(389) -9.0 + 6.0 * IPR(478)
      IF (NLOOP >= 1) THEN
        DUMMY = - PAR(389) / RGBL(6)
        CALL GEN051 (0, RMAT, DUMMY, IPR(479))
      END IF
C * CHECK FOR 'NOT' RECALCULATE LABEL POSITION
      IF (LRET /= 6) PAR(389) = 0.0
C * DERIVE DEORTHOGONALIZATION MATRIX 'ROR' FROM ORTH-MATRIX 'OR'
      CALL GEN003 (OR, ROR, DET, 0)
C * TRANSFORM DEORTHOGONALIZATION MATRIX FOR NEW ORIENTATION
      CALL GEN004 (ROR, RMAT, RORO)
C * GET ORIENTATION MATRIX 'AAREV'
C * ROWS CONTAIN COMPONENTS OF A,B & C RESP IN XO,YO,ZO
      CALL GEN004 (AA, RORO, AAREV)
C * DECOMPOSE RMAT INTO SEQUENCE OF 3 ROTATIONS
      CALL GEN005 (RMAT, DUMV)
      CALL GEN096 (DUMV, IROTX, IROTY, IROTZ, IDET, V6, YNK, RORO)
      RGBL(28) = IROTX
      RGBL(29) = IROTY
      RGBL(30) = IROTZ
      IGBL(87) = IDET
C * ESTABLISH REFERENCE POINT OF VIEW
        DO I = 1, 3
          VIEWV(I) = RORO(I, 3)
        END DO
        CALL GEN007 (AA, VIEWV, VIEWV, -1)
C * AUTOMATIC ORIGIN AND/OR SCAL
      PAR(37) = PAR(38) * PAR(50)
      CALL GEN074 (PAR, 58, 60, -1.E5)
      CALL GEN074 (PAR, 55, 57,  1.E5)
      IPR(477) = 0
C * GET DISPLACEMENT PARAMETERS (EIGENVECTORS & EIGENVALUES) FROM SCRATCH
C * (PREPARED IN PLA024)
      IREF = IPR(297)
      DO I = 1, NASUP
        YNK = 0
        DO J = 1, 9
          YNK       = YNK + ABS (VOID(IREF + J))
          CON(I, J) = VOID(IREF + J)
        END DO
        IF (YNK == 0.0) THEN
          CON(I, 1) = 1.0
          CON(I, 5) = 1.0
          CON(I, 9) = 1.0
        END IF
        IREF = IREF + 21
        DO J = 1, 3
          IF (I > NATOM) THEN
            XSD(I, J) = VOID(IREF + J - 12) / 2.0
          ELSE
            XSD(I, J) = VOID(IREF + J - 12)
          END IF
        END DO
C * CHECK FOR INCLUSION IN THIS PLOT
        IF (IATP(I) <= NP1) THEN
C * FIT BOX AROUND SET OF ATOMS FOR SCALING
          DO J = 1, 3
            V1(J) = VOID((I - 1) * NP71 + J)
          END DO
          CALL GEN002 (-1, AAREV, V1, V7, XLNG)
          IPR(477)       = IPR(477) + 1
          IATC(IPR(477)) = I
          DATC(IPR(477)) = V7(3)
          CALL GEN048 (-1, IFG(2, I), 27, ISKP)
          IF (ISKP == 0) THEN
            DO J = 1, 3
              PAR(57 + J) = MAX (PAR(57 + J), V7(J))
              PAR(54 + J) = MIN (PAR(54 + J), V7(J))
            END DO
          END IF
        END IF
      END DO
C * AUTOMATIC SCALE AND POSITION DETERMINATION SECTION
C * SCALE
      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)
C * POSITION
      DO I = 1, 2
        V2(I) = (PAR(36 + I) - PAR(45) *
     1          (PAR(57 + I) + PAR(54 + I))) / 2.0
      END DO
      V2(3) = 0.0
C * SORT ATOM LIST BY Z-PARAMETER
      CALL GEN036 (DATC, IATC, 1, IPR(477))
C * STORE PROJECTED ATOM CONICS
C * LOOP THROUGH ALL ATOMS IN SORTED ATOMS LIST
      DO I = 1, IPR(477)
        N  = NASUP + I
        IA = IATC(I)
        IF (IA /= 0) THEN
          CALL GEN048 (-1, IFG(2, IA), 27, ISKP)
          IF (ISKP == 0) THEN
C * GET COORDINATES AND EIGENVALUES**2
            DO J = 1, 3
              V1(J) = VOID((IA - 1) * NP71 + J)
C * CHECK/RESET NEGATIVE Eigenvalues
              IF (XSD(IA, J) < 0.001) XSD(IA,J) = 0.001
              V6(J) = 1.0 / XSD(IA, J)**2
            END DO
C * CALCULATE ORTHOGONAL COORDINATES FOR CURRENT ORIENTATION :
C *                                         V7  = V1 * AAREV
            CALL GEN002 (-1, AAREV, V1, V7, XLNG)
C * TO PDB
C * REST FOR RASTER-3D
            IF (IPR(108) /= 0) THEN
              CALL PLA047 (LABA(IA), NQ2, IDUM, JDUM, 0,
     1          IGBL(55), 1, 0)
              WRITE (LU65, 99998, IOSTAT = IOST)
     1          IA, NQ2(1:7), 0, (V7(J), J = 1, 3), 1.0, 0.0
              L    = 0
              IANI = 1
              CALL GEN048 (-1, IFG(1, IA), 7, IHAT)
              IF (IHAT == 1) THEN
                CALL GEN048 (-1, IFG(1, IA), 4, IANI)
              END IF
              DO J = 1, 3
                DO K = 1, 3
                  L = L + 1
                  UIJC(J, K) = VOID(IPR(297) + IA * 21 + L - 9)
     1                       * 10000.0
                  IF ((IANI == 0 .OR. NQ2(1:2) == 'CG')
     1              .AND. J == K) UIJC(J, K) = 25
                END DO
              END DO
              CALL GEN001 (1, TMAT, UIJC, UIJC)
              WRITE (LU65, 99997, IOSTAT = IOST)
     1          IA, NQ2(1:7), 0, (NINT (UIJC(J, J)), J = 1, 3),
     2          NINT (UIJC(1, 2)), NINT (UIJC(1, 3)), NINT (UIJC(2, 3))
            END IF
C * SCALE AND CENTER MOLECULE COORDINATES (CM)
            DO J = 1, 3
              XXO(I, J) = V7(J) * PAR(45) + V2(J)
            END DO
C * GET CONTRAVARIANT EIGENVECTORS IN COLUMNS OF PAC
            DO M = 1, 9
              J = MOD (M - 1, 3) + 1
              K = ((M - 1) / 3)  + 1
              PAT(J, K) = CON(IA, M)
            END DO
C * TRANSFORM TO CARTESIAN SYSTEMS
C * TRANSPOSE(TRANSPOSE(PAT) * AAREV) = TRANSPOSE(AAREV) * PAT = PAC
            CALL GEN005 (AAREV, QD)
            CALL GEN004 (QD, PAT, PAC)
C * FORM QUADRATIC FORM 'A'
            CALL GEN099 (PAC, V6, QD)
C * CALCULATE ENVELOPING CYLINDER ALONG Z OF WORKING SYSTEM
            DO J = 1, 2
              DO K = 1, 2
                QD(J, K) = QD(J, K) - QD(J, 3) * QD(K, 3) / QD(3, 3)
              END DO
            END DO
            DO J = 1, 2
              QD(J, 3) = 0.0
              QD(3, J) = 0.0
              V6(J)    = XXO(I, J)
            END DO
C * PROJECTED ELLIPSE IN HOMOGENEOUS COORDINATES ABOUT CENTER OF ATOM
            QD(3, 3) = - PAR(47)**2
C * FIT RECTANGLE AROUND ELLIPSE ALLOWING OVERLAP MARGIN
C * FORM MATRIX OF COFACTORS, RESCALED SO THAT QCC(3,3)=1.0
            CALL GEN003 (QD, QCC, DUMMY, 1)
            TD2 = QD(3, 3)
            NDG = 0
            DO J = 1, 2
C * SOLVE QUADRATIC EQUATION
              T1 = QCC(3, J)**2 - QCC(J, J)
              IF (T1 <= 0.0) THEN
C * ROUNDOFF PROBLEMS, RESET LIMITS IN X OR Y
                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)
              END IF
              XXO(N, 2 * J - 1) = V6(J) - V5(J)
              XXO(N, 2 * J)     = V6(J) + V5(J)
            END DO
            IF (NDG == 0) THEN
              IF (TD2 < 0.0) THEN
C * STORE NORMALIZED QUADRATIC COEFFICIENTS FOR ELLIPSE
C * SCALED BY OVERLAP MARGIN PARAMETER
                TD3 = - (1.0 - 2.0 * PAR(44) / (V5(1) + V5(2)))**2
     1              / TD2
                XSD(N, 1) = QD(1, 1) * TD3
                XSD(N, 2) = QD(1, 2) * TD3
                XSD(N, 3) = QD(2, 2) * TD3
                CYCLE
              END IF
            END IF
C * ELLIPSE IMAGINARY DUE TO ROUNDOFF, RESET TO REAL VALUE
            XSD(N, 1) = 4.0 / (XXO(N, 2) - XXO(N, 1))**2
            XSD(N, 2) = 0.0
            XSD(N, 3) = 4.0 / (XXO(N, 4) - XXO(N, 3))**2
          END IF
        END IF
      END DO
C * GET BOND DATA: AT1, AT2, NR-LINES, RADIUS
      K   = NASUP + 1
      NCD = 0
      DO I = 1, NCB
C * GET ATOM NUMBERS IN BOND
        IATP1 = IATP(NINT (VOID(IPR(298) + I * 3 - 2)))
        IATP2 = IATP(NINT (VOID(IPR(298) + I * 3 - 1)))
C * SKIP BONDS IN EXCLUDED RESIDUES
        IF (IATP1 < NP1 .AND. IATP2 < NP1) THEN
          XSD(K, 4) = IATP1
          XSD(K, 5) = IATP2
C * NEGATIVE VALUE INDICATES DASHED BOND
          XBND = VOID(IPR(298) + I * 3)
C * 'NUMBER OF LINES ON BONDS'
          XB   = PAR(84 + NINT (ABS (XBND)))
          IF (XB < 0) THEN
            XB   = - XB
            XBND = - ABS (XBND)
          END IF
          XSD(K, 6) = SIGN (128 / 2**XB, XBND)
          XXO(K, 5) = PAR(85 + NINT (ABS (XBND)))
          NCD = NCD + 1
          K   = K   + 1
        END IF
      END DO
C * CHECK FOR RASTER3D
      IF (IPR(108) /= 0) THEN
        CLOSE (UNIT = LU65)
        IF (IPR(477) > 1) CALL PLA209
        IPR(108) = 0
        GO TO 50
      END IF
C * INITIALIZE ARRAYS SCIR (3 * 130) AND DP (2 * 130) ON 0
   60 CALL GEN074 (SCIR, 1, 390, 0.0)
      CALL GEN074 (DP,   1, 260, 0.0)
C * GRAPHICS OUTPUT SECTION
      PVER = PAR(349)
C * INIT GRAPHICS AND SET SCALING
      IF (IPR(478) <= 1 .AND. NLOOP >= 1) THEN
        BCD(1:12) = 'P.L.A.T.O.N'//CHAR (0)
        CALL GGIP (PAR(37), PAR(38), 0.0, 1)
      END IF
C * CHECK FOR RECALCULATE LABEL POSITION
      IF (IWIN == 1 .AND. LRET == 6) THEN
        BCD = 'Click on Window to STOP Rotation'//CHAR (0)
        CALL GGIP (-999.0, 2.0, 33.0, 111)
      END IF
      IF (IPR(116) == 0) THEN
C * SET DEFAULT COLOR
        CALL GGIP (0.0, 1.0, 0.0, 0)
      ELSE
C * RG-STEREO COLORS
        CALL GGIP (0.0, FLOAT (IPR(143 + IPR(478) - 1)), 0.0, 0)
      END IF
C * PLOT BOX
      CALL PLA110 (PAR(37), PAR(38), 1)
C * DRAW BONDS
C * GET ACTIVE NUMBER OF BONDS
      IF (NCD > 0 .OR. IPR(201) == 0) THEN
        NQD   = 0
        V8(1) = 0.0
        V8(2) = 0.0
        V8(3) = 1.0
C * MLOOP = 1 : BOND OUTLINE STORAGE RUN
C * MLOOP = 2 : BOND PLOT RUN
C * MLOOP = 3 : LABEL SETTING RUN
        IF (NCD == 0) THEN
          MILP = 3
        ELSE
          MILP = 1
        END IF
        IF (IGBL(75) /= 0 .AND. IPR(201) == 0) THEN
          MLP = 3
        ELSE
          MLP = 2
        END IF
        DO MLOOP = MILP, MLP
C * DETERMINE BOND/LABEL LOOP MAXIMUM
          IF (MLOOP < 3) THEN
            MNB = NCD
          ELSE
            MNB = IPR(477)
          END IF
C * LOOPS OVER ACTIVE BONDS/OR LABELS
          DO 140 NBLP = 1, MNB
            IF (CC) GO TO 210
C * LOOP OVER ACTIVE BONDS
            NSHIFT = 1
   70       IF (MLOOP < 3) THEN
              NBND = NINT (XSD(NASUP + NBLP, 6))
              IF (NBND > 0) THEN
                IDASH = 0
              ELSE
                IDASH = 1
                NBND  = IABS (NBND)
              END IF
C * GET DATA RELEVANT TO THIS BOND IN W
C *
C * W(I, J)   1       2    ATOM WITH HIGHEST Z IN FIRST POSITION
C * ====================
C *    1     KD1     KD2   ADDRESSES OF BOND ATOMS IN PRIM. ATOM LIST
C *    2     X1      X2  -I
C *    3     Y1      Y2  -I - TRANSFORMED COORDINATES
C *    4     Z1      Z2  -I
              KD1     = NINT (XSD(NASUP + NBLP, 4))
              KD2     = NINT (XSD(NASUP + NBLP, 5))
              W(1, 1) = KD1
              W(1, 2) = KD2
              NA1     = 0
              NA2     = 0
              ID1     = 0
              DO K = 1, IPR(477)
                L = IATC(K)
                IF (L /= 0) THEN
                  I = 0
                  IF (L == KD1) THEN
                    NA1 = K
                    I   = 1
                    CALL GEN048 (-1, IFG(2, L), 27, ISKP)
                    IF (ISKP == 1) GO TO 140
                  ELSE IF (L == KD2) THEN
                    NA2 = K
                    I   = 2
                    CALL GEN048 (-1, IFG(2, L), 27, ISKP)
                    IF (ISKP == 1) GO TO 140
                  END IF
                  IF (I /= 0) THEN
C * OBTAIN POSITIONAL PARAMETERS (PROJECTED)
                    DO J = 2, 4
                      W(J, I) = XXO(K, J - 1)
                    END DO
                    IF (NA1 > 0 .AND. NA2 > 0) THEN
C * FIND UPPERMOST ATOM PUT IN POSITION ONE
                      IF (W(4, 1) < W(4, 2)) THEN
C * SWAP ATOMS AND RELATED DATA
                        DO J = 1, 4
                          CALL GEN018 (W(J, 1), W(J, 2))
                        END DO
                        CALL GEN014 (NA1, NA2)
                      END IF
                      ID1 = NA1 * (NP1 + 1) + NA2
                      IF (NEXIT == 0) EXIT
                    END IF
                  END IF
                END IF
              END DO
              IF (ID1 == 0) GO TO 140
C * FORM VECTOR SET RADIAL TO BOND
              DO I = 1, 3
                DAM(I, 3) = W(1 + I, 2) - W(1 + I, 1)
              END DO
              CALL GEN007 (AA, DAM(1, 3), V3, 1)
C * CALCULATE DISTANCE
              IF (MLOOP == 2) DIST = SQRT (DAM(1, 3)**2 + DAM(2, 3)**2
     1           + DAM(3, 3)**2) / PAR(45)
C * UNIT VECTOR FROM BOND MIDPOINT TO REFERENCE VIEWPOINT
              CALL GEN002 (-1, RORO, AAREV(1, 3), V2, XLNG)
              CALL GEN007 (AA, V2, V2, 1)
              T6 = ABS(GEN009 (V3, V2))
C * SKIP BOND IF BOND IS ALONG REFERENCE VIEW DIRECTION
              IF (0.9994 <= T6) GO TO 140
              CALL GEN019 (AA, BB, V3, V2, B, 1)
              TX = XXO(NASUP + NBLP, 5) / PAR(46)
C * GENERATE ELLIPSE FROM TWO CONJUGATE VECTORS
C * ORTHONORMAL VECTORS PRODUCE 8-128 SPOKED CIRCLE
C * ND DENOTES NUMBER OF SUBDIVISIONS (1 TO 5)
              DO 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
              END DO
              DO K = 1, 3
                T1 = SQRT (1.0 /
     1            (2.0 * (1.0 + COS (RGBL(5) / (2**(K + 1))))))
                KDEL  = 2**(6 - K)
                KDEL1 = KDEL + 1
                KDEL2 = KDEL / 2
                DO L = KDEL1, 65, KDEL
                  J = L - KDEL
                  M = L - KDEL2
                  DO N = 1, 3
                    T2 = (SCIR(N, L) + SCIR(N, J)) * T1
                    SCIR(N, M)      =  T2
                    SCIR(N, M + 64) = -T2
                  END DO
                END DO
              END DO
C * DERIVE QUADRICS FOR EACH ATOM CONSTITUTING THE BOND
              DO II = 1, 2
                N = NINT (W(1, II))
C * CONTRAVARIANT EIGENVECTORS FOR Q IN COLUMNS OF PAC
                DO I = 1, 9
                  J = MOD (I - 1, 3) + 1
                  K = ((I - 1) / 3)  + 1
                  PAT(J, K) = CON(N, I)
                END DO
C * TRANSFORM TO CARTESIAN SYSTEMS
C * TRANSPOSE(TRANSPOSE(PAT) * AAREV) = TRANSPOSE(AAREV) * PAT = PAC
                CALL GEN005 (AAREV, QM)
                CALL GEN004 (QM, PAT, PAC)
C * FORM DIAGONAL MATRIX OR ITS INVERSE
                DO J = 1, 3
                  IF (XSD(N, J) /= 0.0) THEN
                    V6(J) = 1.0 / XSD(N, J)**2
                  ELSE
                    V6(J) = 1.0
                  END IF
                END DO
C * FORM QUADRATIC FORM
                CALL GEN099 (PAC, V6, QM)
C * DOES BOND GOTO ELLIPSOID OR TO ENVELOPE
                T1 = 3 - II * 2
                DO J = 1, 3
                  V3(J) = V3(J) * T1
                END DO
                IF (GEN006 (V3, QM, V8) < 0.0) THEN
                  IBND = 0
C * DERIVE TANGENT CYLINDER WITH AXIS ALONG Z
                  T1 = - 1.0 / QM(3, 3)
                  DO J = 1, 2
                    DO K = 1, 2
                      S(K, J) = QM(K, J) + QM(K, 3) * QM(J, 3) * T1
                    END DO
                    S(3, J) = 0.0
                    S(J, 3) = 0.0
                  END DO
                  S(3, 3) = 0.0
                ELSE
C * TRANSFER ELLIPSOID
                  DO J = 1, 3
                    DO K = 1, 3
                      S(J, K) = QM(J, K)
                    END DO
                  END DO
                  IBND = II
                END IF
                T5 = 1.0
C * CHECK FOR BOND TAPER
                IF (II < 2) THEN
                  RADIUS = 1.0 + T6 * PAR(48)
                ELSE
                  RADIUS = 1.0 - T6 * PAR(48)
                END IF
                CALL GEN002 (1, S, V3, V4, XLNG)
                T2 = GEN009 (V3, V4)
C * COMPUTE BOND INTERSECTION
                KL = 5 - 2 * II
                IF (MLOOP == 2) THEN
                  KSTP = 4
                ELSE
                  KSTP = 32
                END IF
                DO K = 1, 65, KSTP
                  DO J = 1, 3
                    V6(J) = SCIR(J, K) * RADIUS
                    V5(J) = V6(J)
                  END DO
                  T3 = GEN009 (V5, V4)
                  T4 = T3 * T3 - T2 * (GEN006(V5, S, V5) - T5)
                  IF (T4 < 0.0000001) GO TO 140
                  T4 = SQRT (T4)
                  T1 = ( T4 - T3) / T2
                  T3 = (-T4 - T3) / T2
                  L  = K + KL - 1
                  DO J = 1, 3
                    SCIR(J, L)     = ( V6(J) + T1 * V3(J)) * PAR(47)
                    SCIR(J, L + 1) = (-V6(J) - T3 * V3(J)) * PAR(47)
                  END DO
                END DO
                IF (IBND + MLOOP == 2) THEN
C * FOR OVERLAP, MAKE BOND QUADRANGLE TANGENT TO ENVELOPING CONE
                  T4 = T2 * T5
                  IF (T4 < 0.0) GO TO 140
                  T1 = SQRT (T4)  / T2
                  DO 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
                  END DO
                END IF
C * 3D CARTESIAN TO 2D PLOTTER COORDINATES
                DO 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)
                END DO
                IF (IBND == 1) THEN
C * 3D CARTESIAN TO 2D PLOTTER COORDINATES
                  DO 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)
                  END DO
                  CYCLE
                END IF
C * RETRACE TOP HALF
                DO K = 4, 64, 4
                  L = K + II
                  M = L + 64
                  N = 66 - L
                  IF (N <= 0) EXIT
                  DP(1, M) = DP(1, N)
                  DP(2, M) = DP(2, N)
                END DO
              END DO
C * CHECK FOR OVERLAP OR HIDDEN BOND
              DO K = 1, 65, 32
                T1 = 0.0
                T2 = 0.0
                DO J = 1, 2
                  T1 = T1 + (DP(J, K)     - W(J + 1, 1))**2
                  T2 = T2 + (DP(J, K + 1) - W(J + 1, 1))**2
                END DO
                IF (T2 <= T1) GO TO 140
              END DO
            ELSE
C * LOOP OVER LABELS (MLOOP = 3 CASE)
              NTOM = NASUP + NBLP
 
C * GET ATOM NUMBER IN FULL ATOM DATA LIST
              KAT  = IATC(NBLP)
              IF (KAT == 0) GO TO 140
C * IGNORE SUPPORT ATOM (CG etc)
              IF (KAT > NATOM) THEN
                IF (IPR(506) == 0) GO TO 140
              END IF
C * GET ATOM TYPE
              CALL GEN048 (-4, IFG(1, KAT), 15,  NO1)
C * GET H-ATOM BIT
              CALL GEN048 (-1, IFG(1, KAT),  7, IHAT)
C * GET H-INCLUDE BIT
              CALL GEN048 (-1, IFG(2, KAT), 12, HINC)
              NO1 = NO1 + 1
C * PLOT LABEL FOR NON-HATOMS + (HATOMS OPTIONAL)
              IF ((IHAT /= 1 .AND. IEN(NO1) /= 2 * IPR(618)) .OR.
     1          (MAX (IPR(212), HINC) * IPR(232) == 1 .AND.
     2           IPR(618) == 0)) THEN
                NPOS = 0
C * GET LABEL AND NUMBER OF NON-BLANK POSITIONS (NP)
                CALL PLA047 (LABA(KAT), NQ1, IDUM, JDUM,
     1            IPR(350), IGBL(55), 0, 1 - IGBL(55))
C * STRIP BLANKS
                CALL GEN039 (1, NQ1, 1, 6, NB, NP)
C * FETCH ENCLOSING BOX DIMENSIONS FOR THIS ELLIPSOID
C * XXO(NTOM, 1:4) = XMIN, XMAX, YMIN, YMAX
                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
C * DETERMINE STARTING POSITION FOR SEARCH
                IF (POSL(5) > PAR(37) / 2.0) THEN
                  IF (POSL(6) > PAR(38) / 2.0) THEN
                    IPOS = 2
                  ELSE
                    IPOS = 0
                  END IF
                ELSE
                  IF (POSL(6) > PAR(37) / 2.0) THEN
                    IPOS = 4
                  ELSE
                    IPOS = 6
                  END IF
                END IF
              ELSE
                GO TO 140
              END IF
            END IF
C * MLOOP/1/2 -HANDLING
            IF (MLOOP == 1) THEN
C * STORES BOND OUTLINE INFORMATION
              NQD = NQD + 1
C * CALCULATE OVERLAP MARGIN FOR BOND QUADRANGLE
              T1 = 0.0
              T2 = 0.0
              DO 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
              END DO
              IF (T1 * T2 <= 0.0) THEN
                T1 = 0.0
                T2 = 0.0
              ELSE
                T1 = PAR(44) / SQRT (T1)
                T2 = PAR(44) / SQRT (T2)
              END IF
C * STORE BOND QUADRANGLE
              NREF = NASUP + NQD
              DO 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)
              END DO
              JNSC(1, NQD) = ID1
            ELSE
C * LABEL OVERLAP TEST
   80         IF (MLOOP == 3) THEN
C * GET LABEL COORDINATES
C * POSITION LABEL CLOSE TO ASSOCIATED ELLIPSOID OUTLINE BOX
   90           IPOS = MOD (IPOS, 8) + 1
                NPOS = NPOS + 1
                KKKA = KAT * NP71
                IF (NPOS > 8) THEN
                  IF (NSHIFT < 10) GO TO 70
C * REPORT LABEL POSITIONING PROBLEM
                  IF (LRET /= 6) THEN
C * CHECK FOR ZERO ROTATION STEP
                    IF (PAR(389) == 0.0) THEN
                      WRITE (LU6, 99999, IOSTAT = IOST) NQ1
                    END IF
                  END IF
                  IF (IGBL(105) == 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
                  END IF
                  GO TO 140
                END IF
                LPOS1  = LPOS(IPOS, 1)
                LPOS2  = LPOS(IPOS, 2)
                LPOS12 = LPOS1 * 10 + LPOS2
                SELECT CASE (LPOS12)
                  CASE (23)
                    XSHFT = - XSFT
                    YSHFT =   YSFT
                  CASE (24)
                    XSHFT = - XSFT
                    YSHFT = - YSFT
                  CASE (14)
                    XSHFT =   XSFT
                    YSHFT = - YSFT
                  CASE (13)
                    XSHFT =   XSFT
                    YSHFT =   YSFT
                  CASE DEFAULT
                    XSHFT  = 0.0
                    YSHFT  = 0.0
                END SELECT
                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)
C * CHECK BOUNDARY
                IF (DP(1, 1) < 0.0 .OR. DP(1, 65) > PAR(37) .OR.
     1              DP(2, 1) < 0.0 .OR. DP(2, 65) > PAR(38))
     2              GO TO 90
                ID1 = 0
                NA1 = 0
                NA2 = 0
C * CHECK FOR LABEL_LABEL OVERLAP
                IF (NBLP > 1) THEN
                  NBM1 = NBLP - 1
                  DO J = 1, NBM1
                    N = IATC(J)
                    IF (N /= 0) THEN
                      CALL GEN048 (-1, IFG(2, N), 27, ISKP)
                      IF (ISKP == 0) THEN
                        IF (IPR(232) == 0) THEN
                          CALL GEN048 (-1, IFG(1, N), 7, JHAT)
                          ISKP = JHAT
                        END IF
                        IF (ISKP == 0) THEN
                          L    = KAT * NP71
                          M    = N   * NP71
                          DSX  = ABS (VOID(L - 2) - VOID(M - 2))
                          DSY  = ABS (VOID(L - 1) - VOID(M - 1))
                          IF (DSY < 1.1 * PAR(349)) THEN
                            IF (DSX < MAX (PHOR, VOID(M)))
     1                          GO TO 90
                          END IF
                        END IF
                      END IF
                    END IF
                  END DO
                END IF
C * SHOW LABEL BOXES (IN DEBUG MODE)
                IF (IGBL(74) /= 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 PLA439 (0.0, CHAR (48 + IPOS), 1, 0.3, 2, 1,
     1               DP(1, 1), DP(2, 1))
                END IF
              END IF
C * CHECK FOR ATOMS AND BONDS OVERLAPPING BOND OR LABEL NA1-NA2
C * ATOM WITH HIGHEST Z-VALUE HAS HIGHEST ATOM NUMBER
              IPR(151) = 0
              IPR(152) = 0
              IQ       = NQD + 1
              IQN      = IQ + NASUP
C * FIT RECTANGLE AROUND QUADRANGLE & SAVE QUADRANGLE TEMPORARILY
              DO 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)
              END DO
              JNSC(1, IQ) = ID1
C * CHECK FOR ATOM-OVER-BOND OVERLAP
              DUMP = 0.0
              CALL PLA107 (0, 0, 0, DUMP)
              NA1P1 = NA1 + 1
              DO IA = NA1P1, IPR(477)
                IATCIA = IATC(IA)
                IF (IATCIA /= 0) THEN
                  IF (IA /= NA2 .AND. IATCIA <= NATOM) THEN
                    NIA = NASUP + IA
                    CALL GEN048 (-1, IFG(2, IATCIA), 27, ISKP)
                    IF (ISKP == 0) THEN
C * ROUGH CHECK FOR ATOM-OVER-BOND OVERLAP
                      DO J = 1, 2
                        IF (YMAX(J) <= XXO(NIA, 2 * J - 1)) ISKP = 1
                        IF (YMIN(J) >= XXO(NIA, 2 * J    )) ISKP = 1
                      END DO
                      IF (ISKP == 1) CYCLE
C * CHECK FOR TRUE ATOM-OVER-BOND OVERLAP
                      DUMP = 0.0
                      CALL PLA107 (1, IQ, IA, DUMP)
                      IF (DUMP > 0.0) THEN
                        IF (IPR(151) >= NP15) EXIT
                      ELSE IF (DUMP < 0.0) THEN
                        GO TO 140
                      END IF
                    END IF
                  END IF
                END IF
              END DO
C * ROUGH CHECK FOR BOND-OVER-BOND OVERLAP OF BOND/LABEL NA1-NA2
C * SKIP IN CASE OF NO-BOND OUTLINES STORED
C * TEST FOR # BONDS > 0
              IF (NQD > 0) THEN
C * GET UNIT VECTOR ALONG BOND
                IF (MLOOP < 3) THEN
                  DO J = 1, 3
                    V1(J)  = XXO(NA2, J) - XXO(NA1, J)
                  END DO
                  CALL GEN007 (AA, V1, V1, 1)
                END IF
C * LOOP OVER PROJECTED BOND OUTLINES
                DO 120 IB = 1, NQD
                  NIB = NASUP + IB
                  ID2 = JNSC(1, IB)
                  IF (ID1 == ID2) GO TO 120
                  NB2 = MOD (ID2, NP1 + 1)
                  NB1 = ID2 / (NP1 + 1)
                  IF (NA2 > NB1) GO TO 120
                  DO J = 1, 2
                    IF (YMAX(J) <= MIN (CON(NIB, J), CON(NIB, J + 2),
     1                CON(NIB, J + 4), CON(NIB, J + 6))) GO TO 120
                    IF (YMIN(J) >= MAX (CON(NIB, J), CON(NIB, J + 2),
     1                CON(NIB, J + 4), CON(NIB, J + 6))) GO TO 120
                  END DO
C * SET UP LINEAR FORMS FOR EDGES OF QUADRANGLE
                  DO 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)
C * NORMALIZE LINE EQUATION COEFFICIENTS
                    T1 = SQRT (QUA(1, L)**2 + QUA(2, L)**2)
                    IF (T1 <= 0.0) GO TO 120
                    DO J = 1, 3
                      QUA(J, L) = QUA(J, L) / T1
                    END DO
                  END DO
C * EVALUATE LINEAR FORMS AND SIGNATURES FOR QUADRANGLE
                  T3    = 3.0
                  NASIQ = NASUP + IQ
                  SCONX = 0.0
                  SCONY = 0.0
                  DO 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 L = 1, 4
                      T1 = XCONK * QUA(1, L)
     1                   + YCONK * QUA(2, L) + QUA(3, L)
                      IF (T1 < 0.0) T2 = T2 - 1.0
                      FL(L, K) = T1
                    END DO
                    IF (T2 < 0.0) T3 = T3 - 1.0
                  END DO
                  IF (MLOOP == 3) THEN
                    XCONK = SCONX / 4.0
                    YCONK = SCONY / 4.0
                    T2    = 3.0
                    DO L = 1, 4
                      T1 = XCONK * QUA(1, L)
     1                   + YCONK * QUA(2, L) + QUA(3, L)
                      IF (T1 < 0.0) T2 = T2 - 1.0
                    END DO
                    IF (T2 < 0.0) GO TO 80
                  END IF
C * CHECK FOR 4 POINTS INSIDE QUADRANGLE
                  IF (T3 < 0.0) THEN
                    ITYPE = -1
C * CHECK FOR 1 TO 3 POINTS INSIDE QUADRANGLE
                  ELSE IF (T3 < 3.0) THEN
                    ITYPE = 0
                  ELSE
C * DETERMINE WHICH EDGES ARE CROSSED BY THE 4 LINE SEGMENTS
                    NASIQ = NASUP + IQ
                    DO L = 1, 4
                      L1 = MOD (L, 4) + 1
C * LINE SEGMENT L FROM POINT Y1 TO POINT Y2
                      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 K = 1, 4
                        T1 = FL(K, L)
                        T2 = FL(K, L1)
                        T3 = T1 - T2
C * T1 AND T2 MUST HAVE OPPOSITE SIGNS FOR INTERSECTION TO OCCUR
                        IF (T1 * T2 <= 0.0) THEN
C * COMPONENT OF SEGMENT L PERPENDICULAR TO EDGE K OF IB IS T3
                          IF (ABS(T3) > PAR(54)) THEN
C * CALCULATE COORDINATES OF INTERSECTION
                            T4 = (T1 * Y2(1) - T2 * Y1(1)) / T3
                            T5 = (T1 * Y2(2) - T2 * Y1(2)) / T3
                            K0 = 2 * K
                            K1 = 2 * (MOD (K, 4) + 1)
C * IS INTERSECTION WITHIN QUADRANGLE IQ
                            IF ((T4 - CON(NIB, K0 - 1)) *
     1                         (CON(NIB, K1 - 1) - T4)
     2                        + (T5 - CON(NIB, K0)) *
     3                         (CON(NIB, K1) - T5)
     4                       > -1.E-4) GO TO 100
                          END IF
                        END IF
                      END DO
                    END DO
                    GO TO 120
  100               ITYPE = 1
                  END IF
                  IF (MLOOP < 3) THEN
C * CHECK FOR EXACT DISORDERED BOND OBERLAP
                    DIF = 0.0
                    DO J = 1, 3
                      DIF = DIF + ABS (XXO(NA1,J) - XXO(NB1, J)) +
     1                            ABS (XXO(NA2,J) - XXO(NB2, J))
                    END DO
                    IF (DIF < 0.001) GO TO 120
C * CHECK OVER/UNDER AMBIGUITY
                    IF (NA1 == NB1 .OR.
     1                  NA1 == NB2 .OR.
     2                  NA2 == NB2 .OR.
     3                  NA2 == NB1) THEN
C * BONDS SHARE AN ATOM
                      IF ((NA1 + NA2) < (NB1 + NB2)) THEN
                        GO TO 110
                      ELSE
                        GO TO 120
                      END IF
                    END IF
                    DO J = 1, 3
                      V2(J) = XXO(NB2, J) - XXO(NB1, J)
                      V4(J) = XXO(NB1, J) - XXO(NA1, J)
                    END DO
C * GET UNIT-VECTORS
                    CALL GEN007 (AA, V2, V2, 1)
                    CALL GEN007 (AA, V4, V4, 1)
                    CALL GEN011 (BB, V1, V2, V3, 1)
                    IF (GEN009 (V3, V3) <= PAR(54)) THEN
C * PARALLEL BONDS, RECALCULATE V3
                      CALL GEN011 (BB, V1, V4, V5, 1)
                      CALL GEN011 (BB, V5, V1, V3, 1)
C * CHECK FOR COLLINEAR BONDS
                      YNK = GEN009 (V3, V3) - PAR(54)
                      IF (YNK > 0.0) THEN
                        IF (V3(3) <= 0.0) GO TO 120
                      END IF
                      GO TO 110
                    END IF
                    IF (GEN009 (V3, V4) < - PAR(54)) THEN
                      DO J = 1, 3
                        V3(J) = - V3(J)
                      END DO
                    END IF
C * V3 IS NORMAL TO BONDS IQ AND IB GOING FROM IQ TOWARD IB
                    IF (V3(3) <= 0.0) GO TO 120
C * OVERLAPPING BOND FOUND
C * HIDDEN BOND
                  END IF
  110             IF (ITYPE < 0) GO TO 140
C * STORE INTERFERING QUADRANGLE
                  IF (IPR(152) < NP7) THEN
                    IPR(152) = IPR(152) + 1
                    DO K = 1, 4
                      DO J = 1, 3
                        XDIR(IPR(152), J, K) = QUA(J, K)
                      END DO
                    END DO
                    IDIR(IPR(152)) = IB
                  ELSE
C * OVERFLOW WARNING
                    WRITE (6, 99992)
                    GO TO 130
                  END IF
  120           CONTINUE
              END IF
C * DRAW BOND ENDS OUTLINE
  130         IF (MLOOP < 3) THEN
                CALL PLA108 (1, 4, 129, 3)
                CALL PLA108 (2, 4, 66,  3)
C * DRAW BOND DETAIL (DIRECTION OF DRAWING ALTERNATED)
                BDIR = - 0.5
                DO K = 1, 65, NBND
                  BDIR = - BDIR
                  DO J = 1, 2
                    DP(J, 130 + NINT (1.5 - BDIR)) = DP(J, K)
                    DP(J, 130 + NINT (1.5 + BDIR)) = DP(J, K + 1)
                  END DO
C * FULL/DASHED BOND
                  IF (IDASH == 1) THEN
                    NSTEP = NINT(DIST / 0.4) * 2 + 1
                  ELSE
                    NSTEP = 1
                  END IF
                  DELX  = (DP(1, 132) - DP(1, 131)) / NSTEP
                  DELY  = (DP(2, 132) - DP(2, 131)) / NSTEP
                  DO 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
                  END DO
                END DO
              ELSE
C * CHECK FOR CROT
                IF (IPR(151) > 0 .OR. IPR(152) > 0) GO TO 80
              END IF
            END IF
  140     CONTINUE
        END DO
      END IF
C * LOOP THROUGH ATOM LIST TO DRAW ELLIPSOIDS
      DO 200 ITOM = 1, IPR(477)
        IF (CC) GO TO 210
        NTOM = NASUP + ITOM
C * GET ATOM NUMBER IN FULL ATOM DATA LIST
        KAT = IATC(ITOM)
        IF (KAT == 0) GO TO 200
C * IGNORE SUPPORT ATOM (CG etc)
        IF (KAT > NATOM) THEN
          IF (IPR(506) == 0) GO TO 200
        END IF
C * IGNORE ELIMINATED ATOMS
        CALL GEN048 (-1, IFG(2, KAT), 27, ISKP)
        IF (ISKP == 1) GO TO 200
C * GET ENCLOSING BOX DIMENSIONS
        DO J = 1, 2
          YMIN(J) = XXO(NTOM, 2 * J - 1)
          YMAX(J) = XXO(NTOM, 2 * J    )
        END DO
C * GET ATOM TYPE
        CALL GEN048 (-4, IFG(1, KAT), 15, NO1)
        NO1 = NO1 + 1
C * SET ELLIPSOID GRAPHIC DETAILS
C * C-ATOM
        IF (IEN(NO1) == 2) THEN
          NFRST = IPR(175)
          LINES = IPR(176)
C * H-ATOM (H, D OR Hw)
        ELSE IF (IEN(NO1) == 1 .OR. IEN(NO1) == 33 .OR.
     1           IEN(NO1) == 113) THEN
          NFRST = IPR(177)
          LINES = IPR(178)
C * OTHER
        ELSE
          NFRST = IPR(179)
          LINES = IPR(180)
        END IF
C * ENVELOPE
        IF (IPR(211) == 1) THEN
          NFRST = 0
C * OCTANT
        ELSE IF (IPR(211) == 2) THEN
          CALL GEN048 (-1, IFG(1, KAT), 7, IVAL)
          IF (IVAL == 0) THEN
            NFRST = 1
          ELSE
            NFRST = IPR(177)
          END IF
          LINES = IPR(180)
        END IF
C * NFRST = 1 : 3D ELLIPSOIDS, NFRST = 0 : 2D OUTLINE
        DO J = 1, 3
          V1(J) = VOID((KAT -1) * NP71 + J)
          V7(J) = XXO(ITOM, J)
        END DO
C * GET LABEL AND NUMBER OF NON-BLANK POSITIONS
        CALL PLA047 (LABA(KAT), NQ1, IDUM, JDUM, IPR(350),
     1               IGBL(55), 0, 1 - IGBL(55))
C * PLOT LABEL
        IF (IGBL(75) > 0) THEN
          CALL GEN048 (-1, IFG(2, KAT), 11, IVAL)
          CALL GEN048 (-1, IFG(2, KAT), 12, HINC)
          CALL GEN048 (-1, IFG(1, KAT),  7, IHAT)
          IF ((IHAT /= 1 .AND. IEN(NO1) >  IPR(618) * 2) .OR.
     1      (MAX (IPR(212), HINC) * IPR(232) > 0 .AND.
     2       IPR(618) .EQ.0)) THEN
C * SET COLOR BLACK
            IF (IPR(116) == 0) THEN
              IF (IPR(328) == 0) THEN
                COLX = FLOAT (IVAL)
              ELSE
                COLX = FLOAT (2 - IVAL)
              END IF
              CALL GGIP (0.0, COLX, 0.0, 0)
            END IF
            XLPOS = VOID(KAT * NP71 - 2)
            YLPOS = VOID(KAT * NP71 - 1)
            IF ((XLPOS > 1.0 .OR. YLPOS > 1.0)
     1          .AND. COLX /= 0.0) CALL PLA439
     1         (0.0, NQ1, 6, PAR(349), -1, 1, XLPOS, YLPOS)
            IF (IPR(116) == 0) CALL GGIP (0.0, 1.0, 0.0, 0)
          END IF
        END IF
C * IGNORE CG-ELLIPSOIDS
        IF (KAT > NATOM) GO TO 200
C * SET ATOM COLOR
        IF (IPR(116) == 0 .AND. IPR(346) == 1) THEN
          CALL GEN048 (-4, IFG(1, KAT), 15, NRI)
          CALL GGIP (0.0, FLOAT (IACL(NRI + 1)) , 0.0, 0)
        END IF
C * OVERLAP HANDLING
        IPR(151) = 0
        IPR(152) = 0
        IF (IPR(477) > ITOM) THEN
C * ROUGH CHECK FOR OVERLAPPING ATOMS
          L = 0
          DO 180 IA = ITOM, IPR(477)
C * IGNORE SUPPORT ATOMS (EG Cg ..)
            IATCIA = IATC(IA)
            IF (IATCIA == 0) GO TO 180
            IF (IATCIA > NATOM) GO TO 180
            CALL GEN048 (-1, IFG(2, IATCIA), 27, ISKP)
            IF (ISKP == 1) GO TO 180
            NIA = NASUP + IA
            IF (IA > ITOM) THEN
              DO J = 1, 2
                IF (YMAX(J) <= XXO(NIA, 2 * J - 1)) GO TO 180
                IF (YMIN(J) >= XXO(NIA, 2 * J    )) GO TO 180
              END DO
            END IF
C * EXACT CHECK FOR OVERLAPPING ATOMS
            IF (L < 2) L = L + 1
            IF (L == 2) THEN
              OVMR = 0.0
            ELSE
              OVMR = PAR(44)
            END IF
C * TRANSFORM CONIC TO PLOTTER HOMOGENEOUS COORDINATE SYSTEM
            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 K = 1, 2
              QA(K, 3, L) = 0.0
              DO J = 1, 2
                QA(K, 3, L) = QA(K, 3, L) - V12(J, L) * QA(J, K, L)
              END DO
              QA(3, K, L) = QA(K, 3, L)
              QA(3, 3, L) = QA(3, 3, L) - QA(3, K, L) * V12(K, L)
            END DO
C * CALCULATE COFACTORS AND DETERMINANTS
            CALL GEN003 (QA(1, 1, L), QC(1, 1, L), DET, -1)
            DETER(L) = DET * 3.0
C * DETER(L) IS THE DETERMINANT TIMES 3
            IF (L < 2) GO TO 180
C * FORM CHARACTERISTIC EQUATION AND EXAMINE ITS ROOTS
            AOV3 = 0.0
            BOV3 = 0.0
            DO J = 1, 3
              DO K = 1, 3
                AOV3 = AOV3 + QC(J, K, 2) * QA(J, K, 1)
                BOV3 = BOV3 + QC(J, K, 1) * QA(J, K, 2)
              END DO
            END DO
            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)
C * CHECK DISCRIMINANT OF CHARACTERISTIC CUBIC EQUATION
            POV3CU = POV3**3
            QOV2SQ = QOV2**2
            PQTEST = POV3CU + QOV2SQ
            IF (PQTEST > 0.0) THEN
              IF (PQTEST + POV3CU * 0.00001 > 0.0) THEN
                GO TO 170
              END IF
            ELSE IF (PQTEST < 0.0) THEN
              IF (PQTEST + QOV2SQ * 0.00001 < 0.0) THEN
C * THREE REAL ROOTS, ALL DIFFERENT
C * NO INTERSECTION IF A/3 AND B/3 INVARIANTS ARE NEGATIVE
                IF (AOV3 < 0.0) THEN
                  IF (BOV3 < 0.0) GO TO 180
                END IF
C * CALCULATE ONE ROOT OF CHARACTERISTIC CUBIC EQUATION
                IF (QOV2 == 0.0) THEN
                  PHI = RGBL(5) / 4.0
                ELSE
                  PHI = ATAN (- SQRT ( - PQTEST) / QOV2)
                  IF (PHI < 0.0) PHI = PHI + RGBL(5) / 2.0
                END IF
                ROOT = 2.0 * SQRT ( - POV3) * COS (PHI / 3.0) - AOV3
                GO TO 150
              END IF
            END IF
C * THREE REAL ROOTS, AT LEAST TWO ARE EQUAL
C * CHECK SIGNS OF INVARIANTS A/3 AND B/3
            IF (AOV3 < 0.0 .AND. BOV3 < 0.0) GO TO 180
C * CALCULATE REPEATED ROOT OF CUBIC EQUATION
            ROOT = SIGN (SQRT( - POV3), QOV2) - AOV3
C * FORM DEGENERATE CONIC (LINE PAIR WHICH MAY BE COINCIDENT)
  150       DO J = 1, 3
              DO K = 1, 3
                DAM(J, K) = QA(J, K, 1) + ROOT * QA(J, K, 2)
              END DO
            END DO
C * EXAMINE INVARIANTS OF THE DEGENERATE CONIC
            T6 = DAM(1, 1) * DAM(2, 2)
            T7 = DAM(1, 2)**2
C * NEGATIVE DENOTES REAL INTERSECTING LINE PAIR
C * POSITIVE DENOTES IMAGINARY LINES INTERSECTING AT REAL POINT
            IF (T6 > 1.0001 * T7) THEN
              GO TO 160
            ELSE IF (T6 <  0.9999 * T7) THEN
              GO TO 170
            ELSE
              T8 = DAM(3, 3) * (DAM(1, 1) + DAM(2, 2))
              T9 = DAM(1, 3)**2 + DAM(2, 3)**2
C * NEGATIVE DENOTES REAL PARALLEL LINE PAIR
C * POSITIVE DENOTES IMAGINARY PARALLELS
C * ZERO DENOTES ONE REAL LINE (COINCIDENT PARALLELS)
              IF (T8 * 1.0001 < T9) GO TO 170
            END IF
C * COINCIDENT LINE PAIR FOUND FOR THE REPEATED ROOT
C * COMPARE AREAS OF CONICS
  160       IF (QC(3, 3, 1) < QC(3, 3, 2)) THEN
              KA = 2
              KB = 1
            ELSE
              KA = 1
              KB = 2
            END IF
C * SEE IF ONE CONIC IS INSIDE THE OTHER CONIC
            T1 = 0.0
            DO J = 1, 3
              T2 = QA(J, 3, KB)
              DO K = 1, 2
                T2 = T2 + QA(J, K, KB) * V12(K, KA)
              END DO
              T1 = T1 + V12(J, KA) * T2
            END DO
C * DISCARD IF KA IS OUTSIDE KB
            IF (T1 > 0.0) GO TO 180
C * THE OVERLAPPING ATOM HIDES THE ORIGINAL ATOM FOR KA = 1
            IF (KA == 1) GO TO 200
C * STORE OVERLAPPING ATOM
  170       IF (IPR(151) <  NP15) IPR(151) = IPR(151) + 1
            IJ = 1
            DO I = 1, 3
              DO J = I, 3
                XXO(IPR(174) + IPR(151), IJ) = QA(I, J, 2)
                IJ = IJ + 1
              END DO
            END DO
  180     CONTINUE
C * SECOND PART OF SUBROUTINE CHECKS FOR BONDS OVER THE ATOM
          IF (NQD > 0) THEN
            DUMP = 0.0
            CALL PLA107 (0, 0, 0, DUMP)
C * ROUGH CHECK FOR OVERLAPPING BONDS
            DO 190 IQ = 1, NQD
              NIQ = NASUP + IQ
              ID  = JNSC(1, IQ)
              NA1 = ID / (NP1 + 1)
              NA2 = MOD (ID, NP1 + 1)
              IF (ITOM <= NA2) THEN
                DO J = 1, 2
                  IF (YMAX(J) <= MIN (CON(NIQ, J),
     1              CON(NIQ, J + 2), CON(NIQ, J + 4),
     2              CON(NIQ, J + 6))) GO TO 190
                  IF (YMIN(J) >= MAX (CON(NIQ, J),
     1              CON(NIQ, J + 2), CON(NIQ, J + 4),
     2              CON(NIQ, J + 6))) GO TO 190
                END DO
C * EXACT CHECK FOR OVERLAPPING BONDS
                CALL PLA107 (-1, IQ, ITOM, YNK)
                IF (YNK < 0.0) GO TO 200
                IF (IPR(152) >= NP7) EXIT
              END IF
  190       CONTINUE
          END IF
        END IF
C * ELLIPSOID PRINCIPAL VECTORS TOWARD VIEWER
C * CONTRAVARIANT EIGENVECTORS FOR Q IN COLUMNS OF PAC
        DO I = 1, 9
          J = MOD (I - 1, 3) + 1
          K = ((I - 1) / 3)  + 1
          PAT(J, K) = CON(KAT, I)
        END DO
C * TRANSFORM TO CARTESIAN SYSTEMS
C * TRANSPOSE(TRANSPOSE(PAT) * AAREV) = TRANSPOSE(AAREV) * PAT = PAC
        CALL GEN005 (AAREV, QM)
        CALL GEN004 (QM, PAT, PAC)
C * FORM DIAGONAL MATRIX OR ITS INVERSE
        DO J = 1, 3
          T1 = XSD(KAT, J)
          IF (T1 /= 0.0) THEN
            V6(J)  = 1.0 / (T1**2)
          ELSE
            V6(J)  = 1.0
          END IF
          RMS(J) = T1
        END DO
C * FORM QUADRATIC FORM
        CALL GEN099 (PAC, V6, QM)
        CALL GEN002 (-1, AA, VIEWV, V2, XLNG)
        DO I = 1, 3
          IF (GEN009 (V2, PAT(1, I)) < 0.0) THEN
            DO J = 1, 3
              PAC(J, I) = - PAC(J, I)
              PAT(J, I) = - PAT(J, I)
            END DO
          END IF
        END DO
        DO J = 1, 3
          PAC(J, 4) = PAC(J, 1)
          PAC(J, 5) = PAC(J, 2)
        END DO
C * V4 = VECTOR NORMAL TO POLAR PLANE
        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)
C * SET PLOTTING RESOLUTION FOR ELLIPSOID
        T3     = RMS(3) * PAR(47)
        NRESOL = 1
        NBIS   = 5
        DO J = 1, 3
          IF (T3 < PAR(50 + J)) THEN
            NBIS   = NBIS - 1
            NRESOL = NRESOL * 2
          ELSE
            EXIT
          END IF
        END DO
        NRES1 = NRESOL + 1
C * LOOP THROUGH PRINCIPAL AND POLAR PLANES
        NFIRST = 4 - 3 * NFRST
        DO II = NFIRST, 4
          II0 = MOD (II + 2, 3) + 1
          II1 = MOD (II, 3) + 1
          II2 = MOD (II + 1, 3) + 1
C * GENERATE CONJUGATE DIAMETERS
          IF (0.99938 <= ABS(GEN009(V4, PAC(1, II2)))) THEN
            T1 = RMS(II0) * PAR(47)
            T2 = RMS(II1) * PAR(47)
            DO J = 1, 3
              DAM(J, 1) = PAC(J, II0) * T1
              DAM(J, 2) = PAC(J, II1) * T2
            END DO
          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 < 4) THEN
              CALL GEN011 (BB, V3, V1, V5, 1)
            ELSE
              CALL GEN011 (BB, V3, V4, V5, 1)
            END IF
            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 J = 1, 3
              DAM(J, 1) = V2(J) * PAR(47) / SQRT (T1)
              DAM(J, 2) = V5(J) * PAR(47) / SQRT (T2)
            END DO
          END IF
C * GENERATE ELLIPSE FROM TWO CONJUGATE VECTORS
C * ORTHONORMAL VECTORS PRODUCE 8-128 SPOKED CIRCLE
C * ND DENOTES NUMBER OF SUBDIVISIONS (1 TO 5)
          DO 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
          END DO
          DO K = 1, NBIS
            T1    =
     1        SQRT (1.0 / (2.0 * (1.0 + COS (RGBL(5) / 2**(K + 1)))))
            KDEL  = 2**(6 - K)
            KDEL1 = KDEL + 1
            KDEL2 = KDEL / 2
            DO L = KDEL1, 65, KDEL
              J = L - KDEL
              M = L - KDEL2
              DO N = 1, 3
                T2 = (SCIR(N, L) + SCIR(N, J)) * T1
                SCIR(N, M)      =   T2
                SCIR(N, M + 64) = - T2
              END DO
            END DO
          END DO
          IF (II < 4) THEN
C * PLOT HALF AN ELLIPSE
            JEND = 65
          ELSE
C * PLOT SOLID BOUNDARY ELLIPSE
            JEND = 129
          END IF
C * 3D CARTESIAN TO 2D PLOTTER COORDINATES
          DO J = 1, JEND, NRESOL
            DP(1, J) = SCIR(1, J) + V7(1)
            DP(2, J) = SCIR(2, J) + V7(2)
          END DO
          CALL PLA108 (1, 1, 1, 3)
          CALL PLA108 (NRES1, NRESOL, JEND, 2)
          IF (II < 4) THEN
C * DETAIL INTERIOR FEATURES
            DO 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
            END DO
C * SOLID LINE FOR FORWARD AXIS
            IF (LINES > 0) THEN
C * 3D CARTESIAN TO 2D PLOTTER COORDINATES
              DO I = 1, 3, 1
                DP(1, I) = DAM(1, I) + V7(1)
                DP(2, I) = DAM(2, I) + V7(2)
              END DO
              CALL PLA108 (1, 2, 3, 3)
C * SHADE QUADRANT BETWEEN TWO PRINCIPAL AXES
              L = LINES - 1
              IF (L > 0) THEN
                DO I = 1, L
                  T1 = FLOAT (I) / LINES
                  T3 = SQRT (1.0 - T1**2)
                  IF (MOD (I, 2) /= 0) THEN
                    M = I * 2
                    N = M - 1
                  ELSE
                    N = I * 2
                    M = N - 1
                  END IF
                  DO J = 1, 3
                    T4 = DAM(J, 1) * T1
                    SCIR(J, M) = T4
                    SCIR(J, N) = DAM(J, 2) * T3 + T4
                  END DO
                END DO
                L = L * 2
C * 3D CARTESIAN TO 2D PLOTTER COORDINATES
                DO I = 1, L
                  DP(1, I) = SCIR(1, I) + V7(1)
                  DP(2, I) = SCIR(2, I) + V7(2)
                END DO
                CALL PLA108 (1, 1, L, -3)
              END IF
            END IF
          END IF
        END DO
  200 CONTINUE
C * PLOT SPECIAL TEXT
      LMOD = 0
      CALL PLA109 (2, 0, 0.0, 0.0)
      IF (IGBL(75) > 0) IPR(201) = 1
C * CHECK FOR STEREO
      IF (IPR(478) > 0 .AND. IPR(478) == IPR(116)) GO TO 50
      IF (LRET == 6) GO TO 30
C * (MOUSE_LOOP) ISSUE AN END-OF-PICTURE
  210 IF (IGBL(6) == 22) THEN
        CALL PLA439 (-90.0, 'ORTEP: CONTOUR-MAP INPUT', 24, 0.8,
     1    5 + IGBL(68), 3, PAR(37) - 1.0 , PAR(38) - 2.0)
        IF (IGBL(3) == 3) IGBL(3) = 0
        RETURN
      END IF
      NLOOP = 2
C * SPECIAL VERSION
      IF (META == 1) THEN
        CALL GGIP (0.0, 0.0, 0.0, -1)
        IGGT = 'END'
      ELSE
C * WHAT NEXT ?
        CALL PLA012 (0, 1)
        IF (IGBL(3) == 28) LRET = 7
        SELECT CASE (LRET)
          CASE (1)
            DO
* LOOK FOR GEOMETRY INSTRUCTIONS
              CALL PLA006 (0, IS)
              IF (IS == 1) THEN
                WRITE (LU6, 99995, IOSTAT = IOST)
                CALL PLA015 (0, 10)
                CYCLE
              END IF
C * END/EXIT
              IF (IFL(1)(1:3) == 'REM') THEN
                IGBL(6)  = 10
                IPR(351) = 0
                EXIT
              ELSE IF (IFL(1)(1:3) == 'END' .OR.
     1           IFL(1)(1:4) == 'EXIT') THEN
                IF (IFL(1)(1:3) == 'END')
     1            REWIND (UNIT = LU2, IOSTAT = IOST)
C * END OF INSTRUCTION SAVE OPTION
                IF (IGBL(3) == 3) THEN
                  IGBL(45) = -1
                END IF
                EXIT
C * SELECT ADP RESIDUE TO BE PLOTTED
              ELSE IF (IS == 185) THEN
                IYUNK = NINT (FN(1))
                IF (IYUNK >= 0 .AND. IYUNK <= IPR(75)) THEN
                  WRITE (ICL, 99994, IOSTAT = IOST) NINT (FN(1))
                  CALL PLA280 (ICL)
                EXIT
                END IF
              END IF
C * INTERACTIVE DIST, ANGLE AND TORSION LISTING
              SELECT CASE (IFL(1)(1:5))
                CASE ('DIST', 'ANGL', 'TORS')
                  IPR(81) = IPR(220)
                  CALL PLA440 (1)
                  GO TO 210
C * CHANGE B&W REVERSE
                CASE ('SET ')
                  IF (IFL(2)(1:3) == 'REV') THEN
                    IGBL(68) = MOD (IGBL(68) + 1, 2)
                    CALL GGIP (-999.0, FLOAT (IGBL(68)),
     1                IGBL(62) * 0.25, 9)
                    CALL GGIP (0.0, 0.0, 0.0, 6)
                    IGGT = 'MENU ON'
                    GO TO 210
                  ELSE IF (IFL(2)(1:3) == 'WIN') THEN
                    CALL GGIP (-999.0, FLOAT (IGBL(68)),
     1                FN(1) * 1000.0, 9)
                    IGBL(62) = MIN (MAX (1, NINT (FN(1) / 0.25)), 4)
                    CALL GGIP (0.0, 0.0, 0.0, 6)
                  ELSE
                    ISW = 1
                  END IF
C * LABEL (ON/OFF) TOGGLE
                CASE ('LABE')
                  IF (IPR(220) > 1) THEN
                    SELECT CASE (IFL(2)(1:5))
                      CASE ('ON   ')
                        IGBL(75) = 1
                      CASE ('OFF  ')
                        IGBL(75) = 0
                    END SELECT
                  ELSE
                    IGBL(75) = MOD (IGBL(75) + 1, 2)
                  END IF
                  GO TO 20
C * LIST OPTIONS
                CASE ('LIST')
                  ISW = -1
                  SELECT CASE (IFL(2)(1:5))
                    CASE ('ARU  ')
                      ISW = 0
                      CALL PLA043 (0, -2, LU6, 0)
C * WHAT NEXT ?
                      CALL PLA012 (1, 1)
                      IGBL(6) = 9
                      GO TO 20
C * LIST UIJ
                    CASE ('UIJ  ')
                      ISW = 0
                      IGBL(6) = 9
C * LIST UEQ
                    CASE ('UEQ  ')
                      ISW = 0
                      IGBL(6) = 9
C * LIST ATOMS
                    CASE ('ATOM ', 'ATOMS')
                      ISW = 0
                      IGBL(6) = 9
C * LIST FLAGS
                    CASE ('FLAG ')
                      ISW = 0
                      IGBL(6) = 9
C * LIST RADII
                    CASE ('RADII')
                      ISW = 0
                      IGBL(6) = 9
C * LIST FLAGS
                    CASE ('FLAGS')
                      ISW = 0
                      IGBL(6) = 9
                  END SELECT
C * CALC
                CASE ('CALC')
                  ISW = 0
                  IF (IFL(2)(1:4) == 'COOR') THEN
                    IF (IFL(3)(1:6) == '******') CYCLE
                    CALL PLA037 (3, NID, 3)
                    IF (IPR(2) /= 0) THEN
                      WRITE (LU6, 99993) IFL(3)
                      IPR(2) = 0
                      CYCLE
                    END IF
                  END IF
                CASE DEFAULT
                  ISW = 0
              END SELECT
              IF (ISW /= 0 .AND. IPR(220) > 1) THEN
C * SET META TYPE
                IF (IFL(2)(1:3) == 'MET') THEN
                  MEDIUM = 2
                  IF (IPR(220) > 2) CALL GGIP (-999.0, 0.0, 0.0, 6)
                ELSE
C * LIST AND SET OF IPR/PAR/IGBL/RGBL
                  CALL PLA206 (ISW, IFL(2)(1:3))
                END IF
                ISW = 0
                GO TO 210
              END IF
C * TRANSFER TO PLUTON
              IF (IFL(1)(1:6) == 'PLUTON') THEN
                CALL PLA280 (IFL(1)(1:7))
              ELSE
                CALL PLA280 (ICL)
              END IF
              IF (NEXIT == 0) EXIT
            END DO
          CASE (2)
            GO TO 50
          CASE (3)
            GO TO 60
C * NEW CONTENT AND ORIENTATION PLOT
          CASE (4)
            GO TO 20
          CASE (5)
C * SPECIAL TEXT
            LMOD = 0
            CALL PLA109 (1, 0, 0.0, 0.0)
            GO TO 210
          CASE (6)
            GO TO 30
          CASE (7)
          CASE (8)
            GO TO 10
          CASE DEFAULT
            GO TO 30
        END SELECT
      END IF
C * RECOVER ARRAYS (XXO, XSD, CON)
      CALL PLA269 (-1, NASUP)
      IF (IGBL(3) == 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', /)
99994 FORMAT ('PLOT ADP RESD ', I5)
99993 FORMAT (/,':: Label Error: ', A)
99992 FORMAT ('NP7 OVERFLOW WARNING IN ORTEP/OVERLAP')
      END SUBROUTINE PLA106
 
      SUBROUTINE PLA107 (MODE, IQ, IA, PCQ)
C * SUBROUTINE CHECKS FOR OVERLAP BETWEEN ATOMS AND BONDS
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: K1
      INTEGER               :: L1
      INTEGER               :: IQ
      INTEGER               :: IA
      INTEGER               :: ID
      INTEGER, SAVE         :: ITY
      INTEGER               :: NIA
      INTEGER               :: NIQ
      INTEGER               :: NA1
      INTEGER               :: NA2
      INTEGER               :: MODE
      INTEGER               :: NSUP
      INTEGER               :: NASUP
      INTEGER               :: NATOM
      INTEGER               :: ITYPE
      REAL                  :: T1
      REAL                  :: T2
      REAL                  :: T3
      REAL                  :: T4
      REAL                  :: T5
      REAL                  :: TX
      REAL                  :: PCQ
      REAL                  :: OVMG
      REAL                  :: GEN009
      REAL, DIMENSION(4)    :: BF
      REAL, DIMENSION(5)    :: QF
      REAL, DIMENSION(3, 4) :: QUA
      REAL, DIMENSION(3, 3) :: CONX
C * MODE = 0, INITIALIZE
C * MODE > 0, CHECK FOR ATOMS OVER A BOND
C * MODE < 0, CHECK FOR BONDS OVER AN ATOM
      IF (MODE == 0) THEN
        ITY = 0
      ELSE
C * GET NUMBER OF ATOMS
        NATOM = IPR(39)
C * GET NUMBER OF SUPPORT POSITIONS
        NSUP  = IPR(64)
        NASUP = NATOM + NSUP
        NIA   = NASUP + IA
        NIQ   = NASUP + IQ
        PCQ   = 0.0
        ID    = JNSC(1, IQ)
        NA1   = ID / (NP1 + 1)
        NA2   = MOD (ID, NP1 + 1)
        ITY   = ITY + MODE
        IF (ITY > 0) THEN
          OVMG = 0.0
        ELSE
          OVMG = PAR(44)
        END IF
        IF (ITY > -2) THEN
C * TRANSFORM CONIC TO PLOTTER HOMOGENEOUS COORDINATE SYSTEM
          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 K = 1, 2
            CONX(K, 3) = 0.0
            DO J = 1, 2
              CONX(K, 3) = CONX(K, 3) - V1(J) * CONX(J, K)
            END DO
            CONX(3, K) = CONX(K, 3)
            CONX(3, 3) = CONX(3, 3) - CONX(3, K) * V1(K)
          END DO
        END IF
        IF (ITY < 2) THEN
C * SET UP LINEAR FORMS FOR EDGES OF QUADRANGLE
          DO 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 <= 0.0) THEN
              ITY = 0
              RETURN
            END IF
C * TRANSFORM COEFFICIENTS FOR EDGES TO NORMAL FORM
            DO J = 1, 3
              QUA(J, L) = QUA(J, L) / T1
            END DO
          END DO
        END IF
C * EVALUATE 4 QUADRATIC AND 4 BILINEAR FORMS
        V2(3) = 1.0
        V3(3) = 1.0
        T2    = 3.0
        DO 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 K = 1, 3
            T1 = CONX(3, K)
            DO J = 1, 2
              T1 = T1 + V2(J) * CONX(J, K)
            END DO
            QF(L) = QF(L) + T1 * V2(K)
            BF(L) = BF(L) + T1 * V3(K)
          END DO
          IF (QF(L) == 0.0)  THEN
            T2 = T2 - 0.8
          ELSE IF (QF(L) < 0.0) THEN
            T2 = T2 - 1.0
          END IF
        END DO
        QF(5) = QF(1)
C * CHECK FOR 4 POINTS OF QUADRANGLE INSIDE OR ON ELLIPSE
        IF (T2 < 0.0) THEN
          ITYPE = -1
        END IF
C * CHECK FOR 1 TO 3 POINTS OF QUADRANGLE INSIDE THE ELLIPSE
        IF (T2 >= 2.2)  THEN
C * CHECK FOR QUADRANGLE-ELLIPSE INTERSECTION
          DO K = 1, 4
C * EVALUATE DISCRIMINANT
            T1 = BF(K)**2 - QF(K) * QF(K + 1)
            IF (T1 > 0.0) THEN
              T1 = SQRT (T1)
C * IS INTERSECTION WITHIN BOUNDS OF QUADRANGLE
              T3 = QF(K) - BF(K)
              T4 = T3 + QF(K + 1) - BF(K)
              IF (ABS (T4) > PAR(54)) THEN
                T5 = (T3 - T1) / T4
                IF (T5 >= 0.0 .AND. T5 < 1.0) THEN
                  ITYPE = 0
                  IF (NA2 == IA) THEN
                    GO TO 20
                  ELSE IF (NA2 > IA) THEN
                    IF (NA1 >= IA) THEN
                      GO TO 20
                    ELSE
                      GO TO 10
                    END IF
                  ELSE
                    GO TO 10
                  END IF
                END IF
              END IF
            END IF
          END DO
C * NO VALID INTERSECTION FOUND
C * CHECK FOR CENTER OF ELLIPSE WITHIN THE QUADRANGLE
          T3 = 3.0
          DO K = 1, 4
            T1 = QUA(3, K)
            DO J = 1, 2
              T1 = T1 + V1(J) * QUA(J, K)
            END DO
            IF (T1 < 0.0) T3 = T3 - 1.0
          END DO
          IF (T3 >= 0.0) RETURN
          ITYPE = 1
          IF (IA >= NA2 .OR. IA <= NA1) GO TO 20
        ELSE
          ITYPE = 0
          IF (NA2 == IA .OR. (NA2 > IA .AND. NA1 >= IA))
     1        GO TO 20
        END IF
C * HANDLE ID, NA1 & NA2 = 0 CASE (LABELS ?)
   10   IF (ID == 0) GO TO 30
C * CHECK OVER/UNDER AMBIGUITY
        DO I = 1, 3
          V2(I) = XXO(NA2, I) - XXO(NA1, I)
          V3(I) = XXO(IA,  I) - XXO(NA1, I)
        END DO
        CALL GEN007 (AA, V2, V2, 1)
        CALL GEN007 (AA, V3, V3, 1)
        CALL GEN011 (BB, V2, V3, V4, 1)
        IF (GEN009 (V4, V4) <= PAR(54)) THEN
C * CENTER OF ATOM IQ IS ON THE BOND LINE
          IF (ITY > 0) THEN
            GO TO 30
          ELSE
            RETURN
          END IF
        END IF
C * CENTER OF ATOM IQ IS NOT ON THE BOND LINE
        CALL GEN011 (BB, V4, V2, V5, 1)
        T1 = - V5(3)
C * NO INTERFERENCE FOUND : PCQ = 0
        IF (T1 * FLOAT(ITY) > 0.0) RETURN
C * ITYPE = 1 ENCLOSED ELLIPSE / ITYPE = -1 ENCLOSED QUADRANGLE
   20   IF (ITYPE * ITY < 0) THEN
C * HIDDEN ATOM OR HIDDEN BOND
          PCQ = -1.0
          RETURN
        END IF
   30   PCQ = 1.0
        IF (ITY < 0) THEN
C * STORE INTERFERING QUADRANGLE
          IF (IPR(152) < NP7) THEN
            IPR(152) = IPR(152) + 1
            DO K = 1, 4
              DO J = 1, 3
                XDIR(IPR(152), J, K) = QUA(J, K)
              END DO
            END DO
            IDIR(IPR(152)) = IQ
          END IF
        ELSE
C * STORE INTERFERING ELLIPSE
          IF (IPR(151) < NP15) THEN
            IPR(151) = IPR(151) + 1
            L = 1
            DO I = 1, 3
              DO J = I, 3
                XXO(IPR(174) + IPR(151), L) = CONX(I, J)
                L                           = L + 1
              END DO
            END DO
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA107
 
      SUBROUTINE PLA108 (IND1, IND2, IND3, NPEN)
C * ELIMINATE HIDDEN AND DRAW VISIBLE LINE PARTS
      USE parameters
      USE plato
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IM
      INTEGER :: I12
      INTEGER :: NCO
      INTEGER :: KCQ
      INTEGER :: KBG
      INTEGER :: NIQ
      INTEGER :: IND1
      INTEGER :: IND2
      INTEGER :: IND3
      INTEGER :: NPEN
      INTEGER :: LPEN
      INTEGER :: KEND
      INTEGER :: MINT
      INTEGER :: NCOK
      INTEGER :: NQOVR
      INTEGER :: NCOVR
      INTEGER :: NCTOT
      INTEGER :: NASUP
      INTEGER :: NEXIT
      REAL    :: P0
      REAL    :: P1
      REAL    :: T1
      REAL    :: T2
      REAL    :: T3
      REAL    :: T4
      REAL    :: T5
      REAL    :: T6
      REAL, DIMENSION(3) :: Y
      REAL, DIMENSION(3) :: Z
      REAL, DIMENSION(2) :: YN
      REAL, DIMENSION(2) :: YO
      REAL, DIMENSION(2) :: SEG
C * NPEN =  3 - FIRST MOVE, THEN DRAW SEQUENCE
C * NPEN =  2 = DRAW SEQUENCE
C * NPEN = -3 = ALTERNATING MOVE,DRAW SEQUENCE
C * IND1 = BEGIN
C * IND2 = STEP
C * IND3 = END
C * NUMBER OF ATOM TYPE OBJECTS
      NASUP = IPR(39) + IPR(64)
C * NUMBER OF OVERLAPPING ATOM OBJECTS
      NCOVR = IPR(151)
C * NUMBER OF OVERLAPPING BOND OBJECTS
      NQOVR = IPR(152)
C * TOTAL NUMBER OF OVERLAPPING OBJECTS
      NCTOT = NCOVR + NQOVR
C * GET ADDRESS -1 OF COVER DATA
      NCO   = IPR(174)
      ZGGIP = 0.0
      LPEN  = IABS(NPEN)
      NEXIT = 0
C * LOOP OVER MOVE/DRAW INSTRUCTIONS IN ARRAY DP
      DO N = IND1, IND3, IND2
C * GET X & Y ; CHECK THEM AGAINST BOUNDRY LIMITS
        DO J = 1, 2
          Y(J) = MAX (0.0, MIN (DP(J, N), PAR(36 + J)))
        END DO
C * CHECK FOR NO OVERLAP
        IF (NCTOT == 0) THEN
          CALL GGIP (Y(1), Y(2), ZGGIP, LPEN)
        ELSE
C * CHECK ALL OVERLAPPING ATOMS AND BONDS
          IF (LPEN == 2) THEN
C * SAVE INFORMATION FROM LAST POINT IF PEN IS DOWN
            DO K = 1, 2
              YO(K) = YN(K)
            END DO
C * LOAD COVER DATA
            DO K = 1, NCTOT
              XSD(NCO + K, 1) = XSD(NCO + K, 2)
            END DO
            IF (NQOVR > 0) THEN
              DO K = 1, NQOVR
                DO J = 1, 4
                  CON(NCO + K, J) = CON(NCO + K, J + 4)
                END DO
              END DO
            END IF
          END IF
C * EVALUATE CONIC QUADRATIC FORMS AT NEW POINT YN (YN(3) = 1.0)
          DO K = 1, 2
            YN(K) = Y(K)
          END DO
          IF (NCOVR > 0) THEN
            KBG  = NCO + 1
            KEND = NCO + NCOVR
            DO 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)
C * EVALUATE CONIC BILINEAR FORM IF PEN IS DOWN
              IF (LPEN == 2) THEN
                XSD(K, 5) = Z(1) * YO(1) + Z(2) * YO(2) + Z(3)
              END IF
            END DO
          END IF
C * EVALUATE LINEAR FORMS AND SIGNATURE FOR QUADRANGLE
          IF (NQOVR > 0) THEN
            KCQ = NCO + NCOVR
            DO K = 1, NQOVR
              T2 = 3.0
              DO J = 1, 4
                T1 = YN(1) * XDIR(K, 1, J) + YN(2) * XDIR(K, 2, J)
     1             + XDIR(K, 3, J)
                IF (T1 < 0) T2 = T2 - 1.0
                CON(NCO + K, J + 4) = T1
              END DO
              KCQ = KCQ + 1
C * T2 = -1 INSIDE, = 0 ACROSS ANY EDGE, = 1 ACROSS ANY VERTEX
              XSD(KCQ, 2) = T2
            END DO
          END IF
C * IF PEN IS UP, OMIT ALL SUBSEQUENT CHECKING
          IF (LPEN == 3) THEN
            CALL GGIP (YN(1), YN(2), ZGGIP, 3)
            GO TO 20
          ELSE
C * CHECK FOR HIDDEN SEGMENT
            DO K = 1, NCTOT
              IF (XSD(NCO + K, 1) < 0.0 .AND.
     1            XSD(NCO + K, 2) < 0.0) THEN
                CALL GGIP (YN(1), YN(2), ZGGIP, 3)
                GO TO 20
              END IF
            END DO
          END IF
C * FIND ENTRY AND EXIT POINTS ON EACH CONIC
          MINT = 0
          IF (NCOVR > 0) THEN
            DO K = 1, NCOVR
              NCOK = NCO + K
C * EVALUATE DISCRIMINANT
              T1 = XSD(NCOK, 5)**2 - XSD(NCOK, 1) * XSD(NCOK, 2)
              IF (T1 > 0.0) THEN
                T1 = SQRT (T1)
C * SOLVE QUADRATIC EQUATION
                T2 =      XSD(NCOK, 1) - XSD(NCOK, 5)
                T3 = T2 + XSD(NCOK, 2) - XSD(NCOK, 5)
                IF (ABS (T3) > PAR(54)) THEN
                  T4 = (T2 - T1) / T3
                  T5 = (T2 + T1) / T3
C * VALID INTERSECTION IF T4 < 1 AND T5 > 0
                  IF (T4 < 1.0 .AND. T5 > 0.0) THEN
C * SAVE VALID CONIC INTERSECTIONS
                    MINT               = MINT + 1
                    XSD(NCO + MINT, 3) = T4
                    XSD(NCO + MINT, 4) = T5
                  END IF
                END IF
              END IF
            END DO
          END IF
C * FIND ENTRY AND EXIT POINTS FOR EACH QUADRANGLE
          IF (NQOVR > 0) THEN
            DO K = 1, NQOVR
              I12 = 1
              KCQ = NCO + NCOVR + K
C * CHECK FOR SINGLE INSIDE POINT
              SEG(1) = XSD(KCQ, 1)
              IF (SEG(1) >= 0.0) THEN
                SEG(1) = 1.0 - XSD(KCQ, 2)
                IF (SEG(1) <= 1.0) I12 = 0
              END IF
C * I12 = 1 : INSIDE POINT FOUND, ONLY ONE INTERSECTION POSSIBLE
C * FIND WHICH EDGES ARE CROSSED BY THE SEGMENT
              DO J = 1, 4
                T1 = CON(NCO + K, J)
                T2 = CON(NCO + K, J + 4)
                T3 = T1 - T2
                IF (T1 * T2 <= 0.0) THEN
C * CHECK FOR SEGMENT ON AN EDGE
                  IF (ABS (T3) <= PAR(54)) THEN
                    I12 = 0
                    EXIT
                  END IF
C * CALCULATE COORDINATES OF INTERSECTION
                  T4  = (T1 * YN(1) - T2 * YO(1)) / T3
                  T5  = (T1 * YN(2) - T2 * YO(2)) / T3
                  L   = 2 * (MOD (J, 4) + 1)
                  NIQ = NASUP + IDIR(K)
C * IS INTERSECTION WITHIN LIMITS OF QUADRANGLE
                  T6 = (T4 - CON(NIQ, 2 * J - 1)) *
     1                 (CON(NIQ, L - 1) - T4) +
     2                 (T5 - CON(NIQ, 2 * J)) * (CON(NIQ, L) - T5)
                  IF (T6 > -1.E-4) THEN
C * CALCULATE FRACTION PARAMETER AND STORE IT
                    T1 = T1 / T3
                    IF (I12 < 1) THEN
C * STORE FIRST INTERSECTION
                      I12    = 1
                      SEG(1) = T1
                    ELSE IF (I12 == 1) THEN
C * STORE SECOND INTERSECTION
                      I12 = 2
                      IF (T1 >= SEG(1)) THEN
                        SEG(2) = T1
                      ELSE
                        SEG(2) = SEG(1)
                        SEG(1) = T1
                      END IF
                    ELSE
C * MORE THAN TWO INTERSECTIONS (I.E., QUADRANGLE DIAGONAL)
                      IF (T1 < SEG(1)) THEN
                        SEG(1) = T1
                      ELSE IF (T1 > SEG(1)) THEN
                        IF (T1 > SEG(2)) SEG(2) = T1
                      END IF
                    END IF
                  END IF
                END IF
              END DO
              IF (I12 > 1) THEN
C * STORE FRACTION PARAMETERS
                MINT               = MINT + 1
                XSD(NCO + MINT, 3) = SEG(1)
                XSD(NCO + MINT, 4) = SEG(2)
              END IF
            END DO
          END IF
C * END OF ENTRY-AND-EXIT-POINT CALCULATIONS
          IF (MINT == 0) THEN
C * NO INTERFERENCE FOUND, DRAW ENTIRE SEGMENT
            CALL GGIP (YN(1), YN(2), ZGGIP, 2)
            GO TO 20
          ELSE
C * SHELL-SORT SEGMENT INTERSECTION LIST
            M  = MINT
            DO
              M = M / 2
              IF (M == 0) EXIT
              K = MINT - M
              J = 1
              DO
                I = J
                DO
                  IM = I + M
                  IF (XSD(NCO + I, 3) < 0.0) THEN
                    IF (XSD(NCO + IM, 3) > 0.0) EXIT
                    IF (XSD(NCO + I, 4) <= XSD(NCO + IM, 4)) EXIT
                  ELSE
                    IF (XSD(NCO + I, 3) <= XSD(NCO + IM, 3)) EXIT
                  END IF
C * SWAP
                  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 <= 0) EXIT
                END DO
                J = J + 1
                IF (J >  K) EXIT
              END DO
            END DO
          END IF
C * FIND STARTING POINT P0 AND END POINT P1
          P0 = 0.0
          K  = 0
          DO
            K  = K + 1
            IF (K > MINT) THEN
              P1 = 1.0
            ELSE
              P1 = XSD(NCO + K, 3)
              IF (P1 < 0.0 .OR. P1 <= P0) THEN
                P0 = MAX (P0, XSD(NCO + K, 4))
                IF (P0 < 1.0) CYCLE
                P0 = 1.0
              END IF
            END IF
C * DRAW SEGMENT FROM P0 TO P1
   10       IF (P0 > 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 >= 1.0) GO TO 20
            END IF
            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 < 1.0) THEN
              P0 = MAX (P0, XSD(NCO + K, 4))
              IF (P0 < 1.0) CYCLE
              P0 = 1.0
              GO TO 10
            END IF
            IF (NEXIT == 0) EXIT
          END DO
        END IF
C * CHANGE MOVE/DRAW MODE FOR NEXT STEP DEPENDING ON NPEN-MODE
   20   IF (NPEN > 0) THEN
          LPEN = 2
        ELSE
          IF (LPEN == 3) THEN
            LPEN = 2
          ELSE
            LPEN = 3
          END IF
        END IF
      END DO
      RETURN
      END SUBROUTINE PLA108
 
      SUBROUTINE PLA109 (MODE, NTYP, X, Y)
C * PLOT SPECIAL TEXT (PLATON/PLUTON)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE tpos
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: MODE
      INTEGER :: NTYP
      INTEGER :: ITEM
      INTEGER :: IASU
      REAL    :: X
      REAL    :: Y
      REAL    :: XX
      REAL    :: YY
      REAL    :: XN
      REAL    :: XMAX
      REAL    :: YMAX
      I    = 0
      IASU = 0
      XMAX = 0.0
      YMAX = 0.0
C * NTYP = 0 - PLATON
C * NTYP = 1 - PLUTON
      IF (NTYP == 0) THEN
        XMAX = PAR(37)
        YMAX = PAR(38)
      ELSE IF (NTYP == 1) THEN
        XMAX = - PAR(61)
        YMAX = - PAR(62)
      END IF
C * MODE = 1 : NEW TEXT
   10 IF (MODE == 1) THEN
        IF (IWIN == 1) THEN
          I = IPR(447) + 1
          WRITE (SBCD, 99999) PAR(350), CHAR (0)
          CALL GEN038 (IGGT, 1, 80)
C * WHAT NEXT ?
          CALL PLA012 (0, 0)
          TKST(I) = IGGT(1:10)
          LINE    = IGGT
          CALL GEN038 (ICL,  1, 80)
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          CALL GEN125 (0, LU6, 'Give Text [ncharmax = 10] :')
          READ  (LU5, 99998) LINE
        END IF
        IF (LINE(1:1) == '!'    .OR. LINE(1:4) == 'TEXT' .OR.
     1      LINE(1:4) == 'PLOT' .OR. LINE(1:3) == 'END'  .OR.
     2      LINE(1:3) == 'REM'  .OR. LINE(1:4) == 'EXIT') THEN
          IPR(453)  = 0
          IPR(448)  = 0
          LINE      = '!'
          IF (NTYP == 1) THEN
            IGBL(6) = 3
          ELSE
            IGBL(6) = 8
          END IF
          RETURN
        END IF
C * STORE POSITION WITH REFERENCE TO CENTRE OF DRAWING
        IF (I == 1) THEN
          KMX = 1
          K   = KMX
        ELSE
          IF (KMX > 0) THEN
            DO J = 1, KMX
              IF (NTK(J) == 0) THEN
                K = J
                GO TO 20
              END IF
            END DO
          END IF
          KMX = KMX + 1
          K   = KMX
        END IF
   20   XTK(I, 1) = XMAX - 5.0
        XTK(I, 2) = YMAX - 1.0 - K
        NTK(K)    = 1
        XTK(I, 3) = PAR(350)
        IPR(447)  = I
        CALL PLA439 (0.0, TKST(I), 10, XTK(I, 3), -1, 1,
     1               XTK(I, 1), XTK(I, 2))
        GO TO 10
C * MODE = 2 : SPECIAL TEXT (RE-PLOT)
      ELSE IF (MODE == 2) THEN
        IF (IPR(173) * IPR(447) > 0) THEN
          DO I = 1, IPR(447)
            CALL PLA439 (0.0, TKST(I), 10, XTK(I, 3), 1, 1, XTK(I, 1),
     1                    XTK(I, 2))
          END DO
        END IF
C * MODE = 3 : DELETE TEXT
      ELSE IF (MODE == 3) THEN
        IASU = 0
        CALL PLA014 (3, NTYP, X, Y, ITEM, IASU)
        IF (ITEM /= 0) THEN
          CALL PLA439 (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) > 1) THEN
            DO I = 1, 3
              XTK(ITEM, I) = XTK(IPR(447), I)
            END DO
            TKST(ITEM) = TKST(IPR(447))
          END IF
          IPR(447) = IPR(447) - 1
        END IF
C * MODE = 4 : CHANGE TEXT SIZE
      ELSE IF (MODE == 4) THEN
        CALL PLA014 (3, NTYP, X, Y, ITEM, IASU)
        IF (ITEM /= 0) THEN
          CALL PLA439 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 0, 1,
     1                 XTK(ITEM, 1), XTK(ITEM, 2))
          XTK(ITEM, 3) = PAR(350)
          CALL PLA439 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 1, 1,
     1                   XTK(ITEM, 1), XTK(ITEM, 2))
        END IF
C * MODE = 5 : MOVE TEXT ITEM
      ELSE IF (MODE == 5) THEN
        IF (IPR(448) /= 0) THEN
          IF (IPR(447) > 0) THEN
            IF (LMOD == 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) < 0.05) THEN
                NTK(N) = 0
              END IF
            ELSE
              XX = - (NTYP * XMAX) + X
              YY =   YMAX - Y
              XTK(IMIN, 1) =  XX
              XTK(IMIN, 2) =  YY
              LMOD = 0
            END IF
            YGGIP = FLOAT (1 - LMOD)
            CALL PLA439 (0.0, TKST(IMIN), 10, XTK(IMIN, 3),
     1                        NINT (YGGIP), 1, XX, YY)
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT ('Give Text[ncharmax = 10, size =', F5.2, ']', A)
99998 FORMAT (A)
      END SUBROUTINE PLA109
 
      SUBROUTINE PLA110 (HORS, VERT, MODE)
C * PLOT BOX
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IP
      INTEGER :: IPRB
      INTEGER :: IDET
      INTEGER :: MODE
      INTEGER :: NJID
      INTEGER :: IROTX
      INTEGER :: IROTY
      INTEGER :: IROTZ
      REAL    :: VR
      REAL    :: VRT
      REAL    :: P14
      REAL    :: HORS
      REAL    :: VERT
      REAL    :: TSHFT
C * MODE -1 : BOX/TITL ONLY
C * MODE  0 : BOX/TITL/ROT'S
C * MODE  1 : BOX/TITL/ROT'S/PROB
      IF (IGBL(103) /= 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 >= 0) THEN
C * (NO)MOVE WARNING
          IF (IPR(116) == 0 .AND. IABS (IGBL(6)) /= 25) THEN
            IF (IGBL(30) == 1) THEN
              IF (IGBL(136) == 1) THEN
                CALL PLA439 (0.0, 'NOMOVE AND NO EXPAND FORCED', 27,
     1            P14, 3, 1, HORS - 45 * P14, VERT - 0.15 - P14)
              ELSE
                CALL PLA439 (0.0, 'NOMOVE FORCED', 13, P14, 3, 1,
     1                     HORS - 31 * P14, VERT - 0.15 - P14)
              END IF
            ELSE
              IF (IGBL(60) > 0) THEN
                CALL PLA439 (0.0, 'INPUT ATOMS MOVED', 17, P14, 2, 1,
     1                       HORS - 35 * P14, VERT - 0.15 - P14)
              END IF
            END IF
          END IF
C * DISPLAY LITERATURE REFERENCE
          IF (MODE == 1 .AND. IGBL(104) == 1 .AND.
     1                          IPR(116) == 0) THEN
            VRT = VERT - 1.0
            DO I = 1, 2 + IPR(565)
              VRT = VRT - 0.4
              CALL PLA439 (0.0, LREF(I), 79, 0.25, 5, 1, 1.0, VRT)
            END DO
          END IF
C * PLOT ROTATION ANGLES XR, YR AND ZR AND DETERMINANT
          IROTX = NINT (RGBL(28))
          IROTY = NINT (RGBL(29))
          IROTZ = NINT (RGBL(30))
          IDET  = IGBL(87)
          IF (IDET == -1 .AND. IPR(116) == 0)
     1        CALL PLA439 (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 PLA439 (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 PLA439 (90.0, NQ2, IP, P14, -1, 1, P14 + 0.15, VERT
     1                  - IP * P14)
          NQ3(1:1) = 'Z'
          CALL PLA439 (0.0, NQ3, 1, P14, -1, 1, 0.15, 0.15)
          CALL GEN040 (IROTZ, NQ3, IP)
          CALL PLA439 (0.0, NQ3, IP, P14, -1, 1, 0.15 + 2 * P14, 0.15)
          IF (MODE == 1) THEN
C * PLOT PROBABILITY LEVEL IN RIGHT UPPER CORNER
            IPRB = IPR(45) * 10
            CALL GEN040 (IPRB, NQ1, IP)
            CALL PLA439 (0.0, 'Prob =  '//NQ1(1:IP)//'%', 9 + IP,
     1        P14, -1, 1, HORS - (8 + IP) * P14, VERT - 0.15 - P14)
C * PLOT TEMPERATURE
            IF (IABS (IGBL(8)) == 3 .AND. IPR(310) > 0) THEN
              CALL GEN040 (IPR(310), NQ1, IP)
              CALL PLA439 (0.0, 'Temp = '//NQ1(1:IP)//'K', 8 + IP, P14,
     1          -1, 1, HORS - (7 + IP) * P14, VERT - 0.25 - 2 * P14)
            END IF
          END IF
          IF (IABS(IGBL(6)) /= 25) THEN
            NQ1 = 'RES=   '
            CALL GEN040 (IPR(140), NQ1(6:7), IP)
            CALL PLA439 (0.0, NQ1, 7, P14, -1, 1, HORS - 11 * P14,
     1                   0.15)
          END IF
        END IF
C * PLOT TITL
        NJID = MAX (74, NINT (HORS / 0.4) - 12)
        IF (MODE == -1) THEN
          TSHFT = 1.0
        ELSE
          TSHFT = 3.0
        END IF
        CALL PLA439 (0.0,  JID, NJID, 0.4, -1, 1, TSHFT, 0.15)
        CALL GEN040 (IGBL(4), NQ2, IP)
        IF (MODE < 0) THEN
          VR = 0.5
        ELSE
          VR = 1.5
        END IF
        CALL pla439 (90.0, PROGNM//' - ('//NQ2(1:IP)//')',
     1               IP + 33, 0.4, -1, 1, 0.6,  VR)
      END IF
      RETURN
      END SUBROUTINE PLA110
 
      SUBROUTINE PLA111
C * ALL (NEWMAN AND RING/PLANE PLOTTING IS INITIATED FROM FROM HERE)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: J1
      INTEGER          :: J2
      INTEGER          :: L0
      INTEGER          :: L4
      INTEGER          :: NR
      INTEGER          :: JM
      INTEGER          :: IS
      INTEGER          :: IP
      INTEGER          :: II
      INTEGER          :: NAT
      INTEGER          :: NWM
      INTEGER          :: NL4
      INTEGER          :: NK0
      INTEGER          :: ISH
      INTEGER          :: IHAT
      INTEGER          :: KHAT
      INTEGER          :: IDET
      INTEGER          :: IDUM
      INTEGER          :: JDUM
      INTEGER          :: MARK
      INTEGER          :: IENR
      INTEGER          :: IVAL
      INTEGER          :: IVWP
      INTEGER          :: IPHI
      INTEGER          :: IPR12
      INTEGER          :: IPHIP
      INTEGER          :: NRING
      INTEGER          :: NHEAD
      INTEGER          :: IOPEN
      INTEGER          :: IROTX
      INTEGER          :: IROTY
      INTEGER          :: IROTZ
      INTEGER          :: NWMNR
      REAL             :: XR
      REAL             :: YR
      REAL             :: ZR
      REAL             :: SX
      REAL             :: SY
      REAL             :: SZ
      REAL             :: SC
      REAL             :: SXY
      REAL             :: XOS
      REAL             :: YOS
      REAL             :: XAG
      REAL             :: ZR1
      REAL             :: ZR2
      REAL             :: XPL
      REAL             :: YPL
      REAL             :: XOR
      REAL             :: YOR
      REAL             :: XLB
      REAL             :: YLB
      REAL             :: YST
      REAL             :: YRR
      REAL             :: XR0
      REAL             :: XR1
      REAL             :: XR2
      REAL             :: XR3
      REAL             :: YR0
      REAL             :: YR1
      REAL             :: YR2
      REAL             :: YR3
      REAL             :: YAG
      REAL             :: XST
      REAL             :: PHI
      REAL             :: YANK
      REAL             :: XYR3
      REAL             :: PMAX
      REAL             :: PHIL
      REAL             :: PHIB
      REAL             :: RADSP
      REAL             :: RADCP
      CHARACTER(len=4) :: TYPEX
      J1    = 0
      J2    = 0
      XOS   = 0.0
      YOS   = 0.0
      IENR  = 0
      NRING = 0
      NHEAD = 0
C * IPR(55) = -1 NEWMAN
C *         =  0
C *         =  1 : PLAN
C *         =  2 : RING
C *         =  3 : RESD
C *         =  4 : LSPL
      IGBL(6) = 13
   10 IOPEN   = 0
      NR      = 0
      NAT     = IPR(39)
   20 READ (LU8, IOSTAT = IOST) MARK, IPR(12), JR, RMAT
      IF (MARK == -100 .OR. IOST /= 0) THEN
C * NO MORE RESD, LSPL, RING, CRDN DATA
        CALL PLA015 (0, 18)
        CALL GEN108 (LU8, 0)
        IPR(169) = 0
        GO TO 70
      END IF
      NL4 = NAT
      IF (MARK == -1) NL4 = 240
      READ (LU8) (IATP(L4), L4 = 1, NL4)
      IF (MARK /= IPR(55)) THEN
        IF (IPR(55) == 1) THEN
          IF (MARK < 1 .OR. MARK > 4) GO TO 20
        ELSE
          GO TO 20
        END IF
      END IF
C * INITIALIZE GRAPHICS
   30 IF (IOPEN == 0) THEN
        HORS = 25.0
        VERT = 25.0
        CALL GGIP (HORS, VERT, 0.0, 1)
C * PLOT BOX
        CALL PLA110 (HORS, VERT, -1)
        IOPEN = 1
        IF (IPR(55) /= -1)
     1    CALL PLA439 (0.0, JID(75:80), 6, 0.45, 1, 2, 10.5, 24.25)
      END IF
C * PLAN, RING, RESD, LSPL
      IF (IPR(55) > 0) THEN
        CALL PLA112 (PMAX, SX, SY, SZ)
        IF (MARK == 1) THEN
          TYPEX = 'Plan'
        ELSE IF (MARK == 2) THEN
          TYPEX = 'Ring'
          NRING = NRING + 1
        ELSE IF (MARK == 3) THEN
          TYPEX = 'Resd'
        ELSE IF (MARK == 4) THEN
          TYPEX = 'Lspl'
        END IF
        CALL PLA439 (0.0, TYPEX, 4, 0.45, 1, 2, 23.0, 24.0)
        NR  = NR + 1
        SXY = VERT / 2.0
        SC  = SXY  * 0.8 / PMAX
C * PLOT ROTATION ANGLES (FOR PLUTON, ADP, STICK, SOLID, CPK)
        CALL GEN096 (RMAT, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM)
        RGBL(28) = IROTX
        RGBL(29) = IROTY
        RGBL(30) = IROTZ
        IGBL(87) = IDET
        IGBL(67) = 1
        CALL GEN040 (IROTX, NQ1, IP)
        CALL GEN040 (IROTY, NQ2, IP)
        CALL GEN040 (IROTZ, NQ3, IP)
        CALL PLA439 (0.0, NQ1, 4, 0.4, 1, 2, 23.6, 0.15)
        CALL PLA439 (0.0, NQ2, 4, 0.4, 1, 2, 0.15, 24.5)
        CALL PLA439 (0.0, NQ3, 4, 0.4, 1, 2, 0.15, 0.15)
        CALL GEN040 (IPR(140), NQ1, IP)
        CALL PLA439 (0.0, NQ1, 2, 0.4, 1, 2, 22.5, 0.15)
        YRR   = 0.4
        IPR12 = IPR(12)
        IF (IPR12 <= 20) THEN
          DO I = 1, IPR12
            CALL PLA047 (LABA(IATP(I)), NQ1, IDUM, JDUM, IPR(71),
     1                   IGBL(55), 0, 0)
            YRR = YRR + 0.5
            YR  = YRR
            XR  = 1.0
            CALL PLA439 (0.0, NQ1, 5, 0.35, 1 + IPR(346), 2, XR, YR)
          END DO
        END IF
        IF (IPR(56) /= 0) THEN
C * PLOT LEAST-SQUARES PLANE
          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 PLA439 (0.0, NQ1, IP, 0.5, 1, 2, 23.0, 24.3)
        END IF
C * PLOT ATOMS & BONDS
        I = 0
        DO WHILE (I < NAT)
          I = I + 1
          IF (IATC(I) /= 0) THEN
C * ATOMS
            CALL GEN048 (-1, IFG(1, I), 7, IVAL)
            IF (IVAL <= 0) THEN
              CALL PLA044 (RMAT, I, XR, YR, ZR, SX, SY, SZ, SC, SXY)
              XR0      = XR
              YR0      = YR
              NQ1(1:1) = '.'
              DO II = 1, IPR12
                IF (I == IATP(II)) THEN
                  NK0 = 1 + IPR(346)
                  GO TO 40
                END IF
              END DO
              CALL GGIP (0.0, 1.0, 0.0, 0)
              NK0 = 1
   40         CALL PLA439 (0.0, NQ1, 1, 0.5, NK0, 2, XR0, YR0)
              CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, IPR(71),
     1          IGBL(55), 0, 0)
              XR0 = XR + 0.4
              YR0 = YR + 0.4
              CALL PLA439 (0.0, NQ1, 6, 0.3, NK0, 2, XR0, YR0)
            END IF
C * BONDS
            CALL GGIP (0.0, -3.0, 0.0, 0)
            JM = - NINT (CON(I, 9))
            IF (JM < 0) JM = 9
            IF (JM > 0) THEN
              CALL GEN048 (-1, IFG(1, I), 7, IHAT)
              CALL PLA044 (RMAT, I, XR1, YR1, ZR1, SX, SY, SZ, SC, SXY)
              DO J = 1, JM
                K = NINT (CON(I, J))
                IF (I < K) THEN
                  IF (IATC(K) /= 0) THEN
                    CALL GEN048 (-1, IFG(1, K), 7, KHAT)
                    IF (IHAT + KHAT > 0) THEN
                      IF (IPR(346) > 0) CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE
                      DO II = 1, IPR12
                        IF (I == IATP(II) .OR. K == IATP(II)) THEN
                          IF (IPR(346) > 0) CALL GGIP (0.0, 2.0,
     1                      0.0, 0)
                          GO TO 50
                        END IF
                      END DO
                      IF (IPR(346) > 0) CALL GGIP (0.0, 3.0, 0.0, 0)
                    END IF
   50               CALL PLA044 (RMAT, K, XR2, YR2, ZR2, SX, SY, SZ, SC,
     1                           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)
                  END IF
                END IF
              END DO
            END IF
          END IF
        END DO
C * NEWMAN PLOT
      ELSE IF (IPR(55) == -1) THEN
        IPR(169) = IPR(169) + 1
C * PLOT REQUESTED NEWMAN PLOT ONLY CASE
        IF (IPR(162) > 0) THEN
          J1 = IPR(162) / (NP1 + 1)
          J2 = MOD (IPR(162), NP1 + 1)
        END IF
        IF (IOPEN == 1) THEN
C * PLOT DIVISION
C * HORIZONTAL
          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)
C * VERTICAL
          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
        END IF
        IVWP = 0
        DO
          IVWP = IVWP + 1
          IF (IVWP > IPR(12)) THEN
            IF (IPR(162) > 0) THEN
              GO TO 20
            ELSE
              GO TO 60
            END IF
          END IF
          ISH = (IVWP - 1) * 60
          J   = IATP(2 + ISH)
          K   = IATP(3 + ISH)
C * CHECK FOR DESIRED NEWMAN PLOT (WHEN SPECIFIED)
          IF (IPR(162) > 0) THEN
            IF ((J1 /= J .OR. J2 /= K) .AND.
     1          (J1 /= K .OR. J2 /= J)) THEN
              CYCLE
            ELSE
              IPR(162) = 0
              IVWP     = 0
              CYCLE
            END IF
          END IF
          CALL PLA047 (LABA(J), NQ1, IDUM, JDUM, 0, IGBL(55),
     1      0, 0)
          CALL PLA047 (LABA(K), NQ2, IDUM, JDUM, 0, IGBL(55),
     1      0, 0)
          IF (IVWP == 1) THEN
            XOR = HORS / 4.0
            YOR = 3.0 * VERT / 4.0
            XOS = XOR
            YOS = YOR
          ELSE IF (IVWP == 2) THEN
            XOR = HORS / 2.0
            YOR = 0.0
            XOS = XOS + XOR
          ELSE IF (IVWP == 3) THEN
            XOR = - HORS / 2.0
            YOR = - VERT / 2.0
            XOS = XOS + XOR
            YOS = YOS + YOR
          ELSE IF (IVWP == 4) THEN
            XOR = HORS / 2.0
            YOR = 0.0
            XOS = XOS + XOR
          END IF
C * RESET ORIGIN
          CALL GGIP (XOR, YOR, 0.0, -3)
C * PLOT CURRENT CENTRAL BOND
          XR = -2.5
          YR =  5.5
          NK0 = 1
          IF (IPR(346) == 1) NK0 = 5
          CALL PLA439 (0.0, NQ1//'-'//NQ2, 15, 0.5, NK0, 2, XR, YR)
C * PLOT SERIAL NUMBER OF NEWMAN-PLOT
          NWMNR = (IPR(169) - 1) * 4 + IVWP
          CALL GEN040 (NWMNR, NQ1, IP)
          XR = 5.9 - (IP * 0.4 * 6.0) / 7.0
          CALL PLA439 (0.0, NQ1, IP, 0.4, 1, 2, XR, YR)
C * PLOT CIRCLE
          CALL PLA289 (0.0, 0.0, 1.0, 24)
C * PLOT BRANCHES/ANGLES & LABELS
          NWM   = IATP(1 + ISH)
          IPHIP = 90
          DO I = 1, NWM
            PHI   = IATP(20 + ISH + I) / (RGBL(6) * 100.0)
            PHIL  = IATP(38 + ISH + I) / (RGBL(6) * 100.0)
            IPHI  = NINT ((IATP(21 + ISH + I) - IATP(20 + ISH + I))
     1            / 100.0)
            CALL GEN040 (IPHI, NQ1, IP)
            PHIB  = PHI + IPHI / (RGBL(6) * 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
C * DETERMINE POSITION FOR ANGLE
            XAG   = PAR(24) * COS (PHIB) * 2
            YAG   = PAR(24) * SIN (PHIB) * 2
            IF (IP <= 1) THEN
              XAG   = XAG * 1.75
              YAG   = YAG * 1.75
            ELSE
              IF (IPHI <= 40) THEN
                XAG  = XAG * 1.4
                YAG  = YAG * 1.4
              END IF
            END IF
            XAG   = XAG - IP * PAR(25) / 2
            YAG   = YAG - PAR(25) / 2
            IF (IATP(I + 3 + ISH) <= NP1) THEN
              XST = RADCP
              YST = RADSP
            ELSE
              XST = 0.0
              YST = 0.0
            END IF
            L = MOD (IATP(I + 3 + ISH), NP1)
            CALL PLA047 (LABA(L), NQ3, IDUM, IENR, 0, IGBL(55),
     1        0, 0)
            DO L0 = 1, 5
              IF (NQ3(6-L0:6-L0) /= ' ') EXIT
            END DO
            L0 = 6 - L0
            IF (COS (PHIL) < 0) THEN
              XLB = XLB + L0 * PAR(25) * COS (PHIL) * 5.0 / 6.0
              IF (IGBL(103) == 1) XLB = MAX (XLB, -5.0)
              IF (IPHIP < 25) THEN
                YLB = YLB - PAR(25) - 0.05
              END IF
            ELSE
              IF (IPHIP < 25) THEN
                YLB = YLB + PAR(25) + 0.05
              END IF
            END IF
            CALL GGIP (XST, YST, 0.0, 3)
            CALL GGIP (XPL, YPL, 0.0, 2)
            NK0 = 1
            IF (IPR(346) == 1 .AND. IENR /= 1) NK0 = 2
            CALL PLA439 (0.0, NQ3, L0, PAR(25), NK0, 2, XLB, YLB)
            IF (IPR(346) == 1) NK0 = 3
            CALL PLA439 (0.0, NQ1, IP, 0.5, NK0, 2, XAG, YAG)
            IPHIP = IPHI
          END DO
        END DO
      END IF
C * TERMINATE THIS PLOT
   60 CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL GGIP (0.0, 0.0, 0.0, 3)
C * RESET ORIGIN
   70 CALL GGIP (-XOS, - YOS, 0.0, -3)
C * WHAT NEXT ?
      CALL PLA012 (1, 1)
      IF (IGBL(5) == LU5) THEN
C * CHECK FOR INPUT FROM GGIP
        CALL GEN020 (1, IGGT, 1, 80)
        IF (IGGT(1:1) == ' ') WRITE (LU6, 99999, IOSTAT = IOST)
        IF (IGGT(1:1) == '!' .OR. IGGT(1:1) == 'Y') GO TO 10
C * TEST FOR CREMER & POPLE RING ANALYSIS
        IF (IGGT(1:5) == 'CANDP') THEN
          IF (IPR(55) == 2 .AND. IPR(12) > 0 .AND. IPR(12) <= 8)
     1      CALL PLA095 (NRING, NHEAD, 1)
          GO TO 10
        END IF
        CALL PLA006 (0, IS)
C * REFRESH
        IF (IFL(1)(1:3) == 'REF') THEN
          IOPEN    = 0
          IPR(169) = IPR(169) - 1
          GO TO 30
        ELSE
          IPR(201) = 0
          CALL PLA280 (ICL)
C * RESET TO MAIN PLATON MENU
          IGBL(6) = 10
        END IF
      ELSE
        GO TO 10
      END IF
      IPR(1) = 5
C * RESET
      CALL PLA286 (0)
      RETURN
99999 FORMAT (':: Type Y(es) to continue this plot sequence, ',
     1 ' or another instruction', /)
      END SUBROUTINE PLA111
 
      SUBROUTINE PLA112 (PMAX, SX, SY, SZ)
C * SUPPORT PLA111
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      INTEGER :: NAT
      INTEGER :: IRESI
      REAL    :: PMAX
      REAL    :: SX
      REAL    :: SY
      REAL    :: SZ
      REAL    :: TEMP
      REAL    :: XLNG
      IF (IPR(56) /= 0) THEN
        DO I = 1, 3
          TEMP       = RMAT(1, I)
          RMAT(1, I) = RMAT(2, I)
          RMAT(2, I) = RMAT(3, I)
          RMAT(3, I) = TEMP
        END DO
      END IF
      NAT = IPR(39)
C * CALCULATE SCALING, POSITIONING AND MINIMUM OVERLAP ORIENTATION
      DO I = 1, 3
        PAR(54 + I) = 1.0E10
        PAR(57 + I) =-1.0E10
      END DO
      DO I = 1, NAT
        IATC(I) = 1
        IF (IPR(140) > 0) THEN
          CALL GEN048 (-6, IFG(1, I), 9, IRESI)
          IF (IRESI /= IPR(140)) THEN
            IATC(I) = 0
            CYCLE
          END IF
        END IF
        DO K = 1, 3
          V5(K) = XXO(I, K + 3)
        END DO
        CALL GEN002 (1, RMAT, V5, V6, XLNG)
        DO K = 1, 3
          PAR(57 + K) = MAX (PAR(57 + K), V6(K))
          PAR(54 + K) = MIN (PAR(54 + K), V6(K))
        END DO
      END DO
      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) < 0.0001) PMAX = 1.0
      RETURN
      END SUBROUTINE PLA112
 
      MODULE simp
      SAVE
      INTEGER :: NP
      INTEGER :: IFN
      INTEGER :: NREFL
      REAL    :: D
      REAL    :: VM
      REAL    :: SCL
      REAL    :: FIN
      REAL    :: AMX
      REAL    :: STHKMAX
 
      END MODULE simp
 
      SUBROUTINE PLA113
C * GENERATION OF SIMULATED POWDER PATTERNS FROM HKL OR COORDINATE DATA
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE spgrdata
      USE simp
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: N
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IP
      INTEGER :: IR
      INTEGER :: KL
      INTEGER :: KN
      INTEGER :: NREFS
      REAL    :: A
      REAL    :: AL
      REAL    :: TH
      REAL    :: THM
      REAL    :: TTH
      REAL    :: AMN
      REAL    :: FACT
      REAL    :: STHK
      REAL    :: GEN095
C * IPR(511) = 0 - SIMPOW from coordinates
C *            1 - SIMPOW from I(obs)
C *            2 - SIMPOW from I(calc)
C * CHECK FOR FRACTIONAL COORDINATES
      IF (IPR(23) == 0) THEN
C * SET RETURN MODE IN MAIN MENU
        IGBL(1)  = 2
C * SET MENU #
        IGBL(6)  = 21
C * NO .HKP FILE
        IGBL(17) = 0
C * SET SIMPOWDER DEFAULT
        IPR(511) = 0
C * SIMPOWDER PLOT BASED ON IOBS FROM HKL OBS DATA
        IF (IPR(220) == 2) THEN
          IPR(220) = 1
C * ASYM AVF 1
          IPR(393) = 1
C * EXPAND HKL
          IPR(408) = -1
C * OBS OR CALC
          IF (IFL(2)(2:4) == 'OBS') THEN
            IPR(511) = 1
C * SIMPOWDER PLOT BASED ON IOBS FROM HKL CALC DATA
          ELSE IF (IFL(2)(2:5) == 'CALC') THEN
C * SHELXL HKLF 4 ONLY
            IF (IGBL(9) == 1) THEN
              IPR(511) = 2
            ELSE
              RETURN
            END IF
          END IF
        END IF
C * HANDLE .cpi file output (powder icalc Q option)
        IF (IGBL(25) == 0 .AND. IGBL(3) == 31) IPR(650) = 1
        IWIN = IGBL(25) * IGBL(32)
        IF (IWIN == 0) THEN
          MEDIUM      = 1
          IGGT(16:22) = 'OFF    '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        END IF
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
        IF (IPR(30) == 0) THEN
C * SET TWO-THETA-MAX
          IPR(500) = NINT (FN(1))
          IF (IPR(511) == 0 .AND. IGBL(143) /= 0) THEN
            PAR(17) = STWL(IGBL(143))
          END IF
C * CHECK WAVELENGTH
          CALL PLA293 (PAR(17))
   10     IF (IPR(511) == 0) THEN
C * CHECK FOR NON-ZERO # OF ATOMS
            IF (IPR(37) == 0) RETURN
C * EXPAND COORDINATE DATA TO TRICLINIC
            CALL PLA287 (1, 1, 0)
          ELSE
C * EXPAND REFLECTION DATA IN IOBS/ICAL MODE (FROM FCF)
C * RUN ASYM
            CALL PLA145 (0)
          END IF
C * POWDER 2THETA-MAX
   20     IF (IPR(500) <= 0 .OR. IPR(500) > 6) THEN
            IF (PAR(17) > 1.0) THEN
              IPR(500) = 2
              PAR(371) = 0.1
            ELSE
              IPR(500) = 1
              PAR(371) = 1
            END IF
          END IF
C * SIMULATE POWDER DIFFRACTION PLOTS
C * GET REFLECTION DATA
          NREFL = 0
          AMX   = 0.0
          IF (IPR(511) == 0) THEN
C * SIMPOWDER PLOT FROM COORDINATES
C * CHECK FOR COMMAND LINE TWOTHETA-MAX OPTION OVERRULE
            IF (RGBL(23) > 0.0 .AND. PAR(17) > 0.0) THEN
              PAR(287) = SIN (RGBL(23) / (2.0 * RGBL(6))) / PAR(17)
            END IF
            STHKMAX = PAR(287)**2
C * GENERATE REFLECTIONS IN HEMISPHERE + CALCULATED STRUCTURE FACTORS
            CALL PLA114
C * HKL2POWDER - ICAL OR IOBS
          ELSE IF (IPR(511) > 0) THEN
C * READ AND STORE ICAL/IOBS REFLECTIONS 'AS I(OBS)'
            STHKMAX = PAR(287)**2
            CALL GEN108 (LU17, 0)
            DO
              READ (LU17, 99996, IOSTAT = IOST) IH, IK, IL, A
              IF (IOST == -1) GO TO 30
              IF (IH == 0 .AND. IK == 0 .AND. IL == 0) EXIT
              STHK = GEN095 (PAR(191), IH, IK, IL)
              IF (STHK <= STHKMAX) THEN
                TH    = ASIN (SQRT (STHK) * PAR(17))
C * LP 'CORRECTION' TO BE APPLIED BACKWARDS
                A     = A * (1.0 + COS(2 * TH) ** 2) /
     1                  (SIN (TH) **2 * COS (TH))
                NREFL = NREFL + 1
                VOID(NP73 + NREFL * 5 - 4) = IH
                VOID(NP73 + NREFL * 5 - 3) = IK
                VOID(NP73 + NREFL * 5 - 2) = IL
                VOID(NP73 + NREFL * 5 - 1) = TH
                VOID(NP73 + NREFL * 5)     = A
                AMX                        = MAX (AMX, A)
              END IF
            END DO
          END IF
C * GENERATE PROFILE
   30     CALL GEN074 (VOID, 1, NP73, 0.0)
          AMN = AMX / 2500.0
          IF (RGBL(23) == 0.0) THEN
            IF (IPR(500) == 6) THEN
              FIN = 180.0
            ELSE
              FIN = 20.0 * IPR(500)
            END IF
          ELSE
            FIN      = RGBL(23)
            IPR(500) = 6
          END IF
          IFN = NINT (FIN / PAR(411))
          AL  = PAR(371)
          SCL = PAR(372)
          N   = 0
          NP  = 0
          DO WHILE (N < NREFL)
            N  = N + 1
            TH = VOID(NP73 + N * 5 - 1)
            A  = VOID(NP73 + N * 5)
            IP = NINT (2.0 * TH * RGBL(6) / PAR(411))
            IF (IP <= IFN) THEN
              VOID(IP) = VOID(IP) + A
              NP       = NP + 1
              I        = 0
              FACT     = A
              DO WHILE (FACT > AMN)
                I  = I + 1
                FACT = A / (1 + AL * I * I)
                IF (IP + I <= IFN) VOID(IP + I) = VOID(IP + I) + FACT
                IF ((IP - I) > 0)  VOID(IP - I) = VOID(IP - I) + FACT
              END DO
            END IF
          END DO
          VM = 0.0
          DO I = 1, IFN
            VM = MAX (VOID(I), VM)
          END DO
          VM = VM / (VERT - 4.0)
C * PLOT SIMULATED POWDER PATTERN
   40     CALL PLA115
C * CHECK FOR 'WHAT NEXT ?'
   50     IGBL(6) = 21
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1,
     1                    1, 80, 7, NP17)
C * CHANGE WAVELENGTH
          IF (IFL(1)(1:4) == 'RADN') THEN
            CALL PLA293 (FN(1))
            IPR(549) = 0
            GO TO 20
C * LIST REFLECTIONS SORTED ON 2TH VALUE
          ELSE IF (IFL(1)(1:4) == 'LIST') THEN
            OPEN (UNIT = LU61, FILE = NAMEFIL(1:KNMFIL)//'.pow',
     1      STATUS = 'UNKNOWN')
            IF (KN /= 0) THEN
              THM = FN(1) / 2.0
            ELSE
              THM = FIN / 2.0
            END IF
            NREFS = 0
            DO I = 1, NREFL
              TH = VOID(NP73 + I * 5 - 1) * RGBL(6)
              IF (TH < THM) THEN
                NREFS          = NREFS + 1
                JNSC(1, NREFS) = NINT (TH * 1000.0)
                JNSC(2, NREFS) = I
              END IF
            END DO
            CALL PLA015 (0, 39)
C * SORT/LIST ON 2-THETA
            CALL GEN037 (JNSC, 1, NREFS)
            CALL PLA262 (0)
            WRITE (LU61, 99999, IOSTAT = IOST)
            CALL PLA262(5)
            DO I = 1, NREFS
              TTH = 0.002 * JNSC(1, I)
              J   = JNSC(2, I)
              IH  = NINT (VOID(NP73 + J * 5 - 4))
              IK  = NINT (VOID(NP73 + J * 5 - 3))
              IL  = NINT (VOID(NP73 + J * 5 - 2))
              IR  = NINT (10000000 * VOID(NP73 + J * 5) / AMX)
              CALL PLA262 (1)
              D = PAR(17) / (2.0 * SIN (TTH / (2.0 * RGBL(6))))
              WRITE (LU61, 99997, IOSTAT = IOST) IH, IK, IL, TTH, IR, D
            END DO
            CLOSE (UNIT = LU61, IOSTAT = IOST)
            WRITE (LU6, 99998) NAMEFIL(1:KNMFIL)//'.pow'
            GO TO 50
          ELSE IF (IFL(1)(1:4) /= 'EXIT') THEN
            SELECT CASE (LRET)
C * REFRESH DISPLAY
              CASE (1)
                GO TO 40
C * EXIT
              CASE (2)
                RETURN
C * REGENERATE PROFILE
              CASE (3)
                GO TO 30
C * NEW 2-THETA-MAX RESTART
              CASE (4)
                GO TO 20
C * RESTART WITH CURRENT FCF IOBS/ICAL SETTING
              CASE (5)
                GO TO 10
            END SELECT
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT ('2-Theta Sorted Reflection Listing', /, 80('='), //, 4X,
     1        'H    K    L 2-Theta', 6X, 'Intensity',5X, 'd Ang',
     1        /, 80('='))
99998 FORMAT (/, '*** Powder data written to ', A, /)
99997 FORMAT (3I5, F8.2, I15, F10.3)
99996 FORMAT (3I4, F8.0)
      END SUBROUTINE PLA113
 
      SUBROUTINE PLA114
C * GENERATE REFLECTIONS IN HEMISPHERE + CALCULATED STRUCTURE FACTORS
      USE files
      USE parameters
      USE cchar
      USE simp
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IHMAX
      INTEGER :: IKMAX
      INTEGER :: ILMAX
      REAL    :: TH
      REAL    :: CALC
      REAL    :: STHK
      REAL    :: ACAL
      REAL    :: BCAL
      REAL    :: ACALA
      REAL    :: BCALA
      REAL    :: SNTHA
      REAL    :: ACALAF
      REAL    :: BCALAF
      REAL    :: GEN095
      IHMAX = INT (2 * PAR(101) * PAR(287)) + 1
      IKMAX = INT (2 * PAR(102) * PAR(287)) + 1
      ILMAX = INT (2 * PAR(103) * PAR(287)) + 1
      IL = - 1
      DO WHILE (IL < ILMAX)
        IL = IL + 1
        IF (IL > 0) THEN
          IK = - IKMAX - 1
        ELSE
          IK = -1
        END IF
        DO WHILE (IK < IKMAX)
          IK = IK + 1
          IF (IL == 0 .AND. IK == 0) THEN
            IH = 0
          ELSE
            IH = - IHMAX - 1
          END IF
          DO WHILE (IH < IHMAX)
            IH = IH + 1
            IF (IH /= 0 .OR. IK /= 0 .OR. IL /= 0) THEN
              SGX(1) = IH
              SGX(2) = IK
              SGX(3) = IL
C * ELIMINATE LATTICE AND SYSTEMATIC ABSENCES
              SGX(12) = 0.0
              CALL SGSM (27, LINE, SGX, 0, 0, IERR)
              IF (NINT (SGX(12)) == 0) THEN
                STHK = GEN095 (PAR(191), IH, IK, IL)
                IF (STHK < STHKMAX + 0.00001) THEN
                  ACAL   = 0.0
                  BCAL   = 0.0
                  ACALA  = 0.0
                  BCALA  = 0.0
                  ACALAF = 0.0
                  BCALAF = 0.0
C * CALCULATE STRUCTURE FACTOR
                  CALL PLA137 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA,
     1              ACALAF, BCALAF, SNTHA)
                  CALC = ACAL ** 2 + BCAL ** 2
                  IF (SNTHA < 1.0) THEN
                    TH = ASIN (SNTHA)
C * LP 'CORRECTION' TO BE APPLIED BACKWARDS
                    CALC  = CALC * (1.0 + COS (2 * TH) ** 2) /
     1                 (SIN (TH) **2 * COS (TH))
                    NREFL = NREFL + 1
                    VOID(NP73 + NREFL * 5 - 4) = IH
                    VOID(NP73 + NREFL * 5 - 3) = IK
                    VOID(NP73 + NREFL * 5 - 2) = IL
                    VOID(NP73 + NREFL * 5 - 1) = TH
                    VOID(NP73 + NREFL * 5)     = CALC
                    AMX                        = MAX (AMX, CALC)
                  END IF
                END IF
              END IF
            END IF
          END DO
        END DO
      END DO
      RETURN
      END SUBROUTINE PLA114
 
      SUBROUTINE PLA115
C * PLOT SIMPOWDER
      USE files
      USE parameters
      USE cchar
      USE xwdw
      USE cggt
      USE simp
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: N
      INTEGER :: M
      INTEGER :: IS
      INTEGER :: IP
      INTEGER :: NB
      INTEGER :: NE
      REAL    :: Q
      REAL    :: XP
      REAL    :: YP
      REAL    :: XM
      REAL    :: XST
      REAL    :: XPP
      REAL    :: YPP
      REAL    :: XSTEP
      REAL    :: THETA
      BCD(1:25) = 'Simulated Powder Pattern'//CHAR (0)
      CALL GGIP (HORS, VERT, 0.0, 1)
      CALL PLA439 (0.0, BCD, 25, 1.2, 4, 8, 0.6, VERT - 1.8)
      CALL PLA439 (0.0, BCD, 25, 1.2, 2, 8, 0.5, VERT - 1.9)
      VRT = VERT - 3.0
C * DATA SOURCE (REFL OR COORD)
      IF (IPR(511) > 0) THEN
        CALL PLA439 (0.0, FNLU16, KNM16, 0.30, 1, 1, 1.75, VRT)
C * SUMFORMULA
        N = INDEX (RLWS(5), '''') - 1
        IF (N > 0) THEN
          CALL PLA439 (0.0, 'SumFormula '//RLWS(5), N + 11, 0.30,
     1      5 + IGBL(68), 2, 10.0, VRT)
        END IF
      ELSE
        CALL PLA439 (0.0, FNLU1,  KNMXT, 0.30, 1, 1, 1.75, VRT)
C * SumFormula
        CALL PLA283 (2, FLOAT (IPR(260)), N, CFORM)
        M = NP52 - N + 1
        CALL PLA439 (0.0, CFORM(N:NP52), M, 0.30,
     1    5 + IGBL(68), 2, 10.0, VRT)
      END IF
      WRITE (LINE, 99989, IOSTAT = IOST) PAR(17)
      CALL PLA439 (0.0, LINE, 17, 0.35, 1, 1, HORS - 5.0, VRT)
      VRT = VRT - 0.7
      IF (IPR(261) > 0) THEN
        WRITE (LINE, 99987, IOSTAT = IOST) IPR(261)
        CALL PLA439 (0.0, LINE, 15, 0.35, 1, 1, HORS - 5.0, VRT)
        VRT = VRT - 0.7
      END IF
      WRITE (LINE, 99990, IOSTAT = IOST) SPGRNM(1)(1:7)
      CALL PLA439 (0.0, LINE, 17, 0.35, 1, 1, HORS - 5.0, VRT)
C * DISPLAY DIRECT CELL
      WRITE (LINE, 99986, IOSTAT = IOST) 'a    ', PAR(101)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, 99986, IOSTAT = IOST) 'b    ', PAR(102)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, 99986, IOSTAT = IOST) 'c    ', PAR(103)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, 99986, IOSTAT = IOST) 'alpha', PAR(104)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, 99986, IOSTAT = IOST) 'beta ', PAR(105)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, 99986, IOSTAT = IOST) 'gamma', PAR(106)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 14, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, 99993, IOSTAT = IOST) 'V  ',   PAR(98)
      VRT = VRT - 0.7
      CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      IF (IPR(511) * IPR(512) /= 0) THEN
        WRITE (LINE, 99991, IOSTAT = IOST) IPR(512)
        CALL PLA439 (90.0, LINE, 35, 0.45, 2, 2, 2.50, 2.5)
      END IF
      IF (IPR(511) == 0) THEN
        LINE(1:10) = 'SimPowderP'
      ELSE
        LINE(1:10) = 'hkl2Powder'
      END IF
      IF (IPR(511) == 0 .OR. IPR(511) == 2) THEN
        LINE(11:19) = ' - I(cal)'
      ELSE
        LINE(11:19) = ' - I(obs)'
      END IF
      CALL PLA439 (90.0, LINE, 19, 0.5, 1, 2, 1.75, VERT - 12.0)
C * PLOT BOX
      CALL PLA110 (HORS, VERT, -1)
      IF (IPR(55) /= -1) CALL PLA439
     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 > 0) THEN
C * OPEN SIETRONICS STYLE PATTERN OUTPUT
        IF (IPR(650) == 1) THEN
          OPEN (UNIT = LU62, FILE = NAMEFIL(1:KNMFIL)//'.cpi',
     1      STATUS = 'UNKNOWN')
          WRITE (LU62, 99999, IOSTAT = IOST)
          WRITE (LINE, 99998, IOSTAT = IOST) PAR(411)
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          WRITE (LU62, 99997, IOSTAT = IOST) LINE(NB:NE)
          WRITE (LINE, 99998, IOSTAT = IOST) FIN
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          WRITE (LU62, 99997, IOSTAT = IOST) LINE(NB:NE)
          WRITE (LINE, 99998, IOSTAT = IOST) PAR(411)
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          WRITE (LU62, 99997, IOSTAT = IOST) LINE(NB:NE)
          WRITE (LU62, 99995, IOSTAT = IOST)
     1      KRAD(1:2), PAR(17), DATIJD
          CALL GEN039 (-1, JID, 1, 50, NB, NE)
          WRITE (LU62, 99997, IOSTAT = IOST) JID(NB:50)
          WRITE (LU62, 99994, IOSTAT = IOST)
        END IF
C * OUTPUT CURVE
        XP = 1.0
        NB = 1
        NE = 1
        CALL GGIP (XP, 1.5, 0.0, 3)
        DO 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) + IPR(570) + IPR(649) > 0) THEN
            IF (I > 1 .AND. I < IFN .AND. YP > 3.0) THEN
              IF (VOID(I - 1) < VOID(I) .AND.
     1            VOID(I + 1) < VOID(I)) THEN
                THETA = I * PAR(411) / 2
                D = PAR(17) / (2.0 * SIN (THETA / RGBL(6)))
                Q = RGBL(5) / D
C * DISPLAY D-VALUES
                IF (IPR(569) == 1) THEN
                  WRITE (NQ1, 99996, IOSTAT = IOST) D
C * DISPLAY TWO-THETA VALUES
                ELSE IF (IPR(570) == 1) THEN
                  WRITE (NQ1, 99996, IOSTAT = IOST) 2 * THETA
C * DISPLAY LAMBDA / (2 * SIN(THETA( = Q VALUES
                ELSE IF (IPR(649) == 1) THEN
                  WRITE (NQ1, 99988, IOSTAT = IOST) Q
                END IF
                XPP = XP + 0.0875
                YPP = YP
                CALL PLA439 (90.0, NQ1, 7, 0.175, 2, 1, XPP, YPP)
                CALL GGIP (XP, YP, 0.0, 3)
              END IF
            END IF
          END IF
          WRITE (LINE, 99992, IOSTAT = IOST)
     1      NINT (VOID(I) * 10000.0 / VM)
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          IF (IPR(650) == 1)
     1      WRITE (LU62, 99997, IOSTAT = IOST) LINE(NB:NE)
        END DO
        IF (IPR(650) == 1) CLOSE (UNIT = LU62, IOSTAT = IOST)
      END IF
      IF (FIN > 40.0) THEN
        IS = 5
      ELSE
        IS = 1
      END IF
      XP  = 1.0
      XST = IS * XSTEP / PAR(411)
      N   = 0
      DO WHILE (N <= NINT (FIN))
        CALL GGIP (XP, 0.8, 0.0, 3)
        CALL GGIP (XP, 1.2, 0.0, 2)
        CALL GEN040 (N, NQ1, IP)
        CALL PLA439 (0.0, NQ1, IP, 0.2, 1, 1, XP + 0.1, 1.1)
        IF (N > 0 .AND. (IPR(569) + IPR(649) /= 0)) THEN
          XM = 0.5 * PAR(17) / SIN (N / (RGBL(6) * 2.0))
          IF (IPR(569) == 1) THEN
            M = NINT (100.0 * XM)
          ELSE IF (IPR(649) == 1) THEN
            M = NINT (1000.0 * RGBL(5) / XM)
          END IF
          CALL GEN040 (M, NQ1, IP)
          CALL PLA439 (0.0, NQ1, IP, 0.175, 2, 1, XP + 0.01, 0.6)
        END IF
        XP = XP + XST
        N  = N  + IS
      END DO
      IF (IPR(649) == 0) THEN
        CALL PLA439 (0.0, '2-Theta Deg. / d * 100 Ang.',
     1    12 + 15 * IPR(569), 0.35, 1, 1, HORS - 8.0, 0.1)
      ELSE
        CALL PLA439 (0.0, '2-Theta Deg. / d * 1000 A-1',
     1       27, 0.35, 1, 1, HORS - 8.0, 0.1)
      END IF
      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 (A, F9.2)
99992 FORMAT (I10)
99991 FORMAT ('Missing Low Order Reflections =', I4)
99990 FORMAT ('SpGroup ', A)
99989 FORMAT ('Lambda ', F8.5)
99988 FORMAT (F6.3)
99987 FORMAT ('Temp', 5X, I5, 'K')
99986 FORMAT (A, F7.2)
      END SUBROUTINE PLA115
 
      MODULE vscr
      SAVE
      INTEGER                  :: IER
      INTEGER                  :: N1
      INTEGER                  :: N2
      INTEGER                  :: N3
      INTEGER                  :: N23
      INTEGER                  :: NGB
      INTEGER                  :: NGE
      INTEGER                  :: NJB
      INTEGER                  :: NJE
      INTEGER                  :: NJGR
      INTEGER                  :: ISLA
      INTEGER                  :: NSAV
      INTEGER                  :: NSYM
      INTEGER                  :: NTGRD
      INTEGER, DIMENSION(4, 2) :: NJG
      INTEGER, DIMENSION(3, 2) :: IGR
      INTEGER, DIMENSION(3)    :: JGR
      INTEGER, DIMENSION(3)    :: KGR
      INTEGER, DIMENSION(3)    :: MGR
      INTEGER, DIMENSION(3)    :: NGNX
      INTEGER, DIMENSION(4, 3) :: I123
      INTEGER, DIMENSION(3, 2) :: NXYZ
      REAL                     :: DOT
      REAL                     :: CSLA
      REAL                     :: OR11
      REAL                     :: OR12
      REAL                     :: OR13
      REAL                     :: OR22
      REAL                     :: OR23
      REAL                     :: OR33
      REAL                     :: GRTR
      REAL,    DIMENSION(6)    :: V9
      REAL,    DIMENSION(3, 3) :: EV
      REAL,    DIMENSION(3)    :: EW
      REAL,    DIMENSION(3, 3) :: DUMW
      CHARACTER(len=255)       :: PLPATH
      END MODULE vscr
 
      SUBROUTINE PLA118
C * VOID/SOLV ROUTINE
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE vscr
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IZ
      INTEGER :: LU
      INTEGER :: NX
      INTEGER :: NY
      INTEGER :: NZ
      INTEGER :: KAT
      INTEGER :: ISL
      INTEGER :: IVD
      INTEGER :: NXY
      INTEGER :: NHV
      INTEGER :: LAST
      INTEGER :: MXYZ
      INTEGER :: NHVL
      INTEGER :: IVDX
      INTEGER :: IVDY
      INTEGER :: IVDZ
      INTEGER :: ISLL
      INTEGER :: IVAL
      INTEGER :: ISAV
      INTEGER :: IAN0
      INTEGER :: NADD
      INTEGER :: ICHR
      INTEGER :: IDUM
      INTEGER :: LVKX
      INTEGER :: LVKY
      INTEGER :: LVKZ
      INTEGER :: LSKX
      INTEGER :: LSKY
      INTEGER :: LSKZ
      INTEGER :: LVDX
      INTEGER :: LVDY
      INTEGER :: LVDZ
      INTEGER :: NGRID
      INTEGER :: IATCK
      INTEGER :: LXMAX
      INTEGER :: LYMAX
      INTEGER :: LZMAX
      INTEGER :: LXMIN
      INTEGER :: LYMIN
      INTEGER :: LZMIN
      INTEGER :: FINDEXE
      INTEGER :: MAXSGRID
      REAL    :: ANG
      REAL    :: AVOL
      REAL    :: CMIN
      REAL    :: CRIT
      REAL    :: DIST
      REAL    :: VMAX
      REAL    :: XLNG
      REAL    :: PERC
      REAL    :: XXOM5
      REAL    :: XXOM6
      REAL    :: XXOM7
      REAL    :: CRIT2
      REAL    :: APERC
      REAL    :: OHASH
      REAL    :: OHASHI
      REAL    :: GEN009
C * IPR(189) = 1 - VOID SEARCH + PACKING INDEX
C * IPR(189) = 2 - SOLV(ent accessible void) SEARCH
C * IPR(210) = -2 - NEWSYM MODE
C * IPR(210) = -1 - CALC FCF MODE
C * IPR(210) =  0 - NONE
C * IPR(210) =  1 - SQUEEZE MODE
C * IPR(210) =  2 - DIFF MAP DISPLAY MODE
      PAGET = 'VOIDS'
C * OPEN/REWIND SAV-FILE (SOLVENT ACCESSIBLE VOLUME)
      INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.sav', OPENED = OPEND)
      IF (OPEND) THEN
        REWIND (UNIT = LU15, IOSTAT = IOST)
      ELSE
        OPEN (UNIT = LU15, FILE = NAMEFIL(1:KNMFIL)//'.sav',
     1    STATUS = 'UNKNOWN', FORM = 'UNFORMATTED')
      END IF
C * SET SUB-MENU #
C * SQUEEZE MODE
      IF (IPR(210) == 1) THEN
        IGBL(6) = 36
C * SOLVENT ACCESSIBLE VOLUME DISPLAY
      ELSE IF (IPR(326) == 2) THEN
        IGBL(6) = 24
C * PLATON
      ELSE
        IGBL(6) = 10
      END IF
      CALL GEN097 (I123, 1, 12, 0)
      I123(2, 1) = 1
      I123(3, 2) = 1
      I123(4, 3) = 1
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
      NGB  = 0
      NGE  = 0
      NADD = 0
      CSLA = 0.0
      GRTR = FLOAT(ICHAR ('>'))
      DOT  = FLOAT(ICHAR ('.'))
C * GET RELEVANT ELEMENTS OF THE ORTHOGONALISATION MATRIX FOR DIST. CALC.
      OR11 = OR(1, 1)
      OR12 = OR(1, 2)
      OR13 = OR(1, 3)
      OR22 = OR(2, 2)
      OR23 = OR(2, 3)
      OR33 = OR(3, 3)
C * SETUP DLIM
      DO K = 1, 3
        DUMA(K + 3) = PAR(112 + K)
      END DO
C * ATOM ARRAY UPPER BOUND CHECK
      IF (IPR(39) <  NP1) THEN
C * STARTING ADDRESS OF CG-SOLVENT VOLUMES IN ATOM ARRAY
        NSAV = IPR(39) + 1
 
      ELSE
        IF (IGBL(3) /= 1) IPR(2) = 25
        GO TO 40
      END IF
C * INIT SOLVENT GRID-POINT COUNTER
   10 IPR(188) = 0
C * INIT OUT OF VDW-RADIUS GRID-POINTS COUNTER
      IPR(190) = 0
C * INIT NUMBER OF VOIDS
      IPR(198) = 0
C * VOID TEST RESULT (-1, 0, 1)
      IPR(199) = 0
C * SET MAXIMUM NUMBER OF GRIDPOINT FURTHER OUT THAN PROBE RAD [= 1.2 A]
C *   FROM VDW
      IF (IPR(491) == 0) THEN
        IF (IGBL(3) == 0) THEN
          IPR(491) = 40000
        ELSE
          IPR(491) = 5000
        END IF
      END IF
      MAXSGRID = IPR(491) * NSYM
C * DETERMINE GRID STEP = PAR(80) FROM PROBE RADIUS = PAR(84) (ANGSTROM)
      IF (IPR(214) > 0) PAR(80) = PAR(84) / IPR(214)
C * SET DMAX0
      PAR(19) = PAR(84)
C * SET DMAXS FOR VOID OR SOLV MODE
      IF (IPR(189) == 1) THEN
C * VOID MODE
        PAR(20) = PAR(84)
      ELSE
C * SOLV MODE
        PAR(20) = 0.0
      END IF
C * CALCULATE VOID SEARCH (PROBE) GRID
      DO K = 1, 3
        NGRID        = NINT (PAR(100 + K) / (PAR(80) * 2)) * 2
        PAR(80  + K) = 1.0 / NGRID
        IPR(193 + K) = NGRID
        MGR(K)       = IFIX (NGRID * PAR(84) * PAR(112 + K)) + 1
      END DO
C * GET NUMBER OF STEPS IN THE THREE DIRECTIONS (X, Y, Z)
      N1    = IPR(194)
      N2    = IPR(195)
      N3    = IPR(196)
      N23   = N2 * N3
      NTGRD = N1 * N23
      WRITE (LU6, 99986, IOSTAT = IOST) PAR(80), NTGRD * 100.0 / NVDR
C * INCREASE GRIDSTEP IN CASE OF OVERFLOW
      IF (NTGRD > NVDR) THEN
        IPR(214) = IPR(214) - 1
        IF (IPR(214) > 0) THEN
          IF (PAR(84) / IPR(214) < 0.41) THEN
            GO TO 10
          END IF
        END IF
C * ALERT _603 - Report TOO large VOID for VOID search
        IF (IGBL(3) == 1) THEN
          CALL PLA236 (603, 0, -999.0, 1.0, ' ', ' ')
        ELSE
          IPR(2) = 19
        END IF
        GO TO 40
      END IF
      KGR(1) = N23
      KGR(2) = N3
      KGR(3) = 1
C * INIT VOID GRID ARRAY
      CALL GEN074 (VOID, 1, NTGRD, 0.0)
      WRITE (PRBUF, 99999, IOSTAT = IOST) PAR(80), PAR(84)
C * START GRAPHICS WINDOW FOR SOLV/VOID RESULTS
      IF (IGBL(25) * IGBL(32) == 1 .AND. IPR(121) == 0 .AND.
     1    IGBL(3) /= 5) THEN
        IWIN = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.6
        CALL PLA439 (0.0, PRBUF, 69, 0.4, 5 + IGBL(68), 2, 1.0, VRT)
        IF (IPR(483) > 0 .AND. IPR(484) == 0) THEN
          WRITE (PRBUF, 99968, IOSTAT = IOST)
          WRITE (LU6, 99971, IOSTAT = IOST) PRBUF(1:80)
          CALL PLA439 (0.0, PRBUF, 60, 0.5, 2, 2, 3.0, 1.0)
        END IF
        CALL PLA439 (0.0, 'WorkinG', 7, 3.0, 2, 10, 5.0, 8.0)
C * INIT GRIDPOINT COUNT TEXT
        WRITE (PRBUF, 99990, IOSTAT = IOST) PAR(84), IPR(198)
        CALL PLA439 (0.0, PRBUF, 68, 0.35, 1, 2, 0.5, 5.0)
        CALL PLA439 (0.0, PRBUF(70:77), 8, 0.35, 1, 2, 21.0, 5.0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        VRT = VRT - 0.2
      END IF
C * GRID SIZE HEADER: LAYER, DOWN, ACROSS
      IF (IGBL(63) > 2) THEN
C * NEWPAGE
        CALL PLA262 (0)
        CALL PLA262 (14)
C * BUT DO NOT INCLUDE 'CG' ENTRY IN LISTING
        IF (LMT(IENS(IAN), 1) == 'Cg') THEN
          IAN0 = IAN - 1
        ELSE
          IAN0 = IAN
        END IF
        DO L = 1, 2
          IF (L == 1) THEN
            LU = LU6
            WRITE (LU, 99963, IOSTAT = IOST) PAR(80), PAR(84), IPR(214)
          ELSE
            LU = LU7
            WRITE (LU, 99999, IOSTAT = IOST) PAR(80), PAR(84), IPR(214)
          END IF
C * LIST ELEMENT TYPES AND RADII
          WRITE (LU, 99975, IOSTAT = IOST)(LMT(IENS(I), 1), I = 1, IAN0)
          WRITE (LU, 99974, IOSTAT = IOST)
     1    (RADR(IENS(I), 4), I = 1, IAN0)
C * LIST GRID PARAMETERS
          WRITE (LU, 99983)
          WRITE (LU, 99989, IOSTAT = IOST)
     1      (CHAR (K + ICHAR ('W')), PAR(80 + K),
     2       IPR(193 + K), PAR(100 + K) / IPR(193 + K),
     3       K = 1, 3)
          WRITE (LU, 99983)
        END DO
C * TEST FOR 'LIST VOID MAP AND DISPLAY LEGEND'
        IF (IPR(197) == 1) THEN
          WRITE (LU7, 99997, IOSTAT = IOST)
          DO K = 1, IAN
            L = IEL(IEN(K))
            M = L / 100
            N = MOD (L, 100)
            NQ1(1 : 1) = CHAR (ICHAR ('A') + M - 1)
            IF (N /= 0) THEN
              NQ1(2 : 2) = CHAR (ICHAR ('a') + N - 1)
            ELSE
              NQ1(2 : 2) = ' '
            END IF
            WRITE (LU7, 99996, IOSTAT = IOST) K, NQ1(1:2)
          END DO
        END IF
      END IF
C * SCAN FOR IN/OUT WITH DUMMY H-ATOM PROBE
C * START GRID LOOP X, Y, Z
      NHV = 0
C * VOID GRID LOOP X (PAGE-TO-PAGE)
      V9(1) = - PAR(81)
      DO K = 1, N1
        V9(1) = V9(1) + PAR(81)
C * VOID GRID Y LOOP (DOWN PAGE)
        V9(2) = - PAR(82)
        DO L = 1, N2
          V9(2) = V9(2) + PAR(82)
C * VOID GRID Z LOOP (ACROSS PAGE)
          V9(3) = - PAR(83)
          DO M = 1, N3
            V9(3) = V9(3) + PAR(83)
            NHV   = NHV + 1
C * SKIP PREVIOUSLY HANDLED GRID POINTS
            IF (NINT (VOID(NHV)) == 0) THEN
C * START LOOP OVER UNIQUE AND AND SYMMETRY RELATED ATOMS
              CALL PLA119 (KAT)
C * CHECK FOR ERROR
              IF (IPR(2) /= 0) THEN
                IF (IGBL(3) == 1) IPR(2) = 0
                GO TO 20
              END IF
C * GET NEXT POINT OF VOID MAP
              IF (IPR(199) < 0) THEN
C * COUNT OUT-OF-VDW GRID-POINTS
                IPR(190)  = IPR(190) + 1
C * SET CHARACTER SPACE
                VOID(NHV) = 32.0
              ELSE IF (IPR(199) == 0) THEN
                DO J = 1, NSYM
                  DO I = 1, 3
                    SGY(I + 3) = 0.0
                    SGY(I)     = V9(I)
                  END DO
                  CALL SGSM (3, ICL, SGY, J, LU6, IERR)
                  IVDX = MOD (NINT (SGY(7) / PAR(81)) + N1, N1)
                  IVDY = MOD (NINT (SGY(8) / PAR(82)) + N2, N2)
                  IVDZ = MOD (NINT (SGY(9) / PAR(83)) + N3, N3)
                  NHVL = IVDX * N23 + IVDY * N3 + IVDZ + 1
                  IF (NINT (VOID(NHVL)) == 0) THEN
                    IPR(190) = IPR(190) + 1
                    IPR(198) = IPR(198) + 1
                    IF (IPR(198) == 1 .AND. IGBL(63) > 0)
     1                WRITE (LU6, 99991, IOSTAT = IOST)
                    IF (MOD (IPR(198), 10000) == 0) THEN
C * UPDATE NUMBER OF GRIDPOINTS FOUND
                      IF (IGBL(25) * IGBL(32) == 1 .AND.
     1                    IGBL(3) /= 5 .AND. IPR(121) == 0) THEN
                        CALL PLA439 (0.0, PRBUF(70:77), 8, 0.35, 0, 2,
     1                               21.0, 5.0)
                        WRITE (PRBUF, 99990, IOSTAT = IOST)
     1                    PAR(84), IPR(198)
                        CALL PLA439 (0.0, PRBUF(70:77), 8, 0.35, 1, 2,
     1                               21.0, 5.0)
                        CALL GGIP (0.0, 0.0, 0.0, 6)
                      END IF
                    END IF
C * TEST FOR VALIDATION RUN
                    IF (IGBL(3) == 1) THEN
                      IF (IPR(198) > MAXSGRID) THEN
C * TEST FOR SQUEEZE
                        IF (PAR(437) == 0.0 .AND. IPR(651) == 0)
     1                    THEN
C * ALERT _602 - VOID TOO LARGE
                          CALL PLA236 (602, 0,  1.0, 1.0, ' ', ' ')
                        ELSE
C * ALERT _606 - VERY LARGE VOID
                          CALL PLA236 (606, 0, -999.0, 1.0, ' ', ' ')
                        END IF
                        GO TO 40
                      END IF
                    END IF
C * SET CHARACTER >
                    VOID(NHVL) = GRTR
                  END IF
                END DO
C * IPR(199) > 0 - GRIDPOINT WITHIN VAN DER WAALS RADIUS
              ELSE
                CRIT  = PAR(23) - PAR(20)
                CRIT2 = CRIT**2
                LSKX  = INT (CRIT / (PAR(81) * PAR(101))) + 1
                LSKY  = INT (CRIT / (PAR(82) * PAR(102))) + 1
                LSKZ  = INT (CRIT / (PAR(83) * PAR(103))) + 1
                IVD   = IPR(59) + 1
C * SET NUMERICAL CHARACTER TO IDENTIFY WITHIN-ATOM-TYPE RANGE
                IF (IVD < 10) THEN
                  ICHR = ICHAR ('0') + IVD
                ELSE
                  ICHR = ICHAR ('*')
                END IF
                DO J = 1, NSYM
                  DO I = 1, 3
                    SGY(I + 3) = 0.0
                    SGY(I)     = XXO(KAT, I)
                  END DO
                  CALL SGSM (3, ICL, SGY, J, LU6, IERR)
                  XXOM5 = SGY(7)
                  XXOM6 = SGY(8)
                  XXOM7 = SGY(9)
                  LVKX  = NINT (XXOM5 / PAR(81))
                  LVKY  = NINT (XXOM6 / PAR(82))
                  LVKZ  = NINT (XXOM7 / PAR(83))
                  LXMIN = MAX (LVKX - LSKX, K - 1)
                  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)
                  LVDX  = LXMIN
                  DO WHILE (LVDX <= LXMAX)
                    SGY(1) = LVDX * PAR(81) - XXOM5
                    LVDY   = LYMIN
                    DO WHILE (LVDY <= LYMAX)
                      SGY(2) = LVDY * PAR(82) - XXOM6
                      NHVL   = LVDX * N23 + LVDY * N3 + LZMIN
                      LVDZ   = LZMIN
                      DO WHILE (LVDZ <= LZMAX)
                        NHVL = NHVL + 1
                        IF (NINT (VOID(NHVL)) == 0) THEN
                          SGY(3) = LVDZ * PAR(83) - XXOM7
                          IF ((OR11 * SGY(1) + OR12 * SGY(2)
     1                      + OR13 * SGY(3))**2 + (OR22 * SGY(2)
     2                      + OR23 * SGY(3))**2 + (OR33 * SGY(3))**2
     3                      < CRIT2) VOID(NHVL) = ICHR
                        END IF
                        LVDZ = LVDZ + 1
                      END DO
                      LVDY = LVDY + 1
                    END DO
                    LVDX = LVDX + 1
                  END DO
                END DO
                IF (NINT (VOID(NHV)) == 0) VOID(NHV) = 32.0
              END IF
            END IF
          END DO
C * END OF M LOOP
        END DO
C * END OF L LOOP
      END DO
C * END OF K LOOP
C * DISPLAY SOLV/VOID SEARCH PROGRESS
      IF (IPR(198) > 0) THEN
        IF (IGBL(25) * IGBL(32) == 1 .AND.
     1    IPR(121) == 0 .AND. IGBL(3) /= 5) THEN
          CALL PLA439 (0.0, PRBUF(70:77), 8, 0.35, 0, 2, 21.0, 5.0)
          WRITE (PRBUF, 99990, IOSTAT = IOST)
     1      PAR(84), IPR(198)
          CALL PLA439 (0.0, PRBUF(70:77), 8, 0.35, 1, 2, 21.0, 5.0)
          WRITE (LU6, 99972, IOSTAT = IOST) PRBUF(1:80)
          CALL PLA439 (0.0, 'Collect S.A.V.', 14, 0.35, 3, 2, 11.0,
     1                 3.0)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
      END IF
C * TEST FOR VOID-MODE
      IF (IPR(189) == 1) THEN
C * Calculate PACKING INDEX (Kitaigorodskii)
        IF (IPR(43) == 0) THEN
          PERC = 100.0 * (1.0  - (IPR(190) / FLOAT (NTGRD)))
          WRITE (PRBUF, 99992, IOSTAT = IOST) IPR(198), PERC
        ELSE
          WRITE (PRBUF, 99976, IOSTAT = IOST)
        END IF
        IF (IWIN == 1) THEN
          VRT = VRT - 0.8
          CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
        END IF
        WRITE (LU6, 99993, IOSTAT = IOST) PRBUF(1:80)
        IF (IGBL(63) > 1) THEN
          CALL PLA262 (5)
          WRITE (LU7, 99993, IOSTAT = IOST) PRBUF(1:80)
          WRITE (LU7, 99985, IOSTAT = IOST)
        END IF
      END IF
C * SET-UP PROBE
      IER = 0
      CALL PLA120
      IF (IER /= 0) GO TO 40
C * EXPAND
      IER = 0
      CALL PLA121
      IF (IER > 0) GO TO 40
      IF (IER < 0) GO TO 10
C * LIST VOID MAP (IPR(197) = 1)
      IF (IPR(197) == 1 .AND. IGBL(63) > 2) THEN
        DO I = 0, IPR(194) - 1
C * HEADER
          CALL PLA262 (-2)
          WRITE (LU7, 99998, IOSTAT = IOST)
     1      'X', I, IPR(194) - 1, 'Y', 'Z'
          DO J = 0, IPR(195) - 1
            N = I * N23 + J * N3
            M = N + N3
            N = N + 1
            CALL PLA262 (1)
            WRITE (LU7, 99995, IOSTAT = IOST)
     1        (CHAR (NINT (VOID(L))), L = N, M)
          END DO
        END DO
      END IF
      PAR(79)  = PAR(98)  / NTGRD
      PAR(150) = IPR(188) * PAR(79)
      IF (IWIN == 1) THEN
        WRITE (PRBUF, 99990, IOSTAT = IOST) PAR(84), IPR(198)
        CALL PLA439 (0.0, PRBUF, 76, 0.35, 0, 2, 0.5, 5.0)
        CALL PLA439 (0.0, PRBUF(70:77), 8, 0.35, 0, 2, 21.0, 5.0)
        CALL PLA439 (0.0, 'WorkinG', 7, 3.0, 0, 10, 5.0, 8.0)
        CALL PLA439 (0.0, 'Collect S.A.R.', 14, 0.35, 0, 2, 11.0,
     1               3.0)
        IF (IPR(483) > 0 .AND. IPR(484) == 0) THEN
          WRITE (PRBUF, 99968, IOSTAT = IOST)
          CALL PLA439 (0.0, PRBUF, 60, 0.5, 0, 2, 3.0, 1.0)
        END IF
        CALL GGIP (0.0, 0.0, 0.0, 6)
      END IF
C * TEST SOLVENT  VOLUME
      IF (PAR(150) > 0.0) THEN
        IF (IGBL(63) > 1) THEN
          IF (IPR(197) == 1) CALL PLA262 (0)
          CALL PLA262 (3)
          PAR(409) = PAR(150) * 100.0 / PAR(98)
          WRITE (LU6, 99994, IOSTAT = IOST)
     1      PAR(150), PAR(98), PAR(409)
          WRITE (LU7, 99994, IOSTAT = IOST)
     1      PAR(150), PAR(98), PAR(409)
C * TEST FOR CALC SOLV MODE
          IF (IPR(189) > 0) THEN
            WRITE (LU6, 99981, IOSTAT = IOST)
            CALL PLA262 (6)
            WRITE (LU7, 99981, IOSTAT = IOST)
            IF (IPR(210) <= 0) THEN
              CALL PLA262 (4)
              WRITE (LU7, 99980, IOSTAT = IOST)
              WRITE (LU6, 99980, IOSTAT = IOST)
            END IF
C * SOLV/VOID TABLE HEADER
            WRITE (PRBUF, 99984, IOSTAT = IOST)
            WRITE (LU6, 99970, IOSTAT = IOST) PRBUF(1:80)
            CALL PLA262 (3)
            WRITE (LU7, 99970, IOSTAT = IOST) PRBUF(1:80)
            IF (IWIN == 1) THEN
              IF (ISLA - NSAV > 15)
     1          PRBUF(55:) = ' Sqrt(Eigenvalues) (Ang.)'
              VRT = VRT - 0.8
              CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68),
     1                     2, 1.0, VRT)
              VRT = VRT - 0.2
            END IF
          END IF
        END IF
        PAR(549) = 0.0
        DO K = NSAV + 1, ISLA
          ISAV     = K - NSAV
          APERC    = JATC(K) * 100.0 / NTGRD
          AVOL     = APERC * PAR(98) / 100.0
          PAR(549) = PAR(549) + AVOL
C * REGISTER LARGEST SOLVENT ACCESSIBLE VOLUME
          PAR(289) = MAX (PAR(289), AVOL)
          DO L = 1, 3
            XXO(K, L) = XXO(K, L) / JATC(K)
            SXYZ(9 + L, ISAV) = XXO(K, L)
          END DO
          DUMW(1, 1) = SXYZ(4, ISAV) - SXYZ(1, ISAV)**2 / JATC(K)
          DUMW(1, 2) = SXYZ(7, ISAV)
     1               - SXYZ(1, ISAV) * SXYZ(2, ISAV) / JATC(K)
          DUMW(1, 3) = SXYZ(8, ISAV)
     1               - SXYZ(1, ISAV) * SXYZ(3, ISAV) / JATC(K)
          DUMW(2, 2) = SXYZ(5, ISAV)
     1               - SXYZ(2, ISAV)**2 / JATC(K)
          DUMW(2, 3) = SXYZ(9, ISAV)
     1               - SXYZ(2, ISAV) * SXYZ(3, ISAV) / JATC(K)
          DUMW(3, 3) = SXYZ(6, ISAV)
     1               - SXYZ(3, ISAV)**2 / JATC(K)
          CALL GEN024 (DUMW, EV, EW, DUMV)
C * TRANSFORM TO FRACTIONAL COORDINATES
          CALL GEN004 (ROR, DUMV, DUMW)
          DO I = 1, 3
            VMAX = 0.0
            DO J = 1, 3
              VMAX = MAX (VMAX, ABS (DUMW(J, I)))
              SXYZ ((I - 1) * 3 + J, ISAV) = DUMV(J, I)
            END DO
            OHASHI = IATC(K) * AVOL / JATC(K)
            IATCK  = MIN (999999, IATC(K))
            OHASH  = MIN (9999.9, OHASHI)
            WRITE (PRBUF, 99987, IOSTAT = IOST)
     1        K - NSAV, JATC(K), IATCK, NINT (APERC), NINT (AVOL),
     2        OHASH, (XXO(K, L), L = 1, 3), I,
     3        (DUMW(J, I) / VMAX, J = 1, 3),
     4        SQRT (MAX (0.0, EW(I) / JATC(K)))
            IF (I /= 1) CALL GEN038 (PRBUF, 1, 53)
            IF (IGBL(63) > 1) THEN
              WRITE (LU6, 99972, IOSTAT = IOST) PRBUF(1:80)
              CALL PLA262 (1)
              WRITE (LU7, 99972, IOSTAT = IOST) PRBUF(1:80)
            END IF
            IF (IWIN == 1) THEN
              IF (ISLA - NSAV > 15) THEN
                IF (I == 3) THEN
                    WRITE (PRBUF, 99967, IOSTAT = IOST)
     1              K - NSAV, JATC(K), IATCK, NINT (APERC),
     2              NINT (AVOL), OHASH, (XXO(K, L), L = 1, 3),
     3              (SQRT (MAX (0.0, EW(L) / JATC(K))), L = 1, 3)
                  VRT = VRT - 0.4
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                END IF
              ELSE
                VRT = VRT - 0.4
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
              END IF
            END IF
          END DO
        END DO
C * ANALYSE DIFFERENCE FOURIER MAP
        CALL PLA143 (2, 4.5, NSAV + 1, ISLA, IDUM)
      ELSE
        WRITE (PRBUF, 99988, IOSTAT = IOST)
        IF (IGBL(63) > 1) THEN
          WRITE (LU6, 99971, IOSTAT = IOST) PRBUF
          WRITE (LU7, 99971, IOSTAT = IOST) PRBUF
        END IF
        IF (IWIN == 1) THEN
          VRT = VRT - 5.0
          CALL PLA439 (0.0, PRBUF, 61, 0.45, 3, 2, 1.0, VRT)
          VRT = VRT - 3.0
          IF (IPR(210) == 1) THEN
            WRITE (PRBUF, 99962, IOSTAT = IOST)
            CALL PLA439 (0.0, PRBUF, 21, 0.45, 3, 2, 9.0, VRT)
          END IF
        END IF
C * RESET CALC SQUEEZE
        IPR(210) = 0
        RETURN
      END IF
      IF (IPR(200) == 2) THEN
        IF (IGBL(63) > 0) THEN
          WRITE (LU6, 99978, IOSTAT = IOST)
          CALL PLA262 (3)
          WRITE (LU7, 99978, IOSTAT = IOST)
        END IF
C * TEST FOR SQUEEZE
        IF (PAR(437) == 0.0 .AND. IPR(651) == 0) THEN
C * ALERT _601 - Report Largest Isolated VOID size
          CALL PLA236 (601, 0, PAR(289), PAR(289), ' ', ' ')
        ELSE
C * ALERT _605
          CALL PLA236 (605, 0, -999.0, PAR(289), ' ', ' ')
        END IF
        IF (PAR(289) > 20.0) THEN
          CALL PLA015 (0, 4)
        ELSE
          CALL PLA015 (0, 3)
        END IF
      END IF
C * CHECK FOR CONTINUE (TEST # GRIDPOINTS > 0)
   20 IF (IPR(188) > 0) THEN
C * DETERMINE DIMENSIONS OF THE VOIDS
        IF (IPR(189) > 0 .AND. IGBL(63) > 1) THEN
          ISLL = 0
          LAST = 0
          CMIN = 0.95
          NADD = 0
          REWIND (UNIT = LU15, IOSTAT = IOST)
          DO
            READ (LU15, IOSTAT = IOST) IX, IY, IZ, ISL, NADD, V3
            LAST = IOST
            IF (IOST /= 0 .OR. ISL /= ISLL) THEN
C * REPORT VOID SIZE DATA
              IF (ISLL == 0) THEN
C * OUPUT HEADER TEXT FOR VOID MAIN AXES VALUES
                CALL PLA262 (5)
                WRITE (LU6, 99982, IOSTAT = IOST)
                WRITE (LU7, 99982, IOSTAT = IOST)
              ELSE
C * REPORT VOID MAIN AXIS VALUES
                CALL PLA262 (1)
                WRITE (LU6, 99979, IOSTAT = IOST)
     1            ISLL, (VECN(K), K = 1, 7)
                WRITE (LU7, 99979, IOSTAT = IOST)
     1            ISLL, (VECN(K), K = 1, 7)
                DO I = 1, 3
                  SXYZ(12 + I, ISLL) = VECN(2 * I)
                END DO
                IF (LAST /= 0) GO TO 30
              END IF
              CALL GEN074 (VECN, 1, 7, 0.0)
              ISLL = ISLL + 1
              DO I = 1, 3
                V4(I) = SXYZ(9 + I, ISLL)
                V5(I) = SXYZ(I,     ISLL)
                V6(I) = SXYZ(3 + I, ISLL)
                V8(I) = SXYZ(6 + I, ISLL)
              END DO
              CALL GEN002 (1, OR, V4, V2, XLNG)
            END IF
            DO I = 1, 3
              V4(I) = V3(I) - V2(I)
            END DO
            DIST = SQRT (GEN009 (V4, V4))
            IF (DIST > VECN(7)) VECN(7) = DIST
C * CHECK WITH LARGEST EW DIRECTION
            ANG = GEN009 (V5, V4) / DIST
            IF (ANG > CMIN) THEN
              IF (DIST > VECN(2)) VECN(2) = DIST
            ELSE IF (ANG < - CMIN) THEN
              IF (DIST > ABS (VECN(1))) VECN(1) = - DIST
            ELSE
              ANG = GEN009 (V6, V4) / DIST
              IF (ANG > CMIN) THEN
                IF (DIST > VECN(4)) VECN(4) = DIST
              ELSE IF (ANG < - CMIN) THEN
                IF (DIST > ABS (VECN(3))) VECN(3) = - DIST
              ELSE
                ANG = GEN009 (V8, V4) / DIST
                IF (ANG > CMIN) THEN
                  IF (DIST > VECN(6)) VECN(6) = DIST
                ELSE IF (ANG < - CMIN) THEN
                  IF (DIST > ABS (VECN(5))) VECN(5) = - DIST
                END IF
              END IF
            END IF
          END DO
        END IF
C * TEST FOR SOLV-PLOT TYPE
   30   IF (IPR(326) == 2) THEN
          IF (IWIN == 1) CALL PLA123
C * TEST FOR F3D PLOT TYPE
        ELSE IF (IPR(326) == 3) THEN
          IPR(580) = 2
C * GENERATE F3D STYLE INPUT FOR SOLV-MAP
          OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'.slv',
     1          STATUS = 'UNKNOWN')
          WRITE (LU65, 99966, IOSTAT = IOST) 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, 1, MXYZ, 0.0)
C * NV   = VOID #
C * NADD = 1 - OHASHI
C * NADD = 2 - SOLV
          REWIND (UNIT = LU15, IOSTAT = IOST)
          DO
            READ (LU15, IOSTAT = IOST) IX, IY, IZ
            IF (IOST /= 0) EXIT
            IF (IX < 0)   IX = IX + NX
            IF (IY < 0)   IY = IY + NY
            IF (IZ < 0)   IZ = IZ + NZ
            IF (IX >= NX) IX = IX - NX
            IF (IY >= NY) IY = IY - NY
            IF (IZ >= NZ) IZ = IZ - NZ
            VOID(IZ * NXY + IY * NX + IX + 1) = 1.0
          END DO
          DO K = 1, NZ
            M = (K - 1) * NXY
            WRITE (LU65, 99965, IOSTAT = IOST) K - 1
            DO J = 1, NY
              N = M + (J - 1) * NX
              WRITE (LU65, 99969, IOSTAT = IOST)
     1          (NINT (VOID(N + I)), I = 1, NX)
            END DO
          END DO
          WRITE (LU65, 99973, IOSTAT = IOST) IPR(39)
          DO I = 1, IPR(39)
            CALL GEN048 (-4, IFG(1, I), 15, IVAL)
            NQ1 = LMT(IVAL + 1, 1)
            CALL GEN020 (1, NQ1, 2, 2)
            N = 0
            IF (NQ1(1:1) == ' ') N = 1
            WRITE (LU65, 99977, IOSTAT = IOST)
     1        NQ1(1+N:4+N), (XXO(I, J), J = 1, 3)
          END DO
          CLOSE (UNIT = LU65)
C * F3D
          PLPATH = ' '
          IGBL(145) = FINDEXE ('F3DEXE', PLPATH, 'f3d')
          IF (IGBL(145) > 0) THEN
            PLPATH(IGBL(145) + 1:) = ' '//NAMEFIL(1:KNMFIL)//'.slv &'
            IER = 0
            CALL SPAWN (PLPATH, LU6, .true., IER)
          END IF
          IPR(580) = -2
          IPR(2)   = -1
        END IF
      END IF
      RETURN
C * ERROR -> NO-SQUEEZE
   40 IPR(210) = 0
      WRITE (LU6, 99964, IOSTAT = IOST)
C * RESET MENU #
      IGBL(6) = 10
      RETURN
99999 FORMAT ('Search for and Analysis of Solvent Accessible Voids',
     1        ' in ''P1'' Structure - Grid =', F5.2,
     2        ' Ang., Probe Radius =', F6.2, ' Ang., NStep =', I2)
99998 FORMAT (A, '-Section : ', I5, ' - (Max =', I5, ') --- ',
     1        A, '-Vertical and ', A, '-Horizontal', /)
99997 FORMAT (/, 'SOLV- or VOID-Map Gridpoint Entries: ', //,
     1           '- Numerical  : Atom Type Number', /,
     2           '- ''*''        : Atom Type Number > 9', /,
     3           '- Alphabetic : Independent Solvent Accessible Void',
     4           ' with Extension = Dots', /)
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       ', Model Filled Space', F5.1, '% (= Packing Index)')
99991 FORMAT (':: Note: VOID/SOLV/SQUEEZE is relatively compute',
     1       ' compute intense', /)
99990 FORMAT (':: Nr of gridpoints at least', F5.2, ' Ang.',
     1        ' from nearest vdWaals Surface =', I8)
99989 FORMAT ('Grid: ', A, '-Axis Step =', F10.6,
     1        ' = Points', I4, ', Angstrom Step =', F8.5)
99988 FORMAT (':: Unit cell Contains NO Residual Solvent',
     1       ' Accessible Void(s).')
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 ('Void #GridPoint VolPerc.  Vol(A^3)', 2X,
     1        'X(av) Y(av) Z(av) Eigenvector(frac) Sig(Ang)')
99983 FORMAT (1X)
99982 FORMAT (5X, 'Report the Distance from VOID-CG to Boundary in ',
     1        'EigenVector-Directions', //, ' Nr', 1X, 'MinEV1', 1X,
     2        'MaxEV1', 1X, 'MinEV2', 1X, 'MaxEV2', 1X, 'MinEV3', 1X,
     3        'MaxEV3', 1X, 'MaxDist (Ang)', /, 80('='))
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, 'The maximum number of molecules of a given type',
     4       /, 6X, 'in a void can be estimated by deviding the void',
     5       /, 6X, 'volume by twice the molecular volume of that',
     6       /, 6X, 'molecule as calculated with the MOLVOL routine.',
     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 (I3, 7F7.2)
99978 FORMAT (':: Note: use CALC VOID (not CALC SOLV) for',
     1       ' Packing Index. ', /)
99977 FORMAT (A, 3F10.4)
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 ('ATOMS',  I8)
99972 FORMAT (A)
99971 FORMAT (/, A, /)
99970 FORMAT (/, A, /, 80('-'))
99969 FORMAT (250I1)
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 (/, 'Problem, IPR(210) set to zero')
99963 FORMAT (':: Search for and Analysis of Solvent Accessible Voids',
     1        ' in ''P1'' Structure', /, ':: Grid =', F5.2, ' Ang.,',
     2        ' Probe Radius =', F6.2, ' Ang., NStep =', I2, /)
99962 FORMAT ('SQUEEZE Job Cancelled')
      END SUBROUTINE PLA118
 
      SUBROUTINE PLA119 (KAT)
C * SUBROUTINE HANDLES ATOM LOOP
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      USE vscr
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: JAT
      INTEGER          :: JP3
      INTEGER          :: KAX
      INTEGER          :: KAT
      INTEGER          :: NAT
      INTEGER          :: NPOW
      INTEGER          :: IOMT
      INTEGER          :: IHLP0
      INTEGER          :: ILOOP
      REAL             :: DIJ
      REAL             :: DIJK
      REAL             :: P23K
      CHARACTER(len=1) :: CSCRAT
C * ORTHOGONALIZE GRID POINT COORDINATES
      V9(4) = OR11 * V9(1) + OR12 * V9(2) + OR13 * V9(3)
      V9(5) = OR22 * V9(2) + OR23 * V9(3)
      V9(6) = OR33 * V9(3)
      IPR(199) = 0
      P23K     = 0.0
C * GET NUMBER OF UNIQUE ATOMS
      NAT      = IPR(37)
C * COPY AND ORDER ATOM NP1 COORDINATES,
      KAX      = -1
      DO
        IF (KAX == 0) THEN
          GO TO 20
        ELSE IF (KAX > 0) THEN
          KAX = KAX - 1
          GO TO 40
        END IF
C * SYMMETRY ELEMENT LOOP
        IPR(54) = 0
   10   IPR(54) = IPR(54) + 1
        KAX     = -1
        IF (IPR(54) > NSYM) RETURN
C * ATOM J LOOP
        JAT = 0
   20   JAT = JAT + 1
        IF (JAT > NAT) GO TO 10
        CALL GEN048 (-1, IFG(2, JAT), 27, IOMT)
        IF (IOMT /= 0) GO TO 20
C * GET BIT 9-18   (IPR(59), IPR(62))
        CALL GEN048 (-10, IFG(1, JAT), 9, IHLP0)
C * RETRIEVE EL.TYPE (BIT 15 - 18) AND RESD NUMB (BIT 9-14) FOR ATOM JAT
        IPR(59)  = IHLP0 / 64
        IPR(62)  = MOD (IHLP0, 64)
        PAR(23)  = PAR(19)
        PAR(293) = 0.0
C * GET ELEMENT TYPE (E.G. 1 = H)
        IPR(510) = IEN(IPR(59) + 1)
        PAR(23)  = PAR(23) + RADR(IPR(59) + 1, 2) + PAR(293)
        P23K     = PAR(23)**2
C * SET D-LIMITS ON EACH AXIS AND ZERO INITIAL SHIFTS
        DO I = 1, 3
          DUMA(I) = DUMA(I + 3) * PAR(23)
          ITR(I)  = 0
        END DO
        DO I = 1, 3
          SGZ(I + 3) = 0.0
          SGZ(I)     = XXO(JAT, I)
        END DO
        CALL SGSM (3, CSCRAT, SGZ, IPR(54), LU7, IERR)
        DO I = 1, 3
          SGZ(I) = SGZ(I + 6)
        END DO
C * BEGIN TRANSLATIONAL SEARCH ROUTINE (SEE ROLLETT)
        KAX = 1
C * TRANSLATE SGZ ON AXIS KAX TO A POINT BELOW LOWER LIMIT
   30   IF (V9(KAX) - SGZ(KAX) <= DUMA(KAX)) THEN
          SGZ(KAX) = SGZ(KAX) - 1.0
          GO TO 30
        END IF
   40   DO
C * ADVANCE 1 UNIT ON AXIS KAX
          SGZ(KAX) = SGZ(KAX) + 1.0
          IF (V9(KAX) - SGZ(KAX) < DUMA(KAX)) THEN
            IF (SGZ(KAX) - V9(KAX) <= DUMA(KAX)) EXIT
C * TEST GIVES ATOM OUT OF RANGE. REDUCE AXIS KAX BY 1
            KAX = KAX - 1
            IF (KAX <= 0) GO TO 20
          END IF
        END DO
C * KAX = 0 SIGNALS THE END OF THE TRANSLATION SEARCH
C * IF SGZ WAS WITHIN RANGE ON AXIS KAX THEN WE ADVANCE KAX BY 1
        KAX = KAX + 1
        IF (KAX < 4) GO TO 30
C * CALCULATE ITR  AND IPR(26)
        NPOW    = 1000
        IPR(26) = IPR(54) * NPOW + 555
        ILOOP   = 0
        DO J = 1, 3
          NPOW       = NPOW / 10
          ITR(J)     = ITR(J) + NINT (SGZ(J) - SGZ(J + 6))
          SGZ(J + 6) = SGZ(J)
          IF (IABS(ITR(J)) > 4) THEN
C * OUT OF +/- 4 TRANSLATION RANGE
            IPR(494) = IPR(494) + 1
            ILOOP = 1
            EXIT
          END IF
          IPR(26) = IPR(26) + ITR(J) * NPOW
        END DO
        IF (ILOOP == 1) CYCLE
        KAT = IPR(39) + IPR(24) + 1
        IF (KAT > NP1 - IPR(75)) THEN
C * ATTEMPT TO EXCEED MAX ATOM LIMIT
          IPR(2) = 1
          RETURN
        END IF
        DO N = 1, 3
          J   = 4 - N
          JP3 = J + 3
          IF (JAT /= KAT) THEN
            XXO(KAT, J) = SGZ(J + 6)
          END IF
          XXO(KAT, JP3) = 0
          DO L = J, 3
            XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * OR(J, L)
          END DO
        END DO
C * ATOM IN RANGE FOR ALL 3 AXES. NOW CALCULATE EXACT DISTANCE AND TEST
        DIJK = (V9(4) - XXO(KAT, 4))**2 + (V9(5) - XXO(KAT, 5))**2 +
     1         (V9(6) - XXO(KAT, 6))**2
        IF (DIJK <= P23K) THEN
          DIJ = SQRT (DIJK)
C * IPR(199) RANGE:  I ... 1 ... VDW ... -1 ... VDW + PAR(19) .... 0
          IF (DIJ > PAR(23) - PAR(20)) THEN
            IPR(199) = -1
            CYCLE
          ELSE
            IPR(199) = 1
            RETURN
          END IF
        END IF
      END DO
      END SUBROUTINE PLA119
 
      SUBROUTINE PLA120
C * SOLV - SETUP PROBE
      USE files
      USE parameters
      USE plato
      USE vscr
      USE sgxyz
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: I1
      INTEGER :: I2
      INTEGER :: I3
      INTEGER :: I1N
      INTEGER :: I2N
      INTEGER :: I3N
      INTEGER :: INDX
      INTEGER :: INDX3
      REAL    :: GEN006
C * SETUP LIST OF GRIDPOINTS WITHIN PAR(84) Angstrom OF CENTRAL GRIDPOINT
      NJG(1, 1) = - 1
      NJG(1, 2) = 25
      L         = 0
      DO
        L      =   L      + 1
        JGR(L) = - MGR(L) - 1
   10   JGR(L) =   JGR(L) + 1
        IF (JGR(L) > MGR(L)) THEN
          L = L - 1
          IF (L == 0) THEN
C * GENERATE SHIFTED SETS (IN X, Y & Z)
            NJGR = NJG(1, 2)
            DO N = 2, 4
              NJG(N, 1) = NJG(N - 1, 2) - 1
              NJG(N, 2) = NJG(N - 1, 2) + 8
              DO 20 I = 1, NJGR
                I1 = JNSX(I * 3 - 2)
                I2 = JNSX(I * 3 - 1)
                I3 = JNSX(I * 3)
                IF (ABS (I1) < 2 .AND. ABS (I2) < 2 .AND.
     1              ABS (I3) < 2) THEN
                  IF (JNSX(I * 3 - 4 + N) == 1) THEN
                    NJG(N, 1) = NJG(N, 1) + 1
                    INDX      = NJG(N, 1)
                  ELSE
                    GO TO 20
                  END IF
                ELSE
                  I1N = I1 + I123(N, 1)
                  I2N = I2 + I123(N, 2)
                  I3N = I3 + I123(N, 3)
                  M   = 0
                  DO J = 1, NJGR
                    IF (ABS (JNSX(M + 1) - I1N) +
     1                  ABS (JNSX(M + 2) - I2N) +
     2                  ABS (JNSX(M + 3) - I3N) == 0) GO TO 20
                    M = M + 3
                  END DO
                  NJG(N, 2) = NJG(N, 2) + 1
                  INDX      = NJG(N, 2)
                END IF
                INDX3 = INDX * 3
                IF (INDX3 + 3 > 2 * NP23) THEN
                  WRITE (LU6, 99999, IOSTAT = IOST)
                  IER = 1
                  RETURN
                END IF
                DO K = 1, 3
                  JNSX(INDX3 + K) = JNSX(I * 3 - 3 + K)
                END DO
   20         CONTINUE
            END DO
            RETURN
          END IF
          GO TO 10
        ELSE
          IF (L >= 3) THEN
C * PUT FIRST COORDINATION SPHERE IN FRONT
            IF (ABS (JGR(1)) < 2 .AND. ABS (JGR(2)) < 2 .AND.
     1          ABS (JGR(3)) < 2) THEN
              IF (ABS (JGR(1)) + ABS (JGR(2)) + ABS (JGR(3)) == 0)
     1          GO TO 10
              NJG(1, 1) = NJG(1, 1) + 1
              INDX  = NJG(1, 1)
            ELSE
              DO K = 1, 3
                V6(K) = PAR(80 + K) * JGR(K)
              END DO
              IF (SQRT (GEN006 (V6, AA, V6)) > PAR(84)) GO TO 10
              NJG(1, 2) = NJG(1, 2) + 1
              INDX      = NJG(1, 2)
            END IF
            IND3 = INDX * 3
            IF (IND3 + 3 > 2 * NP23) THEN
              WRITE (LU6, 99999, IOSTAT = IOST)
              IER = 1
              RETURN
            END IF
C * STORE GRIDPOINT WITHIN PROBE SPHERE
            DO K = 1, 3
              JNSX(IND3 + K) = JGR(K)
            END DO
            GO TO 10
          END IF
        END IF
      END DO
      RETURN
99999 FORMAT (/, ':: Internal Problem: Request Aborted')
      END SUBROUTINE PLA120
 
      SUBROUTINE PLA121
C * EXPAND
      USE parameters
      USE files
      USE plato
      USE vscr
 
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: NJ
      INTEGER               :: NJI
      INTEGER               :: NJ3
      INTEGER               :: NGRD
      INTEGER               :: IJGRL
      INTEGER               :: I193L
      INTEGER               :: NXYZP
      INTEGER               :: NXYZI
      INTEGER               :: NXYZM
      INTEGER, DIMENSION(3) :: NGPV
 
C * ANALYSE WHAT WE HAVE GOT IN TERMS OF DISCRETE CONNECTED SOLVENT VOLUMES
C * SOLVENT-VOLUME CG-S ARE STORED BELOW THE REGULAR ATOMS IN XXO
      NGPV(1) = -1000
      NGPV(2) = -1000
      NGPV(3) = -1000
      ISLA    = NSAV
C * INIT NUMBER OF SOLVENT VOLUMES
      IPR(530) = 0
C * LOOP OVER ALL GRIDPOINTS
      DO N = 1, NTGRD
C * TEST FOR GRIDPOINTS AT MORE THAN VAN DER WAALS DISTANCE : CHARACTER >
        IF (VOID(N) == GRTR) THEN
          NGRD = N
C * TEST FOR CALC SOLV MODE
          IF (IPR(189) > 0) THEN
C * INITIATE NEW SOLVENT VOLUME AND (RE)SET TEMPORARY STACK POINTERS
            NGB      = NTGRD
            NGE      = NTGRD
            ISLA     = ISLA + 1
            IPR(530) = IPR(530) + 1
C * TEST FOR XXO-ARRAY OVERFLOW
            IF (ISLA > NP1 - IPR(75)) THEN
              IF (IGBL(3) /= 1) IPR(2) = 25
              IER = 1
              RETURN
            END IF
C * GENERATE APPROPRIATE ALPHABETIC CHARACTER TO DESIGNATE THIS VOLUME
            IF (ISLA - NSAV > 26) THEN
              IF (ISLA - NSAV > NP41) THEN
                WRITE (LU6, 99999, IOSTAT = IOST)
C * ALERT _604
                CALL PLA236 (604, 2, -999.0, 1.0, ' ', ' ')
                IER = 1
                RETURN
              END IF
              CSLA = ICHAR ('Z')
            ELSE
              CSLA = ICHAR ('A') + IPR(530) - 1
            END IF
C * ZERO VOID CG-DETERMINATION AND VARIANCE COUNTERS
            IATC(ISLA) = 0
            JATC(ISLA) = 0
            DO K = 1, 3
              XXO(ISLA, K) = 0.0
              NXYZ(K, 2)   = 0
            END DO
            DO K = 1, 9
              SXYZ(K, IPR(530)) = 0.0
            END DO
            VOID(NGRD) = CSLA
          END IF
C * RECOVER GRID COORDINATES IGR(1, 2) (0:N1-1), IGR(2, 2) (0:N2-1),
C *   IGR(3, 2) (0:N3-1)
   10     M         = NGRD - 1
          IGR(1, 2) = M / N23
          IGR(3, 2) = M - IGR(1, 2) * N23
          IGR(2, 2) = IGR(3, 2) / N3
          IGR(3, 2) = IGR(3, 2) - IGR(2, 2) * N3
C * ADD TO SOLVENT VOLUME STATISTICS
          CALL PLA122 (2)
C * COMPARE NEXT WITH PREVIOUS EXPAND POINT
          DO L = 1, 3
            NGNX(L) = NXYZ(L, 2) + IGR(L, 2)
          END DO
          NJI = 1
C * + Z
          IF (NGPV(3) + 1 == NGNX(3)) THEN
            IF (NGPV(2) == NGNX(2)) THEN
              IF (NGPV(1) == NGNX(1)) NJI = 4
            END IF
C * + Y
          ELSE IF (NGPV(2) + 1 == NGNX(2)) THEN
            IF (NGPV(1) == NGNX(1)) THEN
              IF (NGPV(3) == NGNX(3)) NJI = 3
            END IF
C * + X
          ELSE IF (NGPV(1) + 1 == NGNX(1)) THEN
            IF (NGPV(2) == NGNX(2)) THEN
              IF (NGPV(3) == NGNX(3)) NJI = 2
            END IF
          END IF
          IF (NJI == 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)
          END IF
          DO L = 1, 3
            NGPV(L) = NGNX(L)
          END DO
C * GRID SEARCH AROUND POINT (WITHIN PAR(84) Angstrom FROM BASE-POINT
          DO NJ = NJB, NJE
            NJ3 = NJ3 + 3
            M   = 1
            DO L = 1, 3
              I193L      = IPR(193 + L)
              NXYZ(L, 1) = NXYZ(L, 2)
              IJGRL      = IGR(L, 2) + JNSX(NJ3 + L)
C * BRING IJGRL - GRIDPOINT IN UNIT BOX RANGE (REGISTER SHIFTS)
   20         IF (IJGRL < 0) THEN
                IJGRL      = IJGRL      + I193L
                NXYZ(L, 1) = NXYZ(L, 1) - I193L
                GO TO 20
              ELSE
   30           IF (IJGRL >= I193L) THEN
                  IJGRL      = IJGRL   - I193L
                  NXYZ(L, 1) = NXYZ(L, 1) + I193L
                  GO TO 30
                END IF
              END IF
C * ACCUMULATE GRIDPOINT ADDRESS (IN UNITCELL RANGE)
              M         = M + IJGRL * KGR(L)
              IGR(L, 1) = IJGRL
            END DO
C * TEST FOR CHARACTERS . AND > ( = PREVIOUSLY TAKEN CARE OF GRIDPOINTS)
C * TEST FOR ZERO, BLANK AND DOT
            IF (VOID(M) < GRTR) THEN
              IF (VOID(M) /= DOT) THEN
C * TEST FOR VOID-MODE
                IF (IPR(189) == 1) THEN
C * SET CHARACTER DOT
                  VOID(M) = DOT
                ELSE
                  VOID(M) = CSLA
                END IF
C * ADD TO SOLVENT VOLUME STATISTICS
                CALL PLA122 (1)
              END IF
            ELSE IF (VOID(M) == GRTR) THEN
C * TEST FOR SOLV MODE
              IF (IPR(189) > 0) THEN
C * OVERFLOW CHECK
                IF (NGE + 2 > NVDR) THEN
C * TRY TO SHIFT BACK TO MAKE SPACE
                  IF (NGB > NTGRD) THEN
                    I = NTGRD
                    J = NGB
                    DO WHILE (J < NGE)
                      I           = I + 2
                      VOID(I - 1) = VOID(J + 1)
                      VOID(I)     = VOID(J + 2)
                      J           = J + 2
                    END DO
                    NGB = NTGRD
                    NGE = I
                  END IF
                  IPR(214) = IPR(214) - 1
                  IER = -1
                  RETURN
                END IF
                NGE = NGE + 2
C * TEMPORARILY STORE THIS GRIDPOINT ON A STACK
                NXYZP = 555
                NXYZM = 100
                DO I = 1, 3
                  NXYZP = NXYZP
     1                  + NXYZ(I, 1) * NXYZM / IPR(193 + I)
                  NXYZM = NXYZM / 10
                END DO
                VOID(NGE - 1) = NXYZP
                VOID(NGE)     = M
C * MARK VOLUME
                VOID(M)       = CSLA
              END IF
            END IF
          END DO
C * TEST FOR CALC SOLV MODE
          IF (IPR(189) > 0) THEN
C * GET NEXT 'GRTR' GRIDPOINT FROM BOTTOM OF STACK
            IF (NGE > NGB) THEN
              NGB   = NGB + 2
              NXYZP = NINT (VOID(NGB - 1))
              NXYZM = 100
              DO I = 1, 3
                NXYZI      = NXYZP / NXYZM
                NXYZ(I, 2) = (NXYZI - 5) * IPR(193 + I)
                NXYZP      = NXYZP - NXYZI * NXYZM
                NXYZM      = NXYZM / 10
              END DO
              NGRD = NINT (VOID(NGB))
              GO TO 10
            END IF
          END IF
        END IF
      END DO
      RETURN
99999 FORMAT ('Too Many Voids')
      END SUBROUTINE PLA121
 
      SUBROUTINE PLA122 (NADD)
C * OHASHI/SOLV VOLUME STATISTICS
      USE files
      USE parameters
      USE plato
      USE vscr
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: ISL
      INTEGER               :: IJG
      INTEGER               :: ISLB
      INTEGER               :: NADD
      INTEGER, DIMENSION(3) :: IJGRD
      REAL,    DIMENSION(3) :: VO
      REAL,    DIMENSION(3) :: VG
C * NADD = 1 - OHASHI
C * NADD = 2 - SOLV
C * SOLVENT GRID-POINT COUNTER
      IPR(188) = IPR(188) + 1
C * TEST FOR CALC SOLV MODE
      IF (IPR(189) > 0) THEN
C * GET CURRENT VOID NUMBER
        ISL        = IPR(530)
        ISLB       = IPR(39) + ISL + 1
        JATC(ISLB) = JATC(ISLB) + 1
        IF (NADD == 2) IATC(ISLB) = IATC(ISLB) + 1
C * GET VOLUME CODE
        IATP(ISLB) = IATP(ISLB) + 1
C * GET FRACTIONAL COORDINATES OF GRID POINT
        DO I = 1, 3
          J            = NXYZ(I, NADD) + IGR(I, NADD)
          VG(I)        = PAR(80 + I)  * J
          XXO(ISLB, I) = XXO(ISLB, I) + VG(I)
C * BRING GRID POINTS IN 0-1 RANGE FOR SQUEEZE
          IF (IPR(326) == 1) THEN
            IJG = MOD (J, IPR(193 + I))
            IF (IJG < 0) IJG = IJG + IPR(193 + I)
            IJGRD(I) = IJG
          ELSE
            IJGRD(I) = J
          END IF
        END DO
C * TRANSFORM TO ORTHOGONAL GRID POINT COORDINATES
        VO(1) = OR11 * VG(1) + OR12 * VG(2) + OR13 * VG(3)
        VO(2) =                OR22 * VG(2) + OR23 * VG(3)
        VO(3) =                               OR33 * VG(3)
C * ACCUMULATE DATA FOR FIRST AND SECOND MOMENT CALCULATIONS
        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)
C * WRITE 'SAV'-FILE (SOLV, SQUEEZE=1, PLOT=2, F3D=3, SAV= -1)
        IF (IPR(326) /= 0) WRITE (LU15) IJGRD, ISL, NADD, VO
      END IF
      RETURN
      END SUBROUTINE PLA122
 
      SUBROUTINE PLA123
C * SOLVENT ACCESSIBLE VOLUME DISPLAY
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE vscr
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER        :: NP81 = 100000
      INTEGER                   :: I
      INTEGER                   :: J
      INTEGER                   :: K
      INTEGER                   :: L
      INTEGER                   :: M
      INTEGER                   :: N
      INTEGER                   :: NJ
      INTEGER                   :: I0
      INTEGER                   :: J0
      INTEGER                   :: N0
      INTEGER                   :: IB
      INTEGER                   :: IE
      INTEGER                   :: MN
      INTEGER                   :: MB
      INTEGER                   :: NB
      INTEGER                   :: NF
      INTEGER                   :: NI
      INTEGER                   :: NL
      INTEGER                   :: NP
      INTEGER                   :: NS
      INTEGER                   :: NV
      INTEGER                   :: NP0
      INTEGER                   :: NLA
      INTEGER                   :: NLB
      INTEGER                   :: NLC
      INTEGER                   :: NVL
      INTEGER                   :: NF0
      INTEGER                   :: NBJ
      INTEGER                   :: NBK
      INTEGER                   :: MBJ
      INTEGER                   :: MBK
      INTEGER                   :: IP1
      INTEGER                   :: IP2
      INTEGER                   :: IP3
      INTEGER                   :: NAT
      INTEGER                   :: NO1
      INTEGER                   :: NO2
      INTEGER                   :: NOF
      INTEGER                   :: NRES
      INTEGER                   :: NOFF
      INTEGER                   :: NLAB
      INTEGER                   :: NADD
      INTEGER                   :: IENR
      INTEGER                   :: IDET
      INTEGER                   :: IADR
      INTEGER                   :: INDX1
      INTEGER                   :: INDX2
      INTEGER                   :: INDX3
      INTEGER                   :: NBOND
      INTEGER                   :: IRESI
      INTEGER                   :: IROTX
      INTEGER                   :: IROTY
      INTEGER                   :: IROTZ
      INTEGER                   :: ISTER
      INTEGER, DIMENSION(3)     :: ISH
      INTEGER, DIMENSION(3)     :: IMX
      INTEGER, DIMENSION(3)     :: IGMN
      INTEGER, DIMENSION(3)     :: IGMX
      INTEGER, DIMENSION(2, 12) :: IUNCL
      REAL                      :: X
      REAL                      :: ANG
      REAL                      :: CL1
      REAL                      :: CL2
      REAL                      :: HRS
      REAL                      :: SHX
      REAL                      :: SHY
      REAL                      :: V61
      REAL                      :: V81
      REAL                      :: DXYZ
      REAL                      :: YANK
      REAL                      :: XLNG
      REAL                      :: VRTH
      REAL                      :: HRSH
      REAL                      :: COL1
      REAL                      :: COL2
      REAL                      :: DIST
      REAL                      :: DISTI
      REAL                      :: SCHAAL
      REAL                      :: DUMMY
      REAL                      :: DISTMX
      REAL,    DIMENSION(3)     :: V0
      REAL,    DIMENSION(3)     :: XMN
      REAL,    DIMENSION(3)     :: XMX
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MBOND
      ALLOCATE (MBOND(2, NP81))
      IUNCL = RESHAPE ((/1, 2, 1, 3, 1, 5, 3, 4, 2, 4, 2, 6, 5, 6, 4,
     1                   8, 7, 8, 3, 7, 6, 8, 5, 7/), (/2, 12/))
C * DEFAULT SETTINGS
C * STEREO ON
      IPR(116) = 1
C * DISPLAY ALL RESIDUES
      IPR(140) = 0
C * RMAT-DEFAULT
      IPR(526) = 0
      INDX3    = 3
      INDX2    = 2
      INDX1    = 1
C * UNIT CELL ON
      IPR(527) = 1
C * SHOW MOL ON
      IPR(528) = 1
C * OHASHI-VOL OFF
      IPR(529) = 0
C * R/G- STEREO
      IPR(533) = 1
C * DOTS DEFAULT
      IPR(534) = 1
C * ATOM LABELS OFF
      IGBL(75) = 0
      NAT      = IPR(39)
      NRES     = IPR(75)
C * INTERACTIVE I/O LOOP
      DO
C * WHAT NEXT ?
        CALL PLA012 (1, 1)
C * CHECK FOR BLACK TO WHITE BACKGROUND
        IF (IGGT(1:3) == 'REV') THEN
          IGBL(68) = MOD (IGBL(68) + 1, 2)
          CALL GGIP (-999.0, FLOAT (IGBL(68)), IGBL(62) * 0.25, 9)
        END IF
        IF (IGGT(1:4) == 'EXIT' .OR. IGGT(1:1) == 'N') RETURN
        IF (LRET == 1) THEN
        ELSE IF (LRET == 3) THEN
          IPR(526) = -1
        ELSE IF (LRET == 4) THEN
          GO TO 20
        ELSE
          IPR(526) = -1
        END IF
C * SETUP RMAT FROM ROTATIONS
C * INCREMENTAL XROT, YROT, ZROT
        IF (IPR(526) == -1) THEN
          DUMMY = PAR(389) / RGBL(6)
          CALL GEN051 (1, RMAT, DUMMY, IPR(479))
          IPR(526) = 0
C * TAKE CURRENT MATRIX
        ELSE IF (IPR(526) == 0) THEN
C * GENERATE UNIT MATRIX
          CALL GEN021 (RMAT, 1.0)
          DO I = 1, 3
            X = - RGBL(27 + I) / RGBL(6)
            L = I
            CALL GEN051 (0, RMAT, X, L)
          END DO
C * VIEW XO
        ELSE IF (IPR(526) == 1) THEN
          CALL GEN043 (2, RMAT,  90.0 / RGBL(6))
          INDX3 = 1
          INDX2 = 2
          INDX1 = 3
C * VIEW YO
        ELSE IF (IPR(526) == 2) THEN
          CALL GEN043 (1, RMAT, -90.0 / RGBL(6))
          INDX3 = 2
          INDX2 = 1
          INDX1 = 3
C * VIEW ZO
        ELSE IF (IPR(526) == 3) THEN
          CALL GEN043 (1, RMAT,   0.0 / RGBL(6))
          INDX3 = 3
          INDX2 = 2
          INDX1 = 1
        ELSE
          GO TO 10
        END IF
        CALL GEN096 (RMAT, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM)
        RGBL(28) = IROTX
        RGBL(29) = IROTY
        RGBL(30) = IROTZ
        IPR(526) = 4
   10   ANG = IPR(116) * 3.0 / RGBL(6)
        CALL GEN043 (2, ROTM1, - ANG)
        CALL GEN043 (2, ROTM2, + ANG)
   20   CALL GGIP (HORS, VERT, 0.0, 1)
        ISTER = IPR(533)
        HRS   = HORS / ISTER
        CALL PLA110 (HORS, VERT, 0)
        DO I = 1, 3
          IGMN(I) =  999
          IGMX(I) = -999
          XMN(I)  =  999.0
          XMX(I)  = -999.0
        END DO
        NOFF  = 0
        NBOND = 0
        NP    = 0
C * UNITCELL OUTLINE
        IF (IPR(527) == 1) THEN
          DO I = 1, 2
            V3(1) = I - 1
            DO J = 1, 2
              V3(2) = J - 1
              DO 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 M = 1, 3
                  XMN(M) = MIN (XMN(M), V2(M))
                  XMX(M) = MAX (XMX(M), V2(M))
                  VOID(NOFF + 1 + M) = V2(M)
                END DO
                NP   = NP + 1
                NOFF = NOFF + 7
              END DO
            END DO
          END DO
          NP0 = NP
C * INCLUDE UNITCELL 'BONDS'
          DO I = 1, 2
            DO J = 1, 12
              MBOND(I, J) = IUNCL(I, J)
            END DO
          END DO
          NBOND = 12
        END IF
C * LOAD ATOMIC COORDINATES
        IF (IPR(528) == 1) THEN
          DO K = 1, NRES
            IF (IPR(140) == 0 .OR. K == IPR(140)) THEN
C * GET CENTER-OF-GRAVITY (CG)
              CALL GEN074 (V5, 1, 3, 0.0)
              N = 0
              DO I = 1, NAT
                CALL GEN048 (-6, IFG(1, I), 9, IRESI)
                IF (IRESI == K) THEN
                  N = N + 1
                  DO J = 1, 3
                    V5(J) = V5(J) + XXO(I, J)
                  END DO
                END IF
              END DO
              DO J = 1, 3
                V5(J) = V5(J) / N
              END DO
              IF (IPR(537) == 1) THEN
                NS = NSYM
              ELSE
                NS = 1
              END IF
              DO N = 1, NS
                DO I = 1, 3
                  SGY(I + 3) = 0.0
                  SGY(I)     = V5(I)
                END DO
                CALL SGSM (3, IDM, SGY, N, LU6, IERR)
                DO I = 1, 3
                  SGY(I + 3) =  - (INT (SGY(6 + I) + 5.0) - 5)
                END DO
                DO I = 1, NAT
                  CALL GEN048 (-6, IFG(1, I), 9, IRESI)
                  IF (IRESI == K) THEN
                    DO J = 1, 3
                      SGY(J) = XXO(I, J)
                    END DO
                    CALL SGSM (3, IDM, SGY, N, LU6, IERR)
                    V2(1) = OR11 * SGY(7) + OR12 * SGY(8)
     1                    + OR13 * SGY(9)
                    V2(2) = OR22 * SGY(8) + OR23 * SGY(9)
                    V2(3) = OR33 * SGY(9)
                    DO J = 1, 3
                      XMN(J) = MIN (XMN(J), V2(J))
                      XMX(J) = MAX (XMX(J), V2(J))
                      VOID(NOFF + 1 + J) = V2(J)
                    END DO
                    VOID(NOFF + 1) = I
                    DXYZ = 1.0
                    IF (NP > NP0 .AND. N > 1) THEN
                      DO L = NP0 + 1, NP
                        M = (L - 1) * 7 + 1
                       DXYZ = ABS (VOID(M + 1) - V2(1)) +
     1                         ABS (VOID(M + 2) - V2(2)) +
     2                         ABS (VOID(M + 3) - V2(3))
                        IF (DXYZ < 0.001) EXIT
                      END DO
                    END IF
                    IF (DXYZ > 0.001) THEN
                      NP   = NP   + 1
                      NOFF = NOFF + 7
                    END IF
                  END IF
                END DO
              END DO
            END IF
          END DO
C * LOAD BONDS
          NOF = IPR(527) * 8
          DO I = NOF + 1, NP - 1
            NI = NINT (VOID(I * 7 - 6))
            DO K = 1, 3
              V2(K) = VOID(I * 7 - 6 + K)
            END DO
            CALL GEN048 (-4, IFG(1, NI), 15, NO1)
            DISTI = REL(IEN(NO1 + 1)) + 0.4
            DO J = I + 1, NP
              NJ = NINT (VOID(J * 7 - 6))
              DO K = 1, 3
                V3(K) = VOID(J * 7 - 6 + K)
              END DO
              CALL GEN048 (-4, IFG(1, NJ), 15, NO2)
              DISTMX = DISTI + REL(IEN(NO2 + 1))
              DIST   = 0
              DO K = 1, 3
                DIST = DIST + (V2(K) - V3(K))**2
              END DO
              IF (SQRT (DIST) < DISTMX) THEN
                IF (NBOND < NP81) THEN
                  NBOND           = NBOND + 1
                  MBOND(1, NBOND) = I
                  MBOND(2, NBOND) = J
                ELSE
                  GO TO 40
                END IF
              END IF
            END DO
          END DO
        END IF
C * DISPLAY CG & EIGENVECTORS
        IF (IPR(598) /= 0) THEN
C * UNIT MATRIX
          CALL GEN021 (QQ, 1.0)
C * DETERMINE ALL OR SELECTED VOID(S)
          IF (IPR(531) == 0) THEN
            IB = 1
            IE = IPR(530)
          ELSE
            IB = IPR(531)
            IE = IPR(531)
          END IF
          DO I = IB, IE
            DO J = 1, 3
              V4(J) = SXYZ(9 + J, I)
              V5(J) = SXYZ(J    , I)
              V6(J) = SXYZ(3 + J, I)
              V8(J) = SXYZ(6 + J, I)
            END DO
            CALL GEN002 (1, OR, V4, V4, XLNG)
            CALL GEN002 (2, QQ, V5, V5, XLNG)
            CALL GEN002 (2, QQ, V6, V6, XLNG)
            CALL GEN002 (2, QQ, V8, V8, XLNG)
C * LOAD PSEUDO ATOMS FOR DIRECTION/SIZE DISPLAY
            DO J = 1, 3
              VOID(NOFF +  1 + J) = V4(J)
              VOID(NOFF +  8 + J) = V4(J) + V5(J) * SXYZ(13, I)
              VOID(NOFF + 15 + J) = V4(J) + V6(J) * SXYZ(14, I)
              VOID(NOFF + 22 + J) = V4(J) + V8(J) * SXYZ(15, I)
            END DO
            NOFF = NOFF + 28
C * ADD DIRECTIONS AS PSEUDO-BONDS
            IF (NBOND - 2 < NP81) THEN
              DO J = 1, 3
                NBOND          = NBOND + 1
                MBOND(1, NBOND) = NP + 1
                MBOND(2, NBOND) = NP + J + 1
              END DO
            ELSE
              GO TO 40
            END IF
            NP = NP   + 4
          END DO
        END IF
C * READ SOLVENT DATA FOR SCALING
        NVL = IPR(531)
        NF  = NOFF
        REWIND (UNIT = LU15, IOSTAT = IOST)
        DO
          READ (LU15, IOSTAT = IOST) (IGR(I, 2), I = 1, 3), NV, NADD
          IF (IOST /= 0) EXIT
          IF (NVL == 0 .OR. NV == NVL) THEN
C * TEST FOR NO OHASHI SURFACE DISPLAY
            IF (IPR(529) == 0 .OR. NADD == 2) THEN
              DO I = 1, 3
                IF (IPR(535) /= 0) THEN
                  IF (IGR(I, 2) < 0) IGR(I, 2) =
     1              IGR(I, 2) + IPR(193 + I)
                END IF
                V3(I) = FLOAT(IGR(I, 2)) / IPR(193 + I)
              END DO
              V2(1) = OR11 * V3(1) + OR12 * V3(2) + OR13 * V3(3)
              V2(2) =                OR22 * V3(2) + OR23 * V3(3)
              V2(3) =                               OR33 * V3(3)
              NP    = NP + 1
              NOFF  = NOFF + 7
              IF (NOFF > NVDR) GO TO 30
              DO I = 1, 3
                IGMN(I)            = MIN (IGMN(I), IGR(I, 2))
                IGMX(I)            = MAX (IGMX(I), IGR(I, 2))
                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, 2)
              END DO
            END IF
          END IF
        END DO
C * ADD ONE BORDER AND SHIFT TO MAKE ALL GRIDPOINTS >= 0
        DO I = 1, 3
          ISH(I) = - IGMN(I) + 1
          IMX(I) =   IGMX(I) + ISH(I) + 1
          V0(I)  =   (XMN(I) + XMX(I)) / 2.0
        END DO
C * DETERMINE SCHAAL FACTOR
        CALL GEN074 (XMN, 1, 3,  999.0)
        CALL GEN074 (XMX, 1, 3, -999.0)
        DO I = 1, NP
          N = (I - 1) * 7
          DO M = 1, 3
            V4(M) = VOID(N + 1 + M) - V0(M)
          END DO
          CALL GEN002 (1, RMAT, V4, V5, XLNG)
          DO 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)
          END DO
        END DO
        SHX    = HORS / ((XMX(1) - XMN(1)) * ISTER)
        SHY    = VERT / (XMX(2) - XMN(2))
        SCHAAL = MIN (SHX, SHY) * 0.80
C * APPLY SCHAAL ON VOID, UNITCELL & ATOM COORDINATES
        DO I = 1, NP
          N = (I - 1) * 7 + 1
          DO M = 1, 2
            VOID(N + M) = SCHAAL * VOID(N + M)
          END DO
          VOID(N + 3) = SCHAAL * (VOID(N + 3) - XMX(3))
        END DO
C * GRID PACKING
        IP1 =  IMX(INDX1) + 1
        IP2 = (IMX(INDX2) + 1) * IP1
        IP3 = (IMX(INDX3) + 1) * IP2
        IB  = NOFF + 1
        IE  = NOFF + IP3 * 4
        IF (IE > NVDR) GO TO 30
        CALL GEN074 (VOID, IB, IE, 0.0)
C * RE-READ SOLVENT DATA POINTS FOR STORAGE & PLOTTING
        NF0 = NF + 7
        DO WHILE (NF0 <= NOFF)
          DO I = 1, 3
            V2(I)  = VOID(NF0 - 6 + I)
            IGR(I, 2) = NINT (VOID(NF0 - 3 + I))
          END DO
          IADR = (IGR(INDX3, 2) * IP2 + IGR(INDX2, 2) * IP1
     1         + IGR(INDX1, 2)) * 4  + NOFF
          VOID(IADR + 1) = 99.0
          VOID(IADR + 2) = V2(1)
          VOID(IADR + 3) = V2(2)
          VOID(IADR + 4) = V2(3)
          NF0            = NF0 + 7
        END DO
C * ELIMINATE 'INTRA' POINTS
        DO K = 1, IMX(INDX3) + 1
          NBK = (K - 1) * IP2
          DO J = 1, IMX(INDX2) + 1
            NBJ = (J - 1) * IP1
            DO I = 1, IMX(INDX1) + 1
              NB = (NBK + NBJ + I - 1) * 4 + 1 + NOFF
              N  = - 1
              IF (VOID(NB) > 0.0) THEN
                  MBK = (K  - 1) * IP2
                  DO J0 = 1, 3
                    MBJ = (J + J0 - 3) * IP1
                    DO I0 = 1, 3
                      MB = (MBK + MBJ + I + I0 - 3) * 4 + 1 + NOFF
                      IF (VOID(MB) /= 0.0) THEN
                        N = N + 1
                      END IF
                    END DO
                  END DO
                VOID(NB) =  N
              END IF
            END DO
          END DO
        END DO
C * PLOT SOLVENT OUTLINE
        HRSH = HORS / (2.0 * ISTER)
        VRTH = VERT / 2.0
        IF (ISTER == 1) THEN
          COL1 = 1.0 + IPR(116)
          COL2 = 3.0
        ELSE
          COL1 = 1.0
          COL2 = 1.0
        END IF
        IF ((IPR(116) == 0 .OR. IPR(533) == 2) .AND.
     1       IPR(346) == 1) THEN
C * TEST FOR OHASHI SURFACE  DISPLAY
          IF (IPR(529) == 1) THEN
            CL1 = 2
            CL2 = 2
          ELSE
            CL1 = 3
            CL2 = 3
          END IF
        ELSE
          CL1 = COL1
          CL2 = COL2
        END IF
        N0 = 8
        IF (IPR(534) == 2) THEN
          NLA = 1
          NLB = 3
          NLC = 1
        ELSE
          NLA = 2
          NLB = 2
          NLC = 0
        END IF
        CALL GGIP (HRSH, VRTH, 0.0, -3)
        DO K = 1, IMX(INDX3) + 1
          NBK = (K - 1) * IP2
          DO J = 1, IMX(INDX2) + 1
            NBJ = (J - 1) * IP1
            DO I = 1, IMX(INDX1) + 1
              NB = (NBK + NBJ + I - 1) * 4 + NOFF
              N = NINT (VOID(NB + 1))
              IF (N > 0) THEN
                IF (N < N0) THEN
                  DO L = 1, 3
                    V2(L) = VOID(NB + 1 + L)
                  END DO
                  CALL GEN002 (1, ROTM1, V2, V4, XLNG)
                  DO J0 = NLA, NLB
                    DO I0 = NLA, NLB
                      IF (ABS (J0 - 2) + ABS (I0 - 2) == NLC) THEN
                        MB = NB + ((J0 - 2) * IP1 + I0 - 2) * 4
                        M = NINT (VOID(MB + 1))
                        IF (M > 0 .AND. M < N0) THEN
                          DO L = 1, 3
                            V3(L) = VOID(MB + 1 + L)
                          END DO
                          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) == 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 == 2) THEN
                              V61 = V6(1) + HRS
                              V81 = V8(1) + HRS
                            ELSE
                              V61 = V6(1)
                              V81 = V8(1)
                            END IF
                            CALL GGIP (V61, V6(2), 0.0, 3)
                            CALL GGIP (V81, V8(2), 0.0, 2)
                          END IF
                        END IF
                      END IF
                    END DO
                  END DO
                END IF
              END IF
            END DO
          END DO
        END DO
C * PLOT UNITCELL AND OR MOLECULE
        CALL GGIP (0.0, -2.0, 0.0, 0)
        IF (NBOND > 0) THEN
          DO I = 1, NBOND
            DO J = 1, 3
              V3(J) = VOID((MBOND(1, I) - 1) * 7 + 1 + J)
              V4(J) = VOID((MBOND(2, I) - 1) * 7 + 1 + J)
            END DO
            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) == 1) THEN
              CALL GEN002 (1, ROTM2, V3, V5, XLNG)
              CALL GEN002 (1, ROTM2, V4, V6, XLNG)
              IF (ISTER == 2) THEN
                V5(1) = V5(1) + HRS
                V6(1) = V6(1) + HRS
              ELSE
                CALL GGIP (0.0, COL2, 0.0, 0)
              END IF
              CALL GGIP (V5(1), V5(2), 0.0, 3)
              CALL GGIP (V6(1), V6(2), 0.0, 2)
            END IF
          END DO
C * LABELS
          NLAB = IPR(527) * 8 + IGBL(75) * NAT
          IF (NLAB > 0) THEN
            DO I = 1, NLAB
              NQ1 = ' '
              NL = NINT (VOID((I - 1) * 7 + 1))
              DO J = 1, 3
                V2(J) = VOID((I - 1) * 7 + J + 1)
              END DO
              CALL GEN002 (1, ROTM1, V2, V3, XLNG)
              CALL GEN002 (1, ROTM2, V2, V4, XLNG)
              IENR = 0
              IF (NL <= 0) THEN
                IF (IPR(532) /= 0) THEN
                  IF (NL == 0) THEN
                    NQ1 = 'O'
                  ELSE IF (NL == -4) THEN
                    NQ1 = 'a'
                  ELSE IF (NL == -2) THEN
                    NQ1 = 'b'
                  ELSE IF (NL == -1) THEN
                    NQ1 = 'c'
                  END IF
                END IF
              ELSE
                CALL PLA047 (LABA(NL), NQ1, MN, IENR, 0, IGBL(55),
     1                       0, 0)
              END IF
              IF (IENR /= 1 .OR. IPR(232) == 1) THEN
              CALL PLA439 (0.0, NQ1, 5, PAR(349), NINT (COL1), 2,
     1                V3(1) + 0.4, V3(2) - 0.4)
                IF (IPR(116) == 1) THEN
                  IF (ISTER == 2) V4(1) = V4(1) + HRS
                  CALL PLA439 (0.0, NQ1, 5, PAR(349), NINT (COL2), 2,
     1                V4(1) + 0.4, V4(2) - 0.4)
                END IF
              END IF
            END DO
          END IF
        END IF
      END DO
      DEALLOCATE (MBOND)
      RETURN
C * CALL EXIT/STOP
   30 CALL GEN127
     1 ('VOID Array too small; raise NVDR parameter for larger version')
      RETURN
   40 CALL GEN127 ('Bond Overflow: NBOND >= NP81 (Raise par. value)')
      RETURN
      END SUBROUTINE PLA123
 
      MODULE squeeze
      SAVE
      INTEGER                          :: HMAX
      INTEGER                          :: KMAX
      INTEGER                          :: LMAX
      INTEGER                          :: NREF
      INTEGER                          :: NREFS
      REAL                             :: RF
      REAL                             :: RFS
      REAL                             :: DRHOMN
      REAL                             :: DRHOMX
      REAL,DIMENSION(20, 9)            :: STAT
      CHARACTER(len=62), DIMENSION(3)  :: TXT1
      CHARACTER(len=62), DIMENSION(30) :: TXT = (/
     1 '==============================================================',
     2 'SQUEEZE produces and analyzes a phase enhanced difference map ',
     3 'using the files name.ins & name.hkl. Density found in solvent ',
     4 'accessible voids is back-fourier transformed into A(solv) &   ',
     5 'B(solv) contributions to F(calc) to be used for subsequent    ',
     6 'L.S. refinement. No model refinement is done by PLATON/SQUEEZE',
     7 '==============================================================',
     8 'HOW TO PROCEED with L.S. refinement after running SQUEEZE:    ',
     9 '==============================================================',
     * 'SHELXL201n: Continue refinement in the presence of the three  ',
     1 'files name_sq.ins, name_sq.hkl & name_sq.fab                  ',
     2 'Additional info on name_sq.sqf , name_sq.sqz & name_sq.lis    ',
     3 '==============================================================',
     4 'Citation: Spek, A.L. (2015). Acta Cryst. C71, 9-18.           ',
     5 '==============================================================',
     6 'SHELXL97 (Deprecated): Refine in the presence of the files    ',
     7 'name_sqd.ins, name_sqd.hkl, name_sqd.sqz & name_sqd.sqf:      ',
     8 '-The file name_sqd.hkl contains solvent free reflection data. ',
     9 ' (Original I(obs), A(solv) and B(solv) are beyond column 80)  ',
     * '-Use this name_sqd.hkl file to continue (SHELXL97) refinement ',
     1 ' with the solvent free name_sqd.ins. (A copy of the original  ',
     2 ' name.res file).                                              ',
     3 '-After SHELXL(97) L.S.-convergence, run PLATON again with the ',
     4 ' instruction "CALC FCF-SQ" using the new name_sqd.ins and     ',
     5 ' name_sqd.hkl files in order to produce a proper final        ',
     6 ' FoFc-CIF on a file named name_sqd_pl.fcf.                    ',
     7 '-The name_sqd.sqf file produced by PLATON (detailing the      ',
     8 ' SQUEEZE results) is appended to name_sqd.cif (created by     ',
     9 ' SHELXL(97)) to generate a final name_sqd_pl.cif file.        ',
     * '-Optionally inspect the improved peak list on name_sqd.sqz    '
     1 /)
      END MODULE squeeze
 
      MODULE reflex
      SAVE
      INTEGER, PARAMETER          :: NP60 = 1000
      INTEGER, PARAMETER          :: NP69 = 16
      INTEGER                     :: MHK
      INTEGER                     :: MPH
      INTEGER                     :: IND1
      INTEGER                     :: IND2
      INTEGER                     :: IND3
      INTEGER                     :: NSYM
      INTEGER                     :: NSYMH
      INTEGER                     :: ICNTR
      INTEGER, DIMENSION(5, 48)   :: IHKLS
      INTEGER, DIMENSION(4, NP60) :: MISSING
      REAL,    DIMENSION(48)      :: PHIS
      END MODULE reflex
 
      SUBROUTINE PLA125
C * SQUEEZE: HANDLE (DISORDERED) SOLVENT CONTRIBUTION TO STRUCTURE FACTORS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE reflex
      USE squeeze
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: M3
      INTEGER :: NM
      INTEGER :: NV
      INTEGER :: LOC
      INTEGER :: IR3D
      INTEGER :: ITOP
      INTEGER :: ILOC
      INTEGER :: IBOT
      INTEGER :: IADR
      INTEGER :: NVOID
      INTEGER :: NGRID
      INTEGER :: NLOOP
      INTEGER :: NLOPM
      INTEGER :: NLPMX
      INTEGER :: NREFA
      INTEGER :: NREFB
      REAL    :: FC
      REAL    :: FO
      REAL    :: ST
      REAL    :: VA
      REAL    :: FCS
      REAL    :: EPS
      REAL    :: AVA
      REAL    :: AVB
      REAL    :: SIGF
      REAL    :: SMDL
      REAL    :: SMFO
      REAL    :: F000
      REAL    :: AVOL
      REAL    :: ACAL
      REAL    :: BCAL
      REAL    :: BVOL
      REAL    :: VVOL
      REAL    :: YUNK
      REAL    :: ACALS
      REAL    :: BCALS
      REAL    :: DELTA
      REAL    :: FS000
      REAL    :: FSOLD
      REAL    :: SUMDL
      REAL    :: SUMFO
      REAL    :: SUMFC
      REAL    :: RFSOD
      REAL    :: DELRHO
C * PLA125 (MAIN SQUEEZE ROUTINE)
C *       - PLA292 (FILE OPEN .sqz FILE WITH DIFF. DENS. PEAKS)
C *       - PLA024 (GET CONNECTED COORDINATE SET)
C *       - PLA023 (LOAD AND EXPAND COORDINATE SET)
C *       - PLA133 (GET NUMBER OF REFLNS,H-,K-,LMAX)
C *               - PLA134 (HKL-READ /TRANS)
C *                       - PLA132 (GET REFL. DATA - FCF OR HKL)
C *       - PLA126 (REMAP GRID)
C *       - PLA130 (STORE REFLECTION DATA)
C *               - PLA136
C *               - PLA137
C *       - PLA142
C *               - PLA140
C *                       - PLA141
C *               - PLA143
C *       - PLA127 (GENERATE CIF-STRUCTURED VOID INFO)
C *               - PLA129
C *                       - PLA128
C *               - PLA139
C *
C * REFLECTION DATA STORAGE (INCLUDING '3D' POINTER ARRAY TO DATA)
C *
C * LAYOUT VOID ARRAY
C *
C *         NVDR I - TOP REFLECTION DATA POINTER ARRAY (HALF REFL. SPHERE)
C *              I
C *              I      INDEX TO THE DIFFERENCE MAP REFLECTION DATA STORAGE
C *              I
C *         IADR I - ADDRESS 0,0,0 Reflection Pointer
C *              I
C *              V
C *              I      (EMPTY)
C *--------------------------------------------------------------------
C *              ^
C *              I
C *         IR3D I - TOP R3D ARRAY (DENSITY MAP SECTIONS)
C *              I
C *              I      THREE R3D SECTIONS (3 * (M1 + 2) * (M2 + 2))
C *              I
C *         ITOP I - TOP FFT ARRAY
C *              I
C *              I      FFT ARRAY SIZE = NGRID * 2
C *              I
C * NREFA * NP69 I - TOP TOTAL REFLECTION DATA STORAGE
C *              I
C *              I      ENTRIES FOR MISSING REFLECTION DATA
C *              I
C * NREFB * NP69 I - TOP (SYMMETRY EXPANDED) REFLECTION DATA STORAGE
C *              I
C *              I      VOID(N +  1) - F(obs)
C *              I      VOID(N +  2) - SIG(F(obs))
C *              I      VOID(N +  3) - NON-SOLVENT ACAL
C *              I      VOID(N +  4) - NON-SOLVENT BCAL
C *              I      VOID(N +  5) - SOLVENT     ACALSOLVENT
C *              I                     (ACALS = ACAL + ACALSOLVENT)
C *              I      VOID(N +  6) - SOLVENT     BCALSOLVENT
C *              I                     (BCALS = BCAL + BCALSOLVENT)
C *              I      VOID(N +  7) - DIFF-MAP    ACAL
C *              I      VOID(N +  8) - DIFF-MAP    BCAL
C *              I      VOID(N +  9) - H
C *              I      VOID(N + 10) - K
C *              I      VOID(N + 11) - L
C *              I      VOID(N + 12) - ANOM-DISP   ACALA
C *              I      VOID(N + 13) - ANOM-DISP   ACALB
C *              I      VOID(N + 14) - SIN(THETA)/LAMBDA
C *              I      VOID(N + 15) - ASYMMETRIC REFL INFO
C *              I      VOID(N + 16) - SUM WEIGHTS AVERAGED REFLNS
C *              I
C *
C * SQUEEZE LISTING HEADER
      PAGET = 'SQUEEZE'
      CALL PLA262 (-2)
      WRITE (LU7, 99999, IOSTAT = IOST)
C * SQUEEZE GRAPHICS HEADER
      IF (IGBL(25) * IGBL(32) == 1 .AND. IGBL(3) /= 5) THEN
        IWIN = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.8
        WRITE (BCD, 99988, IOSTAT = IOST)
        CALL PLA439 (0.0, BCD, 80, 0.50, 5 + IGBL(68), 2, 1.0, VRT)
        WRITE (BCD, 99990, IOSTAT = IOST)
        VRT = VERT - 2.0
        CALL PLA439 (0.0, BCD, 80, 0.30, 5 + IGBL(68), 2, 0.1, VRT)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        VRT = VRT - 0.2
      ELSE
        IWIN = 0
      END IF
C * GET PREVIOUSLY DETERMINED CONNECTED COORDINATE SET
      CALL PLA024
C * LOAD AND EXPAND COORDINATE DATA TO UNIT CELL CONTENTS
C * (BUT EXCLUDING BRAVAIS CENTERING)
      CALL PLA023 (0)
C * CHECK FOR NON-ERROR RETURN  (POSITIVE = NUMBER OF ATOMS (NATO))
      IF (IPR(589) > 0) THEN
C * TOTAL NUMBER OF SYMMETRY OPERATIONS
        NSYM  = IPR(48)
C * GET NUMBER OF OPERATIONS EXCLUDING INVERSION AND BRAVAIS CENTERING
        NSYMH = IPR(255)
C * GET CENTER OF SYMMETRY NUMBER  [(1/2) ACENT/CENT]
        ICNTR = IPR(257)
        HMAX  = -999
        KMAX  = -999
        LMAX  = -999
        NREF  = 0
        NREFA = 0
        NREFB = 0
C * GET NR OF REFLECTIONS (SHELX(L) HKLF4 FORMAT OR FCF & HMAX, KMAX, LMAX
C * TWINNED DATA SHOULD HAVE BEEN DETWINNED USING A SHELXL/LIST 8 SHELXL JOB
C * REFLECTIONS ARE WRITTEN TO FILE LU27
        CALL PLA133 (NREF, HMAX, KMAX, LMAX)
C * CHECK FOR ERROR RETURN
        IF (IPR(2) <= 0) THEN
C * TRANSFORM SOLV GRID POINTS TO FFT SOLV GRID POINTS
          CALL PLA126
C * FFT GRID
          M1    = IPR(395)
          M2    = IPR(396)
          M3    = IPR(397)
          NGRID = M1 * M2 * M3
C * STORE REFLECTION DATA
          CALL PLA130 (HMAX, KMAX, LMAX, NREF, IADR, NREFA, NREFB)
C * CHECK FOR ERROR RETURN (NO SUITABLE REFLECTIONS)
          IF (NREFB > 0) THEN
C * OPEN UNIT #2 FOR SQUEEZED DIFFERENCE MAP PEAK LIST (_sq.sqz or _sqd.sqz)
            IGBL(31) = 10
            CALL PLA292
C * LOOP TO CONVERGENCE (MAXLOOP = IPR(142))
            NLPMX = IPR(142)
C * SET MODIFYABLE LOOP-MAXIMUM
            NLOPM = NLPMX
            FS000 = 0.0
            FSOLD = 0.0
            RFSOD = 999.0
            DO NLOOP = 1, NLPMX
C * EPS - FUDGE
              IF (NLOOP == 1) THEN
                EPS = 0.0
              ELSE IF (NLOOP == 2) THEN
                EPS = 3.0 - IPR(257)
              ELSE
                EPS = 1.0
              END IF
C * GET Fobs/Fcalc SCALING AND R-FACTOR
              SUMFO = 0.0
              SUMFC = 0.0
              SMFO  = 0.0
              N     = 0
              DO I = 1, NREFB
                ST       = VOID(N + 14)
                PAR(572) = MAX (PAR(572), ST)
C * EXCLUDE REFLECTIONS BELOW MINIMUM SIN(THETA)/LAMBDA
                IF (ST > PAR(290)) THEN
                  FO   = VOID(N + 1)
                  ACAL = VOID(N + 3)
                  BCAL = VOID(N + 4)
                  IF (EPS > 0.0) THEN
                    ACAL = ACAL + EPS * VOID(N + 5)
                    BCAL = BCAL + EPS * VOID(N + 6)
                  END IF
                  FC    = SQRT (ACAL**2 + BCAL**2)
                  SUMFO = SUMFO + FO
                  SUMFC = SUMFC + FC
                END IF
                N = N + NP69
              END DO
              PAR(566) = SUMFC / SUMFO
C * REPORT Fo/Fc SCALING DATA
              WRITE (LU6, 99991, IOSTAT = IOST) PAR(566), PAR(290)
              CALL PLA262 (3)
              WRITE (LU7, 99991, IOSTAT = IOST) PAR(566), PAR(290)
C * GENERATE DIFFERENCE FOURIER COEFFICIENTS
              SUMFO = SUMFO * PAR(566)
              SUMDL = 0.0
              SMFO  = 0.0
              SMDL  = 0.0
              M     = 0
C * (0/1) ADD DUMMY SOLVENT CONTRIBUTION FOR MISSING REFLECTIONS
              IF (IPR(681) == 1) THEN
                NREF = NREFA
              ELSE
                NREF = NREFB
              END IF
              WRITE (LU6, 99978) NREFB, NREFA - NREFB, NREFA, NREF
              NM = 0
              N  = 0
              DO I = 1, NREF
                FO   = VOID(N + 1) * PAR(566)
                SIGF = MAX (VOID(N + 2) * PAR(566), 0.0001)
C * F-CALC WITHOUT SOLVENT CONTRIBUTION
                ACAL = VOID(N + 3)
                BCAL = VOID(N + 4)
C * SOLVENT CONTRIBUTION
                AVA  = VOID(N + 5)
                AVB  = VOID(N + 6)
                IF (NLOOP > 1) THEN
                  IF (I > NREFB) THEN
                    IF (VOID(N + 14) <= PAR(486)) THEN
C * CHECK FOR ASYMMETRIC UNIT REFLECTION
                      IF (VOID(N + 15) > 0) THEN
                        NM = NM + 1
                        IF (NM == 1) THEN
                          WRITE (LU6, 99992) PAR(486)
                          WRITE (LU7, 99992) PAR(486)
                        END IF
                        IH = NINT (VOID(N +  9))
                        IK = NINT (VOID(N + 10))
                        IL = NINT (VOID(N + 11))
                        WRITE (LU6, 99989) IH, IK, IL, AVA, AVB
                        WRITE (LU7, 99989) IH, IK, IL, AVA, AVB
                      END IF
                    END IF
                  END IF
                END IF
C * F-CALC WITH SOLVENT CONTRIBUTION
                IF (EPS > 0.0) THEN
                  ACALS = ACAL + EPS * AVA
                  BCALS = BCAL + EPS * AVB
                ELSE
                  ACALS = ACAL
                  BCALS = BCAL
                END IF
                IF (I <= NREFB) THEN
                  FCS         = SQRT (ACALS**2 + BCALS**2)
                  DELTA       = ABS (FO - FCS)
                  VOID(N + 7) = FO * ACALS / FCS - ACAL
                  VOID(N + 8) = FO * BCALS / FCS - BCAL
                ELSE
                  VOID(N + 7) = AVA
                  VOID(N + 8) = AVB
                END IF
C * ZERO SOLVENT AREA CONTRIBUTION
                IF (NLOOP < NLOPM) THEN
                  VOID(N + 5) = 0.0
                  VOID(N + 6) = 0.0
                END IF
                IF (I <= NREFB) THEN
                  SUMDL = SUMDL + DELTA
                  IF (FO > 4.0 * SIGF) THEN
                    SMFO = SMFO + FO
                    SMDL = SMDL + DELTA
                    M    = M    + 1
                  END IF
                END IF
                N = N + NP69
              END DO
              RF    = SUMDL / SUMFO
              RFS   = SMDL  / SMFO
              NREFS = M
              WRITE (BCD, 99993, IOSTAT = IOST) NLOOP, RF, NREF, RFS,
     1          NREFS
              WRITE (LU6, 99986, IOSTAT = IOST) BCD
              CALL PLA262 (5)
              WRITE (LU7, 99986, IOSTAT = IOST) BCD
              IF (IWIN == 1) THEN
                WRITE (BCD, 99980, IOSTAT = IOST)
     1            NLOOP, RF, NREF, RFS, M, NINT (FS000)
                VRT = VRT - 0.50
                CALL PLA439 (0.0, BCD, 80, 0.35, 1, 2, 0.1, VRT)
                CALL GGIP (0.0, 0.0, 0.0, 6)
              END IF
              IF (NLOOP < NLOPM) THEN
                CALL GEN108 (LU15, 0)
                DO I = 1, 2
                  DO J = 1, NP41
                    SXYZ(I, J) = 0.0
                  END DO
                END DO
                NV = 0
C * FFT
                IBOT = NREFA * NP69
                ITOP = IBOT + NGRID * 2
C * CHECK FOR SCRATCH OVERRUN (FFT + R3D)
                IR3D = ITOP + 3 * (M1 + 2) * (M2 + 2)
                IF (IR3D >= IADR) THEN
                  WRITE (LU6, 99996, IOSTAT = IOST) 2, CHAR(IPR(223))
                  WRITE (LU7, 99996, IOSTAT = IOST) 2, CHAR(IPR(223))
                  RETURN
                END IF
C * SQUEEZE MODE ? (i.e. ELECTRON COUNT OR FFT_F000
                IF (IPR(304) == 0) THEN
                  F000 = PAR(149)
                ELSE IF (IPR(304) == 1) THEN
                  F000 = PAR(539)
                END IF
C * FFT & PEAKSEARCH
                CALL PLA142 (-1, VOID(1), VOID(IBOT + 1), VOID(ITOP + 1)
     1            , NREF, F000)
C * REPORT TOTAL ELECTRON COUNT IN (FO-FC)-MAP
                IF (NLOOP > 1) THEN
                  VA = 0
                  DO I = IBOT + 1, ITOP, 2
                    VA = VA + VOID(I)
                  END DO
                  PAR(353) = VA / NGRID
                END IF
C * READ .sav FILE
                CALL GEN108 (LU9, 0)
C * GET LOCATION AND NUMBER OF VOIDMAP GRIDPOINT
                DO
                  READ (LU15, IOSTAT = IOST) ILOC, NVOID
                  IF (IOST /= 0) EXIT
                  LOC    = IBOT + ILOC
C * GET REAL-PART DIFFERENCE MAP DENSITY
                  DELRHO = VOID(LOC - 1) / NGRID
C * REMOVE DENSITY ON SOLVENT SITE
                  VOID(LOC - 1) = 0.0
                  VOID(LOC)     = 0.0
                  WRITE (LU9) LOC, DELRHO
                  SXYZ(1, NVOID) = SXYZ(1, NVOID) + 1
                  SXYZ(2, NVOID) = SXYZ(2, NVOID) + DELRHO
                  NV = MAX (NV, NVOID)
                END DO
                FS000 = 0
                WRITE (PRBUF, 99995, IOSTAT = IOST)
                WRITE (LU6, 99987, IOSTAT = IOST) PRBUF(1:80)
                CALL PLA262 (3)
                WRITE (LU7, 99987, IOSTAT = IOST) PRBUF(1:80)
                PAR(525) = 0.0
                PAR(526) = 0.0
                DO I = 1, NV
                  VVOL = SXYZ(1, I) * PAR(79)
                  AVOL = 0.0
                  BVOL = 0.0
                  YUNK = SXYZ(2, I)
                  IF (VVOL > PAR(525)) THEN
                    PAR(525) = VVOL
                    PAR(526) = YUNK
                  END IF
                  IF (YUNK > 0.0) THEN
                    FS000 = FS000 + YUNK
                    AVOL  = VVOL  / (YUNK / 8)
                    BVOL  = VVOL  / YUNK
                  END IF
                  PAR(354) = FS000
                  WRITE (PRBUF, 99984, IOSTAT = IOST)
     1              I, (SXYZ(J, I), J = 10, 12),
     2              NINT (VVOL), NINT (YUNK), BVOL, NINT (AVOL)
                  WRITE (LU6, 99981, IOSTAT = IOST) PRBUF(1:80)
                  CALL PLA262 (1)
                  WRITE (LU7, 99981, IOSTAT = IOST) PRBUF(1:80)
                END DO
                PAR(149) = FS000
                IF (NLOOP > 1) THEN
                  WRITE (LU6, 99985, IOSTAT = IOST) NINT (PAR(353))
                  CALL PLA262 (2)
                  WRITE (LU7, 99985, IOSTAT = IOST) NINT (PAR(353))
                END IF
                WRITE (TXT1(1), 99994, IOSTAT = IOST) NINT (PAR(354))
                WRITE (LU6, 99982, IOSTAT = IOST) TXT1(1)
                CALL PLA262 (2)
                WRITE (LU7, 99982, IOSTAT = IOST) TXT1(1)
C * ELECTRON COUNT OUTSIDE VOIDS
                PAR(355) = 0.0
                DO I = IBOT + 1, ITOP, 2
                  PAR(355)    = PAR(355) + VOID(I) / NGRID
                  VOID(I)     = 0.0
                  VOID(I + 1) = 0.0
                END DO
                WRITE (TXT1(1), 99998, IOSTAT = IOST) NINT (PAR(355))
                WRITE (LU6, 99982, IOSTAT = IOST) TXT1(1)
                CALL PLA262 (2)
                WRITE (LU7, 99982, IOSTAT = IOST) TXT1(1)
C * CALCULATE SOLVENT AREA CONTRIBUTION TO STRUCTURE FACTORS
                CALL GEN108 (LU9, 0)
                DRHOMN =  99999.0
                DRHOMX = -99999.0
                DO
                  READ (LU9, IOSTAT = IOST) LOC, DELRHO
                  IF (IOST /= 0) EXIT
                  DRHOMN = MIN (DRHOMN, DELRHO)
                  DRHOMX = MAX (DRHOMX, DELRHO)
                  IF (DELRHO > PAR(285)) VOID(LOC - 1) = DELRHO
                END DO
                DRHOMX = DRHOMX * NGRID / PAR(98)
                DRHOMN = DRHOMN * NGRID / PAR(98)
                WRITE (LU6, 99983, IOSTAT = IOST) DRHOMN, DRHOMX,
     1            PAR(285), PAR(329), PAR(330), PAR(269)
                CALL PLA262 (3)
                WRITE (LU7, 99983, IOSTAT = IOST) DRHOMN, DRHOMX,
     1            PAR(285), PAR(329), PAR(330), PAR(269)
C * DO FOURIER TRANSFORMATION (DIRECT TO RECIPROCAL)
                CALL GEN028 (VOID(IBOT + 1), IPR(395), 3, 1)
C * SAVE FFT-F000
                PAR(539) = VOID(IBOT + 1)
                WRITE (LU6, 99979) PAR(539)
                DO I = 1, NREFA
                  N  = (I - 1) * NP69
                  IH = NINT (VOID(N +  9))
                  IK = NINT (VOID(N + 10))
                  IL = NINT (VOID(N + 11))
                  IF (IH < 0) IH = IH + M1
                  IF (IK < 0) IK = IK + M2
                  IF (IL < 0) IL = IL + M3
                  LOC = IBOT + 2 * ((IL * M2 + IK) * M1 + IH + 1)
                  VOID(N + 5) = VOID(LOC - 1)
                  IF (ICNTR == 1) THEN
                    VOID(N + 6) = VOID(LOC)
                  ELSE
                    VOID(N + 6) = 0.0
                  END IF
                END DO
C * CHECK FOR ITERATION STOP CRITERIUM
                IF (ABS (ABS (FS000) - ABS (FSOLD)) < PAR(250) * NSYM
     1            .AND. FS000 > 1.0 .AND. RFSOD - RFS < PAR(249)) THEN
                  NLOPM = NLOOP + 1
                ELSE
                  FSOLD = FS000
                  RFSOD = RFS
                END IF
              ELSE
                IF (IWIN == 1) THEN
                  VRT = VERT - 2.0
                  WRITE (PRBUF, 99976)
                  CALL PLA439 (0.0, PRBUF, 34, 0.30, 5 + IGBL(68), 2,
     1              17.0, VRT)
                  VRT = VRT - 0.2
                  DO I = 1, NV
                    WRITE (PRBUF, 99977) I, (SXYZ(J, I), J = 10, 12),
     1                NINT (SXYZ(1, I) * PAR(79)), NINT (SXYZ(2, I))
                    VRT = VRT - 0.5
                    CALL PLA439 (0.0, PRBUF, 34, 0.30, 1, 2, 17.0, VRT)
                  END DO
                  VRT = 3.0
                  WRITE (PRBUF, 99975) NINT (PAR(353))
                  CALL PLA439 (0.0, PRBUF, 80, 0.30, 1, 2, 0.1, VRT)
                  VRT = VRT - 0.5
                  WRITE (PRBUF, 99974) NINT (PAR(354))
                  CALL PLA439 (0.0, PRBUF, 80, 0.30, 1, 2, 0.1, VRT)
                  VRT = VRT - 0.5
                  WRITE (PRBUF, 99973) NINT (PAR(355))
                  CALL PLA439 (0.0, PRBUF, 80, 0.30, 1, 2, 0.1, VRT)
                  VRT = VRT - 0.7
                  WRITE (PRBUF, 99972, IOSTAT = IOST) DRHOMN, DRHOMX,
     1            PAR(285)
                  CALL PLA439 (0.0, PRBUF, 80, 0.30, 1, 2, 0.1, VRT)
                  VRT = VRT - 0.5
                  WRITE (PRBUF, 99971, IOSTAT = IOST)
     1            PAR(329), PAR(330), PAR(269)
                  CALL PLA439 (0.0, PRBUF, 80, 0.30, 1, 2, 0.1, VRT)
                END IF
C * REPORT, WRITE FILES, TERMINATE
                CALL PLA127 (IADR, NREFA, NV)
                RETURN
              END IF
            END DO
C * SET RETURN SUBMENU NUMBER
            IGBL(6) = 10
          ELSE
            WRITE (LU6, 99997, IOSTAT = IOST)
          END IF
        END IF
      ELSE
        IPR(1) = 1
      END IF
      RETURN
99999 FORMAT ('SQUEEZE - Procedure (A.L.Spek (2015). Acta Cryst. C71',
     1 ', 9-18)', /, 132('='))
99998 FORMAT (':: Total (Fo-Fc)map Electron Count Outside Voids =', I9)
99997 FORMAT (/, 'F: No Suitable Reflections Found', /)
99996 FORMAT (/, 'F: Scratch Array Overrun Code', I2, ' (Fatal)', /,
     1        '    Use larger program version i.e. larger NVDR', A, /)
99995 FORMAT ('Void  X(av) Y(av) Z(av) Volume Ang^3 El-Count (e-)',
     1        ' Vol/Electron Vol/Atom')
99994 FORMAT (':: Total (Fo-Fc)map Electron Count in Voids/Cell =', I9)
99993 FORMAT (':: Cycle =', I3, ', R(F) =', F5.2, ', Nref(Hemi) =',
     1        I6, ', R(F > 4SIGF) =', F5.2, ' Nref =', I6)
99992 FORMAT (':: Missing Reflections Below sin(theta)/lambda =', F5.2,
     1  /, 4X, 'H', 4X, 'K', 4X, 'L', 5X,  'ASOLV', 5X, 'BSOLV')
99991 FORMAT (/, ':: Fo-Scale =', E14.6, ' - SinT/L-Min =', F5.2,
     1        ' for Fo/Fc-Scaling', /)
99990 FORMAT ('Cycle   R(F)   Nref(Hemi)  R(F)>4*sig(F)   Nref',
     1        ' El(Solv)/Cell')
99989 FORMAT (3I5, 2F10.2)
99988 FORMAT (24X, 'PLATON/SQUEEZE ')
99987 FORMAT (A, /, 80('='))
99986 FORMAT (/, A, /)
99985 FORMAT (/, ':: Total (Fo-Fc)map Electron Count in  Unit Cell =',
     1        I9)
99984 FORMAT (I4, 1X, 3F6.3, 3X, I10, I9, 8X, F10.1, I9)
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 (/, A)
99981 FORMAT (A)
99980 FORMAT (I3, F8.3, I10, F9.3, I10, I9)
99979 FORMAT (/, ':: FFT-F000 = ', F10.2)
99978 FORMAT (/, ':: NREFB - SYMMETRY EXPANDED  REFL. SET:', I10,
     1        /, ':: NREFC - ADDED MISSING REFLECTION SET:', I10,
     2        /, ':: NREFA - TOTAL NUMBER IN HEMISPHERE  :', I10,
     3        /, ':: NREF  - USED NUMBER OF REFLECTIONS  :', I10, /)
99977 FORMAT (I3, 3F7.3, 2I5)
99976 FORMAT ('sav  x(av)  y(av)  z(av)  vol   e-')
99975 FORMAT ('Total (Fo-Fc)map Electron Count in  Unit Cell =', I9)
99974 FORMAT ('Total (Fo-Fc)map Electron Count in Voids/Cell =', I9)
99973 FORMAT ('Total (Fo-Fc)map Electron Count Outside Voids =', I9)
99972 FORMAT ('VOID-Fo-Fc-Map:    Rho(min) =', F10.2,
     1        ', Rho(max) =', F10.2, ', RhoCutOff =', F6.2)
99971 FORMAT ('PeaksCloseToAtoms: Rho(min) =', F10.2, ', Rho(max) =',
     1        F10.2, ', RhoCutOff =', F6.2)
      END SUBROUTINE PLA125
 
      SUBROUTINE PLA126
C * REMAP SAV-FILE GRID TO FFT 2**N GRID (ROUTINE SCRATCHES IN VOID)
      USE files
      USE parameters
      USE squeeze
      USE vscr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: M3
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IZ
      INTEGER :: LU
      INTEGER :: JX
      INTEGER :: JY
      INTEGER :: JZ
      INTEGER :: LOC
      INTEGER :: NGRID
      INTEGER :: NLOCS
      INTEGER :: NLOCF
C * INIT SAV-GRID
      CALL GEN074 (VOID, 1, NTGRD, 0.0)
C * LOAD SOLV GRID IN VOID ARRAY FROM FILE LU15
      CALL GEN108 (LU15, 0)
      NLOCS = 0
      DO
        READ (LU15, IOSTAT = IOST)  IX, IY, IZ, N
        IF (IOST /= 0) EXIT
        VOID(IX * N23 + IY * N3 + IZ + 1) = N
        NLOCS                             = NLOCS + 1
      END DO
      CALL GEN108 (LU15, 0)
C * GET SUITABLE FFT-GRID AS A POWER OF 2
      DO I = 1, 3
        DO J = 4, 8
          IPR(394 + I) = 2**J
          IF (PAR(100 + I) * 3.0 < IPR(394 + I)) EXIT
        END DO
      END DO
      IF (IPR(395) < 2 * HMAX + 1) IPR(395) = IPR(395) * 2
      IF (IPR(396) < 2 * KMAX + 1) IPR(396) = IPR(396) * 2
      IF (IPR(397) < 2 * LMAX + 1) IPR(397) = IPR(397) * 2
      M1      = IPR(395)
      M2      = IPR(396)
      M3      = IPR(397)
      NGRID   = M1 * M2 * M3
      PAR(79) = PAR(98) / NGRID
      NLOCF   = 0
C * MAP SOLV GRID ON FFT GRID
      DO I = 0, M1 - 1
        JX = NINT (FLOAT (I) * N1 / FLOAT (M1)) * N23
        DO J = 0, M2 - 1
          JY = NINT (FLOAT (J) * N2 / FLOAT (M2)) * N3
          DO K = 0, M3 - 1
            JZ = NINT (FLOAT (K) * N3 / FLOAT (M3))
            N = NINT(VOID(JX + JY + JZ + 1))
            IF (N /= 0) THEN
              LOC = 2 * ((K * M2 + J) * M1 + I + 1)
              WRITE (LU15) LOC, N
              NLOCF = NLOCF + 1
            END IF
          END DO
        END DO
      END DO
C * REPORT GRID REMAPPING STATISTICS
      DO I = 1, 2
        IF (I == 1) THEN
          LU = LU6
        ELSE
          LU = LU7
          CALL PLA262 (5)
        END IF
        WRITE (LU, 99999, IOSTAT = IOST)
     1    (PAR(100 + J), J = 1, 3), N1, N2, N3, NLOCS, M1, M2, M3,
     2    NLOCF, PAR(101) / M1, PAR(102) / M2, PAR(103) / M3
      END DO
      RETURN
99999 FORMAT (/, ':: A,  B,  C  (Angstrom) = ', 3F8.3, /,
     1 ':: NX, NY, NZ (SOLV-MAP) = ', 3I8, ' - SAV-GridPoints =', I8,/,
     2 ':: NX, NY, NZ (FFT-MAP)  = ', 3I8, ' - SAV-GridPoints =', I8,/,
     3 ':: Resolution (FFT-MAP)  = ', 3F8.2, ' Angstrom')
      END SUBROUTINE PLA126
 
      MODULE pl127
      SAVE
      INTEGER               :: IOBS
      INTEGER               :: NDEC
      INTEGER               :: IEND
      INTEGER               :: ISKIP
      INTEGER               :: ITSKP
      INTEGER               :: ICALC
      INTEGER               :: UNITMAT
      REAL                  :: SHXMP
      REAL                  :: STHKM
      REAL                  :: ABSCOR
      REAL, DIMENSION(3, 3) :: TRMX
      END MODULE pl127
 
      SUBROUTINE PLA127 (IADR, NREFA, NV)
C * GENERATE FAB-FILE AND CIF-STRUCTURED VOID INFO
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cif
      USE reflex
      USE squeeze
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: NV
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: JH
      INTEGER :: JK
      INTEGER :: JL
      INTEGER :: IHT
      INTEGER :: IKT
      INTEGER :: ILT
      INTEGER :: ILS
      INTEGER :: IXI
      INTEGER :: NXI
      INTEGER :: ISGN
      INTEGER :: IHKL
      INTEGER :: IADR
      INTEGER :: NMIN
      INTEGER :: NPRT
      INTEGER :: ISIGI
      INTEGER :: IWGHT
      INTEGER :: NREFA
      INTEGER :: IABIN
      INTEGER :: IACTA
      INTEGER :: ITWMT
      INTEGER :: NEXTRA
      REAL    :: FO
      REAL    :: ST
      REAL    :: XI
      REAL    :: FOA
      REAL    :: FOB
      REAL    :: FCM
      REAL    :: FCS
      REAL    :: XXI
      REAL    :: DEL1
      REAL    :: DEL2
      REAL    :: DELS
      REAL    :: DUM1
      REAL    :: DUM2
      REAL    :: DUM3
      REAL    :: PFCS
      REAL    :: PFCM
      REAL    :: PFCT
      REAL    :: SIGI
      REAL    :: XNXI
      REAL    :: SIGIW
      REAL    :: SCLI8
      REAL    :: FCALT
      REAL    :: ACALM
      REAL    :: ACALS
      REAL    :: ACALT
      REAL    :: BCALM
      REAL    :: BCALS
      REAL    :: BCALT
      REAL    :: X8MAX
      REAL    :: XSIGI
      REAL    :: GEN095
C * OPEN FILE TO RECEIVE SQUEEZE RESULTS IN CIF FORMAT
      IF (IPR(663) == 0) THEN
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sqd.sqf',
     1    STATUS = 'UNKNOWN')
      ELSE
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sq.sqf',
     1    STATUS = 'UNKNOWN')
      END IF
      WRITE (LU61, 99999, IOSTAT = IOST) IGBL(4),
     1  (CIFDIR(I), I = 503, 509)
      DO I = 1, NV
        WRITE (LU61, 99993, IOSTAT = IOST)
     1    I, SXYZ(10, I), SXYZ(11, I), SXYZ(12, I),
     2    NINT (SXYZ(1,  I) * PAR(79)), NINT (SXYZ(2, I)), ''' '''
      END DO
      WRITE (LU61, 99990, IOSTAT = IOST) CIFDIR(639), PAR(84)
      WRITE (LU61, 99988, IOSTAT = IOST) CIFDIR(510)
      CLOSE (UNIT = LU61)
C * COPY .res to _sqd.ins
C * TEST FOR CIF BASED INPUT
      IF (IABS(IGBL(8)) == 3) THEN
        CLOSE (UNIT = LU1)
        IF (IPR(663) < 0) THEN
          REWIND  (UNIT = LU24, IOSTAT = IOST)
          OPEN (LU1, FILE = NAMEFIL(1:KNMFIL)//'.dum',
     1      STATUS = 'UNKNOWN')
          DO
            READ  (LU24, 99989, IOSTAT = IOST) IDM
              IF (IOST /= 0) EXIT
            WRITE (LU1,  99989, IOSTAT = IOST) IDM
          END DO
          REWIND (UNIT = LU1, IOSTAT = IOST)
          EXST = .TRUE.
        ELSE
          INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.res', EXIST = EXST)
          IF (EXST) OPEN (LU1, FILE = NAMEFIL(1:KNMFIL)//'.res',
     1      STATUS = 'UNKNOWN')
        END IF
C * TEST FOR RES INPUT CASE
      ELSE IF (IABS(IGBL(8)) == 2) THEN
        EXST = .TRUE.
      ELSE
        EXST = .FALSE.
      END IF
      IF (EXST) THEN
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sqd.ins',
     1    STATUS = 'UNKNOWN')
        OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.ins',
     1    STATUS = 'UNKNOWN')
        REWIND (UNIT = LU1, IOSTAT = IOST)
        NEXTRA = NINT ((PAR(149) * 9) / (IPR(48) * 8))
        IABIN = 0
        IACTA = 0
        ILS   = 0
        IWGHT = 0
        ITWMT = 0
C * PREPARE _sq.ins FILE
        DO
          READ  (LU1,  99989, IOSTAT = IOST) IDM
          IF (IOST /= 0) EXIT
          CALL GEN020 (1, IDM, 1, 4)
          IF (IDM(1:4) == 'WGHT') THEN
            IWGHT = 1
            WRITE (LU62, 99985, IOSTAT = IOST)
            IABIN = 1
C * HANDLE BASF/TWIN CASE
          ELSE IF (IDM(1:4) == 'TWIN') THEN
            READ (IDM(5:80), *, IOSTAT = IOST)
     1        ((RMAT(I, J), J = 1, 3), I = 1, 3), ITWMT
            IF (IOST /= 0) THEN
              READ (IDM(5:80), *, IOSTAT = IOST)
     1          ((RMAT(I, J), J = 1, 3), I = 1, 3)
              IF (IOST == 0) ITWMT = 2
            END IF
            IF (IOST == 0 .AND. ITWMT > 0) WRITE (LU6, 99980) ITWMT,
     1        ((RMAT(I, J), J = 1, 3), I = 1, 3)
          ELSE IF (IDM(1:4) == 'ABIN') THEN
            CYCLE
          ELSE IF (IDM(1:4) == 'ACTA') THEN
            IACTA = 1
C * REMOVE LIST INSTRUCTION WHEN ENCOUNTERED
          ELSE IF (IDM(1:4) == 'LIST') THEN
            CYCLE
          ELSE IF (IDM(1:4) == 'L.S.') THEN
            WRITE (IDM, 99984) NEXTRA
            ILS = 1
          ELSE IF (IDM(1:4) == 'FVAR') THEN
            IF (ILS == 0) THEN
              WRITE (LU62, 99982, IOSTAT = IOST) NEXTRA
              ILS = 1
            END IF
            IF (IACTA == 0) THEN
              WRITE (LU61, 99985, IOSTAT = IOST)
              WRITE (LU62, 99983, IOSTAT = IOST)
              IACTA = 1
            END IF
            IF (IABIN == 0) THEN
              WRITE (LU61, 99985, IOSTAT = IOST)
              WRITE (LU62, 99985, IOSTAT = IOST)
              IABIN = 1
            END IF
            IF (IWGHT == 0) THEN
              WRITE (LU61, 99981, IOSTAT = IOST)
              WRITE (LU62, 99981, IOSTAT = IOST)
              IWGHT = 1
            END IF
          END IF
          WRITE (LU61, 99989, IOSTAT = IOST) IDM
          WRITE (LU62, 99989, IOSTAT = IOST) IDM
        END DO
C * CHECK FOR SHELXL21x - EMBEDDED RES
        IF (IPR(663) /= 0) THEN
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU1,  STATUS = 'DELETE')
        ELSE
          CLOSE (UNIT = LU61)
        END IF
        CLOSE (UNIT = LU62)
      END IF
C * CHECK FOR (EMBEDDED) SHELXL201n HKL
      IF (IPR(664) == 0) THEN
        REWIND (UNIT = LU16, IOSTAT = IOST)
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sq.hkl',
     1    STATUS = 'UNKNOWN')
C * TEST FOR SHELXL LIST 4 FCF
        IF (IGBL(9) == 1) THEN
          CALL PLA139 (LU6, LU16, LU61, IPR(384))
        ELSE
          DO
            READ  (LU16, 99989, IOSTAT = IOST) IDM
            IF (IOST /= 0) EXIT
            WRITE (LU61, 99989, IOSTAT = IOST) IDM
          END DO
        END IF
C * CHECK FOR (EMBEDDED) SHELXL201n HKL
      ELSE IF (IPR(664) == -1) THEN
        REWIND (UNIT = LU25, IOSTAT = IOST)
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sq.hkl',
     1    STATUS = 'UNKNOWN')
        DO
          READ  (LU25, 99989, IOSTAT = IOST) IDM
          IF (IOST /= 0) EXIT
          WRITE (LU61, 99989, IOSTAT = IOST) IDM
        END DO
      END IF
      CLOSE (UNIT = LU61)
C * GENERATE '_sqd.hkl' FILE FOR SHELXL97 AND CRYSTALS
      OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sqd.hkl',
     1  STATUS = 'UNKNOWN')
      DO I = 1, 20
        DO J = 1, 9
          STAT(I, J) = 0.0
        END DO
      END DO
      X8MAX = 0
      SCLI8 = 1.0
C * DOUBLE LOOP FOR SCALING TO SHELXL FORMAT
      DO K = 1, 2
        IF (K == 2) THEN
          IF (X8MAX > 0.99999E8) SCLI8 = 0.99999E8 / X8MAX
        END IF
        NPRT = 0
        IEND = -1
C * TRANSFORM REFLECTIONS FOR SF-CALCULATION (EXCLUDE NON-INTEGRAL H,K,L)
        DO
          CALL PLA134 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI,
     1      SIGIW, DUM1, DUM2, DUM3)
          IF (IEND > 0) EXIT
          IF (IGBL(9) == -1) XI = DUM1
          XSIGI = SCLI8 * SIGI
          IHKL  = ILT * MHK + IKT * MPH + IHT
          IF (IHKL > 0) THEN
            ISGN = 1
          ELSE
            ISGN = -1
            IHKL = - IHKL
          END IF
          N = NP69 * (NINT (VOID(IADR + IHKL)) - 1)
          IF (N >= 0) THEN
C * TEST FOR SHELXL STYLE FCF
            IF (IGBL(9) == 1) THEN
              XI    = XI    * 0.01
              XSIGI = XSIGI * 0.01
            END IF
            FO    = SQRT (MAX (0.0, XI)) * PAR(566)
            ACALM = VOID(N + 3)        + VOID(N + 12)
            BCALM = VOID(N + 4) * ISGN + VOID(N + 13)
            ACALS = VOID(N + 5)
            BCALS = VOID(N + 6) * ISGN
            ACALT = ACALS + ACALM
            BCALT = BCALS + BCALM
            FCALT = SQRT(ACALT**2 + BCALT**2)
C * CALCULATE CORRECTED FO BY SUBSTRACTING THE SOLVENT CONTRIBUTION
            FOA   = (FO * ACALT / FCALT - ACALS) / PAR(566)
            FOB   = (FO * BCALT / FCALT - BCALS) / PAR(566)
            XXI   = SCLI8 * (FOA**2 + FOB**2)
            XNXI  = SCLI8 * XI
            IF (K == 1) THEN
              X8MAX = MAX (X8MAX, XXI)
              X8MAX = MAX (X8MAX, XSIGI)
              X8MAX = MAX (X8MAX, XNXI)
            ELSE
              IXI   = NINT (XXI)
              ISIGI = NINT (XSIGI)
              NXI   = NINT (XNXI)
C * WRITE SOLVENT CONTRIBUTION FREE HKL WITH/WITHOUT DIRECTION COSINES
              IF (IGBL(37) /= 0) THEN
                WRITE (LU61, 99996, IOSTAT = IOST) IH, IK, IL, IXI,
     1            ISIGI, (V2(I), V3(I), I = 1, 3), NXI, ACALS, BCALS,
     2            1.0
              ELSE
                WRITE (LU61, 99995, IOSTAT = IOST)
     1            IH, IK, IL, IXI, ISIGI, NXI, ACALS, BCALS, 1.0
              END IF
              ST   = VOID(N + 14)
              FCS  = SQRT (ACALS**2 + BCALS**2)
              FCM  = SQRT (ACALM**2 + BCALM**2)
              PFCS = 0.0
              PFCM = 0.0
              PFCT = 0.0
              IF (ACALS /= 0.0 .OR. BCALS /= 0.0)
     1          PFCS = ATAN2 (BCALS, ACALS) * RGBL(6)
              IF (ACALM /= 0.0 .OR. BCALM /= 0.0)
     1          PFCM = ATAN2 (BCALM, ACALM) * RGBL(6)
              IF (ACALT /= 0.0 .OR. BCALT /= 0.0)
     1          PFCT = ATAN2 (BCALT, ACALT) * RGBL(6)
              DEL1 = MOD (PFCM + 360.0 - PFCS, 360.0)
              IF (DEL1 > 180.0) DEL1 = 360.0 - DEL1
              DEL2  = MOD (PFCM + 360.0 - PFCT, 360.0)
              IF (DEL2 > 180.0) DEL2 = 360.0 - DEL2
              IF (SIGI > 0.0) THEN
                DELS = ABS (FO**2 - FCALT**2) / (PAR(566)**2 * SIGI)
                IF (ST <= PAR(286) .AND. DELS > PAR(288)) THEN
                  NPRT = NPRT + 1
                  IF (NPRT == 1) THEN
                    CALL PLA262 (-2)
                    WRITE (LU7, 99997, IOSTAT = IOST)
                  END IF
                  CALL PLA262 (1)
                  WRITE (LU7, 99994, IOSTAT = IOST)
     1              IH, IK, IL, ST, FO, FCM, FCS,
     2              FCALT, DELS, XI * PAR(566)**2, SIGI * PAR(566)**2
                END IF
              END IF
              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)
            END IF
          END IF
        END DO
      END DO
      IF (IPR(664) /= 0) CLOSE (LU61, STATUS = 'DELETE')
C * GENERATE '.fab' FILE FOR SHELXL201n: H, K, L, ASOLV, BSOLV
C * ASYMMETRIC UNIT, INCLUDING MISSING REFLECTION CONTRIBUTIONS
      OPEN (LU65, FILE = NAMEFIL(1:KNMFIL)//'_sq.fab',
     1  STATUS = 'UNKNOWN')
      K = 0
      DO I = 1, NREFA
C * CHECK FOR ASYMMETRIC REFLECTION UNIT REFLECTION
        N = (I - 1) * NP69
        IF (NINT(VOID(N + 15)) > 0) THEN
          V1(1) = VOID(N +  9)
          V1(2) = VOID(N + 10)
          V1(3) = VOID(N + 11)
          ACALS = VOID(N + 5)
          IF (ICNTR == 1) THEN
            BCALS = VOID(N + 6)
          ELSE
             BCALS = 0.0
          END IF
          WRITE (LU65, 99992, IOSTAT = IOST)
     1      (NINT(V1(J)), J = 1, 3), ACALS, BCALS
C * ADD DUMMY OUT-OF-RESOLUTION TWIN COMPONENT REFLECTIONS TO FAB
          IF (ITWMT == 2) THEN
            K = K + 1
            IF (K == 1) WRITE (LU6, 99978)
            IH   = NINT(V1(1))
            IK   = NINT(V1(2))
            IL   = NINT(V1(3))
            DUM1 = ASIN (VOID(N + 14) * PAR(17)) * RGBL(6)
            CALL GEN002 (1, RMAT, V1, V2, DUM3)
            JH   = NINT(V2(1))
            JK   = NINT(V2(2))
            JL   = NINT(V2(3))
            DUM3 = SQRT (GEN095 (PAR(191), JH, JK, JL))
            DUM2 = ASIN (DUM3 * PAR(17)) * RGBL(6)
            IF (VOID(N + 14) <= PAR(572) .AND. DUM3 > PAR(572)) THEN
              WRITE (LU65, 99992, IOSTAT = IOST) JH, JK, JL, 0.0, 0.0
              WRITE (LU6, 99979) IH, IK, IL, DUM1, JH, JK, JL, DUM2
            END IF
          END IF
        END IF
      END DO
C * ADD TERMINATING DUMMY REFLECTION
      WRITE (LU65, 99992, IOSTAT = IOST) 0, 0, 0, 0.0, 0.0
C * COPY SQF & SQZ INFO AT THE END OF THE FAB FILE
C * HEADER LOOP FOR .SQF
      WRITE (LU65, 99999, IOSTAT = IOST) IGBL(4),
     1  (CIFDIR(I), I = 503, 509)
      DO I = 1, NV
        WRITE (LU65, 99993, IOSTAT = IOST)
     1    I, SXYZ(10, I), SXYZ(11, I), SXYZ(12, I),
     2    NINT (SXYZ(1,  I) * PAR(79)), NINT (SXYZ(2,  I)), ''' '''
      END DO
C * HEADER LOOP FOR MISSING (LOW ANGLE) REFLECTIONS
      IF (IPR(610) > 0) THEN
        WRITE (LU65, 99998, IOSTAT = IOST) PAR(486),
     1    (CIFDIR(I), I = 642, 645)
        NMIN = MIN (IPR(610), NP60)
        DO I = 1, NMIN
          WRITE (LU65, 99991) (MISSING(J, I), J = 1, 3),
     1      FLOAT (MISSING(4, I)) / 1000.0
        END DO
      END IF
      WRITE (LU65, 99990, IOSTAT = IOST) CIFDIR(639), PAR(84)
      WRITE (LU65, 99987, IOSTAT = IOST) CIFDIR(510)
      REWIND (UNIT = LU2, IOSTAT = IOST)
C * COPY .SQZ DATA
      DO
        READ (LU2, 99989, IOSTAT = IOST) IDM
        IF (IOST /= 0) EXIT
        WRITE (LU65, 99989, IOSTAT = IOST) IDM
      END DO
      WRITE (LU65, 99986)
C * REPORT SQUEEZE RESULT
      CALL PLA129
C * REMOVE DUMMY FILES
      CLOSE (UNIT = LU17, STATUS = 'DELETE', IOSTAT = IOST)
      CLOSE (UNIT = LU13, STATUS = 'DELETE', IOSTAT = IOST)
      RETURN
99999 FORMAT ('# SQUEEZE RESULTS (Version =', I7, ')', /,
     1        '# Note: Data are Listed for all Voids in the P1 Unit',
     2        ' Cell', /,
     3        '# i.e. Centre of Gravity, Solvent Accessible Volume,', /,
     4        '# Recovered number of Electrons in the Void and', /,
     5        '# Details about the Squeezed Material', /,
     6        'loop_', 7(/, 2X, A))
99998 FORMAT ('# Missing Reflections Below sin(th)/lambda =', F5.2, /,
     1        'loop_', 4(/, 2X, A))
99997 FORMAT ('  H  K  L  Sinth/l F(obs)  F(mod) F(solv)  ',
     1        'F(tot) D(F^2)/S       I       Sig(I)', /)
99996 FORMAT (3I4, 2I8, 4X, 6F8.5, I8, 2F8.2, F8.4)
99995 FORMAT (3I4, 2I8, 52X, I8, 2F8.2, F8.4)
99994 FORMAT (3I3, 6F8.2, F12.2, F10.2)
99993 FORMAT (I4, 3(F7.3), 2I10, 1X, A)
99992 FORMAT (3I5, 2F10.2)
99991 FORMAT (3I5, F10.3)
99990 FORMAT (A, F6.2)
99989 FORMAT (A)
99988 FORMAT (A, ' ?')
99987 FORMAT (A, /, ';')
99986 FORMAT (';')
99985 FORMAT ('ABIN')
99984 FORMAT ('L.S. 5 0', I5)
99983 FORMAT ('ACTA')
99982 FORMAT ('L.S. 5', I5)
99981 FORMAT ('WGHT 0.1')
99980 FORMAT (':: Twin Matrix (', I1, ') from Embedded RES file',
     1       3(/, 3F8.3))
99979 FORMAT (3I5, F10.2, 3I5, F10.2)
99978 FORMAT (/, 'Listing of added component(2) reflections to FAB ',
     1       'file beyond Theta(max)', //,
     2       3X, 'Component(1)  Theta(1)   Component(2)  Theta(2)')
      END SUBROUTINE PLA127
 
      SUBROUTINE PLA128
C * SQUEEZE SUMMARY (GRAPHICS)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE squeeze
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: M
      INTEGER           :: N
      REAL              :: X
      REAL              :: Y
      REAL              :: XOR
      REAL              :: YOR
      REAL              :: DSH
      REAL              :: PEN
      REAL              :: OLDX
      REAL              :: OLDY
      REAL              :: RVAL
      REAL              :: STLM
      REAL              :: RMODEL
      REAL              :: SCALHOR
      REAL              :: SCALVER
      CHARACTER(len=4)  :: A
      CHARACTER(len=10) :: B
      IF (IWIN == 1) THEN
        MEDIUM = 2
        IGGT(16:22) = 'ON     '
        CALL GGIP (-999.0, 0.0, 0.0, 6)
      END IF
   10 DO I = 1, 20
        N = 21 - I
        IF (STAT(N, 7) /= 0.0) THEN
          STLM = N * 0.05
          EXIT
        END IF
      END DO
      M = 1
      DO I = 1, N
        IF (STAT(I, 7) /= 0.0) THEN
          M = I
          EXIT
        END IF
      END DO
      RMODEL = 0.0
      DO I = 1, N
        RMODEL = MAX (STAT(I, 8), RMODEL)
      END DO
      RMODEL = MIN (1.0, RMODEL)
      DSH  = 0.05
      HORS = 25.0
      VERT = 25.0
      XOR  = 1.0
      YOR  = 1.0
      SCALHOR = (HORS - XOR) / STLM
      SCALVER = (VERT - YOR) / (RMODEL + 0.02)
C * OPEN WINDOW
      CALL GGIP (HORS, VERT, 0.0, 1)
C * OUTLINE FRAME
      CALL PLA110 (HORS, VERT, -1)
      CALL PLA439 (0.0, 'SQUEEZE SUMMARY', 15, 0.45, 6, 2,
     1  9.0, VERT - 0.6)
      CALL GGIP (0.0, 1.0, 0.0, 0)
C * MOVE ORIGIN
      CALL GGIP (XOR, YOR, 0.0, -3)
C * VERTICAL AND HORIZONTAL AXES
      CALL GGIP (0.0, VERT - YOR, 0.0, 2)
      CALL GGIP (0.0, 0.0, 0.0, 3)
      CALL GGIP (HORS - XOR, 0.0, 0.0, 2)
C * HORIZONTAL SCALE
      DO I = 1, N
        X = I * 0.05 * SCALHOR
        Y = 0.0
        CALL GGIP (X, Y, 0.0, 3)
        CALL GGIP (X, Y + 0.3, 0.0, 2)
        WRITE (A, 99999) I * 0.05
        CALL PLA439 (90.0, A, 4, 0.2, 1, 1, X -0.1, Y + 0.1)
      END DO
      CALL PLA439 (0.0, 'sin(theta)/lambda', 17, 0.25, 1, 1,
     1  HORS - XOR - 4.0, -0.35)
C * VERTICAL SCALE
      DO I = 1, 20
        RVAL = I * 0.05
        IF (RVAL < RMODEL) THEN
          X = 0.0
          Y = RVAL * SCALVER
          CALL GGIP (X, Y, 0.0, 3)
          CALL GGIP (X + 0.3, Y, 0.0, 2)
          WRITE (A, 99999) RVAL
          CALL PLA439 (0.0, A, 4, 0.2, 1, 1, X + 0.1, Y + 0.1)
        END IF
      END DO
C * PLOT CURVES
      DO J = 8, 9
        OLDX = 0.0
        OLDY = 0.0
        IF (J == 8) THEN
          PEN = 2
          B   = '  R(Model)'
          Y   = 3.0
        ELSE
          PEN = 3
          B   = 'R(Squeeze)'
          Y   = 2.0
        END IF
        CALL PLA439 (0.0, B, 10, 0.3, NINT (PEN), 1, HORS - XOR - 2.8,
     1       Y)
        CALL GGIP (0.0, PEN, 0.0, 0)
        DO I = M, N
          X = (I - 0.5) * 0.05 * SCALHOR
          Y =  MIN (STAT(I, J) * SCALVER, VERT - XOR)
          IF (I > M) THEN
            CALL GGIP (OLDX, OLDY, 0.0, 3)
            CALL GGIP (X   , Y   , 0.0, 2)
          END IF
          OLDX = X
          OLDY = Y
C * PLOT MARKER
          CALL PLA411 (X, Y, DSH, -1.0)
        END DO
      END DO
C * INFO
      VRT = VERT - XOR - 2.0
      K   = 14 + KNMFIL + KXT + 1
      WRITE (LINE, 99988) FNLU1(1 : KNMFIL + KXT + 1)
      CALL PLA439 (0.0, LINE, K, 0.35, 1, 1, 8.0, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99987) FNLU16(1 : KNM16)
      CALL PLA439 (0.0, LINE, 14 + KNM16, 0.35, 1, 1, 8.0, VRT)
      IF (IABS (IGBL(8)) == 3) THEN
        VRT = VRT - 0.6
        K   = INDEX (RLWS(5)(1:65), CHAR (39)) - 1
        WRITE (LINE, 99983) RLWS(5)(1:K)
        CALL PLA439 (0.0, LINE, 14 + K, 0.35, 1, 1, 8.0, VRT)
      END IF
      VRT = VRT - 0.6
      WRITE (LINE, 99986) ZSPG
      CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, 8.0, VRT)
      VRT = VRT - 0.6
      PAR(166) = ASIN (SQRT (PAR(166)) * PAR(17)) * RGBL(6)
      WRITE (LINE, 99985) MAX (PAR(166), PAR(168), 0.0)
      CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, 8.0, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99984) MAX (IPR(261), 0)
      CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, 8.0, VRT)
      IF (PAR(197) > 0.0) THEN
        VRT = VRT - 0.6
        WRITE (LINE, 99982) PAR(197)
        CALL PLA439 (0.0, LINE, 26, 0.35, 1, 1, 8.0, VRT)
      END IF
      IF (PAR(173) > 0.0) THEN
        VRT = VRT - 0.6
        WRITE (LINE, 99981) PAR(173)
        CALL PLA439 (0.0, LINE, 26, 0.35, 1, 1, 8.0, VRT)
      END IF
      IF (PAR(174) > 0.0) THEN
        VRT = VRT - 0.6
        WRITE (LINE, 99980) PAR(174)
        CALL PLA439 (0.0, LINE, 26, 0.35, 1, 1, 8.0, VRT)
      END IF
      X = - XOR + HORS
      Y = - YOR
      CALL GGIP (X, Y, 0.0, -3)
C * CELL VOLUME
      WRITE (LINE, 99998) NINT (PAR(98))
      VRT = VERT - 0.6
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * VOID VOLUME
      WRITE (LINE, 99997) NINT (PAR(150))
      VRT = VRT - 0.6
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * VOID PERCENTAGE
      WRITE (LINE, 99996) NINT (PAR(409))
      VRT = VRT - 0.6
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * ELECTRON COUNT IN CELL
      WRITE (LINE, 99995) NINT (PAR(354))
      VRT = VRT - 0.6
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * VOID MAX
      WRITE (LINE, 99993) NINT (PAR(525))
      VRT = VRT - 1.2
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * ELECTRON COUNT VOID MAX
      WRITE (LINE, 99992) NINT (PAR(526))
      VRT = VRT - 0.6
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * TOTAL # OF REFLECTIONS
      VRT = VRT - 1.2
      WRITE (LINE, 99989) IPR(712)
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * MISSING # OF REFLECTIONS
      VRT = VRT - 0.6
      WRITE (LINE, 99991) IPR(609)
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
C * MISSING # OF LOW ANGLE REFLECTIONS
      VRT = VRT - 0.6
      WRITE (LINE, 99990) IPR(610)
C * NUMBER OF HEMI-SPHERE REFLECTIONS
      VRT = VRT - 1.2
      WRITE (LINE, 99979) NREF
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99978) RF
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99977) NREFS
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99994) RFS
      CALL PLA439 (0.0, LINE, 24, 0.4, 1, 1, 0.1, VRT)
      CALL GGIP (0.0, 0.0, 0.0, -1)
      DO
C * WHAT NEXT ?
        CALL PLA012 (2, 1)
        SELECT CASE (IGGT(1:4))
          CASE ('!   ', 'END ', 'EXIT')
            EXIT
          CASE ('PLOT')
            GO TO 10
          CASE DEFAULT
            EXIT
        END SELECT
      END DO
99999 FORMAT (F4.2)
99998 FORMAT ('Cell Vol ....', I6, ' A**3')
99997 FORMAT ('Void Vol ....', I6, ' A**3')
99996 FORMAT ('Void Perc ...', I6, ' %')
99995 FORMAT ('Cell Count ..', I6, ' e-')
99994 FORMAT ('R(F > 4sig(F)', F6.3)
99993 FORMAT ('Void Max ....', I6, ' A**3')
99992 FORMAT ('ElCountMax ..', I6, ' e-')
99991 FORMAT ('Missing .....', I6, ' Refl')
99990 FORMAT ('MissingLowAng', I6, ' Refl')
99989 FORMAT ('Unique Number', I6, ' Refl')
99988 FORMAT ('FormData ....', 1X, A)
99987 FORMAT ('ReflData ....', 1X, A)
99986 FORMAT ('SpaceGroup ..', 1X, A)
99985 FORMAT ('ThetaMax ....', F6.2, ' Deg.')
99984 FORMAT ('Temperature .', I4, ' K')
99983 FORMAT ('Model .......', 1X, A)
99982 Format ('R(int) ......', F6.3, ' (CIF)')
99981 Format ('R1(I>2sig(I))', F6.3, ' (CIF)')
99980 FORMAT ('wR2 .........', F6.3, ' (CIF)')
99979 FORMAT ('Hemi-Sphere .', I6, ' Refl')
99978 FORMAT ('R(F) ........', F6.3)
99977 FORMAT ('F > 4sig(F)  ', I6, ' Refl')
      END SUBROUTINE PLA128
 
      SUBROUTINE PLA129
C * REPORT SQUEEZE RESULT
      USE files
      USE parameters
      USE xwdw
      USE squeeze
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: IB
      INTEGER :: IC
      REAL    :: ST
C * COMMENT ON SQUEEZE RUN
      IGBL(6) = 36
      CALL PLA262 (0)
      WRITE (LU7, 99993, IOSTAT = IOST)
      DO I = 1, 20
        IF (STAT(I, 7) > 0.0) THEN
          IF (STAT(I, 4) /= 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
          END IF
          DO J = 1, 6
            STAT(I, J) = STAT(I, J) / STAT(I, 7)
          END DO
          ST = I / 20.0
          WRITE (LU7, 99992, IOSTAT = IOST) ST, (STAT(I, K), K = 1, 9)
        END IF
      END DO
C * DISPLAY SQUEEZE RESULT
      IF (IWIN == 1) THEN
C * WHAT NEXT ?
        CALL PLA012 (2, 1)
      ELSE
        CALL PLA431
      END IF
      CALL PLA128
      WRITE (LU7, 99998, IOSTAT = IOST)
      IF (MAX (-PAR(329), PAR(330)) > 1.0)
     1  WRITE (LU7, 99997, IOSTAT = IOST) PAR(329), PAR(330)
      IF (IPR(489) + IPR(490) > 0)
     1  WRITE (LU7, 99996, IOSTAT = IOST) IPR(489) + IPR(490)
C * NOTE ON HOW TO PROCEED
      IF (IGBL(29) == 1 .OR. IGBL(29) == 3) THEN
        IB = 7
        IC = 15
      ELSE
        IB = 1
        IC = 30
      END IF
      WRITE (LU6, 99999, IOSTAT = IOST) (TXT(I), I = IB, IC)
      WRITE (LU7, 99999, IOSTAT = IOST) (TXT(I), I = IB, IC)
      IF (IWIN == 1) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 1.0
        CALL PLA439 (0.0, 'S U M M A R Y', 13, 0.60, 5 + IGBL(68),
     1               2, 10.0, VRT)
        VRT = VRT - 0.9
        CALL PLA439 (0.0, TXT1(1), 62, 0.30, 1, 2, 5.0, VRT)
        IF (MAX (-PAR(329), PAR(330)) > 1.0) THEN
          WRITE (TXT1(2), 99995, IOSTAT = IOST) PAR(329), PAR(330)
          VRT = VRT - 0.40
          CALL PLA439 (0.0, TXT1(2), 62, 0.30, 1, 2, 5.0, VRT)
        END IF
        IF (IPR(610) > 0) THEN
          WRITE (TXT1(3), 99994, IOSTAT = IOST) PAR(486), IPR(610)
          VRT = VRT - 0.40
          CALL PLA439 (0.0, TXT1(3), 62, 0.30, 2, 2, 5.0, VRT)
          VRT = VRT - 0.40
          CALL PLA439 (0.0,
     1  'Estimates Substituted for Missing Reflexion Intensites',
     2   54, 0.30, 2, 2, 5.0, VRT)
        END IF
        DO I = IB, IC
          VRT = VRT - 0.60
          CALL PLA439 (0.0, TXT(I), 62, 0.45, 1, 2, 1.0, VRT)
        END DO
        CALL PLA297 (0)
      END IF
      IPR(1) = 1
      RETURN
99999 FORMAT (/, 30(A, /), /)
99998 FORMAT (/, 'Comments on and Analysis of the SQUEEZE run',
     1        /, 80('='))
99997 FORMAT (/, '- Significant Residual Density Excursion(s) in  the',
     1        /, '  Ordered part of the Structure:', 2F6.1)
99996 FORMAT (/, '- Model includes', I4, ' Isotropic Non-H-Atoms', /,
     1           '  Rerun SQUEEZE with Anisotropically Refined Model')
99995 FORMAT ('Significant Residual Model Density Excursions:',
     1        F5.1, ',', F5.1)
99994 FORMAT ('Number of Missing Reflections Below sin(th)/L =',
     1         F5.2, ' =', I4)
99993 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  'Fo       = Observed Fobs scaled on Fc-total', /,
     *  'N        = Number of reflections in Sin(Theta)/Lambda range',/,
     1  'R(Mod)   = SUM(ABS(ABS(FcMod) - Fo)) / SUM(Fo)', /,
     2  'R(Tot)   = SUM(ABS(ABS(FcTot) - Fo)) / SUM(Fo)', /,
     3  /, 'SinT/L <FcMod> <FcSolv>  <FcTot>    <Fo> ',
     4        ' <DelMS> <DelMT>    N  R(Mod) R(Tot)', /, 80('='))
99992 FORMAT (F4.2, 4F9.2, 2F8.2, F7.0, 2F7.3)
      END SUBROUTINE PLA129
 
      SUBROUTINE PLA130 (HMAX, KMAX, LMAX, NREF, IADR, NREFA, NREFB)
C * REFLECTION DATA SUPPORT ROUTINE FOR : PLA125 - SQUEEZE
      USE files
      USE parameters
      USE spgrdata
      USE reflex
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: K
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: NR
      INTEGER           :: IH
      INTEGER           :: IK
      INTEGER           :: IL
      INTEGER           :: ISN
      INTEGER           :: IHQ
      INTEGER           :: IKQ
      INTEGER           :: ILQ
      INTEGER           :: IHP
      INTEGER           :: IKP
      INTEGER           :: ILP
      INTEGER           :: MPK
      INTEGER           :: MPL
      INTEGER           :: NRF
      INTEGER           :: IASM
      INTEGER           :: NRF1
      INTEGER           :: IADD
      INTEGER           :: HMAX
      INTEGER           :: KMAX
      INTEGER           :: LMAX
      INTEGER           :: NREF
      INTEGER           :: IADR
      INTEGER           :: NIND
      INTEGER           :: MHKL
      INTEGER           :: NEXT
      INTEGER           :: JUNK
      INTEGER           :: NREFA
      INTEGER           :: NREFB
      INTEGER           :: MHKLH
      REAL              :: TH
      REAL              :: XI
      REAL              :: F1
      REAL              :: F2
      REAL              :: F3
      REAL              :: F4
      REAL              :: F1I
      REAL              :: F2I
      REAL              :: F3I
      REAL              :: FC1
      REAL              :: FC2
      REAL              :: FC3
      REAL              :: ARG
      REAL              :: SGI
      REAL              :: STL
      REAL              :: WGHT
      REAL              :: XCAL
      REAL              :: STLK
      REAL              :: SUM1
      REAL              :: SUM2
      REAL              :: SUM3
      REAL              :: SUM4
      REAL              :: ASOL
      REAL              :: BSOL
      REAL              :: ACAL
      REAL              :: BCAL
      REAL              :: FOBS
      REAL              :: SGIK
      REAL              :: YUNK
      REAL              :: ZCAL
      REAL              :: SNTHA
      REAL              :: SIGXI
      REAL              :: FOBSX
      REAL              :: ACALT
      REAL              :: BCALT
      REAL              :: FCALT
      REAL              :: ACALA
      REAL              :: BCALA
      REAL              :: SIGIW
      REAL              :: XFCAL
      REAL              :: SCHAAL
      REAL              :: ACALAF
      REAL              :: BCALAF
      REAL              :: FACTOR
      REAL              :: GEN095
      CHARACTER(len=80) :: LINE
C * LAYOUT VOID ARRAY
C *         NVDR I - TOP REFLECTION DATA POINTER ARRAY (HALF REFL. SPHERE)
C *              I
C *              I      INDEX TO THE DIFFERENCE MAP REFLECTION DATA STORAGE
C *              I
C *         IADR I - ADDRESS 0,0,0 Reflection
C *              I
C *              I      (EMPTY)
C *              I
C *         IR3D I - TOP R3D ARRAY
C *              I
C *              I      THREE R3D SECTIONS (3 * (M1 + 2) * (M2 + 2))
C *              I
C *         ITOP I - TOP FFT ARRAY
C *              I
C *              I      FFT ARRAY SIZE = NGRID * 2
C *              I
C * NREFA * NP69 I - TOP TOTAL REFLECTION DATA STORAGE
C *              I
C *              I      ENTRIES FOR MISSING REFLECTION DATA
C *              I
C * NREFB * NP69 I - TOP (SYMMETRY EXPANDED) REFLECTION DATA STORAGE
C *              I
C *              I      VOID(N +  1) - F(obs)
C *              I      VOID(N +  2) - SIG(F(obs))
C *              I      VOID(N +  3) - NON-SOLVENT ACAL
C *              I      VOID(N +  4) - NON-SOLVENT BCAL
C *              I      VOID(N +  5) - SOLVENT     ACALSOLVENT
C *              I                     (ACALS = ACAL + ACALSOLVENT)
C *              I      VOID(N +  6) - SOLVENT     BCALSOLVENT
C *              I                     (BCALS = BCAL + BCALSOLVENT)
C *              I      VOID(N +  7) - DIFF-MAP    ACAL
C *              I      VOID(N +  8) - DIFF-MAP    BCAL
C *              I      VOID(N +  9) - H
C *              I      VOID(N + 10) - K
C *              I      VOID(N + 11) - L
C *              I      VOID(N + 12) - ANOM-DISP   ACALA
C *              I      VOID(N + 13) - ANOM-DISP   ACALB
C *              I      VOID(N + 14) - SIN(THETA)/LAMBDA
C *              I      VOID(N + 15) - ASYMMETRIC REFL INFO
C *              I      VOID(N + 16) - SUM WEIGHTS AVERAGED REFLNS
C *              I
      IND1  = 1
      IND2  = 2
      IND3  = 3
      NIND  = 0
      NREFA = 0
C * GET CENTROSYMMETRY NUMBER
      ICNTR = IPR(257)
C * DETERMINE PACKING CONSTANTS AND ADRESSES
      MPH   = 2 * HMAX + 1
      MPK   = 2 * KMAX + 1
      MPL   = 2 * LMAX + 1
      MHK   = MPH * MPK
      MHKL  = MPL * MHK
      MHKLH = (MHKL - 1) / 2
C * TOP-DOWN STORAGE ARRAY OF REFLECTION ADDRESSES
C * CALCULATE ADDRESS OF 0,0,0 REFLECTION
      IADR  = NVDR - MHKLH
C * PRELIMINARY CHECK FOR SUFFICIENT SPACE
      IF (IADR < 1) THEN
        IF (IGBL(63) > 0)
     1    WRITE (LU6, 99998, IOSTAT = IOST) NIND, IADR, NVDR
C * ERROR/PROBLEM
        NREFA = -1
        RETURN
      END IF
C * INIT & LOAD POINTERS TO REFLECTION DATA FOR ALL REFLECTIONS
      CALL GEN074 (VOID, IADR + 1, NVDR, 0.0)
      NEXT  = 0
C * REWIND REFLECTION FILE LU27 CREATED BY PLA133
      REWIND (LU27, IOSTAT = IOST)
      IF (IOST /= 0) THEN
        WRITE (6, 99993)
        STOP
      END IF
C * TEST FOR SHELXL LIST 4 TYPE HKL FILE (IGBL(9) = 1)
C * TEST FOR SHELXL HKLF 4 TYPE HKL FILE (IGBL(9) = 0)
C * ??  IF (IGBL(9) == 1 .OR. IGBL(9) .EQ. 0) THEN
      IF (IGBL(9) == 1) THEN
        SCHAAL   = 1.0 / PAR(230)
        PAR(230) = 1.0
C * ASSUME FCF FILE
      ELSE
        SCHAAL = 1.0
      END IF
      NRF    = 0
      NRF1   = 0
      SUM1   = 0.0
      SUM2   = 0.0
      SUM3   = 0.0
      SUM4   = 0.0
      ACAL   = 0.0
      BCAL   = 0.0
      ACALA  = 0.0
      BCALA  = 0.0
      ACALAF = 0.0
      BCALAF = 0.0
      DO NR = 1, NREF
        READ (LU27, IOSTAT = IOST) IHP, IKP, ILP, XI, SGI, SIGIW,
     1    ASOL, BSOL
        IF (IOST /= 0) THEN
          IF (IGBL(63) /= 0) WRITE (LU6, 99996, IOSTAT = IOST)
C * ERROR/PROBLEM
          NREFA = -1
          RETURN
        END IF
C * TAKE SWAT CORRECTION TO I(obs) INTO ACCOUNT
        IF (IPR(698) /= 0) THEN
C * CALCULATE (SIN(THETA) / LAMBDA)**2
          STLK = GEN095 (PAR(191), IHP, IKP, ILP)
          ARG  = RGBL(8) * PAR(502) * STLK
          IF (PAR(501) == 0.0 .OR. ARG > 20) THEN
            FACTOR = 1.0
          ELSE
            FACTOR = 1.0 - PAR(501) * EXP (- ARG)
          END IF
          XI  = XI  * SCHAAL / FACTOR**2
          SGI = SGI * SCHAAL / FACTOR**2
        ELSE
          XI  = XI  * SCHAAL
          SGI = SGI * SCHAAL
        END IF
        FOBS  = SQRT (MAX (0.0, XI))
        SIGXI = 0.7071068 * AMIN1 (SQRT (SGI),
     1              SGI / MAX (FOBS, 0.0001))
C * CHECK FOR SYSTEMATIC EXTINCTIONS ABSENCES
        SGX(1)  = IHP
        SGX(2)  = IKP
        SGX(3)  = ILP
        SGX(12) = 0.0
        CALL SGSM (27, LINE, SGX, 0, 0, IERR)
        IF (NINT (SGX(12)) == 0) THEN
          CALL PLA136 (1, IHP, IKP, ILP, IASM)
C * LOOP OVER SYMMETRY (EXCLUDING Lattice Centering and Inversion)
          DO I = 1, NSYMH
            M = IADR + IHKLS(4, I)
C * CALCULATE STRUCTURE FACTOR
            ISN = IHKLS(5, I)
            IHQ = IHKLS(1, I) * ISN
            IKQ = IHKLS(2, I) * ISN
            ILQ = IHKLS(3, I) * ISN
            F4  = PHIS(I) * RGBL(6)
            IF (I == 1) THEN
              CALL PLA137 (IHQ, IKQ, ILQ, ACAL, BCAL, ACALA, BCALA,
     1          ACALAF, BCALAF, SNTHA)
              IF (IPR(210) == 2) THEN
                ACAL = ACAL + ASOL
                BCAL = BCAL + BSOL
              END IF
              FC1    = SQRT (ACAL**2   + BCAL**2)
              FC2    = SQRT (ACALA**2  + BCALA**2)
              FC3    = SQRT (ACALAF**2 + BCALAF**2)
              F1     = ATAN2 (BCAL,   ACAL)   * RGBL(6)
              F2     = ATAN2 (BCALA,  ACALA)  * RGBL(6)
              F3     = ATAN2 (BCALAF, ACALAF) * RGBL(6)
            ELSE
              F1I    = MOD (F1 + F4 + 360.0, 360.0) / RGBL(6)
              F2I    = MOD (F2 + F4 + 360.0, 360.0) / RGBL(6)
              F3I    = MOD (F3 - F4 + 360.0, 360.0) / RGBL(6)
              ACAL   = FC1 * COS (F1I)
              BCAL   = FC1 * SIN (F1I)
              ACALA  = FC2 * COS (F2I)
              BCALA  = FC2 * SIN (F2I)
              ACALAF = FC3 * COS (F3I)
              BCALAF = FC3 * SIN (F3I)
            END IF
C * CORRECT (SUBSTRACT) ANOMALOUS DISPERSION FROM F(obs) [X-RAYS]
            IF (IPR(493) < 7) THEN
              IF (IPR(210) == 2) THEN
                ACALT = ACAL + ACALA
                BCALT = BCAL + BCALA
              ELSE
                ACALT = ACAL + ACALA + ASOL
                BCALT = BCAL + BCALA + BSOL
              END IF
              XCAL  = ACALT ** 2 + BCALT ** 2
C * HANDLE FLACK PARAMETER
              IF (PAR(433) < 999999.0) THEN
                IF (IPR(210) == 2) THEN
                  ZCAL = ( ACAL + ACALAF)**2
     1                 + (-BCAL + BCALAF)**2
                ELSE
                  ZCAL = ( ACAL + ASOL + ACALAF)**2
     1                 + (-BCAL - BSOL + BCALAF)**2
                END IF
                XFCAL = MAX (0.0,
     1                  (1.0 - PAR(433)) * XCAL + PAR(433) * ZCAL)
              ELSE
                XFCAL = XCAL
              END IF
              FCALT = SQRT (ACALT ** 2 + BCALT ** 2)
              FOBSX = SQRT ((FOBS * ACALT / FCALT - ACALA) ** 2 +
     1                      (FOBS * BCALT / FCALT - BCALA) ** 2)
            ELSE
              XFCAL = ACAL ** 2 + BCAL ** 2
              FOBSX = FOBS
            END IF
C * CALCULATE R, wR2, S CONTRIBUTIONS
            IF (I == 1) THEN
              NRF1 = NRF1 + 1
              IF (XI > PAR(484) * SGI) THEN
                SUM1 = SUM1 + ABS (FOBS - SQRT (XFCAL))
                SUM2 = SUM2 + FOBS
                NRF  = NRF  + 1
              END IF
              SGIK = SIGIW ** 2
              IF (IPR(698) /= 0) THEN
                XI    = XI    * FACTOR**2
                XFCAL = XFCAL * FACTOR**2
              END IF
C * AVOID SIGMA = 0.0 (e.g. LIST 3)
              IF (SGIK > 0.0001) THEN
                SUM3 = SUM3 + ((XI - XFCAL) ** 2) / SGIK
                SUM4 = SUM4 + (XI ** 2) / SGIK
              END IF
            END IF
            IF (SIGXI > 0.0) THEN
              WGHT = 1.0 / SIGXI**2
            ELSE
              WGHT = 0.0
            END IF
            IF (NINT (VOID(M)) == 0) THEN
              IH = IHKLS(1, I)
              IK = IHKLS(2, I)
              IL = IHKLS(3, I)
C * STORE REFLECTION DATA BOTTOM UP
              VOID(NIND + 1)  = WGHT * FOBSX
              VOID(NIND + 2)  = SIGXI
              VOID(NIND + 3)  = ACAL
              VOID(NIND + 4)  = BCAL * ISN
C * SOLVENT AREA CONTRIBUTION
              VOID(NIND + 5)  = 0.0
              VOID(NIND + 6)  = 0.0
C * DIFF-MAP COEFFICIENTS
              VOID(NIND + 7)  = 0.0
              VOID(NIND + 8)  = 0.0
              VOID(NIND + 9)  = IH
              VOID(NIND + 10) = IK
              VOID(NIND + 11) = IL
              VOID(NIND + 12) = ACALA
              VOID(NIND + 13) = BCALA
              VOID(NIND + 14) = SQRT (GEN095 (PAR(191), IH, IK, IL))
              CALL PLA136 (0, IH, IK, IL, IASM)
              VOID(NIND + 15) = 2 * IASM - 1
              VOID(NIND + 16) = WGHT
              NREFA           = NREFA + 1
              NIND            = NIND  + NP69
C * STORE REFERENCE
              VOID(M) = NREFA
C * CHECK FOR SCRATCH ARRAY OVERRUN
              IF (NIND + NP69 >= IADR) THEN
                IF (IGBL(63) > 0) THEN
                  WRITE (LU6, 99998, IOSTAT = IOST)
     1              NIND, IADR, NVDR, CHAR (IPR(223))
                  WRITE (LU7, 99998, IOSTAT = IOST)
     1              NIND, IADR, NVDR, CHAR (IPR(223))
                END IF
C * ERROR/PROBLEM
                NREFA = -1
                RETURN
              END IF
            ELSE
C * FIND INDEX IN REFLECTION DATA STORAGE
              N            = (NINT(VOID(M)) - 1) * NP69
              VOID(N + 1)  = VOID(N +  1) + WGHT * FOBSX
              VOID(N + 16) = VOID(N + 16) + WGHT
            END IF
          END DO
        ELSE
          NEXT = NEXT + 1
        END IF
      END DO
      IF (NRF1 < IPR(266) + IPR(767)) THEN
C * ERROR/PROBLEM
        NREFA = -1
        RETURN
      END IF
      IF (SUM2 /= 0.0) PAR(480) = SUM1 / SUM2
      IF (SUM4 /= 0.0) PAR(481) = SQRT (SUM3 / SUM4)
      JUNK = NRF1 - IPR(266) - IPR(767)
      IF (JUNK /= 0) PAR(482) = SQRT (SUM3 / JUNK)
      IPR(625) = NRF
      IPR(626) = NRF1
      IF (IGBL(9) .NE. 0) THEN
        IF (IGBL(63) > 0) THEN
          WRITE (LU6, 99997, IOSTAT = IOST)
     1      PAR(480), NRF, PAR(481), NRF1, PAR(482)
          CALL PLA262 (5)
          WRITE (LU7, 99997, IOSTAT = IOST)
     1      PAR(480), NRF, PAR(481), NRF1, PAR(482)
        END IF
      END IF
C * CHECK FOR SHELXL WEIGHT PARAMETERS AND TWINNING
      IF (PAR(493) >= 0.0 .AND. IPR(619) == 0) THEN
C * CHECK ONLY FOR NON-NEUTRON
        IF (IPR(493) < 7) THEN
C * CHECK FOR JANA WEIGHT + EXTINCTION
          IF (IPR(632) /= 2 .OR. PAR(229) <= 0.0) THEN
            IF (IPR(651) == 0 .AND. ABS (PAR(481)) > 0.001) THEN
              YUNK = PAR(173) - PAR(480)
C * SUPPRESS ALERTS FOR MOPRO & IDEAL & anharm & Pseudo Flack Twin
              IF (IPR(725) /= 9 .AND. IPR(667) /= -1 .AND.
     1            IPR(756) == 0 .AND. IPR(757) == 0 .AND.
     2            IPR(779) == 0) THEN
C * ALERT _926 - COMPARE REPORTED AND CALCULATED R-VALUE DIFFERENCE
                IF (ABS (YUNK) > 0.001 .AND. IPR(775) == 0)
     1            CALL PLA236 (926, 4, ABS (YUNK), YUNK, ' ', ' ')
              YUNK = PAR(174) - PAR(481)
C * ALERT _927 - COMPARE REPORTED AND CALCULATED wR2-VALUE DIFFERENCE
                IF (ABS (YUNK) > 0.001 .AND. IPR(775) == 0)
     1            CALL PLA236 (927, 4, ABS (YUNK), YUNK, ' ', ' ')
              YUNK = PAR(299) - PAR(482)
C * ALERT _928 - COMPARE REPORTED AND CALCULATED S-VALUE DIFFERENCE
                IF (ABS (YUNK) > 0.005 .AND. IPR(775) == 0)
     1            CALL PLA236 (928, 3, ABS (YUNK), YUNK, ' ', ' ')
              END IF
            END IF
          END IF
        END IF
      END IF
C * AVERAGE
      NREFB = NREFA
      IADD  = LMAX * MHK + KMAX * MPH + HMAX
      DO I = 1, MHKLH
        K = NINT (VOID(IADR + I))
        IF (K /= 0) THEN
          K = (K - 1) * NP69
          IF (VOID(K + 16) > 0.0) THEN
            VOID(K + 1) = VOID(K + 1) / VOID(K + 16)
          ELSE
            VOID(K + 1) = 0.0
          END IF
        ELSE
C * HANDLE MISSING REFLECTION IN SQUEEZE CASE (I.E. APPEND REFL. RECORD)
          IF (.TRUE.) THEN
            IH = I  + IADD
            IL = IH / MHK
            IH = IH - IL * MHK
            IL = IL - LMAX
            IK = IH / MPH
            IH = IH - IK * MPH - HMAX
            IK = IK - KMAX
C * CHECK FOR BRAVAIS AND SPACE GROUP ABSENCES
            SGX(1)  = IH
            SGX(2)  = IK
            SGX(3)  = IL
            SGX(12) = 0.0
            CALL SGSM (27, LINE, SGX, 0, 0, IERR)
            IF (NINT (SGX(12)) /= 0) CYCLE
            CALL PLA136 (0, IH, IK, IL, IASM)
            STL = SQRT(GEN095 (PAR(191), IH, IK, IL))
C * TEST AGAINST SIN(THETA)/LAMBDA-MAX + TOLERANCE
            IF (STL < (PAR(287) + PAR(442))) THEN
C * STORE REFLECTION DATA BOTTOM UP
              VOID(NIND + 1)  = 0.0
              VOID(NIND + 2)  = 0.0
              VOID(NIND + 3)  = 0.0
              VOID(NIND + 4)  = 0.0
C * SOLVENT AREA CONTRIBUTION
              VOID(NIND + 5)  = 0.0
              VOID(NIND + 6)  = 0.0
C * DIFF-MAP COEFFICIENTS
              VOID(NIND + 7)  = 0.0
              VOID(NIND + 8)  = 0.0
              VOID(NIND + 9)  = IH
              VOID(NIND + 10) = IK
              VOID(NIND + 11) = IL
              VOID(NIND + 14) = STL
              VOID(NIND + 15) = FLOAT (IASM) * 2 - 1
              NREFA           = NREFA + 1
              NIND            = NIND  + NP69
              VOID(IADR + I)  = NREFA
C * CHECK FOR SCRATCH ARRAY OVERRUN
              IF (NIND + NP69 >= IADR) THEN
                IF (IGBL(63) > 0) THEN
                  WRITE (LU6, 99998, IOSTAT = IOST)
     1              NIND, IADR, NVDR, CHAR (IPR(223))
                  WRITE (LU7, 99998, IOSTAT = IOST)
     1              NIND, IADR, NVDR, CHAR (IPR(223))
                END IF
C * ERROR/PROBLEM
                NREFA = -1
                RETURN
              END IF
C * CHECK FOR IN ASYMMETRIC REFLECTION UNIT (IASM = 1)
              IF (IASM /= 0) THEN
C * COUNT NUMBER OF MISSING REFLECTIONS
                IF (STL <= PAR(486)) THEN
                  TH = ASIN (STL * PAR(17)) * RGBL(6)
                  IF (IPR(610) < NP60) THEN
C * COUNT NUMBER OF MISSING LOW ORDER REFLECTIONS (AND REGISTER)
                    IPR(610)             = IPR(610) + 1
                    MISSING(1, IPR(610)) = IH
                    MISSING(2, IPR(610)) = IK
                    MISSING(3, IPR(610)) = IL
                    MISSING(4, IPR(610)) = NINT (TH * 1000)
C * WRITE HEADER
                    IF (IPR(610) == 1) THEN
                      CALL PLA262 (4)
                      WRITE (LU6, 99995, IOSTAT = IOST) PAR(486)
                      WRITE (LU7, 99995, IOSTAT = IOST) PAR(486)
                    END IF
                    CALL PLA262 (1)
                    WRITE (LU6, 99994, IOSTAT = IOST)
     1                IPR(610), IH, IK, IL, TH
                    WRITE (LU7, 99994, IOSTAT = IOST)
     1                IPR(610), IH, IK, IL, TH
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
      END DO
C * REPORT REFLECTION STATISTICS
      IPR(609) = IPR(553) + IPR(555) + IPR(557)
      IF (IGBL(63) > 0) THEN
        WRITE (LU6, 99999, IOSTAT = IOST)
     1    NEXT, NREF - NEXT, IPR(609), IPR(610)
        CALL PLA262 (5)
        IPR(712) = NREF - NEXT
        WRITE (LU7, 99999, IOSTAT = IOST)
     1    NEXT, IPR(712), IPR(609), IPR(610)
      END IF
      RETURN
99999 FORMAT (/,
     1        ':: Number of Removed Systematic Absences    = ', I7, /,
     2        ':: Number of Non-Syst.Absence   Reflections = ', I7, /,
     3        ':: Number of Missing            Reflections = ', I7, /,
     4        ':: Number of Missing Low Order  Reflections = ', I7)
99998 FORMAT (/, 'F: Scratch Array Overrun (NXX,IADR,NVDR =)', 3I6, /,
     1        3X, 'Use larger program version i.e. recompile with ',
     2        'larger NVDR', A, /)
99997 FORMAT (/, ':: R1   =', F9.4, ' for', I6,
     1        ' Refl. with I > 2 s(I) and', /,
     2        ':: wR2  =', F9.4, ' for', I6, ' reflections', /,
     3        ':: S    =', F9.4, /)
99996 FORMAT (/, ':: Problem Reading .hkp File in PLA130.', /)
99995 FORMAT (/, 'Missing Reflections Below sin(theta)/lambda=', F5.2,
     1        /, 47('='), /,
     2        '   N    H    K    L     Theta', /, 29('='))
99994 FORMAT (I4, 3I5, F10.2)
99993 FORMAT (/, '** REWIND PROBLEM OF FILE LU27 ** - STOP')
      END SUBROUTINE PLA130
      SUBROUTINE PLA131 (MLOOP)
C * HYBRID: SQUEEZE/SHELXL201n CYCLE BASED ON SUPPLIED SHELX201n <name>.cif
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: KL
      INTEGER                :: KN
      INTEGER                :: LU
      INTEGER                :: MLOOP
      INTEGER                :: NLOOP
      INTEGER                :: NLOOPMAX
      REAL, DIMENSION(10, 7) :: RESULTX
      CHARACTER(len=80)      :: DUM
      CHARACTER(len=132)     :: DUMA
      DO J = 1, 7
        RESULTX(1, J) = 0.0
      END DO
      IF (IPR(221) > 0) IPR(682) = MIN (10, MLOOP)
      IGBL(31) = 10
C * CHECK FOR SHELXL201n CIF OR INS/RES + HKL
C * SHELXL201n CIF WITH EMBEDDED .res & .hkl test)
      IF (IABS(IGBL(8)) == 3 .AND. IPR(663) /= 0
     1  .AND. IPR(664) /= 0) THEN
        CLOSE (UNIT = LU24)
        CLOSE (UNIT = LU25)
        CLOSE (UNIT = LU26)
        CLOSE (UNIT = LU1)
        CLOSE (UNIT = LU16)
        OPEN (LU1,  FILE = NAMEFIL(1:KNMFIL)//'_sx.ins',
     1    STATUS = 'UNKNOWN')
        OPEN (LU16, FILE = NAMEFIL(1:KNMFIL)//'_sx.hkl',
     1    STATUS = 'UNKNOWN')
C * INS/RES + HKL
      ELSE IF (IGBL(29) /= -1) THEN
        IPR(2) = 71
        IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
        IGBL(1) = 3
        RETURN
      END IF
C * CREATE SCRATCH .INS & .HKL FILES FOR SHELXL201n REFINEMENT
      OPEN (LU62, FILE = 'x_dummy.hkl', STATUS = 'UNKNOWN')
      REWIND (UNIT = LU16, IOSTAT = IOST)
      DO
        READ (LU16, 99999, IOSTAT = IOST) DUM
        IF (IOST /= 0) EXIT
        WRITE (LU62, 99999) DUM
      END DO
      IF (IGBL(29) > 0) THEN
        CLOSE (UNIT = LU16, STATUS = 'DELETE')
      ELSE
        CLOSE (UNIT = LU16)
      END IF
      CLOSE (UNIT = LU62)
C * OUTER REFINEMENT LOOP - GET NUMBER OF MAJOR REFINEMENT LOOPS
      LU       = LU1
      NLOOP    = 1
      NLOOPMAX = IPR(682)
      DO
        OPEN (LU62, FILE = 'x_dummy.ins', STATUS = 'UNKNOWN')
        REWIND (UNIT = LU, IOSTAT = IOST)
        DO
          READ (LU, 99999, IOSTAT = IOST) DUM
          IF (IOST /= 0) EXIT
          IF (DUM(1:3) == 'REM') THEN
          ELSE IF (DUM(1:4) == 'L.S.') THEN
            CALL GEN072 (DUM, IFL, FN, KL, KN, 0, 0, 1, 5, 80, 7, NP17)
            WRITE (LU62, 99995) (IPR(619) + 1) * 4
            FN(1) = 5
            WRITE (DUM, 99996) 'L.S.', (NINT (FN(I)), I = 1, KN)
            WRITE (LU6, 99999) ':: Substituted:'//DUM(1:65)
          ELSE IF (DUM(1:4) == 'LIST') THEN
            CYCLE
          ELSE IF (DUM(1:4) == 'ACTA') THEN
            CYCLE
          ELSE IF (DUM(1:4) == 'DAMP') THEN
            WRITE (LU6, 99999) 'Deleted:    '//DUM(1:65)
            CYCLE
          ELSE IF (DUM(1:4) == 'MORE') THEN
            WRITE (LU6, 99999) 'Deleted:    '//DUM(1:65)
            CYCLE
          ELSE IF (DUM(1:4) == 'WPDB') THEN
            WRITE (LU6, 99999) 'Deleted:    '//DUM(1:65)
            CYCLE
          ELSE IF (DUM(1:4) == 'OMIT') THEN
            CALL GEN072 (DUM, IFL, FN, KL, KN, 0, 0, 1, 5, 80, 7, NP17)
            IF (KN == 3)
     1         WRITE (LU6, 99999) ':: Omitted:   '//DUM(1:65)
          END IF
          WRITE (LU62, 99999) DUM
        END DO
        IF (IPR(663) /= 0) THEN
          CLOSE (UNIT = LU, STATUS = 'DELETE')
          IPR(663) = 0
        ELSE
          CLOSE (UNIT = LU)
        END IF
        CLOSE (UNIT = LU62)
C * REFINE AND CREATE .cif AND .fcf IN A SPAWNED SHELXL201n JOB
        KERR = 0
        CALL SPAWN (SHLPATH(1:IGBL(110))//' x_dummy', LU6, .true., KERR)
C * REGISTER REFINEMENT RESULTS
        OPEN (LU61, FILE = 'x_dummy.cif', STATUS = 'UNKNOWN')
        DO
          READ (LU61, 99999, IOSTAT = IOST) DUM
          IF (IOST /= 0) EXIT
          IF (DUM(1:22) == '_refine_ls_R_factor_gt') THEN
            READ (DUM(34:40), *) RESULTX(NLOOP, 1)
          ELSE IF (DUM(1:24) == '_refine_ls_wR_factor_ref') THEN
            READ (DUM(34:40), *) RESULTX(NLOOP, 2)
          ELSE IF (DUM(1:30) == '_refine_ls_goodness_of_fit_ref') THEN
            READ (DUM(34:40), *) RESULTX(NLOOP, 3)
          ELSE IF (DUM(1:24) == '_refine_diff_density_max') THEN
            READ (DUM(25:33), *) RESULTX(NLOOP, 4)
          ELSE IF (DUM(1:24) == '_refine_diff_density_min') THEN
            READ (DUM(25:33), *) RESULTX(NLOOP, 5)
            EXIT
          END IF
        END DO
        CLOSE (UNIT = LU61)
C * RUN SPAWNED PLATON/SQUEEZE JOB
        KERR = 0
        CALL SPAWN (PLAPATH(1:IGBL(80))//' -q x_dummy.cif', LU6, .true.,
     1    KERR)
C * REGISTER SQUEEZE RESULT
        OPEN (LU61, FILE = 'x_dummy_sq.sqz', STATUS = 'UNKNOWN')
        DO
          READ (LU61, 99999, IOSTAT = IOST) DUM
          IF (IOST /= 0) EXIT
          IF (DUM(1:9) == '# Solvent') THEN
            READ (DUM(30:39), *) RESULTX(NLOOP, 7)
          ELSE IF (DUM(1:11) == '# Electrons') THEN
            READ (DUM(30:39), *) RESULTX(NLOOP, 6)
            EXIT
          END IF
        END DO
        CLOSE (UNIT = LU61)
C * TERMINATION TEST AND HANDLING
        IF (NLOOP > 1) THEN
          IF (NINT (RESULTX(NLOOP, 6)) == NINT (RESULTX(NLOOP - 1, 6)))
     1      NLOOPMAX = NLOOP
        END IF
        IF (NLOOP < NLOOPMAX) THEN
          NLOOP = NLOOP + 1
C * COPY HKL & RES FILES FOR SCRATCH USE
C * COPY FAB FILE
          OPEN (LU61, FILE = 'x_dummy_sq.fab', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = 'x_dummy.fab',    STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUM
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUM
          END DO
          CLOSE (UNIT = LU61)
          CLOSE (UNIT = LU62)
C * COPY 'RES' FILE
          OPEN (LU61, FILE = 'x_dummy_sq.ins', STATUS = 'UNKNOWN')
          LU = LU61
        ELSE
C * FINAL FILE RENAME TO NAME_sq.ins
          OPEN (LU61, FILE = 'x_dummy_sq.ins', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.ins',
     1      STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUM
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUM
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
C * FINAL FILE RENAME TO NAME_sq.hkl
          OPEN (LU61, FILE = 'x_dummy_sq.hkl', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.hkl',
     1      STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUM
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUM
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
C * FINAL FILE RENAME TO NAME_sq.fab
          OPEN (LU61, FILE = 'x_dummy_sq.fab', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.fab',
     1      STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUM
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUM
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
C * FINAL FILE RENAME TO NAME_sq.sqz
          OPEN (LU61, FILE = 'x_dummy_sq.sqz', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.sqz',
     1      STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUM
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUM
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
C * FINAL FILE RENAME TO NAME_sq.sqf
          OPEN (LU61, FILE = 'x_dummy_sq.sqf', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.sqf',
     1      STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUM
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUM
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
C * FINAL FILE RENAME TO NAME_sq.lis
          OPEN (LU61, FILE = 'x_dummy_sq.lis', STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_sq.lis',
     1      STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99999, IOSTAT = IOST) DUMA
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99999) DUMA
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
C * REMOVE INTERMEDIATES
          OPEN (LU61, FILE = 'x_dummy.ins', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.res', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.eld', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.fab', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.hkl', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.cif', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.lst', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          OPEN (LU61, FILE = 'x_dummy.fcf', STATUS = 'UNKNOWN')
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          WRITE (LU6, 99998)
          DO I = 1, NLOOPMAX
            WRITE (LU6, 99997) I, (RESULTX(I, J), J = 1, 5),
     1        (NINT (RESULTX(I, J)), J = 6, 7)
          END DO
          IF (IPR(2) == 0) IPR(2) = -1
C * ERROR HANDLING
          IGBL(1) = 3
          EXIT
        END IF
      END DO
      RETURN
99999 FORMAT (A)
99998 FORMAT (//, ':: HYBRID: SQUEEZE/SHELXL LOOP RESULTS', //,
     1 '  -------------S.H.E.L.X.L.2.0.n.m--------- -----SQUEEZE----',/,
     1 '  CYC      R1     wR2       S RhoMax RhoMin Electrons Volume')
99997 FORMAT (I5, 3F8.4, 2F6.2, 2I8)
99996 FORMAT (A, I3, 10I5)
99995 FORMAT ('ACTA', /, 'LIST', I3)
      END SUBROUTINE PLA131
 
      SUBROUTINE PLA132 (IH, IK, IL, XI, SIGI, SIGIW, CALI, UCINT,
     1 ACALS, BCALS)
C * GET REFLECTION DATA FROM VARIOUS FCF & HKL FILE FORMATS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE mentry
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: M
      INTEGER            :: NB
      INTEGER            :: NE
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      INTEGER            :: ID1
      INTEGER            :: ID2
      INTEGER, SAVE      :: IH0
      INTEGER, SAVE      :: IK0
      INTEGER, SAVE      :: IL0
      INTEGER            :: NCR
      INTEGER            :: NBAT
      INTEGER            :: IDIF
      INTEGER            :: IDTW
      INTEGER, SAVE      :: HMAX
      INTEGER, SAVE      :: KMAX
      INTEGER, SAVE      :: LMAX
      INTEGER            :: IDIND
      INTEGER            :: IOSTY
      INTEGER            :: IYUNK
      INTEGER            :: NSKIP
      INTEGER            :: MARKER
      INTEGER            :: GEN135
      REAL               :: XI
      REAL               :: YI
      REAL               :: FC
      REAL               :: TH
      REAL               :: YI1
      REAL               :: YI2
      REAL               :: ACAL
      REAL               :: BCAL
      REAL               :: DLDS
      REAL               :: SIGI
      REAL               :: CALI
      REAL               :: STHK
      REAL               :: YUNK
      REAL               :: SIGIW
      REAL               :: XFCAL
      REAL               :: XFOBS
      REAL               :: XSIGI
      REAL               :: UCINT
      REAL               :: ACALS
      REAL               :: BCALS
      REAL               :: XSIGIW
      REAL               :: GEN095
      REAL               :: PLA183
      REAL, DIMENSION(2) :: XINT
      CHARACTER(len=5)   :: CNT
      CHARACTER(len=4)   :: FOFC
      CHARACTER(len=4)   :: INEX
      CHARACTER(len=1)   :: STATUSX
C * IEND = -1 : Initialize
C *      =  0 : Next Reflection
C *      =  1 : Termination
      CALI   = 0.0
      UCINT  = 0.0
      ACALS  = 0.0
      BCALS  = 0.0
      ABSCOR = 1.0
C * INITIALIZE
      IF (IEND == -1) THEN
        ISKIP    = 0
        ITSKP    = 0
        SHXMP    = 1.0
        PAR(166) = 0.0
C * CHECK FOR HKL GENERATE MODE
        IF (IPR(408) == 1) THEN
          PAR(287) = PAR(540)
          PAR(165) = ASIN (MIN (1.0, PAR(287) * PAR(17))) * RGBL(6)
C * CHECK EXPECT MODE
        ELSE IF (IPR(408) == 2 .AND. PAR(168) > 0.0) THEN
          PAR(165) = PAR(168)
          IF (PAR(17) > 0)
     1      PAR(287) = SIN (PAR(165) / RGBL(6)) / PAR(17)
        END IF
        STHKM = (SIN (PAR(165) / RGBL(6)) / PAR(17))**2
C * HANDLE HKL TRANSFORMATION MATRICES
        IF (IABS (IGBL(8)) /= 2) THEN
C * COPY TM1 TO TRMX
          CALL GEN052 (TM1, TRMX)
        ELSE
C * SHELX-HKLF MATRIX
          IF ((IGBL(9) <= 0 .OR. IABS (IGBL(8)) == 2) .AND.
     1        IPR(408) /= 2) THEN
            K = 230
            DO I = 1, 3
              DO J = 1, 3
                K = K + 1
                TRMX(I, J) = PAR(K)
              END DO
            END DO
          ELSE
C * INIT TO UNIT MATRIX
            CALL GEN021 (TRMX, 1.0)
          END IF
        END IF
        UNITMAT = GEN135 (TRMX)
        WRITE (LU6, 99981, IOSTAT = IOST)
     1    ((TRMX(I, J), J = 1, 3), I = 1, 3)
        WRITE (LU6, 99979, IOSTAT = IOST) (PAR(I), I = 101, 106)
        CALL GEN074 (V2, 1, 3, 0.0)
        CALL GEN074 (V3, 1, 3, 0.0)
        NDEC = 0
C * GET REFLECTION DATA - SHELX(L) HKLF 4 FORMAT or FCF-CIF
        IF (IPR(408) <= 0) THEN
          FOFC = 'FoFc'
          IF (IPR(132) == 0) THEN
            FOFC = ' OBS'
          ELSE IF (IPR(132) == 1) THEN
            FOFC = 'CALC'
          ELSE IF (IPR(132) == 2) THEN
            FOFC = 'DELT'
          ELSE IF (IPR(132) == 3) THEN
            FOFC = 'DELG'
          END IF
          WRITE (LU6, 99998, IOSTAT = IOST) FNLU16(1:KNM16), FOFC
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99998, IOSTAT = IOST) FNLU16(1:KNM16), FOFC
          END IF
C * REWIND
          CALL GEN108 (LU16, 0)
C * FCF-CIF (SHELXL ETC.)
C * LOAD MATCHING DATA-SET
          IGBL(9) = IENTRY(IGBL(54), 3)
          IF (IGBL(9) > 0) THEN
            NSKIP = IENTRY(IGBL(54), 4)
            IF (NSKIP > 0) THEN
              DO I = 1, NSKIP
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) EXIT
                IF (IABS (IGBL(8)) /= 3) GO TO 10
              END DO
              GO TO 10
            END IF
            IPR(2) = 69
C * OPEN FCF-CHECK OUTPUT
            INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.ckf',
     1               OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU13, FILE = NAMEFIL(1:KNMFIL) //'.ckf',
     1              STATUS = 'UNKNOWN')
            END IF
C * COUNT # 900 ALERTS
            IPR(659) = IPR(659) + 1
            IF (IPR(659) == 1) THEN
              WRITE (LU13, 99990, IOSTAT = IOST) JID(1:10)
C * ALERT _900
              CALL PLA236 (900, 0, 1.0, 1.0, ' ', ' ')
              CALL PLA015 (0, 51)
            END IF
            IEND = 1
            RETURN
          END IF
C * HANDLE FILE TYPE HEADER SECTION UP TO FIRST REFLECTION DATA
   10     SELECT CASE (IGBL(9))
C * FCF TYPE 1 - SHELXL
            CASE (1)
              SHXMP = 1.0
              NDEC  = 2
              ICALC = 0
              IOBS  = 0
              IDIF  = 0
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST == 0) THEN
                  IF (INDEX (IDM, 'cell_') /= 0) THEN
                    IF (PAR(101) > 0.0 .AND. IABS (IGBL(8)) == 3)
     1                THEN
C * REMOVE SU WHEN PRESENT
                      M = INDEX (IDM, '(')
                      IF (M /= 0) IDM(M:) = '        '
                      NB = INDEX (IDM, '_cell_length_a')
                      IF (NB /= 0) THEN
                        READ (IDM(NB + 14:), *, IOSTAT = IOST) PAR(455)
                        DLDS = MAX (0.01, PAR(107) * 2.0)
                        IF (ABS (PAR(455) - PAR(101)) > DLDS .OR.
     1                    IOST /= 0) IDIF = IDIF + 1
                      ELSE
                        NB = INDEX (IDM, '_cell_length_b')
                        IF (NB /= 0) THEN
                          READ (IDM(NB + 14:), *, IOSTAT = IOST)
     1                      PAR(456)
                          DLDS = MAX (0.01, PAR(108) * 2.0)
                          IF (ABS(PAR(456) - PAR(102)) > DLDS .OR.
     1                      IOST /= 0) IDIF = IDIF + 1
                        ELSE
                          NB = INDEX (IDM, '_cell_length_c')
                          IF (NB /= 0) THEN
                            READ (IDM(NB + 14:), *, IOSTAT = IOST)
     1                        PAR(457)
                            DLDS = MAX (0.01, PAR(109) * 2.0)
                            IF (ABS(PAR(457) - PAR(103)) > DLDS .OR.
     1                        IOST /= 0) IDIF = IDIF + 1
                          ELSE
                            NB = INDEX (IDM, '_cell_angle_alpha')
                            IF (NB /= 0) THEN
                              READ (IDM(NB + 17:), *, IOSTAT = IOST)
     1                              PAR(458)
                              DLDS = MAX (0.01, PAR(110) * 2.0)
                              IF (ABS(PAR(458) - PAR(104)) > DLDS
     1                          .OR. IOST /= 0) IDIF = IDIF + 1
                            ELSE
                              NB = INDEX (IDM, '_cell_angle_beta')
                              IF (NB /= 0) THEN
                                READ (IDM(NB + 16:), *, IOSTAT = IOST)
     1                                PAR(459)
                                DLDS = MAX (0.01, PAR(111) * 2.0)
                                IF (ABS(PAR(459) - PAR(105)) > DLDS
     1                            .OR. IOST /= 0) IDIF = IDIF + 1
                              ELSE
                                NB = INDEX (IDM, '_cell_angle_gamma')
                                IF (NB /= 0) THEN
                                  READ (IDM(NB + 17:), *, IOSTAT = IOST)
     1                                  PAR(460)
                                  DLDS = MAX (0.01, PAR(112) * 2.0)
                                  IF (ABS (PAR(460) - PAR(106))
     1                              > DLDS .OR. IOST /= 0)
     2                              IDIF = IDIF + 1
                                END IF
                              END IF
                            END IF
                          END IF
                        END IF
                      END IF
                      IF (IDIF > 0) THEN
C * ALERT _901
                        IPR(674) = IPR(674) + 1
                        IPR(676) = 0
                        IF (IPR(674) == 1)
     1                    CALL PLA236 (901, 0, 1.0, 1.0, ' ', ' ')
                        IF (IGBL(22) == -1) THEN
                          WRITE (LU13, 99984, IOSTAT = IOST)
     1                      (PAR(M), M = 455, 460)
                          WRITE (LU13, 99986, IOSTAT = IOST)
                        END IF
                        IPR(2) = 76
                        IEND   = 2
                        RETURN
                      END IF
                    END IF
                  ELSE IF (INDEX (IDM, '_refln_F_squared_calc') /= 0)
     1                       THEN
                    IF (IOBS == 1) THEN
                      ICALC = 2
                    ELSE
                      ICALC = 1
                    END IF
                  ELSE IF (INDEX (IDM, '_refln_F_squared_meas') /= 0)
     1                     THEN
                    IF (ICALC == 1) THEN
                      IOBS = 2
                    ELSE
                      IOBS = 1
                    END IF
                  ELSE IF (INDEX (IDM, '_shelx_F_squared_multiplier')
     1                   /= 0) THEN
                    IYUNK = INDEX (IDM, '_shelx_F_squared_multiplier')
                    READ (IDM(IYUNK + 27:80), *, IOSTAT = IOST) SHXMP
                    IF (IOST /= 0) THEN
                      IEND = 1
                      RETURN
                    END IF
                  ELSE IF (INDEX (IDM, '_refln_observed_status') /= 0
     1                .OR. INDEX (IDM, '_refln_include_status') /= 0)
     2                     THEN
                    DO
                      READ (LU16, 99997, IOSTAT = IOST) IDM
                      IF (IOST /= 0) THEN
                        IEND = 1
                        RETURN
                      END IF
                      IF (INDEX (IDM, '_refln_sint/lambda') == 0) EXIT
                    END DO
                    BACKSPACE LU16
                    EXIT
                  ELSE IF (INDEX (IDM, '_twin_refln') /= 0) THEN
                    IEND = 1
                    RETURN
                  END IF
                ELSE
                  IEND = 1
                  RETURN
                END IF
              END DO
              IF (IPR(132) == 0 .AND. IOBS == 0 .OR.
     1            IPR(132) == 1 .AND. ICALC == 0) THEN
                IEND = 1
                RETURN
              END IF
C * FCF TYPE 2 - XTAL Fobs/Fcal
            CASE (2)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_scale_group_code') /= 0) EXIT
              END DO
              NDEC = 3
C * FCF TYPE 3 - NRCVAX
            CASE (3)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_F_squared_sigma') /= 0) EXIT
              END DO
              IOBS  = 1
              ICALC = 2
              NDEC  = 3
C * FCF TYPE 4 - MOLEN
            CASE (4)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_10*F_sigm') /= 0 .OR.
     1              INDEX (IDM, '_refln_F_10*sigm') /= 0) EXIT
              END DO
              IOBS  = 1
              ICALC = 2
              NDEC  = 0
              FMOL  = '(I4,2I3,2F7.0,F6.0)'
   20         READ (LU16, 99997, IOSTAT = IOST) IDM
              IF (IOST /= 0) THEN
                IEND = 1
                RETURN
              END IF
              NB = 1
              NE = 80
              CALL GEN039 (1, IDM, 1, 80, NB, NE)
              IF (NE == 0) THEN
                GO TO 20
              ELSE IF (NE == 31) THEN
                FMOL(3:3) = '5'
              END IF
             BACKSPACE LU16
C * FCF TYPE 5, 8, 17, 18 - CRYSTALS
            CASE (5, 8, 17, 18)
              IF (IGBL(9) == 17 .OR. IGBL(9) == 18) THEN
                PAR(564) = 0.0
                IPR(764) = 0
              END IF
C * READ UP TO FIRST '_refln_ DATANAME
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_') /= 0) EXIT
              END DO
C * LOOK FOR SELECTED DATANAMES
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
C * LOOK FOR WEIGHT DATANAME
                IF (INDEX (IDM, '_refln_refinement_weight') /= 0) THEN
C * SET WEIGHT TYPE
                  IF (IPR(632) == 0) IPR(632) = 5
                END IF
                IF (INDEX (IDM, '_refln_') == 0) EXIT
              END DO
              IOBS  = 1
              ICALC = 2
              BACKSPACE LU16
C * FCF TYPE 6, 10, 13 & 15 - TEXSAN1 & TEXSAN2 & TEXSAN3 &  RIGAKU
            CASE (6, 10, 13, 15)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_observed_status') /= 0 .OR.
     1              INDEX (IDM, '_refln_include_status') /= 0) EXIT
              END DO
C * FCF TYPE 7 - MOLEN1
            CASE (7)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_observed_status') /= 0) EXIT
              END DO
              IOBS  = 1
              ICALC = 2
              FMOL  = '(3I4,3F8.0)'
              BACKSPACE LU16
C * FCF TYPE 9 & 14 - JANA2
            CASE (9, 14, 16)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_observed_status') /= 0 .OR.
     1              INDEX (IDM, '_refln_include_status') /= 0) EXIT
              END DO
C * FCF TYPE 11 - XD
            CASE (11)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
                IF (INDEX (IDM, '_refln_XD_refine_code') /= 0) EXIT
              END DO
C * FCF TYPE 12 - RAELS - Fobs/Fcalc/sigma
            CASE (12)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  IF (INDEX (IDM, '_refln_F_sigma') /= 0) EXIT
                END IF
              END DO
C * HKL TYPE 21 - SHELXL - LIST3
            CASE (21)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  IF (INDEX (IDM, '_refln_B_calc') /= 0) EXIT
                END IF
              END DO
C * HKL TYPE 22 - SHELXL - LIST5
            CASE (22)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  IF (INDEX (IDM, '_refln_phase_calc') /= 0) EXIT
                END IF
              END DO
C * HKL TYPE 23 - SHELXL - LIST6
            CASE (23)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  IF (INDEX (IDM, '_refln_phase_calc') /= 0) EXIT
                END IF
              END DO
C * HKL TYPE 24 - SHELXL - LIST7
            CASE (24)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  READ (IDM, *, IOSTAT = IOST)
     1              IYUNK, IYUNK, IYUNK, YUNK, YUNK, YUNK, YUNK
                END IF
              END DO
C * HKL TYPE
C * DUMMY STATEMENT
              YUNK = YUNK + FLOAT (IYUNK)
              BACKSPACE LU16
C * HKL TYPE 25 - SHELXL - LIST8
            CASE (25)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  IF (INDEX (IDM, '_shelx_refinement_sigma') /= 0) EXIT
                END IF
              END DO
C * TYPE JANA-TWIN
            CASE (27)
              DO
                READ (LU16, 99997, IOSTAT = IOST) IDM
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                ELSE
                  IF (INDEX (IDM, '_twin_refln_include_status') /= 0)
     1            EXIT
                END IF
              END DO
            CASE DEFAULT
C * HKL TYPE 0 & -1 - SHELX-HKL
              READ (LU16, 99997, IOSTAT = IOST) PRBUF(1:20)
              IF (IOST /= 0) THEN
                IEND = 1
                RETURN
              ELSE
C * REWIND LU16
                CALL GEN108 (LU16, 0)
                NDEC = INDEX (PRBUF(13:20), '.')
                IF (NDEC > 0) NDEC = 8 - NDEC
C * DETERMINE SHORT/LONG SHELX HKLF RECORD
                IF (IGBL(9) == -1) THEN
                  IF (IPR(210) == -1)
     1              WRITE (LU6, 99999, IOSTAT = IOST)
                END IF
              END IF
          END SELECT
          PAR(230) = 10**NDEC
        ELSE
C * GENERATE REFLECTION SERIES
          HMAX = INT (2 * PAR(101) * PAR(287)) + 1
          KMAX = INT (2 * PAR(102) * PAR(287)) + 1
          LMAX = INT (2 * PAR(103) * PAR(287)) + 1
          IH0  = - HMAX - 1
          IK0  = - KMAX - 1
          IF ((IPR(408) == 1 .AND. IPR(257) == 1) .OR.
     1         IPR(408) == 2) THEN
            IL0 = - LMAX - 1
          ELSE
            IL0 = -1
          END IF
          XI       = 100000.00
          SIGI     = 10.00
          SIGIW    = SIGI
          PAR(230) = 1.0
        END IF
      END IF
C * TRANSFORM REFLECTIONS FOR SF-CALCULATION (EXCLUDE NON-INTEGRAL H,K,L)
      IF (IPR(408) <= 0) THEN
C * REFLECTION READ LOOP
   30   READ (LU16, 99997, IOSTAT = IOST) PRBUF
        IF (IOST /= 0) THEN
          IEND = 1
          RETURN
        END IF
C * REMOVE DOS <CR>
        NCR = INDEX (PRBUF, CHAR (13))
        IF (NCR /= 0) PRBUF(NCR:NCR) = ' '
C * SELECT REFLECTION FILE TYPE
        SELECT CASE (IGBL(9))
C * HKL TYPE 0 - HKLF
          CASE (0)
            IF (IGBL(37) == 0) THEN
              READ (PRBUF, 99987, IOSTAT = IOST)
     1        IH, IK, IL, XI, SIGI, NBAT
            ELSE
              READ (PRBUF, 99987, IOSTAT = IOST)
     1        IH, IK, IL, XI, SIGI, NBAT, (V2(I), V3(I), I = 1, 3)
            END IF
            IF (IH == 0 .AND. IK == 0 .AND. IL == 0) THEN
              IEND = 1
              RETURN
            END IF
C * EXCLUDE TWIN COMPONENTS
            IF (NBAT < 0) GO TO 30
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (NBAT > 1 .AND. IPR(193) < 100) THEN
              IF (IPR(513) >= NBAT - 1 .AND. IPR(513) > 0) THEN
                XI   = BASF(NBAT - 1) * XI
                SIGI = BASF(NBAT - 1) * SIGI
              END IF
            END IF
            CALI  = XI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * HKL TYPE -1 - HKLF - EXTENDED
          CASE (-1)
            READ (PRBUF, 99996, IOSTAT = IOST) IH, IK, IL, XI, SIGI,
     1        (V2(I), V3(I), I = 1, 3), UCINT, ACALS, BCALS, ABSCOR
            IF (IOST == -1) GO TO 30
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * FCF TYPE 1 - SHELXL LIST 4
          CASE (1)
            CNT = PRBUF(1:5)
            IF (CNT == 'data_') THEN
              IEND = 1
              RETURN
            ELSE IF (CNT == '     ') THEN
              GO TO 30
            ELSE
              READ (PRBUF, *, IOSTAT = IOST) IH, IK, IL,
     1             (XINT(I), I = 1, 2), SIGI, STATUSX
              IF (IOST /= 0) THEN
C * TRY SHELXL FIXED FORMAT
                READ (PRBUF, 99991, IOSTAT = IOST) IH, IK, IL,
     1            (XINT(I), I = 1, 2), SIGI, STATUSX
                IF (IOST /= 0) THEN
                  IEND = 1
                  RETURN
                END IF
              END IF
            END IF
C * EXCLUDE 'x' AND '-' FLAGGED REFLECTIONS
            IF (STATUSX == 'x' .OR. STATUSX == '-') THEN
              WRITE (LU6, 99977) IH, IK, IL, STATUSX
              GO TO 30
            END IF
            XI   = XINT(IOBS)  * SHXMP
            YI   = XINT(ICALC) * SHXMP
            CALI = YI
            IF (IPR(132) == 1) THEN
              XI = YI
            ELSE IF (IPR(132) == 2) THEN
              XI = ABS (XI - YI)
            ELSE IF (IPR(132) == 3) THEN
              XI = MAX (XI - YI, 0.0)
            ELSE IF (IPR(132) == -1) THEN
              UCINT = YI
            END IF
            SIGI = MAX (0.0, SIGI * SHXMP)
            IF (PAR(493) >= 0.0 .OR. PAR(494) >= 0.0) THEN
C * SHELXL WEIGHT
              IF (IABS (IPR(632)) == 1) THEN
                SIGIW = PLA183 (IH, IK, IL, XI, YI, SIGI)
C * JANA WEIGHT
              ELSE IF (IPR(632) == 2) THEN
                SIGIW = SQRT (SIGI**2 + PAR(493) * XI**2)
              ELSE
                SIGIW = SIGI
              END IF
            ELSE
              SIGIW = SIGI
            END IF
C * FCF TYPE 2 - XTAL-F
          CASE (2)
            READ (PRBUF, 99995, IOSTAT = IOST) IH, IK, IL, XFOBS, XFCAL,
     1                                     XSIGI
            IF (IOST == -1) GO TO 30
            XI    = XFOBS**2
            SIGI  = 2.0 * SQRT (XI) * XSIGI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * FCF TYPE 3 - NRCVAX
          CASE (3)
            READ (PRBUF, 99994, IOSTAT = IOST) IH, IK, IL,
     1            (XINT(I), I = 1, 2), SIGI
            IF (IOST > 0) GO TO 30
            XI = XINT(IOBS)  * SHXMP
            YI = XINT(ICALC) * SHXMP
            IF (IPR(132) == 1) XI = YI
            SIGI  = MAX (0.0, SIGI * SHXMP)
            SIGIW = SIGI
C * FCF TYPE 4 & 7 - MOLEN & MOLEN1 FCF
          CASE (4, 7)
            READ (PRBUF, FMOL, IOSTAT = IOST) IH, IK, IL,
     1        XFOBS, XFCAL, XSIGI
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (IABS (IH) + IABS (IK) + IABS (IL) == 0) GO TO 30
            XI   = XFOBS**2
            SIGI = 2.0 * SQRT(XI) * XSIGI
            CALI = XFCAL**2
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * FCF TYPE 5 - CRYSTALS FCF(F)
          CASE (5)
            IF (IPR(769) == 0) THEN
              READ (PRBUF, 99993, IOSTAT = IOST) IH, IK, IL,
     1              XFOBS, XFCAL, XSIGI, STATUSX, XSIGIW
              INEX = '    '
            ELSE
              READ (PRBUF, 99980, IOSTAT = IOST) IH, IK, IL,
     1              XFOBS, XFCAL, XSIGI, STATUSX, INEX, XSIGIW
            END IF
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
C * ELIMINATE 'SPECIAL' REFLECTIONS
            IF (STATUSX == 'x' .OR. STATUSX == '<' .OR.
     1          STATUSX == 'l' .OR. STATUSX == 'h') GO TO 30
            IF (XSIGIW <= 0.0) GO TO 30
            IF (INEX == 'excl') GO TO 30
            XI    = SIGN (ABS (XFOBS)**2, XFOBS)
            SIGI  = 2.0 * ABS (XFOBS) * XSIGI
            SIGIW = 2.0 * ABS (XFOBS) / SQRT (XSIGIW)
            CALI  = XFCAL**2
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
C * FCF TYPE 6 - TEXSAN1 FCF
          CASE (6)
            READ (PRBUF, 99992, IOSTAT = IOST)
     1        IH, IK, IL, XFOBS, XSIGI, XFCAL
            IF (IOST /= 0) THEN
              IF (PRBUF(1:1) == '#') THEN
                IEND = 1
                RETURN
              END IF
              IF (INDEX (PRBUF, 'data_') /= 0) THEN
                IEND = 1
                RETURN
              END IF
C * ERROR IN RECORD
              WRITE (LU6, 99988, IOSTAT = IOST) PRBUF(1:65)
              GO TO 30
            END IF
            XI = SIGN (XFOBS**2, XFOBS)
            IF (XFOBS > XSIGI / 2.0) THEN
              SIGI = 2.0 * ABS (XFOBS) * XSIGI
            ELSE
              SIGI = 2.0 * ABS (XFCAL) * XSIGI
            END IF
            CALI = XFCAL**2
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * FCF TYPE 8 - CRYSTALS FCF(I)
          CASE (8)
            READ (PRBUF, 99993, IOSTAT = IOST) IH, IK, IL,
     1            XI, CALI, SIGI, STATUSX, SIGIW
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
C * GET TH-MAX INCLUDING EXCLUDED REFLECTIONS
            STHK = GEN095 (PAR(191), IH, IK, IL)
            TH   = ASIN (SQRT (STHK) * PAR(17)) * RGBL(6)
            PAR(517) = MAX (PAR(517), TH)
            IF (STATUSX == 'x' .OR. STATUSX == '<' .OR.
     1          STATUSX == 'l' .OR. STATUSX == 'h') GO TO 30
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            IF (SIGIW /= 0.0) THEN
              SIGIW = 1.0 / SQRT (SIGIW)
            ELSE
              SIGIW = 0.1E+15
            END IF
C * FCF TYPE 9 - JANA
          CASE (9)
            READ (PRBUF, *, IOSTAT = IOST) IH, IK, IL,
     1            XI, CALI, SIGI
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            IF (PAR(493) > 0.0) THEN
              SIGIW = SQRT (SIGI**2 + PAR(493) * (MAX (XI, 0.0))**2)
            ELSE
              SIGIW = SIGI
            END IF
C * FCF TYPE 16 - JANA3
          CASE (16)
            READ (PRBUF, 99976, IOSTAT = IOST)
     1        IH, IK, IL, CALI, XI, SIGI, STATUSX
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (IH == 0 .AND. IK == 0 .AND. IL == 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            IF (PAR(493) > 0.0) THEN
              SIGIW = SQRT (SIGI**2 + PAR(493) * (MAX (XI, 0.0))**2)
            ELSE
              SIGIW = SIGI
            END IF
C * FCF TYPE 17 - CRYSTALS FCF(I,TWIN)
          CASE (17)
C * QUIET NAG COMPILER FOR ID1
            ID2 = ID1
            READ (PRBUF, 99975, IOSTAT = IOST) ID1, ID2,
     1            IH, IK, IL, XI, CALI, SIGI, STATUSX, INEX, SIGIW
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (ID2 > 1) GO TO 30
C * GET TH-MAX INCLUDING EXCLUDED REFLECTIONS
            STHK = GEN095 (PAR(191), IH, IK, IL)
            TH   = ASIN (SQRT (STHK) * PAR(17)) * RGBL(6)
            IF (STATUSX == 'x' .OR.
     1          STATUSX == 'l' .OR. STATUSX == 'h') GO TO 30
            PAR(517) = MAX (PAR(517), TH)
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            IF (SIGIW /= 0.0) THEN
              IF(INEX == 'incl') THEN
                PAR(564) = PAR(564) + SIGIW*(XI - CALI)**2
                IPR(764) = IPR(764) + 1
              END IF
              SIGIW = 1.0 / SQRT (SIGIW)
            ELSE
              SIGIW = 0.1E+15
            END IF
            IF (XI > 2*SIGI) IPR(747) = IPR(747) + 1
            IPR(748) = IPR(748) + 1
C * FCF TYPE 18 - CRYSTALS FCF(I) + incl/excl
          CASE (18)
            READ (PRBUF, 99989, IOSTAT = IOST) IH, IK, IL,
     1        XI, CALI, SIGI, STATUSX, INEX, SIGIW
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (STATUSX == 'x' .OR.
     1          STATUSX == 'l' .OR. STATUSX == 'h') GO TO 30
C * GET TH-MAX INCLUDING EXCLUDED REFLECTIONS
            STHK = GEN095 (PAR(191), IH, IK, IL)
            TH   = ASIN (SQRT (STHK) * PAR(17)) * RGBL(6)
            PAR(517) = MAX (PAR(517), TH)
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            IF (SIGIW /= 0.0) THEN
              IF(INEX == 'incl') THEN
                PAR(564) = PAR(564) + SIGIW*(XI - CALI)**2
                IPR(764) = IPR(764) + 1
              END IF
              SIGIW = 1.0 / SQRT (SIGIW)
            ELSE
              SIGIW = 0.1E+15
            END IF
C * FCF TYPE 10 - TEXSAN2 FCF
          CASE (10)
            READ (PRBUF, 99985, IOSTAT = IOST)
     1              IH, IK, IL, CALI, XI, SIGI
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * FCF TYPE 11 - XD
          CASE (11)
            MARKER = 0
            READ (PRBUF, *, IOSTAT = IOST) IH, IK, IL,
     1            CALI, XI, SIGI, YUNK, MARKER
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (MARKER /= 0) THEN
              GO TO 30
            ELSE
              GO TO 40
            END IF
            READ (PRBUF, *, IOSTAT = IOST) IH, IK, IL,
     1            CALI, XI, SIGI, YUNK
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
   40       IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
C * SHELXL STYLE WEIGHT
            IF (IABS(IPR(632)) == 1) THEN
              SIGIW = PLA183 (IH, IK, IL, XI, CALI, SIGI)
            ELSE
              SIGIW = SIGI
            END IF
C * FCF TYPE 12 - RAELS FCF
          CASE (12)
            READ (PRBUF, 99982, IOSTAT = IOST) IH, IK, IL,
     1            XFOBS, XFCAL, XSIGI
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            XI   = SIGN (ABS (XFOBS)**2, XFOBS)
            SIGI = 2.0 * ABS (XFOBS) * XSIGI
            CALI = XFCAL**2
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
C * FCF TYPE 13,15 - TEXSAN3/RIGAKU FCF
          CASE (13, 15)
            READ (PRBUF, *, IOSTAT = IOSTY)
     1              IH, IK, IL, XI, SIGI, CALI
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * JANA1 FCF
          CASE (14)
            READ (PRBUF, 99978, IOSTAT = IOST) IH, IK, IL,
     1            XFOBS, XFCAL, XSIGI
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            XI   = SIGN (ABS (XFOBS)**2, XFOBS)
            SIGI = 2.0 * ABS (XFOBS) * XSIGI
            CALI = XFCAL**2
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * HKL TYPE 21 - SHELXL - LIST3
          CASE (21)
            READ (PRBUF, *, IOSTAT = IOST)
     1        IH, IK, IL, XFOBS, XSIGI, ACAL, BCAL
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            XI   = XFOBS**2
            SIGI = 2.0 * XFOBS * XSIGI
            YI   = ACAL**2 + BCAL**2
            CALI = YI
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * HKL TYPE 22 - SHELXL - LIST5
          CASE (22)
            READ (PRBUF, 99983, IOSTAT = IOST)
     1            IH, IK, IL, XFOBS, XFCAL
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            IF (IH == 0 .AND. IK == 0 .AND. IL == 0) THEN
              IEND = 1
              RETURN
            END IF
C * HKL TYPE 23 - SHELXL - LIST6
          CASE (23)
            IH   = 0
            IK   = 0
            IL   = 0
            READ (PRBUF, *, IOSTAT = IOST)
     1        IH, IK, IL, XI, SIGI, FC
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            YI   = FC ** 2
            CALI = YI
            IF (IPR(132) == -1) UCINT = CALI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * HKL TYPE 24 - SHELXL - LIST 7
          CASE (24)
            READ (PRBUF, *, IOSTAT = IOST)
     1        IH, IK, IL, XI, SIGI, YI1, YI2
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            YI = 0.0
            IF (YI1 > 0.0) YI = YI1
            IF (YI2 > 0.0) YI = YI + YI2
            CALI  = YI
            UCINT = YI
            SIGI  = MAX (0.0, SIGI)
            SIGIW = SIGI
C * HKL TYPE 25 - SHELXL - LIST 8
          CASE (25)
            READ (PRBUF, *, IOSTAT = IOST)
     1        IH, IK, IL, XI, SIGI, YI, YUNK, YUNK, SIGIW
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
            CALI = YI
            IF (IPR(132) == -1) UCINT = CALI
C * JANA-TW TYPE 27
          CASE (27)
            READ (PRBUF, *, IOSTAT= IOST) IDTW, IDIND, IH, IK, IL,
     1        CALI, XI, SIGI
C * DUMMY INSTRUCTION TO SATISFY FTNCHEK
            IDTW = IDTW * 0
            IF (IOST /= 0) THEN
              IEND = 1
              RETURN
            END IF
C * CHECK FOR SKIP THIS REFLECTION
            IF (IDIND /= 1) GO TO 30
            IF (IPR(132) == -1) UCINT = CALI
            SIGI = MAX (0.0, SIGI)
            IF (PAR(493) > 0.0) THEN
              SIGIW = SQRT (SIGI**2 + PAR(493) * (MAX (XI, 0.0))**2)
            ELSE
              SIGIW = SIGI
            END IF
        END SELECT
C * ELIMINATE SHELXL OMIT REFLECTIONS
        M = IPR(620)
        IF (M /= 0) THEN
          DO I = 1, M
            IF (IH == IHKLOMIT(1, I) .AND. IK == IHKLOMIT(2, I)
     1        .AND. IL == IHKLOMIT(3, I)) GO TO 30
          END DO
        END IF
      ELSE
C * GENERATE REFLECTION INDICES
        GO TO 70
   50   IL0 = IL0 + 1
        IF (IL0 > LMAX) THEN
          IEND = 1
          RETURN
        END IF
        IK0 = - KMAX - 1
   60   IK0 = IK0 + 1
        IF (IK0 > KMAX) GO TO 50
        IH0 = - HMAX - 1
   70   DO
          IH0 = IH0 + 1
          IF (IH0 > HMAX) GO TO 60
C * SKIP 0 0 0 REFLECTION
          IF (IABS (IH0) + IABS (IK0) + IABS (IL0) == 0) CYCLE
C * ACCEPT WHEN WITHIN RESOLUTION SPHERE
          IF (SQRT (GEN095 (PAR(191), IH0, IK0, IL0)) < PAR(287) +
     1      0.00001)  EXIT
        END DO
        IH = IH0
        IK = IK0
        IL = IL0
      END IF
      IEND = 0
      RETURN
99999 FORMAT (':: Expanded HKLF Data Record found',
     1        ' (SQUEEZE contribution added - if any)')
99998 FORMAT (/, ':: Reflection Data are READ from File : ', A,
     1        ' - (', A, '-Data)')
99997 FORMAT (A)
99996 FORMAT (3I4, 2F8.0, 4X, 6F8.5, F8.0, 2F8.0, F8.4)
99995 FORMAT (I5, 2I4, 3F8.0)
99994 FORMAT (I4, 2I5, 3F10.3)
99993 FORMAT (3I4, 3F12.2, 1X, A, E13.4)
99992 FORMAT (I4, 2I5, 3F11.2)
99991 FORMAT (3I4, 2F14.2, F13.2, 1X, A)
99990 FORMAT (/, ':: No Matching Reflection Data Entry found for ', A)
99989 FORMAT (3I4, 3F12.2, 2(1X, A), E13.4)
99988 FORMAT (/, 'ERROR/SKIPPED: ', A)
99987 FORMAT (3I4, 2F8.0, I4, 6F8.5)
99986 FORMAT (/, ':: CIF & FCF CELL DIMENSIONS Inconsistent (ABORT!)',
     1        /)
99985 FORMAT (3I4, 2F12.2, F10.2)
99984 FORMAT ('Unit Cell (FCF)  : ', 3F9.4, 3F9.3)
99983 FORMAT (3I4, 2F10.0, F7.0)
99982 FORMAT (3I4, 2F9.0, F7.0)
99981 FORMAT (/, ':: TRMX = (', 3F6.2, '/', 3F6.2, '/', 3F6.2, ')')
99980 FORMAT (3I4, 3F12.2, 2(1X, A), E13.4)
99979 FORMAT (':: CELL =', 6F10.3)
99978 FORMAT (3I4, 3F10.0)
99977 FORMAT (3I4, 1X, 'Flag = ', A, ' Removed')
99976 FORMAT (3I4, 3F9.0, 1X, A)
99975 FORMAT (I10, I2, 3I4, 3F12.2, 2(1X, A), E13.4)
      END SUBROUTINE PLA132
 
      SUBROUTINE PLA133 (NREF, HMAX, KMAX, LMAX)
C * DETERMINE HMAX, KMAX & LMAX
      USE files
      USE parameters
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: NS
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: IHT
      INTEGER               :: IKT
      INTEGER               :: ILT
      INTEGER               :: NFAB
      INTEGER               :: HMAX
      INTEGER               :: KMAX
      INTEGER               :: LMAX
      INTEGER               :: MPH0
      INTEGER               :: MPK0
      INTEGER               :: MPL0
      INTEGER               :: NREF
      INTEGER               :: MHK0
      INTEGER               :: MHKL0
      INTEGER               :: IADR0
      INTEGER               :: IHKL0
      INTEGER               :: HMAX0
      INTEGER               :: KMAX0
      INTEGER               :: LMAX0
      INTEGER               :: IHEXL
      INTEGER               :: NSYMH
      INTEGER               :: MHKLH0
      INTEGER, DIMENSION(3) :: IND
      REAL                  :: XI
      REAL                  :: PHI
      REAL                  :: SIGI
      REAL                  :: YUNK
      REAL                  :: ASOL
      REAL                  :: BSOL
      REAL                  :: FSOL
      REAL                  :: ASOL0
      REAL                  :: BSOL0
      REAL                  :: ACALS
      REAL                  :: BCALS
      REAL                  :: SIGIW
      REAL                  :: UCINT
      CHARACTER(len=80)     :: IDUM
C * FILES: LU26 - FAB FILE
C *        LU27 - (TRANSFORMED) HKL FILE PREPARED BY PLA134
C * TEST FOR AND HANDLE HEXAGONAL LATTICE TYPE
      IF (IPR(259) == 5 .OR. IPR(259) == 6) THEN
        IHEXL = 1
      ELSE
        IHEXL = 0
      END IF
C * HANDLE FAB FILE (LU26)
      IF (IPR(665) /= 0) THEN
C * GET MAX H,K,L FOR REFLECTIONS IN FAB FILE
        NSYMH = IPR(255)
        HMAX0 = -999
        KMAX0 = -999
        LMAX0 = -999
        REWIND (UNIT = LU26, IOSTAT = IOST)
        WRITE (LU6, 99998)
        DO
          READ (LU26, *, IOSTAT = IOST) IH, IK, IL, ASOL, BSOL
          IF (IOST /= 0) EXIT
          IF (IH == 0 .AND. IK == 0 .AND. IL == 0) EXIT
C * KEEP TRACK OF REFLECTION INDEX MAXIMA
          DO I = 1, NSYMH
            SGX(1) = IH
            SGX(2) = IK
            SGX(3) = IL
            NS     = I
            CALL SGSM (5, IDUM, SGX, NS, 0, IERR)
            HMAX0 = MAX (HMAX0, IABS (NINT (SGX(7))))
            KMAX0 = MAX (KMAX0, IABS (NINT (SGX(8))))
            LMAX0 = MAX (LMAX0, IABS (NINT (SGX(9))))
          END DO
        END DO
C * DETERMINE PACKING CONSTANTS AND ADRESSES
        MPH0   = 2 * HMAX0 + 1
        MPK0   = 2 * KMAX0 + 1
        MPL0   = 2 * LMAX0 + 1
        MHK0   = MPH0 * MPK0
        MHKL0  = MPL0 * MHK0
        MHKLH0 = (MHKL0 - 1) / 2
C * TOP-DOWN STORAGE ARRAY OF REFLECTION ADDRESSES
C * CALCULATE ADDRESS OF 0,0,0 REFLECTION
        IADR0  = NVDR - MHKLH0
        CALL GEN074 (VOID, NVDR - MHKL0 + 1, NVDR, 0.0)
        REWIND (UNIT = LU26, IOSTAT = IOST)
        NFAB = 0
        WRITE (LU6, 99998)
        DO
          READ (LU26, *, IOSTAT = IOST) IH, IK, IL, ASOL, BSOL
          IF (IOST /= 0) EXIT
          IF (IH == 0 .AND. IK == 0 .AND. IL == 0) EXIT
          IF (ASOL.EQ. 0.0 .AND. BSOL == 0.0) THEN
            SGX(4) = 0.0
          ELSE
            SGX(4) = ATAN2 (BSOL, ASOL) * RGBL(6)
          END IF
          FSOL   = SQRT (ASOL**2 + BSOL**2)
          DO I = 1, NSYMH
            SGX(1) = IH
            SGX(2) = IK
            SGX(3) = IL
            NS     = I
            CALL SGSM (5, IDUM, SGX, NS, 0, IERR)
            DO J = 1, 3
              IND(J) = NINT (SGX(J + 6))
            END DO
            IHKL0 = IND(3) * MHK0 + IND(2) * MPH0 + IND(1)
            PHI            = SGX(10) / RGBL(6)
            ASOL0          = FSOL * COS (PHI)
            BSOL0          = FSOL * SIN (PHI)
            NFAB           = NFAB + 2
            VOID(NFAB - 1) = ASOL0
            VOID(NFAB)     = BSOL0
            IF ((IADR0 + IHKL0) > NVDR) THEN
              WRITE (LU6, 99996, IOSTAT = IOST) HMAX0, KMAX0, LMAX0,
     1          IADR0, MHKLH0, IND(1), IND(2), IND(3), IADR0 + IHKL0
              STOP
            END IF
            VOID(IADR0 + IHKL0) =  NFAB - 1
            NFAB                =  NFAB + 2
            VOID(NFAB - 1)      =  ASOL0
            VOID(NFAB)          = -BSOL0
            VOID(IADR0 - IHKL0) =  NFAB - 1
          END DO
        END DO
      END IF
      NREF = 0
      IHT  = 0
      IKT  = 0
      ILT  = 0
      HMAX = -999
      KMAX = -999
      LMAX = -999
      INQUIRE (UNIT = LU27, OPENED = OPEND)
      IF (OPEND) CLOSE (UNIT = LU27)
      OPEN (UNIT = LU27, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1   IOSTAT = IOST)
      IF (IOST /= 0) THEN
        WRITE (LU6, '(''PROBLEM OF LU27'')')
        IPR(2) = 74
        RETURN
      END IF
      IEND = -1
C * TRANSFORM REFLECTIONS FOR SF-CALCULATION (EXCLUDE NON-INTEGRAL H,K,L)
C * WITH TRANSFORMATION MATRIX FROM HKLF LINE ON INSTRUCTION FILE
C * REFLECTION DATA FROM LU16, TRANSFORMED DATA ON LU17
      WRITE (LU6, 99997)
      DO
        CALL PLA134 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI,
     1    SIGIW, UCINT, ACALS, BCALS)
        IF (IEND > 0) EXIT
C * HANDLE FAB FILE
        IF (IPR(665) /= 0) THEN
          IHKL0 = ILT * MHK0 + IKT * MPH0 + IHT
          N     = NINT (VOID(IADR0 + IHKL0))
          ASOL  = VOID(N)
          BSOL  = VOID(N + 1)
        ELSE
          ASOL = 0.0
          BSOL = 0.0
        END IF
C * KEEP TRACK OF REFLECTION INDEX MAXIMA
        HMAX = MAX (HMAX, IABS (IHT))
        KMAX = MAX (KMAX, IABS (IKT))
C * HEXAGONAL LATTICE CASE
        IF (IHEXL == 1) THEN
          HMAX = MAX (KMAX, HMAX, IABS (IHT + IKT))
          KMAX = HMAX
        END IF
        LMAX = MAX (LMAX, IABS (ILT))
        NREF = NREF + 1
C * TEST FOR hkl-ext FILE TYPE
        IF (IGBL(9) == -1) THEN
          YUNK = UCINT
        ELSE
          YUNK = XI
        END IF
        WRITE (LU27, IOSTAT = IOST) IHT, IKT, ILT, YUNK, SIGI, SIGIW,
     1    ASOL, BSOL
      END DO
C * TETRAGONAL LATTICE CASE
      IF (IPR(259) == 4) THEN
        HMAX = MAX (HMAX, KMAX)
        KMAX = HMAX
C * CUBIC LATTICE CASE
      ELSE IF (IPR(259) == 7) THEN
        HMAX = MAX (HMAX, KMAX, LMAX)
        KMAX = HMAX
        LMAX = HMAX
      END IF
C * CHECK FOR 'ANY" VALID REFLECTIONS READ
      IF (NREF == 0) THEN
        IPR(1) = 1
        IF (IPR(2) == 0) IPR(2) = 39
        RETURN
      END IF
C * REPORT # REFLECTIONS AND INDEX MAXIMA
      WRITE (LU6, 99999, IOSTAT = IOST) NREF, HMAX, KMAX, LMAX
      CALL PLA262 (3)
      WRITE (LU7, 99999, IOSTAT = IOST) NREF, HMAX, KMAX, LMAX
      RETURN
99999 FORMAT (/, ':: # Accepted Reflns     Hmax Kmax Lmax', /,
     1           '::', 12X, I6, 3X, 3I5)
99998 FORMAT (':: READ .fab FILE')
99997 FORMAT (':: READ Reflection File')
99996 FORMAT (3I5, 2I12, 3I5, I12)
      END SUBROUTINE PLA133
 
      SUBROUTINE PLA134 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI,
     1  SIGIW, UCINT, ACALS, BCALS)
C * HKL - READ / TRANS
      USE files
      USE parameters
      USE spgrdata
      USE pl127
      IMPLICIT NONE
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IHT
      INTEGER :: IKT
      INTEGER :: ILT
      REAL    :: XI
      REAL    :: STHK
      REAL    :: CALI
      REAL    :: SIGI
      REAL    :: SIGIW
      REAL    :: UCINT
      REAL    :: ACALS
      REAL    :: BCALS
      REAL    :: GEN049
      REAL    :: GEN050
      REAL    :: GEN095
      DO
        CALL PLA132 (IH, IK, IL, XI, SIGI, SIGIW, CALI, UCINT, ACALS,
     1               BCALS)
        IF (IEND == 2) RETURN
        IF (IEND <= 0) THEN
          IF (IABS (IH) + IABS (IK) + IABS (IL) /= 0) THEN
C * APPLY TRANSFORMATION (IF ANY) AND ELIMINATE REFL WITH NON-INTEGRAL INDICES
            IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) > 0.0) THEN
C * FIRST HANDLE BRAVAIS EXTINCTIONS
              IF (IPR(241) > 1) THEN
                IF (GEN049 (LAT(IPR(241)), IHT, IKT, ILT) <= 0.0) THEN
C * COUNT NUMBER OF SKIPPED REFLECTIONS
                  ISKIP = ISKIP + 1
                  CYCLE
                END IF
              END IF
            ELSE
C * COUNT NUMBER OF SKIPPED REFLECTIONS
              ISKIP = ISKIP + 1
              CYCLE
            END IF
C * TEST ON THETAMAX
            STHK = GEN095 (PAR(191), IHT, IKT, ILT)
            IF (IGBL(30) == 0) THEN
              IF (STHK > STHKM) THEN
                ITSKP = ITSKP + 1
                CYCLE
              END IF
            END IF
            PAR(166) = MAX (PAR(166), STHK)
            XI       = XI   * PAR(230)
            SIGI     = SIGI * PAR(230)
          END IF
          EXIT
        ELSE
C * REPORT THE NUMBER OF REFLECTION SKIPPED
          IEND = 1
          IF (ISKIP > 0 .AND. IPR(408) <= 0) THEN
            WRITE (LU6, 99999, IOSTAT = IOST) ISKIP
            CALL PLA262 (3)
            WRITE (LU7, 99999, IOSTAT = IOST) ISKIP
          END IF
          ISKIP = 0
          IF (ITSKP > 0 .AND. IPR(408) <= 0) THEN
            WRITE (LU6, 99998, IOSTAT = IOST) PAR(165), ITSKP
            CALL PLA262 (3)
            WRITE (LU7, 99998, IOSTAT = IOST) PAR(165), ITSKP
          END IF
          ITSKP = 0
          EXIT
        END IF
      END DO
      RETURN
99999 FORMAT (/, ':: Nr. of Eliminated Reflections (Latt Ext. etc.)',
     1 ' =', I5, /)
99998 FORMAT (/, ':: Nr. of Eliminated Reflections (Theta Limit = ',
     1 F5.1, ' Deg) =', I10, /)
      END SUBROUTINE PLA134
 
      SUBROUTINE PLA135
C * STRUCTURE FACTOR CALCULATION FOR CALC FCF - IPR(210) = -1
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cif
      USE reflex
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: K
      INTEGER             :: L
      INTEGER             :: N
      INTEGER             :: NR
      INTEGER             :: NS
      INTEGER             :: IS
      INTEGER             :: IH
      INTEGER             :: IK
      INTEGER             :: IL
      INTEGER             :: IHT
      INTEGER             :: IKT
      INTEGER             :: ILT
      INTEGER             :: IH2
      INTEGER             :: IK2
      INTEGER             :: IL2
      INTEGER             :: MPK
      INTEGER             :: MPL
      INTEGER             :: NR0
      INTEGER             :: NR7
      INTEGER             :: NRF
      INTEGER             :: NREF
      INTEGER             :: NRF1
      INTEGER             :: NATO
      INTEGER             :: ISYM
      INTEGER             :: HMAX
      INTEGER             :: KMAX
      INTEGER             :: LMAX
      INTEGER             :: IHKL
      INTEGER             :: IADR
      INTEGER             :: IHTN
      INTEGER             :: IKTN
      INTEGER             :: ILTN
      INTEGER             :: MHKL
      INTEGER             :: MHKLH
      INTEGER             :: IADR1
      INTEGER             :: IHEXL
      INTEGER             :: IHKL0
      INTEGER             :: IHKLN
      INTEGER             :: NSYMC
      REAL                :: ACL
      REAL                :: BCL
      REAL                :: XCL
      REAL                :: SCF
      REAL                :: RID
      REAL                :: RK2
      REAL                :: RL2
      REAL                :: RH2
      REAL                :: ACLA
      REAL                :: BCLA
      REAL                :: FCLM
      REAL                :: FCLS
      REAL                :: ACAL
      REAL                :: BCAL
      REAL                :: XOBS
      REAL                :: XCAL
      REAL                :: WGHT
      REAL                :: SUM1
      REAL                :: SUM2
      REAL                :: SUM3
      REAL                :: SUM4
      REAL                :: SUMN
      REAL                :: SUMT
      REAL                :: STHL
      REAL                :: STLK
      REAL                :: SGIK
      REAL                :: SIGI
      REAL                :: PCAL
      REAL                :: PCALN
      REAL                :: SIGI1
      REAL                :: SIGI2
      REAL                :: UCINT
      REAL                :: ACALA
      REAL                :: BCALA
      REAL                :: ACALS
      REAL                :: BCALS
      REAL                :: ACALX
      REAL                :: BCALX
      REAL                :: XCALC
      REAL                :: XOBS1
      REAL                :: XOBS2
      REAL                :: WGTI1
      REAL                :: WGTI2
      REAL                :: WGTIS
      REAL                :: SOMXC
      REAL                :: SOMXO
      REAL                :: SNTHA
      REAL                :: SN2TH
      REAL                :: SIGIW
      REAL                :: ACALAF
      REAL                :: BCALAF
      REAL                :: GEN095
      REAL                :: PLA183
C * LOAD ATOMS AND EXPAND (EXCLUDING BRAVAIS CENTERING)
      CALL PLA023 (0)
      NATO = IPR(589)
      IF (NATO < 0) THEN
        IPR(1) = 1
        IPR(2) = 42
        RETURN
      END IF
      NSYMH = IPR(255)
      ICNTR = IPR(257)
      IND1  = 1
      IND2  = 2
      IND3  = 3
C * READ SHELX(L).HKL - TYPE 4 OR FCF
      NREF  = 0
      SOMXO = 0.0
      SOMXC = 0.0
C * TEST FOR HEXAGONAL LATTICE TYPE
      IF (IPR(259) == 5 .OR. IPR(259) == 6) THEN
        IHEXL = 1
      ELSE
        IHEXL = 0
      END IF
C * TRANSFORM REFLECTIONS FOR SF-CALCULATION (EXCLUDE NON-INTEGRAL H,K,L)
      CALL GEN108 (LU9, 0)
      HMAX = -999
      KMAX = -999
      LMAX = -999
      IHT  = 0
      IKT  = 0
      ILT  = 0
      IEND = -1
      DO WHILE (IEND /= 1)
        CALL PLA134 (IH, IK, IL, IHT, IKT, ILT, XOBS, SIGI,
     1    SIGIW, UCINT, ACALS, BCALS)
C * END_OF_DATA HANDLING
        IF (IEND == 1) THEN
          IF (NREF == 0) THEN
            WRITE (LU6, 99998, IOSTAT = IOST)
            IPR(210) = 0
            RETURN
          ELSE
C * THETA-MAX
            PAR(166) = ASIN (SQRT (PAR(166)) * PAR(17)) * RGBL(6)
C * TETRAGONAL LATTICE
            IF (IPR(259) == 4) THEN
              HMAX = MAX (HMAX, KMAX)
              KMAX = HMAX
C * CUBIC LATTICE
            ELSE IF (IPR(259) == 7) THEN
              HMAX = MAX (HMAX, KMAX, LMAX)
              KMAX = HMAX
              LMAX = HMAX
            END IF
          END IF
        ELSE
          HMAX = MAX (HMAX, IABS (IHT))
          KMAX = MAX (KMAX, IABS (IKT))
          LMAX = MAX (LMAX, IABS (ILT))
C * HEXAGONAL LATTICE
          IF (IHEXL == 1) THEN
            HMAX = MAX (KMAX, HMAX, IABS (IHT + IKT))
            KMAX = HMAX
          END IF
C * TETRAGONAL LATTICE
          IF (IPR(259) == 4) THEN
            HMAX = MAX (HMAX, KMAX)
            KMAX = HMAX
C * CUBIC LATTICE
          ELSE IF (IPR(259) == 7) THEN
            HMAX = MAX (HMAX, KMAX, LMAX)
            KMAX = HMAX
            LMAX = HMAX
          END IF
          NREF   = NREF + 1
          ACAL   = 0.0
          BCAL   = 0.0
          ACALA  = 0.0
          BCALA  = 0.0
          ACALAF = 0.0
          BCALAF = 0.0
C * CHECK FOR 'LONG' HKLF FORMAT (FCF-MODE)
          IF (IGBL(9) == -1) THEN
C * FCF CASE
            IF (IPR(210) == -1) THEN
C * START WITH SOLVENT CONTRIBUTION
              ACAL = ACALS
              BCAL = BCALS
              XOBS = UCINT * ABSCOR
            END IF
          END IF
C * CALCULATE STRUCTURE FACTOR
          CALL PLA137 (IHT, IKT, ILT, ACALX, BCALX, ACALA, BCALA,
     1      ACALAF, BCALAF, SNTHA)
C * ADD ANOMALOUS (F' & F") CONTRIBUTION
          ACAL = ACAL + ACALX + ACALA
          BCAL = BCAL + BCALX + BCALA
          XCAL = ACAL ** 2 + BCAL ** 2
C * HANDLE TWIN CONTRIBUTION
          IF (IPR(193) == 101) THEN
            RH2 = PAR(332) * IHT + PAR(333) * IKT + PAR(334) * ILT
            RK2 = PAR(335) * IHT + PAR(336) * IKT + PAR(337) * ILT
            RL2 = PAR(338) * IHT + PAR(339) * IKT + PAR(340) * ILT
            IH2 = NINT (RH2)
            IK2 = NINT (RK2)
            IL2 = NINT (RL2)
            RID = ABS (RH2 - IH2) + ABS (RK2 - IK2) + ABS (RL2 - IL2)
            IF (RID <= 0.01) THEN
C * CALCULATE STRUCTURE FACTOR FOR TWIN PART
              ACL = 0.0
              BCL = 0.0
              CALL PLA137 (IH2, IK2, IL2, ACL, BCL, ACLA, BCLA,
     1          ACALAF, BCALAF, SNTHA)
C * ADD ANOMALOUS (F' & F") CONTRIBUTION
              ACL = ACL + ACLA
              BCL = BCL + BCLA
              XCL = ACL ** 2 + BCL ** 2
              XCAL = (1.0 - PAR(341)) * XCAL + PAR(341) * XCL
            ELSE
              XCAL = (1.0 - PAR(341)) * XCAL
            END IF
          END IF
C * TAKE SWAT CORRECTION TO XCAL INTO ACCOUNT (NOT FOR SHELXL.FCF OR GENER)
          IF (IPR(408) <= 0 .AND. IPR(698) /= 0) THEN
C * CALCULATE (SIN(THETA) / LAMBDA)**2
            STLK  = GEN095 (PAR(191), IHT, IKT, ILT)
            XCAL = XCAL * (1.0 - PAR(501) *
     1        EXP (- RGBL(8) * PAR(502) * STLK))**2
          END IF
C * TAKE EXTINCTION CORRECTION INTO ACCOUNT (NOT FOR SHELXL.FCF OR GENER)
          IF (IPR(408) <= 0) THEN
            IF (PAR(229) > -99999.0 .AND. IGBL(9) /= 1) THEN
              SN2TH = 2 * SNTHA * SQRT (1.0 - MIN (SNTHA, 1.0) ** 2)
              XOBS = XOBS *
     1      (1.0 + 0.001 * PAR(229) * XCAL * PAR(17)**3 / SN2TH) ** 0.5
            END IF
          END IF
          IF (XOBS > 2 * SIGI) THEN
            SOMXO = SOMXO + XOBS
            SOMXC = SOMXC + XCAL
          END IF
C * WRITE TO SCRATCH REFLECTION FILE
          IF (ACAL == 0.0 .AND. BCAL == 0.0) THEN
            PCAL = 0.0
          ELSE
            PCAL = ATAN2 (BCAL, ACAL) * RGBL(6)
          END IF
          WRITE (LU9) IH, IK, IL, IHT, IKT, ILT, XOBS, XCAL, SIGI,
     1      PCAL, ACAL, BCAL, ACALA, BCALA
        END IF
      END DO
C * END HKL READ/CALC LOOP
C * PATT
      IF (IGBL(9) == 1) THEN
        IF (IPR(516) == 0) THEN
          SCF = 0.01 * PAR(240)
        ELSE
          SCF = SOMXC / (SOMXO * PAR(240))
        END IF
      ELSE
        SCF = SOMXC / (SOMXO * PAR(240))
      END IF
      WRITE (LU6, 99984, IOSTAT = IOST) SCF
      CALL GEN108 (LU9,  0)
      CALL GEN108 (LU17, 0)
      FCLM = 0.0
      NR7  = 0
C * READ SCRATCH REFLECTION FILE
      DO I = 1, NREF
        READ (LU9) IH, IK, IL, IHT, IKT, ILT, XOBS, XCAL, SIGI,
     1   PCAL, ACAL, BCAL, ACALA, BCALA
        XOBS = MAX (0.0, XOBS) * SCF
        SIGI = SIGI * SCF
        XCAL = XCAL / PAR(240)
        IF (IPR(414) > 0) THEN
C * HANDLE CONTOUR 'REAL MAP' CASE
          IF (.TRUE.) THEN
            XCALC = XCAL
            BCAL  = BCAL - BCALA
            IF (ACAL == 0.0 .AND. BCAL == 0) THEN
              PCAL = 0.0
            ELSE
              PCAL = ATAN2 (BCAL, ACAL) * RGBL(6)
            END IF
            XCAL = ACAL**2 + BCAL**2
            XOBS = XOBS * XCAL / XCALC
          ELSE
          XOBS = (SQRT (XOBS) * ACAL / SQRT (XCAL) - ACALA) ** 2 +
     1           (SQRT (XOBS) * BCAL / SQRT (XCAL) - BCALA) ** 2
          ACAL = ACAL - ACALA
          BCAL = BCAL - BCALA
          IF (ACAL == 0.0 .AND. BCAL == 0) THEN
            PCAL = 0.0
          ELSE
            PCAL = ATAN2 (BCAL, ACAL) * RGBL(6)
          END IF
          XCAL = ACAL ** 2 + BCAL ** 2
          END IF
        END IF
        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
      END DO
C * CALC FCF MODE
      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
C * CALCULATE ADDRESS OF 0,0,0
      IADR     = NVDR - MHKLH
      IADR1    = NVDR - MHKL
      IF (IADR1 < NR7) THEN
        WRITE (LU6, 99994, IOSTAT = IOST)
        RETURN
      END IF
      DO I = 1, MHKL
        VOID(IADR1 + I) = - 1.0
      END DO
      NR7 = 0
      DO 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 < 0) THEN
          VOID(IADR + IHKL) = I
        ELSE
          XOBS1 = VOID((N - 1) * 7 + 4)
          SIGI1 = VOID((N - 1) * 7 + 6)
          IF (SIGI1 > 0.0) THEN
            WGTI1 = 1.0 / SIGI1**2
          ELSE
            WGTI1 = 1.0
          END IF
          XOBS2 = VOID(NR7 + 4)
          SIGI2 = VOID(NR7 + 6)
          IF (SIGI2 > 0.0) THEN
            WGTI2 = 1.0 / SIGI2**2
          ELSE
            WGTI2 = 1.0
          END IF
          WGTIS = WGTI1 + WGTI2
          VOID((N - 1) * 7 + 4) =
     1         (WGTI1 * XOBS1 + WGTI2 * XOBS2) / WGTIS
          VOID((N - 1) * 7 + 6) = 1.0 / SQRT (WGTIS)
        END IF
        NR7  = NR7 + 7
      END DO
C * AVERAGE
      NSYMC = NSYMH * ICNTR
      IF (NSYMC > 1) THEN
        DO I = 1, MHKL
          J = MHKL + 1 - I
          K = NINT (VOID(IADR1 + J))
          IF (K > 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 /= 0.0) THEN
              SUMT  = XOBS / SIGI**2
              SUMN  = 1.0  / SIGI**2
            ELSE
              SUMT = XOBS
              SUMN = 1.0
            END IF
            DO L = 2, NSYMC
              SGY(1) = IHT
              SGY(2) = IKT
              SGY(3) = ILT
              SGY(4) = PCAL
              IF (L > NSYMH) THEN
                NS = L - NSYMH
                IS = -1
              ELSE
                NS = L
                IS = 1
              END IF
              CALL SGSM (5, ICL, SGY, NS, LU7, IERR)
              IH   = NINT (SGY(7))
              IK   = NINT (SGY(8))
              IL   = NINT (SGY(9))
              IHKL = (IL * MHK + IK * MPH  + IH) * IS
              IF (IHKL > IHKLN) THEN
                IHKLN = IHKL
                IHTN  = IH
                IKTN  = IK
                ILTN  = IL
                PCALN = SGY(10)
              END IF
              IF (IHKL /= IHKL0) THEN
                NR = NINT (VOID(IADR + IHKL))
                IF (NR > 0) THEN
                  XOBS = VOID((NR - 1) * 7 + 4)
                  SIGI = VOID((NR - 1) * 7 + 6)
                  IF (SIGI /= 0.0) THEN
                    WGHT = 1.0 / SIGI**2
                  ELSE
                    WGHT = 1.0
                  END IF
                  SUMT = SUMT + XOBS * WGHT
                  SUMN = SUMN + WGHT
                  VOID(IADR + IHKL) = - 1.0
                END IF
              END IF
            END DO
            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
          END IF
        END DO
      END IF
C * GENERATE SHELXL.CIF & SHELXL.FCF LOOK-ALIKES
      FCLS = 1.0
      IF (FCLM < 250.0) FCLS = 100.0
C * CIF LOOK-ALIKE
      INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.cif', EXIST = EXST)
      IF (EXST) THEN
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_pl.cif',
     1        STATUS = 'UNKNOWN')
        IF (IABS (IGBL(8)) == 3) CLOSE (UNIT = LU1)
        OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'.cif',
     1        STATUS = 'UNKNOWN')
        DO WHILE (.TRUE.)
          READ (LU62, 99989, IOSTAT = IOST) IDM
          IF (IOST /= 0) EXIT
          IF (INDEX (IDM, 'data_') /= 0) THEN
            WRITE (LU61, 99995, IOSTAT = IOST) NAMEFIL(1:KNMFIL)
          ELSE
            WRITE (LU61, 99989, IOSTAT = IOST) IDM
          END IF
        END DO
        CLOSE (UNIT = LU62)
        INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.sqf', EXIST = EXST)
        IF (EXST) THEN
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'.sqf',
     1          STATUS = 'UNKNOWN')
          DO WHILE (.TRUE.)
            READ (LU62, 99989, IOSTAT = IOST) IDM
            IF (IOST /= 0) EXIT
            WRITE (LU61, 99989, IOSTAT = IOST) IDM
          END DO
          CLOSE (UNIT = LU62)
        END IF
C * ADD _iucr_refine_instructions_details  ???
        IF (IABS(IGBL(8)) == 2) THEN
          REWIND (UNIT = LU1, IOSTAT = IOST)
          WRITE (LU61, 99989, IOSTAT = IOST) CIFDIR(513)
          WRITE (LU61, 99988, IOSTAT = IOST)
          DO WHILE (.TRUE.)
            READ (LU1,   99989, IOSTAT = IOST) IDM
            IF (IOST /= 0) EXIT
            WRITE (LU61, 99989, IOSTAT = IOST) IDM
          END DO
          WRITE (LU61, 99988, IOSTAT = IOST)
        END IF
        CLOSE (UNIT = LU61)
      END IF
C * GENERATE FCF LOOK-ALIKE
      OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_pl.fcf',
     1        STATUS = 'UNKNOWN')
      WRITE (LU61, 99987)
      IF (IPR(408) == 1) WRITE (LU61, 99986)
      WRITE (LU61, 99985, IOSTAT = IOST)
     1  NAMEFIL(1:KNMFIL), JID(1: 50), FCLM, PAR(157),
     2  1.0 / (2.0 * PAR(287))
      NSYM   = IPR(48)
      SGY(4) = 0.0
      SGY(5) = 0.0
      SGY(6) = 0.0
      DO K = 1, NSYM
        ISYM = K
        CALL SGSM (20, ICL, SGY, ISYM, 0, IERR)
        CALL GEN020 (-1, ICL, 1, 30)
        N = INDEX (ICL, ' ') -1
        WRITE (LU61, 99991, IOSTAT = IOST) ICL(1:N)
      END DO
      WRITE (LU61, 99997, IOSTAT = IOST)
     1  (PAR(K), K = 101, 106), 1.0 / FCLS
      NRF  = 0
      NRF1 = 0
      CALL GEN108 (LU9, 0)
      DO I = 1, MHKL
        NR0 = NINT (VOID(IADR1 + I))
        IF (NR0 > 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) <= 0) THEN
            XOBS =    VOID((NR0 - 1) * 7 + 4)
            SIGI =    VOID((NR0 - 1) * 7 + 6)
          ELSE
            XOBS = XCAL
            SIGI = SQRT (XOBS)
          END IF
          PCAL    = VOID((NR0 - 1) * 7 + 7)
          SGX(1)  = IHT
          SGX(2)  = IKT
          SGX(3)  = ILT
          SGX(12) = 0.0
          CALL SGSM (27, LINE, SGX, 0, 0, IERR)
          IF (NINT (SGX(12)) == 0) THEN
            NRF1 = NRF1 + 1
            IF (XOBS >= 2 * SIGI) THEN
              SUM1 = SUM1 + ABS (SQRT (XOBS) - SQRT (XCAL))
              SUM2 = SUM2 + SQRT(XOBS)
              NRF  = NRF  + 1
            END IF
C * SHELXL WEIGHT
            IF (PAR(493) >= 0.0) THEN
              SGIK = PLA183(IHT, IKT, ILT, XOBS, XCAL, SIGI) ** 2
            ELSE
              SGIK = SIGI ** 2
            END IF
            SUM3 = SUM3 + ((XOBS - XCAL) ** 2) / SGIK
            SUM4 = SUM4 + (XOBS ** 2) / SGIK
            STHL = SQRT (GEN095 (PAR(191), IHT, IKT, ILT))
C * FCF GENERATE (SNTL_MAX = 0.65 - copper sphere)
              WRITE (LU61, 99993, IOSTAT = IOST)
     1          IHT, IKT, ILT, XCAL * FCLS,
     1          XOBS * FCLS, SIGI * FCLS, STHL
          END IF
        END IF
      END DO
      IF (IPR(408) <= 0) THEN
        CALL PLA262 (3)
        WRITE (LU6, 99999, IOSTAT = IOST)
        WRITE (LU7, 99999, IOSTAT = IOST)
      END IF
C * R-VALUES (NOT FOR SQUEEZE_CONTOUR AND PATTERSON MAPS)
      IF (IPR(414) < 4) THEN
        N = 0
        IF (PAR(493) >= 0) THEN
          N = INDEX (RLWS(1)(2:80), '''')
          IF (N >= 2) WRITE (LU6, 99992, IOSTAT = IOST) RLWS(1)(2:N)
        END IF
        WRITE (LU6, 99996, IOSTAT = IOST)
     1    SUM1 / SUM2, NRF, SQRT (SUM3 / SUM4), NRF1,
     1    SQRT(SUM3 / (NRF1 - IPR(226)))
        IF (N >= 2) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99992, IOSTAT = IOST) RLWS(1)(2:N)
        END IF
        CALL PLA262 (6)
        WRITE (LU7, 99996, IOSTAT = IOST)
     1    SUM1 / SUM2, NRF, SQRT (SUM3 / SUM4), NRF1,
     2    SQRT (SUM3 / (NREF - IPR(226)))
      END IF
      WRITE (LU61, 99990, IOSTAT = IOST)
      CLOSE (UNIT = LU61)
      CLOSE (UNIT = LU17, STATUS = 'DELETE')
      RETURN
99999 FORMAT (/, ':: Structure Factor Calculation including SQUEEZE',
     1           ' Contribution', /)
99998 FORMAT (/, ':: However, no reflection data found', /)
99997 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_include_status', /,
     5 ' _refln_sint/lambda')
99996 FORMAT (':: R1   =', F9.3, ' for', I6,
     1        ' Refl. with I > 2 s(I) and', /,
     2        ':: wR2  =', F9.3, ' for', I6, ' reflections', /,
     3        ':: S    =', F9.3, /)
99995 FORMAT ('data_', A)
99994 FORMAT (/, 'NVDR too Small in PLA135', /)
99993 FORMAT (3I4, 2F12.2, F10.2, ' o', F10.5)
99992 FORMAT (/, ':: ', A)
99991 FORMAT (1X, '''', A, '''')
99990 FORMAT (1X)
99989 FORMAT (A)
99988 FORMAT (';')
99987 FORMAT ('#', /, '# h,k,l, Fc-squared, Fo-squared,',
     1 ' sigma(Fo-squared) and status flag', /, '#')
99986 FORMAT ('# !!! FCF Generated for TEST Purposes only, ',
     1 'NOT for FCF Deposition !!!')
99985 FORMAT ('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')
99984 FORMAT (':: SCF =', F10.6)
      END SUBROUTINE PLA135
 
      SUBROUTINE PLA136 (MODE, IH, IK, IL, IASM)
C * HANDLE ASYMMETRIC REFLECTION UNIT
      USE parameters
      USE reflex
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: NS
      INTEGER               :: IASM
      INTEGER               :: IHKL
      INTEGER               :: MODE
      INTEGER               :: ISHKL
      INTEGER               :: IHKLM
      INTEGER, DIMENSION(3) :: IND
C * IASM = 0 - NOT IN ASYM UNIT
C *      = 1 - IN ASYM UNIT
      IASM  = 1
      IHKLM = 0
      DO I = 1, NSYMH
        SGX(1) = IH
        SGX(2) = IK
        SGX(3) = IL
        SGX(4) = 0.0
        NS     = I
        CALL SGSM (5, ICL, SGX, NS, 0, IERR)
        IND(1) = NINT (SGX(IND1 + 6))
        IND(2) = NINT (SGX(IND2 + 6))
        IND(3) = NINT (SGX(IND3 + 6))
        IHKL   = IND(3) * MHK + IND(2) * MPH + IND(1)
C * UPPER HALF OF REFLECTION SPHERE ONLY (L >= 0)
        IF (IHKL < 0) THEN
          DO J = 1, 3
            IND(J) = - IND(J)
          END DO
          IHKL  = - IHKL
          ISHKL = - 1
        ELSE
          ISHKL =   1
        END IF
        IF (IHKL > IHKLM) THEN
          IHKLM = IHKL
          IF (I > 1) IASM = 0
        END IF
        IHKLM = MAX (IHKLM, IHKL)
        IF (MODE == 1) THEN
          DO J = 1, 3
            IHKLS(J, I) = IND(J)
          END DO
          IHKLS(4, I) = IHKL
          IHKLS(5, I) = ISHKL
C * PHASE SHIFT IN RADIANS
          PHIS(I) = SGX(10) / RGBL(6)
        END IF
      END DO
      RETURN
      END SUBROUTINE PLA136
 
      SUBROUTINE PLA137 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA,
     1  ACALAF, BCALAF, SNTHA)
C * STRUCTURE FACTOR CALCULATION ROUTINE (BASED ON SYMMETRY EXPANDED COORD SET)
C * CALLED FROM PLA130, 132, 145, 146, 147, 150, 160, 190, 251, 265, 351, 410
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IBV
      INTEGER :: NAT
      INTEGER :: ICENT
      INTEGER :: IATPI
      REAL    :: TF
      REAL    :: TF1
      REAL    :: TF2
      REAL    :: ARG
      REAL    :: FSC
      REAL    :: CARG
      REAL    :: SARG
      REAL    :: FACT
      REAL    :: ACAL
      REAL    :: BCAL
      REAL    :: STLK
      REAL    :: YUNK
      REAL    :: FACTC
      REAL    :: FACTD
      REAL    :: FACTR
      REAL    :: ACALA
      REAL    :: BCALA
      REAL    :: SNTHA
      REAL    :: ACALAF
      REAL    :: BCALAF
      REAL    :: GEN095
      NAT    = IPR(589)
      IBV    = IPR(256)
      ICENT  = IPR(257)
      ACAL   = 0.0
      BCAL   = 0.0
      ACALA  = 0.0
      BCALA  = 0.0
      ACALAF = 0.0
      BCALAF = 0.0
C * T = exp(-2pi^2^[h^2^(a*)^2^U11+k^2^(b*)^2^U22+ ... + 2hka*b*U12])
      DUMA(1) = IH**2   * PAR(191)
      DUMA(2) = IK**2   * PAR(192)
      DUMA(3) = IL**2   * PAR(193)
      DUMA(4) = IK * IL * PAR(114) * PAR(115) * 2.0
      DUMA(5) = IH * IL * PAR(113) * PAR(115) * 2.0
      DUMA(6) = IH * IK * PAR(113) * PAR(114) * 2.0
C * CALCULATE (SIN(THETA) / LAMBDA)**2 AND SIN(THETA)
      STLK  = GEN095 (PAR(191), IH, IK, IL)
      SNTHA = SQRT (STLK) * PAR(17)
C * SF-CALC EXCEPT FOR SQUEEZE-CONTOUR AND PATTERSON
      IF (IPR(414) < 4) THEN
        TF1 = - RGBL(8) * STLK
        TF2 = - TF1 * 100
C * CALCULATE STRUCTURE FACTOR (ACAL, BCAL, ACALA, BCALA for HKL & -H-K-L)
        DO I = 1, NAT
C * CHECK FOR NON-ZERO POPULATION
          IF (XXO(I, 4) > 0.0) THEN
            ARG   = RGBL(5) * (IH * XXO(I, 1) + IK * XXO(I, 2)
     1            + IL * XXO(I, 3))
            CARG  = COS (ARG)
            SARG  = SIN (ARG)
C * DISPLACEMENT PARAMETERS - ISO/ANISO FLAG
C * ISOTROPIC
            IF (XSD(I, 1) > 99.0) THEN
              YUNK = - TF1 * XSD(I, 1) - TF2
C * ANISOTROPIC
            ELSE
              TF = 0.0
              DO J = 1, 6
                TF = TF + XSD(I, J) * DUMA(J)
              END DO
              YUNK = RGBL(7) * TF
            END IF
            IF (YUNK < 30) THEN
              TF = EXP (- YUNK)
            ELSE
              TF = 0.0
            END IF
            FACT = XXO(I, 4) * IBV * TF
C * GET SCATTERING FACTOR
            FSC = CON(I, 9)
C * CONSTANT Z VALUE SCATTERING FACTORS FOR E**2 PATTERSON
            IF (IABS (IPR(493)) < 9) THEN
              DO J = 1, 7, 2
C * HANDLE UNDERFLOW
                YUNK = CON(I, J + 1) * STLK
                IF (YUNK < 30) FSC = FSC + CON(I, J) * EXP (- YUNK)
              END DO
            END IF
C * REAL SCATTERING CONTRIBUTION  (ACAL, BCAL)
            FACTR = FACT * FSC
            ACAL  = ACAL + FACTR * CARG
            IF (ICENT == 1) BCAL = BCAL + FACTR * SARG
C * COMPLEX SCATTERING CONTRIBUTION DUE TO F'' (ACALA, BCALA) FOR XRAY
            IF (IABS(IPR(493)) < 7) THEN
              IATPI = IATP(I)
              IF (IATPI /= 0) THEN
                FACTD = FACT  * ANOM(IATPI, 1)
                FACTC = FACT  * ANOM(IATPI, 2)
                ACALA = ACALA + FACTD * CARG
                BCALA = BCALA + FACTC * CARG
C * ANOMALOUS CONTRIBUTION TO FRIEDEL PAIRED REFLECTION
                ACALAF = ACALAF + FACTD * CARG
                BCALAF = BCALAF + FACTC * CARG
C * ADD FOR NON-CENTRO CASE
                IF (ICENT == 1) THEN
                  ACALA = ACALA - FACTC * SARG
                  BCALA = BCALA + FACTD * SARG
C * ANOMALOUS CONTRIBUTION TO FRIEDEL PAIRED REFLECTION
                  ACALAF = ACALAF + FACTC * SARG
                  BCALAF = BCALAF - FACTD * SARG
                END IF
              END IF
            END IF
          END IF
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA137
 
      MODULE analysis
      SAVE
      INTEGER, PARAMETER              :: NREC  = 12
      INTEGER, PARAMETER              :: NSMAX = 500
      INTEGER, PARAMETER              :: MXTWN = 5
      INTEGER                         :: IADR
      INTEGER                         :: NREF
      INTEGER                         :: NADR
      INTEGER                         :: HMAX
      INTEGER                         :: KMAX
      INTEGER                         :: LMAX
      INTEGER                         :: NSEL
      INTEGER                         :: NTWIN
      INTEGER                         :: ICALT
      INTEGER                         :: NSYMHA
      INTEGER                         :: NSYMHB
      INTEGER                         :: NREFF1
      INTEGER                         :: NREFF2
      INTEGER, DIMENSION(MXTWN)       :: NTW
      INTEGER, DIMENSION(MXTWN)       :: MTW
      INTEGER, DIMENSION(MXTWN)       :: NFRQ
      INTEGER, DIMENSION(MXTWN)       :: NTW0
      INTEGER, DIMENSION(3, MXTWN)    :: IHKLR
      INTEGER, DIMENSION(3, MXTWN)    :: IHKLD
      INTEGER, DIMENSION(MXTWN * 2)   :: MTWIN
      INTEGER, DIMENSION(NSMAX)       :: ISDAT
      INTEGER, DIMENSION(14, 3)       :: NSTATH
      INTEGER, DIMENSION(14, 3)       :: NSTATK
      INTEGER, DIMENSION(14, 3)       :: NSTATL
      REAL                            :: SCL
      REAL,    DIMENSION(3, 3, MXTWN) :: TWM
      REAL,    DIMENSION(NSMAX)       :: SDAT
      REAL,    DIMENSION(20, 12)      :: STAT
      REAL,    DIMENSION(MXTWN)       :: DRVAL
      REAL,    DIMENSION(MXTWN)       :: BASFM
      REAL,    DIMENSION(MXTWN)       :: ALPHA
      REAL,    DIMENSION(7)           :: CELLA
      REAL,    DIMENSION(7)           :: CELLB
      REAL,    DIMENSION(3, 3)        :: TRNSA
      REAL,    DIMENSION(3, 3)        :: TRNSB
      REAL,    DIMENSION(7)           :: RCELLA
      REAL,    DIMENSION(7)           :: RCELLB
      REAL,    DIMENSION(11, 5)       :: VSTATA
      REAL,    DIMENSION(11, 5)       :: VSTATB
      REAL,    DIMENSION(11, 5)       :: VSTATC
      REAL,    DIMENSION(90, 5)       :: AVIOSIG
      REAL,    DIMENSION(6)           :: REFLCELL
      CHARACTER(len=12)               :: SPGRA
      CHARACTER(len=12)               :: SPGRB
      END MODULE analysis
 
      SUBROUTINE PLA139 (LUN0, LUN1, LUN2, NREFF)
C * FCF TO HKL EXTRACTION
      USE parameters
      USE atomdata
      USE cchar
      USE mentry
      USE analysis
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: JE
      INTEGER          :: NL
      INTEGER          :: IH
      INTEGER          :: IK
      INTEGER          :: IL
      INTEGER          :: LUN0
      INTEGER          :: LUN1
      INTEGER          :: LUN2
      INTEGER          :: NREFF
      INTEGER          :: IOST
      INTEGER          :: IDTYP
      INTEGER          :: IYUNK
      INTEGER          :: NSKIP
      INTEGER          :: IFTYPE
      INTEGER          :: ISTATE
      REAL             :: XT
      REAL             :: TH
      REAL             :: ST
      REAL             :: FC
      REAL             :: FCK
      REAL             :: FOK
      REAL             :: SCF
      REAL             :: FKMX
      REAL             :: YUNK
      REAL             :: SFOK
      REAL             :: XFCAL
      REAL             :: XFOBS
      REAL             :: XSIGI
      REAL             :: GEN095
      CHARACTER(len=1) :: STATX
      IDTYP = IENTRY(IGBL(54), 3)
      CALL GEN074 (REFLCELL, 1, 6, 0.0)
      IF (IDTYP /= 0) THEN
        IFTYPE = 0
        SCF    = 0.0
        FKMX   = 0.0
        NREFF  = 0
        NSKIP  = 0
        IF (IABS (IDTYP) == 7) THEN
          FMOL = '(3I4,3F8.0)'
        ELSE
          FMOL = '(I4,2I3,2F7.0,F6.0)'
        END IF
C * REFLECTION FILE TYPES ARE IDENTIFIED IN PLA008-10
C * IDTYP =  1 - FCF (SHELXL LIST 4)
C * IDTYP =  2 - XTAL-F
C * IDTYP =  3 - NRCVAX
C * IDTYP =  4 - MOLEN
C * IDTYP =  5 - CRYSTALS(F)
C * IDTYP =  6 - TEXSAN1
C * IDTYP =  7 - MOLEN1 VARIANT
C * IDTYP =  8 - CRYSTALS(I)
C * IDTYP =  9 - JANA2 (F**2)
C * IDTYP = 10 - TEXSAN2
C * IDTYP = 11 - XD
C * IDTYP = 12 - REALS
C * IDTYP = 13 - TEXSAN3
C * IDTYP = 14 - JANA1 (F)
C * IDTYP = 15 - RIGAKU
C * IDTYP = 16 - JANA3-STYLE
C * IDTYP = 17 - CRYSTALS(I,TWIN)
C * IDTYP = 18 - CRYSTL3
C * IDTYP = 21 - SHELXL - LIST 3
C * IDTYP = 22 - SHELXL - LIST 5
C * IDTYP = 23 - SHELXL - LIST 6
C * IDTYP = 24 - SHELXL - LIST 7
C * IDTYP = 25 - SHELXL - LIST 8
C * IDTYP = 26 - REALS - FCF
        IF (IDTYP > 0 .AND. IABS (IGBL(8)) == 3) THEN
          NSKIP = IENTRY(IGBL(54), 4)
          IF (NSKIP > 0) THEN
            GO TO 10
          ELSE
            GO TO 50
          END IF
        ELSE
          IDTYP = IABS (IDTYP)
        END IF
C * LOOP TWICE TO DETERMINING SCALING WITHIN FORMAT
   10   DO I = 1, 2
          REWIND (UNIT = LUN1, IOSTAT = IOST)
          REWIND (UNIT = LUN2, IOSTAT = IOST)
          DO J = 1, NSKIP
            READ (LUN1, 99996) LINE
          END DO
          IF (I == 2) THEN
            IF (FKMX < 999999.0) THEN
              SCF = 100.0
            ELSE
              SCF = FLOAT (90000000) / FKMX
            END IF
          END IF
   20     READ (LUN1, 99996, IOSTAT = IOST) LINE
          IF (IOST == -1) CYCLE
C * HANDLE EXTRA LF & CR
          NL = INDEX (LINE, CHAR (13))
          IF (NL /= 0) LINE(NL:NL) = CHAR (32)
          SELECT CASE (IDTYP)
C * SHELXL FCF
            CASE (1)
              IFTYPE = 0
              ISTATE = 0
              IDM = 'LATT P A'
              CALL SGSM (0, IDM, SGX, 0, 0, IERR)
              DO
                READ (LUN1, 99996, IOSTAT = IOST) LINE
                IF (IOST == -1) EXIT
                NL = INDEX (LINE, CHAR (13))
                IF (NL /= 0) LINE(NL:NL) = CHAR (32)
                IF (I == 1) THEN
                  IF (ISTATE == 0) THEN
                    J = INDEX (LINE, '_space_group_symop_operation_xyz')
                    IF (J == 0) THEN
                      J = INDEX (LINE, '_symmetry_equiv_pos_as_xyz')
                    END IF
                    IF (J > 0) ISTATE = 1
                  ELSE IF (ISTATE == 1) THEN
                    J = INDEX (LINE, '_cell_length_a')
                    IF (J > 0) THEN
                      JE = INDEX (LINE(J+14:80), '(')
                      IF (JE /= 0) THEN
                        JE = J + JE + 12
                      ELSE
                        JE = 80
                      END IF
                      READ (LINE(J+14:JE), *) REFLCELL(1)
                      ISTATE = 2
                      CALL SGSM (18, IDM, SGX, 0, 0, IERR)
                      SPGRNAMF = IDM(15:26)
                      IPR(241) = NINT (SGX(7))
                      IPR(255) = NINT (SGX(4))
                    ELSE
                      J  = INDEX (LINE, '''')
                      IF (J /= 0) THEN
                        K = INDEX (LINE(J+1:80), '''')
                        IF (K /= 0) THEN
                          IDM = 'SYMM '//LINE(J+1:K +J -1)
                          CALL SGSM (0, IDM, SGX, 0, 0, IERR)
                        END IF
                      END IF
                    END IF
                  ELSE IF (ISTATE == 2) THEN
                    J = INDEX (LINE, '_cell_length_b')
                    IF (J > 0) THEN
                      JE = INDEX (LINE(J+14:80), '(')
                      IF (JE /= 0) THEN
                        JE = J + JE + 12
                      ELSE
                        JE = 80
                      END IF
                      READ (LINE(J+14:JE), *) REFLCELL(2)
                    ELSE
                      J = INDEX (LINE, '_cell_length_c')
                      IF (J > 0) THEN
                        JE = INDEX (LINE(J+14:80), '(')
                        IF (JE /= 0) THEN
                          JE = J + JE + 12
                        ELSE
                          JE = 80
                        END IF
                        READ (LINE(J+14:JE), *) REFLCELL(3)
                      ELSE
                        J = INDEX (LINE, '_cell_angle_alpha')
                        IF (J > 0) THEN
                          JE = INDEX (LINE(J+17:80), '(')
                          IF (JE /= 0) THEN
                            JE = J + JE + 15
                          ELSE
                            JE = 80
                          END IF
                          READ (LINE(J+17:JE), *) REFLCELL(4)
                        ELSE
                          J = INDEX (LINE, '_cell_angle_beta')
                          IF (J > 0) THEN
                            JE = INDEX (LINE(J+16:80), '(')
                            IF (JE /= 0) THEN
                              JE = J + JE + 14
                            ELSE
                              JE = 80
                            END IF
                            READ (LINE(J+16:JE), *) REFLCELL(5)
                          ELSE
                            J = INDEX (LINE, '_cell_angle_gamma')
                            IF (J > 0) THEN
                              JE = INDEX (LINE(J+17:80), '(')
                              IF (JE /= 0) THEN
                                JE = J + JE + 15
                              ELSE
                               JE = 80
                              END IF
                               READ (LINE(J+17:JE), *) REFLCELL(6)
                               ISTATE = 3
                            END IF
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
                IF (INDEX (LINE,  '_refln_F_squared_calc') /= 0) THEN
                  IFTYPE = IFTYPE * 10 + 2
                ELSE IF (INDEX (LINE, '_refln_F_squared_meas') /= 0)
     1            THEN
                  IFTYPE = IFTYPE * 10 + 1
                END IF
                IF (INDEX (LINE, '_refln_observed_status') /= 0 .OR.
     1              INDEX (LINE, '_refln_include_status')  /= 0) THEN
                  READ (LUN1, 99996, IOSTAT = IOST) LINE
                  IF (IOST == -1) CYCLE
                  IF (INDEX (LINE, '_refln_sint/lambda') == 0)
     1               BACKSPACE (LUN1)
                  GO TO 40
                END IF
              END DO
C * MOLEN
            CASE (4)
              IF (INDEX (LINE, '_refln_10*F_sigm') == 0 .OR.
     1            INDEX (LINE, '_refln_F_10*sigm') == 0) GO TO 20
              GO TO 40
C * CRYSTALS(F)
            CASE (5)
              DO
                READ  (LUN1, 99996, IOSTAT = IOST) LINE
                IF (IOST == -1) CYCLE
                WRITE (LUN0, 99996) LINE
                IF (INDEX (LINE, '_refln_refinement_weight') /= 0)
     1            GO TO 40
              END DO
C * TEXSAN & RIGAKU
            CASE (6, 13, 15)
              IF (INDEX (LINE, '_refln_observed_status') == 0 .AND.
     1            INDEX (LINE, '_refln_include_status') == 0) GO TO 20
              GO TO 40
C * MOLEN1
            CASE (7)
              IF (INDEX (LINE, '_refln_observed_status') == 0)
     1          GO TO 20
              GO TO 40
C * CRYSTALS(I)
            CASE (8)
              IF (INDEX (LINE, '_refln_index') == 0) THEN
                GO TO 20
              ELSE
                DO
                  READ (LUN1, 99996, IOSTAT = IOST) LINE
                  IF (IOST == -1) CYCLE
                  IF (INDEX (LINE, '_refln_') == 0) THEN
                    BACKSPACE LUN1
                    GO TO 40
                  END IF
                END DO
              END IF
C * JANA1 & JANA2
            CASE (9, 14)
              IF (INDEX (LINE, '_refln_observed_status') == 0 .AND.
     1            INDEX (LINE, '_refln_include_status') == 0) GO TO 20
              GO TO 40
C * XD
            CASE (11)
              IF (INDEX (LINE, '_refln_XD_refine_code') == 0)
     1          GO TO 20
              GO TO 40
C * JANA3-STYLE FCF
            CASE (16)
              IF (INDEX (LINE, '_refln_observed_status') == 0)
     1          GO TO 20
              GO TO 40
C * SHELXL LIST 3
            CASE (21)
              IF (INDEX (LINE, '_refln_B_calc') == 0) GO TO 20
              GO TO 40
C * SHELXL LIST 6
            CASE (23)
              IF (INDEX (LINE, '_refln_phase_calc') == 0) GO TO 20
              GO TO 40
C * SHELXL LIST 7
            CASE (24)
              READ (LINE, *, IOSTAT = IOST)
     1          IYUNK,IYUNK,IYUNK,YUNK,YUNK,YUNK,YUNK
              IF (IOST /= 0) GO TO 20
C * DUMMY STATEMENT
              YUNK = FLOAT (IYUNK) + YUNK
            CASE (25)
              IF (INDEX (LINE, '_shelx_refinement_sigma') == 0) THEN
                GO TO 20
              ELSE
                GO TO 40
              END IF
C * REALS
            CASE (26)
              IF (INDEX (LINE, '_refln_F_sigma') == 0) GO TO 20
              GO TO 40
C * DEFAULT
            CASE DEFAULT
              CYCLE
          END SELECT
          BACKSPACE LUN1
          GO TO 40
   30     IF (I == 1) WRITE (LUN0, 99989, IOSTAT = IOST) LINE(1:50)
C * DUMMY
          IF (IOST == -999) RETURN
C * FCF REFLECTION READ LOOP
   40     DO
            READ (LUN1, 99996, IOSTAT = IOST) LINE
            IF (IOST == -1) EXIT
            NL = INDEX (LINE, CHAR (13))
            IF (NL /= 0) LINE(NL:NL) = CHAR (32)
            SELECT CASE (IDTYP)
C * SHELXL
              CASE (1)
                IF (LINE(1:1) == '#') EXIT
                IF (LINE(1:10) == '          ') CYCLE
                IF (INDEX (LINE, 'data_') /= 0) EXIT
                IF (IFTYPE == 12) THEN
                  READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FOK, FCK,
     1                                          SFOK
                  IF (IOST /= 0) THEN
                    IF (IOST == -1) THEN
                      EXIT
                    ELSE
                      GO TO 30
                    END IF
                  END IF
                ELSE IF (IFTYPE == 21) THEN
                  READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FCK, FOK,
     1                                          SFOK
                  IF (IOST /= 0) THEN
                    IF (IOST == -1) THEN
                      EXIT
                    ELSE
                      GO TO 30
                    END IF
                  END IF
                END IF
C * HANDLE EXTINCTION CORRECTION (SHELXL ONLY)
                IF (PAR(229) > 0.0) THEN
                  ST  = SQRT (GEN095 (PAR(191), IH, IK, IL)) * PAR(17)
                  TH  = ASIN (ST)
                  XT  = (1.0 + (0.001 * PAR(229) * FCK * PAR(17)**3) /
     1                  SIN (2.0 * TH)) ** 0.5
                  FOK = FOK / XT
                END IF
C * DUMMY
                FCK = FCK + 0.0
C * MOLEN
              CASE (4, 7)
                READ (LINE, FMOL, IOSTAT = IOST) IH, IK, IL,
     1                XFOBS, XFCAL, XSIGI
                IF (IOST /= 0) EXIT
                FOK  = SIGN (XFOBS**2, XFOBS) / 100.0
                SFOK = 2.0 * ABS (XFOBS) * XSIGI / 100.0
C * CRYSTALS(F)
              CASE (5)
                READ (LINE, 99998, IOSTAT = IOST)
     1            IH, IK, IL, XFOBS, XFCAL, XSIGI, STATX
                IF (IOST  /= 0) CYCLE
                IF (STATX == 'x') CYCLE
                IF (STATX == '<') CYCLE
                IF (STATX == 'l') CYCLE
                IF (STATX == 'h') CYCLE
                FOK  = SIGN (XFOBS**2, XFOBS)
                SFOK = 2.0 * ABS (XFOBS) * XSIGI
C * CRYSTALS(I)
              CASE (8)
                READ (LINE, 99998, IOSTAT = IOST) IH, IK, IL, FOK, FCK,
     1                                      SFOK, STATX
                IF (IOST == -1) EXIT
                IF (STATX == 'x') CYCLE
                IF (STATX == '<') CYCLE
                IF (STATX == 'l') CYCLE
                IF (STATX == 'h') CYCLE
C * JANA2
              CASE (9)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FOK, FCK,
     1                                        SFOK
                IF (IOST == -1) EXIT
C * JANA1
              CASE (14)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, XFOBS, XFCAL,
     1                                        XSIGI
                IF (IOST == -1) EXIT
                FOK = XFOBS ** 2
                FCK = XFCAL ** 2
                IF (XFOBS > XSIGI / 2.0) THEN
                  SFOK = 2.0 * ABS (XFOBS) * XSIGI
                ELSE
                  SFOK = 2.0 * ABS (XFCAL) * XSIGI
                END IF
C * JANA3-STYLE FCF
              CASE (16)
                READ (LINE, 99997, IOSTAT = IOST)
     1            IH, IK, IL, XFCAL, FOK, SFOK, STATX
                IF (IOST == -1) EXIT
C * TEXSAN1 FCF
              CASE (6)
                READ (LINE, 99993, IOSTAT = IOST) IH, IK, IL, XFOBS,
     1                                            XSIGI, XFCAL
                IF (IOST == -1) EXIT
                FOK = SIGN (XFOBS**2, XFOBS)
                FCK = XFCAL ** 2
                IF (XFOBS > XSIGI / 2.0) THEN
                  SFOK = 2.0 * ABS (XFOBS) * XSIGI
                ELSE
                  SFOK = 2.0 * ABS (XFCAL) * XSIGI
                END IF
C * TEXSAN3/RIGAKU FCF
              CASE (13, 15)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FOK, SFOK,
     1                                        FCK
                IF (IOST == -1) EXIT
C * XD FCF (F)
              CASE (11)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FCK, FOK,
     1                                        SFOK, YUNK
                IF (IOST == -1) EXIT
C * SHELXL - LIST 3
              CASE (21)
                IF (LINE(1:1) == '#') EXIT
                IF (LINE(1:10) == '          ') CYCLE
                IF (INDEX (LINE, 'data_') /= 0) EXIT
                READ (LINE, 99991, IOSTAT = IOST) IH, IK, IL, XFOBS,
     1                                            XSIGI
                IF (IOST == -1) EXIT
                IF (XFOBS > 0.0 .AND. XSIGI > 0) THEN
                  FOK  = XFOBS**2
                  SFOK = 2.0 * SQRT (FOK) * XSIGI
                ELSE
                  CYCLE
                END IF
C * SHELXL - LIST 6
              CASE (23)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FOK, SFOK, FC
                IF (IOST == -1) EXIT
                FCK = FC**2
C * SHELXL - LIST 7
              CASE (24)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FOK, SFOK, FCK
                IF (IOST == -1) EXIT
C * SHELXL - LIST 8
              CASE (25)
                READ (LINE, *, IOSTAT = IOST) IH, IK, IL, FOK, SFOK, FCK
                IF (IOST == -1) EXIT
C * REALS FCF F
                CASE (26)
                READ (LINE, 99990, IOSTAT = IOST) IH, IK, IL, XFOBS,
     1                                            XFCAL, XSIGI
                IF (IOST == -1) EXIT
                FOK  = SIGN (XFOBS**2, XFOBS)
                SFOK = 2.0 * ABS (XFOBS) * XSIGI
                IF (SFOK < 0.0001) CYCLE
            END SELECT
            IF (IH == 0 .AND. IK == 0 .AND. IL == 0) EXIT
            IF (I == 1) THEN
              IF (FOK  > FKMX) FKMX = FOK
              IF (SFOK > FKMX) FKMX = SFOK
            ELSE
              NREFF = NREFF + 1
              WRITE (LUN2, 99999, IOSTAT = IOST)
     1          IH, IK, IL, NINT (FOK * SCF), NINT (SFOK * SCF)
            END IF
          END DO
        END DO
      ELSE
        CALL GEN127 ('No Recognizable FCF')
      END IF
        IF (IDTYP == 1 .AND. PAR(229) > 0.0)
     1    WRITE (LUN0, 99988, IOSTAT = IOST) PAR(229)
      IF (NREFF == 0) THEN
        WRITE (LUN0, 99994, IOSTAT = IOST)
      ELSE
        WRITE (LUN2, 99992, IOSTAT = IOST)
      END IF
      RETURN
   50 WRITE (LUN0, 99995, IOSTAT = IOST) NREFF
      CALL GEN127 (' ')
99999 FORMAT (3I4, 2I8)
99998 FORMAT (3I4, 3F12.2, 1X, A, E13.4)
99997 FORMAT (3I4, 3F9.0, 1X, A)
99996 FORMAT (A)
99995 FORMAT (':: STOP: Free Read Problem in FCF-file NREFF =', I6)
99994 FORMAT (/, ':: No Suitable Reflections found in FCF-file', /)
99993 FORMAT (I4, 2I5, 3F11.2)
99992 FORMAT (//)
99991 FORMAT (3I4, 4F12.0)
99990 FORMAT (3I4, 2F9.0, F7.0)
99989 FORMAT ('Free Format READ Problem: ', A)
99988 FORMAT (/, ':: Retro Extinction Correction Applied on Fo**2',
     1        ' - EXTI =', F7.4, /)
      END SUBROUTINE PLA139
 
      SUBROUTINE PLA140 (FFT, R3D, NATO, RHOMIN, MODE, NPK, IPOSNEG,
     1 NSYM)
C * PEAK SEARCH
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: M
      INTEGER                :: N
      INTEGER                :: N1
      INTEGER                :: N2
      INTEGER                :: IR
      INTEGER                :: IX
      INTEGER                :: IY
      INTEGER                :: IZ
      INTEGER                :: MN
      INTEGER                :: MX
      INTEGER                :: NO
      INTEGER                :: NZ
      INTEGER                :: NAT
      INTEGER                :: NPK
      INTEGER                :: ISW
      INTEGER                :: NNX
      INTEGER                :: NNY
      INTEGER                :: NNZ
      INTEGER                :: NXY
      INTEGER                :: MAXX
      INTEGER                :: NOP1
      INTEGER                :: NPIC
      INTEGER                :: KSYM
      INTEGER                :: NATO
      INTEGER                :: MODE
      INTEGER                :: NSYM
      INTEGER                :: NXY3
      INTEGER                :: LIMIT
      INTEGER                :: KUSER
      INTEGER                :: IPOSNEG
      INTEGER, DIMENSION(19) :: IDF
      REAL                   :: C
      REAL                   :: D
      REAL                   :: E
      REAL                   :: F
      REAL                   :: B1
      REAL                   :: B2
      REAL                   :: DX
      REAL                   :: DY
      REAL                   :: DZ
      REAL                   :: DM
      REAL                   :: XX
      REAL                   :: YY
      REAL                   :: ZZ
      REAL                   :: DELTAX
      REAL                   :: DELTAY
      REAL                   :: DELTAZ
      REAL                   :: RHOMIN
      REAL                   :: XLEVEL
      REAL                   :: GEN006
      REAL,    DIMENSION(*)  :: FFT
      REAL,    DIMENSION(*)  :: R3D
      REAL,    DIMENSION(3)  :: XS
      REAL,    DIMENSION(3)  :: X1
      REAL,    DIMENSION(3)  :: DXMAX
      REAL,    DIMENSION(19) :: B
C * MODE = -3 : DIFFERENCE MAP
      IF (MODE /= 0) THEN
        ISW = 3
      ELSE
        ISW = -3
      END IF
C * INPUT DATA FROM FFT FILE
      NNX   = IPR(395)
      NNY   = IPR(396)
      NNZ   = IPR(397)
C * INPUT DIMENSIONS OF MAP AND CHECK ARRAY SIZE
      NXY   = (NNX + 2) * (NNY + 2)
      NXY3  = 3 * NXY
C * INITIALISE CONSTANTS
      DX    = 1.0 / FLOAT (NNX)
      DY    = 1.0 / FLOAT (NNY)
      DZ    = 1.0 / FLOAT (NNZ)
C * KUSER = MAXIMUM NUMBER OF PEAKS TO BE FOUND + 20,
C *         ALSO MAXIMUM NUMBER OF PEAKS FOR INTERPRETATION
      KUSER = NP1 - NATO
      NAT   = KUSER - 20
      NPIC  = KUSER - 20
      LIMIT = MIN (KUSER, 2 * NAT)
C * IF 2 PEAKS ARE CLOSER THAN DM THE SMALLER IS ELIMINATED
      DM    = 0.50
C * SET UP CONSTANTS
      DO I = 1, 3
        DXMAX(I) = DM * PAR(112 + I)
      END DO
      DM = DM ** 2
C * SEARCH MAP FOR PEAK POSITIONS AND RECORD PEAK HEIGHTS
C * FIND POSITIONS OF PEAKS BY FITTING QUADRATIC FUNCTION TO 19 POINTS
      XLEVEL  = RHOMIN
C * SET UP TABLE OF OFFSETS TO LOOK UP 19 POINTS IN MAP
      IDF(1)  = - NXY - 1
      IDF(2)  = - NXY - NNX - 2
      IDF(3)  = - NXY
      IDF(4)  = - NXY + NNX + 2
      IDF(5)  = - NXY + 1
      IDF(6)  = - NNX - 3
      IDF(7)  = - 1
      IDF(8)  =   NNX + 1
      IDF(9)  = - NNX - 2
      IDF(10) = 0
      DO I = 1, 9
        IDF(20 - I) = - IDF(I)
      END DO
C * INITIALISE VARIABLES
      NO = 0
      IZ = - 1
      NZ = 0
   10 N  = - 1
      IF (IZ + 2 /= NNZ) THEN
C * READ IN FIRST SECTION (END OF LAST UNIT CELL)
        MAXX = NXY
        N    = NNZ - 1
        CALL PLA141 (FFT, R3D, MAXX, NNX, NNY, NXY3, N, IPOSNEG)
C * READ SECOND SECTION (START OF UNIT CELL)
        N   = 0
        CALL PLA141 (FFT, R3D, MAXX, NNX, NNY, NXY3, N, IPOSNEG)
      END IF
C * READ IN THE NEXT SECTION
   20 MX = MAXX - NXY + NNX + 1
      N  = N + 1
      CALL PLA141 (FFT, R3D, MAXX, NNX, NNY, NXY3, N, IPOSNEG)
      IZ = IZ + 1
      NZ = MOD (NZ + 2, 3) - 1
      M  = ISIGN (NXY3, NZ)
      IF (NZ <= 0) THEN
        DO I = 1, 5
          IDF(I) = IDF(I) - M
        END DO
        IF (NZ == 0) GO TO 30
      END IF
      DO I = 15, 19
        IDF(I) = IDF(I) - M
      END DO
C * SEARCH ONE SECTION OF THE MAP
   30 DO IY = 1, NNY
        MN = MX + 3
        MX = MX + NNX + 2
        DO 70 IX = MN, MX
          IF (R3D(IX) >= XLEVEL) THEN
C * LOCATE GRID POINT WITH MAXIMUM DENSITY
            DO I = 1, 9
              J = IDF(I) + IX
              IF (R3D(IX) <= R3D(J)) GO TO 70
            END DO
            DO I = 11, 19
              J = IDF(I) + IX
              IF (R3D(IX) < R3D(J)) GO TO 70
            END DO
C * FIT QUADRATIC FUNCTION TO 19 POINTS
C * DENS = A + C*X + D*Y + E*Z - 0.5*F*(X*X + Y*Y + Z*Z)
            DO I = 1, 19
              B(I) = R3D(IDF(I) + IX)
            END DO
            B1 = B(3)  + B(7)  + B(9)  + B(11) + B(13) + B(17)
            B2 = B(1)  + B(2)  + B(4)  + B(5)  + B(6)  + B(8) + B(12)
     1         + B(14) + B(15) + B(16) + B(18) + B(19)
            F  = (30.0 * B(10) + 11.0 * B1 - 8.0 * B2) / 63.0
            C  = (B(5) + B(12) + B(13) + B(14) + B(19) - B(1) - B(6)
     1         - B(7) - B(8) - B(15)) / 10.0
            DELTAX = C / F
            IF (ABS (DELTAX) <= 1.0) THEN
              D = (B(15) + B(16) + B(17) + B(18) + B(19) - B(1) - B(2)
     1          - B(3) - B(4) - B(5)) / 10.0
              DELTAY = D / F
              IF (ABS (DELTAY) <= 1.0) THEN
                E  = (B(4) + B(8) + B(11) + B(14) + B(18) - B(2) - B(6)
     1             - B(9) - B(12) - B(16)) / 10.0
                DELTAZ = E / F
                IF (ABS (DELTAZ) <= 1.0) GO TO 40
              END IF
            END IF
            DELTAX = 0.0
            DELTAY = 0.0
            DELTAZ = 0.0
   40       XX     = (FLOAT (IX - MN + 1) + DELTAX) * DX
            YY     = (FLOAT (IY)          + DELTAY) * DY
            ZZ     = (FLOAT (IZ)          + DELTAZ) * DZ
            NOP1                = NO + 1
            XXO(NATO + NOP1, 1) = XX
            XXO(NATO + NOP1, 2) = YY
            XXO(NATO + NOP1, 3) = ZZ
            XXO(NATO + NOP1, 4) = B(10)
            XXO(NATO + NOP1, 5) = F
            IF (NO > 0) THEN
              IR = 0
C * IF TWO PEAKS ARE CLOSER THAN DM ANGSTROMS ELIMINATE THE SMALLER
              DO K = 1, 3
                SGY(K)     = XXO(NATO + NOP1, K)
                SGY(K + 3) = 0.0
              END DO
              DO K = 1, NSYM
                KSYM = K
                CALL SGSM (ISW, ICL, SGY, KSYM, 6, IERR)
                XS(1) = SGY(7)
                XS(2) = SGY(8)
                XS(3) = SGY(9)
                DO 60 I = 1, NO
                  DO L = 1, 3
                    X1(L) = XXO(NATO + I, L) - XS(L)
   50               IF (ABS (X1(L)) <= 0.5) THEN
                      IF (ABS (X1(L)) > DXMAX(L)) THEN
                        GO TO 60
                      ELSE
                        CYCLE
                      END IF
                    END IF
                    X1(L) = X1(L) - SIGN (1.0, X1(L))
                    IF (.TRUE.) GO TO 50
                  END DO
                  IF (GEN006 (X1, AA, X1) <= DM) THEN
                    IF (B(10) <= XXO(NATO + I, 4)) GO TO 70
                    IF (IR > 0) XXO(NATO + IR, 4) =  -1.0
                    IR               = 0
                    XXO(NATO + I, 1) = XX
                    XXO(NATO + I, 2) = YY
                    XXO(NATO + I, 3) = ZZ
                    XXO(NATO + I, 4) = B(10)
                    XXO(NATO + I, 5) = F
                    IR               = I
                  END IF
   60           CONTINUE
              END DO
              IF (IR > 0) GO TO 70
            END IF
            NO = NOP1
            IF (NO >= LIMIT) THEN
              CALL GEN091 (XXO, DUMA, NP1, 6, NATO, NO, 4)
              NO     = NPIC
              XLEVEL = XXO(NATO + NPIC, 4)
            END IF
          END IF
   70   CONTINUE
      END DO
      IF (IZ < NNZ) THEN
        IF (IZ == (NNZ - 2)) THEN
          GO TO 10
        ELSE
          GO TO 20
        END IF
      END IF
C * SORT PEAKS IN ORDER OF PEAK HEIGHT (EL #4)
      CALL GEN091 (XXO, DUMA, NP1, 6, NATO, NO, 4)
      NPK = NO
      IF (MODE < 0) THEN
        N1 = NATO + 1
        N2 = NATO + NPK
C * GET ENVIRONMENT OF THE MAXIMA
C * DIFFERENCE MAP MODE
        IF (NPK > 0) THEN
          IF (MODE == -3) THEN
            N2 = MIN (N2, N1 + 24)
            CALL PLA143 (-1, 3.2, N1, N2, IPOSNEG)
            CALL PLA361 (1.2, N1, N2, IPOSNEG)
          ELSE
            CALL PLA143 (1, 3.2, N1, N2, IPOSNEG)
          END IF
        ELSE
          IF (IGBL(63) > 0) THEN
            IF (IPOSNEG > 0) THEN
              WRITE (LU6, 99999, IOSTAT = IOST)  RHOMIN / PAR(98)
            ELSE
              WRITE (LU6, 99998, IOSTAT = IOST) -RHOMIN / PAR(98)
            END IF
          END IF
        END IF
      END IF
99999 FORMAT (/, ':: No Positive Density Peaks > ', F5.2, ' eA^3', /)
99998 FORMAT (/, ':: No Negative Density Peaks < ', F5.2, ' eA^3', /)
      RETURN
      END SUBROUTINE PLA140
 
      SUBROUTINE PLA141 (FFT, R3D, IMAX, NNX, NNY, NXY3, NZ, IPOSNEG)
C * FOURIER + PEAKS
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: IX
      INTEGER            :: IY
      INTEGER            :: MX
      INTEGER            :: NZ
      INTEGER            :: LOC
      INTEGER            :: NNX
      INTEGER            :: NNY
      INTEGER            :: IMIN
      INTEGER            :: IMAX
      INTEGER            :: NXY3
      INTEGER            :: IPOSNEG
      REAL, DIMENSION(*) :: FFT
      REAL, DIMENSION(*) :: R3D
C * LOAD XY-LAYER (+ 2 ADDITIONAL COLUMNS AND ROWS)
      IF (IMAX >= NXY3) IMAX = 0
      MX   = IMAX
      IMAX = IMAX - 2
      LOC  = NNX * NNY * NZ
      DO IY = 1, NNY
        IMIN = IMAX + 3
        IMAX = IMAX + NNX + 2
        DO I = IMIN, IMAX
          LOC    = LOC + 1
          R3D(I) = AMAX1 (0.0, FFT(2 * LOC - 1) * IPOSNEG)
        END DO
C * ADD/COPY TWO COLUMN ENTRIES
        R3D(IMAX + 1) = R3D(IMIN)
        R3D(IMAX + 2) = R3D(IMIN + 1)
      END DO
C * ADD/COPY TWO ROWS
      IMIN = IMAX + 3
      IMAX = IMAX + 2 * NNX + 6
      DO IX = IMIN, IMAX
        MX      = MX + 1
        R3D(IX) = R3D(MX)
      END DO
      RETURN
      END SUBROUTINE PLA141
 
      SUBROUTINE PLA142 (MODE, VOD, FFT, R3D, NREF, FS000)
C * FFT & PEAKSEARCH
      USE files
      USE parameters
      USE reflex
 
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: M1
      INTEGER            :: M2
      INTEGER            :: M3
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      INTEGER            :: NPK
      INTEGER            :: LOC
      INTEGER            :: NATO
      INTEGER            :: NMAX
      INTEGER            :: MODE
      INTEGER            :: NREF
      INTEGER            :: NGRD2
      REAL               :: AC
      REAL               :: BC
      REAL               :: FS000
      REAL               :: RHOMIN
      REAL, DIMENSION(*) :: VOD
      REAL, DIMENSION(*) :: FFT
      REAL, DIMENSION(*) :: R3D
      WRITE (LU6, 99999) FS000
      WRITE (LU7, 99999) FS000
C * FILL FFT ARRAY WITH FRIEDEL MERGED REFLECTION DATA
      NATO  = IPR(589)
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      NGRD2 = 2 * M1 * M2 * M3
C * ZERO FFT-ARRAY
      CALL GEN074 (FFT, 1, NGRD2, 0.0)
      FFT(1) = FS000
      NMAX   = (NREF - 1) * NP69
      DO I = 0, NMAX, NP69
C * LOAD H, K, L DATA
        AC           = VOD(I + 7)
        BC           = VOD(I + 8)
        IH           = MOD (NINT (VOD(I +  9)) + M1, M1)
        IK           = MOD (NINT (VOD(I + 10)) + M2, M2)
        IL           = MOD (NINT (VOD(I + 11)) + M3, M3)
        LOC          = 2 * ((IL * M2 + IK) * M1 + IH + 1)
        FFT(LOC - 1) = AC
        FFT(LOC)     = BC
C * LOAD -H, -K, -L DATA
        IH           = MOD (-IH + M1, M1)
        IK           = MOD (-IK + M2, M2)
        IL           = MOD (-IL + M3, M3)
        LOC          = 2 * ((IL * M2 + IK) * M1 + IH + 1)
        FFT(LOC - 1) =  AC
        FFT(LOC)     = -BC
      END DO
C * FFT-TRANSFORM DATA FROM RECIPROCAL TO DIRECT SPACE
      CALL GEN028 (FFT, IPR(395), 3, -1)
C * ANALYSE GRID DENSITY DISTRIBUTION (VALIDATION MODE)
      IF (IGBL(129) /= 0) CALL PLA362 (FFT)
C * PEAK-SEARCH (POSITIVE AND NEGATIVE)
      RHOMIN = PAR(269) * PAR(98)
      CALL PLA140 (FFT, R3D, NATO, RHOMIN, MODE, NPK,  1, IPR(48))
      CALL PLA140 (FFT, R3D, NATO, RHOMIN, MODE, NPK, -1, IPR(48))
      RETURN
99999 FORMAT (':: F000 Input for FFT:', F10.2)
      END SUBROUTINE PLA142
 
      SUBROUTINE PLA143 (MODE, DMX, NB, NE, IPOSNEG)
C * Difference Fourier Map and Peak list Analysis
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: N
      INTEGER           :: MN
      INTEGER           :: NS
      INTEGER           :: NB
      INTEGER           :: NE
      INTEGER           :: ISW
      INTEGER           :: IXL
      INTEGER           :: NPK
      INTEGER           :: NAT
      INTEGER           :: NSYM
      INTEGER           :: NPKM
      INTEGER           :: NCCD
      INTEGER           :: MODE
      INTEGER           :: IHAT
      INTEGER           :: IHYB
      INTEGER           :: JMET
      INTEGER           :: IENR
      INTEGER           :: NPKV
      INTEGER           :: NPKM1
      INTEGER           :: IENR1
      INTEGER           :: IENR2
      INTEGER           :: JTEST
      INTEGER           :: IPOSNEG
      REAL              :: DMX
      REAL              :: DIST
      REAL              :: XDENS
      REAL              :: ALERT
      CHARACTER(len=1)  :: TYP
      CHARACTER(len=2)  :: AREA
      CHARACTER(len=4)  :: TYPEX
      CHARACTER(len=6)  :: MAXMIN
      CHARACTER(len=10) :: ENHANCED
C * MODE = -1 - DiffMap Listing
C * MODE =  1 - SQUEEZE-LISTING
C * MODE =  2 - SOLV-LISTING
C * DMX = MAXIMUM COORDINATION SEARCH DISTANCE
      V2(1) = DMX / (PAR(101) * SIN (PAR(105) / RGBL(6)) * PAR(121))
      V2(2) = DMX / (PAR(102) * SIN (PAR(106) / RGBL(6)) * PAR(119))
      V2(3) = DMX / (PAR(103) * SIN (PAR(104) / RGBL(6)) * PAR(120))
C * NB = FIRST DIFFERENCE MAP PEAK ADDRESS IN XXO COORDINATE ARRAY
C * NE = LAST  DIFFERENCE MAP PEAK ADDRESS IN XXO COORDINATE ARRAY
C * IPOSNEG =  1 - POSITIVE DENSITY PEAK ANALYSIS
C *         = -1 - NEGATIVE DENSITY PEAK ANALYSIS
C * GET NUMBER OF SYMMETRY OPERATIONS
      NSYM = IPR(48)
C * GET NUMBER OF INDEPENDENT ATOMS
      NAT  = IPR(37)
      NPKV = 0
      NCCD = 0
C * FIND DISTANCES BETWEEN ATOMS - ROLLETT, COMP. METH. IN CRYST. 1965
      IF (NE >= NB) THEN
        ENHANCED = ' '
        IF (ABS (MODE) == 1) THEN
          IF (IPOSNEG > 0) THEN
            MAXMIN = 'Maxima'
            IF (MODE == -1) PAR(330) = XXO(NB, 4) / PAR(98)
            IF (MODE == 1) THEN
              ENHANCED = ' Enhanced '
              PAR(330) = 0.0
              REWIND (UNIT = LU2, IOSTAT = IOST)
              IF (IOST /= 0) CALL GEN148 (LU2, 1)
              WRITE (LU2, 99994, IOSTAT = IOST)
     1          JID(1:74), (PAR(100 + I), I = 1, 6)
C * OUTPUT EITHER EXPLICIT SYMMETRY OR SPACEGROUP NAME (IF KNOWN)
              IF (SPGRNM(1)(1:3) == '   ') THEN
                WRITE (LU2, 99990, IOSTAT = IOST)
     1            SPGRNM(1)(13:13), SPGRNM(1)(14:14)
                ISW = 2
                DO I = 2, IPR(255)
                  CALL SGSM (ISW, ICL, SGY, I, 0, IERR)
                  WRITE (LU2, 99989, IOSTAT = IOST) ICL(1:60)
                END DO
              ELSE
                IF (SPGRNM(1)(8:11) == '    ') THEN
                  I = ICHAR (' ')
                ELSE
                  I = ICHAR ('.')
                END IF
                WRITE (LU2, 99988, IOSTAT = IOST)
     1            SPGRNM(1)(1:7), CHAR (I), SPGRNM(1)(8:11)
              END IF
              WRITE (LU2, 99991, IOSTAT = IOST)
     1          NINT (PAR(150)), NINT (PAR(354))
            END IF
          ELSE
            MAXMIN   = 'Minima'
            PAR(329) = 0.0
            IF (MODE == -1) PAR(329) = XXO(NB, 4) / PAR(98)
          END IF
          IF (IGBL(129) /= 0) THEN
            WRITE (LU13, 99998, IOSTAT = IOST)
            WRITE (LU13, 99999, IOSTAT = IOST) MAXMIN, ENHANCED,
     1        MAX (0.10, PAR(269)) * IPOSNEG, DMX
          END IF
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (0)
            WRITE (LU6, 99999, IOSTAT = IOST) MAXMIN, ENHANCED,
     1        MAX (0.10, PAR(269)) * IPOSNEG, DMX
            CALL PLA262 (5)
            WRITE (LU7, 99999, IOSTAT = IOST) MAXMIN, ENHANCED,
     1        MAX (0.10, PAR(269)) * IPOSNEG, DMX
          END IF
        ELSE
          WRITE (PRBUF, 99996, IOSTAT = IOST) DMX
          IF (IGBL(63) > 0) THEN
            WRITE (LU6, 99987, IOSTAT = IOST) PRBUF(1:80)
            CALL PLA262 (3)
            WRITE (LU7, 99987, IOSTAT = IOST) PRBUF(1:80)
          END IF
        END IF
C * LOOP OVER ADDITIONAL MAXIMA IN DIFFERENCE MAP PEAK LIST
        DO I = NB, NE
C * INIT NUMBER OF ATOMS WITHIN MAX COORDINATION DISTANCE DMX
          NPK = 0
C * LOOP OVER ATOMS
          DO J = 1, NAT
C * TEST FOR HYDROGEN (SKIPPED)
            CALL GEN048 (-1, IFG(1, J), 7, IHAT)
            IF (IHAT == 0) THEN
C * SYMMETRY LOOP
              DO N = 1, NSYM
                DO K = 1, 3
                  SGY(K)     = XXO(J, K)
                  SGY(K + 3) = 0.0
                END DO
                NS = N
                CALL SGSM (3, LINE, SGY, NS, LU6, IERR)
                K = 1
                GO TO 20
   10           SGY(6 + K) = SGY(6 + K) - 1.0
   20           IF ((XXO(I, K) - SGY(6 + K)) <= V2(K)) GO TO 10
                DO
                  SGY(6 + K) = SGY(6 + K) + 1.0
                  IF ((XXO(I, K) - SGY(6 + K)) < - V2(K)) THEN
                    K = K - 1
                    IF (K == 0) EXIT
                    CYCLE
                  END IF
                  IF (ABS (XXO(I, K) - SGY(6 + K)) <= V2(K)) THEN
                    K = K + 1
                    IF (K > 3) THEN
                      DO L = 1, 3
                        V3(L) = XXO(I, L) - SGY(6 + L)
                      END DO
                      CALL GEN002 (2, OR, V3, V4, DIST)
                      IF (DIST < DMX) THEN
                        IF (NPK == 0) THEN
                          JTEST = 0
                        ELSE
                          JTEST = IATC(NPK)
                        END IF
                        IF (J /= JTEST) THEN
                          NPK = NPK + 1
                          DATC(NPK) = DIST
                          IATC(NPK) = J
                        ELSE
                          IF (DIST < DATC(NPK)) DATC(NPK) = DIST
                        END IF
                      END IF
                      K = K - 1
                      CYCLE
                    END IF
                    GO TO 20
                  END IF
                END DO
              END DO
            END IF
          END DO
C * SORT SHORT CONTACTS AND LIST
          IENR1 = 0
          IENR2 = 0
          IF (MODE == 1) THEN
            TYPEX = 'void'
          ELSE
            TYPEX = '    '
          END IF
          CALL GEN036 (DATC, IATC, 1, NPK)
          NPKM1 = MIN (NPK, 9)
          IF (NPKM1 > 0) THEN
            DO J = 1, NPKM1
              IXL = - LABA(IATC(J))
              CALL PLA047 (IXL, NQ1, MN, IENR, 0, IGBL(55), 0,
     1          1 - IGBL(55))
              NAMS(J, 1) = NQ1
              IF (MODE == 1 .AND. IENR > 0) THEN
                IF (DATC(J) < ABS (VDWR(IENR)) + 1.2) TYPEX = '    '
              END IF
              IF (J == 1) IENR1 = IENR
              IF (J == 2) IENR2 = IENR
 
C * TEST FOR METAL CONTAINING STRUCTURE
              IF (IPR(155) == 1) THEN
                IF (DATC(J) < 1.2) THEN
C * TEST FOR METAL
                  CALL GEN048 (-1, IFG(1, IATC(J)), 19, JMET)
                  IF (JMET == 1) THEN
                    IF (DATC(J) < 0.2) THEN
                      IF (MODE == -1) THEN
                        XDENS = IPOSNEG * XXO(I, 4) / PAR(98)
                        IF (ABS(XDENS) > 0.75) THEN
C * CHECK FOR TWINNING AND NoSpherA2 AND _UNHARM_
                          IF (IPR(619) == 0 .AND. IPR(775) == 0 .AND.
     1                        IPR(756) == 0) THEN
                            IF (IPOSNEG > 0) THEN
C * ALERT _973 - LARGE POSITIVE DENSITY ON METAL
                              CALL PLA236 (973, 2,   XDENS, XDENS,
     1                          NQ1, ' ')
                            ELSE
C * ALERT _974 - LARGE NEGATIVE DENSITY ON METAL
                              CALL PLA236 (974, 2, - XDENS, XDENS,
     1                          NQ1, ' ')
                            END IF
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END IF
          NPKM = MIN (NPK, 4)
C * SOLV-LISTING MODE
          IF (MODE == 2) THEN
            WRITE (AREA, 99992, IOSTAT = IOST) I + 1 - NB
C * DIFF MAP & SQUEEZE MAP MODE
          ELSE IF (ABS (MODE) == 1) THEN
            XDENS = IPOSNEG * XXO(I, 4) / PAR(98)
            IF (ABS (XDENS) < 0.1) THEN
              NE = I
              GO TO 30
            END IF
            NPKV = NPKV + 1
C * SQUEEZE MODE = 1
            IF (NPKM > 0) THEN
              IF (DATC(1) < 2.0) THEN
                IF (IPOSNEG > 0) THEN
                  PAR(330) = MAX (PAR(330), XDENS)
                ELSE
                  PAR(329) = MIN (PAR(329), XDENS)
                END IF
              END IF
            END IF
          END IF
          IF (IGBL(63) > 0) CALL PLA262 (1)
          IF (ABS (MODE) == 1) THEN
C * TEST FOR FCF CHECKING
            IF (IGBL(129) /= 0) THEN
              IF (ABS (XDENS) > 0.75) THEN
C * CHECK FOR TWINNING, SQUEEZE/SQF, anharm
                IF (IPR(619) == 0 .AND. IPR(756) == 0) THEN
C * TEST FOR METAL TYPE OF NEAREST ATOM
                  CALL GEN048 (-1, IFG(1, IATC(1)), 19, JMET)
                  IF (JMET == 0 .OR. DATC(1) >= 0.2) THEN
                    WRITE (NQ2, 99986, IOSTAT = IOST) DATC(1)
C * CHECK FOR NoSpherA2
                    IF (IPR(775) == 0 .AND. NPKM > 0) THEN
                      IF (IPOSNEG > 0) THEN
C * ALERT _971 - Large + calculated resdidual density outside metal location
                        IF (IPR(725) /= 9) THEN
                          CALL PLA236 (971, 2,   XDENS, XDENS,
     1                      NAMS(1, 1), NQ2)
                        ELSE
                          CALL PLA236 (971, 2,  -999.0, XDENS,
     1                      NAMS(1, 1), NQ2)
                        END IF
                      ELSE
C * ALERT _972 - Large - calculated residual density outside metal location
                        IF (IPR(725) /= 9) THEN
                          CALL PLA236 (972, 2, -XDENS, XDENS,
     1                      NAMS(1, 1), NQ2)
                        ELSE
                          CALL PLA236 (972, 2, -999.0, XDENS,
     1                      NAMS(1, 1), NQ2)
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
C * CHECK FOR TWINNING
              IF (IPR(619) == 0) THEN
                ALERT = 0.0
                TYPEX = '    '
                IF (ABS (XDENS) > 0.4) THEN
                  WRITE (NQ2, 99986, IOSTAT = IOST) DATC(1)
                  IF (ABS (DATC(1) - 0.75) < 0.35) THEN
                    IF (NPKM > 1) THEN
                      IF (DATC(2) > 1.75) THEN
C * CHECK FOR NITROGEN OR OXYGEN
                        IF (IENR1 >= 2 .AND. IENR1 <= 4) THEN
                          IF (IENR1 == 2) THEN
                            CALL GEN048 (-4, IFG(1, IATC(1)), 24, IHYB)
                            IF (IHYB == 0) ALERT = XDENS
                          ELSE
                            ALERT = XDENS
                          END IF
                        END IF
                      END IF
                    ELSE
                      IF (IENR1 == 3) ALERT = XDENS
                    ENDIF
C * CHECK FOR NoSpherA2
                    IF (IPR(775) == 0) THEN
                      IF (ALERT > 0.0) THEN
C * ALERT _975 - POSITIVE DENSITY NEAR C, N OR O
                        CALL PLA236 (975, 2,   ALERT, ALERT,
     1                    NAMS(1, 1)(1:7)//' .', NQ2)
                        TYPEX = '+H?'
                      ELSE IF (ALERT < 0.0) THEN
C * ALERT _976 - NEGATIVE DENSITY NEAR N OR O
                        CALL PLA236 (976, 2, - ALERT, ALERT,
     1                    NAMS(1, 1)(1:7)//' .', NQ2)
                        TYPEX = '-H?'
                      END IF
                    END IF
                  END IF
                END IF
              END IF
              IF (MODE == -1) THEN
                IF (IPOSNEG > 0 .AND. NPKM >= 2) THEN
                  IF (DATC(1) < 0.9 .AND. DATC(2) < 0.9) THEN
                    IF (IENR1 == 2 .AND. IENR2 == 2) THEN
                      TYPEX = 'C-C'
                      NCCD = NCCD + 1
                    ELSE IF ((IENR1 == 2 .AND. IENR2 == 4) .OR.
     1                       (IENR1 == 4 .AND. IENR2 == 2)) THEN
                      TYPEX = 'C-N'
                    ELSE IF ((IENR1 == 2 .AND. IENR2 == 3) .OR.
     1                       (IENR1 == 3 .AND. IENR2 == 2)) THEN
                      TYPEX = 'C-O'
                    END IF
                  END IF
                END IF
              END IF
              WRITE (LU13, 99997, IOSTAT = IOST)
     1          NPKV, (XXO(I, J), J = 1, 3), XDENS, TYPEX,
     2          (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM)
            END IF
            IF (IGBL(63) > 0) THEN
              WRITE (LU6, 99997, IOSTAT = IOST)
     1          NPKV, (XXO(I, J), J = 1, 3), XDENS, TYPEX,
     2          (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM)
              WRITE (LU7, 99997, IOSTAT = IOST)
     1          NPKV, (XXO(I, J), J = 1, 3), XDENS, TYPEX,
     2          (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM1)
            END IF
            IF (IPOSNEG > 0) THEN
              IF (MODE == 1 .AND. NPKV < 100) THEN
                IF (TYPEX == 'void') THEN
                  TYP = 'C'
                ELSE
                  TYP = 'Q'
                END IF
                WRITE (LU2, 99993, IOSTAT = IOST)  TYP, 100 + NPKV,
     1            (XXO(I, J), J = 1, 3), XXO(I, 4) / PAR(98)
              END IF
            END IF
          ELSE
            IF (IGBL(63) > 0) THEN
              IF (NPKM == 0) TYPEX = 'none'
              WRITE (LU6, 99995, IOSTAT = IOST)
     1          AREA, (XXO(I, J), J = 1, 3), TYPEX,
     2          (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM)
              WRITE (LU7, 99995, IOSTAT = IOST)
     1          AREA, (XXO(I, J), J = 1, 3), TYPEX,
     2          (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM1)
            END IF
          END IF
        END DO
   30   WRITE (LU6, 99998, IOSTAT = IOST)
        IF (IGBL(63) > 0) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99998, IOSTAT = IOST)
        END IF
C * SKIP FOR IDEAL
        IF (BNDTP(1) == '  C-C' .AND. IPR(667) /= -1 .AND.
     1    IPR(757) == 0) THEN
C * ALERT _978 - REPORT DENSITY ON C-C BONDS (X-RAY ONLY)
          IF (MODE == -1 .AND. IPR(493) /= 7) THEN
            IF (IPOSNEG > 0 .AND. IPR(325) >= 0) THEN
              IF (NCCD > 0) THEN
                CALL PLA236 (978, 0, -999.0, FLOAT (NCCD), ' ', ' ')
              ELSE
                CALL PLA236 (978, 0, -999.0, FLOAT (NCCD), ' ', ' ')
              END IF
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (79('='), /, 'Unique Density ', A, ' in', A, 'Difference ',
     1 'Map (CutOff level =', F9.2, ' eA-3)', /, 79('='), /, 3X, '#',
     2 3X, 'x', 5X, 'y', 5X, 'z  (e/A^3)', 5X,
     3 'Shortest Contacts within', F4.1, ' Ang. (Excl. H)', /, 79('='))
99998 FORMAT (' ')
99997 FORMAT (I4, 3F6.3, F6.2, 1X, A, 1X, 9(A, F4.2, '; '))
99996 FORMAT (7X, 'x', 5X, 'y', 5X, 'z', 14X, 'Shortest ',
     1 'Contacts within', F4.1, ' Ang. (Excl. H)')
99995 FORMAT (1X, A, 1X, 3F6.3, 7X, A, 1X, 9(A, F4.2, '; '))
99994 FORMAT ('TITL ', A, /, 'CELL', 3F10.4, 3F10.2)
99993 FORMAT (A, I3, 3F6.3, ' ! ', F10.2, ' eA-3')
99992 FORMAT (I2)
99991 FORMAT ('# Solvent Accessible Volume =', I10, /,
     1        '# Electrons Found in S.A.V. =', I10, /,
     2        '# Note: Atoms in Void are Labelled as Cxxx and Qxxx ',
     3        'for all Others')
99990 FORMAT ('LATT ', A, 2X, A)
99989 FORMAT ('SYMM ', A)
99988 FORMAT ('SPGR ', 3A)
99987 FORMAT (/, A, /, 80('='))
99986 FORMAT (F6.2, 'Ang')
      END SUBROUTINE PLA143
 
      SUBROUTINE PLA144 (MODE, IAT)
C * CALCULATE AND DISPLAY RADIAL DISTRIBUTION FUNCTION
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER       :: I
      INTEGER       :: J
      INTEGER       :: K
      INTEGER       :: N
      INTEGER       :: NC
      INTEGER       :: JJ
      INTEGER       :: KL
      INTEGER       :: KN
      INTEGER       :: NI
      INTEGER       :: NK
      INTEGER       :: NM
      INTEGER       :: NIJ
      INTEGER       :: NCI
      INTEGER       :: NDB
      INTEGER       :: IAT
      INTEGER       :: IER
      INTEGER       :: IHA
      INTEGER       :: IPP
      INTEGER       :: KAT
      INTEGER       :: LBB
      INTEGER       :: LBC
      INTEGER       :: LBD
      INTEGER       :: MNI
      INTEGER       :: MNJ
      INTEGER       :: MNX
      INTEGER       :: MNY
      INTEGER       :: NDEC
      INTEGER       :: NORM
      INTEGER       :: KATP
      INTEGER       :: MKAT
      INTEGER       :: IDUB
      INTEGER       :: IDUM
      INTEGER       :: MODE
      INTEGER       :: IENI
      INTEGER       :: IENK
      INTEGER       :: ILMP
      INTEGER, SAVE :: NPNT
      INTEGER       :: MULTI
      INTEGER       :: ISDIJ
      INTEGER       :: IRESJ
      INTEGER       :: ILABX
      INTEGER       :: IDUM1
      INTEGER       :: IDUM3
      INTEGER       :: JNQNR
      INTEGER, SAVE :: NPNTM
      INTEGER, SAVE :: NBOND
      REAL          :: A
      REAL          :: XP
      REAL          :: YP
      REAL          :: XST
      REAL          :: DIJ
      REAL          :: SCF
      REAL          :: AMX
      REAL          :: SDIJ
      REAL          :: FACT
      REAL          :: PADD
      REAL          :: XSTEP
      REAL          :: SIGMA
C * MODE =  0 - INIT RADIAL DISTRIBUTION FUNCTION
C *      =  1 - COORDINATION LOOP OVER ATOMS
C *      = -1 - PLOT RADIAL DISTRIBUTION FUNCTION
C * GET NUMBER OF ATOMS IN COORDN ARRAYS (IATC AND DATC)
      IF (MODE > 0) THEN
        NC = IPR(79)
        IF (NC > 0) THEN
          CALL PLA047 (LABA(IAT), NQ3, MNX, IENI, 0, IGBL(55), 0,
     1                                             1 - IGBL(55))
          CALL GEN048 (-8, IFG(2, IAT), 1, IPP)
          MULTI = IPR(48) / IPPR(IPP + 1, 3)
C * GET LABEL ETC. IAT
          CALL PLA036 (IAT, 1, 1, IDUM1, MNI, IDUM3, IPR(71),
     1         IGBL(55))
C * DETERMINE NUMBER OF BONDED ATOMS
          NCI = 0
          NDB = 0
          DO J = 1, NC
            KAT  = IATC(J)
            MKAT = MOD (KAT, NP1)
C * ELIMINATE SOME REDUNDANCY
            IDUB = 0
            IF (J > 1) THEN
              DO K = 2, J
                IF (MKAT == MOD(IATC(K - 1), NP1)) THEN
                  IDUB = 2
                  NDB  = NDB + 1
                END IF
              END DO
            END IF
C * CHECK FOR H
            CALL GEN048 (-1, IFG(1, MKAT), 7, IHA)
C * MAKE NON-BOND TO SORT DOWNWARDS IN THE BOND-LIST
            PADD = (IDUB + IHA + 1) * PAR(23)
            IF (KAT <= NP1) THEN
C * CHECK WHETHER THIS CONNECTION IS IN THE BOND ARRAY
              CALL PLA040 (-1, IAT, JJ, KAT)
              IF (JJ > 0) THEN
                NCI  = NCI + 1
                PADD = 0
              END IF
            END IF
            DATC(J) = PADD + DATC(J)
          END DO
C * SORT COORDINATION BONDS IN IATC ACCORDING TO DISTANCE IN DATC
          CALL GEN036 (DATC, IATC, 1, NC)
          NC = NC - NDB
C * LOOP OVER CONTACTS
          DO J = 1, NC
            KAT     = IATC(J)
            IPR(20) = 0
            IF (KAT > NP1) THEN
              KAT     = KAT - NP1
              IATC(J) = KAT
              IPR(20) = 1
            END IF
            CALL GEN048 (-6, IFG(1, KAT), 9, IRESJ)
C * GET LABEL ETC. INFORMATION KAT
            CALL PLA036 (KAT, 1, 2, IDUM1, MNJ, IDUM3, IPR(71),
     1           IGBL(55))
C * FIRST GET SEQUENCE # IN PRIMARY LIST
            ILABX = - LABA(KAT)
            CALL PLA047 (ILABX, NQ4, MNY, IENK, IPR(71), IGBL(55),
     1        0, 1 - IGBL(55))
            CALL PLA046 (2, NQ4, IDUM, LBB, LBC, LBD, ILMP, JNQNR, KATP)
            CALL PLA047 (LABA(KAT), NQ3, MNY, IENK, IPR(71),
     1        IGBL(55), 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       = NINT (DIJ * 100.0) + NPNT + 1
            DATC(NIJ) = DATC(NIJ) + FLOAT (NI * NK) / FLOAT (MULTI)
          END DO
        END IF
C * INIT RADIAL DISTRIBUTION FUNCTION CALCULATION
      ELSE IF (MODE == 0) THEN
        NBOND = 0
        NPNT  = NINT (PAR(262) * 100.0) + 1
        NPNTM = 2 * NPNT
        CALL GEN074 (DATC, NPNT + 1, NPNTM, 0.0)
C * PLOT RADIAL DISTRIBUTION FUNCTION
      ELSE IF (MODE == -1) THEN
        DO
C * INDIVIDUAL PEAK SIGMA
          SIGMA = PAR(451)
C * NORMALIZE RDF (0/1)
          NORM  = IPR(581)
C * ZERO RDF-Y ARRAY
          CALL GEN074 (DATC, 1, NPNT, 0.0)
          DO I = 2, NPNT
            A = DATC(NPNT + I)
            IF (A > 0.0) THEN
C * NORMALIZE
              IF (NORM /= 0) A = A / (I - 1)
              DATC(I) = DATC(I) + A
              DO J = 1, 199
                FACT = A * EXP (- (J / SIGMA) ** 2)
                IF (FACT < 0.1E-30) EXIT
                IF (I + J <= NPNT) DATC(I + J) = DATC(I + J) + FACT
                IF (I - J > 0)     DATC(I - J) = DATC(I - J) + FACT
              END DO
            END IF
          END DO
          AMX = 0.0
          DO I = 1, NPNT
            AMX = MAX (AMX, DATC(I))
          END DO
          DO
            IGBL(6)   = 28
            BCD(1:30) = 'Simulated Radial Distribution'//CHAR (0)
            CALL GGIP (HORS, VERT, 0.0, 1)
            CALL PLA439 (0.0,  BCD, 29, 1.0, 4, 8, 0.6, VERT - 1.6)
            CALL PLA439 (0.0,  BCD, 29, 1.0, 2, 8, 0.5, VERT - 1.7)
            CALL PLA110 (HORS, VERT, -1)
            VRT = VERT - 3.0
            CALL PLA283 (0, 1.0, N, CFORM)
            WRITE (LINE, 99989, IOSTAT = IOST) CFORM(N:NP52)
            CALL PLA439 (0.0, LINE, 60, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99999,IOSTAT = IOST) SPGRNM(1)(1:7)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 17, 0.35, 1, 1, 1.5, VRT)
C * DISPLAY DIRECT CELL
            WRITE (LINE, 99998, IOSTAT = IOST) PAR(101)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99997, IOSTAT = IOST) PAR(102)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99996, IOSTAT = IOST) PAR(103)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99995, IOSTAT = IOST) PAR(104)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99994, IOSTAT = IOST) PAR(105)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99993, IOSTAT = IOST) PAR(106)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            WRITE (LINE, 99990, IOSTAT = IOST) PAR(98)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
            XSTEP = (HORS - 2.0) / (NPNT - 1)
            SCF   = (VERT - 4.0) / AMX
            CALL GGIP (1.0, 2.0, 0.0, 3)
            OPEN (UNIT = LU64, FILE = NAMEFIL(1:KNMFIL)//'.rdf',
     1        STATUS = 'UNKNOWN')
            DO I = 1, NPNT
              XP = 1.0 + (I - 1) * XSTEP
              YP = 2.0 + SCF * DATC(I)
              CALL GGIP (XP, YP, 0.0, 2)
              WRITE (LU64, 99988) FLOAT (I - 1) / 100.0, SCF * DATC(I)
            END DO
            CLOSE (LU64)
            WRITE (LU6, 99987) NAMEFIL(1:KNMFIL)//'.rdf'
            CALL GGIP (0.0, 0.0, 0.0, 3)
C * PLOT HORIZONTAL SCALE
            XP  = 1.0
            N   = 0
            NM  = NPNT / 50
            XST = XSTEP * 50
            DO WHILE (N <= NM)
              CALL GGIP (XP, 1.0, 0.0, 3)
              CALL GGIP (XP, 1.4, 0.0, 2)
              IF (N < 20) THEN
                WRITE (NQ1, 99992, IOSTAT = IOST) N * 0.5
              ELSE
                WRITE (NQ1, 99991, IOSTAT = IOST) N * 0.5
              END IF
              CALL PLA439 (0.0, NQ1, 4, 0.2, 2, 2, XP + 0.1, 1.2)
              XP = XP + XST
              N  = N  + 1
            END DO
            CALL PLA439 (0.0, 'Angstrom', 8, 0.3, 2,2, HORS - 2.4, 0.2)
C * WHAT NEXT ?
C * WHAT NEXT ?
            CALL PLA012 (0, 1)
              CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7,
     1          NP17)
            IF (IFL(1)(1:4) == 'EXIT') THEN
              RETURN
            ELSE IF (IFL(1)(1:4) == 'CALC') THEN
              EXIT
            ELSE IF (IFL(1)(1:3) == 'END') THEN
              IGGT = ' '
              IGBL(6) = 10
C * RESET
              CALL PLA286 (0)
              RETURN
            ELSE IF (LRET == 2) THEN
              EXIT
            END IF
          END DO
          IF (LRET /= 2) EXIT
        END DO
      END IF
      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)
99988 FORMAT (2F10.3)
99987 FORMAT (/, ':: RDF on: ', A, /)
      END SUBROUTINE PLA144
 
      MODULE asym
      SAVE NONE
      INTEGER, PARAMETER                    :: NP44 = 512
      INTEGER, PARAMETER                    :: NP63 = 1000
      INTEGER, PARAMETER                    :: NP68 = 48
      INTEGER, PARAMETER                    :: NP79 = 24
      INTEGER, PARAMETER                    :: NP80 = 96
      INTEGER, PARAMETER                    :: NP82 = 6
      INTEGER, PARAMETER                    :: NP83 = 24
      INTEGER, PARAMETER                    :: NP84 = 24
      INTEGER                               :: IPL
      INTEGER                               :: NHEAD
      INTEGER                               :: NMISS
      INTEGER,           DIMENSION(252)     :: ID
      INTEGER,           DIMENSION(NP63)    :: IT
      INTEGER,           DIMENSION(NP68, 2) :: IRC
      INTEGER,           DIMENSION(NP68, 2) :: IRD
      INTEGER,           DIMENSION(3)       :: IKS
      INTEGER,           DIMENSION(6)       :: IHM
      INTEGER,           DIMENSION(2, 2)    :: IRAB
      INTEGER,           DIMENSION(3)       :: IHKL
      INTEGER,           DIMENSION(NP68)    :: MULT
      INTEGER,           DIMENSION(20, 2)   :: ICNT
      INTEGER,           DIMENSION(3)       :: IHKLE
      INTEGER,           DIMENSION(3, NP79) :: NTHMN
      INTEGER,           DIMENSION(3, NP80) :: NTHMX
      INTEGER,           DIMENSION(3, NP82) :: NBSTP
      INTEGER,           DIMENSION(3, NP83) :: NOUTX
      INTEGER,           DIMENSION(3, NP84) :: NSTRM
      REAL                                  :: ATHM
      REAL                                  :: ATHMN
      REAL                                  :: CALIM
      REAL,              DIMENSION(2, 3)    :: SM
      REAL,              DIMENSION(NP68, 2) :: RA
      REAL,              DIMENSION(NP68, 2) :: RB
      REAL,              DIMENSION(12)      :: FULL
      REAL,              DIMENSION(20, 12)  :: STAT
      REAL,              DIMENSION(NP68)    :: PERCENT
      CHARACTER(len=NP44)                   :: CID
      CHARACTER(len=60), DIMENSION(104)     :: AR
      CHARACTER(len=1),  DIMENSION(3)       :: ZONE = (/'H', 'K', 'L'/)
      END MODULE asym
 
      SUBROUTINE PLA145 (MODE)
C *********************************************************************
C * ASYM - PROGRAM FOR THE DISPLAY AND EXTRACTION OF A UNIQUE SET OF  *
C *        REFLECTIONS OUT OF A REDUNDANT SET + AB-INITIO GENERATION. *
C *        A.L.SPEK, Utrecht University, The Netherlands (1975-2025)  *
C *********************************************************************
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE mentry
      USE xwdw
      USE cggt
      USE spgrdata
      USE reflex
      USE pl127
      USE asym
      USE sgxyz
      USE cif
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: I6
      INTEGER           :: N2
      INTEGER           :: JM
      INTEGER           :: IS
      INTEGER           :: IH
      INTEGER           :: IK
      INTEGER           :: IL
      INTEGER           :: IA
      INTEGER           :: JP
      INTEGER           :: MH
      INTEGER           :: MK
      INTEGER           :: ML
      INTEGER           :: MM
      INTEGER           :: NB
      INTEGER           :: NN
      INTEGER           :: N01
      INTEGER           :: N02
      INTEGER           :: N11
      INTEGER           :: N12
      INTEGER           :: IJK
      INTEGER           :: IHK
      INTEGER           :: IHT
      INTEGER           :: IKT
      INTEGER           :: ILT
      INTEGER           :: IND
      INTEGER           :: NID
      INTEGER           :: NPZ
      INTEGER           :: INTM
      INTEGER           :: NLEV
      INTEGER           :: MAXI
      INTEGER           :: MAXM
      INTEGER           :: JUNK
      INTEGER           :: JMAX
      INTEGER           :: ITEL
      INTEGER           :: IRM1
      INTEGER           :: IRM2
      INTEGER           :: IOB1
      INTEGER           :: IOB2
      INTEGER           :: IOB3
      INTEGER           :: IOB4
      INTEGER           :: IMAX
      INTEGER           :: IJKM
      INTEGER           :: IHKA
      INTEGER           :: IHKB
      INTEGER           :: IDUM
      INTEGER           :: MODE
      INTEGER           :: IBVT
      INTEGER           :: NORI
      INTEGER           :: NTEL
      INTEGER           :: NSMAL
      INTEGER           :: NOUTL
      INTEGER           :: NFUL1
      INTEGER           :: NFULL
      INTEGER           :: IVGNR
      INTEGER           :: IHKL2
      INTEGER           :: IASIG
      INTEGER           :: LUP17
      INTEGER           :: LUP18
      INTEGER           :: IGETAL
      INTEGER           :: IOBUF1
      INTEGER           :: LOGMAX
      INTEGER           :: IGBL6SAVE = 0
      REAL              :: R
      REAL              :: S
      REAL              :: TH
      REAL              :: SA
      REAL              :: R1
      REAL              :: R2
      REAL              :: AI
      REAL              :: RS
      REAL              :: XI
      REAL              :: CR1
      REAL              :: CR2
      REAL              :: CR3
      REAL              :: WR2
      REAL              :: GOF
      REAL              :: STH
      REAL              :: STL
      REAL              :: THM
      REAL              :: TEL
      REAL              :: STHK
      REAL              :: REFA
      REAL              :: REFB
      REAL              :: CRIT
      REAL              :: ACAL
      REAL              :: BCAL
      REAL              :: CALI
      REAL              :: DIFF
      REAL              :: DIFH
      REAL              :: DIFK
      REAL              :: DIFL
      REAL              :: DOSW
      REAL              :: RSIG
      REAL              :: SIGI
      REAL              :: SIGK
      REAL              :: SIGS
      REAL              :: YDUM
      REAL              :: YUNK
      REAL              :: SCAL
      REAL              :: XSIGM
      REAL              :: XIMAX
      REAL              :: UCINT
      REAL              :: STLMX
      REAL              :: PSCFA
      REAL              :: PSCFB
      REAL              :: DOSAV
      REAL              :: DOSAW
      REAL              :: ACALA
      REAL              :: BCALA
      REAL              :: ACALS
      REAL              :: BCALS
      REAL              :: CRITO
      REAL              :: SIGIW
      REAL              :: SMCAL
      REAL              :: SMEXB
      REAL              :: SMEXT
      REAL              :: SMOBS
      REAL              :: SNTHA
      REAL              :: WEIGHT
      REAL              :: SINTHL
      REAL              :: SCFHKL
      REAL              :: DOVERS
      REAL              :: FACTOR
      REAL              :: COUNTB
      REAL              :: ACALAF
      REAL              :: BCALAF
      REAL              :: GEN013
      REAL              :: GEN050
      REAL              :: GEN095
      REAL              :: AVERAGE
      REAL              :: SIGIMAX
      CHARACTER(len=80) :: AA
      CHARACTER(len=1)  :: IUU
      CHARACTER(len=60) :: XAR
      CHARACTER(len=80) :: LIJN
      CHARACTER(len=1)  :: QMRK
      CHARACTER(len=80) :: ICRD
      CHARACTER(len=38) :: STAR
      CHARACTER(len=39) :: BLANKO
      CHARACTER(len=3)  :: FILETYPE
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IAR
C * MODE     =  0 - DEFAULT ASYM
C * MODE     =  1 - EXPECT NUMBER OF REFLECTIONS
C * MODE     =  2 - VALIDATION MODE (+ AVF)
C * MODE     =  3 - VALIDATION MODE
C * IPR(408) = -1 - EXPAND (IOBS)
C *          =  0 - NORMAL-MODE
C *          =  1 - GENERATE
C *          =  2 - EXPECT
C * IPR(392) =  0 - LISTING OF SYMMETRY ABSENT REFLECTIONS ONLY
C *          =  1 - LISTING OF REFLECTIONS ONLY
C *          =  2 - LISTING OF RECIPROCAL LATTICE ONLY
C *          =  3 - FULL LISTING OPTION
      ALLOCATE (IAR(NVDI))
      LUP17    = LU17
      LUP18    = LU18
      IRM1     = 0
      IRM2     = 0
      PAGET    = 'ASYM'
      IPR(512) = 0
C * SET DEFAULT RESOLUTION (0/1)
      IPR(387) = 1
C * SET AXES (0/1)
      IPR(388) = 1
C * SET SUMMARY (0/1)
      IPR(406) = 1
C * SPECIAL OPTION GENERATION MODES
      IPR(221) = 0
C * SET EXOR/SS
      PAR(284) = 2.0
      NOUTL    = 0
      NSMAL    = 0
      SMOBS    = 0.0
      SMCAL    = 0.0
      WRITE (BLANKO, 99920)
      WRITE (STAR  , 99919)
C * CHECK FOR PROPER UNITCELL
      IF (PAR(101) < 1.001) THEN
C * CHECK FOR VALIDATION MODE
        IF (IGBL(22) == -1) THEN
          WRITE (LU13, 99954, IOSTAT = IOST)
        ELSE
          WRITE (LU6,  99954, IOSTAT = IOST)
        END IF
        RETURN
      END IF
C * CHECK FOR RADIATION TYPE
      CALL PLA293 (PAR(17))
C * CREATE FCF WHEN ABSENT (GIVEN SHELXL-20xy CIF INPUT BASED)
C * OR COPY FROM EMBEDDED FCF
      CALL PLA346
C * OPEN .hks file
      OPEN (UNIT = LUP18, FILE = NAMEFIL(1:KNMFIL) //'.hks',
     1  STATUS = 'UNKNOWN', IOSTAT = IOST)
C * DEFAULT ASYM RUN
      IF (MODE == 0) THEN
        REWIND (UNIT = LUP17, IOSTAT = IOST)
        REWIND (UNIT = LUP18, IOSTAT = IOST)
C * EXPECT NUMBER OF REFLECTIONS
      ELSE IF (MODE == 1) THEN
        IFL(2)   = 'EXPECT'
        IPR(220) = 2
C * VALIDATION MODE (+ AVF)
      ELSE IF (MODE == 2) THEN
C * SET ANOMALOUS DISPERSION VALUES
        IF (IPR(704) == 0) CALL PLA340
        IFL(2)   = 'AVF'
        IFL(3)   = 'VALID'
        IPR(220) = 3
C * ZERO # OBSERVED SPGR ABSENT REFLECTIONS
        IPR(754) = 0
C * VALIDATION MODE
      ELSE IF (MODE == 3) THEN
        IFL(2)   = 'VALID'
        IPR(220) = 2
      END IF
C * LOOP OVER COMMAND OPTIONS
      N = 0
      IF (IPR(220) > 1) THEN
        DO I = 2, IPR(220)
          SELECT CASE (IFL(I)(1:6))
C * ASYM EXPECT MODE (BASED ON REPORTED THETA-MAX) [MODE = 1]
            CASE ('EXPECT')
              PAGET    = 'EXPECT'
              PAR(165) = PAR(168)
              IPR(408) = 2
              IPR(392) = 0
              IPR(393) = 0
              WRITE (LU6, 99940, IOSTAT = IOST)
C * ASYM VALIDATION MODE [MODE = 2 & 3]
            CASE ('VALID ')
C * ALERT _998 - LIST 3 (UNSUITABLE)
              IF (IGBL(9) == 21) THEN
                CALL PLA236 (998, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _999 - LIST 6 (UNSUITABLE)
              ELSE IF (IGBL(9) == 23) THEN
                CALL PLA236 (999, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _997 - NO-SHELXL CIF/FCF COMBINATION
              ELSE IF (IPR(725) > 0 .AND. IPR(725) < 3) THEN
                IF (IGBL(9) /= 1 .AND. IGBL(9) /= 25) THEN
                  CALL PLA236 (997, 0, 1.0, 1.0, ' ', ' ')
                END IF
              END IF
              INQUIRE (FILE = FNLU16(1:KNM16), EXIST = EXST)
              IF (.NOT. EXST) THEN
                WRITE (6, 99963, IOSTAT = IOST)
     1          FNLU16(1:KNM16-3)//'hkl or fcf'
                WRITE (LU13, 99963, IOSTAT = IOST)
     1          FNLU16(1:KNM16-3)//'hkl or fcf'
                GO TO 90
              END IF
              PAR(165)  = PAR(168)
              IPR(408)  = 0
              IPR(392)  = 3
              IGBL(22)  = -1
              IGBL(129) = 1
C * OPEN FCF-CHECK OUTPUT
              INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.ckf',
     1                 OPENED = OPEND)
              IF (.NOT. OPEND) THEN
                OPEN (UNIT = LU13, FILE = NAMEFIL(1:KNMFIL) //'.ckf',
     1                STATUS = 'UNKNOWN')
              END IF
C * ASYM HKL EXPAND MODE
            CASE ('EXPAND')
              IPR(408) = -1
C * ASYM GENERATE MODE
            CASE ('GENERA')
C * CHECK FOR ATOMS
              IF (IPR(37) > 0) THEN
                IPR(408) = 1
                IPR(700) = NINT (FN(1))
                CLOSE (UNIT = LU17, STATUS = 'DELETE', IOSTAT = IOST)
                OPEN (UNIT = LU17,
     1            FILE = NAMEFIL(1:KNMFIL)//'_gener.hkl',
     2            STATUS = 'UNKNOWN', IOSTAT = IOST)
              ELSE
                IPR(2) = 42
                RETURN
              END IF
C * AVERAGE FRIEDEL PAIRS
            CASE ('AVF   ')
              IPR(393) = 1
C * ASYM VIEW MODE
            CASE ('VIEW  ')
              IGBL(22) = 1
            CASE ('ZONEH ')
              IPR(394) = 1
            CASE ('ZONEK ')
              IPR(394) = 2
            CASE ('ZONEL ')
              IPR(394) = 3
C * REFLECTION LIST OPTION
            CASE ('LIST  ')
              N        = N + 1
              IPR(392) = NINT (FN(N))
C * THETA MAX
            CASE ('THM   ')
              N        = N + 1
              PAR(165) = FN(N)
          END SELECT
        END DO
      END IF
C * CHECK FOR REGULAR REFLECTION DATA INPUT OR REFLECTION DATA TO BE GENERATED
C * REFLECTION GENERATE MODE
      IF (IPR(408) == 1) THEN
        PAR(165) = ASIN (MIN (1.0, PAR(287) * PAR(17))) * RGBL(6)
C * EXPAND COORDINATE DATA TO TRICLINIC
        CALL PLA287 (1, 1, 0)
C * INIT RANDOM NUMBER GENERATOR
        IDUM = -1
        YUNK = GEN013 (IDUM)
C * REPORT NUMBER OF EXPECTED REFLECTIONS
      ELSE IF (IPR(408) == 2) THEN
        IF (IGBL(63) > 0) THEN
          CALL PLA262 (0)
          WRITE (LU7, 99978, IOSTAT = IOST)
          CALL PLA262 (2)
        END IF
C * REGULAR REFLECTION MODE
      ELSE
        IF (IPR(39) == 0 .OR. MODE == 0) THEN
C * CELL PARAMETERS
          CALL PLA100
C * LATTICE/SYMMETRY HEADER
          CALL PLA042 (1)
        END IF
      END IF
      CALL PLA262 (0)
C * CHECK FOR VALIDATION MODE
      IF (IGBL(22) == -1) THEN
        IF (IPR(37) /= 0) CALL PLA287 (1, 0, 0)
        IGBL(63) = 0
        IPR(676) = 1
C * WRITE .CKF LISTING HEADER
        WRITE (LU13, 99971, IOSTAT = IOST) IGBL(4), MODE, JID(1:16),
     1    HTTPSERVER(1:IGBL(135)),
     2    NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT), FNLU16(1:KNM16),
     3    RDTYP(IGBL(9)), SPGRNM(1)(1:7), PAR(17),
     4    (PAR(100 + M), M = 1, 6)
C * SHELXL WEIGHT PARAMETERS
        IF (PAR(493) >= 0.0) THEN
          IF (IABS(IPR(632)) == 1) THEN
            WRITE (LU13, 99952, IOSTAT = IOST) (PAR(I), I = 493, 498)
C * JANA WEIGHT PARAMETER
          ELSE IF (IPR(632) == 2) THEN
            WRITE (LU13, 99936, IOSTAT = IOST) PAR(493)
C * CRYSTALS WEIGHT PARAMETERS
          ELSE IF (IABS(IPR(632)) == 3) THEN
            WRITE (LU13, 99952, IOSTAT = IOST) PAR(493), PAR(494)
          ENDIF
        ENDIF
        IF (PAR(229) > -999999.0)
     1    WRITE (LU13, 99951, IOSTAT = IOST) PAR(229)
      END IF
C * CHECK FOR VALIDATION (= -1) OR VIEW (= 1) MODE
      IF (IGBL(22) /= 0) THEN
        LUP17 = 0
        LUP18 = 0
        NMISS = 0
      END IF
      NLEV = -2
      NID  =  0
      GO TO 40
C * INPUT EVENT LOOP
   10 CALL PLA012 (0, 1)
      SELECT CASE (LRET)
        CASE (2)
          GO TO 90
        CASE (3)
          NLEV = -2
          NID  =  0
          GO TO 40
        CASE (4)
          IF (NLEV == -2) GO TO 40
      END SELECT
C * TEST FOR FULL LISTING OPTION (=3)
   20 IF (IPR(392) /= 3) GO TO 90
C * LEVEL UP/DOWN
      NLEV = MAX (0, NLEV + IPR(389))
C * LOOP OVER LEVELS
      IF (NLEV > -1) THEN
        NHEAD = 0
        DO
          CALL PLA147 (NLEV)
          IF (IGBL(22) < 0) THEN
            IF (IKS(IND3) > NLEV) THEN
              GO TO 60
            ELSE
              NLEV = NLEV + 1
              CYCLE
            END IF
          ELSE
            GO TO 10
          END IF
        END DO
      END IF
C * ZONE(X) - X = H,K,L
   40 IND3 = IPR(394)
      IF (IPR(394) == 2) THEN
        IND1 = 1
        IND2 = 3
      ELSE IF (IPR(394) == 1) THEN
        IND1 = 2
        IND2 = 3
      ELSE
        IND1 = 1
        IND2 = 2
      END IF
      IPR(362) = 0
      CALL GEN097 (IHM,   1,   6, 0)
      CALL GEN097 (IPR, 370, 386, 0)
      CALL GEN097 (ICNT,  1,  40, 0)
      CALL GEN097 (IT,    1, 200, 0)
      THM   = PAR(165)
      STHKM = (SIN (THM / RGBL(6)) / PAR(17))**2
 
C * READ REFLECTIONS
      ITEL   = 0
      NLEV   = -1
      IHT    = 0
      IKT    = 0
      ILT    = 0
      INTM   = 0
      XSIGM  = 0.0
      ATHM   = 0.0
      ATHMN  = 999.0
      DOSAV  = 0.0
      DOSAW  = 0.0
      CALIM  = 0.0
      SMEXT  = 0.0
      SMEXB  = 0.0
      NSYMH  = IPR(255)
      ICNTR  = IPR(257)
      IBVT   = IPR(241)
C * CHECK FOR CENTRO
      IF (ICNTR == 1 .AND. IPR(275) == 2) NSYMH = NSYMH / 2
      IMAX   = NSYMH * 6 + 3
      FACTOR = 10.0 / (0.65**3 + 0.0001)
 
C * REFLECTION INTENSITY SCALING (LOOP)
C * GENERATE MODE RUN
      IF (IPR(408) == 1) THEN
        PSCFA = 100.0
        PSCFB =  10.0
C * EXPECT MODE RUN
      ELSE IF (IPR(408) == 2) THEN
        PSCFA = 1.0
        PSCFB = 1.0
C * NORMAL & EXPAND MODE RUNS
      ELSE
        XIMAX   = 0.0
        SIGIMAX = 0.0
        LOGMAX  = 0.0
        IEND    = -1
        DO WHILE (IEND <= 0)
          CALL PLA132 (IH, IK, IL, XI, SIGI, SIGIW, CALI, UCINT,
     1      ACALS, BCALS)
          IF (IEND /= 1) THEN
            IF (IEND == 2) THEN
              RETURN
            ELSE
              IF (IABS (IH) + IABS (IK) + IABS (IL) > 0) THEN
C * USE IOBS OR ICALC (FOR SIMULATED POWDER DIAGRAM)
                IF (IPR(511) == 2) XI = CALI
                XIMAX   = MAX (XIMAX, XI)
                SIGIMAX = MAX (SIGIMAX, SIGI)
              END IF
            END IF
          END IF
        END DO
        IF (SIGIMAX /= 0.0) THEN
          LOGMAX = INT (MAX (LOG10 (XIMAX), LOG10 (SIGIMAX)))
        END IF
        IPR(746) = LOGMAX
        IF (LOGMAX < 7) THEN
          PSCFA    = 10**(6 - LOGMAX)
        ELSE
          PSCFA = 1.0 / 10**(LOGMAX - 6)
        END IF
        PSCFB = PSCFA
      END IF
C * REWIND
      CALL GEN108 (LU8, 0)
      NFUL1 = 0
      DO I = 1, 20
        DO J = 1, 12
          STAT(I, J) = 0.0
        END DO
      END DO
      IPR(371) = 0
      IPR(637) = 0
      IPR(638) = 0
      NMISS    = 0
      NTEL     = 0
      PAR(373) = 0.0
      PAR(374) = 0.0
      CALL PLA169 (0, 0.0, 0.0, 0.0, 0)
      CALL GEN097 (MULT, 1, NP68, 0)
C * REFLECTION FILE READ LOOP
      M    = 0
      IEND = -1
      DO WHILE (IEND <= 0)
        CALL PLA132 (IH, IK, IL, XI, SIGI, SIGIW, CALI, UCINT,
     1               ACALS, BCALS)
C * USE IOBS OR ICALC (FOR SIMULATED POWDER DIAGRAM)
        IF (IPR(511) == 2) XI = CALI
        IF (IEND == 2) RETURN
        IF (IEND /= 1 .AND. (IABS(IH) + IABS(IK) + IABS(IL)) > 0) THEN
C * APPLY TRANSFORMATION (IF ANY) AND ELIMINATE REFL WITH NON-INTEGRAL INDICES
C * TEST FOR NON-GENERATE MODE
          IHT = IH
          IKT = IK
          ILT = IL
          IF (IPR(408) /= 1) THEN
C * CHECK FOR NON-UNIT TRANSFORMATION MATRIX (VALUE 0 OR 1)
              IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) < 0.0)
     1          THEN
                IPR(371) = IPR(371) + 1
                IF (XI > 5.0 * SIGI) THEN
                  ITEL = ITEL + 1
C * TEST FOR NON-VALIDATION MODE (= -1)
                  IF (IGBL(22) /= -1) THEN
                    IF (ITEL == 1) WRITE (LU7, 99992, IOSTAT = IOST)
                    WRITE (LU7, 99991, IOSTAT = IOST) IH, IK, IL, XI,
     1                SIGI
                  END IF
                END IF
                CYCLE
              END IF
          END IF
C * ELIMINATE BRAVAIS LATTICE ABSENCES
          IF (IBVT > 1) THEN
            SGX(1)  = IHT
            SGX(2)  = IKT
            SGX(3)  = ILT
            SGX(12) = -1.0
            CALL SGSM (27, LINE, SGX, 0, 0, IERR)
            IF (NINT (SGX(12)) > 0) THEN
              IF (IPR(408) <= 0) THEN
                IPR(370) = IPR(370) + 1
                IF (XI > 5.0 * SIGI) THEN
                  ITEL = ITEL + 1
                  IF (IGBL(22) /= -1) THEN
                    IF (ITEL == 1) WRITE (LU7, 99992, IOSTAT = IOST)
                    WRITE (LU7, 99994, IOSTAT = IOST)
     1                IHT, IKT, ILT, XI, SIGI
                  END IF
                END IF
              END IF
              CYCLE
            END IF
          END IF
C * DETERMINE THETA-MAX AND SKIP REFLECTIONS ON THETA
          STHK = GEN095 (PAR(191), IHT, IKT, ILT)
          CALL PLA169 (1, XI * 100.0,
     1                 SIGI * 100.0, SQRT (STHK), 0)
          IF (STHK > (STHKM + 0.00001)) THEN
            IF (IPR(408) <= 0) IPR(372) = IPR(372) + 1
            IF (IPR(408) == 2 .OR. IGBL(129) <= 0) CYCLE
            IPR(379) = IPR(379) + 1
          END IF
          IF (IPR(648) /= 2) THEN
            TH = ASIN (SQRT (STHK) * PAR(17)) * RGBL(6)
            IF (STHK < ATHMN + 0.00001) THEN
              ATHMN = STHK
              PAR(445) = ASIN (MIN (1.0, SQRT (ATHMN) * PAR(17)))
     1                 * RGBL(6)
            END IF
          END IF
          IF (STHK > ATHM) THEN
            ATHM = STHK
          END IF
C * COUNT NUMBER OF REFLECTIONS WITH NEGATIVE INTENSITIES
          IF (MODE > 1) THEN
            IF (XI < 0.0) THEN
              IPR(627) = IPR(627) + 1
              IF (XI < - 2.0 * SIGI) THEN
                  IPR(628) = IPR(628) + 1
              END IF
            END IF
C * COUNT NUMBER OF REFLECTIONS WITH SIGMA = 0.0
            IF (IGBL(9) /= 21 .AND. IGBL(9) /= 23 .AND.
     1          IGBL(9) /= 5) THEN
              IF (SIGI == 0.0) IPR(631) = IPR(631) + 1
            END IF
          END IF
          IPR(373) = IPR(373) + 1
C * TEST FOR FCF-VALIDATION (= -1)
          IF (IGBL(22) < 0) THEN
            CALIM = MAX (CALIM, CALI)
            SIGS  = SIGI**2
C * INCLUDE L.S. WEIGHT PARAMETERS IN SIGMAI (SHELXL & JANA)
            SIGK  = SIGIW**2
C * PSEUDO EXTINCTION PARAMETER
            IF (CALI > 0 .AND. XI > 0) THEN
              IF (SIGI > 0.0) THEN
                WEIGHT = 1.0
                SMEXT  = SMEXT + WEIGHT * (LOG (XI / CALI)) * CALI
                SMEXB  = SMEXB + WEIGHT * CALI**2
              END IF
            END IF
C * DELTA-I OUTLIERS
            IF (CALI > 0.0) THEN
              IF (CALI < 2 * SIGI) THEN
                SMOBS = SMOBS + XI
                SMCAL = SMCAL + CALI
                NSMAL = NSMAL + 1
              END IF
              IF (SIGI > 0.0) THEN
                DOVERS = (XI - CALI) / SIGI
                IF (DOVERS < -100.0) THEN
                  QMRK = '?'
                  IPR(641) = IPR(641) + 1
                ELSE
                  QMRK = ' '
                END IF
C * INCLUDE L.S. WEIGHT PARAMETERS IN SIGMAI
                IF (IPR(632) /= 0) THEN
                  DOSW = (XI - CALI) / SIGIW
                  IF (DOSW < -10.0 .AND. TH < 3.0) THEN
                    TH = - TH
                    IF (IPR(588) < NP82) THEN
                      IPR(588) = IPR(588) + 1
                      NBSTP(1, IPR(588)) = IH
                      NBSTP(2, IPR(588)) = IK
                      NBSTP(3, IPR(588)) = IL
            END IF
                  END IF
                  CRIT  = 3.0
                  CRITO = 10.0
                  IF (ABS (DOSW) > CRIT .OR. QMRK == '?') THEN
                    IF (ABS (DOSW) > CRITO .AND. IPR(642) < NP83) THEN
                      IPR(642) = IPR(642) + 1
                      NOUTX(1, IPR(642)) = IH
                      NOUTX(2, IPR(642)) = IK
                      NOUTX(3, IPR(642)) = IL
                    END IF
                    NOUTL = NOUTL + 1
                    DOSAW = DOSAW + DOSW
                    DOSAV = DOSAV + DOVERS
                    IF (NOUTL == 1) WRITE (LU13, 99967, IOSTAT = IOST)
     1                'SigW(I)', CRIT, 'SigW(I) RatioW'
                    IF (IPR(746) < 8) THEN
                      WRITE (LU13, 99966, IOSTAT = IOST)
     1                  NOUTL, IH, IK, IL, TH, XI, CALI, SIGI,
     2                  MAX (-9999.99, DOVERS), QMRK,
     3                  MIN (99999.99, SIGIW), DOSW
                    ELSE
                      WRITE (LU13, 99921, IOSTAT = IOST)
     1                  NOUTL, IH, IK, IL, TH, INT (XI), INT (CALI),
     2                  INT (SIGI), MAX (-9999.99, DOVERS), QMRK,
     3                  MIN (99999.99, SIGIW), DOSW
                    END IF
                  END IF
                ELSE
                  IF (DOVERS < -10.0 .AND. TH < 3.0) THEN
                    TH = - TH
                    IF (IPR(588) < NP82) THEN
                      IPR(588) = IPR(588) + 1
                      NBSTP(1, IPR(588)) = IH
                      NBSTP(2, IPR(588)) = IK
                      NBSTP(3, IPR(588)) = IL
                    END IF
                  END IF
                  CRIT = 5.0
                  IF (ABS (DOVERS) > CRIT .OR. QMRK == '?') THEN
                    NOUTL = NOUTL + 1
                    DOSAV = DOSAV + DOVERS
                    IF (NOUTL == 1) WRITE (LU13, 99967, IOSTAT = IOST)
     1                'Sigma(I)', CRIT, ' '
                    IF (IPR(746) < 8) THEN
                      WRITE (LU13, 99966, IOSTAT = IOST)
     1                  NOUTL, IH, IK, IL, TH, XI, CALI, SIGI,
     2                  MAX (-9999.99, DOVERS), QMRK
                    ELSE
                      WRITE (LU13, 99921, IOSTAT = IOST)
     1                  NOUTL, IH, IK, IL, TH, INT (XI), INT (CALI),
     2                  INT (SIGI), MAX (-9999.99, DOVERS), QMRK
                    END IF
                  END IF
                END IF
              END IF
            END IF
C * R-GAP
            IF (SIGI > 0.0 .AND. SIGIW > 0.0) THEN
              NTEL     = NTEL + 1
              PAR(373) = PAR(373) + XI**2 / SIGI**2
              PAR(374) = PAR(374) + XI**2 / SIGIW**2
            END IF
C * STATISTICS
            IPR(585)   = MAX (IPR(585), IABS (IH))
            IPR(586)   = MAX (IPR(586), IABS (IK))
            IPR(587)   = MAX (IPR(587), IABS (IL))
            N          = MAX (1, MIN (20, 1 + INT (STHK ** 1.5 *
     1                   FACTOR)))
            STAT(N, 1) = STAT(N, 1) + XI
            STAT(N, 2) = STAT(N, 2) + MAX (0.0, CALI)
            STAT(N, 3) = STAT(N, 3) + SIGI
            STAT(N, 9) = STAT(N, 9) + 1.0
C * PAR(484) GENERALLY SHELXL 2 & JANA 3
            IF (XI > PAR(484) * SIGI) THEN
              NFUL1      = NFUL1 + 1
              STAT(N, 4) = STAT(N, 4) + SQRT (XI)
              STAT(N, 5) = STAT(N, 5)
     1                   + ABS (SQRT (XI) - SQRT (MAX (0.0, CALI)))
            END IF
            IF (SIGI. GT. 0.0) THEN
              IF (SIGK /= 0.0) THEN
                STAT(N, 6)  = STAT(N, 6)
     1                      + (XI - MAX (0.0, CALI)) ** 2 / SIGK
                STAT(N, 7)  = STAT(N, 7)  + XI ** 2 / SIGK
                STAT(N, 11) = STAT(N, 11)
     1                      + (XI - MAX (0.0, CALI)) ** 2 / SIGS
                STAT(N, 12) = STAT(N, 12) + XI ** 2 / SIGS
 
              END IF
              STAT(N, 8)  = STAT(N, 8)  + XI / SIGIW
              IF (SIGIW < 0.1E+15)
     1          STAT(N, 10) = STAT(N, 10) + SIGIW
            END IF
          END IF
C * CALCULATE STRUCTURE FACTORS ?
C * CHECK FOR GENERATE MODE (= 1)
          IF (IPR(408) == 1) THEN
            ACAL   = 0
            BCAL   = 0
            ACALA  = 0.0
            BCALA  = 0.0
            ACALAF = 0.0
            BCALAF = 0.0
            CALL PLA137 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA,
     1        ACALAF, BCALAF, SNTHA)
            ACAL = ACAL + ACALA
            BCAL = BCAL + BCALA
            XI   = (ACAL ** 2 + BCAL ** 2)
            SIGI = SQRT (XI) + 0.02 * XI
            IF (IPR(647) == 1) THEN
              XI = XI + (2.0 * GEN013 (IDUM) - 1.0) * SIGI
            END IF
 
C * CALC MODE (IUCR-CHECK) - EXPECT
          ELSE IF (IPR(408) == 2) THEN
            XI   = 100000.0
            SIGI = 10.0
          END IF
C * CHECK FOR SPACE GROUP ABSENCES
          SGX(1)  = IHT
          SGX(2)  = IKT
          SGX(3)  = ILT
          SGX(12) = 1.0
          CALL SGSM (27, LINE, SGX, 0, 0, IERR)
          NORI = NINT (SGX(12))
C * GENERATE BUFFER WITH NSYMH * 6 + 3 ENTRIES
C * STORE SYMMETRY RELATED REFLECTIONS AND DETERMINE MAX H, MAX K, MAX L
C * ONE BUFFER PER REFLECTION + SYMMETRY RELATED ONES
C * CHECK FOR ROOM FOR ADDITIONAL SYMMETRY EXPANDED SET FOR ANOTHER HKL
          IF (M + IMAX > NVDI) THEN
            WRITE (LU6, 99990, IOSTAT = IOST)
C * ALERT _810
            CALL PLA236 (810, 0, -999.0, 1.0, ' ', ' ')
            GO TO 90
          END IF
          SGX(4) = 0.0
          DO J = 1, NSYMH
            CALL SGSM (5, ICRD, SGX, J, LU7, IERR)
            DO I = 1, 3
              L          = NINT (SGX(I + 6))
              IHM(I)     = MAX (IHM(I), IABS (L))
              IAR(M + I) = L
            END DO
            IAR(M + 4) = NORI
            M          = M + 6
          END DO
          IAR(M + 1) = NINT (XI   * PSCFA)
          IAR(M + 2) = NINT (SIGI * PSCFB)
          IAR(M + 3) = 10000
          M          = M + 3
        END IF
      END DO
C * REFLECTION READ COMPLETED
      IF (MODE > 1) THEN
        IF (NOUTL > 0) THEN
          IF (PAR(493) >= 0.0) THEN
            WRITE (LU13, 99949, IOSTAT = IOST)
     1        DOSAV / NOUTL, DOSAW / NOUTL
          ELSE
            WRITE (LU13, 99962, IOSTAT = IOST) DOSAV / NOUTL
          END IF
        END IF
        IF (IPR(632) /= 0) WRITE (LU13, 99931, IOSTAT = IOST)
        IF (NSMAL > 0) WRITE (LU13, 99960, IOSTAT = IOST)
     1      SMOBS / NSMAL, SMCAL / NSMAL
C * TELL ABOUT LIKELY BEAMSTOP EFFECTED LOW ORDER REFLECTIONS
        IF (IPR(588) > 0) WRITE (LU13, 99935, IOSTAT = IOST)
        IF (MODE > 1 .AND. IPR(373) > 0) THEN
C * REPORT PSEUDO EXTINCTION PARAMETER VALUE
 
C * ALERT _935
        END IF
      ENDIF
      IF (IPR(392) > 1) THEN
C * CHANGE SORTING ORDER (H,K) WHEN HORIZONTAL MAX > 29
        IF (IHM(IND1) > IHM(IND2)) THEN
          CALL GEN014 (IND1, IND2)
        END IF
        IPR(394) = IND3
      END IF
      IHM(4)   =  2 * IHM(IND1) + 1
      IHM(5)   = (2 * IHM(IND2) + 1) * IHM(4)
      IHM(6)   = IHM(IND3) * IHM(5) + IHM(IND2) * IHM(4) + IHM(IND1)
      NPZ      = IHM(6) + 1
      MPH      = IHM(4)
      MHK      = IHM(5)
      IPR(305) = IHM(1)
      IPR(306) = IHM(2)
      IPR(307) = IHM(3)
C * CHECK FOR VALIDATION MODE (=-1)
      IF (IGBL(22) /= -1) THEN
        WRITE (LU6, 99996, IOSTAT = IOST)
     1    (IHM(MM), MM = 1, 3), ZONE(IND1), ZONE(IND2), ZONE(IND3)
        IF (IGBL(63) > 0) WRITE (LU7, 99996, IOSTAT = IOST)
     1    (IHM(MM), MM = 1, 3), ZONE(IND1), ZONE(IND2), ZONE(IND3)
      END IF
C * Check for 'any reflections accepted ?'
      IF (IPR(373) == 0) THEN
        IF (IGBL(22) /= -1) THEN
          WRITE (LU6, 99995, IOSTAT = IOST) JID(1:10)
          WRITE (LU7, 99995, IOSTAT = IOST) JID(1:10)
        END IF
        IF (IGBL(22) /= 0) THEN
          INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.ckf',
     1      OPENED = OPEND)
          IF (.NOT. OPEND) THEN
            OPEN (UNIT = LU13, FILE = NAMEFIL(1:KNMFIL) //'.ckf',
     1        STATUS = 'UNKNOWN')
          END IF
          WRITE (LU13, 99995, IOSTAT = IOST) JID(1:10)
        END IF
C * ALERT _902
        IF (IPR(659) == 0 .AND. IPR(674) == 0) THEN
          IPR(676) = 0
          CALL PLA236 (902, 0, 1.0, 1.0, ' ', ' ')
        END IF
        GO TO 90
      ELSE IF (IPR(373) < IPR(266)) THEN
        IF (IGBL(22) /= -1) THEN
          WRITE (LU6, 99956, IOSTAT = IOST) JID(1:10)
          WRITE (LU7, 99956, IOSTAT = IOST) JID(1:10)
        END IF
        WRITE (LU13, 99956, IOSTAT = IOST) JID(1:10)
C * ALERT _904
        CALL PLA236 (904, 0, FLOAT (IPR(373)), FLOAT (IPR(373)),
     1               ' ', ' ')
        GO TO 90
      END IF
C * TRANSFORM H,K,L BY SYMMETRY OPERATION TO THE ONE WITH HIGHEST
C * PACKING INDEX = IHKL
      I = 0
      L = - IMAX
      DO N = 1, IPR(373)
C * EXTINCTION REFLECTIONS ARE ELIMINATED
        NORI = 0
C * GENERATE SYMMETRY RELATED REFLECTIONS
        L = L + IMAX
        M = L
        K = L - 6
        DO J = 1, NSYMH
          K          = K + 6
          IAR(K + 5) = 1
          IF (IAR(K + 4) > 0) NORI = -1
C * ADD PACKING INDEX
          IAR(K + 6) = IHM(5) * IAR(K + IND3)
     1               + IHM(4) * IAR(K + IND2) + IAR(K + IND1)
C * TEST PACKING INDEX RANGE
          IF (IABS (IAR(K + 6)) >= NPZ) THEN
            WRITE (LU6, 99999, IOSTAT = IOST)
     1        N, IAR(K + IND1), IAR(K + IND2),
     2        IAR(K + IND3), IAR(K + 6), IHM(4), IHM(5), IHM(6), NPZ
            GO TO 90
          END IF
C * LOOK FOR STANDARD REFLECTION  (MAXIMUM  VALUE  OF  PACKED  INDICES)
          JUNK = IABS (IAR(K + 6)) - IABS (IAR(M + 6))
          IF (JUNK >= 0) THEN
            IF (JUNK == 0) THEN
              IF (IAR(K + 6) <= 0) CYCLE
            END IF
            M = K
          END IF
        END DO
C * MAKE THE FIRST REFLECTION THE STANDARD ONE (INTERCHANGE 1 & MX6 DATA)
        IOB4 = IAR(L + 6)
        DO J = 1, 6
          CALL GEN014 (IAR(L + J), IAR(M + J))
        END DO
        IF (IAR(L + 6) /= 0) THEN
          IF (IAR(L + 4) > 0) NORI = 1
          DO J = 1, NSYMH
            IOB1 = IAR(L + IND3 + (J - 1) * 6)
            IOB2 = IAR(L + J * 6)
            IOB3 = 0
            IF (J == 1) IOB3 = IOB4
            IF (NORI /= 0) THEN
              IF (IOB3 == 0) CYCLE
              IPR(381) = IPR(381) + 1
              IOBUF1   = -1
            ELSE
              IOBUF1   = IABS (IOB1)
            END IF
C * MAKE SURE THAT SIGMA (=SIGI) GREATER THAN ZERO
            IA    = IAR(L + IMAX - 2)
            IASIG = IAR(L + IMAX - 1)
            INTM  = MAX (INTM, IA)
            XSIGM = MAX (XSIGM, FLOAT (IASIG))
C * STORE NOT TRANSFORMED PACKED HKL
            NID       = NID + 1
            ID(I + 1) = IOBUF1
            ID(I + 2) = IOB2
            ID(I + 3) = IOB3
            ID(I + 4) = IA
            ID(I + 5) = IASIG
            ID(I + 6) = IAR(L + IMAX)
            I         = I + 6
            IF (I >= 252) THEN
              WRITE (LU8) ID
              I = 0
            END IF
          END DO
        END IF
      END DO
C * END OF FILE, CLEAR BUFFER
      WRITE (LU8) ID
      CALL GEN108 (LU8, 0)
C * DETERMINE SCALEFACTOR TO FIT OUTPUT FORMAT (2I8) FOR HKL
      SCFHKL   = 99999999.0 / FLOAT (INTM)
      IF (SCFHKL > 1.0)    SCFHKL = 1.0
      IF (IGBL(63) > 0 .AND. IPR(408) /= 2) THEN
        IF (IGBL(22) /= -1) THEN
          WRITE (LU6, 99998, IOSTAT = IOST) PSCFA, PSCFB, SCFHKL
          WRITE (LU7, 99998, IOSTAT = IOST) PSCFA, PSCFB, SCFHKL
          IF (PAR(426) > 0.0) THEN
            WRITE (LU6, 99939, IOSTAT = IOST)
     1        PSCFA * SCFHKL * PAR(426)**2
            WRITE (LU7, 99939, IOSTAT = IOST)
     1        PSCFA * SCFHKL * PAR(426)**2
          END IF
          WRITE (LU7, 99993, IOSTAT = IOST) PAR(284)
        END IF
      END IF
C * TEST FOR HKL - MODE
C * TEST FOR AVERAGING FRIEDEL RELATED REFLECTIONS
      IF (IPR(393) == 1 .AND. IGBL(22) /= -1)
     1  WRITE (LU7, 99997, IOSTAT = IOST)
      PAR(446) = ASIN (MIN (1.0, SQRT (ATHM) * PAR(17))) * RGBL(6)
      WRITE (LU6, 99989) PAR(446), PAR(165)
      IF (IGBL(63) > 0 .AND. IGBL(22) /= -1) THEN
        WRITE (LU7, 99989, IOSTAT = IOST) PAR(446), THM
C * LIST RECIPROCAL LATTICE SYMMETRY
        CALL SGSM (4, ICRD, SGX, 0, LU7, IERR)
      END IF
C * DATA ARE COLLECTED PER NEXT SECTION
C * THE BOTTOM UP PART OF IAR CONTAINS THE PACKED REFLECTION INDICES
C * INCLUDING A POINTER TO THE CORRESPONDING DATA (IF ANY)
C * THE RELEVANT DATA ARE STACKED TOP-DOWN-WARDS (6 WORDS / REFLECTION)
      CALL GEN108 (LU14, 0)
      IPL = 1
      CR1 = 0.0
      CR2 = 0.0
      CR3 = 0.0
      CALL GEN074 (SM, 1, 6, 0.0)
C * TAKE CARE OF EXTINCTION REFLECTION LISTING (# = IPR(381)
      IF (IPR(381) == 0) THEN
        IKS(IND3) = -1
      ELSE
        IKS(IND3) = -2
      END IF
      DO
        CALL GEN108 (LU8, 0)
        IKS(IND3) = IKS(IND3) + 1
        IF (IKS(IND3) <= IHM(IND3)) THEN
C * BOTTOM UP COUNTER
          N   = 0
C * TOP DOWN COUNTER
          K = 0
          L = NVDI
          M = 252
          DO I = 1, NID
            M = M + 6
C * GET NEW BUFFER
            IF (M >= 252) THEN
              M = 0
              READ (LU8) ID
            END IF
C * GET ZONE NUMBER FOR THIS REFLECTION
C * TEST WHETHER THIS REFLECTION FITS IN THE CURRENT ZONE IKS(IND3)
            IF (ID(M + 1) == IKS(IND3)) THEN
C * GET PACKED HKL VALUE OF ORIGINAL (UNTRANSFORMED) REFLECTION
              IF (ID(M + 3) == 0) THEN
                IOB2 = 0
              ELSE
                K    = K + 1
                L    = L - 6
                IOB2 = K
C * TEST WHETHER THIS IS AN NON-ASYMMETRIC UNIT REFLECTION
                IAR(L + 1) = ID(M + 2)
                IAR(L + 2) = MAX (0, ID(M + 4))
                IAR(L + 3) = ID(M + 6)
                IAR(L + 4) = ID(M + 3)
                IAR(L + 5) = ID(M + 5)
                IAR(L + 6) = I
              END IF
              N2 = N + N
              IF (N2 + 2 > L) THEN
                WRITE (LU7, 99979, IOSTAT = IOST)
                GO TO 90
              END IF
              IAR(N2 + 1) = IABS (ID(M + 2))
              IAR(N2 + 2) = IOB2
              N = N + 1
            END IF
          END DO
C * SORT AND OUTPUT THE DATA OF THIS LEVEL
C * SKIP THIS LATTICE LEVEL FOR N = 0 - UNLESS VIEW or FCF-CHK MODE
          IF (N > 0 .OR. IGBL(22) /= 0) THEN
C * SORT DATA
            IF (N > 1) THEN
              N2 = N * 2
              CALL GEN124 (IAR, 1, N2)
              NB = 2
              CALL GEN014 (IAR(1), IAR(2))
              DO I = 4, N2, 2
                CALL GEN014 (IAR(I - 1), IAR(I))
                IF (IAR(I) /= IAR(NB)) THEN
                  CALL GEN124 (IAR, NB - 1, I - 2)
                  NB = I
                END IF
              END DO
              CALL GEN124 (IAR, NB - 1, N2)
C * ELIMINATE THE OVERREDUNDANCY OF SYMMETRY REL. REFL.
C * GET FIRST ELEMENT
              N01 = IAR(2)
              N02 = IAR(1)
              J   = 0
C * LOOP OVER ALL OTHER ENTRIES
              DO I = 2, N
C * N11 CONTAINS PACKED HKL VALUE
                N11 = IAR((I - 1) * 2 + 2)
C * N12 CONTAINS REFERENCE TO DATA (IF ANY)
                N12 = IAR((I - 1) * 2 + 1)
C * IS THIS ENTRY DIFFERENT FROM PREVIOUS ONE ?
                IF (N11 /= N01 .OR. N12 /= N02) THEN
                  IF (N11 == N01 .AND. N02 == 0) THEN
                    N02 = N12
                  ELSE
                    IAR(J * 2 + 1) = N01
                    IAR(J * 2 + 2) = N02
                    J              = J + 1
                    N01            = N11
                    N02            = N12
                  END IF
                END IF
              END DO
              IAR(J * 2 + 1) = N01
              IAR(J * 2 + 2) = N02
C * RETURN NEW NUMBER OF ELEMENTS IN N
              N              = J + 1
            END IF
C * SET VERTICAL INDEX ON MINIMUM VALUE
            IKS(IND2) = - IHM(IND2)
            IF (IKS(IND3) >= 0) THEN
              IF (IPR(392) > 1) THEN
                CALL PLA148
                IJKM = IHM(IND1) + 1
C * PREPARE NUMERICAL ( = IND1 INDEX) LINE
                DO IJK = 1, IJKM
                  IUU      = CHAR (ICHAR('0') + MOD (IJK - 1, 10))
                  I        = 2 * (IHM(IND1) + IJK)
                  IF (I <= NP44) CID(I:I) = IUU
                  J        = 2 * (IHM(IND1) - IJK + 2)
                  IF (J <= NP44) CID(J:J) = IUU
                END DO
                WRITE (LU14, 99977, IOSTAT = IOST) ZONE(IND3),
     1            IKS(IND3), ZONE(IND1), CID(1:150), ZONE(IND2)
                CALL PLA148
              END IF
            END IF
C * REFLECTION ZONE HEADER PRINT
            IF (IABS (IPR(392) - 2) == 1 .OR. IKS(IND3) == -1) THEN
C * PRINT PAGE HEADER
              IF (IPL > 98) THEN
                IF (IPL <= 102) THEN
                  DO I = IPL, 102
                    CALL GEN038 (AR(I), 1, 60)
                  END DO
                END IF
                IPL   = 1
                IF (IGBL(22) /= -1) THEN
                  CALL PLA262 (0)
                  WRITE (LU7, 99973, IOSTAT = IOST)
                  DO I = 1, 51
                    WRITE (LU7, 99972, IOSTAT = IOST) AR(I), AR(I + 51)
                  END DO
                END IF
              END IF
              DO I = 1, 3
                CALL GEN038 (AR(IPL + I - 1), 1, 60)
              END DO
              IF (IPR(408) /= 2) THEN
                IF (IKS(IND3) == -1) THEN
C * EXTINCTION PRINT HEADER
                  WRITE (XAR, 99975, IOSTAT = IOST)
                ELSE
C * ZONE HEADER PRINT
                  WRITE (XAR, 99976, IOSTAT = IOST) ZONE(IND3),
     1              IKS(IND3)
                END IF
              END IF
              AR(IPL + 1) = XAR
              IPL         = IPL + 3
            END IF
            JP             = 0
            JM             = 0
            IHKA           = - NPZ
            IAR(N * 2 + 1) = 2100000000
            IAR(N * 2 + 2) = 0
            NN             = N + 1
            DO K = 1, NN
              IHKB = IAR((K - 1) * 2 + 1)
              I    = IAR((K - 1) * 2 + 2)
              I6   = NVDI - I * 6
              IF (I > 0) IHKB = IAR(I6 + 1)
              IF (IABS (IHKB) /= IABS (IHKA)) THEN
                IF (IHKA  > - NPZ) THEN
                  IHK = IABS(IHKA)
                  IND        = IHK + IHM(6)
                  IL         = IND / IHM(5)
                  IS         = IND - IHM(5) * IL
                  IK         = IS  / IHM(4)
                  IH         = IS  - IHM(4) * IK - IHM(IND1)
                  IK         = IK  - IHM(IND2)
                  IL         = IL  - IHM(IND3)
                  IHKL(IND1) = IH
                  IHKL(IND2) = IK
                  IHKL(IND3) = IL
                  DO MM = 1, 3
                    IHKLE(MM) = IHKL(MM)
                  END DO
C * ADD INFORMATION TO R.L. PRINT BUT SKIP THIS SECTION IN CASE OF
C * EXTINCTION REFLECTIONS
                  IF (IKS(IND3) >= 0) THEN
C * START A NEW LINE TEST
                    IF (IPR(392) > 1) THEN
                      DO WHILE (IHKL(IND2) > IKS(IND2))
C * OUTPUT THIS LINE
                        WRITE (LU14, 99974, IOSTAT = IOST) IKS(IND2),
     1                    CID(1:(4 * IHM(IND1) + 2))
                        IKS(IND2) = IKS(IND2) + 1
C * CLEAR BUFFER
                        CALL PLA148
                      END DO
                    END IF
                  END IF
C * OUTPUT (LISTING & FILE) (IRM1 = AVERAGE OBS ON RETURN)
                  IF (IKS(IND3) == -1) IPR(754) = IPR(754) + JP
                  CALL PLA146 (JP, 1, LUP17, IRM1)
                  IF (IPR(275) /= 2 .AND. IPR(393) /= 1) THEN
                    IF (IPR(408) /= 2) IGBL(18) = 1
                    CALL PLA146 (JM, 2, LUP18, IRM2)
                    IF (JP /= 0 .AND. JM /= 0) THEN
                      SM(1, 3) = ABS(IRM1 - IRM2) + SM(1, 3)
                      SM(2, 3) = SM(2, 3) + IRM1 + IRM2
C * FRIEDEL COUNT - EXCLUDE SYSTEMATIC EXTINCTIONS
                      IF (IKS(IND3) /= -1) IPR(380) = IPR(380) + 1
                    END IF
                  END IF
                  JP  = 0
                  JM  = 0
                  IF (IPR(275) == 2) THEN
                    IHKA = IABS (IHKB)
                  ELSE
                    IHKA = IHKB
                  END IF
                ELSE
                  IF (IPR(275) == 2) IHKB = IABS (IHKB)
                  IHKA = IHKB
                END IF
              END IF
              IF (I > 0 .AND. I < NN) THEN
                REFA  = IAR(I6 + 2) * SCFHKL
                REFB  = IAR(I6 + 5) * SCFHKL
C * MAKE ESD AT LEAST SMALL POSITIVE
                IF (REFB <= 0) REFB = 0.001
                IVGNR = IAR(I6 + 6)
                IHKL2 = IAR(I6 + 4)
                IF (IPR(275) /= 2 .AND. IPR(393) /= 1 .AND.
     1            IHKB < 0) THEN
C * REFLECTION H,K,L WITH PACKING ADDRES NEGATIVE
                  IF (JM < NP68) JM = JM + 1
                  RA(JM,  2) = REFA
                  RB(JM,  2) = REFB
                  IRC(JM, 2) = IVGNR
                  IRD(JM, 2) = IHKL2
                ELSE
C * REFLECTION H,K,L WITH PACKING ADDRESS POSITIVE
                  IF (JP < NP68) JP = JP + 1
                  RA(JP,  1) = REFA
                  RB(JP,  1) = REFB
                  IRC(JP, 1) = IVGNR
                  IRD(JP, 1) = IHKL2
                END IF
              END IF
            END DO
            IF (IKS(IND3) >= 0) THEN
              IF (IPR(392) > 1) THEN
                DO WHILE (IKS(IND2) <= IHM(IND2))
                  WRITE (LU14, 99974, IOSTAT = IOST)
     1              IKS(IND2), CID(1:(4 * IHM(IND1) + 2))
                  IKS(IND2) = IKS(IND2) + 1
                  CALL PLA148
                END DO
              END IF
            END IF
          END IF
          CYCLE
        ELSE
          EXIT
        END IF
      END DO
C * CLEAR PRINTBUFFER IF ANY
      IF (IPL > 1 .AND. IPR(408) /= 2) THEN
        IF (IPL <= 102) THEN
          DO I = IPL, 102
            CALL GEN038 (AR(I), 1, 60)
          END DO
        END IF
        IPL   = 1
        IF (IGBL(22) /= -1) THEN
          CALL PLA262 (0)
          WRITE (LU7, 99973, IOSTAT = IOST)
          DO I = 1, 51
            WRITE (LU7, 99972, IOSTAT = IOST) AR(I), AR(I + 51)
          END DO
        END IF
      END IF
C * PRINT RECIPROCAL LATTICE (NOT FOR VALIDATION)
      IF (IPR(392) > 1 .AND. IGBL(22) /= -1) THEN
        CALL GEN108 (LU14, 0)
        DO WHILE (.TRUE.)
          READ (LU14, 99959, IOSTAT = IOST) PRBUF
          IF (IOST /= 0) EXIT
          IF (PRBUF(8:8) == ZONE(IND3)) THEN
            CALL PLA262 (0)
          END IF
          WRITE (LU7, 99959, IOSTAT = IOST) PRBUF
        END DO
      END IF
      IF (IGBL(22) /= -1) THEN
        IF (IPR(408) /= 2) THEN
          CALL PLA262 (0)
        ELSE
          CALL PLA262 (2)
        END IF
        IF (IPR(408) <= 0) THEN
          WRITE (LU6, 99982, IOSTAT = IOST)
     1      IPR(372), IPR(371), IPR(370), IPR(754)
          WRITE (LU7, 99982, IOSTAT = IOST)
     1      IPR(372), IPR(371), IPR(370), IPR(754)
        END IF
        IF (IPR(408) < 2) THEN
          WRITE (LU6, 99984, IOSTAT = IOST) IPR(373), IPR(375)
          WRITE (LU7, 99984, IOSTAT = IOST) IPR(373), IPR(375)
          IF (IPR(376) > 0 .AND. IPR(408) < 1) THEN
            WRITE (LU6, 99983, IOSTAT = IOST) IPR(376)
            WRITE (LU7, 99983, IOSTAT = IOST) IPR(376)
          END IF
        END IF
      END IF
C * COMBINE .hkp & .hks
      IF ((IPR(408) == 0 .AND. IGBL(22) == 0) .OR.
     1    (IPR(408) == 1 .AND. IPR(393) == 0)) THEN
        IF (IPR(378) > 0) THEN
C * ENDFILE/REWIND
          CALL GEN108 (LUP18 , 1)
          DO I = 1, IPR(378)
            READ  (LUP18, 99959) AA
            WRITE (LUP17, 99959, IOSTAT = IOST) AA
          END DO
        END IF
        WRITE (LUP17, 99930) 0, 0, 0, 0, 0, 0
C * APPEND TRAILER INFO TO GENERATED 'OBSERVED' REFLECTION FILE
        IF (IPR(408) == 1) THEN
          WRITE (LUP17, 99926) IPR(377) + IPR(378)
          WRITE (LUP17, 99928) SPGRNM(1)(1:11), (PAR(I), I = 101, 106),
     1      PAR(17)
          N = INDEX (RLWS(5), '''')
          WRITE (LUP17, 99927) RLWS(5)(1:N - 1)
          WRITE (LU6  , 99927) RLWS(5)(1:N - 1)
          DO I = 1, IAN
            WRITE (LUP17, 99929)
     1        LMT(IENS(I), 1), ANOM(IENS(I), 1), ANOM(IENS(I), 2)
            WRITE (LU6  , 99929)
     1        LMT(IENS(I), 1), ANOM(IENS(I), 1), ANOM(IENS(I), 2)
          END DO
        END IF
      END IF
C * CHECK FOR 'NON-FCF VALIDATION'
      IF (IGBL(22) /= -1) THEN
        WRITE (LU6, 99988, IOSTAT = IOST) IPR(377)
C * CHECK PRINT LEVEL
        IF (IGBL(63) > 0) WRITE (LU7, 99988, IOSTAT = IOST) IPR(377)
        IF (IPR(378) > 0 .AND. IPR(408) /= 1) THEN
          WRITE (LU6, 99987, IOSTAT = IOST) IPR(378),
     1      IPR(377) + IPR(378)
          IF (IGBL(63) > 0) THEN
            WRITE (LU7, 99987, IOSTAT = IOST) IPR(378),
     1        IPR(377) + IPR(378)
          END IF
        END IF
        IF (IPR(380) > 0) THEN
          IF (IPR(408) < 1) THEN
            WRITE (LU6, 99985, IOSTAT = IOST) IPR(380)
            IF (IGBL(63) > 0)
     1        WRITE (LU7, 99985, IOSTAT = IOST) IPR(380)
          END IF
        END IF
      END IF
      IF (SM(2, 1) > 0.0) THEN
        CR1 = SM(1, 1) / SM(2, 1)
      END IF
      IF (SM(2, 2) > 0.0) THEN
        CR2 = SM(1, 2) / SM(2, 2)
        IF (IPR(380) > 0) CR3 = 2 * SM(1, 3) / SM(2, 3)
      END IF
      IF (IPR(408) < 1) THEN
        IF (IGBL(22) /= -1) THEN
          IF (CR1 /= 0.0) THEN
            WRITE (LU6, 99981, IOSTAT = IOST) CR1
            WRITE (LU7, 99981, IOSTAT = IOST) CR1
            IF (IPR(378) > 0) THEN
              WRITE (LU6, 99980, IOSTAT = IOST) CR2, CR3
              WRITE (LU7, 99980, IOSTAT = IOST) CR2, CR3
            END IF
          END IF
        END IF
        MAXM = 0
        TEL  = 0
        MAXI = 0
        DO I = 1, NP68
          MAXM = MAX (MAXM, MULT(I))
          TEL  = TEL + MULT(I)
          IF (MULT(I) > 0) MAXI = I
        END DO
        PERCENT(MAXI) = MULT(MAXI)
        DO I = MAXI -1, 1, -1
          PERCENT(I) = PERCENT(I + 1) + MULT(I)
        END DO
        SCAL = 38.0 / MAXM
        IF (IGBL(9) > 0) THEN
          FILETYPE = 'FCF'
        ELSE
          FILETYPE = 'HKL'
        END IF
        WRITE (LU6, 99923) FILETYPE
        WRITE (LU7, 99923) FILETYPE
        AVERAGE = 0.0
        COUNTB  = 0
        DO I = 1, MAXI
          IF (MULT(I) > 0) THEN
            IGETAL  = I * MULT(I)
            COUNTB  = COUNTB  + IGETAL
            AVERAGE = AVERAGE + IGETAL
            N       = MAX (1, NINT (SCAL * MULT(I)))
            WRITE (LU6, 99924) I, MULT(I), IGETAL, STAR(1:N),
     1        BLANKO(N+1:39), PERCENT(I) * 100.0 / TEL, I
            WRITE (LU7, 99924) I, MULT(I), IGETAL, STAR(1:N),
     1        BLANKO(N+1:39), PERCENT(I) * 100.0 / TEL, I
          END IF
        END DO
        AVERAGE = AVERAGE / TEL
        WRITE (LU6, 99922) NINT (TEL), NINT (COUNTB), AVERAGE,
     1    FILETYPE
        WRITE (LU7, 99922) NINT (TEL), NINT (COUNTB), AVERAGE,
     !    FILETYPE
      END IF
      IF (IGBL(22) /= 0) GO TO 20
C * FCF VALIDATION REPORT
   60 IF (IGBL(22) < 0) THEN
        WRITE (LU13, 99970, IOSTAT = IOST)
        STLMX = SIN (PAR(446) / RGBL(6)) / PAR(17)
        JMAX  = MIN (29, INT (STLMX / 0.05) + 1)
        STL   = 0.45
        DO I = 10, JMAX
          STL = STL + 0.05
          STH = MIN (1.0, STL * PAR(17), STLMX * PAR(17))
          IF (STH <= 1.0) THEN
            TH  = ASIN (STH) * RGBL(6)
            IF (ICNT(I - 9, 1) /= 0) THEN
              YDUM = FLOAT (ICNT(I - 9, 2)) / ICNT(I - 9, 1)
            ELSE
              YDUM = 0.0
            END IF
            WRITE (LU13, 99969, IOSTAT = IOST)
     1        TH, STH / PAR(17), YDUM, (ICNT(I - 9, J), J = 1, 2),
     2        ICNT(I - 9, 1) - ICNT(I - 9, 2)
            IF (I == 12) WRITE (LU13, 99957, IOSTAT = IOST)
          END IF
        END DO
        WRITE (LU13, 99938, IOSTAT = IOST)
        IF (PAR(493) >= 0.0) THEN
          WRITE (LU13, 99948, IOSTAT = IOST)
        ELSE
          WRITE (LU13, 99965, IOSTAT = IOST)
        END IF
        CALL GEN074 (FULL, 1, 12, 0.0)
        NFULL  = 0
        DO I = 1, 20
          DO J = 1, 12
            FULL(J) = FULL(J) + STAT(I, J)
          END DO
          N = NINT (STAT(I, 9))
          IF (N > 0) THEN
            NFULL = NFULL + N
            R1    = 0.0
            R2    = 0.0
            IF (NINT (STAT(I, 4)) /= 0) R1 = STAT(I, 5) / STAT(I, 4)
            IF (STAT(I, 7) > 0.0) R2 = SQRT (STAT(I, 6) / STAT(I, 7))
            S   = SQRT(STAT(I, 6) / N)
            R   = STAT(I, 8)  / N
            AI  = STAT(I, 1)  / N
            SA  = STAT(I, 10) / N
            IF (STAT(I, 1) /= 0.0) THEN
              RS = STAT(I, 3) / STAT(I, 1)
            ELSE
              RS = 0.0
            ENDIF
            SINTHL = (I / FACTOR) ** 0.333333
            IF (I < 20) THEN
              STH = MIN (1.0, SINTHL * PAR(17), STLMX * PAR(17))
            ELSE
              STH = MIN (1.0, STLMX * PAR(17))
            END IF
            TH  = ASIN(STH) * RGBL(6)
            WRITE (LU13, 99964, IOSTAT = IOST)
     1        TH, STH / PAR(17), N, R1, R2, S, RS, R, AI, SA
          END IF
        END DO
C * LIST TOTALS
        IF (FULL(4)  /= 0.0) PAR(477) = FULL(5) / FULL(4)
        IF (FULL(7)  /= 0.0) PAR(478) = SQRT (FULL(6) / FULL(7))
        IF (FULL(12) /= 0.0) WR2      = SQRT (FULL(11) / FULL(12))
        IF (FULL(1)  /= 0.0) RSIG     = FULL(3) / FULL(1)
        JUNK = NFULL - MAX (0, IPR(266) + IPR(767))
        IF (JUNK /= 0) THEN
          PAR(479) = SQRT (FULL(6)  / JUNK)
          GOF      = SQRT (FULL(11) / JUNK)
        END IF
        IPR(623) = NFUL1
        IPR(624) = NFULL
C * PREDICTED wR2's  (BASED ON SIG(I) AND SIGW(I) RESP.)
        PAR(373) = SQRT ((NTEL - IPR(266)) / PAR(373))
        PAR(374) = SQRT ((NTEL - IPR(266)) / PAR(374))
C * _969 ALERT - R-FACTOR GAP
        IF (IPR(105) == 0) THEN
          CALL PLA236 (-969, 3, -999.0, PAR(478) / PAR(373), ' ', ' ')
C * REPORT PREDICTED wR2's
          WRITE (LU68, 99918) PAR(373) * 100.0, PAR(374) * 100.0
        END IF
        IF (IGBL(9) == 17 .OR. IGBL(9) == 18) THEN
          PAR(479) = SQRT (PAR(564) / (IPR(764) - IPR(266)))
        END IF
        YUNK = ABS (FLOAT (IPR(623) - IPR(264)))
C * ALERT _992 - _reflns_number_gt CIF/FCF inconsistency
        IF (YUNK > 1.0 .AND. YUNK <= 10) THEN
          CALL PLA236 (992, 0, -999.0, YUNK, ' ', ' ')
        ELSE
          CALL PLA236 (992, 0, ABS (YUNK), YUNK, ' ', ' ')
        END IF
        WRITE (LU13, 99932, IOSTAT = IOST) RSIG
        WRITE (LU13, 99942, IOSTAT = IOST)
     1    PAR(477), NFUL1, PAR(478), NFULL, PAR(479)
        IF (PAR(173) > 0.0 .AND. PAR(174) > 0.0) THEN
          WRITE (LU13, 99941, IOSTAT = IOST)
     1      PAR(173), IPR(264), PAR(174), MAX (IPR(265), IPR(765)),
     2 PAR(299), MAX (0, IPR(266))
C * CHECK FOR SHELXL WEIGHT PARAMETERS
          IF (PAR(493) >= 0.0) THEN
              IF (ABS(PAR(478)) < 0.001) THEN
C * ALERT _903 - Fobs = Fcalc in FCF
                CALL PLA236 (903, 0, 1.0, 1.0, ' ', ' ')
              ELSE
                YUNK = PAR(173) - PAR(477)
C * ALERT _921 - COMPARE REPORTED AND CALCULATED R-VALUE DIFFERENCE
                IF (ABS(YUNK) > 0.001)
     1             CALL PLA236 (921, 4, ABS (YUNK), YUNK, ' ', ' ')
                  YUNK = PAR(174) - PAR(478)
C * ALERT _922 - COMPARE REPORTED AND CALCULATED wR2-VALUE DIFFERENCE
                IF (ABS(YUNK) > 0.001) THEN
C * TEST FOR XD
                  IF (IGBL(9) /= 11) THEN
                    CALL PLA236 (922, 4, ABS(YUNK), YUNK, ' ', ' ')
                  ELSE
                    CALL PLA236 (922, 4, -999.0, YUNK, ' ', ' ')
                  END IF
                END IF
                YUNK = PAR(299) - PAR(479)
C * ALERT _923 - COMPARE REPORTED AND CALCULATED S-VALUE DIFFERENCE
                IF (ABS(YUNK) > 0.005) THEN
C * TEST FOR XD
                  IF (IGBL(9) /= 11) THEN
                    CALL PLA236 (923, 3, ABS (YUNK), YUNK, ' ', ' ')
                  ELSE
                    CALL PLA236 (923, 3, -999.0, YUNK, ' ', ' ')
                  END IF
                END IF
              END IF
C * ALERT _929 - TEST FOR NO WEIGHT PARAMETERS
          ELSE
            CALL PLA236 (929, 0, -999.0, 0.0, ' ', ' ')
          END IF
        END IF
        WRITE (LU13, 99934, IOSTAT = IOST) WR2, GOF
C * ALERT _939 - High GOF
        IF (GOF > 5.0 .AND. IPR(651) == 0)
     1    CALL PLA236 (939, 2, GOF, GOF, ' ', ' ')
C * CHECK FOR HKL-RANGE REPORTED IN THE CIF WITH THAT FOUND IN THE FCF
        IF (IPR(672) == 6) THEN
C * CHECK FOR LAUE GROUP TRICLINIC, MONOCLINIC, ORTHORHOMBIC
          IF (IPR(258) < 4) THEN
C * ALERT _953
            DIFH = ABS(IPR(585) - MAX (0, -IPR(267), IPR(268)))
            IF (DIFH /= 0.0)
     1        CALL PLA236 (953, 0, -999.0, DIFH, ' ', ' ')
C * ALERT _954
            DIFK = ABS(IPR(586) - MAX (0, -IPR(269), IPR(270)))
            IF (DIFK /= 0.0)
     1        CALL PLA236 (954, 0, -999.0, DIFK, ' ', ' ')
          END IF
C * ALERT _955
          DIFL = ABS (IPR(587) - MAX (0, -IPR(271), IPR(272)))
          IF (DIFL /= 0.0)
     1      CALL PLA236 (955, 0, -999.0, DIFL, ' ', ' ')
        END IF
C * CHECK CALCULATED H,K,L RANGE VERSUS H,K,L RANGE IN FCF
C * CHECK FOR LAUE GROUP TRICLINIC, MONOCLINIC, ORTHORHOMBIC
        IF (IPR(258) < 4 .AND. IGBL(9) /= 11) THEN
C * ALERT _956
          DIFH = ABS (IPR(585) - IPR(561))
          IF (DIFH > 1.0)
     1      CALL PLA236 (956, 0, -999.0, DIFH, ' ', ' ')
C * ALERT _957
          DIFK = ABS (IPR(586) - IPR(562))
          IF (DIFK > 1.0)
     1      CALL PLA236 (957, 0, -999.0, DIFK, ' ', ' ')
        END IF
C * ALERT _958
        DIFL = ABS (IPR(587) - IPR(563))
        IF (DIFL > 1.0)
     1    CALL PLA236 (958, 0, -999.0, DIFL, ' ', ' ')
C * SUMMARY
        YUNK = MIN (STLMX, 0.6)
        IF (IPR(393) == 1 .OR. IPR(275) == 2) THEN
          WRITE (LU13, 99947, IOSTAT = IOST)
        ELSE
          WRITE (LU13, 99946, IOSTAT = IOST)
        END IF
        MH = MAX (0, -IPR(267), IPR(268))
        MK = MAX (0, -IPR(269), IPR(270))
        ML = MAX (0, -IPR(271), IPR(272))
        WRITE (LU13, 99968, IOSTAT = IOST)
     1    IPR(373), (MIN (999, IPR(M)), M = 585, 587), IPR(379),
     2    PAR(446), (MIN (999, IHM(M)), M = 1, 3), MAX (0.0, PAR(168)),
     3    MH, MK, ML, PAR(445), MAX(0.0, PAR(167))
        IF (IPR(393) == 1 .OR. IPR(275) == 2) THEN
          WRITE (LU13, 99944, IOSTAT = IOST)
     1      IPR(559), IPR(377), IPR(383), IPR(375), IPR(627), IPR(628)
C * ALERT _960
          IF (IPR(628) > 0) THEN
            CALL PLA236 (960, 0, -999.0, FLOAT (IPR(628)), ' ', ' ')
          END IF
C * ALERT _961 - REPORT NO NEGATIVE INTENSITIES (EXCL CRYSTALS-5)
          IF (IPR(627) == 0 .AND. IGBL(9) .NE. 5) THEN
            CALL PLA236 (961, 0, -999.0, 0.0, ' ', ' ')
          END IF
C * ALERT _962 - REPORT # OF REFLECTIONS IN FCF WITH SIGMA = 0.0
          IF (IABS(IGBL(8)) .EQ. 3 .AND. IPR(631) .GT. 0)
     1      CALL PLA236 (962, 0, -999.0, FLOAT (IPR(631)),
     2                   ' FCF File', ' ')
        ELSE
          WRITE (LU13, 99945, IOSTAT = IOST)
     1      IPR(559) + IPR(560), IPR(559), IPR(560),
     2      IPR(377) + IPR(378), IPR(377), IPR(378),
     3      IPR(383) + IPR(362), IPR(383), IPR(362),
     4      IPR(375) + IPR(376), IPR(375), IPR(376),
     5      IPR(559) - IPR(377) + IPR(560) - IPR(378),
     6      IPR(559) - IPR(377) , IPR(560) - IPR(378)
        END IF
        WRITE (LU13, 99943, IOSTAT = IOST)
     1    IPR(386), IPR(553), YUNK, IPR(555), YUNK,
     2    IPR(557), IPR(584), IPR(588), IPR(385)
        CALL PLA169 (-1, 0.0, 0.0, 0.0, 0)
        CALL PLA169 (-3, 0.0, 0.0, 0.0, LU13)
C * ALERT _910
        IF (IPR(553) < 5) THEN
          YUNK = -999.0
        ELSE
          YUNK = FLOAT(IPR(553))
        END IF
        IF (IPR(553) > 0) THEN
          CALL PLA236 (-910, 0, YUNK, FLOAT(IPR(553)), ' ', ' ')
          N = MIN (IPR(553), NP79)
          DO I = 1, N, 6
            K = MIN (5, N - I)
            WRITE (PRBUF, 99955) ((NTHMN(L, I + J), L = 1, 3), J = 0, K)
            WRITE (LU68,  99959) PRBUF(1:79)
          END DO
        END IF
        YUNK = MIN(SIN(PAR(446) / RGBL(6)) / PAR(17), 0.6)
        WRITE (LIJN(1:7), 99953, IOSTAT = IOST) YUNK
        IF (IPR(559) > 0) THEN
C * ALERT _911 - TEST for missing refl between th-min and sth/l=0.6
          IF (IPR(555) > 1) THEN
            IF (IPR(309) == 2) THEN
              CALL PLA236 (-911, 0,
     1          (FLOAT (IPR(555)) * 100.0) / IPR(559), FLOAT (IPR(555)),
     2          LIJN(1:7), ' ')
            ELSE
              CALL PLA236 (-911, 0, -999.0, FLOAT (IPR(555)),
     2          LIJN(1:7), ' ')
            END IF
            N = MIN (IPR(555), NP80)
            DO I = 1, N, 6
              K = MIN (5, N - I)
              WRITE (PRBUF, 99955)
     1          ((NTHMX(L, I + J), L = 1, 3), J = 0, K)
              WRITE (LU68,  99959) PRBUF(1:79)
            END DO
          END IF
C * ALERT _912
          IF (IPR(557) > 0 .AND. STLMX > 0.6) CALL PLA236
     1      (912, 0, -999.0, FLOAT (IPR(557)), ' ', ' ')
        END IF
C * ALERT _913 - REPORT NUMBER MISSING STRONG REFLECTIONS (AVOID CRYSTL1)
        IF (IPR(584) > 0 .AND. IGBL(9) /= 5) THEN
          IF (IPR(584) > 3) THEN
            CALL PLA236 (-913, 0, FLOAT (IPR(584)), FLOAT (IPR(584)),
     1        ' ', ' ')
          ELSE
            CALL PLA236 (-913, 0, -999.0, FLOAT (IPR(584)), ' ', ' ')
          END IF
          N = MIN (IPR(584), NP84)
          DO I = 1, N, 6
            K = MIN (5, N - I)
            WRITE (PRBUF, 99955)
     1        ((NSTRM(L, I + J), L = 1, 3), J = 0, K)
            WRITE (LU68,  99959) PRBUF(1:79)
          END DO
        END IF
C * REPORT BEAMSTOP EFFECTED REFLECTIONS
C * ALERT _919
        IF (IPR(588) > 0) THEN
          CALL PLA236 (-919, 0, FLOAT (IPR(588)), FLOAT (IPR(588)),
     1      ' ', ' ')
          N = MIN (IPR(588), NP82)
          DO I = 1, N, 6
            K = MIN (5, N - I)
            WRITE (PRBUF, 99955)
     1        ((NBSTP(L, I + J), L = 1, 3), J = 0, K)
            WRITE (LU68,  99959) PRBUF(1:79)
          END DO
        END IF
C * ALERT _912
C * ALERT _918 - REPORT ON # I(obs) << I(calc)
        IF (IPR(641) > 0) CALL PLA236 (918, 0, FLOAT (IPR(641)),
     1    FLOAT (IPR(641)), ' ', ' ')
C * ALERT _934 - REPORT ON # OF OUTLIERS > 10 (SKIPPED FOR HKLF 5)
        IF (IPR(619) == 0) THEN
          IF (IPR(642) > 0) THEN
            CALL PLA236 (-934, 0, FLOAT (IPR(642)), FLOAT (IPR(642)),
     1        ' ', ' ')
            N = MIN (IPR(642), NP83)
            DO I = 1, N, 6
              K = MIN (5, N - I)
              WRITE (PRBUF, 99955)
     1          ((NOUTX(L, I + J), L = 1, 3), J = 0, K)
              WRITE (LU68,  99959) PRBUF(1:79)
            END DO
          ENDIF
        END IF
        IF (IPR(380) > 0) WRITE (LU13, 99961, IOSTAT = IOST) IPR(380)
C * TAKE EXCLUDED REFLECTION INTO ACCOUNT FOR CRYSTALS(I)
        IF (IGBL(9) == 8) THEN
          YUNK = PAR(517)
        ELSE
          YUNK = PAR(446)
        END IF
C * USE _diffrn_reflns_theta_full when _diffrn_reflrn_theta_max NOT GIVEN
        IF (PAR(168) < 0.0 .AND. PAR(312) > 0.0) THEN
          DIFF = ABS (YUNK - PAR(312))
        ELSE
          DIFF = ABS (YUNK - PAR(168))
        END IF
C * ALERT _920
        IF (ABS (DIFF) > 0.01)
     1    CALL PLA236 (920, 2, ABS (DIFF), DIFF, ' ', ' ')
 
C * CHECK FOR TWINNING & BIJVOET PAIR ANALYSIS (DUMMY !!)
        CALL PLA410 (2)
C * GRAPHICS OUTPUT
        IF (IPR(123) == 0 .AND. IGBL(3) /= 1 .AND. IGBL(3) /= 33
     1      .AND. IGBL(3) /= 34) THEN
          CALL GEN108 (LU13, 1)
C * INACTIVATE CLICKABLE MENU-OPTIONS
          IGBL6SAVE = IGBL(6)
          IGBL(6)   = 0
          N         = 0
          DO
            VRT = 19.4
            BCD = 'FCF-VALIDATION'//CHAR (0)
            CALL GGIP (HORS, VERT, 0.0, 1)
            N   = N + 1
            IF (N == 1) THEN
              LIJN = 'VALIDATION REPORT FOR CURRENT FCF'
              CALL PLA439 (0.0, LIJN, 33, 0.375, 5 + IGBL(68), 2, 7.0,
     1                     VRT - 0.6)
              VRT = VRT - 1.1
            END IF
            DO WHILE (VRT > 0.6)
              READ (LU13, 99959, IOSTAT = IOST) LIJN
              IF (IOST == -1) GO TO 80
              WRITE (6, 99959) LIJN
              VRT = VRT - 0.5
              CALL PLA439 (0.0, LIJN, 80, 0.35, 1, 2, 1.0, VRT)
            END DO
C * WHAT NEXT ?
   70       CALL PLA012 (1, 1)
            IF (IGGT(1:4) == 'PLOT') GO TO 70
            IF (IGGT(1:4) == 'CALC' .OR. IGGT(1:1) == 'Y') CYCLE
            IF (IGGT(1:4) == 'EXIT') GO TO 90
            IF (IGGT(1:1) /= ' ' .AND. IGGT(1:1) /= '!') THEN
              IF (IGGT(1:1) == 'N') GO TO 90
              IF (LRET == 2) THEN
                CALL GEN108 (LU13, 0)
                CYCLE
              END IF
              LINE = IGGT
              CALL GEN038 (IGGT, 1, 80)
            END IF
          END DO
   80     CALL PLA297 (0)
        END IF
      END IF
   90 IGBL(6) = IGBL6SAVE
      IF (IPR(408) == 2) THEN
C * SAVE 'EXACT' VALUES FOR VALIDATION OUTPUT
        IPR(559) = IPR(377)
        IPR(560) = IPR(378)
        IPR(561) = IPR(305)
        IPR(562) = IPR(306)
        IPR(563) = IPR(307)
C * REPORT DIFFERENCES BETWEEN CALCULATED AND REPORTED INDEX MAXIMA
        DIFH     = IPR(561) - MAX (0, -IPR(267), IPR(268))
        IF (IPR(105) == 0 .AND. IPR(672) == 6 .AND.
     1    IGBL(9) /= 11) THEN
C * ALERT _950 - DIFF (HMAX-CALC & HMAX-REPORTED)
          IF (ABS (DIFH) > 1.0)
     1      CALL PLA236 (950, 0, -999.0, DIFH, ' ', ' ')
          DIFK = IPR(562) - MAX (0, -IPR(269), IPR(270))
C * ALERT _951 - DIFF (KMAX-CALC & HMAX-REPORTED)
          IF (ABS(DIFK) > 1.0)
     1      CALL PLA236 (951, 0, -999.0, DIFK, ' ', ' ')
          DIFL = IPR(563) - MAX (0, -IPR(271), IPR(272))
C * ALERT _952 - DIFF (LMAX-CALC & LMAX-REPORTED)
          IF (ABS(DIFL) > 1.0)
     1      CALL PLA236 (952, 0, -999.0, DIFL, ' ', ' ')
        END IF
      END IF
C * HANDLE .hks STATUS
      IF (IGBL(18) == 0 .OR.  IGBL(22) == -1 .OR.
     1   (IGBL(18) == 1 .AND. IPR(408) > 0) .OR.
     2   (IGBL(22) == 0 .AND. IPR(408) < 1)) THEN
        CLOSE (UNIT = LU18, STATUS = 'DELETE', IOSTAT = IOST)
        IF (IOST /= 0) RETURN
        IGBL(18) = 0
      ELSE
        CLOSE (UNIT = LU18, IOSTAT = IOST)
      END IF
      DEALLOCATE (IAR)
      RETURN
99999 FORMAT (/, ':: Packing Problem (NPZ)', 9I10)
99998 FORMAT (/, ':: Pre-Scale Factors Applied to I and Sig(I):', 2F10.1
     1      , /, ':: Post-Scale Factor Applied to I and Sig(I):', F10.5)
99997 FORMAT (/, ':: Friedel Related Reflections are Averaged')
99996 FORMAT (/, ':: Hmax =', I3, ' Kmax =', I3, ' Lmax=', I3,
     1 ' ,  Sorting Order : Fast ', A, ',  Medium ', A, ', Slow ', A)
99995 FORMAT (/, ':: No Recognizable Reflections Encountered for ', A,
     1 /)
99994 FORMAT (':: Deleted (Bravais) : ', 3I5, 2F10.0)
99993 FORMAT (/, ':: ILT Criterium', 10X, ': I < ', F5.1, ' SIG(I)')
99992 FORMAT ('Deleted Reflections (Bravais or Non-Int. I > 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 NVDI of array IAR)', /)
99989 FORMAT (/, ':: Actual Theta-Max:', F7.3, ' Deg.',
     1        ' ( Applied Theta Limit:', F7.3, ' Deg.)', /)
99988 FORMAT (/,
     1 ':: Number of Independent   Type  H, K, L Reflections =', I7)
99987 FORMAT (
     1 ':: Number of Independent   Type -H,-K,-L Reflections =', I7, /,
     2 ':: Total',  46X, I7)
99985 FORMAT (':: Number of Bijvoet Pairs', 27X, '=', I7)
99984 FORMAT (/,':: Total Number of Reflections Encountered on INPUT',
     1 2X, '=', I7, //, ':: Number of Less-Thans of Type  H, K, L', 13X,
     2 '=', I7)
99983 FORMAT (':: Number of Less-Thans of Type -H,-K,-L', 13X, '=', 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, /,
     3        ':: Number of Observed Spacegroup Absences  =', I7, /)
99981 FORMAT (//, ':: R(int) for    +HKL:', F10.4)
99980 FORMAT (':: R(int) for    -HKL:', F10.4, /,
     1        ':: R(Bijvoet/Friedel):', F10.4)
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 /, 132('-'), /, 4X, A, '--->', A, /, 3X, A, /)
99976 FORMAT (20('*'), ' ZONE  ', A, ' = ', I4, 1X, 24('*'))
99975 FORMAT (22('*'), ' Spacegroup Absences ', 17('*'))
99974 FORMAT (I4, 5X, A)
99973 FORMAT (
     1 '   H  K  L     <I>   <SIG> ILT     I  &  SIG       I  &  SIG',
     2 15X,
     3 'H  K  L     <I>   <SIG> ILT     I  &  SIG       I  &  SIG', /,
     4 132('-'))
99972 FORMAT (A, 12X, A)
99971 FORMAT (79('='), /, 'PLATON/ASYM-(Version', I8, ')-[Mode=', I1,
     1 '] FCF-File Validation for:', A, /, 79('='), /,
     2 'For Documentation: http://', A, 'FCF-VALIDATION.pdf', //,
     3 'Section 1', /, 79('='), /, 'General Data', /, 79('='), /,
     4 'Crystal Data From: ', A, /,
     5 'Fo/Fc   Data From: ', A, 1X, 'FCF-TYPE=', A, /,
     6 'Space Group      : ', A, /,
     7 'Wavelength (Ang) : ', F9.5, /,
     8 'Unit Cell (CIF)  : ', 3F9.4, 3F9.3)
99970 FORMAT (/, 'Section 4', /, 79('='), /,
     1 'Resolution & Completeness Statistics',
     2 ' (Cumulative and Friedel Pairs Averaged)', /, 79('='),
     3 /, 'Theta sin(th)/Lambda Complete  Expected Measured ',
     4 'Total Missing', /, 79('-'))
99969 FORMAT (F6.2, 2F10.3, 4X, 3I9)
99968 FORMAT (79('='), /, 'Total # of Reflections in FCF.', I7, 2X,
     1 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Obs', /,
     2                    'Number above Rep. Theta(Max) .', I7, /,
     3 'Actual   Theta(Max) (Deg.) ...', F7.3, 2X,
     4 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Exp', /,
     5 'Reported Theta(Max) (Deg.) ...', F7.3, 2X,
     6 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Rep', /,
     7 'Actual   Theta(Min) (Deg.) ...', F7.3, /,
     8 'Reported Theta(Min) (Deg.) ...', F7.3, /)
99967 FORMAT (/, 'Section 2', /, 79('='), /, 'Reflections with',
     1 ' abs((I(obs) - I(calc)) / ', A, ') >', F4.1, 5X,
     2 '[I(calc) from FCF]',/, 79('='), /, 3X,
     3 'Nr   H   K   L  Theta', 5X,
     4 'I(obs)', 4X, 'I(calc) Sigma(I)   Ratio', 2X, A, /, 79('-'))
99966 FORMAT (I5, 3I4, F7.2, 2F11.2, F9.2, F8.2, A, F8.2, F7.2)
99965 FORMAT (/, 79('='), /,
     1 'R-Value Statistics as a Function of Resolution',
     2 ' (in Resolution Shell)', /, 79('='), /,
     3 'Theta sin(Th)/L    #     R1    wR2      S  Rsig av(I/Sigma)',
     4 3X, 'av(I)', 3X, 'av(Sigma)', /, 79('-'))
99964 FORMAT (F6.2, F7.3, I7, 4F7.3, F7.2, 2F12.2)
99963 FORMAT ('Requested FCF-FILE not Found:', A)
99962 FORMAT (55X, 8('-'), /, 45X, 'Average =', F9.2)
99961 FORMAT ('Number of Bijvoet Pairs ......', I7)
99960 FORMAT (/, 'For I(calc) < 2 Sigma(I): <I(obs)> = ', F10.2,
     1        ' and <I(calc)> = ', F10.2)
99959 FORMAT (A)
99957 FORMAT (60('-'), ' ACTA Min. Res. ---')
99956 FORMAT (/, ':: # of Refls in fcf less than # of Parameters for ',
     1        A, /)
99955 FORMAT (14X, 6(3I3, ', '))
99954 FORMAT (/, '>> No CELL DATA Found !! - Abort')
99953 FORMAT (F7.3)
99952 FORMAT ('SHELX WGHT Pars. : ', 6F9.4)
99951 FORMAT ('Extinction Par.  : ', F12.4)
99949 FORMAT (55X, 8('-'), 8X, 8('-'),/, 45X,
     1        'Average =', F9.2, 8X, F8.2)
99948 FORMAT (/, 'Section 5', /, 79('='), /,
     1 'R-Value Statistics as a Function of Resolution',
     2 ' (in Resolution Shell)', /, 79('='), /,
     3 'Theta sin(Th)/L    #     R1    wR2      S     Rs av(I/SigW)',
     4 3X, 'av(I)    av(SigW)', /, 79('-'))
99947 FORMAT (/, 'Section 6', /, 79('='), /,
     1 'Summary of Reflection Data in FCF',
     2 ' - Note: Friedel Pairs Averaged')
99946 FORMAT (/, 'Section 6', /, 79('='), /,
     1 'Summary of Reflection Data in FCF',
     2 ' - Note: Friedel Pairs NOT Averaged')
99945 FORMAT (
     1 'Unique (Expected) ............', I7, 2X,
     2 '(HKL', I6, ', -H-K-L', I6, ')', /,
     3 'Unique (in FCF) ..............', I7, 2X,
     4 '(HKL', I6, ', -H-K-L', I6, ')', /,
     5 'Observed [I .gt. 2 Sig(I)] ...', I7, 2X,
     6 '(HKL', I6, ', -H-K-L', I6, ')', /,
     7 'Less-Thans ...................', I7, 2X,
     8 '(HKL', I6, ', -H-K-L', I6, ')', /,
     9 'Missing (Total) ..............', I7, 2X,
     * '(HKL', I6, ', -H-K-L', I6, ')', /)
99944 FORMAT (
     1 'Unique (Expected) ............', I7, /,
     2 'Unique (in FCF) ..............', I7, /,
     3 'Observed [I .gt. 2 Sig(I)] ...', I7, /,
     4 'Less-Thans ...................', I7, /,
     5 'Negative Intensities .........', I7, /,
     6 'Negative Intensities < - 2 SIG', I7, /)
99943 FORMAT (
     1 'Missing (Total) ..............', I7, /,
     2 'Missing Below Th(Min) ........', I7, /,
     3 'Missing Th(Min) to STh/L=', F5.3, I7, /,
     4 'Missing STh/L=', F5.3, ' to Th(Max)', I7, /,
     5 'Missing Very Strong Refl. ....', I7, /,
     6 'Beamstop Effected Reflections ', I7, //,
     7 'Space Group Absences .........', I7)
99942 FORMAT (/, 79('-'), /,
     1        'From FCF: R1 =', F7.4, '(', I7, '), wR2 =', F7.4,
     2        '(', I7, '), S =', F8.3)
99941 FORMAT ('From CIF: R1 =', F7.4, '(', I7, '), wR2 =', F7.4,
     2        '(', I7, '), S =', F8.3, ', Npar =', I5)
99940 FORMAT (/, ':: ASYM - EXPECT GENERATE MODE')
99939 FORMAT (':: Scaled F(000)**2 =', 19X, F15.1, /)
99938 FORMAT (/, 'Note: The Reported Completeness refers to the Actual',
     1 ' H,K,L Index Range', /)
99936 FORMAT ('JANA  WGHT Par.  : ', F9.4)
99935 FORMAT (/, 'Note: Negative Theta Values Mark Likely Beamstop ',
     1           'Effected Reflections')
99934 FORMAT (/, 'No (SHELXL) Optimized Weights:  ',
     1        'wR2 =', F7.4, 9X, ', S =', F8.2)
99932 FORMAT (/, 'R(sig) = sum(sig(I)) / sum(I) =', F8.4)
99931 FORMAT (/, 'Note: SigW(I) is the SHELXL optimized weight')
99930 FORMAT (3I4, 2I8, I4)
99929 FORMAT ('DISP', 1X, A, 2F10.3)
99928 FORMAT ('SPGR ', A, /, 'CELL ', 6F9.3, /, 'Wavelength', F10.5)
99927 FORMAT ('_chemical_formula_sum ', A)
99926 FORMAT (/, '_platon_generate_hkl', I10)
99924 FORMAT ('Multiplicity', I3, ', Frequency', I6, ' = ', I6, 1X,
     1  2A, F6.2,'% Mult >= ', I3)
99923 FORMAT (/, A,'-File Measurement Multiplicity Statistics',
     1  /, 44('='))
99922 FORMAT (26X, 6('='), 3X, 6('='), /, 'Totals', 20X, I6, 3X, I6, //,
     1 'Average Measurement Multiplicity = ', F6.1, ' in ', A,'-File')
99921 FORMAT (I5, 3I4, F7.2, 2I11, I9, F8.2, A, F8.2, F7.2)
99920 FORMAT (39X)
99919 FORMAT (38('*'))
99918 FORMAT (14X, 'Predicted wR2: Based on SigI**2', F6.2,
     1 ' or SHELX Weight', F6.2)
 
      END SUBROUTINE PLA145
 
      SUBROUTINE PLA146 (JP, IND, LPUN, IRM)
C * ASYM (2)
      USE files
      USE parameters
      USE reflex
      USE asym
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: N
      INTEGER           :: JP
      INTEGER           :: MM
      INTEGER           :: IH
      INTEGER           :: IK
      INTEGER           :: IL
      INTEGER           :: NDC
      INTEGER           :: IHU
      INTEGER           :: ILT
      INTEGER           :: ISM
      INTEGER           :: IND
      INTEGER           :: JPA
      INTEGER           :: JPB
      INTEGER           :: IRM
      INTEGER           :: LPAB
      INTEGER           :: LPUN
      REAL              :: RM
      REAL              :: SA
      REAL              :: SB
      REAL              :: SY
      REAL              :: SZ
      REAL              :: SM0
      REAL              :: DEL
      REAL              :: ACAL
      REAL              :: BCAL
      REAL              :: STHK
      REAL              :: ACALA
      REAL              :: BCALA
      REAL              :: SNTHA
      REAL              :: ACALAF
      REAL              :: BCALAF
      REAL              :: GEN095
      CHARACTER(len=60) :: XAR
      CHARACTER(len=80) :: ICRD
      CHARACTER(len=1)  :: IDSM
      IF (JP == 1 .AND. IND == 1) IPR(727) = IPR(727) + 1
      NSYMH = IPR(255)
      IHU   = 2 * (IHKL(IND1) + IHM(IND1) + 1) + 1 - IND
      IF (IND == 1) THEN
        IDSM = '+'
      ELSE
        IDSM = '-'
      END IF
      IF (JP == 1) THEN
        IPR(637) = IPR(637) + 1
      ELSE IF (JP > 1) THEN
        IPR(638) = IPR(638) + 1
      ENDIF
      IF (JP > 0) THEN
        IF (IKS(IND3) >= 0) MULT(JP) = MULT(JP) + 1
        SA = 0.0
        SB = 0.0
        DO K = 1, JP
          SY = RB(K, IND)
          SZ = 1.0 / (SY**2)
          SA = SA + RA(K, IND) * SZ
          SB = SB + SZ
        END DO
C * CALCULATE AVERAGE INTENSITY
        RM  = SA  / SB
        IRM = NINT (RM)
        IF (IPR(408) /= 1) THEN
          SM0 = 1.0 / SQRT(SB)
C * SIGI(I) = SQRT(I) FOR GENERATED DATA (IPR(408) = 1)
        ELSE
          SM0 = SQRT (RM)
        END IF
        ISM = NINT (SM0)
C * CHECK FOR NON SPACEGROUP ABCENT REFLECTION
        IF (IKS(IND3) >= 0 .AND. JP > 1) THEN
          DO K = 1, JP
            IPR(755)   = IPR(755) + 1
            DEL        = ABS (ABS (RA(K, IND)) - ABS (RM))
            SM(1, IND) = SM(1, IND) + DEL
            SM(2, IND) = SM(2, IND) + RA(K, IND)
          END DO
        END IF
        IF (IND /= 1) THEN
          DO MM = 1, 3
            IHKLE(MM) = - IHKL(MM)
          END DO
        END IF
        ILT = 1
        IF (RM < PAR(284) * SM0) ILT = 2
        IF (IKS(IND3) /= -1) THEN
          IDSM = '*'
C * DISPLAY INTENSITY OR FREQUENCY
          IF (IPR(468) == 0) THEN
            IF (SM0 /= 0.0) THEN
              NDC = NINT (RM / SM0)
            ELSE
              NDC = 10
            END IF
          ELSE
            NDC = JP
          END IF
          IF (NDC < 10) IDSM = CHAR (ICHAR ('0') + NDC)
          IF (ILT == 2) THEN
            IF (IPR(468) == 0) IDSM = 'L'
            IPR(374 + IND) = IPR(374 + IND) + 1
          END IF
        END IF
        IF (IABS (IPR(392) - 2) == 1 .OR. IKS(IND3) == -1) THEN
          DO JPA = 1, JP, 2
            JPB = JPA + 1
            IF (JPB > JP) JPB = JP
            LPAB = 0
            DO K = JPA, JPB
              LPAB = LPAB + 1
              IRAB(LPAB, 1) = NINT (RA(K, IND))
              IRAB(LPAB, 2) = NINT (RB(K, IND))
            END DO
            IF (IPR(408) /= 2) THEN
              WRITE (XAR, 99999, IOSTAT = IOST)
     1          (IRAB(K, 1), IRAB(K, 2), K = 1, LPAB)
              AR(IPL) = XAR
              IF (JPA == 1) WRITE (XAR, 99997, IOSTAT = IOST)
     1          (IHKLE(MM), MM = 1, 3), IRM, ISM, ILT
              AR(IPL)(1:30) = XAR(1:30)
              IPL = IPL + 1
              IF (IPL > 102) THEN
                IPL = 1
C * NO PRINT FOR VALIDATION RUN
                IF (IGBL(22) /= -1) THEN
                  CALL PLA262 (0)
                  WRITE (LU7, 99998, IOSTAT = IOST)
                  WRITE (LU7, 99995, IOSTAT = IOST)
     1              (AR(I), AR(I + 51), I = 1, 51)
                END IF
              END IF
            END IF
          END DO
        END IF
        IF (IKS(IND3) /= -1) THEN
C * IPR(377) & IPR(378) COUNTS
          IPR(376 + IND) = IPR(376 + IND) + 1
          IF (ILT == 1) THEN
            IF (IND == 1) THEN
              IPR(383) = IPR(383) + 1
            ELSE
              IPR(362) = IPR(362) + 1
            END IF
          END IF
          IF (IPR(408) < 2) THEN
            IF (IPR(408) == 1 .AND. IRM == 0) ISM = 1
            IF (LPUN > 0) THEN
              IH = IHKLE(1)
              IK = IHKLE(2)
              IL = IHKLE(3)
              IF (IPR(700) == 0) THEN
                WRITE (LPUN, 99996, IOSTAT = IOST) IH, IK, IL, IRM, ISM
              ELSE
                ACAL   = 0
                BCAL   = 0
                ACALA  = 0.0
                BCALA  = 0.0
                ACALAF = 0.0
                BCALAF = 0.0
                CALL PLA137 (IH, IK, IL, ACAL, BCAL, ACALA,
     1            BCALA, ACALAF, BCALAF, SNTHA)
                WRITE (LPUN, 99994, IOSTAT = IOST)
     1                  IH, IK, IL, ACAL, BCAL
              END IF
            END IF
C * EXPAND DATASET TO P-1
            IF (IPR(408) < 0) THEN
              IF (NSYMH > 1) THEN
                DO I = 1, 3
                  SGX(I)      = IHKLE(I)
                  IHKLS(I, 1) = IHKLE(I)
                END DO
                SGX(4) = 0.0
                N     = 1
                DO 20 I = 2, NSYMH
                  CALL SGSM (5, ICRD, SGX, I, LU7, IERR)
                  DO J = 1, 3
                    IHKLS(J, N + 1) = NINT (SGX(J + 6))
                  END DO
                  DO K = 1, N
                    IF (IHKLS(1, K) == IHKLS(1, N + 1)) THEN
                      IF (IHKLS(2, K) == IHKLS(2, N + 1)) THEN
                        IF (IHKLS(3, K) == IHKLS(3, N + 1)) GO TO 20
                      END IF
                    END IF
                    IF (IHKLS(1, K) == - IHKLS(1, N + 1)) THEN
                      IF (IHKLS(2, K) == - IHKLS(2, N + 1)) THEN
                        IF (IHKLS(3, K) == - IHKLS(3, N + 1))
     1                    GO TO 20
                      END IF
                    END IF
                  END DO
                  N = N + 1
                  IF (LPUN > 0) THEN
                    IH = IHKLS(1, N)
                    IK = IHKLS(2, N)
                    IL = IHKLS(3, N)
                    WRITE (LPUN, 99996, IOSTAT = IOST)
     1                IH, IK, IL, IRM, ISM
                  END IF
   20           CONTINUE
              END IF
            END IF
          END IF
        END IF
      END IF
      IF (IHU > 0 .AND. IHU <= NP44) THEN
        CID(IHU:IHU) = IDSM
        IF (IDSM /= '+' .AND. IDSM /= '-') THEN
          STHK = GEN095 (PAR(191), IHKLE(1), IHKLE(2), IHKLE(3))
          IF (STHK < 0.09) IPR(512) = IPR(512) - 1
        END IF
      END IF
      RETURN
99999 FORMAT (28X, 2(I9, I7))
99998 FORMAT (
     1 '   H  K  L     <I>   <SIG> ILT     I  &  SIG       I  &  SIG',
     2 15X,
     3 'H  K  L     <I>   <SIG> ILT     I  &  SIG       I  &  SIG', /,
     4 132('-'))
99997 FORMAT (1X, 3I3, I9, I7, I2)
99996 FORMAT (3I4, 2I8, 3X, '1')
99995 FORMAT (A, 12X, A)
99994 FORMAT (3I4, 2F10.2)
      END SUBROUTINE PLA146
 
      SUBROUTINE PLA147 (LEV)
C * ASYM (3) - SHOW RECIPROCAL LATTICE IN GRAPHICAL WINDOW
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE mentry
      USE xwdw
      USE reflex
      USE asym
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: NK
      INTEGER          :: NL
      INTEGER          :: NS
      INTEGER          :: LEV
      INTEGER          :: JMX
      INTEGER          :: NCOL
      INTEGER          :: ISTH
      INTEGER          :: JMAX
      REAL             :: CR
      REAL             :: CX
      REAL             :: CY
      REAL             :: TH
      REAL             :: CYS
      REAL             :: CXH
      REAL             :: CXS
      REAL             :: CXV
      REAL             :: CYV
      REAL             :: STL
      REAL             :: TH25
      REAL             :: THOR
      REAL             :: YDUM
      REAL             :: STPA
      REAL             :: STPB
      REAL             :: SVER
      REAL             :: SCA1
      REAL             :: SCA2
      REAL             :: SCAL
      REAL             :: SHFT
      REAL             :: SHOR
      REAL             :: STEP
      REAL             :: STHK
      REAL             :: STHL
      REAL             :: ANG1
      REAL             :: ANG2
      REAL             :: ANG3
      REAL             :: ACAL
      REAL             :: BCAL
      REAL             :: CALC
      REAL             :: CHOR
      REAL             :: ACALA
      REAL             :: BCALA
      REAL             :: SNTHA
      REAL             :: ACALAF
      REAL             :: BCALAF
      REAL             :: GEN095
      CHARACTER(len=1) :: THFL
      JMAX = 0
      SHOR = 0.0
      STEP = 0.0
      STPA = 0.0
      STPB = 0.0
      SVER = 0.0
      CHOR = 0.0
      SCAL = 0.0
      TH25 = MIN (ASIN  (0.6 * PAR(17)) * RGBL(6), PAR(446))
C * CHECK FOR ASYM VIEW MODE (1)
      IF (IGBL(22) > 0) THEN
        IGBL(6) = 14
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP (0.0, 1.0, 0.0, 0)
        CALL PLA110 (HORS, VERT, -1)
C * REPORT ON PARAMETER & REFLECTION INPUT FILES
        IF (IPR(406) == 1) THEN
          KNMXT = KNMFIL + KXT + 1
          WRITE (PRBUF, 99989, IOSTAT = IOST)
     1      FNLU1(1:KNMXT), DTYPE(IABS (IGBL(8)))
          CALL PLA439 (0.0,  PRBUF, KNMXT + 8, 0.3, -1, 2, 17.0, 1.0)
          IF (IPR(408) <= 0) THEN
            WRITE (PRBUF, 99989, IOSTAT = IOST) FNLU16(1:KNM16),
     1      RDTYP(IGBL(9))
            CALL PLA439 (0.0,  PRBUF, KNM16 + 8, 0.3, -1, 2, 17.0, 0.2)
          ELSE
            WRITE (PRBUF, 99988, IOSTAT = IOST)
            CALL PLA439 (0.0, PRBUF, 14, 0.3, -1, 2, 17.0, 0.2)
          END IF
          THOR = VERT + 2.5
          IF (IPR(275) == 1) THEN
            IF (IPR(393) == 1) THEN
              WRITE (PRBUF, 99991, IOSTAT = IOST)
            ELSE
              WRITE (PRBUF, 99990, IOSTAT = IOST)
            END IF
            CALL PLA439 (0.0, PRBUF, 18, 0.3, 2, 2, VERT + 1.9,
     1                   VERT - 0.8)
          END IF
          IF (IPR(132) ==  0) THEN
            WRITE (PRBUF, 99997, IOSTAT = IOST) ' Iobs Data'
          ELSE IF (IPR(132) == 1) THEN
            WRITE (PRBUF, 99997, IOSTAT = IOST) ' Icalc Data'
          ELSE IF (IPR(132) == 2) THEN
            WRITE (PRBUF, 99997, IOSTAT = IOST)
     1        'abs(Iobs-Icalc)/sig(Iobs)'
          ELSE IF (IPR(132) == 3) THEN
            WRITE (PRBUF, 99997, IOSTAT = IOST)
     1        'Pos(Iobs-Icalc)/sig(Iobs)'
          END IF
          CALL PLA439 (0.0, PRBUF, 36, 0.3, 2, 2, 1.6 , 0.9)
          WRITE (PRBUF, 99987, IOSTAT = IOST) 'SpaceGr ', SPGRNM(1)(1:7)
          CALL PLA439 (0.0, PRBUF, 15, 0.3, 1, 2, THOR, VERT - 1.5)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'a      ', PAR(101)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 2.0)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'b      ', PAR(102)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 2.5)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'c      ', PAR(103)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 3.0)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'alpha  ', PAR(104)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 3.5)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'beta   ', PAR(105)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 4.0)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'gamma  ', PAR(106)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 4.5)
          WRITE (PRBUF, 99984, IOSTAT = IOST) 'lambda ', PAR(17)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 5.0)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'Th(min)', PAR(445)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 5.5)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'Th(max)', PAR(446)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 6.0)
          WRITE (PRBUF, 99996, IOSTAT = IOST) 'SigOmit', PAR(284)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 6.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST)   'Total  ', IPR(373)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 7.0)
          WRITE (PRBUF, 99995, IOSTAT = IOST)   'Unique ', IPR(377)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 7.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST)   'Obsd   ', IPR(383)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 8.0)
        END IF
C * RECIPROCAL LAYER PLOTS
        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)
C * GET SCALE FACTOR
        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
      END IF
      CALL GEN108 (LU14, 0)
      DO
        READ (LU14, 99997, IOSTAT = IOST) CID
        IF (IOST == -1) GO TO 10
        IF (CID(1:4) == 'ZONE') THEN
          READ (CID(11:15), 99994) NL
          IF (NL > NP63 - 1) THEN
            WRITE (6, 99981) NP63
            STOP
          END IF
          IF (NL == LEV) EXIT
        END IF
      END DO
      IKS(IND3) = NL
      IPR(382)  = MAX (IPR(382), NL)
C * Zone
      WRITE (CID(16:29), 99993, IOSTAT = IOST) IHM(IND3)
      IF (IGBL(22) >= 0) THEN
        HRT = SHFT
        VRT = VERT - 0.4
        CALL PLA439 (0.0, CID, 29, 0.2, -1, 1, HRT, VRT)
      END IF
      READ (LU14, 99997, IOSTAT = IOST) CID
      IF (IOST == -1) GO TO 10
      NS = - IHM(IND2)
      READ (LU14, 99997, IOSTAT = IOST) CID
      IF (IOST == -1) GO TO 10
C * GET/PLOT HORIZONTAL INDEX MARKERS
      IF (IGBL(22) >= 0) THEN
        VRT = VRT - SVER
        CALL PLA439 (0.0, CID(1:5), 5, 0.2, -1, 1, HRT, VRT)
        HRT = HRT + 1.45 + SHOR + NS * CHOR
        DO I = 11, NP44, 2
          IF (HRT > (SHFT + 1.0)) THEN
            CALL PLA439 (0.0, CID(I:I), 1, 0.2, -1, 1, HRT, VRT)
          END IF
          HRT = HRT + SHOR
        END DO
      END IF
C * GET DOWN INDEX LABEL
      READ (LU14, 99997, IOSTAT = IOST) CID
      IF (IOST == -1) GO TO 10
      IF (IGBL(22) >= 0) THEN
C * PLOT DOWN INDEX LABEL
        VRT = VRT - SVER
        CALL PLA439 (0.0, CID, 15, 0.2, -1, 2, SHFT, VRT)
C * PLOT AXES
        CX  = SHFT + 1.5 +
     1        (IHM(IND1) + 1) * SHOR + (NS + IHM(IND2) + 1) * CHOR
        CY  = VRT - (IHM(IND2) + 1) * SVER
C * PLOT RESOLUTION CIRCLES
        IF (IPR(387) == 1) THEN
          CXS = CX - LEV * STPA
          CYS = CY + LEV * STPB
          JMAX = NINT(SIN(PAR(446) / RGBL(6)) / (PAR(17) * 0.05))
          DO J = 10, JMAX
            STL = J * 0.05
            IF (J == 12) THEN
              CALL GGIP (0.0, 2.0, 0.0, 0)
            ELSE
              CALL GGIP (0.0, 1.0, 0.0, 0)
            END IF
            CR = SCAL * 2.0 * STL
            CR = SQRT (MAX (0.0, CR**2 - (NL * STEP)**2))
C * PLOT CIRCLE
            CALL PLA289 (CXS, CYS, CR, 120)
          END DO
C * MINIMUM resolution CIRCLE
          IF (PAR(445) > 0.0) THEN
            STL = SIN(PAR(445) / RGBL(6)) / PAR(17)
            CALL GGIP (0.0, 5.0, 0.0, 0)
            CR = SCAL * 2.0 * STL
            CR = SQRT (MAX (0.0, CR**2 - (NL * STEP)**2))
C * PLOT CIRCLE
            CALL PLA289 (CXS, CYS, CR, 120)
          END IF
        END IF
C * PLOT AXES
        IF (IPR(388) == 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)
        END IF
      END IF
C * READ BLANK LINE
      READ (LU14, 99997, IOSTAT = IOST) CID
      IF (IOST == -1) GO TO 10
      DO
        READ (LU14, 99997, IOSTAT = IOST) CID
        IF (IOST == -1) GO TO 10
        IF (CID(1:4) == 'ZONE') THEN
          GO TO 20
        ELSE
          NS = NS + 1
C * ONE STEP DOWN
          IF (IGBL(22) >= 0) THEN
            VRT = VRT - SVER
            CALL GGIP (0.0, 1.0, 0.0, 0)
          END IF
          READ (CID(1:4), 99992) NK
          IKS(IND2) = NK
          IF (IGBL(22) >= 0) THEN
            CALL PLA439 (0.0, CID(1:5), 5 + IGBL(68), 0.2, -1, 1, SHFT,
     1                   VRT)
            HRT = SHFT + 1.5 + SHOR + NS * CHOR
          END IF
          IKS(IND1) = - IHM(IND1) - 1
          DO I = 11, NP44, 2
            IF (IT(NL + 1) == 0) THEN
              IKS(IND1) = IKS(IND1) + 1
              IF (CID(I:I) == 'E') THEN
                IF (IPR(776) == 0) CID(I:I) = ' '
                IPR(385) = IPR(385) + 1
              END IF
              IF (CID(I + 1:I + 1) /= ' ' .AND. CID(I + 1:I + 1) /= '-'
     1            .AND. CID(I + 1:I + 1) /= '#') THEN
                IPR(390) = IPR(390) + 1
                IF (CID(I + 1:I + 1) == '?') THEN
                  IPR(391) = IPR(391) + 1
                END IF
              END IF
              IF (CID(I:I) /= ' ' .AND. CID(I:I) /= '+'
     1            .AND. CID(I:I) /= '#') THEN
                STHK = GEN095 (PAR(191), IKS(1), IKS(2), IKS(3))
                STHL = SQRT (STHK)
C * HANDLE MISSING REFLECTIONS
                IF (CID(I:I) == '?') THEN
                  IPR(386) = IPR(386) + 1
C * NO PRINT FOR VALIDATION RUN
                  IF (IGBL(22) /= -1) THEN
                    IF (IPR(386) == 1) THEN
                      CALL PLA262 (0)
                      WRITE (LU7, 99999, IOSTAT = IOST)
     1                  MIN (0.6, PAR(446))
                      CALL PLA262 (3)
                    END IF
                    CALL PLA262 (1)
                    WRITE (LU7, 99998, IOSTAT = IOST)
     1                IPR(386), IKS(1), IKS(2), IKS(3), STHL
                  END IF
C * TEST FOR NON-HKLF 2
                  IF (IPR(648) /= 2) THEN
                    TH = ASIN (STHL * PAR(17)) * RGBL(6)
C * CHECK FOR MISSING REFLECTION BELOW DATASET  TH(MIN) (= PAR(445))
                    IF (TH < PAR(445)) THEN
                      IPR(553) = IPR(553) + 1
                      IF (IPR(553) <= NP79) THEN
                        DO J = 1, 3
                          NTHMN(J, IPR(553)) = IKS(J)
                        END DO
                      END IF
                    ELSE IF (TH > TH25) THEN
                      IPR(557) = IPR(557) + 1
                    ELSE
C * CHECK FOR MISSING REFLECTIONS BETWEEN Sin(ThMin) AND MIN(SinThmax, 0.6)
                      IPR(555) = IPR(555) + 1
                      IF (IPR(555) <= NP80) THEN
                        DO J = 1, 3
                          NTHMX(J, IPR(555)) = IKS(J)
                        END DO
                      END IF
                    END IF
                  END IF
                  IF (IGBL(22) == 1) THEN
                    NMISS = NMISS + 1
                    IF (NMISS == 1) WRITE (LU6, 99979)
                    WRITE (LU6, 99980) NMISS, IKS(1), IKS(2), IKS(3), TH
                  END IF
                  IF (TH <= TH25) THEN
                    ACAL   = 0.0
                    BCAL   = 0.0
                    ACALA  = 0.0
                    BCALA  = 0.0
                    ACALAF = 0.0
                    BCALAF = 0.0
                    CALL PLA137 (IKS(1), IKS(2), IKS(3), ACAL, BCAL,
     1                ACALA, BCALA, ACALAF, BCALAF, SNTHA)
                    CALC = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2
                    IF (IGBL(22) < 0) THEN
                    NHEAD = NHEAD + 1
                    IF (NHEAD == 1) WRITE (LU13, 99999, IOSTAT = IOST)
     1                MIN (0.6, PAR(446))
                    IF (TH < PAR(445)) THEN
                      THFL = '*'
                    ELSE
                      THFL = ' '
                    END IF
                    IF (CALC / CALIM > 1.0) THEN
                      IPR(584) = IPR(584) + 1
                      IF (IPR(584) <= NP84) THEN
                        DO J = 1, 3
                          NSTRM(J, IPR(584)) = IKS(J)
                        END DO
                      END IF
                    END IF
                    WRITE (LU13, 99998, IOSTAT = IOST)
     1                NHEAD, IKS(1), IKS(2), IKS(3), STHL, TH, THFL,
     2                CALC, CALC / CALIM
                    END IF
                  END IF
                END IF
                IPR(384) = IPR(384) + 1
                ISTH     = INT (STHL * 20.0) - 8
                DO J = 1, 20
                  IF (ISTH <= J .AND. CID(I:I) /= 'E') THEN
                    ICNT(J, 1) = ICNT(J, 1) + 1
                    IF (CID(I:I) /= '?') ICNT(J, 2) = ICNT(J, 2) + 1
 
 
                  END IF
                END DO
              END IF
            END IF
            IF (IGBL(22) >= 0) THEN
              IF (CID(I:I) == '*') THEN
                NCOL = 2
              ELSE IF (CID(I:I) == 'L') THEN
                NCOL = 4
              ELSE IF (CID(I:I) == 'E') THEN
                IF (IPR(776) == 0) CID(I:I) = ' '
                NCOL = 1
              ELSE IF (CID(I:I) == '+') THEN
                NCOL = 1
              ELSE IF (CID(I:I) == '?') THEN
                NCOL = 5 + IGBL(68)
              ELSE IF (CID(I:I) == '#') THEN
                NCOL = 5 + IGBL(68)
              ELSE
                IF (IPR(468) == 0 .OR. CID(I:I) == '1') THEN
                  NCOL = 3
                ELSE
                  NCOL = 2
                END IF
              END IF
              IF (IPR(369) /= 0) THEN
                IF (CID(I:I) /= '?' .AND. CID(I:I) /= '#'
     1              .AND. CID(I:I) /= ' ') THEN
                  NCOL = 4
                  CID(I:I) = '.'
                END IF
              END IF
              CALL PLA439 (0.0, CID(I:I), 1, 0.2, NCOL, 1, HRT - 0.1,
     1                     VRT - 0.1)
C * ADD 1 STEP TO THE RIGHT
              HRT = HRT + SHOR
            END IF
          END DO
        END IF
      END DO
   10 IF (NHEAD > 0) THEN
C * ACTUAL THETA-MIN FROM HKL/FCF
        WRITE (LU13, 99983, IOSTAT = IOST) MAX (0.0, PAR(445))
C * THETA-MIN FROM CIF
        IF (PAR(167) > 0.0)
     1    WRITE (LU13, 99982, IOSTAT = IOST) PAR(167)
      END IF
      CALL GEN108 (LU14, 0)
      LEV = -1
   20 IT (NL + 1) = 1
      IF (IPR(406) == 1) THEN
        IF (IGBL(22) >= 0) THEN
          PRBUF = 'Resol Perc'
          CALL PLA439 (0.0, PRBUF(1:10), 10, 0.3, 2, 2, THOR, 1.6)
        END IF
        DO I = 10, JMAX
          IF (I < 20) THEN
            IF (I == 12) THEN
              NCOL = 2
            ELSE
              NCOL = 1
            END IF
            IF (ICNT(I - 9, 1) /= 0) THEN
              YDUM = ICNT(I - 9, 2) * 100.0 / ICNT(I - 9, 1)
            ELSE
              YDUM = 0.0
            END IF
            IF (IGBL(22) >= 0) THEN
              WRITE (PRBUF, 99986, IOSTAT = IOST) I * 0.05, YDUM
              CALL PLA439 (0.0, PRBUF(1:10), 10, 0.3, NCOL, 2, THOR,
     1                    (I - 6) * 0.5)
            END IF
          END IF
        END DO
        IF (IGBL(22) >= 0) THEN
          JMX = MIN (JMAX, 20) + 1
          WRITE (PRBUF, 99985, IOSTAT = IOST) 'Layer 0 -', IPR(382)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 2, 2, THOR, JMX * 0.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST) 'SpGrExt', IPR(385)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 4, 2, THOR, (JMX - 1) * 0.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST) 'MaxUniq', IPR(384)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, (JMX - 2) * 0.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST) 'Missing', IPR(386)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 5 + IGBL(68), 2, THOR,
     1                 (JMX - 3) * 0.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST) 'N eq 1 ', IPR(637)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, (JMX - 4) * 0.5)
          WRITE (PRBUF, 99995, IOSTAT = IOST) 'N gt 1 ', IPR(638)
          CALL PLA439 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, (JMX - 5) * 0.5)
          CALL GGIP (0.0, 1.0, 0.0, 0)
        END IF
      END IF
      RETURN
99999 FORMAT (/, 'Section 3', /, 79('='), /,
     1 'Missing Reflections (Asym. Refl. Unit)',
     2 ' below sin(th)/lambda =', F6.3, /, 79('='), /,
     3 '   Nr       H    K    L  sin(th)/lambda', 3X,
     4 'Theta', 8X, 'I(calc)', 2X, 'I(calc)/I(max)', /, 79('-'))
99998 FORMAT (I5, 3X, 3I5, F11.3, 6X, F7.2, A, F14.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, /)
99981 FORMAT ('** Too Many Layers (Max =', I4, ') **')
99980 FORMAT (I5, ' : ', 3I5, F8.2)
99979 FORMAT (//, 6X, 'Missing Reflections', /, 3X, 'Nr', 7X, 'H', 4X,
     1        'K', 4X, 'L', 3X, 'THETA')
      END SUBROUTINE PLA147
 
      SUBROUTINE PLA148
 
C * ASYM (4)
      USE files
      USE parameters
      USE reflex
      USE sgxyz
      USE asym
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: N
      INTEGER           :: IASM
      REAL              :: STHK
      REAL              :: GEN095
      CHARACTER(len=80) :: LINE
      CALL GEN038 (CID, 1, NP44)
      N = 2 * IHM(IND1) + 1
      J = -1
      DO I = 1, N
        IKS(IND1) = - IHM(IND1) - 1 + I
        J = J + 2
        IF (IKS(IND3) == 0) THEN
          IF (IKS(IND2) < 0) THEN
            CYCLE
          ELSE IF (IKS(IND2) == 0) THEN
            IF (IKS(IND1) <= 0) CYCLE
          END IF
        END IF
        STHK = GEN095 (PAR(191), IKS(1), IKS(2), IKS(3))
        IF (STHK < ATHM) THEN
C * CHECK FOR LATTICE AND NON-LATTICE ABSENCES
          DO K = 1, 3
            SGX(K) = IKS(K)
          END DO
          SGX(12) = 0.0
          CALL SGSM (27, LINE, SGX, 0, 0, IERR)
          IF (NINT (SGX(12)) == 2) CYCLE
C * CHECK FOR IASM
          CALL PLA136 (0, IKS(1), IKS(2), IKS(3), IASM)
          IF (J > 0 .AND. J < NP44) THEN
            IF (NINT (SGX(12)) == 0) THEN
              IF (IASM == 1) THEN
                CID(J:) = ' ?'
                IF (STHK < 0.09) IPR(512) = IPR(512) + 1
              ELSE
                CID(J:) = ' #'
              END IF
            ELSE
              IF (IASM == 1) THEN
                IF (IPR(275) == 2 .OR. IPR(393) == 1) THEN
                  CID(J:) = ' E'
                ELSE
                  CID(J:) = 'EE'
                END IF
              END IF
            END IF
          END IF
        END IF
      END DO
      RETURN
      END SUBROUTINE PLA148
 
      SUBROUTINE PLA149
C * ASYM - HKL AVERAGING AND REFLECTION MULTIPLICITY REPORTING
      USE FILES
      USE PARAMETERS
      USE cchar
      IMPLICIT NONE
      REAL :: YUNK
C * COPY _sx.ins -> lasym.ins
      OPEN (UNIT = LU60, FILE = 'lasym.ins', STATUS = 'UNKNOWN',
     1  IOSTAT = IOST)
      REWIND (UNIT = LU24, IOSTAT = IOST)
      DO
        READ (LU24, 99999, IOSTAT = IOST) LINE
        IF (IOST /= 0) EXIT
        WRITE (LU60, 99999) LINE
      END DO
      CLOSE  (UNIT = LU60, IOSTAT = IOST)
C * COPY _sx.hkl -> lasym.hkl
      OPEN (UNIT = LU60, FILE = 'lasym.hkl', STATUS = 'UNKNOWN',
     1  IOSTAT = IOST)
      REWIND (UNIT = LU25, IOSTAT = IOST)
      DO
        READ (LU25, 99999, IOSTAT = IOST) LINE
        IF (IOST /= 0) EXIT
        WRITE (LU60, 99999) LINE
      END DO
      CLOSE (UNIT = LU60, IOSTAT = IOST)
      KERR = 0
C * SPAWN PLATON/ASYM JOB
      IF (DOS) THEN
        CALL SPAWN (PLAPATH(1:IGBL(80))//' -o -l2 '//
     1    ' +0lasym.log lasym.ins', LU6, .true., KERR)
      ELSE
        CALL SPAWN (PLAPATH(1:IGBL(80))//' -o -l2 '//
     1    'lasym.ins > lasym.log', LU6, .true., KERR)
      END IF
C * REMOVE lasym.ckf
      OPEN (UNIT = LU60, FILE = 'lasym.ckf',
     1  STATUS = 'UNKNOWN', IOSTAT = IOST)
      CLOSE (UNIT = LU60, STATUS = 'DELETE', IOSTAT = IOST)
C * REMOVE lasym.ins
      OPEN (UNIT = LU60, FILE = 'lasym.ins',
     1  STATUS = 'UNKNOWN', IOSTAT = IOST)
      CLOSE (UNIT = LU60, STATUS = 'DELETE', IOSTAT = IOST)
C * REMOVE lasym.hkl
      OPEN (UNIT = LU60, FILE = 'lasym.hkl',
     1  STATUS = 'UNKNOWN', IOSTAT = IOST)
      CLOSE (UNIT = LU60, STATUS = 'DELETE', IOSTAT = IOST)
C * GET AVERAGE MULTIPLICITY FROM lasym.log
      OPEN (UNIT = LU60, FILE = 'lasym.log', STATUS = 'old',
     1  IOSTAT = IOST)
      PAR(558) = 0.0
      DO
        READ  (LU60, 99999, IOSTAT = IOST) ICL(1:41)
        IF (IOST /= 0) EXIT
        IF (ICL(1:4) == 'Aver') THEN
          READ (ICL(36:41), 99998, IOSTAT = IOST) PAR(558)
          EXIT
        END IF
      END DO
C * ALERT _941 - REPORT LOW HKL MULTIPLICITY
      YUNK = 5.0 - PAR(558)
      IF (YUNK > 0.0 .AND. PAR(558) /= 0.0)
     1  CALL PLA236 (941, 1, -999.0, PAR(558), ' ', ' ')
        CLOSE (UNIT = LU60, STATUS = 'DELETE', IOSTAT = IOST)
C * LOWER THE NUMBER OF REQUESTED TASKS
      IPR(121) = IPR(121) - 1
      RETURN
99999 FORMAT (A)
99998 FORMAT (F7.1)
      END SUBROUTINE PLA149
 
      MODULE exor
      SAVE
      INTEGER, PARAMETER          :: MP3 = 1000
      INTEGER, DIMENSION(MP3, 40) :: ICON
      INTEGER, DIMENSION(MP3)     :: NCON
      REAL,    DIMENSION(84)      :: F
      REAL,    DIMENSION(1616)    :: SFC
      REAL,    DIMENSION(MP3, 46) :: PEAK
      REAL,    DIMENSION(5001, 2) :: RCURVE
      END MODULE exor
 
      SUBROUTINE PLA151 (MODE)
C * SETUP EXOR.BIN/EXOR (1)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE spgrdata
      USE pl127
      USE exor
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: L0
      INTEGER                  :: N0
      INTEGER                  :: IH
      INTEGER                  :: IK
      INTEGER                  :: IL
      INTEGER                  :: MF
      INTEGER                  :: MR
      INTEGER                  :: NE
      INTEGER                  :: NM
      INTEGER                  :: NO
      INTEGER                  :: NI
      INTEGER                  :: NJ
      INTEGER                  :: NK
      INTEGER                  :: NS
      INTEGER                  :: NT
      INTEGER                  :: NPK
      INTEGER                  :: NEK
      INTEGER                  :: NAT
      INTEGER                  :: ISW
      INTEGER                  :: MPM
      INTEGER                  :: NUMS
      INTEGER                  :: NPKM
      INTEGER                  :: NPRV
      INTEGER                  :: NEL0
      INTEGER                  :: NDIF
      INTEGER                  :: NATR
      INTEGER                  :: MDIP
      INTEGER                  :: KEEP
      INTEGER                  :: JMAX
      INTEGER                  :: IAN0
      INTEGER                  :: IBVT
      INTEGER                  :: MODE
      INTEGER                  :: NRSH
      INTEGER                  :: LOOP
      INTEGER                  :: NSYM
      INTEGER                  :: NSYMH
      INTEGER                  :: NSTAR
      INTEGER                  :: NRNEW
      INTEGER                  :: LATTS
      INTEGER                  :: ICNT3
      INTEGER                  :: IHMAX
      INTEGER                  :: IHMIN
      INTEGER                  :: IKMAX
      INTEGER                  :: IKMIN
      INTEGER                  :: ILMAX
      INTEGER                  :: ILMIN
      INTEGER                  :: IRMIN
      INTEGER                  :: KNOWN
      INTEGER, DIMENSION(NP10) :: IA
      INTEGER, DIMENSION(NP10) :: MCONT
      REAL                     :: P
      REAL                     :: Q
      REAL                     :: R
      REAL                     :: S
      REAL                     :: T
      REAL                     :: U
      REAL                     :: V
      REAL                     :: W
      REAL                     :: X
      REAL                     :: Y
      REAL                     :: Z
      REAL                     :: U1
      REAL                     :: Q1
      REAL                     :: QS
      REAL                     :: EE
      REAL                     :: GA
      REAL                     :: GD
      REAL                     :: HB
      REAL                     :: SS
      REAL                     :: UT
      REAL                     :: X1
      REAL                     :: Y1
      REAL                     :: Z1
      REAL                     :: EKW
      REAL                     :: QSMX
      REAL                     :: STLM
      REAL                     :: TEMP
      REAL                     :: HGHT
      REAL                     :: CALI
      REAL                     :: CENT
      REAL                     :: CRIT
      REAL                     :: DELT
      REAL                     :: DIST
      REAL                     :: FACT
      REAL                     :: PMAX
      REAL                     :: RSHN
      REAL                     :: XPEAK
      REAL                     :: UCINT
      REAL                     :: THMAX
      REAL                     :: THMIN
      REAL                     :: SIGIW
      REAL                     :: PHMIN
      REAL                     :: EXPMX
      REAL                     :: DELTA
      REAL                     :: CRIT0
      REAL                     :: ACALS
      REAL                     :: BCALS
      REAL                     :: RATIO
      REAL                     :: PICKUP
      REAL                     :: BONDIJ
      REAL                     :: GEN049
      REAL                     :: GEN050
      REAL                     :: GEN095
      REAL,    DIMENSION(84)   :: E
      REAL,    DIMENSION(52)   :: G
      REAL,    DIMENSION(NP10) :: DA
      CHARACTER(len=4)         :: LABI
      CHARACTER(len=2)         :: ATTP
      CHARACTER(len=50)        :: STAR
C * MODE =  0 - SETUP/PATTERSON
C * MODE >  0 - EXOR
C * MODE = -1 - FLIPPER
      IWIN  = 0
      S     = 0
      NSYM  = IPR(48)
      NSYMH = IPR(255)
      CENT  = 2 - IPR(257)
      IBVT  = IPR(241)
      LATTS = IPR(256) * IPR(257)
      ISW   = 5
      KEEP  = 1
      STLM  = 0.6
      QSMX  = STLM **2
C * MANAGE MENU (ON/OFF)
      IGBL(63) = 0
      IF (IPR(220) > 1) THEN
        IF (IFL(2)(1:4) == 'AUTO') IGBL(25) = 0
      END IF
      IF (IGBL(25) * IGBL(32) == 1 .AND. IGBL(50) == 0) IWIN = 1
C * SETUP-MODE PARAMETERS
      IF (MODE == 0) THEN
        IPR(525) = 0
        IF (IPR(220) > 1) THEN
          DO I = 2, IPR(220)
            IF (IFL(I)(1:4) == 'PATT') THEN
              IPR(525) = 1
            ELSE IF (IFL(I)(1:4) == 'PATR') THEN
              IPR(525) = -1
            END IF
          END DO
        END IF
        IF (FN(1) /= 0) IPR(548) = 1
C * FLIPPER SETUP MODE
      ELSE IF (MODE == -1) THEN
        IPR(525) =  0
        CENT     =  0
        ISW      = -5
C * ISW EXOR MODE
      ELSE
C * CALL EXIT/STOP
        IF (IPR(37) > MP3) CALL GEN127 ('MEMORY (MP3) PROBLEM')
C * EXOR-MODE PARAMETERS
C * OMIT CRITERIUM
        IF (FN(1) >  0.0) PAR(284) = FN(1)
C * SINTH/LAMBDA MIN
        IF (FN(2) >= 0.0) PAR(281) = FN(2)
C * SINTH/LAMBDA MAX
        IF (FN(3) >  0.0) PAR(282) = FN(3)
C * STOP CRITERIUM
        IF (FN(4) >  0.0) PAR(283) = FN(4)
C * NUMBER OF CYCLES
        IF (FN(5) >  0.0) IPR(482) = NINT (FN(5))
C * NUMBER OF CYCLES
        IF (FN(6) /= 0.0) IPR(467) = NINT (FN(6))
        IGBL(31) = 6
C * PLATON/SYSTEM-S MODE
        IF (FN(7) /= 0.0) IPR(548) = 1
C * KEEP BIN
        KEEP = NINT (FN(8))
C * OPEN UNIT #2
        CALL PLA292
      END IF
C * GRAPHICS
      IF (IWIN == 1) THEN
C * SET MENU #
        IGBL(6)    = 27
        IGGT(2:21) = NAMEFIL(1:20)
C * GENERAL GRAPHICS OPEN
        CALL GGIP (-999.0, FLOAT (-KNMFIL), 0.0, 5)
        IF (MODE == 0) THEN
          IF (IPR(525) /= 0) THEN
            IF (IPR(548) == 1) BCD = 'S.Y.S.T.E.M - S'//CHAR (0)
            CALL GGIP (HORS, VERT, 0.0, 1)
            BCD = 'FO**2 - PATTERSON'//CHAR (0)
            CALL PLA439 (0.0,  BCD, 18, 1.0, 4, 6,  6.1, VERT - 1.5)
            CALL PLA439 (0.0,  BCD, 18, 1.0, 2, 6,  5.9, VERT - 1.6)
            CALL GGIP (0.0, 0.0, 0.0, 6)
            VRT = VERT - 1.8
          END IF
        ELSE IF (MODE == 1) THEN
          IF (IPR(548) == 1) BCD = 'S.Y.S.T.E.M - S'//CHAR (0)
          CALL GGIP (HORS, VERT, 0.0, 1)
          BCD = 'E.X.O.R'//CHAR (0)
          CALL PLA439 (0.0,  BCD, 7, 1.8, 4, 15, 1.7, VERT - 2.3)
          CALL PLA439 (0.0,  BCD, 7, 1.8, 2, 15, 1.5, VERT - 2.4)
        END IF
      END IF
C * BIN-SETUP/EXOR, SET 'LPS' OFF
      IGBL(70) = 0
C * CALCULATE CELL PARAMETERS
      CALL PLA100
C * SETUP SFAC TABLES
      ICNT3 = 3
C * CHECK FOR NON-RES DATA
      IF (IABS(IGBL(8)) /= 2 .AND. IPR(30) == 0) THEN
C * SETUP CONNECTED SET
        CALL PLA067
        IF (IPR(2) /= 0) RETURN
        CALL PLA073 (-1, 1)
        ICNT3   = 2
      END IF
      Z = 0.004 / PAR(17)**2
      L = 1
      DO I = 1, IAN
        N = IEN(I)
        L = L - 1
        W = 0.0
        DO N0 = 1, 51
          X = 0.0
          Y = 0.0
          DO K = 1, 6
            M = L + K
            SFC(M) = SFAC((N - 1) * 19 + 9)
            DO J = 1, 7, 2
              V = - SFAC((N - 1) * 19 + J + 1) * (W + X)
C * CHANGED FROM 87 TO 84 FOR UNDERFLOW PROTECTION
              IF (ABS(V) < 84.0) THEN
                SFC(M) = SFC(M) + SFAC((N - 1) * 19 + J) * EXP (V)
              END IF
            END DO
            X = X + Z
            Y = Y + SFC(M)
          END DO
          SFC(L + 2) = 1.25 * Y - 3.75 * (SFC(L + 1) + SFC(L + 6))
          L          = L + 2
          W          = W + 5.0 * Z
        END DO
      END DO
C * BIN-SETUP FOR EXOR
      IF (IGBL(16) == 0) THEN
C * REWIND BIN
        CALL GEN108 (LU19, 0)
C * GET DATA ON SYMMETRY
        MF = 1
C * SETUP/CONTENTS
        DO J = 1, 51
          G(J) = 0.0
          F(J) = 0.0
          M = 2 * J - 1
          DO 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
          END DO
        END DO
        WRITE (LU6, 99967, IOSTAT = IOST) PAR(17)
C * READ REFLECTION DATA, KEEP TRACK OF H, K, L, THETA MIN, MAX
        CALL GEN074 (VOID, 4, 6,  999.0)
        CALL GEN074 (VOID, 7, 9, -999.0)
        IPR(602) = 0
        IHMIN    =  999
        IKMIN    =  999
        ILMIN    =  999
        IHMAX    = -999
        IKMAX    = -999
        ILMAX    = -999
        THMAX    =  0.0
        THMIN    =  1.0
        IEND     = -1
        MR       = 0
        IH       = 0
        IK       = 0
        IL       = 0
C * READ H,K,L, F**2 , SIGMA(F**2), N
        DO
          CALL PLA132 (NI, NJ, NK, T, W, SIGIW, CALI, UCINT,
     1      ACALS, BCALS)
C * HANDLE HKLF-EXT (FROM SQUEEZE)
          IF (IGBL(9) == -1) T = UCINT
          K = 0
C * TEST FOR END OF DATA (H=0, K=0, L=0)
          IF (IEND == 0 .AND. ABS(NI) + ABS(NJ) + ABS(NK) /= 0) THEN
            IF (W <= 0.0) THEN
              IF (T <= 0.0) CYCLE
              W = SQRT (ABS(T))
            END IF
            IPR(602) = IPR(602) + 1
C * APPLY TRANSF.TION (IF ANY) AND ELIMINATE REFL WITH NON-INTEGRAL INDICES
            IF (GEN050 (TRMX, NI, NJ, NK, IH, IK, IL) >= 0.0) THEN
C * ELIMINATE BRAVAIS EXTINCTIONS
              IF (IBVT > 1) THEN
                IF (GEN049 (LAT(IBVT), IH, IK, IL) < 0) GO TO 10
              END IF
C * MULTIPLICITY
              U      = -9999999.0
              U1     = U
              P      = 0.0
              R      = 0.0
              SGY(1) = IH
              SGY(2) = IK
              SGY(3) = IL
              SGY(4) = 0.0
              DO N = 1, NSYMH
                CALL SGSM (ISW, LINE, SGY, N, 0, IERR)
                IF (MAX (ABS (SGY(7)), ABS (SGY(8))) >= 99.5) GO TO 10
                Q1 = SGY(7) + 200.0 * (SGY(8) + 200.0 * SGY(9))
                Q  = ABS (Q1)
                IF (CENT == 0) Q1 = Q
                IF (NINT (Q1) >= NINT (U1)) THEN
                  TEMP = SGY(10) / RGBL(6)
                  TEMP = COS (TEMP) + 21.42 * SIN (TEMP) * CENT
                  R = R + TEMP
                  IF (NINT (Q1) > NINT (U1)) THEN
                    R  = TEMP
                    U1 = Q1
                  END IF
                END IF
                IF (NINT (Q) >= NINT (U)) THEN
                  P = P + 1.0
                  IF (NINT (Q) > NINT (U)) THEN
                    P = 1.0
                    U = Q
                  END IF
                END IF
              END DO
              IF (ABS(R) >= 0.1) THEN
C * GET (SIN(TH)/Lambda)**2 FOR H,K,L
                QS = GEN095 (PAR(191), IH, IK, IL)
C * LIMIT TO SIN(THETA)/LAMBDA = 0.65 FOR FLIP
                IF (MODE == -1) THEN
                  IF (QS > QSMX) CYCLE
                END IF
C * UNPACK REFLECTION HKL
                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)
                VOID(7)  = MAX (VOID(7), X1)
                VOID(8)  = MAX (VOID(8), Y1)
                VOID(9)  = MAX (VOID(9), Z1)
                VOID(4)  = MIN (VOID(4), X1)
                VOID(5)  = MIN (VOID(5), Y1)
                VOID(6)  = MIN (VOID(6), Z1)
C * GET (SIN(TH)**2
                S     = QS * PAR(17)**2
                TEMP  = S * 50.0
                K     = INT (TEMP)
                IF (K > 50) GO TO 10
                THMAX = MAX (THMAX, S)
                THMIN = MIN (THMIN, S)
                TEMP  = MOD (TEMP, 1.0)
                EE    = SQRT ((TEMP * (G(K + 2) - G(K + 1)) + G(K + 1))
     1                  * P)
                IF (EE. NE. 0.0) EE = EXP (3.94784 * QS) / EE
C * STORE F(OBS) DATA
                V = T * 100.0
                W = W * 100.0
                IF (V < W) V = 0.5 * W
                V = SQRT (V)
                W = W / (2.0 * V)
C * PACKED H,K,L
                F(MF)     = U
C * F(OBS)
                F(MF + 1) = V
                IF (ABS (W) > 0.00001) THEN
                  F(MF + 2) = W**2
                ELSE
                  F(MF + 2) = 1.E-10
                END IF
C * STORE 8PI**2(SIN(TH)/LAMBDA)**2
                F(MF + 3) = RGBL(8) * QS
                F(MF + 4) = MIN (EE * V, 900.0)
                F(MF + 5) = 0.0
                MF        = MF + 6
                IF (MF > 79) THEN
                  WRITE (LU19) F
                  MF = 1
                END IF
                CYCLE
              END IF
            END IF
C * ERRORS IN REFLECTION DATA
   10       MR = MR + 1
            IF (MR == 1) WRITE (LU6, 99983, IOSTAT = IOST)
            IF (K > 50) THEN
              WRITE (LU6, 99980, IOSTAT = IOST) NI, NJ, NK, T, W, S
            ELSE
              WRITE (LU6, 99980, IOSTAT = IOST) NI, NJ, NK, T, W
            END IF
            CYCLE
          ELSE
            EXIT
          END IF
        END DO
        WRITE (LU6, 99994, IOSTAT = IOST) IPR(602), MR
        IF (IPR(602) == 0) GO TO 190
        THMIN = NINT (ASIN (SQRT (THMIN)) * 572.9578) / 10.0
        IF (THMAX > 1.0) THEN
          THMAX = 90.0
        ELSE
          THMAX = NINT (ASIN (SQRT (THMAX)) * 572.9578) / 10.0
        END IF
        WRITE (LU6, 99966) STLM
        WRITE (LU6, 99991, IOSTAT = IOST)
     1    IHMIN, IHMAX, IKMIN, IKMAX, ILMIN, ILMAX,
     1   THMIN, THMAX
        IPR(267) = IHMIN
        IPR(268) = IHMAX
        IPR(269) = IKMIN
        IPR(270) = IKMAX
        IPR(271) = ILMIN
        IPR(272) = ILMAX
        F(MF)    = 0.0
        WRITE (LU19) F
        CALL GEN108 (LU19, 1)
        HB = VOID(7) - VOID(4) + 1.0
        GD = VOID(8) - VOID(5) + 1.0
        GA = 1.0  - VOID(4) - HB * (VOID(5) + GD * VOID(6))
        NE = -5
        R  = 0.0
        S  = 0.0
        NM = 0
C * ZERO C
        CALL GEN074 (VOID, 1, NVDR, 0.0)
        NT  = 0
        MPM = NVDR - 8
        M   = MPM
C * SORT/MERGE
        DO
          READ (LU19) F
          DO I = 1, 79, 6
            IF (0.5 > ABS (F(I))) THEN
              CALL GEN108 (LU19, 0)
              IF (M == MPM) THEN
                DO K = 1, NT
                  IF (K + 10 > M) EXIT
                  IF (VOID(K) >= 1.0) THEN
                    M    = M - 8
                    VOID(K) = M + 1
                  END IF
                END DO
                CALL GEN074 (VOID, NT + 1, MPM, 0.0)
                M = NT
                EXIT
              END IF
              GO TO 20
            END IF
            CALL GEN046 (F(I), X, Y, Z)
            N = NINT (GA + X + HB * (Y + GD * Z))
            IF (N > 0 .AND. N <= M) THEN
              IF (M /= MPM) THEN
                N        = NINT (VOID(N))
                V        = F(I + 1)
                W        = 1.0 / F(I + 2)
                VOID(N + 1) = VOID(N + 1) + V * W
                VOID(N + 2) = VOID(N + 2) + W
                VOID(N + 3) = F(I + 3)
                VOID(N + 4) = VOID(N + 4) + F(I + 4) * W
                VOID(N + 6) = VOID(N + 6) + V * V * W
                VOID(N + 7) = F(I)
              ELSE
                NT = MAX (N, NT)
              END IF
              VOID(N) = VOID(N) + 1.0
            END IF
          END DO
        END DO
C * R-INDEX AND INCONSISTENCIES
   20   DO J = 1, NT
          M = NINT (VOID(J))
          IF (M /= 0) THEN
            NE        = NE + 6
            E(NE)     = VOID(M + 7)
            W         = 1.0 / VOID(M + 2)
            E(NE + 1) = VOID(M + 1) * W
            E(NE + 2) = W
            E(NE + 3) = VOID(M + 3)
            E(NE + 4) = MIN (900.0, VOID(M + 4) * W)
            E(NE + 5) = 0.0
            IF (NE >= 79) THEN
              WRITE (LU9) E
              NE = - 5
            END IF
            NM = NM + 1
            IF (void(M) > 1.0 .AND. VOID(M + 1) >= 1.E-8) THEN
              X = VOID(M + 2) * VOID(M + 6)
              Y = VOID(M + 1) **2
              S = S + W * X * (VOID(M) - 1.0)
              R = R + W * VOID(M) * (X - Y)
              IF (1.04 * Y <= X) THEN
                U = 1.0 / (SQRT (W) * VOID(M + 1))
                W = SQRT (ABS (X / Y - 1.0))
                N = NINT (VOID(M))
                CALL GEN046 (VOID(M + 7), X, Y, Z)
              END IF
            END IF
          END IF
        END DO
        E(NE + 6) = 0.0
        WRITE (LU9) E
        T = 0.0
        IF (S /= 0.0) T = SQRT (ABS (R / S))
        WRITE (LU6, 99985, IOSTAT = IOST) NM, T
        CALL GEN108 (LU9, 1)
C * NORMALISE E-VALUES
        L = 0
        CALL GEN074 (VOID, 1, 64, 0.0)
        CALL GEN074 (E, 1, 64, 0.0)
        DO M = 1, 2
   30     READ (LU9) F
          I = -5
          DO
            I = I + 6
            IF (0.5 <= 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 == 1) THEN
                VOID(K)      = VOID(K)      + P * W**2
                VOID(K + 1)  = VOID(K + 1)  + T * W**2
                VOID(K + 15) = VOID(K + 15) + P
                VOID(K + 16) = VOID(K + 16) + T
              ELSE
                W        = W * (P * VOID(K + 30) + T * VOID(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)
                VOID(K)     = VOID(K) + P * V / MAX (VOID(K + 15), 0.01)
                VOID(K + 1) = VOID(K + 1) + T * V / MAX (VOID(K + 16),
     1            0.01)
                CALL GEN046 (F(I), X, Y, Z)
                IF (L >= 4) L = 0
                L = L + 1
                VOID(L + 45) = F(I + 1)
                VOID(L + 49) = SQRT (F(I + 2))
              END IF
              IF (I >= 79) THEN
                IF (M == 2) WRITE (LU19) F
                GO TO 30
              END IF
            ELSE
              EXIT
            END IF
          END DO
          IF (M == 1) THEN
            Q = 1.0
            U = 0.0
            DO J = 1, 10
              CALL GEN074 (E, 1, 8, 0.0)
              DO I = 1, 15
                X    = E(8)**2
                P    = EXP (X * U) * VOID(I)
                V    = P / MAX (1.E-5, VOID(I + 15))
                W    = P * Q
                Z    = VOID(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) + VOID(I)
                E(7) = E(7) + VOID(I + 15)
                E(8) = E(8) + 0.622004
              END DO
              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) >= 0.1) THEN
                U = SIGN (0.09999, U)
                X = 0.0
                Y = 1.0 / (0.1 + E(3))
              END IF
              Q = Q + E(4) * X + E(5) * Y
            END DO
            IF (Q <= 0.0) Q = 1.0
            Q = SQRT (MAX (Q, 0.0)) * SQRT (FLOAT (LATTS)) * 0.96
            U = 0.05 - 0.5 * U
            DO I = 1, 15
              VOID(I + 30) = SQRT ((VOID(I + 15) + 0.01 * E(7))
     1                  / (VOID(I) + 0.01 * E(6)))
            END DO
          END IF
          CALL GEN108 (LU9, 0)
        END DO
        WRITE  (LU19) F
        WRITE (LU6, 99984, IOSTAT = IOST) Q, U
        PAR(465) = U
C * WRITE UNIQUE REFLECTION FILE FOR DIRECT METHODS
        IF (IPR(525) <= 0 .AND. IPR(409) == 0) THEN
          CALL GEN108 (LU19, 1)
          CALL GEN108 (LU17, 0)
          EKW = 0.0
          NEK = 0
          DO WHILE (.TRUE.)
            READ (LU19) F
            DO I = 1, 79, 6
              IF (0.5 > ABS (F(I))) GO TO 50
              CALL GEN046 (F(I), VOID(1), VOID(2), VOID(3))
              V = F(I + 1) * 100.0
              W = SQRT (F(I + 2)) * 100.0
              WRITE (LU17, 99982, IOSTAT = IOST) NINT (VOID(1)),
     1          NINT (VOID(2)), NINT (VOID(3)), NINT (V), NINT (W)
C * E-VALUES IN F(I+4)
              EKW = EKW + ABS (F(I + 4)**2 - 1.0)
              NEK = NEK + 1
            END DO
          END DO
   50     WRITE (LU17, 99981, IOSTAT = IOST)
          WRITE (LU6,  99979, IOSTAT = IOST) EKW / NEK
          IGBL(16) = 1
        END IF
      END IF
C * EXOR (MODE > 0)
      IF (MODE > 0) THEN
C * UNIT CONTENT KNOWN ?  (i.e. => 1)
        KNOWN = 0
        DO I = 2, IAN
          IF (LMT(I, 1) /= ' Q') THEN
            IF (CONT(I, 3) /= CONT(1, 3)) KNOWN = 1
          END IF
        END DO
C * EDIT (OMIT)
        UT = 2.0 * (RGBL(5) / PAR(17))**2
        SS = PAR(284)**2
        N  = 0
        M  = 0
C * LU19 - BINARY REFLECTION FILE
        CALL GEN108 (LU19, 0)
        CALL GEN108 (LU4, 0)
        IF (SS <= 1.E9) THEN
          DO
            READ  (LU19) F
            WRITE (LU4)  F
            DO I = 1, 79, 6
              IF (NINT (F(I)) == 0) THEN
                CALL GEN108 (LU19, 0)
                CALL GEN108 (LU4, 1)
                DO
                  READ (LU4) F
                  DO J = 1, 79, 6
                    IF (NINT (F(J)) == 0) THEN
                      WRITE (LU19) F
                      CALL GEN108 (LU19, 1)
                      CALL GEN108 (LU4, 0)
                      WRITE (LU6, 99999, IOSTAT = IOST) SQRT (SS), M, N
                      GO TO 60
                    END IF
                    X = 0.0
C * OMIT TEST
                    IF (SS * F(J + 2) > F(J + 1)**2) THEN
                      X = 1.0
                      M = M + 1
                    END IF
C * RESET OMIT FLAG
                    F(J + 3) = MOD (F(J + 3), UT) + UT * X
                  END DO
                  WRITE (LU19) F
                END DO
              END IF
              N = N + 1
            END DO
          END DO
        END IF
C * EXOR RECYCLE
C * ROUGH (OVER)ESTIMATE  OF # OF ATOMS/ASYM UNIT
   60   EXPMX  = PAR(98) / (12.0 * NSYM)
        CRIT0  = 0.33
        PICKUP = 1.0
C * ORDER SCATTERING TYPES ON SCATTERING POWER (EXCLUDE Q)
        IAN0 = IAN
        IF (LMT(IAN, 1) == ' Q') IAN0 = IAN - 1
        DO I = 1, IAN0
          DA(I) = 1000.0 - IATNR(IEN(I))
          IA(I) = I
        END DO
        CALL GEN036 (DA, IA, 1, IAN0)
C * DETERMINE MAX/MIN SCATTERING POWER RATIO (EXCLUDING H)
        IRMIN = IAN0
        DO I = 1, IAN0
          DA(I) = 1000.0 - DA(I)
          IF (NINT (DA(I)) <= 1) IRMIN = IRMIN - 1
        END DO
        RATIO = DA(1) / DA(IRMIN)
C * SET POPULATION CUTOFF CRITERIUM
        CRIT = CRIT0 / RATIO
C * MAX DIST IN DISTANCE SCAN
        DO I = 1, 3
          V2(I) = 2.0 * PAR(112 + I)
        END DO
C * EXOR-LOOP
        NPK  = 0
        LOOP = 0
        VRT  = VERT - 3.0
   70   LOOP = LOOP + 1
        NAT  = MIN (MP3, IPR(37) + NPK)
C * LOAD INPUT ATOMS IN LOOP # 1
        IF (LOOP == 1) THEN
C * PEAK(I, 1)    = X
C * PEAK(I, 2)    = Y
C * PEAK(I, 3)    = Z
C * PEAK(I, 4)    = POP. PAR.
C * PEAK(I, 5)    = PEAK HEIGHT
C * PEAK(I, 6)    = SOF PAR (SYMM)
C * PEAK(I, 7:46) = BONDS (DISTANCE)
          DO J = 1, NAT
            DO I = 1, 3
              SGY(I)     = CON(J, I + 2)
              PEAK(J, I) = SGY(I)
            END DO
            PEAK(J, 5) = 100.0
            SGY(10)    = 0.0
C * GET SOF (SYMMETRY PART = TO BE MULTIPLIED WITH POP.PAR)
            CALL SGSM (19, LINE, SGY, 0, LU6, IERR)
            PEAK(J, 6) = SGY(10)
C * SET STARTING 'POPULATION' BASED ON STORED ATOM TYPE
            ATTP = LMT(NINT (CON(J, 8)), 1)
            DO I = 1, IAN0
              IF (ATTP == LMT(IA(I), 1)) GO TO 80
            END DO
   80       PEAK(J, 4) = SGY(10) * DA(I) / DA(1)
          END DO
C * ANALYZE (refined population + difmap peaks) (LOOP > 1)
        ELSE
          DO I = 1, NAT
            IF (I <= IPR(37)) THEN
              DO J = 1, 3
                SGY(J)     = CON(I, J + 2)
                PEAK(I, J) = SGY(J)
              END DO
              PEAK(I, 4) = CON(I, 9)
              PEAK(I, 5) = 0.0
C * ADD PEAKS FROM DIFF-MAP
            ELSE
              DO J = 1, 3
                SGY(J)     = XXO(I - IPR(37), J)
                PEAK(I, J) = SGY(J)
              ENDDO
              PEAK(I, 4) = PEAK(I, 6) * CRIT
              PEAK(I, 5) = XXO(I - IPR(37), 4) / PAR(98)
              IF (PEAK(I, 5) < PICKUP) PEAK(I, 4) = 0.0
            END IF
            SGY(10) = 0.0
C * GET SOF (SYMMETRY PART = TO BE MULTIPLIED WITH POP.PAR)
            CALL SGSM (19, LINE, SGY, 0, 6, IERR)
            PEAK(I, 6) = SGY(10)
          END DO
        END IF
C * ANALYSE GEOMETRY
C * RESET NR OF BONDS TO ATOM TO ZERO
        CALL GEN097 (NCON, 1, NAT, 0)
C * FIND DISTANCES BETWEEN ATOMS - ROLLETT, COMP. METH. IN CRYST. 1965
        DO I = 1, NAT
          DO J = I, NAT
            DO 150 N = 1, NSYM
              IF (J /= I .OR. N /= 1) THEN
                DO K = 1, 3
                  SGY(K)     = PEAK(J, K)
                  SGY(K + 3) = 0.0
                END DO
                NS = N
                CALL SGSM (3, LINE, SGY, NS, LU6, IERR)
                K = 1
                GO TO 100
   90           SGY(6 + K) = SGY(6 + K) - 1.0
  100           IF ((PEAK(I, K) - SGY(6 + K)) <= V2(K)) GO TO 90
                GO TO 120
  110           IF (ABS (PEAK(I, K)  - SGY(6 + K)) <= V2(K)) GO TO 130
  120           SGY(6 + K) = SGY(6 + K) + 1.0
                IF ((PEAK(I, K)  - SGY(6 + K)) >= - V2(K)) GO TO 110
                K = K - 1
                IF (K == 0) GO TO 150
                GO TO 120
  130           K = K + 1
                IF (K > 3) THEN
                  DO L = 1, 3
                    V3(L) = PEAK(I, L) - SGY(6 + L)
                  END DO
                  CALL GEN002 (2, OR, V3, V4, DIST)
                  IF (DIST < 2.0) THEN
                    IF (I /= J .OR. DIST > 0.05) THEN
                      IF (NCON(I) < 40) THEN
                        NCON(I)              = NCON(I) + 1
                        PEAK(I, 6 + NCON(I)) = DIST
                        ICON(I, NCON(I))     = J
                      END IF
                      IF (NCON(J) < 40) THEN
                        NCON(J)              = NCON(J) + 1
                        PEAK(J, 6 + NCON(J)) = DIST
                        ICON(J, NCON(J))     = I
                      END IF
                    END IF
                  END IF
                  GO TO 140
                END IF
                GO TO 100
  140           K = K - 1
                GO TO 120
              END IF
  150       CONTINUE
          END DO
        END DO
        NRNEW = 0
C * CONVERT/SELECT PEAKS TO EXOR INPUT FOR POPULATION REFINEMENT
        NRSH = 0
        RSHN = 0.0
        DO 160 I = 1, NAT
C * TEST FOR OCCUPANCY
          IF (PEAK(I, 4) / PEAK(I, 6) >= CRIT) THEN
C * ELIMINATE SHORT DISTANCE PEAKS
            JMAX = NCON(I)
            DO J = 1, JMAX
C * GET BOND
              BONDIJ = PEAK(I, J + 6)
C * ELIMINATE (ABSORPTION) GHOSTS
              IF (BONDIJ < 1.3) THEN
                K = ICON(I, J)
                IF (BONDIJ < 0.9 .OR.
     1            PEAK(I, 4) > PEAK(K, 4) * 3) THEN
C * SET POPULATION ZERO FOR GHOST
                  PEAK(K, 4) = 0.0
                END IF
              END IF
              IF (PEAK(I, 5) > 0.0 .AND. PEAK(I, 5) < 2.0) THEN
                IF (BONDIJ > 1.6) GO TO 160
              END IF
              IF (LOOP == 1) THEN
                PHMIN = 2.0
              ELSE
                PHMIN = 1.0
              END IF
              IF (BONDIJ < 1.8 .AND. PEAK(I, 5) > 0.0
     1           .AND. PEAK(I, 5) < PHMIN) GO TO 160
            END DO
C * LIMIT LIST TO MAXIMUM
            IF (RSHN < EXPMX) THEN
              NRSH  = NRSH + 1
              RSHN  = RSHN + PEAK(I, 6)
              DO J = 1, 3
                CON(NRSH, J + 2) = PEAK(I, J)
              END DO
              CON(NRSH, 8) = IA(1)
              CON(NRSH, 9) = PEAK(I, 4)
              IF (PEAK(I, 5) > 0.0) NRNEW = NRNEW + 1
              DATC(NRSH) = 1000.0 - PEAK(I, 4) / PEAK(I, 6)
              IATC(NRSH) = I
            END IF
          END IF
  160   CONTINUE
C * CHECK FOR NO ATOMS - PROBLEM
        IF (NRSH == 0) WRITE (LU6, 99969, IOSTAT = IOST)
        IPR(37) = NRSH
C * STOP WHEN NO NEW ATOMS HAVE BEEN PICKED UP
        IF (NRNEW /= 0 .OR. LOOP <= 2) THEN
          IF (LOOP < IABS (IPR(467))) THEN
C * SOF REFINEMENT
            CALL PLA152 (LOOP)
C * CHECK NO-ERROR - CALC DIFFERENCE MAP (NO GEOM)
            IF (IPR(2) == 0) CALL PLA153 (-2, NPK)
            GO TO 70
          END IF
        END IF
C * ANALYZE EXOR RESULT
        REWIND (UNIT = LU2, IOSTAT = IOST)
        IF (IOST /= 0) CALL GEN148 (LU2, 1)
        HRT = 0.57 * HORS
        VRT = VERT - 3.4
C * TITL, CELL, SPGR, SFAC, UNIT
        WRITE (LU2, 99990, IOSTAT = IOST)
     1    JID(1:6), PAR(17), (PAR(100  + I), I = 1, 12)
        WRITE (LU2, 99989, IOSTAT = IOST) IPR(242)
        DO I = 2, IPR(255)
          NUMS = I
          CALL SGSM (17, LINE, SGY, NUMS, 0, IERR)
          WRITE (LU2, 99988, IOSTAT = IOST) LINE(1:60)
        END DO
C * SFAC
        WRITE (LU2, 99987, IOSTAT = IOST) (LMT(I, 1), I = 1, IAN0)
C * UNIT
        WRITE (LU2, 99986, IOSTAT = IOST)
     1    (NINT(CONT(I, 3)), I = 1, IAN0)
        WRITE (LU2, 99995, IOSTAT = IOST) PAR(74)
C * ANALYSE POPULATION PEAKLIST
        FACT  = 0.5
        XPEAK = 999.0
        N     = 0
        DELTA = 1.0
        CALL GEN097 (MCONT, 1, NP10, 0)
        CALL GEN036 (DATC, IATC, 1, NRSH)
        DO I = 1, NRSH
          DATC(I) = (1000.0 - DATC(I)) * DA(1)
          IF (XPEAK - DATC(I) > DELTA) THEN
            IF (N < IRMIN) THEN
              N = N + 1
              IF (N < IRMIN) THEN
                DELT = DA(N) - DA(N + 1)
              ELSE
                DELT = 999.0
              END IF
            END IF
          END IF
          XPEAK    = DATC(I)
          DELTA    = DELT * FACT * XPEAK / DA(N)
          MCONT(N) = MCONT(N) + 1
        END DO
C * WRITE OUT ATOM-LIST
        N    = 0
        NEL0 = 1
        L    = 0
        NATR = 0
        HGHT = DATC(1)
C * LOOP OVER ATOMS
        DO I = 1, NRSH
          K    = IATC(I)
          NATR = NATR + 1
          N    = N + 1
C * HANDLE MULTIPLICITY
          L    = L + NINT(NSYM * PEAK(K, 6))
C * AVOID ASSIGNING TO H SCATTERERS
          IF (NEL0 < IAN0 .AND. NINT (DA(NEL0 + 1)) /= 1) THEN
            IF (KNOWN == 0) THEN
              IF (N <= MCONT(NEL0)) GO TO 170
            ELSE IF (KNOWN == 1) THEN
              IF (DA(NEL0) .gt. 15 .AND.
     1            (DA(NEL0) - DA(NEL0 + 1)) > 5) THEN
                IF ((HGHT - DATC(I)) / HGHT < 0.20) GO TO 170
              ELSE
                IF (L <= NINT (CONT(IA(NEL0), 3))) GO TO 170
              END IF
            END IF
            L    = NINT (NSYM * PEAK(K, 6))
            NEL0 = NEL0 + 1
            N    = 1
          END IF
  170     HGHT = DATC(I)
          LABI(1:4) = LMT(IA(NEL0), 1)(1:2)//'  '
          IF (LABI(1:1) /= ' ') THEN
            L0 = 1
            NO = 50 + N
          ELSE
            LABI(1:4) = LMT(IA(NEL0), 1)(2:2)//'   '
            L0 = 0
            NO = 500 + N
          END IF
          IF (NO < 100) THEN
            WRITE (LABI(2 + L0 : 3 + L0), 99971, IOSTAT = IOST) NO
          ELSE
            WRITE (LABI(2:4), 99972, IOSTAT = IOST) NO
          END IF
          WRITE (LU2, 99993, IOSTAT = IOST)
     1      LABI, IA(NEL0), (PEAK(K, J), J = 1, 3), 10 + PEAK(K, 6),
     2      RP(2)
          IF (IWIN == 1) THEN
            IF (I == 1) THEN
              WRITE (IDM, 99975, IOSTAT = IOST)
              VRT = VERT - 0.5
              CALL PLA439 (0.0, IDM, 38, 0.3, 5 + IGBL(68), 2, HRT, VRT)
            END IF
            IF (I <= 42) THEN
              WRITE (IDM, 99976, IOSTAT = IOST)
     1          I, LABI, (PEAK(K, J), J = 1, 3), DATC(I)
              VRT = VRT - 0.45
              CALL PLA439 (0.0, IDM, 38, 0.3, 1, 2, HRT, VRT)
            END IF
          END IF
        END DO
        WRITE (LU2, 99996, IOSTAT = IOST) (PAR(I), I = 231, 239)
        WRITE (IDM, 99992, IOSTAT = IOST) PAR(281), PAR(282), NATR
        WRITE (LU6, 99970, IOSTAT = IOST) IDM
        IF (IWIN == 1)
     1      CALL PLA439 (0.0, IDM, 56, 0.3, 5 + IGBL(68), 2, 0.2, 0.2)
C * PATTERSON
      ELSE
        IF (IABS (IPR(525)) == 1) THEN
          NPK  = 30
          MDIP = 0
          CALL PLA153 (0, NPK)
          IF (XXO(1, 4) > 0.0) THEN
            PMAX = 999.0 / XXO(1, 4)
          ELSE
            PMAX = 1.0
          END IF
          DO I = 1, NPK
            DO J = 1, 3
              XXO(I, J) = MOD (XXO(I, J), 1.0)
            END DO
            XXO(I, 4) = XXO(I, 4) * PMAX
          END DO
          NPKM = MIN (35, NPK)
          NPRV = 50
C * PATTERSON PEAK LISTING
          WRITE (LU6, 99978, IOSTAT = IOST)
          VRT = VERT - 1.8
          DO I = 1, NPKM
            NSTAR = NINT (XXO(I, 4) * 50 / 999.0)
            STAR  = ' '
            IF (NSTAR > 0) THEN
              DO J = 1, NSTAR
                STAR(J:J) = '*'
              END DO
            END IF
            NDIF = NPRV - NSTAR
            NPRV = NSTAR
            IF (NDIF > 0) THEN
              IF (I > 2) MDIP = MAX (MDIP, NDIF)
              DO J = 1, NDIF
                STAR(51-J:51-J) = '<'
              END DO
            END IF
            WRITE (LINE, 99998, IOSTAT = IOST)
     1        I, (XXO(I, J), J = 1, 4), STAR
            WRITE (LU6, 99968, IOSTAT = IOST) LINE
            IF (IWIN == 1) THEN
              VRT = VRT - 0.5
              CALL PLA439 (0.0, LINE, 80, 0.3, 1, 2, 2.2, VRT)
            END IF
          END DO
          WRITE (LU6, 99974, IOSTAT = IOST) MDIP, IGBL(89)
          IF (MDIP < IGBL(89)) THEN
            LINE = 'EQUAL ATOM TYPE PATTERSON'
          ELSE
            LINE = 'HEAVY ATOM TYPE PATTERSON'
          END IF
          WRITE (LU6, 99970, IOSTAT = IOST) LINE
          CALL PLA439 (0.0, LINE, 80, 0.4, 5 + IGBL(68), 2, 12.0, 2.0)
        END IF
      END IF
      IF (IWIN == 1) THEN
        IF (MODE > 0 .OR. IPR(525) /= 0) THEN
  180     IF (IPR(467) > 0) THEN
            WRITE (SBCD, 99997, IOSTAT = IOST) CHAR (0)
          ELSE
            WRITE (SBCD, 99973, IOSTAT = IOST) CHAR (0)
          END IF
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          IF (IGGT(1:4) == 'PLOT') GO TO 180
          OPEN (LU61, FILE = 'NEXT', STATUS = 'UNKNOWN')
          WRITE (LU61, 99968, IOSTAT = IOST) IGGT
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
        END IF
      END IF
  190 IF (MODE == 0 .AND. IPR(2) == 0) IPR(2) = -13
      IGBL(16) = KEEP
      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', 9F7.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 (':: Hmin,   Hmax =', 2I5, /,
     1        ':: Kmin,   Kmax =', 2I5, /,
     2        ':: Lmin,   Lmax =', 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 (':: Nr Unique Reflections =', I6, '(Rav =', F8.4, ')')
99984 FORMAT (':: Overall Scale', F12.5, /, ':: Estimated U =', F6.3)
99983 FORMAT (/, ':: Excluded Weak Reflections from F(obs)',
     1        ' based S.o.f Refinement')
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 (/, 'PATTERSON', /)
99976 FORMAT (I2, 1X, A, 3F7.3, F6.1)
99975 FORMAT ('Nr Label     x      y      z    PP')
99974 FORMAT (/, 'PATT DIP', I3, ', [TEST CRIT = >', 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)
99966 FORMAT (':: Sintheta/lambda cutoff = ', F8.4)
      END SUBROUTINE PLA151
 
      MODULE comdrie
      SAVE
      INTEGER :: ITOP
      INTEGER :: NGRID
      REAL    :: STHM
      END MODULE comdrie
 
      SUBROUTINE PLA152 (LOOP)
C * SETUP EXOR.BIN/EXOR (2)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE comdrie
      USE exor
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER      :: MP2 = 1700
      INTEGER, PARAMETER      :: MP5 = MP2 * 5
      INTEGER, PARAMETER      :: MP6 = 2000
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: K
      INTEGER                 :: L
      INTEGER                 :: M
      INTEGER                 :: N
      INTEGER                 :: NC
      INTEGER                 :: NI
      INTEGER                 :: NN
      INTEGER                 :: NR
      INTEGER                 :: NV
      INTEGER                 :: NSM
      INTEGER                 :: NAT
      INTEGER                 :: NISO
      INTEGER                 :: LOOP
      INTEGER                 :: LATTS
      INTEGER                 :: NSYMH
      INTEGER, DIMENSION(MP2) :: INX
      REAL                    :: P
      REAL                    :: Q
      REAL                    :: R
      REAL                    :: S
      REAL                    :: U
      REAL                    :: V
      REAL                    :: W
      REAL                    :: Y
      REAL                    :: E5
      REAL                    :: FC
      REAL                    :: FO
      REAL                    :: RNC
      REAL                    :: FCK
      REAL                    :: FOK
      REAL                    :: CR1
      REAL                    :: CR2
      REAL                    :: CR3
      REAL                    :: CR4
      REAL                    :: TPI
      REAL                    :: XVL
      REAL                    :: VMAX
      REAL                    :: CENT
      REAL                    :: VMEAN
      REAL                    :: STHMN
      REAL                    :: DELTA
      REAL                    :: SGY10
      REAL                    :: DELTA2
      REAL,    DIMENSION(16)  :: ENB
      REAL,    DIMENSION(MP6) :: A
      REAL,    DIMENSION(MP6) :: E
      REAL,    DIMENSION(MP5) :: D1
      REAL,    DIMENSION(MP5) :: D2
      REAL,    DIMENSION(MP5) :: CT
      N = 0
C * EXOR - LS
      NSYMH = IPR(255)
      CENT  = 2 - IPR(257)
      LATTS = IPR(256) * IPR(257)
      NAT   = IPR(37)
C * GET # CYCLES
      NV    = IPR(482)
      TPI   = RGBL(5)
      STHMN = RGBL(8) * PAR(281)**2
      STHM  = RGBL(8) * PAR(282)**2
      VMAX  = 0.0
      VMEAN = 0.0
C * FVAR
      IF (LOOP > 1) THEN
        CT(1) = MIN (0.08, MAX (0.03, RP(2)))
      ELSE
        CT(1) = 0.05
      END IF
C * ATOMS
      L = 1
      DO I = 1, NAT
        INX(I) = NINT (CON(I, 8))
        DO J = 1, 3
          CT(L + J) = CON(I, J + 2)
        END DO
        CT(L + 4) = CON(I, 9)
        CT(L + 5) = CT(1)
        L         = L + 5
      END DO
      WRITE (IDM, 99999, IOSTAT = IOST)
      WRITE (LU6, 99997, IOSTAT = IOST) IDM
      IF (IWIN == 1) THEN
        VRT = VRT - 0.5
        CALL PLA439 (0.0, IDM, 80, 0.3, 5 + IGBL(68), 2, 0.2, VRT)
      END IF
C * LS LOOP
      NC    = 0
      NISO  = 0
      DO
        NC    = NC + 1
        IF (NC > 1) NISO = 1
        R  = 0.0
        NN = NISO + NAT
        K  = 1
C * PARAMETER VALUES
        DO I = 1, NAT
          IF (NV == 0) THEN
            CON(I, 9) = CT(K + 4)
            RP(2)       = CT(1)
          END IF
          K = K + 5
          CT(K) = CT(1)
        END DO
        IF (NV < 0) THEN
C * FOURIER/PEAK SEARCH
          GO TO 20
        ELSE IF (NV > 0) THEN
          I = ((NN * (NN + 3)) / 2) + 10
          CALL GEN074 (VOID, 1, I, 0.0)
        END IF
C * SFLS
        NR = 0
        CALL GEN074 (A,  1, MP6, 0.0)
        CALL GEN074 (E,  1, MP6, 0.0)
        CALL GEN074 (D1, 1, MP5, 0.0)
        CALL GEN074 (D2, 1, MP5, 0.0)
        CR1 = 0.0
        CR2 = 0.0
        CR3 = 0.0
        CR4 = 0.0
        XVL = 100.0 * (PAR(17)**2) / RGBL(8)
C * LOOP OVER REFLECTIONS
        DO
          READ (LU19) F
          DO I = 1, 79, 6
            IF (NINT (F(I)) == 0) GO TO 10
            IF (F(I + 3) <= STHM) THEN
              NR = NR + 1
C * SFAC
              V  = XVL * F(I + 3)
              U  = MOD (V, 2.0)
              M  = INT (V - U) - 100
              U  = 0.5 * U
              DO K = 1, IAN
                M = M + 101
                ENB(K) = SFC(M) + U * (SFC(M + 2)
     1                 - SFC(M) + SFC(M + 1) - U * SFC(M + 1))
              END DO
C * H K L
              CALL GEN046 (F(I), SGY(1), SGY(2), SGY(3))
              U = 0.0
              V = 0.0
              J = 1
              DO K = 1, NAT
                J    = J + 5
                E(K) = EXP ( - CT(J) * F(I + 3)) * ENB(INX(K)) * LATTS
              END DO
C * SYMMETRY LOOP
              DO NSM = 1, NSYMH
                SGY(4) = 0.0
                CALL SGSM (5, LINE, SGY, NSM, LU6, IERR)
                SGY10 = SGY(10) / 360.0
C * ATOMS
                K  = 1
                N  = 0
                DO NI = 1, NAT
C * FORM FACTOR * TEMP FACTOR * POPULATION ETC.
                  W  = CT(K + 4)
                  R  = E(NI) * W
                  S  = TPI * (CT(K + 1) * SGY(7) + CT(K + 2) * SGY(8)
     1               + CT(K + 3) * SGY(9) + SGY10)
                  P  = R * COS (S)
                  R  = R * SIN (S)
                  U  = U + P
                  V  = V + R * CENT
                  K  = K + 5
                  IF (NV > 0) THEN
                    IF (F(I + 3) > STHMN) THEN
C * DERIVATIVES
                      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
                    END IF
                  END IF
                END DO
              END DO
C * F CALC AND F OBS
C * A-Calc & B-Calc
              F(I + 4) = U
              F(I + 5) = V
C * FC-Squared
              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)
     1               + (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 > 0) THEN
                IF (F(I + 3) > STHMN) THEN
C * ADD DERIVATIVES
                  Y = DELTA2
                  Q = W
                  CALL GEN074 (E, 1, NN, 0.0)
                  U = U * Q
                  V = V * Q
                  DO J = 2, N, 2
                    K = J / 2 + NISO
C * CONTRIBUTION FOR POP.PAR
                    E(K) = E(K) + 2 * (U * D1(J - 1) + V * D2(J - 1))
                    IF (NISO == 1) THEN
C * CONTRIBUTION FOR U(ISO)
                      E(1) = E(1) + 2 * (U * D1(J) + V * D2(J))
                    END IF
                    D1(J - 1) = 0.0
                    D2(J - 1) = 0.0
                    D1(J)     = 0.0
                    D2(J)     = 0.0
                  END DO
                  W = W * Y
                  M = NN + 1
                  DO N = 1, NN
                    Y = E(N)
                    L = M
                    M = L + NN - N + 1
                    IF (Y /= 0.0) THEN
                      A(N) = W * Y + A(N)
                      VOID(N) = VOID(N) + Y ** 2
                      DO K = N, NN
                        VOID(L) = Y * E(K) + VOID(L)
                        L    = L + 1
                      END DO
                    END IF
                  END DO
                END IF
              END IF
            END IF
          END DO
          WRITE (LU4) F
        END DO
C * RESIDUALS
   10   R = CR3 / FLOAT (NR - NN)
        WRITE (LU4) F
        CALL GEN108 (LU4, 1)
        CALL GEN108 (LU19, 0)
        U   = CR1 / CR2
        W   = SQRT (CR3 / CR4)
        RNC = LOOP + FLOAT (NC) / 10.0
        WRITE (IDM, 99998, IOSTAT = IOST)
     1    RNC, U, W, NR, NN, VMEAN, VMAX, CT(1)
        WRITE (LU6, 99995, IOSTAT = IOST) IDM
        IF (IWIN == 1) THEN
          VRT = VRT - 0.5
          CALL PLA439 (0.0, IDM, 80, 0.3, 1, 2, 0.2, VRT)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
        IF (NV == 0) THEN
          OPEN (LU65, FILE = NAMEFIL(1:KNMFIL)//'_log',
     1          STATUS = 'UNKNOWN')
          WRITE (LU65, 99996, IOSTAT = IOST) U, W, NR, NN
          CLOSE (UNIT = LU65)
        END IF
        NV = NV - 1
        IF (NV >= 0) THEN
C * INVERT MATRIX
          CALL GEN012 (VOID, A, NN, 0.0, 0.0, R)
C * L.S. RESULTS
          IF (NISO == 1) CT(1) = MAX (CT(1) + VOID(1), 0.02)
          VMAX  = 0.0
          VMEAN = 0.0
          K     = 0
          DO N = 1 + NISO, NN
            K     = K + 5
            CT(K) = CT(K) + VOID(N)
            V     = VOID(N)  / A(N)
            VMEAN = VMEAN + ABS (V)
            VMAX  = MAX (VMAX, ABS (V))
          END DO
          IF (NN > 0) VMEAN = VMEAN / NN
          IF (VMEAN < PAR(283)) NV = 0
        END IF
      END DO
   20 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)
99995 FORMAT (A)
      END SUBROUTINE PLA152
 
      SUBROUTINE PLA153 (MODE, NPK)
C * SETUP EXOR.BIN/EXOR (3)
      USE files
      USE parameters
      USE comdrie
      USE exor
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: M3
      INTEGER :: NPK
      INTEGER :: MODE
      INTEGER :: ITOP2
C * GET SUITABLE FFT-GRID
      DO 10 I = 1, 3
        DO J = 4, 8
          IPR(I + 394) = 2**J
          IF (PAR(I + 100) * 3.0 < IPR(I + 394)) GO TO 10
        END DO
   10 CONTINUE
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      NGRID = M1 * M2 * M3
C * FFT - RESERVE SPACE FOR GRID AND PEAKSEARCH
      ITOP  = NGRID * 2
      ITOP2 = ITOP + 3 * (M1 + 2) * (M2 + 2)
C * CHECK FOR SCRATCH OVERRUN (FFT + R3D)
      IF (ITOP2 > NVDR) THEN
        IPR(2) = 49
      ELSE
        CALL PLA154 (MODE, VOID(1), VOID(ITOP + 1), NPK)
      END IF
      RETURN
      END SUBROUTINE PLA153
 
      SUBROUTINE PLA154 (MODE, FFT, R3D, NPK)
C * SETUP EXOR.BIN/EXOR (4)
      USE files
      USE parameters
      USE plato
      USE comdrie
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: N
      INTEGER             :: M1
      INTEGER             :: M2
      INTEGER             :: M3
      INTEGER             :: IH
      INTEGER             :: IK
      INTEGER             :: IL
      INTEGER             :: LU
      INTEGER             :: LOC
      INTEGER             :: IHT
      INTEGER             :: IKT
      INTEGER             :: ILT
      INTEGER             :: ISN
      INTEGER             :: ISW
      INTEGER             :: NPK
      INTEGER             :: MODE
      INTEGER             :: NSYMH
      REAL                :: C2
      REAL                :: C3
      REAL                :: C4
      REAL                :: AC
      REAL                :: BC
      REAL                :: FC
      REAL                :: ACAL
      REAL                :: BCAL
      REAL                :: FCAL
      REAL                :: FRAC
      REAL                :: PCAL
      REAL                :: PHAS
      REAL                :: FS000
      REAL                :: RHOMIN
      REAL, DIMENSION(84) :: F
      REAL, DIMENSION(*)  :: FFT
      REAL, DIMENSION(*)  :: R3D
      CHARACTER(len=80)   :: LINE
C * MODE = -2 - DIFFERENCE MAP
C * MODE = -1 - DIFFERENCE MAP + GEOM
C * MODE =  0 - PATTERSON
C * MODE =  1 - Fobs Map (sign Fcalc)
      ACAL  = 0.0
      BCAL  = 0.0
      FCAL  = 0.0
      PCAL  = 0.0
      NSYMH = IPR(255)
C * SGSM SWITCH FOR PATTERSON (ISW = -5) OR FOURIER (ISW = 5)
      IF (MODE == 0) THEN
        LU  = LU19
        ISW = -5
      ELSE
        LU  = LU4
        ISW = 5
      END IF
      CALL GEN108 (LU, 0)
C * FFT GRID
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      FS000 = 0.0
      CALL GEN074 (FFT, 1, ITOP, 0.0)
      FFT(1) = FS000
C * LOAD FFT array
C * F(I)     = PACKED HKL (0 = END)
C * F(I + 1) = F(OBS)
C * F(I + 2) = SIGMA**2(F)
C * F(I + 3) = (STH)
C * F(I + 4) = ACALC
C * F(I + 5) = BCALC
      DO
        READ (LU) F
        DO I = 1, 79, 6
          IF (NINT (F(I)) == 0) GO TO 10
          CALL GEN046 (F(I), C2, C3, C4)
C * PATTERSON MODE
          IF (MODE == 0) THEN
            ACAL = F(I + 1) ** 2
            BCAL = 0.0
          ELSE
            IF (F(I + 3) > STHM) CYCLE
            FC = SQRT (F(I + 4)**2 + F(I + 5)**2) + 1.E-8
            IF (MODE < 0) THEN
C * CALCULATE DIFFERENCE MAP COEFFICIENTS
              FRAC = F(I + 1) / FC - 1.0
            ELSE
              FRAC = F(I + 1) / FC
            END IF
            AC   = F(I + 4) * FRAC
            BC   = F(I + 5) * FRAC
            FCAL = FRAC * FC
            IF (BC /= 0.0 .OR. AC /= 0.0) THEN
              PCAL = ATAN2 (BC, AC) * RGBL(6)
            ELSE
              PCAL = 0.0
            END IF
          END IF
          DO N = 1, NSYMH
            SGY(1) = C2
            SGY(2) = C3
            SGY(3) = C4
            SGY(4) = PCAL
            CALL SGSM (ISW, LINE, SGY, N, LU6, IERR)
            IHT = NINT (SGY(7))
            IKT = NINT (SGY(8))
            ILT = NINT (SGY(9))
            IF (MODE /= 0) THEN
              PHAS = SGY(10) / RGBL(6)
              ACAL = FCAL * COS (PHAS)
              BCAL = FCAL * SIN (PHAS)
            END IF
            ISN = 1
            DO J = 1, 2
              IF (J == 2) ISN = -1
              IH = ISN * IHT
              IK = ISN * IKT
              IL = ISN * ILT
              IF (IH < 0) IH = IH + M1
              IF (IK < 0) IK = IK + M2
              IF (IL < 0) IL = IL + M3
              LOC          = 2 * ((IL * M2 + IK) * M1 + IH + 1)
              FFT(LOC - 1) = ACAL
              FFT(LOC)     = BCAL * ISN
            END DO
          END DO
        END DO
      END DO
C * TRANSFORM FROM RECIPROCAL TO DIRECT SPACE
   10 CALL GEN028 (FFT, IPR(395), 3, -1)
C * PEAK-SEARCH
      RHOMIN = PAR(268) * PAR(98)
      CALL PLA140 (FFT, R3D, 0, RHOMIN, MODE, NPK, 1, IPR(48))
      RETURN
      END SUBROUTINE PLA154
 
C * STRIP_BEG
 
      MODULE shx86
      SAVE
      INTEGER              :: JR
      INTEGER              :: LR
      INTEGER              :: LG
      INTEGER              :: LH
      INTEGER              :: LI
      INTEGER              :: LP
      INTEGER              :: LF
      INTEGER              :: LA
      INTEGER              :: LB
      INTEGER              :: LY
      INTEGER              :: LL
      INTEGER              :: LQ
      INTEGER              :: LE
      INTEGER              :: LV
      INTEGER              :: LX
      INTEGER              :: LD
      INTEGER              :: LZ
      INTEGER              :: LJ
      REAL, DIMENSION(126) :: F
      REAL, DIMENSION(126) :: G
      REAL, DIMENSION(13)  :: RS =
     1 (/5.0, 3.5, 2.5, 2.0, 1.7, 1.5, 1.4, 1.3, 1.2, 1.1, 1.0, 0.9,
     2   0.8/)
      REAL,             DIMENSION(11) :: HKLF
      CHARACTER(len=80)               :: IR
      CHARACTER(len=1), DIMENSION(20) :: IH =
     1 (/ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '.',
     2  '-', '+', 'X', 'Y', 'Z', ',', '=', '/', ' '/)
      END MODULE shx86
 
      SUBROUTINE PLA155 (TNP)
C * SHELXS-86 * CRYSTAL STRUCTURE SOLUTION (STRIPPED & MODIFIED S-VERSION)
      USE files
      USE parameters
      USE shx86
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: NA
      INTEGER          :: NB
      INTEGER          :: NJ
      INTEGER          :: LU
      INTEGER          :: KK
      INTEGER          :: JD
      INTEGER          :: IER
      REAL             :: P
      REAL             :: Q
      REAL             :: R
      REAL             :: T
      REAL             :: U
      REAL             :: V
      REAL             :: W
      REAL             :: X
      REAL             :: Y
      REAL             :: Z
      REAL             :: FF
      REAL             :: HS
      REAL             :: TNP
      CHARACTER(len=4) :: KEY
      REAL, ALLOCATABLE, DIMENSION(:) :: A
      ALLOCATE (A(NVDS))
C * SET RETURN CODE FROM SHELXS86
      IGBL(1) = 4
C * SET UNITS FOR INPUT (LR), HKL DATA (LH), PRINTER (LI), RESULT (LP)
      LR = 1
      LU = LR
      OPEN (LR, FILE = 'shelxs.ins', STATUS = 'OLD', IOSTAT = IOST)
      IF (IOST == 0) THEN
        LH = 3
        LU = LH
        OPEN (LH, FILE = 'shelxs.hkl', STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST == 0) THEN
          LI = 10
          LU = LI
          OPEN (LI, FILE = 'shelxs.lis', STATUS = 'UNKNOWN',
     1          IOSTAT = IOST)
          IF (IOST == 0) THEN
            LP = 60
            LU = LP
            OPEN (LP, FILE = 'shelxs.res', STATUS = 'UNKNOWN',
     1            IOSTAT = IOST)
            IF (IOST == 0) THEN
C * SET BINARY (UNFORMATTED) SCRATCH UNITS (LA, LB, LF AND LG)
              LA = 2
              LU = LA
              OPEN (LA, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1          IOSTAT = IOST)
              IF (IOST == 0) THEN
                LB = 4
                LU = LB
                OPEN (LB, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1            IOSTAT = IOST)
                IF (IOST == 0) THEN
                  LF = 8
                  LU = LF
                  OPEN (LF, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1              IOSTAT = IOST)
                  IF (IOST == 0) THEN
                    LG = 9
                    LU = LG
                    OPEN (LG, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1                IOSTAT = IOST)
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
      IF (IOST /= 0) THEN
        WRITE (6, 99999, IOSTAT = IOST) LU
        GO TO 80
      END IF
      WRITE (LI, 99998, IOSTAT = IOST)
C * SET DEFAULT PARAMETER VALUES
      CALL GEN074 (F, 121, 123,  1.0)
      CALL GEN074 (F, 124, 126,  0.0)
      CALL GEN074 (A,   1,  76,  0.0)
      CALL GEN074 (A,  33,  35, -2.0)
      CALL GEN074 (A,  36,  38,  2.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
      A(39) = TNP
      A(43) = 4.0
      A(52) = 2.0
      A(53) = 1.0
      A(56) = 28.0
C * DEL1 & DEL2
      A(58) = 0.5
      A(59) = 1.5
      A(64) = 1.0
C * SYMM X,Y,Z DEFAULT
      A(65) = 1.0
      A(69) = 1.0
      A(73) = 1.0
      IER   = 0
      LX    = 25
      LL    = 1
      LZ    = 0
      LQ    = 0
      LY    = 65
      LJ    = 0
      NB    = 4
      JR    = 4
      HS    = 0.0
      X     = 0.0
C * INSTRUCTION LOOP
      DO
        READ (LR, 99996, IOSTAT = IOST) IR
        KEY = IR(1:4)
        CALL GEN039 (1, IR, 4, 80, NB, JR)
        WRITE (LI, 99996, IOSTAT = IOST) IR(1:JR)
C * TITL
        IF (KEY /= 'TITL') THEN
C * INIT SYMM RECORD (12 LOCATIONS)
          IF (KEY == 'SYMM') CALL GEN074 (A, LY + 12, LY + 23, 0.0)
C * DECODE INSTRUCTION
          CALL GEN074 (G, 1, 126, 0.0)
          W  = 1.0
          NA = 0
          JD = 0
          NJ = LY + 7
          L  = LY + 21
          N  = 4
   10     V  = 0.0
          NB = 0
          Y  = 1.0
          U  = 10.0
          Z  = 1.0
   20     N  = N + 1
          K  = 10
          IF (N <= JR) THEN
            X = 0.0
            DO KK = 1, 19
              IF (IR(N:N) == IH(KK)) THEN
                IF (KK < 11) THEN
                  Z  = Y * Z
                  V  = U * ABS (V) + Z * X
                  NB = 1
                  IF (V /= 0.0) THEN
                    V = SIGN (V, W)
                    W = V
                  END IF
                  GO TO 20
                END IF
                K = KK - 9
                GO TO 30
              END IF
              X = X + 1.0
            END DO
            K = 1
          END IF
   30     IF (KEY /= 'SYMM') THEN
            IF (K  == 2) THEN
              U = 1.0
              Y = 0.1
              GO TO 20
            ENDIF
            IF (NB == 0) THEN
              IF (K == 1) K = 6
              IF (IABS (K - 6) > 1)  GO TO 40
              IF (IR(N:N) == IH(20)) GO TO 40
              JD = JD + 1
              DO K = 1, 4
                IF (N > JR) GO TO 60
                IF (IR(N:N) == IH(17)) THEN
                  W = 1.0
                  GO TO 10
                ENDIF
                IF (IR(N:N) == IH(18)) THEN
                  WRITE (LP, 99996, IOSTAT = IOST) IR(1: JR)
                  GO TO 50
                END IF
                IF (IR(N:N) == IH(19)) GO TO 60
                IF (IR(N:N) == IH(20)) THEN
                  W = 1.0
                  GO TO 10
                ENDIF
                N = N + 1
              END DO
              W = 1.0
              GO TO 10
            END IF
            NA    = NA + 1
            G(NA) = V
   40       IF (K < 9) THEN
              IF (K /= 3) THEN
                W =  1.0
              ELSE
                W = -1.0
              ENDIF
              GO TO 10
            ELSE IF (K == 9) THEN
              WRITE (LP, 99996, IOSTAT = IOST) IR(1: JR)
              GO TO 50
            ELSE
              GO TO 60
            END IF
C * SYMM INSTRUCTION
          ELSE
            SELECT CASE (K)
              CASE (1)
                GO TO 20
              CASE (2)
                U = 1.0
                Y = 0.1
                GO TO 20
              CASE (3)
                A(L) = AINT (24.5 * V) / 24.0
                W = -1.0
                GO TO 10
              CASE (4)
                A(L) = AINT (24.5 * V) / 24.0
                W = 1.0
                GO TO 10
              CASE (5, 6, 7)
                K    = K + NJ
                A(K) = W
                W    = 1.0
                GO TO 10
              CASE (8, 10)
                A(L) = A(L) + AINT (24.5 * V) / 24.0
                L  = L + 1
                NJ = NJ + 3
                IF (NJ + 8 < L) THEN
                  W = 1.0
                  GO TO 10
                END IF
                LY = LY + 12
                GO TO 70
              CASE (9)
                GO TO 50
            END SELECT
            U = 1.0
            Y = 0.1
            GO TO 20
          END IF
C * CONTINUATION LINES AND ERRORS
   50     READ (LR, 99996, IOSTAT = IOST) IR
          NB = 4
          JR = 4
          CALL GEN039 (1, IR, 4, 80, NB, JR)
          WRITE (LI, 99996, IOSTAT = IOST) IR(1: JR)
          N = 4
          W = 1.0
          GO TO 10
C * CELL
   60     IF (KEY == 'CELL') THEN
            DO J = 1, 7
              A(J) = G(J)
            END DO
            U = 2.0 * A(2) * A(3) * A(4)
            DO J = 2, 4
              X        = A(J + 3) / RGBL(6)
              G(J)     = COS (X)
              G(J + 3) = SIN (X)
              A(J + 9) = U * G(J) / A(J)
              A(J + 6) = A(J) * A(J)
            END DO
            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))
C * LATT
          ELSE IF (KEY == 'LATT') THEN
            IF (G(1) < 0.0) A(23) = 1.0
            LL = NINT (ABS (G(1)))
C * SFAC
          ELSE IF (KEY == 'SFAC')  THEN
            IF (LL <= 65) THEN
              N = 3 * LL
              L = INT (4.1 - 2.0 * A(23))
              CALL GEN074 (F, 1, 12, 0.5)
              CALL GEN074 (F, 1,  3, 0.0)
              IF (N == 12) THEN
                F(4)  = 0.0
                F(8)  = 0.0
                F(12) = 0.0
              ELSE IF (N == 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 > 12) THEN
                F(LL - 1) = 0.0
                N         = 4
              END IF
              LL = LY + 8
              DO K = 2, L, 2
                DO 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
                END DO
              END DO
              LQ   = LL - 1
              F(1) = 1.1
            END IF
            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)
C * UNIT
          ELSE IF (KEY == '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 I = 1, NA
              IF (A(J) > 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
            END DO
            T = Q * 1.66052 / A(60)
            Z = A(60) / Z
            X = FLOAT (LL - LY - 8)
            WRITE (LI, 99995, IOSTAT = IOST) A(60), Z, P, Q, T
            A(24) = SQRT (0.25 * X / U)
C * DEFAULT PARAMETERS FOR DIRECT METHODS
            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 K = 65, LY, 12
              IF (A(K)     < - 0.5) L = 1
              IF (A(K + 4) < - 0.5) M = 1
              IF (A(K + 8) < - 0.5) N = 1
              IF (ABS(A(K + 9)) + ABS(A(K + 10))
     1                          + ABS(A(K + 11)) > 0.1) T = 20.0
            END DO
            A(42) = MAX (-1.1 + 0.3 * A(23),
     1              MIN (-0.2, -T * Y * (2.0 - A(23))))
            IF (T <= 25.0) THEN
              IF (A(23) < 0.5) L = 3
              IF (L + M + N > 2) A(44) = ABS(A(44))
            END IF
C * OMIT
          ELSE IF (KEY == 'OMIT') THEN
            IF (NA == 3) THEN
              IF (F(1) > 119.5) THEN
                WRITE (6, 99997, IOSTAT = IOST)
                GO TO 80
              END IF
              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 == 2) A(53) = (SIN (8.726646E-3 * G(2)))**2
            END IF
C * HKLF INSTRUCTIONS
          ELSE IF (KEY == 'HKLF')  THEN
            A(41) = -4.0 -3.0 * A(23)
            IF (ABS (A(41)) < 0.99) THEN
              WRITE (6, 99997, IOSTAT = IOST)
              GO TO 80
            END IF
            A(41) = SIGN (AINT (ABS (A(41))) + 0.1, A(41))
            A(60) = ABS(A(60))
            CLOSE (UNIT = LR, STATUS = 'KEEP')
            IF (G(2) == 0.0) THEN
              G(2)  = 1.0
              G(3)  = 1.0
              G(7)  = 1.0
              G(11) = 1.0
            END IF
            DO  I = 1, 11
              HKLF(I) = G(I)
            END DO
            A(54) = 7.0
            IF (HS > 290.0) A(54) = 4.0
            U = 195.0
            IF (A(20) < -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 J = 2, 4
              F(J)     = U * COS (1.74533E-2 * A(J + 3)) / A(J)
              F(J + 3) = F(J) * F(J)
            END DO
            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 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)
            END DO
            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 (A, IER)
            IF (IER /= 0) THEN
              WRITE (6, 99997, IOSTAT = IOST)
            ELSE
              CALL PLA157 (A, IER)
              IF (IER /= 0) THEN
                WRITE (6, 99997, IOSTAT = IOST)
              ELSE
                CALL PLA158 (A)
                CALL PLA159 (A)
              END IF
            END IF
            GO TO 80
          ELSE
            CYCLE
          ENDIF
        END IF
C * COPY INSTRUCTION TO .RES
   70   WRITE (LP, 99996, IOSTAT = IOST) IR(1:JR)
      END DO
   80 CLOSE (UNIT = LP)
      CLOSE (UNIT = LI)
      CLOSE (UNIT = LA)
      CLOSE (UNIT = LB)
      CLOSE (UNIT = LF)
      CLOSE (UNIT = LG)
      DEALLOCATE (A)
      RETURN
99999 FORMAT (/, ':: Cannot OPEN File Number', I5, /)
99998 FORMAT (
     1 'Crystal Structure Solution - Stripped Version of SHELXS-86', /)
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, /)
      END SUBROUTINE PLA155
 
      SUBROUTINE PLA156 (A, IER)
C * READ REFLECTION DATA, GENERATE AND SORT E-VALUES
      USE files
      USE parameters
      USE shx86
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: M
      INTEGER                :: N
      INTEGER                :: ND
      INTEGER                :: NF
      INTEGER                :: NI
      INTEGER                :: ML
      INTEGER                :: NA
      INTEGER                :: NJ
      INTEGER                :: NQ
      INTEGER                :: NR
      INTEGER                :: NU
      INTEGER                :: NX
      INTEGER                :: JF
      INTEGER                :: JJ
      INTEGER                :: JU
      INTEGER                :: IER
      INTEGER                :: NEXIT
      INTEGER                :: NERROR
      INTEGER, DIMENSION(20) :: IP
      REAL                   :: O
      REAL                   :: P
      REAL                   :: Q
      REAL                   :: R
      REAL                   :: S
      REAL                   :: T
      REAL                   :: U
      REAL                   :: V
      REAL                   :: W
      REAL                   :: X
      REAL                   :: Y
      REAL                   :: Z
      REAL                   :: AP
      REAL                   :: XX
      REAL                   :: YY
      REAL                   :: ZZ
      REAL                   :: RA
      REAL                   :: RB
      REAL                   :: RC
      REAL                   :: RD
      REAL                   :: QC
      REAL                   :: QH
      REAL                   :: QK
      REAL                   :: QL
      REAL                   :: QM
      REAL                   :: SB
      REAL,    DIMENSION(*)  :: A
      REAL,    DIMENSION(87) :: E
      REAL,    DIMENSION(14) :: SO
      REAL,    DIMENSION(14) :: SU
      REAL,    DIMENSION(4)  :: AA
      NEXIT = 0
      LZ    = LX + 7
      CALL GEN074 (SO, 1, 14, 0.0)
      CALL GEN074 (SU, 1, 14, 0.0)
      ML = LY + 12
      DO I = ML, LL, 4
        DO J = 1, 3
          A(I + J) = A(I + J) - 99.5
        END DO
      END DO
      CALL GEN074 (A, 61, 64, 0.0)
      CALL GEN074 (E, 52, 87, 0.0)
      SB = 1.0
      N  = 1
      NR = 0
      ND = 0
      NU = 0
      NX = 0
      M  = IABS(INT(G(1))) + 1
      G(1) = 0.5
C * READ H, K, L, F, SIGMA
      NERROR = -1
   10 NERROR = NERROR + 1
      IF (NERROR <= 100) THEN
        DO
          READ (LH, 99999, IOSTAT = IOST) J, K, L, T, S
          IF (IOST /= 0) THEN
            IF (IOST == -1) THEN
              EXIT
            ELSE
              GO TO 10
            END IF
          END IF
          IF (IABS (J) + IABS (K) + IABS (L) == 0) EXIT
          X = FLOAT (J)
          Y = FLOAT (K)
          Z = FLOAT (L)
          T = T * G(2)
          S = S * G(2)
          IF (S < 1.E-4) S = 0.1
          IF (T < 0.5 * S) T = MIN (0.25 * S, 0.5 * SB)
          SB       = 0.8 * SB + 0.2 * S
          F(N + 1) = T
          F(N + 2) = S
C * REORIENTATE, REJECT LATTICE ABSENCES
          IF (T < 1.E-6) GO TO 40
          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) > 0.01) GO TO 20
          J = ML
          DO
            J = J + 4
            IF (J <= LL) THEN
              IF (ABS (AMOD (U * A(J + 1) + V * A(J + 2) +
     1            W * A(J + 3) + 999.5, 1.0) - 0.5) < 0.01) THEN
                CYCLE
              ELSE
                GO TO 20
              END IF
            END IF
            IF (NEXIT == 0) EXIT
          END DO
C * MAXIMISE INDICES
          F(N) = 0.0
          DO 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)) > 99.5) GO TO 40
            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))
          END DO
          CALL GEN046 (F(N), X, Y, Z)
          IF (E(52) > X) E(52) = X
          IF (E(53) < X) E(53) = X
          IF (E(54) > Y) E(54) = Y
          IF (E(55) < Y) E(55) = Y
          IF (E(56) > Z) E(56) = Z
          IF (E(57) < Z) E(57) = Z
C * REJECT SYSTEMATIC ABSENCES
          K = 65
          DO
            K = K + 12
            IF (K <= 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) < 0.5) Q = ABS (Q)
              IF (Q + 0.5 < F(N)) CYCLE
              IF (ABS (AMOD (0.5 + ABS (X * A(K + 9) + Y * A(K + 10) +
     1          Z * A(K + 11)), 1.0) - 0.5) - 0.01 < 0.0) THEN
                CYCLE
              ELSE
                GO TO 20
              END IF
            END IF
            IF (NEXIT == 0) EXIT
          END DO
          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 > A(64)) A(64) = Q
          IF (Q >= 1.0) GO TO 30
          N = N + 3
          IF (N >= 126) THEN
            WRITE (LA) F
            N = 1
          END IF
          ND = ND + 1
          CYCLE
   20     IF (F(N + 1) < A(52) * F(N + 2)) GO TO 40
   30     NU = NU + 1
   40     NR = NR + 1
          ND = ND + 1
        END DO
      ELSE
        IER = 1
        RETURN
      END IF
C * END OF DATA - UNIT LH MAY BE CLOSED AT THIS POINT
      F(N) = 0.0
      WRITE (LA) F
      CALL GEN108 (LA, 0)
      CLOSE (UNIT = LH, STATUS = 'KEEP')
      IF (A(64) > 1.0) A(64) = 1.0
      X = 2.0 * RGBL(6) * ATAN2 (SQRT (A(64)), SQRT (1.0 - A(64)))
      WRITE (LI, 99998, IOSTAT = IOST) ND, NR, A(61), A(62), A(63), X
      IF (A(20) < - 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
C * SORT/MERGE REFLECTION DATA
   60 QM = FLOAT (NVDS) + 0.3
      JF = 0
      N  = INT (MIN (QC + E(53) + QH * (E(55) + QK * E(57)), QM))
      NF = 0
      M  = LX + 8
   70 CALL GEN074 (A, M, N, 0.0)
      IF (LZ < N) LZ = N
   80 READ (LA) F
      I = - 2
      DO
        I = I + 3
        IF (I > 126) GO TO 80
        IF (F(I) >= 0.5) THEN
          CALL GEN046 (F(I), X, Y, Z)
          Q = QC + QH * (Y + QK * Z) + X
          IF (Q >= QL) THEN
            IF (Q <= QM) THEN
              J = INT(Q)
              IF (NF == 0) THEN
                A(J) = 1.0
              ELSE IF (NF == 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
              END IF
            END IF
          END IF
          CYCLE
        END IF
        IF (NEXIT == 0) EXIT
      END DO
      CALL GEN108 (LA, 0)
      IF (NF == 0) THEN
        NF = 1
        Q  = 0.3
        DO I = M, N
          IF (A(I) >= 0.5) THEN
            A(I) = Q
            Q    = Q + 5.0
            IF (I + INT (Q) > NVDS) GO TO 90
            K = I
          END IF
        END DO
        JF = 1
        Q  = Q + 5.0
        K  = N
   90   I  = K
        QM = FLOAT (I) + 1.0
        DO J = M, I
          A(J) = A(J) + QM
        END DO
        M  = I + 1
        QM = QM - 0.7
        N  = I + INT (Q - 5.0)
        GO TO 70
      END IF
      I  = M - 5
      IF (NF < 2) THEN
        DO
          I = I + 5
          IF (I > N) THEN
            NF = 2
            GO TO 80
          END IF
          A(I + 2) = A(I + 2) / A(I + 1)
          A(I + 1) = 0.0
          IF (A(I + 3) > 1.5) RB = RB + A(I + 4)
          A(I + 4) = 0.0
        END DO
      END IF
      READ (LG) F
      CALL GEN108 (LG, 0)
      JU = INT (F(1))
  100 I  = I + 5
      IF (I <= N) THEN
        NR = NR + 1
C * LIST REFLECTIONS
        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) >= 1.5) THEN
          RA = RA + A(I + 1)
          P  = A(I + 1) / (A(I + 3) * SQRT (A(I + 3) - 1.0))
          IF (P >= 5.0 * W) THEN
            NX = NX + 1
          END IF
          W = MAX (P, W)
        END IF
C * FIND EPSILON AND RESTRICTED PHASES
        P = 0.0
        T = 0.0
        DO 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) < 0.5) Q = ABS (Q)
          IF (Q + 0.5 >= G(L)) P = P + 1.0
          IF (0.5 - Q >= G(L))
     1      T = 10.0 * AINT (12.0 * AMOD (400.01 - S, 1.0) + 12.0)
        END DO
C * SIN(THETA), PARITY, R(INT) AND R(SIGMA)
        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
        DO
          IF (RS(K) <= S) THEN
            K = K - 1
            IF (K > 0) CYCLE
          END IF
          IF (NEXIT == 0) EXIT
        END DO
        K = K + 1
        SU(K) = SU(K) + 1.0
        IF (Q <= A(53)) THEN
          J = 1
          DO
            J = J + 1
            IF (JU >= J) THEN
              IF (ABS (G(L) - F(J)) >= 0.5) CYCLE
            ELSE
              IF (V > W * A(52)) GO TO 110
            END IF
            IF (NEXIT == 0) EXIT
          END DO
        END IF
        G(L + 1) = - G(L + 1)
        SO(K) = SO(K) + 1.0
        NU = NU + 1
  110   RC = RC + W
        RD = RD + V
        L  = L  + 4
        IF (L >= 124) THEN
          WRITE (LB) G
          L = 1
        END IF
        GO TO 100
      END IF
      QC = QC - QM + QL
      IF (JF == 0) GO TO 60
      G(L) = 0.0
      WRITE (LB) G
      CALL GEN108 (LB, 0)
      NU = NR - NU
      RA = RA / RB
      RC = RC / RD
      WRITE (LI, 99991, IOSTAT = IOST) NR, NU, RA, RC
      I = 0
      X = 0.0
C * NUMBER OF UNIQUE DATA IN SHELLS
      NQ = 1
      DO I = 1, 13
        IF (SU(I) > 0.5) NQ = I
      END DO
      DO I = 2, 4
        X        = AINT (A(I) / RS(NQ))
        J        = I + I + 18
        G(J - 1) = - X
        G(J)     = X + 0.5
      END DO
      DO I = 1, NQ
        P = 0.5 * A(1) / RS(I)
        G(I + 30) = P * P
        G(I + 50) =
     1    2.0 * RGBL(6) * ATAN2 (P, SQRT (MAX (0.0, 1.0 - G(I + 30))))
        SO(I) = SU(I) - SO(I)
        G(I) = 0.0
      END DO
      G(14) = 0.0
      Z     = 0.0
      IF (LY /= 77) THEN
        IF (LY < 90) THEN
          GO TO 140
        ELSE
          GO TO 130
        END IF
      END IF
      IF (A(81) * A(85) < 0.0) GO TO 130
  120 G(21) = 0.0
      GO TO 140
  130 G(23) = 0.0
      IF (LY == 101) THEN
        IF (ABS (A(78)) + ABS (A(90)) < 0.1) GO TO 120
      END IF
  140 Y = G(23)
  150 X = G(21)
  160 J = ML
      DO
        J = J + 4
        IF (J <= LL) THEN
          IF (ABS (AMOD (X * A(J + 1) + Y * A(J + 2) + Z * A(J + 3)
     1       + 999.5, 1.0) - 0.5) - 0.01 < 0.0) THEN
            CYCLE
          ELSE
            GO TO 180
          END IF
        END IF
        IF (NEXIT == 0) EXIT
      END DO
      W = X + 200.0 * (Y + 200.0 * Z) + 0.5
      K = 65
  170 K = K + 12
      IF (K <= 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) > W) GO TO 180
        IF (A(23) < 0.5) Q = ABS (Q)
        IF (Q + 1.0 < W) GO TO 170
        IF (ABS (AMOD (0.5 + ABS (X * A(K + 9) + Y * A(K + 10)
     1    + Z * A(K + 11)), 1.0) - 0.5) -  0.01 < 0.0) THEN
          GO TO 170
        ELSE
          GO TO 180
        END IF
      END IF
      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 >= 0.0001) THEN
        K = 30 + NQ
        DO
          IF (G(K) >= Q) THEN
            K = K - 1
            IF (K > 30) CYCLE
          END IF
          IF (NEXIT == 0) EXIT
        END DO
        K = K - 29
        G(K) = G(K) + 1.0
      END IF
  180 X = X + 1.0
      IF (X < G(22)) GO TO 160
      Y = Y + 1.0
      IF (Y < G(24)) GO TO 150
      Z = Z + 1.0
      IF (Z < G(26)) GO TO 140
      WRITE (LI, 99990, IOSTAT = IOST) (RS(I),     I = 1, NQ)
      WRITE (LI, 99989, IOSTAT = IOST) (SO(I),     I = 1, NQ)
      WRITE (LI, 99988, IOSTAT = IOST) (SU(I),     I = 1, NQ)
      WRITE (LI, 99987, IOSTAT = IOST) (G(I),      I = 1, NQ)
      WRITE (LI, 99986, IOSTAT = IOST) (G(I + 50), I = 1, NQ)
C * THETA DEPENDENCE
      CALL GEN074 (G, 1, 5, 0.0)
      Q = 0.015
      DO I = 58, 72
        IF (E(I) >= 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
        END IF
        Q = Q + 0.03
      END DO
      P = 20.0
      IF (G(1) >= 0.5) THEN
        Q = G(1) * G(3) - G(2) * G(2)
        IF (Q >= 1.E-6) P = (G(2) * G(4) - G(1) * G(5)) / Q
      END IF
      P = P / (A(1) * A(1))
C * NORMALISE E-VALUES
      T  = 10.0 / (A(64) + 0.001)
      NR = 1
      ND = LX + 39
      LH = ND
      I  = INT (A(29) * 0.1)
      IF (I > 0) LH = LH + 2 * INT (1.5 + A(I + 60))
      LD = LH - 2
      W = 1.0 / (A(27) * A(27))
      W = W * W
      U = RGBL(8) * A(28) / (A(1) * A(1))
      DO M = 1, 4
        IF (M == 1) CALL GEN074 (G, 1, 38, 0.0)
        IF (M == 2) THEN
          J = LX + 27
          DO K = J, LH, 2
            A(K)     = 0.0
            A(K + 1) = 0.0
          END DO
          R = 0.0
          Q = 0.0
          DO K = 12, 19
            R = R + G(K)
            Q = Q + G(K + 19)
          END DO
          R = R / MAX (Q, 0.01)
          DO K = 31, 38
            G(K) = G(K) * R
          END DO
          J = LX + 8
          DO K = 1, 19
            A(J) = G(K) / MAX (G(K + 19), 0.01)
            J = J + 1
          END DO
          DO K = 12, 19
            A(J) = AMOD (A(29), 10.0) * (A(J) - 1.0) + 1.0
          END DO
          IF (A(29) < 5.0) CYCLE
        END IF
        IF (M == 3) THEN
          IF (A(29) >= 5.0) THEN
            DO K = ND, LH, 2
              A(K) = AMOD (A(29), 10.0) * (A(K) / MAX (A(K + 1), 0.01)
     1             - 1.0) + 1.0
            END DO
          END IF
        END IF
        IF (M == 4) THEN
          J = LX + 27
          L = J + 3
          DO K = J, L
            A(K + 4) = A(K) / MAX (A(K + 4), 0.01)
          END DO
        END IF
        DO
          READ (LB) F
          DO I = 1, 124, 4
            IF (F(I) < 0.5) GO TO 200
            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 == 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
              CYCLE
            END IF
            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) >= 5.0) THEN
              J = INT (A(29) * 0.1)
              J = INT (0.5 + 2.0 * E(J)) + LX + 39
              IF (M == 2) THEN
                A(J)     = A(J)     + 1.0
                A(J + 1) = A(J + 1) + R
                CYCLE
              END IF
              R = R * A(J)
            END IF
            IF (IABS (N - 5) <= 2) THEN
              IF (E(1) <= 0.5) THEN
                IF (MIN (E(2), E(3)) < 0.5) GO TO 190
                J = LX + 27
              ELSE
                IF (E(2) <= 0.5) THEN
                  IF (E(3) < 0.5) GO TO 190
                  J = LX + 28
                ELSE
                  J = LX + 29
                  IF (E(3) > 0.5) J = J + 1
                END IF
              END IF
              IF (M == 3) THEN
                A(J)     = A(J) + 1.0
                A(J + 4) = A(J + 4) + R
                GO TO 190
              END IF
              A(J + 8) = A(J + 8) + ABS (1.0 - R * A(J + 4))
            END IF
  190       IF (M == 4) THEN
              IF (R > 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 >= 126) THEN
                WRITE (LA) G
                NR = 1
              END IF
              IF (R >= ABS (A(26))) THEN
                IF (F(I + 1) >= 0.0) THEN
                  DO K = 4, L
                    LD    = LD + 4
                    A(LD) = E(K)
                    IF (LD > NVDS - 2000) THEN
                      IER = 1
                      RETURN
                    END IF
                    A(LD + 1) = MIN (R, 9.0)
                    A(LD + 2) = 0.0
                    A(LD + 3) = 1.0
                    IF (A(26) > 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)
                    END IF
                  END DO
                END IF
              END IF
            END IF
          END DO
        END DO
  200   CALL GEN108 (LB, 0)
      END DO
      G(NR) = 0.0
      WRITE (LA) G
      CALL GEN108 (LA, 0)
C * E-LISTS AND E-CALC
      NA = LX + 4
      AP = 0.0
      M  = LY + 12
      DO 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
      END DO
      JJ = IABS (INT (A(54)))
      M  = 0
      K  = 0
      I  = 0
      DO J = 65, LY, 12
        IF (ABS (A(J + 1)) > 0.5) I = 1
        IF (ABS (A(J + 2)) > 0.5) K = 1
        IF (ABS (A(J + 5)) > 0.5) M = 1
      END DO
      J = LX + 27
      IF (I + K + M == 3) THEN
        DO M = 1, 2
          K = J + 2
          X = A(J) + A(J + 1) + A(K)
          CALL GEN074 (A, J, K, X)
          J = J + 8
        END DO
        GO TO 210
      END IF
      IF (I /= 0) THEN
        I = LX + 28
      ELSE
        IF (K /= 0) THEN
          I = LX + 29
        ELSE
          IF (M == 0) GO TO 210
          J = LX + 28
          I = LX + 29
        END IF
      END IF
      M = J + 8
      DO K = J, M, 8
        X    = A(K) + A(I)
        A(K) = X
        A(I) = X
        I    = I + 8
      END DO
  210 J = LX + 27
      DO I = 1, 4
        G(I) = A(J + 8) / MAX (A(J), 0.01)
        J    = J + 1
      END DO
      IF (LZ < LD + 3) LZ = LD + 3
C * FILE UNIQUE LARGE E
      T = ABS (A(26))
      S = T
      DO I = 5, 14
        IP(I) = 0
        G(I)  = T
        T     = T + 0.1
      END DO
      I = LX + 4
      K = LH - 2
      IF (LD <= LH) THEN
        WRITE (LI, 99985, IOSTAT = IOST) S
        IER = 1
        RETURN
      END IF
      DO
        M = 1
  220   K = K + 4
        IF (K <= LD) THEN
          Q = A(K + 1)
          DO L = 5, 14
            IF (Q > G(L)) IP(L) = IP(L) + 1
          END DO
          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 < 126) GO TO 220
          WRITE (LF) F
          CYCLE
        END IF
        IF (NEXIT == 0) EXIT
      END DO
      LD   = I
      F(M) = 0.0
      WRITE (LF) F
      CALL GEN108 (LF, 0)
      WRITE (LI, 99983, IOSTAT = IOST)
     1  (G(I), I = 5, 14), (IP(I), I = 5, 14)
      WRITE (LI, 99984, IOSTAT = IOST) (G(I), I = 1, 4)
C * SUMMARISE PARAMETERS
      WRITE (LI, 99992, IOSTAT = IOST)
      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, 99993, IOSTAT = IOST) A(26), A(27), A(28), U, J, P, Q
      IF (ABS (A(39)) >= 0.5) THEN
        J = INT (A(40))
        K = INT (A(41))
        Q = AMOD (ABS (A(41)), 1.0)
        WRITE (LI, 99994, IOSTAT = IOST) A(39), J, K, Q, A(42)
        L = INT (A(43))
        M = INT (A(44))
        WRITE (LI, 99995, IOSTAT = IOST) L, M
      END IF
      I = INT (A(54))
      IF (I == 2) I = 6
      J = INT (A(57))
      WRITE (LI, 99996, IOSTAT = IOST) I, J, A(58), A(59)
      L = LX + 4
      DO WHILE (L <= LD - 4)
        L        = L  + 4
        A(L)     = ABS (A(L))
        A(L + 3) = 0.0
      END DO
C * E-CALC
      LJ = LL - 1
      IF (IABS (JJ - 1) >= 2) THEN
        IF (LX /= LV) THEN
          M = 0
          CALL GEN074 (F, 1, 3, 0.0)
          I = LX + 4
          DO WHILE (I <= LD - 4)
            I = I + 4
            R = AMOD (A(I + 1), 10.0)
            CALL GEN046 (A(I), X, Y, Z)
            X = X * RGBL(5)
            Y = Y * RGBL(5)
            Z = Z * RGBL(5)
            O = 0.0
            P = 0.0
            J = LV
            DO WHILE (J <= LX - 8)
              J = J + 8
              K = INT (0.001 * A(J + 1)) * 5 + LJ
              Q = A(K) * A(J + 5)
              DO 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)
              END DO
            END DO
            O = O * A(23)
            Q = SQRT (O * O + P * P)
            IF (Q >= 1.E-6) THEN
              A(I + 2) = RGBL(6) * ATAN2 (O, P)
              IF (A(I + 2) < 0.0) A(I + 2) = A(I + 2) + 360.0
              IF (R >= 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
              END IF
            END IF
          END DO
          J = (LX - LV) / 8
          R = SQRT (ABS (1.0 - F(2) * F(2) / (F(1) * F(3))))
          WRITE (LI, 99997, IOSTAT = IOST) R, J, M, A(32)
        END IF
        IF (ABS (A(39)) > 0.5 .OR. AP > 0.5 .OR. LE >= LQ + 4)
     1    THEN
          I = LX + 4
          DO WHILE (I <= LD - 4)
            I = I  + 4
            A(I + 3) = AMOD (A(I + 1), 10.0)
          END DO
C * SORT REFLECTIONS ACCORDING TO E
          N = (LD - NA) / 4
          M = 1
          DO
            M = 3 * M + 1
            IF (M >= N) EXIT
          END DO
          DO
            M  = M / 3
            N  = 4 * M
            NJ = NA + N
            NI = NJ + 4
            DO I = NI, LD, 4
              CALL GEN113 (A(I), AA, 4)
              J = I
              DO
                K = J - N
                IF (A(K + 3) <= T) THEN
                  CALL GEN113 (A(K), A(J), 4)
                  J = K
                  IF (J > NJ) CYCLE
                END IF
                IF (NEXIT == 0) EXIT
              END DO
              CALL GEN113 (AA, A(J), 4)
            END DO
            IF (M <= 2) EXIT
          END DO
        END IF
      END IF
      LZ = NA
      IF (IOST /= 0) RETURN
      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)
99997 FORMAT (///, 'RE =', F7.4, ' for', I4, ' Atoms and',
     1        I5, ' E Greater Than', F7.3)
99996 FORMAT ('FMAP  CODE', I3, /, 'PLAN  NPEAKS', I5,
     1        3X, 'DEL1', F6.3, 3X, 'DEL2', F6.3)
99995 FORMAT ('SUBS  TYPE', I4, 3X, 'NS', I5)
99994 FORMAT ('TREF  NP', F10.0, 3X, 'NE', I6, 3X, 'NTAN', I4,
     1        '   TW', F7.3, 3X, 'WN', F7.3)
99993 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)
99992 FORMAT (/, 6X, 'Summary of Parameters', /)
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)
99985 FORMAT (/, '** No Observed E Above', F7.3)
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)
      END SUBROUTINE PLA156
 
      SUBROUTINE PLA157 (A, IER)
C * DERIVE PHASE RELATIONS
      USE files
      USE shx86
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: M
      INTEGER                :: N
      INTEGER                :: IZ
      INTEGER                :: JN
      INTEGER                :: KZ
      INTEGER                :: MA
      INTEGER                :: MB
      INTEGER                :: ME
      INTEGER                :: MP
      INTEGER                :: MT
      INTEGER                :: MZ
      INTEGER                :: NA
      INTEGER                :: NB
      INTEGER                :: NC
      INTEGER                :: NF
      INTEGER                :: NG
      INTEGER                :: NI
      INTEGER                :: NJ
      INTEGER                :: NK
      INTEGER                :: NL
      INTEGER                :: NM
      INTEGER                :: NN
      INTEGER                :: NQ
      INTEGER                :: NS
      INTEGER                :: NT
      INTEGER                :: NU
      INTEGER                :: NY
      INTEGER                :: NZ
      INTEGER                :: IER
      INTEGER, DIMENSION(27) :: IP
      REAL                   :: P
      REAL                   :: Q
      REAL                   :: R
      REAL                   :: S
      REAL                   :: T
      REAL                   :: V
      REAL                   :: W
      REAL                   :: X
      REAL                   :: Y
      REAL                   :: Z
      REAL                   :: RR
      REAL                   :: PA
      REAL                   :: PF
      REAL                   :: PI
      REAL                   :: PQ
      REAL                   :: PS
      REAL                   :: PZ
      REAL,    DIMENSION(*)  :: A
      REAL,    DIMENSION(4)  :: AA
      NA = LZ
      IF (ABS (A(39)) < 0.5 .OR. ABS (ABS (A(54)) - 1.5) < 0.8) THEN
        LE = NA
        RETURN
      END IF
      CALL GEN097 (IP, 1, 27, 0)
      NQ    = 0
      NC    = 0
      NT    = 0
      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)
C * MOVE SPECIAL REFLECTIONS TO TOP OF LIST (TYPE 1, 2, 3 OR 5)
      MT = INT(A(43))
      I  = NA
      J  = NA
      IF (MT > 0 .AND. MT < 6 .AND. MT /= 4) THEN
        DO WHILE (I <= LD - 4)
          I = I + 4
          CALL GEN046 (A(I), F(1), F(2), F(3))
          F(5) = AMOD (ABS (F(1)) + 0.1, 2.0)
     1         + AMOD (ABS (F(2)) + 0.1, 2.0)
     2         + AMOD (ABS(F(3)) + 0.1, 2.0)
          IF (ABS(F(MT)) <= 0.5) THEN
            K = I + 3
            DO L = I, K
              CALL GEN018 (A(L), A(J + 4))
              J = J + 1
            END DO
          END IF
        END DO
        NZ = MIN (NZ, J)
      END IF
      MA = LX + 4
      NS = 0
      ME = LD + 4
      IF (MT >= 0) GO TO 260
C * EXCLUDE STRONGEST E FROM SUBSET (TYPE NEGATIVE)
      N = MIN (LX + 4 - 4 * MT, NZ)
      I = NA
      J = MIN (NZ - 4 * MT, LD)
      DO WHILE (I <= N - 4)
        I = I + 4
        K = I + 3
        DO L = I, K
          CALL GEN018 (A(L), A(J))
          J = J + 1
        END DO
        J = J - 8
        IF (J <= NZ) THEN
          NZ = NZ - 4
          N  = MIN (N, NZ)
        END IF
      END DO
C * SCAN PART OF REFLECTION LIST
   10 L  = NA
      MB = NT + ((NZ - LX) / 4) - 3
   20 L  = L + 4
      IF (L > NZ) GO TO 160
      R  = AMOD (A(L + 1), 10.0) * A(45)
      NQ = MB
      IZ = (L - LX - 4) / 4
C * FIND TPR (AS SUM)
      W  = A(L) - 0.5
   30 PQ = 0.0001
      RR = 0.0001
      Q  = 1.0
      PI = 0.0
      NN = NT + 2
      I  = ME
      K  = I
      MZ = NT
   40 J  = MZ
   50 MZ = K + 2 * ((J - K) / 4)
      IF (A(MZ) > W) GO TO 40
      K  = MZ
      IF (J > K + 2) GO TO 50
      W = W + 1.0
   60 I = I + 2
   70 IF (I >= J) GO TO 100
      X = W - A(I) - A(J)
      IF (X > 1.0) GO TO 60
      IF (X <= 0.0) THEN
        J = J - 2
        GO TO 70
      END IF
   80 NI = INT (A(I + 1) * Q)
      NJ = INT (A(J + 1))
C * REJECT SIGMA-1 TPR
      IF (IABS (NJ) <= IABS (NI)) THEN
        K  = NI
        NI = NJ
        NJ = K
      END IF
      IF (A(23) <= 0.5) THEN
        NJ = - IABS (NJ)
        NI =   IABS (NI)
      END IF
      IF (NI + NJ /= 0) THEN
        N = IABS (NJ)
        M = IABS (NI)
        IF (M /= IZ) THEN
          IF (N /= IZ) THEN
C * ROUGH ALPHA SUMS TO SELECT SUBSET REFLECTIONS
            IF (NS /= 2) THEN
              IF (NS /= 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 == 1) THEN
                  N    = N + NT + 1
                  A(N) = A(N) + P
                  M    = M + NT + 1
                  A(M) = A(M) + P
                END IF
                GO TO 90
              END IF
            END IF
C * PHASE SHIFT
            IF (NQ + 3 > NVDS) THEN
              IER = 1
              RETURN
            END IF
            NQ    = NQ + 2
            A(NQ) = FLOAT (NI)
            Y     = AMOD (ABS (A(I + 1)), 1.0)
            IF (Q < 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))
          END IF
        END IF
      END IF
   90 IF (Q < 0) THEN
        GO TO 110
      ELSE
        GO TO 60
      END IF
C * FIND TPR (AS DIFFERENCE)
  100 Q = - 1.0
      I = ME
      J = MZ
  110 I = I + 2
  120 X = W + A(I) - A(J)
      IF (X < 0.0) GO TO 110
      IF (X < 1.0) GO TO 80
      J = J + 2
      IF (J < NN) GO TO 120
      IF (NS == 3 .OR. NS <= 0) THEN
        A(L + 3) = R * SQRT (PQ)
        GO TO 20
      END IF
      IF (NS == 1) GO TO 180
C * FIND STATISTICAL WEIGHTS FOR TPR
      I = MB
  130 I = I + 2
      IF (I <= 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
  140   J  = J + 2
  150   IF (J <= NQ) THEN
          IF (IABS (INT (A(J))) /= N) GO TO 140
          IF (IABS (INT (A(J + 1))) /= M) GO TO 140
          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) < 10.0) GO TO 140
          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 <= 0.0) THEN
            IF (A(NI) < 10.0) GO TO 150
            K = K + INT (SIGN (0.1 * A(NI), A(I)))
          END IF
          IF (A(I + 1) * V <= 0.0) THEN
            IF (A(NJ) < 10.0) GO TO 150
            K = K + INT (SIGN (0.1 * A(NJ), A(I + 1)))
          END IF
          IF (MOD (K, 12) /= 0) Q = -9.E5
          GO TO 150
        END IF
        IF (Q < 0.0) GO TO 130
C * COUNT TPR AND SUM FOR ALPHA(EST)
        IF (NS == 4) THEN
          IF (M <= IZ) THEN
            PA = PA + 1.0
            IF (L <= NC) PS = PS + 1.0
          END IF
        END IF
        Q = SQRT (Q)
        X = AMOD (A(NJ), 10.0) * AMOD (A(NI), 10.0)
        IF (NJ == 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
        GO TO 130
      END IF
C * WRITE TPR TO FILE
      A(L + 3) = SQRT (PQ)
      IF (NS /= 2) THEN
        NQ = NQ + 2
        A(NQ) = 0.0
        A(NQ + 1) = FLOAT (IZ)
        I = MB
        DO WHILE (I <= NQ - 2)
          I         = I + 2
          F(NF)     = A(I)
          F(NF + 1) = A(I + 1)
          NF        = NF + 2
          IF (NF >= 126) THEN
            WRITE (LB) F
            NF = 1
          END IF
        END DO
        IF (PA > 2.0 * PS + 0.5) GO TO 320
        GO TO 20
      END IF
C * REFLECTION AND TPR LISTS
      A(28) = A(28) + A(L + 3)**2
C * SPECIAL TPR LIST
      I = MB
      DO WHILE (I <= NQ - 2)
        I = I + 2
        IF (L <= NB) THEN
          IF (INT (ABS (A(I + 1))) < IZ) PF = PF + 1.0
        END IF
        MB        = MB + 2
        A(MB)     = A(I)
        A(MB + 1) = A(I + 1)
      END DO
      MB = MB + 2
      IF (MB > NVDS - 2000) THEN
        IER = 1
        RETURN
      END IF
      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
      GO TO 20
C * IF TYPE 0 OR 4, TAKE SIGMA-2 SUMS FOR WEAK E INTO ACCOUNT
  160 IF (NS /= 0) GO TO 190
      NS = 1
      IF (IABS (MT - 2) /= 2) GO TO 190
      IZ = 0
      I  = NT + 2
      CALL GEN074 (A, I, MB, 1.0)
  170 READ (LA) F
      NF = - 2
  180 NF = NF + 3
      IF (NF > 124) GO TO 170
      IF (0.5 <= 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 > R) GO TO 180
        IF (EXP (2.0 * R / A(1)**2) * F(NF + 2) > 0.65 + 0.05 * A(23))
     1    GO TO 180
        W = F(NF) - 0.5
        GO TO 30
      END IF
      I = LX + 4
      CALL GEN108 (LA, 0)
      J = NT + 1
      DO WHILE (I <= NZ - 4)
        I        = I + 4
        J        = J + 1
        A(I + 3) = A(I + 3) * A(J)
      END DO
C * SIN-THETA WEIGHTING IF TYPE GREATER THAN 6
  190 IF (NS == 1) THEN
        IF (MT > 6) THEN
          T = FLOAT (6 - MT) / A(1)**2
          I = NA
          DO WHILE (I <= NZ - 4)
            I = I + 4
            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)))
          END DO
        END IF
C * DEFINE SUBSET
        NB = NA
        NC = LX + 4 * INT (ABS (A(44)) + 1.1)
  200   Q = 0.01
        I = NB
        DO WHILE ( I <= NZ - 4)
          I = I + 4
          IF (Q <= A(I + 3)) THEN
            Q = A(I + 3)
            M = I
          END IF
        END DO
        IF (Q >= 0.1) THEN
          K = M + 3
          DO I = M, K
            P         = A(I)
            A(I)      = A(NB + 4)
            A(NB + 4) = P
            NB        = NB + 1
          END DO
          IF (NB < NC) GO TO 200
        END IF
C * SORT REMAINING REFLECTIONS ON E
        I  = NB
        NZ = MIN (NZ, NC)
        DO WHILE (I <= LD - 4)
          I        = I + 4
          A(I + 3) = AMOD (A(I + 1), 10.0)
        END DO
        N = (LD - NB) / 4
        M = 1
  210   M = 3 * M + 1
        IF (M < N) GO TO 210
  220   M = M / 3
        N = 4 * M
        NJ = NB + N
        NI = NJ + 4
        DO I = NI, LD, 4
          CALL GEN113 (A(I), AA, 4)
          J = I
  230     K = J - N
          IF (A(K + 3) <= T) THEN
            CALL GEN113 (A(K), A(J), 4)
            J = K
            IF (J > NJ) GO TO 230
          END IF
          CALL GEN113 (AA, A(J), 4)
        END DO
        IF (M > 2) GO TO 220
        NS = 2
        NZ = NB
        MB = NT
        IF (MT /= 0) GO TO 260
      END IF
C * MOVE UP SUBSET SIGMA-2 LIST
      IF (NS == 2) THEN
        K = MB + 3
        A(K - 1) = 0.0
        A(K) = 0.0
        J    = NT + 2
        DO I = J, K
          A(ME) = A(I)
          ME    = ME + 1
        END DO
        NS = 3
        NC = MIN (LD, LX + 4 + 4 * NY)
        GO TO 250
      END IF
C * OPTIMISE REFLECTION SET FOR PHASE REFINEMENT
      IF (NS /= 3) GO TO 320
      NF = 1
      NC = NB
  240 Q  = 0.01
      I  = NC
      DO WHILE (I <= NZ - 4)
        I  = I + 4
        IF (Q <= A(I + 3)) THEN
          Q  = A(I + 3)
          M  = I
        END IF
      END DO
      IF (Q >= 0.1) THEN
        K  = M + 3
        DO I = M, K
          P    = A(I)
          A(I) = A(NC + 4)
          A(NC + 4) = P
          NC = NC + 1
        END DO
        IF (NC < LX + 4 + 4 * NY) GO TO 240
      END IF
      NS = 4
  250 NZ = NC
C * EXPANDED LIST
  260 L  = MA
      NT = ME
      A(NT) = 0.0
      P  = 0.0
      DO WHILE (L < NZ - 4)
        L  = L + 4
        NG = NT
        P  = P + 1.0
        CALL GEN046 (A(L), X, Y, Z)
        DO 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
  270     J = J + 2
          IF (J <= NT) THEN
            IF (ABS (W - A(J)) > 0.5) THEN
              GO TO 270
            ELSE
              CYCLE
            END IF
          END IF
          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))
        END DO
        IF (NT > NVDS - 3000) THEN
          IER = 1
          RETURN
        END IF
      END DO
C * SORT EXPANDED LIST
      N = (NT - ME) / 2
      M = 1
  290 M = 3 * M + 1
      IF (M < N) GO TO 290
  300 M  = M / 3
      N  = M * 2
      NJ = ME + N
      NI = NJ + 2
      DO I = NI, NT, 2
        Q = A(I)
        T = A(I + 1)
        J = I
  310   K = J - N
        IF (A(K) >= Q) THEN
          A(J)     = A(K)
          A(J + 1) = A(K + 1)
          J        = K
          IF (J > NJ) GO TO 310
        END IF
        A(J)     = Q
        A(J + 1) = T
      END DO
      IF (M  > 2) GO TO 300
      IF (NS == 0) GO TO 10
      L  = NA
      MB = NT
      IF (NS > 2) THEN
        NZ = MIN (LD, NC + 2 * NY)
        IF (NS == 4) THEN
          L  = MA
          NZ = NC
          IF (A(41) < 0.0) NZ = LD
          A(41) = ABS (A(41))
        END IF
      END IF
      GO TO 20
C * SUMMARISE PHASE RELATIONS
  320 F(NF)     = 0.0
      F(NF + 1) = 0.0
      WRITE (LB) F
      CALL GEN108 (LB, 0)
      J = (NB - LX - 4) / 4
      WRITE (LI, 99998, IOSTAT = IOST) J, PF
      J = (NC - LX - 4) / 4
      WRITE (LI, 99999, IOSTAT = IOST) J, PS, IZ, PA
      NY = NT + 4
      M  = LD - 1
      NQ = M
      IF (A(42) >= 0.9999) THEN
        IF (A(44) > 0.0) GO TO 580
      END IF
C * SMALL E FOR NQR
      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 (NVDS) + 0.7 * FLOAT (NQ), FLOAT (NQ)
     1   + 10000.0))
  330 READ (LA) F
      I = -2
  340 I = I + 3
      IF (I > 124) GO TO 330
      IF (0.5 <= 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 > P) GO TO 340
        P = EXP (2.0 * P / A(1)**2) * F(I + 2)
        IF (P > R) GO TO 340
        M = NQ
        DO 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
  350     J = J + 2
          IF (J <= NQ) THEN
            IF (ABS (Q - A(J)) < 0.5) THEN
              CYCLE
            ELSE
              GO TO 350
            END IF
          END IF
          NQ        = NQ + 2
          A(NQ)     = Q
          A(NQ + 1) = P
        END DO
  370   IF (NQ < MZ) GO TO 340
        R  = R - 0.01
        J  = NT + 3
        K  = NQ
        NQ = J
        DO WHILE (J <= K - 2)
          J  = J + 2
          IF (A(J + 1) <= R) THEN
            NQ        = NQ + 2
            A(NQ)     = A(J)
            A(NQ + 1) = A(J + 1)
          END IF
        END DO
        GO TO 370
      END IF
      CALL GEN108 (LA, 0)
      NY = NQ + 1
C * SORT SMALL E VALUES
      N = (NQ - NT - 3) / 2
      M = 1
  380 M = 3 * M + 1
      IF (M < N) GO TO 380
  390 M  = M / 3
      N  = M + M
      NJ = NT + 3 + N
      NI = NJ + 2
      DO I = NI, NQ, 2
        Q = A(I)
        T = A(I + 1)
        J = I
  400   K = J - N
        IF (A(K) >= Q) THEN
          A(J)     = A(K)
          A(J + 1) = A(K + 1)
          J        = K
          IF (J > NJ) GO TO 400
        END IF
        A(J)     = Q
        A(J + 1) = T
      END DO
      IF (M > 2) GO TO 390
      A(NQ + 2) = 9.E9
C * DERIVE NQR
      MZ = 5 * MIN ((NVDS - 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
  410 L  = L + 4
      IF (L > NC) THEN
        I = (M - NQ) / 5
        A(43) = 64.0 * A(45) / SQRT (FLOAT (I) + 24.0)
        IF (I == 0) A(43) = 0.0
        WRITE (LI, 99997, IOSTAT = IOST) KZ, I
        GO TO 580
      END IF
      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 >= A(J)) THEN
        NM = NT
  420   K  = NM
  430   NM = J + 2 * ((K - J) / 4)
        IF (A(NM) > X) GO TO 420
        J = NM
        IF (K > J + 2) GO TO 430
      END IF
  440 I = I - 2
  450 X = A(J) - A(I) + R
      IF (X < -0.5) GO TO 440
      IF (X <  0.5) GO TO 560
      J = J - 2
      IF (J > ME) GO TO 450
      S  = -1.0
      NU = 0
  460 J  = J + 2
  470 X  = R - A(I) - A(J)
      IF (X >  0.5) GO TO 460
      IF (X > -0.5) GO TO 560
      I = I - 2
      IF (I > JN) GO TO 470
      Q  = 1.0
      NU = 1
  480 I  = I + 2
  490 X  = R + A(I) - A(J)
      IF (X < -0.5) GO TO 480
      IF (X <  0.5) GO TO 560
      J = J + 2
      IF (J < NI) GO TO 490
  500 J = MZ
  510 J = J + 3
      IF (J > N) GO TO 410
      S = A(J) + R
      I = J + 3
      K = N + 3
  520 K = K - 3
  530 IF (K <= I) GO TO 510
      X = S + A(I) + A(K)
      IF (X < -0.5) GO TO 520
      IF (X <  0.5) GO TO 540
      I = I + 3
      GO TO 530
C * SORT NQR
  540 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 NJ = 1, 4
        NM = INT (ABS (G(NJ))) * 4 + LX + 5
        P  = P * AMOD (A(NM), 10.0)
      END DO
      IF (P < PZ) GO TO 520
      IF (M < 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 >= MZ - 8) THEN
        PZ = P
        NJ = NQ + 2
  550   NJ = NJ + 5
        IF (NJ > M) GO TO 520
        IF (A(NJ) <= PZ) THEN
          PZ = A(NJ)
          MP = NJ
        END IF
        GO TO 550
      END IF
      MP = MP + 5
      GO TO 520
C * INTERMEDIATE LIST FOR NQR SEARCH
  560 NM = INT (ABS (A(J + 1)))
      IF (NM < NL) THEN
        K = MZ
        DO WHILE (K <= N - 3)
          K = K + 3
          IF (NM == INT (ABS (A(K + 1)))) GO TO 570
        END DO
        IF (N > NVDS - 5) GO TO 500
        N = N + 3
        IF (NY < N + 2) NY = N + 2
        A(N) = A(J) * S
        X = AMOD (ABS (A(J + 1)), 1.0)
        IF (S < 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
      END IF
  570 IF (NU < 0) THEN
        GO TO 440
      ELSE IF (NU == 0) THEN
        GO TO 460
      ELSE
        GO TO 480
      END IF
  580 LZ = M
      LQ = NQ + 2
      N  = ((M - LQ) / 5) * 8 + M + 5
      IF (N > NY) NY = N
      A(27) = PF
      A(29) = FLOAT (ME)
      LR    = NB
      LH    = NC
      LE    = NA
      IF (IOST /= 0) RETURN
      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 PLA157
 
      SUBROUTINE PLA158 (A)
C * TANGENT REFINEMENT
      USE files
      USE shx86
      IMPLICIT NONE
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: K
      INTEGER                 :: L
      INTEGER                 :: M
      INTEGER                 :: N
      INTEGER                 :: IZ
      INTEGER                 :: KI
      INTEGER                 :: KJ
      INTEGER                 :: MB
      INTEGER                 :: ME
      INTEGER                 :: MH
      INTEGER                 :: ML
      INTEGER                 :: MM
      INTEGER                 :: MP
      INTEGER                 :: MQ
      INTEGER                 :: MS
      INTEGER                 :: MT
      INTEGER                 :: MU
      INTEGER                 :: NA
      INTEGER                 :: NB
      INTEGER                 :: NC
      INTEGER                 :: NE
      INTEGER                 :: NF
      INTEGER                 :: NG
      INTEGER                 :: NI
      INTEGER                 :: NJ
      INTEGER                 :: NL
      INTEGER                 :: NM
      INTEGER                 :: NQ
      INTEGER                 :: NS
      INTEGER                 :: NZ
      INTEGER, DIMENSION(20)  :: IP
      INTEGER, DIMENSION(31)  :: ID
      REAL                    :: P
      REAL                    :: Q
      REAL                    :: R
      REAL                    :: S
      REAL                    :: T
      REAL                    :: U
      REAL                    :: V
      REAL                    :: W
      REAL                    :: X
      REAL                    :: Y
      REAL                    :: Z
      REAL                    :: PN
      REAL                    :: PQ
      REAL                    :: PS
      REAL                    :: RN
      REAL                    :: RR
      REAL                    :: TN
      REAL                    :: TS
      REAL                    :: TW
      REAL                    :: TZ
      REAL                    :: WF
      REAL                    :: ZG
      REAL                    :: ZT
      REAL                    :: ZZ
      REAL                    :: XQ
      REAL,    DIMENSION(15)  :: SN
      REAL,    DIMENSION(64)  :: B
      REAL,    DIMENSION(64)  :: C
      REAL,    DIMENSION(64)  :: FB
      REAL,    DIMENSION(64)  :: FC
      REAL,    DIMENSION(64)  :: FD
      REAL,    DIMENSION(64)  :: FE
      REAL,    DIMENSION(64)  :: PM
      REAL,    DIMENSION(64)  :: PR
      REAL,    DIMENSION(126) :: D
      REAL,    DIMENSION(126) :: E
      REAL,    DIMENSION(*)   :: A
      NG = 0
      RR = 1.E8
      W  = 0.0
      S  = 0.0
      NA = LE
      IF (ABS (A(39)) < 0.5) THEN
        LE = NA
        RETURN
      END IF
      TW = AMOD (A(41), 1.0)
      MB = -1
      IF (A(27) < 0.5) MB = 0
      IF (MB /= 0) TW = 5.0 * TW
      ME = INT (A(29))
      NB = LR
      NC = LH
C * PREPARE NQR INDEX TABLES
      NI = ME + 1
      NJ = (NC - LX - 4) / 4 + ME
      CALL GEN074 (A, NI, NJ, 0.1)
      MP = LZ + 5
      NE = MP
      A(NE) = 0.0
      J = LQ
   10 J = J + 5
      IF (J <= LZ) THEN
        K = J + 3
        DO 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
        END DO
        GO TO 10
      END IF
      ML = MP
      DO I = NI, NJ
        J    = INT (A(I))
        A(I) = FLOAT (ML)
        ML   = ML + J
      END DO
      I = MP
   20 I = I + 2
      IF (I <= NE) THEN
   30   IF (A(I) > 0.0) GO TO 20
        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 == M) GO TO 20
        A(I)     = Q
        Q        = A(M + 1)
        A(M + 1) = A(I + 1)
        A(I + 1) = Q
        GO TO 30
      END IF
C * WRITE  EXPANDED NQRS
      L  = 0
      NF = 1
      K  = LX + 4
   40 K  = K + 4
      IF (K <= NC) THEN
        L  = L + 1
        NJ = L + ME
        NJ = INT(A (NJ))
   50   IF (INT (A(NJ)) < L) GO TO 40
        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))
   60   IF (INT (ABS (W)) == 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 >= 122) THEN
            WRITE (LG) G
            NF = 1
          END IF
          GO TO 50
        END IF
        S = W
        W = X
        X = Y
        Y = Z
        Z = S
        GO TO 60
      END IF
      G(NF) = 0.0
      WRITE (LG) G
      CALL GEN108 (LG, 0)
C * RETAIN UP TO 100 STRONGEST NQR FOR FILTER
      WF = 0.0
      MS = ME - 3
      IF (MB /= 0) THEN
        IF (A(44) <= 0.0) THEN
          M  = (NB - LX - 4) / 4
          N  = LZ
          LZ = LQ
          I  = LQ
          DO WHILE (I <= N - 5)
            I  = I + 5
            IF (INT (A(I + 1)) <= 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)
            END IF
          END DO
   70     Q = - 1.0
          N = 0
          I = LQ
   80     I = I + 5
          IF (I <= LZ) THEN
            IF (A(I) >= Q) THEN
              N = I
              Q = A(I)
            END IF
            GO TO 80
          END IF
          IF (N /= 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 I = K, ME
              J = INT (ABS (A(I))) * 4 + LX + 5
              Q = Q * AMOD (A(J), 10.0)
            END DO
            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 < MS + 400) GO TO 70
          END IF
        END IF
      END IF
      I = (ME - MS) / 4
      WRITE (LI, 99999, IOSTAT = IOST) I
C * SEMINVARIANTS
      TS = 0.0
      TZ = 0.0
      NS = ME
      I  = LX + 4
   90 I  = I + 4
      IF (I <= LD) THEN
        TS = TS + A(I + 3)
        TZ = TZ + A(I + 3)**2 / (A(I + 3) + 5.0)
        IF (I <= NC) THEN
          IF (A(23) >= 0.5) THEN
            IF (A(I + 1) < 120.0) GO TO 90
            IF (A(I + 1) > 130.0) GO TO 90
          END IF
          IF (NS - ME <= 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) <= 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)
            END IF
          END IF
        END IF
        GO TO 90
      END IF
C * SET UP PHASE DETERMINATION
      NQ = 1
      MQ = 1
      IF (A(39) >= 0.0) THEN
        X  = 2.0 * FLOAT (NVDS - 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)
      END IF
      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 NJ = 1, 15
        SN(NJ) = SIN (FLOAT (NJ - 1) * 0.523598)
      END DO
      CALL GEN097 (ID, 1, 31,      0)
  100 CALL GEN074 (FB, 1, NQ,    0.0)
      CALL GEN074 (FC, 1, NQ, 0.0001)
      CALL GEN074 (FD, 1, NQ,    0.0)
      CALL GEN074 (FE, 1, NQ,    0.0)
      CALL GEN074 (B , 1, NQ,    0.0)
      CALL GEN074 (C , 1, NQ,    0.0)
      CALL GEN074 (PM, 1, NQ,   9.E9)
      CALL GEN074 (D,  1, MQ, -1.E-6)
      CALL GEN074 (E,  1, MQ,    0.0)
      NZ = MB
      MM = MQ
      PN = 0.1
C * STARTING PHASES
  110 DO 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 == 0) THEN
          PM(I) = 0.0
          PR(I) = RN
        END IF
        G(I) = RN
      END DO
      IF (A(39) < 0.0) G(1) = - A(39)
  120 N = NE
      M = NB
      IF (NZ == 0) M = NC
      DO I = 1, MM
        R = G(I)
        R = AMOD (7169.0 * SQRT (R / 2097152.0), 1.0)
        K = N
        L = LX + 4
        DO WHILE (L <= M - 4)
          L = L + 4
          P = AMOD (A(L + 1), 10.0)
          IF (MB /= 0) P = P * 0.2
          IF (L > 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 <= NA) Q = A(L + 2) / 360.0
          IF (A(23) <= 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) > 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)
          END IF
          K = K + MM * 2
        END DO
        N = N + 2
      END DO
C * INITIAL PHASING
      MU = 1
      IF (MB == 0) GO TO 140
      M  = LD + 2
      IZ = 5
      IF (A(22) >= 3.5) THEN
        DO K = 65, LY, 12
          IF (ABS (A(K + 9)) + ABS (A(K + 10)) + ABS (A(K + 11)) > 0.1)
     1        IZ = MIN (IZ + 1, 8)
        END DO
      END IF
      GO TO 250
  130 CALL GEN108 (LB, 0)
      CALL GEN108 (LG, 0)
  140 MU = NZ
      NZ = NZ + 1
      IF (NZ > MT) GO TO 400
      READ (LG) G
      NG = 1
      MP = 0
  150 READ (LB) F
      M = -1
  160 M = M + 2
      IF (M > 125) GO TO 150
      P  = F(M)
      T  = ABS (P)
      XQ = F(M + 1)
      Z  = ABS (XQ)
  170 I  = INT (T) * NM + NL
      J  = INT (Z) * NM + NL
      IF (I == NL) GO TO 260
      IF (MU == 0) GO TO 160
  180 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) > 0.5) GO TO 200
      IF (Z > 0.25) J = J + 1
      IF (ABS (T - 1.0) <= 0.001) THEN
C * VERY CRITICAL LOOP
        DO K = 1, MM
          D(K) = D(K) + A(I) * A(J)
          I    = I + 2
          J    = J + 2
        END DO
        GO TO 240
      END IF
C * VERY CRITICAL LOOP
  190 DO K = 1, MM
        D(K) = D(K) + T * A(I) * A(J)
        I    = I + 2
        J    = J + 2
      END DO
      GO TO 240
  200 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
C * SIMPLIFY TPR SUMS INVOLVING TWO RESTRICTED PHASES
      KJ = INT (0.1 * A(KJ))
      IF (KJ < 12) GO TO 230
      IF (ABS (V) > 0.001) GO TO 230
      KI = INT (0.1 * A(KI))
      IF (KI /= 12) GO TO 220
      T = U
      IF (KJ == 12) GO TO 190
      IF (KJ /= 18) GO TO 230
      T = T * S
      J = J + 1
C * VERY CRITICAL LOOP
  210 DO K = 1, MM
        E(K) = E(K) + T * A(I) * A(J)
        I    = I + 2
        J    = J + 2
      END DO
      GO TO 240
  220 IF (KI == 18) THEN
        T = U * R
        I = I + 1
        IF (KJ == 12) GO TO 210
        T = -T * S
        J = J + 1
        IF (KJ == 18) GO TO 190
        J = J - 1
        I = I - 1
      END IF
C * VERY CRITICAL LOOP
  230 DO 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
      END DO
  240 IF (NZ > 0) GO TO 160
  250 M  = M + 2
      P  = A(M)
      XQ = A(M + 1)
      T  = ABS (P)
      Z  = ABS (XQ)
      IF (NZ == 0) GO TO 170
      I = INT (T) * MH + ML
      J = INT (Z) * MH + ML
      IF (I > ML) GO TO 180
      IF (J > ML) THEN
        GO TO 280
      ELSE
        GO TO 360
      END IF
  260 IF (J  == NL) GO TO 360
      IF (NZ == 0)  GO TO 280
      IF (MU == 0)  GO TO 290
      MP = MP + 1
      IF (NZ == MT) GO TO 270
      IF (A(43) < 1.E-6) GO TO 290
  270 IF (MP /= INT (G(NG))) GO TO 290
      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) <= 0.5) THEN
        IF (AMOD (G(NG), 1.0) > 0.25) N = N + 1
        DO I = 1, NQ
          B(I) = B(I) + A(N) * A(K) * A(L)
          N    = N + 2
          K    = K + 2
          L    = L + 2
        END DO
      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 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
        END DO
      END IF
      NG = NG + 4
      IF (NG >= 122) THEN
        READ (LG) G
        NG = 1
      END IF
      GO TO 270
C * PHASE RESTRICTIONS
  280 M  = M + 2
      Z  = A(M)
      RR = A(M + 1)
  290 L  = 4 * INT (XQ) + LX + 4
      K  = MU
      IF (L >= NB) MU = 1
      IF (K == 0) GO TO 160
      P = AMOD (A(L + 1), 10.0)
      IF (A(L + 1) >= 10.0) THEN
        Q = 0.261799 * AINT (0.1 * A(L + 1))
        U = COS (Q)
        V = SIN (Q)
        IF (NZ <= 0) THEN
          DO K = 1, MM
            X    = D(K) * U + E(K) * V
            E(K) = X * V
            D(K) = X * U
          END DO
        ELSE
          DO 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
          END DO
        END IF
      END IF
C * SUM FOR RALPHA(0)
      T = P * A(45)
      IF (NZ > 0) Z = A(L + 3)
      ZG = 1.0 / (Z + 5.0)
      IF (NZ == 0) THEN
        GO TO 320
      ELSE IF (NZ > 0) THEN
        GO TO 340
      END IF
      IF (IZ > 0) GO TO 320
      IF (A(23) > 0.5) GO TO 310
C * CRITICAL LOOP
      DO K = 1, MQ
        F(K) = F(K) + (Z - T * ABS (D(K)))**2
        D(K) = -1.E-6
      END DO
      GO TO 250
C * CRITICAL LOOP
  300 DO 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
      END DO
      GO TO 330
C * CRITICAL LOOP
  310 DO 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
      END DO
      GO TO 250
C * SELECT NEW PHASES FOR SUBSET
  320 IF (A(23) < 0.5) GO TO 300
C * CRITICAL LOOP
      DO 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
      END DO
  330 IF (L < NB) GO TO 250
      GO TO 360
C * NEW PHASES FOR FULL REFINEMENT
  340 ZZ = (Z / T)**2
      ZT = ZZ
      IF (A(L + 1) > 10.0) ZT = 9.E9
      IF (NZ >= MT) THEN
        IF (A(23) <= 0.5) THEN
C * CRITICAL LOOP
          DO 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
          END DO
        ELSE
C * CRITICAL LOOP
          DO 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
          END DO
        END IF
        IF (L > NC) GO TO 350
      END IF
      IF (L > NA) THEN
        IF (A(23) >= 0.5) THEN
C * CRITICAL LOOP
          DO 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 >= 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
            END IF
            W        = P / SQRT (W)
            A(J + 1) = W * V
            A(J)     = W * U
            J        = J + 2
          END DO
        ELSE
C * CRITICAL LOOP
          DO K = 1, NQ
            W        = SIGN (P, D(K) - A(43) * B(K))
            A(J + 1) = -W
            A(J)     =  W
            J        = J + 2
          END DO
        END IF
      END IF
C * CRITICAL LOOP
  350 DO K = 1, NQ
        B(K) = 0.0
        C(K) = 0.0
        D(K) = -1.E-6
        E(K) = 0.0
      END DO
      IF (NZ == MT) GO TO 160
      IF (L < NC)  GO TO 240
C * NQR SUMS FOR FILTER
  360 IF (NZ > 0) GO TO 130
      M  = LD + 2
      IZ = IZ - 1
      IF (IZ > NZ) GO TO 250
      IF (NZ == 0)  GO TO 140
      J = MS
  370 J = J + 4
      IF (J <= 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) <= 0.5) THEN
          IF (AMOD (A(J), 1.0) > 0.25) K = K + 1
C * CRITICAL LOOP
          DO 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
          END DO
          GO TO 370
        END IF
        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))
C * CRITICAL LOOP
        DO 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
        END DO
        GO TO 370
      END IF
C * APPLY FILTER
      J = 0
      Q = -9.E9
  380 DO I = 1, NQ
        IF (PM(I) >= Q) THEN
          Q = PM(I)
          M = I
        END IF
      END DO
  390 J = J + 1
      IF (J <= MQ) THEN
        P = F(J) / A(28)
        IF (WF > 0.1) P = P + MAX (0.0, E(J) / WF + 0.25)**2
        F(J) = 0.0
        E(J) = 0.0
        IF (P > Q) GO TO 390
        PM(M) = P
        PR(M) = G(J)
        Q     = P
        GO TO 380
      END IF
      PN = PN + 1.0
      IF (A(39) >= 0.0) THEN
        IF (Q >= 0.125) THEN
          IF (PN < 5.0) GO TO 110
        END IF
      END IF
      MM = NQ
      DO I = 1, NQ
        G(I) = PR(I)
      END DO
      NZ = 0
      GO TO 120
C * CALCULATE AND COMPARE CFOM
  400 Q = 9.E9
      R = 0.0
      V = 0.0
      T = 0.0
      M = 0
      DO 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)) > 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 <= Q) THEN
          Q = P
          R = C(K)
          S = D(K)
          W = PR(K)
          V = PM(K)
          T = E(K)
          M = K
        END IF
        B(K) = P
      END DO
      IF (TN < 0.8 .OR. A(40) <= 0.0) THEN
        DO K = 1, NQ
          J       = 1
          IR(1:1) = ' '
          IF (K == M) IR(1:1) = '*'
          L = K + K - 2 + NL
          N = ME
  410     N = N + 1
          IF (N <= NS) THEN
            I = INT (A(N)) * NM + L
            J       = J + 1
            IR(J:J) = '+'
            IF (A(I) < 0.0) IR(J:J) = '-'
            GO TO 410
          END IF
        END DO
      END IF
      M       = M + M - 2 + NL
      K       = 0
      J       = 1
      IR(1:1) = ' '
      N = ME
      DO WHILE (N <= NS - 1)
        N       = N + 1
        I       = INT (A(N)) * NM + M
        J       = J + 1
        IR(J:J) = '+'
        IF (A(I) < 0.0) IR(J:J) = '-'
      END DO
C * PRINT AND SAVE RESULTS
      IF (PQ >= Q) THEN
        I = LX + 4
        DO WHILE (I <= NC - 4)
          I = I + 4
          M = M + NM
          U = -9.E9
          IF (ABS (A(M)) + ABS (A(M + 1)) > 0.01)
     1      U = 57.29578 * ATAN2 (A(M + 1) * A(23), A(M))
          IF (U < 0.0) U = U + 360.0
          A(I + 2) = U
        END DO
        PQ = Q
        PS = W
      END IF
C * TERMINATE TANGENT REFINEMENT
      TN = TN + FLOAT (NQ)
      IF (TN < A(39)) GO TO 100
      DO I = 1, 31
        F(I) = FLOAT (I - 1) * 0.02
      END DO
      F(32) = 9.999
      WRITE (LI, 99997, IOSTAT = IOST)
     1  (F(I), F(I + 1), ID(I), I = 1, 31)
      IF (TN < 1.1) TN = 1.1
      WRITE (LI, 99998, IOSTAT = IOST) TN, PS, PQ
C * SET UP TANGENT EXPANSION
      K = 0
      I = NA
  420 M = 0
  430 I = I + 4
      IF (I <= NC) THEN
        K    = K + 1
        A(I) = ABS (A(I))
        IF (A(I + 2) >= - 8.E9) THEN
          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)
          GO TO 420
        END IF
        GO TO 430
      END IF
      IF (M > 0) WRITE (LI, 99996, IOSTAT = IOST) (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
      LE = NA
      IF (IOST /= 0) RETURN
      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 PLA158
 
      SUBROUTINE PLA159 (A)
C * PARTIAL STRUCTURE EXPANSION
      USE files
      USE parameters
      USE shx86
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: IX
      INTEGER            :: IY
      INTEGER            :: IZ
      INTEGER            :: KP
      INTEGER            :: KW
      INTEGER            :: KX
      INTEGER            :: KY
      INTEGER            :: KZ
      INTEGER            :: MA
      INTEGER            :: MB
      INTEGER            :: ML
      INTEGER            :: MP
      INTEGER            :: MS
      INTEGER            :: NA
      INTEGER            :: NB
      INTEGER            :: NC
      INTEGER            :: NF
      INTEGER            :: NG
      INTEGER            :: NH
      INTEGER            :: NK
      INTEGER            :: NL
      INTEGER            :: NQ
      INTEGER            :: NS
      INTEGER            :: NT
      INTEGER            :: NX
      INTEGER            :: NZ
      REAL               :: H
      REAL               :: O
      REAL               :: P
      REAL               :: Q
      REAL               :: R
      REAL               :: S
      REAL               :: T
      REAL               :: U
      REAL               :: V
      REAL               :: W
      REAL               :: X
      REAL               :: Y
      REAL               :: Z
      REAL               :: HM
      REAL               :: CS
      REAL               :: EZ
      REAL               :: PQ
      REAL               :: RA
      REAL               :: RB
      REAL               :: RC
      REAL               :: RE
      REAL               :: RR
      REAL               :: SK
      REAL               :: SM
      REAL               :: SS
      REAL               :: TP
      REAL               :: WP
      REAL               :: XA
      REAL               :: XJ
      REAL               :: XK
      REAL               :: XL
      REAL               :: XS
      REAL               :: YA
      REAL               :: YJ
      REAL               :: YK
      REAL               :: YL
      REAL               :: YM
      REAL               :: YS
      REAL               :: ZA
      REAL               :: ZJ
      REAL               :: ZK
      REAL               :: ZL
      REAL               :: ZM
      REAL               :: ZS
      REAL               :: ZZ
      REAL               :: WWP
      REAL               :: YUNK
      REAL, DIMENSION(*) :: A
      W  = 0.0
   10 NA = LE
      NZ = INT (A(54))
      IF (NZ < 4) GO TO 240
      IF (NZ == 5) GO TO 240
      IF (NA <= LX - 4) GO TO 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 < NA) GO TO 20
C * EXPANDED LIST
   30 IF (NT <= NVDS - 6) THEN
        NQ = NT
        I  = NB
   40   I  = I + 4
        IF (I <= NA) THEN
          CALL GEN046 (A(I), X, Y, Z)
          DO 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 < 0.0) Q = - Q
            W = ABS (W)
            K = NQ
   50       K = K + 3
            IF (K <= NT) THEN
              IF (ABS (W - A(K)) < 0.5) THEN
                CYCLE
              ELSE
                GO TO 50
              END IF
            END IF
            NT        = NT + 3
            A(NT)     = W
            A(NT + 1) = P
            A(NT + 2) = Q * A(23)
            IF (NT > NVDS - 6) GO TO 70
          END DO
          NQ = NT
          GO TO 40
        END IF
C * SORT EXPANDED LIST
   70   LZ    = NT + 3
        A(LZ) = 9.E9
        M     = (LZ - LD) / 3
   80   M     = M / 2
        IF (M > 0) THEN
          N = M * 3
          K = LZ - N
          J = LD + 4
   90     I = J
  100     L = I + N
          IF (A(I) >= 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 > LD + 4) GO TO 100
          END IF
          J = J + 3
          IF (J > K) THEN
            GO TO 80
          ELSE
            GO TO 90
          END IF
        END IF
      END IF
C * TANGENT EXPANSION
  110 NB = NA
      S  = 0.0
      L  = NB
  120 L  = L + 4
      IF (L <= 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) > Z) GO TO 130
        K = M
        IF (J > K + 3) GO TO 140
        Z = Z + 0.5
  150   I = I + 3
  160   IF (I > J) GO TO 180
        X = Z - A(I) - A(J)
        IF (X >   0.5) GO TO 150
        IF (X <= - 0.5) THEN
          J = J - 3
          GO TO 160
        END IF
  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 < 0.0) THEN
          GO TO 190
        ELSE
          GO TO 150
        END IF
  180   I = LD + 4
        J = M
        Q = -1.0
  190   I = I + 3
  200   X = Z + A(I) - A(J)
        IF (X < -0.5) GO TO 190
        IF (X <  0.5) GO TO 170
        J = J + 3
        IF (J < LZ) GO TO 200
C * ACCEPT NEW PHASES
        IF (A(L + 1) >= 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
        END IF
        W = SQRT (U * U + V * V)
        X = P * W * A(45)
        IF (S < X) S = X
        IF (X < PQ) GO TO 120
        NA = NA + 4
        Q = A(L)
        T = A(L + 1)
        J = L
  210   J = J - 4
        IF (J >= NA) THEN
          A(J + 4) = A(J)
          A(J + 5) = A(J + 1)
          GO TO 210
        END IF
        A(NA) = Q
        A(NA + 1) = T
        A(NA + 2) = P * U / W
        A(NA + 3) = P * V * A(23) / W
        IF (NA - NB < 400) GO TO 120
      END IF
      PQ = PQ * 0.8
      IF (S >= 0.1) THEN
        IF (NA /= LD) THEN
          IF (NA > NB) GO TO 30
          PQ = 0.8 * S
          GO TO 110
        END IF
      END IF
C * RESULTS TO FILE
      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 <= NA) THEN
        N        = N + 3
        F(N)     = A(I)
        F(N + 1) = A(I + 2)
        F(N + 2) = A(I + 3)
        IF (N < 124) GO TO 230
        WRITE (LA) F
        GO TO 220
      END IF
      N    = N + 3
      F(N) = 0.0
      WRITE (LA) F
      CALL GEN108 (LA, 0)
      LE = - 1
  240 IF (NZ == 0) GO TO 370
      IF (ABS (A(55)) <= 0.5) THEN
C * FIND ASYMMETRIC UNIT OF FOURIER
        WP = 1.0
        IF (NZ < 4) WP = 0.0
        XJ = A(2)
        YJ = A(3)
        ZJ = A(4)
        IX = 0
        IY = 0
        IZ = 0
        KP = 1
        IF (A(23) >= 0.5) THEN
          IF (NZ < 4) KP = 2
        END IF
        ML = LY + 12
        DO I = 1, 3
          J = I + 30
          DO K = I, J, 6
            F(K)     = 9.E9
            F(K + 3) = 1.0
          END DO
        END DO
        DO L = ML, LL, 4
          DO N = 65, LY, 12
            W = A(L)
            DO 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))) <= 0.01) THEN
                IX = 1
                IF (ABS (X) <= 0.01) THEN
                  IF (A(N) * W >= 0.5) IX = 0
                END IF
              END IF
              IY = 9
              IF (MAX (ABS (A(N + 3)), ABS (A(N + 5))) <= 0.01) THEN
                IY = 1
                IF (ABS (Y) <= 0.01) THEN
                  IF (A(N + 4) * W >= 0.5) IY = 0
                END IF
              END IF
              IZ = 9
              IF (MAX (ABS (A(N + 6)), ABS (A(N + 7))) <= 0.01) THEN
                IZ = 1
                IF (ABS (Z) <= 0.01) THEN
                  IF (A(N + 8) * W >= 0.5) IZ = 0
                END IF
                IF (A(N + 8) * W >= 0.0) THEN
                  IF (IZ /= 0) THEN
                    IF (IX + IY < 1) F(6) = MIN (F(6),  Z)
                    IF (IX < 1) F(12)     = MIN (F(12), Z)
                    IF (IY < 1) F(18)     = MIN (F(18), Z)
                    IF (F(30) > Z) F(30)  = Z
                  END IF
                  GO TO 250
                END IF
                IF (IX + IY < 1) F(3) = MIN (F(3),  Z)
                IF (IX < 1) F(9)      = MIN (F(9),  Z)
                IF (IY < 1) F(15)     = MIN (F(15), Z)
                IF (F(27) > Z) F(27)  = Z
              END IF
  250         IF (IY < 2) THEN
                IF (A(N + 4) * W >= 0.0) THEN
                  IF (IY /= 0) THEN
                    IF (IX + IZ < 1) F(11) = MIN (F(11), Y)
                    IF (IX < 1)      F(5)  = MIN (F(5),  Y)
                    IF (IZ < 1)      F(35) = MIN (F(35), Y)
                    IF (F(17) > Y)   F(17) = Y
                  END IF
                  GO TO 260
                END IF
                IF (IX + IZ < 1) F(8)  = MIN (F(8),  Y)
                IF (IX < 1)      F(2)  = MIN (F(2),  Y)
                IF (IZ < 1)      F(32) = MIN (F(32), Y)
                IF (F(14) > Y)   F(14) = Y
              END IF
  260         IF (IX < 2) THEN
                IF (A(N) * W >= 0.0) THEN
                  IF (IX /= 0) THEN
                    IF (IY + IZ < 1) F(16) = MIN (F(16), X)
                    IF (IY < 1)      F(22) = MIN (F(22), X)
                    IF (IZ < 1)      F(28) = MIN (F(28), X)
                    IF (F(4) > X) F(4) = X
                  END IF
                ELSE
                  IF (IY + IZ < 1) F(13) = MIN (F(13), X)
                  IF (IY < 1)      F(19) = MIN (F(19), X)
                  IF (IZ < 1)      F(25) = MIN (F(25), X)
                  IF (F(1) > X)    F(1)  = X
                END IF
              END IF
              W = - W
            END DO
          END DO
        END DO
        DO I = 1, 27, 13
          F(I + 6) = F(I)
          F(I + 9) = F(I + 3)
        END DO
        DO I = 3, 13, 5
          F(I + 18) = F(I)
          F(I + 21) = F(I + 3)
        END DO
        DO I = 1, 31, 6
          J = I + 2
          DO K = I, J
            F(K) = 0.5 * F(K)
            IF (F(K) < 1.0) F(K + 3) = 0.5 * F(K + 3)
            IF (F(K) > 1.0) F(K) = 0.0
          END DO
        END DO
C * SET UP FMAP AND GRID
        RE = 19.6 * A(1) / SQRT (A(64))
        U  = 9.E9
        DO M = 1, 31, 6
          DO N = 1, 3
            L = N
  270       K = 1
            IF (0.501 <= F(M + 5)) K = 2
            J = 1
            IF (0.501 <= F(M + 4)) J = 2
            V = FLOAT (J * K) * F(M + 3)
            IF (V <= U) THEN
              IF (U > 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 <= 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)
              END IF
            END IF
            CALL GEN018 (YJ, ZJ)
            CALL GEN018 (F(M + 1), F(M + 2))
            CALL GEN018 (F(M + 4), F(M + 5))
            L = -L
            IF (L < 0) GO TO 270
            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
          END DO
        END DO
        J = INT (A(55))
        K = INT (A(56))
        L = NZ
        IF (NZ == 2) L = 6
        A(34) = IX
        A(35) = IY
        A(37) = IZ
        A(38) = KP
      END IF
      IF (NZ < 7) GO TO 370
      IF (LE < 0) GO TO 370
      A(54) = A(54) - 1.0
C * SET UP PEAKLIST OPTIMISATION
      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
      DO WHILE (I <= LD - 8)
        I  = I + 8
        J        = INT (A(I + 1) * 0.001) * 5 + LJ
        A(I + 6) = A(J)
        IF (I <= LX) THEN
          IF (HM < A(J)) HM = A(J)
          R = R + A(I + 5) * A(J) * A(J)
        END IF
      END DO
      DO
        READ (LF) F
        DO I = 1, 124, 3
          IF (F(I) < 0.5) GO TO 310
          IF (F(I + 1) >= 0.0) THEN
            P = AMOD (F(I + 1), 10.0)
            IF (ABS (P**2 - 0.8) >= T) THEN
  280         IF (NB + 16 >= NVDS) THEN
                T = T + 0.05
                J = MB
  290           J = J + 9
  300           IF (J > NB) GO TO 280
                IF (ABS (A(NB + 5)**2 - 0.8) > T) GO TO 290
                A(J + 4) = A(NB + 4)
                A(J + 5) = A(NB + 5)
                A(J + 6) = A(NB + 6)
                NB = NB - 9
                GO TO 300
              END IF
              NB        = NB + 9
              A(NB + 6) = F(I)
              A(NB + 5) = P
              A(NB + 4) = F(I + 2)
            END IF
          END IF
        END DO
      END DO
  310 CALL GEN108 (LF, 0)
      DO 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
        DO WHILE (J <= LX - 8)
          J = J + 8
          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
        END DO
        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
      END DO
      J = LZ
      DO I = 1, 1251
        A(J) = SIN (6.283185E-3 * FLOAT (I - 1))
        J    = J + 1
      END DO
      IX = (LD - LX) / 16
      IZ = LV + 1
      NA = LD + 8
      KP = (LD - LV) / 8
      SM = 0.0
C * SCAN PEAKS
      IY = 0
  320 I  = NA
  330 I  = I - 8
      IF (I < IZ) GO TO 360
      IF (A(I + 5) == 0.0) GO TO 330
      NK = -2
      DO 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))
      END DO
  340 RA = 0.0
      RB = 0.0
C * TRICLINIC INNER LOOP
      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 == 65) THEN
        DO 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 >= IY) THEN
            A(J + 6) = V
            A(J + 5) = U
          END IF
          RB = RB + A(J + 3) * SQRT (S)
        END DO
      ELSE
C * MONOCLINIC INNER LOOP
        XJ = G(4)
        YJ = G(5)
        ZJ = G(6)
        IF (LY == 77) THEN
          DO 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 >= IY) THEN
              A(J + 6) = V
              A(J + 5) = U
            END IF
            RB = RB + SQRT (S) * A(J + 3)
          END DO
C * ORTHORHOMBIC INNER LOOP
        ELSE IF (LY == 101) THEN
          XK = G(7)
          YK = G(8)
          ZK = G(9)
          XL = G(10)
          YL = G(11)
          ZL = G(12)
          DO 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 >= IY) THEN
              A(J + 6) = V
              A(J + 5) = U
            END IF
            RB = RB + SQRT (S) * A(J + 3)
          END DO
        ELSE
C * INNER LOOP FOR OTHER CRYSTAL SYSTEMS
          DO J = MB, NB, 9
            X = 0.0
            Y = 0.0
            DO 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)
            END DO
            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 >= IY) THEN
              A(J + 6) = V
              A(J + 5) = U
            END IF
            RB = RB + SQRT (S) * A(J + 3)
          END DO
        END IF
      END IF
      W = RB * RB / (RA * RC)
      IF (IY < 0) THEN
        GO TO 350
      ELSE IF (IY == 0) THEN
        GO TO 330
      END IF
      IF (W < SM) GO TO 330
      IY = -IY
      GO TO 340
C * ELIMINATE PEAK
  350 A(I + 5) = 0.0
      KP       = KP - 1
      IX       = IX - 1
      IY       = - IY
      SM       = W
  360 IF (IY /= IX + 1) THEN
        IF (IY == 0) THEN
          SM = W
          IZ = LX + 1
          DO J = MB, NB, 9
            A(J + 5) = - A(J + 5)
            A(J + 6) = - A(J + 6)
          END DO
        END IF
        IF (IX > 0) THEN
          IF (I > IZ - 1) GO TO 330
          IY = IX + 1
          GO TO 320
        END IF
      END IF
C * WRITE WEIGHTED FOURIER FILE, PRINT R-INDEX
      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 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)
      END DO
      X = SQRT (Y / X)
      DO J = MB, NB, 9
        F(I) = A(J) + 200.0 * (A(J + 1) + 200.0 * A(J + 2))
        W = 1.0
        IF (HM <= 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 * RGBL(8) / (A(1) * A(1))
          S = SQRT (U + U)
          DO K = 1, 7, 3
            V = G(K + 1) * S
            W = W + G(K) * SIN (V) * EXP (U * G(K+2)) / V
          END DO
          W = SQRT (W)
        END IF
        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) > 6.5) T = T * A(J + 8)
        F(I + 1) = U * T
        F(I + 2) = V * T
        IF (I >= 124) THEN
          WRITE (LA) F
          I = -2
        END IF
        I = I + 3
      END DO
      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
  370 LE = 0
      I  = LV
      DO WHILE (I <= LX - 8)
        I        = I + 8
        J        = INT (0.001 * A(I + 1)) * 5 + LJ
        A(I + 7) = (0.1 + A(J + 1))**2
      END DO
C * E-MAPS AND PEAKSEARCH
      IF (A(57) < 0.0) LX = LV
      RR = 0.1
      IF (MAX (A(5), A(6), A(7)) > 110.0) RR = 0.3
      NZ = INT (A(54))
      IF (NZ == 6) NZ = 4
      IF (NZ > 6)  NZ = 6
      LX = MIN (LX, LV)
      RR = 0.5
      LD = LX
      IF (NZ == 0) GO TO 500
      IF (ABS (A(57)) < 0.5) GO TO 500
      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 > NVDS) GO TO 500
      NL = 0
      NH = LZ + 8134
      CALL GEN074 (A, LZ, NH, 0.0)
      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
C * READ REFLECTIONS
  380 READ (LA) F
      I = - 2
  390 I = I + 3
      IF (I > 124) GO TO 380
      IF (ABS (F(I)) >= 0.5) THEN
        S = F(I + 1) * F(I + 1) + F(I + 2) * F(I + 2)
        IF (S < 1.E-10) GO TO 390
        U = SQRT (S)
        CALL GEN046 (F(I), X, Y, Z)
        EZ = 0.0
        L  = NA
C * LOCATING SCHEME
        DO 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)
     1      + Z * A(K + 7)))
          R = AINT (1.001 * (X * A(K + 2) + Y * A(K + 5)
     2      + Z * A(K + 8)))
          W = P + 200.0 * (Q + 200.0 * R)
          A(L + 7) = ABS (W)
          IF (ABS (W - F(I)) < 0.5) EZ = EZ + 1.0
          IF (ABS (W + F(I)) < 0.5 - A(23)) EZ = EZ + 1.0
          J = NA
  400     J = J + 4
          IF (J <= L) THEN
            IF (ABS (A(J + 3) - A(L + 7)) < 0.5) THEN
              CYCLE
            ELSE
              GO TO 400
            END IF
          END IF
          DO J = 1, MA
            A(L + 4) = P
            P        = Q
            Q        = R
            R        = A(L + 4)
          END DO
          IF (A(55) >= 0.0) THEN
            T = P
            P = Q
            Q = T
          END IF
          IF (ABS (Q) <= 63.5) THEN
            T = 127.0 * P + Q
            IF (ABS (T) <= 8134.5) THEN
              M = INT (ABS (T) + 0.001) + LZ
              L = L + 4
              IF (NF <= 1) THEN
                A(M) = 1.1
                CYCLE
              END IF
              A(L + 2) = 100.0 * (X * A(K + 9) + Y * A(K + 10)
     1                 + Z * A(K + 11))
              A(L + 1) = T
            END IF
          END IF
        END DO
        IF (NF == 1) GO TO 390
C * FOURIER TYPE
        R = 0.0
        P = F(I + 1)
        K = NA
        T = SQRT (EZ)
        Q = F(I + 2)
        Q = Q * T
        P = P * T
        DO
          K = K + 4
          IF (K > L) GO TO 390
          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
C * HX SUMS
          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 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
          END DO
        END DO
      END IF
C * ALLOCATE MEMORY
      CALL GEN108 (LA, 0)
      IF (NF == 1) THEN
        NF = 2
        M  = 0
        DO I = LZ, NH
          M = M + INT (A(I))
        END DO
        IF (M <= 0) THEN
          WRITE (LI, 99999, IOSTAT = IOST)
        ELSE
          NH = MIN (NX, ((NVDS - NS) / M - 1) / 2)
          IF (NH >= NX) THEN
            NH = NH + NH + 1
            IF (NH > 2) GO TO 430
          END IF
        END IF
        GO TO 500
  430   NL = NS + (NH * M)
        CALL GEN074 (A, NS, NL, 0.0)
        K = 0
        L = LZ + 8134
        DO I = LZ, L
          IF (A(I) >= 0.5) THEN
            A(I) = FLOAT (K)
            K    = K + 1
          END IF
        END DO
        GO TO 380
      END IF
C * INITIATE SCANS
      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 I = 1, 126
        G(I) = SIN (6.283185E-2 * FLOAT (I - 1))
      END DO
C * FOURIER SUMMATIONS
      MS = NS + 1
  440 Z  = 0.0
      W  = 63.5
      NK = NA + 2808
      CALL GEN074 (A, NA,  NK, 0.0)
      CALL GEN074 (F,  1, 106, 0.0)
      NK = MS
      DO I = NS, NL, NH
        IF (W <= A(I)) THEN
          K = INT (AMOD (Z * A(38), 100.0))
          L = INT (AMOD (Z * ZM, 100.0))
          N = NA
          DO J = 1, 53
            L = MOD (L, 100)
            W = G(L + 1)
            Z = G(L + 26)
C * CRITICAL LOOP
            DO M = 1, 53
              A(N) = A(N) + F(M) * Z + F(M + 53) * W
              N    = N + 1
            END DO
            L = L + K
          END DO
          IF (I == NL) GO TO 450
          Z = AINT (A(I) / 127.0 + 0.5) + 0.0001
          W = 127.0 * Z + 63.5
          CALL GEN074 (F, 1, 106, 0.0)
        END IF
        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
C * CRITICAL LOOP
        DO 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
        END DO
  450   NK = NK + NH
      END DO
      IF (NC >= 0) THEN
C * LOCATE MAXIMA
        Z = A(35)
        DO I = 53, 2703, 53
          Z = Z + A(38)
          Y = A(34)
          DO 490 K = 1, 51
            Y  = Y + A(37)
            NK = I + K
            M  = NK + NB
            IF (EZ > A(M)) EZ = A(M)
            P = A(M)
            IF (P * 1.2 < A(MP + 6)) GO TO 490
            IF (A(M - 1) > P) GO TO 490
            IF (A(M + 1) > P) GO TO 490
            IF (MAX (A(M - 54), A(M - 53), A(M - 52)) > P) GO TO 490
            IF (MAX (A(M + 52), A(M + 53), A(M + 54)) > P) GO TO 490
            L = NK + NC
            IF (MAX (A(L - 53), A(L - 1), A(L), A(L + 1),
     1          A(L + 53)) > P) GO TO 490
            N = NK + NA
            IF (MAX (A(N - 53), A(N - 1), A(N), A(N + 1),
     1          A(N + 53)) > P) GO TO 490
            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 > A(44)) A(44) = H
            IF (H < A(20)) GO TO 490
C * ELIMINATE EQUIVALENTS, FIND S.O.F.
            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) >= 0.0) THEN
              T = U
              U = V
              V = T
            END IF
            DO  NK = 1, MA
              T = W
              W = V
              V = U
              U = T
            END DO
            SK = 0.0
            XS = 0.0
            YS = 0.0
            ZS = 0.0
            CS = 1.0
            DO NK = 1, KP
              DO 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 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) <= RR) THEN
                    XS = XS + R + U
                    YS = YS + S + V
                    ZS = ZS + T + W
                    SK = SK + 1.0
                  END IF
  460             N  = N + 8
                  IF (N <= 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 < 0.0) THEN
                      GO TO 490
                    ELSE
                      GO TO 460
                    END IF
                  END IF
                END DO
              END DO
              CS = -1.0
            END DO
C * SORT PEAKS
            J  = LD + 8
            NK = J
  470       J  = J - 8
            IF (A(J + 6) < H) GO TO 470
  480       NK = NK - 8
            IF (J < NK) THEN
              N = NK + 7
              DO L = NK, N
                A(L + 8) = A(L)
              END DO
              GO TO 480
            END IF
            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)
  490     CONTINUE
        END DO
      END IF
C * RECYCLE
      NC = NB
      NB = NA
      NA = NA + 2809
      IF (NA > LZ + 8426) NA = LZ
      MS = MS + 2
      NG = NG + 1
      ZZ = ZZ + A(36)
      IF (NX /= NG) GO TO 440
      A(LX + 6) = TP
  500 IF (A(54) > 6.5) GO TO 10
C * WRITE PEAKS TO RESULTS FILE
      I = LV
      DO WHILE (I <= LD - 8)
        I = I + 8
        WRITE (LP, 99997, IOSTAT = IOST) A(I + 2), A(I + 3), A(I + 4)
      END DO
      WRITE (LP, 99998, IOSTAT = IOST) (HKLF(I), I = 1, 11)
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (/, ':: No Data for Fourier', ///)
99998 FORMAT ('HKLF ', 2F6.2, 9F7.3, /, 'END ', //)
99997 FORMAT ('Q000 1', 3F8.4)
      END SUBROUTINE PLA159
C STRIP_END
 
      MODULE lplat
      SAVE
      INTEGER, PARAMETER                   :: NP18 = 60
      INTEGER                              :: NRLT
      INTEGER                              :: NRLT0
      INTEGER                              :: NREXT
      INTEGER,          DIMENSION(12, 3)   :: NTL
      INTEGER,          DIMENSION(NP18)    :: LLAUE
      INTEGER,          DIMENSION(NP18, 3) :: NRVAL
      REAL                                 :: RMAX
      REAL                                 :: AVIOS
      REAL,             DIMENSION(12, 3)   :: RVL
      REAL,             DIMENSION(NP18, 3) :: RVAL
      REAL,             DIMENSION(9, NP18) :: TLATT
      REAL,             DIMENSION(7, NP18) :: XCELL
      CHARACTER(len=1), DIMENSION(NP18)    :: BLATT
      CHARACTER(len=1), DIMENSION(NP18)    :: CLATT
      CHARACTER(len=1), DIMENSION(NP18)    :: ELATT
      END MODULE lplat
 
      SUBROUTINE PLA160 (MODE, TM1)
C *******************************************************************
C *           ROUTINE FOR SPACE GROUP DETERMINATION BY THE          *
C *       DETECTION AND ANALYSIS OF SPACE GROUP EXTINCTIONS,        *
C *              LAUE AND METRICAL LATTICE SYMMETRY.                *
C *                                                                 *
C * THE ANALYSIS IS BASED ON THE DATA IN TABLE 3.2 (P 41) GIVEN I   *
C *    INTERNATIONAL TABLES FOR CRYSTALLOGRAPHY - VOL A, 198        *
C *                                                                 *
C *******************************************************************
C * LAUE =    1  - -1                                               *
C *      =    2  - 2/M                                              *
C *      =    3  - MMM                                              *
C *      =    4  - 4/M                                              *
C *      =    5  - 4/MMM                                            *
C *      =    6  - -3                                               *
C *      =    7  - -3M1                                             *
C *      =    8  - -31M                                             *
C *      =    9  - 6/M                                              *
C *      =   10  - 6/MMM                                            *
C *      =   11  - M-3                                              *
C *      =   12  - M-3M                                             *
C *******************************************************************
C * LAT0 =  ' '  - Subroutine asks for crystal family               *
C *      =  'a'  - Anorthic          CRYSTAL SYSTEM                 *
C *      =  'm'  - Monoclinic                                       *
C *      =  'o'  - Orthorhombic                                     *
C *      =  't'  - Tetragonal                                       *
C *      =  'h'  - Hexagonal                                        *
C *      =  'c'  - Cubic                                            *
C *******************************************************************
C * LAT1 =  LATTICE TYPE 1=P, 2=A, 3=B, 4=C, 5=F, 6=I, 7=R(obv)     *
C *******************************************************************
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE spgrdata
      USE reflex
      USE lplat
      USE dfspgr
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER    :: NZM = 200000
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: JH
      INTEGER               :: JK
      INTEGER               :: JL
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: KH
      INTEGER               :: KK
      INTEGER               :: KL
      INTEGER               :: IS
      INTEGER               :: IX
      INTEGER               :: NR
      INTEGER               :: NZ
      INTEGER               :: NRF
      INTEGER               :: IAT
      INTEGER               :: IAB
      INTEGER               :: IAE
      INTEGER               :: MPK
      INTEGER               :: NZMX
      INTEGER               :: NXCT
      INTEGER               :: NATO
      INTEGER               :: IDUM
      INTEGER               :: HMAX
      INTEGER               :: KMAX
      INTEGER               :: LMAX
      INTEGER               :: LATT
      INTEGER               :: MODE
      INTEGER               :: LRET0
      INTEGER               :: IUNIT
      INTEGER               :: ISPR47
      INTEGER               :: GEN135
      INTEGER               :: IAPPEND
      REAL                  :: SI
      REAL                  :: XI
      REAL                  :: DUM
      REAL                  :: FSC
      REAL                  :: STL
      REAL                  :: XISI
      REAL                  :: RSIG
      REAL                  :: RINT
      REAL                  :: STLM
      REAL                  :: ACAL
      REAL                  :: BCAL
      REAL                  :: CALI
      REAL                  :: ANZM
      REAL                  :: AVER
      REAL                  :: XANZ
      REAL                  :: UCINT
      REAL                  :: SIGIW
      REAL                  :: SCHAAL
      REAL                  :: ACALA
      REAL                  :: BCALA
      REAL                  :: ACALS
      REAL                  :: BCALS
      REAL                  :: ACALAF
      REAL                  :: BCALAF
      REAL                  :: GEN050
      REAL                  :: GEN095
      REAL, DIMENSION(3, 3) :: TM1
      REAL, DIMENSION(3, 3) :: TM2
      REAL, DIMENSION(107)  :: YPAR
      CHARACTER(len=1)      :: GEXT
      REAL, ALLOCATABLE, DIMENSION(:, :) :: TNZ
      ALLOCATE (TNZ(NZM, 10))
C * MODE = > 0 - FSPGR  (1, 2, 3)
C * MODE = < 0 - NEWSYM (-3)
C * INIT VARIABLES
      JH      = 0
      JK      = 0
      JL      = 0
      IND1    = 1
      IND2    = 2
      IND3    = 3
      HMAX    = 0
      STLM    = 0.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
C * SPGR-FROM-EXT CRITERIUM
      CRI(11) = PAR(141)
      IGBL(6) = 37
C * CHECK TO RUN IN X-DISPLAY MODE
      IWIN = IGBL(25) * IGBL(32)
C * FSPGR : DETERMINE SPACEGROUP FROM OBSERVED DATA
      IF (MODE > 0) THEN
C * RUN WILSON PLOT (FOR SPGRfromEX)
        IF (MODE == 3) CALL PLA370 (1)
C * COLLECT STATISTICS AND REFLECTION DATA ON SCRATCH FILE
        PAGET    = 'SPGRfrEx'
C * IGNORE BASF/TWIN
        IPR(193) = 0
        IPR(513) = 0
        IPR(48)  = 0
        IPR(255) = 0
        IPR(257) = 1
        RMAX     = PAR(430)
        CALL PLA262 (-2)
C * BEAM STOP OBSCURATION
        STLM = SIN (PAR(419) / RGBL(6)) / PAR(17)
        WRITE (LU7, 99985, IOSTAT = IOST) JID(1:9)
        WRITE (LU6, 99985, IOSTAT = IOST) JID(1:9)
C * NEWSYM : FIND SPACEGROUP (POSSIBLE HIGHER SYMMETRY) FROM FCALC
      ELSE IF (MODE < 0) THEN
        RMAX = PAR(429)
        IF (IWIN == 1) THEN
          BCD  = 'NewSym'//CHAR (0)
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA439 (0.0,  BCD, 7, 1.4, 4, 8, 9.6, VERT - 1.8)
          CALL PLA439 (0.0,  BCD, 7, 1.4, 2, 8, 9.4, VERT - 1.9)
          PRBUF = 'Calculate Structure Factors from Model Data'
          CALL PLA439 (0.0, PRBUF, 43, 0.5, 1, 1, 4.0, VERT - 4.0)
          CALL GGIP (0.0, 0.0, 0.0, 6)
          VRT = VERT - 8.5
          CALL GEN038 (PRBUF, 1, 80)
        END IF
        PAGET = 'NEWSYM'
        CALL PLA262 (0)
        STLM = 0.0
        WRITE (LU7, 99986, IOSTAT = IOST) PAR(248), JID(1:9)
        WRITE (LU6, 99986, IOSTAT = IOST) PAR(248), JID(1:9)
C * TOTAL NUMBER OF SYMMETRY OPERATIONS
        NSYM  = IPR(48)
C * GET NUMBER OF OPERATIONS EXCLUDING INVERSION AND BRAVAIS
        NSYMH = IPR(255)
C * GET CENTROSYMMETRY NUMBER
        ICNTR = IPR(257)
C * LOAD AND EXPAND COORDINATE DATA TO UNIT CELL CONTENTS
C * (EXCLUDING BRAVAIS CENTERING)
        CALL PLA023 (0)
        NATO = IPR(589)
        IF (NATO < 0) THEN
          WRITE (LU6, 99998, IOSTAT = IOST)
          GO TO 100
        END IF
C * CALCULATE MAXIMUM INDICES
        HMAX = INT (4 * PAR(101) / 3)
        KMAX = INT (4 * PAR(102) / 3)
        LMAX = INT (4 * PAR(103) / 3)
C * DETERMINE PACKING CONSTANTS AND ADRESSES
        MPH  = 2 * HMAX + 1
        MPK  = 2 * KMAX + 1
        MHK  = MPH * MPK
      END IF
C * MODE =  1 - DETERMINE TRMX (i.e. LATTICE TYPE)
C * MODE =  2 - GET SPACE GROUP FROM EXTINCTIONS GIVEN TRMX
C * MODE =  3 - BOTH
C * MODE = -3 - NEWSYM
C * MODE = 1, 3, -3
      IF (ABS (MODE) /= 2) THEN
C * INITIALIZE INTENSITY DISTRIBUTION STATISTICS
        CALL PLA169 (0, 0.0, 0.0, 0.0, LU6)
C * INITIALIZE SPACEGROUP DETERMINATION ROUTINE
        CALL PLA162 (0, 0, 0, 0, 0, 0.0, 0.0, IDUM)
      END IF
C * INITIALIZE NZ-TEST (ABS(MODE) > 1)
      IF (ABS (MODE) > 1) THEN
        CALL GEN097 (NNZ, 1, 10, 0)
        CALL GEN074 (ANZ, 1, 10, 0.0)
        CALL GEN074 (PNZ, 1, 13, 0.0)
C * PNZ(14, I) & PNZ(15,I) as data statements
C * (NON-CENTRO & CENTRO * DISTRIBUTION)
        DO I = 1, 10
          PNZ(12, I) = PNZ(14, I)
          PNZ(13, I) = PNZ(15, I)
        END DO
      END IF
C * OPEN INTERNAL REFLECTION SCRATCH FILE WITH TRANSFORMED INDICES
      INQUIRE (UNIT = LU8, OPENED = OPEND)
      IF (.NOT. OPEND) THEN
        OPEN (UNIT = LU8, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      ELSE
        REWIND (UNIT = LU8, IOSTAT = IOST)
      END IF
C * TEST FOR FSPGR/NEWSYM CASE
      IF (MODE == -3) GO TO 20
      WRITE (LU6, '(''TM1'',/, 3(3f10.3, /))') ((TM1(I, J),J=1,3),I=1,3)
C * RECEIVE HKLF TRANSFORMATION NATRIX INTO 3*3 TM2 MATRIX
      CALL GEN112 (TM2, PAR(231), 1)
      WRITE (LU6, '(''TM2'',/, 3(3f10.3, /))') ((TM2(I, J),J=1,3),I=1,3)
C * UPDATE HKLF TRANSFORMATION MATRIX TM2 FOR CELL TRANSFORMATION MATRIX TM1
      CALL GEN004 (TM1, TM2, TM2)
      WRITE (LU6, '(''TM2'',/, 3(3f10.3, /))') ((TM2(I, J),J=1,3),I=1,3)
C * CHECK FOR NON-UNIT TRANSFORMATION
      IUNIT = GEN135(TM2)
C * CHECK I(obs) MAXIMUM VALUE FOR SCALING
      SCHAAL = 100.0
      IEND   = -1
      NREF   = 0
      DO
        CALL PLA132 (JH, JK, JL, RINT, RSIG, SIGIW, CALI, UCINT, ACALS,
     1               BCALS)
C * TEST FOR INCONSISTENT CIF/FCF
        IF (IEND == 2) RETURN
        IF (IEND /= 1) THEN
          IF (RINT >= 999999.0) THEN
            SCHAAL = 1.0
            EXIT
          END IF
        ELSE
          EXIT
        END IF
      END DO
C * GET, SCALE, TRANSFORM REFLECTION DATA
      IEND  = -1
   10 CALL PLA132 (JH, JK, JL, RINT, RSIG, SIGIW, CALI, UCINT, ACALS,
     1             BCALS)
      IF (IEND > 0) GO TO 80
      IF (JH == 0 .AND. JK == 0 .AND. JL == 0) GO TO 80
C * HANDLE NON-UNIT TRANSFORMATION MATRIX
      IF (IUNIT /= 1) THEN
        IH = JH
        IK = JK
        IL = JL
C * TRANSFORM INPUT REFLECTION DATA ACCORDING TO CELL INPUT TRMX = TM2
C * E.G. SPGR 2 CASE
        IF (GEN050 (TM2, IH, IK, IL, JH, JK, JL) < 0.0) GO TO 10
      END IF
      IF (RSIG <= 0.0) RSIG = 0.5
      IX  = NINT (MAX (0.0, RINT * SCHAAL))
      IS  = NINT (RSIG * SCHAAL)
      STL = SQRT (GEN095 (PAR(191), JH, JK, JL))
      FSC = 1.0
C * ADD DATA TO STATISTICS ACCUMULATORS
      GO TO 60
C * GENERATE REFLECTION INDICES
   20 JH = - HMAX -1
   30 JH = JH + 1
      IF (JH > HMAX) THEN
        IF (IWIN == 1)
     1    CALL PLA439 (0.0, PRBUF, 20, 0.8, 0, 2, 7.0, VRT)
        GO TO 80
      END IF
      JK = - KMAX - 1
   40 JK = JK + 1
      IF (JK > KMAX) GO TO 30
      JL = - 1
   50 JL = JL + 1
      IF (JL > LMAX) GO TO 40
      IF (JH == 0 .AND. JK == 0 .AND. JL == 0) GO TO 50
C * SKIP LATTICE AND SPACE GROUP ABSENCES
      SGX(1)  = JH
      SGX(2)  = JK
      SGX(3)  = JL
      SGX(12) = 0.0
      CALL SGSM (27, LINE, SGX, 0, 0, IERR)
      IF (NINT (SGX(12)) /= 0) GO TO 50
      STL = SQRT (GEN095 (PAR(191), JH, JK, JL))
      FSC = 1.0
      IF (STL < PAR(248)) THEN
C * CALCULATE STRUCTURE FACTOR
        ACAL   = 0.0
        BCAL   = 0.0
        ACALA  = 0.0
        BCALA  = 0.0
        ACALAF = 0.0
        BCALAF = 0.0
        CALL PLA137 (JH, JK, JL, ACAL, BCAL, ACALA, BCALA,
     1    ACALAF, BCALAF, DUM)
        IX = MIN (999999999, NINT (100.0 * (ACAL**2 + BCAL**2)))
        IS = MAX (1, NINT (SQRT (FLOAT(IX))))
      ELSE
        GO TO 50
      END IF
C * ADD TO INTENSITY STATISTICS
  60  IF (MODE /= 2) CALL PLA169 (1, FLOAT (IX), FLOAT (IS), STL, LU6)
C * HANDLE BEAMSTOP OBSCURATION
      IF (STL > STLM) THEN
        XI = IX
        SI = IS
C * WRITE REFLECTION DATA TO SCRATCH FILE
        WRITE (LU8) JH, JK, JL, XI, SI, FSC, STL
        NREF = NREF + 1
C * DATA FOR N(Z)-TEST
        IF (ABS (MODE) > 1) THEN
          IF (JH /= 0 .AND. JK /= 0 .AND. JL /= 0) THEN
C * STORE IN 10 THETA-SHELL FOR NZ-TEST
            DO I = 1, 10
              IF (STL <= STLS(I)) THEN
                NNZ(I) = NNZ(I) + 1
                IF (NNZ(I) <= NZM) THEN
                  TNZ(NNZ(I), I) = XI
                  ANZ(I)         = ANZ(I) + XI
                ELSE IF (NNZ(I) == NZM) THEN
                  WRITE (LU6, 99987, IOSTAT = IOST)
C * CALL EXIT/STOP
                  CALL GEN127 (' ')
                END IF
                EXIT
              END IF
            END DO
          END IF
        END IF
        IF (MODE /= 2) THEN
          IF (SI > 0.0) THEN
            XISI = XI / SI
          ELSE
            XISI = 0.0
          END IF
          CALL PLA161 (0, JH, JK, JL, XISI, FSC)
        END IF
      END IF
      IF (MODE < 0) THEN
        IF (IWIN == 1) THEN
          IF (MOD (NREF, 1000) == 0) THEN
            CALL PLA439 (0.0, PRBUF, 20, 0.8, 0, 2, 7.0, VRT)
            WRITE (PRBUF, 99983, IOSTAT = IOST) NREF
            CALL PLA439 (0.0, PRBUF, 20, 0.8, 1, 2, 7.0, VRT)
            CALL GGIP (0.0, 0.0, 0.0, 6)
          END IF
        END IF
        GO TO 50
      END IF
      GO TO 10
C * ANALYSE RESULTS / DETERMINE POSSIBLE SPACE GROUPS
C * COLLECT DATA ON AND ANALYSE FOR EXTINCTIONS
C * MODE = 1 OR 3 (I.E. TRMX OR TRMX + SPGR ANALYSIS)
   80 IF (ABS (MODE) /= 2) THEN
C * CALCULATE INTENSITY DISTRIBUTION STATISTICS
        CALL PLA169 (-1, 0.0, 0.0, 0.0, LU6)
C * OUTPUT INTENSITY DISTRIBUTION STATISTICS AS FUNCTION OF SINTH/LAMBDA
        IF (IPR(210) /= -2) CALL PLA169 (-2, 0.0, 0.0, 0.0, 0)
C * GET (TRANSFORMED) INPUT DATA LATTICE TYPE FROM 3-D EXTINCTIONS
        CALL PLA162 (-1, 0, 0, 0, 0, 0.0, 0.0, NR)
        IF (NR > 0) THEN
          NXCT = 0
          GEXT = ' '
        ELSE
          NXCT = 1
          NR   = - NR
          IF (NR > 10) THEN
            NR = NR - 10
            GEXT = '?'
          ELSE
            GEXT = ' '
          END IF
        END IF
C * CONVERT REVERSE TO OBVERSE
        IF (NR == 8) THEN
          NR = 7
          DO I = 1, 3
            DO J = 1, 2
              TM1(I, J) = - TM1(I, J)
              TM2(I, J) = - TM2(I, J)
            END DO
          END DO
        END IF
C * RUN LEPAGE FOR LATTICE SYMMETRY DETERMINATION
C * INPUT  : - OCELL  = CELL (PAR(101) - PAR(106))
        IPR(94) = 2
        IAPPEND = 0
C * MAKE SHURE THAT 'P'-Lattice IS ALSO CONSIDERED FOR COMPLETENESS
        IF (MODE == 1 .AND. NR /= 1 .AND. NXCT /= 0) THEN
          CALL PLA164 (MODE, 0, LAT(1), TM1, PAR(383), ' ')
          IAPPEND = 1
        END IF
        CALL PLA164 (ABS(MODE), IAPPEND, LAT(NR), TM1, PAR(383), GEXT)
        LRET0  = 0
        ISPR47 = 0
        REWIND (UNIT = LU2, IOSTAT = IOST)
C * TEST FOR NON-S MODE
        IF (IPR(548) == 0 .AND. IWIN == 1) THEN
          CALL PLA262 (0)
          CALL PLA432 (LRET0, TM1, LU2, LU7, ISPR47, YPAR, 0)
        END IF
C * MODE = 2
      ELSE
C * GENERATE UNIT TRANSFORMATION MATRIX
        CALL GEN021 (TRMXS, 1.0)
        WRITE (LU2, 99999, IOSTAT = IOST)
     1    ((TM1(I, J), J = 1, 3), I = 1, 3), ILAT0
C * GET LAUE SYMMETRY DATA
        CALL PLA167
      END IF
C * NZ-TEST STATISTICS
      IF (ABS(MODE) > 1) THEN
        CALL GEN074 (AVNZ, 1, 3, 0.0)
        NZMX = 10
        ANZM = 0.0
        DO I = 1, NZMX
          IF (NNZ(I) > 0) THEN
            ANZ(I) = ANZ(I) / NNZ(I)
            ANZM   = MAX (ANZ(I), ANZM)
          ELSE
            NZMX   = I - 1
            EXIT
          END IF
        END DO
        DO I = 1, NZMX
          DO J = 1, 10
            XANZ = J * 0.1 * ANZ(I)
            NZ   = 0
            DO K = 1, NNZ(I)
              IF (K > NZM) THEN
                WRITE (LU6, 99987, IOSTAT = IOST)
C * CALL EXIT/STOP
                CALL GEN127 (' ')
              END IF
              IF (TNZ(K, I) <= XANZ) NZ = NZ + 1
            END DO
            PNZ(I, J) = FLOAT (NZ) * 100.0 / FLOAT (NNZ(I))
          END DO
        END DO
        IAE = MIN (6, NZMX)
        IAB = MIN (3, IAE)
        IAT = IAE - IAB + 1
        DO J = 1, 10
          AVER = 0
          IF (IAB > 0) THEN
            DO I = IAB, IAE
              AVER = AVER + PNZ(I, J)
            END DO
          END IF
          PNZ(11, J) = AVER / IAT
        END DO
C * LIST N(z) DISTRIBUTION RESULTS
        LU = LU6
        DO N = 1, 2
          IF (N == 2) THEN
            LU = LU7
            CALL PLA262 (0)
          END IF
          WRITE (LU, 99994, IOSTAT = IOST)
          IF (ANZM /= 0.0) THEN
            DO I = 1, 10
              WRITE (LU, 99993, IOSTAT = IOST) I,
     1          (PNZ(I, J), J = 1, 10), NNZ(I), ANZ(I) * 1000.0 / ANZM
            END DO
          END IF
C * ACTUAL AND THEORETICAL N(Z) CURVES
          WRITE (LU, 99996)
          WRITE (LU, 99992, IOSTAT = IOST)
     1      (0.1 * J, J = 1, 10), IAB, IAE, (PNZ(11, J), J = 1, 10),
     2      (PNZ(12, J), J = 1, 10), (PNZ(13, J), J = 1, 10)
C * NORMALIZE CURVES
          DO I = 11, 13
            DO J = 1, 10
              PNZ(I, J) = PNZ(I, J) - 0.1 * J * PNZ(I, 10)
            END DO
          END DO
          IF (N == 1) THEN
            DO I = 11, 13, 2
              DO J = 1, 10
                PNZ(I, J)    = PNZ(I, J)    - PNZ(12, J)
                AVNZ(I - 10) = AVNZ(I - 10) + PNZ(I, J)
              END DO
            END DO
            DO I = 1, 10
              PNZ(12, I) = 0.0
            END DO
            IPERC = MAX (0, MIN (100, NINT (100.0 * AVNZ(1) / AVNZ(3))))
          END IF
C * 'NORMALIZED' N(Z) CURVES
          WRITE (LU, 99991, IOSTAT = IOST) IPERC
          WRITE (LU, 99992, IOSTAT = IOST)
     1      (0.1 * J, J = 1, 10), IAB, IAE, (PNZ(11, J), J = 1, 10),
     2      (PNZ(12, J), J = 1, 10), (PNZ(13, J), J = 1, 10)
        END DO
      END IF
C * MODE = 2 & 3
      IF (ABS(MODE) > 1) THEN
        CALL PLA162 (0, 0, 0, 0, 0, 0.0, 0.0, IDUM)
C * GET DATA FROM SCRATCH BINARY REFLECTION FILE
        IF (ABS(MODE) == 3) THEN
          K = 0
          DO I = 1, 3
            DO J = 1, 3
              K = K + 1
              TRMXS (I, J) = TLATT (K, NRLT)
            END DO
          END DO
          LAUE  = NLAUE(LLAUE(NRLT))
          ILAT0 = CLATT(NRLT)
          ILAT1 = BLATT(NRLT)
        END IF
        CALL GEN108 (LU8, 0)
        CALL GEN004 (TM1, TRMXS, TRMXS)
        DO NRF = 1, NREF
          READ (LU8) KH, KK, KL, XI, SI, FSC, STL
          IF (GEN050 (TRMXS, KH, KK, KL, IH, IK, IL) >= 0.0) THEN
C * APPLY FRIEDEL SYMMETRY TO MAKE IL >= 0
            CALL GEN145 (IH, IK, IL)
            IF (SI > 0.0) THEN
              XISI = XI / SI
            ELSE
              XISI = 0.0
            END IF
            CALL PLA161 (1, IH, IK, IL, XISI, FSC)
          END IF
        END DO
C * COLLECT SPECIAL EXTINCTIONS
        CALL PLA162 (-2, 0, 0, 0, 0, 0.0, 0.0, LATT)
C * ANALYSE FOR SPACE GROUPS
        IF (IPR(548) == 0) THEN
          M = 2 + IWIN
        ELSE
          M = 2
        END IF
        DO N = 1, M
          IF (N == 1) THEN
            LU = LU6
          ELSE IF (N == 2) THEN
            LU = LU7
          ELSE
            LU = 0
          END IF
   90     WRITE (PRBUF, 99990, IOSTAT = IOST)
     1      ((TRMXS(I, J), J = 1, 3), I = 1, 3)
          IF (LU > 0) THEN
            IF (LU == LU7) CALL PLA262 (0)
            WRITE (LU, 99997, IOSTAT = IOST)
            WRITE (LU, 99995, IOSTAT = IOST)
            WRITE (LU, 99989, IOSTAT = IOST) PRBUF(1:80)
          ELSE
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT - 1.0
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 0.1, VRT)
          END IF
          WRITE (PRBUF, 99988, IOSTAT = IOST)
          IF (LU > 0) THEN
            WRITE (LU, 99984, IOSTAT = IOST) PRBUF(1:80)
          ELSE
            VRT = VRT - 1.0
            CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 0.1,
     1                   VRT)
          END IF
C * FIND OUT SPACE GROUP NAME FROM SYSTEMATIC ABSENCES
          CALL PLA168
          IF (LU == LU7) WRITE (LU2, 99982, IOSTAT = IOST)
     1      ISPGRC, ISPGRA, ISPGRH, IPCNTC, IPCNTA, IPCNTH
C * WHAT NEXT ?
C * CHECK FOR INTERACTIVE MODE
          IF (LU == 0) THEN
            CALL PLA015 (0, 39)
C * WHAT NEXT ?
            CALL PLA012 (2, 1)
            SELECT CASE (IGGT(1:4))
              CASE ('PLOT')
                GO TO 90
              CASE ('END ')
                IGBL(54) = IGBL(54) - 1
                CALL PLA280 ('RESTART')
                IGBL(6) = 10
                RETURN
              CASE ('!   ')
                IF (IPR(548) == 0) THEN
                  IGBL(54) = IGBL(54) - 1
                  CALL PLA280 ('RESTART')
                  IPR(6) = 10
                  RETURN
                END IF
            END SELECT
          END IF
        END DO
      END IF
  100 IF (IPR(2) == 0) IPR(2) = -1
      CLOSE (UNIT = LU8)
      IGBL(6) = 10
      DEALLOCATE (TNZ)
      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('='), /)
99996 FORMAT (/, 'Actual and Theoretical N(z) Curves', /,80('='))
99995 FORMAT (':: NOTE: Space Group Determination Pitfalls:', /,
     1  9X, 'Twinning, Pseudo-Symmetry, Mult.Refl.')
99994 FORMAT (/, 'N(z)-Test Statistics',
     1  ' (see: Howells et al. (1950) Acta Cryst. 3, 210)', /, 80('='))
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  /, 80('='))
99990 FORMAT ('Candidate Space Groups in (',
     1  3F5.2, '/', 3F5.2, '/', 3F5.2, ') Cell')
99989 FORMAT (/, A, /, 80('='), /)
99988 FORMAT ('Name      # AbsFreq', 2X,
     1  'StandSetting %R(sym) N(sym) %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', 6I5)
      END SUBROUTINE PLA160
 
      SUBROUTINE PLA161 (MODE, IH, IK, IL, XISI, FSC)
C * FSPGR/NEWSYM  (2)
      IMPLICIT NONE
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IDUM
      INTEGER :: MODE
      INTEGER :: MODRTWIN
      REAL    :: XISI
      REAL    :: FSC
C * FIRST CONSIDER GENERAL 3-D EXTINCTIONS
C * HKL:H+K=2N C OR F
      CALL PLA162 (1, IH, IK, IL, MOD(IH + IK, 2), XISI, FSC, IDUM)
C * HKL:H+L=2N B OR F
      CALL PLA162 (2, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC, IDUM)
C * HKL:K+L=2N A OR F
      CALL PLA162 (3, IH, IK, IL, MOD(IK + IL, 2), XISI, FSC, IDUM)
C * HKL:H+K+L=2N I
      CALL PLA162 (4, IH, IK, IL, MOD(IH + IK + IL, 2), XISI, FSC,
     1                IDUM)
C * HKL:-H+K+L=3N R(OBVERSE)
      CALL PLA162 (5, IH, IK, IL, MOD(- IH + IK + IL, 3), XISI,
     1                FSC, IDUM)
C * HKL:H-K+L=3N  R(REVERSE)
      CALL PLA162 (6, IH, IK, IL, MOD(IH - IK + IL, 3), XISI,
     1                FSC, IDUM)
C * CONSIDER PSEUDO-TRANSLATIONS IN A,B AND C DIRECTION
      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)
C * Obverse/Reverse twinning
      IF (MOD (-IH + IK + IL, 3) == 0 .OR.
     1    MOD ( IH - IK + IL, 3) == 0) THEN
        MODRTWIN = 0
      ELSE
        MODRTWIN = 1
      END IF
      CALL PLA162 (47, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MOD (IK, 2) == 0 .AND. MOD (IK + IL, 4) == 2) THEN
        MODRTWIN = 1
      ELSE
        MODRTWIN = 0
      END IF
      CALL PLA162 (48, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MOD (IH, 2) == 0 .AND. MOD (IH + IL, 4) == 2) THEN
        MODRTWIN = 1
      ELSE
        MODRTWIN = 0
      END IF
      CALL PLA162 (49, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MOD (IH, 2) == 0 .AND. MOD (IH + IK, 4) == 2) THEN
        MODRTWIN = 1
      ELSE
        MODRTWIN = 0
      END IF
      CALL PLA162 (50, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      CALL PLA162 (51, IH, IK, IL, MOD (IH + 2 * IL, 3), XISI,
     1  FSC, IDUM)
      CALL PLA162 (52, IH, IK, IL, MOD (IH + IK + IL, 3), XISI,
     1  FSC, IDUM)
      IF (MODE /= 0) THEN
C * CONSIDER THE 2-DIMENSIONAL PROJECTIONS
C * 0KL - TESTS
        IF (IH == 0) THEN
C * 0KL:K=2N
          CALL PLA162 (7, IH, IK, IL, MOD (IK, 2), XISI, FSC, IDUM)
C * 0KL:L=2N
          CALL PLA162 (8, IH, IK, IL, MOD (IL, 2), XISI, FSC, IDUM)
C * 0KL:K+L=2N
          CALL PLA162 (9, IH, IK, IL, MOD (IK + IL, 2), XISI, FSC,
     1                  IDUM)
C * 0KL:K+L=4N
          CALL PLA162 (19, IH, IK, IL, MOD (IK + IL, 4), XISI, FSC,
     1                  IDUM)
C * CONSIDER THE 1-D PROJECTIONS
C * 00L - TESTS
          IF (IK == 0) THEN
            CALL PLA162 (10, IH, IK, IL, 0, XISI, FSC, IDUM)
C * 00L:L=2N
            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)
C * 00L:L=4N
            CALL PLA162 (20, IH, IK, IL, MOD (IL, 4), XISI, FSC, IDUM)
            CALL PLA162 (24, IH, IK, IL, MOD (IL, 4), XISI, FSC, IDUM)
C * 00L:L=6N
            CALL PLA162 (31, IH, IK, IL, MOD (IL, 6), XISI, FSC, IDUM)
C * 00L:L=3N
            CALL PLA162 (39, IH, IK, IL, MOD (IL, 3), XISI, FSC, IDUM)
C * 0K0 - TESTS
          ELSE IF (IL == 0) THEN
C * 0K0:K=2N
            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)
C * 0K0:K=4N
            CALL PLA162 (21, IH, IK, IL, MOD (IK, 4), XISI, FSC, IDUM)
            CALL PLA162 (23, IH, IK, IL, MOD (IK, 4), XISI, FSC, IDUM)
          END IF
C * H0L - TESTS
        ELSE IF (IK == 0) THEN
C * H0L:H=2N
          CALL PLA162 (10, IH, IK, IL, MOD (IH, 2), XISI, FSC, IDUM)
C * H0L:L=2N
          CALL PLA162 (11, IH, IK, IL, MOD (IL, 2), XISI, FSC, IDUM)
C * H0L:H+L=2N
          CALL PLA162 (12, IH, IK, IL, MOD (IH + IL, 2), XISI, FSC,
     1                  IDUM)
C * H0L:H+L=4N
          CALL PLA162 (20, IH, IK, IL, MOD (IH + IL, 4), XISI, FSC,
     1                  IDUM)
C * H00 - TESTS
          IF (IL == 0) THEN
            CALL PLA162 (14, IH, IH, IL, 0, XISI, FSC, IDUM)
C * H00:H=2N
            CALL PLA162 (16, IH, IK, IL, MOD (IH, 2), XISI, FSC, IDUM)
C * H00:H=4N
            CALL PLA162 (22, IH, IK, IL, MOD (IH, 4), XISI, FSC, IDUM)
          END IF
C * HK0 - TESTS
        ELSE IF (IL == 0) THEN
C * HK0:H=2N
          CALL PLA162 (13, IH, IK, IL, MOD (IH, 2), XISI, FSC, IDUM)
C * HK0:K=2N
          CALL PLA162 (14, IH, IK, IL, MOD (IK, 2), XISI, FSC, IDUM)
C * HK0:H+K=2N
          CALL PLA162 (15, IH, IK, IL, MOD (IH + IK, 2), XISI, FSC,
     1                  IDUM)
C * HK0:H+K=4N
          CALL PLA162 (21, IH, IK, IL, MOD (IH + IK, 4), XISI, FSC,
     1                  IDUM)
C * HH0 -TEST
          IF (IH == IK) THEN
C * HH0:H=2N
            CALL PLA162 (32, IH, IK, IL, MOD (IH, 2), XISI, FSC, IDUM)
          END IF
C * HHL -TESTS
        ELSE IF (IH == IK) THEN
C * HHL:L=2N
          CALL PLA162 (25, IH, IK, IL, MOD (IL, 2), XISI, FSC, IDUM)
C * HHL:H=2N
          CALL PLA162 (26, IH, IK, IL, MOD (IH, 2), XISI, FSC, IDUM)
C * HHL:H+L=2N
          CALL PLA162 (27, IH, IK, IL, MOD (IH + IL, 2), XISI, FSC,
     1                  IDUM)
C * HHL:2H+L=4N
          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)
C * H-HL - TESTS
        ELSE IF (IH == -IK .AND. IH /= 0) THEN
C * H-HL:H+L=3N
          CALL PLA162 (29, IH, IK, IL, MOD (IH + IL, 3), XISI, FSC,
     1                  IDUM)
C * H-HL:-H+L=3N
          CALL PLA162 (30, IH, IK, IL, MOD (- IH + IL, 3), XISI,
     1                  FSC, IDUM)
C * H-HL: L=2N
          CALL PLA162 (33, IH, IK, IL, MOD (IL, 2), XISI, FSC, IDUM)
C * H-HL: H=2N
          CALL PLA162 (40, IH, IK, IL, MOD (IH, 2), XISI, FSC, IDUM)
C * H-2HL - TESTS
        ELSE IF (IK == -2 * IH .AND. IH /= 0) THEN
C * H-2HL: L=2N
          CALL PLA162 (35, IH, IK, IL, MOD (IL, 2), XISI, FSC, IDUM)
C * H-2HL: L=3N
          CALL PLA162 (37, IH, IK, IL, MOD (IL, 3), XISI, FSC, IDUM)
        ELSE IF (IH == - 2 * IK .AND. IH /= 0) THEN
C * -2HHL: L=2N
          CALL PLA162 (36, IH, IK, IL, MOD (IL, 2), XISI, FSC, IDUM)
C * -2HHL: L=3N
          CALL PLA162 (38, IH, IK, IL, MOD (IL, 3), XISI, FSC, IDUM)
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA161
 
      SUBROUTINE PLA162 (NEX, IH, IK, IL, MHKL, XISI, FSC, LATT)
C * SPGR/NEWSYM (3)
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE spgrdata
      USE dfspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      INTEGER            :: NEX
      INTEGER            :: NRSC
      INTEGER            :: NXCT
      INTEGER            :: MHKL
      INTEGER            :: LATT
      REAL               :: FSC
      REAL               :: XISI
      REAL               :: YUNK
      CHARACTER(len=132) :: PRBUF
      CHARACTER(len=3)   :: TYP0
C ******************************************************************C
C * TESTED EXTINCTION CONDITIONS                                    C
C *  1 : HKL:  H+K  =   2N   C      - centering                     C
C *  2 : HKL:  H+L  =   2N   B      - centering                     C
C *  3 : HKL:  K+L  =   2N   A      - centering                     C
C *  4 : HKL:  H+K+L=   2N   I      - centering                     C
C *  5 : HKL: -H+K+L=   3N   R(obv) - centering                     C
C *  6 : HKL:  H-K+L=   3N   R(rev) - centering                     C
C *  7 : 0KL:  K    =   2N   b-glide  perpendicular to a            C
C *  8 : 0KL:  L    =   2N   c-glide  perpendicular to a            C
C *  9 : 0KL:  K+L  =   2N   n-glide  perpendicular to a            C
C * 10 : H0L:  H    =   2N   a-glide  perpendicular to b            C
C * 11 : H0L:  L    =   2N   c-glide  perpendicular to b            C
C * 12 : H0L:  H+L  =   2N   n-glide  perpendicular to b            C
C * 13 : HK0:  H    =   2N   a-glide  perpendicular to c            C
C * 14 : HK0:  K    =   2N   b-glide  perpendicular to c            C
C * 15 : HK0:  H+K  =   2N   n-glide  perpendicular to c            C
C * 16 : H00:  H    =   2N   screw axis parallel to a               C
C * 17 : 0K0:  K    =   2N   screw axis parallel to b               C
C * 18 : 00L:  L    =   2N   screw axis parallel to c               C
C * 19 : 0KL:  K+L  =   4N                                          C
C * 20 : H0L:  H+L  =   4N                                          C
C * 21 : HK0:  H+K  =   4N                                          C
C * 22 : H00:  H    =   4N                                          C
C * 23 : 0K0:  K    =   4N                                          C
C * 24 : 00L:  L    =   4N                                          C
C * 25 : HHL:  L    =   2N                                          C
C * 26 : HHL:  H    =   2N                                          C
C * 27 : HHL:  H+L  =   2N                                          C
C * 28 : HHL: 2H+L  =   4N                                          C
C * 29 : H-HL: H+L  =   3N                                          C
C * 30 : H-HL:-H+L  =   3N                                          C
C * 31 : 00L:  L    =   6N                                          C
C * 32 : HH0:  H    =   2N                                          C
C * 33 : H-HL: L    =   2N                                          C
C * 34 : HHL : L    =   3N                                          C
C * 35 : H-2HL:L    =   2N                                          C
C * 36 : -2HHL:L    =   2N                                          C
C * 37 : H-2HL:L    =   3N                                          C
C * 38 : -2HHL:L    =   3N                                          C
C * 39 : 00L  :L    =   3N                                          C
C * 40 : H-HL :H    =   2N                                          C
C * 41 : HKL:  H    =   2N                                          C
C * 42 : HKL:  K    =   2N                                          C
C * 43 : HKL:  L    =   2N                                          C
C * 44 : HKL:  H    =   3N                                          C
C * 45 : HKL:  K    =   3N                                          C
C * 46 : HKL:  L    =   3N                                          C
C * 47 : HKL:  -HKL =   3N OR H-KL = 3N                             C
C * 48 : HKL:                                                       C
C * 49 : HKL:                                                       C
C * 50 : HKL:                                                       C
C * 51 : HKL:  H+2L =   3N                                          C
C * NEX  >  0 : ADD TO STATISTICS MODE
C *     ==  0 : INITIALIZE
C * NEX == -1 : LIST GENERAL EXTINCTIONS
C * NEX == -2 : LIST SPECIAL EXTINCTIONS
      IF (NEX > 0) THEN
        IF (MHKL == 0) THEN
          SUMZ(NEX, 1) = SUMZ(NEX, 1) + FSC * XISI
          SUMZ(NEX, 4) = SUMZ(NEX, 4) + FSC
          NUM(NEX, 1)  = NUM(NEX, 1) + 1
        ELSE
          SUMZ(NEX, 2) = SUMZ(NEX, 2) + FSC * XISI
          SUMZ(NEX, 5) = SUMZ(NEX, 5) + FSC
          NUM(NEX, 2)  = NUM(NEX, 2) + 1
          IF (XISI > XMFS(NEX)) THEN
C * AVOID FE - ORDER 4 REFLECTIONS (IF ANY)
            IF (IH /= 5 .AND. IK /= 5 .AND. IL /= 5) THEN
              XMFS(NEX)   = XISI
              NUM(NEX, 3) = IH
              NUM(NEX, 4) = IK
              NUM(NEX, 5) = IL
            END IF
          END IF
        END IF
      ELSE IF (NEX == 0) THEN
        DO I = 1, NCS
          XMFS(I) = 0.0
          DO J = 1, 5
            SUMZ(I, J) = 0.0
            NUM(I, J) = 0
          END DO
        END DO
        IPR(481) = 0
      ELSE IF (NEX < 0) THEN
        DO I = 1, NCS
          IF (NUM(I, 1) > 0) SUMZ(I, 1) = SUMZ(I, 1) / SUMZ(I, 4)
          IF (NUM(I, 2) > 0) SUMZ(I, 2) = SUMZ(I, 2) / SUMZ(I, 5)
          IF (SUMZ(I, 2) > 0.0) THEN
            SUMZ(I, 3) = MIN (SUMZ(I, 1) / SUMZ(I, 2), 999.0)
          ELSE
            IF (SUMZ(I, 1) > 1.0) THEN
              SUMZ(I, 3) = 999.0
            ELSE
              SUMZ(I, 3) = 0.0
            END IF
          END IF
          IF    ((SUMZ(I, 2) < CRI(1) .AND. SUMZ(I, 3) > CRI(2))
     1      .OR. (SUMZ(I, 2) < CRI(3) .AND. SUMZ(I, 3) > CRI(4))
     2      .OR. (SUMZ(I, 2) < CRI(5) .AND. SUMZ(I, 3) > CRI(6))
     3      .OR. (SUMZ(I, 2) < CRI(7) .AND. SUMZ(I, 3) > CRI(8))
     4      .OR. (SUMZ(I, 2) < CRI(9) .AND. SUMZ(I, 3) > CRI(10))
     5      .OR.  SUMZ(I, 3) > CRI(11)) THEN
            IF (XMFS(I) > 5.0) THEN
              EXT(I) = '?'
            ELSE
              EXT(I) = 'E'
            END IF
            EX(I)  = .TRUE.
          ELSE
            IF (SUMZ(I, 2) > 0.0 .AND. SUMZ(I, 2) < 1.5
     1        .AND. XMFS(I) < 3.0) THEN
              EXT(I) = '?'
              EX(I)  = .TRUE.
            ELSE
              IF (SUMZ(I, 3) > 2.0) THEN
                EXT(I) = '>'
              ELSE
                EXT(I) = ' '
              END IF
              EX(I)  = .FALSE.
            END IF
          END IF
        END DO
C * DETERMINE LATTICE CENTERING TYPE FROM EXTINCTIONS
C * F - LATTICE
        IF (EX(1) .AND. EX(2) .AND. EX(3)) THEN
          LATT = 5
          NXCT = NUM(1, 2) + NUM(2, 2) + NUM(3, 2)
          IF (EXT(1) /= 'E' .OR. EXT(2) /= 'E'
     1                        .OR. EXT(3) /= 'E') NXCT = - NXCT
C * R(obv) -LATTICE
        ELSE IF (EX(5)) THEN
          LATT = 7
          NXCT = NUM(5, 2)
          IF (EXT(5) /= 'E') NXCT = - NXCT
C * R(rev) -LATTICE
        ELSE IF (EX(6)) THEN
          LATT = 8
          NXCT = NUM(6, 2)
          IF (EXT(6) /= 'E') NXCT = - NXCT
C * I - LATTICE
        ELSE IF (EX(4)) THEN
          LATT = 6
          NXCT = NUM(4, 2)
          IF (EXT(4) /= 'E') NXCT = - NXCT
C * C - LATTICE
        ELSE IF (EX(1)) THEN
          LATT = 4
          NXCT = NUM(1, 2)
          IF (EXT(1) /= 'E') NXCT = - NXCT
C * B - LATTICE
        ELSE IF (EX(2)) THEN
          LATT = 3
          NXCT = NUM(2, 2)
          IF (EXT(2) /= 'E') NXCT = - NXCT
C * A - LATTICE
        ELSE IF (EX(3)) THEN
          LATT = 2
          NXCT = NUM(3, 2)
          IF (EXT(3) /= 'E') NXCT = - NXCT
C * P - LATTICE
        ELSE
          LATT = 1
          NXCT = 0
        END IF
        IF (NXCT > 0) THEN
          LATT = - LATT
        ELSE IF (NXCT < 0) THEN
          LATT = - LATT - 10
        END IF
C * OUTPUT EXTINCTION RESULTS
        IF (IPR(548) == 0) THEN
          M = 2 + IWIN
        ELSE
          M = 2
        END IF
        DO N = 1, M
          NRSC = 0
          IF (N == 1) THEN
            LU = LU6
          ELSE IF (N == 2) THEN
            LU = LU7
          ELSE
            LU = 0
          END IF
   10     IF (LU == 0) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT
          END IF
C * CHECK FOR BRAVAIS TYPE EXTINCTIONS
          IF (NEX == -1) THEN
            WRITE (PRBUF, 99994, IOSTAT = IOST)
            IF (LU > 0) THEN
              WRITE (LU, 99988, IOSTAT = IOST) PRBUF(1:80)
            ELSE
              VRT = VRT - 0.7
              CALL PLA439 (0.0, PRBUF, 80, 0.25, 1, 2, 1.0, VRT)
              VRT = VRT - 0.35
            END IF
C * CHECK FOR ALL EXTINCTIONS
          ELSE IF (NEX == -2) THEN
            WRITE (PRBUF, 99990, IOSTAT = IOST)
            IF (LU > 0) THEN
              IF (LU == LU7) CALL PLA262 (0)
              WRITE (LU, 99989, IOSTAT = IOST) PRBUF(1:80)
              IF (LU == LU7) CALL PLA262 (6)
            END IF
          END IF
          YUNK = NUM(1, 1) + NUM(1, 2)
          IF (YUNK /= 0.0) THEN
            PAR(428) = (SUMZ(1, 1) * NUM(1, 1) + SUMZ(1, 2) * NUM(1, 2))
     1               / (NUM(1, 1) + NUM(1, 2))
          ELSE
            PAR(428) = 0.0
          END IF
          DO I = 1, NCS
            IF (NEX == -1) THEN
              IF (I > 6 .AND. I <= 40) CYCLE
              IF (I == 47) THEN
                IF (EXT(5) == 'E' .OR. EXT(6) == 'E') CYCLE
              END IF
            ELSE IF (NEX == -2) THEN
              IF (I > 52) CYCLE
            END IF
            IF (EXT(I) /= ' ') THEN
              TYP0 = EXTYPE(I)(14:16)
              NRSC = 1
            ELSE
              TYP0 = ' '
            END IF
C * LIST GENERAL EXTINCTIONS
            WRITE (PRBUF, 99999, IOSTAT = IOST)
            IF (I == 1) THEN
              IF (LU > 0) THEN
                WRITE (LU, 99992, IOSTAT = IOST) PRBUF(1:80)
                WRITE (LU, 99998, IOSTAT = IOST)
                WRITE (LU, 99997, IOSTAT = IOST)
              ELSE
                VRT = VRT - 0.45
                CALL PLA439 (0.0, PRBUF, 80, 0.25, 5 + IGBL(68), 2,
     1            1.0, VRT)
                VRT = VRT - 0.35
                WRITE (PRBUF, 99998, IOSTAT = IOST)
                CALL PLA439 (0.0, PRBUF, 80, 0.25, 5 + IGBL(68), 2,
     1            1.0, VRT)
              END IF
            END IF
            WRITE (PRBUF, 99996, IOSTAT = IOST)
     1        I, EXT(I), TYP0, EXTYPE(I)(1:13), SUMZ(I, 1), SUMZ(I, 2),
     2        NUM(I, 1), NUM(I, 2), XMFS(I), (NUM(I, J), J = 3, 5),
     3        SUMZ(I, 3)
            IF (LU > 0) THEN
              IF (LU == LU6) THEN
                IF (TYP0 /= ' ' .OR. (I >= 16 .AND. I <= 18)) THEN
                  IPR(481) = IPR(481) + 1
                  WRITE (LU6, 99992, IOSTAT = IOST) PRBUF(1:80)
                  WRITE (LU2, 99995, IOSTAT = IOST)
     1              EXT(I), TYP0, EXTYPE(I)(1:13), SUMZ(I, 1),
     2              SUMZ(I, 2), NUM(I, 1), NUM(I, 2), XMFS(I),
     3              (NUM(I, J), J = 3, 5), SUMZ(I, 3)
                END IF
              ELSE IF (LU == LU7) THEN
                CALL PLA262 (1)
                WRITE (LU7, 99992, IOSTAT = IOST) PRBUF(1:80)
              END IF
            ELSE
              VRT = VRT - 0.35
              CALL PLA439 (0.0, PRBUF, 80, 0.25, 1, 2, 1.0, VRT)
            END IF
          END DO
          IF (LU == 0) THEN
            VRT = VERT - 2.0
            CALL PLA439 (0.0, 'E = Extinction', 14, 0.35, 1, 2,
     1        HORS - 7.0, VRT)
            VRT = VRT - 0.6
            CALL PLA439 (0.0, '? = Likely Extinction', 21, 0.35, 1, 2,
     1        HORS - 7.0, VRT)
            VRT = VRT - 0.6
            CALL PLA439 (0.0, '> = Pseudo Extinction?', 22, 0.35, 1, 2,
     1        HORS - 7.0, VRT)
          END IF
          IF (LU > 0) THEN
            IF (NRSC == 0) WRITE (LU, 99993, IOSTAT = IOST)
            IF (NEX == -2) THEN
              IF (LU == LU7) CALL PLA262 (10)
              WRITE (LU, 99991, IOSTAT = IOST) (CRI(J), J = 1, 10)
            END IF
          ELSE
C * WHAT NEXT ?
            CALL PLA012 (2, 1)
            IF (IGGT(1:4) == 'PLOT') GO TO 10
          END IF
        END DO
      END IF
      RETURN
99999 FORMAT ('Nr     Ex. Condition    Aver(I/sig(I)) ',
     1 'Number of Refl', 2X, 'I/sigI', 5X, 'False?',' .T/F.')
99998 FORMAT (24X, '.True. .False. .True. .False. Max.False.',
     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')
99992 FORMAT (A)
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 or ? ',
     4 '(I/sigI-Max.F > 5.0) when', /,
     4 '     <I/Sig>(.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /,
     5 '.or. <I/Sig>(.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /,
     6 '.or. <I/Sig>(.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /,
     7 '.or. <I/Sig>(.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /,
     8 '.or. <I/Sig>(.F.) <',F5.1,' .and. Ratio(.T./.F.) >', F5.1, /)
99990 FORMAT ('Analysis of Systematic Absences')
99989 FORMAT (/, A, /, 31('='))
99988 FORMAT (/, A, /)
      END SUBROUTINE PLA162
 
      SUBROUTINE PLA163 (NAMEX)
C * SPGR/NEWSYM (4)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE lplat
      USE dfspgr
      USE latice
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: IL
      INTEGER               :: ID2
      INTEGER               :: ID3
      INTEGER               :: NZP
      INTEGER               :: NCOL
      INTEGER               :: IFRQ
      INTEGER               :: ISGNR
      INTEGER               :: NRAVER
      REAL                  :: RAVER
      REAL, DIMENSION(3, 3) :: YUNK
      CHARACTER(len=7)      :: NAMEX
      CHARACTER(len=7)      :: NAME1
      CHARACTER(len=5)      :: NAME2
C * SETUP SPACE GROUP DATA FOR NAME
      LINE = 'SPGR '//NAMEX
      CALL GEN038 (LINE, 13, 80)
      CALL SGSM (0,  LINE, FN, 0, 0, IERR)
C * GET SPACEGROUP INFO
      CALL SGSM (18, LINE, FN, 0, 0, IERR)
C * TRANSFORM TO STANDARD SETTINGS
      IF (NAMEX == 'Pa     ') THEN
        NAME1 = 'Pc'
        NAME2 = 'C-BA'
      ELSE IF (NAMEX == 'P2/a   ') THEN
        NAME1 = 'P2/c'
        NAME2 = 'C-BA'
      ELSE IF (NAMEX == 'P21/a  ') THEN
        NAME1 = 'P21/c'
        NAME2 = 'C-BA'
      ELSE IF (NAMEX == 'Pn     ') THEN
        NAME1 = 'Pc'
        NAME2 = 'A-B-N'
      ELSE IF (NAMEX == 'P2/n   ') THEN
        NAME1 = 'P2/c'
        NAME2 = 'A-B-N'
      ELSE IF (NAMEX == 'P21/n  ') THEN
        NAME1 = 'P21/c'
        NAME2 = 'A-B-N'
      ELSE IF (NAMEX == 'Pb-3   ') THEN
        NAME1 = 'Pa-3'
        NAME2 = 'BA-C'
      ELSE
        NAME1 = LINE(1:7)
        NAME2 = LINE(8:11)
      END IF
      IF (NAME2(1:3) == '   ') NAME2 = 'ABC  '
      CALL GEN020 (1, NAME2, 1, 5)
      IL  = NINT (FN(3))
      ID2 = NINT (FN(5))
      ID3 = 1
      IF (ID2 == 2) THEN
        NZP = IPERC
      ELSE
        NZP = 100 - IPERC
      END IF
      IF (LINE(71:72) == ' C') THEN
        LINE(71:77) = ' Chiral'
      ELSE
        LINE(71:77) = '       '
      END IF
      IF (IPR(548) == 0) THEN
        RAVER  = RVAL(NRLT, 1)
        NRAVER = NRVAL(NRLT, 3)
      ELSE
        RAVER  = RVL(IL, 1)
        NRAVER = NTL(IL, 3)
      END IF
      ISGNR = NINT (FN(1))
      READ (LINE(66:70), 99997) IFRQ
      WRITE (PRBUF, 99999, IOSTAT = IOST) IL, ID2, ID3, NAMEX, ISGNR,
     1  IFRQ, NAME1, NAME2, RAVER, NRAVER,
     2  NZP, LINE(71:77), LINE(14:14)
C * INFO TO GRAPHICS WINDOW
      IF (LU == 0) THEN
        VRT = VRT - 0.7
        IF (RVL(IL, 1) > RMAX) THEN
          NCOL = 2
        ELSE
          NCOL = 1
        END IF
        CALL PLA439 (0.0, PRBUF(13:80), 68, 0.35, NCOL, 2, 0.1, VRT)
        DO I = 2, 8
          IF (NAME2 == TRTYP(I)) THEN
            CALL GEN004 (TRDAT(1, 1, I), TRMXS, YUNK)
            WRITE (IDM , 99996) NAME1,
     1        ((YUNK(J, K), K = 1, 3), J = 1, 3)
            VRT = VRT - 0.5
            CALL PLA439 (0.0, IDM, 80, 0.35, NCOL, 2, 0.1, VRT)
          END IF
        END DO
 
C * INFO TO LU6 & LU7
      ELSE
        WRITE (LU, 99998, IOSTAT = IOST) PRBUF(13:80)
        IF (LU == LU7) THEN
          WRITE (LU2, 99998, IOSTAT = IOST) PRBUF(1:80)
C * CENTRIC
          IF (LINE(14:14) == 'C') THEN
            IF (RAVER < RAVERC) THEN
              IF (NZP > IPCNTC) THEN
                IF (IFRQ > IFRQC) THEN
                  ISPGRC = ISGNR
                  IFRQC  = IFRQ
                  RAVERC = RVL(IL, 1)
                  IPCNTC = NZP
                END IF
              END IF
            END IF
C * ACENTRIC
          ELSE
            IF (RAVER < RAVERA) THEN
              IF (NZP > IPCNTA) THEN
                IF (IFRQ > IFRQA) THEN
                  ISPGRA = ISGNR
                  IFRQA  = IFRQ
                  RAVERA = RVL(IL, 1)
                  IPCNTA = NZP
                END IF
              END IF
            END IF
C * CHIRAL TEST
            IF (LINE(71:72) == ' C') THEN
              IF (RAVER < RAVERH) THEN
                IF (NZP > IPCNTH) THEN
                  IF (IFRQ > IFRQH) THEN
                    ISPGRH = ISGNR
                    IFRQH  = IFRQ
                    RAVERH = RVL(IL, 1)
                    IPCNTH = NZP
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
      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)
99996 FORMAT (A, ' StandSetting in (', 3F5.2, '/', 3F5.2, '/',
     1        3F5.2, ') Cell')
      END SUBROUTINE PLA163
 
      MODULE lepage
      SAVE
      INTEGER                 :: IDET
      INTEGER                 :: NVEC
      REAL, DIMENSION(3, 3)   :: G
      REAL, DIMENSION(3)      :: T
      REAL, DIMENSION(3)      :: H
      REAL, DIMENSION(6)      :: TC
      REAL, DIMENSION(3, 3)   :: OR
      REAL, DIMENSION(3, 3)   :: TM
      REAL, DIMENSION(3, 5)   :: CL
      REAL, DIMENSION(3, 3)   :: TP
      REAL, DIMENSION(3, 3)   :: TG
      REAL, DIMENSION(3, 3)   :: TPQ
      REAL, DIMENSION(3, 3)   :: TPS
      REAL, DIMENSION(15, 23) :: AXES
      REAL, DIMENSION(3, 3)   :: ROTQ
      REAL, DIMENSION(7)      :: CELL
      REAL, DIMENSION(3, 3)   :: TRMXT
      REAL, DIMENSION(7)      :: OCELL
      REAL, DIMENSION(7)      :: RCELL
      END MODULE lepage
 
      Module lepage1
      SAVE
      REAL,             DIMENSION(1501, 11) :: TT
      REAL,             DIMENSION(3, 1501)  :: DHX
      CHARACTER(len=1), DIMENSION(3)        :: LATT
      CHARACTER(len=1)                      :: LAT0
      END MODULE lepage1
 
      SUBROUTINE PLA164 (IMODE, IAPPEND, OLATT, TM1, AXCRIT, GEXT)
C * ROUTINE TO DETERMINE THE METRICAL SYMMETRY OF A GIVEN LATTICE
      USE files
      USE parameters
      USE cchar
      USE xwdw
      USE cggt
      USE spgrdata
      USE lepage
      USE lepage1
      USE lplat
      USE dfspgr
      USE latice
 
      IMPLICIT NONE
      LOGICAL                    :: CHANGE
      INTEGER                    :: I
      INTEGER                    :: J
      INTEGER                    :: K
      INTEGER                    :: L
      INTEGER                    :: M
      INTEGER                    :: N
      INTEGER                    :: I1
      INTEGER                    :: I2
      INTEGER                    :: K1
      INTEGER                    :: DOT
      INTEGER                    :: NLP
      INTEGER                    :: NLPB
      INTEGER                    :: NLPE
      INTEGER                    :: NLPI
      INTEGER                    :: NTEL
      INTEGER                    :: IBEG
      INTEGER                    :: IEND
      INTEGER                    :: ISOL
      INTEGER                    :: ITEL
      INTEGER                    :: LUIM
      INTEGER                    :: IMODE
      INTEGER                    :: KEEPI
      INTEGER                    :: METRIC
      INTEGER                    :: IPR117
      INTEGER                    :: IAPPEND
      INTEGER, DIMENSION(10, 55) :: MS
      REAL                       :: DET
      REAL                       :: DKW
      REAL                       :: DIFF
      REAL                       :: MAXD
      REAL                       :: RVLX
      REAL                       :: TAND
      REAL                       :: XLNG
      REAL                       :: YUNK
      REAL                       :: RMAXM
      REAL                       :: AXCRIT
      REAL                       :: GEN045
      REAL,    DIMENSION(3)      :: V
      REAL,    DIMENSION(3, 3)   :: TM1
      REAL,    DIMENSION(3)      :: TAU
      REAL,    DIMENSION(3, 3)   :: ORT
      CHARACTER(len=1)           :: GEXT
      CHARACTER(len=1)           :: OLATT
C ***********************************************************************
C * G(3,3)     -  METRICAL MATRIX OF DIRECT CELL                        *
C * OR(3,3)    -  [T] = [OR] [U]; DIRECT SPACE ORTHOGONALISATION        *
C * ROTQ(3,3)  -  [TAU] = [ROT][H]; RECIPROCAL SPACE ORTHOGONALISATION  *
C *               (IN PROGRAM U AND H ARE IN(K,1-3) AND IN(J,1-3), RESP *
C * TM(3,3)    -  TABLE WITH TRANSFORMATION MATRICES IN CELL REDUCTION  *
C *            -  CENTERED TO PRIMITIVE CELL TRANSFORMATION             *
C * TP(3,3)    -  ACCUMALATED TRANSFORMATION                            *
C * TPS(3,3)   -  SAVED INPUT TO REDUCED CELL                           *
C ***********************************************************************
C * LATT(1) =  ORIGINAL LATTICE                                         *
C * LATT(2) =  REDUCED  LATTICE                                         *
C * LATT(3) =  CONVENTIONAL LATTICE                                     *
C ***********************************************************************
C * IMODE   = 0  - LEPAGE                                               *
C ***********************************************************************
      IWIN = IGBL(25) * IGBL(32)
      K1   = 1
      LUIM = 2
C * LEPAGE MODE
      IF (IMODE == 0) THEN
        LUIM = LUIM + IWIN
C * SPGR/NEWSYM MODE
      ELSE IF (IMODE > 0) THEN
        IF (IAPPEND == 0) THEN
          NRLT0 = 1
          NRLT  = 1
        ELSE
          NRLT0 = NRLT0 + 1
          IF (GEXT /= '?') NRLT  = NRLT  + 1
        END IF
        DO I = 1, 6
          XCELL(I, NRLT0) = PAR(100 + I)
        END DO
        XCELL(7, NRLT0) = GEN045 (PAR(101))
        DO I = 1, 9
          TLATT(I, NRLT0) = 0.0
        END DO
        TLATT (1, NRLT0) = 1.0
        TLATT (5, NRLT0) = 1.0
        TLATT (9, NRLT0) = 1.0
        BLATT(NRLT0)     = OLATT
        CLATT(NRLT0)     = 'a'
        ELATT(NRLT0)     = GEXT
        LLAUE(NRLT0)     = 1
        RVAL(NRLT0, 1)   = 0.0
        RVAL(NRLT0, 2)   = 0.0
        RVAL(NRLT0, 3)   = 0.0
      END IF
      NLPB = 0
      NLPE = 0
C * INITIALIZE DATA, START GRAPHICS
C * SET SUB/SUPER CELL LOOP RANGE
      IPR(117) = 4
   10 IPR117   = IPR(117)
      IF (IPR(117) == 1) THEN
        NLPB  = 72
        NLPE  = 127
      ELSE IF (IPR(117) == 2) THEN
        NLPB  = 72
        NLPE  = 92
      ELSE IF (IPR(117) == 3) THEN
        NLPB  = 72
        NLPE  = 79
      ELSE IF (IPR(117) == 4) THEN
        NLPB  = 16
        NLPE  = 16
      ELSE IF (IPR(117) == 5) THEN
        NLPB  = 16
        NLPE  = 23
      ELSE IF (IPR(117) == 6) THEN
        NLPB  = 16
        NLPE  = 36
      ELSE IF (IPR(117) == 7) THEN
        NLPB  = 16
        NLPE  = 71
      END IF
      DO NLPI = NLPB, NLPE
        NLP = NLPI
   20   CALL GEN101 (IPR(94), NVEC, DHX)
        CALL GEN074 (AXES, 1, 345, 0.0)
        CALL GEN074 (TT, 1, NVEC * 11, 0.0)
        IDET = 1
C * COPY FROM (TRANSFORMED) INPUT CELL
        DO I = 1, 6
          OCELL(I) = PAR(100 + I)
        END DO
C * ADD VOLUME
        OCELL(7) = GEN045 (OCELL)
        LATT(1)  = OLATT
C * FIND TRANSFORMATION MATRIX NUMBER CORRESPONDING WITH 'OLATT'
        L        = 0
        DO I = 1, 7
          IF (LAT(I) == OLATT) THEN
            L = I
            EXIT
          END IF
        END DO
C * LOAD TRANSFORMATION MATRIX FOR LATT/NR & SUB/SUPER
        DO J = 1, 3
          DO K = 1, 3
            TPS(J, K) = TRNSX(J, K, L)
            TPQ(J, K) = TRNSX(J, K, NLP)
          END DO
        END DO
        CALL GEN004 (TPQ, TPS, TP)
C * CALCULATE THE METRICAL TENSOR
        CALL GEN026 (1, G, OCELL)
C * TRANSFORM METRICAL MATRIX FOR INPUT CELL TO PRIMITIVE
        CALL GEN001 (1, TP, G, G)
C * FIND REDUCED CELL
        CALL PLA267 (G, TP, PAR(440))
        CALL GEN026 (-1, G, RCELL)
C * ADD VOLUME
        RCELL(7) = GEN045 (RCELL)
C * SAVE INPUT TO REDUCED CELL TRANSFORMATION MATRIX
        K = 0
        L = 0
        DO I = 1, 3
          DO J = 1, 3
            TPS(I, J) = TP(I, J)
            K = K + 1
            TLATT(K, NRLT0 + 1) = TP(I, J)
            IF (NRLT0 /= 0) THEN
              IF (TLATT(K, NRLT0 + 1) /= TLATT(K, NRLT0)) L = 1
            ELSE
              L = 1
            END IF
          END DO
        END DO
        BLATT(NRLT0 + 1)     = 'P'
        CLATT(NRLT0 + 1)     = 'a'
        ELATT(NRLT0 + 1)     = GEXT
        LLAUE(NRLT0 + 1)     = 1
        RVAL(NRLT0 + 1, 1)   = 0.0
        RVAL(NRLT0 + 1, 2)   = 0.0
        RVAL(NRLT0 + 1, 3)   = 0.0
        DO K = 1, 7
          XCELL(K, NRLT0 + 1) = RCELL(K)
        END DO
        IF (NRLT0 /= 0) THEN
          IF (BLATT(NRLT0 + 1) /= BLATT(NRLT0)) L = 1
        ELSE
          L = 1
        END IF
        NRLT0 = NRLT0 + L
        IF (GEXT /= '?') NRLT = NRLT0
C * CALCULATE ORTHOGONALISATION MATRICES  (=> [OR])
        CALL GEN044 (RCELL, OR, 1)
C * CALCULATE THE TRANSPOSE OF OR (=> [ORT])
        CALL GEN005 (OR, ORT)
C * CALCULATE THE INVERSE OF ORT (=> [ROTQ])
        CALL GEN003 (ORT, ROTQ, DET, 0)
C * TRANSFORM U, V, W TO ORTHOGONAL COORDINATES.
        DO K = 1, NVEC
          DO I = 1, 3
            V(I) = DHX(I, K)
          END DO
          CALL GEN002 (1, OR, V, T, XLNG)
          DKW = 0.0
          DO J = 1, 3
            TT(K, J)     = T(J)
            TT(K, J + 3) = T(J) * T(J)
            DKW          = DKW  + TT(K, J + 3)
          END DO
          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
        END DO
C * ORDER VECTOR LIST: SORT ON LENGTH:
C * BUBBLE SORT WITH SWAPPING OF THE SEQUENCE NUMBERS
C * SEQUENCE NUMBER IN TT(K, 11)!!
        DO
          CHANGE = .FALSE.
          DO K = 1, NVEC - 1
            IF (TT(NINT (TT(K, 11)), 10) .GT.
     1          TT(NINT (TT(K + 1, 11)), 10)) THEN
              CALL GEN018 (TT(K, 11), TT(K + 1, 11))
              CHANGE = .TRUE.
            END IF
          END DO
          IF (.NOT. CHANGE) EXIT
        END DO
C * LIST SHORTEST VECTORS
        IF (IMODE == 0) THEN
          CALL PLA262 (0)
          DO I = 1, 2
            IF (I == 1) THEN
              LU = LU6
            ELSE
              LU = LU7
            END IF
            WRITE (LU, 99996, IOSTAT = IOST) (RCELL(J), J = 1, 6),
     1        RCELL(7)
            WRITE (LU, 99993)
            DO N = 1, 18
              K = N + 18
              WRITE (LU, 99995, IOSTAT = IOST) N,
     1          (NINT (DHX(J, NINT (TT(N, 11)))), J = 1, 3),
     2          TT(NINT (TT(N, 11)), 10), K,
     3          (NINT (DHX(J, NINT (TT(K, 11)))), J = 1, 3),
     4          TT(NINT (TT(K, 11)), 10)
            END DO
            WRITE (LU, 99994, IOSTAT = IOST) 37,
     1        (NINT (DHX(J, NINT (TT(37, 11)))), J = 1, 3),
     2        TT(NINT (TT(37, 11)), 10)
          END DO
        END IF
        I = NVEC
C * FIND 2-FOLD AXES
        ITEL = 0
        MAXD = 0.0
        DO J = 1, NVEC
C * TRANSFORM H,K,L, TO ORTHOGONAL COORDINATES
          DO I = 1, 3
            V(I) = DHX(I, J)
          END DO
          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 K = 1, NVEC
            DOT = 0
            DO N = 1, 3
              DOT = DOT + ABS (NINT (DHX(N, J) * DHX(N, K)))
            END DO
            IF (DOT <= IPR(94) .AND. DOT > 0) THEN
              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) * RGBL(6)
              IF (TAND <= AXCRIT) THEN
C * HANDLE TOO MANY AXES CASE
                IF (ITEL == 15) THEN
C * FIRST RANK ACCORDING TO AXIAL LENGTH
                  CALL GEN122 (AXES, 8, ITEL)
C * AND RANK ACCORING TO TAND (ANGLE DEVIATION)
                  CALL GEN122 (AXES, 7, ITEL)
                  ITEL = 8
                END IF
                ITEL = ITEL + 1
                DO 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)
                END DO
                AXES(ITEL, 7) = TAND
                AXES(ITEL, 8) = TT(K, 10)
                AXES(ITEL, 9) = DOT
                IF (TAND > MAXD) MAXD = TAND
              END IF
            END IF
          END DO
        END DO
C * ANALYSE RESULTS IN TERMS OF LATTICE TYPE AND TRANSFORMATION
        IF (ITEL > IPR(514)) THEN
C * AVOID MORE THAN 9 AXES CASE; RANK ON ANGLE TAND
          CALL GEN122 (AXES, 7, ITEL)
          ITEL = IPR(514)
        END IF
C * LOOP
        METRIC = 0
        NTEL   = ITEL
        IBEG   = 1
        IEND   = 0
        ISOL   = 0
        KEEPI  = IGBL(106)
C * SORT ON TAND; THE LARGEST DELTAS ARE ELIMINATED IN THE NEXT PASSES
        CALL GEN122 (AXES, 7, ITEL)
        GO TO 40
C * SORT ON TAND; THE LARGEST DELTAS ARE ELIMINATED IN THE NEXT PASSES
   30   CALL GEN122 (AXES, 7, ITEL)
        IF (ITEL == 7) THEN
          ITEL = ITEL - 4
        ELSE
          ITEL = ITEL - 2
        END IF
C * RESTORE TRANSFORMATION MATRIX; INPUT TO REDUCED CELL
   40   DO I = 1, 3
          DO J = 1, 3
            TP(I, J) = TPS(I, J)
          END DO
        END DO
        IF (ITEL == -1) THEN
          ITEL = 0
        ELSE IF (ITEL == -2) THEN
          GO TO 80
        ELSE
C * SORT ON AXIAL LENGTH
          CALL GEN122 (AXES, 8, ITEL)
        END IF
C * ANALYSE RESULTS
C * AVOID EVEN NUMBER OF 2-AXES BY ELIMINATING THE 'WEAKEST' ONE
        IF (ITEL > 1 .AND. MOD (ITEL, 2) == 0) ITEL = ITEL - 1
        CALL PLA165 (ITEL, MAXD, AXCRIT, ISOL, LUIM, KEEPI, NLPB, NLPE,
     1    NLP)
        ISOL = 1
        IF (MAXD <= PAR(441) .AND. METRIC == 0 .AND. ISOL == 1)
     1     THEN
          METRIC = 1
          NTEL   = ITEL
C * SAVE ORDER OF AXES
          DO I = 1, 9
            AXES(I, 23) = I
          END DO
        END IF
C * CHECK FOR NON-METRICAL CASE
        IF (ITEL == 0 .OR. (METRIC /= 0 .AND. ISOL /= 0)) THEN
C * COPY RESULT TO OUTPUT PARAMETERS
          ILAT0 = LAT0
C * COPY MATRIX
          CALL GEN052 (TP, TRMXS)
C * CONCATENATE TRMX WITH INPUT TM1 AND REPORT RESULT
          CALL GEN004 (TRMXS, TM1, TRMXT)
          ILAT1 = LATT(3)
C * GET LAUE SYMMETRY DATA
          CALL PLA167
C * GENERATE LAUE GROUP RANGE
          SELECT CASE (ILAT0)
            CASE ('a')
              I1 = 1
              I2 = 1
            CASE ('m')
              I1 = 2
              I2 = 2
            CASE ('o')
              I1 = 3
              I2 = 3
            CASE ('t')
              I1 = 4
              I2 = 5
            CASE ('h')
              IF (ILAT1 == 'R') THEN
                I1 = 6
                I2 = 7
              ELSE
                I1 = 6
                I2 = 10
              END IF
            CASE DEFAULT
              I1 = 11
              I2 = 12
          END SELECT
          IF (IMODE == 3) THEN
            RVLX = 100.0
          ELSE
            RVLX = 0.0
          END IF
          DO 50 N = I2, I1, - 1
            RVLX = MIN (RVLX, RVL(N, 1))
            IF (IMODE /= 0) THEN
C * AVOID TRIVIAL TRANSFORMATIONS
              YUNK = ABS (CELL(4) - 90.0) + ABS (CELL(5) - 90.0) +
     1               ABS (CELL(6) - 90.0)
              IF (YUNK < 0.001) THEN
                YUNK = 0.0
                DO I = 1, 3
                  DO J = 1, 3
                    IF (I /= J) THEN
                      YUNK = YUNK + ABS (TRMXT(I, J))
                    END IF
                  END DO
                END DO
                IF (YUNK < 0.001) THEN
                  DO I = 1, 3
                    TRMXT(I, I) = ABS (TRMXT(I, I))
                  END DO
                END IF
              END IF
              WRITE (LU2, 99999, IOSTAT = IOST)
     1          ((TRMXT(I, J), J = 1, 3), I = 1, 3), ILAT0, ILAT1, N,
     2          (RVL(N, K), K = 1, 3), (NTL(N, K), K = 1, 3),
     3          (CELL(I), I = 1, 7), GEXT
C * DO CONSIDER ONLY LAUE GROUPS WITH RAVER < PAR(431)
              IF (RVL(N, 1) <= PAR(431)) THEN
                CLATT(NRLT0 + 1) = ILAT0
                BLATT(NRLT0 + 1) = ILAT1
                ELATT(NRLT0 + 1) = GEXT
                CALL GEN020 (-1, CLATT(NRLT0 + 1), 1, 1)
                CALL GEN020 ( 1, BLATT(NRLT0 + 1), 1, 1)
                LLAUE(NRLT0 + 1) = N
                DO I = 1, 3
                  RVAL(NRLT0 + 1, I)  = RVL(N, I)
                  NRVAL(NRLT0 + 1, I) = NTL(N, I)
                END DO
                DO I = 1, 7
                  XCELL(I, NRLT0 + 1) = CELL(I)
                END DO
                M = 0
                DO K = 1, 3
                  DO J = 1, 3
                    M = M + 1
                    TLATT(M, NRLT0 + 1) = TRMXT(K, J)
                  END DO
                END DO
                DO I = 1, NRLT0
                  DIFF = 0.0
                  DO M = 1, 9
                    DIFF = DIFF + ABS(TLATT(M, I) - TLATT(M, NRLT0 + 1))
                  END DO
                  IF (DIFF < 0.001) THEN
                    IF (CLATT(NRLT0 + 1) == CLATT(I)) THEN
                      IF (BLATT(NRLT0 + 1) == BLATT(I)) THEN
                        IF (LLAUE(NRLT0 + 1) == LLAUE(I)) THEN
                          DIFF = 0.0
                          DO J = 1, 7
                            DIFF = DIFF +
     1                      ABS (XCELL(J, I) - XCELL(J, NRLT0 + 1))
                          END DO
                          IF (DIFF < 0.01) THEN
                            DO J = 1, 3
                              RVAL(I, J)  = RVAL(NRLT0  + 1, J)
                              NRVAL(I, J) = NRVAL(NRLT0 + 1, J)
                            END DO
                            GO TO 50
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END DO
                NRLT0 = NRLT0 + 1
                IF (RVAL(NRLT0, 1) < RMAX) THEN
C * CHECK FOR STANDARD TRICLINIC SETTING
                  IF (K1 == 1) THEN
                    IF (BLATT(NRLT0) == 'P' .AND.
     1                  CLATT(NRLT0) == 'a') THEN
                      IF (ELATT(NRLT0) /= '?')  NRLT = NRLT0
                    END IF
                  END IF
                  IF (LLAUE(NRLT0) > K1) THEN
                    IF (ELATT(NRLT0) /= '?')  THEN
                      NRLT = NRLT0
                      K1   = LLAUE(NRLT0)
                    END IF
                  END IF
                END IF
              END IF
            END IF
   50     CONTINUE
C * GENERATE METRICAL SUB-SYMMETRIES
          IF (IMODE == 0) THEN
            RMAXM = RMAX
          ELSE
            RMAXM = -1.0
          END IF
          IF ((IMODE == 1 .OR. RVLX > RMAXM) .AND. ITEL > 0) THEN
            IF (IMODE == 1 .AND. (IEND < IBEG .AND. ITEL == 1))
     1        THEN
              ITEL = 0
              GO TO 30
            END IF
            DO I = 1, NTEL
              AXES(I, 23) = MOD (AXES(I, 23), 1000.0)
            END DO
            CALL GEN122 (AXES, 23, NTEL)
C * MONOCLINIC SUBGROUPS
            IF (IEND == 0) THEN
              IF (NTEL > 1) THEN
                DO I = 1, NTEL
                  IEND = IEND + 1
                  MS(10, IEND) = 1
                  DO J = 1, 9
                    IF (J == I) THEN
                      MS(J, IEND) = 1
                    ELSE
                      MS(J, IEND) = 0
                    END IF
                  END DO
                END DO
              END IF
C * ANORTIC
              IEND = IEND + 1
              DO J = 1, 10
                MS(J, IEND) = 0
              END DO
            END IF
            IF (ILAT0 == 'c') THEN
C * LOOK FOR 4 AXIS PERPENDICULAR TO 4-FOLD AXIS
              DO J = 1, 3
                IEND         = IEND + 1
                MS(10, IEND) = 5
                DO I = 1, 9
                  IF (ABS (ABS (AXES(J, 13 + I)) - 90.0) < AXCRIT) THEN
                    MS(I, IEND) = 1
                  ELSE
                    MS(I, IEND) = 0
                  END IF
                END DO
                MS(J,  IEND) = 1
              END DO
C * RHOMBOHEDRAL
              V(1) = 1.0
              DO I = 1, 4
                IF (I > 2) THEN
                  V(2) = -1.0
                ELSE
                  V(2) = 1.0
                END IF
                IF (MOD (I, 2) == 0) THEN
                  V(3) = -1.0
                ELSE
                  V(3) = 1.0
                END IF
                IEND = IEND + 1
                MS(10, IEND) = 3
                DO J = 1, 9
                  DOT = 0
                  DO K = 1, 3
                    DOT = DOT + NINT (AXES(J, K) * V(K))
                  END DO
                  IF (DOT == 0) THEN
                    MS(J, IEND) = 1
                  ELSE
                    MS(J, IEND) = 0
                  END IF
                END DO
              END DO
            ELSE IF (ILAT0 == 'h') THEN
              IF (ILAT1 == 'P') THEN
C * GET ORTHORHOMBIC SUB-LATTICES
                DO J = 1, 7
                  IF (NINT (AXES(J, 13)) == 2) THEN
                    IEND         = IEND + 1
                    MS(10, IEND) = 3
                    DO I = 1, 7
                      IF (ABS (ABS (AXES(J, 13 + I)) - 90.0) < AXCRIT)
     1                 THEN
                        MS(I, IEND) = 1
                      ELSE
                        MS(I, IEND) = 0
                      END IF
                    END DO
                    MS(J, IEND) = 1
                  END IF
                END DO
              END IF
C * GET TETRAGONAL TO ORTHORHOMBIC SUB-LATTICE
            ELSE IF (ILAT0 == 't') THEN
              IEND = IEND + 1
              MS(10, IEND) = 3
C * SEARCH 4-axis
              DO I = 1, 9
                IF (NINT(AXES(I, 13)) == 4) THEN
                  MS(I, IEND) = 1
                  J = I
                ELSE
                  MS(I, IEND) = 0
                END IF
              END DO
              N = 1
              DO I = 1, 5
                IF (ABS (ABS (AXES(J, 13 + I)) - 90.0) < AXCRIT) THEN
                  N = N + 1
                  MS(I, IEND) = 1
                  IF (N == 3) GO TO 60
                END IF
              END DO
            END IF
          END IF
   60     IF (IEND >= IBEG) THEN
C * ELIMINATE DUPLICATES
            IF (IBEG > 1) THEN
              DO 70 I = 1, IBEG - 1
                DO J = 1, 10
                  IF (MS(J, IBEG) /= MS(J, I)) GO TO 70
                END DO
                IBEG = IBEG + 1
                GO TO 80
   70         CONTINUE
            END IF
            DO I = 1, NTEL
              AXES(I, 23) = MOD (AXES(I, 23), 1000.0)
            END DO
            DO I = 1, NTEL
              IF (MS(I, IBEG) == 0) AXES(I, 23) = AXES(I, 23) + 1000.0
            END DO
            CALL GEN122 (AXES, 23, NTEL)
            ITEL = MS(10, IBEG)
            IBEG = IBEG + 1
            GO TO 40
          END IF
          IF (IEND > 0) ITEL = 1
        END IF
C * CHECK FOR X-WINDOW MODE
        IF (IWIN == 1 .AND. IMODE == 0) THEN
          IF (METRIC == 0 .OR. NLP < NLPE) THEN
            WRITE (SBCD, 99997, IOSTAT = IOST) CHAR (0)
          ELSE
            WRITE (SBCD, 99998, IOSTAT = IOST) CHAR (0)
          END IF
          CALL PLA015 (0, 39)
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          IF (IPR(117)  /= IPR117) GO TO 10
          IF (IGGT(1:4) == 'REST' .OR. IGGT(1:4) == 'PLOT') GO TO 20
          IF (IGGT(1:4) == 'EXIT') GO TO 80
          IF (IGGT(1:3) /= 'END')  THEN
            IF (IGGT(1:1) == '!' .OR. IGGT(1:4) == 'NEXT') THEN
              IF (METRIC == 0) GO TO 30
            END IF
          END IF
        END IF
      END DO
   80 IF (IMODE > 0) THEN
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'.trm',
     1    STATUS = 'UNKNOWN', FORM = 'UNFORMATTED')
C * NR EXTINCTIONS
        NREXT = IPR(481)
        AVIOS = PAR(428)
        WRITE (LU61) NRLT0, NRLT, NREXT, AVIOS, RMAX,
     1   RVL, NTL, TLATT, XCELL, LLAUE, RVAL, CLATT, BLATT, ELATT
        CLOSE (UNIT = LU61)
      END IF
      CALL GEN038 (IGGT, 1, 80)
      IGBL(6) = 10
      RETURN
99999 FORMAT ('TRMX ', 9F7.3, 1X, A, A, I3, ' =', /, 5X, 3F6.1, 3I8,
     1        ' = ', /, 5X, 3F10.4, 3F8.3, F10.2, 1X, A)
99998 FORMAT ('[END]',  A)
99997 FORMAT ('[NEXT]', A)
99996 FORMAT ('REDUCED CELL:', 3F8.4, 3F8.3, F10.2, /)
99995 FORMAT (I3, 3I5, F10.4, 5X, I3, 3I5, F10.4)
99994 FORMAT (33X, I3, 3I5, F10.4)
99993 FORMAT ('Listing of Reduced Lattice Vectors with Indices |u|<=2',
     1        //, ' Nr', 4X, 'u', 4X, 'v', 4X, 'w', 3X, 'D (Ang)')
      END SUBROUTINE PLA164
 
      SUBROUTINE PLA165 (ITEL, MAXD, AXCRIT, ISOL, LUIM, KEEPI, NLPB,
     1  NLPE, NLP)
C * LEPAGE (2)
      USE files
      USE parameters
      USE cchar
      USE lepage
      USE lepage1
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: N
      INTEGER               :: I3
      INTEGER               :: J3
      INTEGER               :: K3
      INTEGER               :: LU
      INTEGER               :: LUI
      INTEGER               :: N90
      INTEGER               :: IOK
      INTEGER               :: NLP
      INTEGER               :: NUM
      INTEGER               :: LAT1
      INTEGER               :: MODL
      INTEGER               :: LOOP
      INTEGER               :: ITEL
      INTEGER               :: ISOL
      INTEGER               :: LUIM
      INTEGER               :: NLPB
      INTEGER               :: NLPE
      INTEGER               :: KEEPI
      REAL                  :: D1
      REAL                  :: D2
      REAL                  :: DET
      REAL                  :: ANG
      REAL                  :: DOT
      REAL                  :: DUM
      REAL                  :: YDUM
      REAL                  :: DETM
      REAL                  :: CRS1
      REAL                  :: CRS2
      REAL                  :: CRS3
      REAL                  :: ANGM
      REAL                  :: ZANG
      REAL                  :: YDUM1
      REAL                  :: YDUM2
      REAL                  :: ANGMN
      REAL                  :: MAXD
      REAL                  :: TMDUM
      REAL                  :: AXCRIT
      REAL                  :: GEN045
      REAL, DIMENSION(3, 3) :: BB
      REAL, DIMENSION(3, 3) :: DUM4
      REAL, DIMENSION(3, 3) :: YUNK
      CHARACTER(len=12)     :: SYST
      CHARACTER(len=10)     :: SYST0
      CHARACTER(len=4)      :: LINE14
      LATT(3) = 'P'
      MAXD    = 0.0
      ANGM    = 0.0
      ANGMN   = 0.0
C * CALCULATE INTERAXIAL ANGLES
      IF (ITEL > 0) THEN
C * CALCULATE INTERAXIAL ANGLES
        ANGM  = 0.0
        ANGMN = 180.0
        DO I = 1, ITEL
          IF (AXES(I, 7) > MAXD) MAXD = AXES(I, 7)
          AXES(I, 13) = 0.0
          DO J = 1, ITEL
            ANG = 0.0
            AXES(I, J + 13) = 0.0
            IF (I /= 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) < 0.00001) THEN
                ANG = 90.0
              ELSE IF (ANG >= 1.0) THEN
                ANG = 0
              ELSE
                ANG = ACOS (ANG) * RGBL(6)
                IF (ANG < 0.0)  ANG = ANG + 180.0
                IF (ANG < 90.0) ANG = 180.0 - ANG
              END IF
              IF (ANG > ANGM)   ANGM = ANG
              IF (ANG < ANGMN) ANGMN = ANG
              AXES(I, J + 13) = ANG
C * SEARCH 4- AND 6-AXES
              IF (ANG + AXCRIT > 90.0 .AND.
     1            ANG - AXCRIT < 90.0)
     2            AXES(I, 13) = AXES(I, 13) + 1
            END IF
          END DO
        END DO
      END IF
C * ANALYSIS OF THE RESULT
      IF (ITEL == 0) THEN
C * TRICLINIC
        SYST = 'Anorthic'
        CALL GEN021 (TM, 1.0)
      ELSE IF (ITEL == 1) THEN
C * MONOCLINIC
        SYST = 'Monoclinic'
C * MAKE THE 2-AXIS THE MONOCLINIC-B AXIS
        DO N = 1, 3
          TM(2, N) = AXES(ITEL, N)
        END DO
C * LOOK FOR TWO ADDITIONAL SHORTEST VECTORS PERPENDICULAR TO 2-AXIS.
        YDUM = COS ((90.0 - AXCRIT) / RGBL(6))
        D1   = 999.0
        D2   = 0.0
        DO 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) <= YDUM) THEN
            IF (TT(K, 10) >= D1) THEN
              IF (TT(K, 10) > D2) CYCLE
              I  = 3
              D2 = TT(K, 10)
            ELSE
              D2 = D1
              DO N = 1, 3
                TM(3, N) = TM(1, N)
                CL(3, N) = CL(1, N)
              END DO
              I  = 1
              D1 = TT(K, 10)
            END IF
            DO N = 1, 3
              TM(I, N) = DHX(N, K)
              CL(I, N) = TT(K, N)
            END DO
          END IF
        END DO
C * MAKE BETA > 90
        DUM = CL(1, 1) * CL(3, 1) + CL(1, 2) * CL(3, 2)
     1      + CL(1, 3) * CL(3, 3)
        IF (DUM > 0.0) THEN
          DO N = 1, 3
            TM(3, N) = - TM(3, N)
          END DO
        END IF
        CALL GEN003 (TM, BB, DET, 0)
        IF (DET <= 0) THEN
          DO N = 1, 3
            TM(2, N) = - TM(2, N)
          END DO
        END IF
      ELSE IF (ITEL == 3) THEN
C * RHOMBOHEDRAL/ORTHORHOMBIC
        SYST = 'Hexagonal   '
        IF (ANGM  > 120.0 + AXCRIT .OR.
     1      ANGMN < 120.0 - AXCRIT) THEN
C * ORTHORHOMBIC
          SYST = 'Orthorhombic'
          ZANG = 90
          GO TO 170
        END IF
C * RHOMBOHEDRAL
        DOT  = 0.0
        K    = 0
        DO I3 = 1, 3, 2
          K = K + 1
          DO J3 = 1, 3
            TM(K, J3) = AXES(I3, J3)
            CL(K, J3) = AXES(I3, J3 + 9)
            IF (K == 2) DOT = DOT + CL(1, J3) * CL(2, J3)
          END DO
        END DO
        IF (DOT > 0) THEN
          DO J3 = 1, 3
            TM(2, J3) = - TM(2, J3)
            CL(2, J3) = - CL(2, J3)
          END DO
        END IF
C * CALCULATE THIRD AXIS PERP TO 1 AND 2
        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 N = 1, 3
          TMDUM    = TM(3, N) * 3 / DET
          TM(3, N) = NINT (TMDUM)
        END DO
C * TEST FOR OBVERSE SETTING
        DO LOOP = 1, 2
C * ONLY ONCE THROUGH THE  LOOP; IF TWICE THEN EXIT!!
          MODL = 3
          H(1) = 2
          H(2) = 1
          H(3) = 1
          CALL GEN092 (MODL, H, TM, NUM)
          IF (NUM == 0) GO TO 230
          DO N = 1, 3
            TM(1, N) = - TM(1, N)
            TM(2, N) = - TM(2, N)
          END DO
        END DO
        GO TO 310
      ELSE IF (ITEL == 5) THEN
C * TETRAGONAL
        SYST = 'Tetragonal'
        ZANG = 90.0
        GO TO 170
      ELSE IF (ITEL == 7) THEN
C * HEXAGONAL
        SYST = 'Hexagonal'
        ZANG = 120.0
        GO TO 170
      ELSE IF (ITEL == 9) THEN
C * CUBIC
        SYST = 'Cubic'
        K3   = 0
        N90  = 4
C * LOAD THE THREE FOUR-FOLD AXES INDICES IN TM
        DO I3 = 1, 9
          IF (NINT(AXES(I3, 13)) == N90) THEN
            K3 = K3 + 1
            IF (K3 <= 3) THEN
              DO J3 = 1, 3
                TM(K3, J3) = AXES(I3, J3)
              END DO
            END IF
          END IF
        END DO
        IF (K3 /= 3) GO TO 310
      ELSE
        GO TO 320
      END IF
      GO TO 230
  170 N90 = ITEL - 1
      IOK = 0
      DO I = 1, ITEL
        IF (NINT (AXES(I, 13)) == N90) IOK = 1
      END DO
      IF (IOK == 0) GO TO 310
      YDUM1 = COS ((ZANG - AXCRIT) / RGBL(6))
      YDUM2 = COS ((ZANG + AXCRIT) / RGBL(6))
      K = 0
      DO I3 = 1, ITEL
        IF (NINT (AXES(I3, 13)) < 2) GO TO 310
        IF (ITEL <= 3) THEN
          K3 = I3
          GO TO 190
        END IF
        IF (NINT (AXES(I3, 13)) == N90) THEN
          K3 = 3
          GO TO 190
        END IF
        K = K + 1
        IF (K > 2) THEN
          K3 = 0
        ELSE
          K3 = K
        END IF
C * SAVE THE AXIAL INDICES
  190   IF (K3 > 0) THEN
          DO J3 = 1, 3
            TM(K3, J3) = AXES(I3, J3)
            CL(K3, J3) = AXES(I3, J3 + 9)
          END DO
        END IF
      END DO
      DUM = CL(1, 1) * CL(2, 1) + CL(1, 2) * CL(2, 2)
     1    + CL(1, 3) * CL(2, 3)
      IF (DUM > 0.0) THEN
        DO N = 1, 3
          TM(2, N) = - TM(2, N)
        END DO
        DUM = - DUM
      END IF
      IF ((DUM > YDUM1) .OR. (DUM < YDUM2)) GO TO 310
C * FIND LATTICE TYPE
  230 LAT0 = SYST(1:1)
      CALL GEN020 (-1, LAT0, 1, 1)
      CALL GEN003 (TM, BB, DET, 0)
      IF (DET < 0) THEN
        DO N = 1, 3
          TM(3, N) = - TM(3, N)
        END DO
      END IF
      IDET = NINT (ABS (DET))
      IF (IDET /= 2) THEN
        IF (IDET == 3) LATT(3) = 'R'
        IF (IDET == 4) LATT(3) = 'F'
      ELSE
C * TEST FOR A
        MODL = 2
        LATT(3) = 'A'
        H(1) = 0
        H(2) = 1
        H(3) = 1
        CALL GEN092 (MODL, H, TM, NUM)
        IF (NUM == 0) GO TO 250
C * TEST FOR B
        LATT(3) = 'B'
        H(1) = 1
        H(2) = 0
        H(3) = 1
        CALL GEN092 (MODL, H, TM, NUM)
        IF (NUM == 0) GO TO 250
C * TEST FOR C
        LATT(3) = 'C'
        H(1)    = 1
        H(2)    = 1
        H(3)    = 0
        CALL GEN092 (MODL, H, TM, NUM)
        IF (NUM == 0) GO TO 250
C * TEST FOR I
        LATT(3) = 'I'
        H(1)    = 1
        H(2)    = 1
        H(3)    = 1
        CALL GEN092 (MODL, H, TM, NUM)
        IF ((NUM /= 0) .OR. (IDET > 4)) THEN
          WRITE (LU6, 99988, IOSTAT = IOST)
          WRITE (LU7, 99988, IOSTAT = IOST)
C * CALL EXIT/STOP
          CALL GEN127 ('WRONG DETERMINANT!')
        END IF
      END IF
  250 IF ((ITEL < 3) .AND. (LATT(3) == 'A')) THEN
        DO N = 1, 3
          CALL GEN018 (TM(1, N), TM(3, N))
          TM(2, N) = - TM(2, N)
        END DO
        LATT(3) = 'C'
      END IF
      IF ((ITEL == 3) .AND. ((LATT(3) == 'A') .OR.
     1   (LATT(3) == 'B'))) THEN
        IF (LATT(3) == 'A') THEN
          DO N = 1, 3
            CALL GEN018 (TM(1, N), TM(3, N))
            CALL GEN018 (TM(1, N), TM(2, N))
          END DO
        ELSE
          DO N = 1, 3
            CALL GEN018 (TM(2, N), TM(3, N))
            TM(1, N) = - TM(1, N)
          END DO
        END IF
        LATT(3) = 'C'
      END IF
      CALL PLA166 (ITEL, LATT(1), AXCRIT, PAR(441), LUIM, NLPB, NLPE,
     1  NLP)
      CALL GEN004 (TM(1, 1), TP, YUNK)
      CALL GEN052 (YUNK, TP)
      IF (LAT0 == 'm') THEN
C * TRANSFORM MONOCLINIC A TO MONOCLINIC C
        IF (LATT(3) == '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'
C * TRANSFORM MONOCLINIC I TO MONOCLINIC C
        ELSE IF (LATT(3) == 'I' .AND. KEEPI == 0) 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'
        END IF
      END IF
      IF (LAT0 == 'c') THEN
        LAT1 = 7
      ELSE IF (LAT0 == 'h') THEN
        IF (LATT(3) == 'R') THEN
          LAT1 = 5
        ELSE
          LAT1 = 6
        END IF
      ELSE IF (LAT0 == 't') THEN
        LAT1 = 4
      ELSE IF (LAT0 == 'o') THEN
        LAT1 = 3
      ELSE IF (LAT0 == 'm') THEN
        LAT1 = 2
      ELSE
        LAT1 = 1
      END IF
C * ELIMINATE TRIVIAL TRANSFORMATIONS
      CALL GEN021 (DUM4, 1.0)
      CALL GEN104 (LAT1, TP, DUM4)
C * GET INVERS MATRIX IN TG
      CALL GEN003 (TP, TG, DETM, 0)
      SYST0 = 'Metrically'
      IF (MAXD > PAR(441)) SYST0 = 'Pseudo'
C * LOOPED RESULT LISTING ON LU6, LU7 AND OPTIONALLY ON DISPLAY
      DO LUI = 1, LUIM
        IF (LUI == 1) THEN
          LU = LU6
        ELSE IF (LUI == 2) THEN
          LU = LU7
        ELSE
          LU = 0
        END IF
        WRITE (LINE, 99999, IOSTAT = IOST)
        IF (LU /= 0) THEN
          WRITE (LU, 99989, IOSTAT = IOST)
          WRITE (LU, 99995, IOSTAT = IOST) LINE
          WRITE (LU, 99990, IOSTAT = IOST)
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 5.0)
        END IF
        WRITE (LINE, 99998, IOSTAT = IOST)
     1    (TP(1, J), J = 1, 3), (TG(J, 1), J = 1, 3), SYST0
        IF (LU /= 0) THEN
          WRITE (LU, 99995, IOSTAT = IOST) LINE
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 4.5)
        END IF
        WRITE (LINE, 99997, IOSTAT = IOST)
     1    (TP(2, J), J = 1, 3), (TG(J, 2), J = 1, 3), SYST
        IF (LU /= 0) THEN
          WRITE (LU, 99995, IOSTAT = IOST) LINE
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 4.0)
        END IF
        WRITE (LINE, 99996, IOSTAT = IOST)
     1    (TP(3, J), J = 1, 3), (TG(J, 3), J = 1, 3), MAXD
        IF (LU /= 0) THEN
          WRITE (LU, 99995, IOSTAT = IOST) LINE
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 3.5)
        END IF
      END DO
C * GET ORIGINAL METRIC
      CALL GEN026 (1, G, OCELL)
      CALL GEN001 (1, TP, G, G)
      CALL GEN026 (-1, G, CELL)
C * GET VOLUME
      CELL(7) = GEN045 (CELL)
C * DISPLAY/LIST INPUT/REDUCED/CONVENTIONAL CELL
      DO LUI = 1, LUIM
        IF (LUI == 1) THEN
          LU = LU6
        ELSE IF (LUI == 2) THEN
          LU = LU7
        ELSE
          LU = 0
        END IF
        WRITE (LINE, 99994, IOSTAT = IOST)
        IF (LU /= 0) THEN
          WRITE (LU, 99989, IOSTAT = IOST)
          WRITE (LU, 99995, IOSTAT = IOST) LINE
          WRITE (LU, 99990, IOSTAT = IOST)
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 2.5)
        END IF
        WRITE (LINE, 99993, IOSTAT = IOST)
     1    LATT(1), (OCELL(J), J = 1, 7)
        IF (LU /= 0) THEN
          WRITE (LU, 99995, IOSTAT = IOST) LINE
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 2.0)
        END IF
        WRITE (LINE, 99992, IOSTAT = IOST) (RCELL(I), I = 1, 7)
        IF (LU /= 0) THEN
          WRITE (LU, 99995, IOSTAT = IOST) LINE
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1.5)
        END IF
        IF (IPR(94) /= 2) LATT(3) = ' '
        WRITE (LINE, 99991, IOSTAT = IOST)
     1    LAT0, LATT(3), (CELL(J), J = 1, 7)
        IF (LU /= 0) THEN
          WRITE (LU, 99995, IOSTAT = IOST) LINE
        ELSE
          CALL PLA439 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1.0)
        END IF
      END DO
C * HANDLE SHELX OPTION
      IF (IPR(504) == 2 .AND. IABS (IGBL(8)) == 2) THEN
        OPEN (LU64, FILE = 'lepage_r.res', STATUS = 'UNKNOWN',
     1    IOSTAT = IOST)
        REWIND (UNIT = LU1, IOSTAT = IOST)
        DO
          READ (LU1, 99986, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          IF (LINE(1:3) == 'END') THEN
            WRITE (LU64, 99986) LINE
            EXIT
          END IF
          IF (LINE(1:4) == 'TITL') THEN
            WRITE (LU64, 99986) LINE
            WRITE (LU64, 99985) ((TP(I, J), J = 1, 3), I = 1, 3)
          ELSE
            WRITE (LU64, 99986) LINE
          END IF
        END DO
        CLOSE (UNIT = LU1,  IOSTAT = IOST)
        CLOSE (UNIT = LU64, IOSTAT = IOST)
C * RUN SPAWNED LEPAGE JOB
        CALL SPAWN
     1    (PLAPATH(1:IGBL(80))//' -g lepage_r.res', LU6, .true., KERR)
        OPEN (UNIT = LU64, FILE = 'lepage_r.res', STATUS = 'UNKNOWN',
     1    IOSTAT = IOST)
        CLOSE (UNIT = LU64, STATUS = 'DELETE', IOSTAT = IOST)
        OPEN (UNIT = LU64, FILE = 'lepage_r_pl.res',
     1    STATUS = 'UNKNOWN', IOSTAT = IOST)
        REWIND (UNIT = LU21, IOSTAT = IOST)
        IGBL(26) = 1
        DO
          READ (LU64, 99986, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          LINE14 = LINE(1:4)
          IF (LINE14 == 'DISP') CYCLE
          IF (LINE14 == 'AFIX') CYCLE
          IF (LINE14 == 'BOND') CYCLE
          IF (LINE14 == 'CONF') CYCLE
          IF (LINE14 == 'WGHT') CYCLE
          IF (LINE14 == 'ACTA') CYCLE
          IF (LINE14 == 'PLAN') CYCLE
          IF (LINE14 == 'FMAP') CYCLE
          IF (LINE14 == 'L.S.') CYCLE
          IF (LINE14 == 'END ') THEN
            WRITE (LU21, 99986) LINE
            EXIT
          END IF
          WRITE (LU21, 99986) LINE
        END DO
        WRITE (LU6, 99984) NAMEFIL(1:KNMFIL)//'_pl.res'
      END IF
      RETURN
C * DISPLAY/LIST TWO-FOLD AXES
  310 CALL PLA166 (ITEL, LATT(1), AXCRIT, PAR(441), LUIM, NLPB, NLPE,
     1  NLP)
      ISOL = 0
      RETURN
  320 WRITE (LU6, 99987, IOSTAT = IOST) ITEL
C * CALL EXIT/STOP
      CALL GEN127 (' 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)
99986 FORMAT (A)
99985 FORMAT ('TRMX', 9F7.4)
99984 FORMAT (/, ':: TRANSFORMED RES FILE ON: ', A)
      END SUBROUTINE PLA165
 
      SUBROUTINE PLA166 (ITEL, LATT, P2, P3, LUIM, NLPB, NLPE, NLP)
C * LEPAGE (3)
      USE files
      USE parameters
      USE cggt
      USE lepage
      USE latice
      USE cchar
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: LU
      INTEGER          :: NLP
      INTEGER          :: ITEL
      INTEGER          :: LUIM
      INTEGER          :: NLPB
      INTEGER          :: NLPE
      REAL             :: P2
      REAL             :: P3
      REAL             :: HORS
      REAL             :: VERT
      REAL             :: GEN084
      CHARACTER(len=1) :: LATT
      VERT = RGBL(1)
      HORS     = VERT * RGBL(2)
      DO L = 1, LUIM
        IF (L == 1) THEN
          LU = LU6
        ELSE IF (L == 2) THEN
          CALL PLA262 (0)
          LU = LU7
        ELSE
          LU = 0
          BCD = 'LePage'//CHAR (0)
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA439 (0.0,  BCD, 7, 1.4, 4, 8, 10.6, VERT - 1.8)
          CALL PLA439 (0.0,  BCD, 7, 1.4, 2, 8, 10.4, VERT - 1.9)
          IF (NLPE > NLPB) THEN
            WRITE (BCD, 99991, IOSTAT = IOST) NLP - NLPB + 1,
     1        ((TPQ(I, J), J = 1, 3), I = 1, 3), GEN084 (TRNSX, NLP)
            CALL PLA439 (0.0, BCD, 80, 0.35, 3, 2, 0.1, 6.0)
          END IF
C * DISPLAY DATA SET TITL
          CALL PLA439 (0.0, 'Data Set:'//JID, 50, 0.25, 1, 1, 0.1,
     1      VERT - 0.35)
        END IF
        WRITE (LINE, 99993, IOSTAT = IOST) IPR(94)
        IF (IGBL(106) == 1) THEN
          N = 80
        ELSE
          N = 40
        END IF
        IF (LU == 0) THEN
          CALL PLA439 (0.0, LINE, N, 0.35, 1, 2, 0.1, VERT - 2.5)
        END IF
        WRITE (LINE, 99999, IOSTAT = IOST) P2, P3, LATT
        IF (LU /= 0) THEN
          WRITE (LU, 99996, IOSTAT = IOST)
          WRITE (LU, 99992, IOSTAT = IOST) LINE
          WRITE (LU, 99995, IOSTAT = IOST)
        ELSE
          CALL PLA439 (0.0, LINE, 76, 0.4, 1, 2, 0.1, VERT - 3.5)
        END IF
        IF (ITEL > 0) THEN
          WRITE (LINE, 99998, IOSTAT = IOST)
          IF (LU /= 0) THEN
            WRITE (LU, 99992, IOSTAT = IOST) LINE
          ELSE
            CALL PLA439 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2,
     1                   0.1, VERT - 4.5)
          END IF
          WRITE (LINE, 99994, IOSTAT = IOST) (I, I = 1, 9)
          IF (LU /= 0) THEN
            WRITE (LU, 99992, IOSTAT = IOST) LINE
            WRITE (LU, 99995, IOSTAT = IOST)
          ELSE
            CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 0.1,
     1                   VERT - 5.0)
          END IF
          DO I = 1, ITEL
            WRITE (LINE, 99997, IOSTAT = IOST)
     1        I, AXES(I, 8), NINT (AXES(I, 13)),
     1            (NINT(AXES(I, K)), K = 1, 6), NINT (AXES(I, 9)),
     2            AXES(I, 7), (NINT (AXES(I, 13 + J)), J = 1, ITEL)
            IF (LU /= 0) THEN
              WRITE (LU, 99992, IOSTAT = IOST) LINE
            ELSE
              CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 0.1,
     1                     VERT - 5.1 - I * 0.5)
            END IF
          END DO
        END IF
      END DO
      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(I5))
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, 49X, 'Keep mI Mode')
99992 FORMAT (A)
99991 FORMAT ('TRANS:', I2, ' (', 3F6.2, ' /', 3F6.2, ' /',
     1         3F6.2, ') Det =', F5.2)
      END SUBROUTINE PLA166
 
      MODULE hklmx
      SAVE
      INTEGER :: IHM
      INTEGER :: IHKM
      INTEGER :: IHKP
      INTEGER :: HMAX
      INTEGER :: KMAX
      INTEGER :: LMAX
      END MODULE hklmx
 
      SUBROUTINE PLA167
C * DETERMINE LAUE AVERAGES (1)
      USE files
      USE parameters
      USE lplat
      USE dfspgr
      USE hklmx
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: I0
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: JH
      INTEGER               :: JK
      INTEGER               :: JL
      INTEGER               :: KH
      INTEGER               :: KK
      INTEGER               :: KL
      INTEGER               :: LH
      INTEGER               :: LK
      INTEGER               :: LL
      INTEGER               :: NL
      INTEGER               :: NLB
      INTEGER               :: NLE
      INTEGER               :: NRF
      INTEGER               :: IND
      INTEGER               :: IST1
      INTEGER               :: IST2
      INTEGER               :: ISET
      INTEGER               :: IR1M
      INTEGER               :: IR2M
      INTEGER               :: IR3M
      INTEGER               :: IRPM
      INTEGER               :: IHPK
      INTEGER               :: IHKLM
      REAL                  :: SI
      REAL                  :: XI
      REAL                  :: STL
      REAL                  :: DET
      REAL                  :: STLK
      REAL                  :: STLMX
      REAL                  :: GEN049
      REAL                  :: GEN050
      REAL                  :: GEN095
      REAL, DIMENSION(6)    :: V
      REAL, DIMENSION(3, 3) :: AA
      REAL, DIMENSION(3, 3) :: BB
      REAL, DIMENSION(3, 3) :: DUMV
      REAL, ALLOCATABLE, DIMENSION(:) :: RS
      ALLOCATE (RS(NVDL))
C * INIT
      LH  = 0
      LK  = 0
      LL  = 0
      IH  = 0
      IK  = 0
      IL  = 0
      NLB = 0
      NLE = 0
      DO I = 1, 12
        XTL(I) = 0.0
        XNM(I) = 0.0
        DO J = 1, 3
          RVL(I, J) = 0.0
          NTL(I, J) = 0
        END DO
      END DO
      STLMX = 0.0
C * LOOP THROUGH BINARY REFLECTION FILE TO DETERMINE TRANSFORMED INDEX MAXIMA
      HMAX = 0
      KMAX = 0
      LMAX = 0
      CALL GEN108 (LU8, 0)
      DO I = 1, NREF
        READ (LU8) KH, KK, KL, XI, SI, STL, STL
        IF (GEN050 (TRMXS, KH, KK, KL, LH, LK, LL) >= 0.0) THEN
          HMAX  = MAX (HMAX, IABS (LH))
          KMAX  = MAX (KMAX, IABS (LK))
          LMAX  = MAX (LMAX, IABS (LL))
          STLMX = MAX (STLMX, STL)
          IF (ILAT0 == 'h') THEN
            HMAX = MAX (HMAX, KMAX, IABS (LH + LK))
            KMAX = HMAX
          END IF
        END IF
      END DO
C * TETRAGONAL
      IF (ILAT0 == 't') THEN
        HMAX = MAX (HMAX, KMAX)
        KMAX = HMAX
C * CUBIC
      ELSE IF (ILAT0 == 'c') THEN
        HMAX = MAX (HMAX, KMAX, LMAX)
        KMAX = HMAX
        LMAX = HMAX
      END IF
C * CALCULATE LINEAR PACKING CONSTANTS : L * C1 + K * C2 + H
      IHM   =  2 * HMAX + 1
      IHKM  = (2 * KMAX + 1) * IHM
      IHKLM = (2 * LMAX + 1) * IHKM
      IHKP  = (IHKLM + 1) / 2
      IF (IHKLM > NVDL) THEN
        WRITE (LU6, 99989, IOSTAT = IOST) HMAX, KMAX, LMAX, IHKLM, NVDL
C * CALL EXIT/STOP
        CALL GEN127 ('FORCED ...')
      END IF
C * GET TRANSFORMED RECIPROCAL METRIC & RESET
      CALL GEN026 (1, AA, PAR(101))
C * APPLY AXES TRANSFORMATION
      CALL GEN001 (1, TRMXS, AA, DUMV)
      CALL GEN003 (DUMV, BB, DET, 0)
      CALL GEN025 (BB, V, 1)
 
      IF (ILAT0 == 'a') THEN
        NLB = 1
        NLE = 1
      ELSE IF (ILAT0 == 'm') THEN
        NLB = 2
        NLE = 2
      ELSE IF (ILAT0 == 'o') THEN
        NLB = 3
        NLE = 3
      ELSE IF (ILAT0 == 't') THEN
        NLB = 4
        NLE = 5
      ELSE IF (ILAT0 == 'h') THEN
        NLB = 6
        NLE = 10
      ELSE IF (ILAT0 == 'c') THEN
        NLB = 11
        NLE = 12
      END IF
C * LOOP OVER SELECTED LAUE GROUPS
      DO NL = NLB, NLE
C * LOOP THROUGH THE REFLECTION SPHERE TO SET DEFAULTS
        DO I = 1, IHKLM
          RS(I) = - 2.0
C * UNPACK HKL INTO H, K, L
          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 /= 0 .AND. JK /= 0 .AND. JL /= 0) THEN
C * CHECK FOR LATTICE EXTINCTIONS
            IF (GEN049 (ILAT1, JH, JK, JL) > 0.0) THEN
              STLK = GEN095 (V, JH, JK, JL)
              STL  = SQRT (STLK)
              IF (STL <= STLMX) RS(I) = - 1.0
            END IF
          END IF
        END DO
C * GET DATA FROM SCRATCH BINARY REFLECTION FILE
        CALL GEN108 (LU8, 0)
        DO NRF = 1, NREF
          READ (LU8) KH, KK, KL, XI, SI, STL, STL
          IF (GEN050 (TRMXS, KH, KK, KL, IH, IK, IL) > 0.0) THEN
              IND = IL * IHKM + IK * IHM + IH + IHKP
C * OBSERVED DATA ONLY
              IF (XI > 2.5 * SI) THEN
C * AVERAGE WITH PREVIOUS CONTENT
                IF (RS(IND) > - 0.5) THEN
                  RS(IND) = (RS(IND) + XI) / 2.0
                ELSE
                  RS(IND) = XI
                END IF
              ELSE
                RS(IND) = 0.0
              END IF
          END IF
        END DO
C * GET LAUE SYMMETRY
        DO I = 1, IHKLM
C * CHECK FOR POINT BEING WITHIN REFLECTION SPHERE
          IF (RS(I) > -1.5) THEN
C * STORE PACKED HKL
            INZ(1) = I
C * UNPACK HKL INTO H, K, L
            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
C * TRICLINIC
            IF (ILAT0 == 'a') THEN
              CALL PLA170 (RS, NL, 1, 1)
C * MONOCLINIC-B
            ELSE IF (ILAT0 == 'm') THEN
C * H,-K,L
              INZ(2) = ISET  - IR2M + IR(1)
C * LAUE 2/m
              CALL PLA170 (RS, NL, 1, 2)
C * ORTHORHOMBIC
            ELSE IF (ILAT0 == 'o') THEN
C * H,-K,L
              INZ(2) = ISET - IR2M + IR(1)
C * -H,K,L
              INZ(3) = ISET + IR2M - IR(1)
C * -H,-K,L
              INZ(4) = ISET - IR2M - IR(1)
C * LAUE mmm
              CALL PLA170 (RS, NL, 1, 4)
C * TETRAGONAL
            ELSE IF (ILAT0 == 't') THEN
C * -K,H,L
              INZ(2) = ISET + IR1M - IR(2)
C * -H,-K,L
              INZ(3) = ISET - IR2M - IR(1)
C * K,-H,L
              INZ(4) = ISET - IR1M + IR(2)
C * LAUE 4/mmm
              IF (NL == 5) THEN
C * -H,K,L
                INZ(5) = ISET + IR2M - IR(1)
C * K,H,L
                INZ(6) = ISET + IR1M + IR(2)
C * H,-K,L
                INZ(7) = ISET - IR2M + IR(1)
C * -K,-H,L
                INZ(8) = ISET - IR1M - IR(2)
                CALL PLA170 (RS, NL, 1, 8)
C * LAUE 4/m
              ELSE
                CALL PLA170 (RS, NL, 1, 4)
              END IF
C * HEXAGONAL LATTICE TYPE
            ELSE IF (ILAT0 == 'h') THEN
              IHPK = IR(1) + IR(2)
              IRPM = IHPK * IHM
C * TRIGONAL (HEXAGONAL SETTING)
              IF (NL < 9) THEN
C * K,-H-K,L
                INZ(2) = ISET - IRPM + IR(2)
C * -H-K,H,L
                INZ(3) = ISET + IR1M - IHPK
C * LAUE -3m1
                IF (NL == 7) THEN
C * -K,-H,L
                  INZ(4) = ISET - IR1M - IR(2)
C * H+K,-K,L
                  INZ(5) = ISET - IR2M + IHPK
C * -H,H+K,L
                  INZ(6) = ISET + IRPM - IR(1)
                  CALL PLA170 (RS, 7, 1, 6)
C * LAUE -31m
                ELSE IF (NL == 8) THEN
C * K,H,L
                  INZ(4) = ISET + IR1M + IR(2)
C * -H-K,K,L
                  INZ(5) = ISET + IR2M - IHPK
C * H,-H-K,L
                  INZ(6) = ISET - IRPM + IR(1)
                  CALL PLA170 (RS, 8, 1, 6)
C * LAUE -3
                ELSE
                  CALL PLA170 (RS, 6, 1, 3)
                END IF
C * HEXAGONAL
              ELSE
C * -K,H+K,L
                INZ(2) = ISET + IRPM - IR(2)
C * -H-K,H,L
                INZ(3) = ISET + IR1M - IHPK
C * -H,-K,L
                INZ(4) = ISET - IR2M - IR(1)
C * K,-H-K,L
                INZ(5) = ISET - IRPM + IR(2)
C * H+K,-H,L
                INZ(6) = ISET - IR1M + IHPK
C * LAUE 6/mmm
                IF (NL == 10) THEN
C * K,H,L
                  INZ(7)  = ISET + IR1M + IR(2)
C * H+K,-K,L
                  INZ(8)  = ISET - IR2M + IHPK
C * H,-H-K,L
                  INZ(9)  = ISET - IRPM + IR(1)
C * -K,-H,L
                  INZ(10) = ISET - IR1M - IR(2)
C * -H-K,K,L
                  INZ(11) = ISET + IR2M - IHPK
C * -H,H+K,L
                  INZ(12) = ISET + IRPM - IR(1)
                  CALL PLA170 (RS, NL, 1, 12)
C * LAUE P6/m
                ELSE
                  CALL PLA170 (RS, NL, 1, 6)
                END IF
              END IF
C * CUBIC
            ELSE IF (ILAT0 == 'c') THEN
              IST1 = IR(1) * IHKM + IHKP
              IST2 = IR(2) * IHKM + IHKP
              IR3M = IR(3) * IHM
C * LAUE M-3
C * H,-K,L
              INZ(2)  = ISET - IR2M + IR(1)
C * -H,K,L
              INZ(3)  = ISET + IR2M - IR(1)
C * -H,-K,L
              INZ(4)  = ISET - IR2M - IR(1)
C * K,L,H
              INZ(5)  = IST1 + IR3M + IR(2)
C * L,H,K
              INZ(6)  = IST2 + IR1M + IR(3)
C * -K,-L,H
              INZ(7)  = IST1 - IR3M - IR(2)
C * -L,-H,K
              INZ(8)  = IST2 - IR1M - IR(3)
C * -L,H,K
              INZ(9)  = IST2 + IR1M - IR(3)
C * K,-L,H
              INZ(10) = IST1 - IR3M + IR(2)
C * -K,L,H
              INZ(11) = IST1 + IR3M - IR(2)
C * L,-H,K
              INZ(12) = IST2 - IR1M + IR(3)
C * LAUE M-3M
              IF (NL == 12) THEN
C * K,H,L
                INZ(13) = ISET + IR1M + IR(2)
C * -K,H,L
                INZ(14) = ISET + IR1M - IR(2)
C * K,-H,L
                INZ(15) = ISET - IR1M + IR(2)
C * -K,-H,L
                INZ(16) = ISET - IR1M - IR(2)
C * L,K,H
                INZ(17) = IST1 + IR2M + IR(3)
C * H,L,K
                INZ(18) = IST2 + IR3M + IR(1)
C * -L,-K,H
                INZ(19) = IST1 - IR2M - IR(3)
C * -H,-L,K
                INZ(20) = IST2 - IR3M - IR(1)
C * H,-L,K
                INZ(21) = IST2 - IR3M + IR(1)
C * -L,K,H
                INZ(22) = IST1 + IR2M - IR(3)
C * L,-K,H
                INZ(23) = IST1 - IR2M + IR(3)
C * -H,L,K
                INZ(24) = IST2 + IR3M - IR(1)
C * LAUE M-3M
                CALL PLA170 (RS, NL, 1, 24)
              ELSE
C * LAUE M-3
                CALL PLA170 (RS, NL, 1, 12)
              END IF
            END IF
          END IF
        END DO
      END DO
C * AVERAGES & COUNTS
      DO J = 1, 12
        IF (XNM(J) > 0.0) THEN
          RVL(J, 1) = XTL(J) * 100.0 / XNM(J)
        END IF
        IF (NTL(J, 1) > 0) THEN
          RVL(J, 2) = 100.0 * NTL(J, 2) / NTL(J, 1)
        END IF
        IF (NTL(J, 2) > 0) THEN
          RVL(J, 3) = 100.0 * NTL(J, 3) / NTL(J, 2)
        END IF
      END DO
      DEALLOCATE (RS)
      RETURN
99989 FORMAT (':: Increase NVDL: hm, km, lm =', 3I5, /,
     1        ':: NVDL(needed/current)', 2I10)
      END SUBROUTINE PLA167
 
      SUBROUTINE PLA168
C * LAUE (2)
      USE parameters
      USE spgrdata
      USE lplat
      USE dfspgr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: NB
      INTEGER :: NE
      INTEGER :: IVAL
      IF (LAUE == NLAUE(13)) THEN
        IVAL = 13
        IF (ILAT1 == 'R') THEN
          NB = 6
          NE = 7
        ELSE
          NB = 1
          NE = 12
        END IF
        DO I = NB, NE
          IF (RVL(I, 1) > 0.0) THEN
            IF (IVAL == 13) THEN
              IVAL  = I
            ELSE IF (RVL(I, 1) < RMAX) THEN
              IVAL = I
            END IF
          END IF
        END DO
        LAUE = NLAUE(IVAL)
      END IF
C ********************************************************************
C * TRICLINIC : LAUE CLASS -1                                        *
C ********************************************************************
      IF (ILAT0 == 'a') THEN
C * CLASS: 1, -1
        IF (ILAT1 == 'P') THEN
          CALL PLA163 ('P1     ')
          CALL PLA163 ('P-1    ')
        ELSE IF (ILAT1 == 'A') THEN
          CALL PLA163 ('A1     ')
          CALL PLA163 ('A-1    ')
        ELSE IF (ILAT1 == 'B') THEN
          CALL PLA163 ('B1     ')
          CALL PLA163 ('B-1    ')
        ELSE IF (ILAT1 == 'C') THEN
          CALL PLA163 ('C1     ')
          CALL PLA163 ('C-1    ')
        ELSE IF (ILAT1 == 'I') THEN
          CALL PLA163 ('I1     ')
          CALL PLA163 ('I-1    ')
        ELSE IF (ILAT1 == 'F') THEN
          CALL PLA163 ('F1     ')
          CALL PLA163 ('F-1    ')
        ELSE IF (ILAT1 == 'R') THEN
          CALL PLA163 ('R1     ')
          CALL PLA163 ('R-1    ')
        END IF
C ********************************************************************
C * MONOCLINIC : B-UNIQUE  LAUE CLASS 1 2/M 1                        *
C ********************************************************************
      ELSE IF (ILAT0 == 'm') THEN
C * CLASS: 2, M, 2/M
C * I CENTERING
        IF (ILAT1 == 'I') THEN
C * a & c glide
          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   ')
          END IF
C * A CENTERING
        ELSE IF (ILAT1 == 'A') THEN
          IF (EX(10)) THEN
            CALL PLA163 ('Aa     ')
            CALL PLA163 ('A2/a   ')
          ELSE
            CALL PLA163 ('A2     ')
            CALL PLA163 ('Am     ')
            CALL PLA163 ('A2/m   ')
          END IF
C * C CENTERING
        ELSE IF (ILAT1 == 'C') THEN
C * c-glide
          IF (EX(11)) THEN
            CALL PLA163 ('Cc     ')
            CALL PLA163 ('C2/c   ')
          ELSE
            CALL PLA163 ('C2     ')
            CALL PLA163 ('Cm     ')
            CALL PLA163 ('C2/m   ')
          END IF
C * P CENTERING
        ELSE
C * n GLIDE
          IF (EX(12)) THEN
C * 21 screw 0k0
            IF (EX(17)) THEN
              CALL PLA163 ('P21/n  ')
C * PSEUDO ?
              IF (EXT(12) == '?') CALL PLA163 ('P21    ')
              IF (EXT(17) == '?') CALL PLA163 ('Pn     ')
            ELSE
              CALL PLA163 ('Pn     ')
              CALL PLA163 ('P2/n   ')
            END IF
C * N + A-GLIDE
            IF (EX(10)) THEN
              IF (EX(17)) THEN
                CALL PLA163 ('P21/a  ')
C * PSEUDO ?
                IF (EXT(17) == '?') CALL PLA163 ('Pa     ')
              ELSE
                CALL PLA163 ('Pa     ')
                CALL PLA163 ('P2/a   ')
              END IF
            END IF
C * N + C-GLIDE
            IF (EX(11)) THEN
              IF (EX(17)) THEN
                CALL PLA163 ('P21/c  ')
                IF (EXT(17) == '?') CALL PLA163 ('Pc     ')
              ELSE
                CALL PLA163 ('Pc     ')
                CALL PLA163 ('P2/c   ')
              END IF
            END IF
C * a GLIDE
          ELSE IF (EX(10)) THEN
C * 21 screw 0k0
            IF (EX(17)) THEN
              CALL PLA163 ('P21/a  ')
C * PSEUDO ?
              IF (EXT(10) == '?') CALL PLA163 ('P21    ')
              IF (EXT(17) == '?') CALL PLA163 ('Pa     ')
            ELSE
              CALL PLA163 ('Pa     ')
              CALL PLA163 ('P2/a   ')
            END IF
C * c GLIDE
          ELSE IF (EX(11)) THEN
C * 21 screw 0k0
            IF (EX(17)) THEN
              CALL PLA163 ('P21/c  ')
C * PSEUDO ?
              IF (EXT(11) == '?') CALL PLA163 ('P21    ')
              IF (EXT(17) == '?') CALL PLA163 ('Pc     ')
            ELSE
              CALL PLA163 ('Pc     ')
              CALL PLA163 ('P2/c   ')
            END IF
C * no GLIDE
          ELSE
C * 21 screw 0k0
            IF (EX(17)) THEN
              CALL PLA163 ('P21    ')
              CALL PLA163 ('P21/m  ')
            ELSE
              CALL PLA163 ('P2     ')
              CALL PLA163 ('Pm     ')
              CALL PLA163 ('P2/m   ')
            END IF
          END IF
        END IF
C ******************************************************************
C * ORTHORHOMBIC LAUE CLASS 3 = 2/m 2/m 2/m                        *
C ******************************************************************
      ELSE IF (ILAT0 == 'o') THEN
C * CLASS:  222, MM2, M2M, 2MM, MMM
C * F CENTERING
        IF (ILAT1 == 'F') THEN
          IF (EX(19) .AND. EX(20) .AND. EX(21)) THEN
            CALL PLA163 ('Fddd   ')
            IF (EXT(21) == '?') CALL PLA163 ('Fdd2   ')
            IF (EXT(20) == '?') CALL PLA163 ('Fd2d   ')
            IF (EXT(19) == '?') CALL PLA163 ('F2dd   ')
          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   ')
          END IF
C * I CENTERING
        ELSE IF (ILAT1 == 'I') THEN
C * 0kl
          IF (EX(7) .AND. EX(8)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Ibca   ')
              ELSE
                CALL PLA163 ('Iba2   ')
                CALL PLA163 ('Ibam   ')
              END IF
C * h0l
            ELSE IF (EX(12)) THEN
C * hk0
              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   ')
              END IF
            END IF
C * 0kl
          ELSE IF (EX(9)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('I2cb   ')
                CALL PLA163 ('Imcb   ')
C * h0k
              ELSE IF (EX(15)) THEN
                CALL PLA163 ('Ima2   ')
                CALL PLA163 ('I2cm   ')
                CALL PLA163 ('Imam   ')
                CALL PLA163 ('Imcm   ')
              END IF
C * h0l
            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   ')
              END IF
            END IF
          END IF
C * A CENTERING
        ELSE IF (ILAT1 == 'A') THEN
C * 0kl
          IF (EX(7) .AND. EX(8)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Abaa   ')
                CALL PLA163 ('Acaa   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Aba2   ')
                CALL PLA163 ('Acam   ')
              END IF
C * h0l
            ELSE IF (EX(11)) THEN
C * hk0
              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   ')
              END IF
            END IF
C * 0kl
          ELSE IF (EX(9)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('A2aa   ')
                CALL PLA163 ('Amaa   ')
C * hk0
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('A21am  ')
                CALL PLA163 ('Ama2   ')
                CALL PLA163 ('Amam   ')
              END IF
C * h0l
            ELSE IF (EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('A21ma  ')
                CALL PLA163 ('Am2a   ')
                CALL PLA163 ('Amma   ')
C * h0l
              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   ')
              END IF
            END IF
          END IF
C * B CENTERING
        ELSE IF (ILAT1 == 'B') THEN
C * 0kl
          IF (EX(7) .AND. EX(8)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Bbab   ')
                CALL PLA163 ('Bbcb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Bba2   ')
                CALL PLA163 ('Bbcm   ')
              END IF
C * h0l
            ELSE IF (EX(12)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Bb2b   ')
                CALL PLA163 ('Bbmb   ')
C * hk0
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Bb21m  ')
                CALL PLA163 ('Bbm2   ')
                CALL PLA163 ('Bbmm   ')
              END IF
            END IF
C * 0kl
          ELSE IF (EX(8)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('B2cb   ')
                CALL PLA163 ('Bmab   ')
C * hk0
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Bma2   ')
                CALL PLA163 ('B2cm   ')
                CALL PLA163 ('Bmam   ')
                CALL PLA163 ('Bmcm   ')
              END IF
C * h0l
            ELSE IF (EX(12)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Bm21b  ')
                CALL PLA163 ('Bmmb   ')
                CALL PLA163 ('B2mb   ')
              ELSE
C * 21 screw 0k0
                IF (EX(17)) THEN
                  CALL PLA163 ('B2212  ')
                ELSE
                  CALL PLA163 ('B222   ')
                  CALL PLA163 ('Bmm2   ')
                  CALL PLA163 ('B2mm   ')
                  CALL PLA163 ('Bm2m   ')
                  CALL PLA163 ('Bmmm   ')
                END IF
              END IF
            END IF
          END IF
C * C CENTERING
        ELSE IF (ILAT1 == 'C') THEN
C * 0kl
          IF (EX(7) .AND. EX(8)) THEN
C * h0l
            IF (EX(10) .AND. EX(11)) THEN
C * hk0
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Ccca   ')
                CALL PLA163 ('Cccb   ')
              ELSE
                CALL PLA163 ('Ccc2   ')
                CALL PLA163 ('Cccm   ')
              END IF
            ELSE
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Cc2a   ')
                CALL PLA163 ('Ccmb   ')
              ELSE
                CALL PLA163 ('Ccm21  ')
                CALL PLA163 ('Cc2m   ')
                CALL PLA163 ('Ccmm   ')
              END IF
            END IF
          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   ')
              END IF
            ELSE
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Cm2a   ')
                CALL PLA163 ('C2mb   ')
                CALL PLA163 ('Cmma   ')
                CALL PLA163 ('Cmmb   ')
              ELSE
C * 21 screw 00l
                IF (EX(18)) THEN
                  CALL PLA163 ('C2221  ')
                ELSE
                  CALL PLA163 ('C222   ')
                  CALL PLA163 ('Cm2m   ')
                  CALL PLA163 ('C2mm   ')
                  CALL PLA163 ('Cmm2   ')
                  CALL PLA163 ('Cmmm   ')
                END IF
              END IF
            END IF
          END IF
C * P CENTERING
        ELSE IF (ILAT1 == 'P') THEN
C * n GLIDE (0kl)
          IF (EX(9)) THEN
C * n glide (h0l)
            IF (EX(12)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pnnn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pnnb   ')
C * a glide
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pnna   ')
              ELSE
                CALL PLA163 ('Pnn2   ')
                CALL PLA163 ('Pnnm   ')
              END IF
            END IF
C * c glide (h0l)
            IF (EX(11)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pncn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pncb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pnca   ')
              ELSE
                CALL PLA163 ('Pnc2   ')
                CALL PLA163 ('Pncm   ')
              END IF
            END IF
C * a glide (h0l)
            IF (EX(10)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pnan   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pnab   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pnaa   ')
              ELSE
                CALL PLA163 ('Pna21  ')
                CALL PLA163 ('Pnam   ')
              END IF
            END IF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pn2n   ')
                CALL PLA163 ('Pnmn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pn2b   ')
                CALL PLA163 ('Pnmb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pn21a  ')
                CALL PLA163 ('Pnma   ')
              ELSE
                CALL PLA163 ('Pnm21  ')
                CALL PLA163 ('Pn21m  ')
                CALL PLA163 ('Pnmm   ')
              END IF
            END IF
C * c GLIDE (0kl)
          ELSE IF (EX(8)) THEN
C * n glide (h0l)
            IF (EX(12)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pcnn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pcnb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pcna   ')
              ELSE
                CALL PLA163 ('Pcn2   ')
                CALL PLA163 ('Pcnm   ')
              END IF
            END IF
C * c glide (h0l)
            IF (EX(11)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pccn   ')
                IF (EXT(11) == '?') CALL PLA163 ('Pc21n  ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pccb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pcca   ')
              ELSE
                CALL PLA163 ('Pcc2   ')
                CALL PLA163 ('Pccm   ')
              END IF
            END IF
C * a glide (h0l)
            IF (EX(10)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pcan   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pcab   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pcaa   ')
              ELSE
                CALL PLA163 ('Pca21  ')
                CALL PLA163 ('Pcam   ')
              END IF
            END IF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pc21n  ')
                CALL PLA163 ('Pcmn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pc21b  ')
                CALL PLA163 ('Pcmb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pc2a   ')
                CALL PLA163 ('Pcma   ')
              ELSE
                CALL PLA163 ('Pcm21  ')
                CALL PLA163 ('Pc2m   ')
                CALL PLA163 ('Pcmm   ')
              END IF
            END IF
C * b GLIDE(0kl)
          ELSE IF (EX(7)) THEN
C * n glide(h0l)
            IF (EX(12)) THEN
C * n glide(hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pbnn   ')
C * b glide(hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pbnb   ')
C * a glide(hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pbna   ')
              ELSE
                CALL PLA163 ('Pbn21  ')
                CALL PLA163 ('Pbnm   ')
              END IF
            END IF
C * c glide (h0l)
            IF (EX(11)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pbcn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pbcb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pbca   ')
              ELSE
                CALL PLA163 ('Pbc21  ')
                CALL PLA163 ('Pbcm   ')
              END IF
            END IF
C * a glide (h0l)
            IF (EX(10)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pban   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pbab   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pbaa   ')
              ELSE
                CALL PLA163 ('Pba2   ')
                CALL PLA163 ('Pbam   ')
              END IF
            END IF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('Pb2n   ')
                CALL PLA163 ('Pbmn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pb2b   ')
                CALL PLA163 ('Pbmb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pb21a  ')
                CALL PLA163 ('Pbma   ')
              ELSE
                CALL PLA163 ('Pb21m  ')
                CALL PLA163 ('Pbm2   ')
                CALL PLA163 ('Pbmm   ')
              END IF
            END IF
C * no GLIDE(a)
          ELSE
C * n GLIDE(h0l)
            IF (EX(12)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('P2nn   ')
                CALL PLA163 ('Pmnn   ')
C * b glide (hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('P21nb  ')
                CALL PLA163 ('Pmnb   ')
C * a glide (hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P2na   ')
                CALL PLA163 ('Pmna   ')
              ELSE
                CALL PLA163 ('Pmn21  ')
                CALL PLA163 ('P21nm  ')
                CALL PLA163 ('Pmnm   ')
              END IF
C * c GLIDE(h0l)
            ELSE IF (EX(11)) THEN
C * n glide (hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('P21cn  ')
                CALL PLA163 ('Pmcn   ')
C * b glide(hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('P2cb   ')
                CALL PLA163 ('Pmcb   ')
C * a glide(hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P21ca  ')
                CALL PLA163 ('Pmca   ')
              ELSE
                CALL PLA163 ('Pmc21  ')
                CALL PLA163 ('P2cm   ')
                CALL PLA163 ('Pmcm   ')
              END IF
C * a GLIDE(h0l)
            ELSE IF (EX(10)) THEN
C * n glide(hk0)
              IF (EX(15)) THEN
                CALL PLA163 ('P2an   ')
                CALL PLA163 ('Pman   ')
C * b glide(hk0)
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('P21ab  ')
                CALL PLA163 ('Pmab   ')
C * a glide(hk0)
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P2aa   ')
                CALL PLA163 ('Pmaa   ')
              ELSE
                CALL PLA163 ('P21am  ')
                CALL PLA163 ('Pma2   ')
                CALL PLA163 ('Pmam   ')
C * no GLIDE(b)
              END IF
            ELSE
C * n GLIDE(hk0)
              IF (EX(15)) THEN
                IF (.NOT. EX(18)) THEN
                  CALL PLA163 ('Pm21n  ')
                  CALL PLA163 ('P21mn  ')
                  CALL PLA163 ('Pmmn   ')
                END IF
C * b GLIDE(hk0)
              ELSE IF (EX(14)) THEN
                IF (.NOT. EX(18)) THEN
                  CALL PLA163 ('Pm21b  ')
                  CALL PLA163 ('P2mb   ')
                  CALL PLA163 ('Pmmb   ')
                END IF
C * a GLIDE(hk0)
              ELSE IF (EX(13)) THEN
                IF (.NOT. EX(18)) THEN
                  CALL PLA163 ('P21ma  ')
                  CALL PLA163 ('Pm2a   ')
                  CALL PLA163 ('Pmma   ')
                END IF
C * no GLIDE(c)
              ELSE
C * 21 screw h00
                IF (EX(16)) THEN
C * 21 screw 0k0
                  IF (EX(17)) THEN
C * 21 screw 00l
                    IF (EX(18)) THEN
                      CALL PLA163 ('P212121')
                      IF (EXT(16) == '?') CALL PLA163 ('P22121 ')
                      IF (EXT(17) == '?') CALL PLA163 ('P21221 ')
                      IF (EXT(18) == '?') CALL PLA163 ('P21212 ')
                      IF (EXT(16) == '?' .AND. EXT(17) == '?')
     1                    CALL PLA163 ('P2221  ')
                      IF (EXT(16) == '?' .AND. EXT(18) == '?')
     1                    CALL PLA163 ('P2212  ')
                      IF (EXT(17) == '?' .AND. EXT(18) == '?')
     1                    CALL PLA163 ('P2122  ')
                    ELSE
                      CALL PLA163 ('P21212 ')
                    END IF
                  ELSE
C * 21 screw 00l
                    IF (EX(18)) THEN
                      CALL PLA163 ('P21221 ')
                    ELSE
                      CALL PLA163 ('P2122  ')
                    END IF
                  END IF
                ELSE
C * 21 screw 0k0
                  IF (EX(17)) THEN
C * 21 screw 00l
                    IF (EX(18)) THEN
                      CALL PLA163 ('P22121 ')
                    ELSE
                      CALL PLA163 ('P2212  ')
                    END IF
                  ELSE
C * 21 screw 00l
                    IF (EX(18)) THEN
                      CALL PLA163 ('P2221  ')
                    ELSE
                      CALL PLA163 ('P222   ')
                      CALL PLA163 ('Pmm2   ')
                      CALL PLA163 ('Pm2m   ')
                      CALL PLA163 ('P2mm   ')
                      CALL PLA163 ('Pmmm   ')
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
C *********************************************************************
C * TETRAGONAL : LAUE CLASSES 4 = 4/M AND 5 = 4/M 2/M 2/M             *
C *********************************************************************
      ELSE IF (ILAT0 == 't') THEN
C * POINT GROUPS: 4, -4, 4/M, 422, 4MM, -42M, -4M2, 4/MMM
C * I CENTERING
        IF (ILAT1 == 'I') THEN
          IF (LAUE == '  4/m') THEN
            IF (EX(13) .AND. EX(14)) THEN
              CALL PLA163 ('I41/a  ')
            ELSE
C * 00L = L = 4N
              IF (EX(24)) THEN
                CALL PLA163 ('I41    ')
              ELSE
                CALL PLA163 ('I-4    ')
                CALL PLA163 ('I4     ')
                CALL PLA163 ('I4/m   ')
              END IF
            END IF
          ELSE IF (LAUE == '4/mmm') THEN
C * HK0 H,K
            IF (EX(13) .AND. EX(14)) THEN
              IF (EX(28)) THEN
C * 0KL H+L, (H0L H+L)
                IF (EX(9) .OR. EX(12)) THEN
                  CALL PLA163 ('I41/amd')
                ELSE
                  CALL PLA163 ('I41/acd')
                END IF
              END IF
            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 ')
                END IF
              ELSE
                IF (EX(28)) THEN
                  CALL PLA163 ('I41md  ')
                  CALL PLA163 ('I-42d  ')
                ELSE
C * 00L = L = 4N
                  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 ')
                  END IF
                END IF
              END IF
            END IF
          END IF
        ELSE IF (ILAT1 == 'P') THEN
C * P CENTERING
          IF (LAUE == '  4/m') THEN
C * n - glide
            IF (EX(15)) THEN
C * 42 screw 00l
              IF (EX(18)) THEN
                CALL PLA163 ('P42/n  ')
              ELSE
                CALL PLA163 ('P4/n   ')
              END IF
            ELSE
C * 00L = L = 4N
              IF (EX(24)) THEN
                CALL PLA163 ('P41    ')
                CALL PLA163 ('P43    ')
C * 42 screw 00l
              ELSE IF (EX(18)) THEN
                CALL PLA163 ('P42    ')
                CALL PLA163 ('P42/m  ')
              ELSE
                CALL PLA163 ('P-4    ')
                CALL PLA163 ('P4     ')
                CALL PLA163 ('P4/m   ')
              END IF
            END IF
          ELSE IF (LAUE == '4/mmm') THEN
C * hk0 - h+k = 2n
            IF (EX(15)) THEN
C * 0kl - k+l = 2n
              IF (EX(9)) THEN
C * hhl or h-hl - l = 2n
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P4/nnc ')
                ELSE
                  CALL PLA163 ('P42/nnm')
                END IF
C * 0kl - l = 2n
              ELSE IF (EX(8)) THEN
C * hhl or h-hl - l = 2n
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P4/ncc ')
                ELSE
                  CALL PLA163 ('P42/ncm')
                END IF
C * 0kl - k = 2n
              ELSE IF (EX(7)) THEN
C * hhl or h-hl - l = 2n
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P42/nbc')
                ELSE
                  CALL PLA163 ('P4/nbm ')
                END IF
              ELSE
C * hhl or h-hl - l = 2n
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P42/nmc')
                ELSE
                  CALL PLA163 ('P4/nmm ')
                END IF
              END IF
            ELSE
C * 0kl - k+l = 2n
              IF (EX(9)) THEN
C * hhl or h-hl - l = 2n
                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')
                END IF
C * 0kl - l = 2n
              ELSE IF (EX(8)) THEN
C * hhl or h-hl - l = 2n
                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')
                END IF
C * 0kl - k = 2n
              ELSE IF (EX(7)) THEN
C * hhl or h-hl - l = 2n
                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 ')
                END IF
              ELSE
C * hhl or h-hl - l = 2n
                IF (EX(25) .OR. EX(33)) THEN
C * 21 screw 0k0
                  IF (EX(17)) THEN
                    CALL PLA163 ('P-421c ')
                  ELSE
                    CALL PLA163 ('P42mc  ')
                    CALL PLA163 ('P-42c  ')
                    CALL PLA163 ('P42/mmc')
                  END IF
                ELSE
C * 00L = L = 4N
                  IF (EX(24)) THEN
C * 21 screw 0k0
                    IF (EX(17)) THEN
                      CALL PLA163 ('P41212 ')
                      CALL PLA163 ('P43212 ')
                    ELSE
                      CALL PLA163 ('P4122  ')
                      CALL PLA163 ('P4322  ')
                    END IF
C * 21 screw 00l
                  ELSE IF (EX(18)) THEN
C * 21 screw 0k0
                    IF (EX(17)) THEN
                      CALL PLA163 ('P42212 ')
                    ELSE
                      CALL PLA163 ('P4222  ')
                    END IF
                  ELSE
C * 21 screw 0k0
                    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 ')
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
C **********************************************************************
C * TRI/HEXAGONAL LAUE CLASSES 6=-3, 7=-3m1, 8=-31m, 9=6/m, 10=6/mmm   *
C **********************************************************************
      ELSE IF (ILAT0 == 'h') THEN
C * POINT GROUPS: 6    -6    6/m    622   6mm   -62m     6/mmm  -6m2
        IF (LAUE == '  6/m') THEN
          IF (EX(31)) THEN
            CALL PLA163 ('P61    ')
            CALL PLA163 ('P65    ')
          ELSE IF (EX(39)) THEN
            CALL PLA163 ('P62    ')
            CALL PLA163 ('P64    ')
C * 21 screw 00l
          ELSE IF (EX(18)) THEN
            CALL PLA163 ('P63    ')
            CALL PLA163 ('P63/m  ')
          ELSE
            CALL PLA163 ('P-6    ')
            CALL PLA163 ('P6     ')
            CALL PLA163 ('P6/m   ')
          END IF
        ELSE IF (LAUE == '6/mmm') THEN
C * CHECK 0KL,H0L and H-HL, L=2N
          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')
            END IF
          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  ')
C * 21 screw 00l
              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 ')
              END IF
            END IF
          END IF
        ELSE
C * TRIGONAL CLASSES: 3, -3, 32, 3m, -3m, 312, 31m, -31m
C * R(obs) or R(Rev) Lattice
          IF (ILAT1 == 'R') THEN
            IF (LAUE == '   -3') THEN
              CALL PLA163 ('R3     ')
              CALL PLA163 ('R-3    ')
            ELSE IF (LAUE == ' -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   ')
              END IF
            END IF
          ELSE IF (ILAT1 == 'P') THEN
            IF (LAUE == '   -3') THEN
              IF (EX(39)) THEN
                CALL PLA163 ('P31    ')
                CALL PLA163 ('P32    ')
C * TWINNING ? ABOUT (1 0 0)
                IF (EXT(5) == '>') THEN
                  CALL PLA163 ('P-3    ')
                  CALL PLA163 ('R-3    ')
                END IF
              ELSE
                CALL PLA163 ('P3     ')
                CALL PLA163 ('P-3    ')
              END IF
            ELSE IF (LAUE == ' -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  ')
C * OBVERSE/REVERSE TWINNING ?
                  IF (EXT(47) /= '  ') THEN
                    CALL PLA163 ('R-3    ')
                  END IF
                ELSE
                  CALL PLA163 ('P321   ')
                  CALL PLA163 ('P3m1   ')
                  CALL PLA163 ('P-3m1  ')
                END IF
              END IF
            ELSE IF (LAUE == ' -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  ')
C * OBVERSE/REVERSE TWINNING ?
                  IF (EXT(47) /= '  ') THEN
                    CALL PLA163 ('R-3    ')
                  END IF
                ELSE
                  CALL PLA163 ('P312   ')
                  CALL PLA163 ('P31m   ')
                  CALL PLA163 ('P-31m  ')
                END IF
              END IF
            END IF
          END IF
        END IF
C **********************************************************************
C * CUBIC   LAUE CLASS 11 : m-3 , 12 : m-3m                            *
C **********************************************************************
C * POINT GROUPS:  23, M-3, 432, -43M, M-3M
      ELSE IF (ILAT0 == 'c') THEN
C * F - CENTERING
        IF (ILAT1 == 'F') THEN
C * 0KL - TEST FOR K + l = 4N (K,L IMPLICIET IN F !)
          IF (EX(19)) THEN
C * HHL (H-HL)
            IF ((EX(25) .OR. EX(33)) .AND. (EX(26) .OR. EX(43))) THEN
              CALL PLA163 ('Fd-3c  ')
            ELSE
              IF (LAUE == ' m-3m') THEN
                CALL PLA163 ('Fd-3m  ')
              ELSE
                CALL PLA163 ('Fd-3   ')
              END IF
            END IF
          ELSE
C * HHL (H-HL)
            IF ((EX(25) .OR. EX(33)) .AND. (EX(26) .OR. EX(43))) THEN
              CALL PLA163 ('F-43c  ')
              CALL PLA163 ('Fm-3c  ')
            ELSE
C * 00L = L = 4N
              IF (EX(24)) THEN
                CALL PLA163 ('F4132  ')
              ELSE
                IF (LAUE == ' m-3m') THEN
                  CALL PLA163 ('F-43m  ')
                  CALL PLA163 ('F432   ')
                  CALL PLA163 ('Fm-3m  ')
                ELSE
                  CALL PLA163 ('F23    ')
                  CALL PLA163 ('Fm-3   ')
                END IF
              END IF
            END IF
          END IF
C * I - CENTERING
        ELSE IF (ILAT1 == 'I') THEN
C * 0KL
          IF (EX(7) .AND. EX(8)) THEN
C * HHL
            IF (EX(25) .AND. EX(28)) THEN
              CALL PLA163 ('Ia-3d  ')
            ELSE
              CALL PLA163 ('Ia-3   ')
            END IF
          ELSE
            IF (EX(25) .AND. EX(28)) THEN
              CALL PLA163 ('I-43d  ')
            ELSE
C * 00L = L = 4N
              IF (EX(24)) THEN
                CALL PLA163 ('I4132  ')
              ELSE
                IF (LAUE == ' 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   ')
                END IF
              END IF
            END IF
          END IF
C * P - CENTERING
        ELSE IF (ILAT1 == 'P') THEN
C * 0KL
          IF (EX(9)) THEN
            IF (LAUE == ' m-3m') THEN
C * HHL , H-HL
              IF (EX(25) .OR. EX(33)) THEN
                CALL PLA163 ('Pn-3n  ')
              ELSE
                CALL PLA163 ('Pn-3m  ')
              END IF
            ELSE
              CALL PLA163 ('Pn-3   ')
            END IF
          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
C * HHL , H-HL
            IF (EX(25) .OR. EX(33)) THEN
              CALL PLA163 ('P-43n  ')
              CALL PLA163 ('Pm-3n  ')
            ELSE
              IF (LAUE == '  m-3') THEN
C * 21 screw 00l
                IF (EX(18)) THEN
                  CALL PLA163 ('P213   ')
                ELSE
                  CALL PLA163 ('P23    ')
                  CALL PLA163 ('Pm-3   ')
                END IF
              ELSE
C * 00L = L = 4N
                IF (EX(24)) THEN
                  CALL PLA163 ('P4132  ')
                  CALL PLA163 ('P4332  ')
C * 21 screw 00l
                ELSE IF (EX(18)) THEN
                  CALL PLA163 ('P4232  ')
                ELSE
                  CALL PLA163 ('P432   ')
                  CALL PLA163 ('P-43m  ')
                  CALL PLA163 ('Pm-3m  ')
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA168
 
      MODULE stat
      SAVE
      REAL,    DIMENSION(20, 3) :: ST
      INTEGER, DIMENSION(20, 3) :: NSTAT
      INTEGER, DIMENSION(20)    :: NSTOT
      REAL                      :: PERCMAX
      END MODULE stat
 
      SUBROUTINE PLA169 (MODE, RII, RISIG, SINTL, LUO)
C * LAUE (3)
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE dfspgr
      USE stat
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: LUO
      INTEGER           :: LUX
      INTEGER           :: MODE
      INTEGER           :: MSHEL
      REAL              :: RI
      REAL              :: RII
      REAL              :: RSIG
      REAL              :: YUNK
      REAL              :: SINTL
      REAL              :: RISIG
      REAL              :: XIDSI
      CHARACTER(len=40) :: BALK
      CHARACTER(len=80) :: PRBUF
C * MODE =  0 - INIT
C * MODE =  1 - ADD TO STATISTICS
C * MODE = -1 - CALC STATISTICS
C * MODE = -2 - OUTPUT STATISTICS
C * MODE = -3 - OUTPUT STATISTICS WITH ALERT
      IF (MODE == 0) THEN
        CALL GEN097 (NSTOT, 1, 20, 0)
        CALL GEN097 (NSTAT, 1, 60, 0)
        CALL GEN074 (ST,    1, 60, 0.0)
        PERCMAX = 0.0
      ELSE IF (MODE == 1) THEN
        DO I = 1, 20
          IF (SINTL < STLS(I)) THEN
            NSTOT(I) = NSTOT(I) + 1
            RSIG     = RISIG
            RI       = RII
            IF (RI <= 0.0) RI = 1.0
            IF (RSIG <= 0.0) RSIG = SQRT (RI)
            XIDSI = RI / RSIG
            IF (XIDSI >= 0.25) THEN
              NSTAT(I, 1) = NSTAT(I, 1) + 1
              IF (XIDSI > 1.0) THEN
                NSTAT(I, 2) = NSTAT(I, 2) + 1
                IF (XIDSI >= 2.0) THEN
                  NSTAT(I, 3) = NSTAT(I, 3) + 1
                END IF
              END IF
            END IF
            EXIT
          END IF
        END DO
      ELSE IF (MODE == -1) THEN
        DO I = 1, 20
          IF (NSTOT(I) > 0) THEN
            DO J = 1, 3
              ST(I, J) = 100.0 * NSTAT(I, J) / NSTOT(I)
            END DO
          END IF
          IF (ST(I, 3) > PERCMAX) PERCMAX = ST(I, 3)
        END DO
C * OUTPUT STATISTICS
      ELSE IF (MODE <= -2) THEN
        IF (LUO == 0) THEN
C * SPGR-EXT MODE
          IF (IPR(548) == 0) THEN
            M = 2 + IWIN
C * SYSTEM S MODE
          ELSE
            M = 2
          ENDIF
        ELSE
          M = 1
        END IF
        DO N = 1, M
          IF (N == 1) THEN
            IF (M == 1) THEN
              LUX = LUO
            ELSE
              LUX = LU6
            END IF
          ELSE IF (N == 2) THEN
            LUX = LU7
            WRITE (LUX, 99999, IOSTAT = IOST)
          ELSE
            LUX = 0
          ENDIF
   10     IF (LUX == 0) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT
          END IF
          WRITE (PRBUF, 99998, IOSTAT = IOST)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99990, IOSTAT = IOST)
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 0.8
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 5, 2, 0.3, VRT)
          END IF
          WRITE (PRBUF, 99997, IOSTAT = IOST)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 5, 2, 0.3, VRT)
          END IF
          WRITE (PRBUF, 99996, IOSTAT = IOST)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 5, 2, 0.3, VRT)
          END IF
          WRITE (PRBUF, 99997, IOSTAT = IOST)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 5, 2, 0.3, VRT)
          END IF
          MSHEL = 0
          DO I = 1, 20
            IF (NSTOT(I) > 0) THEN
              MSHEL = I
              L = NINT (ST(I, 3) * 0.4)
              DO K = 1, 40
                IF (K > L) THEN
                  BALK(K:K) = '.'
                ELSE
                  BALK(K:K) = '*'
                END IF
              END DO
              WRITE (PRBUF, 99995, IOSTAT = IOST)
     1          I, STLS(I), 1 / (2 * STLS(I)), NSTOT(I),
     2          (ST(I, J), J = 1, 3), BALK
              IF (LUX /= 0) THEN
                WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
              ELSE
                VRT = VRT - 0.7
                CALL PLA439 (0.0, PRBUF, 80, 0.37, 1, 2, 0.3, VRT)
              END IF
            END IF
          END DO
          WRITE (PRBUF, 99994, IOSTAT = IOST)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 0.7
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 5, 2, 0.3, VRT)
          END IF
          WRITE (PRBUF, 99993, IOSTAT = IOST)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 0.5
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 5, 2, 0.3, VRT)
          END IF
          WRITE (PRBUF, 99992, IOSTAT = IOST) NINT (PERCMAX)
          IF (LUX /= 0) THEN
            WRITE (LUX, 99990, IOSTAT = IOST)
            WRITE (LUX, 99991, IOSTAT = IOST) PRBUF
          ELSE
            VRT = VRT - 1.0
            CALL PLA439 (0.0, PRBUF, 80, 0.37, 1, 2, 0.3, VRT)
C * WHAT NEXT ?
            CALL PLA012 (2, 1)
            IF (IGGT(1:4) == 'PLOT') GO TO 10
          END IF
        END DO
        IF (MODE == -3) THEN
          WRITE (LUO, 99999, IOSTAT = IOST)
C * ALERT _908
          IF (PERCMAX < 75.0) THEN
            CALL PLA236 (908, 2, -999.0, PERCMAX, ' ', ' ')
          END IF
          IF (MSHEL <= 8) THEN
            YUNK = ST(MSHEL, 3)
C * ALERT _909
            IF (YUNK > 30.0) THEN
              CALL PLA236 (909, 2, -999.0, YUNK, ' ', ' ')
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (/, 'Section 7', /, 79('='),
     1        /, 'Analysis of Variance (F(obs) and F(calc) from FCF)',
     2        /, 79('='))
99998 FORMAT ('Intensity Distribution',
     1 ' [Decay of I/Sigma(I) versus sin(theta)/lambda]')
99997 FORMAT (79('='))
99996 FORMAT ('sh  st/l   Ang     #  0.25   1.0   2.0', 2X,
     3        'Percent  Distr. for I .gt. 2.0 * sig(I)')
99995 FORMAT (I2, 2F6.3, I6, 3F6.1, 1X, A)
99994 FORMAT (38X, 'I', 19X, 'I', 19X, 'I')
99993 FORMAT (18X, 'Percent Observed:   0',18X, '50', 17X, '100')
99992 FORMAT ('Maximum Percentage of Reflections with I >  2*sig(I)',
     3        ' in any Resolution Shell', I3, '%')
99991 FORMAT (A)
99990 FORMAT (/)
      END SUBROUTINE PLA169
 
      SUBROUTINE PLA170 (RS, N, I, M)
C * LAUE (4)
      USE files
      USE parameters
      USE lplat
      USE dfspgr
      USE hklmx
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: INZJ
      INTEGER            :: NCNT
      REAL, DIMENSION(*) :: RS
C * N = LAUE CLASS
C * NUMBER OF POSSIBLE ASYMMETRIC REFLECTIONS
      FMN(N) = 0.0
      ITL(N) = 0
      NCNT   = 0
      IF (RS(INZ(I)) > -1.5) NTL(N, 1) = NTL(N, 1) + 1
      DO J = I, M
        DO K = 1, 2
          IF (K == 1) THEN
            INZJ = INZ(J)
            L    = J
          ELSE
            INZJ = - INZ(J) + 2 * IHKP
            L    = J + 24
          END IF
          XN(L)    = RS(INZJ)
          RS(INZJ) = -2.0
          IF (XN(L) > - 0.5) THEN
            NCNT = 1
            IF (XN(L) > 0.0) THEN
              FMN(N) = FMN(N) + XN(L)
              ITL(N) = ITL(N) + 1
            END IF
          END IF
        END DO
      END DO
C * NUMBER OF OBSERVED REFLECTIONS (AT LEAST ONCE)
      NTL(N, 2) = NTL(N, 2) + NCNT
      IF (ITL(N) > 1) THEN
        FMN(N)    = FMN(N) / ITL(N)
C * NUMBER OF REFLECTIONS MEASURED MORE THAN ONCE
        NTL(N, 3) = NTL(N, 3) + 1
        DO J = I, M
          DO K = 1, 2
            IF (K == 1) THEN
              INZJ = INZ(J)
              L    = J
            ELSE
              INZJ = - INZ(J) + 2 * IHKP
              L    = J + 24
            END IF
            IF (XN(L) > 0.0) THEN
              XTL(N) = XTL(N) + ABS (XN(L) - FMN(N))
              XNM(N) = XNM(N) + XN(L)
            END IF
          END DO
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA170
 
      SUBROUTINE PLA171
C * TABLE & CIF CREATION
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: IS
      INTEGER               :: LBB
      INTEGER               :: LBC
      INTEGER               :: LBD
      INTEGER               :: LVK
      INTEGER               :: ISL
      INTEGER               :: NQH
      INTEGER               :: NRES
      INTEGER               :: NLBX
      INTEGER               :: NIEN
      INTEGER               :: IENM
      INTEGER               :: JSORT
      INTEGER               :: INQNR
      INTEGER               :: JNQNR
      INTEGER               :: IPR53S
      INTEGER, DIMENSION(6) :: LV
      INTEGER, DIMENSION(4) :: NV1
C * TABLE LIST FUNCTION & CIF GENERATION
C **********************************************************************
C **********************************************************************
C *                      VOID                          JNSC            *
C *                        I                             I             *
C *  At. par.  LV(1)  -->  I                             I             *
C *                       -I- IPR(245)     IPR(226) -->  I             *
C *  (esd's)               I                             I             *
C *                       -I- IPR(246)                  -I- IPR(233)   *
C *  Bonds     LV(2)  -->  I               IPR(227) -->  I             *
C *                       -I- IPR(247)                  -I- IPR(234)   *
C *  Angles    LV(3)  -->  I               IPR(228) -->  I             *
C *                       -I- IPR(248)                  -I- IPR(235)   *
C *  Torsions  LV(4)  -->  I               IPR(229) -->  I             *
C *                       -I- IPR(249)                  -I- IPR(236)   *
C *  NonBonds  LV(5)  -->  I               IPR(230) -->  I             *
C *                       -I- IPR(250)                  -I- IPR(237)   *
C *  HBonds    LV(6)  -->  I               IPR(231) -->  I             *
C *                        I                             I  IPR(238)   *
C *                        I                             I             *
C *                        I                             I             *
C *                       -I- NVDR                      -I- NP23       *
C **********************************************************************
      K     = 0
      M     = 0
      LVK   = 0
      ISL   = 0
      NRES  = 0
      NLBX  = 0
      JSORT = 0
C * OME - FILE - REWIND
      REWIND (UNIT = LU2, IOSTAT = IOST)
      IF (IOST /= 0) CALL GEN148 (LU2, 1)
C * RESULT FILES
      IF (IPR(431) == 1) THEN
C * SUPPLEMENTARY MATERIAL
        OPEN (UNIT = LU60, FILE = NAMEFIL(1:KNMFIL)//'.sup',
     1        STATUS = 'UNKNOWN')
      ELSE IF (IPR(431) == -1) THEN
C * ACC/CIF
        OPEN (UNIT = LU60, FILE = NAMEFIL(1:KNMFIL)//'_acc.cif',
     1        STATUS = 'UNKNOWN')
      END IF
C * INITIALISATION
C * PUB - TABLE NUMBER
      IPR(239) = 0
C * TOP COORDINATES IN VOID
      IPR(245) = IPR(37)  * 12
C * TOP COORDINATE ESD'S IN VOID
      IPR(246) = IPR(245) * 2
C * TOP BOND  LIST
      IPR(247) = IPR(246) + IPR(251) * 4
C * TOP ANGLE LIST
      IPR(248) = IPR(247) + IPR(252) * 5
C * TOP TORSION LIST
      IPR(249) = IPR(248) + IPR(253) * 6
C * TOP NONBOND LIST
      IPR(250) = IPR(249) + IPR(254) * 4
C * TOP COORDINATES IN JNSC
      IPR(233) = IPR(37) * 2
C * TOP BONDS IN JNSC
      IPR(234) = IPR(233) + IPR(251) * 2
C * TOP ANGLES IN JNSC
      IPR(235) = IPR(234) + IPR(252) * 2
C * TOP TORSION IN JNSC
      IPR(236) = IPR(235) + IPR(253) * 2
      IF (IPR(236) > NP23) THEN
        IPR(236) = IPR(235)
        IPR(237) = IPR(235)
        IPR(238) = IPR(235)
        IPR(253) = 0
        IPR(254) = 0
        WRITE (LU6, 99998, IOSTAT = IOST)
        WRITE (LU6, 99997, IOSTAT = IOST)
        WRITE (LU6, 99996, IOSTAT = IOST)
      ELSE
C * TOP NONB IN JNSC
        IPR(237) = IPR(236) + IPR(254) * 2
        IF (IPR(237) > NP23) THEN
          IPR(237) = IPR(236)
          IPR(238) = IPR(236)
          IPR(254) = 0
          WRITE (LU6, 99997, IOSTAT = IOST)
          WRITE (LU6, 99996, IOSTAT = IOST)
        ELSE
C * TOP H-BONDS IN JNSC
          IPR(238) = IPR(237) + IPR(452) * 2
          IF (IPR(238) > NP23) THEN
            IPR(238) = IPR(237)
            WRITE (LU6, 99996, IOSTAT = IOST)
          END IF
        END IF
      END IF
C * SET COORDINATE POINTER IN JNSC
      IPR(226) = 0
C * SET BOND POINTER IN JNSC
      IPR(227) = IPR(233)
C * SET ANGLE POINTER IN JNSC
      IPR(228) = IPR(234)
C * SET TORSION POINTER IN JNSC
      IPR(229) = IPR(235)
C * SET NONB    POINTER IN JNSC
      IPR(230) = IPR(236)
C * SET HBON    POINTER IN JNSC
      IPR(231) = IPR(237)
      LV(1)    = 1
      DO I = 2, 6
        LV(I) = IPR(244 + I) + 1
      END DO
      N        = 0
C * TEMP SAVE/RESTORE IGBL(5)
   10 IPR53S   = IGBL(5)
      IGBL(5)  = LU2
C * GET NEW LINE FROM LU2
      CALL PLA006 (0, IS)
      IF (IS >= 0) THEN
        IGBL(5) = IPR53S
C * RESD
        IF (IS == 185) THEN
          NRES = NINT (FN(1))
          GO TO 10
C * UIJ, SUIJ, U, ATOM
        ELSE IF (IS > 24 .AND. IS < 29) THEN
          N = 1
          K = 1
C * BOND
        ELSE IF (IS ==  54) THEN
          N = 2
          K = 2
C * ANGLE
        ELSE IF (IS ==  36) THEN
          N = 3
          K = 3
C * TORSION
        ELSE IF (IS ==  37) THEN
          N = 4
          K = 4
C * NONBONDING
        ELSE IF (IS == 217) THEN
          N = 5
          K = 2
C * HBOND
        ELSE IF (IS ==  38) THEN
          N = 6
          K = 3
        END IF
C * EVALUATE
        IF (N > 0) THEN
C * TEST FOR H OR D OR Hw FOR SORTING
          NQH = 0
          DO I = 1, K
            NQ1 = IFL(I + 1)(1:7)
            CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD, INQNR, JNQNR,
     1        NIEN)
            NLBX                = NLBX + 1
            VOID(LV(N) + I - 1) = NLBX
            LABB(NLBX)          = INQNR
            NV1(I)              = JNQNR
            IF (NIEN >= 0) THEN
              NIEN = IEN(NIEN + 1)
              IF (NIEN == 1 .OR. NIEN == 33 .OR.
     1            NIEN == 113) THEN
C * TEST FOR -NO-H- INSTRUCTION
                IF (IPR(454) == 0) GO TO 10
                NQH = IPR(465)
              END IF
            ELSE
              WRITE (LU6, 99999, IOSTAT = IOST) IFL(I + 1), NIEN, NQ1
              GO TO 10
            END IF
          END DO
          IF (N == 1) THEN
            IF (IS == 28) THEN
C * ATOM
              JSORT = NV1(1)
C * PACK ADDRESS IN VOID + NUMBER OF ITEMS IN ONE WORD
              LVK = LV(N) * 16 + 5
C * GET CORRECT SOF
              SGY(1)  = FN(1)
              SGY(2)  = FN(2)
              SGY(3)  = FN(3)
              SGY(10) = 0.0
              CALL SGSM (19, IDM, SGY, 0, LU6, IERR)
              FN(4)  = FN(4) / SGY(10)
              FN(8)  = FN(8) / SGY(10)
              M      = 4
              GO TO 20
            ELSE IF (IS == 25) THEN
C * UIJ
              JNSC(2, IPR(225 + N)) = LVK + 7
              ISL                   = LV(N)
              DO J = 1, 7
                VOID(LV(N)) = FN(J)
                LV(N)       = LV(N) + 1
              END DO
            ELSE IF (IS == 26) THEN
C * SUIJ
              DO J = 1, 7
                VOID(ISL + IPR(245)) = FN(J)
                ISL                  = ISL + 1
              END DO
            ELSE IF (IS == 27) THEN
C * U
              JNSC(2, IPR(225 + N))  = LVK + 1
              VOID(LV(N))            = FN(1)
              VOID(LV(N) + IPR(245)) = FN(2)
              LV(N)                  = LV(N) + 1
            END IF
            GO TO 10
          ELSE IF (N == 2) THEN
            IF (NV1(1) > NV1(2)) THEN
              CALL GEN014 (NV1(1), NV1(2))
              CALL GEN018 (VOID(LV(N)), VOID(LV(N) + 1))
            END IF
            JSORT = NV1(1)
            M     = 2
          ELSE IF (N == 3) THEN
            IF (NV1(1) > NV1(3)) THEN
              CALL GEN014 (NV1(1), NV1(3))
              CALL GEN018 (VOID(LV(N)), VOID(LV(N) + 2))
            END IF
            JSORT = NV1(2)
            M     = 2
          ELSE IF (N == 4) THEN
            IF (NV1(2) > NV1(3)) THEN
              CALL GEN014 (NV1(2), NV1(3))
              CALL GEN014 (NV1(1), NV1(4))
              CALL GEN018 (VOID(LV(N) + 1), VOID(LV(N) + 2))
              CALL GEN018 (VOID(LV(N)), VOID(LV(N) + 3))
            END IF
            JSORT = NV1(2)
            M     = 2
C * NONBONDING CONTACTS
          ELSE IF (N == 5) THEN
            M     = 2
            JSORT = NV1(1)
C * HBONDS
          ELSE IF (N == 6) THEN
            M     = 9
            JSORT = NV1(1)
          END IF
          LVK = LV(N)
C * ADD THE QUANTITY NQH AND NRES FOR SORTING
   20     IF (IPR(225 + N) < IPR(232 + N)) THEN
            IPR(225 + N)          = IPR(225 + N) + 1
            JNSC(1, IPR(225 + N)) = JSORT
     1                             + NQH + IPR(240) * IPR(466) * NRES
            JNSC(2, IPR(225 + N)) = LVK
C * GET DATA SUCH AS X,Y,Z, SOF
            DO J = 1, M
              VOID(LV(N) + K + J - 1) = FN(J)
              IF (IS == 28)
     1            VOID(LV(N) + K + J + IPR(245) - 1) = FN(J + 4)
            END DO
            LV(N) = LV(N) + K + M
          END IF
        END IF
        GO TO 10
C * END OF FILE
      END IF
C * CLOSE/DELETE OMEGA FILE
      IF (IPR(226) > 0) THEN
C * SORT ATOM RECORDS
        CALL GEN037 (JNSC, 1, IPR(226))
C * DORT BOND RECORDS
        CALL GEN037 (JNSC, IPR(233) + 1, IPR(227))
C * SORT ANGLE RECORDS
        CALL GEN037 (JNSC, IPR(234) + 1, IPR(228))
C * SORT TORSION RECORDS
        IF (IPR(253) > 0) CALL GEN037 (JNSC, IPR(235) + 1, IPR(229))
C * SORT NON-BONDING RECORDS
        IF (IPR(254) > 0) CALL GEN037 (JNSC, IPR(236) + 1, IPR(230))
C * LIST SECTION
C * TITLE PAGE SUPPLEMENTARY MATERIAL / CIF HEADER
        CALL PLA172 (-1, 0, 0)
C * CRYSTAL DATA
        CALL PLA172 ( 0, 1, 0)
C * ATOMS
        IF (IPR(431) == 1) THEN
          CALL PLA172 ( 1,  0, 0)
        ELSE
          CALL PLA172 ( 1,  1, 0)
        ENDIF
C * H -ATOMS
        IF (IPR(484) > 0) CALL PLA172 (2, 1, 0)
C * ANISOTROPIC DISPLACEMENT PARAMETERS SUP
        IF (IPR(32) == 2) CALL PLA172 (3, 0, 0)
        IF (IPR(251) > 0) THEN
C * BOND DISTANCES
          IF (IPR(431) == 1) THEN
            CALL PLA172 (4, 1, 2)
          ELSE
            CALL PLA172 (4, 1, 1)
          END IF
        END IF
        IF (IPR(252) > 0) THEN
C * BOND ANGLES
          IF (IPR(431) == 1) THEN
            CALL PLA172 (5, 1, 2)
          ELSE
            CALL PLA172 (5, 1, 1)
          END IF
        END IF
C * TORSION ANGLES
        IF (IPR(253) > 0) CALL PLA172 (6, 1, 1)
C * CONTACT-DISTANCES
        IF (IPR(254) > 0 .AND. IPR(431) == 1)
     1    CALL PLA172 (7, 1, 2)
C * HBONDS
        IF (IPR(452) > 0) CALL PLA172 (8, 0, 1)
C * FINISH
        CALL PLA172 (9, 0, 0)
      END IF
      CLOSE (UNIT = LU60)
      RETURN
99999 FORMAT ('Ignored Label Problem in PLA171 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 PLA171
 
      SUBROUTINE PLA172 (MODE, INCLH, NCOL)
C * TABLE & CIF CREATION (CONT)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cif
      USE sgxyz
      INTEGER            :: MODE
      INTEGER            :: INCLH
      INTEGER            :: NCOL
      CHARACTER(len=1)   :: CTAB
      CHARACTER(len=11)  :: ASCF
      CHARACTER(len=79)  :: FORMA
      CHARACTER(len=67)  :: FORMB
      CHARACTER(len=120) :: FORMC
      CHARACTER(len=100) :: FORMT
      CHARACTER(len=82)  :: FBOND
      CHARACTER(len=88)  :: FANGL
      CHARACTER(len=40)  :: FVOLU
      CHARACTER(len=3)   :: DCHAR
      CHARACTER(len=1)   :: DISOR
      CHARACTER(len=5)   :: UTYPE
      CHARACTER(len=3)   :: SCTYP
      CHARACTER(len=75)  :: FORMHA
      CHARACTER(len=75)  :: FORMHB
      CHARACTER(len=75)  :: FORMHT
      CHARACTER(len=77)  :: FORMNB
      CHARACTER(len=79)  :: FORMBH
      CHARACTER(len=88)  :: FORMAN
      CHARACTER(len=120) :: FORMHC
      CHARACTER(len=151)  :: FORMNH
      CHARACTER(len=104) :: FORMCD
      CHARACTER(len=88)  :: FORHBF
      CHARACTER(len=18)  :: FPARSU
      CHARACTER(len=3)   :: CIFTYPE
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 * LU2  = OME-FILE
C * LU7  = LIS-FILE
C * LU60 = SUP/CIF-FILE
      IF (IPR(431) == 0) THEN
        LU = LU7
      ELSE
        LU = LU60
      ENDIF
      DCHAR = '   '
      N     = 1
C * MAKE Mo-Ka default when wavelength absent
      IF (IPR(493) == 0) THEN
        IPR(493) = -3
      END IF
      IF (PAR(170) < 0) THEN
        IF (KRAD(1:2) == 'Mo') THEN
          PAR(170) = 0.35
        ELSE IF (KRAD(1:2) == 'Cu') THEN
          PAR(170) = 0.14
        ELSE
          PAR(170) = 0.0
        END IF
      END IF
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 (IPR(431) >= 0) THEN
        IF (MODE < 4) THEN
          LSTART = 8
        ELSE
          LSTART = 4
        END IF
        IF (IPR(431) == 1) THEN
          IF (MODE /= -1) IGBL(84) = IGBL(84) + 1
          NTAB     = IGBL(84)
          CTAB     = 'S'
          IDOUBL   = IPR(274)
        ELSE IF (IPR(431) == 0) THEN
          IDOUBL   = 1
          NTAB     = 0
          CTAB     = ' '
        END IF
        MXLIN  = IPR(243) / IDOUBL
        LSTART = LSTART   / IDOUBL
        IF (IDOUBL == 1) THEN
          DCHAR = '   '
        ELSE
          DCHAR = '  '//CHAR (10)
        END IF
      ELSE
        MXLIN  = 99999
        LSTART = 1
        IDOUBL = 1
      END IF
      IF (MODE == -1) THEN
C * COVER PAGE SUPPLEMENTARY MATERIAL
        IF (IPR(431) == 1) THEN
          IF (IPR(431) == 1) THEN
            IGBL(85) = IGBL(85) + 1
            WRITE (LU, 99982, IOSTAT = IOST) CHAR (12), IGBL(85)
          END IF
          WRITE (LU, 99999, IOSTAT = IOST) JID(1:40), DATIJD
C * COUNTER FOR CONTENTS PAGE
          NTB = IGBL(84)
C * CRYSTAL DATA
          CALL PLA175 (0, LU, CTAB, NTB, FORMCD, JID)
C * NON-HATOM COORDINATES
          CALL PLA175 (0, LU, CTAB, NTB, FORMNH, JID)
C * H_ATOM COORDINATES
          IF (IPR(484) > 0)
     1      CALL PLA175 (0, LU, CTAB, NTB, FORMHC, JID)
C * DISPLACEMENT MOTION PARAMETERS
          IF (IPR(32) > 0) THEN
            FORMAN( 4 :  4) = '8'
            FORMAN(73 : 74) = '19'
            CALL PLA175 (0, LU, CTAB, NTB, FORMAN, JID)
            FORMAN( 4 :  4) = '4'
            FORMAN(73 : 74) = '15'
          END IF
C * BONDS
          IF (IPR(251) > 0)
     1        CALL PLA175 (0, LU, CTAB, NTB, FORMHB, JID)
C * ANGLES
          IF (IPR(252) > 0) THEN
            FORMHA( 4 :  4) = '8'
            FORMHA(60 : 61) = '19'
            CALL PLA175 (0, LU, CTAB, NTB, FORMHA, JID)
            FORMHA( 4 :  4) = '4'
            FORMHA(60 : 61) = '15'
          END IF
C * TORSIONS
          IF (IPR(253) > 0 .AND. IPR(431) == 1) THEN
            FORMHT( 4 :  4) = '8'
            FORMHT(60 : 61) = '19'
            CALL PLA175 (0, LU, CTAB, NTB, FORMHT, JID)
            FORMHT( 4 : 4)  = '9'
            FORMHT(60 : 61) = '20'
          END IF
C * NonBonded
          IF (IPR(254) > 0)
     1      CALL PLA175 (0, LU, CTAB, NTB, FORMNB, JID)
C * Hydrogen Bonds
          IF (IPR(452) > 0)
     1      CALL PLA175 (0, LU, CTAB, NTB, FORMBH, JID)
        ELSE
C * CIF - FILE - HEADER
          WRITE (LU, 99300, IOSTAT = IOST) JID(1:40)
          WRITE (LU, 99299, IOSTAT = IOST)
          WRITE (LU, 99298, IOSTAT = IOST) 'global'
          CIFTYPE = 'ACC'
          WRITE (LU, 99299, IOSTAT = IOST)
C * AUDIT DETAILS SECTION
          WRITE (LU, 99297, IOSTAT = IOST)
          WRITE (LU, 99296, IOSTAT = IOST)
     1      CIFDIR(71), DATIJD, CIFDIR(72), CIFTYPE, CIFDIR(73)
C * SUBMISSION DETAILS SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99294, IOSTAT = IOST)
          IF (IPR(399) == 0) THEN
            WRITE (LU, 99293, IOSTAT = IOST) CIFDIR(437), CIFDIR(438)
            WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(325), '?'
            WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(326), '?'
            WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(327), '?'
          ELSE
            WRITE (LU, 99278, IOSTAT = IOST) CIFDIR(437), CIFDIR(438)
            WRITE (LU, 99277, IOSTAT = IOST)
            WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(325),
     1                        '''a.l.spek@uu.nl'''
            WRITE (LU, 99292, IOSTAT = IOST)
     1       CIFDIR(326), '''+31 30 2533940'''
            WRITE (LU, 99292, IOSTAT = IOST)
     1        CIFDIR(327), '''+31 30 2532538'''
          END IF
C * ACC-CIF MODE ONLY
          WRITE (LU, 99291, IOSTAT = IOST)
          WRITE (LU, 99290, IOSTAT = IOST) CIFDIR(336), CIFDIR(436)
          WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(335), '?'
          WRITE (LU, 99291, IOSTAT = IOST)
          WRITE (LU, 99289, IOSTAT = IOST) CIFDIR(328)
C * PROCESSION SUMMARY SECTION (JOURNAL OFFICE)
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99288, IOSTAT = IOST)
          WRITE (LU, 99287, IOSTAT = IOST)
     1      CIFDIR(305), CIFDIR(299), CIFDIR(298), CIFDIR(297),
     2      CIFDIR(301), CIFDIR(300), CIFDIR(303), CIFDIR(302),
     3      CIFDIR(294), CIFDIR(291), CIFDIR(295), CIFDIR(314),
     4      CIFDIR(318), CIFDIR(288), CIFDIR(308), CIFDIR(321),
     5      CIFDIR(320), CIFDIR(307), CIFDIR(309), CIFDIR(310),
     6      CIFDIR(311), CIFDIR(312)
C * TITLE AND AUTHOR LIST SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99286, IOSTAT = IOST)
          WRITE (LU, 99285, IOSTAT = IOST) CIFDIR(337), CIFDIR(439)
          WRITE (LU, 99284, IOSTAT = IOST)
          WRITE (LU, 99283, IOSTAT = IOST) CIFDIR(323), CIFDIR(469),
     1      CIFDIR(322)
          IF (IPR(399) == 1) THEN
            WRITE (LU, 99279, IOSTAT = IOST)
            WRITE (LU, 99277, IOSTAT = IOST)
          END IF
C * TEXT SECTION (ACC & CIF MODE)
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99282, IOSTAT = IOST)
          WRITE (LU, 99248, IOSTAT = IOST) CIFDIR(440), CIFDIR(338)
          WRITE (LU, 99252, IOSTAT = IOST)
          WRITE (LU, 99281, IOSTAT = IOST) CIFDIR(339)
          WRITE (LU, 99250, IOSTAT = IOST) CIFDIR(424), CIFDIR(425)
          WRITE (LU, 99251, IOSTAT = IOST)
          WRITE (LU, 99259, IOSTAT = IOST)
     1      CIFDIR(344), CHAR (92), CHAR (39)
          WRITE (LU, 99258, IOSTAT = IOST)
          WRITE (LU, 99257, IOSTAT = IOST)
C * ACKNOWLEDGEMENT
          IF (IPR(399) == 0) THEN
            WRITE (LU, 99265, IOSTAT = IOST) CIFDIR(343)
          ELSE
            WRITE (LU, 99274, IOSTAT = IOST) CIFDIR(343)
          END IF
C * FIGURE LEGEND
          WRITE (LU, 99245, IOSTAT = IOST) CIFDIR(345)
C * STRUCTURE DATA PARTITION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99298, IOSTAT = IOST) DATANM
C * CHEMICAL DATA SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99280, IOSTAT = IOST)
        END IF
      ELSE IF (MODE == 0) THEN
C * CHECK FOR 'INTEGER' COMPOSITION
        IF (IPR(215) == 0) THEN
          CALL PLA283 (0, 1.0, N, CFORM)
          CALL PLA283 (2, FLOAT (IPR(260)), N1, ICL(1:NP52))
        ELSE
          CALL GEN038 (CFORM, 1, NP52)
          CALL GEN038 (ICL,   1, NP52)
          CFORM(NP52:NP52) = '?'
          ICL  (NP52:NP52) = '?'
          N                = NP52
          N1               = NP52
        END IF
        DO 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))
        END DO
        FVOLU(26 : 26) = CHAR(ICHAR('0') + IPR(294))
C * CIF-FILE
        IF (IPR(431) == -1) THEN
          WRITE (LU, 99281, IOSTAT = IOST) CIFDIR(116)
          WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(113), '?'
          WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(112), '?'
C * FIND OUT WHEN MOIETY INFO NOT GIVEN IN CIF
          IF (INDEX (RLWS(4), '?') == 0) THEN
            WRITE (LU, 99197, IOSTAT = IOST) CIFDIR(107), RLWS(4)(1:79)
          ELSE
            WRITE (LU, 99397, IOSTAT = IOST) CIFDIR(107), CFORM(N:NP52)
          END IF
          WRITE (LU, 99253, IOSTAT = IOST)
          WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(108), '?'
C * INVENT FORMULA-SUM WHEN MOIETY INFO NOT GIVEN IN CIF
          IF (INDEX (RLWS(5), '?') == 0) THEN
            WRITE (LU, 99197, IOSTAT = IOST) CIFDIR(109), RLWS(5)(1:79)
          ELSE
C * AVOID 'UNDERFLOW'
            N1 = MAX (5, N1)
            WRITE (LU, 99397, IOSTAT = IOST) CIFDIR(109), CFORM(N1:NP52)
          END IF
          WRITE (LU, 99292, IOSTAT = IOST) CIFDIR(482), '?'
          IF (INDEX (RLWS(4), '?') == 0) THEN
            WRITE (LU, 99396, IOSTAT = IOST) CIFDIR(110), PAR(308)
          ELSE
            WRITE (LU, 99396, IOSTAT = IOST)
     1        CIFDIR(110), PAR(163) / IPR(260)
          END IF
          WRITE (LU, 99399, IOSTAT = IOST) CIFDIR(94)
C * SCATTERING FACTOR LOOP
          WRITE (LU, 99270, IOSTAT = IOST)
     1      CIFDIR(70), CIFDIR(52), CIFDIR(67), CIFDIR(66), CIFDIR(68)
C * ANOMALOUS DISPERSION DATA
          IF (IABS (IPR(493)) < 7) THEN
            DO I = 1, IAN
              K = IENS(I)
              IF (NINT (CONT(K, 2) / IPR(260)) > 0) THEN
                WRITE (LU, 99261, IOSTAT = IOST)
     1            LMT(K, 1)(1:2), LMT(K, 1)(1:2),
     2            (ANOM(K, L), L = 1, 2)
                IF (IABS (IPR(493)) < 6) THEN
                  WRITE (LU, 99060, IOSTAT = IOST)
                ELSE IF (IABS (IPR(493)) == 6) THEN
                  WRITE (LU, 99061, IOSTAT = IOST)
                END IF
              END IF
            END DO
          END IF
C * CRYSTAL DATA SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99269, IOSTAT = IOST)
          WRITE (LU, 99376, IOSTAT = IOST) CIFDIR(418), KRSYST(2)
C * STRIP TRAILING BLANKS
          CALL GEN039 (0, SPGRNM(3),  1, 17, K03, K3)
          IF (K03 >= K3) THEN
            SPGRNM(3)(1:1) = '?'
            K03 = 1
            K3  = 1
          END IF
          CALL GEN039 (1, SPGRNM(1), 15, 26, K01, K1)
          IF (K01 >= K1) SPGRNM(1)(K01:K01) = '?'
          WRITE (LU, 99375, IOSTAT = IOST)
     1      CIFDIR(421), SPGRNM(3)(K03:K3), CIFDIR(422),
     2      SPGRNM(1)(K01:K1), CIFDIR(420), IPR(202)
C * SYMM LOOP HEADER
          WRITE (LU, 99373, IOSTAT = IOST) CIFDIR(489), CIFDIR(490)
          NSYM   = IPR(48)
          SGY(4) = 0.0
          SGY(5) = 0.0
          SGY(6) = 0.0
C * FULL SYMMETRY OPERATOR LIST
          DO I = 1, NSYM
            ISYM = I
            CALL SGSM (20, ICL, SGY, ISYM, 0, IERR)
            CALL GEN020 (-1, ICL, 1, 30)
            WRITE (LU, 99984, IOSTAT = IOST) ISYM, ICL(1:30)
          END DO
          WRITE (LU, 99291, IOSTAT = IOST)
          WRITE (PRBUF, FBOND, IOSTAT = IOST)
     1      PAR(101), IPR(281), PAR(102), IPR(282), PAR(103), IPR(283),
     2      DCHAR
          CALL GEN065 (0, PRBUF, 1, 80, 1)
          WRITE (LU, 99388, IOSTAT = IOST)
     1      CIFDIR(78), PRBUF(36:48), CIFDIR(79), PRBUF(49:61),
     2      CIFDIR(80), PRBUF(62:74)
          WRITE (PRBUF, FANGL, IOSTAT = IOST)
     1      PAR(104), IPR(284), PAR(105), IPR(285), PAR(106), IPR(286),
     2      DCHAR
          CALL GEN065 (0, PRBUF, 1, 80, 3)
          WRITE (LU, 99388, IOSTAT = IOST)
     1      CIFDIR(74), PRBUF(36:48), CIFDIR(75), PRBUF(49:61),
     2      CIFDIR(76), PRBUF(62:74)
          WRITE (PRBUF, FVOLU, IOSTAT = IOST) PAR(98), IPR(293), DCHAR
          CALL GEN065 (0, PRBUF, 1, 80, 1)
          WRITE (LU, 99382, IOSTAT = IOST) CIFDIR(93), PRBUF(62:74)
          IF (INDEX (RLWS(4), '?') == 0) THEN
            CALL PLA174 (2, LU,  77, '(A, I6)', IPR(276), 0.0)
          ELSE
            CALL PLA174 (2, LU,  77, '(A, I6)', IPR(260), 0.0)
          END IF
          CALL PLA174 (2, LU,  88, '(A, I6)', IPR(261), 0.0)
          IF (IPR(601) == 0) IPR(601) = 999999
          CALL PLA174 (2, LU,  87, '(A, I6)', IPR(601), 0.0)
          YUNK = PAR(227)
          IF (PAR(227) == 0.0) YUNK = 999999.0
          CALL PLA174 (3, LU,  90, '(A, F10.2)', 0, YUNK)
          YUNK = PAR(228)
          IF (PAR(228) == 0.0) YUNK = 999999.0
          CALL PLA174 (3, LU,  89, '(A, F10.2)', 0, YUNK)
          IF (IPR(399) == 1) THEN
            WRITE (LU, 99255, IOSTAT = IOST) CIFDIR(92)
          ELSE
            WRITE (LU, 99268, IOSTAT = IOST) CIFDIR(92)
          END IF
          WRITE (LU, 99291, IOSTAT = IOST)
          WRITE (LU, 99243, IOSTAT = IOST)
     1      CIFDIR(239), CCIF(5)(1:NCIF(5)), CIFDIR(234),
     2      CCIF(14)(1:NCIF(14))
C * CRYSTAL_SIZE
          CALL PLA174 (3, LU, 251, '(A, F10.3)', 0, PAR(302))
          CALL PLA174 (3, LU, 252, '(A, F10.3)', 0, PAR(303))
          CALL PLA174 (3, LU, 253, '(A, F10.3)', 0, PAR(304))
          CALL PLA174 (1, LU, 254, ' ?', 0, 0.0)
          CALL PLA174 (3, LU, 236, '(A, F10.3)', 0, PAR(158))
          IF (INDEX (RLWS(4), '?') == 0) THEN
            CALL PLA174 (3, LU, 235, '(A, F10.3)', 0, PAR(267))
          ELSE
            CALL PLA174 (3, LU, 235, '(A, F10.3)', 0, PAR(160))
          END IF
          CALL PLA174 (1, LU, 238, '''Not Measured''', 0, 0.0)
          CALL PLA174 (2, LU, 240, '(A, I10)', NINT (PAR(157)), 0.0)
          IF (INDEX (RLWS(4), '?') == 0) THEN
            CALL PLA174 (3, LU, 229, '(A, F10.3)', 0, PAR(301))
          ELSE
            XMUM = PAR(162)
            IF (XMUM == 0.0) XMUM = -999999.0
            CALL PLA174 (3, LU, 229, '(A, F10.3)', 0, XMUM)
          END IF
          CALL PLA174 (1, LU, 237, ' ?', 0, 0.0)
          IF (IPR(485) == 4) THEN
            WRITE (LU, 99247, IOSTAT = IOST) CIFDIR(232), CIFDIR(233)
          ELSE
            WRITE (LU, 99244, IOSTAT = IOST)
            WRITE (LU, 99246, IOSTAT = IOST)
     1        CIFDIR(232), CCIF(15)(1:NCIF(15)), CIFDIR(233)
          END IF
          CALL PLA174 (3, LU, 231, '(A, F10.3)', 0, PAR(307))
          CALL PLA174 (3, LU, 230, '(A, F10.3)', 0, PAR(306))
C * EXPERIMENTAL DATA SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99266, IOSTAT = IOST)
          WRITE (LU, 99265, IOSTAT = IOST) CIFDIR(256)
          CALL PLA174 (2, LU, 133, '(A, I6)', IPR(310), 0.0)
          CALL PLA174 (3, LU, 164, '(A, F10.5)', 0, PAR(17))
          IF (IABS (IPR(493)) < 7) THEN
            WRITE (LU, 99362, IOSTAT = IOST) CIFDIR(481), 'x-ray'
            IF (IABS(IPR(493)) < 6) THEN
              WRITE (LU, 99362, IOSTAT = IOST)
     1          CIFDIR(163), KRAD(1:3)//CHAR (92)//'a'
            ELSE
              WRITE (LU, 99362, IOSTAT = IOST) CIFDIR(163), '?'
            END IF
          ELSE
            WRITE (LU, 99362, IOSTAT = IOST) CIFDIR(481), 'neutron'
          END IF
C * TEST FOR LOCAL
          IF (IPR(399) == 0) THEN
            CALL PLA174 (1, LU, 162, ' ?', 0, 0.0)
            CALL PLA174 (1, LU, 159, ' ?', 0, 0.0)
          ELSE
            WRITE (LU, 99392, IOSTAT = IOST) CIFDIR(162), CIFDIR(159)
          END IF
          WRITE (LU, 99291, IOSTAT = IOST)
          CALL PLA174 (1, LU, 441, ' ?', 0, 0.0)
          CALL PLA174 (1, LU, 137, ' ?', 0, 0.0)
          IF (IPR(399) == 1) THEN
            CALL PLA174 (3, LU, 463, '(A, F10.1)', 0, 18.4)
          ELSE
            CALL PLA174 (1, LU, 463, ' ?', 0, 0.0)
          END IF
          WRITE (LU, 99291, IOSTAT = IOST)
          WRITE (LU, 99355, IOSTAT = IOST)
          CALL PLA174 (2, LU, 204, '(A, I6)', IPR(262), 0.0)
          CALL PLA174 (3, LU, 196, '(A, F8.4)', 0, PAR(197))
          CALL PLA174 (3, LU, 497, '(A, F8.4)', 0, PAR(198))
          CALL PLA174 (2, LU, 199, '(A, I6)', IPR(267), 0.0)
          CALL PLA174 (2, LU, 198, '(A, I6)', IPR(268), 0.0)
          CALL PLA174 (2, LU, 201, '(A, I6)', IPR(269), 0.0)
          CALL PLA174 (2, LU, 200, '(A, I6)', IPR(270), 0.0)
          CALL PLA174 (2, LU, 203, '(A, I6)', IPR(271), 0.0)
          CALL PLA174 (2, LU, 202, '(A, I6)', IPR(272), 0.0)
          CALL PLA174 (3, LU, 207, '(A, F6.2)', 0, PAR(167))
          CALL PLA174 (3, LU, 206, '(A, F6.2)', 0, PAR(168))
          CALL PLA174 (3, LU, 444, '(A, F6.2)', 0, PAR(312))
          CALL PLA174 (3, LU, 458, '(A, F6.3)', 0, PAR(313))
          CALL PLA174 (3, LU, 459, '(A, F6.3)', 0, PAR(314))
          WRITE (LU, 99351, IOSTAT = IOST) CIFDIR(205)
          WRITE (LU, 99324, IOSTAT = IOST)
          CALL PLA174 (2, LU, 410, '(A, I8)', IPR(263), 0.0)
          WRITE (LU, 99323, IOSTAT = IOST)
          CALL PLA174 (2, LU, 442, '(A, I8)', IPR(264), 0.0)
          IF (CCIF(1)(1:5) == 'i > 2' .OR.
     1    CCIF(1)(2:3) == '2s') CCIF(1) = 'I>2'//CHAR (92)//'s(I)'
          WRITE (LU, 99322, IOSTAT = IOST)
     1      CIFDIR(443), CCIF(1)(1:NCIF(1))
          WRITE (LU, 99291, IOSTAT = IOST)
          IF (IPR(399) == 1) THEN
            WRITE (LU, 99394, IOSTAT = IOST)
     1        CIFDIR(118), CIFDIR(117), CIFDIR(119)
          ELSE
            WRITE (LU, 99393, IOSTAT = IOST)
     1        CIFDIR(118), CIFDIR(117), CIFDIR(119)
          END IF
          WRITE (LU, 99391, IOSTAT = IOST) CIFDIR(123)
C * SHELX-97 STYLE
          IF (IPR(725) == 1) THEN
            WRITE (LU, 99390, IOSTAT = IOST)
     1        CIFDIR(122), ' ''SHELXL-97 (Sheldrick, 1997)'''
C * SHELXL-201n STYLE
          ELSE IF (IPR(725) == 2) THEN
            WRITE (LU, 99390, IOSTAT = IOST)
     1        CIFDIR(122), ' ''SHELXL-201n (Sheldrick, 2014)'''
          ELSE
            WRITE (LU, 99390, IOSTAT = IOST) CIFDIR(122), ' ?'
          END IF
          WRITE (LU, 99264, IOSTAT = IOST) CIFDIR(120)
          WRITE (LU, 99389, IOSTAT = IOST) CIFDIR(121)
C * REFINEMENT DATA SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99263, IOSTAT = IOST)
          IF (IPR(725) == 0) THEN
            WRITE (LU, 99332, IOSTAT = IOST) CIFDIR(373)
C * SHELXL/APEX/SHELXL-20xy
          ELSE IF (IPR(725) == 1 .OR. IPR(725) == 2) THEN
            WRITE (LU, 99276, IOSTAT = IOST) CIFDIR(373)
C * PLATON
          ELSE IF (IPR(725) == 3) THEN
            WRITE (LU, 99332, IOSTAT = IOST) CIFDIR(373)
C * CRYSTALSTRUCTURE
          ELSE IF (IPR(725) == 4) THEN
            WRITE (LU, 99332, IOSTAT = IOST) CIFDIR(373)
C * CRYSTALS
          ELSE IF (IPR(725) == 5) THEN
            WRITE (LU, 99332, IOSTAT = IOST) CIFDIR(373)
          END IF
          WRITE (LU, 99348, IOSTAT = IOST)
     1      CIFDIR(369), CCIF(2)(1:NCIF(2))
          WRITE (LU, 99347, IOSTAT = IOST)
     1      CIFDIR(358), CCIF(3)(1:NCIF(3))
          WRITE (LU, 99344, IOSTAT = IOST)
     1      CIFDIR(370), CCIF(9)(1:NCIF(9))
          WRITE (LU, 99342, IOSTAT = IOST) CIFDIR(451), RLWS(1)
C * H-REF
          IF (IPR(484) <= 0) THEN
            CCIF(12) = ' .'
            CCIF(13) = ' .'
            NCIF(12) = 2
            NCIF(13) = 2
          END IF
          WRITE (LU, 99345, IOSTAT = IOST)
     1      CIFDIR(48),  CCIF(10)(1:NCIF(10)), CIFDIR(49),
     2      CCIF(11)(1:NCIF(11)), CIFDIR(50),  CCIF(12)(1:NCIF(12))
          WRITE (LU, 99301, IOSTAT = IOST)
     1      CIFDIR(357), CCIF(13)(1:NCIF(13))
          WRITE (LU, 99344, IOSTAT = IOST)
     1      CIFDIR(354), CCIF(4)(1:NCIF(4))
          IF (CCIF(4)(1:4) /= 'none') THEN
C * EXTINCTION REFINEMENT
            IF (PAR(229) < -999990) THEN
              PRBUF(1:1) = '?'
              CALL GEN038 (PRBUF, 2, 20)
            ELSE
              FPARSU(6:6) = CHAR (ICHAR ('0') + IPR(278))
              WRITE (PRBUF, FPARSU, IOSTAT = IOST) PAR(229), IPR(277)
              CALL GEN065 (0, PRBUF, 1, 80, 1)
            END IF
            WRITE (LU, 99981, IOSTAT = IOST) CIFDIR(352), PRBUF(1:20)
            WRITE (LU, 99342, IOSTAT = IOST) CIFDIR(353), RLWS(2)
          END IF
C * FLACK PARAMETER ETC
          IF (IPR(275) == 2) THEN
            WRITE (LU, 99341, IOSTAT = IOST) CIFDIR(349), CIFDIR(350)
          ELSE
            WRITE (LU, 99254, IOSTAT = IOST) CIFDIR(349)
            IF (PAR(433) < 999999.0) THEN
              FPARSU(6:6) = CHAR (ICHAR ('0') + IPR(280))
              WRITE (PRBUF, FPARSU, IOSTAT = IOST) PAR(433), IPR(279)
              CALL GEN065 (0, PRBUF, 1, 80, 1)
              WRITE (LU, 99981, IOSTAT = IOST) CIFDIR(350), PRBUF(1:20)
            ELSE
              CALL PLA174 (1, LU, 350, ' ?', 0, 0.0)
            END IF
            WRITE (LU, 99059, IOSTAT = IOST)
     1        CIFDIR(758), CCIF(17)(1:NCIF(17))
          END IF
          CALL PLA174 (2, LU, 361, '(A, I10)', IPR(265), 0.0)
          CALL PLA174 (2, LU, 360, '(A, I10)', IPR(266), 0.0)
C * # LS-Restraints
          CALL PLA174 (2, LU, 362, '(A, I10)', IPR(273), 0.0)
          CALL PLA174 (1, LU, 359, ' ?', 0, 0.0)
C * R-all
          CALL PLA174 (3, LU, 363, '(A, F10.4)', 0, PAR(309))
C * R(obs/gt)
          CALL PLA174 (3, LU, 445, '(A, F10.4)', 0, PAR(173))
C * wR(all/ref)
          CALL PLA174 (3, LU, 446, '(A, F10.4)', 0, PAR(174))
C * wR(obs/gt)
          CALL PLA174 (3, LU, 460, '(A, F10.4)', 0, PAR(310))
C * goodness_of_fit_all/ref
          CALL PLA174 (3, LU, 447, '(A, F10.3)', 0, PAR(299))
C * restrained_S_all
          CALL PLA174 (3, LU, 365, '(A, F10.3)', 0, PAR(300))
C * SHIFT/SU MAX & MEAN
          CALL PLA174 (3, LU, 448, '(A, F10.3)', 0, PAR(178))
          CALL PLA174 (3, LU, 461, '(A, F10.3)', 0, PAR(179))
C * RESIDUAL DIFF-MAX,MIN & RMS
          CALL PLA174 (3, LU, 347, '(A, F10.3)', 0, PAR(177))
          CALL PLA174 (3, LU, 348, '(A, F10.3)', 0, PAR(176))
          CALL PLA174 (3, LU, 462, '(A, F10.3)', 0, PAR(175))
C * ATOMIC COORDINATES AND DISPLACEMENT PARAMETER SECTION
          WRITE (LU, 99295, IOSTAT = IOST)
          WRITE (LU, 99262, IOSTAT = IOST)
        END IF
C * CRYSTAL DATA TABLE  (INCLH = 0: PARTIAL, = 1 : FULL)
        IF (IPR(431) >= 0) THEN
          IF (IPR(431) == 0) THEN
            CALL PLA262 (0)
          ELSE IF (IPR(431) == 1) THEN
            IGBL(85) = IGBL(85) + 1
            WRITE (LU, 99982, IOSTAT = IOST) CHAR (12), IGBL(85)
          END IF
          IF (INCLH == 0) THEN
            WRITE (LU, 99978, IOSTAT = IOST)
     1        CTAB, NTAB, DCHAR, JID(1:40), DCHAR
          ELSE
            CALL PLA175 (-1, LU, CTAB, NTAB, FORMCD, JID)
          END IF
          IF (INCLH > 0) WRITE (LU, 99977, IOSTAT = IOST)
          IF (INDEX (RLWS(4), '?') == 0) THEN
            N2 = INDEX (RLWS(4), CHAR (39))
            CALL GEN038 (PRBUF, 1, 80)
            IF (N2 > 1 .AND. N2 < 59) THEN
              WRITE (LU, 99976, IOSTAT = IOST)
     1          PRBUF(1:59-N2)//RLWS(4)(1:N2-1), DCHAR
            ELSE
              WRITE (LU, 99976, IOSTAT = IOST) PRBUF(1:57)//'?', DCHAR
            END IF
            WRITE (LU, 99975, IOSTAT = IOST) PAR(308), DCHAR
          ELSE
            WRITE (LU, 99976, IOSTAT = IOST)
     1        CFORM(NP52 - 57: NP52), DCHAR
            WRITE (LU, 99975, IOSTAT = IOST) PAR(163) / IPR(260), DCHAR
          END IF
          IF (INCLH > 0)
     1      WRITE (LU, 99974, IOSTAT = IOST) KRSYST(2), DCHAR
          WRITE (LU, 99973, IOSTAT = IOST)
     1      SPGRNM(1)(1:7), SPGRNM(1)(8:11), IPR(202), DCHAR
          WRITE (PRBUF, FBOND, IOSTAT = IOST)
     1      PAR(101), IPR(281), PAR(102), IPR(282), PAR(103), IPR(283),
     2      DCHAR
          CALL GEN065 (LU, PRBUF, 1, 80, 1)
          WRITE (PRBUF, FANGL, IOSTAT = IOST)
     1      PAR(104), IPR(284), PAR(105), IPR(285), PAR(106), IPR(286),
     2      DCHAR
          IF (INDEX (KRSYST(2), 'tri') /= 0 .OR.
     1        INDEX (KRSYST(2), 'mon') /= 0) THEN
            CALL GEN065 (LU, PRBUF, 1, 80, 3)
          END IF
          WRITE (PRBUF, FVOLU, IOSTAT = IOST) PAR(98), IPR(293), DCHAR
          CALL GEN065 (LU, PRBUF, 1, 80, 1)
          IF (INDEX (RLWS(4), '?') == 0) THEN
            WRITE (LU, 99970, IOSTAT = IOST) IPR(276), DCHAR
            IF (PAR(158) < 10000.0) THEN
              WRITE (LU, 99969, IOSTAT = IOST) PAR(158), PAR(267), DCHAR
            ELSE
              WRITE (LU, 99948, IOSTAT = IOST) PAR(160), DCHAR
            END IF
            WRITE (LU, 99967, IOSTAT = IOST) KRAD, PAR(301), DCHAR
          ELSE
            WRITE (LU, 99970, IOSTAT = IOST) IPR(260), DCHAR
            IF (PAR(158) < 10000.0) THEN
              WRITE (LU, 99969, IOSTAT = IOST)
     1          PAR(158), PAR(160), DCHAR
            ELSE
              WRITE (LU, 99948, IOSTAT = IOST) PAR(160), DCHAR
            END IF
            WRITE (LU, 99967, IOSTAT = IOST) KRAD, PAR(162), DCHAR
          END IF
          IF (INCLH > 0)
     1      WRITE (LU, 99968, IOSTAT = IOST) NINT (PAR(157)), DCHAR
          IF (INCLH > 0) THEN
            WRITE (LU, 99966, IOSTAT = IOST)
     1        MAX (0.0, PAR(304)), MAX (0.0, PAR(303)),
     2        MAX (0.0, PAR(302)), DCHAR
            WRITE (LU, 99965, IOSTAT = IOST)
          END IF
          WRITE (LU, 99964, IOSTAT = IOST) IPR(261), DCHAR
          WRITE (LU, 99963, IOSTAT = IOST)
     1      KRAD, MAX (0.0, PAR(17)), DCHAR
          IF (INCLH > 0) THEN
            WRITE (LU, 99962, IOSTAT = IOST)
     1        MAX (0.0, PAR(167)), MAX (0.0, PAR(168)), DCHAR
            WRITE (LU, 99957, IOSTAT = IOST)
     1            (MIN (999, MAX (-99, IPR(I))), I = 267, 272), DCHAR
            WRITE (LU, 99956, IOSTAT = IOST)
     1        MAX (0, IPR(262)), MAX (0, IPR(263)),
     2        MAX (0.0, PAR(197)), DCHAR
C * SHELXL97, SHELXL201n, CRYSTALS, WinGX
            IF (IPR(725) == 1 .OR. IPR(725) == 2 .OR.
     1        IPR(725) == 5 .OR. IPR(725) == 7) PAR(180) = 2.0
            WRITE (LU, 99955, IOSTAT = IOST)
     1        PAR(180), MAX (0, IPR(264)), DCHAR
            WRITE (LU, 99954, IOSTAT = IOST)
            WRITE (LU, 99953, IOSTAT = IOST)
     1        MAX (0, IPR(265)), MAX (0, IPR(266)), DCHAR
          END IF
          WRITE (LU, 99952, IOSTAT = IOST)
     1      MAX (0.0, PAR(173)), MAX (0.0, PAR(174)),
     2      MAX (0.0, PAR(299)), DCHAR
          IF (INCLH > 0) THEN
            WRITE (LU, 99951, IOSTAT = IOST) RLWS(1)(9:70), DCHAR
            WRITE (LU, 99950, IOSTAT = IOST)
     1        MAX (0.0, PAR(178)), MAX (0.0, PAR(179)), DCHAR
            IF (PAR(433) < 999999.0) THEN
              FPARSU(6:6) = CHAR (ICHAR ('0') + IPR(280))
              WRITE (PRBUF, FPARSU, IOSTAT = IOST) PAR(433), IPR(279)
              CALL GEN065 (0, PRBUF, 1, 80, 1)
              WRITE (LU, 99947, IOSTAT = IOST) PRBUF(1:14), DCHAR
            END IF
            WRITE (LU, 99949, IOSTAT = IOST)
     1        MIN (0.0, PAR(176)), MAX (0.0, PAR(177))
          END IF
        END IF
      ELSE IF (MODE < 4) THEN
        IF (IPR(431) == 1) THEN
          IGBL(85) = IGBL(85) + 1
          WRITE (LU, 99982, IOSTAT = IOST) CHAR (12), IGBL(85)
        END IF
C * MODE = 1  - COORDINATES AND (AN)ISOTROPIC DISPLACEMENT PARAMETERS
        IF (MODE == 1) THEN
C * CIF - COORDINATES + (AN)ISO
          IF (IPR(431) == -1) THEN
C * _atom_site_label
C * _atom_site_type_symbol
C * _atom_site_fract_x
C * _atom_site_fract_y
C * _atom_site_fract_z
C * _atom_site_U_iso_or_equiv
C * _atom_site_adp_type
C * _atom_site_occupancy
C * _atom_site_site_symmetry_order
C * _atom_site_calc_flag
C * _atom_site_refinement_flags
C * _atom_site_disorder_assembly
C * _atom_site_disorder_group
            WRITE (LU, 99499, IOSTAT = IOST)
     1        CIFDIR(22), CIFDIR(35),  CIFDIR(34), CIFDIR(19),
     2        CIFDIR(20),  CIFDIR(21), CIFDIR(30), CIFDIR(36),
     3        CIFDIR(11),  CIFDIR(31), CIFDIR(450), CIFDIR(18)
 
          ELSE
            CALL PLA175 (-1, LU, CTAB, NTAB, FORMNH, JID)
            WRITE (LU, 99998, IOSTAT = IOST)
          END IF
C * MODE =  2 - H-ATOM COORDINATES
        ELSE IF (MODE == 2) THEN
          IF (IPR(431) == 1) THEN
            CALL PLA175 (-1, LU, CTAB, NTAB, FORMHC, JID)
            WRITE (LU, 99995, IOSTAT = IOST)
          END IF
C * MODE =  3 - DISPLACEMENT PARAMETERS
        ELSE IF (MODE == 3) THEN
          IF (IPR(431) == -1) THEN
            WRITE (LU, 99799, IOSTAT = IOST)
     1      CIFDIR(1), CIFDIR(3),  CIFDIR(6), CIFDIR(8),  CIFDIR(7),
     2      CIFDIR(5), CIFDIR(4)
          ELSE
            CALL PLA175 (-1, LU, CTAB, NTAB, FORMAN, JID)
            WRITE (LU, 99997, IOSTAT = IOST)
          END IF
        END IF
C * SET LINE COUNT
        ITEL = LSTART
        NAT  = IPR(226)
        IF (IPR(240) == 0) THEN
          NRO = 0
        ELSE
          NRO = 1
        END IF
        NDISO = 0
C * LOOP OVER ATOMS FOR POSITIONAL/DISPLACEMENT PARAMETER PRINTING
        DO I = 1, NAT
          DISOR = ' '
C * GET RESIDUE NUMBER
          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
C * OUTPUT SOF FOR CIF
          IF (IPR(431) == -1) N2 = N2 + 1
C * ANISO CASE
          IF (N4 /= N3) THEN
            UTYPE = 'Uani '
            IF (MODE == 3) THEN
C * SELECT U11 TO U12
              N4 = N4 - 1
            ELSE
C * SELECT U(EQ)
              N3 = N4
            END IF
          ELSE
            UTYPE = 'Uiso '
          END IF
C * HANDLE ISOTROPIC ATOM / CIF-MODE
          IF (MODE == 3 .AND. N4 == N3) CYCLE
C * HANDLE H,D, Hw ATOMS
          JLABN = LABB(NINT(VOID(N1 - 1)))
          CALL PLA047 (JLABN, NQ1, IDUM, IENR, IPR(71),
     1                 IGBL(55), 0, 1)
          N = IEL(IENR)
          M = N / 100
          SCTYP = CHAR (ICHAR('A') + M - 1)//'  '
          N = N - M * 100
          IF (N > 0) SCTYP(2 : 2) = CHAR (ICHAR ('a') + N - 1)
          IF (IENR == 1 .OR. IENR == 33 .OR. IENR == 113) THEN
            IF (MODE == 1) CYCLE
          ELSE
            IF (MODE == 2) CYCLE
          END IF
          N   =  0
          IPS = -4
          FORMC(5 : 5) = '2'
          IF (IPR(431) == -1) THEN
            FORMC(2 : 2) = '1'
          ELSE
            FORMC(2 : 2) = '3'
          END IF
          IF (MODE < 3) THEN
            IF (IPR(431) == -1) THEN
              FORMC(2 : 2) = '1'
              FORMC(5 : 5) = '3'
            ELSE
              FORMC(2 : 2) = '7'
              FORMC(5 : 5) = '2'
            END IF
            IF (VOID(N2 + 1) < 1.0) THEN
              DISOR = '*'
              NDISO = NDISO + 1
            END IF
            DO M = N1, N2
              N         = N + 1
              IPS   = IPS + 16
              IF (M - N1 == 3) THEN
                FORMC(IPS - 2 : IPS - 2) = '6'
                MDEC = 3
              ELSE
                FORMC(IPS - 2 : IPS - 2) = '9'
                MDEC = MIN (IPR(183), 5)
              END IF
              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)
            END DO
          END IF
C * UEQ, U OR UIJ
          DO 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
C * SET FIELDWIDTH UIJ ENTRY
            IF (MODE == 3) THEN
              IF (IPR(431) == -1 .AND. IPS >= 60) THEN
                FORMC(IPS - 2 : IPS - 2) = '8'
              ELSE
                FORMC(IPS - 2 : IPS - 2) = '7'
              END IF
            END IF
            FORMC(IPS : IPS) = CHAR (ICHAR ('0') + IDEC)
            DEV(N) = VOID(M)
          END DO
          IF (IPR(431) == 1) THEN
            ITEL = ITEL + 1
            IF (NR > NRO) THEN
              ITEL = ITEL + 1
              NRO  = NR
              WRITE (LU, 99985, IOSTAT = IOST)
              IF (IDOUBL == 2) WRITE (LU, 99985, IOSTAT = IOST)
            END IF
            IF (ITEL > MXLIN) THEN
              ITEL = LSTART + 1
              IGBL(85) = IGBL(85) + 1
              WRITE (LU, 99982, IOSTAT = IOST) CHAR (12), IGBL(85)
              IF (MODE == 1) THEN
                CALL PLA175 (1, LU, CTAB, NTAB, FORMNH, JID)
                WRITE (LU, 99998, IOSTAT = IOST)
              ELSE IF (MODE == 2) THEN
                CALL PLA175 (1, LU, CTAB, NTAB, FORMHC, JID)
                WRITE (LU, 99995, IOSTAT = IOST)
              ELSE IF (MODE == 3) THEN
                CALL PLA175 (1, LU, CTAB, NTAB, FORMAN, JID)
                WRITE (LU, 99997, IOSTAT = IOST)
              END IF
            END IF
          END IF
C * TEST FOR ACC (= -1) OR SUP (= 1)
          IF (IPR(431) == -1) THEN
            IF (MODE == 1 .OR. MODE == 2) THEN
              ASCF = '. .   . .  '
              NQ4  = NQ1
              CALL PLA046 (2, NQ4, IX, LBB, LBC, LBD, INQNR, JNQNR, NR)
              IF (NR > 0) THEN
C * calc_flag
                CALL GEN048 (-1, IFG(3, NR), 1, IVL)
                IF (IVL > 0) ASCF(1:1) = 'd'
                CALL GEN048 (-1, IFG(3, NR), 2, IVL)
                IF (IVL > 0) ASCF(1:1) = 'c'
                K = 2
C * refinement_flags
                DO J = 4, 10
                  IF (K < 5) THEN
                    CALL GEN048 (-1, IFG(3, NR), J, IVL)
                    IF (IVL /= 0) THEN
                      K = K + 1
                      ASCF(K:K) = CVLAG(J - 3)
                    END IF
                  END IF
                END DO
C * disorder_assembly
                CALL GEN048 (-1, IFG(3, NR), 11, IVL)
                IF (IVL > 0) ASCF(7:7) = 'A'
                CALL GEN048 (-1, IFG(3, NR), 12, IVL)
                IF (IVL > 0) ASCF(7:7) = 'B'
                CALL GEN048 (-1, IFG(3, NR), 13, IVL)
                IF (IVL > 0) ASCF(7:7) = 'S'
C * disorder_group
                CALL GEN048 (-5, IFG(3, NR), 14, IVL)
                IF (IVL /= 16) THEN
                  WRITE (ASCF(9:11), '(I3)', IOSTAT = IOST) IVL - 16
                END IF
              END IF
              WRITE (PRBUF, FORMC, IOSTAT = IOST) NQ1(1:8), SCTYP,
     1          UTYPE, (DEV(M), ISDV(M), M = 1, N)
              PRBUF(82:) = ASCF
            ELSE IF (MODE == 3) THEN
              WRITE (PRBUF, FORMC, IOSTAT = IOST) DISOR, NQ1(1:7),
     1          (DEV(M), ISDV(M), M = 1, N)
            END IF
            CALL GEN065 (0, PRBUF, 1, 92, 1)
C * COMPACT LINE TO ONE BLANK CHARACTER
            CALL GEN103 (PRBUF, 92)
            WRITE (LU, 99983, IOSTAT = IOST) PRBUF(1:80)
          ELSE
            WRITE (PRBUF, FORMC, IOSTAT = IOST) DISOR, NQ1(1:7),
     1          (DEV(M), ISDV(M), M = 1, N)
            CALL GEN065 (LU, PRBUF, 1, 80, 3)
            IF (IDOUBL == 2) WRITE (LU, 99985, IOSTAT = IOST)
          END IF
        END DO
        IF (IPR(431) == 1) THEN
          IF (MODE == 1) THEN
            WRITE (LU, 99993, IOSTAT = IOST)
            IF (NDISO > 0) WRITE (LU, 99996, IOSTAT = IOST)
          ELSE IF (MODE == 2) THEN
            WRITE (LU, 99989, IOSTAT = IOST)
            WRITE (LU, 99988, IOSTAT = IOST)
            WRITE (LU, 99987, IOSTAT = IOST)
          ELSE IF (MODE == 3) THEN
            WRITE (LU, 99989, IOSTAT = IOST)
            WRITE (LU, 99988, IOSTAT = IOST)
            WRITE (LU, 99987, IOSTAT = IOST)
            WRITE (LU, 99986, IOSTAT = IOST)
          END IF
        END IF
C * BOND TABLE
      ELSE IF (MODE == 4) THEN
        CALL PLA173 (MODE, FORMB, FORMHB, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 33, 11, 4, IDOUBL)
C * ANGLE TABLE
      ELSE IF (MODE == 5) THEN
        CALL PLA173 (MODE, FORMA, FORMHA, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 39, 11, 2, IDOUBL)
C * TORSION TABLE
      ELSE IF (MODE == 6) THEN
        CALL PLA173 (MODE, FORMT, FORMHT, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 42, 0, 2, IDOUBL)
C * INTER-CONTACTS
      ELSE IF (MODE == 7 .AND. IPR(431) == 1) THEN
        CALL PLA173 (MODE, FORMB, FORMNB, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 33, 11, 4, IDOUBL)
C * H-BONDS
      ELSE IF (MODE == 8) THEN
        CALL PLA173 (MODE, FORHBF, FORMBH, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 42, 0, 4, IDOUBL)
C * FINISH
      ELSE IF (MODE == 9) THEN
        IF (IPR(431) == 1) THEN
          IGBL(85) = IGBL(85) + 1
          WRITE (LU, 99982, IOSTAT = IOST) CHAR (12), IGBL(85)
          WRITE (LU, 99249, IOSTAT = IOST)
          CALL PLA043 (0, -1, LU, 0)
        END IF
        IF (IPR(431) == -1) THEN
C * OPTIONAL EXTRA TABLES
          WRITE (LU, 99001, IOSTAT = IOST)
          WRITE (LU, 99002, IOSTAT = IOST)
          WRITE (LU, 99003, IOSTAT = IOST)
          WRITE (LU, 99004, IOSTAT = IOST)
          WRITE (LU, 99005, IOSTAT = IOST)
          WRITE (LU, 99006, IOSTAT = IOST)
          WRITE (LU, 99007, IOSTAT = IOST)
        END IF
C * COPY/APPEND RES-FILE
        IF (IPR(663) == 0) THEN
C * WRITE PLACEHOLDER FOR RES
          WRITE (LU, 99994, IOSTAT = IOST) CIFDIR(513)
          WRITE (LU, 99992, IOSTAT = IOST)
        ELSE
          REWIND (UNIT = LU24, IOSTAT = IOST)
          WRITE (LU, 99994, IOSTAT = IOST) CIFDIR(578)
          DO
            READ (LU24, 99983, IOSTAT = IOST) LINE
            IF (IOST /= 0) EXIT
            WRITE (LU, 99983) LINE
          END DO
          WRITE (LU, 99992, IOSTAT = IOST)
          IF (IPR(677) > 0)
     1      WRITE (LU, 99991, IOSTAT = IOST) CIFDIR(579), IPR(677)
        END IF
C * COPY/APPEND HKL-FILE
        IF (IPR(664) == 0) THEN
C * WRITE PLACEHOLDER FOR HKL
          WRITE (LU, 99994, IOSTAT = IOST) CIFDIR(569)
          WRITE (LU, 99992, IOSTAT = IOST)
        ELSE
          REWIND (UNIT = LU25, IOSTAT = IOST)
          WRITE (LU, 99994, IOSTAT = IOST) CIFDIR(580)
          DO
            READ (LU25, 99983, IOSTAT = IOST) LINE
            IF (IOST /= 0) EXIT
            WRITE (LU, 99983) LINE
          END DO
          WRITE (LU, 99992, IOSTAT = IOST)
            IF (IPR(678) > 0)
     1        WRITE (LU, 99991, IOSTAT = IOST) CIFDIR(581), IPR(678)
        END IF
C * COPY/APPEND FAB-FILE
        IF (IPR(665) /= 0) THEN
          REWIND (UNIT = LU26, IOSTAT = IOST)
          WRITE (LU, 99994, IOSTAT = IOST) CIFDIR(601)
          DO
            READ (LU26, 99983, IOSTAT=IOST) LINE
            IF (IOST /= 0) EXIT
            WRITE (LU, 99983) LINE
          END DO
          WRITE (LU, 99992, IOSTAT = IOST)
          IF (IPR(679) > 0)
     1      WRITE (LU, 99991, IOSTAT = IOST) CIFDIR(602), IPR(679)
        END IF
C * WRITE END TO CIF-FILE
        WRITE (LU, 99260, IOSTAT = IOST)
      END IF
      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('-'))
99994 FORMAT (A, /, ';')
99993 FORMAT (/, 10X,
     1 'U(eq) = 1/3 of the trace of the orthogonalized U Tensor')
99992 FORMAT (';')
99991 FORMAT (A, I10)
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)', 18X, I8, ', ', 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', 43X, I7, ',', 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_', 12(/, A))
99399 FORMAT (A, '''see text''')
99397 FORMAT (A, /, '''', A, '''')
99197 FORMAT (A, /, '''', A)
99396 FORMAT (A, F10.2)
99394 FORMAT (A, ' ?', /, A, ' ?', /, A, ' ?')
99393 FORMAT (A, ' ?', /, A, ' ?', /, A, ' ?')
99392 FORMAT (A, ' ?', /, A, ' ?')
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, '''')
99355 FORMAT ('# number of measured reflections (redundant set)')
99351 FORMAT (A, /, ';', /, ';')
99348 FORMAT (A, 1X, A)
99347 FORMAT (A, 1X, 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 <TABLE ', A, '> option'' ', /,
     3        A, /, ';', /, ';')
99295 FORMAT (/, '#', 79('='), /)
99294 FORMAT ('# 1. SUBMISSION DETAILS', /)
99293 FORMAT ('# Name of author for correspondence', /, A,
     1        /, ';', / ';', /,
     2        '# address of author for correspondence', /, A,
     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 wassupported 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)
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, /, ';', /,  ' ', /,  ';')
99254 FORMAT (A, /, ' ''Flack (1983)'' ')
99059 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, ', /,
     5        '# sphere         ''spherical''', /,
     6        '#                Example: PLATON/ABSS')
99243 FORMAT (2(A, '''', A, '''', /))
99301 FORMAT (/,
     1 '# Permitted for _refine_ls_hydrogen_treatment :', /,
     2 '# refall            - refined all H-atom parameters', /,
     3 '# refxyz            - refined H-atom coordinates only', /,
     4 '# refU              - refined H-atom U only', /,
     5 '# noref             - no refinement of H-atom parameters', /,
     6 '# constr            - H-atom parameters constrained', /,
     7 '# hetero            - H-atom parameters constrained for H on C,'
     8                        , /,
     9 '#                     all H-atom parameters refined for H on', /
     * '#                     heteroatoms', /,
     1 '# heteroxyz         - H-atom parameters constrained for H on C,'
     2                        , /,
     3 '#                     refined H-atom coordinates only for H', /,
     4 '#                     on heteroatoms', /,
     5 '# heteroU           - H-atom parameters constrained for H on C,'
     6                        , /,
     7 '#                     refined H-atom U''s only for H on', /,
     8 '#                     heteroatoms', /,
     9 '# heteronoref       - H-atom parameters constrained for H on C,'
     *                        , /,
     1 '#                     no refinement of H-atom parameters for', /
     2 '#                     H on heteroatoms', /,
     3 '# hetero-mixed      - H-atom parameters constrained for H on C'
     4                        , /,
     5 '#                     and some heteroatoms, all H-atom', /,
     6 '#                     parameters refined for H on remaining', /,
     7 '#                     heteroatoms.', /,
     8 '# heteroxyz-mixed   - H-atom parameters constrained for H on C'
     9                        , /,
     * '#                     and some heteroatoms, refined H-atom', /,
     1 '#                     coordinates only for H on remaining', /,
     2 '#                     heteroatoms.', /,
     3 '# heteroU-mixed     - H-atom parameters constrained for H on C'
     4                        , /,
     5 '#                     and some heteroatoms, refined H-atom', /,
     6 '#                     U''s only for H on remaining heteroatoms'
     7                        , /,
     8 '# heteronoref-mixed - H-atom parameters constrained for H on C'
     9                        , /,
     * '#                     and some heteroatoms, no refinement of',/
     1 '#                     H-atom parameters for H on remaining', /,
     2 '#                     heteroatoms', /,
     3 '# mixed   - some constrained, some independent', /,
     4 '# undef   - H-atom parameters not defined', /,
     5 A, '''', A, '''', /)
99060 FORMAT (
     1 ''' International Tables Vol C Tables 4.2.6.8 and 6.1.1.4''')
99061 FORMAT (
     1 ' ''S.Brennan & P.L.Cowan (1992).Rev.Sci.Instr.,63,850-853''')
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 PLA172
 
      SUBROUTINE PLA173 (MODE, FORMX, FORMH, LU, CTAB, NTAB, MXLIN,
     1 LSTART, NCOL, INCLH, IPS1, IPS2, IDECM, IDOUBL)
C * TABLE & CIF CREATION (CONT)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cif
      USE sgxyz
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: L
      INTEGER                        :: M
      INTEGER                        :: N
      INTEGER                        :: IC
      INTEGER                        :: LU
      INTEGER                        :: IM
      INTEGER                        :: IN1
      INTEGER                        :: IN2
      INTEGER                        :: IN3
      INTEGER                        :: IC3
      INTEGER                        :: ICS
      INTEGER                        :: IND
      INTEGER                        :: INM
      INTEGER                        :: INP
      INTEGER                        :: IPS
      INTEGER                        :: JMX
      INTEGER                        :: ISOP
      INTEGER                        :: IN01
      INTEGER                        :: IN02
      INTEGER                        :: IN2P
      INTEGER                        :: IENR
      INTEGER                        :: IDEC
      INTEGER                        :: ICP2
      INTEGER                        :: NTAB
      INTEGER                        :: MODE
      INTEGER                        :: NCOL
      INTEGER                        :: IPS1
      INTEGER                        :: IPS2
      INTEGER                        :: ITEL
      INTEGER                        :: NHET
      INTEGER                        :: NLIN
      INTEGER                        :: MISOP
      INTEGER                        :: JLABN
      INTEGER                        :: MXLIN
      INTEGER                        :: IDECM
      INTEGER                        :: INCLH
      INTEGER                        :: MJNSC
      INTEGER                        :: NDECM
      INTEGER                        :: NHATS
      INTEGER                        :: MISOPH
      INTEGER                        :: MISOPT
      INTEGER                        :: ISPACE
      INTEGER                        :: LSTART
      INTEGER                        :: IDOUBL
      INTEGER,          DIMENSION(4) :: IDHA
      REAL,             DIMENSION(4) :: DHA
      CHARACTER(len=1)               :: CTAB
      CHARACTER(len=*)               :: FORMX
      CHARACTER(len=*)               :: FORMH
      CHARACTER(len=1)               :: DASH
      CHARACTER(len=8), DIMENSION(4) :: GSS
      ISPACE = 0
      JMX    = 0
      NHATS  = 0
      NHET   = 0
C * MODE = 4 : BONDS
C * MODE = 5 : ANGLES
C * MODE = 6 : TORSIONS
C * MODE = 7 : INTER-CONTACTS
C * MODE = 8 : H-BONDS
C * MODE = 9 : FINISH
C * MOLECULAR GEOMETRY SECTION
C * MODE = 4 : BONDS
      IF (MODE == 4) THEN
        ISPACE = 8
        IF (IPR(431) == -1) THEN
          WRITE (LU, 99995, IOSTAT = IOST)
          WRITE (LU, 99994, IOSTAT = IOST)
          WRITE (LU, 99993, IOSTAT = IOST) CIFDIR(277)
          WRITE (LU, 99998, IOSTAT = IOST)
     1      CIFDIR(265), CIFDIR(266), CIFDIR(267), CIFDIR(269),
     2      CIFDIR(270), CIFDIR(268)
          ISPACE = 1
        END IF
C * MODE = 5 : ANGLES
      ELSE IF (MODE == 5) THEN
        ISPACE = 4
        IF (IPR(431) == -1) THEN
          WRITE (LU, 99997, IOSTAT = IOST)
     1      CIFDIR(258), CIFDIR(259), CIFDIR(260), CIFDIR(257),
     2      CIFDIR(262), CIFDIR(263), CIFDIR(264), CIFDIR(261)
          ISPACE = 1
        END IF
C * MODE = 6 : TORSIONS
      ELSE IF (MODE == 6) THEN
        ISPACE = 9
        IF (IPR(431) == -1) THEN
          WRITE (LU, 99996, IOSTAT = IOST)
     1      CIFDIR(279), CIFDIR(280), CIFDIR(281), CIFDIR(282),
     2      CIFDIR(278), CIFDIR(284), CIFDIR(285), CIFDIR(286),
     3      CIFDIR(287), CIFDIR(283)
          ISPACE = 1
        END IF
C * WRITE CONTACTS LOOP-HEADER
C * MODE = 7 : INTER-CONTACTS
      ELSE IF (MODE == 7) THEN
        ISPACE = 8
        IF (IPR(431) == -1) THEN
          WRITE (LU, 99998, IOSTAT = IOST)
     1      CIFDIR(271), CIFDIR(272), CIFDIR(273), CIFDIR(275),
     2      CIFDIR(276), CIFDIR(274)
          ISPACE = 1
        END IF
C * MODE = 8 : H-BONDS
      ELSE IF (MODE == 8) THEN
        ISPACE = 1
        IF (IPR(431) == -1) THEN
          WRITE (LU, 99992, IOSTAT = IOST)
     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)
            FORMX(84:86) = 'yes'
        END IF
      END IF
      IN01 = IPR(229 + MODE) + 1
      IN02 = IPR(223 + MODE)
C * MODE < 7
      IF (MODE < 7) THEN
        JMX  = MODE - 2
      ELSE IF (MODE == 7) THEN
        JMX = 2
      END IF
      IF (IPR(431) == 1) THEN
        IGBL(85) = IGBL(85) + 1
        WRITE (LU, 99999, IOSTAT = IOST) CHAR (12), IGBL(85)
      END IF
C * NO DASH BETWEEN ATOM LABELS IN CIF-FILE FOR BONDS, ANGLES ETC.
      DASH = ' '
      IF (IPR(431) == 1) THEN
        CALL PLA175 (-1, LU, CTAB, NTAB, FORMH, JID)
        IF (MODE == 7) THEN
          DASH = '.'
        ELSE
          DASH = '-'
        END IF
      END IF
C * LIST HBONDS (ACC OR SUP)
      IF (MODE == 8) THEN
        DO J = IN01, IN02
          L = JNSC(2, J)
          JLABN = LABB(NINT (VOID(L)))
          CALL PLA047 (JLABN, NQ1, ISOP, IENR, IPR(71), IGBL(55), 0, 1)
          JLABN = LABB(NINT (VOID(L + 1)))
          CALL PLA047 (JLABN, NQ2, ISOP, IENR, IPR(71), IGBL(55), 0, 1)
          JLABN = - LABB(NINT (VOID(L + 2)))
          CALL PLA047 (JLABN, NQ3, ISOP, IENR, IPR(71), IGBL(55), 0, 1)
          ISOP  = NINT (VOID(L + 11))
C * TEST FOR ACC OR SUP
          IF (IPR(431) == 1) THEN
            NQ1(6:7) = '--'
            NQ2(6:7) = '..'
          END IF
C * TEST FOR 1555 (UNIT SYMMETRY OPERATION)
          IF (ISOP == 1) THEN
            GSS(3) = '    .   '
          ELSE
            MISOP  = MOL(ISOP) / NINT (PAR(42))
            MISOPH = MISOP / 1000
            MISOPT = MISOP - MISOPH * 1000
            WRITE (GSS(3)(1:8), 99991, IOSTAT = IOST) MISOPH, MISOPT
          END IF
          NDECM = IDECM
          M = 0
          DO K = 1, 7, 2
            M = M + 1
            IF (K == 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
            FORMX(IPS:IPS) = CHAR (ICHAR ('0') + IDEC)
          END DO
          WRITE (PRBUF, FORMX, IOSTAT = IOST) NQ1(1:7), NQ2(1:7),
     1      NQ3(1:7), (DHA(M), IDHA(M), M = 1, 4), GSS(3)
          IF (IDOUBL == 2) WRITE (LU, 99990)
          CALL GEN065 (LU, PRBUF, 1, 80, 1)
        END DO
        RETURN
      END IF
      IF (IDOUBL == 2) WRITE (LU, 99990, IOSTAT = IOST)
      FORMX(2 : 2) = CHAR (ICHAR ('0') + ISPACE)
      NLIN        = MXLIN - LSTART
      ITEL        = LSTART
      IN3         = IPR(231)
      IN1         = IN3 + 1
      IN2         = IN3
C * SELECT AND COPY BEFORE SORTING
      DO J = IN01, IN02
        MJNSC = MOD (JNSC(1, J), IPR(466))
        IF (INCLH /= 0 .OR. MJNSC <= IPR(465)) THEN
          IN2          = IN2 + 1
          JNSC(1, IN2) = MJNSC
          JNSC(2, IN2) = JNSC(2, J)
        END IF
      END DO
C * REARRANGE JNSC FOR PRINTING IN A4-FORMAT WITH NLIN LINES AND
C *    NCOL COLUMS  AND N = IN2 - IN1 + 1 ENTRIES
C * UP TO NCOL - 1 ZERO ENTRIES ARE ADDED IN ORDER TO MAKE THE NUMBER OF
C *  ENTRIES DEVISABLE BY NCOL (N TO INP)
      IC  = NLIN * NCOL
C * IC IS THE NUMBER OF ENTRIES IN A FULL PAGE
      ICP2 = NCOL
      N    = IN2 - IN1 + 1
      INP  = (N + NCOL - 1) / NCOL
      INP  = INP * NCOL
C * MAKE THE LINKS IN JNSC ZERO FOR ENTRIES N + 1 TO INP
      INM  = INP - N
      IN2P = IN2 + INM
      DO J = 1, INM
        JNSC(2, J + IN2) = 0
      END DO
C * IM IS THE TOTAL NUMBER OF PAGES FOR THIS TABEL (THE LAST ONE POSSIBLY
C *    INCOMPLETE)
      IM = (INP + IC - 1) / IC
C * IC3 IS THE NUMBER OF ENTRIES ON THE LAST PAGE
      IC3 = INP - (IM - 1) * IC
C * SUPPLY SORTING INFORMATION FOR JNSC(1, J)
      DO M = 1, IM
        I = (M - 1) * NLIN * NCOL + IN1 - 1
        IF (M >= IM) IC = IC3
C * DETERMINE NUMBER OF LINES IN THIS PAGE
        ICS = IC / NCOL
        DO J = 1, NCOL
          DO K = 1, ICS
            IND = I + (J - 1) * ICS + K
            JNSC(1, IND) = (K - 1) * NCOL + J
          END DO
        END DO
        CALL GEN037 (JNSC, I + 1, I + IC)
      END DO
      K = 0
      DO I = IN1, IN2P
        K = K + 1
        L = JNSC(2, I)
        IF (L <= 0) THEN
          ICP2 = ICP2 - 1
        ELSE
          NHATS = 0
          NHET  = 0
          DO J = 1, JMX
            JLABN = LABB(NINT (VOID(L + J - 1)))
            IF (IPR(431) == -1) JLABN = - JLABN
            CALL PLA047 (JLABN, NQ1, ISOP, IENR, IPR(71),
     1        IGBL(55), 0, 1)
C * TEST FOR H-ATOMS
            IF (IENR == 1) NHATS = NHATS + 1
C * COUNT NUMBER OF HETERO ATOMS (= OTHER THAN CARBON, HYDROGEN)
            IF (IENR > 2) NHET  = NHET  + 1
            NAMS(K, J) = NQ1
            IF (IPR(431) == -1) THEN
              IF (ISOP == 1) THEN
                GSS(J) = '    .   '
              ELSE
                MISOP  = MOL(ISOP) / NINT (PAR(42))
                MISOPH = MISOP / 1000
                MISOPT = MISOP - MISOPH * 1000
                WRITE (GSS(J), 99991, IOSTAT = IOST) MISOPH, MISOPT
              END IF
            END IF
          END DO
          V2(K) = VOID(L + JMX)
          CALL GEN041 (V2(K), VOID(L + JMX + 1), ISDV(K),
     1                IDECM, IDEC, IPR(68))
          IPS = K * IPS1 - IPS2
          FORMX(IPS : IPS) = CHAR (ICHAR ('0') + IDEC)
        END IF
        IF (K >= NCOL) THEN
          ITEL = ITEL + 1
          IF (ITEL > MXLIN) THEN
            ITEL = LSTART + 1
            IF (IPR(431) == 1) THEN
              IGBL(85) = IGBL(85) + 1
              WRITE (LU, 99999, IOSTAT = IOST) CHAR (12), IGBL(85)
            END IF
            IF (IPR(431) == 1) THEN
              CALL PLA175 (1, LU, CTAB, NTAB, FORMH, JID)
            END IF
            IF (IDOUBL == 2) WRITE (LU, 99990, IOSTAT = IOST)
          END IF
          WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1      ((NAMS(M, J)(1:7), DASH, J = 1, JMX - 1),
     2      NAMS(M, JMX)(1:7), V2(M), ISDV(M), M = 1, ICP2)
          IF (IPR(431) == -1) THEN
            DO M = 1, JMX
              J = 38 + M * 8
              PRBUF(J : J + 8) = GSS(M)
            END DO
            IF (MODE < 7 .AND. NHATS == 0 .AND.
     1        NHET > 0 .AND. JMX < 4) THEN
              PRBUF(78:80) = 'yes'
            ELSE
              PRBUF(78:80) = 'no '
            END IF
          END IF
          CALL GEN065 (LU, PRBUF, 1, 80, 1)
          IF (IPR(431) == 1) WRITE (LU, 99990, IOSTAT = IOST)
          K    = 0
          ICP2 = NCOL
        END IF
      END DO
      IF (IOST /= 0) RETURN
      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 (1X)
      END SUBROUTINE PLA173
 
      SUBROUTINE PLA174 (MODE, LU, NCIFDIR, STR, IVAR, VAR)
C * TABLE & CIF CREATION (CONT)
      USE cif
      IMPLICIT NONE
      INTEGER          :: LU
      INTEGER          :: MODE
      INTEGER          :: IVAR
      INTEGER          :: IOST
      INTEGER          :: NCIFDIR
      REAL             :: VAR
      CHARACTER(len=*) :: STR
C * CHARACTER MODE
      IF (MODE == 1) THEN
        WRITE (LU, 99999, IOSTAT = IOST) CIFDIR(NCIFDIR), STR
C * INTEGER MODE
      ELSE IF (MODE == 2) THEN
        IF (IABS(IVAR) < 999999) THEN
          WRITE (LU, STR, IOSTAT = IOST) CIFDIR(NCIFDIR), IVAR
        ELSE
          WRITE (LU, 99999, IOSTAT = IOST) CIFDIR(NCIFDIR), ' ?'
        END IF
C * REAL VARIABLE MODE
      ELSE IF (MODE == 3) THEN
        IF (ABS(VAR) < 10000.0) THEN
          WRITE (LU, STR, IOSTAT = IOST) CIFDIR(NCIFDIR), VAR
        ELSE
          WRITE (LU, 99999, IOSTAT = IOST) CIFDIR(NCIFDIR), ' ?'
        END IF
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (2A)
      END SUBROUTINE PLA174
 
      SUBROUTINE PLA175 (MODE, LU, CTAB, NTB, FORMX, JID)
C * TABLE & CIF CREATION (CONT)
      IMPLICIT NONE
      INTEGER           :: N
      INTEGER           :: LU
      INTEGER           :: NTB
      INTEGER           :: MODE
      INTEGER           :: IOST
      CHARACTER(len=*)  :: JID
      CHARACTER(len=1)  :: CTAB
      CHARACTER(len=*)  :: FORMX
      CHARACTER(len=11) :: CHCON
      IF (MODE <= 0) THEN
        N     = 1
        CHCON = ' '
      ELSE
        N     = 11
        CHCON = '(continued)'
      END IF
      IF (MODE == 0) NTB         = NTB + 1
      IF (NTB  > 9) FORMX(19:19) = '2'
      WRITE (LU, FORMX, IOSTAT = IOST) CTAB, NTB, CHCON(1:N), JID(1:40)
      IF (IOST /= 0) RETURN
      RETURN
      END SUBROUTINE PLA175
 
      SUBROUTINE PLA176 (MODE)
C * CIF-READ ROUTINE
C * HANDLES, data_, loop_ and stop_ INSTRUCTIONS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cif
      USE cggt
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: N
      INTEGER            :: IESC
      INTEGER            :: MODE
      INTEGER            :: NLPNL
      CHARACTER(len=1)   :: QT
      CHARACTER(len=50)  :: SAV
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=1)   :: ICHU
      CHARACTER(len=1)   :: ICHUS
      CHARACTER(len=NKW) :: KEYWRD
C * PLA176 - MAIN CIF READ
C * PLA177 - CHECK FOR EMBEDDED MATERIAL BETWEEN ;;
C * PLA178 - SAVE EMBEDDED MATERIAL BETWEEN ;;
C * PLA179 - DATANAME -> VALUE
C * PLA180 - BUILDING KEYWORD
C * PLA181 - BOND, ANGLE ETC
C * PLA182 - HANDLE WEIGHT EXPRESSION
C * PLA184 - INSPECT EMBEDDED RES FILE
C * PLA185 - HANDLE CELL DATA
C * CIF-READ MODE = 0 : PLATON,
C *          MODE = 1 : PLUTON
C * LRETCIF = -2
C * LRETCIF - -1
C * LRETCIF =  0 :                                                (Input)
C * LRETCIF =  1 : NORMAL RETURN
C * LRETCIF =  2 : ERROR RETURN
C * LRETCIF =  3 : SYSTEM-S RETURN
C * LRETCIF =  4 : BOND, ANGLE, TORSION, HBOND
C * LRETCIF = 10 : LEAVE PLA176, GET NEW RECORD
C * LRETCIF = 12 :
C * INTERPRETE THE CIF-RECORD IN ICL
C * CHECK FOR/HANDLE/SAVE MATERIAL BETWEEN ;;
      IF (ISEMCOL == 0 .AND. ICL(1:1) == '#') RETURN
C * CHECK FOR/EMBEDDED MATERIAL BETWEEN ;:
      CALL PLA177
      IF (LRETCIF > 0) THEN
        LRETCIF = MOD (LRETCIF, 10)
      ELSE
        IF (ICL(1:1) /= '#') THEN
C * SKIP BLANK RECORDS
          DO I = 1, IRECMAX
            IF (ICL(I : I) /= CHAR (32)) GO TO 10
          END DO
        END IF
      END IF
      RETURN
C * TEST FOR DATASET HEADER data_ RECORD
   10 K = INDEX (ICL, 'data_')
      IF (K > 0) THEN
        IF (INDEX (ICL(1:80), '_data_') == 0) THEN
          IPR(752) = INDEX (ICL(1:80), 'global')
C * (RE)SET # H-M TO ZERO
          IPR(713) = 0
C * CHECK FOR TRAILING GLOBAL RECORD
          IF (IPR(499) > 0) THEN
            IF (INDEX (ICL(1:80), 'global') /= 0) THEN
              LRETCIF = 2
              RETURN
            END IF
          END IF
          ISEMCOL = 0
          N = INDEX (ICL(1:80), 'CSD_CIF')
          IF (N == 0) THEN
            N = K + 5
          ELSE
            IF (ICL(N+8:N+11) == 'MIF_') THEN
              N = N + 12
            ELSE
              N = N + 8
            END IF
C * CSD CIF STYLE DATA
            IGBL(94) = 1
          END IF
C * TEST FOR 'No-Atom-Yet'
          IF (IPR(39) == 0) THEN
            CALL GEN151 (ICL, N)
            JID = ICL(N:79 + N)
          END IF
C * INIT CELL/CIF
          LRETCIF = 0
          CALL PLA185 (0)
C * COUNT # DATASETS IN CIF
          IPR(499) = IPR(499) + 1
C * HANDLE INCOMPLETE STRUCTURE DATA ENTRY
          IF (IPR(499) > 1) THEN
C * TEST FOR 'No-Atom-Yet'
            IF (IPR(39) == 0) THEN
C * TEST FOR AUTO-S-MODE
              IF (IGBL(50) == 0)
     1          WRITE (LU6, 99999, IOSTAT = IOST) JID
C * TEST FOR CSD-CIF
              IF (IGBL(94) == 1) THEN
C * TEST FOR PREVIOUS/HANDLE CURRENT ENTRY NUMBER
                IF (IGBL(58) == 0) THEN
                  IGBL(54) = IGBL(54) + 1
                ELSE
                  IGBL(54) = IGBL(54) - 1
                END IF
              END IF
              RETURN
            END IF
            BACKSPACE IGBL(5)
            IFL(1)   = 'ENDS'
            ICL      = 'ENDS'
            IPR(220) = 1
            IPR(221) = 0
            IGBL(8)  = - IABS (IGBL(8))
            LRETCIF  = 1
            RETURN
          END IF
          ICL    = 'TITL '//JID(1:75)
          IFL(1) = 'TITL'
          IF (IGBL(3) /= 14) CALL GEN108 (LU11, 0)
          CALL PLA236 (0, 0, 0.0, 0.0, LINE(I:80), ' ')
          IPR(220) = 1
          IPR(221) = 0
          LRETCIF  = 1
          RETURN
        END IF
C * TEST FOR loop_ RECORD
      ELSE IF (ICL(I : I + 4) == 'loop_') THEN
C * SAVE POSSIBLE REMAINING CONTENTS
        DO J = I + 5, 80
          IF (ICL(J:J) /= CHAR (32)) THEN
            IGGT(1:80) = ICL(J:80)
            EXIT
          END IF
        END DO
        NSTRS    = 0
        ILOOP    = 1
        NLPM     = 0
        IPR(220) = 0
        IPR(221) = 0
        RETURN
C * TEST FOR stop_ RECORD
      ELSE IF (ICL(I : I + 4) == 'stop_') THEN
        RETURN
      END IF
C * RESET (NON)KEYWORD STATUS FOR NEW RECORD
C * KW = NUMBER OF CHARACTERS IN KEYWORD
C * NW = NUMBER OF CHARACTERS IN NON-KEYWORD STRING(TEXT OR NUMBER)
      KW = 0
      NW = 0
      NL = 0
C * BLANK KEYWORD (MAX KEYWORD LENGTH = NKW
      CALL GEN038 (KEYWRD, 1, NKW)
C * DEFAULT ESCAPE
   20 IESC = 0
      DO I = 1, IRECMAX + 1
        ICH = ICL(I : I)
C * SUBSTITUTE BLANK FOR CONTROL CHARACTERS ETC.
        IF (ICHAR (ICH) < 32 .OR. ICHAR (ICH) > 126)
     1    ICH = CHAR (32)
C * UPPERCASE
        ICHU  = ICH
        ICHUS = ICH
        CALL GEN020 (1, ICHU, 1, 1)
C * CONTINUE/FINISH BUILDING KEYWORD
        IF (KW /= 0) THEN
          CALL PLA180 (ICH, KEYWRD)
          IF (LRETCIF > 0) RETURN
        ELSE
C * START NEW WORD
          IF (NW == 0) THEN
C * START NEW KEYWORD
            IF (ICH == '_') THEN
              KW          = 1
              KEYWRD(1:1) = ICH
              IF (ILOOP == 0) NLPM = 0
              LINE = ' '
C * START NEW STRING
            ELSE IF (ICH /= CHAR (32)) THEN
              IF (ICH /= '''' .AND. ICH /= '"') THEN
                CALL GEN038 (NWRD, 3, NP70)
                NW         = 2
                NWRD(2:2)  = ICHU
                NWRDS(2:2) = ICHUS
                QT         = CHAR (32)
              ELSE
                NW         = 1
                QT         = ICH
              END IF
            END IF
          ELSE
            IF (NW > 0 .AND. NW <= NP70 - 2) THEN
              NW            = NW + 1
              NWRD(NW:NW)   = ICHU
              NWRDS(NW:NW)  = ICHUS
            ELSE IF (NW == NP70 - 1) THEN
              NW            = NW + 1
              NWRD(NW:NW)   = NWRD(1:1)
              NWRDS(NW:NW)  = NWRDS(1:1)
              WRITE (LU6, 99998, IOSTAT = IOST) ICL(1:80), ICL(81:160)
            END IF
C * HANDLE \' AND \" IN
            IF ((ICH == '''' .OR. ICH == '"') .AND. IESC == 1)
     1        THEN
              IESC = 0
            ELSE IF (ICH == CHAR (92)) THEN
              IESC = 1
            ELSE IF (ICH == QT) THEN
              IF (QT == ' ' .OR. QT == '"') NWRD(NW:NW) = ''''
              ILOOP = 0
              IF (NL == 0) THEN
                IPR(220) = 0
                IPR(221) = 0
              END IF
C * ANALYSE DATUM IN POSITION 2 TO END (I.E. QUOTE)
              CALL GEN042 (NWRD, FA, KNUM)
C * REPORT OVERFLOW
              IF (KNUM == -2) THEN
                WRITE (LU6, 99997, IOSTAT = IOST) KEYWRD, NWRD
              END IF
              IF (NL < NLPM) THEN
                NL    = NL + 1
                K     = I
                NLPNL = NLP(NL)
                CALL PLA179 (MODE, K, NLPNL)
                IF (LRETCIF > 0) THEN
                  LRETCIF = MOD (LRETCIF, 10)
                  RETURN
                ELSE
C * OUTPUT RESULTS
                  IF (NL == NLPM) THEN
                    IF (NLPM > 1) THEN
                      IF (ICL(1:4) /= 'SYMM') THEN
                        DO J = I, I + 10
                          IF (ICL(J:J) /= CHAR(32)) THEN
C * CHECK FOR QUOTE
                            IF (ICL(J:J) /= CHAR (39)) THEN
C *  SAVE RESIDUAL CONTENT
                              IGGT(1:80) = ICL(J : J + 79)
                            END IF
                            EXIT
                          END IF
                        END DO
                      END IF
                    END IF
 
                    IF (IPR(220) <= 0) THEN
C * CHECK FOR BOND/ANGLE/TORSION/CONTACT/HBONDS
                      IF (IPR(751) == 1) CALL PLA181 (MODE)
                    ELSE
                      LRETCIF = 1
                      RETURN
                    END IF
                  END IF
                END IF
              END IF
              CALL GEN038  (NWRD, 1, NP70)
              NW = 0
            ELSE
              IESC = 0
            END IF
          END IF
        END IF
      END DO
C * HANDLE INCOMPLETE LOOP (CONTINUE ON NEW LINE)
   30 IF (KW == 0 .AND. NL > 0) THEN
        IF (NL < NLPM) THEN
          READ (LU1, 99996, IOSTAT = IOST) ICL
          IF (IOST == 0) THEN
   40       N = INDEX (ICL, 'data_')
            IF (N /= 0) THEN
              I     = N
              NLPM  = 0
              ILOOP = 0
              GO TO 10
            ELSE
              IF (ICL(1:1) == ';') THEN
                IF (NLPM > 1) THEN
                  IF (ISEMCOL == 0) THEN
                    ISEMCOL = 1
                    DO J = 2, 51
                      IF (ICL(J:J) /= ' ') THEN
                        SAV = ICL(J:J+49)
                        ICL = SAV
                        GO TO 40
                      END IF
                    END DO
                    GO TO 30
                  ELSE
                    BACKSPACE LU1
                    ICL = '?'
                    GO TO 40
                  END IF
                END IF
C * HANDLE ; PROBLEM IN LOOP
                DO
                  READ (LU1, 99996, IOSTAT = IOST) ICL
                  IF (IOST /= 0) THEN
                    IF (ICL(1:1) /= ';') CYCLE
                    ICL(1:9) = ' '' ? '' # '
                    EXIT
                  ELSE
                    LRETCIF = 2
                    RETURN
                  END IF
                END DO
              END IF
              NW = 0
              GO TO 20
            END IF
          ELSE
            LRETCIF = 2
          END IF
        END IF
      END IF
C * RETURN TO PLA006
      RETURN
99999 FORMAT ('W: CIF Data_Record with no Atom Data: Skipped', //,
     1        ':: New Data Set ', A, /)
99998 FORMAT (':: OVERFLOW PROBLEM in RECORD:', /, A, /, A, /,
     1    '... etc ...', /, ':: RECORD TRUNCATED to 80 Characters', /)
99997 FORMAT (':: ERROR: KEYWORD/DATUM OVERFLOW ', A, /, A)
99996 FORMAT (A)
      END SUBROUTINE PLA176
 
      SUBROUTINE PLA177
C * CHECK FOR/EMBEDDED MATERIAL BETWEEN ;:
      USE files
      USE parameters
      USE cif
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: N
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: NB
      INTEGER :: NE
      INTEGER :: NZERO
      REAL    :: VAL1
      REAL    :: VAL2
      REAL    :: RATIO
C * SKIP/SAVE TEXT WITHIN SECTION STRINGS AND EMBEDDED INFO
      NZERO   = 0
      LRETCIF = 0
      IF (ISEMCOL == 0) THEN
        NSTRS = 0
        NSTR  = 0
      END IF
      IF (ICL(1:1) /= ';') THEN
C * CHECK FOR CURRENT SEMICOLUMN SECTION STATUS
        IF (ISEMCOL == 1) THEN
C * INIT VOID COUNTS
          IF (INDEX (ICL, '_platon_squeeze_void_nr') /= 0) THEN
            PAR(437) = 0.0
            PAR(438) = 0.0
          END IF
          IF (IVOID == -1) THEN
            IF (INDEX (ICL, '_platon_squeeze_void_content') /= 0)
     1        IVOID = 1
          ELSE IF (IVOID == 1) THEN
            IF (INDEX (ICL, '_platon_squeeze_details') /= 0) THEN
                IVOID = 0
            ELSE
              IF (IPR(665) == 1) THEN
                READ (ICL, *, IOSTAT = IOST) (FN(I), I = 1, 6)
                PAR(437) = PAR(437) + FN(5)
                PAR(438) = PAR(438) + FN(6)
              END IF
            END IF
C * TEST FOR SQUEEZE DETAILS
          ELSE IF (ICL(1:9) == '# SQUEEZE') THEN
            IF (IPR(665) == 1) THEN
              IF (MOD (IPR(651), 10) /= 1) IPR(651) = IPR(651) + 1
              IF (IPR(665) /= 0) IVOID = -1
            END IF
          END IF
C * COPY _shelx_res DATA
          IF (IPR(663) == 1) THEN
            CALL GEN155 (1, ICL, NZERO)
C * INSPECT .RES FILE CONTENT
            CALL PLA184
            WRITE (LU24, 99998, IOSTAT = IOST) ICL(1:80)
            IPR(653) = IPR(653) + 1
C * COPY _shelx_hkl DATA
          ELSE IF (IPR(664) == 1) THEN
            CALL GEN155 (1, ICL, NZERO)
            IF (ICL(1:1) /= '_') THEN
C * HANDLE SPURIOUS BLANK RECORDS IN EMBEDDED HKL FILE
              IF (ICL(1:4) == '    ') THEN
                READ (LU1, 99998, IOSTAT = IOST) ICL
                IF (IOST == 0) THEN
                  IF (ICL(1:1) == ';') THEN
                    BACKSPACE (LU1)
                  ELSE
                    READ (ICL, 99997, IOSTAT = IOST) IH, IK, IL,
     1                VAL1, VAL2
                    IF (IOST == 0) THEN
                      IF (IABS (IH) + IABS (IK) + IABS (IL) /= 0) THEN
                        BACKSPACE (LU1)
C * REPORT/COUNT REMOVED BLANK RECORDS
                        WRITE (LU6, 99994)
                        IPR(770) = IPR(770) + 1
                      ELSE
                        WRITE (LU25, 99996)
                      END IF
                    ELSE
                      IF (ICL(88:88) == ' ') THEN
                        WRITE (LU25, 99995) ICL(1:80)
                      ELSE
                        WRITE (LU25, 99995) ICL(1:112)
                      END IF
                      CALL GEN155 (1, ICL, NZERO)
                    END IF
                  END IF
                END IF
              ELSE
                IF (ICL(88:88) == ' ') THEN
                  WRITE (LU25, 99998, IOSTAT = IOST) ICL(1:80)
                ELSE
                  WRITE (LU25, 99998, IOSTAT = IOST) ICL(1:112)
                END IF
                READ (ICL(1:28), 99997, IOSTAT = IOST)
     1            IH, IK, IL, VAL1, VAL2
                IF (IOST == 0) THEN
                  IF (IABS (IH) + IABS (IK) + IABS (IL) /= 0)
     1              IPR(742) = IPR(742) + 1
C * CHECK FOR UNUSUAL (CALCULATED) DATA
                  IF (VAL1 > 0.0 .AND. VAL2 /= 0.0) THEN
                    IF (IPR(741) == 0)
     1                REWIND (UNIT = LU67, IOSTAT = IOST)
                    RATIO    = VAL2 / SQRT (VAL1)
                    PAR(555) = PAR(555) + RATIO
                    IPR(741) = IPR(741) + 1
                    WRITE (LU67) RATIO
                  END IF
                END IF
              END IF
            END IF
            IF (ICL(1:7) == '_platon')
     1        CALL PLA236 (991, 0, -999.0, 1.0, ' ', ' ')
C * COPY _shelx_fab DATA
          ELSE IF (IPR(665) == 1) THEN
            CALL GEN155 (1, ICL, NZERO)
            WRITE (LU26, 99998, IOSTAT = IOST) ICL(1:80)
C * COPY EMBEDDED FCF DATA
          ELSE IF (IPR(666) == 1) THEN
            WRITE (LU28, 99998, IOSTAT = IOST) ICL(1:80)
C * COPY EMBEDDED FILE (e.g. .bodd - IDEAL Invariom Software)
          ELSE IF (IPR(667) == 1) THEN
            WRITE (LU65, 99998, IOSTAT = IOST) ICL(1:80)
C * COPY OTHER TEXT DATA
          ELSE
C * COUNT LINES BETWEEN ;; FOR NONE OF THE ABOVE
            IPR(654) = IPR(654) + 1
C * CHECK ACTUAL RECORD LENGTH - ASSUME 80 WHEN FOLLOWED BY 10 BLANKS
            IF (ICL(81:90) /= '          ') THEN
C * SKIP IN CASE OF _iucr_refine_reflections_details
              IF (NLP(1) /= 569) THEN
                IPR(544) = IPR(544) + 1
                IF (IPR(544) == 1)
     1            WRITE (LU6, 99999, IOSTAT = IOST) ICL(1:15)
              END IF
            END IF
            CALL GEN039 (1, ICL, 1, 250, NB, NE)
            IF (NSTR < 0) NSTR = 0
            IF (NE - NB + 1 > 0 .AND. NSTR + NE - NB + 2 < 5000)
     1        THEN
              STRSAVE(NSTR + 1:) = ICL(1:NE + 1)
              NSTR = NSTR + NE - NB + 2
            END IF
            NSTRS = NSTR
          END IF
          LRETCIF = 10
          RETURN
        END IF
C * END ISEMCOL = 1 SECTION
C * SECTION STRINGS (IN-STRING FLIP-FLOP ISEMCOL)
      ELSE
        CALL PLA178
        IF (LRETCIF == 10) RETURN
      END IF
C * SKIP EMPTY RECORDS
      IF (ICL(1:1) /= CHAR(13)) THEN
        NSTR = -1
C * CHECK ACTUAL RECORD LENGTH - ASSUME 80 WHEN FOLLOWED BY 10 BLANKS
C * EXCEPT FOR THE EMBEDDED REFLECTION SECTION
        IRECMAX = 80
        IF (IPR(646) <= 0) THEN
          IF (ICL(81:81) == CHAR (13)) ICL(81:81) = CHAR (32)
          IF (ICL(81:90) /= '          ') THEN
            IRECMAX = NP45 - 1
            IF (IPR(654) == 0) THEN
              IPR(544) = IPR(544) + 1
              IF (IPR(544) == 1)
     1          WRITE (LU6, 99999, IOSTAT = IOST) ICL(1:15)
            END IF
          END IF
        END IF
        N    = INDEX (ICL(1:IRECMAX), ' #')
C * BLANK DATA FROM #
        IF (N > 1) CALL GEN038 (ICL, N, IRECMAX)
      END IF
      RETURN
99999 FORMAT (':: Record(s) Longer than 80 Bytes found,',
     1        ' 2048 Bytes Assumed: ', A, ' ...')
99998 FORMAT (A)
99997 FORMAT (3I4, 2F8.0)
99996 FORMAT (1X)
99995 FORMAT (/, A)
99994 FORMAT (':: Empty Record in Embedded HKL File Removed !')
      END SUBROUTINE PLA177
 
      SUBROUTINE PLA178
C * SAVE EMBEDDED MATERIAL BETWEEN ;;
      USE files
      USE parameters
      USE cchar
      USE cif
      IMPLICIT NONE
      INTEGER :: MSTR
      INTEGER :: NB
      INTEGER :: NE
      INTEGER :: NZERO
      ISEMCOL = MOD (ISEMCOL + 1, 2)
C * ISEMCOL = 1 : HANDLE TEXT SECTIONS BETWEEN SEMI-COLONS
      IF (ISEMCOL == 1) THEN
C * _shelx_res_file (SHELXL201n) (578)
C * _iucr_refine_instructions_details + WINGX (513)
        IF (NLP(1) == 578 .OR. NLP(1) == 513) THEN
          IPR(663) = 1
C * INIT CHECKSUM RES
          CALL GEN155 (0, ICL, NZERO)
C *HANDLE RARE CASE WHERE BOTH _shelx_res_file and
C * _iucr_refine_instructions_details are erroneously embedded
          IF (NLP(1) == 578) THEN
            IF (IPR(701) /= 1) IPR(701) = 1
          ELSE IF (NLP(1) == 513) THEN
            IF (IPR(701) /= 1) IPR(701) = 2
          END IF
C * INIT RES CHECKSUM (NOT) PRESENT
          IF (IPR(725) /= 5 .AND. IPR(725) /= 7) THEN
            IF (IPR(677) == 0) THEN
              IPR(677) = -1
            ELSE
              IPR(677) = IABS (IPR(677))
            END IF
          END IF
          INQUIRE (UNIT = LU24, OPENED = OPEND)
          IF (OPEND) CLOSE (UNIT = LU24, STATUS = 'DELETE')
          OPEN (UNIT = LU24, FILE =  NAMEFIL(1:KNMFIL)//'_sx.ins',
     1      STATUS = 'UNKNOWN', IOSTAT = IOST)
          IF (IOST /= 0) REWIND (UNIT = LU24, IOSTAT = IOST)
          WRITE (LU6, 99999) NAMEFIL(1:KNMFIL)//'_sx.ins'
C * _shelx_hkl_file (SHELXL201n) (580)
C * _iucr_refine_reflections_details + WINGX (569)
        ELSE IF (NLP(1) == 580 .OR.
     1    (NLP(1) == 569 .AND. IPR(725) == 7)) THEN
          IF (NLP(1) == 580) THEN
            IPR(702) = 1
          ELSE IF (NLP(1) == 569) THEN
            IPR(702) = 2
          END IF
          IPR(664) = 1
          IPR(676) = 1
          IPR(646) = 1
C * INIT CHECKSUM HKL
          CALL GEN155 (0, ICL, NZERO)
C * INIT HKL CHECKSUM (NOT) PRESENT
          IF (IPR(725) /= 7) THEN
            IF (IPR(678) == 0) THEN
              IPR(678) = -1
            ELSE
              IPR(678) = IABS (IPR(678))
            END IF
          END IF
          INQUIRE (UNIT = LU25, OPENED = OPEND)
          IF (OPEND) CLOSE (UNIT = LU25, STATUS = 'DELETE')
          OPEN (UNIT = LU25, FILE = NAMEFIL(1:KNMFIL)//'_sx.hkl',
     2      STATUS = 'UNKNOWN', IOSTAT = IOST)
          IF (IOST /= 0) REWIND (UNIT = LU25, IOSTAT = IOST)
          WRITE (LU6, 99999) NAMEFIL(1:KNMFIL)//'_sx.hkl'
C * _shelx_fab_file (SHELXL201n) (601)
        ELSE IF (NLP(1) == 601) THEN
          IPR(665) =  1
C * INIT CHECKSUM FAB
          CALL GEN155 (0, ICL, NZERO)
C * INIT FAB CHECKSUM (NOT) PRESENT
          IF (IPR(679) == 0) THEN
            IPR(679) = -1
          ELSE
            IPR(679) = IABS (IPR(679))
          END IF
          INQUIRE (UNIT = LU26, OPENED = OPEND)
          IF (OPEND) CLOSE (UNIT = LU26, STATUS = 'DELETE')
          OPEN (UNIT = LU26, FILE =
     1      NAMEFIL(1:KNMFIL)//'_sx.fab', STATUS = 'UNKNOWN')
          IF (IOST /= 0) REWIND (UNIT = LU26, IOSTAT = IOST)
          WRITE (LU6, 99999) NAMEFIL(1:KNMFIL)//'_sx.fab'
C * _shelx_fcf_file (905)
C * _iucr_refine_fcf_details (761)
        ELSE IF (NLP(1) == 761 .OR. NLP(1) == 905) THEN
          IPR(666) = 1
          INQUIRE (UNIT = LU28, OPENED = OPEND)
          IF (OPEND) CLOSE (UNIT = LU28, STATUS = 'DELETE')
          OPEN (UNIT = LU28, FILE = NAMEFIL(1:KNMFIL)//'_sx.fcf',
     1    STATUS = 'UNKNOWN')
          WRITE (LU6, 99999) NAMEFIL(1:KNMFIL)//'_sx.fcf'
C * INIT CHECKSUM INCLUDE FILE
        ELSE IF (NLP(1) == 892) THEN
          CALL GEN155 (0, ICL, NZERO)
C * REGULAR TEXT SECTION
        ELSE
          IPR(654) = 0
          CALL GEN039 (1, ICL, 1, 250, NB, NE)
          IF (NE > 1) THEN
            STRSAVE(1:NE) = ICL(2:NE + 1)
            NSTR    = NE
          ELSE
            STRSAVE = ' '
            NSTR    = 0
            NSTRS   = 0
          END IF
        END IF
        LRETCIF = 10
        RETURN
C * ISEMCOL = 0: TERMINATE TEXT SECTION
      ELSE
        IPR(646) = - IABS (IPR(646))
        IF (IPR(663) == 1) THEN
          CALL GEN155 (-1, ICL, IPR(721))
          IF (IPR(725) == 5) THEN
            IPR(663) = 0
            CLOSE (UNIT = LU24, IOSTAT = IOST)
          ELSE
            IPR(663) = -1
            ENDFILE (LU24, IOSTAT = IOST)
          END IF
C * END EMBEDDED HKL
        ELSE IF (IPR(664) == 1) THEN
          IPR(664) = -1
          CALL GEN155 (-1, ICL, IPR(722))
C * END EMBEDDED FAB
        ELSE IF (IPR(665) == 1) THEN
          IPR(665) = -1
          CALL GEN155 (-1, ICL, IPR(723))
C * END EMBEDDED FCF
        ELSE IF (IPR(666) == 1) THEN
          IPR(666) = -1
          CLOSE (UNIT = LU28, IOSTAT = IOST)
C * END EMBEDDED INCLUDE FILE
        ELSE IF (IPR(667) == 1) THEN
          IPR(667) = -1
          CALL GEN155 (-1, ICL, IPR(724))
          CLOSE (UNIT = LU65, IOSTAT = IOST)
        ELSE
          MSTR = MIN (78, MAX (NSTR, 1))
          ICL  = CHAR (39)//STRSAVE(1:MSTR)//CHAR (39)
        END IF
      END IF
      RETURN
99999 FORMAT (':: Extracted from CIF: ', A)
      END SUBROUTINE PLA178
 
      SUBROUTINE PLA179 (MODE, I0, NLPNL)
C * DATANAME > VALUE
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cif
      USE cggt
      USE pl273
      USE sgxyz
      IMPLICIT NONE
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: K
      INTEGER                 :: M
      INTEGER                 :: N
      INTEGER                 :: N1
      INTEGER                 :: N2
      INTEGER                 :: I0
      INTEGER, SAVE           :: JH = 0
      INTEGER, SAVE           :: JK = 0
      INTEGER, SAVE           :: JL = 0
      INTEGER                 :: LB
      INTEGER                 :: LE
      INTEGER                 :: NB
      INTEGER                 :: NE
      INTEGER                 :: JSGR
      INTEGER                 :: MODE
      INTEGER                 :: NORC
      INTEGER                 :: NWMX
      INTEGER                 :: NLPNL
      INTEGER                 :: NZERO
      INTEGER                 :: NELTYPE
      REAL, SAVE              :: FSQ = 0.0
      REAL, SAVE              :: SIG = 0.0
      REAL                    :: YUNK
      REAL                    :: RATIO
      REAL                    :: RATIO1
      CHARACTER(len=9)        :: NQY
      CHARACTER(len=18), SAVE :: FORMA
      CHARACTER(len=2)        :: ELTYPE
      NZERO = 0
      SELECT CASE (NLPNL)
C * _pd_block_id
        CASE (937)
          IPR(105) = 1
C * _reflns_special_details
        CASE (417)
C * _shelx_space_group_comment
        CASE (574)
C * _geom_special_details
        CASE (277)
C * _chemical_name_systematic
        CASE (116)
C * _ATOM_SITES_SOLUTION_PRIMARY
        CASE (48)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(10) = NWRD(2:NW - 1)
            NCIF(10) = NW - 2
C * CHECK FOR NON-DEFAULT INFO
            IF (INDEX(CCIF(10), '?') == 0) IPR(740) = 1
          END IF
          CALL GEN020 (-1, CCIF(10),  1, NP57)
C * _atom_sites_solution_secondary
        CASE (49)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(11) = NWRD(2:NW-1)
            NCIF(11) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(11),  1, NP57)
C * _atom_sites_solution_hydrogen
        CASE (50)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(12) = NWRD(2:NW-1)
            NCIF(12) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(12),  1, NP57)
C * NOTE GENERATION BY SHELXL/CRYSTALS etc
C * _audit_creation_method
        CASE (72)
          NWMX     = MIN (NW - 2, NP57)
          CCIF(23) = NWRD(2:NWMX + 1)
          NCIF(23) = NWMX
          IF (INDEX (NWRD, 'SHELXL-97') /= 0 .OR.
     1        INDEX (NWRD, 'SHELXL97')  /=0) THEN
            IF (IPR(725) /= 1) THEN
              IPR(725) = 1
C * ALERT _899
              CALL PLA236 (899, 0, -999.0, 2019.0, '   2019/3',
     1          'SHELXL-97 ')
            END IF
            XLDTP = '97'
C * APEX
          ELSE IF (INDEX (NWRD, 'APEX') /= 0) THEN
            IPR(725) = 1
C * SHELXL-20xx
          ELSE IF (INDEX (NWRD, 'SHELXL-20') /= 0) THEN
            IPR(725) = 2
            N = INDEX (NWRD, '-20')
            XLDTP = NWRD(N + 3:N + 4)
            IF (XLDTP == '18')
C * ALERT _899
     1        CALL PLA236 (899, 0, -999.0, 2019.0, '   2019/3',
     2          'SHELXL2018')
C * PLATON
          ELSE IF (INDEX (NWRD, 'PLATON') /= 0) THEN
            IPR(725) = 3
C * CRYSTALSTRUCTURE
          ELSE IF (INDEX (NWRD, 'CRYSTALSTRUCTURE') /= 0)
     1      THEN
            IPR(725) = 4
C * CRYSTALS
          ELSE IF (INDEX (NWRD, 'CRYSTALS') /= 0) THEN
            IPR(725) = 5
C * JANA
          ELSE IF (INDEX (NWRD, 'JANA') /= 0) THEN
            IPR(725) = 6
C * WINGX
          ELSE IF (INDEX (NWRD, 'WINGX') /= 0) THEN
            IPR(725) = 7
C * OLEX2-REFINE
          ELSE IF (INDEX (NWRD, 'OLEX2') /= 0) THEN
            IPR(725) = 8
C * MOPRO - REFINE
          ELSE IF (INDEX (NWRD, 'MOPRO') /= 0) THEN
            IPR(725) = 9
C * SET MOPRO WEIGHT DEFAULT
            IPR(632) = 4
          END IF
C * _computing_data_collection
        CASE (118)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(20) = NWRD(2:NW-1)
            NCIF(20) = NW - 2
          END IF
C * _computing_data_reduction
        CASE (119)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(21) = NWRD(2:NW-1)
            NCIF(21) = NW - 2
          END IF
C * _computing_structure_refinement
        CASE (122)
          NWMX = MIN(NW -2, NP57)
          CCIF(22) = NWRD(2:NW-1)
          NCIF(22) = NWMX
C * _diffrn_measurement_method
        CASE (137)
          IF (INDEX (NWRD, 'LAUE') /= 0) IPR(106) = 1
C * _diffrn_radiation_source, _diffrn_source (e.g. Rotating Anode)
        CASE (162, 492)
C * GET ABSORPTION CORRECTION TYPE
C * _diffrn_radiation_probe
        CASE (481)
          IF (INDEX (NWRD, 'X-RAY') > 0) THEN
            IPR(630) = 0
          ELSE IF (INDEX (NWRD, 'NEUTRON') > 0) THEN
            IPR(671) = 7
            IPR(493) = 7
            IPR(630) = 1
          ELSE IF (INDEX (NWRD, 'ELECTRON') > 0) THEN
            IPR(493) = 8
            IPR(671) = 8
            IPR(630) = 2
          ELSE IF (INDEX (NWRD, 'SYNCHROTRON') > 0) THEN
            IPR(671) = 6
            IPR(630) = 3
          ELSE IF (INDEX (NWRD, 'GAMMA') > 0) THEN
C * NOT YET IMPLEMENTED
          END IF
        CASE (232)
          RLWS(3)  = ''''//NWRD(2:79)
          IPR(485) = -2
          IF (KNUM < 0) THEN
            IPR(485) = -1
          ELSE
            SELECT CASE (NWRD(2:3))
C * NONE
              CASE ('NO')
                IPR(485) = 0
C * ANALYTICAL
              CASE ('AN')
                IPR(485) = 1
C * GAUSSIAN
              CASE ('IN', 'GA')
                IPR(485) = 2
C * NUMERICAL
              CASE ('NU')
                IPR(485) = 3
C * PSI-SCAN
              CASE ('EM', 'PS')
                IPR(485) = 4
C * MULTI-SCAN
              CASE ('MU')
                IPR(485) = 5
C * REFINE/DIFABS
              CASE ('RE')
                IPR(485) = 6
C * SPHERICAL ABS CORRECTION REPORTED
              CASE ('SP')
                IPR(485) = 7
C * CYLINDER
              CASE ('CY')
                IPR(485) = 8
            END SELECT
          END IF
C * _exptl_absorpt_process_details
        CASE (233)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(19) = NWRD(2:NW-1)
            NCIF(19) = NW - 2
          END IF
C * _exptl_crystal_color
        CASE (234)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(14) = NWRD(2:NW-1)
            NCIF(14) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(14),  1, NP57)
C * _exptl_crystal_description
        CASE (239)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(5) = NWRD(2:NW-1)
            NCIF(5) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(5),  1, NP57)
C * EXTINCTION EXPRESSION
        CASE (353)
          RLWS(2) = ''''//NWRD(2:79)
C * _refine_ls_structure_factor_coef
        CASE (369)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(2) = NWRD(2:NW-1)
            NCIF(2) = NW - 2
          END IF
          IF (CCIF(2)(1:4) == 'FSQD') THEN
            CCIF(2) = 'Fsqd'
            IPR(309) = 2
          ELSE
            IPR(309) = 1
          END IF
C * _refine_ls_extinction_method
        CASE (354)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(4) = NWRD(2:NW-1)
            NCIF(4) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(4),  1, NP57)
C * _refine_ls_matrix_type
        CASE (358)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(3) = NWRD(2:NW-1)
            NCIF(3) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(3),  1, NP57)
C * _refine_ls_number_restraints
        CASE (362)
          IPR(273) = NINT(FA(1))
C * ALERT FOR MORE THAN 1 RESTRAINTS IN NON-CENTRO AND 0 FOR CENTRO
C * ALERT _860
          CALL SGSM (18, IDM, SGY, 0, 0, IERR)
          NORC = 0
          DO K = 1, 3
            IF (NINT (SGY(9 + K)) /= 0) NORC = NORC + 1
          END DO
          IF (IPR(273) > NORC) THEN
            CALL PLA236 (860, 0, -999.0, FA(1), ' ', ' ')
          END IF
C *  _refine_ls_weighting_scheme
        CASE (370)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(9) = NWRD(2 : NW - 1)
            NCIF(9) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(9), 1, 9)
C * RESET VOID VOLUME & COUNT INFO
        CASE (503)
          IF (NINT(FA(1)) == 1) THEN
            IF (IPR(651) == 0) IPR(651) = 1
            PAR(437) = 0.0
            PAR(438) = 0.0
          END IF
C * _refine_special_details
        CASE (373)
C * _reflns_observed_criterion
C * _reflns_threshold_expression
        CASE (412, 443)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(1) = NWRD(2:NW-1)
            NCIF(1) = NW - 2
          END IF
C * TEST FOR '>' AND '\'
          N1 = INDEX (CCIF(1)(1:NCIF(1)), CHAR (62))
          N2 = INDEX (CCIF(1)(1:NCIF(1)), CHAR (92))
          IF (N2 - N1 > 1) THEN
            READ (CCIF(1)(N1+1:N2-1), *, IOSTAT = IOST) YUNK
            IF (IOST == 0) THEN
              PAR(484) = YUNK
C * ALERT _966 - NON-STANDARD THRESHOLD VALUE
              IF (YUNK /= 2.0) THEN
                CALL PLA236 (966, 1, -999.0, YUNK, ' ', ' ')
              END IF
            END IF
          END IF
          CALL GEN020 (-1, CCIF(1),  1, NP57)
C * _refine_ls_weighting_details
        CASE (451)
          CALL PLA182
C * _iucr_refine_instruction(s)_details
C * _iucr_refine_instructions_details_restraints
C * _iucr_refine_instructions_details_constraints
        CASE (513, 518, 519, 520)
C * _chemical_absolute_configuration
        CASE (758)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(17) = NWRD(2:NW-1)
            NCIF(17) = NW - 2
          END IF
C * POWDER 2Thetamin
        CASE (544)
          IPR(105) = 1
C * POWDER 2Thetamax
        CASE (545)
          IPR(105) = 1
          PAR(168) = FA(1) / 2.0
C * _iucr_refine_reflections_details
        CASE (569)
          IPR(646) = 1
          IPR(660) = IPR(654)
          IPR(676) = 1
C * _reflns_Friedel_fraction_max
        CASE (572)
C * _reflns_Friedel_fraction_full
        CASE (573)
C * _shelx_res_checksum
        CASE (579)
          IF (IPR(677) == 0) THEN
            IPR(677) = -2
          ELSE
            IPR(677) = NINT (FA(1))
          END IF
C * _shelx_hkl_checksum
        CASE (581)
          IF (IPR(678) == 0) THEN
            IPR(678) = -2
          ELSE
            IPR(678) = NINT(FA(1))
          END IF
C * _diffrn_reflns_Laue_measured_fraction_max
        CASE (585)
C * _diffrn_reflns_Laue_measured_fraction_full
        CASE (586)
C * _diffrn_reflns_point_group_measured_fraction_max
        CASE (587)
C * _diffrn_reflns_point_group_measured_fraction_full
        CASE (588)
C * _reflns_Friedel_coverage
        CASE (589)
C * _shelx_fab_checksum
        CASE (602)
          IF (IPR(679) == 0) THEN
            IPR(679) = -1
          ELSE
            IPR(679) = NINT(FA(1))
          END IF
C * _diffrn_measurement_device & _diffrn_measurement_device_type'
        CASE (136, 441)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(18) = NWRD(2:NW-1)
            NCIF(18) = NW - 2
          END IF
C * LS-HYDROGEN TREATMENT
        CASE (357)
          IF (NW > 2) THEN
            IF (NW > NP57 + 2) NW = NP57 + 2
            CCIF(13) = NWRD(2:NW-1)
            NCIF(13) = NW - 2
          END IF
          CALL GEN020 (-1, CCIF(13),  1, NP57)
C * JOURNAL_NAME_FULL
        CASE (308)
          LREF(1)  = NWRD(2:NW-1)
          IPR(565) = 0
C * JOURNAL_YEAR
        CASE (321)
          LREF(2)(1:NW) = NWRD(2: NW - 1)//', '
C * JOURNAL_VOLUME
        CASE (320)
          LREF(2)(7:NW + 6) = NWRD(2:NW-1)//', '
C * JOURNAL_PAGE_FIRST
        CASE (309)
          LREF(2)(12:NW + 11) = NWRD(2:NW-1)
C * _publ_author_name
        CASE (323)
          IF (IPR(565) < 23) THEN
            IPR(565) = IPR(565) + 1
            LREF(2 + IPR(565)) = NWRD(2:NW-1)
          END IF
C * _publ_author_address
        CASE (322)
C * _publ_author_footnote
        CASE (469)
C * _publ_author_email
        CASE (532)
C * _publ_contact_author_name
C * _publ_contact_author_address
        CASE (438)
C * _publ_contact_author_email
C * _symmetry_equiv_pos_site_id & _space_group_symop_id
        CASE (480, 489)
          NSCF = NSCF + 1
          NSID(NSCF) = NINT (FA(1))
C * _symmetry_equiv_pos_as_xyz & _space_group_symop_operation_xyz
        CASE (419, 490)
          IF (IPR(319) == 0) THEN
            IPR(319) = 1
C * INIT SPACE GROUP SYMMETRY TO P1
            CALL SGSM (1, IDM, FN, 0, 0, IERR)
            IPR(48)  = 1
          END IF
C * SAVE POSSIBLE REMAINING CONTENTS
          DO J = I0 + 1, 80
            IF (ICL(J:J) /= ' ') THEN
              IGGT(1:80) = ICL(J:80)
              EXIT
            END IF
          END DO
          IFL(1)   = 'SYMM   '
          ICL      = 'SYMM '//NWRD(2:NW-1)
          IPR(220) = 1
          IPR(221) = 0
C * SAVE FOR BOND/ANGLE/TORSION VALIDATION (IFL & FN ARE DUMMY)
          IF (MODE == 0 .AND. IGBL(3) /= 14) THEN
             WRITE (LU11) ICL(1:80), (IFL(J), J = 1, 4),
     1       (FN(J), J = 1, 6)
          END IF
C * REFLECTION FILE LOOP
C * _refln_index_h
        CASE (385)
          FN(1) = FA(1)
C * _refln_index_k
        CASE (386)
          FN(2) = FA(1)
C * _refln_index_l
        CASE (387)
          FN(3) = FA(1)
C * _refln_F_squared_calc & _refln_intensity_calc
        CASE (382, 388)
C * _refln_F_squared_meas &_refln_intensity_meas
        CASE (383, 389)
          FN(4) = FA(1)
C * _refln_F_squared_sigma & _refln_F_intensity_sigma
        CASE (384, 390)
          FN(5)    = FA(1)
          IPR(321) = IPR(321) + 1
C * CHECK FOR UNUSUAL (CALCULATED) DATA
          IF (FN(4) > 0.0 .AND. FN(5) /= 0.0) THEN
            IF (IPR(741) == 0) REWIND (UNIT = LU67, IOSTAT = IOST)
            RATIO    = FN(5) / SQRT (FN(4))
            PAR(555) = PAR(555) + RATIO
            IPR(741) = IPR(741) + 1
            WRITE (LU67) RATIO
          END IF
          IF (IPR(321) == 1) THEN
            INQUIRE (UNIT = LU25, OPENED = OPEND)
            IPR(664) = -1
            IF (OPEND) THEN
              REWIND (LU25, IOSTAT = IOST)
            ELSE
              OPEN (UNIT = LU25, FILE =
     1          NAMEFIL(1:KNMFIL)//'_sx.hkl',
     2          STATUS = 'UNKNOWN', IOSTAT = IOST)
              IF (IOST /= 0) REWIND (UNIT = LU25, IOSTAT = IOST)
            END IF
          END IF
C * MAKE SURE THAT INTENSITY FITS WITHIN THE SHELXL HKLF FORMAT
          IF (FN(4) < 99999.0) THEN
            WRITE (LU25, 99998)
     1        (NINT (FN(I)), I = 1, 3), (FN(I), I = 4, 5)
          ELSE IF (FN(4) < 999999.0) THEN
            WRITE (LU25, 99997)
     1        (NINT (FN(I)), I = 1, 3), (FN(I), I = 4, 5)
          ELSE IF (FN(4) < 9999999.0) THEN
            WRITE (LU25, 99996)
     1        (NINT (FN(I)), I = 1, 3), (FN(I), I = 4, 5)
          END IF
C * Cromer_Mann scat. fact & DISPERSION LOOP
        CASE (70)
          CALL GEN020 (1, NWRD, 2, NW - 1)
          IF (NW == 3) THEN
            ELTYPE = ' '//NWRD(2:2)
          ELSE
            CALL GEN020 (-1, NWRD, 3, 3)
            ELTYPE = NWRD(2:3)
          END IF
          NELTYPE = 1
          IF (IPR(761) > 0) THEN
            DO I = 1, IPR(761)
              IF (DISPTYPE(I) == ELTYPE) THEN
                NELTYPE = 0
              END IF
            END DO
          END IF
          IF (NELTYPE == 1) THEN
          IPR(761) = IPR(761) + 1
            DISPTYPE(IPR(761)) = ELTYPE
          END IF
C * _atom_type_scat_dispersion_real
        CASE (67)
          DISPVAL(IPR(761), 1) = FA(1)
C * _atom_type_scat_dispersion_imag
        CASE (66)
          DISPVAL(IPR(761), 2) = FA(1)
C * _atom_type_scat_source
        CASE (68)
C * HANDLE INFO BETWEEN SEMI-COLUMNS
          IF (ISEMCOL == 1) THEN
            DO
              READ (LU1, 99994) ICL
              IF (ICL(1:1) == ';') THEN
                ISEMCOL = 0
                EXIT
              END IF
            END DO
          ELSE
            IF (INDEX(NWRD(2 : NW - 1), 'NOSPHERA2') > 0) IPR(775) = 1
          ENDIF
C * _atom_type_scat_Cromer_Mann_a1
        CASE (57)
          CIFSF(IPR(761), 1) = FA(1)
          IPR(762) = IPR(762) + 1
C * _atom_type_scat_Cromer_Mann_b1
        CASE (61)
          CIFSF(IPR(761), 2) = FA(1)
C * _atom_type_scat_Cromer_Mann_a2
        CASE (58)
          CIFSF(IPR(761), 3) = FA(1)
C * _atom_type_scat_Cromer_Mann_b2
        CASE (62)
          CIFSF(IPR(761), 4) = FA(1)
C * _atom_type_scat_Cromer_Mann_a3
        CASE (59)
          CIFSF(IPR(761), 5) = FA(1)
C * _atom_type_scat_Cromer_Mann_b3
        CASE (63)
          CIFSF(IPR(761), 6) = FA(1)
C * _atom_type_scat_Cromer_Mann_a4
        CASE (60)
          CIFSF(IPR(761), 7) = FA(1)
C * _atom_type_scat_Cromer_Mann_b4
        CASE (64)
          CIFSF(IPR(761), 8) = FA(1)
C * _atom_type_scat_Cromer_Mann_c
        CASE (65)
          CIFSF(IPR(761), 9) = FA(1)
C * _diffrn_radiation_type
        CASE (163)
          NWMX     = MIN (NW -2, NP57)
          CCIF(24) = NWRD(2:NW - 1)
          NCIF(24) = NWMX
C * REMOVE BACKSLASH CHARACTER
          J = INDEX (NWRD, CHAR(92))
          IF (J /= 0) NWRD(J:J) = ' '
          J = INDEX (NWRD, '~1~')
          IF (J /= 0) NWRD(J:J+2) = '   '
          J = INDEX (NWRD, '~2~')
          IF (J /= 0) NWRD(J:J+2) = '   '
C * ELIMINATE BLANKS
          CALL GEN047 (NWRD, 2, NW - 1)
          IF (INDEX (NWRD, 'CUKA') /= 0) THEN
            IPR(671) = 5
            IPR(493) = 5
            KRAD     = 'CuKa'
          ELSE IF (INDEX (NWRD, 'GAKA') /= 0) THEN
            IPR(671) = 4
            IPR(493) = 4
            KRAD     = 'GaKa'
          ELSE IF (INDEX (NWRD, 'MOKA') /= 0) THEN
            IPR(671) = 3
            IPR(493) = 3
            KRAD     = 'MoKa'
          ELSE IF (INDEX (NWRD, 'AGKA') /= 0) THEN
            IPR(671) = 2
            IPR(493) = 2
            KRAD     = 'AgKa'
          ELSE IF (INDEX (NWRD, 'INKA') /= 0) THEN
            IPR(671) = 1
            IPR(493) = 1
            KRAD     = 'InKa'
          ELSE IF (INDEX (NWRD, 'KB') /= 0) THEN
            IPR(493) = 6
            IPR(671) = 6
            IPR(630) = 0
            KRAD     = NWRD(2:4)//'b'
            CALL GEN020 (-1, KRAD, 2, 2)
          ELSE IF (INDEX (NWRD, 'SYNCHROTRON') /= 0) THEN
            IPR(493) = 6
            IPR(671) = 6
            IPR(630) = 3
          ELSE IF (INDEX (NWRD, 'NEUTRON') /= 0) THEN
            IPR(671) = 7
            IPR(493) = 7
            IPR(630) = 1
C * SET DEFAULT HKLF 2
            IPR(648) = 2
          ELSE IF (INDEX (NWRD, 'ELECTRON') /= 0) THEN
            IPR(493) = 8
            IPR(671) = 8
            IPR(630) = 2
C * ALERT _660 - Missing _diffrn_radiation_type value
          ELSE IF (INDEX (NWRD, '?') /= 0 .AND. NLPNL == 163) THEN
            CALL PLA236 (660, 0, 1.0, 1.0, ' ', ' ')
          END IF
C * _diffrn_radiation_wavelength
        CASE (164)
          IF (KNUM > -2) THEN
            CALL PLA293 (FA(1))
            IF (PAR(551) == 0.0) THEN
              PAR(551) = FA(1)
            ELSE
              PAR(552) = FA(1)
            END IF
            IF (PAR(554) /= 0.0 .AND. PAR(552) /= 0.0) THEN
              FA(1) = (PAR(553) * PAR(551) + PAR(554) * PAR(552))
     1          / (PAR(553) + PAR(554))
              PAR(17) = FA(1)
            END IF
            IPR(220) = 1
            IPR(221) = 1
            FN(1)    = FA(1)
            IFL(1)   = 'RADN'
            LRETCIF  = 1
            RETURN
          ELSE IF (KNUM == -3) THEN
            WRITE (LU6, 99995, IOSTAT = IOST) NWRD
          END IF
C * _diffrn_radiation_wavelength_id
        CASE (165)
C * _diffrn_radiation_wavelength_wt
        CASE (166)
          IF (PAR(552) == 0.0) THEN
            PAR(553) = FA(1)
          ELSE
            PAR(554) = FA(1)
          END IF
          IF (PAR(554) /= 0.0 .AND. PAR(552) /= 0.0) THEN
            FA(1) = (PAR(553) * PAR(551) + PAR(554) * PAR(552)) /
     1        (PAR(553) + PAR(554))
            PAR(17) = FA(1)
          END IF
C * _publ_body_loop
C * _publ_body_element
        CASE (635)
C * _publ_body_title
        CASE (636)
C * _publ_body_contents
        CASE (637)
C * INCLUDE FILE LOOP
C * _shelx_include_file_name
        CASE (891)
          IPR(667) = 0
          CALL GEN155 (0, ICL, NZERO)
          OPEN (UNIT = LU65, FILE = NWRDS(2:NW-1), STATUS = 'UNKNOWN',
     1      IOSTAT = IOST)
          WRITE (LU6, 99993) NWRDS(2:NW - 1)
C * _shelx_include_file
        CASE (892)
          DO
            IF (ICL(1:1) /= ';') THEN
              WRITE (LU65, 99994) ICL(1:80)
              CALL GEN155 (1, ICL, NZERO)
              READ (LU1, 99994) ICL(1:80)
            ELSE
              IPR(667) = -1
              CALL GEN155 (-1, ICL, IPR(724))
              CLOSE (LU65)
              EXIT
            END IF
          END DO
C * _shelx_include_file_checksum
        CASE (893)
          IF (IPR(724) /= NINT (FA(1))) THEN
C * _698 ALERT
            CALL PLA236 (698, 0, 1.0, 1.0, 'N.O.K.', ' ')
          END IF
C * SQUEEZE LOOP
C * VOID VOLUME (PLATON/SQUEEZE)
        CASE (507)
          PAR(437) = PAR(437) + FA(1)
C * VOID ELECTRON COUNT (PLATON/SQUEEZE)
        CASE (508)
          PAR(438) = PAR(438) + FA(1)
C * VOID NUMBER OLEX2/_smtbx_masks/void_nr
        CASE (614)
          IF (NINT (FA(1)) == 1) THEN
            PAR(469) = 0
            PAR(470) = 0.0
            IPR(651) = 2
          END IF
C * VOID VOLUME (OLEX2/_smtbx_masks)
        CASE (618)
C * ACCUMULATE _smtbx_masks VOLUME
          PAR(469) = PAR(469) + FA(1)
C * VOID ELECTRON COUNT (OLEX2/_smtbx_masks)
        CASE (619)
          PAR(470) = PAR(470) + FA(1)
C * TWIN MATRIX LOOP (CRYSTALS/OLEX2/JANA etc.)
C * _twin_individual_id
        CASE (648)
          IF (INDEX (NWRD, '?') == 0)  IPR(781) = IPR(781) + 1
C * _twin_individual_mass_fraction_refined
        CASE (649)
                IF (IPR(781) > 0) TWINF(IPR(781)) = FA(1)
C * _twin_individual_twin_matrix_11
        CASE (650)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_12
        CASE (651)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_13
        CASE (652)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_21
        CASE (653)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_22
        CASE (654)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_23
        CASE (655)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_31
        CASE (656)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_32
        CASE (657)
          IPR(782) = IPR(782) + 1
C * _twin_individual_twin_matrix_33
        CASE (658)
          IPR(782) = IPR(782) + 1
C * ORIENTATION MATRIX LOOP
C * _diffrn_orient_matrix_type
        CASE (138)
          IPR(655) = IPR(655) + 1
C *  REGISTER TWINNING
C * _diffrn_orient_matrix_UB_11
        CASE (139)
C * _diffrn_orient_matrix_UB_12
        CASE (140)
C * _diffrn_orient_matrix_UB_13
        CASE (141)
C * _diffrn_orient_matrix_UB_21
        CASE (142)
C * _diffrn_orient_matrix_UB_22
        CASE (143)
C * _diffrn_orient_matrix_UB_23
        CASE (144)
C * _diffrn_orient_matrix_UB_31
        CASE (145)
C * _diffrn_orient_matrix_UB_32
        CASE (146)
C * _diffrn_orient_matrix_UB_33
        CASE (147)
C * REFLECTION LOOP
C * _diffrn_refln_index_h
        CASE (183)
          IF (IPR(753) == 0) THEN
            IPR(664) = -1
            INQUIRE (UNIT = LU25, OPENED = OPEND)
            IF (OPEND) THEN
              REWIND (LU25, IOSTAT = IOST)
            ELSE
              OPEN (UNIT = LU25, FILE =
     1          NAMEFIL(1:KNMFIL)//'_sx.hkl',
     2          STATUS = 'UNKNOWN', IOSTAT = IOST)
              IF (IOST /= 0) REWIND (UNIT = LU25, IOSTAT = IOST)
            END IF
            FORMA = '(3I4,F8.0,F8.2,I4)'
          END IF
C * _diffrn_refln_index_h
          JH = NINT (FA(1))
C * _diffrn_refln_index_k
        CASE (184)
          JK = NINT (FA(1))
C * _diffrn_refln_index_l
        CASE (185)
          JL = NINT (FA(1))
C * _diffrn_refln_intensity_net
        CASE (186)
          FSQ = FA(1)
C * _diffrn_refln_intensity_u
        CASE (187, 897)
          SIG = FA(1)
C * _diffrn_refln_scale_group_code
        CASE (188)
          JSGR = NINT (FA(1))
          IPR(753) = IPR(753) + 1
          N = 50
          M = 50
          IF (FSQ > 99999.0 .OR. FSQ < -9999.0) N = 48
          IF (FSQ > 9999999) FSQ = 9999999.0
          FORMA(9:9) = CHAR (N)
          IF (SIG > 99999.0) M = 48
          FORMA(14:14) = CHAR (M)
          WRITE (LU25, FORMA) JH, JK, JL, FSQ, SIG, JSGR
C * ANISOTROPIC DISPLACEMENT PARAMETERS
C * _atom_site_aniso_label
        CASE (1)
C * CHECK FOR 'NO ATOMS' Prior to Uij
          IF (IPR(39) == 0) THEN
            IPR(2)  = 42
            LRETCIF = 4
            RETURN
          END IF
          IPR(220) = 2
          IPR(221) = 0
          IFL(1)   = 'UIJ'
          IFL(2)   = NWRD(2:NW-1)
C * ALERT _799
          IF (KNUM /= 0) THEN
            CALL PLA236 (799, 1, 1.0, 1.0, IFL(2), ' ')
          END IF
C * _atom_site_aniso_U_11
        CASE (3)
          IF (KNUM /= 0) THEN
            FN(1)    = FA(1)
            FN(7)    = FA(2)
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_aniso_U_12
        CASE (4)
          IF (KNUM /= 0) THEN
            FN(6)    = FA(1)
            FN(12)   = FA(2)
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_aniso_U_13
        CASE (5)
          IF (KNUM /= 0) THEN
            FN(5)    = FA(1)
            FN(11)   = FA(2)
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_aniso_U_22
        CASE (6)
          IF (KNUM /= 0) THEN
            FN(2)    = FA(1)
            FN(8)    = FA(2)
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_aniso_U_23
        CASE (7)
          IF (KNUM /= 0) THEN
            FN(4)    = FA(1)
            FN(10)   = FA(2)
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_aniso_U_33
        CASE (8)
          IF (KNUM /= 0) THEN
            FN(3)    = FA(1)
            FN(9)    = FA(2)
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * B11, B22 etc
        CASE (452)
          FN(1)    = FA(1) / RGBL(8)
          FN(7)    = FA(2) / RGBL(8)
          IPR(221) = IPR(221) + 2
C * B12
        CASE (453)
          FN(6)    = FA(1) / RGBL(8)
          FN(12)   = FA(2) / RGBL(8)
          IPR(221) = IPR(221) + 2
C * B13
        CASE (454)
          FN(5)    = FA(1) / RGBL(8)
          FN(11)   = FA(2) / RGBL(8)
          IPR(221) = IPR(221) + 2
C * B22
        CASE (455)
          FN(2)    = FA(1) / RGBL(8)
          FN(8)    = FA(2) / RGBL(8)
          IPR(221) = IPR(221) + 2
C * B23
        CASE (456)
          FN(4)    = FA(1) / RGBL(8)
          FN(10)   = FA(2) / RGBL(8)
          IPR(221) = IPR(221) + 2
C * B33
        CASE (457)
          FN(3)    = FA(1) / RGBL(8)
          FN(9)    = FA(2) / RGBL(8)
          IPR(221) = IPR(221) + 2
C * COORDINATES
C * _atom_site_label
        CASE (22)
          DO I = 1, 34
            FN(I) = 0.0
          END DO
          IPR(221) = 4
          IF (IPR(220) == 0) NHTP   = -1
          IFL(1) = 'ATOM'
          IFL(2) = NWRD(2:NW-1)
C * ALERT _798 : REPORT ON NUMERAL LABEL
          IF (KNUM /= 0) THEN
            CALL PLA236 (798, 1, 1.0, 1.0, IFL(2), ' ')
          END IF
          FN(4)    = 1.0
          IPR(220) = IPR(220) + 2
C * _atom_site_type_symbol
        CASE (35)
          NHTP   = 0
          IFL(3) = NWRD(2:NW-1)
          IF (IFL(3)(1:2) == 'H ') NHTP = 1
          IF (NHTP == 0 .AND. IPR(220) == 2)
     1      IPR(644) = IPR(644) + NINT (FN(29))
          IPR(220) = IPR(220) + 1
C * _atom_site_Cartn_x
        CASE (12)
          IF (KNUM /= 0) THEN
            FN(1)    = FA(1)
            FN(5)    = -1.0
            IPR(23)  = 1
            IPR(221) = IPR(221) + 2
          END IF
C * _atom_site_Cartn_y
        CASE (13)
          IF (KNUM /= 0) THEN
            FN(2)    = FA(1)
            FN(6)    = -1.0
            IPR(221) = IPR(221) + 2
          END IF
C * _atom_site_Cartn_z
        CASE (14)
          IF (KNUM /= 0) THEN
            FN(3)    = FA(1)
            FN(8)    = -1.0
            IPR(221) = IPR(221) + 2
          END IF
C * _atom_site_fract_x
        CASE (19)
          IF (KNUM /= 0) THEN
            FN(1) = FA(1)
            FN(5) = FA(2)
C * ALERT _101
            IF (FA(2) == 0.0 .AND. IPR(105) == 0) THEN
              IF (IPR(606) == 4 .OR. IPR(606) == 6) THEN
                YUNK   = ABS (FA(1))
                IF (YUNK == 0.333 .OR. YUNK == 0.3333 .OR.
     1              YUNK == 0.667 .OR. YUNK == 0.6667) THEN
                  IFL(4) = NWRD(2:NW-1)
                  CALL GEN156 (IFL(4)(1:9))
                  NQY = IFL(2)(1:9)
                  CALL GEN156 (NQY)
                  CALL PLA236 (101, 1, 1.0, 1.0, IFL(4), NQY)
                END IF
              END IF
            END IF
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_frac_y
        CASE (20)
          IF (KNUM /= 0) THEN
            FN(2) = FA(1)
            FN(6) = FA(2)
C * ALERT _102
            IF (FA(2) == 0.0 .AND. IPR(105) == 0) THEN
              IF (IPR(606) == 4 .OR. IPR(606) == 6) THEN
                YUNK   = ABS (FA(1))
                IF (YUNK == 0.333 .OR. YUNK == 0.3333 .OR.
     1              YUNK == 0.667 .OR. YUNK == 0.6667) THEN
                  IFL(4) = NWRD(2:NW-1)
                  CALL GEN156 (IFL(4)(1:9))
                  NQY = IFL(2)(1:9)
                  CALL GEN156 (NQY)
                  CALL PLA236 (102, 1, 1.0, 1.0, IFL(4), NQY)
                END IF
              END IF
            END IF
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_fract_z
        CASE (21)
          IF (KNUM /= 0) THEN
            FN(3) = FA(1)
            FN(7) = FA(2)
C * ALERT _103
            IF (FA(2) == 0.0 .AND. IPR(105) == 0) THEN
              IF (IPR(606) == 4 .OR. IPR(606) == 6) THEN
                YUNK   = ABS (FA(1))
                IF (YUNK == 0.333 .OR. YUNK == 0.3333 .OR.
     1              YUNK == 0.667 .OR. YUNK == 0.6667) THEN
                  IFL(4) = NWRD(2:NW-1)
                  CALL GEN156 (IFL(4)(1:9))
                  NQY = IFL(2)(1:9)
                  CALL GEN156 (NQY)
                  CALL PLA236 (103, 1, 1.0, 1.0, IFL(4), NQY)
                END IF
              END IF
            END IF
            IPR(221) = IPR(221) + 2
          ELSE
            LRETCIF = 1
            RETURN
          END IF
C * _atom_site_calc_flag
        CASE (11)
          IF (NWRD(2:3) == 'D''') THEN
            FN(21) = 1.0
          ELSE IF (NWRD(2:2) == 'C') THEN
            FN(22) = 1.0
          ELSE IF (NWRD(2:4) == 'DUM') THEN
            FN(23) = 1.0
          END IF
C * _atom_site_refinement_flags & _atom_site_refinement_flags_pos
        CASE (31, 598)
          IF (INDEX (NWRD(2:NW - 1), 'S')  /= 0) FN(24) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'G')  /= 0) FN(25) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'R')  /= 0) FN(26) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'D')  /= 0) THEN
            FN(27)   = 1.0
            IPR(643) = IPR(643) + 1
          END IF
          IF (INDEX (NWRD(2:NW - 1), 'T')  /= 0) FN(28) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'U')  /= 0) THEN
            FN(29) = 1.0
            IF (NHTP == 0) IPR(644) = IPR(644) + 1
          END IF
          IF (INDEX (NWRD(2:NW - 1), 'P')  /= 0) THEN
            FN(30) = 1.0
          END IF
C * _atom_site_refinement_flags_adp
        CASE (599)
          IF (INDEX (NWRD(2:NW - 1), 'T')  /= 0) FN(28) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'U')  /= 0) THEN
            FN(29)   = 1.0
            IF (NHTP == 0) IPR(644) = IPR(644) + 1
          END IF
C * _atom_site_refinement_flags_occupancy
        CASE (600)
          IF (INDEX (NWRD(2:NW-1), 'P')  /= 0) THEN
            FN(30) = 1.0
          END IF
C * _atom_site_disorder_assembly
        CASE (450)
          IF (INDEX (NWRD(2:NW - 1), 'A')  /= 0) FN(31) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'B')  /= 0) FN(32) = 1.0
          IF (INDEX (NWRD(2:NW - 1), 'S')  /= 0) FN(33) = 1.0
C * _atom_site_disorder_group
        CASE (18)
          IPR(612) = NINT (FA(1))
          IF (IPR(612) < 0) IPR(695) = IPR(695) + 1
C * _atom_site_symmetry_multiplicity (SHELXL - JANA INTERPRETATION)
        CASE (33)
          IF (IPR(725) == 6) FA(1) = IPR(48) / FA(1)
          FN(35) = FA(1)
C * _atom_site_site_symmetry_order
        CASE (570)
          FN(35) = FA(1)
C * _atom_site_thermal_displace_type & _atom_site_adp_type
        CASE (34, 449)
C * _atom_site_site_symmetry_multiplicity
        CASE (571)
          FN(36) = FA(1)
C *_atom_site_occupancy
        CASE (30)
          IF (KNUM == 0)  THEN
            IPR(221) = IPR(221) - 2
            LRETCIF  = 1
            RETURN
          ELSE IF (KNUM < 0) THEN
            FA(1) = 1.0
            FA(2) = 0.0
          END IF
C * ELIMINATE DUMMY ATOMS
          IF (FA(1) < 0.0001 .AND.
     1      IFL(2)(1:2) /= 'CG') THEN
C * ALERT _074
            CALL PLA236 (74, 1, 1.0, 1.0, IFL(2), ' ')
          END IF
          FN(4) = FA(1)
          FN(8) = FA(2)
 
C * U-iso/equiv
        CASE (36)
          IF (KNUM /= 0) THEN
            FN(9)  = FA(1)
            FN(10) = FA(2)
            IF (FN(9) < 0.0) THEN
              CALL PLA236 (203, 3, -FN(9), FN(9), IFL(2), ' ')
            END IF
          ELSE
            IPR(221) = IPR(221) - 2
            LRETCIF  = 1
            RETURN
          END IF
C * B-ISO/equiv
        CASE (423)
          IF (KNUM /= 0) THEN
            FN(9)  = FA(1) / RGBL(8)
            FN(10) = FA(2) / RGBL(8)
          ELSE
            IPR(221) = IPR(221) - 2
            LRETCIF  = 1
            RETURN
          END IF
C * BOND
C * _geom_bond_site_label_1
        CASE (265)
          IPR(751) = 1
          LINE     = 'BOND '
          IFL(1)   = NWRD(2:NW - 1)
          FN(3)    = 1.555
          FN(4)    = 1.555
C * _geom_bond_site_label_2
        CASE (266)
          IFL(2) = NWRD(2:NW - 1)
C * _geom_bond_distance
        CASE (267)
          FN(1)  = FA(1)
          FN(2)  = FA(2)
C * _geom_bond_site_symmetry_1
        CASE (269)
          FN(3)  = FA(1)
C * _geom_bond_site_symmetry_2
        CASE (270)
          FN(4)  = FA(1)
 
C * CONTACT
C * _geom_contact_atom_site_label_1
        CASE (271)
          IPR(751) = 1
          LINE     = 'CONTACT '
          IFL(1)   = NWRD(2:NW - 1)
          FN(3)    = 1.555
          FN(4)    = 1.555
C * _geom_contact_atom_site_label_2
        CASE (272)
          IFL(2) = NWRD(2:NW - 1)
C * _geom_contact_distance
        CASE (273)
          FN(1)  = FA(1)
          FN(2)  = FA(2)
C * _geom_contact_site_symmetry_1
        CASE (275)
          FN(3)  = FA(1)
C * _geom_contact_site_symmetry_2
        CASE (276)
          FN(4)  = FA(1)
C * ANGLE
C * _geom_angle_atom_site_label_1
        CASE (258)
          IPR(751) = 1
          LINE     = 'ANGLE '
          IFL(1)   = NWRD(2:NW - 1)
          FN(3)    = 1.555
          FN(4)    = 1.555
          FN(5)    = 1.555
C * _geom_angle_atom_site_label_2
        CASE (259)
          IFL(2) = NWRD(2:NW - 1)
C * _geom_angle_atom_site_label_3
        CASE (260)
          IFL(3) = NWRD(2:NW - 1)
C * _geom_angle
        CASE (257)
          FN(1)  = FA(1)
          FN(2)  = FA(2)
C * _geom_angle_site_symmetry_1
        CASE (262)
          FN(3)  = FA(1)
C * _geom_angle_site_symmetry_2
        CASE (263)
          FN(4)  = FA(1)
C *_geom_angle_site_symmetry_3
        CASE (264)
          FN(5)  = FA(1)
C * TORSION
C * _geom_torsion_atom_site_label_1
        CASE (279)
          IPR(751) = 1
          LINE     = 'TORSION '
          IFL(1)   = NWRD(2:NW - 1)
          FN(3)    = 1.555
          FN(4)    = 1.555
          FN(5)    = 1.555
          FN(6)    = 1.555
C * _geom_torsion_atom_site_label_2
        CASE (280)
          IFL(2) = NWRD(2:NW - 1)
C * _geom_torsion_atom_site_label_3
        CASE (281)
          IFL(3) = NWRD(2:NW - 1)
C * _geom_torsion_atom_site_label_4
        CASE (282)
          IFL(4) = NWRD(2:NW - 1)
C * _geom_torsion
        CASE (278)
          FN(1)  = FA(1)
          FN(2)  = FA(2)
C * _geom_torsion_site_symmetry_1
        CASE (284)
          FN(3)  = FA(1)
C * _geom_torsion_site_symmetry_2
        CASE (285)
          FN(4)  = FA(1)
C * _geom_torsion_site_symmetry_3
        CASE (286)
          FN(5)  = FA(1)
C * _geom_torsion_site_symmetry_4
        CASE (287)
          FN(6)  = FA(1)
C * H-BOND
C * _geom_hbond_atom_site_label_D
        CASE (426)
          IPR(751) = 1
          LINE     = 'HBOND '
          IFL(1)   = NWRD(2:NW - 1)
          FN(9)    = 1.555
          FN(10)   = 1.555
          FN(11)   = 1.555
C * _geom_hbond_atom_site_label_H
        CASE (427)
          IFL(2) = NWRD(2:NW - 1)
C * _geom_hbond_atom_site_label_A
        CASE (428)
          IFL(3) = NWRD(2:NW - 1)
C * _geom_hbond_distance_DH
        CASE (429)
          FN(1)  = FA(1)
          FN(2)  = FA(2)
C * _geom_hbond_distance_HA
        CASE (430)
          FN(3)  = FA(1)
          FN(4)  = FA(2)
C * _geom_hbond_distance_DA
        CASE (431)
          FN(5)  = FA(1)
          FN(6)  = FA(2)
C * _geom_hbond_angle_DHA
        CASE (432)
          FN(7)  = FA(1)
          FN(8)  = FA(2)
C * SYMMETRY D
        CASE (466)
          FN(9)  = FA(1)
C * SYMMETRY H
        CASE (467)
          FN(10) = FA(1)
C * SYMMETRY A
        CASE (433)
          FN(11) = FA(1)
C * GSAS _restr_rigid_body loop
C * _restr_rigid_body_class.class_id
        CASE (907)
          IPR(639) = 1
C * _restr_rigid_body_class.details
        CASE (908)
          IPR(639) = 1
C * _restr_rigid_body.id
        CASE (909)
          IPR(639) = 1
C * _restr_rigid_body.atom_site_label
        CASE (910)
          IPR(639) = 1
C * _restr_rigid_body.site_symmetry
        CASE (911)
          IPR(639) = 1
C * _restr_rigid_body.class_id
        CASE (912)
          IPR(639) = 1
C * _restr_rigid_body.details
        CASE (913)
          IPR(639) = 1
C * SUM & MOIETY FORMULA
C * _chemical_formula_moiety
        CASE (107)
          CALL GEN134 (NWRD, RLWS(4), 2, 80)
          RLWS(4)(80:80) = CHAR(39)
          J = INDEX (RLWS(4), 'SOLVENT')
          IF (J /= 0) RLWS(4)(j:J + 6) = 'solvent'
C * _chemical_formula_sum
        CASE (109)
          CALL GEN134 (NWRD, RLWS(5), 2, 79)
          IFL(1)  = 'FSUM'
          ICL     = RLWS(5)
          J = INDEX (RLWS(5), 'SOLVENT')
          IF (J /= 0) RLWS(5)(j:J + 6) = 'solvent'
          LRETCIF = 1
          RETURN
C * _symmetry_cell_setting & _space_group_crystal_system
C * Note: _symmetry_cell_setting superseded
        CASE (418, 483)
          IF (INDEX (NWRD, 'TRICLINIC') /= 0) THEN
            KRSYST(1) = '   triclinic'
            IPR(606)  = 1
          ELSE IF (INDEX (NWRD, 'MONOCLINIC') /= 0) THEN
            KRSYST(1) = '  monoclinic'
            IPR(606)  = 2
          ELSE IF (INDEX (NWRD, 'ORTHORHOMBIC') /= 0) THEN
            KRSYST(1) = 'orthorhombic'
            IPR(606)  = 3
          ELSE IF (INDEX (NWRD, 'TRIGONAL') /= 0) THEN
            KRSYST(1) = '    trigonal'
            IPR(606)  = 4
          ELSE IF (INDEX (NWRD, 'TETRAGONAL') /= 0) THEN
            KRSYST(1) = '  tetragonal'
            IPR(606)  = 5
          ELSE IF (INDEX (NWRD, 'HEXAGONAL') /= 0) THEN
            KRSYST(1) = '   hexagonal'
            IPR(606)  = 6
          ELSE IF (INDEX (NWRD, 'CUBIC') /= 0) THEN
            KRSYST(1) = '       cubic'
            IPR(606)  = 7
          ELSE IF (INDEX (NWRD, 'RHOMBOHEDRAL') /= 0) THEN
            IF (IPR(606) == 0) THEN
              KRSYST(1) = 'rhombohedral'
              IPR(606) = 8
            END IF
          END IF
C * _symmetry_Int_Tables_number & _space_group_IT_number
        CASE (420, 485)
C * _symmetry_space_group_name_Hall & _space_group_name_Hall (OLD & NEW FORMS)
        CASE (421, 486)
          IF (IPR(37) == 0) THEN
            IF (IPR(319) == 0) IPR(318) =  1
            IF (NW > 2) THEN
              IF (NW > NP57 + 2) NW = NP57 + 2
C * STRIP HEADER AND TRAILING BLANKS
              LINE = NWRD(2:NW-1)
              LB   = 1
              LE   = NW - 2
              NB   = 1
              NE   = NW - 2
              CALL GEN039 (0, LINE, LB, LE, NB, NE)
              CCIF(16) = LINE(NB:NE)
              NCIF(16) = NE - NB + 1
            END IF
            CALL GEN020 (-1, CCIF(16), 3, NP57)
            IF (NWRD(2:2) /= '?' .AND. NWRD(2:2) /= ' ') THEN
              IFL(1) = 'HALL'
              ICL    = 'HALL '//NWRD(2:NW-1)
              IPR(220) = 2
              IPR(221) = 0
              LRETCIF  = 1
              RETURN
            END IF
          ELSE
C * ALERT _800 - MISPLACED SYMMETRY INFO
            CALL PLA236 (-800, 0, 1.0, 1.0, ' ', ' ')
            CALL PLA236 (0, 0, 0.0, 0.0,
     1        '              '//ICL(1:50), ' ')
          END IF
C * H-M SPACEGROUP SYMBOL (OLD & NEW FORMS - 488 preferred)
        CASE (422, 917, 487, 488, 923)
C * REPORT DUPLICATION OF H-M Symbol
          IF (IPR(713) > 0)
     1      CALL PLA236 (898, 0, -999.0, 0.0, ' ', ' ')
          IF (IPR(37) == 0 .AND. IPR(713) == 0) THEN
            IPR(713) = IPR(713) + 1
            IF (IPR(319) == 0) IPR(318) =  1
            IF (NW > NP57 + 2) NW = NP57 + 2
            NB = 2
            NE = NW - 1
C * ELIMINATE BLANKS
            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, NP57)
            IF (CCIF(6)(NCIF(6):NCIF(6)) == 'h') THEN
                CCIF(6)(NCIF(6):NCIF(6)) = 'H'
            ELSE IF (CCIF(6)(NCIF(6):NCIF(6)) == 'r') THEN
                CCIF(6)(NCIF(6):NCIF(6)) = 'R'
            END IF
            IF (NWRD(NB:NB) /= '?' .AND.
     1          NWRD(NB:NB) /= ' ') THEN
              IFL(1) = 'SPGR'
              ICL    = 'SPGR '//CCIF(6)(1:NCIF(6))
              JID(18:18 + NE - NB) = CCIF(6)(1:NCIF(6))
              IPR(220) = 2
              IPR(221) = 0
              LRETCIF  = 1
              RETURN
            ELSE
C * NO H-M SPACEGROUP SPECIFIED
C * ALERT _122
              CALL PLA236 (122, 0, 1.0, 1.0, ' ', ' ')
            END IF
          ELSE IF (IPR(37) > 0) THEN
C * ALERT _800 - MISPLACED SYMMETRY INFO
            CALL PLA236 (-800, 0, 1.0, 1.0, ' ', ' ')
            CALL PLA236 (0, 0, 0.0, 0.0,
     1        '              '//ICL(1:50), ' ')
          END IF
C * _space_group_ssg_name
        CASE (622)
          IGBL(140) = 1
C * ALERT _814 - (In)Commensurate Structure
          CALL PLA236 (814, 0, -999.0, 0.0, ' ', ' ')
C * NUMERAL
        CASE DEFAULT
          IF (KNUM == 1) THEN
            SELECT CASE (NLPNL)
C * ALPHA
              CASE (74)
                CALL PLA185 (4)
C * BETA
              CASE (75)
                CALL PLA185 (5)
C * GAMMA
              CASE (76)
                CALL PLA185 (6)
C * REPORTED Z  (FLOAT & INT)
              CASE (77)
                PAR(568) = FA(1)
                IPR(276) = NINT (FA(1))
                IF (ABS (PAR(568) - IPR(276)) > 0.0001)
     1            CALL PLA236 (100, 3, -999.0, PAR(568), ' ', ' ')
C * A-AXIS
              CASE (78)
                CALL PLA185 (1)
C * B-AXIS
              CASE (79)
                CALL PLA185 (2)
C * C-AXIS
              CASE (80)
                CALL PLA185 (3)
C * CELL_MEASUREMENT_TEMPERATURE
              CASE (88)
                IPR(261) = NINT (FA(1))
                IPR(220) = 1
                IPR(221) = 1
                IFL(1)   = 'TEMP'
                IFL(2)   = 'K'
                FN(1)    = FA(1)
                LRETCIF  = 1
C * CELL_MEASUREMENT_REFLNS_USED
              CASE (87)
                IPR(601) = NINT (FA(1))
C * CELL_MEASUREMENT_THETA_MAX
              CASE (89)
                PAR (228) = FA(1)
                PAR (470) = FA(1)
C * CELL_MEASUREMENT_THETA_MIN
              CASE (90)
                PAR(227) = FA(1)
C * VOLUME
              CASE (93)
                PAR(164) = FA(1)
                PAR(327) = MAX (0.0, FA(2))
C * ALERT _151
                IF (FA(2) <= 0.0 .AND. IGBL(94) == 0) THEN
                  CALL PLA236 (151, 0, 1.0, 1.0, ' ', ' ')
                ELSE
C * ROUND VOLUME
                  CALL GEN041 (PAR(164), PAR(327), IPR(313),
     1              3, IPR(314), IPR(68))
                END IF
C * MOL-WEIGHT
              CASE (110)
                PAR(308) = FA(1)
C * CELL_AMBIENT_TEMPERATURE
              CASE (133)
                IPR(310) = NINT (FA(1))
C * R(int)
              CASE (196)
                PAR(197) = FA(1)
C * R(sig)
              CASE (197, 497)
                PAR(198) = FA(1)
C * HMIN... LMAX, THETA-MIN THETA-MAX
              CASE (198, 404)
                IPR(268) = NINT (FA(1))
                IPR(672) = IPR(672) + 1
              CASE (199, 405)
                IPR(267) = NINT (FA(1))
                IPR(672) = IPR(672) + 1
              CASE (200, 406)
                IPR(270) = NINT (FA(1))
                IPR(672) = IPR(672) + 1
              CASE (201, 407)
                IPR(269) = NINT (FA(1))
                IPR(672) = IPR(672) + 1
              CASE (202, 408)
                IPR(272) = NINT (FA(1))
                IPR(672) = IPR(672) + 1
              CASE (203, 409)
                IPR(271) = NINT (FA(1))
                IPR(672) = IPR(672) + 1
C * NR REFL & PARAMETERS
              CASE (204)
C * _diffrn_reflns_number
                IPR(262) = NINT (FA(1))
C * REFLECTION -_diffrn_reflns_theta_max
              CASE (206)
                PAR(168) = FA(1)
                IF (PAR(17) > 0) PAR(287) =
     1            SIN (PAR(168) / RGBL(6)) / PAR(17)
C * REFLECTION -THETA-MIN
              CASE (207)
                PAR(167) = FA(1)
C * DATA RELATED TO ABSORPTION
              CASE (229)
                PAR(301) = FA(1)
C * transmission min
              CASE (230, 582)
                PAR(306) = FA(1)
C * transmission max
              CASE (231, 583)
                PAR(307) = FA(1)
C * DENSITY(diffrn)
              CASE (235)
                PAR(267) = FA(1)
C * DENSITY(meas)
              CASE (236)
                PAR(158) = FA(1)
C * REPORTED F000
              CASE (240)
                PAR(324) = FA(1)
C * DIFF-DENS-MAX
              CASE (347)
                PAR(177) = FA(1)
C * DIFF-DENS-MIN
              CASE (348)
                PAR(176) = FA(1)
C * FLACK PARAMETER
              CASE (350)
                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) <= 0.0 .AND. IPR(105) == 0) THEN
C * ALERT _036 - Test for no-su on Flack x
                  IF (FA(1) /= 0.500) THEN
                    CALL PLA236 (36, 3, 1.0, 1.0, ' ', ' ')
                  END IF
                ELSE
C * ALERT _032
                  IF (FA(2) > 0.2)
     1              CALL PLA236 (32, 3, -999.0, FA(2), ' ', ' ')
                END IF
C * CENTRO/NON-CENTRO CRIT FOR ADDSYM
                IF (FA(2) < 0.1 .AND. FA(2) < 0.2) IPR(773) = 1
C * ALERT _033 - TEST FOR FLACK PARAMETER VALUE OFF ZERO
                IF (FA(1) < 99999.0) THEN
C * CHECK FOR ACENTRO
                  IF (IPR(275) == 1) THEN
C * TEST FOR 'CHIRAL'
                    IF (CHSG(1:1) == 'C') THEN
                      IF (FA(1) > 3.0 * FA(2)) THEN
                        CALL PLA236 (33, 3, -999.0, FA(1), ' ', ' ')
                      END IF
                    END IF
                  ELSE
C * ALERT _781 - NO FLACK PARAMETER FOR CENTRO STRUCTURE
                    CALL PLA236 (781, 0, 1.0, 1.0, ' ', ' ')
                  END IF
C * ALERT _907 - Flack x > 0.5
                  CALL PLA236 (907, 2, PAR(433), PAR(433), ' ', ' ')
                END IF
C * ALERT _850
                IF (FA(1) == 0.0 .AND. FA(2) > 0.0)
     1            CALL PLA236 (850, 2, -999.0, FA(2), ' ', ' ')
C * XTAL-SIZE-MAX
              CASE (251)
                PAR(302) = FA(1)
C * XTAL-SIZE-MID
              CASE (252)
                PAR(303) = FA(1)
C * XTAL-SIZE-MIN
              CASE (253)
                PAR(304) = FA(1)
C * XTAL-RADIUS
              CASE (254)
                PAR(305) = FA(1)
C * EXTINCTION PARAMETER
              CASE (352)
                RATIO = 0.0
                IF (FA(2) > 0.0) THEN
                  IF (FA(1) < 0.1 * FA(2)) THEN
                    RATIO1 = 10.0
                  ELSE
                    RATIO  = FA(1) / FA(2)
                    RATIO1 = 1.0 / RATIO
                  END IF
C * ALERT _031
                  CALL PLA236 (31, 3, RATIO1, RATIO, ' ', ' ')
                END IF
                IF (FA(2) > 0.0) THEN
                  CALL GEN041 (FA(1), FA(2), IPR(277), -8,
     1                         IPR(278), IPR(68))
                ELSE
                  IPR(277) = 0
                END IF
                PAR(229) = FA(1)
C * S(all/ref/obs)
              CASE (355, 447, 356)
                PAR(299) = FA(1)
C * NUMBER OF L.S.-PARAMETERS
              CASE (360)
                IPR(266) = NINT (FA(1))
C * NUMBER OF UNIQUE REFLECTIONS _refine_ls_number_reflns
              CASE (361)
                IPR(265) = NINT (FA(1))
C * NUMBER OF UNIQUE REFLEXTIONS _reflns_number_all
              CASE (906)
                IPR(765) = NINT (FA(1))
C * R-all
              CASE (363)
                IF (FA(1) > 1.0) FA(1) = FA(1) * 0.01
                PAR(309) = FA(1)
C * R-obs/gt  _refine_ls_R_factor_gt
              CASE (364, 445)
                IF (FA(1) > 1.0) FA(1) = FA(1) * 0.01
                PAR(173) = FA(1)
                WRITE (JID(31:38), 99999, IOSTAT = IOST) FA(1)
C * S(Restrained-obs)
              CASE (365)
                PAR(300) = FA(1)
C * SHIFT/ESD(SU)-MAX
              CASE (367, 448)
                IF (PAR(178) < 0.0) PAR(178) = FA(1)
C * SHIFT/ESD(SU)-MEAN
              CASE (368, 461)
                PAR(179) = FA(1)
C * wR-All/Ref
              CASE (371, 446)
                IF (FA(1) > 1.0) FA(1) = FA(1) * 0.01
                PAR(174) = FA(1)
C * wR-obs/gt
              CASE (372, 460)
                IF (FA(1) > 1.0) FA(1) = FA(1) * 0.01
                PAR(310) = FA(1)
C * _reflns_number_total
              CASE (410)
                IPR(263) = NINT (FA(1))
C * _reflns_number_observed
              CASE (411)
                IPR(264) = NINT (FA(1))
C * _reflns_number_gt
              CASE (442)
                IPR(264) = NINT (FA(1))
C * _diffrn_reflns_theta_full
              CASE (444)
                PAR(312) = FA(1)
C * MEAS FRACTION THETA-MAX
              CASE (458)
                PAR(313) = FA(1)
C * MEAS FRACTION THETA-FULL
              CASE (459)
                PAR(314) = FA(1)
C * DIFF-DENS-RMS
              CASE (462)
                PAR(175) = FA(1)
C * SHIFT/ESD(SU)-MAX_LT
              CASE (511)
                IF (PAR(178) < 0.0) PAR(178) = FA(1)
C * HOOFT PARAMETER
              CASE (512)
                CALL GEN041 (FA(1), FA(2), IPR(615), 3,
     1                       IPR(616), IPR(68))
                PAR(435) = FA(1)
                PAR(436) = FA(2)
C * FACE LOOP (H,K,K,D)
C * _exptl_crystal_face_index_h
              CASE (245)
                FN(1) = FA(1)
C * _exptl_crystal_face_index_k
              CASE (246)
                FN(2) = FA(1)
C * _exptl_crystal_face_index_l
              CASE (247)
                FN(3) = FA(1)
C * _exptl_crystal_face_perp_dist
              CASE (248)
                IF (FA(1) > 0.0) THEN
                  FN(4)    = FA(1)
                  IPR(220) = 1
                  IPR(221) = 4
                  IFL(1)   = 'FACE'
                  LRETCIF  = 1
                END IF
            END SELECT
          END IF
      END SELECT
      RETURN
99999 FORMAT ('R =', F5.2)
99998 FORMAT (3I4, 2F8.2)
99997 FORMAT (3I4, 2F8.1)
99996 FORMAT (3I4, 2F8.0)
99995 FORMAT (':: ERROR: Wavelength = NOT-A-NUMBER', A)
99994 FORMAT (A)
99993 FORMAT (':: INCLUDE FILE ', A)
      END SUBROUTINE PLA179
 
      SUBROUTINE PLA180 (ICH, KEYWRD)
C * HANDLE CELL/CIF
      USE files
      USE parameters
      USE cif
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=1)   :: ICHU
      CHARACTER(len=NKW) :: UCIFD
      CHARACTER(len=NKW) :: KEYWRD
C * CONTINUE/FINISH BUILDING THE KEYWORD
      LRETCIF = 0
      ICHU    = ICH
      CALL GEN020 (1, ICHU, 1, 1)
C * CHECK FOR END-OF-KEYWORD
      IF (ICH /= CHAR(32)) THEN
C * HANDLE NEW CANONICAL KEYWORD FORMAT ('_' <> '.')
        IF (ICH == '.') ICH = '_'
C * CHECK FOR MAX KEYWORD LENGTH
        IF (KW < NKW) THEN
          KW            = KW + 1
          KEYWRD(KW:KW) = ICH
        END IF
C * HANDLE KEYWORD
      ELSE
        NLPM = NLPM + 1
C * CHECK FOR MAXIMUM NUMBER OF LOOP ENTRIES
        IF (NLPM <= NP58) THEN
          NLP(NLPM) = 0
C * REPORT KEYWORD LOOP NUMBER OVERFLOW
        ELSE
          IPR(2)  = 60
C * ERROR
          LRETCIF = 2
          RETURN
        END IF
        IPR(751) = 0
C * CHECK FOR OFFICIAL KEYWORDS (I = 1) OR UPPERCASE VARIANT (I = 2)
        DO I = 1, 2
          IF (I == 2) CALL GEN020 (-1, KEYWRD, 1, NKW)
          DO J = 1, NP34
            UCIFD = CIFDIR(J)
            IF (I == 2) CALL GEN020 (-1, UCIFD,  1, NKW)
            IF (KEYWRD == UCIFD) THEN
              IF (NLPM <= NP58) THEN
C * CHECK FOR EMPTY BOND LOOP
                IF (NLP(1) == 265) THEN
                  IF (J < 265 .OR. J > 270) THEN
                    NLPM  = 1
                    ILOOP = 0
                  END IF
C * CHECK FOR EMPTY ANGLE LOOP
                ELSE IF (NLP(1) == 258) THEN
                  IF (J < 257 .OR. J > 264) THEN
                    NLPM  = 1
                    ILOOP = 0
                  END IF
C * CHECK FOR EMPTY TORSION LOOP
                ELSE IF (NLP(1) == 279) THEN
                  IF (J < 278 .OR. J > 288) THEN
                    NLPM  = 1
                    ILOOP = 0
                  END IF
                END IF
                NLP(NLPM) = J
C * REPORT KEYWORD LOOP NUMBER OVERFLOW
              ELSE
                IPR(2)  = 60
                LRETCIF = 2
                RETURN
              END IF
              GO TO 10
            END IF
          END DO
        END DO
        J  = 0
        IF (KEYWRD(1:5) /= '_vrf_' .AND.
     1    KEYWRD(1:4) /= '_pd_' .AND.
     2    KEYWRD(1:11) /= '_jana_atom_') THEN
          IPR(429) = IPR(429) + 1
C * COUNT _atom_site_anharm_GC* datanames in CIF
          IF (KEYWRD(1:20) == '_atom_site_anharm_gc' .OR.
     1        KEYWRD(1:20) == '_atom_site_anharm_GC') THEN
            IPR(756) = IPR(756) + 1
          ELSE
            WRITE (LU6, 99999, IOSTAT = IOST) KEYWRD
          END IF
        END IF
C * CHECK FOR POWDER DATANAMES
        IF (KEYWRD(1:4) == '_pd_') IPR(105) = 1
   10   CALL GEN038 (KEYWRD, 1, NKW)
        KW = 0
C * CHECK FOR '_refln_index_h'
        IF (J == 385) THEN
C * TEST FOR SYSTEM - S
          IF (IGBL(3) == 14) THEN
            LRETCIF = 3
            RETURN
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT ('W: Keyword Not in PLATON/CIFDIR - Ignored:', /, 3X, A)
      END SUBROUTINE PLA180
 
      SUBROUTINE PLA181 (MODE)
C * SUPPORT PLA176 -BOND, ANGLE etc. loop data
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cif
      IMPLICIT NONE
      INTEGER :: N
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: NIEN
      INTEGER :: MODE
      INTEGER :: IENM0
      INTEGER :: IENM1
      INTEGER :: IENM2
      INTEGER :: IENM3
      INTEGER :: INQNR
      INTEGER :: JNQNR
      INTEGER :: MSUBST
      REAL    :: VDWR1
      REAL    :: VDWR2
      REAL    :: VDWR3
      REAL    :: DELTA
      IF (MODE == 0 .AND. IGBL(3) /= 14) THEN
        IF (LINE(1:4) == 'BOND' .OR.
     1      LINE(1:5) == 'ANGLE' .OR.
     2      LINE(1:5) == 'TORSI' .OR.
     3      LINE(1:7) == 'CONTACT') THEN
C * TEST/REMOVE '^' ISSUES
          CALL PLA392 (4)
          WRITE (LU11) LINE, (IFL(N), N = 1, 4), (FN(N), N = 1, 6)
          LRETCIF = 4
        ELSE IF (LINE(1:5) == 'HBOND') THEN
          IF (IFL(1)(1:1) /= '?') THEN
C * TEST/REMOVE '^' ISSUES
            CALL PLA392 (4)
            NQ1 = IFL(1)
            CALL PLA046 (1, NQ1, IENM1, LBB, LBC, LBD, INQNR,
     1        JNQNR, NIEN)
            IF (NIEN < 0) THEN
C * ALERT _715
              CALL PLA236 (715, 0, 1.0, 1.0, IFL(1)(1:9), ' ')
            ELSE
              VDWR1 = VDWR(IEN(IENM1))
              NQ1 = IFL(2)
              CALL PLA046 (1, NQ1, IENM2, LBB, LBC, LBD, INQNR,
     1          JNQNR, NIEN)
              IF (NIEN < 0) THEN
C * ALERT _716
                CALL PLA236 (716, 0, 1.0, 1.0, IFL(2)(1:9), ' ')
              ELSE
                VDWR2 = VDWR(IEN(IENM2))
                NQ1 = IFL(3)
                CALL PLA046 (1, NQ1, IENM3, LBB, LBC, LBD, INQNR,
     1            JNQNR, NIEN)
                IF (NIEN < 0) THEN
                  CALL GEN020 (1, IFL(3), 1, 9)
C * ALERT _717
                  IF (INDEX (IFL(3), 'CG') == 0) THEN
                    CALL PLA236 (717, 0, 1.0, 1.0, IFL(3)(1:9), ' ')
                  ELSE
                    CALL PLA236 (717, 0, -999.0, 1.0, IFL(3)(1:9), ' ')
                  END IF
                ELSE
                  IENM0 = IEN(IENM3)
                  VDWR3 = VDWR(IENM0)
                  IF (FN(1) > 0.0) THEN
                    LINE = 'D-H'
                    WRITE (LU11) LINE, (IFL(N), N = 1, 4),
     1                (FN(N), N = 1, 2), FN(9), FN(10), 0.0, 0.0
                  END IF
                  IF (FN(3) > 0.0 .AND. (IFL(2)(1:1) == 'H' .OR.
     1              IFL(2)(1:1) == 'D')) THEN
                    DELTA = FN(3) - VDWR2 - VDWR3
                    IF (DELTA > -0.12) THEN
                      NQ2 = IFL(2)
C * TRANSLATE TO ALAB
                      MSUBST = 0
                      CALL PLA281 (-1, NQ2, MSUBST)
C * ALERT _480
                      IF (IFL(3)(1:2) /= 'CG')
     1                  CALL PLA236 (480, 2, -999.0, FN(3), NQ2, IFL(3))
                    END IF
                    LINE = 'H..A'
                    WRITE (LU11) LINE, (IFL(N), N = 2, 5),
     1                (FN(N), N = 3, 4), FN(10), FN(11), 0.0, 0.0
                  END IF
                  IF (FN(5) > 0.0 .AND. (IFL(2)(1:1) == 'H' .OR.
     1              IFL(2)(1:1) == 'D')) THEN
                    DELTA = FN(5) - VDWR1 - VDWR3
                    IF (DELTA > 0.0) THEN
C * ALERT _481
                      CALL PLA236 (481, 2, DELTA, FN(5), IFL(1), IFL(3))
                    END IF
                    LINE = 'D..A'
                    WRITE (LU11) LINE, IFL(1), (IFL(N), N = 3, 5),
     1                (FN(N), N = 5, 6), FN(9), FN(11), 0.0, 0.0
                  END IF
                  IF (FN(7) > 0.0 .AND. (IFL(2)(1:1) == 'H' .OR.
     1              IFL(2)(1:1) == 'D')) THEN
                    DELTA = 180.0 - FN(7)
                    IF (DELTA > 60.0) THEN
C * ALERT _482
                      CALL PLA236 (482, 2, DELTA, FN(7), IFL(1), IFL(3))
                    END IF
C * TEST FOR PROPER ROUNDING OF D-H..A without SU
                    IF (FN(8) == 0.0 .AND. IPR(105) == 0) THEN
C * ALERT _484
                      IF (ABS (FN(7) - NINT (FN(7))) > 0.001)
     1                  CALL PLA236 (484, 0, -999.0, FN(7), IFL(1),
     2                    IFL(3))
                    END IF
                    LINE = 'D-H..A'
                    WRITE (LU11) LINE, (IFL(N), N = 1, 4),
     1                (FN(N), N = 7, 8), FN(9), FN(10), FN(11), 0.0
                  END IF
                END IF
              END IF
              LINE(1:1) = CHAR (32)
            END IF
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA181
 
      SUBROUTINE PLA182
C * PARSE WEIGHT EXPRESSION
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cif
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      INTEGER :: M
      INTEGER :: N
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: JB
      INTEGER :: JC
      INTEGER :: JD
      INTEGER :: JE
      INTEGER :: JX
      INTEGER :: JEP
      INTEGER :: IER
      INTEGER :: ISTP
      REAL    :: PAR_A
      REAL    :: PAR_B
      REAL    :: PAR_C
      REAL    :: PAR_D
      REAL    :: PAR_E
      REAL    :: PAR_F
C * HANDLE WEIGHT EXPRESSION
      PAR_A = 0.0
      PAR_B = 0.0
      PAR_C = 0.0
      PAR_D = 0.0
      PAR_E = 0.0
      PAR_F = 0.33333
      M1    = 0
      M2    = 0
      IER   = 0
      RLWS(1) = ''''//NWRD(2 : NP70)
C * MoPro STYLE WEIGHT
      IF (IPR(725) == 9) THEN
        RLWS(1) = ' w'//NWRD(9 : NP70)
        N = INDEX (RLWS(1), 'S')
        IF (N /= 0) RLWS(1)(N : N) = 's'
        N = INDEX (RLWS(1), 'FO')
        IF (N /= 0) RLWS(1)(N : N + 1) = 'Fo'
      END IF
C * SHELXL20xy REFINEMENT STYLE WEIGHT
      IF (IPR(725) == 2) THEN
C * GET A PARAMETER VALUE
        N = INDEX (RLWS(1), 'P)^2^')
        IF (N > 0) THEN
          M1 = N + 4
          M  = N - 1
          DO I = 1, 9
            M = M - 1
            IF (RLWS(1)(M:M) == '(') THEN
              READ (RLWS(1)(M + 1:N - 1), *, IOSTAT = IOST) PAR_A
              IF (IOST /= 0) IER = IER + 1
              EXIT
            END IF
          END DO
        END IF
C * GET B PARAMETER VALUE
        N = MAX(INDEX (RLWS(1), 'P+'), INDEX (RLWS(1), 'P-'),
     1          INDEX (RLWS(1), 'P]'))
        IF (N > 0) THEN
          M1 = N
          M  = N - 1
          DO I = 1, 9
            M = M - 1
            IF (RLWS(1)(M:M) == '+' .OR. RLWS(1)(M:M) == '-') THEN
              READ (RLWS(1)(M:N - 1), *, IOSTAT = IOST) PAR_B
              IF (IOST /= 0) IER = IER + 1
              EXIT
            END IF
          END DO
        END IF
C * GET E PARAMETER VALUE
        N = INDEX (RLWS(1), 'L] WHERE') - 8
        IF (N > 0) THEN
          M = N
          DO I = 1, 9
            M = M - I
            IF (RLWS(1)(M:M) == '+' .OR. RLWS(1)(M:M) == '-') THEN
              M2 = M
              READ (RLWS(1)(M:N), *, IOSTAT = IOST) PAR_E
              IF (IOST /= 0) IER = IER + 1
              EXIT
            END IF
          END DO
        ELSE
          N = INDEX (RLWS(1), '] WHERE')
          IF (N > 0) M2 = N
        END IF
C * GET D PARAMETER VALUE
        IF (M1 /= 0 .AND. M2 - M1 > 1) THEN
          READ (RLWS(1)(M1+1:M2-1), *, IOSTAT = IOST) PAR_D
          IF (IOST /= 0) IER = IER + 1
        END IF
C * GET C PARAMETER VALUE
        IF (RLWS(1)(2:4) == 'W=1') THEN
          PAR_C = 0.0
        ELSE IF (RLWS(1)(2:7) == 'W=EXP[') THEN
          N = INDEX (RLWS(1), '(SIN')
          READ(RLWS(1)(8:N-1), *, IOSTAT = IOST) PAR_C
          IF (IOST /= 0) IER = IER + 1
        ELSE IF (RLWS(1)(2:10) == 'W={1-EXP[') THEN
          N = INDEX (RLWS(1), '(SIN')
          READ(RLWS(1)(11:N-1), *, IOSTAT = IOST) PAR_C
          IF (IOST /= 0) IER = IER + 1
        END IF
C * GET F PARAMETER VALUE
        IF (INDEX (RLWS(1), 'WHERE P=') > 0) THEN
          N = INDEX (RLWS(1), '^)/')
          M = INDEX (RLWS(1)(N+3:), '''')
 
          IF (M == 2) THEN
            READ(RLWS(1)(N+3:N+3), *, IOSTAT = IOST) K
            IF (IOST /= 0) THEN
              PAR_F = 0.3333
            ELSE
              PAR_F = 1.0 / K
            END IF
          END IF
        END IF
        IF (IER /= 0) GO TO 10
        PAR(493) = PAR_A
        PAR(494) = PAR_B
        PAR(495) = PAR_C
        PAR(496) = PAR_D
        PAR(497) = PAR_E
        PAR(498) = PAR_F
        IPR(632) = 1
C * ALERT _083 : TEST FOR EXTREME SECOND WEIGHTING PARAMETER VALUE (SHELXL)
                  IF (PAR(494) > 5.0) CALL PLA236
     1              (83, 2, -999.0, PAR(494), ' ', ' ')
C * ALERT _085 : TEST FOR SHELXL DEFAULT
                  IF (PAR(493) == 0.1 .AND. PAR(494) == 0.0)
     1              CALL PLA236 (85, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _963 : TEST FOR BOTH WEIGHT PARAMETERS ZERO
            IF (PAR(493) == 0.0 .AND. PAR(494) == 0.0)
     1        CALL PLA236 (963, 0, -999.0, 1.0, ' ', ' ')
C * IGNORE TEXSAN
C * HANDLE MOPRO WEIGHT EXPRESSION
      ELSE IF (IPR(725) == 9) THEN
C * IPR(725) = 1 : SHELXL97; IGBL(725) = 2 : SHELXL(20XX)
      ELSE IF (IPR(725) < 2  .OR.
     1   (IGBL(9) /= 6  .AND. IGBL(9) /= 10 .AND.
     2    IGBL(9) /= 13 .AND. IGBL(9) /= 15)) THEN
C * HANDLE EXTENDED SHELXL SCHEME
        IF (INDEX (RLWS(1), 'CALC  [') /= 0) THEN
          READ (STRSAVE, 99999, IOSTAT = IOST) (PAR(492 + K), K = 1, 8)
          IF (IOST /= 0) GO TO 10
          WRITE (LU6, 99997, IOSTAT = IOST) (PAR(K), K = 493, 500)
          IF (PAR(493) == 1.0) THEN
            IPR(632) = -1
            CALL GEN018 (PAR(493), PAR(494))
          ELSE
            GO TO 10
          END IF
C * NORMAL SHELXL SCHEME ?
        ELSE
          IF (RLWS(1)(70:70) == '3') THEN
            ISTP = 0
          ELSE IF (RLWS(1)(71:71) == '3') THEN
            ISTP = 1
          ELSE
            ISTP = -1
          END IF
          IF (ISTP >= 0) THEN
            CALL GEN020 (-1, RLWS(1),  2, 13)
C * SHELXL-97 FORMAT
            IF (RLWS(1)(18:19) == 'FO') RLWS(1)(19:19) = 'o'
C * SHELXL-93 FORMAT
            IF (RLWS(1)(17:18) == '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) == '+0.0000P]')
     1          RLWS(1)(37:45) =    ']        '
          END IF
C * FIND WEIGHT PARAMETERS (TEST FOR SHELXL/JANA)
          JE = INDEX (RLWS(1), '(I)')
          JC = INDEX (RLWS(1), 'I^2')
C * JANA
          IF (JE > 0 .AND. JC > 0) THEN
            JEP = INDEX (RLWS(1)(JE:), '+')
            IPR(632) = 2
            PAR(484) = 3.0
            READ (RLWS(1)(JE + JEP + 1: JC - 1), *, IOSTAT = IOST)
     1        PAR(493)
            IF (IOST > 0) GO TO 10
            PAR(494) = 0.0
C * SHELXL
          ELSE
C * HANDLE CASE WITH THIRD PARAMETER 'C' NOT EQUAL 1.0
            JE = INDEX (RLWS(1), 'W=EXP[')
            IF (JE /= 0) THEN
              JC = INDEX (RLWS(1), '(SIN')
              IF (JC /= 0) THEN
                JE = JE + 6
                JC = JC - 1
                READ (RLWS(1)(JE:JC), *, IOSTAT = IOST) PAR(495)
              END IF
            END IF
            JE = INDEX (RLWS(1), 'P)')
            JC = INDEX (RLWS(1), 'P]')
            IF (JE /= 0 .OR. JC /= 0) THEN
              PAR(498) = 0.33333
              IPR(632) = 1
C * CRYSTALS: Pseudo Shelx weights
              JX = INDEX (RLWS(1), 'SHELDRICK')
              IF (JX /= 0) IPR(632) = 3
              IF (JE == 0 .AND. JC /= 0) PAR(493) = 0.0
              IF (JE /= 0) THEN
                JD = 2
                JB = INDEX (RLWS(1)(1:JE), '+(')
                IF (JB == 0) THEN
                  JB = INDEX (RLWS(1)(1:JE), '+ (')
                  IF (JB /= 0) JD = 3
                END IF
                IF (JB > 0) THEN
                  READ (RLWS(1)(JB + JD: JE - 1), *, IOSTAT = IOST)
     1              PAR(493)
                  IF (IOST /= 0) GO TO 10
                  IF (PAR(493) >= 0.0) THEN
                    PAR(494) = 0.0
C * ALERT _072 : TEST FOR EXTREME FIRST WEIGHTING PARAMETER VALUE (SHELXL)
                    IF (PAR(493) > 0.1) CALL PLA236
     1                 (72, 2, -999.0, PAR(493), ' ', ' ')
                  END IF
                END IF
              END IF
              IF (JC /= 0) THEN
                JB = INDEX (RLWS(1)(JE + 1:JC - 1), '+')
                IF (JB > 0 .AND. JB + JE <= JC - 1) THEN
                  READ (RLWS(1)(JB + JE + 1: JC - 1), *,
     1              IOSTAT = IOST) PAR(494)
                  IF (IOST /= 0) GO TO 10
C * ALERT _083 : TEST FOR EXTREME SECOND WEIGHTING PARAMETER VALUE (SHELXL)
                  IF (PAR(494) > 5.0) CALL PLA236
     1              (83, 2, -999.0, PAR(494), ' ', ' ')
C * ALERT _085 : TEST FOR SHELXL DEFAULT
                  IF (PAR(493) == 0.1 .AND. PAR(494) == 0.0)
     1              CALL PLA236 (85, 0, 1.0, 1.0, ' ', ' ')
                END IF
              END IF
            ELSE
              JB = INDEX (RLWS(1), '(FO^2^)')
              IF (JB /= 0) THEN
                PAR(493) = 0.0
                PAR(494) = 0.0
                IPR(632) = 1
              END IF
            END IF
C * ALERT _963 : TEST FOR BOTH WEIGHT PARAMETERS ZERO
            IF (PAR(493) == 0.0 .AND. PAR(494) == 0.0)
     1        CALL PLA236 (963, 0, -999.0, 1.0, ' ', ' ')
          END IF
        END IF
        RETURN
      END IF
      RETURN
C * PROBLEM WITH PARSING THE WEIGHT EXPRESSION STRING
   10 WRITE (LU6, 99998, IOSTAT = IOST) RLWS(1)
      IPR(632) = 0
      PAR(493) = -999999.0
      PAR(494) = -999999.0
      CALL PLA236 (809, 0, -999.0, 0.0, ' ', ' ')
99999 FORMAT (8X, F7.0, F8.0, 4X, F4.0, 33X, F7.0, F7.0, 4X, F6.0, 5X,
     1        F7.0, 20X, F8.0)
99998 FORMAT (':: Problem with Weight Formula:', /, A)
99997 FORMAT (8F8.4)
      END SUBROUTINE PLA182
 
      REAL FUNCTION PLA183 (IH, IK, IL, OBS, CALC, SIGOBS)
C * CALCULATE SIGIW
      USE parameters
      IMPLICIT NONE
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      REAL    :: P
      REAL    :: Q
      REAL    :: F1
      REAL    :: F2
      REAL    :: F3
      REAL    :: OBS
      REAL    :: CALC
      REAL    :: SIGOBS
      REAL    :: GEN095
C * PAR_A = PAR(493)
C * PAR_B = PAR(494)
C * PAR_C = PAR(495)
C * PAR_D = PAR(496)
C * PAR_E = PAR(497)
C * PAR_F = PAR(498)
      P  = PAR(498) * MAX (OBS, 0.0) + (1.0 - PAR(498)) * CALC
      F2 = SIGOBS**2 + (PAR(493)*P)**2 + PAR(494) * P + PAR(496)
C * CHECK FOR NONZERO PAR_C OR PAR_E
      IF (PAR(495) /= 0.0 .OR. PAR(497) /= 0.0) THEN
        Q = GEN095(PAR(191), IH, IK, IL)
      END IF
      IF (PAR(495) > 0.0) THEN
        F1 = EXP (PAR(495) * Q)
      ELSE IF (PAR(495) < 0.0) THEN
        F1 = 1.0 - EXP (PAR(495) * Q)
      ELSE
        F1 = 1.0
      END IF
      IF (PAR(497) /= 0.0) THEN
        F3 = PAR(497) * SQRT (Q)
      ELSE
        F3 = 0.0
      END IF
      PLA183 = SQRT (F2 + F3 / F1)
      END FUNCTION PLA183
 
      SUBROUTINE PLA184
C * INSPECT .RES FILE CONTENT
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE sgxyz
      USE cif
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: N
      INTEGER          :: N1
      INTEGER          :: N2
      INTEGER          :: N3
      INTEGER          :: KL
      INTEGER          :: KN
      INTEGER          :: JUNK
      INTEGER          :: IYUNK
      INTEGER          :: JUNK1
      INTEGER          :: NRSYM
      INTEGER, SAVE    :: ITEMP
      REAL             :: YUNC
      REAL             :: YUNK
      REAL             :: YUNK1
      CHARACTER(len=4) :: KEY
      CHARACTER(len=2) :: ELTYP
      KEY  = ICL(1:4)
C * UPPER CASE
      CALL GEN020 (1, KEY, 1, 4)
      CALL GEN074 (FN, 1, 6, 0.0)
C * TITL
      IF (KEY == 'TITL') THEN
        ITEMP = -2
C * CHECK CELL REPORTED WAVELENGTH AGAINST CIF REPORTED VALUE
      ELSE IF (KEY == 'CELL') THEN
        IF (PAR(17) > 0.0) THEN
          READ (ICL(5:80), *, IOSTAT = IOST) FN(1)
          IF (ABS(PAR(17) - FN(1)) > 0.0001) THEN
C * ALERT _105
            CALL PLA236 (105, 0, 1.0, 0.0, ' ', ' ')
          END IF
        END IF
C * REPORT ON EXPLICITLY SUPPLIED SCATTERING FACTOR DATA
      ELSE IF (KEY == 'SFAC') THEN
        N = INDEX (ICL(1:80), '=')
        IF (N > 0) THEN
          N = N - 1
        ELSE
          N = 80
        END IF
        CALL GEN072 (ICL, IFL, FN, KL, KN, 0, 0, 1, 1, N, 7, NP17)
        IF (KN >= 5) IPR(763) = IPR(763) + 1
C * REGISTER FVAR VALUE
      ELSE IF (KEY == 'FVAR') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) YUNK
        IF (IOST == 0) PAR(74) = YUNK
C * REGISTER WEIGHT PARAMETER VALUES
      ELSE IF (KEY == 'WGHT') THEN
        FN(6) = 1.0 / 3.0
        READ (ICL(5:80), *, IOSTAT = IOST) (FN(I), I = 1, 6)
        IF (PAR(563) < 0.0) PAR(563) =
     1    ABS (FN(3)) + ABS (FN(4)) + ABS (FN(5)) + ABS (FN(6))
     2    - 1.0 / 3.0
        IF (PAR(559) < 0.0) THEN
          PAR(559) = FN(1)
          PAR(560) = FN(2)
        ELSE
          PAR(561) = FN(1)
          PAR(562) = FN(2)
        ENDIF
C * GET # OF PART -N RECORDS IN THE CIF-EMBEDDED RES
      ELSE IF (KEY == 'PART') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) JUNK
        IF (JUNK < 0) IPR(780) = IPR(780) + 1
C * GET NEXTRA (SQUEEZE)
      ELSE IF (KEY == 'L.S.') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) JUNK, JUNK, IPR(767)
C * REPORT ON AFIX 1 RECORDS
      ELSE IF (KEY == 'AFIX') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) YUNK
        IF (IOST == 0) THEN
          IF (NINT (YUNK) == 1) IPR(709) = IPR(709) + 1
        END IF
C * REPORT ON DAMP INSTRUCTION IN EMBEDDED RES FILE
      ELSE IF (KEY == 'DAMP') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) YUNK
C * ALERT _936
        IF (IOST == 0) THEN
          IF (YUNK == 0.0) THEN
          YUNC = 2
          ELSE IF (YUNK > 0.7) THEN
            YUNC = 1
          ELSE
            YUNC = 0.001
          END IF
          CALL PLA236 (936, 1, YUNC, YUNK, ' ', ' ')
        END IF
C * TEST FOR AND REGISTER ABIN INSTRUCTION IN EMBEDDED .res
      ELSE IF (KEY == 'ABIN') THEN
        IPR(766) = 1
        IF (IPR(651) < 10) IPR(651) = IPR(651) + 10
C * REGISTER MERG INSTRUCTION
      ELSE IF (KEY == 'MERG') THEN
        IPR(703) = 1
C * REGISTER EXYZ CONSTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'EXYZ') THEN
        IPR(684) = IPR(684) + 1
C * REGISTER EADP CONSTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'EADP') THEN
        IPR(685) = IPR(685) + 1
C * REGISTER DFIX RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'DFIX') THEN
        IPR(686) = IPR(686) + 1
C * ALERT _195
        IF (FN(2) /= 0.0 .AND. FN(2) /= 0.02)
     1    CALL PLA236 (195, 4, -999.0, FN(2), ' ', ' ')
C * REGISTER DANG RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'DANG') THEN
        IPR(687) = IPR(687) + 1
C * ALERT _167
        IF (FN(2) /= 0.0 .AND. FN(2) /= 0.02)
     1    CALL PLA236 (167, 4, -999.0, FN(2), ' ', ' ')
C * REGISTER FLAT RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'FLAT') THEN
        IPR(688) = IPR(688) + 1
C * REGISTER SAME RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'SAME') THEN
        IPR(689) = IPR(689) + 1
C * ALERT _189 - CHECK FOR NON-DEFAULT CONSTRAINT VALUE
        READ (ICL(5:80), *, IOSTAT = IOST) FN(1), FN(2)
        IF (FN(1) /= 0.0 .AND. FN(1) /= 0.02)
     1    CALL PLA236 (189, 4, -999.0, FN(1), 'First Par', ' ')
        IF (FN(2) /= 0.0 .AND. FN(2) /= 0.04)
     1    CALL PLA236 (189, 4, -999.0, FN(2), 'SecondPar', ' ')
C * REGISTER SADI RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'SADI') THEN
        IPR(690) = IPR(690) + 1
C * ALERT _191 - CHECK FOR NON-DEFAULT CONSTRAINT VALUE
        READ (ICL(5:80), *, IOSTAT = IOST) FN(1)
        IF (FN(1) /= 0.0 .AND. FN(1) /= 0.02)
     1    CALL PLA236 (191, 4, -999.0, FN(1), ' ', ' ')
C * REGISTER DELU RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'DELU') THEN
        IPR(691) = IPR(691) + 1
C * ALERT _192 - CHECK FOR NON-DEFAULT CONSTRAINT VALUE
        READ (ICL(5:80), *, IOSTAT = IOST) FN(1), FN(2)
        IF (FN(1) /= 0.0 .AND. FN(1) /= 0.01)
     1    CALL PLA236 (192, 4, -999.0, FN(1), 'First Par', ' ')
        IF (FN(2) /= 0.0 .AND. FN(2) /= 0.01)
     1    CALL PLA236 (192, 4, -999.0, FN(2), 'SecondPar', ' ')
C * REGISTER SIMU RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'SIMU') THEN
        IPR(692) = IPR(692) + 1
C * ALERT _188 - CHECK FOR NON-DEFAULT CONSTRAINT VALUE
        READ (ICL(5:80), *, IOSTAT = IOST) FN(1)
        IF (FN(1) /= 0.0 .AND. FN(1) /= 0.04)
     1    CALL PLA236 (188, 4, -999.0, FN(1), ' ', ' ')
C * REGISTER CHIV RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'CHIV') THEN
        IPR(693) = IPR(693) + 1
C * REGISTER ISOR RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'ISOR') THEN
        IPR(694) = IPR(694) + 1
C * REGISTER RIGU RESTRAINT INSTRUCTION RECORD(S)
      ELSE IF (KEY == 'RIGU') THEN
        IPR(710) = IPR(710) + 1
C * ALERT _190 - CHECK FOR NON-DEFAULT RESTRAINT VALUE
        READ (ICL(5:80), *, IOSTAT = IOST) FN(1), FN(2)
        IF (FN(1) /= 0.0 .AND. FN(1) /= 0.004)
     1    CALL PLA236 (190, 4, -999.0, FN(1), 'First Par', ' ')
        IF (FN(2) /= 0.0 .AND. FN(2) /= 0.004)
     1    CALL PLA236 (190, 4, -999.0, FN(2), 'SecondPar', ' ')
C * CHECK FOR NON-DEFAULT DEFS RESTRAINT VALUE
      ELSE IF (KEY == 'DEFS') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) (FN(I), I = 1, 5)
        IF (FN(1) /= 0.0 .AND. FN(1) /= 0.02)
     1    CALL PLA236 (194, 4, -999.0, FN(1), ' for sd', ' ')
        IF (FN(2) /= 0.0 .AND. FN(2) /= 0.1)
     1    CALL PLA236 (194, 4, -999.0, FN(2), ' for sf', ' ')
        IF (FN(3) /= 0.0 .AND. FN(3) /= 0.01)
     1    CALL PLA236 (194, 4, -999.0, FN(3), ' for su', ' ')
        IF (FN(4) /= 0.0 .AND. FN(4) /= 0.04)
     1    CALL PLA236 (194, 4, -999.0, FN(4), ' for ss', ' ')
        IF (FN(5) /= 0.0 .AND. FN(5) /= 1.0)
     1    CALL PLA236 (194, 4, -999.0, FN(5), ' maxsof', ' ')
C * REGISTER SWAT INSTRUCTION
      ELSE IF (KEY == 'SWAT') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) PAR(501), PAR(502)
        IPR(698) = 1
      ELSE IF (KEY == 'EXTI') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) PAR(226)
C * CHECK FOR LIST 6 OR 8
      ELSE IF (KEY == 'LIST') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) IYUNK
        IF (IYUNK == 8) THEN
          CALL PLA236 (766, 0, 1.0, 0.0, ' ', ' ')
        ELSE IF (IYUNK == 6) THEN
          CALL PLA236 (767, 0, 1.0, 0.0, ' ', ' ')
        END IF
C * CHECK HKLF RECORD
      ELSE IF (KEY == 'HKLF') THEN
C * ALERT _196 - TEMP CHECK
        IF (ITEMP == -2 .AND. IPR(310) /= 293)
     1    CALL PLA236 (196, 0, 1.0, 293.0, ' ', ' ')
        READ (ICL(5:80), *, IOSTAT = IOST) IYUNK
        IF (IOST == 0) THEN
          IPR(648) = IYUNK
C * TEST FOR HKLF 2 REFINEMENT (LAUE)
          IF (IYUNK == 2) THEN
            IPR(106) = 1
C * TEST FOR HKLF 5
          ELSE IF (IYUNK == 5) THEN
            IPR(619) = 1
          END IF
        ELSE
          IPR(2)  = 70
          LRETCIF = 12
        END IF
C * TWINNING (BUT NOT INVERSION TWINNING)
      ELSE IF (KEY == 'TWIN') THEN
        N = 10
        DO
          READ (ICL(5:80), *, IOSTAT = IOST) (FN(I), I = 1, N)
          IF (IOST == 0) THEN
            EXIT
          ELSE
            N = N - 1
            IF (N == 0) EXIT
          END IF
        END DO
C * REGISTER TWINNING
        IF (N >= 9) THEN
          IPR(619) = 1
          IPR(779) = 0
          JUNK     = 0
          JUNK1    = 0
C * LOOP OVER SPACE GROUP SYMMETRY TO CHECK FOR 'FLACK INVERSION TWINNING'
          DO I = 1, IPR(48)
            NRSYM = I
            YUNK  = 0.0
            YUNK1 = 0.0
            IERR  = 0
            CALL SGSM (6, LINE, SGX, NRSYM, 0, IERR)
            DO J = 1, 9
              YUNK  = YUNK  + ABS (SGX(J) + FN(J))
              YUNK1 = YUNK1 + ABS (SGX(J) - FN(J))
            END DO
            IF (YUNK < 0.01) THEN
              JUNK = I
              IF (JUNK == 1) THEN
                IPR(619) = 0
              ELSE IF (JUNK > 1) THEN
C * REGISTER AS FLACK TWIN
                IPR(619) = 0
                IPR(779) = 1
C * ALERT _109 - Twinning Matrix is Alternate Inversion Twinning
                IF (IPR(257) == 1) THEN
                  IF (JUNK > 1)
     1              CALL PLA236 (109, 1, FLOAT (JUNK), FLOAT (JUNK),
     2                '  ', ' ')
C * ALERT _107 - Twinning Matrix Invalid in Centrosymmetric Space Group
                ELSE
                  CALL PLA236 (107, 1, FLOAT (JUNK), FLOAT (JUNK),
     1              ' ', ' ')
                END IF
              END IF
              EXIT
            END IF
            IF (YUNK1 < 0.01) THEN
              JUNK1 = I
              IF (JUNK1 > 0) THEN
                IPR(619) = 0
                IPR(779) = 1
C * ALERT _108 - Twinning Matrix is inverted Laue Group operation
                CALL PLA236 (108, 1, FLOAT (JUNK1), FLOAT (JUNK1),
     1            ' ', ' ')
                EXIT
              END IF
            END IF
          END DO
        END IF
        IF (IPR(619) == 0) IPR(193) = IPR(193) + 100
        IPR(705) = IPR(705) + 1
C * TEMP
      ELSE IF (KEY == 'TEMP') THEN
        ITEMP = -1
C * BASF
      ELSE IF (KEY == 'BASF') THEN
        IPR(193) = IPR(193) + 1
        IPR(705) = IPR(705) + 1
C * CATCH DISP MU VALUE
      ELSE IF (KEY == 'DISP') THEN
        CALL GEN020 (1, ICL, 1, 80)
        DO K = 1, IAN
          ELTYP = DISPTYPE(K)
          CALL GEN020 (1, ELTYP, 1, 2)
          J = INDEX (ICL(5:80), ELTYP)
          IF (J /= 0) THEN
            READ (ICL(J + 7: 80), *, IOSTAT = IOST)
     1        FN(1), FN(2),FN(3)
            IF (IOST == 0) THEN
              IF (DISPVAL(K, 3) == 0.0) DISPVAL(K, 3) = FN(3)
            END IF
          END IF
        END DO
C * REGISTER NUMBER OF OMIT RECORDS
      ELSE IF (KEY == 'OMIT') THEN
        READ (ICL(5:80), *, IOSTAT = IOST) N1, N2, N3
        IF (IOST == 0) THEN
          IF (IABS (N1) + IABS (N2) + IABS (N3) > 0) THEN
            IPR(714) = IPR(714) + 1
            IF (IPR(714) <= NP78) THEN
              NOMIT(1, IPR(714)) = N1
              NOMIT(2, IPR(714)) = N2
              NOMIT(3, IPR(714)) = N3
            END IF
          END IF
C * _967 - THETA CUTOFF OMIT RECORD
        ELSE
          READ (ICL(5:80), *, IOSTAT = IOST) YUNK, YUNK1
          IF (IOST == 0) THEN
            PAR(500) = YUNK1
            IF (YUNK1 < 180.0)
     1        CALL PLA236 (967, 1, -999.0, PAR(500), ' ', ' ')
          END IF
        END IF
C * REGISTER INCLUDE FILE
      ELSE IF (ICL(1:1) == '+') THEN
        IPR(738)    = -1
        INCLUDEFILE = ICL(2:80)
C * REGISTER LONE/BEDE
      ELSE IF (KEY == 'BEDE' .OR. KEY == 'LONE') THEN
        IPR(757) = IPR(757) + 1
      END IF
      RETURN
      END SUBROUTINE PLA184
 
      SUBROUTINE PLA185 (N)
C * HANDLE CELL DATA
      USE parameters
      USE cif
      IMPLICIT NONE
      INTEGER       :: I
      INTEGER       :: N
      INTEGER, SAVE :: M
C * REGISTER UNTIL 6 CELL PARAMETERS
      IF (N /= 0) THEN
        CELL(N)     = FA(1)
        CELL(6 + N) = FA(2)
        M           = M + 1
C * CELL DATA COMPLETE
        IF (M == 6) THEN
          IFL(1) = 'CELL'
          DO I = 1, 12
            FN(I) = CELL(I)
          END DO
          IPR(220) = 1
          IPR(221) = 6
          LRETCIF  = 1
        END IF
C * N = 0: INIT
      ELSE
        M       = 0
        LRETCIF = 0
      END IF
      RETURN
      END SUBROUTINE PLA185
 
      MODULE abspsi
      SAVE
      INTEGER                    :: NPSI
      INTEGER, DIMENSION(4, 10)  :: IHKLPS
      REAL, DIMENSION(3,  3, 11) :: OP
      REAL, DIMENSION(38, 4, 10) :: PSIS
      END MODULE abspsi
 
      SUBROUTINE PLA186
C * SELECTOR FOR ABSORPTION CORRECTION
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cggt
      USE crystal
      USE abspsi
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: I1
      INTEGER               :: I2
      INTEGER               :: IG
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: IS
      INTEGER               :: NRF
      INTEGER               :: ILP
      INTEGER               :: ITEL
      INTEGER               :: IPH1
      INTEGER               :: IPH2
      INTEGER               :: ICRT
      INTEGER               :: MODE
      INTEGER               :: NATO
      INTEGER               :: NREF
      INTEGER               :: NRET
      INTEGER               :: NOCLS
      INTEGER               :: NAUTO
      INTEGER               :: INEXT
      INTEGER, DIMENSION(3) :: IHMIN
      INTEGER, DIMENSION(3) :: IHMAX
      REAL                  :: TT
      REAL                  :: XG
      REAL                  :: YG
      REAL                  :: ZG
      REAL                  :: DUM
      REAL                  :: STH
      REAL                  :: TH1
      REAL                  :: TH2
      REAL                  :: XINT
      REAL                  :: XLNG
      REAL                  :: SUMT
      REAL                  :: PHI1
      REAL                  :: PHI2
      REAL                  :: FMAX
      REAL                  :: YUNK
      REAL                  :: RELI
      REAL                  :: SIGI
      REAL                  :: SINT
      REAL                  :: TMAX
      REAL                  :: TMIN
      REAL                  :: ACAL
      REAL                  :: BCAL
      REAL                  :: ACALA
      REAL                  :: BCALA
      REAL                  :: TPRIM
      REAL                  :: TDIFF
      REAL                  :: THETA
      REAL                  :: ANGLE
      REAL                  :: ASTAR
      REAL                  :: DUMMY
      REAL                  :: FSCAL
      REAL                  :: REANAS
      REAL                  :: ACALAF
      REAL                  :: BCALAF
      REAL                  :: GEN006
      REAL                  :: GEN009
      REAL                  :: GEN056
      REAL                  :: GEN095
      REAL                  :: ABSCOR
      MODE = IPR(78)
C * MODE = -2 - MULABS
C * MODE = -1 - SPHERICAL CORRECTION
C * MODE =  0 - XTAL-HABIT PLOT
C * MODE =  1 - MODEL <-> PSISCAN TEST
C * MODE =  2 - GAUSSIAN INTEGRATION
C * MODE =  3 - MEULENAER & TOMPA
C * MODE =  4 - PSI-SCAN BASED CORRECTION
C * SPHERICAL ABSORPTION CORRECTION (INITIALIZATION)
      IF (MODE == -1) THEN
        IF (IPR(221) == 2) THEN
          PAR(321) = FN(1) * FN(2)
          CALL PLA191 (1, PAR(321), YUNK)
        END IF
        IPR(363) = 0
      ELSE IF (MODE == 2) THEN
C * CHECK FOR PROPER FILE ASSOCIATION AND DIRECTION COSINES
        CALL PLA008
        IF (IGBL(37) /= 0) THEN
          PAR(162) = FN(1)
          IF (IPR(221) == 4) THEN
            DO I = 2, 4
              IPR(419 + I) = NINT (FN(I))
            END DO
          END IF
          PAGET = 'ABSGAUSS'
        ELSE
          IPR(2) = 56
          RETURN
        END IF
      ELSE IF (MODE == 3) THEN
        CALL PLA008
        IF (IGBL(37) /= 0) THEN
          PAR(162) = FN(1)
          PAGET = 'ABSTOMPA'
        ELSE
          IPR(2) = 56
          RETURN
        END IF
      END IF
C * ABSORPTION CORRECTION QUALIFIERS/OPTIONS
      IF (IPR(220) > 1) THEN
        DO I = 2, IPR(220)
          IF (IFL(I)(1:5) == 'LIST')    IGBL(57) = 1
          IF (IFL(I)(1:7) == 'NOCHECK') IPR(363) = 0
        END DO
      END IF
      NRF      = 0
      I2       = 0
      PAR(301) = PAR(162)
      IPR(388) = 1
      IGBL(75) = 1
      IGBL(6)  = 16
C * TEST FOR DIRECTION COSINE OUTPUT ON .HKP REQUESTED
      IF (IPR(220) > 1) THEN
        IF (IFL(2)(1:4) == 'DIRC') IPR(445) = 1
      END IF
      IF (MODE == 4) PAR(321) = FN(1)
      IF (PAR(301) == 0.0 .OR.
     1   (MODE == -1 .AND. PAR(321) == 0.0)) THEN
        NAUTO = IGBL(25)
      ELSE
        NAUTO = 0
      END IF
C * CELL-CALCULATION
      CALL PLA100
C * DEFAULT XTAL-PLOT ORIENTATION MATRIX (COPY)
      CALL GEN052 (OR, OP(1, 1, 11))
C * OUTPUT PROGRAM HEADER AND CELL DATA
      CALL PLA042 (0)
      IF (MODE == -1 .AND. PAR(321) > 0.0) GO TO 60
C * ANALYSE CRYSTAL DESCRIPTION
   10 IF (NFACES > 0 .AND. MODE /= -1) THEN
        NRET = 0
        CALL PLA201 (NRET, NAUTO)
        IF (NRET == 1) GO TO 150
      END IF
   20 IF (NAUTO == 1) THEN
        INEXT   = 0
        IGBL(6) = 16
        IF (MODE /= -2) THEN
          ICRT  = 0
          ANGLE = 0
          NOCLS = 0
   30     CALL PLA198 (MODE, INEXT, NOCLS, 0)
          IF (ICRT > 0) THEN
            BCD = 'Click on Window to STOP Rotation'//CHAR (0)
            CALL GGIP (-999.0, 2.0, 33.0, 111)
            XG = 0.0
            YG = 0.0
            ZG = 0.0
            IG = 9
            CALL GGIP (XG, YG, ZG, IG)
            IF (IG > 0) THEN
              ICRT  = 0
              NOCLS = 0
            ELSE
              NOCLS = -1
              CALL PLA198 (MODE, INEXT, NOCLS, 0)
              NOCLS =  1
              CALL GEN051 (1, OP(1, 1, 11), ANGLE, ICRT)
              GO TO 30
            END IF
          END IF
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          CALL PLA006 (0, IS)
          SELECT CASE (IFL(1)(1:5))
C * SET MU
            CASE ('MU   ')
              PAR(301) = FN(1)
              IPR(441) = 0
C * SET MUR
            CASE ('MUR  ')
              PAR(321) = FN(1)
              IPR(443) = 0
              CALL PLA191 (1, PAR(321), YUNK)
C * ADD FACE
            CASE ('FACE ')
              IF (IPR(221) == 4) THEN
C * TEST FOR PRE-OCCURRENCE
                IF (NFACES > 0) THEN
                  DO 40 I = 1, NFACES
                    DO J = 1, 3
                      IF (ABS (PMILL(I, J) - FN(J)) > 0.001) GO TO 40
                    END DO
                    GO TO 50
   40             CONTINUE
                END IF
                NFACES = NFACES + 1
                I      = NFACES
   50           DO J = 1, 4
                  PMILL(I, J) = FN(J)
                END DO
                PMILL(I, 5) = FN(4)
                IPR(451) = 0
                GO TO 10
              END IF
C * DELETE FACES
            CASE ('DELF ')
              IF (IPR(221) == 3) THEN
                DO I = 1, NFACES
                  IF (PMILL(I, 1) == FN(1) .AND.
     1                PMILL(I, 2) == FN(2) .AND.
     2                PMILL(I, 3) == FN(3)) THEN
                    IF (I < NFACES) THEN
                      DO J = 1, 5
                        PMILL(I, J) = PMILL(NFACES, J)
                      END DO
                    END IF
                    NFACES = NFACES - 1
                    GO TO 10
                  END IF
                END DO
              END IF
C * SET GAUSS GRID
            CASE ('GRID ')
              IF (IPR(221) == 3) THEN
                IPR(421) = NINT (FN(1))
                IPR(422) = NINT (FN(2))
                IPR(423) = NINT (FN(3))
                IPR(444) = 0
              END IF
            CASE ('NEXT ', 'CALC ')
              IF (IPR(432) > 0) GO TO 140
              IF (PAR(301) == 0.0) THEN
                IF (MODE /= -1 .AND. MODE /= 4) THEN
                  CALL PLA015 (0, 46)
                  GO TO 30
                END IF
              END IF
              INEXT = INEXT + 1
              GO TO 60
            CASE ('XROT ')
              CALL GEN051 (1, OP(1, 1, 11), FN(1) / RGBL(6), 1)
            CASE ('YROT ')
              CALL GEN051 (1, OP(1, 1, 11), FN(1) / RGBL(6), 2)
            CASE ('ZROT ')
              CALL GEN051 (1, OP(1, 1, 11), FN(1) / RGBL(6), 3)
            CASE ('CROTX')
              ANGLE = FN(1) / RGBL(6)
              CALL GEN051 (1, OP(1, 1, 11), ANGLE, 1)
              ICRT = 1
            CASE ('CROTY')
              ANGLE = FN(1) / RGBL(6)
              CALL GEN051 (1, OP(1, 1, 11), ANGLE, 2)
              ICRT = 2
            CASE ('CROTZ')
              ANGLE = FN(1) / RGBL(6)
              CALL GEN051 (1, OP(1, 1, 11), ANGLE, 3)
              ICRT = 3
            CASE ('PLOT ')
              GO TO 30
            CASE ('END  ')
              GO TO 140
            CASE ('EXIT ')
              GO TO 140
          END SELECT
          GO TO 30
        END IF
      END IF
C * CHECK FOR INPUT ATOMS
   60 IF (IPR(39) > 0) THEN
C * LOAD ATOMS AND EXPAND (EXCLUDING BRAVAIS CENTERING)
        CALL PLA023 (0)
        NATO = IPR(589)
C * CALL EXIT/STOP
        IF (NATO < 0) CALL GEN127 ('PLA186')
      END IF
C * STORE REFLECTION FILE IN SCRAT
C * IHLP(1)     = NUMBER OF SUB-SETS SEPARATED BY BLANK LINES
C * IHLP(N) + 1 = STARTING ADDRESS (N - 1)TH DATASET
      IHLP(1) = 0
      IHLP(2) = 10000
      I1      = IHLP(2) + 1
      I2      = IHLP(2) + 11
      NREF    = 0
      WRITE (LU6, 99998, IOSTAT = IOST) NAMEFIL(1:KNMFIL)//'.hkl'
      IF (IGBL(37) == 0 .AND. IPR(78) /= -1) THEN
        IPR(2) = 37
        GO TO 140
      ELSE IF (IGBL(37) == 1) THEN
        IF (IPR(648) == 3) THEN
          WRITE (LU6, 99988, IOSTAT = IOST)
        ELSE
          WRITE (LU6, 99987, IOSTAT = IOST)
        END IF
        I2 = IHLP(2) + 11
      ELSE IF (IGBL(37) == 2) THEN
        WRITE (LU6, 99986, IOSTAT = IOST)
        I2 = IHLP(2) + 6
      END IF
      CALL GEN108 (LU16, 0)
C * CHECK DIRCOS
      CALL PLA199 (0)
      GO TO 80
   70 READ (LU16, 99985, IOSTAT = IOST) PRBUF
      IF (IOST == -1) GO TO 90
      IF (INDEX (PRBUF, '<?') /= 0) GO TO 90
      BACKSPACE LU16
   80 IF (IGBL(37) == 1 .OR. MODE == -1) THEN
        IF (IGBL(9) == 0) THEN
          READ (LU16, 99981, IOSTAT = IOST) (VOID(I), I = I1, I1 + 4),
     1        VOID(I1 + 13), (VOID(I), I = I1 + 5, I2)
          IF (IOST == -1) GO TO 90
        ELSE
C * HKLF4 NEEDED
          IPR(2) = 65
          GO TO 140
        END IF
      ELSE
        READ (LU16, 99980, IOSTAT = IOST) (VOID(I), I = I1, I2)
        IF (IOST == -1) GO TO 90
      END IF
      VOID(I1 + 11) = 1.0
      VOID(I1 + 12) = 0.0
      IF (NINT (VOID(I1 + 13)) == 0) VOID(I1 + 13) = 1.0
      IH = NINT (VOID(I1))
      IK = NINT (VOID(I1 + 1))
      IL = NINT (VOID(I1 + 2))
      IF (ABS (IH) + ABS (IK) + ABS (IL) > 0.1) THEN
        STH = SQRT (GEN095 (PAR(391), IH, IK, IL)) * PAR(17)
C * CHECK DIRECTION COSINES ON VALIDITY
        IF (IGBL(37) /= 2) THEN
          L = 3
          DO K = 1, 3
            L = L + 2
            V4(K) = PAR(134 + K) * VOID(I1 + L)
            V5(K) = PAR(134 + K) * VOID(I1 + L + 1)
          END DO
          TPRIM = GEN009 (VOID(I1), V4)
          TDIFF = GEN009 (VOID(I1), V5)
C * CHECK/CORRECT FOR OUT-OF-RANGE
          DUMMY = GEN006 (V4, RAA, V5) /
     1            SQRT (GEN006 (V4, RAA, V4) * GEN006 (V5, RAA, V5))
          IF (ABS (DUMMY) > 1.0) DUMMY = SIGN (1.0, DUMMY)
          IF (ABS (STH) > 0.99999999)
     1      WRITE (LU6, 99984, IOSTAT = IOST) IH, IK, IL, STH
          TH1 = 90.0 - ACOS (DUMMY) * RGBL(6) / 2.0
          TH2 = ASIN (STH) * RGBL(6)
          CALL PLA200 (TPRIM, TDIFF, TH1, TH2)
        ELSE
C * TRANSFORM PSI-VALUES TO DIRECTION COSINES
          CALL GEN106 (VOID(I1), STH, VOID(I1 + 5) / RGBL(6),
     1                 RAA, RBB, V6, V8, PAR(135))
          L = 3
          DO K = 1, 3
            L                = L + 2
            VOID(I1 + L)     = V6(K)
            VOID(I1 + L + 1) = V8(K)
          END DO
        END IF
        NREF = NREF + 1
        IF (MODE == -1) THEN
          CALL PLA191 (0, STH, ASTAR)
          VOID(I2 + 1) = ASTAR
        END IF
        IF (IPR(39) > 0) THEN
          ACAL = 0
          BCAL = 0
          CALL PLA137 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA,
     1      ACALAF, BCALAF,  DUM)
C * ADD ANOMALOUS (F' & F") CONTRIBUTION
          ACAL = ACAL + ACALA
          BCAL = BCAL + BCALA
          VOID(I2 + 2) = ACAL**2 + BCAL**2
        END IF
        I1 = I1 + 14
        IF (IGBL(37) == 1 .OR. MODE == -1) THEN
          I2 = I1 + 10
        ELSE
          I2 = I1 + 5
        END IF
      ELSE
        IF (VOID(I1 - 1) > -1000.0) THEN
          VOID(I1)          = - 1000.0
          IHLP(1)           = IHLP(1) + 1
          IHLP(IHLP(1) + 2) = I1
          I1                = I1 + 1
          I2                = I1 + 10
        END IF
      END IF
      GO TO 70
   90 IF (NREF == 0) THEN
        IPR(2) = 39
        GO TO 140
      END IF
      IPR(383) = NREF
C * CHECK DIRCOS
      IF (IGBL(37) == 1) CALL PLA199 (-1)
      IF (VOID(I1 - 1) > -1000.0) THEN
        VOID(I1) = - 1000.0
        IHLP(1)  = IHLP(1) + 1
      END IF
C * PSI-SCAN/XTAL
      IF (MODE == 1) THEN
        CALL PLA193 (IHLP(1) + 1)
        CALL PLA189
        IF (NPSI <= 0) THEN
          IPR(2) = 38
        ELSE
          CALL PLA188 (MODE, 1, NPSI)
        END IF
        IF (NAUTO == 1) GO TO 20
        GO TO 140
C * ABSGAUSS
      ELSE IF (MODE == 2) THEN
        IF (IGBL(25) == 0 .AND. PAR(301) == 0.0) THEN
          IPR(2) = 35
          GO TO 140
        END IF
        CALL PLA192 (2)
C * ABSTOMPA
      ELSE IF (MODE == 3) THEN
        IF (IGBL(25) == 0 .AND. PAR(301) == 0.0) THEN
          IPR(2) = 35
          GO TO 140
        END IF
        CALL PLA193 (2)
C * ABSPSI
      ELSE IF (MODE == 4) THEN
        IF (IHLP(1) <= 1) THEN
          IPR(2) = 38
          GO TO 140
        END IF
        CALL PLA191 (1, PAR(321), YUNK)
C * CALCULATE PSISCAN CURVES
        CALL PLA189
        IF (NPSI <= 0) THEN
          IPR(2) = 38
          GO TO 130
        END IF
C * CORRECT REFLECTION DATA
        CALL PLA262 (0)
        WRITE (LU7, 99997, IOSTAT = IOST) NPSI
        ILP  = 1
        I1   = IHLP(2) - 13
  100   I1   = I1 + 14
        IH   = NINT (VOID(I1))
        IK   = NINT (VOID(I1 + 1))
        IL   = NINT (VOID(I1 + 2))
        XINT = VOID(I1 + 3)
        SINT = VOID(I1 + 4)
        IF (IH < - 999) THEN
          ILP = ILP + 1
          IF (ILP > IHLP(1)) THEN
            GO TO 110
          ELSE
            I1 = I1 - 13
            GO TO 100
          END IF
        END IF
        THETA = ASIN (GEN056 (IH, IK, IL, RBB) * PAR(17))
        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)
        TT    = 0.0
        DO K = 1, NPSI
          CALL GEN002 (2, OP(1, 1, K), V2, V4, XLNG)
          CALL GEN002 (2, OP(1, 1, K), V3, V5, XLNG)
          IF (V4(3) < 0.99999) THEN
            PHI1 = MOD (ATAN2 (V4(2), V4(1)) * RGBL(6) + 360.0, 360.0)
          ELSE
            PHI1 = 0.0
          END IF
          IPH1 = INT (PHI1 / 10.0)
          IF (V5(3) < 0.99999) THEN
            PHI2 = MOD (ATAN2 (V5(2), V5(1)) * RGBL(6) + 360.0, 360.0)
          ELSE
            PHI2 = 0.0
          END IF
          IPH2 = INT (PHI2 / 10.0)
          DBUF(K) = (PSIS(IPH1 + 1, 2, K) + PSIS(IPH1 + 2, 2, K) +
     1               PSIS(IPH2 + 1, 2, K) + PSIS(IPH2 + 2, 2, K)) / 4
          TT      = TT + DBUF(K)
        END DO
        TT = TT / NPSI
        CALL PLA191 (0, THETA, ABSCOR)
        VOID(I1 + 11) = TT * ABSCOR
        WRITE (LU7, 99996, IOSTAT = IOST)
     1   IH, IK, IL, XINT, SINT, TT, XINT / TT, (DBUF(J), J = 1, NPSI)
        GO TO 100
  110   CALL PLA189
        CALL PLA188 (MODE, 1, NPSI)
      END IF
C * FIND OUTPUT SCALE AND STATISTICS
      FMAX = 0.0
      SUMT = 0.0
      TMAX = 0.0
      TMIN = 1.0
      ITEL = 0
      I    = IHLP(2) - 13
  120 I    = I + 14
      ITEL = ITEL + 1
      IH   = NINT (VOID(I))
      IF (IH /= -1000) THEN
        TT   = VOID(I + 11)
        FMAX = MAX (FMAX, VOID(I + 3) / TT)
        SUMT = SUMT + TT
C * KEEP TRACK OF THE MAXIMUM (TMAX) AND MINIMUM (TMIN) TRANSMISSION
        IF (TT > TMAX) THEN
          TMAX = TT
          DO J = 1, 3
            IHMAX(J) = NINT (VOID(I + J - 1))
          END DO
        END IF
        IF (TT < TMIN) THEN
          TMIN = TT
          DO J = 1, 3
            IHMIN(J) = NINT (VOID(I + J - 1))
          END DO
        END IF
        GO TO 120
      END IF
      FSCAL = 1.0
      DO WHILE (FMAX * FSCAL > 99998.0)
        FSCAL = FSCAL * 0.1
      END DO
      WRITE (LU6, 99979, IOSTAT = IOST) FSCAL
      WRITE (LU7, 99979, IOSTAT = IOST) FSCAL
C * GENERATE OUTPUT FILE
      CALL GEN108 (LU17, 0)
      I  = IHLP(2) - 13
  130 I  = I + 14
      IH = NINT (VOID(I))
      IF (IH /= -1000) THEN
        NRF  = NRF + 1
        IK   = NINT (VOID(I + 1))
        IL   = NINT (VOID(I + 2))
        DUM  = VOID(I + 11)
C * HKLF3 CASE
        IF (IPR(648) == 3) THEN
          DUM = SQRT (DUM)
          RELI = FSCAL * VOID(I + 3) / DUM
          SIGI = FSCAL * VOID(I + 4) / SQRT (DUM)
C * HKLF4 CASE
        ELSE IF (IPR(648) == 4) THEN
          RELI = FSCAL * VOID(I + 3) / DUM
          SIGI = FSCAL * VOID(I + 4) / DUM
        END IF
C * FIT INTO 2F8.x FORMAT
        IF (RELI <= 99999.0) THEN
          LINE = '(3I4,2F8.2,I4,6F8.5)'
        ELSE IF (RELI <= 999999.0) THEN
          LINE = '(3I4,2F8.1,I4,6F8.5)'
        ELSE
          LINE = '(3I4,2F8.0,I4,6F8.5)'
        END IF
        IF (MODE == 5 .OR. IPR(445) == 1) THEN
          WRITE (LU17, LINE(1:20), IOSTAT = IOST)
     1     IH, IK, IL, RELI, SIGI, NINT (VOID(I + 13)),
     2     (VOID(I + K), K = 5, 10)
        ELSE
          WRITE (LU17, LINE(1:20), IOSTAT = IOST)
     1      IH, IK, IL, RELI, SIGI, NINT (VOID(I + 13))
        END IF
        GO TO 130
      END IF
      WRITE (LU17, 99983, IOSTAT = IOST)
C * OUTPUT STATISTICS
      IF (NRF > 0) THEN
        REANAS = SUMT / FLOAT (NRF)
        IF (MODE == 4) THEN
          WRITE (LU6, 99982, IOSTAT = IOST) NPSI
          WRITE (LU7, 99982, IOSTAT = IOST) NPSI
        END IF
        PAR(315) = TMIN
        PAR(317) = TMAX
        IPR(432) = NRF
        WRITE (LU6, 99999, IOSTAT = IOST)
     1    IPR(383), IPR(432), TMIN, IHMIN, TMAX, IHMAX, REANAS
        WRITE (LU7, 99999, IOSTAT = IOST)
     1   IPR(383), IPR(432), TMIN, IHMIN, TMAX,  IHMAX, REANAS
      END IF
      IF (NAUTO == 1) GO TO 20
  140 IPR(432) = NRF
  150 IF (IPR(2) == 0) THEN
        SELECT CASE (IPR(78))
          CASE (-1)
            IPR(2) = -5
          CASE (1)
            IPR(2) = -1
          CASE (2)
            IPR(2) = -8
          CASE (3)
            IPR(2) = -7
          CASE (4)
            IPR(2) = -6
        END SELECT
      END IF
      RETURN
99999 FORMAT ('::', I8, ' Reflections on Input', /,
     1 '::', I8, ' Reflections Processed', //,
     2 ':: MIN  Transmission =', F9.5, ' for the ', 2(I3, ','), I3, /,
     3 ':: MAX  Transmission =', F9.5, ' for the ', 2(I3, ','), I3, /,
     4 ':: MEAN Transmission =', F9.5)
99998 FORMAT (/, ':: Reflection Data are Expected/READ on/from File: ',
     1         A)
99997 FORMAT ('Absorption correction based on', I3, ' Psi-Scan(s)',
     1 ' following:', /,
     2 ' North, A.C.T, Phillips, D.C. & Scott Mathews, F., (1968)',
     3 ' Acta Cryst. A24, 351-359', //,
     4 '   H   K   L      INT       SIG     T   INT(COR)  T(s)',
     1 /, 80('='))
99996 FORMAT (3I4, 2F10.0, F6.3, F10.0, 10F6.3)
99988 FORMAT (/, ':: H K L F SIG(F) Direction Cosine Data Assumed', /)
99987 FORMAT (/, ':: H K L I SIG(I) Direction Cosine Data Assumed', /)
99986 FORMAT ('N: H K L I SIG(I) Psi-Data Assumed', /)
99985 FORMAT (A)
99984 FORMAT ('|SIN(THETA)| > 1.0 ?', 3I5, F10.5, /)
99983 FORMAT (1X)
99982 FORMAT (/, ':: Correction Based on', I3, ' Psi-scans', /)
99981 FORMAT (3F4.0, 2F8.0, F4.0, 6F8.0)
99980 FORMAT (3F4.0, 2F8.0, F9.0)
99979 FORMAT (':: Multiplicative Output Scaling Factor:', F10.4, /)
      END SUBROUTINE PLA186
 
 
      SUBROUTINE PLA187 (MODE, SCL, NR, NOCLS)
C * XTAL
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE crystal
      USE abspsi
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: I0
      INTEGER          :: J0
      INTEGER          :: MC
      INTEGER          :: NR
      INTEGER          :: NV
      INTEGER          :: IVIS
      INTEGER          :: MODE
      INTEGER          :: NSTEP
      INTEGER          :: NOCLS
      REAL             :: XB
      REAL             :: XE
      REAL             :: XG
      REAL             :: YB
      REAL             :: YE
      REAL             :: DX
      REAL             :: DY
      REAL             :: SCL
      REAL             :: DIS
      REAL             :: DET
      REAL             :: SHT
      REAL             :: DIST
      REAL             :: DELX
      REAL             :: DELY
      REAL             :: SCAL
      REAL             :: VERT
      REAL             :: STEPX
      REAL             :: STEPY
      REAL             :: ANGLE
      REAL             :: COLOR
      REAL             :: GEN009
      CHARACTER(len=6) :: NRV
      VERT = 25.0
      IDM  = '  H  K  L  DIST(mm)'
      CALL PLA439 (0.0, IDM, 19, 0.5, 5, 2, VERT + 0.1, VERT - 3.0)
      DO I = 1, NFACES
        WRITE (IDM, 99999, IOSTAT = IOST)
     1   (NINT (PMILL(I, J)), J = 1, 3), PMILL(I, 5)
        CALL PLA439 (0.0, IDM, 18, 0.5, -1, 2, VERT + 0.1,
     1       VERT - 3.5 - I * 0.8)
      END DO
C * MOVE ORIGIN
      CALL GGIP (13.0, 12.0, 0.0, -3)
C * CHECK FOR FINITENESS OF CRYSTAL WITH EULERS RULE
      IF (NVER > NXT2) THEN
        CALL PLA439 (0.0, 'Too Many Vertices ', 18, 0.75,
     1                         2, 2, 1.0, -6.5)
        GO TO 20
      ELSE IF (NFACES + NVRR - 2 /= NEDGE) THEN
        WRITE (PRBUF, 99994, IOSTAT = IOST)
        WRITE (LU6,   99998, IOSTAT = IOST) PRBUF
        WRITE (LU7,   99998, IOSTAT = IOST) PRBUF
        CALL PLA439 (0.0, PRBUF, 18, 0.75, 2, 2, 1.0, -8.0)
        GO TO 20
      END IF
C * RAA - DIRECT CELL METRIC (REFLECTION CELL)
C * GENERATE CRYSTAL PLOT DATA
C * COPY MATRIX
      CALL GEN052 (OP(1, 1, NR), 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 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
      END DO
      IF (NVER > 0) THEN
        CALL GEN074 (V2, 1, 3, 0.0)
        DO 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)
        END DO
        V2(1) = V2(1) / NVER
        V2(2) = V2(2) / NVER
        V2(3) = V2(3) / NVER
        DO 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)
        END DO
        DIS = 0.0
        DO I = 1, NVER
          DIS = MAX (DIS, SQRT (GEN009 (XYZPL(1, I), XYZPL(1, I))))
        END DO
        SCAL = PAR(325) * SCL / DIS
        DO I = 1, NFACES
          ANGLE = 0
          DO J = 1, 3
            ANGLE       = ANGLE + PAT(J, 3) * PMILL(I, J)
            CFACE(J, I) = 0.0
          END DO
          CFACE(4, I) = 0
          CFACE(5, I) = ANGLE
          DO K = 1, NVER
            DO J = 4, 6
              N = IABS (NINT (XTLV(J, K)))
              IF (N == I) THEN
                IF (ANGLE < 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
              END IF
            END DO
          END DO
        END DO
        IF (NOCLS >= 0) THEN
          COLOR = 1.0
        ELSE
          COLOR = 0.0
        END IF
        CALL GGIP (0.0, COLOR, 0.0, 0)
        DO I = 1, NVER
          DO K = 1, 3
            XYZPL(K, I) = SCAL * XYZPL(K, I)
          END DO
          IF (IGBL(75) == 1) THEN
            IF (NVER < 100) THEN
              NV = 2
              WRITE (NRV, 99997, IOSTAT = IOST) NINT (XTLV(7, I))
            ELSE
              NV = 3
              WRITE (NRV, 99996, IOSTAT = IOST) NINT (XTLV(7, I))
            END IF
            CALL PLA439 (0.0, NRV, NV, 0.3, -1, 2,
     1                   XYZPL(1, I), XYZPL(2, I))
          END IF
        END DO
        DO I = 1, NFACES
          DO K = 1, 3
            CFACE(K, I) = SCAL * (CFACE(K, I) / CFACE(4, I))
          END DO
          IF (IGBL(75) == 1) THEN
            IF (CFACE(5, I) > 0.0) THEN
              COLOR = 1.0
              SHT = 0.15
            ELSE
              COLOR = 4.0
              SHT = -0.15
            END IF
            IF (NOCLS < 0) THEN
              COLOR = 0.0
            END IF
            CALL GGIP (0.0, COLOR, 0.0, 0)
            WRITE (NRV, 99995, IOSTAT = IOST)
     1        (NINT (PMILL(I, K)), K = 1, 3)
            CALL PLA439 (0.0, NRV, 6, 0.25, -1, 2,
     1                   CFACE(1, I) - 0.5, CFACE(2, I) + SHT)
          END IF
        END DO
      END IF
      DO 10 I0 = 1, NEDGE
        I  = IDG(I0, 3)
        J0 = IDG(I0, 4)
        MC   = 0
        IVIS = 0
        IF (NOCLS < 0) THEN
          COLOR = 0.0
        ELSE
          COLOR = 1.0
        END IF
        CALL GGIP (0.0, COLOR, 0.0, 0)
        DO K = 1, 3
          DO L = 1, 3
            IF (ABS (XTLV(K + 3, I)) == ABS (XTLV(L + 3, J0))) THEN
              MC = MC + 1
              IF (XTLV(K + 3, I) > 0.0) IVIS = IVIS + 1
              IF (MC == 2) THEN
                IF (IVIS < 1) THEN
C * DRAW OBSCURED EDGE - DASHED
                  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 > 0) THEN
                    STEPX = (XYZPL(1, J0) - XB) / NSTEP
                    STEPY = (XYZPL(2, J0) - YB) / NSTEP
                    DO M = 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
                    END DO
                  END IF
C * DRAW UNOBSCURED EDGE
                ELSE
                  IF (NOCLS < 0) THEN
                    COLOR = 0.0
                  ELSE
                    COLOR = 1.0
                  END IF
                  CALL GGIP (0.0, COLOR, 0.0, 0)
                  DELX = XYZPL(1, J0) - XYZPL(1, I)
                  DELY = XYZPL(2, J0) - XYZPL(2, I)
                  IF (DELX == 0) THEN
                    DX = 0.025
                    DY = 0.0
                  ELSE IF (DELY == 0) THEN
                    DX = 0.0
                    DY = 0.025
                  ELSE
                    DY = - (DELX / DELY)
                    DX = SQRT (0.000625 / (1 + DY**2))
                    DY = DX * DY
                  END IF
                  XB = XYZPL(1, I)  - DX
                  YB = XYZPL(2, I)  - DY
                  XE = XYZPL(1, J0) - DX
                  YE = XYZPL(2, J0) - DY
                  DO M = 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
                  END DO
                END IF
                GO TO 10
              END IF
            END IF
          END DO
        END DO
   10 CONTINUE
C * AXIAL SYSTEM
      IF (IPR(388) == 1) THEN
        IF (NOCLS < 0) THEN
          COLOR = 0.0
        ELSE
          COLOR = 2.0
        END IF
        CALL GGIP (0.0, COLOR, 0.0, 0)
        CALL GGIP (0.0,   0.0,   0.0, 3)
        CALL GGIP (V3(1), V3(2), 0.0, 2)
        CALL PLA439 (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 PLA439 (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 PLA439 (0.0, 'c', 1, 0.35,  -1, 2, V5(1) + 0.2, V5(2))
      END IF
C * MOVE ORIGIN
   20 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
 
      SUBROUTINE PLA188 (MODE, JB, JE)
C * CRYSTAL & PSI-SCAN PLOTS
      USE parameters
      USE atomdata
      USE cchar
      USE abspsi
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: L
      INTEGER                        :: M
      INTEGER                        :: JB
      INTEGER                        :: JE
      INTEGER                        :: IS
      INTEGER                        :: JJ
      INTEGER                        :: IPX
      INTEGER                        :: MODE
      INTEGER                        :: IPERC
      REAL                           :: DS
      REAL                           :: DX
      REAL                           :: DY
      REAL                           :: XP
      REAL                           :: YP
      REAL                           :: XPL
      REAL                           :: YPL
      REAL                           :: XP0
      REAL                           :: YP0
      REAL                           :: PSI
      REAL                           :: PSS
      REAL                           :: TEMP1
      CHARACTER(len=3), DIMENSION(3) :: TXT
      TXT(1) = 'Obs'
      TXT(2) = 'Cal'
      TXT(3) = 'Cor'
C * LOOP OVER REQUESTED PSI-SCAN RANGE
      DO J = JB, JE
C * PLOT-PSI ROUTINE
   10   CALL PLA198 (MODE, 1, 0, 0)
C * GENERATE CRYSTAL PLOT DATA
C * MOVE ORIGIN
        CALL GGIP (13.0, 12.0, 0.0, -3)
        CALL PLA439 (0.0, 'Psi-Scan', 8,  0.6, 1, 2, 15.3, -11.5)
        CALL PLA439 (0.0, '0',        1, 0.25, 1, 2, 12.0,  -0.1)
        CALL PLA439 (0.0, '270',      3, 0.25, 1, 2, -0.2, -11.3)
        CALL PLA439 (0.0, '180',      3, 0.25, 1, 2,-12.1,   0.3)
        CALL PLA439 (0.0, '90',       2, 0.25, 1, 2, -0.2,  11.4)
        DO K = 1, 4
C * SET COLOR
          CALL GGIP (0.0, FLOAT (K), 0.0, 0)
          IF (K > 1) THEN
            TEMP1 = 9999999.0
            DO I = 1, 36
              IF (PSIS(I, K, J) >= 0.01)
     1          TEMP1 = MIN (TEMP1, PSIS(I, K, J))
            END DO
            IPERC = NINT (TEMP1 * 100.0)
            IPX = 0
            YPL = 10.5 + 1.5 - K * 0.75
            CALL PLA439 (0.0, TXT(K - 1), 3, 0.5, -1, 2, 8.4, YPL)
            CALL GEN040 (IPERC, NQ1, IPX)
            CALL PLA439 (0.0, NQ1, IPX, 0.5, -1, 2, 11.0, YPL)
          END IF
          DO I = 1, 36
            PSI = PSIS(I, 1, J) / RGBL(6)
            XPL = COS (PSI)
            YPL = SIN (PSI)
            XP  = 6.0
            YP  = 6.0
            DS  = 0.1 * (K - 1)
            IF (K > 1) THEN
              PSS = PSIS(I, K, J)
              IF (PSS < 0.0) PSS = 0.0
              XP = PSS * XP
              YP = PSS * YP
            END IF
            XPL = XPL * (XP + 5.0)
            YPL = YPL * (YP + 5.0)
            IF (K > 1) THEN
              IF (I == 1) THEN
                XP0 = XPL
                YP0 = YPL
                GO TO 20
              END IF
              CALL GGIP (XPL, YPL, 0.0, 2)
            END IF
   20       YPL = YPL - DS
            CALL GGIP (XPL, YPL, 0.0, 3)
            IF (K <= 1) THEN
              XPL = XPL * (5.0 / 11.5)
              YPL = YPL * (5.0 / 11.5)
              CALL GGIP (XPL, YPL, 0.0, 2)
              CYCLE
            END IF
            DO L = 1, 3, 2
              DY = DS * (2 - L)
              DO M = 1, 3, 2
                DX  = DS * (2 - M) * (2 - L)
                XPL = XPL + DX
                YPL = YPL + DY
                CALL GGIP (XPL, YPL, 0.0, 2)
              END DO
            END DO
            YPL = YPL + DS
            CALL GGIP (XPL, YPL, 0.0, 3)
          END DO
          IF (K /= 1) THEN
            CALL GGIP (XP0, YP0, 0.0, 2)
            CALL GGIP (0.0, 0.0, 0.0, 3)
          END IF
        END DO
C * SET COLOR
        CALL GGIP (0.0, 1.0, 0.0, 0)
        DO JJ = 1, 3
          XPL = 5 + JJ * 2
          CALL GEN040 (IHKLPS(JJ, J), NQ1, IPX)
          CALL PLA439 (0.0, NQ1, IPX, 0.5, -1, 2, XPL, -11.5)
        END DO
        CALL GGIP (0.0, 0.0, 0.0, 3)
C * ENDPLT
        CALL GGIP (0.0, 0.0,   0.0, -1)
C * WHAT NEXT ?
        CALL PLA012 (0, 1)
        CALL PLA006 (0, IS)
        SELECT CASE (IFL(1)(1:4))
          CASE ('PLOT')
            GOTO 10
          CASE ('EXIT')
            GO TO 30
        END SELECT
      END DO
   30 RETURN
      END SUBROUTINE PLA188
 
      SUBROUTINE PLA189
C * PSI SCAN HANDLING
      USE files
      USE parameters
      USE plato
      USE crystal
      USE abspsi
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: KAS
      INTEGER :: IHO
      INTEGER :: IKO
      INTEGER :: ILO
      INTEGER :: MPSI
      INTEGER :: ICHANGE
      REAL    :: T1
      REAL    :: T2
      REAl    :: T3
      REAl    :: T4
      REAL    :: PH1
      REAL    :: PH2
      REAL    :: PHI
      REAL    :: XLNG
      REAL    :: YUNK
      REAL    :: PMAX2
      REAL    :: PMAX3
      REAL    :: PMAX4
      REAL    :: PSISJ
      REAL    :: PSISL
      REAL    :: YUNKM
      REAL    :: GEN009
C * ANALYSE PSI-SCAN DATA
C * DUNITZ p 237: OR = Tr(beta), ROR = Tr(alpha)
C * A-AXIS etc. VERTICAL i.e. (OR(1, 1), OR(2, 1), OR(3, 1)
      IHO  = 0
      IKO  = 0
      ILO  = 0
      NPSI = 0
      MPSI = 0
      KAS  = 0
      N    = IHLP(IHLP(1) + 1) - 13
      DO
        N     = N + 14
C * GET HKL & DIRECTION COSINES (REFERRED TO DIRECT CELL AXES)
        V6(1) = VOID(N)
        V6(2) = VOID(N + 1)
        V6(3) = VOID(N + 2)
        V2(1) = VOID(N + 5)  * PAR(135)
        V3(1) = VOID(N + 6)  * PAR(135)
        V2(2) = VOID(N + 7)  * PAR(136)
        V3(2) = VOID(N + 8)  * PAR(136)
        V2(3) = VOID(N + 9)  * PAR(137)
        V3(3) = VOID(N + 10) * PAR(137)
        IH = NINT (V6(1))
        IK = NINT (V6(2))
        IL = NINT (V6(3))
C * END-TEST
        IF (IH < - 999.0) EXIT
C * TRANSFORM HKL TO ORTHONORMAL COORDINATES
        CALL GEN002 (-2, ROR, V6, V8, XLNG)
C * IS THIS A NEW PSI-SCAN ?
        IF (IH /= IHO .OR. IK /= IKO .OR. IL /= ILO) THEN
          IF (NPSI > 0) THEN
            IF (IHKLPS(4, NPSI) < 37) THEN
              WRITE (LU6, 99999, IOSTAT = IOST) IHO, IKO, ILO
              NPSI = NPSI - 1
              IF (IHKLPS(4, NPSI + 1) == 2) RETURN
            END IF
          END IF
          IHO  = IH
          IKO  = IK
          ILO  = IL
          MPSI = 1
C * AVOID OVERFLOW OF NUMBER OF PSI-SCANS
          IF (NPSI == 10) THEN
            WRITE (LU6, 99998, IOSTAT = IOST)
            EXIT
          END IF
          NPSI            = NPSI + 1
          IHKLPS(1, NPSI) = IH
          IHKLPS(2, NPSI) = IK
          IHKLPS(3, NPSI) = IL
C * HKL- VERTICAL
          DO J = 1, 3
            QM(J, 3) = V8(J)
            QM(J, 2) = 0.0
          END DO
C * CALCULATE ANGLES OF H WITH A,B & C
          YUNKM = 2.0
          IF (NPSI == 1) THEN
            DO J = 1, 3
              YUNK = GEN009(OR(1, J), V8) /
     1               SQRT (GEN009(OR(1, J), OR(1, J)))
              IF (ABS(YUNK) < YUNKM) THEN
                YUNKM = ABS (YUNK)
                KAS = J
              END IF
            END DO
          END IF
          QM(KAS, 2) = 1.0
C * A(B OR C)-AXIS IN YZ-PLANE
C * X PERP TO H & A(B OR C)
          CALL GEN008 (QM(1, 2), QM(1, 3), QM(1, 1), 1)
C * Y PERPENDICULAR TO XZ
          CALL GEN008 (QM(1, 3), QM(1, 1), QM(1, 2), 1)
C * TRANSPOSE
          CALL GEN005 (QM, DUMV)
C * TRANSFORM AND SAVE ORTHOGONALIZATION MATRIX
          CALL GEN004 (DUMV, OR, OP(1, 1, NPSI))
        END IF
        CALL GEN002 (2, OP(1, 1, NPSI), V2, V4, XLNG)
        CALL GEN002 (2, OP(1, 1, NPSI), V3, V5, XLNG)
        IF (V5(3) < 0.99999) THEN
          PHI = ATAN2(V5(2), V5(1)) * RGBL(6)
        ELSE
          PHI = 0.0
        END IF
        MPSI                = MPSI + 1
        PSIS(MPSI, 1, NPSI) = MOD (360.0 + PHI, 360.0)
        PSIS(MPSI, 2, NPSI) = VOID(N + 3)
        PSIS(MPSI, 3, NPSI) = VOID(N + 11)
        IHKLPS(4, NPSI)     = MPSI
      END DO
      IF (NPSI > 0) THEN
        DO K = 1, NPSI
          MPSI = IHKLPS(4, K)
C * BUBBLE SORT ON PHI
   10     ICHANGE = 0
          DO J = 2, MPSI - 1
            IF (PSIS(J, 1, K) > PSIS(J + 1, 1, K)) THEN
              DO I = 1, 3
                CALL GEN018 (PSIS(J, I, K), PSIS(J + 1, I, K))
              END DO
              ICHANGE = 1
            END IF
          END DO
          IF (ICHANGE /= 0) GO TO 10
          L = 2
          PSISL = PSIS(L, 1, K)
          DO J = 3, MPSI
            PSISJ = PSIS(J, 1, K)
            IF (ABS (PSISJ - PSISL) > 0.05) THEN
              L = L + 1
              DO I = 1, 3
                PSIS(L, I, K) = PSIS(J, I, K)
              END DO
              PSISL = PSIS(L, 1, K)
            END IF
          END DO
          IHKLPS(4, NPSI) = L
          PSIS(1, 1, K)   = PSIS(37, 1, K) - 360.0
          PSIS(1, 2, K)   = PSIS(37, 2, K)
          PSIS(1, 3, K)   = PSIS(37, 3, K)
C * INTERPOLATE TO 0, 10, 20 ETC.
          DO I = 1, 36
            PHI = (I - 1) * 10.0
            PH1 = 2 - I + PSIS(I, 1, K) / 10.0
            PH2 = I     - PSIS(I + 1, 1, K) / 10.0
            T1  = PSIS(I,     2, K)
            T2  = PSIS(I + 1, 2, K)
            T3  = PSIS(I,     3, K)
            T4  = PSIS(I + 1, 3, K)
            PSIS(I, 1, K) = PHI
            PSIS(I, 2, K) = (PH1 * T1 + PH2 * T2) / (PH1 + PH2)
            PSIS(I, 3, K) = (PH1 * T3 + PH2 * T4) / (PH1 + PH2)
            IF (PSIS(I, 3, K) > 0.0) THEN
              PSIS(I, 4, K) = PSIS(I, 2, K) / PSIS(I, 3, K)
            ELSE
              PSIS(I, 4, K) = 0.0
            END IF
          END DO
          PSIS(37, 1, K) = 360.0
          PSIS(37, 2, K) = PSIS(1, 2, K)
          PSIS(37, 3, K) = PSIS(1, 3, K)
          PSIS(37, 4, K) = PSIS(1, 4, K)
C * NORMALIZE CURVE TO 1.0
          PMAX2 = 0.0
          PMAX3 = 0.0
          PMAX4 = 0.0
          DO I = 1, MPSI
            PMAX2 = MAX (PMAX2, PSIS(I, 2, K))
            PMAX3 = MAX (PMAX3, PSIS(I, 3, K))
            PMAX4 = MAX (PMAX4, PSIS(I, 4, K))
          END DO
          DO I = 1, MPSI
            PSIS(I, 2, K) = PSIS(I, 2, K) / PMAX2
            PSIS(I, 3, K) = PSIS(I, 3, K) / PMAX3
            PSIS(I, 4, K) = PSIS(I, 4, K) / PMAX4
          END DO
        END DO
      END IF
      RETURN
99999 FORMAT ('E: PSI-SCAN FOR', 3I4,
     1 ' SKIPPED (CONTAINS NOT EXACTLY 36*10 DEG. STEPS)')
99998 FORMAT ('E: TOO MANY PSI-SCANS - (ADDITIONAL ONES IGNORED)')
      END SUBROUTINE PLA189
 
      SUBROUTINE PLA190
C * MULABS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER  :: NMX  = 1000
      INTEGER, PARAMETER  :: NMAX = 50000000
      INTEGER                             :: I
      INTEGER                             :: J
      INTEGER                             :: K
      INTEGER                             :: L
      INTEGER                             :: M
      INTEGER                             :: N
      INTEGER                             :: I0
      INTEGER                             :: IH
      INTEGER                             :: IK
      INTEGER                             :: IL
      INTEGER                             :: II
      INTEGER                             :: JH
      INTEGER                             :: JK
      INTEGER                             :: JL
      INTEGER                             :: IS
      INTEGER                             :: NK
      INTEGER                             :: NL
      INTEGER                             :: NS
      INTEGER                             :: NKL
      INTEGER                             :: III
      INTEGER                             :: N01
      INTEGER                             :: N02
      INTEGER                             :: N03
      INTEGER                             :: IH0
      INTEGER                             :: IK0
      INTEGER                             :: IL0
      INTEGER                             :: IHM
      INTEGER                             :: IKM
      INTEGER                             :: ILM
      INTEGER                             :: NRZ
      INTEGER                             :: NSM
      INTEGER                             :: IHKL
      INTEGER                             :: IREC
      INTEGER                             :: LMAX
      INTEGER                             :: LURA
      INTEGER                             :: LURB
      INTEGER                             :: NINP
      INTEGER                             :: NOUT
      INTEGER                             :: NPAR
      INTEGER                             :: NRSM
      INTEGER                             :: NZERO
      INTEGER                             :: NSYMH
      INTEGER                             :: NSIZE
      INTEGER                             :: NMEAS
      INTEGER                             :: NAUTO
      INTEGER                             :: NDATA
      INTEGER                             :: N3REJ
      INTEGER                             :: N6REJ
      INTEGER                             :: N7REJ
      INTEGER                             :: IHKLM
      INTEGER                             :: ICNTR
      INTEGER                             :: ITEST = 0
      INTEGER                             :: IPRINT
      INTEGER,          DIMENSION(NMX)    :: IHH
      INTEGER,          DIMENSION(NMX)    :: IKK
      INTEGER,          DIMENSION(NMX)    :: ILL
      REAL                                :: A
      REAL                                :: S
      REAL                                :: T
      REAL                                :: V
      REAL                                :: X
      REAL                                :: Y
      REAL                                :: Z1
      REAL                                :: ZA
      REAL                                :: ZY
      REAL                                :: WQ
      REAL                                :: A0
      REAL                                :: AI
      REAL                                :: DI
      REAL                                :: RA
      REAL                                :: YJ
      REAL                                :: YII
      REAL                                :: TH1
      REAL                                :: TH2
      REAL                                :: ALX
      REAL                                :: DET
      REAL                                :: SCF
      REAL                                :: STH
      REAL                                :: YLMJ
      REAL                                :: YLMK
      REAL                                :: SGYJ
      REAL                                :: SIGA
      REAL                                :: SIGY
      REAL                                :: AMAX
      REAL                                :: COSA
      REAL                                :: SINA
      REAL                                :: SMAX
      REAL                                :: SMIN
      REAL                                :: SUMA
      REAL                                :: SUMN
      REAL                                :: SUMV
      REAL                                :: SUMW
      REAL                                :: UMAX
      REAL                                :: YUNK
      REAL                                :: TPRIM
      REAL                                :: TDIFF
      REAL                                :: XIMAX
      REAL                                :: THETA
      REAL                                :: SMAX1
      REAL                                :: SMIN1
      REAL                                :: SINBS
      REAL                                :: SINGS
      REAL                                :: SIGYJ
      REAL                                :: RMSDA
      REAL                                :: DUMMY
      REAL                                :: COSBS
      REAL                                :: COSGS
      REAL                                :: DELTA
      REAL                                :: AMEAN
      REAL                                :: AIMAX
      REAL                                :: AIMIN
      REAL                                :: CHISQ
      REAL                                :: SUMSQ
      REAL                                :: SUMASQ
      REAL                                :: STLMAX
      REAL                                :: STLMIN
      REAL                                :: CHISQA
      REAL                                :: FSQMAX
      REAL                                :: FSQMIN
      REAL                                :: GEN006
      REAL                                :: GEN009
      REAL                                :: GEN056
      REAL                                :: GEN095
      REAL                                :: ASPHERE
      REAL                                :: YMEDIAN
      REAL,             DIMENSION(3)      :: S0
      REAL,             DIMENSION(3)      :: S1
      REAL,             DIMENSION(12)     :: FMUR
      REAL,             DIMENSION(12)     :: AMUR
      REAL,             DIMENSION(80)     :: SIGALM
      REAL,             DIMENSION(80)     :: ALM
      REAL,             DIMENSION(80)     :: YLM0
      REAL,             DIMENSION(80)     :: YLM1
      REAL,             DIMENSION(80)     :: QI
      REAL,             DIMENSION(80)     :: XI
      REAL,             DIMENSION(80, 80) :: CORR
      REAL,             DIMENSION(NMX)    :: YI
      REAL,             DIMENSION(NMX)    :: SIGYI
      REAL,             DIMENSION(3, NMX) :: U0
      REAL,             DIMENSION(3, NMX) :: U1
      REAL,             DIMENSION(NMX)    :: AII
      REAL,             DIMENSION(NMX)    :: SAA
      REAL,             DIMENSION(NMX)    :: WI
      DOUBLE PRECISION, DIMENSION(80, 80) :: AZ
      DOUBLE PRECISION, DIMENSION(80)     :: BZ
      DOUBLE PRECISION, DIMENSION(80)     :: UZ
      DOUBLE PRECISION, DIMENSION(80, 80) :: VZ
      DOUBLE PRECISION, DIMENSION(80, 80) :: VA
      DOUBLE PRECISION                    :: TYUNK
      CHARACTER(len=1)                    :: N0
      CHARACTER(len=1)                    :: N1
      CHARACTER(len=1)                    :: N2
      INTEGER, ALLOCATABLE, DIMENSION(:) :: INDEY
      REAL,    ALLOCATABLE, DIMENSION(:) :: DATAX
      ALLOCATE (DATAX(NMAX), INDEY(NMAX))
      FMUR = (/ 0.0, 0.5, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0,
     1 10.0/)
      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/)
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)
C * CHECK FOR RECORD LENGTH (I.E. WORD OR BYTE-COUNT)
      LURA  = 29
      LURB  = 30
      NSIZE = 1
      DO I = 1, 2
        NRZ = 14 * NSIZE
        OPEN (UNIT = LURA, STATUS = 'SCRATCH',
     1    FORM = 'UNFORMATTED', ACCESS = 'DIRECT', RECL = NRZ)
        WRITE (LURA, REC = 1, IOSTAT = IOST) (FN(II), II = 1, 14)
        IF (IOST > 0) GO TO 10
        GO TO 20
   10   NSIZE = 4
        CLOSE (UNIT = LURA, STATUS = 'DELETE')
      END DO
C * CALL EXIT/STOP
      CALL GEN127 ('CANNOT FIGURE OUT DIRECT ACCESS RECORD LENGTH')
   20 NRZ = 11 * NSIZE
          OPEN (UNIT = LURB, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1        ACCESS = 'DIRECT', RECL = NRZ)
      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) == 0.0) THEN
        IGBL(6) = 16
        NAUTO   = IGBL(25)
      ELSE
        NAUTO = 0
      END IF
      CALL PLA262 (-3)
      WRITE (LU7, 99999, IOSTAT = IOST)
C * LATTICE PARAMETERS
      IF (PAR(17) <= 0) THEN
        WRITE (LU6, 99974, IOSTAT = IOST)
        WRITE (LU7, 99974, IOSTAT = IOST)
        GO TO 180
      END IF
C * CALCULATE RECIPROCAL LATTICE PARAMETERS AND DIRECT AND RECIPROCAL
C * LATTICE METRIC TENSORS FROM DIRECT LATTICE PARAMETERS.
      SINA  = SIN (PAR(244) / RGBL(6))
      COSA  = COS (PAR(244) / RGBL(6))
      COSBS = COS (PAR(139) / RGBL(6))
      COSGS = COS (PAR(140) / RGBL(6))
      SINBS = SIN (PAR(139) / RGBL(6))
      SINGS = SIN (PAR(140) / RGBL(6))
C * CHECK FOR HKLF TRANSFORMATION
      DELTA = 0.0
      DO I = 1, 6
        DELTA = DELTA + ABS(PAR(100 + I) - PAR(240 + I))
      END DO
      IF (DELTA > 0.01) THEN
        CALL GEN112 (QQ, PAR(231), 1)
        CALL GEN003 (QQ, DUMV, DET, 0)
        CALL GEN112 (DUMV, SGY(1), -1)
        SGY(10)  = 0.0
        SGY(11)  = 0.0
        SGY(12)  = 0.0
        LINE = 'SPGR '//SPGRNM(1)(1:11)
        CALL SGSM (16, LINE, SGY, NRSM, LU6, IERR)
        CALL SGSM (2,  LINE, SGY, NSM, LU6, IERR)
        CALL SGSM (10, LINE, SGY,   0,   0, IERR)
        IPR(255) = NINT (SGY(4))
        IPR(257) = NINT (SGY(5))
      END IF
C * ABSORPTION CORRECTION VARIABLES
      FSQMIN = 1.0
      FSQMAX = 1E10
      STLMIN = 0.0
      STLMAX = 9.0
      SMIN1  = 0
      SMAX1  = 9
      IF (NAUTO == 1) THEN
        CALL PLA198 (6, 1, 0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      END IF
C * READ INPUT REFLECTION DATA FILE(S) AND FORM A FILE SORTED ON HKL.
C * LOOP TO READ IN REFLECTION DATA AND WRITE FILE FOR SORTING.
      N3REJ    = 0
      N6REJ    = 0
      N7REJ    = 0
      IPR(371) = 0
      IPR(372) = 0
C * CHECK DIRCOS
      CALL PLA199 (0)
      CALL GEN108 (LU16, 0)
      NINP = 0
      DO
        READ (LU16, 99998, IOSTAT = IOST) IH, IK, IL, Y, SIGY,
     1    (V1(K), V2(K), K = 1, 3)
        IF (IOST /= 0) EXIT
        IF (IH == 0 .AND. IK == 0 .AND. IL == 0) EXIT
        NINP  = NINP + 1
        V3(1) = IH
        V3(2) = IK
        V3(3) = IL
        STH = SQRT (GEN095 (PAR(391), IH, IK, IL)) * PAR(17)
C * CHECK DIRECTION COSINES ON VALIDITY
        DO K = 1, 3
          V4(K) = PAR(134 + K) * V1(K)
          V5(K) = PAR(134 + K) * V2(K)
        END DO
        TPRIM = GEN009 (V3, V4)
        TDIFF = GEN009 (V3, V5)
C * CHECK/CORRECT FOR OUT-OF-RANGE
        DUMMY = GEN006 (V4, RAA, V5) /
     1    SQRT (GEN006 (V4, RAA, V4) * GEN006 (V5, RAA, V5))
        IF (ABS (DUMMY) > 1.0) DUMMY = SIGN (1.0, DUMMY)
        IF (ABS (STH) > 0.99999999)
     1    WRITE (LU6, 99973, IOSTAT = IOST) IH, IK, IL, STH
        TH1    = ASIN (STH) * RGBL(6)
        TH2    = 90.0 - ACOS (DUMMY) * RGBL(6) / 2.0
C * CHECK FOR (BAD OR ABSENT) DIRECTION COSINES
        CALL PLA200 (TPRIM, TDIFF, TH1, TH2)
C * TRANSFORM SHELX-STYLE TO CARTESIAN STYLE DIRECTION COSINES
        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
C * CHECK S = SIN(THETA)/LAMBDA SHELL LIMITS.
        S = GEN056 (IH, IK, IL, RBB)
        IF (S < SMIN1 .OR. S > SMAX1) THEN
          N3REJ = N3REJ + 1
          CYCLE
        END IF
C * CHECK FOR POSITIVE ERROR ESTIMATE.
        IF (SIGY <= 0) THEN
          N6REJ = N6REJ + 1
          CYCLE
        END IF
C * CHECK FOR ABNORMALLY NEGATIVE DATA.
        IF (Y < -4 * SIGY) THEN
          N7REJ = N7REJ + 1
          CYCLE
        END IF
C * TABULATE INDEX AND SIN(THETA)/LAMBDA LIMITS FOR THE MEASUREMENTS.
        SMIN = MIN (SMIN, S)
        SMAX = MAX (SMAX, S)
C * TABULATE UNIQUE INDEX LIMITS.
        NSYMH = IPR(255)
        ICNTR = IPR(257)
        IHKLM = -99999
        DO I = 1, NSYMH
          SGY(1) = IH
          SGY(2) = IK
          SGY(3) = IL
          SGY(4) = 0.0
          NS     = I
          CALL SGSM (5, ICL, SGY, NS, 0, IERR)
          IH0  = NINT (SGY(7))
          IK0  = NINT (SGY(8))
          IL0  = NINT (SGY(9))
          IHKL = IL0 * 250000 + IK0 * 500 + IH0
          IF (IHKL < 0 .AND. ICNTR == 2) THEN
            IH0  = - IH0
            IK0  = - IK0
            IL0  = - IL0
            IHKL = - IHKL
          END IF
          IF (IABS(IHKL) > IHKLM) THEN
            IHKLM = IABS(IHKL)
            J     = IH0
            K     = IK0
            L     = IL0
          END IF
        END DO
        IHM = MAX (IHM, IABS (J))
        IKM = MAX (IKM, IABS (K))
        ILM = MAX (ILM, IABS (L))
C * WRITE DATA TO FILE TO BE SORTED.
        IF (IPR(372) < NMAX) IPR(372) = IPR(372) + 1
        IF (NAUTO == 1) THEN
          IF (MOD (IPR(372), 5000) == 0) CALL PLA198 (6, 1, 0, 1)
        END IF
        WRITE (LURA, REC = IPR(372))
     1       J, K, L, IH, IK, IL, Y, SIGY, S0, S1
      END DO
C * END LOOP TO READ REFLECTION DATA.
      WRITE (LU7, 99972, IOSTAT = IOST) IPR(371)
      IF (ITEST /= 0) THEN
        IPR(210) = 0
        GO TO 180
      END IF
      WRITE (LU7, 99971, IOSTAT = IOST) IPR(372)
C * CHECK DIRCOS
      CALL PLA199 (-1)
      CALL PLA262 (6)
   50 IF (IPR(373) == 0) IPR(373) = 8
      IF (IPR(374) > 7)  IPR(374) = 7
      AIMIN  = 0.5
      AIMAX  = 1.5
      IF (AIMIN == 0 .AND. AIMAX == 0) THEN
        IF (PAR(301) > 0 .AND. PAR(304) > 0
     1                      .AND. PAR(306) > PAR(304)) THEN
          AIMIN = EXP (- PAR(301) * PAR(306))
          AIMAX = EXP (- PAR(301) * PAR(304))
        ELSE
          AIMIN = 0.5
          AIMAX = 1.5
        END IF
      END IF
      IF (AIMIN >= 0 .AND. AIMAX > AIMIN) THEN
        AMEAN = 0.5 * (AIMIN + AIMAX)
        AIMIN = AIMIN / AMEAN
        AIMAX = AIMAX / AMEAN
      END IF
      IF (AIMIN < 0) AIMIN = 0
      IF (AIMAX < 0) AIMAX = 1E10
      CALL PLA262 (16)
      WRITE (LU7, 99997, IOSTAT = IOST)
     1  IPR(373), IPR(374), PAR(301), PAR(305), PAR(304), PAR(306),
     2  PAR(326)
      WRITE (LU7, 99982, IOSTAT = IOST)
     1  FSQMIN, FSQMAX, STLMIN, STLMAX, AIMIN, AIMAX
      IF (PAR(301) == 0) THEN
        CALL PLA262 (2)
        WRITE (LU7, 99981, IOSTAT = IOST)
      ELSE IF (PAR(305) == 0 .AND. PAR(304) == 0) THEN
        CALL PLA262 (2)
        WRITE (LU7, 99980, IOSTAT = IOST)
      ELSE IF (PAR(305) == 0 .AND. PAR(304) > 0) THEN
        CALL PLA262 (2)
        WRITE (LU7, 99979, IOSTAT = IOST)
      END IF
      IF (NAUTO == 1) THEN
   60   CALL PLA198 (6, 1, 0, 0)
C * WHAT NEXT ?
        CALL PLA012 (0, 1)
        CALL PLA006 (0, IS)
        SELECT CASE (IFL(1)(1:4))
          CASE ('MU  ')
            PAR(301) = FN(1)
            PAR(321) = PAR(301) * PAR(305)
            IPR(441) = 0
          CASE ('RADI')
            PAR(305) = FN(1)
            PAR(321) = PAR(301) * PAR(305)
            IPR(442) = 0
          CASE ('TMIN')
            PAR(304)   = FN(1)
          CASE ('TMAX')
            PAR(306)   = FN(1)
          CASE ('L0MA')
            IPR(373)   = NINT (FN(1))
          CASE ('L1MA')
            IPR(374)   = NINT (FN(1))
          CASE ('NEXT')
C * EVICT STRING
            CALL PLA439 (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)
            GO TO 70
          CASE ('END ')
            GO TO 180
          CASE ('EXIT')
            GO TO 180
          CASE DEFAULT
            GO TO 60
        END SELECT
        CALL GGIP (0.0, 0.0, 0.0, 6)
        GO TO 50
      END IF
C * PRINT SOME DATA SET STATISTICS.
   70 CALL PLA262 (7)
      WRITE (LU7, 99983, IOSTAT = IOST)
     1  N3REJ, SMIN1, SMAX1, N6REJ, N7REJ
      WRITE (LU7, 99986, IOSTAT = IOST) SMIN, SMAX
C * PACK AND SORT ON THE UNIQUE EQUIVALENT INDICES.
      NL  = 2 * ILM + 1
      NK  = 2 * IKM + 1
      NKL = NK * NL
      DO I = 1, IPR(372)
        READ (LURA, REC = I) J, K, L
        DATAX(I) = (J + IHM) * NKL + (K + IKM) * NL + (L + ILM)
      END DO
      CALL GEN053 (IPR(372), DATAX, INDEY)
      DO I = 1, IPR(372)
        READ  (LURA, REC = INDEY(I)) J, K, L,
     1                               IH, IK, IL, Y, SIGY, S0, S1
        WRITE (LURB, REC = I)        IH, IK, IL, Y, SIGY, S0, S1
 
      END DO
C * REWRITE THE HKL-SORTED DATA FILE IN BLOCKS OF MULTIPLE EQUIVALENT
C * MEASUREMENTS.
      CALL GEN108 (LU8, 0)
      IHKL  = NINT (DATAX(INDEY(1)))
      NMEAS = 1
      INDEY(IPR(372) + 1) = IPR(372) + 1
      DATAX(IPR(372) + 1)  = -999999.0
      DO I = 2, IPR(372) + 1
        IF (DATAX(INDEY(I)) == 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 J = 1, NMEAS
            IREC = I - J
            READ  (LURB, REC = IREC) IH, IK, IL, Y, SIGY, S0, S1
            WRITE (LU8)              IH, IK, IL, Y, SIGY, S0, S1
          END DO
          IHKL  = NINT (DATAX(INDEY(I)))
          NMEAS = 1
        END IF
      END DO
C * PREPARE DATA FOR FIT OF EMPIRICAL ABSORPTION SURFACE.
C * PREPARE A WORKING FILE OF MULTIPLE EQUIVALENT DATA.
      IPR(376) = 0
      IPR(375) = 0
      CHISQ    = 0
      SUMSQ    = 0
      CALL GEN108 (LU8, 1)
      CALL GEN108 (LU9, 0)
   80 READ (LU8, IOSTAT = IOST) N
      IF (IOST == -1) GO TO 90
      DO J = 1, N
        READ (LU8) IH, IK, IL, YJ, SIGYJ, S0, S1
        YI(J)    = YJ
        SIGYI(J) = SIGYJ
        DO K = 1, 3
          U0(K, J) = - S0(K)
          U1(K, J) =   S1(K)
        END DO
      END DO
      IF (N < 2) GO TO 80
C * ELIMINATE MEASUREMENTS OUTSIDE GIVEN SIN(THETA)/LAMBDA LIMITS.
      S =  GEN056 (IH, IK, IL, RBB)
      IF (S < STLMIN .OR. S > STLMAX) GO TO 80
C * ELIMINATE MEASUREMENTS TOO WEAK TO BE SIGNIFICANT OR TOO STRONG TO BE
C * EXTINCTION-FREE.
      DO I = 1, N
        IF (YI(I) / SIGYI(I) < FSQMIN .OR. YI(I) > FSQMAX)
     1      GO TO 80
      END DO
C * ELIMINATE MEASUREMENTS THAT ARE PHYSICALLY UNREASONABLE, EXTREME
C * OUTLIERS FROM THE SAMPLE MEDIAN.
C * SORT
      CALL GEN053 (N, YI, INDEY)
      M = N / 2
      IF (MOD (N, 2) == 0) THEN
        YMEDIAN = 0.5 * (YI(INDEY(M)) + YI(INDEY(M + 1)))
      ELSE
        YMEDIAN = YI(INDEY(M + 1))
      END IF
      NDATA = 0
      SUMW  = 0
      DO I = 1, N
        AI = YI(I) / YMEDIAN
        IF (AI < AIMIN .OR. AI > AIMAX) THEN
          WI(I) = 0.0
        ELSE
          WI(I) = 1.0 / (SIGYI(I)**2)
          SUMW  = SUMW  + WI(I)
          NDATA = NDATA + 1
        END IF
      END DO
      IF (NDATA < 2) GO TO 80
      IPR(376) = IPR(376) + 1
      IPR(375) = IPR(375) + NDATA
C * WRITE DATA FILE FOR LEAST SQUARES FIT.
C * CALCULATE AGREEMENT STATISTICS FOR A = 1.
      WRITE (LU9) NDATA, SUMW
      DO I = 1, N
        IF (WI(I) > 0) WRITE (LU9)
     1     (U0(III, I), III = 1, 3),
     2     (U1(III, I), III = 1, 3), WI(I), YI(I)
        DI = 0
        DO J = 1, N
          YJ = - WI(J) * YI(J) / SUMW
          IF (J == I) YJ = YJ + YI(J)
          DI = DI + YJ
        END DO
        CHISQ = CHISQ + WI(I) * DI**2
        SUMSQ = SUMSQ + WI(I) * YI(I)**2
      END DO
      GO TO 80
   90 CALL PLA262 (16)
      WRITE (LU7, 99984, IOSTAT = IOST)
     1   STLMIN, STLMAX, FSQMIN, FSQMAX, AIMIN, AIMAX,
     1 IPR(375), IPR(376)
C * FIT REAL SPHERICAL HARMONICS, YLM, TO EMPIRICAL ABSORPTION SURFACE AS
C * SAMPLED BY MULTIPLE EQUIVALENT MEASUREMENTS.
C *
C * CHISQ = SUM(H) SUM(I=1,N) [WHI*(YHI*AHI - <YHI*AHI>)**2
C *       + WA*(AHI - 1)**2]
C *
C * CHISQ = SUM(H) SUM(I=1,N) [WHI*(YHI*AHI
C *       - SUM(J=1,N) WHJ*YHJ*AHJ/SUM(J=1,N) WHJ)**2
C *       + WA*(AHI - 1)**2]
C *
C * WHERE HERE THE A VALUES ARE ABSORPTION ANISOTROPY CORRECTION FACTORS,
C * I.E., RECIPROCAL TRANSMISSION FACTORS, WHICH ARE RESTRAINED TOWARD AN
C * AVERAGE VALUE OF UNITY.
C *
C * FSQ(CORR) = FSQ(MEAS)*A
C *
C * A = 0.5*(A(-U0) + A(U1))
C *
C * A(U) = 1 + SUM(L=1,LMAX) SUM(M=-L,+L) ALM*YLM(U)
C *
C * YLM(U) = YLM(X, Y, Z)
C *
C * WHERE X, Y, AND Z ARE THE COMPONENTS OF UNIT VECTORS ALONG THE REVERSE
C * INCIDENT BEAM, -U0, AND THE DIFFRACTED BEAM, U1, REFERRED TO A SET OF
C * CRYSTAL-FIXED CARTESIAN (I.E., ORTHONORMAL) AXES.  IN OTHER WORDS, THE
C * COMPONENTS X, Y, AND Z ARE THE DIRECTION COSINES OF THE BEAM DIRECTION
C * VECTORS, -U0 AND U1.
C *
C * NOTE THAT THERE ARE TWO TERMS IN THE RESIDUAL,
C *
C * CHISQ = CHISQ(Y) + WA*CHISQ(A).
C *
C * THE FIRST TERM,
C *
C * TERM  CHISQ(Y) = SUM(H) SUM(I=1,N) WHI*(YHI*AHI - <YHI*AHI>)**2,
C *
C * IS THE FIT RESIDUAL FOR THE PARAMETERS OF THE AHI, AND IN THE SECOND
C * TERM,
C *
C * CHISQ(A) = SUM(H) SUM(I=1,N) (AHI - 1)**2,
C *
C * IS A RESTRAINT RESIDUAL, WHICH ACTS TO RESTRAIN THE AVERAGE OF THE AHI
C * TOWARD A VALUE OF UNITY.
C *
C * IF THE DIFFERENCES AMONG THE YHI ARE DUE MAINLY TO THE DIFFERENT AHI,
C * EXPECT NORMALIZED MEAN-SQUARE DEVIATIONS
C *
C *  CHISQ(A)/SUM AHI**2 = SUM WHI*(YHI - <YHI>)**2/SUM WHI*YHI**2
C *
C *                      = RW**2.
C *
C * FOR <AHI> = 1, SUM AHI**2 = NOBS, AND
C *
C * CHISQ(A) = NOBS*RW**2.
C *
C * THUS, TO HAVE A STANDARDIZED MEAN-SQUARE DEVIATION
C *
C * WA*CHISQ(A)/NOBS = 1,
C *
C * CHOOSE
C *
C * WA = 1/RW**2.
      PAR(322) = SQRT(CHISQ / SUMSQ)
      Z1 = SQRT(CHISQ / (IPR(375) - IPR(376)))
      WQ = 1.0 / PAR(322)**2
C * CALCULATE THE NUMBER OF PARAMETERS.
      IPR(377) = 0
      LMAX = MAX (IPR(373), IPR(374))
      DO L = 1, LMAX
        IF ((MOD (L, 2) == 0 .AND. L <= IPR(373)) .OR.
     1      (MOD (L, 2) == 1 .AND. L <= IPR(374)))
     2       IPR(377) = IPR(377) + 2 * L + 1
      END DO
  100 IF (IPR(375) / IPR(377) < 10) THEN
        IPR(377) = IPR(377) - (2 * LMAX + 1)
        IF (IPR(377) <= 0) THEN
          WRITE (PRBUF, 99975, IOSTAT = IOST)
          WRITE (LU6, 99976, IOSTAT = IOST) PRBUF
          WRITE (LU7, 99976, IOSTAT = IOST) PRBUF
          GO TO 180
        END IF
        LMAX = LMAX - 1
        IF (IPR(373) > LMAX) IPR(373) = IPR(373) - 2
        IF (IPR(374) > LMAX) IPR(374) = IPR(374) - 2
        GO TO 100
      END IF
C * ZERO THE NORMAL MATRIX AND VECTOR.
      DO I = 1, 80
        BZ(I) = 0
        DO J = I, 80
          AZ(I, J) = 0
        END DO
      END DO
C * ACCUMULATE NORMAL MATRIX AND VECTOR.
      CALL GEN108 (LU9, 1)
      DO
        READ (LU9, IOSTAT = IOST) N, SUMW
        IF (IOST == -1) GO TO 110
        DO I = 1, N
          READ (LU9) (U0(J, I), J = 1, 3), (U1(J, I), J = 1, 3),
     1                WI(I), YI(I)
        END DO
        DO I = 1, N
C * EVALUATE THE RESTRAINT DERIVATIVES.
          CALL GEN055 (YLM0, U0(1, I), IPR(373), IPR(374))
          CALL GEN055 (YLM1, U1(1, I), IPR(373), IPR(374))
          DO K = 1, IPR(377)
            QI(K) = 0.5 * (YLM0(K) + YLM1(K))
            XI(K) = 0.0
          END DO
C * EVALUATE YCALC AND THE FIT DERIVATIVES.
          YII = 0
          DO J = 1, N
            YJ = - WI(J) * YI(J) / SUMW
            IF (J == 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 K = 1, IPR(377)
              XI(K) = XI(K) + YJ * 0.5 * (YLM0(K) + YLM1(K))
            END DO
          END DO
C * SUM THE NORMAL MATRIX AND VECTOR ELEMENTS.
          DO K = 1, IPR(377)
            BZ(K) = BZ(K) - DBLE (WI(I) * YII * XI(K))
            DO L = K, IPR(377)
              AZ(K, L) = AZ(K, L) + DBLE (WQ * QI(K) * QI(L))
     1                            + DBLE (WI(I) * XI(K) * XI(L))
            END DO
          END DO
        END DO
      END DO
  110 DO I = 1, IPR(377) - 1
        DO J = I + 1, IPR(377)
          AZ(J, I) = AZ(I, J)
        END DO
      END DO
C * INVERT THE NORMAL MATRIX VIA DIAGONALIZATION AND EIGENVALUE FILTERING.
      CALL GEN054 (IPR(377), 80, AZ, UZ, VZ)
      UMAX = 0
      DO I = 1, IPR(377)
        UMAX = MAX (UMAX, ABS (SNGL (UZ(I))))
      END DO
      NZERO = 0
      T = PAR(326) * UMAX
      DO I = 1, IPR(377)
        IF (ABS (UZ(I)) < DBLE (T)) THEN
          UZ(I) = 0
          NZERO = NZERO + 1
        ELSE
          UZ(I) = 1 / UZ(I)
        END IF
      END DO
      DO I = 1, IPR(377)
        DO J = 1, IPR(377)
          AZ(I, J) = 0
        END DO
        AZ(I, I) = UZ(I)
      END DO
C * SQUARE MATRIX-MATRIX MULTIPLICATION IN DOUBLE PRECISION
      DO I = 1, IPR(377)
        DO J = 1, IPR(377)
          VA(I, J) = 0
          DO K = 1, IPR(377)
            VA(I, J) = VA(I, J) + VZ(I, K) * AZ(K, J)
          END DO
        END DO
      END DO
      DO I = 1, IPR(377) - 1
        DO J = I + 1, IPR(377)
          TYUNK    = VZ(I, J)
          VZ(I, J) = VZ(J, I)
          VZ(J, I) = TYUNK
        END DO
      END DO
C * SQUARE MATRIX-MATRIX MULTIPLICATION IN DOUBLE PRECISION
      DO I = 1, IPR(377)
        DO J = 1, IPR(377)
          AZ(I, J) = 0
          DO K = 1, IPR(377)
            AZ(I, J) = AZ(I, J) + VA(I, K) * VZ(K, J)
          END DO
        END DO
      END DO
C * CALCULATE THE PARAMETER VALUES.
      DO I = 1, IPR(377)
        ALM(I) = 0.0
        DO J = 1, IPR(377)
          ALM(I) = ALM(I) + REAL (AZ(I, J) * BZ(J))
        END DO
      END DO
C * CALCULATE STATISTICS OF FIT
      CHISQ  = 0
      SUMSQ  = 0
      AIMIN  = 1E10
      AIMAX  = 0
      SUMA   = 0
      SUMASQ = 0
      CHISQA = 0
      CALL GEN108 (LU9, 0)
      DO
        READ (LU9, IOSTAT = IOST) N, SUMW
        IF (IOST == -1) GO TO 120
        DO 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 K = 1, IPR(377)
            AI = AI + ALM(K) * 0.5 * (YLM0(K) + YLM1(K))
          END DO
          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
        END DO
        DO I = 1, N
          DI = 0
          DO J = 1, N
            YJ = - WI(J) * YI(J) / SUMW
            IF (J == I) YJ = YJ + YI(J)
            DI = DI + YJ
          END DO
          CHISQ = CHISQ + WI(I) * DI**2
          SUMSQ = SUMSQ + WI(I) * YI(I)**2
        END DO
      END DO
  120 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)
C * COMPUTE VAR-COV MATRIX.
      DO I = 1, IPR(377)
        SIGALM(I) = REAL (DBLE (ZY) * SQRT (AZ(I, I)))
      END DO
      DO I = 1, IPR(377)
        DO J = I, IPR(377)
          IF (AZ(I, I) * AZ(J, J) > 0) THEN
            IF (I == J) THEN
              T = 1
            ELSE
              T = SNGL (AZ(I, J) / SQRT (AZ(I, I) * AZ(J, J)))
            END IF
          ELSE
            T = 0
          END IF
          CORR(I, J) = T
          CORR(J, I) = T
        END DO
      END DO
      IF (IPR(377) < 80) THEN
        DO I = IPR(377) + 1, 80
          ALM(I)    = 0.0
          SIGALM(I) = 0.0
          DO J = 1, 80
            CORR(I, J) = 0.0
            CORR(J, I) = 0.0
          END DO
        END DO
      END IF
C * PRINT THE FITTED A(L,M) COEFFICIENTS AND STATISTICS OF FIT.
      CALL PLA262 (-18)
      WRITE (LU7, 99996, IOSTAT = IOST)
      NPAR = 0
      N0   = '0'
      N01  = 0
      N02  = 0
      N03  = 0
      SUMA = 0
      DO L = 1, MAX (IPR(373), IPR(374))
        N0 = CHAR (ICHAR ('0') + L)
        N1 = ' '
        N2 = '0'
        J  = 1
        DO M = -L, L
          IF ((MOD (L, 2) == 0 .AND. L <= IPR(373)) .OR.
     1        (MOD (L, 2) == 1 .AND. L <= IPR(374))) THEN
            NPAR = NPAR + 1
            ALX = ABS (ALM(NPAR)) / SIGALM(NPAR)
            CALL PLA262 (1)
            WRITE (LU7, 99995, IOSTAT = IOST)
     1        NPAR, N0, N1//N2, ALM(NPAR), ALX
            IF (ALX >= 1) N01 = N01 + 1
            IF (ALX >= 2) N02 = N02 + 1
            IF (ALX >= 3) N03 = N03 + 1
            SUMA = SUMA + ALX
            J = J + 1
            N2 = CHAR (ICHAR ('0') + J / 2)
            IF (MOD (J, 2) == 1) THEN
              N1 = '-'
            ELSE
              N1 = '+'
            END IF
            N0 = ' '
          END IF
        END DO
      END DO
      IPR(377) = NPAR
      WRITE (LU7, 99989, IOSTAT = IOST)
     1  N01, N02, N03, SUMA / IPR(377), NZERO, PAR(326)
      CALL PLA262 (0)
      WRITE (LU7, 99988, IOSTAT = IOST)
      WRITE (LU7, 99987, IOSTAT = IOST)
      WRITE (LU6, 99985, IOSTAT = IOST)
     1  IPR(375), IPR(376), IPR(377), Z1, PAR(322), ZY, PAR(323),
     2  ZA, RA
      WRITE (LU7, 99985, IOSTAT = IOST)
     1  IPR(375), IPR(376), IPR(377), Z1, PAR(322), ZY, PAR(323),
     2  ZA, RA
      WRITE (LU7, 99992, IOSTAT = IOST) AIMIN, AIMAX, AMEAN, RMSDA
C * IF RADIUS = 0, THEN FIND R FROM EXPECTED MAXIMUM TRANSMISSION FACTOR.
      IF (PAR(305) == 0) THEN
C * RETRIEVE TMIN, THE ESTIMATED MINIMUM CRYSTAL THICKNESS, AND AMAX, THE
C * MAXIMUM TRANSMISSION ANISOTROPY FACTOR FROM THE FITTED YLM, FROM THE
        AMAX = 1.0 / AIMIN
        IF (PAR(304) <= 0 .OR. AMAX <= 0) GO TO 140
        ASPHERE = EXP(- PAR(301) * PAR(304)) / AMAX
        IF (ASPHERE >= 1) GO TO 140
C * INTERPOLATE ON LOG(A) AT THETA = 0 IN THE BOND TABLE TO FIND MU*R AND
C * THE EQUIVALENT SPHERE RADIUS.
        IF (ASPHERE < AMUR(12)) ASPHERE = AMUR(12)
        DO J = 2, 12
          IF (ASPHERE >= AMUR(J)) GO TO 130
        END DO
  130   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)
      END IF
      GO TO 150
  140 PAR(301) = 0.0
C * INIT SPHERICAL ABSORPTION CORRECTION TABLE
  150 CALL PLA191 (1, PAR(301) * PAR(305), YUNK)
      IPR(432) = 0
      IF (NAUTO == 1) THEN
        CALL PLA198 (6, 1, 0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      END IF
C * APPLY ABSORPTION CORRECTION
C * LOOP THROUGH DATA SET.
      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 PLA262 (-2)
      WRITE (LU7, 99994, IOSTAT = IOST)
      DO
        READ  (LU8, IOSTAT = IOST) N, JH, JK, JL
        IF (IOST == -1) GO TO 160
        IPRINT = IPRINT - 1
        THETA  = GEN056 (JH, JK, JL, RBB) * PAR(17)
        IF (ABS (THETA) > 1.0) THEN
           WRITE (LU6, 99977, IOSTAT = IOST) N, JH, JK, JL, THETA
C * CALL EXIT/STOP
           CALL GEN127 ('ASIN() PROBLEM IN MULABS')
        END IF
        THETA = ASIN (THETA)
        DO 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))
C * LIMIT THE ABSORPTION ANISOTROPY CORRECTION TO THE RANGE OF THE FITTED
C * VALUES.
          A = 1
          V = 0
          DO J = 1, IPR(377)
            A    = A + ALM(J) * 0.5 * (YLM0(J) + YLM1(J))
            YLMJ = 0.5 * (YLM0(J) + YLM1(J)) * SIGALM(J)
            DO K = 1, IPR(377)
              YLMK = 0.5 * (YLM0(K) + YLM1(K)) * SIGALM(K)
              V    = V + CORR(J, K) * YLMJ * YLMK
            END DO
          END DO
          A = MAX (A, AIMIN)
          A = MIN (A, AIMAX)
C * REGISTER MIN/MAX ANISOTROPY FACTORS
          PAR(319) = MIN (PAR(319), 1.0 / A)
          PAR(320) = MAX (PAR(320), 1.0 / A)
C * GET SPHERICAL CORRECTION
          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 > 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 J = 1, 3
              U0(J, I0) = S0(J)
              U1(J, I0) = S1(J)
            END DO
          END IF
        END DO
        IF (IPRINT > 0) THEN
          IF (N >= 2) THEN
            CALL GEN053 (N, YI, INDEY)
          ELSE
            INDEY(1) = 1
          END IF
          CALL PLA262 (N + 1)
          WRITE (LU7, 99978, IOSTAT = IOST)
          DO I = 1, N
            J = INDEY(I)
            WRITE (LU7, 99993, IOSTAT = IOST) 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)
          END DO
        END IF
      END DO
C * PRINT DATA SET ABSORPTION STATISTICS.
  160 CALL GEN108 (LU9, 1)
      CALL GEN108 (LU17, 0)
C * SCALE TO FIT INTO FIELDWIDTH
      IF (XIMAX > 99999.0) THEN
        SCF = 99999.0 / XIMAX
      ELSE
        SCF = 1.0
      END IF
      NOUT = 0
      DO
        READ (LU9, IOSTAT = IOST) JH, JK, JL, YJ, SGYJ
        IF (IOST == -1) GO TO 170
        YJ   = YJ   * SCF
        SGYJ = SGYJ * SCF
        NOUT = NOUT + 1
        WRITE (LU17, 99990, IOSTAT = IOST) JH, JK, JL, YJ, SGYJ
      END DO
C * FINISH WITH BLANK RECORD
  170 WRITE (LU17, 99978, IOSTAT = IOST)
      WRITE (LU6, 99991, IOSTAT = IOST) PAR(315), PAR(317), NINP, NOUT
      CALL PLA262 (4)
      WRITE (LU7, 99991, IOSTAT = IOST) PAR(315), PAR(317), NINP, NOUT
      IF (NAUTO == 1) GO TO 50
C * CLOSE RANDOM ACCESS FILE
  180 CLOSE (UNIT = LURA, STATUS = 'DELETE')
      CLOSE (UNIT = LURB, STATUS = 'DELETE')
      DEALLOCATE (DATAX, INDEY)
      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) >= 1', /,
     2 'N2   = ', I3, '    "      "        "         >= 2', /,
     3 'N3   = ', I3, '    "      "        "         >= 3', //,
     4 '<abs(A) / Sigma(A)> = ', 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 - <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/(<WHI*(YHI - <YHI>)**2>/<WHI*YHI**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 ' < SMIN1 = ',F5.3,' OR > SMAX1 = ', F5.3, /, 'N6 =',
     3 I6, 6X, '"           "          "       "    Sigma(Ymeas',
     4 ') <= 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, <A> = 1,  will be ',
     2 'Calculated.')
99979 FORMAT (4X, 'If Radius == 0, and Tmin > 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')
99974 FORMAT ('WAVELENGTH NOT GIVEN')
99973 FORMAT ('|SIN(THETA)| > 1.0 ?', 3I5, F10.5, /)
99972 FORMAT ('Read   =', I7, ' Measurements')
99971 FORMAT ('Accept =', I7, ' Measurements')
      END SUBROUTINE PLA190
 
      SUBROUTINE PLA191 (MODE, VALUEX, ASTER)
C * Spherical Absorption Correction
      IMPLICIT NONE
      INTEGER                     :: I
      INTEGER                     :: J
      INTEGER                     :: K
      INTEGER                     :: MODE
      REAL                        :: Y
      REAL                        :: STH
      REAL                        :: RAD
      REAL                        :: ASTER
      REAL                        :: VALUEX
      REAL,       DIMENSION(6, 6) :: A
      REAL,       DIMENSION(6)    :: D
      REAL,       DIMENSION(5, 7) :: RMF
      REAL, SAVE, DIMENSION(7)    :: TMC
      REAL, SAVE, DIMENSION(6)    :: X
      RMF = RESHAPE ( (/
     1  1.4997809, -0.07413433, -0.00943029,  0.00040669,  0.00015026,
     2  1.4999662, -0.09367724, -0.01235379, -0.00058663,  0.00050426,
     3  1.4988822, -0.14574555, -0.02797312,  0.00817433, -0.00049362,
     4  1.4995843, -0.24116768, -0.01740035,  0.01511804, -0.00195657,
     5  1.5018433, -0.36087828,  0.03103321,  0.00846806, -0.00183552,
     6  1.5037652, -0.46125653,  0.08544717, -0.00449737, -0.00059269,
     7  1.5043426, -0.49981128,  0.10691309, -0.00980878, -0.00007175/),
     8  (/5, 7/))
C * SPHERICAL ABSORPTION CORRECTION, USING  CURVE FITTING CONSTANTS
C * BASED ON (DWIGGENS, ACTA CRYST(1975),A31,395)
      RAD = ATAN (1.0) / 45.0
C * MODE = 1 : SET UP ANALYTICAL FUNCTIONS (INIT CALL) VALUE = MU*R
C *      = 0 : CALCULATE CORRECTION                    VALUE = THETA
      IF (MODE == 1) THEN
C * GENERATE CURVE FITTING FUNCTION FOR A*(MU*R)
        DO J = 1, 7
          Y = 0.0
          DO I = 1, 5
            Y = Y + RMF(I, J) * VALUEX ** I
          END DO
          TMC(J) = EXP (-Y)
        END DO
C * GENERATE CURVE FITTING FUNCTION FOR AT
        DO K = 1, 6
          STH  = SIN (K * 15.0 * RAD)
          D(K) = TMC(K + 1) - TMC(1)
          DO I = 1, 6
            A(K, I) = STH**(2 * I)
          END DO
        END DO
C * SOLVE A * X = D
        CALL GEN057 (A, X, D, 6)
      ELSE
        ASTER = TMC(1)
        DO J = 1, 6
          K = 2 * J
          ASTER = ASTER + X(J) * VALUEX ** K
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA191
 
      SUBROUTINE PLA192 (NBEG)
C * ABSORPTION CORRECTION ROUTINE (GAUSSIAN INTEGRATION)
C * See Ph. Coppens, Crystallographic computing, 1970
      USE files
      USE parameters
      USE crystal
      IMPLICIT NONE
      INTEGER                    :: I
      INTEGER                    :: K
      INTEGER                    :: L
      INTEGER                    :: I0
      INTEGER                    :: J0
      INTEGER                    :: I1
      INTEGER                    :: K1
      INTEGER                    :: N1
      INTEGER                    :: JJ
      INTEGER                    :: KK
      INTEGER                    :: LL
      INTEGER                    :: LO
      INTEGER                    :: MO
      INTEGER                    :: NIA
      INTEGER                    :: NIB
      INTEGER                    :: NIC
      INTEGER                    :: NLO
      INTEGER                    :: NMO
      INTEGER                    :: NPA
      INTEGER                    :: NPB
      INTEGER                    :: NPC
      INTEGER                    :: NCOR
      INTEGER                    :: INTN
      INTEGER                    :: ICOR
      INTEGER                    :: JGRD
      INTEGER                    :: NBEG
      INTEGER                    :: NPOINT
      INTEGER                    :: ISIGMA
      INTEGER, DIMENSION(NXT1)   :: NIN
      INTEGER, DIMENSION(NXT1)   :: NOUTT
      INTEGER, DIMENSION(3)      :: IGA
      REAL                       :: R1
      REAL                       :: R2
      REAL                       :: GK
      REAL                       :: HK
      REAL                       :: DET
      REAL                       :: GAB
      REAL                       :: HAB
      REAL                       :: XMU
      REAL                       :: AXTL
      REAL                       :: PXTL
      REAL                       :: TBAR
      REAL                       :: TBMU
      REAL                       :: TXTL
      REAL                       :: XMAX
      REAL                       :: XMIN
      REAL                       :: YMAX
      REAL                       :: YMIN
      REAL                       :: ZMAX
      REAL                       :: ZMIN
      REAL                       :: RDOTN
      REAL                       :: RINTN
      REAL                       :: CHECK
      REAL                       :: SIGMA
      REAL                       :: ASTAR
      REAL                       :: VOLUME
      REAL                       :: TRANSM
      REAL                       :: DELTAZ
      REAL,    DIMENSION(NXT1)   :: COSIN
      REAL,    DIMENSION(NXT1)   :: COSOUT
      REAL,    DIMENSION(3)      :: SD
      REAL,    DIMENSION(3)      :: SOD
      REAL,    DIMENSION(2, 2)   :: BBOUND
      REAL,    DIMENSION(2, 2)   :: DBOUND
      REAL,    DIMENSION(3)      :: XYZ
      REAL,    DIMENSION(3)      :: HKL
      REAL,    DIMENSION(4)      :: GRD
      REAL,    DIMENSION(3)      :: TEMP
      REAL,    DIMENSION(500, 2) :: GAUSS
C * NOTE: REFLECTION DATA STORED BOTTOM UP & GAUSS GRID TOP DOWN
      WRITE (LU6, 99996)
      XMU    = PAR(301)
      NIA    = IPR(421)
      NIB    = IPR(422)
      NIC    = IPR(423)
      NPOINT = 0
C * CONSTRUCTS GAUSSIAN GRID WITHIN CRYSTAL. GRID AXES PARALLEL TO XTAL
C * DETERMINE AND STORE THE GAUSS GRID LIMITS
C * DETERMINE LOWER AND UPPER LIMITS IN X (Y AND Z)
      VOLUME = 0.0
      XMAX   = XTLV(1, 1)
      YMAX   = XTLV(2, 1)
      ZMAX   = XTLV(3, 1)
      XMIN   = XTLV(1, 1)
      YMIN   = XTLV(2, 1)
      ZMIN   = XTLV(3, 1)
      DO I = 2, NVER
        XMAX = MAX (XMAX, XTLV(1, I))
        YMAX = MAX (YMAX, XTLV(2, I))
        ZMAX = MAX (ZMAX, XTLV(3, I))
        XMIN = MIN (XMIN, XTLV(1, I))
        YMIN = MIN (YMIN, XTLV(2, I))
        ZMIN = MIN (ZMIN, XTLV(3, I))
      END DO
      JGRD  = NVDR
      VOID(JGRD)     = XMIN
      VOID(JGRD - 1) = XMAX
      JGRD           = JGRD - 1
      IF (NIA == 0) THEN
        NIA = MAX (8, NINT (4.0 * XMU * (XMAX - XMIN) * PAR(241)))
        NIB = MAX (8, NINT (4.0 * XMU * (YMAX - YMIN) * PAR(241)))
        NIC = MAX (8, NINT (4.0 * XMU * (ZMAX - ZMIN) * PAR(241)))
        IPR(421) = NIA
        IPR(422) = NIB
        IPR(423) = NIC
      END IF
      NIA    = 2 * MAX (1, (NIA + 1) / 2)
      IGA(1) = 0
      CALL GEN115 (GAUSS(1, 1), GAUSS(1, 2), NIA)
      NIB    = 2 * MAX (1, (NIB + 1) / 2)
      IGA(2) = NIA
      CALL GEN115 (GAUSS(IGA(2) + 1, 1), GAUSS(IGA(2) + 1, 2), NIB)
      NIC    = 2 * MAX (1, (NIC + 1) / 2)
      IGA(3) = NIA + NIB
      CALL GEN115 (GAUSS(IGA(3) + 1, 1), GAUSS(IGA(3) + 1, 2), NIC)
      DO NPA = 1, NIA
C * XYZ(IA) ARE FRACTIONAL COORDINATES OF GRID POINTS ALONG A AXIS
         LL = IGA(1) + NPA
         XYZ(1) = XMIN + (XMAX - XMIN) * GAUSS(LL, 1)
C * R1 IS THE GAUSSIAN WEIGHT CORRESPONDING TO XYZ(IA)
         R1 = GAUSS(LL, 2) * (XMAX - XMIN)
C * SCAN OVER ALL POSSIBLE COMBINATIONS OF TWO FACES TO DETERMINE COOR
C * OF EDGES OF CRYSTAL FOR A GIVEN X
         YMIN =  99999.0
         YMAX = -99999.0
         N1   = NFACES - 1
         DO K = 1, N1
           BBOUND(1, 1) = PMILL(K, 2)
           BBOUND(1, 2) = PMILL(K, 3)
           TEMP(1) = PMILL(K, 4) - PMILL(K, 1) * XYZ(1)
           K1 = K + 1
           DO 10 L = K1, NFACES
             BBOUND(2, 1) = PMILL(L, 2)
             BBOUND(2, 2) = PMILL(L, 3)
C * INVERTS ASYMMETRIC 2X2 MATRIX
             DET = BBOUND(1, 1) * BBOUND(2, 2)
     1           - BBOUND(1, 2) * BBOUND(2, 1)
             IF (DET /= 0) THEN
               DBOUND(1, 1) =  BBOUND(2, 2) / DET
               DBOUND(1, 2) = -BBOUND(1, 2) / DET
               DBOUND(2, 1) = -BBOUND(2, 1) / DET
               DBOUND(2, 2) =  BBOUND(1, 1) / DET
               TEMP(2) = PMILL(L, 4) - PMILL(L, 1) * XYZ(1)
               XYZ(2) = DBOUND(1, 1) * TEMP(1)
     1                + DBOUND(1, 2) * TEMP(2)
               XYZ(3) = DBOUND(2, 1) * TEMP(1)
     1                + DBOUND(2, 2) * TEMP(2)
               DO J0 = 1, NFACES
                 CHECK = 0.0
                 DO I0 = 1, 3
                   CHECK = CHECK + PMILL(J0, I0) * XYZ(I0)
                 END DO
                 IF (PMILL(J0, 4) < CHECK - 0.0000001) GO TO 10
               END DO
               YMAX = MAX (YMAX, XYZ(2))
               YMIN = MIN (YMIN, XYZ(2))
             END IF
   10      CONTINUE
         END DO
C * STORE LOWER AND UPPER LIMITS IN Y FOR GIVEN X
         VOID(JGRD - 1) = YMIN
         VOID(JGRD - 2) = YMAX
         JGRD           = JGRD - 2
         DO NPB = 1, NIB
            KK = IGA(2) + NPB
            XYZ(2) = YMIN + (YMAX - YMIN) * GAUSS(KK, 1)
            R2 = GAUSS(KK, 2) * R1 * (YMAX - YMIN)
            ZMAX = - 99999.0
            ZMIN =   99999.0
C * SCAN OVER ALL FACES TO DETERMINE UPPER AND LOWER LIMITS OF Z FOR G
            DO 20 I = 1, NFACES
               IF (PMILL(I, 3) /= 0) THEN
                 XYZ(3) = (PMILL(I, 4) - XYZ(1) * PMILL(I, 1)
     1                  - XYZ(2) * PMILL(I, 2)) / PMILL(I, 3)
                 DO J0 = 1, NFACES
                   CHECK = 0.0
                   DO I0 = 1, 3
                     CHECK = CHECK + PMILL(J0, I0) * XYZ(I0)
                   END DO
                   IF (PMILL(J0, 4) < CHECK - 0.0000001) GO TO 20
                 END DO
                 ZMAX = MAX (ZMAX, XYZ(3))
                 ZMIN = MIN (ZMIN, XYZ(3))
               END IF
   20       CONTINUE
            VOID(JGRD - 1) = ZMIN
            VOID(JGRD - 2) = ZMAX
            JGRD           = JGRD - 2
            DELTAZ = ZMAX - ZMIN
            DO NPC = 1, NIC
              NPOINT = NPOINT + 1
C * STORE FRACTIONAL COORDINATES OF SAMPLING POINTS AND CORRESPONDING
              JJ = IGA(3) + NPC
C * VOL IS EQUAL TO THE VOLUME OF THE CRYSTAL AS A FRACTION OF THE VOL
C * A PARALLELOPIPED WHOSE EDGES ARE PARALLEL TO A,B,C AND OF LENGTH A
C * B(CMS),C(CMS)
              VOLUME = VOLUME + GAUSS(JJ, 2) * R2 * DELTAZ
            END DO
         END DO
      END DO
      WRITE (LU7, 99997, IOSTAT = IOST)
     1  PAR(301), NIA, NIB, NIC, NPOINT, VOLUME * PAR(98)
      NCOR = 0
C * READ REFLECTION LOOP
      I1 = IHLP(NBEG) - 13
      DO
        I1     = I1 + 14
        HKL(1) = VOID(I1)
        HKL(2) = VOID(I1 + 1)
        HKL(3) = VOID(I1 + 2)
        RINTN  = VOID(I1 + 3)
        SIGMA  = VOID(I1 + 4)
        SOD(1) = VOID(I1 + 5)
        SD(1)  = VOID(I1 + 6)
        SOD(2) = VOID(I1 + 7)
        SD(2)  = VOID(I1 + 8)
        SOD(3) = VOID(I1 + 9)
        SD(3)  = VOID(I1 + 10)
        IF (HKL(1) < - 999.0) EXIT
        INTN   = NINT(RINTN)
C * CONVERT FROM 'SHELX' DIRECTION COSINES (WITH RECIPROCAL AXES) TO
C * DIRECT LATTICE COMPONENTS FOR So & S (See Dunitz page 229, 5.11)
C * s = (s.a*)a + (s.b*)b + (s.c*)c ;  PAR(135)..PAR(137) = a*, b*, c*
C * INCEDENT BEAM REVERSED
        DO I = 1, 3
          SOD(I) = SOD(I) * PAR(134 + I)
          SD(I)  = SD(I)  * PAR(134 + I)
        END DO
        NCOR = NCOR + 1
C * WRITE HEADER-LINE
        IF (NCOR == 1) THEN
          CALL PLA262 (0)
          CALL PLA262 (2)
          WRITE (LU7, 99999, IOSTAT = IOST)
        END IF
C * CALCULATE ABSORPTION CORRECTION FOR THIS REFLECTION
C * DETERMINES COMPONENTS OF INCIDENT AND DIFFRACTED BEAMS AND COMPONENTS
C * OF NORMAL TO DIFFRACTION PLANE AND NORMAL TO INCIDENT BEAM IN
C * DIFFRACTION PLANE AND CALCULATES THE ABSORPTION CORRECTION
C * SOD AND SD ARE THE COMPONENTS OF THE INCIDENT AND DIFFRACTED RAYS
C * IN DIRECT SPACE
C * CALCULATES PATH LENGTH OF RAY IN CRYSTAL FOR EACH OF THE SAMPLING
C * POINTS OF THE GAUSSIAN GRID AND THE ABSORPTION CORRECTION
        TRANSM = 0.0
        TBAR   = 0
        MO     = 1
        LO     = 1
C * CALCULATE COSINES OF ANGLES OF REVERSED INCIDENT AND DIFFRACTED RAYS
C * WITH A FACE
        DO K = 1, NFACES
          COSIN(MO)  = 0.0
          COSOUT(LO) = 0.0
          DO I = 1, 3
            COSIN(MO)  = COSIN(MO)  + SOD(I) * PMILL(K, I)
            COSOUT(LO) = COSOUT(LO) + SD(I)  * PMILL(K, I)
          END DO
C * REJECT FACES FOR WHICH ANGLE BETWEEN INCIDENT BEAM AND FACENORM ACUTE
          IF (COSIN(MO) > 0.0) THEN
            NIN(MO) = K
            MO      = MO + 1
          END IF
C * REJECT FACE IF ANGLE BETWEEN DIFFRACTED RAY AND FACE NORMAL IS OBTUSE
          IF (COSOUT(LO) > 0.0) THEN
            NOUTT(LO) = K
            LO        = LO + 1
          END IF
        END DO
        MO = MO - 1
        LO = LO - 1
C * CALCULATE PATH LENGTH AND ABSORPTION FOR EACH OF THE SAMPLING POINTS
        JGRD = NVDR
        XMIN = VOID(JGRD)
        XMAX = VOID(JGRD - 1)
        JGRD = JGRD - 1
        DO NPA = 1, NIA
          LL     = IGA(1) + NPA
          GRD(1) = XMIN + (XMAX - XMIN) * GAUSS(LL, 1)
          R1     = GAUSS(LL, 2) * (XMAX - XMIN)
          YMIN   = VOID(JGRD - 1)
          YMAX   = VOID(JGRD - 2)
          JGRD   = JGRD - 2
          DO NPB = 1, NIB
            KK     = IGA(2) + NPB
            GRD(2) = YMIN + (YMAX - YMIN) * GAUSS(KK, 1)
            R2     = GAUSS(KK, 2) * R1 * (YMAX - YMIN)
            ZMIN   = VOID(JGRD - 1)
            ZMAX   = VOID(JGRD - 2)
            JGRD   = JGRD - 2
            DELTAZ = ZMAX - ZMIN
            DO NPC = 1, NIC
              JJ     = IGA(3) + NPC
              GRD(3) = ZMIN + DELTAZ * GAUSS(JJ, 1)
              GRD(4) = GAUSS(JJ, 2) * R2 * DELTAZ
              GK     = 100000.0
              HK     = 100000.0
              DO K = 1, MO
                RDOTN = 0.0
                NMO   = NIN(K)
                DO I = 1, 3
                  RDOTN = RDOTN + GRD(I) * PMILL(NMO, I)
                END DO
                GAB = (PMILL(NMO, 4) - RDOTN) / COSIN(K)
C * CHOOSE MINIMUM PATH AS TRUE PATH LENGTH
                GK = MIN (GK, GAB)
              END DO
              DO K = 1, LO
                RDOTN = 0.0
                NLO = NOUTT(K)
                DO I = 1, 3
                  RDOTN = RDOTN + GRD(I) * PMILL(NLO, I)
                END DO
                HAB = (PMILL(NLO, 4) - RDOTN) / COSOUT(K)
                HK = MIN (HK, HAB)
              END DO
C * MULTIPLY ABSORPTION FOR EACH GRID POINT BY ITS GAUSSIAN WEIGHT
C * SUM ABSORPTION OVER ALL SAMPLING POINTS
              PXTL   = GK + HK
              AXTL   = EXP (-XMU * PXTL)
              TXTL   = PXTL * AXTL
              TBAR   = TBAR   + GRD(4) * TXTL
              TRANSM = TRANSM + GRD(4) * AXTL
            END DO
          END DO
        END DO
        ASTAR = VOLUME / TRANSM
        TBAR  = TBAR   / VOLUME
        TBMU  = ALOG (ASTAR)
C * COMPUTE I(COR)
        ICOR   = NINT (RINTN * ASTAR)
        TRANSM = 1.0 / ASTAR
        ISIGMA = NINT (SIGMA * ASTAR)
        VOID(I1 + 11) = TRANSM
C * PAPER OUTPUT AND WRITE HEADING
        IF (IGBL(57) > 0) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99998, IOSTAT = IOST)
     1      (NINT (HKL(I)), I = 1, 3), TRANSM, TBMU, INTN, NINT(SIGMA),
     2      ICOR, ISIGMA, TBAR
        END IF
      END DO
C * END OF FILE
      RETURN
99999 FORMAT ('  H  K  L  Transm    Mu*T   Intensity  Sigma    I(cor) ',
     1  ' Sig(cor)    Tbar', /, 80('='), /)
99998 FORMAT (3I3, F8.5, F9.4, I10, I7, I10, I7, F12.6)
99997 FORMAT (//, 'Mu = ', F10.2, ' mm-1', /,
     1        'A Grid of ', 2(I2, ' X '), I2, ' =', I6,
     2 ' Sampling Points.', //,
     3 'Crystal Volume =', 8X, F13.8, ' MM**3.')
99996 FORMAT (':: Gaussian Integration - ',
     1 'See Ph. Coppens, Crystallographic computing, 1970', /)
      END SUBROUTINE PLA192
 
      MODULE tompa
      SAVE
      INTEGER, PARAMETER                :: NTMP = 4000
      INTEGER                           :: ND
      INTEGER                           :: NF
      INTEGER                           :: NG
      INTEGER                           :: IL
      INTEGER                           :: NC
      INTEGER                           :: IEX
      INTEGER                           :: ISK
      INTEGER                           :: JNK
      INTEGER                           :: ISK2
      INTEGER                           :: JNK1
      INTEGER                           :: JNK3
      INTEGER                           :: ISTED
      INTEGER                           :: ISTVT
      INTEGER                           :: ISTNV
      INTEGER                           :: ISTTR
      INTEGER                           :: ISTNP
      INTEGER                           :: IENPL
      INTEGER                           :: IENNP
      INTEGER                           :: IENNV
      INTEGER                           :: IENED
      INTEGER                           :: IENVT
      INTEGER                           :: IENTR
      INTEGER                           :: IENPT
      INTEGER                           :: MAXUTL
      INTEGER,          DIMENSION(4)    :: IB
      INTEGER,          DIMENSION(2)    :: IE
      INTEGER,          DIMENSION(2)    :: JI
      INTEGER,          DIMENSION(2)    :: JT
      INTEGER,          DIMENSION(NTMP) :: ISTK
      DOUBLE PRECISION                  :: VT
      DOUBLE PRECISION                  :: TT
      DOUBLE PRECISION                  :: AMU
      DOUBLE PRECISION                  :: VMUL
      DOUBLE PRECISION, DIMENSION(12)   :: D
      DOUBLE PRECISION, DIMENSION(2)    :: CX
      DOUBLE PRECISION, DIMENSION(2)    :: CY
      DOUBLE PRECISION, DIMENSION(2)    :: CZ
      DOUBLE PRECISION, DIMENSION(2)    :: DEV
      DOUBLE PRECISION, DIMENSION(NTMP) :: RSTK
      END MODULE tompa
 
      SUBROUTINE PLA193 (NBEG)
C * DE MEULENAER & TOMPA ABSORPTION CORRECTION (ADAPTED FROM ALCOCK VERSION)
      USE files
      USE parameters
      USE crystal
      USE tompa
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: I1
      INTEGER          :: KA
      INTEGER          :: LA
      INTEGER          :: II
      INTEGER          :: JJ
      INTEGER          :: JA
      INTEGER          :: NU
      INTEGER          :: INV
      INTEGER          :: IP1
      INTEGER          :: JP1
      INTEGER          :: NPP
      INTEGER          :: INED
      INTEGER          :: IERR
      INTEGER          :: JUN1
      INTEGER          :: NBEG
      INTEGER          :: NFMX
      INTEGER          :: NMEM
      INTEGER          :: NFMX1
      INTEGER          :: NFMX2
      INTEGER          :: JUN11
      DOUBLE PRECISION :: C1
      DOUBLE PRECISION :: C2
      DOUBLE PRECISION :: C3
      DOUBLE PRECISION :: C4
      DOUBLE PRECISION :: C5
      DOUBLE PRECISION :: C6
      DOUBLE PRECISION :: AI
      DOUBLE PRECISION :: AJ
      DOUBLE PRECISION :: BI
      DOUBLE PRECISION :: BJ
      DOUBLE PRECISION :: CI
      DOUBLE PRECISION :: CJ
      DOUBLE PRECISION :: DA
      DOUBLE PRECISION :: DB
      DOUBLE PRECISION :: DC
      DOUBLE PRECISION :: DI
      DOUBLE PRECISION :: DJ
      DOUBLE PRECISION :: RM
      DOUBLE PRECISION :: SH
      DOUBLE PRECISION :: VA
      DOUBLE PRECISION :: VM
      DOUBLE PRECISION :: XH
      DOUBLE PRECISION :: XK
      DOUBLE PRECISION :: XL
      DOUBLE PRECISION :: XP
      DOUBLE PRECISION :: YP
      DOUBLE PRECISION :: ZP
      DOUBLE PRECISION :: YAR
      DOUBLE PRECISION :: ZAR
      DOUBLE PRECISION :: DEN
      DOUBLE PRECISION :: AIJ
      DOUBLE PRECISION :: BIJ
      DOUBLE PRECISION :: CIJ
      DOUBLE PRECISION :: CPD
      DOUBLE PRECISION :: CPX
      DOUBLE PRECISION :: CPY
      DOUBLE PRECISION :: CPZ
      DOUBLE PRECISION :: RAD
      DOUBLE PRECISION :: VV1
      DOUBLE PRECISION :: VV2
      DOUBLE PRECISION :: XAR
      DOUBLE PRECISION :: VOLM
      DOUBLE PRECISION :: SIGF
      DOUBLE PRECISION :: QHKL
      DOUBLE PRECISION :: DIST
      DOUBLE PRECISION :: FREL
      DOUBLE PRECISION :: CPBS
      DOUBLE PRECISION :: COSA
      DOUBLE PRECISION :: SINA
      DOUBLE PRECISION :: SINBS
      DOUBLE PRECISION :: SINGS
      DOUBLE PRECISION :: COSAS
      DOUBLE PRECISION :: COSBS
      DOUBLE PRECISION :: COSGS
      DOUBLE PRECISION :: CACBS
      DOUBLE PRECISION :: ABCGS
      DOUBLE PRECISION :: BCCAS
      DOUBLE PRECISION :: SINPBS
      CHARACTER(len=8) :: ITX
C * NOTE MOST CALCULATIONS ARE IN DOUBLE PRECISION - ESSENTIAL FOR 32 BIT
C * STORAGE FOR MAIN ARRAYS IS OPEN-ENDED, 1-DIMENSIONAL IN RSTK/ISTK
C * FROM IENPL ON ARE THE START AND END MARKERS AND INCREMENTS FOR EACH
C * SECTION OF THE ARRAY.  ISTXX AND IENXX MARK THE FIRST AND LAST
C * POINTS OF THE GROUPS, EACH INCXX LONG.  SO IENXX + INCXX = ISTYY
C * VT  = TOTAL VOLUME
C * TT  = TOTAL TRANSMISSION
C * AMU = LINEAR ABS COEFF
      NMEM   = 0
      RAD    = DBLE (RGBL(6))
      MAXUTL = 0
C * GET MU
      AMU    = DBLE (PAR(301))
      CALL PLA262 (0)
      WRITE (LU7, 99999, IOSTAT = IOST)
      WRITE (LU6, 99999, IOSTAT = IOST)
      WRITE (LU7, 99998, IOSTAT = IOST) AMU
      WRITE (LU6, 99998, IOSTAT = IOST) AMU
C * GET CELL PARAMETERS
      SINA  = SIN (DBLE (PAR(244)) / RAD)
      COSA  = COS (DBLE (PAR(244)) / RAD)
C * CALCULATE RECIPROCAL LATTICE CONSTANTS
      COSAS = COS (DBLE (PAR(138)) / RAD)
      COSBS = COS (DBLE (PAR(139)) / RAD)
      COSGS = COS (DBLE (PAR(140)) / RAD)
      SINBS = SIN (DBLE (PAR(139)) / RAD)
      SINGS = SIN (DBLE (PAR(140)) / RAD)
      BCCAS = DBLE (PAR(136)) * DBLE (PAR(137)) * COSAS
      CACBS = DBLE (PAR(137)) * DBLE (PAR(135)) * COSBS
      ABCGS = DBLE (PAR(135)) * DBLE (PAR(136)) * COSGS
C * FIRST PROCESS PLANE DATA
C * AN HKL PLANE - PLANES GIVEN IN TERMS OF MILLER INDICES MUST BE CONVERTED.
C * FOR SPEED OF COMPUTING THE CRYSTAL IS SPECIFIED ON ORTHOGONAL AXES
C * THE ANGLES FROM THE PLANE NORMAL TO THE REAL AXES ARE GIVEN BY
C * N - C = L.D/C, WHERE D = INTERPLANE SPACING.  THIS IS THE ANGLE OZ -N
C * ANGLES TO A* = L AND B* = M CAN BE FOUND AS COMPLEMENTS OF THE
C * INTERFACIAL ANGLES TO 100 AND 010 - FORMULA OF INT. TAB. II, 106
C * N-A*(L) IS OX - N DIRECTLY
C * FOR OY - N CONSIDER SPHERICAL TRIANGLE N - A* - B*.  SIDES GAMMA*
C * AND L AND M.    ANGLE N - B*-A* = D COMES FROM STANDARD FORMULA.
C * SO IN TRIANGLE N - B* - Y, KNOWN ANGLES ARE M, 180-D, 90-GAMMA*,
C * AND THIS IS SOLUBLE FOR N - Y
      IENPL = - 5
      DO I = 1, NFACES
        IENPL = IENPL + 6
        XH    = DBLE (PMILL(I, 1))
        XK    = DBLE (PMILL(I, 2))
        XL    = DBLE (PMILL(I, 3))
        DA    = DBLE (PMILL(I, 5))
        QHKL  =  SQRT (
     1   (XH * DBLE (PAR(135)))**2 + (XK * DBLE (PAR(136)))**2
     2 + (XL * DBLE (PAR(137)))**2
     3       + 2 * XK * XL * BCCAS + 2 * XL * XH * CACBS
     4       + 2 * XH * XK * ABCGS)
        CPZ  = XL / (DBLE (PAR(243)) * QHKL)
        CPX  = (XH * DBLE (PAR(135))**2 + XL * CACBS + XK * ABCGS) /
     1          (QHKL * DBLE (PAR(135)))
        CPBS = (XK * DBLE (PAR(136))**2 + XL * BCCAS + XH * ABCGS) /
     1          (QHKL * DBLE (PAR(136)))
        SINPBS = SQRT(ABS(1 - CPBS**2 ))
C * FIRST FIND ANGLE D, IF N COINCIDES WITH B* THEN D IS INDETERMINATE
        IF (ABS (SINPBS) < 1.0D-6) THEN
          CPY = CPBS * SINGS
        ELSE
          CPD = (CPX - COSGS * CPBS) / (SINPBS * SINGS)
C * ITS COMPLEMENT JUST HAS NEGATIVE COSINE
          CPY = CPBS * SINGS - SINPBS * COSGS * CPD
        END IF
        RSTK(IENPL    ) = CPX
        RSTK(IENPL + 1) = CPY
        RSTK(IENPL + 2) = CPZ
        RSTK(IENPL + 3) = DA
      END DO
C * END OF LOOP FOR PLANES CALCULATION
C * INITIALISE POINTERS
C * TEMP STORAGE AT END OF ARRAY
      NPP   = NTMP
      ISTNV = IENPL + 6
      INV   = ISTNV - 10
      NFMX  = IENPL
      NFMX1 = IENPL - 6
      NFMX2 = NFMX1 - 6
C * FIRST FACE
      DO I = 1, NFMX2, 6
        AI  = RSTK(I)
        BI  = RSTK(I + 1)
        CI  = RSTK(I + 2)
        DI  = RSTK(I + 3)
        IP1 = I + 6
C * SECOND FACE
        DO J = IP1, NFMX1, 6
          AJ  = RSTK(J)
          BJ  = RSTK(J + 1)
          CJ  = RSTK(J + 2)
          DJ  = RSTK(J + 3)
          AIJ = BI * CJ - BJ * CI
          BIJ = CI * AJ - CJ * AI
          CIJ = AI * BJ - AJ * BI
          DEN = AIJ * AIJ + BIJ * BIJ + CIJ * CIJ
          IF (DEN /= 0) THEN
            DA  = DI * AJ - DJ * AI
            DB  = DI * BJ - DJ * BI
            DC  = DI * CJ - DJ * CI
            XAR = (DB * CIJ - DC * BIJ) / DEN
            YAR = (DC * AIJ - DA * CIJ) / DEN
            ZAR = (DA * BIJ - DB * AIJ) / DEN
            JP1 = J + 6
C * THIRD FACE
            DO 30 K = JP1, NFMX, 6
              DEN = RSTK(K) * AIJ + RSTK(K + 1) * BIJ
     1            + RSTK(K + 2) * CIJ
              IF (DEN /= 0) THEN
                SH = (RSTK(K + 3) - RSTK(K) * XAR - RSTK(K + 1) * YAR
     1             - RSTK(K + 2) * ZAR) / DEN
                XP = XAR + SH * AIJ
                YP = YAR + SH * BIJ
                ZP = ZAR + SH * CIJ
                NF = 2
C * FURTHER FACES - REALITY OF VERTEX
                DO 20 NU = 1, NFMX, 6
                  IF (NU /= I .AND. NU /= J .AND. NU /= K) THEN
                    DIST = RSTK(NU + 3) - RSTK(NU) * XP
     1                   - RSTK(NU + 1) * YP - RSTK(NU + 2) * ZP
                    IF (DIST > 1.0D-7) THEN
                      GO TO 20
                    ELSE IF (DIST == 1.0D-7) THEN
                      GO TO 10
                    END IF
                    IF (DIST < -1.0D-7) GO TO 30
   10               IF (NU <= K) GO TO 30
C * OTHERWISE WE HAVE THIS VERTEX ALREADY
                    NF = NF + 1
                    ISTK(NPP - NF) = NU
                  END IF
   20           CONTINUE
C * STORE FIRST FACES
                ISTK(NPP)     = I
                ISTK(NPP - 1) = J
                ISTK(NPP - 2) = K
C * STORE VERTICES
                INV           = INV + 10
                RSTK(INV)     = XP
                RSTK(INV + 1) = YP
                RSTK(INV + 2) = ZP
C * THESE MUST BE THE TRUE LOCATIONS AFTER RE-STORING
                ISTK(INV + 4) = ISTNV + NTMP - NPP
                ISTK(INV + 5) = ISTK(INV + 4) + NF
                NPP           = NPP - NF - 1
              END IF
   30       CONTINUE
          END IF
        END DO
      END DO
C * ASSIGN SPACE FOR EDGES, USING EULERS RULE
      IENNV = ISTNV  + NTMP - NPP - 1
      ISTED = IENNV  + 1
      JNK   = (IENPL + 5) / 6
      JNK1  = (INV   + 10 - ISTNV) / 10
      IENED = JNK    + JNK1 - 2
      IENED = ISTED  + (IENED - 1) * 6
      ISTVT = IENED  + 6
      IENVT = ISTVT  + (JNK1 - 1) * 10
      I     = IENVT  + 9
      J     = INV    + 9
C * -1 BECAUSE K RUNS 1 TO 3 NOT 0 TO 2
   40 I = I - 10
      J = J - 10
      IF (I - ISTVT >= -1) THEN
        DO K = 1, 3
          RSTK(I + K) = RSTK(J + K)
        END DO
        ISTK(I + 5) = ISTK(J + 5)
        ISTK(I + 6) = ISTK(J + 6)
        GO TO 40
      END IF
C * TRANSFER NV LIST
      J = NTMP
      DO I = ISTNV, IENNV
        ISTK(I) = ISTK(J)
        J       = J - 1
      END DO
C * AN EDGE BETWEEN TWO VERTICES WITH TWO FACES IN COMMON
      INED = ISTED - 6
      NFMX = IENVT - 10
      II = 0
      DO I = ISTVT, NFMX, 10
        II = II + 1
        NFMX1 = ISTK(I + 4)
        NFMX2 = ISTK(I + 5)
        JNK   = I + 10
        JJ    = II
        DO 50 J = JNK, IENVT, 10
          JJ  = JJ + 1
          NPP = ISTK(J + 4)
          NF  = ISTK(J + 5)
          M   = 0
          DO K = NFMX1, NFMX2
            JUN1 = ISTK(K)
            DO L = NPP, NF
              JUN11 = ISTK(L)
              IF (JUN1 == JUN11) THEN
                IF (M <= 0) THEN
                  M = 1
                  NMEM = JUN11
                ELSE
C * SUCCESS
                  INED           = INED + 6
                  ISTK(INED)     = NMEM
                  ISTK(INED + 1) = JUN1
                  ISTK(INED + 2) = I
                  ISTK(INED + 3) = J
                  NMEM = 1 + (NMEM - 1) / 6
                  JUN1 = 1 + (JUN1 - 1) / 6
                  GO TO 50
                END IF
              END IF
            END DO
          END DO
   50   CONTINUE
      END DO
C * CHECK CORRECT NO OF EDGES
      IF (INED /= IENED) THEN
        WRITE (LU6, 99997, IOSTAT = IOST)
        WRITE (LU7, 99997, IOSTAT = IOST)
        IENPL = 0
      END IF
      IF (IENPL > 0) THEN
        VM = 0.0D+0
        RM = 0.0D+0
        DO I = 1, 3
          D(I + 3) = 0.0D+0
          D(I)     = 0.0D+0
        END DO
        DO I = ISTVT, IENVT, 10
          DO J = 1, 3
            VT = RSTK(I + J - 1)
            IF (D(J) > VT) THEN
              D(J) = VT
            ELSE IF (D(3 + J) < VT) THEN
              D(3 + J) = VT
            END IF
          END DO
        END DO
        DO I = 1, 3
          VT = D(3 + I) - D(I)
          IF (RM <  VT)       RM =  VT
          IF (VM <  D(3 + I)) VM =  D(3 + I)
          IF (VM < -D(I))     VM = -D(I)
        END DO
C * NOW RESCALE
        VMUL = 1.0D+0 / VM
        DO I = 1, IENPL, 6
          RSTK(I + 3) = RSTK(I + 3) * VMUL
        END DO
        JNK = ISTVT - 1
        DO I = JNK, IENVT, 10
          DO J = 1, 3
            RSTK(I + J) = RSTK(I + J) * VMUL
          END DO
        END DO
        VOLM = 1.0D+0 / (6.0D+0 * VMUL * VMUL * VMUL)
        CALL PLA194 (1)
C * CALL DETERMINES VOLUME ONLY (ALTERED FROM ORIG, NOT RESCALED IN SUBR.
        VT = VT * VOLM
        TT = 1.0D+0
        WRITE (LU7, 99993, IOSTAT = IOST) VT
        VA  = 0.1D-2 * VT
        VV1 = VT - VA
        VV2 = VT + VA
        AMU = AMU / VMUL
        CALL PLA262 (0)
        IF (IGBL(57) > 0) THEN
          CALL PLA262 (2)
C * SHELX(L) INPUT DATA HAS F AND SIGMA(F) - TREAT AS SUCH
          IF (IPR(648) == 3) THEN
            WRITE (LU7, 99995, IOSTAT = IOST) '   F', '   Sig(F)'
C * SHELX(L) INPUT DATA HAS F**2 AND SIGMA(F**2) - TREAT AS SUCH
          ELSE IF (IPR(648) == 4) THEN
            WRITE (LU7, 99995, IOSTAT = IOST) 'F**2', 'Sig(F**2)'
          END IF
        END IF
        I1   = IHLP(NBEG) - 13
        DO
          I1   = I1 + 14
          JA   = NINT (VOID(I1))
          IF (JA /= - 1000) THEN
            KA   = NINT (VOID(I1 + 1))
            LA   = NINT (VOID(I1 + 2))
            FREL = DBLE (VOID(I1 + 3))
            SIGF = DBLE (VOID(I1 + 4))
            C1   = DBLE (VOID(I1 + 5))
            C2   = DBLE (VOID(I1 + 6))
            C3   = DBLE (VOID(I1 + 7))
            C4   = DBLE (VOID(I1 + 8))
            C5   = DBLE (VOID(I1 + 9))
            C6   = DBLE (VOID(I1 + 10))
C * DIRECTION COSINES OF INCIDENT AND REVERSED
C * TRANSFORM FROM SHELX TO TOMPA STYLE DIRECTION COSINES
C * DIFFRACTED RAYS IN CX(1), CY(1), CZ(1), CX(2), CY(2), CZ(2)
            CX(1) = - C1
            CX(2) = - C2
            C3    =  (C3 - C1 * COSGS) / SINGS
            C4    =  (C4 - C2 * COSGS) / SINGS
            CY(1) = - C3
            CY(2) = - C4
            CZ(1) = -(C5 - C1 * COSBS + C3 * SINBS * COSA)
     1            / (SINBS * SINA)
            CZ(2) = -(C6 - C2 * COSBS + C4 * SINBS * COSA)
     1            / (SINBS * SINA)
            IERR  = 2
            CALL PLA194 (2)
            VT = VT * VOLM
            IF (TT > 0.9995D0) THEN
              TT = 1.0D+0
              IF (TT < 1.0D0) THEN
                IF (TT > 0) THEN
                  IF (VT <= VV2) THEN
                    IF (VV1 <= VT) GO TO 60
                  END IF
                  IF (TT > 0.999D0) THEN
                    TT = 1.0D+0
                    IERR = 2
                  ELSE
                    IERR = 1
                    ITX = 'VOLUME  '
                    GO TO 60
                  END IF
                END IF
              END IF
              IF (TT > 0.999D0) THEN
                TT = 1.0D+0
                IERR = 2
              ELSE
                ITX = 'TRANS.'
                TT  = ABS (TT)
                IF (TT < 0.01D0) TT = 0.1D-1
                IERR = 1
              END IF
            END IF
C * ERROR MONITOR IF ERROR FLAG SET
   60       IF (IERR == 1) THEN
              GO TO 70
            ELSE IF (IERR == 2) THEN
              GO TO 80
            END IF
   70       CALL PLA262 (1)
            WRITE (LU7, 99992, IOSTAT = IOST) JA, KA, LA, TT, VT, ITX
   80       IF (IPR(648) == 3) THEN
C * CORRECTS F & SIG(F)
              FREL = FREL / SQRT (TT)
              SIGF = SIGF / SQRT (SQRT (TT))
            ELSE IF (IPR(648) == 4) THEN
C * CORRECTS F**2 & SIGMA
              FREL = FREL / TT
              SIGF = SIGF / TT
            ENDIF
            VOID(I1 + 11) = SNGL (TT)
            IF (IGBL(57) > 0) THEN
              CALL PLA262 (1)
              WRITE (LU7, 99994, IOSTAT = IOST)
     1          JA, KA, LA, FREL, SIGF, TT, VT
            END IF
          ELSE
            EXIT
          END IF
        END DO
        WRITE (LU7, 99996, IOSTAT = IOST) MAXUTL
      END IF
      RETURN
99999 FORMAT ('Analytical Absorption Correction Program', /, 80('-'),
     1  /, '(see. N.W. Alcock (1970). Cryst. Computing, p271)', /)
99998 FORMAT (':: Mu = ', F8.3, ' mm(-1)', /)
99997 FORMAT (':: Crystal not Finite - Additional Bounding Planes ',
     1        'Needed')
99996 FORMAT (/, ':: Array Size Needed = ', I5)
99995 FORMAT (3X, 'H   K   L', 7X, A, 5X, A, 5X, 'Transmission', 6X,
     1       'Volume (mm3)', /, '   -   -   -', 7X, '----', 5X, 9('-'),
     2       5X, 12('-'), 6X, 12('-'))
99994 FORMAT (3I4, 2F12.2, 4X, F12.5, 7X, F14.11)
99993 FORMAT (/, 'Crystal Volume =', 2X, F14.11, ' mm3', //)
99992 FORMAT (3I4, ' Transm ', E12.5, ' Volume ', F12.6, 1X, A,
     1        ' in Error')
      END SUBROUTINE PLA193
 
      SUBROUTINE PLA194 (IZ)
C * ABSTOMPA (2)
      USE files
      USE tompa
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: M
      INTEGER                :: K5
      INTEGER                :: J2
      INTEGER                :: J3
      INTEGER                :: J4
      INTEGER                :: J5
      INTEGER                :: J6
      INTEGER                :: J7
      INTEGER                :: J8
      INTEGER                :: I0
      INTEGER                :: IZ
      INTEGER                :: LA
      INTEGER                :: LB
      INTEGER                :: JA
      INTEGER                :: JB
      INTEGER                :: IP
      INTEGER                :: IQ
      INTEGER                :: IT
      INTEGER                :: IT2
      INTEGER                :: IPC
      INTEGER                :: JPC
      INTEGER                :: JSK
      INTEGER                :: IND
      INTEGER                :: NPER
      INTEGER                :: LRETX
      INTEGER, DIMENSION(6)  :: NE
      DOUBLE PRECISION       :: TX
      DOUBLE PRECISION, SAVE :: VZ
      DOUBLE PRECISION       :: DE2
      DOUBLE PRECISION       :: DEN
      DOUBLE PRECISION       :: FRP
      DOUBLE PRECISION, SAVE :: FLIM
C * MAJOR STORAGE ARRAY IS RSTK/ISTK.  THIS IS IN GROUPS
C * 1 TO IENPL(6) IS PLANES
C * +0,1,2,3 = X,Y,Z,D FOR PLANE
C * +4,5   = 1/-1 FOR LIT/SHADED IN DIR 1/2
C * ISTNV TO IENNV (NVLIST) HAS FACES OF EACH VERTEX. SEE BELOW
C * ISTED TO IENED(6) IS EDGES
C * +0,1   = TWO CONTRIBUTING FACES
C * +2,3   = TWO CONTRIBUTING VERTICES
C * +4,5   = 1/0/-1 FOR LIT/EDGE/SHADED IN DIR 1/2
C * ISTVT TO IENPT(10) IS POINTS (IENVT WITHIN THIS ENDS VERTICES)
C * STORAGE DIFFERS FOR EACH TYPE OF POINT, BUT 0-3 ARE CONSTANT
C * +0,1,2 = X,Y,Z COORDINATES
C * +3     = RHO, THE DISTANCE*MU TO IT FROM ITS SHADING FACE(S)
C *  VERTICES
C * +4,5   = FIRST(4) AND LAST(5) LOCATION IN NVLIST OF FACES ROUND
C *          THIS VERTEX
C * +6,7   = LOCATION FOR SP0(6) OR SQ0(7) POINT
C * +8,9   = NO OF FACE SHADING IT IN DIR 1/2
C *  POINTS SP0 OR SQ0
C * +4     = FACE CONTAINING IT
C * +5     = POSSIBLE FACE SHADING IT
C * +6     = 1 FOR SP0, 2 FOR SQ0
C *  POINTS SPQ
C * +4     = EDGE GENERATING IT
C * +6     = 3 FOR S12, 4 FOR S21
C *  POINTS S0P (S0Q)
C * +4     = EDGE GENERATING IT
C * +5     = EDGE CONTAINING IT
C * +6     = ZERO
C * +7     = FACE SHADING IT IN DIRECTION Q
C *   POINTS S00
C * +4     = EDGE GENERATING IT FROM DIRECTION P
C * +5     = EDGE GENERATING IT FROM DIRECTION Q
C * THE VOLUME CALCULATION CONTINUES
C * ISTNP TO IENNP FOR LIST OF FACES
C * ISTTR TO IENTR(INCTR) FOR THE TETRAHEDRA
C * +0,1,2 = THREE MINORS
C * +3,4,5 FOR NUMBERS OF THREE FACES
C * OTHER STORAGE
C * D        COLLECTS EQUATION COEFFICIENTS
C * JI,JT    GIVE LIMITS OF SOP STORAGE
C * IL       INDICATES CURRENT TYPE OF POINT
C * NE       GIVES NUMBER OF EACH TYPE OF POINT
C *
C * DOUBLE PRECISION FUNCTIONS NOT NEEDED HERE
C * THIS PROGRAM REALLY MUST BE READ WITH TOMPA'S MANUAL
C * OR WITH HIS PAPER OR WITH THE SUMMARY IN' CRYSTALLOGRAPHIC COMPUTING'
      JSK = 0
      DE2 = 0
      J   = 0
C * HERE JUST TO FIND VOLUME.  NB. THESE FORM PART OF THE PRELIM ASSIGNS
      IF (IZ == 1) THEN
        IEX   = 1
        ISK   = 1
        ISK2  = 1
        VT    = 0.0D+0
        IENPT = IENVT
        ISTNP = IENVT + 10
        IENNP = ISTNP - 1
        DO I = ISTVT, IENVT, 10
          IENNP       = IENNP + 1
          ISTK(IENNP) = I
        END DO
        GO TO 220
      END IF
C * HERE FOR MAIN CALC
C * LABEL B IN BLOCK A
C * ENTRY POINT WITH DIR COSINES
C * INITIALISE AND THEN DISCOVER WHICH EDGES ARE LIT OR SHADED
      DO I = 1, 6
        NE(I) = 0
      END DO
      DE2    = 0
      DEV(2) = 0
      VT     = 0.0D+0
      TT     = 0
      IL     = 1
      IENPT  = IENVT
      DO IP = 1, 2
        DO I = 1, IENPL, 6
C * TEST FACES IF IN LIGHT OR SHADE
          DEN = RSTK(I) * CX(IP) + RSTK(I + 1) * CY(IP)
     1        + RSTK(I + 2) * CZ(IP)
C * THIS CALCS. THE ANGLE BETWEEN THE RAY AND THE FACE NORMAL.
C * REMEMBER THE ORIGIN IS WITHIN THE CRYSTAL
          IF (DEN < 0.0D0) THEN
C * FACES SHADED IF ON EDGE
            ISTK(I + IP + 3) = 1
          ELSE
            ISTK(I + IP + 3) = -1
          END IF
        END DO
        DO I = ISTED, IENED, 6
C * TEST EDGES IF IN LIGHT OR SHADE
C * LIT IF BOTH FACES LIT, OR SHADED IF NEITHER. OTHERWISE ON EDGE.
          JA  = ISTK(I)
          JB  = ISTK(I + 1)
          IND = ISTK(JA + IP + 3) + ISTK(JB + IP + 3)
          IF (IND < 0) THEN
            ISTK(I + IP + 3) = -1
          ELSE IF (IND == 0) THEN
            ISTK(I + IP + 3) = 0
          ELSE
            ISTK(I + IP + 3) = 1
          END IF
        END DO
      END DO
C * IN B FINDS POINTS SP0.  IN C POINTS SPQ. FOR ALL LIT VERTICES
C * AND FOR BOTH RAY DIRECTIONS
C * BLOCK B
      IENPT = IENVT
      DO 20 IP = 1, 2
        JNK1 = IP
        IQ   = 3 - IP
        DO 10 J = ISTVT, IENVT, 10
          JNK = J
C * KEEP THESE JNK AND JNK1 IN THIS LOOP
          ISTK(J + IP + 5) = 0
          ISTK(J + IP + 7) = 0
          IF (IP == 1) RSTK(J + 3) = 0.0D+0
          M  = ISTK(J + 4)
          LA = ISTK(J + 5)
C * LIST OF FACES
          LB = ISTK(M)
          NC = ISTK(LB + IP + 3)
C * FIRST FACE IS THIS.  ALL OTHERS MUST AGREE
          M = M + 1
          DO J5 = M, LA
            LB = ISTK(J5)
            IF (NC /= ISTK(LB + IP + 3)) GO TO 10
C * IF VERTEX IS ON BOUNDARY NO ACTION TO 10
          END DO
          IF (NC < 0) THEN
            ND = 1
C * SHADED VERTEX
            CALL PLA195 (DEN)
            RSTK(J + 3) = RSTK(J + 3) + DEN * AMU
C * NO OF FACE SHADING IT
            ISTK(J + IP + 7) = NC
          ELSE IF (NC == 0) THEN
            GO TO 20
          ELSE
            ND = -1
C * VERTEX IN LIGHT FIND ITS SPO
            CALL PLA195 (DEN)
            NE(IL) = NE(IL) + 1
            IENPT  = IENPT + 10
C * STORE NO OF SPO FOR VERTEX
            ISTK(J + IP + 5) = IENPT
C * CONTAINING FACE FOR SPO
            ISTK(IENPT + 4) = NC
C * IDENTIFICATION
            ISTK(IENPT + 6) = IL
            ISTK(IENPT + 5) = 0
C * CLEAR REST TO ZERO. STRICTLY NOT ESSENTIAL, BUT HELPS DIAGNOSTICS
            ISTK(IENPT + 7) = 0
            ISTK(IENPT + 8) = 0
            ISTK(IENPT + 9) = 0
C * COORDINATES AND R VALUE
            RSTK(IENPT)     = RSTK(J)     + DEN * CX(IP)
            RSTK(IENPT + 1) = RSTK(J + 1) + DEN * CY(IP)
            RSTK(IENPT + 2) = RSTK(J + 2) + DEN * CZ(IP)
            FRP = DEN
            RSTK(IENPT + 3) = DEN * AMU
C * IS IT SHADED IN DIRECTION Q
            IF (ISTK(NC + IQ + 3) == -1) THEN
              ND   = 1
              JNK  = IENPT
              JNK1 = IQ
              CALL PLA195 (DEN)
              JNK1 = IP
              JNK  = J
C * STORE SHADING FACE AND R
              ISTK(IENPT + 5) = NC
              RSTK(IENPT + 3) = (FRP + DEN) * AMU
            END IF
C * THIS IS BLOCK C SEARCH FOR POINTS SPQ
            IL = IL + 2
            DO K = ISTED, IENED, 6
              IF (ISTK(K + IQ + 3) == 1) THEN
C * A POSSIBLE EDGE. COMPUTE DELTAS WITH S=1, SE1=3,SE2=4
                IB(1) = J
                IB(2) = J
                IB(3) = ISTK(K + 2)
                IB(4) = ISTK(K + 3)
                CALL PLA196
C * ASSEMBLE EQU COEFFICIENTS
                D(10) = - D(3)
C * THESE DETERMINE THE INTERSECTION OF THE RAY WITH THE PLANE THROUGH
C * ANY EDGE
                D(11) = - D(6)
                D(12) = - D(9)
                D(7)  = - D(2)
                D(9)  = - D(8)
                D(8)  = - D(5)
                D(1)  =   CX(IP)
                D(2)  =   CY(IP)
                D(3)  =   CZ(IP)
                D(4)  = - CX(IQ)
                D(5)  = - CY(IQ)
                D(6)  = - CZ(IQ)
C * FOR EQUATION SOLUTIONS
                CALL GEN157 (D, 3)
C * RETURNS WITH D1 TO D4 = 4 DETERMINANTS(NMP,NMQ,NM,DN)
                NC = 1
                IF (ABS (D(4)) > 1.D-9) THEN
                  DEN = D(3) / D(4)
                  IF (DEN >= - 0.00001D0) THEN
                    IF (1.00001D0 >= DEN) THEN
                      NC = 0
C * A VALID SOLUTION, K LESS THAN 1
                      IF (D(1) /= 0) THEN
C * NOT COINCIDENT WITH VERTEX. OTHERWISE USED ANYWAY
C * THIS IS A NEW TEST.  IT REDUCES THE NUMBER OF POINTS.
                        DEN = D(1) / D(4)
                        IF (DEN > 0) THEN
                          IF (DEN <= FRP) THEN
C * THE INTERSECTION OF EDGE PLANE AND RAY IS WITHIN THE CRYSTAL.
                            NE(IL)          = NE(IL) + 1
                            IENPT           = IENPT  + 10
                            RSTK(IENPT)     = RSTK(J)     + DEN * CX(IP)
                            RSTK(IENPT + 1) = RSTK(J + 1) + DEN * CY(IP)
                            RSTK(IENPT + 2) = RSTK(J + 2) + DEN * CZ(IP)
                            TX              = D(2) / D(4)
                            RSTK(IENPT + 3) = (DEN + TX) * AMU
C * STORE EDGE CONTAINING AN SPQ AND ITS IDENTIFICATION
                            ISTK(IENPT + 4) = K
                            ISTK(IENPT + 5) = 0
                            ISTK(IENPT + 6) = IL
C * CLEAR
                            ISTK(IENPT + 7) = 0
                            ISTK(IENPT + 8) = 0
                            ISTK(IENPT + 9) = 0
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END DO
            IL = IL - 2
          END IF
  10    CONTINUE
        IL = IL + 1
  20  CONTINUE
C * THIS IS BLOCK D FOR POINTS SOP
      ND = 1
      IL = IL + 2
      DO IP = 1, 2
        JI(IP) = IENPT + 10
        IQ     = 3 - IP
        JNK1   = IQ
        DO K = ISTED, IENED, 6
          IF (ISTK(K + IP + 3) == 1) THEN
C * EDGE LIT
            DO K5 = ISTED, IENED, 6
C * 2ND EDGE SHADED
              IF (ISTK(K5 + IP + 3) == -1) THEN
                IB(1) = ISTK(K  + 2)
                IB(2) = ISTK(K  + 3)
                IB(3) = ISTK(K5 + 2)
                IB(4) = ISTK(K5 + 3)
C * USES FOUR VERTICES OF EDGES
                CALL PLA196
                D(10) = D(3)
                D(11) = D(6)
                D(12) = D(9)
                D(3)  = D(7)
                D(6)  = D(8)
                TX    = D(2)
                D(2)  = D(4)
                D(4)  = TX
                D(7)  = - CX(IP)
                D(8)  = - CY(IP)
                D(9)  = - CZ(IP)
                CALL GEN157 (D, 3)
                NC = 1
                IF (ABS (D(4)) > 1.D-9) THEN
                  DEN = D(1) / D(4)
                  IF (DEN >= - 0.00001D0) THEN
                    IF (1.00001D0 >= DEN) NC = 0
                  END IF
                END IF
                IF (NC == 0) THEN
                  NC = 1
                  IF (ABS (D(4)) > 1.D-9) THEN
                    TX = D(2) / D(4)
                    IF (TX >= - 0.00001D0) THEN
                      IF (1.00001D0 >= TX) NC = 0
                    END IF
                  END IF
                  IF (NC == 0) THEN
C * BOTH K.S LESS THAN 1
                    IENPT = IENPT + 10
                    RSTK(IENPT    ) = RSTK(IB(4)    )
     1                + TX * (RSTK(IB(3)    ) - RSTK(IB(4)    ))
                    RSTK(IENPT + 1) = RSTK(IB(4) + 1)
     1                + TX * (RSTK(IB(3) + 1) - RSTK(IB(4) + 1))
                    RSTK(IENPT + 2) = RSTK(IB(4) + 2)
     1                + TX * (RSTK(IB(3) + 2) - RSTK(IB(4) + 2))
                    TX = D(3) / D(4)
                    RSTK(IENPT + 3) = TX * AMU
C * STORE FOR SOP EDGES GENERATING AND CONTAINING IT
                    ISTK(IENPT + 4) = K
                    ISTK(IENPT + 5) = K5
                    ISTK(IENPT + 6) = 0
                    ISTK(IENPT + 7) = 0
C * CLEAR
                    ISTK(IENPT + 8) = 0
                    ISTK(IENPT + 9) = IL
C * SHADED FROM OTHER DIR
                    IF (ISTK(K5 + IQ + 3) == -1) THEN
                      JNK = IENPT
                      CALL PLA195 (TX)
                      RSTK(IENPT + 3) = RSTK(IENPT + 3) + TX * AMU
C * STORE FACE SHADING IT
                      ISTK(IENPT + 7) = NC
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END IF
        END DO
        JT(IP) = IENPT
        IL     = IL + 1
      END DO
C * THIS IS BLOCK E POINTS S00
      DO 100 I = 1, IENPL, 6
C * FOR ALL FACES SHADED IN BOTH DIRS
        IF (ISTK(I + 4) + ISTK(I + 5) == -2) THEN
          IP  = 1
          IPC = 0
C * TESTS ALL EDGES WITH 1ST DIR AND FOR EVERY HIT EACH EDGE IN OTHER
          K      = ISTED
   30     IE(IP) = 2
          JPC    = 0
          IF(ISTK(K + IP + 3) /= 1) GO TO 70
C * EDGE LIT
          J = JI(IP)
   40     IF (J <= JT(IP)) THEN
            IF (ISTK(J + 4) == K) THEN
C * SOP IS GENERATED BY EDGE
              IT = ISTK(J + 5)
C * IS IT IN THE RIGHT FACE
              IF (I /= ISTK(IT)) THEN
                IF (I /= ISTK(IT + 1)) GO TO 50
              END IF
              IF (JPC <= 0) THEN
C * FIRST POINT
                JPC         = 1
                ND          = J
                IB(IPC + 1) = J
                GO TO 50
              END IF
C * SECOND POINT, BUT IS IT DIFFERENT
              NF          = J
              IB(IPC + 2) = J
C * NEGLIGIBLE DIFFERENCE IN TWO COORDINATES, COMPARES POINTS AT ND AND NF
C * NC = 0 IF IDENTICAL, 1 OTHERWISE
              NC = 1
              IF (ABS(RSTK(ND) - RSTK(NF)) <= 0.3D-4) THEN
                IF (ABS(RSTK(ND + 1) - RSTK(NF + 1)) <= 0.3D-4) THEN
                  IF (ABS(RSTK(ND + 2) - RSTK(NF + 2)) <= 0.3D-4)
     1               NC = 0
                END IF
              END IF
              IF (NC > 0) GO TO 80
            END IF
   50       J = J + 10
            GO TO 40
          END IF
C * TEST VERTICES OF EDGE
          DO M = 2, 3
            J   = ISTK(K + M)
            IND = ISTK(J + 4)
            IT  = ISTK(J + 5)
            DO IT2 = IND, IT
C * IS VERTEX IN FACE
              IF (ISTK(IT2) == I) THEN
                IF (JPC <= 0) THEN
                  JPC         = 1
                  ND          = J
                  IB(IPC + 1) = J
                  GO TO 60
                END IF
                NF          = J
                IB(IPC + 2) = J
C * NEGLIGIBLE DIFFERENCE IN TWO COORDINATES, COMPARES POINTS AT ND AND NF
                IF (ABS (RSTK(ND) - RSTK(NF)) <= 0.3D-4) THEN
                  IF (ABS (RSTK(ND + 1) - RSTK(NF + 1)) <= 0.3D-4)
     1               THEN
                    IF (ABS (RSTK(ND + 2) - RSTK(NF + 2)) <= 0.3D-4)
     1                GO TO 60
                  END IF
                END IF
                GO TO 80
              END IF
            END DO
   60       IT = ISTK(J + IP + 5)
            IF (IT > 0) THEN
C * IS SPO OF VERTEX IN FACE
              IF (ISTK(IT + 4) == I) THEN
                IF (JPC > 0) THEN
                  NF          = IT
                  IB(IPC + 2) = IT
C * NEGLIGIBLE DIFFERENCE IN TWO COORDINATES, COMPARES POINTS AT ND AND NF
C * NC = 0 IF IDENTICAL, 1 OTHERWISE
                  NC = 1
                  IF (ABS (RSTK(ND) - RSTK(NF)) <= 0.3D-4) THEN
                    IF (ABS (RSTK(ND + 1) - RSTK(NF + 1)) <= 0.3D-4)
     1                THEN
                      IF (ABS (RSTK(ND + 2) - RSTK(NF + 2)) <= 0.3D-4)
     1                   NC = 0
                    END IF
                  END IF
                  IF (NC > 0) GO TO 80
                ELSE
                  JPC         = 1
                  ND          = IT
                  IB(IPC + 1) = IT
                END IF
              END IF
            END IF
          END DO
C * THIS IS LABEL S1
          IF (JPC > 0) THEN
            IE(IP) = 1
C * HAVE FOUND ONE POINT
            GO TO 80
          END IF
   70     K = K + 6
          IF (K <= IENED) GO TO 30
          IF (IP /= 2) GO TO 100
          IP  = 1
          IPC = 0
          K   = JSK
          GO TO 70
   80     IF (IP <= 1) THEN
            JSK = K
            K   = ISTED
            IP  = 2
            IPC = 2
            GO TO 30
          END IF
C * FINAL PART OF BLOCK E TO CALC COORDS OF POINTS
C * THIS IS LABEL T
          IF (K == JSK) GO TO 70
          IF (IE(1) == 2) THEN
            IF (IE(2) == 2) THEN
              CALL PLA196
              D(10) = D(1) * D(1) + D(4) * D(4) + D(7) * D(7)
              D(11) = D(1) * D(2) + D(4) * D(5) + D(7) * D(8)
              D(12) = D(1) * D(3) + D(4) * D(6) + D(7) * D(9)
              D(1)  = D(10)
              D(10) = D(2) * D(3) + D(5) * D(6) + D(8) * D(9)
              FRP   = D(2) * D(2) + D(5) * D(5) + D(8) * D(8)
              D(2)  = D(11)
              D(3)  = D(11)
              D(4)  = FRP
              D(5)  = D(12)
              D(6)  = D(10)
              CALL GEN157 (D, 2)
C * RETURNS WITH D(1 TO 3) = 3 DETERMINANTS
              NC = 1
              IF (ABS (D(3)) > 1.D-9) THEN
                DEN = D(1) / D(3)
                IF (DEN >= - 0.1D-4) THEN
                  IF (1.00001D0 >= DEN) NC = 0
                END IF
              END IF
              IF (NC /= 0) GO TO 70
              NC = 1
              IF (ABS (D(3)) > 1.D-9) THEN
                DEN = D(2) / D(3)
                IF (DEN >= - 0.1D-4) THEN
                  IF (1.00001D0 >= DEN) NC = 0
                END IF
              END IF
              IF (NC /= 0) GO TO 70
              IENPT = IENPT + 10
              RSTK(IENPT)     = RSTK(IB(4))     + DEN * (RSTK(IB(3))
     1                        - RSTK(IB(4)))
              RSTK(IENPT + 1) = RSTK(IB(4) + 1) + DEN * (RSTK(IB(3) + 1)
     1                        - RSTK(IB(4) + 1))
              RSTK(IENPT + 2) = RSTK(IB(4) + 2) + DEN * (RSTK(IB(3) + 2)
     1                        - RSTK(IB(4) + 2))
              GO TO 90
            END IF
          END IF
C * MUST HAVE FOUND AT LEAST ONE POINT IN EACH DIR, TO BE HERE
          JNK = IE(1)
          DO JA = 1, JNK
            ND = IB(JA)
            JNK1 = IE(2)
            DO JB = 1, JNK1
              NF = IB(2 + JB)
              IF (ABS (RSTK(ND) - RSTK(NF)) <= 0.3D-4) THEN
                IF (ABS (RSTK(ND + 1) - RSTK(NF + 1)) <= 0.3D-4) THEN
                  IF (ABS (RSTK(ND + 2) - RSTK(NF + 2)) <= 0.3D-4)
     1              THEN
                    IENPT           = IENPT + 10
                    RSTK(IENPT)     = RSTK(ND)
                    RSTK(IENPT + 1) = RSTK(ND + 1)
                    RSTK(IENPT + 2) = RSTK(ND + 2)
                    GO TO 90
                  END IF
                END IF
              END IF
            END DO
          End DO
          GO TO 70
   90     ND   = 1
          JNK  = IENPT
          JNK1 = 1
          CALL PLA195 (DEN)
          JNK1 = 2
          CALL PLA195 (TX)
          RSTK(IENPT + 3) = (DEN + TX) * AMU
          ISTK(IENPT + 4) = JSK
          ISTK(IENPT + 5) = K
          ISTK(IENPT + 6) = 0
          ISTK(IENPT + 7) = 0
          ISTK(IENPT + 8) = 0
          ISTK(IENPT + 9) = IL
          GO TO 70
        END IF
  100 CONTINUE
C * THIS IS BLOCK F  TO SELECT THE CORNERS OF POLYHEDRA FOR EACH
C * PAIR OF FACES BOTH LIT
C * IT CONTINUES IN BLOCK G
C * A VERTEX S IS A VERTEC OF THE HOWELLS POLYHEDRON BASED ON A PAIR OF
C * FACES F1 AND F2 IF IT IS IN F1 OR SHADED BY F1 AND IS AT THE SAME TIM
C * IN F2 OR SHADED BY F2.  IF S IS IN F1, ITS ASSOCIATED S10 IS A VERTEX
C * OF THE HOWELLS POLYHEDRON IF IT IS IN F2 OR SHADED BY F2 AND E ERY A
C * ASSOCIATED POINT S12 IS A VERTEX OF THE HOWELLS POLYHEDRON IF IT IS
C * GENERATED BY AN EDGE CONTAINED IN F2.  AND SIMILARLY FOR S20 AND S21.
C * A POINT S01 IS A VERTEX OF THE HOWELLS POLYHEDRON IF IT IS GENERATED
C * BY AN EDGE CONTAINED IN F1 AND IS IN F2 OR IS SHADED BY F2. AND SIMIL
C * ARLY FOR S02.  FINALLY A POINTF S00 IS A VERTEX OF THE HOWELLS
C * POLYHEDRON IF ONE OF THE EDGES CONTAINING IT IS CONTAINED IN F1
C * AND THE OTHER IN F2.
C * THESE DECISIONS ARE PURELY LOGICAL
      I     = 1
      ISTNP = IENPT + 10
  110 IF (ISTK(I + 4) /= 1) GO TO 330
      J     = 1
  120 IB(2) = J
      IB(1) = I
      IF (ISTK(J + 5) /= 1) GO TO 320
      IENNP = ISTNP - 1
      DO J5 = ISTVT, IENVT, 10
        IP = 1
  130   IQ = 3 - IP
        IF (ISTK(J5 + IP + 7) /= IB(IP)) THEN
          JA = ISTK(J5 + 4)
          JB = ISTK(J5 + 5)
          DO J2 = JA, JB
            IF (ISTK(J2) == IB(IP)) GO TO 140
          END DO
          IE(IP) = 1
          GO TO 170
  140     IND = ISTK(J5 + IP + 5)
          IF (IND /= 0) THEN
            IF (ISTK(IND + 5) /= IB(IQ)) THEN
              IF (ISTK(IND + 4) /= IB(IQ)) GO TO 150
            END IF
C * STORING AN SPO
            IENNP = IENNP + 1
            ISTK(IENNP) = IND
  150       JA = ISTK(IND + 6) + 2
  160       IND = IND + 10
            IF (IND <= IENPT) THEN
              IF (ISTK(IND + 6) == JA) THEN
                JB = ISTK(IND + 4)
                IF (ISTK(JB) /= IB(IQ)) THEN
                  IF (ISTK(JB + 1) /= IB(IQ)) GO TO 160
                END IF
C * STORE A POINT SPQ
                IENNP = IENNP + 1
                ISTK(IENNP) = IND
                GO TO 160
              END IF
            END IF
          END IF
        END IF
        IE(IP) = 0
  170   IP     = IP + 1
        IF (IP == 2) GO TO 130
        IF (IE(1) == 0 .AND. IE(2) == 0) THEN
          IENNP       = IENNP + 1
          ISTK(IENNP) = J5
        END IF
      END DO
C * THIS IS BLOCK G TO FIND POINTS SOP SOO CONTRIBUTING
      DO IP = 1, 2
        IQ = 3 - IP
        J6 = JT(IP)
        J5 = JI(IP)
  180   IF (J5 <= J6) THEN
          IND = ISTK(J5 + 4)
          IF (ISTK(IND) /= IB(IP)) THEN
            IF (ISTK(IND + 1) /= IB(IP)) GO TO 190
          END IF
          IF (ISTK(J5 + 7) /= IB(IQ)) THEN
            IND = ISTK(J5 + 5)
            IF (ISTK(IND) /= IB(IQ)) THEN
              IF (ISTK(IND + 1) /= IB(IQ)) GO TO 190
            END IF
          END IF
          IENNP       = IENNP + 1
          ISTK(IENNP) = J5
  190     J5          = J5 + 10
          GO TO 180
        END IF
      END DO
C * NOW WE DO SOO
      J5 = JT(2) + 10
  200 IF (J5 <= IENPT) THEN
        IND = ISTK(J5 + 4)
        IF (ISTK(IND) /= I) THEN
          IF (ISTK(IND + 1) /= I) GO TO 210
        END IF
        IND = ISTK(J5 + 5)
        IF (ISTK(IND) /= J) THEN
          IF (ISTK(IND + 1) /= J) GO TO 210
        END IF
        IENNP       = IENNP + 1
        ISTK(IENNP) = J5
  210   J5          = J5 + 10
        GO TO 200
      END IF
      IF (IENNP - ISTNP <= 2) GO TO 320
C * HERE IS AN ADDITION.  I SEARCH FOR COINCIDENCES IN THE LIST.  THESE
C * OFTEN OCCUR BECAUSE MANY POINTS HAVE MULTIPLE FUNCTIONS.  THEIR
C * ELIMINATION HERE SAVES TIME IN THE NEXT SECTION.
C * JUMP HERE FOR ORIGINAL VOLUME CALC.
  220 J3 = IENNP
  230 J4 = J3 - 1
  240 ND = ISTK(J3)
      NF = ISTK(J4)
C * NEGLIGIBLE DIFFERENCE IN TWO COORDINATES, COMPARES POINTS AT ND AND NF
C * NC = 0 IF IDENTICAL, 1 OTHERWISE
      NC = 1
      IF (ABS (RSTK(ND) - RSTK(NF)) <= 0.3D-4) THEN
        IF (ABS (RSTK(ND + 1) - RSTK(NF + 1)) <= 0.3D-4) THEN
          IF (ABS (RSTK(ND + 2) - RSTK(NF + 2)) <= 0.3D-4) NC = 0
        END IF
      END IF
      IF (NC <= 0) THEN
        J7 = J4
  250   J8 = J7 + 1
        ISTK(J7) = ISTK(J8)
        J7 = J8
        IF (J8 < IENNP) GO TO 250
        J3 = J3 - 1
        IENNP = IENNP - 1
      END IF
      J4 = J4 - 1
      IF (J4 >= ISTNP) GO TO 240
      J3 = J3 - 1
      IF (J3 > ISTNP) GO TO 230
      IF (IENNP - ISTNP <= 2) GO TO 320
C * THIS IS SUBROUTINE VOL, INCORPORATED IN TRANS
      ISTTR = IENNP + 1
      NPER  = ISTNP + 2
C * TAKE FOUR POINTS AND FIND THEIR VOLUME
  260 IENTR = ISTTR - 6
      ND = ISTNP
      NF = ISTNP + 1
      NG = ISTNP + 2
C * TO CALCULATE AND STORE MINORS AND IDENTIFIERS OF FACES
C * THREE COORDINATE POINTERS ARE ND,NF,NG, TO LIST IN ISTNP TO IENNP
      IB(1) = ISTK(ND)
      IB(2) = ISTK(NF)
      IB(3) = ISTK(NF)
      IB(4) = ISTK(NG)
      CALL PLA196
      IENTR           =  IENTR + 6
C * CALL EXIT/STOP
      IF (IENTR + 6 >= NTMP) CALL GEN127 ('INCREASE NTMP')
      ISTK(IENTR + 3) =  ND
      ISTK(IENTR + 4) =  NF
      ISTK(IENTR + 5) =  NG
      RSTK(IENTR    ) =  D(4) * D(9) - D(7) * D(6)
      RSTK(IENTR + 1) = -D(1) * D(9) + D(3) * D(7)
      RSTK(IENTR + 2) =  D(1) * D(6) - D(3) * D(4)
C * CALC VOLUME FROM MINORS AT IENTR + COORDS AT ISTNP+3
      ND = ISTK(ISTNP + 3)
      NF = ISTK(IENTR + 3)
      NF = ISTK(NF)
C * LOCATION OF FIRST COORDINATE OF FACE
      DEN = (RSTK(NF) - RSTK(ND)) * RSTK(IENTR) + (RSTK(NF + 1)
     1    - RSTK(ND + 1)) * RSTK(IENTR + 1) + (RSTK(NF + 2)
     2    - RSTK(ND + 2)) * RSTK(IENTR + 2)
C * BETWEEN THESE LIMITS THE POINTS ARE APPARENTLY COPLANAR
C * WITH A +VE VOLUME WE SIMPLY EXCHANGE TWO POINTS.  N.B. THIS IS DONE
C * USING THE VALUES WHERE THEY ARE KNOWN TO HAVE BEEN STORED.  CARE
      IF (DEN > 1.0D-5) THEN
        ISTK(ISTNP)     = ISTK(ISTNP + 1)
        ISTK(ISTNP + 1) = IB(1)
        GO TO 260
      END IF
      IF (DEN > - 1.0D-5) THEN
        NPER = NPER + 1
C * PERMUTE VERTICES UNTIL FIND A NON-ZERO SET
        IF (NPER > IENNP) GO TO 310
        IQ = ISTNP + 1
        DO IP = IQ, IENNP
          ISTK(IP - 1) = ISTK(IP)
        END DO
        ISTK(IENNP) = IB(1)
        GO TO 260
      END IF
      VT  = VT - DEN
      DEN = - DEN
C * A NEGATIVE VOLUME AS NEEDED
C * JUMP OVER WITH INITIAL VOL CALC
      IF (ISK == 2) THEN
        DEV(1) = DEN
        JNK    = IENTR
        NC     = ISTNP+3
        CALL PLA197
        TT  = TT  + DEV(1)
        DE2 = DE2 + DEV(2)
      END IF
C * SPECIFIC CALLS TO STORE FIRST MINORS IF MORE POINTS
      IF (IENNP - ISTNP > 3) THEN
        ND = ISTNP + 1
        NF = ISTNP
        NG = ISTNP + 3
C * TO CALCULATE AND STORE MINORS AND IDENTIFIERS OF FACES
C * THREE COORDINATE POINTERS ARE ND,NF,NG, TO LIST IN ISTNP TO IENNP
        IB(1) = ISTK(ND)
        IB(2) = ISTK(NF)
        IB(3) = ISTK(NF)
        IB(4) = ISTK(NG)
        CALL PLA196
        IENTR           =  IENTR + 6
        IF (IENTR + 6 >= NTMP) GO TO 350
        ISTK(IENTR + 3) =  ND
        ISTK(IENTR + 4) =  NF
        ISTK(IENTR + 5) =  NG
        RSTK(IENTR    ) =  D(4) * D(9) - D(7) * D(6)
        RSTK(IENTR + 1) = -D(1) * D(9) + D(3) * D(7)
        RSTK(IENTR + 2) =  D(1) * D(6) - D(3) * D(4)
        NF = ND
        ND = ISTNP + 2
C * TO CALCULATE AND STORE MINORS AND IDENTIFIERS OF FACES
C * THREE COORDINATE POINTERS ARE ND,NF,NG, TO LIST IN ISTNP TO IENNP
        IB(1) = ISTK(ND)
        IB(2) = ISTK(NF)
        IB(3) = ISTK(NF)
        IB(4) = ISTK(NG)
        CALL PLA196
        IENTR           =  IENTR + 6
        IF (IENTR + 6 >= NTMP) GO TO 350
        ISTK(IENTR + 3) =  ND
        ISTK(IENTR + 4) =  NF
        ISTK(IENTR + 5) =  NG
        RSTK(IENTR    ) =  D(4) * D(9) - D(7) * D(6)
        RSTK(IENTR + 1) = -D(1) * D(9) + D(3) * D(7)
        RSTK(IENTR + 2) =  D(1) * D(6) - D(3) * D(4)
        NF = ND
        ND = ISTNP
C * TO CALCULATE AND STORE MINORS AND IDENTIFIERS OF FACES
C * THREE COORDINATE POINTERS ARE ND,NF,NG, TO LIST IN ISTNP TO IENNP
        IB(1) = ISTK(ND)
        IB(2) = ISTK(NF)
        IB(3) = ISTK(NF)
        IB(4) = ISTK(NG)
        CALL PLA196
        IENTR           =  IENTR + 6
        IF (IENTR + 6 >= NTMP) GO TO 350
        ISTK(IENTR + 3) =  ND
        ISTK(IENTR + 4) =  NF
        ISTK(IENTR + 5) =  NG
        RSTK(IENTR    ) =  D(4) * D(9) - D(7) * D(6)
        RSTK(IENTR + 1) = -D(1) * D(9) + D(3) * D(7)
        RSTK(IENTR + 2) =  D(1) * D(6) - D(3) * D(4)
C * NOW WE GRADUALLY INCLUDE ALL FURTHER VERTICES, ADDING TETRAHEDRON
C * AFTER TETRAHEDRON.
        L = ISTNP + 3
  270   L = L + 1
        IF (IENNP >= L) THEN
          NC = L
          M  = IENTR
C * THIS MUST BE SAVED AS IT IS CHANGED DURING THE LOOP
          IP = ISTTR
  280     IF (ISTK(IP + 5) > 0) THEN
C * ELIMINATE IF DELETED
            ND  = ISTK(L)
            NF  = ISTK(IP + 3)
            NF  = ISTK(NF)
            DEN = (RSTK(NF)     - RSTK(ND))     * RSTK(IP)
     1          + (RSTK(NF + 1) - RSTK(ND + 1)) * RSTK(IP + 1)
     2          + (RSTK(NF + 2) - RSTK(ND + 2)) * RSTK(IP + 2)
            IF (DEN > 1.D-9) THEN
C * THIS IS CRUCIAL
C * THE OMISSION OF EVEN A SMALL VOLUME MAY LEAD TO RAPIDLY ACCUMULATING
C * ERRORS IF IT HAS ONE OR MORE LARGEISH FACES AS TETRAHEDRA BASED ON THE
C * THESE WILL BE INCLUDED OR EXCLUDED WRONGLY.  E-5 WAS FOUND TO BE MUCH
C * TOO BIG.
C * IF THE DISTANCE OF CONFUSION AS TESTED IN CC  IS 3.E-5, AS HERE
C * A GOOD VALUE CAN BE SELECTED BY LOOKING AT A LIST OF POINTS.
C * THE WORST POSSIBLE REAL TETRAHEDRON WOULD HAVE A VOLUME OF APP. E-15.
C * BUT 4 REALLY COPLANAR POINTS COULD GIVE AN APPARENT VOLUME OF ABOUT
C * THIS, SO BY MAKING THE TEST VOLUME A BIT LARGER I HOPE TO INCLUDE ALL
C * REAL BUT EXCLUDE ALL FALSE TETRAHEDRA
              VT = VT + DEN
C * SKIPPED IN INITIAL VOL CALC
              IF (ISK2 == 2) THEN
                DEV(1) = DEN
                IF (DEN > FLIM) THEN
C * CHECK IF WORTHWHILE
                  JNK = IP
                  CALL PLA197
                  DE2 = DE2 + DEV(2)
                  TT  = TT  + DEV(1)
                END IF
              END IF
              JNK1 = ISTK(IP + 5)
              JNK3 = ISTK(IP + 3)
C * DELETE OLD MINOR
              ISTK(IP + 5) = 0
C * INSERT NEW MINORS
              ND    = ISTK(IP + 4)
              NF    = JNK1
              NG    = L
              LRETX = -1
C * TEST IF ALREADY EXISTS, IF SO, DONT DELETE AND COMPACT,
C * JUST SET MARKER TO ZERO
C * THIS MAY USE SIGNIFICANT STORAGE, BUT BUT SHOULD SAVE A LOT OF TIME
  290         DO I0 = ISTTR, IENTR, 6
C * WITH THIS MARKER ALREADY ZERO, THIS TESXT ALWAYS FAILS
                IF (NG == ISTK(I0 + 5)) THEN
                  IF (ND == ISTK(I0 + 4)) THEN
                    IF (NF == ISTK(I0 + 3)) THEN
                      ISTK(I0 + 5) = 0
                      GO TO 300
                    END IF
                  END IF
                END IF
              END DO
C * TO CALCULATE AND STORE MINORS AND IDENTIFIERS OF FACES
C * THREE COORDINATE POINTERS ARE ND,NF,NG, TO LIST IN ISTNP TO IENNP
              IB(1) = ISTK(ND)
              IB(2) = ISTK(NF)
              IB(3) = ISTK(NF)
              IB(4) = ISTK(NG)
              CALL PLA196
              IENTR           =  IENTR + 6
              IF (IENTR + 6 >= NTMP) GO TO 350
              ISTK(IENTR + 3) =  ND
              ISTK(IENTR + 4) =  NF
              ISTK(IENTR + 5) =  NG
              RSTK(IENTR    ) =  D(4) * D(9) - D(7) * D(6)
              RSTK(IENTR + 1) = -D(1) * D(9) + D(3) * D(7)
              RSTK(IENTR + 2) =  D(1) * D(6) - D(3) * D(4)
  300         IF (LRETX < 0) THEN
                NF    = ND
                ND    = JNK3
                LRETX = 0
                GO TO 290
              ELSE IF (LRETX == 0) THEN
                NF    = ND
                ND    = JNK1
                LRETX = 1
                GO TO 290
              END IF
            END IF
          END IF
          IP = IP + 6
          IF (IP <= M) GO TO 280
          GO TO 270
        END IF
      END IF
C * RESET ASSIGNMENTS FOR MAIN CALC
  310 IF (IEX == 1) THEN
        IEX  = 2
        ISK  = 2
        ISK2 = 2
        VZ   = 0.001D+0 * VT
        FLIM = VZ  * 0.03D+0
C * VOL AS RETURNED IS 6* TRUE
        GO TO 340
      END IF
  320 J = J + 6
      IF (J <= IENPL) GO TO 120
  330 I = I + 6
      IF (I <= IENPL) GO TO 110
      TT = TT * 6.0D+0 / VT
      DEV(2) = DE2 * 6.0D+0 / VT
C * TRANSMISSION SHOULD NOW BE FOUND
  340 J = IENTR + 6
      IF (J > MAXUTL) MAXUTL = J
      IF (MAXUTL <= NTMP) RETURN
  350 WRITE (LU7, 99999, IOSTAT = IOST) NTMP
      RETURN
99999 FORMAT ('Available Array Size Exceeded. NTMP =', I7)
      END SUBROUTINE PLA194
 
      SUBROUTINE PLA195 (TX)
C * ABSTOMPA (3)
      USE tompa
      IMPLICIT NONE
      INTEGER          :: I
      DOUBLE PRECISION :: TX
      DOUBLE PRECISION :: DN
      DOUBLE PRECISION :: ANM
      TX = 2000.0D+0
      NC = 0
      DO I = 1, IENPL, 6
        IF (ND == ISTK(I + JNK1 + 3)) THEN
          ANM = RSTK(I + 3) - RSTK(I) * RSTK(JNK)
     1        - RSTK(I + 1) * RSTK(JNK + 1)
     2        - RSTK(I + 2) * RSTK(JNK + 2)
          DN  = RSTK(I)     * CX(JNK1) + RSTK(I + 1) * CY(JNK1)
     1        + RSTK(I + 2) * CZ(JNK1)
          DN  = ABS (DN)
          ANM = ABS (ANM)
          IF (ANM < TX * DN) THEN
            TX = ANM / DN
            NC = I
          END IF
        END IF
      END DO
C * IF NC IS NON-ZERO, A FACE HAS BEEN FOUND
      RETURN
      END SUBROUTINE PLA195
 
      SUBROUTINE PLA196
C * ABSTOMPA (4)
      USE tompa
      D(1) = RSTK(IB(1))     - RSTK(IB(2))
      D(2) = RSTK(IB(3))     - RSTK(IB(4))
      D(3) = RSTK(IB(1))     - RSTK(IB(4))
      D(4) = RSTK(IB(1) + 1) - RSTK(IB(2) + 1)
      D(5) = RSTK(IB(3) + 1) - RSTK(IB(4) + 1)
      D(6) = RSTK(IB(1) + 1) - RSTK(IB(4) + 1)
      D(7) = RSTK(IB(1) + 2) - RSTK(IB(2) + 2)
      D(8) = RSTK(IB(3) + 2) - RSTK(IB(4) + 2)
      D(9) = RSTK(IB(1) + 2) - RSTK(IB(4) + 2)
      RETURN
      END SUBROUTINE PLA196
 
      SUBROUTINE PLA197
C * ABSTOMPA (5)
      USE tompa
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: IAL
      INTEGER          :: IBL
      INTEGER          :: ICL
      INTEGER          :: ISW
      DOUBLE PRECISION :: AF
      DOUBLE PRECISION :: BF
      DOUBLE PRECISION :: HA
      DOUBLE PRECISION :: HAB
      DOUBLE PRECISION :: DEN
      DOUBLE PRECISION :: HPA
      DOUBLE PRECISION :: HABC
      DOUBLE PRECISION :: HP2A
      DOUBLE PRECISION :: HP3A
      DOUBLE PRECISION :: HP4A
      DOUBLE PRECISION :: HPAB
      DOUBLE PRECISION :: HP2AB
      DOUBLE PRECISION :: HP3AB
C * CALCULATES THE CONTRIBUTION FOR AN ELEMENTARY TETRAHEDRON(=A). VOL=V.
C * IF MU*R FOR THE FOUR APICES ARE G1,G2,G3,G4 (ORDERED) AND A=G2-G1,B=
C * G3-G2,C=G4-G3, THEN CONTRIBUTION
C * = 6V*EXP(-G1)*(((H(A)-H(A+B)/B-(H(A+B)-H(A+B+C))/C)/(B+C))
C * WHERE H(A)=(1-EXP(-X))/X.  ALSO H2(A,B)=(H(A)-H(A+B))/B
C * H(3(A,B,C)=(H2(A,B)-H2(A+B,C))/(B+C), = THE INNER EXPRESSION ABOVE.
C *   TOMPA FINDS H(A) BY A CHEBYSHEV SERIES.  THIS IS UNNECCESSARY ON
C * A LARGE COMPUTER AND EXPLICIT EVALUATION IS FASTER.
C * H,H2 AND H3 ALL BECOME INDERERMINATE OF THEIR DENOMINATORS ARE SMALL.
C * THEY MUST THEN BE EVALUATED DIFFERENTLY.  TOMPA ASSUMES THE DENOMINAR
C * OR TO BE EXACTLY ZERO IF IT IS SMALL.  HERE A SERIES EXPANSION IS
C * USED, GIVING THE DENOMINAROT ITS EXACT VALUE.  ALL TERMS IN X**3 ARE
C * IGNORED.  WITH THIS APPROXIMATION A COMPARISON BETWEEN DIRECT CALC.
C * (BY SUBTRACTION AND DIVISION) ABD SERIES EVALUATION TO THIS ACCURACY
C * SHOWS THAT ON ATLAS,WITH ACCURACY OF E-11, THE ERRORS OF BOTH ROUTES
C * ARE EQUAL WHEN D(X)=3.E-3,  AND SO THIS BREAKPOINT IS USED(LABEL22)
C * I   THEN WITH D(2).LT.D, H(D(2)) IS GIVEN BY -LABEL12-
C * II  H(D(2)+D(3)),D(2).GT.D,D(3).LT.D, BY 4TH LINE AFTER -19-
C *      WHERE HPA=1ST DERIVATIVE OF H(D(2)),HP2A,HP3A= 2ND,3RD DERIVATIVES
C * III(A) H2(D(2),D(3)),D(2).GT.D,  BY 3RD LINE AFTER -19-
C * III(B) H2(D(2),D(3)), D(2),D(3).LT.D,  BY LABEL11-
C * FOR H3 -WITH ONE OF D(2),D(3), D(4) SMALL
C * D(2) SMALL - H(D(2)) BY I AND USE TO CALC H2(D(2),D(3))
C * D(3) SMALL - H(D(2) +D(3)) BY II, H2(D(2),D(3)) BY III(A).
C * D(4) SMALL - H2(D(2) +D(3),D(4)) BY III(A)
C * FOR H3 - WITH TWO SMALL
C * D(2) LARGE - TAYLOR EXPANSION. 5TH LINE AFTER -13-
C * D(3) LARGE - H(A) BY I, H2(D(2)+D(3),D(4)) BY III(A)
C * CX LARGE - H(D(2)+D(3)) BY II, H2(D(2),D(3)) BY III(B)
C * FOR H3 WITH ALL SMALL - USE SERIES EXPANSION -LABEL 10-
C * THE NTH DERIV. OF H(X) =D*(H(X)-(1+D*N*F)/X), WHERE
C * D= (-1)**N,  F= (N-1)TH DERIVATIVE.
C * AT LABEL 20 A SWITCH IS USED.  IF D(2),D(3),D(4) ARE LARGE/SMALL,
C * IAL,IBL,ICL ARE 5/1, 2/0, 1/0
C * THEN  D(2)  D(3)  D(4)  SUM  LABEL
C *        S   S   S    1     10
C *        S   S   L    2     11
C *        S   L   S    3     12
C *        L   S   S    5     13
C *        S   L   L    4     12
C *        L   S   L    6     15
C *        L   L   S    7     15
C *        L   L   L    8     15
C * LOCATIONS ARE JNK FOR MINORS, NC FOR VERTEX, DEN IS VOLUME
      DEN  = DEV(1)
      D(4) = RSTK(ISTK(NC) + 3)
      D(1) = RSTK(ISTK(ISTK(JNK + 3)) + 3)
      D(2) = RSTK(ISTK(ISTK(JNK + 4)) + 3)
      D(3) = RSTK(ISTK(ISTK(JNK + 5)) + 3)
      DO I = 1, 3
        AF = D(I)
C * THESE ARE NOW ORDERED
        JNK = I + 1
        DO J = JNK, 4
          IF (AF > D(J)) THEN
            BF   = D(J)
            D(J) = AF
            AF   = BF
          END IF
        END DO
        D(I) = AF
      END DO
C * THE DIFFERENCES BETWEEN SUCCESSIVE ONES ARE TAKEN
C * G = D1, A = D2, ETC, THEN A+B, B+C, A+B+C
      D(4) = D(4) - D(3)
      D(3) = D(3) - D(2)
      D(2) = D(2) - D(1)
      D(5) = D(2) + D(3)
      D(6) = D(3) + D(4)
      D(7) = D(6) + D(2)
      IF (D(1) < 15) THEN
C * HERE THE SWITCHING DEPENDING ON SIZE IS SET UP
        IAL = 1
        IBL = 0
        ICL = 0
        IF (D(2) > 3.D-3) IAL = 5
        IF (D(3) > 3.D-3) IBL = 2
        IF (D(4) > 3.D-3) ICL = 1
        ISW = IAL + IBL + ICL
        I   = 1
C * NOW THE CALCULATION IS STARTED (LABEL 20)
        IF (ISW == 1) THEN
          D(10) = 0.166667D+0 - 0.125D+0 * (D(2) + D(3)) + 0.0416667D+0
     1          * (D(3) - D(4)) + 0.0083333D+0 * (D(2)
     2          * (D(2) + D(2) + D(3)) + D(4) * D(4) +(D(2) + D(3)
     3          + D(4)) * (4.0D+0 * D(2) + 3.0D+0 * D(3)))
          GO TO 30
        ELSE IF (ISW == 2) THEN
          D(8) = 0.5D+0 - D(2) * (0.33333D+0 - 0.125D+0 * (D(2) + D(3)))
     1         - D(3) * (0.166667D+0 - 0.0416667D+0 * D(3))
          HAB = 1.0D+0 - D(5) * (0.5D+0 - 0.166667D+0 * D(5))
          GO TO 10
        ELSE IF (ISW == 3 .OR. ISW == 4) THEN
          HA = 1.0D+0 - D(2) * (0.5D+0 - 0.166667D+0 * D(2))
        ELSE IF (ISW == 5) THEN
          HA   =  (1.0D+0 - EXP (- D(2))) / D(2)
          HPA  = -HA + (1.0D+0 - HA) / D(2)
          HP2A =  HA - (1.0D+0 + HPA + HPA) / D(2)
          HP3A = -HA + (1.0D+0 - HP2A - HP2A - HP2A) / D(2)
          HP4A =  HA - (1.0D+0 + 4.0D+0 * HP3A) / D(2)
          D(10)  =  0.5D+0 * HP2A + 0.166667D+0 * HP3A * (D(3) + D(3)
     1           + D(4)) + 0.0416667D+0 * HP4A * (3.0D+0 * D(3) * (D(3)
     2           + D(4)) + D(4) * D(4))
          GO TO 30
        ELSE
          HA = (1.0D+0 - EXP (- D(2))) / D(2)
          IF (IBL <= 0) THEN
            HPA  = -HA  + (1.0D+0 - HA) / D(2)
            HP2A =  HA  - (1.0D+0 + HPA + HPA) / D(2)
            HP3A = -HA  + (1.0D+0 - HP2A - HP2A - HP2A) / D(2)
            D(8) = -HPA - D(3) * (0.5D+0 * HP2A
     1           + 0.166667D+0 * HP3A * D(3))
            HAB  =  HA  + D(3) * (HPA + 0.5D+0 * D(3) * HP2A)
            GO TO 10
          END IF
        END IF
        HAB  = (1.0D+0  - EXP (- D(5))) / D(5)
        D(8) = (HA - HAB) / D(3)
        IF (ICL <= 0) THEN
          HPAB  = -HAB + (1.0D+0 - HAB) / D(5)
          HP2AB =  HAB - (1.0D+0 + HPAB + HPAB) / D(5)
          HP3AB = -HAB + (1.0D+0 - HP2AB - HP2AB - HP2AB) / D(5)
          D(9)  = -HPAB - D(4) * (0.5D+0 * HP2AB
     1          + 0.166667D+0 * D(4) * HP3AB)
          GO TO 20
        END IF
  10    HABC   = (1.0D+0 - EXP (- D(7))) / D(7)
        D(9)   = (HAB - HABC) / D(4)
  20    D(10)  = (D(8) - D(9)) / D(6)
  30    DEV(I) = DEN * D(10) * EXP (-D(1))
      ELSE
        DEV(1) = 0
        DEV(2) = 0
      END IF
      RETURN
      END SUBROUTINE PLA197
 
      SUBROUTINE PLA198 (MODE, INEXT, NOCLS, NREPL)
C * GUI - Absorption Correction
      USE parameters
      USE atomdata
      USE cchar
      USE crystal
      USE abspsi
      IMPLICIT NONE
      INTEGER       :: IOST
      INTEGER       :: MODE
      INTEGER       :: INEXT
      INTEGER       :: NOCLS
      INTEGER       :: NREPL
      INTEGER, SAVE :: IPR371
      INTEGER, SAVE :: IPR372
      REAL          :: HORS
      REAL          :: VERT
      IPR371 = 0
      IPR372 = 0
      VERT   = 25.0
      HORS   = PAR(50) * VERT
      IF (NREPL == 0) THEN
        IF (NOCLS == 0) CALL GGIP (HORS, VERT, 0.0, 1)
      ELSE
        GO TO 10
      END IF
      CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL PLA110 (HORS, VERT, -1)
C * HEADER
      IF (MODE == -1) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'Spherical Absorption Correction '
      ELSE IF (MODE == 0) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'Xtal Habit Display+Manipulation '
      ELSE IF (MODE == 1) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'Analytical Correction of PsiScan'
      ELSE IF (MODE == 2) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'Gaussian Integration Correction '
      ELSE IF (MODE == 3) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'de Meulenaer- Tompa  Correction '
      ELSE IF (MODE == 4) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'Psi-Scan  Absorption Correction '
      ELSE IF (MODE == 6) THEN
        WRITE (PRBUF, 99999, IOSTAT = IOST)
     1    'MULtiscan ABSorption Correction '
      END IF
      CALL PLA439 (0.0, PRBUF, 32, 0.75, 5 + IGBL(68), 2, 3.0,
     1             VERT - 1.0)
C * REPORT MUR
      IF (MODE == -1 .OR. MODE == 4) THEN
        WRITE (PRBUF, 99998, IOSTAT = IOST) PAR(321)
        IF (PAR(321) == 0.0) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          IF (MODE == -1) THEN
            CALL PLA439 (0.0, 'Enter MuR         Datum <<', 26, 0.50,
     1                  -1, 2, 21.0, 2.0)
          ELSE IF (MODE == 4 .AND. NPSI == 0) THEN
            CALL PLA439 (0.0,
     1           'Optionally Enter MuR for Additional Theta Correction',
     2             52, 0.50, -1, 2, 10.0, 4.0)
          END IF
        ELSE
          CALL GGIP (0.0, 3.0, 0.0, 0)
        END IF
        CALL PLA439 (0.0, PRBUF, 14, 0.5, -1, 2, VERT + 0.1, VERT - 1.0)
        IF (MODE == 4 .AND. NPSI > 0) THEN
          WRITE (PRBUF, 99997, IOSTAT = IOST)
     1      'Nr. Psi Scans =', NPSI
          CALL PLA439 (0.0, PRBUF, 18, 0.5, 1, 2,
     1                 VERT + 0.1, VERT - 3.0)
        END IF
C * REPORT MU
      ELSE IF (MODE /= 0 .AND. MODE /= 4 .AND. MODE /= 7) THEN
        WRITE (PRBUF, 99996, IOSTAT = IOST) PAR(301)
        IF (PAR(301) == 0.0) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          CALL PLA439 (0.0, 'Enter Mu (mm)     Datum <<', 26, 0.50,
     1                 -1, 2, 21.0, 2.0)
        ELSE
          CALL GGIP (0.0, 3.0, 0.0, 0)
        END IF
        CALL PLA439 (0.0, PRBUF, 19, 0.5, -1, 2, VERT + 0.1, VERT - 1.0)
      END IF
C * REPORT GAUSS GRID
      IF (MODE == 2) THEN
        WRITE (PRBUF, 99995, IOSTAT = IOST) IPR(421), IPR(422), IPR(423)
        CALL PLA439 (0.0, PRBUF, 19, 0.5, 1, 2, VERT + 0.1, VERT - 2.0)
      END IF
C * MULABS MODE
      IF (MODE == 6) THEN
C * REPORT RADIUS
        WRITE (PRBUF, 99994, IOSTAT = IOST) PAR(305)
        IF (PAR(305) == 0.0) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          CALL PLA439 (0.0, 'Enter Radius (mm) Datum', 23, 0.75, -1, 2,
     1                 17.0, 1.0)
        ELSE
          CALL GGIP (0.0, 3.0, 0.0, 0)
        END IF
        CALL PLA439 (0.0, PRBUF, 18, 0.5, -1, 2, VERT + 0.1,
     1       VERT - 2.0)
        WRITE (PRBUF, 99993, IOSTAT = IOST) PAR(304)
        CALL PLA439 (0.0, PRBUF, 17, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 3.0)
        WRITE (PRBUF, 99992, IOSTAT = IOST) PAR(306)
        CALL PLA439 (0.0, PRBUF, 17, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 4.0)
        WRITE (PRBUF, 99991, IOSTAT = IOST) IPR(373)
        CALL PLA439 (0.0, PRBUF, 14, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 5.0)
        WRITE (PRBUF, 99990, IOSTAT = IOST) IPR(374)
        CALL PLA439 (0.0, PRBUF, 14, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 6.0)
        WRITE (PRBUF, 99989, IOSTAT = IOST) PAR(321)
        CALL PLA439 (0.0, PRBUF, 17, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 7.0)
      END IF
      IF (MODE == 2 .OR. MODE == 3 .OR. MODE == 4
     1      .OR. MODE == 6 .OR. MODE == -1 .OR. MODE == 0) THEN
        IF (MODE == 2 .OR. MODE == 3 .OR. MODE == 0)
     1      PAR(305) = 0.0001
        IF (PAR(301) * PAR(305) > 0.0 .OR. MODE == 4
     1      .OR. (MODE == -1 .AND. PAR(321) > 0.0)) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          IF (PAR(315) == 0.0) THEN
            IF (IPR(375) == 0) THEN
              CALL PLA439 (0.0, 'Click on NEXT-STEP to PROCEED', 29,
     1                 0.60, -1, 2, 18.0, 1.5)
            END IF
          ELSE
            CALL PLA439 (0.0, 'Click on END to Terminate    ', 29,
     1                 0.75, -1, 2, 15.0, 1.0)
          END IF
        END IF
      END IF
      IF (IPR(331) == 1) THEN
        WRITE (IDM, 99988, IOSTAT = IOST) PAR(101)
        CALL PLA439 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 2.0)
        WRITE (IDM, 99987, IOSTAT = IOST) PAR(102)
        CALL PLA439 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 2.6)
        WRITE (IDM, 99986, IOSTAT = IOST) PAR(103)
        CALL PLA439 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 3.2)
        WRITE (IDM, 99985, IOSTAT = IOST) PAR(104)
        CALL PLA439 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 3.8)
        WRITE (IDM, 99984, IOSTAT = IOST) PAR(105)
        CALL PLA439 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 4.4)
        WRITE (IDM, 99983, IOSTAT = IOST) PAR(106)
        CALL PLA439 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 5.0)
        IF (NFACES > 0) THEN
          WRITE (PRBUF, 99982, IOSTAT = IOST) NFACES
          CALL PLA439 (0.0, PRBUF, 13, 0.35, 1, 2, 0.5, VERT - 6.0)
          WRITE (PRBUF, 99981, IOSTAT = IOST) NVRR
          CALL PLA439 (0.0, PRBUF, 13, 0.35, 1, 2, 0.5, VERT - 6.5)
          WRITE (PRBUF, 99980, IOSTAT = IOST) NEDGE
          CALL PLA439 (0.0, PRBUF, 13, 0.35, 1, 2, 0.5, VERT - 7.0)
        END IF
      END IF
C * MULABS
   10 IF (MODE == 6) THEN
        WRITE (PRBUF, 99979, IOSTAT = IOST) IPR371
        CALL PLA439 (0.0, PRBUF, 29, 0.5, 0, 2, 3.0, VERT - 8.0)
        IPR371 = IPR(371)
        WRITE (PRBUF, 99979, IOSTAT = IOST) IPR(371)
        CALL PLA439 (0.0, PRBUF, 29, 0.5, 5, 2, 3.0, VERT - 8.0)
        WRITE (PRBUF, 99978, IOSTAT = IOST) IPR372
        CALL PLA439 (0.0, PRBUF, 29, 0.5, 0, 2, 3.0, VERT - 9.0)
        IPR372 = IPR(372)
        WRITE (PRBUF, 99978, IOSTAT = IOST) IPR(372)
        CALL PLA439 (0.0, PRBUF, 29, 0.5, 5, 2, 3.0, VERT - 9.0)
        IF (NREPL == 0) THEN
          WRITE (PRBUF, 99977, IOSTAT = IOST) SPGRNM(1)(1:11)
          CALL PLA439 (0.0, PRBUF, 21, 0.5, 5, 2, 3.0, VERT - 7.0)
          IF (IPR(375) > 0) THEN
            WRITE (PRBUF, 99976, IOSTAT = IOST) IPR(375)
            CALL PLA439 (0.0, PRBUF, 36, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 10.0)
            WRITE (PRBUF, 99975, IOSTAT = IOST) IPR(376)
            CALL PLA439 (0.0, PRBUF, 35, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 11.0)
            WRITE (PRBUF, 99974, IOSTAT = IOST) IPR(377)
            CALL PLA439 (0.0, PRBUF, 36, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 12.0)
            WRITE (PRBUF, 99973, IOSTAT = IOST) PAR(322)
            CALL PLA439 (0.0, PRBUF, 44, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 14.0)
            WRITE (PRBUF, 99972, IOSTAT = IOST) PAR(323)
            CALL PLA439 (0.0, PRBUF, 50, 0.5, 5 + IGBL(68), 2, 3.0,
     1                         VERT - 15.0)
C * ANISOTROPY EXTREMA
            IF (PAR(319) > 0.0) THEN
              WRITE (PRBUF, 99971, IOSTAT = IOST) PAR(319)
              CALL PLA439 (0.0, PRBUF, 16, 0.5, 1, 2, 1.0,
     1                     VERT - 21.0)
              WRITE (PRBUF, 99970, IOSTAT = IOST) PAR(320)
              CALL PLA439 (0.0, PRBUF, 16, 0.5, 1, 2, 1.0,
     1                     VERT - 22.0)
              END IF
          END IF
        END IF
C * FLUSH
        CALL GGIP (0.0, 0.0, 0.0, 6)
      END IF
      IF (MODE /= 0 .AND. PAR(315) /= 0.0) THEN
        IF (MODE /= 6) THEN
          WRITE (PRBUF, 99969, IOSTAT = IOST) IPR(432)
          CALL PLA439 (0.0, PRBUF, 28, 0.5, 5 + IGBL(68), 2, 1.3,
     1                 VERT - 22.0)
        END IF
        WRITE (PRBUF, 99968, IOSTAT = IOST) PAR(315)
        CALL PLA439 (0.0, PRBUF, 16, 0.5, 5 + IGBL(68), 2, 1.3,
     1               VERT - 23.0)
        WRITE (PRBUF, 99967, IOSTAT = IOST) PAR(317)
        CALL PLA439 (0.0, PRBUF, 16, 0.5, 5 + IGBL(68), 2, 1.3,
     1               VERT - 24.0)
      END IF
      IF (INEXT == 0 .AND. MODE /= 4 .AND. MODE /= -1 ) THEN
        CALL PLA187 (1, 9.0, 11, NOCLS)
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (A)
99998 FORMAT ('MuR     ', F6.2)
99997 FORMAT (A, I3)
99996 FORMAT ('Mu      ', F6.2, ' mm-1')
99995 FORMAT ('Grid   ', 3I4)
99994 FORMAT ('Radius  ', F6.3, ' mm')
99993 FORMAT ('Tmin   ', F7.3, ' mm')
99992 FORMAT ('Tmax   ', F7.3, ' mm')
99991 FORMAT ('Lomax  ', I7)
99990 FORMAT ('L1max  ', I7)
99989 FORMAT ('MuR    ', F7.3)
99988 FORMAT ('a     = ', F8.4)
99987 FORMAT ('b     = ', F8.4)
99986 FORMAT ('c     = ', F8.4)
99985 FORMAT ('alpha = ', F8.3)
99984 FORMAT ('beta  = ', F8.3)
99983 FORMAT ('gamma = ', F8.3)
99982 FORMAT ('Faces    ', I4)
99981 FORMAT ('Vertices ', I4)
99980 FORMAT ('Edges    ', I4)
99979 FORMAT ('Read   =', I7, ' Measurements')
99978 FORMAT ('Accept =', I7, ' Measurements')
99977 FORMAT ('SPGR   =  ', A)
99976 FORMAT ('N(obs) =', I7, ' Measurements (Used)')
99975 FORMAT ('N(hkl) =', I7, ' Unique Reflections')
99974 FORMAT ('N(par) =', I7, ' Coefficients A(l,m)')
99973 FORMAT ('Rw = ', F10.3, ' For All AHI = 1 (N(par) = 0)')
99972 FORMAT ('Rw = ', F10.3, ' For the AHI From the Fitted A(l,m)')
99971 FORMAT ('A(min) =', F8.4)
99970 FORMAT ('A(max) =', F8.4)
99969 FORMAT ('Refl. Processed', I7)
99968 FORMAT ('T(min) =', F8.4)
99967 FORMAT ('T(max) =', F8.4)
      END SUBROUTINE PLA198
 
      SUBROUTINE PLA199 (MODE)
C * CHECK DIRCOS
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER :: MODE
      IF (MODE == 0) THEN
        TPMTDM = 0.0
        TOMTCM = 0.0
      ELSE
        WRITE (LU6, 99999, IOSTAT = IOST)
     1    TPMTDM, PAR(77), TOMTCM, PAR(78)
        WRITE (LU7, 99999, IOSTAT = IOST)
     1    TPMTDM, PAR(77), TOMTCM, PAR(78)
      END IF
      RETURN
99999 FORMAT (/, ':: Max(TPRIM - TDIFF)', F8.3, ' Crit <=', F8.3,
     1        /, ':: Max(THobs - THcal)', F8.3, ' Crit <=', F8.3, /)
      END SUBROUTINE PLA199
 
      SUBROUTINE PLA200 (TPRIM, TDIFF, THETA, THHKL)
      USE files
      USE parameters
      IMPLICIT NONE
      REAL               :: TOMTC
      REAL               :: TPMTD
      REAL               :: TPRIM
      REAL               :: TDIFF
      REAL               :: THETA
      REAL               :: THHKL
      CHARACTER(len=132) :: PRBUF
      TPMTD  = ABS (TPRIM - TDIFF)
      TOMTC  = ABS (THETA - THHKL)
      TPMTDM = MAX (TPMTDM, TPMTD)
      TOMTCM = MAX (TOMTCM, TOMTC)
      IF (TPMTD > PAR(77) .OR. TOMTC > PAR(78)) THEN
        IF (IPR(363) == 1) THEN
          BACKSPACE LU16
          READ (LU16, 99998, IOSTAT = IOST) PRBUF
          WRITE (LU6, 99999, IOSTAT = IOST) PRBUF(1:80),
     1      TPRIM, TDIFF, PAR(77), THETA, THHKL, PAR(78)
          WRITE (LU7, 99999, IOSTAT = IOST) PRBUF(1:80),
     1      TPRIM, TDIFF, PAR(77), THETA, THHKL, PAR(78)
        END IF
      END IF
      RETURN
99999 FORMAT (/, ':: Bad Direction Cosines: for reflection:', /, A, //,
     1 ':: Check Cell Dimensions/Transformation and Wavelength !!', //,
     2 ':: The dot product H.P (reversed) ...... [', F8.4, '] and', /,
     3 '   the dot product H.S] ................ [', F8.4, ']', /,
     4 '           should be equal within ...... [', F8.4, ']', //,
     5 ':: The Theta(Calc) from Dir.Cos. ....... [', F8.4, '] and', /,
     8 '   the Theta(obs) from Cell Dimensions . [', F8.4, ']', /,
     9 '                  should be equal within [', F8.4, ']', //,
     7 ':: Check may be overruled with NOCHECK option (DANGEROUS)', //)
99998 FORMAT (A)
      END SUBROUTINE PLA200
 
      SUBROUTINE PLA201 (NRET, NAUTO)
C * ANALYSE CRYSTAL DESCRIPTION
      USE files
      USE plato
      USE crystal
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: I0
      INTEGER :: J0
      INTEGER :: K0
      INTEGER :: IO
      INTEGER :: JO
      INTEGER :: I1
      INTEGER :: K1
      INTEGER :: L1
      INTEGER :: N1
      INTEGER :: N2
      INTEGER :: MC
      INTEGER :: NF
      INTEGER :: NRET
      INTEGER :: ICHK
      INTEGER :: IPLOT
      INTEGER :: NAUTO
      REAL    :: DET
      REAL    :: EDGE
      REAL    :: XLNG
      REAL    :: CHECK
      REAL    :: GEN006
C * DETERMINE LENGTHS OF RECIPROCAL VECTORS PERPENDICULAR TO BOUNDARY
C * MULTIPLY DISTANCE FROM ORIGIN TO FACE BY LENGTH OF RECIPROCAL VECTOR
C * TO FACE, INSTEAD OF NORMALIZING THIS VECTOR TO UNITY BY DIVIDING
C * H,K AND L BY ITS LENGTH
      CALL PLA262 (0)
      WRITE (LU7, 99999, IOSTAT = IOST)
      DO J = 1, NFACES
        DO I = 1, 3
          V1(I) = PMILL(J, I)
        END DO
        WRITE (LU7, 99994, IOSTAT = IOST)
     1    J, (V1(I), I = 1, 3), PMILL(J, 5)
        PMILL(J, 4) = PMILL(J, 5) * SQRT (GEN006 (V1, RBB, V1))
      END DO
      WRITE (LU7, 99998, IOSTAT = IOST)
C * INITIALISE EDGES
      CALL GEN097 (IEDGE, 1, NXT3, 0)
C * SCAN OVER ALL POSSIBLE COMBINATIONS OF THREE FACES TO DETERMINE
C * COORDINATES OF CORNERS OF CRYSTAL
      NVER = 0
      NVRR = 0
      N1   = NFACES - 1
      N2   = N1 - 1
      DO K = 1, N2
        DO I = 1, 3
          PAT(1, I) = PMILL(K, I)
        END DO
        V1(1) = PMILL(K, 4)
        K1 = K + 1
        DO L = K1, N1
          DO I = 1, 3
            PAT(2, I) = PMILL(L, I)
          END DO
          V1(2) = PMILL(L, 4)
          L1 = L + 1
          DO 10 M = L1, NFACES
            DO I = 1, 3
              PAT(3, I) = PMILL(M, I)
            END DO
            V1(3) = PMILL(M, 4)
C * TEST WHETHER THE THREE FACES INDEED INTERSECT IN A POINT BY
C * INVERSION OF PAT
C * IF SO, SOLVE THE THREE EQUATIONS FOR THIS POINT OF INTERSECTION
            CALL GEN003 (PAT, QM, DET, 0)
            IF (DET /= 0.0) THEN
C * MAT*VEC (Coppens - form:18)
              CALL GEN002 (1, QM, V1, V2, XLNG)
C * CHECK WHETHER POINT IS ON CRYSTAL SURFACE, IF OUTSIDE CRYSTAL REJECT
C * V2 ARE FRACTIONAL COORDINATES OF THE POINT OF INTERSECTION OF 3 FACES
C * SINCE THE DIST. FROM THE ORIGIN TO EACH OF THE FACES ARE GIVEN IN CM
C * THE COORD. V2 ARE FRACTIONS OF AXES A,B,C OF LENGTH A(mm),B(mm),C(mm)
              DO J0 = 1, NFACES
                CHECK = 0.0
                DO I0 = 1, 3
                  CHECK = CHECK + PMILL(J0, I0) * V2(I0)
                END DO
                IF (PMILL(J0, 4) < CHECK - 0.00001) GO TO 10
              END DO
              NVER          = NVER + 1
              IF (NVER > NXT2) RETURN
              XTLV(4, NVER) = K
              XTLV(5, NVER) = L
              XTLV(6, NVER) = M
              XTLV(7, NVER) = NVER
              IEDGE(K) = 1
              IEDGE(L) = 1
              IEDGE(M) = 1
C * CHECK FOR COINCIDING POINTS
              ICHK = 1
              DO K0 = 1, NVER - 1
                IF (ABS (XTLV(1, K0) - V2(1)) +
     1              ABS (XTLV(2, K0) - V2(2)) +
     2              ABS (XTLV(3, K0) - V2(3)) < 0.00001) THEN
                    ICHK = 0
                    XTLV(7, NVER) = K0
                  EXIT
                END IF
              END DO
              NVRR = NVRR + ICHK
              WRITE (LU7, 99995, IOSTAT = IOST)
     1               NVER, NINT (XTLV(7, NVER)), V2, K, L, M
              DO IPLOT = 1, 3
                XTLV(IPLOT, NVER) = V2(IPLOT)
              END DO
            END IF
   10     CONTINUE
        END DO
      END DO
      WRITE (LU7, 99993, IOSTAT = IOST)
      DO I = 1, NFACES
        IF (IEDGE(I) /= 1) THEN
C * FACE DOES NOT INTERSECT
          WRITE (LU7, 99996, IOSTAT = IOST) I
          WRITE (LU6, 99996, IOSTAT = IOST) I
          IF (NAUTO == 0) THEN
            NRET = 1
            RETURN
          END IF
        END IF
      END DO
C * DETERMINE EDGES
      WRITE (LU7, 99997, IOSTAT = IOST)
      NEDGE = 0
      NF    = NVER - 1
      DO I = 1, NF
        I1 = I + 1
        DO 20 J = I1, NVER
          IO = NINT (XTLV(7, I))
          JO = NINT (XTLV(7, J))
          IF (JO /= IO) THEN
            IF (IO > JO) CALL GEN014 (IO, JO)
            MC = 0
            DO K = 1, 3
              DO L = 1, 3
                IF (XTLV(K + 3, I) == XTLV(L + 3, J)) THEN
                  MC = MC + 1
                  IF (MC == 2) THEN
                    DO M = 1, NEDGE
                      IF (IDG(M, 1) == IO) THEN
                        IF (IDG(M, 2) == JO) GO TO 20
                      END IF
                    END DO
                    DO N = 1, 3
                      V1(N)  = XTLV(N, I) - XTLV(N, J)
                    END DO
                    EDGE  = SQRT (GEN006 (V1, RAA, V1))
                    NEDGE = NEDGE + 1
                    WRITE (LU7, 99992, IOSTAT = IOST)
     1                NEDGE, IO, JO, EDGE
                    IDG(NEDGE, 1) = IO
                    IDG(NEDGE, 2) = JO
                    IDG(NEDGE, 3) = I
                    IDG(NEDGE, 4) = J
                    GO TO 20
                  END IF
                END IF
              END DO
            END DO
          END IF
   20   CONTINUE
      END DO
      RETURN
99999 FORMAT ('Crystal Face Defining Data', /, 26('='), //,
     1 '   Nr      h       k       l',
     2  10X, 'Distance(mm)', /, 80('-'))
99998 FORMAT (/, 'Points of Intersection of Planes', /, 32('='), //,
     1 19X, 'Crystal System', 9X,
     2 'Inters. of Planes', /, 80('-'), /, 4X, 'Vertex', 6X,
     3 'x         y         z', 8X, 'Face  No.', /, 80('-'))
99997 FORMAT (/, '   NR      EDGE   LENGTH (mm)', /, 30('='), /)
99996 FORMAT (//, ':: Note >> FACE', I3, '  has NO Intersection', /)
99995 FORMAT (I4, ' =', I4, 3F10.5, 2X, 3I4)
99994 FORMAT (I5, 1X, 3F8.2, F15.3)
99993 FORMAT (1X)
99992 FORMAT (3I5, F10.3)
      END SUBROUTINE PLA201
 
      SUBROUTINE PLA202
C * SHXABS: A MODIFIED VERSION OF SHELXA
C * INPUT: shelxl.ins & shelxl.hkl (HKLF 4 style)
C * CHANGE DEFAULTS WITH INSTRUCTION 'SHXABS crit1 crit2 ne no'
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER,          PARAMETER       :: MR = 300000
      INTEGER                           :: I
      INTEGER                           :: J
      INTEGER                           :: K
      INTEGER                           :: L
      INTEGER                           :: M
      INTEGER                           :: N
      INTEGER                           :: ME
      INTEGER                           :: MO
      INTEGER                           :: NN
      INTEGER                           :: NP
      INTEGER                           :: NR
      INTEGER                           :: IH
      INTEGER                           :: IK
      INTEGER                           :: IL
      INTEGER                           :: IHT
      INTEGER                           :: IKT
      INTEGER                           :: ILT
      INTEGER                           :: NERROR
      REAL                              :: O
      REAL                              :: P
      REAL                              :: Q
      REAL                              :: R
      REAL                              :: S
      REAL                              :: T
      REAL                              :: U
      REAL                              :: V
      REAL                              :: W
      REAL                              :: TA
      REAL                              :: TB
      REAL                              :: TH
      REAL                              :: TM
      REAL                              :: TZ
      REAL                              :: SC
      REAL                              :: DU
      REAL                              :: SIG
      REAL                              :: OBS
      REAL                              :: CALC
      REAL                              :: XDNR
      REAL                              :: YDNR
      REAL                              :: XINR
      REAL                              :: YINR
      REAL                              :: ZDNR
      REAL                              :: ZINR
      REAL                              :: ACAL
      REAL                              :: BCAL
      REAL                              :: ACALA
      REAL                              :: BCALA
      REAL                              :: SNTHA
      REAL                              :: ACALAF
      REAL                              :: BCALAF
      REAL                              :: GEN050
      REAL,             DIMENSION(3, 3) :: TRMX
      REAL,             DIMENSION(12)   :: D
      REAL, ALLOCATABLE, DIMENSION(:)   :: FF
      REAL, ALLOCATABLE, DIMENSION(:)   :: FC
      REAL, ALLOCATABLE, DIMENSION(:)   :: SG
      REAL, ALLOCATABLE, DIMENSION(:)   :: XI
      REAL, ALLOCATABLE, DIMENSION(:)   :: XD
      REAL, ALLOCATABLE, DIMENSION(:)   :: YI
      REAL, ALLOCATABLE, DIMENSION(:)   :: YD
      REAL, ALLOCATABLE, DIMENSION(:)   :: ZI
      REAL, ALLOCATABLE, DIMENSION(:)   :: ZD
      DOUBLE PRECISION                  :: DD
      DOUBLE PRECISION                  :: DT
      DOUBLE PRECISION                  :: TT
      DOUBLE PRECISION, DIMENSION(3570) :: B
      DOUBLE PRECISION, DIMENSION(84)   :: C
      DOUBLE PRECISION, DIMENSION(84)   :: E
      DOUBLE PRECISION, DIMENSION(84)   :: F
      ALLOCATE (FF(MR), FC(MR), SG(MR), XI(MR), XD(MR), YI(MR), YD(MR),
     1  ZI(MR), ZD(MR))
      IF (IGBL(37) /= 1) THEN
        IPR(2) = 56
        RETURN
      END IF
      TH  = PAR(417)
      DU  = PAR(418)
      ME  = IPR(523)
      MO  = IPR(524)
      IHT = 0
      IKT = 0
      ILT = 0
      CALL PLA293 (PAR(17))
      IF (IPR(37) == 0) RETURN
      CALL PLA287 (1, 1, 0)
      PAGET = 'SHXABS'
      CALL PLA262 (0)
      WRITE (LU6, 99999, IOSTAT = IOST)
     1   PAR(417), PAR(418), IPR(523), IPR(524)
      WRITE (LU7, 99999, IOSTAT = IOST)
     1   PAR(417), PAR(418), IPR(523), IPR(524)
C * SHELX-HKLF 4 MATRIX
      K = 230
      DO I = 1, 3
        DO J = 1, 3
          K = K + 1
          TRMX(I, J) = PAR(K)
        END DO
      END DO
C * Read in raw reflection data and calculate intensity
      NR     = 0
      U      = 0.0
      V      = 0.0
      NERROR = -1
   10 NERROR = NERROR + 1
      IF (NERROR < 100) THEN
        DO
          READ (LU16, 99998, IOSTAT = IOST) IH, IK, IL, OBS, Q, J,
     1      XINR, XDNR, YINR, YDNR, ZINR, ZDNR
          IF (IOST /= 0) THEN
            IF (IOST == -1) THEN
              GO TO 20
            ELSE
              GO TO 10
            END IF
          END IF
          IF (IH == 0 .AND. IK == 0 .AND. IL == 0) GO TO 20
          IF (OBS >= TH * Q) THEN
            IF (Q > 0.0) THEN
              ACAL = 0.0
              BCAL = 0.0
              IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) > 0.0)
     1          THEN
                CALL PLA137 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA,
     1            ACALAF, BCALAF, 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 == MR) THEN
                  WRITE (LU6, 99991, IOSTAT = IOST)
                  WRITE (LU7, 99991, IOSTAT = IOST)
                  RETURN
                END IF
              END IF
            END IF
          END IF
        END DO
      END IF
  20  N  = NR
      IF (N == 0) RETURN
      NR = 0
C * SCALING FACTOR ON I(OBS), SIG(I(OBS))
      SC = V / U
C * Derive orthogonal transformation matrix for direction cosines
      DO I = 1, 6
        C(I) = 0.D0
      END DO
      DO I = 1, 21
        B(I) = 0.D0
      END DO
      DO I = 1, N
        OBS = FF(I) * SC
        SIG = SG(I) * SC
        IF (AMIN1 (OBS, FC(I)) > 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 J = 1, 6
            C(J) = C(J) + F(J) + F(J + 6)
            DO K = 1, J
              L    = L + 1
              B(L) = B(L) + F(J) * F(K) + F(J + 6) * F(K + 6)
            END DO
          END DO
        END IF
      END DO
      CALL GEN110 (6, 21, C, B)
      DO I = 1, 6
        D(I + 6) = SNGL (C(I))
      END DO
      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)
C * Orthogonalize and check direction cosines
      T = 0.0
      S = 0.0
      R = 0.0
      U = 0.0
      V = 0.0
      DO 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))
      END DO
      R = 0.5 * R / REAL (NR)
      S = 114.59156 * ATAN2 (SQRT (S), SQRT (1.0 - S))
      WRITE (LU6, 99995, IOSTAT = IOST) R, T, S
      WRITE (LU7, 99995, IOSTAT = IOST) R, T, S
C * Number of parameters and R1 before refinement
      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 I = 1, NR
        P = SQRT (T * FF(I))
        Q = SQRT (FC(I))
        U = U + ABS (P - Q)
        V = V + Q
      END DO
      WRITE (LU6, 99997, IOSTAT = IOST) NR, NP, U / V
      WRITE (LU7, 99997, IOSTAT = IOST) NR, NP, U / V
C * Damped full-matrix least-squares refinement of absorption parameters
C * Sum normal matrix and vector
      NN = (NP * (NP + 1)) / 2
      DO I = 1, NN
        B(I) = 0.D0
      END DO
      DO I = 1, NP
        C(I) = 0.D0
      END DO
      DO 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 J = 1, L
          F(J) = F(J) + E(J)
        END DO
        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 J = 1, NP
          C(J) = C(J) + DD * F(J)
          DT = F(J)
          DO K = 1, J
            M = M + 1
            B(M) = B(M) + DT * F(K)
          END DO
        END DO
      END DO
      CALL GEN110 (NP, NN, C, B)
C * Calculate corrected intensities and R1 after refinement
      TM = -9.E9
      TZ = 9.E9
      U  = 0.0
      V  = 0.0
      DO 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 J = 1, L
          F(J) = F(J) + E(J)
        END DO
        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 K = 1, NP
          TT = TT + C(K) * F(K)
        END DO
        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
      END DO
      WRITE (LU6, 99996, IOSTAT = IOST) U / V
      WRITE (LU7, 99996, IOSTAT = IOST) U / V
C * Read .raw and write corrected data to new .hkl file
      O  = 10.0
      TA = -9.E9
      TB = 9.E9
  30  REWIND (UNIT = LU16, IOSTAT = IOST)
      REWIND (UNIT = LU17, IOSTAT = IOST)
      O  = O * 0.1
      N  = 0
      NERROR = -1
  40  NERROR = NERROR + 1
      IF (NERROR <= 100) THEN
        DO
          READ (LU16, 99998, IOSTAT = IOST) IH, IK, IL,
     1      T, S, M, U, P, V, Q, W, R
          IF (IOST /= 0) THEN
            IF (IOST == -1) THEN
              GO TO 60
            ELSE
              GO TO 40
            END IF
          END IF
          IF (IABS (IH) + IABS (IK) + IABS (IL) /= 0) THEN
            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 J = 1, L
              F(J) = F(J) + E(J)
            END DO
            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 K = 1, NP
              P = P + SNGL (C(K) * F(K))
            END DO
            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 > 99999.99) GO TO 50
            IF (S > 99999.99) GO TO 50
            IF (T < -9999.99) GO TO 50
            IF (S < -9999.99) GO TO 50
            WRITE (LU17, 99994, IOSTAT = IOST) IH, IK, IL, T, S, M
            CYCLE
  50        IF (T > 9999999.0) GO TO 30
            IF (S > 9999999.0) GO TO 30
            IF (T < -999999.0) GO TO 30
            IF (S <= -999999.0) GO TO 30
            WRITE (LU17, 99993, IOSTAT = IOST) IH, IK, IL, T, S, M
          END IF
        END DO
      END IF
  60  I = 0
      T = 0.0
      WRITE (LU17, 99994, IOSTAT = IOST) I, I, I, T, T, I
      T = (TB / TA)**0.3333
      WRITE (LU6, 99992, IOSTAT = IOST) N, T * TB / TA, T
      WRITE (LU7, 99992, IOSTAT = IOST) N, T * TB / TA, T
C * SET CLOSE STATUS
      IPR(2) = -10
      DEALLOCATE (FF, FC, SG, XI, XD, YI, YD, ZI, ZD)
      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 PLA202
 
      SUBROUTINE PLA204
C * DISPLAY NORMAL PROBABILITY PLOT IN GRAPH ARRAY
      USE CCHAR
      IMPLICIT NONE
      INTEGER :: I
      REAL    :: VRT
      REAL    :: HORS
      REAL    :: VERT
      HORS = 26.0
      VERT = 19.5
C * OPEN WINDOW
      CALL GGIP (HORS, VERT, 0.0, 1)
      VRT = VERT - 0.5
      DO I = 1, 44
        VRT = VRT - 0.43
        CALL PLA439 (0.0, GRAPH(I)(7:125), 119, 0.25, 1, 1, 0.0, VRT)
      END DO
C * FLUSH
      CALL GGIP (0.0, 0.0, 0.0, 6)
C * CLOSE WINDOW
      CALL GGIP (0.0, 0.0, 0.0, -1)
      RETURN
      END SUBROUTINE PLA204
 
      SUBROUTINE PLA205
C * SHELXT + PLOT SOLUTIONS
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: N
      CHARACTER(len=14) :: SHELXL
C * CHECK FOR CIF DATA (CONVERSION TO .INS & HKL JOB NEEDED)
   10 IF (IGBL(138) == 0 .AND. IABS(IGBL(8)) == 3) THEN
C * GENERATE _sx.ins AND _sx.hkl
C * FROM .cif AND .fcf for L.S. refinement
        CALL PLA345
        IGBL(138) = 1
        IF (IPR(663) < 0) THEN
          CLOSE (UNIT = LU24, IOSTAT = IOST)
          CLOSE (UNIT = LU25, IOSTAT = IOST)
          GO TO 10
        END IF
      ELSE
C * FILE EXTENTION STRING
        SHELXL = ' _sx_xt_a.res'
        IF (IABS (IGBL(8)) == 3) THEN
          CLOSE (UNIT = LU2, IOSTAT = IOST)
C * SELECT ' _sx'         FROM STRING SHELXL
          I = 2
          J = 4
C * SELECT '_sx_xt_a.res' FROM STRING SHELXL
          K = 2
          L = 13
        ELSE
C * SELECT ' '            FROM STRING SHELXL
          I = 1
          J = 1
C * SELECT '_xt_a.res'    FROM STRING SHELXL
          K = 5
          L = 13
        END IF
C * ELIMINATE TWINNING INSTRUCTIONS FROM .ins
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//SHELXL(I:J)//'.ins',
     1    IOSTAT = IOST)
        OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//SHELXL(I:J+3)//'.ins',
     1    IOSTAT = IOST)
        DO
          READ (LU61, 99999, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          IF (LINE(1:4) == 'HKLF') LINE = 'HKLF 4'
          IF (LINE(1:4) == 'TWIN') CYCLE
          IF (LINE(1:4) == 'BASF') CYCLE
          WRITE (LU62, 99999, IOSTAT = IOST) LINE
        END DO
        CLOSE (UNIT = LU61, IOSTAT = IOST)
        CLOSE (UNIT = LU62, IOSTAT = IOST)
C * REMOVE TWINNING CONTRIBUTIONS FROM .hkl
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//SHELXL(I:J)//'.hkl',
     1    IOSTAT = IOST)
        OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//SHELXL(I:J+3)//'.hkl',
     1    IOSTAT = IOST)
        DO
          READ (LU61, 99997, IOSTAT = IOST) LINE(1:28), N
          IF (IOST /= 0) EXIT
          IF (N >= 0) THEN
            WRITE (LU62, 99997, IOSTAT = IOST) LINE(1:28), N
          END IF
        END DO
        CLOSE (UNIT = LU61, IOSTAT = IOST)
        CLOSE (UNIT = LU62, IOSTAT = IOST)
C * RUN SPAWNED SHELXT JOB
        CALL SPAWN
     1 (SHTPATH(1:IGBL(119))//' '//NAMEFIL(1:KNMFIL)//SHELXL(I:J+3),
     2    LU6, .true., KERR)
 
        IF (KERR == 0) THEN
C * LOOP OVER SHELXT SOLUTIONS
          DO N = 1, 10
            SHELXL(9:9) = CHAR (96 + N)
            INQUIRE (FILE = NAMEFIL(1:KNMFIL)//SHELXL(K:L),
     1        EXIST = EXST)
            IF (.NOT. EXST) EXIT
            WRITE (LU6, 99998) NAMEFIL(1:KNMFIL)//SHELXL(K:L)
C * RUN SPAWNED PLATON/ORTEP JOB
            CALL SPAWN
     1      (PLAPATH(1:IGBL(80))//' -a '//NAMEFIL(1:KNMFIL)//
     2      SHELXL(K:L), LU6, .true., KERR)
          END DO
          IF (IPR(2) == 0) IPR(2) = -1
        END IF
C * ERROR HANDLING
        IGBL(1) = 3
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT (/, ':: SOLUTION: ', A, /)
99997 FORMAT (A, I4)
      END SUBROUTINE PLA205
 
      SUBROUTINE PLA206 (ISW, TYPEX)
C * LIST IPR / PAR / IGBL / RGBL / CHK                   *
      USE files
      USE parameters
      USE xwdw
      USE cggt
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: ISW
      INTEGER          :: MODE
      INTEGER          :: IEND
      INTEGER          :: INDX
      INTEGER          :: IVAL
      INTEGER          :: IVALO
      REAL             :: VAL
      REAL             :: VALO
      CHARACTER(len=3) :: TYPEX
C * ISW  =   1 - SET
C * ISW  =  -1 - LIST
C * MODE = +-1 - IPR
C * MODE = +-2 - PAR
C * MODE = +-3 - IGBL
C * MODE = +-4 - RGBL
      MODE = 0
      IEND = 0
      IGBL(6) = - IABS (IGBL(6))
      SELECT CASE (TYPEX)
C * LIST IPR
        CASE ('IPR')
          MODE = ISW
          IEND = NP12
C * LIST PAR
        CASE ('PAR')
          MODE = ISW * 2
          IEND = NP13
C * LIST IGBL
        CASE ('IGB')
          MODE = ISW * 3
          IEND = NP38
C * LIST RGBL
        CASE ('RGB')
          MODE = ISW * 4
          IEND = NP39
C * LIST CHECKSUMS
        CASE ('CHK')
          MODE = ISW * 5
      END SELECT
      IF (MODE < 0) THEN
        IF (IPR(221) == 0) THEN
          J = 1
          K = IEND
        ELSE
          J = NINT (FN(1))
          IF (IPR(221) > 1) THEN
            K = NINT (FN(2))
          ELSE
            K = J
          END IF
          IF (J < 1 .OR. J > IEND .OR. K < J
     1        .OR. K > IEND) GO TO 10
        END IF
C * LIST IPR VALUE(S)
        IF (MODE == -1) THEN
          IF (K - J < 4) THEN
            WRITE (BCD, 99998, IOSTAT = IOST)
     1         (' ', I, IPR(I), I = J, K)
            IF (IWIN == 1) THEN
              BCD(80:80) = CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992, IOSTAT = IOST) BCD
            END IF
          ELSE
            WRITE (LU6, 99998, IOSTAT = IOST)
     1        (' ', I, IPR(I), I = J, K)
            GO TO 20
          END IF
C * LIST PAR VALUE(S)
        ELSE IF (MODE == -2) THEN
          IF (K - J < 3) THEN
            WRITE (BCD, 99997, IOSTAT = IOST)
     1        (' ', I, PAR(I), I = J, K)
            IF (IWIN == 1) THEN
              BCD(80:80) = CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992, IOSTAT = IOST) BCD
            END IF
          ELSE
            WRITE (LU6, 99997, IOSTAT = IOST)
     1        (' ', I, PAR(I), I = J, K)
            GO TO 20
          END IF
C * LIST IGBL VALUE(S)
        ELSE IF (MODE == -3) THEN
          IF (K - J < 3) THEN
            WRITE (BCD, 99999, IOSTAT = IOST)
     1        (' ', I, IGBL(I), I = J, K)
            IF (IWIN == 1) THEN
              BCD(80:80) = CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992, IOSTAT = IOST) BCD
            END IF
          ELSE
            WRITE (LU6, 99999, IOSTAT = IOST)
     1        (' ', I, IGBL(I), I = J, K)
            GO TO 20
          END IF
C * LIST RGBL VALUE(S)
        ELSE IF (MODE == -4) THEN
          IF (K - J < 3) THEN
            WRITE (BCD, 99993, IOSTAT = IOST)
     1        (' ', I, RGBL(I), I = J, K)
            IF (IWIN == 1) THEN
              BCD(80:80) = CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992, IOSTAT = IOST) BCD
            END IF
          ELSE
            WRITE (LU6, 99993, IOSTAT = IOST)
     1        (' ', I, RGBL(I), I = J, K)
            GO TO 20
          END IF
C * LIST CHK VALUE(S)
        ELSE IF (MODE == -5) THEN
          WRITE (LU6, 99987) (IPR(676 + I), IPR(720 + I) , I = 1, 3)
          IF (IWIN == 1) THEN
            WRITE (BCD, 99986, IOSTAT = IOST)
     1        (IPR(676 + I), IPR(720 + I) , I = 1, 3)
              BCD(80:80) = CHAR (0)
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 111)
          END IF
        END IF
      ELSE
        INDX = NINT (FN(1))
        IF (INDX > 0 .AND. INDX <= IEND) THEN
          IF (MODE == 1) THEN
            IVAL      = NINT (FN(2))
            IVALO     = IPR(INDX)
            IPR(INDX) = IVAL
            WRITE (BCD, 99991, IOSTAT = IOST) INDX, IVALO, IVAL
            IF (IWIN == 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994, IOSTAT = IOST) BCD(1:47)
            END IF
          ELSE IF (MODE == 2) THEN
            VAL       = FN(2)
            VALO      = PAR(INDX)
            PAR(INDX) = VAL
            WRITE (BCD, 99990, IOSTAT = IOST) INDX, VALO, VAL
            IF (IWIN == 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994, IOSTAT = IOST) BCD(1:47)
            END IF
          ELSE IF (MODE == 3) THEN
            IVAL       = NINT (FN(2))
            IVALO      = IGBL(INDX)
            IGBL(INDX) = IVAL
            WRITE (BCD, 99989, IOSTAT = IOST) INDX, IVALO, IVAL
            IF (IWIN == 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994, IOSTAT = IOST) BCD(1:47)
            END IF
          ELSE IF (MODE == 4) THEN
            VAL        = FN(2)
            VALO       = RGBL(INDX)
            RGBL(INDX) = VAL
            WRITE (BCD, 99988, IOSTAT = IOST) INDX, VALO, VAL
            IF (IWIN == 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994, IOSTAT = IOST) BCD(1:47)
            END IF
          END IF
        ELSE
          GO TO 10
        END IF
      END IF
      RETURN
   10 WRITE (BCD, 99996, IOSTAT = IOST) CHAR (0)
      IF (IWIN == 1) THEN
        CALL GGIP (-999.0, 2.0, 33.0, 111)
      ELSE
        WRITE (LU6, 99992, IOSTAT = IOST) BCD(1:32)
      END IF
      RETURN
   20 IF (IWIN == 1) THEN
        WRITE (BCD, 99995, IOSTAT = IOST) CHAR (0)
        CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 23.0, 111)
      END IF
      RETURN
99999 FORMAT (1('::',3(A, 'IGBL[', I3, '] =', I10, ', ')))
99998 FORMAT (1('::',4(A, 'IPR[', I3, ']', I8, ', ')))
99997 FORMAT (1('::',3(A, 'PAR[', I3, '] =', F12.4, ', ')))
99996 FORMAT ('E: Out of Range Error, Try again', A)
99995 FORMAT ('Output on Terminal Window', A)
99994 FORMAT (':: ', A)
99993 FORMAT (1('::',3(A, 'RGBL[', I3, '] =', F10.4, ', ')))
99992 FORMAT (A)
99991 FORMAT ('IPR(',  I3, ') old value =', I10,   ' new =', I10,   A)
99990 FORMAT ('PAR(',  I3, ') old value =', F10.4, ' new =', F10.4, A)
99989 FORMAT ('IGBL(', I3, ') old value =', I10,   ' new =', I10,   A)
99988 FORMAT ('RGBL(', I3, ') old value =', F10.4, ' new =', F10.4, A)
99987 FORMAT (/, 'RES', I6, 'R[', I5, 'C]', /,
     1         'HKL', I6, 'R[', I5, 'C]', /,
     2         'FAB', I6, 'R[', I5, 'C]', /)
99986 FORMAT ('RES', I6, 'R[', I5, 'C]', ' - ',
     1        'HKL', I6, 'R[', I5, 'C]', ' - ',
     2        'FAB', I6, 'R[', I5, 'C]')
      END SUBROUTINE PLA206
 
      SUBROUTINE PLA207
C * CAVITY SEARCH BASED ON A PROGRAM BY A. MUGNOLI (Univ. di Genova, 1992)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER :: MP1 = 10000
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: I0
      INTEGER            :: J0
      INTEGER            :: K0
      INTEGER            :: NT
      INTEGER            :: NAT
      INTEGER            :: IER
      INTEGER            :: IND
      INTEGER            :: INX
      INTEGER            :: NTOT
      INTEGER            :: NMIN
      INTEGER            :: NSYM
      INTEGER            :: INX5
      INTEGER            :: IAN0
      INTEGER            :: IDUM
      INTEGER            :: JDUM
      INTEGER            :: IVAL
      INTEGER            :: ITEST
      REAL               :: D2
      REAL               :: DMIN
      REAL               :: TEMP
      REAL               :: RADIUS
      REAL               :: GEN006
      REAL               :: GRIDIJK
      CHARACTER(len=4)   :: LABL
      INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: LGRD
      REAL,    ALLOCATABLE, DIMENSION(:, :)    :: XF
      REAL,    ALLOCATABLE, DIMENSION(:, :, :) :: GRID
      PAGET = 'CAVITY'
      NSYM  = IPR(255) * IPR(256) * IPR(257)
      NAT   = IPR(37)
      CALL PLA262 (0)
      WRITE (LU6, 99978) PAR(519), PAR(520)
C * MAP LIMITS AND INTERVALS: ALLOW ONE FURTHER STEP AT THE MARGINS OF THE MAP
      DO I = 1, 3
        K      = MIN (2, INT (PAR(100 + I) / 10.0))
        V2(I)  = PAR(571) / (2**K)
        ITR(I) = NINT (1.0 / V2(I)) + 3
      END DO
      WRITE (LU6, 99990, IOSTAT = IOST)
     1  (-V2(I), 1.0 + V2(I), V2(I), I = 1, 3)
      WRITE (LU7, 99990, IOSTAT = IOST)
     1  (-V2(I), 1.0 + V2(I), V2(I), I = 1, 3)
      WRITE (LU6, 99988, IOSTAT = IOST) (ITR(I), I = 1, 3)
      WRITE (LU7, 99988, IOSTAT = IOST) (ITR(I), I = 1, 3)
      WRITE (LU6, 99979) (V2(I) * PAR(100 + I), I = 1, 3)
      WRITE (LU7, 99979) (V2(I) * PAR(100 + I), I = 1, 3)
C * ALLOCATE
      ALLOCATE (GRID(ITR(1), ITR(2), ITR(3)),
     1          LGRD(ITR(1), ITR(2), ITR(3)),
     2          XF(6, MP1))
C * OPEN FILE FOR THE RESULTS OF THE CAVITY SEARCH (PLUTON DISPLAY)
      OPEN (UNIT = LU60, FILE = NAMEFIL(1:KNMFIL)//'_cavity.spf',
     1      STATUS = 'UNKNOWN')
      REWIND (LU60, IOSTAT = IOST)
C * WRITE TITL, CELL, SPGR, CONTENT INFO
      WRITE (LU60, 99999, IOSTAT = IOST)
     1   JID(1:74), PAR(519), (PAR(100 + I), I = 1, 6)
      IF (SPGRNM(1)(1:3) /= '   ') THEN
        WRITE (LU60, 99986, IOSTAT = IOST) SPGRNM(1)(1:7)
      ELSE
        WRITE (LU60, 99985, IOSTAT = IOST)
     1    SPGRNM(1)(13:13), SPGRNM(1)(14:14)
        DO I = 2, IPR(255)
          CALL SGSM (2, ICL, SGY, I, 0, IERR)
          WRITE (LU60, 99984, IOSTAT = IOST) ICL(1:60)
        END DO
      END IF
C * BUT DO NOT INCLUDE 'CG' ENTRY IN LISTING
      IF (LMT(IENS(IAN), 1) == 'Cg') THEN
        IAN0 = IAN - 1
      ELSE
        IAN0 = IAN
      END IF
C * REPORT ELEMENT TYPES AND VAN DER WAALS OR ION RADII
      WRITE (LU6, 99995, IOSTAT = IOST) (LMT(IENS(I),  1), I = 1, IAN0)
      WRITE (LU7, 99995, IOSTAT = IOST) (LMT(IENS(I),  1), I = 1, IAN0)
      WRITE (LU6, 99994, IOSTAT = IOST) (RADR(IENS(I), 4), I = 1, IAN0)
      WRITE (LU7, 99994, IOSTAT = IOST) (RADR(IENS(I), 4), I = 1, IAN0)
C * THE BOX IN WHICH ATOMS ARE GENERATED IS ENLARGED, TO ALLOW FOR
C * ATOMS NEAR THE BORDERS, COMING ONLY PARTIALLY INTO THE MAP
C * ORIGINAL AND SYMMETRY-RELATED ATOMS INSIDE THE ENLARGED BOX
      NTOT = 0
      DO N = 1, NAT
        CALL PLA047 (LABA(N), NQ1, IDUM, JDUM, IPR(71), IGBL(55), 0, 0)
        WRITE (LU60, 99998, IOSTAT = IOST) NQ1, (XXO(N, I), I = 1, 3)
        CALL GEN048 (-4, IFG(1, N), 15, IVAL)
        RADIUS = RADR(IVAL + 1, 4)
        DO I = 1, 3
          V3(I) = V2(I) + 1.5 * RADIUS / PAR(100 + I)
        END DO
        DO M = 1, NSYM
          DO I = 1, 3
            SGY(I + 3) = 0.0
            SGY(I)     = XXO(N, I)
          END DO
          CALL SGSM (3, ICL, SGY, M, 6, IERR)
C * BRING COORDINATES WITHIN UNITCELL BOUNDS
          DO I = 7, 9
            SGY(I) = MOD (SGY(I) + 10.0, 1.0)
          END DO
C * APPLY UNIT SHIFTS TO REPEAT ATOMS NEAR TO THE BORDERS
          DO L = -1, 1
            V8(3) = SGY(9) + L
            DO K = -1, 1
              V8(2) = SGY(8) + K
              DO 20 J = -1, 1
                V8(1) = SGY(7) + J
                DO I = 1, 3
                  IF (V8(I) < - V3(I) .OR.
     1                V8(I) > 1.0 + V3(I)) GO TO 20
                  XF(I, NTOT + 1) = V8(I)
                END DO
                IF (NTOT /= 0) THEN
C * AVOID ATOMS REPEATED ON THE SAME POSITION
                  DO 10 NT = 1, NTOT
                    DO I = 1, 3
                      V4(I) = ABS (XF(I, NT) - V8(I))
                      IF (V4(I) > V2(I)) GO TO 10
                    END DO
                    GO TO 20
   10             CONTINUE
                END IF
                NTOT = NTOT + 1
                IF (NTOT >= MP1) THEN
                  WRITE (LU6, 99989, IOSTAT = IOST) MP1
                  GO TO 40
                END IF
                XF(4, NTOT) =  RADIUS
                XF(5, NTOT) = (RADIUS + PAR(519)) ** 2
                XF(6, NTOT) = FLOAT(N)
   20         CONTINUE
            END DO
          END DO
        END DO
      END DO
C * ASSIGN MINIMUM DISTANCE TO VD WAALS SURFACE OF GRIDPOINTS (I,J,K)
      DO K = -1, ITR(3) - 2
        V5(3) = K * V2(3)
        DO J = -1, ITR(2) - 2
          V5(2) = J * V2(2)
          DO I = -1, ITR(1) - 2
            V5(1) = I * V2(1)
C * THE RADIUS OF THE LARGEST CAVITY MUST NOT EXCEED 99.9 A
            DMIN = 99.9
            NMIN = 0
            DO N = 1, NTOT
              DO L = 1, 3
                V6(L) = XF(L, N) - V5(L)
              END DO
              D2 = GEN006 (V6, AA, V6)
              IF (D2 <= XF(5, N)) THEN
                DMIN = 0.0
                NMIN = 0
                EXIT
              ELSE
C * TEMP IS ALWAYS POSITIVE
                TEMP = SQRT (D2) - XF(4, N)
                IF (TEMP < DMIN) THEN
                  DMIN = TEMP
                  NMIN = N
                END IF
              END IF
            END DO
            GRID(I + 2, J + 2, K + 2) = DMIN
            IF (NMIN /= 0)
     1      LGRD(I + 2, J + 2, K + 2) = NINT(XF(6, NMIN))
          END DO
        END DO
      END DO
C * PEAK SEARCH
      WRITE (LU6, 99987, IOSTAT = IOST) PAR(519)
      WRITE (LU7, 99987, IOSTAT = IOST) PAR(519)
C * COMPARE WITH 26 NEIGHBOR GRIDPOINTS
      INX = 0
      DO K = 0, ITR(3) - 3
        DO J = 0, ITR(2) - 3
          DO 30 I = 0, ITR(1) - 3
            GRIDIJK = GRID(I + 2, J + 2, K + 2)
            N       = LGRD(I + 2, J + 2, K + 2)
            IF (GRIDIJK > PAR(519)) THEN
              DO I0 = 1, 3
                DO J0 = 1, 3
                  DO K0 = 1, 3
                    IF (I0 /= 2 .OR. J0 /= 2 .OR. K0 /= 2)
     1                THEN
C * ESCAPE WHEN NEIGHBORING GRIDPOINT HAS HIGHER DISTANCE
                      IF (GRIDIJK < GRID (I + I0, J + J0,
     1                    K + K0)) GO TO 30
                    END IF
                  END DO
                END DO
              END DO
              INX5           = INX * 5
              VOID(INX5 + 1) = GRIDIJK
              VOID(INX5 + 2) = V2(1) * I
              VOID(INX5 + 3) = V2(2) * J
              VOID(INX5 + 4) = V2(3) * K
              VOID(INX5 + 5) = N
              INX            = INX + 1
            END IF
   30     CONTINUE
        END DO
      END DO
      NT = INX * 5 - 4
C * PEAK SORT
      DO
        ITEST = 0
        DO I = 1, NT - 5, 5
          J = I + 5
          IF (VOID(I) < VOID(J)) THEN
            DO K = 0, 4
              CALL GEN018 (VOID(I + K), VOID(J + K))
            END DO
            ITEST = ITEST + 1
          END IF
        END DO
        IF (ITEST == 0) EXIT
      END DO
      IF (INX > 0) THEN
        WRITE (LU7, 99996, IOSTAT = IOST)
        WRITE (LU6, 99996, IOSTAT = IOST)
        WRITE (LU7, 99992, IOSTAT = IOST)
        WRITE (LU6, 99992, IOSTAT = IOST)
        IND = 0
        DO I = 1, NT, 5
          IND = IND + 1
C * GENERATE LABEL
          IF (IND > 99) THEN
            WRITE (LABL, 99982, IOSTAT = IOST) IND
          ELSE IF (IND > 9) THEN
            WRITE (LABL, 99981, IOSTAT = IOST) IND
          ELSE
            WRITE (LABL, 99980, IOSTAT = IOST) IND
          END IF
          N   = NINT (VOID(I + 4))
          NQ1 = ' '
          IF (N /= 0) CALL PLA047 (LABA(N), NQ1, IDUM, JDUM, IPR(71),
     1      IGBL(55), 0, 0)
          WRITE (LU7, 99991, IOSTAT = IOST)
     1      IND, (VOID(I + J), J = 1, 3), VOID(I), LABL, NQ1
          WRITE (LU6, 99991, IOSTAT = IOST)
     1      IND, (VOID(I + J), J = 1, 3), VOID(I), LABL, NQ1
          WRITE (LU60, 99998, IOSTAT = IOST)
     1      LABL, (VOID(I + J), J = 1, 3)
          WRITE (LU60, 99983, IOSTAT = IOST) LABL,  VOID(I)
        END DO
        WRITE (LU6, 99977)
        WRITE (LU60, 99997, IOSTAT = IOST)
        CLOSE (UNIT = LU60)
        IF (VOID(1) < 7.5) THEN
C * RUN SPAWNED PLUTON/CAVITY JOB
          IER = 0
          CALL SPAWN
     1  (PLAPATH(1:IGBL(80))//' -p '//NAMEFIL(1:KNMFIL)//'_cavity.spf',
     2  LU6, .true., IER)
        END IF
      ELSE
        WRITE (LU6, 99993, IOSTAT = IOST)
        CALL PLA015 (0, 52)
      END IF
C * DEALLOCATE
   40 DEALLOCATE (GRID, LGRD, XF)
      RETURN
99999 FORMAT ('TITL ', A, /, 'TEXT CAVITY', F5.1, /,'CELL', 6F12.4)
99998 FORMAT ('ATOM ', A, 3F10.4)
99997 FORMAT ('JOIN RADII UNIQUE', /, 'STRAW COLOR', /, 'UNITCELL', /,
     1 'PACK RANGE -0.1 1.1 -0.1 1.1 -0.1 1.1', /, 'PLOT')
99996 FORMAT (//, 5X, 'Centers of CAVITIES in the Unit Cell with',
     1       ' Their Radius', /)
99995 FORMAT (/, 'van der Waals (or ion) Radii used in the Cavity',
     1        ' Analysis', /, 80('='), /, 16(3X, A))
99994 FORMAT (80('-'), /, 16F5.2)
99993 FORMAT (/, ':: No CAVITY''S Found in this Structure', /)
99992 FORMAT (5X, 'Cavity No.', 9X, 'X', 7X, 'Y', 7X, 'Z', 3X,
     1        'Radius (Ang) Label CloseTo', /)
99991 FORMAT (5X, I4, 9X, 3F8.3, 7X, F7.2, 2X, A, 1X, A)
99990 FORMAT (//, 5X, 'Map Intervals and Limits Along X,Y,Z', //,
     1        2X, 3(3X, 3F7.4))
99989 FORMAT (//, 1X, 'The Limit of', I5,
     1        ' Generated ATOMS has been Reached. (MP1)')
99988 FORMAT (/, 5X, 'Number of Map Points Along X, Y, Z = ', 3I5, /)
99987 FORMAT (/, 5X, 'Minimum CAVITY Radius to be Considered (Ang) =',
     2        F6.2, /)
99986 FORMAT ('SPGR ', A)
99985 FORMAT ('LATT ', A, 2X, A)
99984 FORMAT ('SYMM ', A)
99983 FORMAT ('RADII ATOMS ', A, F10.3)
99982 FORMAT ('X', I3)
99981 FORMAT ('X', I2)
99980 FORMAT ('X', I1)
99979 FORMAT (/,20X, 'Step (Ang)', 3F10.3, /)
99978 FORMAT (/, ':: Default Void Radii Search Range:', 2F8.2,
     1 'Ang.', /)
99977 FORMAT (//, 'Notes:', /,
     1 '1 - Invoke ''CAVITY radius'' for non-default cavity radius', /,
     2 '2 - Issue ''SET VDW el radius ...'' for non-default radii')
      END SUBROUTINE PLA207
 
      SUBROUTINE PLA208
C * EXPAND ASYMMETRIC UNIT CONTENTS TO P1, EXPAND REFLECTION SET
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: N
      INTEGER                :: MN
      INTEGER                :: NB
      INTEGER                :: NE
      INTEGER                :: IP
      INTEGER                :: NR
      INTEGER                :: NS
      INTEGER                :: NSO
      INTEGER                :: NAT
      INTEGER                :: NO1
      INTEGER                :: IHAT
      INTEGER                :: NRES
      INTEGER                :: NATO
      INTEGER                :: IENR
      INTEGER                :: ISCFT
      INTEGER                :: NANIS
      INTEGER                :: IANIS
      INTEGER, DIMENSION(16) :: NCT
      IPR(495) = 0
      NB       = 1
      NE       = 80
C * SET NCT ELEMENTS TO ZERO
      CALL GEN097 (NCT, 1, 16, 0)
C * HANDLE CELL PARAMETERS
      CALL PLA100
C * SETUP CONNECTED SET
      CALL PLA287 (1, 1, 1)
      NAT  = IPR(37)
      NRES = IPR(75)
      NATO = IPR(589)
C * OPEN & WRITE EXPANDED 'RES' FILE
      OPEN (UNIT = LU62, FILE = NAMEFIL(1:KNMFIL)//'_exp.ins',
     1                                     STATUS = 'UNKNOWN')
      WRITE (LU62, 99999, IOSTAT = IOST) JID(1:74), PAR(17),
     1       (PAR(100 + I), I = 1, 6), (PAR(106 + I), I = 1, 6)
C * LOOK FOR AND ELIMINATE 'ELEMENT' Cg
      IF (LMT(IAN, 1) == 'Cg') THEN
        DO I = 1, IAN
          IF (IENS(I) == IAN) THEN
            IF (I < IAN) THEN
              DO J = I + 1, IAN
                IENS(J - 1) = IENS(J)
              END DO
            END IF
            IAN = IAN - 1
            EXIT
          END IF
        END DO
      END IF
C * SFAC RECORD
      WRITE (LU62, 99998, IOSTAT = IOST) (LMT(IENS(I), 1), I = 1, IAN)
C * UNIT RECORD
      WRITE (LU62, 99997, IOSTAT = IOST)
     1  (NINT(CONT(IENS(I), 2)), I = 1, IAN)
      DO N = 1, NRES
        NSO = 0
        DO I = 1, NATO
          IF (XXO(I, 4) /= 0.0) THEN
            CALL GEN048 (-6, IFG(1, I), 9, NR)
            IF (NR == N) THEN
              CALL PLA047 (LABA(I), NQ1, MN, IENR, 0, IGBL(55),
     1          0, 0)
              CALL GEN048 (-4, IFG(1, I), 15, NO1)
              NO1      = NO1 + 1
              NCT(NO1) = NCT(NO1) + 1
              CALL GEN048 (-1, IFG(1, I),  4, IANIS)
              CALL GEN048 (-1, IFG(1, I),  7, IHAT)
C * TAKE CARE OF ELEMENT RESHUFLING
              DO L = 1, IAN
                IF (IENS(L) == NO1) THEN
                  ISCFT = L
                  EXIT
                END IF
              END DO
              NQ3 = LMT(NO1, 1)
              IF (NQ3(1:1) == ' ') THEN
                NQ2 = NQ3(2:2)//'      '
              ELSE
                NQ2 = NQ3(1:2)//'     '
              END IF
              CALL GEN040 (NCT(NO1), NQ3, IP)
              IF (NQ2(2:2) == ' ') THEN
                NQ2(2:) = NQ3(1:IP)
              ELSE
                NQ2(3:) = NQ3(1:IP)
              END IF
              NS = (I - 1) / NAT + 1
              IF (NS /= NSO) THEN
                DO K = 1, 3
                  V2(K) = 0.0
                  DO WHILE (XXO(I, K) + V2(K) < 0.0)
                    V2(K) = V2(K) + 1.0
                  END DO
                END DO
                DO K = 1, 3
                  DO WHILE (XXO(I, K) + V2(K) >= 1.0)
                    V2(K) = V2(K) - 1.0
                  END DO
                END DO
                NSO = NS
                DO K = 1, 3
                  SGY(K + 3) = V2(K)
                END DO
                CALL SGSM (20, ICL, SGY, NS, 0, IERR)
                CALL GEN047 (ICL, 1, 80)
                CALL GEN039 (1, ICL, 1, 80, NB, NE)
              END IF
              WRITE (LU62, 99993, IOSTAT = IOST) NQ2, NQ1, ICL(1:NE)
C * WRITE COORDINATES + POPULATION
              WRITE (LU62, 99995, IOSTAT = IOST)
     1          NQ2, ISCFT, (XXO(I, J) + V2(J), J = 1, 3),
     2          XXO(I, 4) + 10.0
C * REMOVE ISOTROPIC FLAG
              IF (IANIS == 0) THEN
                XSD(I, 1) = MOD (XSD(I, 1), 100.0) + IHAT * 10.0
                NANIS     = 1
              ELSE
                NANIS     = 6
              END IF
C * WRITE DISPLACEMENT PARAMETERS
              WRITE (LU62, 99994, IOSTAT = IOST)
     1          (XSD(I, J), J = 1, NANIS)
            END IF
          END IF
        END DO
      END DO
      WRITE (LU62, 99996, IOSTAT = IOST)
      CLOSE (UNIT = LU62)
C * EXPAND REFLECTION SET
      IF (IGBL(15) /= -1) THEN
        IPR(408) = -1
        CALL PLA145 (0)
C * COPY EXPANDED REFLECTION SET
        IF (IPR(373) > 0) THEN
          OPEN (UNIT = LU63, FILE = NAMEFIL(1:KNMFIL)//'_exp.hkl',
     1                                       STATUS = 'UNKNOWN')
          REWIND (UNIT = LU17, IOSTAT = IOST)
          DO
            READ  (LU17, 99992, IOSTAT = IOST) IDM
            IF (IOST /= 0) GO TO 10
            WRITE (LU63, 99992, IOSTAT = IOST) IDM(1:28)
          END DO
          CLOSE (UNIT = LU63)
        END IF
      END IF
   10 CLOSE (UNIT = LU17, STATUS = 'DELETE')
      IF (IPR(2) == 0) IPR(2) = -12
      RETURN
99999 FORMAT ('TITL ', A, /,
     1        'CELL ', F9.5, 3F10.4, 3F10.3, /,
     2        'ZERR 1', 3F10.4, 3F10.3, /,
     3        'LATT -1')
99998 FORMAT ('SFAC ', 16(1X, A))
99997 FORMAT ('UNIT ', 2I5, 14I4)
99996 FORMAT ('HKLF 4', /, 'END')
99995 FORMAT (A, I3, 4F10.4, ' =')
99994 FORMAT (5X, 6F10.6)
99993 FORMAT (7X, 'new: ', A, ' is old: ', A, '[', A, ']')
99992 FORMAT (A)
      END SUBROUTINE PLA208
 
      SUBROUTINE PLA209
C * PREPARE FOR RENDER3D
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: NB
      INTEGER               :: NE
      INTEGER               :: NS
      INTEGER               :: NCD
      INTEGER               :: IAT
      INTEGER               :: JAT
      INTEGER               :: ICOL
      INTEGER               :: JCOL
      INTEGER               :: IDUM
      INTEGER               :: KNCD
      INTEGER               :: IEN1
      INTEGER               :: IEN2
      INTEGER               :: IENR1
      INTEGER               :: IENR2
      INTEGER               :: FINDEXE
      REAL                  :: X
      REAL                  :: Y
      REAL                  :: Z
      REAL                  :: TX
      REAL                  :: TY
      REAL                  :: TZ
      REAL                  :: RAD
      REAL                  :: XMARG
      REAL                  :: XROOM
      REAL                  :: YROOM
      REAL                  :: ZROOM
      REAL                  :: SCHAAL
      REAL                  :: RADIUS
      REAL                  :: RADLIM
      REAL                  :: ASPECT
      REAL                  :: GEN061
      REAL, DIMENSION(4, 4) :: QP
      REAL, DIMENSION(4, 4) :: UU
      REAL, DIMENSION(4, 4) :: QQQ
      REAL, DIMENSION(4, 4) :: UINV
      REAL, DIMENSION(4, 4) :: TEMP
      REAL, DIMENSION(4, 4) :: EVECS
      REAL, DIMENSION(4)    :: EIGENS
      REAL, DIMENSION(10)   :: QUADRIC
      REAL, DIMENSION(4, 4) :: EVECINV
      REAL, DIMENSION(4, 4) :: EVECIT
      CHARACTER(len=4)      :: REDIR
      CHARACTER(len=5)      :: TIFF
      IF (DOS) THEN
        REDIR = ' -i '
      ELSE
        REDIR = '  < '
      END IF
      IF (IGBL(109) == 0) THEN
        TIFF = 'tiff'
      ELSE
        TIFF = 'png'
      END IF
C * RADIUS DRAWS BONDS WITH THIS RADIUS IN ANGSTROMS (DEFAULT = 0.10)
C * IPR(148)      INCREASINGLY COMPLEX RENDITION OF ELLIPSOIDS
C *           1  [DEFAULT] SOLID SURFACE ONLY
C *           2  EQUATORIAL PLANES ONLY
C *           3  EQUATORIAL PLANES + TRANSPARENT ELLIPSOID
      CALL GEN021 (EVECINV, 0.0)
      ASPECT = 1280.0 / 1024.0
      RADIUS = 0.10
      XMARG  = 1.15
      RAD    = PAR(46) / (4.0 * RGBL(5))
      OPEN (UNIT = LU64, FILE = NAMEFIL(1:KNMFIL)//'.rst',
     1                          STATUS = 'UNKNOWN')
      OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'.r3d',
     1                          STATUS = 'UNKNOWN')
 
      TX = - (PAR(58) + PAR(55)) / 2.0
      TY = - (PAR(59) + PAR(56)) / 2.0
      TZ = - (PAR(60) + PAR(57)) / 2.0
      IF (ASPECT >= 1.0) THEN
C * THE X DIRECTION IS WIDER THAN THE Y
        XROOM = ASPECT
        YROOM = 1.0
        ZROOM = 2.0
      ELSE
        XROOM = 1.0
        YROOM = ASPECT
        ZROOM = 2.0
      END IF
      SCHAAL = MAX ((PAR(58) - PAR(55) + 2 * RAD) / XROOM,
     1             (PAR(59)  - PAR(56) + 2 * RAD) / YROOM,
     2             (PAR(60)  - PAR(57) + 2 * RAD) / ZROOM)
C * LEAVE A LITTLE EXTRA ROOM AS A BORDER:
      SCHAAL = SCHAAL / 0.90
      WRITE (LU65, 99999, IOSTAT = IOST) TX, TY, TZ, SCHAAL
C * WRITE BONDS TO FILE.
C * IF TWO ATOMS OF DIFFERENT COLORS ARE BONDED, MAKE HALF-BOND
C * CYLINDERS WITH EACH COLOR.
      IF (RADIUS > 0.0) THEN
        KNCD = IPR(39) + IPR(64)
        DO NCD = 1, IPR(131)
          KNCD = KNCD + 1
          IAT = NINT (XSD(KNCD, 4))
          JAT = NINT (XSD(KNCD, 5))
          CALL PLA047 (LABA(IAT), NQ1, IDUM, IENR1, 0, IGBL(55),
     1      1, 0)
          CALL PLA047 (LABA(JAT), NQ2, IDUM, IENR2, 0, IGBL(55),
     1      1, 0)
          CALL GEN048 (-4,  IFG(1, IAT), 15, IEN1)
          CALL GEN048 (-4,  IFG(1, JAT), 15, IEN2)
          ICOL = IACL(IEN1 + 1)
          JCOL = IACL(IEN2 + 1)
          CALL GEN108 (LU64, 0)
          NS = 0
          DO
            READ (LU64, 99988, IOSTAT = IOST) LINE
            IF (IOST /= 0) EXIT
            WRITE (LU6, 99988) LINE
            IF (LINE(1:4) == 'ATOM') THEN
              IF (NQ1(1:7) == LINE(13:19)) THEN
                READ (LINE(31:54), 99990) V1(1), V1(2), V1(3)
                NS = NS + 1
              ELSE IF (NQ2(1:7) == LINE(13:19)) THEN
                READ (LINE(31:54), 99990) V2(1), V2(2), V2(3)
                NS = NS + 1
              END IF
              IF (NS > 1) THEN
                WRITE (LU65, 99993, IOSTAT = IOST) NQ1(1:7), NQ2(1:7)
                IF (ICOL == JCOL) THEN
                  WRITE (LU65, 99994, IOSTAT = IOST)
     1             (V1(K), K = 1, 3), RADIUS, (V2(K), K = 1, 3), RADIUS,
     2             RGB(1, ICOL), RGB(2, ICOL), RGB(3, ICOL)
                ELSE
                  DO K = 1, 3
                    V3(K) = (V1(K) + V2(K)) / 2
                  END DO
                  WRITE (LU65, 99994, IOSTAT = IOST)
     1              (V1(K), K = 1, 3), RADIUS, (V3(K), K = 1, 3),
     2              RADIUS, RGB(1, ICOL), RGB(2, ICOL), RGB(3, ICOL)
                  WRITE (LU65, 99994, IOSTAT = IOST)
     1              (V3(K), K = 1, 3), RADIUS, (V2(K), K = 1, 3),
     2              RADIUS, RGB(1, JCOL), RGB(2, JCOL), RGB(3, JCOL)
                END IF
                EXIT
              END IF
            END IF
          END DO
        END DO
      END IF
      IF (IPR(148) /= 0) THEN
        NB = 1
        NE = 2
        IF (IPR(148) == 1) NB = 2
        IF (IPR(148) == 2) NE = 1
C * WRITE ELLIPSOIDS + OPTIONAL MAIN PLANES TO INPUT FILE FOR RENDER
        DO NS = NB, NE
          CALL GEN108 (LU64, 0)
   10     READ (LU64, 99988, IOSTAT = IOST) LINE
          IF (IOST == -1) GO TO 30
          IF (LINE(1:4) == 'ATOM') THEN
            IF (LINE(13:13) /= ' ') CALL GEN020 (-1, LINE, 14, 14)
            IF (LINE(13:14) /= 'CG') THEN
              DO I = 1, 16
                IF (LINE(13:14) == LMT(I, 1)) THEN
                  ICOL = IACL(I)
                  GO TO 20
                END IF
              END DO
              ICOL = 1
            ELSE
              GO TO 10
            END IF
   20       READ (LINE(31:54), 99990) X, Y, Z
            READ (LU64, 99988, IOSTAT = IOST) LINE
            IF (IOST == -1) GO TO 30
            READ (LINE(29:70), 99989) (DUMA(I), I = 1, 6)
            CALL GEN074 (EIGENS, 1,  3, 0.0)
            CALL GEN074 (EVECS,  1, 16, 0.0)
            CALL GEN074 (UU,     1, 16, 0.0)
            CALL GEN074 (UINV,   1, 16, 0.0)
            EIGENS(4)   = 1.0
            EVECS(4, 4) = 1.0
C * CONVERT ANISOU DESCRIPTION OF ANISOTROPIC DISPLACEMENT PARAMETERS
C * INTO QUADRIC SURFACE ENCLOSING A GIVEN PROBABILITY VOLUME
C * RETURNS -1 IF THE UIJ ARE NON-POSITIVE DEFINITE, 1 OTHERWISE
C * BUILD MATRIX FROM UIJ COEFFICIENTS AND INVERT IT
            UU(1, 1) = DUMA(1) / 10000
            UU(2, 2) = DUMA(2) / 10000
            UU(3, 3) = DUMA(3) / 10000
            UU(4, 4) = - (1.0 / PAR(46) ** 2)
            UU(1, 2) = DUMA(4) / 10000
            UU(2, 1) = DUMA(4) / 10000
            UU(2, 3) = DUMA(6) / 10000
            UU(3, 2) = DUMA(6) / 10000
            UU(1, 3) = DUMA(5) / 10000
            UU(3, 1) = DUMA(5) / 10000
C * CALL EXIT/STOP
            IF (GEN061 (UU, UINV) == 0.0)
     1        CALL GEN127 ('PLA209')
C * AND FROM THAT WE EXTRACT THE COEFFICIENTS OF THE SURFACE
            QUADRIC(1)  = UINV(1, 1)
            QUADRIC(2)  = UINV(2, 2)
            QUADRIC(3)  = UINV(3, 3)
            QUADRIC(4)  = UINV(1, 2)
            QUADRIC(5)  = UINV(2, 3)
            QUADRIC(6)  = UINV(1, 3)
            QUADRIC(7)  = UINV(1, 4)
            QUADRIC(8)  = UINV(2, 4)
            QUADRIC(9)  = UINV(3, 4)
            QUADRIC(10) = UINV(4, 4)
C * FIND EIGENVALUES OF THE ELLIPSOID
            CALL GEN064 (UU, 3, 4, EIGENS, EVECS)
C * UNITS OF THIS MATRIX ARE A**2; WE WANT VALUES IN A
            DO I = 1, 3
              IF (EIGENS(I) > 0.0) THEN
                EIGENS(I) = SQRT (EIGENS(I))
              ELSE
                GO TO 10
              END IF
            END DO
            RADLIM = PAR(46) * MAX (EIGENS(1), EIGENS(2), EIGENS(3))
     1             * XMARG
            IF (NS == 1) THEN
C * CONSTRUCT 3 QUADRICS CORRESPONDING TO THE 3 ORTHOGONAL PLANES
C * THROUGH THE CENTER OF OUR ELLIPSOID
C * CALL EXIT/STOP
              IF (GEN061 (EVECS, EVECINV) == 0.0)
     1          CALL GEN127 ('PLA209')
              CALL GEN060 (EVECINV, EVECIT)
              DO K = 1, 3
                DO I = 1, 4
                  DO J = 1, 4
                    QQQ(I, J) = 0.0
                  END DO
                  QQQ(I, I) = 1.0 / EIGENS(I)**2
                END DO
                QQQ(K, K) = 1000.0
                QQQ(4, 4) = - PAR(46) ** 2
                CALL GEN059 (QQQ, EVECINV, TEMP)
                CALL GEN059 (EVECIT, TEMP, QP)
                IF (ICOL /= 8) THEN
                  WRITE (LU65, 99996, IOSTAT = IOST)
     1              LINE(13:19), X, Y, Z, RADLIM,
     2              (RGB(L, ICOL), L = 1, 3)
                  WRITE (LU65, 99995, IOSTAT = IOST)
     1              QP(1, 1), QP(2, 2), QP(3, 3), QP(1, 2), QP(2, 3),
     2              QP(1, 3), QP(1, 4), QP(2, 4), QP(3, 4), QP(4, 4)
                END IF
              END DO
            ELSE
              IF (ICOL /= 8) THEN
                WRITE (LU65, 99996, IOSTAT = IOST)
     1            LINE(13:19), X, Y, Z, RADLIM,
     2            (RGB(K, ICOL), K = 1, 3)
                WRITE (LU65, 99995, IOSTAT = IOST)
     1           (QUADRIC(I), I = 1, 10)
              END IF
            END IF
          END IF
          GO TO 10
C * SET TRANSPARENCY FOR ENCLOSING ELLIPSOIDS
   30     IF (NS == 1) THEN
            IF (IPR(148) == 3) THEN
              WRITE (LU65, 99998, IOSTAT = IOST)
            ELSE IF (IPR(148) == 2) THEN
              GO TO 40
            END IF
          ELSE
            IF (IPR(148) == 3) WRITE (LU65, 99997, IOSTAT = IOST)
          END IF
        END DO
      END IF
   40 CLOSE (UNIT = LU64)
      CLOSE (UNIT = LU65)
      CALL GEN038 (CGETENV, 1, 255)
      NE = FINDEXE ('R3DEXE', CGETENV, 'render')
      IF (NE > 0) THEN
        CGETENV(NE + 1:)  = REDIR//NAMEFIL(1:KNMFIL)//
     1 '.r3d  -'//TIFF//NAMEFIL(1:KNMFIL)//'.'//TIFF
        KERR = 0
        CALL SPAWN (CGETENV, LU6, .true., KERR)
        CALL GEN038 (CGETENV, 1, 255)
        NE = FINDEXE ('XVWEXE', CGETENV, 'display')
        IF (NE == 0) THEN
          WRITE (LU6, 99992, IOSTAT = IOST)
          NE = FINDEXE ('XVWEXE', CGETENV, 'xv')
        END IF
        IF (NE == 0) THEN
          WRITE (LU6, 99991, IOSTAT = IOST)
          NE = FINDEXE ('XVWEXE', CGETENV, 'gimp')
        END IF
        IF (NE > 0) THEN
          CGETENV(NE + 1:) = ' '//NAMEFIL(1:KNMFIL)//'.'//TIFF//' &'
          KERR = 0
          CALL SPAWN (CGETENV, LU6, .true., KERR)
        END IF
      ELSE
        CALL PLA015 (0, 9)
      END IF
      RETURN
99999 FORMAT ('PLATON-TO-RASTER3D', /,
     1        '80  64    TILES IN X,Y', /,
     2        '12  12    PIXELS (X,Y) PER TILE', /,
     3        '4         3X3 VIRTUAL PIXELS -> 2X2 PIXELS', /,
     4        '0.3 0.6 1.0      BACKGROUND', /,
     5        'F         NO, SHADOWS ARE DORKY', /,
     6        '25        PHONG POWER', /,
     7        '0.15      SECONDARY LIGHT CONTRIBUTION', /,
     8        '0.05      AMBIENT LIGHT CONTRIBUTION', /,
     9        '0.25      SPECULAR REFLECTION COMPONENT', /,
     *        '0.0       NO PERSPECTIVE', /,
     1        '1 1 1     MAIN LIGHT SOURCE POSITION', /,
     2        '1 0 0 0   INPUT CO-ORDINATE + RADIUS TRANSFORMATION', /,
     3        '0 1 0 0', /, '0 0 1 0', /,  4F10.3, /,
     4        '3         MIXED OBJECT TYPES', /,
     5        '*', /, '*', /, '*')
99998 FORMAT ('9 BEGIN TRANSPARENT ELLIPSOIDS', /, '8 ', /,
     1        ' 15.  0.6   1.0 1.0 1.0   0.6   0 0 0 0')
99997 FORMAT ('9 END TRANSPARENT ELLIPSOIDS')
99996 FORMAT ('# ', A, /, '14', /, 7F8.3)
99995 FORMAT (10F12.4)
99994 FORMAT ('3', /, 11F8.3)
99993 FORMAT ('#', 2(1X, A))
99992 FORMAT ('program display not found, try xv')
99991 FORMAT ('program xv not found, try gimp')
99990 FORMAT (3F8.3)
99989 FORMAT (6F7.0)
99988 FORMAT (A)
      END SUBROUTINE PLA209
 
      SUBROUTINE PLA210 (X, Y)
C * CHECK FOR NEW PLATON SOURCE/VERSION & DOWNLOAD
      USE files
      USE parameters
      USE cggt
      IMPLICIT NONE
      INTEGER           :: FINDEXE
      REAL              :: X
      REAL              :: Y
      CHARACTER(len=80) :: BUF
C STRIP_END
      RETURN
99999 FORMAT (':: Downloaded: platon.f.gz')
99998 FORMAT (':: Downloaded: xdrvr.c.gz')
99997 FORMAT (':: Downloaded: PLATON-COMPILE-README')
99996 FORMAT (/, ':: Latest ''platon.zip'' downloaded to current ',
     1 'working directory')
99995 FORMAT ('Latest ''platon.zip'' downloaded to working directory',
     1 A)
99994 FORMAT
     1 ('Latest platon.f.gz, xdrvr.c.gz downloaded in working directory'
     2 , A)
99993 FORMAT (/, '** The curl download utility is not available **', /)
      END SUBROUTINE PLA210
 
      MODULE symmol
      SAVE
      INTEGER,           PARAMETER     :: NMA = 550
      INTEGER,           PARAMETER     :: NMG = 120
      INTEGER                          :: NMS
      INTEGER, DIMENSION(NMA)          :: IV
      INTEGER, DIMENSION(NMA)          :: MN
      INTEGER, DIMENSION(NMA, NMG)     :: MK
      INTEGER, DIMENSION(NMA, 2)       :: MD
      INTEGER, DIMENSION(NMG, NMG)     :: MTG
      INTEGER, DIMENSION(NMG)          :: ISU
      INTEGER, DIMENSION(NMA)          :: NGE
      INTEGER, DIMENSION(NMA)          :: IAT
      INTEGER, DIMENSION(NMA)          :: MEQ
      INTEGER, DIMENSION(NMA)          :: IASU
      REAL                             :: DCM
      REAL                             :: CSMT
      REAL                             :: RMST
      REAL,    DIMENSION(NMA)          :: D
      REAL,    DIMENSION(3, NMA)       :: XO
      REAL,    DIMENSION(3, NMA)       :: XS
      REAL,    DIMENSION(3, NMA)       :: CO
      REAL,    DIMENSION(NMA)          :: DC
      REAL,    DIMENSION(NMA)          :: CF
      REAL,    DIMENSION(NMA)          :: DA
      REAL,    DIMENSION(3, 3)         :: AL
      REAL,    DIMENSION(3, 3)         :: OT
      REAL,    DIMENSION(3, 3)         :: ALX
      REAL,    DIMENSION(3, 3)         :: AAY
      REAL,    DIMENSION(3, 3)         :: ORI
      REAL,    DIMENSION(3, 3)         :: ORX
      REAL,    DIMENSION(3, 3)         :: OTI
      REAL,    DIMENSION(3)            :: RIN
      REAL,    DIMENSION(4)            :: DEL
      REAL,    DIMENSION(3, NMG)       :: TRL
      REAL,    DIMENSION(3, 3, NMG)    :: SIM
      REAL,    DIMENSION(3, NMA)       :: COY
      REAL,    DIMENSION(NMA)          :: WWW
      REAL,    DIMENSION(NMG)          :: CSM
      REAL,    DIMENSION(NMA)          :: WGHT
      REAL,    DIMENSION(NMG)          :: DEVX
      REAL,    DIMENSION(3, NMA)       :: RMSX
      REAL,    DIMENSION(3)            :: BARC
      REAL,    DIMENSION(3)            :: BARO
      REAL,    DIMENSION(4)            :: DELM
      CHARACTER(len=3), DIMENSION(NMG) :: LBLS
      CHARACTER(len=3), DIMENSION(32)  :: PNTGR
      END MODULE symmol
 
      SUBROUTINE PLA211 (JID, IWEIGHT)
C * ADAPTED FROM SYMMOL: T. Pilati & A. Forni, J.Appl.Cryst. (1998), 31,
C *                      503-504 & (2000), 33, 417.
C * MOLSYS (1)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE xwdw
      USE symmol
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: I1
      INTEGER            :: I2
      INTEGER            :: I3
      INTEGER            :: I4
      INTEGER            :: J1
      INTEGER            :: N1
      INTEGER            :: N2
      INTEGER            :: NA
      INTEGER            :: IB
      INTEGER            :: IC
      INTEGER            :: II
      INTEGER            :: JJ
      INTEGER            :: MM
      INTEGER            :: MO
      INTEGER            :: MV
      INTEGER            :: ND
      INTEGER            :: IU
      INTEGER            :: MOO
      INTEGER            :: IN1
      INTEGER            :: IN2
      INTEGER            :: INV
      INTEGER            :: IER
      INTEGER            :: IES
      INTEGER            :: IAI
      INTEGER            :: IAX
      INTEGER            :: IPP
      INTEGER            :: NES
      INTEGER            :: MMD
      INTEGER            :: NO1
      INTEGER            :: NDCM
      INTEGER            :: NAX2
      INTEGER            :: NASS
      INTEGER            :: MORD
      INTEGER            :: MDEG
      INTEGER            :: LAX2
      INTEGER            :: IRES
      INTEGER            :: IPRW
      INTEGER            :: IHAT
      INTEGER            :: ICOM
      INTEGER            :: IDCM
      INTEGER            :: IAXV
      INTEGER            :: IPGR
      INTEGER            :: NMS1
      INTEGER            :: NLOOP
      INTEGER            :: ITRAC
      INTEGER            :: IABST
      INTEGER            :: MSIGN
      INTEGER            :: NTEST
      INTEGER            :: NPLANE
      INTEGER            :: MPLANE
      INTEGER            :: MAXASI
      INTEGER            :: MAXASP
      INTEGER            :: IABSTR
      INTEGER            :: INVERS
      INTEGER            :: IWEIGHT
      INTEGER            :: IHEADER
      REAL               :: CA
      REAL               :: CB
      REAL               :: CC
      REAL               :: DM
      REAL               :: PRO
      REAL               :: COM
      REAL               :: CAM
      REAL               :: ANG
      REAL               :: ROT
      REAL               :: SUMX
      REAL               :: COMT
      REAL               :: COST
      REAL               :: DIFF
      REAL               :: RINMX
      REAL               :: DETER
      REAL               :: PORIG
      REAL               :: DLINER
      REAL               :: GEN086
      CHARACTER(len=7)   :: PT
      CHARACTER(len=1)   :: S1
      CHARACTER(len=1)   :: S2
      CHARACTER(len=2)   :: SN
      CHARACTER(len=4)   :: TOT
      CHARACTER(len=*)   :: JID
      CHARACTER(len=80)  :: LINE
      CHARACTER(len=40)  :: RIGA
      CHARACTER(len=7)   :: OLDPT
      CHARACTER(len=132) :: PRBUF
      CHARACTER(len=6)   :: CWEIGHT
      PNTGR = (/
     1 'C1 ', 'Ci ', 'C2 ', 'Cs ', 'C2h', 'D2 ', 'C2v', 'D2h', 'C4 ',
     2 'S4 ', 'C4h', 'D4 ', 'C4v', 'D2d', 'D4h', 'C3 ', 'C3i', 'D3 ',
     3 'C3v', 'D3d', 'C6 ', 'C3h', 'C6h', 'D6 ', 'C6v', 'D3h', 'D6h',
     4 'T  ', 'Th ', 'O  ', 'Td ', 'Oh '/)
      ND    = 0
      ICOM  = 0
      MOO   = -1
      PAGET = 'MOLSYM'
      IF (IWEIGHT == 1) THEN
        CWEIGHT = 'ATOMIC'
      ELSE
        CWEIGHT = 'UNIT'
      ENDIF
      IHEADER = 0
      IF (IGBL(25) * IGBL(32) == 1 .AND. IPR(495) == 2 .AND.
     1  IPR(121) == 0) THEN
        IWIN = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.8
        WRITE (PRBUF, 99982, IOSTAT = IOST) JID(1:20)
        CALL PLA439 (0.0, PRBUF, 80, 0.50, 5 + IGBL(68), 2, 1.0, VRT)
        VRT = VRT - 0.8
        WRITE (PRBUF, 99981, IOSTAT = IOST) CWEIGHT
        CALL PLA439 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68), 2, 1.0, VRT)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ELSE
        IWIN = 0
      END IF
C * MO  = RESIDUE NUMBER
C * NA  = TOTAL NUMBER OF ATOMS
C * XO  = COORDINATES OF THE ATOM TO BE SYMMETRIZED
C * N   = NUMBER OF (NON-H) ATOMS IN RESIDUE T.B.S.
C * SIM = MATRICI DI SIMMETRIA DEL GRUPPO MOLECOLARE
C * NMS = ORDER OF THE SYMMETRY GROUP FOUND
      NA   = IPR(39)
      NDCM = NINT(PAR(75) / PAR(73))
C * LOOP OVER RESIDUES
      DO 210 MO = 1, IPR(75)
        IDCM  = 0
        OLDPT = ' '
        IPRW  = 0
C * LOOP OVER TOLERANCES (INCREMENT PAR(73))
   10   IF (IDCM == NDCM) THEN
          IF (NMS == 1) THEN
            WRITE (PRBUF, 99995, IOSTAT = IOST) MO, DCM
            WRITE (LU6,   99985, IOSTAT = IOST) PRBUF
            CALL PLA262 (3)
            WRITE (LU7,   99985, IOSTAT = IOST) PRBUF
            VRT = VRT - 0.5
            IF (IWIN == 1) THEN
              VRT = VRT - 1.0
              CALL PLA439 (0.0, PRBUF, 80, 0.37, 1, 2, 0.1, VRT)
              VRT = VRT - 0.6
              WRITE (PRBUF, 99984, IOSTAT = IOST)
     1          (NINT (RIN(I)), I = 1, 3), ND
              CALL PLA439 (0.0, PRBUF, 80, 0.37, 1, 2, 0.1, VRT)
            END IF
            WRITE (LU6, 99989, IOSTAT = IOST) PRBUF
            WRITE (LU7, 99989, IOSTAT = IOST) PRBUF
          END IF
          GO TO 210
        END IF
        IDCM   = IDCM + 1
        DCM    = IDCM * PAR(73)
        DLINER = 0.1
        CALL GEN074 (SIM, 1, 9 * NMG, 0.0)
        CALL GEN021 (AL, 1.0)
        SIM(1, 1, 1) = 1.0
        SIM(2, 2, 1) = 1.0
        SIM(3, 3, 1) = 1.0
        IES          = 0
        N            = 0
        NMS          = 1
C * SELECT ATOMS FOR THIS RESIDUE
        DO I = 1, NA
C * EXCLUDE H-ATOMS
          CALL GEN048 (-1, IFG(1, I), 7, IHAT)
          IF (IHAT == 0) THEN
C * CHECK RESIDUE NUMBER
            CALL GEN048 (-6, IFG(1, I), 9, IRES)
            IF (IRES == MO) THEN
C * NO ANALYSIS FOR DISORDERED MOLECULE
              CALL GEN048 (-8, IFG(2, I), 1, IPP)
              IF (IPPR(IPP + 1, 1) < 10000) THEN
                N = 0
                GO TO 210
              END IF
              N = N + 1
              IF (N > NMA) THEN
                CALL PLA262 (3)
                WRITE (LU6, 99990, IOSTAT = IOST) MO
                WRITE (LU7, 99990, IOSTAT = IOST) MO
                GO TO 220
              END IF
              IASU(I) = 2
C * COPY CARTESIAN COORDINATES
              DO K = 1, 3
                XO(K, N) = XXO(I, K + 3)
              END DO
              CALL GEN048 (-4, IFG(1, I), 15, NO1)
              NO1 = NO1 + 1
              IF (IWEIGHT == 1) THEN
                WGHT(N) = ATWT(IEN(NO1))
              ELSE
                WGHT(N) = 1.0
              END IF
              MN(N)    = NO1
              MK(N, 1) = N
            END IF
          END IF
        END DO
        IF (IHEADER == 0) THEN
          IHEADER = 1
          CALL PLA262 (-8)
          WRITE (LU7, 99998, IOSTAT = IOST) CWEIGHT
          WRITE (LU6, 99983, IOSTAT = IOST) CWEIGHT
        END IF
        PORIG = WGHT(1)
        IF (N > 2) THEN
C * CALCULATE CG AND MAIN AXES
          NLOOP = 0
   20     CALL GEN021 (PAT, 1.0)
          CALL GEN074 (BARO, 1, 3, 0.0)
          CALL GEN074 (SDV,  1, 6, 0.0)
          SUMX = 0.0
          DO I = 1, N
            DO J = 1, 3
              BARO(J) = BARO(J) + WGHT(I) * XO(J, I)
            END DO
            SUMX = SUMX + WGHT(I)
          END DO
          IF (SUMX == 0.0) RETURN
          DO I = 1, 3
            BARO(I) = BARO(I) / SUMX
          END DO
          DO I = 1, N
            DO J = 1, 3
              XO(J, I) = XO(J, I) - BARO(J)
              V2(J)    = XO(J, I) * WGHT(I)
            END DO
            SDV(1) = SDV(1) + V2(1) * XO(1, I)
            SDV(2) = SDV(2) - V2(1) * XO(2, I)
            SDV(3) = SDV(3) - V2(1) * XO(3, I)
            SDV(4) = SDV(4) + V2(2) * XO(2, I)
            SDV(5) = SDV(5) - V2(2) * XO(3, I)
            SDV(6) = SDV(6) + V2(3) * XO(3, I)
          END DO
          DAM(1, 1) = SDV(4) + SDV(6)
          DAM(2, 2) = SDV(1) + SDV(6)
          DAM(3, 3) = SDV(1) + SDV(4)
          DAM(1, 2) = SDV(2)
          DAM(1, 3) = SDV(3)
          DAM(2, 3) = SDV(5)
          CALL GEN024 (DAM, DUMV, RIN, ORX)
          CALL GEN076 (ORX, ORX, ORX, 1, 2, 3)
          CALL GEN081 (ORX, ORX, 1, 1)
          CALL GEN077 (ORX, PAT, OT, 1, 1, 1)
          CALL GEN003 (OT,  OTI, DETER, 0)
          CALL GEN003 (PAT, ORI, DETER, 0)
          CALL GEN078 (ORI, BARO, BARC, 1, 1, 1)
C * TRANSFORM COORDINATES TO INERTIAL AXIAL SYSTEM
          DO I = 1, N
            CALL GEN078 (ORX, XO, XO, 1, I, I)
          END DO
C * DM = MAXIMUM LENGTH OF VECTORS XO(I)
          DM = 0.0
          DO I = 1, N
            CALL GEN075  (XO, XO, D(I), I, I, 2)
            IF (D(I) > DM) DM = D(I)
          END DO
          MDEG = 0
          RINMX = MAX (RIN(1), RIN(2), RIN(3))
          IF (ABS (RIN(1) - RIN(2)) / RINMX <= DLINER) MDEG = 1
          IF (ABS (RIN(2) - RIN(3)) / RINMX <= DLINER) MDEG = MDEG + 2
          ND = (MDEG + 1) / 2 + 1
          IF (MDEG == 1) THEN
            DO I = 1, N
              COM = SQRT (XO(1, I) ** 2 + XO(2, I) ** 2)
              IF (COM > DCM) GO TO 30
            END DO
            CALL GEN074 (CO, 1, 9, 0.0)
            CO(1, 1) = -1.0
            CO(2, 2) = -1.0
            CO(3, 3) =  1.0
C * VERIFY
            CALL PLA212 (CO, MV, N)
            CO(3, 3) = -1.0
C * VERIFY
            CALL PLA212 (CO, MV, N)
            MDEG = 5
            GO TO 100
C * UNIQUE AXIS, TAKE IT ALONG Z
C * MODIFICA DI CONSEGUENZA ANCHE LA MATRICE DI ORIENTAZIONE
          ELSE IF (MDEG == 2) THEN
            CALL GEN074 (CO, 1, 9, 0.0)
            MDEG     =  1
            CO(3, 1) =  1.0
            CO(1, 3) =  1.0
            CO(2, 2) = -1.0
            CALL PLA214 (CO, N)
            CALL GEN018 (RIN(1), RIN(3))
            GO TO 30
C * TRIPLE DEGENERATE CASE
          ELSE IF (MDEG == 3) THEN
            N1 = N - 1
            N2 = N - 2
            DO I = 1, N
              MD(I, 1) = 0
              MD(I, 2) = 0
              DO J = 2, NMG
                MK(I, J) = 0
              END DO
            END DO
            IAI = 0
C * IAI=NUMERO DI ENNUPLE DI ATOMI AVENTI DISTANZE COMPRESE IN UN RANGE
C * X< D <X+ DCM *.5
C * MD(I,1)=NUMERO DELLA ENNUPLA DI CUI L'ATOMO I FA PARTE
C * MD(IAI,2)=N PER IL PRIMO ATOMO DELLA ENNUPLA DOVE N E' IL NUMERO DI
C * ATOMI DELLA STESSA
            DO I = 1, N1
              IF (MD(I, 1) == 0) THEN
                IAI        = IAI + 1
                MD(I, 1)   = IAI
                MD(IAI, 2) = 1
                J          = I + 1
                DO K = J, N
                  IF (MN(I) == MN(K) .AND. K /= I
     1                    .AND. MD(K, 1) == 0) THEN
                    IF (ABS (D(I) - D(K)) <= 0.5 * DCM) THEN
                      MD(K, 1)   = IAI
                      MD(IAI, 2) = MD(IAI, 2) + 1
                    END IF
                  END IF
                END DO
              END IF
            END DO
C * SE CI SONO ATOMI SU POSIZIONI SPECIALI USA QUESTI PER TROVARE LA
C * MATRICE DI ROTAZIONE
            CALL GEN074 (CO, 1, 9, 0.0)
            MMD = 1000
            DO I = 1, IAI
              IF (MD(I, 2) < MMD .AND. MD(I, 2) > 1) THEN
                MMD = MD(I, 2)
                II  = I
              END IF
            END DO
C * PERCHE' CI SIA SIMMETRIA I O IH CI DEVONO ESSERE ALMENO 12 ATOMI EQUIVALENTI
            IER = 0
            IF (II <= NMA) THEN
              IF (MD(II, 2) == 12 .OR. MD(II, 2) == 20 .OR.
     1            MD(II, 2) == 30 .OR. MD(II, 2) > 48)
     2          CALL PLA213 (N, II, MDEG, IER, LU6)
            ELSE
              IER = 1
            END IF
            IF (IER /= 0) GO TO 130
            IF (MDEG == 1) GO TO 30
            IF (NMS >= 5) THEN
              MDEG = 1
              CALL GEN074 (AAY, 1, 9, 0.0)
              DO I = 1, 3
                DO J = 1, 3
                  IF (J == 4 - I) THEN
                    AAY(J, J) = -1
                  ELSE
                    AAY(J, J) =  1
                  END IF
                END DO
C * VERIFY
                CALL PLA212 (AAY, MV, N)
              END DO
C * LOOK FOR AN INVERSION CENTRE
              II = 2
              CALL GEN021 (CO, -1.0)
C * VERIFY
              CALL PLA212 (CO, MV, N)
              GO TO 90
            END IF
C * RICERCA ASSE 3 SU ATOMI IN POSIZIONE GENERALE
C * NOTA: TRE ATOMI EQUIVALANTI PER UN ASSE 3 DEVONO FORMARE UN TRIANGOLO
C * EQUILATERO
C * II E' IL NUMERO DI ATOMI DEL SOTTOGRUPPO
            CA = 0.0
C * MATRICE DI ROTAZIONE 3 COINCIDENTE CON Z
            CALL GEN074 (AAY, 1, 9, 0.0)
            AAY(3, 3) = 1.0
            AAY(1, 1) = -0.5
            AAY(2, 2) = -0.5
            AAY(2, 1) = 0.5 * SQRT (3.0)
            AAY(1, 2) = -AAY(2, 1)
            NMS1      = 1
C * I1,I2,I3=INDICATORI DEI TRE ATOMI POSSIBILE GENERATORI DELL'ASSE 3
            N2 = N - 2
            N1 = N - 1
            DO I1 = 1, N2
              IF (MD(I1, 1) == II) THEN
                IN1 = I1 + 1
                DO I2 = IN1, N1
                  IF (MD(I2, 1) == II) THEN
                    CALL GEN073 (XO, XO, CO, 1.0, -1.0, I1, I2, 4)
                    CALL GEN075 (CO, CO, CA, 4, 4, 2)
                    IN2 = I2 + 1
                    DO I3 = IN2, N
                      IF (MD(I3, 1) == II) THEN
                        CALL GEN073 (XO, XO, CO, 1.0, -1.0, I1, I3, 5)
                        CALL GEN075 (CO, CO, CB, 5, 5, 2)
                        CALL GEN073 (XO, XO, CO, 1.0, -1.0, I2, I3, 6)
                        CALL GEN075 (CO, CO, CC, 6, 6, 2)
                        IF (ABS (CA - CB) > DCM) CYCLE
                        IF (ABS (CA - CC) > DCM) CYCLE
                        IF (ABS (CB - CC) > DCM) CYCLE
                        DO J1 = 1, 3
                          CO(J1, 3) = XO(J1, I1) + XO(J1, I2) +
     1                      XO(J1, I3)
                        END DO
                        CALL GEN082 (CO, 3)
C * SALVATAGGIO DEL POSSIBILE ASSE 3
                        DO J1 = 1, 3
                          CO(J1, 6 + NMS1) = CO(J1, 3)
                        END DO
C * CONTROLLO CHE L'ASSE TROVATO NON COINCIDA GIA' CON Z CIOE'
C * CON IL PRIMO ASSE C3 TROVATO
                        IF (NMS1 > 1) THEN
                          CALL GEN075 (CO, CO, PRO, 7, 8, 1)
                          IF (ABS (PRO) > 0.9) CYCLE
                          IF (PRO > 0.0) THEN
                            DO J1 = 1, 3
                              CO(J1, 8) = - CO(J1, 8)
                            END DO
                          END IF
                        END IF
C * DEFINIZIONE DI UN SECONDO ASSE
                        DO I = 1, 3
                          CALL GEN074 (CO, 1, 3, 0.0)
                          CO(I, 1) = 1.0
                          CALL GEN075 (CO, CO, PRO, 1, 3, 1)
                          IF (ABS (PRO) > 0.5) EXIT
                        END DO
C * VERIFICA SE L' ASSE TROVATO E' UN C3
C * ROTAZIONE PER PORTARE IL C3 A COINCIDERE CON Z
                        CALL GEN076 (CO, CO, CO, 3, 1, 2)
                        CALL GEN082 (CO, 2)
                        CALL GEN076 (CO, CO, CO, 2, 3, 1)
                        CALL GEN081 (CO, CO, 1, 1)
                        CALL PLA214 (CO, N)
C * VERIFY
                        CALL PLA212 (AAY, MV, N)
                        NMS  = 1
                        NMS1 = NMS1 + MV
                        CALL GEN081 (CO, CO, 1, 1)
                        CALL PLA214 (CO, N)
                        IF (NMS1 == 3) THEN
C * HA TROVATO DUE ASSI C3 [CO(7) E CO(8)] E LI USA PER
C * DETERMINARE IL RIFERIMENTO DEFINITIVO
                          CALL GEN073 (CO, CO, CO, 1.0, 1.0, 7, 8, 1)
                          CALL GEN082 (CO, 1)
                          CALL GEN073 (CO, CO, CO, 1.0, -1.0, 7, 8, 3)
                          CALL GEN076 (CO, CO, CO, 3, 1, 2)
                          CALL GEN082 (CO, 2)
                          CALL GEN076 (CO, CO, CO, 1, 2, 3)
                          CALL GEN081 (CO, CO, 1, 1)
                          CALL PLA214 (CO, N)
                          CALL GEN074 (CO, 1, 9, 0.0)
                          CO(1, 1) =  1.0
                          CO(2, 2) =  SQRT (0.5)
                          CO(3, 3) =  CO(2, 2)
                          CO(2, 3) =  CO(2, 2)
                          CO(3, 2) = -CO(2, 2)
C * ROTAZIONE SU NUOVA TERNA
                          CALL PLA214 (CO, N)
C * VERIFICA GENERALE ESISTENZA ASSE TERNARIO
                          CALL GEN074 (AAY, 1, 9, 0.0)
                          AAY(1, 2) = 1.0
                          AAY(2, 3) = 1.0
                          AAY(3, 1) = 1.0
C * VERIFY
                          CALL PLA212 (AAY, MV, N)
                          NASS = 1
C * HA TORVATO UN ASSE 3 (DIAGONALE) ORA CERCA UN ASSE 2
                          IU   = 1
                          IB   = 2
                          IC   = 3
                          MORD = 4
                          CALL GEN074 (CO, 1, 9, 0.0)
                          CO(1, 1) = -1.0
                          CO(2, 2) = -1.0
                          CO(3, 3) =  1.0
C * VERIFY
                          CALL PLA212 (CO, MV, N)
                          IF (MV == 1) GO TO 50
C * NON ESISTE L'ASSE 2 ALLINETO SU X: SI TRATTA DI UNA PSEUDODEGENERAZIONE
C * MI METTO IN MODO CHE L'ASSE 3 SIA ALLINETO A Z
                          CALL GEN074 (CO, 1, 9, 0.0)
                          COST = SQRT (0.5)
                          CO(1, 1) =  COST
                          CO(2, 2) =  COST
                          CO(1, 2) = -COST
                          CO(2, 1) =  COST
                          CO(3, 3) =  1.0
                          ANG      = 0.5 * ACOS (-1.0 / 3.0)
                          CALL GEN043 (1, AAY, - ANG)
                          CALL GEN077 (AAY, CO, CO, 1, 1, 1)
                          CALL PLA214 (CO, N)
                          NMS  = 1
                          MORD = 6
                          MDEG = 1
                          IU   = 3
                          IB   = 2
                          IC   = 1
                          WRITE (LU6, 99993, IOSTAT = IOST) DCM
                          GO TO 90
                        END IF
                      END IF
                    END DO
                  END IF
                END DO
              END IF
            END DO
            IF (NMS1 == 1) THEN
              IF (PORIG /= WGHT(1)) THEN
                DLINER = DLINER * 0.1
                GO TO 20
              END IF
C * PSEUDODEGENERAZIONE 3 SENZA ASSI C3. ESISTE ANCORA LA POSSIBILITA'
C * CHE LA PSEUDODEGENERAZIONE SIA COMPLETA (MDEG=0) O CHE CI SIA UNA
C * ASSE 4,-4,5,-5,7,-7,8,-8
              IPRW = IPRW + 1
              IF (IPRW == 1) THEN
                CALL PLA262 (2)
                WRITE (LU7, 99992, IOSTAT = IOST)
              END IF
              DO K = 1, N
                WGHT(K) = WGHT(K) * (D(K) / DM)**4
              END DO
              NLOOP = NLOOP + 1
              IF (NLOOP < 100) GO TO 20
            END IF
C * HA TROVATO UN SOLO ASSE 3 [ = CO(7)] E SI RIPORTA IN QUEL
C * RIFERIMENTO RIPRISTINANDO NMS
C * DEFINIZIONE DI UN SECONDO ASSE
            CO(1, 3) = CO(1, 7)
            CO(2, 3) = CO(2, 7)
            CO(3, 3) = CO(3, 7)
            DO I = 1, 3
              CALL GEN074 (CO, 1, 3, 0.0)
              CO(I, 1) = 1.0
              CALL GEN075 (CO, CO, PRO, 1, 3, 1)
              IF (ABS (PRO) > 0.5) EXIT
            END DO
            CALL GEN076 (CO, CO, CO, 3, 1, 2)
            CALL GEN082 (CO, 2)
            CALL GEN076 (CO, CO, CO, 2, 3, 1)
            CALL GEN081 (CO, CO, 1, 1)
            CALL PLA214 (CO, N)
            NMS  = 1
            MORD = 6
            MDEG = 1
            IU   = 3
            IB   = 2
            IC   = 1
            WRITE (LU6, 99993, IOSTAT = IOST) DCM
            GO TO 90
          END IF
C * UNIQUE Z-AXIS
   30     IU = 3
          IB = 2
          IC = 1
C * SEARCH FOR AXIS OF ORDER MORD
          MORD = 9
          IF (MDEG == 0) MORD = 3
          NASS = 1
   40     MORD = MORD - 1
          IF (MORD == 3 .AND. MDEG == 3) MORD = 2
          IF (MORD == 1) GO TO 70
C * GENERATE SYMMETRY MATRIX
   50     COST = 1.0
          CALL GEN074 (CO, 1, 9, 0.0)
          ROT = RGBL(5) / FLOAT (MORD)
          CA  = COS (ROT)
          CB  = SIN (ROT)
   60     CO(IB, IB) =  CA * COST
          CO(IC, IC) =  CO(IB, IB)
          CO(IB, IC) =  CB * COST
          CO(IC, IB) = -CO(IB, IC)
          CO(IU, IU) =  COST
C * VERIFY
          CALL PLA212 (CO, MV, N)
          IF (MV /= 1) THEN
            IF (COST == -1.0) GO TO 40
            COST = -1.0
            GO TO 60
          END IF
C * SYMMETRY ELEMENT FOUND
          IF (MORD == 3 .OR. MORD == 6) IES = 1
          IF (MDEG == 1 .AND. MORD > 2) GO TO 80
C * RICERCA ELEMENTI DI SIMMETRIA SU NUOVI ASSI
          IF (MORD > 2) GO TO 40
   70     NASS = NASS + 1
C * AL COMPLETAMENTO DEL GRUPPO
          IF (NASS == 4) THEN
C * LOOK FOR AN INVERSION CENTRE
            II = 2
            CALL GEN021 (CO, -1.0)
C * VERIFY
            CALL PLA212 (CO, MV, N)
            GO TO 90
          END IF
C * RICICLO SUL SECONDO O TERZO ASSE
          MORD = 2
          I    = IU
          IU   = IB
          IB   = IC
          IC   = I
          GO TO 50
C * RICERCA DELLA ROTAZIONE PER PORTARE EVENTUALI ELEMENTI DI SIMMETRIA
C * A COINCIDERE CON GLI ASSI DI RIFERIMENTO
C * SELEZIONE DELL'ATOMO DA USARE PER DETERMINARE LA ROTAZIONE
   80     CALL GEN074 (CO, 1, 18, 0.0)
          CO(3, 3) = 1.0
C * DIVISIONE IN GRUPPI EQUIDISTANTI DALL'ASSE UNICO
          DO I = 1, N
            D(I)     = SQRT (XO(1, I) * XO(1, I) + XO(2, I) * XO(2, I))
            MD(I, 1) = 0
            MD(I, 2) = 0
          END DO
          IAI = 0
C * IAI=NUMERO DI ENNUPLE DI ATOMI AVENTI DISTANZE COMPRESE IN UN RANGE
C * MD(I,1)=NUMERO DELLA ENNUPLA DI CUI L'ATOMO I FA PARTE
C * MD(IAI,2)=N PER IL PRIMO ATOMO DELLA ENNUPLA DOVE N E' IL NUMERO DI
          N1 = N - 1
          DO I = 1, N1
            IF (MD(I, 1) == 0) THEN
              IAI        = IAI + 1
              MD(I, 1)   = IAI
              MD(IAI, 2) = 1
              J          = I + 1
              DO K = J, N
                IF (MN(I) == MN(K) .AND. K /= I
     1                    .AND. MD(K, 1) == 0) THEN
                  IF (ABS (D(I) - D(K)) <= 0.5 * DCM) THEN
                    MD(K, 1)   = IAI
                    MD(IAI, 2) = MD(IAI, 2) + 1
                  END IF
                END IF
              END DO
            END IF
          END DO
C * SEARCH FOR MINIMAL SUBGROUP
          JJ = 10000
          DO I = 1, IAI
            IF (MD(I, 2) < JJ .OR. MD(I, 2) > 2) JJ = MD(I, 2)
          END DO
C * FRA I SOTTOGRUPPI MINIMI VIENE SCELTO IL PIU' DISTANTE
C * DALL'ASSE UNICO
          DM = 0.0
          DO I = 1, IAI
            IF (MD(I, 2) == JJ) THEN
              DO K = 1, N
                IF (MD(K, 1) == I) THEN
                  IF (D(K) > DM) THEN
                    DM = D(K)
                    II = I
                  END IF
                END IF
              END DO
            END IF
          END DO
C * ZERO ARRAY
          CALL GEN074 (AAY, 1, 9, 0.0)
          N1 = N - 1
          DO I1 = 1, N1
            IF (MD(I1, 1) == II) THEN
              IN1 = I1 + 1
              DO I2 = IN1, N
                IF (MD(I2, 1) == II) THEN
                  CALL GEN073 (XO, XO, CO, 1.0, 1.0, I1, I2, 1)
                  CALL GEN076 (CO, CO, CO, 3, 1, 2)
                  CAM = CO(1, 2) ** 2 + CO(2, 2) ** 2 + CO(3, 2) ** 2
                  IF (CAM > 0.00001) THEN
                    CALL GEN082 (CO, 2)
                    CALL GEN076 (CO, CO, CO, 2, 3, 1)
                    CALL GEN081 (CO, CO, 1, 1)
C * R_FRAME
                    CALL PLA214 (CO, N)
                    COM = 1.0
                    DO
                      AAY(1, 1) = -1
                      AAY(2, 2) = -1
                      AAY(3, 3) =  COM
C * VERIFY
                      CALL PLA212 (AAY, MV, N)
                      AAY(1, 1) = -1
                      AAY(2, 2) =  1
                      AAY(3, 3) =  COM
C * VERIFY
                      CALL PLA212 (AAY, MV, N)
                      AAY(1, 1) =  1
                      AAY(2, 2) = -1
                      AAY(3, 3) =  COM
C * VERIFY
                      CALL PLA212 (AAY, MV, N)
                      AAY(1, 1) = 0
                      AAY(1, 2) = 1
                      AAY(2, 1) = 1
                      AAY(2, 2) = 0
                      AAY(3, 3) = COM
C * VERIFY
                      CALL PLA212 (AAY, MV, N)
                      IF (NMS >= 3) GO TO 40
                      IF (COM <= 0.0) EXIT
                      COM = - COM
C * ZERO ARRAY
                      CALL GEN074 (AAY, 1, 9, 0.0)
                    END DO
                  END IF
                END IF
              END DO
            END IF
          END DO
C * LOOK FOR AN INVERSION CENTRE
          II = 2
          CALL GEN021 (CO, -1.0)
C * VERIFY
          CALL PLA212 (CO, MV, N)
   90     IF (NMS == 1) THEN
            IF (IDCM < NDCM) THEN
              OLDPT = ' '
              IPRW  = 0
            END IF
            GO TO 10
          END IF
C * COMPLETE THE GROUP
  100     IER = 0
          CALL PLA215 (N, IER)
          IF (IER /= 0) GO TO 220
C * LINEAR GROUP
          IF (MDEG == 5) GO TO 130
          NTEST = 0
          DO I = 1, NMS
            IF (MTG(I, I) /= 1) NTEST = 1
          END DO
C * VARIAZIONE PER FAR SI CHE IN UN C2 O C2V L'ASSE 2 COINCIDA CON Z
          IF (NMS == 2 .OR. NMS == 4) THEN
            NAX2 = 0
            LAX2 = 0
            DO I = 2, NMS
              ITRAC = NINT (SIM(1, 1, I) + SIM(2, 2, I) + SIM(3, 3, I))
              IABST = NINT (ABS (SIM(1, 1, I)) + ABS (SIM(2, 2, I))
     1              + ABS (SIM(3, 3, I)))
              IF (IABST /= 3) GO TO 110
              IF (ITRAC == -1) THEN
                NAX2 = NAX2 + 1
                LAX2 = I
              END IF
            END DO
            IF (NAX2 == 0 .OR. NAX2 == 3) GO TO 130
            IF (NAX2 == 1) THEN
              DO  L = 1, 3
                IF (NINT (SIM(L, L, LAX2)) == 1) EXIT
              END DO
              IF (L == 3) GO TO 130
              CALL GEN074 (CO, 1, 9, 0.0)
              I = 3 - L
              K = 6 - I - L
              CO(K, L) =  1.0
              CO(L, K) = -1.0
              CO(I, I) =  1.0
              CALL PLA214 (CO, N)
              CALL GEN018 (RIN(3), RIN(L))
            END IF
            NMS = 1
            GO TO 30
          END IF
  110     IF (NTEST /= 0 .AND. MDEG /= 0) THEN
C * OTTIMIZZAZIONE DEL RIFERIMENTO PER MDEG > 0
            IF (MDEG == 1) THEN
              IAXV = 0
              DO I = 2, NMS
                IABSTR = INT (ABS (SIM(1, 1, I)) + ABS (SIM(2, 2, I))
     1                 + ABS (SIM(3, 3, I)) + 0.001)
                IF (IABSTR == 3) THEN
                  ITRAC =
     1              INT((SIM(1, 1, I) + SIM(2, 2, I) + SIM(3, 3, I))
     2              * 1.001)
                  IAX = ITRAC
                  IF (ITRAC == NINT (SIM(3, 3, I))) THEN
                    IAX = - ITRAC * I
                    DO J = 1, 2
                      IF (ITRAC /= NINT (SIM(J, J, I))) ICOM = J
                    END DO
                    IF (IAX > 0) THEN
                      V3(3)        = 0.0
                      V3(ICOM)     = 1.0
                      V3(3 - ICOM) = 0.0
                      IAXV         = IABS (IAX)
                      IF (IAX == 0) GO TO 130
                      CALL PLA216 (V3, N, IAXV, LU6)
                      COST = 0.0
                      DO J = 1, 3
                        IF (ABS (V3(J)) > COST) THEN
                          COST = ABS (V3(J))
                          ICOM = J
                        END IF
                      END DO
                      COST = 1.0
                      IF (V3(ICOM) < 0.0) COST = -1.0
                      CALL GEN074 (AAY, 1, 9, 0.0)
                      AAY(3, 3)    = 1.0
                      DO J = 1, 3
                        AAY(J, ICOM) = COST * V3(J)
                      END DO
                      IF (ICOM == 2) THEN
                        CALL GEN076 (AAY, AAY, AAY, 2, 3, 1)
                        CALL GEN076 (AAY, AAY, AAY, 3, 1, 2)
                      ELSE
                        CALL GEN076 (AAY, AAY, AAY, 3, 1, 2)
                        CALL GEN076 (AAY, AAY, AAY, 2, 3, 1)
                      END IF
                      CALL GEN082 (AAY, 1)
                      CALL GEN082 (AAY, 2)
                      GO TO 120
                    END IF
                  END IF
                END IF
              END DO
C * SE NON C'E' UN ASSE 2 PERPENDICOLARE ALL'ASSE DEGENERE O UN MIRROR
C * CHE LO CONTENGA LA PROCEDURA SEGUENTE E' SUPERFLUA
              GO TO 130
            ELSE IF (MDEG == 3) THEN
              CALL GEN074 (CO, 1, 9, 0.0)
              CO(1, 1) =  1.0
              CO(2, 2) = -1.0
              CO(3, 3) = -1.0
              DO K = 1, NMS
                IF (NINT (GEN086 (SIM, CO, 0.001, K, 1)) == 1) EXIT
              END DO
              V3(1) = 1.0
              V3(2) = 0.0
              V3(3) = 0.0
              CALL PLA216 (V3, N, K, LU6)
              DO L = 1, 3
                AAY(L, 1) = V3(L)
              END DO
              CO(1, 1) = -1.0
              CO(2, 2) =  1.0
              CO(3, 3) = -1.0
              DO K = 1, NMS
                IF (NINT (GEN086 (SIM, CO, 0.001, K, 1)) == 1) EXIT
              END DO
              V3(1) = 0.0
              V3(2) = 1.0
              V3(3) = 0.0
              DO L = 1, 3
                AAY(L, 2) = V3(L)
              END DO
              CALL GEN076 (AAY, AAY, AAY, 1, 2, 3)
              CALL GEN082 (AAY, 3)
              CALL GEN076 (AAY, AAY, AAY, 3, 1, 2)
              CALL GEN082 (AAY, 2)
              CALL GEN076 (AAY, AAY, AAY, 2, 3, 1)
              CALL GEN082 (AAY, 1)
            END IF
  120       CALL GEN081 (AAY, AAY, 1, 1)
            CALL PLA214 (AAY, N)
          END IF
C * CALCOLO SIMMETRIA PER SOTTOGRUPPI DI OPERAZIONI
  130     CSM(1)  = 0.0
          DEVX(1) = 0.0
C * SIMMETRIZZAZIONE PER SOTTOGRUPPI DI UNA SOLO ELEMENTO (E SUE POTENZE)
          DO I = 2, NMS
            NES      = 1
            ISU(1)   = NES
            K        = I
  140       NES      = NES + 1
            ISU(NES) = K
            L        = MTG(I, K)
            IF (L /= 1) THEN
              K = L
              GO TO 140
            END IF
            CALL PLA217 (COMT, NES, N)
            DEVX(I) = DELM(4)
            CSM(I)  = COMT
          END DO
C * CALCULATE  LE COORDINATEE SIMMETRIZZATE PER L'INTERO GRUPPO
          DO I = 1, NMS
            ISU(I) = I
          END DO
          CALL PLA217 (CSMT, NMS, N)
          N1 = N
          CALL GEN097 (IASU, 1, N1, 2)
          DO 150 I = 1, N1
            IF (IASU(I) == 2) THEN
              DO J = 1, NMS
                K = MK(I, J)
                IF (K /= I) THEN
                  IF (K == 0) THEN
                    IASU(I) = 0
                    GO TO 150
                  END IF
                  IASU(K) = 1
                END IF
              END DO
            END IF
  150     CONTINUE
          DO I = 1, 4
            DEL(I) = DEL(I) / FLOAT (N)
          END DO
          DO I = 1, N
            DO J = 1, NMS
              K = MK(I, J)
              CALL GEN078 (SIM, XS, V3, J, I, 1)
              DO L = 1, 3
                DIFF = ABS (XS(L, K) - V3(L))
                IF (DIFF > 0.001) THEN
                  GO TO 160
                END IF
              END DO
            END DO
          END DO
C * FROM THE GROUP MATRICES GIVES THE SCHOENFLIES SYMBOL
  160     IPGR    = 0
          MAXASP  = 0
          MAXASI  = 0
          MPLANE  = 0
          INVERS  = 0
          NPLANE  = 0
          LBLS(1) = 'E'
C * LINEAR GROUP
          IF (MDEG == 5) THEN
            PT = 'C(inf)v'
            DO I = 1, NMS
              CALL GEN088 (SIM, I, M, MSIGN, INV)
              IF (INV == 1) THEN
                PT = 'D(inf)h'
                EXIT
              END IF
            END DO
            NMS = 1
            GO TO 200
          END IF
          IF (NMS == 1) THEN
            PT   = 'C1 '
            IPGR = 1
            GO TO 220
          END IF
          DO I = 2, NMS
            TOT = '    '
            S1  = ' '
            S2  = ' '
            SN  = '  '
            CALL GEN088 (SIM, I, M, MSIGN, INV)
            IF (M > MAXASP .AND. MSIGN ==  1) MAXASP = M
            IF (M > MAXASI .AND. MSIGN == -1) MAXASI = M
            IF (M == 2 .AND. MPLANE == 0) MPLANE = 1
            S1 = 'C'
            IF (M == 2) THEN
C * CENTRE
              IF (INV == 1) THEN
                INVERS = 1
                SN     = 'i '
                GO TO 170
              END IF
C * PIANO
              SN = '2 '
C * 2-AXIS
              IF (MSIGN == -1) THEN
                SN     = 's '
                NPLANE = NPLANE + 1
              END IF
              GO TO 170
            END IF
C * IMPROPER AXIS  M > 2
            WRITE (SN, 99986, IOSTAT = IOST) M
            IF (MSIGN == -1) S1 = 'S'
  170       TOT = S1//SN//S2
            CALL GEN085 (TOT, 4, K)
            LBLS(I) = TOT(1:3)
          END DO
          PT = '   '
          IF (NMS ==  48) THEN
            PT = 'Oh '
          ELSE IF (NMS ==  60) THEN
            PT = 'I  '
          ELSE IF (NMS == 120) THEN
            PT = 'Ih '
          END IF
          IF (PT  /= '   ') GO TO 190
          IF (MDEG == 3) THEN
            IF (NMS == 12)   PT = 'T23'
            IF (INVERS == 1) PT = 'Th '
            IF (MAXASI == 4) PT = 'Td '
            IF (PT == '   ') PT = 'O  '
            GO TO 190
          END IF
          IF (NMS == 2) THEN
            PT = LBLS(2)
            GO TO 180
          END IF
          S2 = ' '
          S1 = 'C'
C * CN E S2N DOVE N=MAXASP
          WRITE (SN, 99986, IOSTAT = IOST) MAXASP
          IF (MOD (NMS, 2) == 0 .AND. MAXASI == NMS) THEN
            S1 = 'S'
            WRITE (SN, 99986, IOSTAT = IOST) MAXASI
            IF (NMS /= 6) GO TO 180
            PT = 'C3i'
            GO TO 190
          END IF
          IF (NMS /= MAXASP) THEN
            IF (NMS < MAXASI) THEN
              WRITE (SN, 99986, IOSTAT = IOST) MAXASI
              S1 = 'S'
            ELSE
C * DN, CNV OR CNH
              S1 = 'D'
              IF (NMS == MAXASP * 2) THEN
                IF (NPLANE /= 0) THEN
                  S1 = 'C'
                  S2 = 'v'
                  IF (NPLANE /= MAXASP) S2 = 'h'
                END IF
              ELSE
                S2 = 'h'
                IF (NPLANE == MAXASP) S2 = 'd'
              END IF
            END IF
          END IF
  180     TOT = '    '
          TOT = S1//SN//S2
          CALL GEN085 (TOT, 4, K)
          PT = TOT(1:3)
  190     DO M = 1, 32
            IF (PT(1:3) == PNTGR(M)) IPGR = M
          END DO
  200     IF (PT /= OLDPT .AND. RMST < 0.5) THEN
            CALL PLA262 (6)
            WRITE (PRBUF, 99996, IOSTAT = IOST)
            WRITE (LU7, 99987, IOSTAT = IOST) PRBUF(1:80)
            IF (IWIN == 1 .AND. MO > MOO) THEN
              MOO = MO
              VRT = VRT - 1.5
              CALL PLA439 (0.0, PRBUF, 80, 0.37, 5 + IGBL(68), 2,
     1                     0.1, VRT)
            END IF
            WRITE (LU6, 99994, IOSTAT = IOST) MO, PT, CSMT, RMST, DCM
            WRITE (PRBUF, 99997, IOSTAT = IOST)
     1        MO, (NINT (RIN(I)), I = 1, 3), ND, PT, CSMT, RMST, DCM
            WRITE (LU7, 99989, IOSTAT = IOST) PRBUF(1:80)
            IF (IWIN == 1) THEN
              VRT = VRT - 1.0
              CALL PLA439 (0.0, PRBUF, 80, 0.37, 1, 2, 0.1, VRT)
              CALL GGIP (0.0, 0.0, 0.0, 6)
            END IF
            IF (IPGR >= 16 .AND. IPGR <= 27) THEN
              IF (IES == 1) THEN
                AL(2, 2) = SQRT (3.0) * 0.5
                AL(1, 2) = -0.5
                AL(1, 1) = 1.0
                AL(3, 3) = 1.0
                CALL GEN003 (AL, ALX, DETER, 0)
                DO I = 1, NMS
                  CALL GEN077 (ALX, SIM, AAY, 1, I, 1)
                  CALL GEN077 (AAY, AL, SIM, 1, 1, I)
                END DO
C * PRINT EQUIVALENT POSITIONS
                CALL GEN074 (TRL, 1, 3 * NMS, 0.0)
                I1 = - 39
                I  = 1
                IF (NMS > 1) I = 2
                CALL PLA262 (3)
                WRITE (LU7, 99988, IOSTAT = IOST)
     1          (' Symmetry element     CSM and Max.Diff. ', K = 1, I)
                WRITE (LU7, 99980, IOSTAT = IOST)
                DO M = 1, NMS
                  MM = M
                  CALL GEN087 (RIGA(1:39), SIM, TRL, MM, 2)
                  I1 = I1 + 40
                  I2 = I1 + 39
                  I3 = I1 + 25
                  I4 = I1 + 39
                  WRITE (LINE(I1:I2), 99999, IOSTAT = IOST)
     1              M, LBLS(M), RIGA
                  WRITE (LINE(I3:I4), 99991, IOSTAT = IOST)
     1              CSM(M), DEVX(M)
                  IF (I1 == 41) THEN
                    CALL PLA262 (1)
                    WRITE (LU7, 99989, IOSTAT = IOST) LINE
                    CALL GEN038 (LINE, 1, 80)
                    I1 = -39
                  END IF
                END DO
                IF (I1 >= 1) THEN
                  CALL PLA262 (1)
                  WRITE (LU7, 99989, IOSTAT = IOST) LINE(1 : I1 + 39)
                END IF
              END IF
            END IF
          END IF
          OLDPT = PT
          GO TO 10
        END IF
  210 CONTINUE
  220 IF (IWIN == 1) CALL PLA297 (0)
      RETURN
99999 FORMAT (I3,' [',A3,']', A30)
99998 FORMAT ('MOLSYM: Search for (additional) Molecular ',
     1 '(Point Group) Symmetry - Hydrogen Atoms Excluded !',
     2 ' - Ordered Residues Only !', /, 132('='), //,
     3 'For Details on the Molecular Symmetry ',
     4 'Determination see: T. Pilati & A. Forni, J.Appl.Cryst. ',
     5 '(1998), 31, 503-504 & (2000), 33, 417.', //,
     6 'For CSM (i.e. Continuous Symmetry Measure),',
     7 ' see: H. Zabrodsky et al. (1993) JACS, 115, 8278-8289', //,
     8 ' ***** Weighting Mode = ', A, ' *****')
99997 FORMAT (I6, 2X, '(', I6, ',', I9, ',', I9, ')', I4, 3X, A, F8.4,
     1        4X, F8.4, F5.2, ' Ang.')
99996 FORMAT ('Resd #', 9X, 'Inertial  Moments',
     1 4X, 'Degree Symbol', 6X, 'CSM', 9X, 'RMS  Tol')
99995 FORMAT ('Resd', I2, 10X,
     1 'No Molecular Symmetry Within Tolerance =', F6.2, ' Ang.')
99994 FORMAT (':: Resd #',  I5, 3X, A, ' CSM = ', F8.4,
     1 1X, 'RMS = ', F8.4, 1X, 'Tol =', F5.2)
99993 FORMAT (':: Degeneration Degree=3 but no CUBIC ',
     1'or ICOSAHEDRAL Group Found. (Tol =', F5.2, 'A)')
99992 FORMAT (/, ':: Weights are Changed')
99991 FORMAT (2F7.4)
99990 FORMAT (/, ':: Too Many Atoms in RESD #', I5, /)
99989 FORMAT (A)
99988 FORMAT (/, 2A)
99987 FORMAT (/, 80('-'), /, A, /, 80('-'))
99986 FORMAT (I2)
99985 FORMAT (/, A)
99984 FORMAT (14X, 'Inertial Moments: ', 3I8, ', Degree =', I3)
99983 FORMAT (/, ' ***** Weighting Mode = ', A, ' *****')
99982 FORMAT (15X, 'PLATON/MOLSYM for ', A)
99981 FORMAT (24X, 'Weighting Mode: ', A)
99980 FORMAT (80('-'))
      END SUBROUTINE PLA211
 
      SUBROUTINE PLA212 (A, MV, N)
C * MOLSYM (2)
      USE files
      USE symmol
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: JJ
      INTEGER               :: MV
      INTEGER               :: INV
      INTEGER               :: NEQ
      INTEGER               :: NORD
      INTEGER               :: MSIGN
      REAL                  :: F
      REAL                  :: FMIN
      REAL                  :: GEN086
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3)    :: V
      REAL, DIMENSION(3)    :: W
      MV = 1
C * CONTROLLA PER PRIMA COSA CHE LS MATRICE A NON SIA GIA' COMPRESA IN SIM
      DO I = 1, NMS
        IF (GEN086 (A, SIM, 1.E-2, 1, I) /= 0.0) THEN
          MV = 0
          RETURN
        END IF
      END DO
      NMS = NMS + 1
      DO I = 1, N
        MK(I, NMS) = 0
        JJ         = 0
        FMIN       = DCM
        CALL GEN078 (A, XO, V, 1, I, 1)
        DO J = 1, N
          IF (MN(I) == MN(J)) THEN
            CALL GEN073 (XO, V, W, 1.0, -1.0, J, 1, 1)
            CALL GEN075 (W, W, F, 1, 1, 2)
            IF (F <= FMIN) THEN
              FMIN = F
              JJ   = J
            END IF
          END IF
        END DO
        IF (JJ == 0) THEN
          NMS = NMS - 1
          MV  = 0
          RETURN
        END IF
        MK(I, NMS) = JJ
      END DO
C * ANALYSE THE MULTIPLICATION MATRIX
      CALL GEN097 (IAT, 1, N, 0)
      DO K = 1, N
        IF (IAT(K) == 0) THEN
          IAT(K) = 1
          NEQ    = 1
          L      = K
   10     M      = MK(L, NMS)
          IF (M /= K) THEN
            IAT(M) = 1
            NEQ    = NEQ + 1
            IF (NEQ > N) THEN
              NMS = NMS - 1
              MV  = 0
              RETURN
            END IF
            L = M
            GO TO 10
          END IF
          CALL GEN088 (A, 1, NORD, MSIGN, INV)
C * IL NUMERO DI ATOMI EQUIVALENTI PER L'OPERAZIONE DI ORDINE M PUO' ESSERE
C * SOLO 1 O 2 (ATOMI GIACENTI SULL'ELEMENTO DI SIMMETRIA) M (CASO NORMALE)
C * O 2M ( QUANDO SI HA UN ELEMENTO RIDUCIBILE 3/M 5/M ETC.)
          IF (NEQ /= 1 .AND. NEQ /= 2) THEN
            IF (NEQ /= NORD) THEN
              IF (NEQ /= 2 * NORD) THEN
                NMS = NMS - 1
                MV  = 0
                RETURN
              END IF
            END IF
          END IF
        END IF
      END DO
      CALL GEN079 (A, SIM, 1, NMS)
      RETURN
      END SUBROUTINE PLA212
 
      SUBROUTINE PLA213 (N, II, MDEG, IER, LU6)
C * MOLSYM (3)
      USE symmol
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: N
      INTEGER                  :: I1
      INTEGER                  :: I2
      INTEGER                  :: I3
      INTEGER                  :: I4
      INTEGER                  :: I5
      INTEGER                  :: K1
      INTEGER                  :: II
      INTEGER                  :: JJ
      INTEGER                  :: KK
      INTEGER                  :: ME
      INTEGER                  :: MV
      INTEGER                  :: IN1
      INTEGER                  :: IN2
      INTEGER                  :: IN3
      INTEGER                  :: IN4
      INTEGER                  :: IER
      INTEGER                  :: LU6
      INTEGER                  :: MDEG
      INTEGER, DIMENSION(5)    :: MP
      INTEGER, DIMENSION(5)    :: IO
      REAL                     :: D1
      REAL                     :: D2
      REAL                     :: DM
      REAL                     :: DP1
      REAL                     :: RAD
      REAL                     :: ROT
      REAL                     :: COM
      REAL                     :: DMED
      REAL                     :: DMIN
      REAL                     :: COSA
      REAL                     :: COST
      REAL                     :: ROT18
      REAL,    DIMENSION(4)    :: EQP
      REAL,    DIMENSION(5)    :: DP
      REAL,    DIMENSION(3, 5) :: VD
      REAL,    DIMENSION(3, 3) :: A
      REAL,    DIMENSION(3, 3) :: B
      REAL,    DIMENSION(3)    :: V
      KK  = 0
      RAD = 57.295779
      DO 50 I1 = 1, N - 4
        IF (MD(I1, 1) /= II) GO TO 50
        MP(1) = I1
        IO(1) = I1
        IN1 = I1 + 1
        DO 40 I2 = IN1, N - 3
          IF (MD(I1, 1) /= II) GO TO 40
          MP(2) = I2
          IN2 = I2 + 1
          DO 30 I3 = IN2, N - 2
            IF (MD(I3, 1) /= II) GO TO 30
            MP(3) = I3
            CALL GEN083 (XO(1, I1), XO(1, I2), XO(1, I3), EQP)
C * SE IL PIANO E' TROPPO VICINO ALL'ORIGINE VIENE SCARTATO
            IF (EQP(4) < 0.5) GO TO 30
            IN3 = I3 + 1
            DO 20 I4 = IN3, N - 1
              IF (MD(I4, 1) /= II) GO TO 20
              MP(4) = I4
              D2 = EQP(1) * XO(1, I4) + EQP(2) * XO(2, I4)
     1           + EQP(3) * XO(3, I4) + EQP(4)
              IF (ABS (D2) > DCM) GO TO 20
              IN4 = I4 + 1
              DO 10 I5 = IN4, N
                IF (MD(I5, 1) /= II) GO TO 10
                MP(5) = I5
                D2 = EQP(1) * XO(1, I5) + EQP(2) * XO(2, I5)
     1             + EQP(3) * XO(3, I5) + EQP(4)
                IF (ABS(D2) > DCM) GO TO 10
C * IN MP CI SONO I POSSIBILI 5 ATOMI EQUIVALENTI RISPETTO ALL'ASSE 5
                DMIN  = 100.0
                DP(1) = DMIN
                DO I = 2, 5
                  IO(I) = 0
                  DP(I) = 0.0
                  CALL GEN073 (XO, XO, VD, 1.0, -1.0, I1, MP(I), 1)
                  CALL GEN075 (VD, VD, DP(I), 1, 1, 2)
                  IF (DP(I) < DMIN) THEN
                    DMIN = DP(I)
                    JJ = I
                  END IF
                END DO
                IO(2)  = MP(JJ)
                DP(JJ) = 100.0
                DMIN   = 100.0
                DO I = 2, 5
                  IF (DP(I) < DMIN .AND. IO(2) /= MP(I)) THEN
                    DMIN = DP(I)
                    KK   = I
                  END IF
                END DO
                IO(5) = MP(KK)
                DO I = 2, 5
                  IF (MP(I) /= IO(2) .AND. MP(I) /= IO(5)
     1               .AND. IO(3) == 0) IO(3) = MP(I)
                  IF (MP(I) /= IO(2) .AND. MP(I) /= IO(5)
     1               .AND. MP(I) /= IO(3)) JJ = MP(I)
                END DO
                CALL GEN073 (XO, XO, VD, 1.0, -1.0, IO(2), IO(3), 1)
                CALL GEN075 (VD, VD, D1, 1, 1, 1)
                CALL GEN073 (XO, XO, VD, 1.0, -1.0, IO(2), JJ, 1)
                CALL GEN075 (VD, VD, D2, 1, 1, 1)
                IO(4) = JJ
                IF (D2 < D1) THEN
                  IO(4) = IO(3)
                  IO(3) = JJ
                END IF
C * ORA I CINQUE ATOMI SONO ORDINATI
C * PER CONTROLLO PRELIMINARE PRIMA DI PASSARE ALLA VERIFY, CONTROLLO
C * CHE SIANO UGUALI ( A MENO DELLA TOLLERANZA) LE DISTANZE 1-2
                DMED = 0.0
                DO I = 1, 5
                  K = I + 1
                  IF (K > 5) K = K - 5
                  CALL GEN073 (XO, XO, VD, 1.0, -1.0, IO(I), IO(K), I)
                  CALL GEN075 (VD, VD, DP(I), I, I, 2)
                  DMED = DMED + DP(I)
                END DO
                DMED = DMED * 0.2
                CALL GEN074 (A, 1, 9, 0.0)
                DO I = 1, 5
                  IF (ABS(DMED - DP(I)) > DCM * 0.5) GO TO 10
C * ASSE C5 COME SOMMA DEI VERTICI DEL PENTAGONO
                  A(1, 3) = A(1, 3) + XO(1, IO(I))
                  A(2, 3) = A(2, 3) + XO(2, IO(I))
                  A(3, 3) = A(3, 3) + XO(3, IO(I))
                END DO
C * METTE IL RIFERIMENTO IN MODO CHE IL PRIMO ASSE 5 COINCIDA CON Z E CHE
C * IL SECONDO SIA NEL PIANO XZ
                A(1, 1) = XO(1, IO(1)) + XO(1, IO(2)) - XO(1, IO(3))
     1                  - XO(1, IO(4)) + XO(1, IO(5))
                A(2, 1) = XO(2, IO(1)) + XO(2, IO(2)) - XO(2, IO(3))
     1                  - XO(2, IO(4)) + XO(2, IO(5))
                A(3, 1) = XO(3, IO(1)) + XO(3, IO(2)) - XO(3, IO(3))
     1                  - XO(3, IO(4)) + XO(3, IO(5))
C * SE LA SOMMA DEI CINQUE ATOMI DA' UN VETTORE NULLO, CIOE' IL PENTAGONO
C * E' SUL CERCHIO MASSIMO (CASO POSSIBILE PER UN GRUPPO DI 30 ATOMI SUGLI
C * ASSI C2) PASSO AD ALTRO PENTAGONO
                CALL GEN082 (A, 3)
                CALL GEN082 (A, 1)
                CALL GEN076 (A, A, A, 3, 1, 2)
                CALL GEN082 (A, 2)
                CALL GEN076 (A, A, A, 2, 3, 1)
                CALL GEN081 (A, A, 1, 1)
                CALL PLA214 (A, N)
C * CONSTRUCT C5-AXIS
                ROT = 72.0 / RAD
                CALL GEN043 (3, B, ROT)
C * VERIFICA E OTTIMIZZA IL PRIMO ASSE 5
                CALL PLA212 (B, MV, N)
                IF (MV == 0) GO TO 10
                CALL PLA216 (V, N, 2, LU6)
C * OTTIMIZZA L'SSE X CON LA STESSA TECNICA PRECEDENTE
                CALL GEN074 (A, 1, 9, 0.0)
                IF (V(3) < 0) THEN
                  V(1) = - V(1)
                  V(2) = - V(2)
                  V(3) = - V(3)
                END IF
                CALL GEN080 (V, A, 1, 3)
                A(1, 1) = XO(1, IO(1)) + XO(1, IO(2)) - XO(1, IO(3))
     1                  - XO(1, IO(4)) + XO(1, IO(5))
                A(2, 1) = XO(2, IO(1)) + XO(2, IO(2)) - XO(2, IO(3))
     1                  - XO(2, IO(4)) + XO(2, IO(5))
                A(3, 1) = XO(3, IO(1)) + XO(3, IO(2)) - XO(3, IO(3))
     1                  - XO(3, IO(4)) + XO(3, IO(5))
                CALL GEN082 (A, 3)
                CALL GEN082 (A, 1)
                CALL GEN076 (A, A, A, 3, 1, 2)
                CALL GEN082 (A, 2)
                CALL GEN076 (A, A, A, 2, 3, 1)
                CALL GEN081 (A, A, 1, 1)
                CALL PLA214 (A, N)
                GO TO 60
   10         CONTINUE
   20       CONTINUE
   30     CONTINUE
   40   CONTINUE
   50 CONTINUE
C * NORMAL EXIT  (NON HA TROVATO NESSUN ASSE C5)
      IF (NMS == 1) RETURN
C * COMPLETA IL GRUPPO C5. INDISPENSABILE QUI!!!
   60 IER = 0
      CALL PLA215 (N, IER)
      IF (IER /= 0) RETURN
C * SCELGO I DUE PENTAGONI PIU' DISTANTI DALL'ASSE C5 PER TROVARE
C * UN ASSE C2. NEL CASO CHE GLI ATOMI DEL SOTTOSET NON SIANO
C * TUTTI INDIPENDENTI, POSTREBBERO ESSERCI PIU' DI CINQUE ATOMI
C * SUL PIANO PARALLELO AL PRIMO PENTAGONO E QUINDI DEVO
C * TESTARE TUTTI I POSSIBILI PENTAGONI
      DM = 0.0
      DO I = 1, N
        IF (MD(I1, 1) == II) THEN
          DA(I) = XO(1, I)**2 + XO(2, I)**2
          IF (DM <= DA(I)) THEN
            KK = I
            DM = DA(I)
          END IF
        END IF
      END DO
      IO(1) = KK
      DP1   = XO(3, KK)
      DO K = 1, 4
        K1     = K + 1
        IO(K1) = MK(IO(K), 2)
        DP1    = DP1 + XO(3, IO(K1))
      END DO
      DP1 = - 0.2 * DP1
C * IN IO(I) CI SONO I CINQUE ATOMI DEL PRIMO PENTAGONO
C * IN MEQ(I) VANNO GLI ATOMI DEL PIANO PARALLELO
      ME = 0
      DO 70 I = 1, N
        COM = ABS (DP1 - XO(3, I))
        IF (COM <= DCM) THEN
C * ELIMINAZIONE (EVENTUALE) DEGLI ATOMI DEL PRIMO PIANO
          DO K = 1, 5
            IF (I == IO(K)) GO TO 70
          END DO
          ME      = ME + 1
          MEQ(ME) = I
        END IF
   70 CONTINUE
C * SCELTA DEGLI ATOMI DEL SECONDO PENTAGONO
   80 DO I = 1, ME
        IF (MEQ(I) /= 0) GO TO 90
      END DO
C * NON CI SONO ASSI C2!!!
      MDEG = 1
      RETURN
C * I E' IL PRIMO ATOMO DEL NUOVO PENTAGONO
   90 MP(1)  = MEQ(I)
      MEQ(I) = 0
      K = 1
C * CERCA GLI ALTRI ATOMI DEL SECONDO PENATGONO E ANNULLA I RELATIVI MEQ
      DO K = 1, 4
        K1     = K + 1
        MP(K1) = MK(MP(K), 2)
        DO L = 1, ME
          IF (MP(K1) == MEQ(L)) MEQ(L) = 0
        END DO
      END DO
C * SOMMA VETTORI DEL PRIMO PENTAGONO OPPORTUNAMENTE RUOTATI
C * COSTRUZIONE DELL'ASSE C2 PERPENDICOLARE A C5 E PARALLELO A X
      CALL GEN074 (A,  1,  9, 0.0)
      CALL GEN074 (VD, 1, 15, 0.0)
      DO 110 I = 1, 5
        K = IO(I)
        DO L = 1, NMS
          IF (MK(K, L) == IO(1)) THEN
            CALL GEN078 (SIM, XO, VD, L, K, 3)
            CALL GEN073 (VD, VD, VD, 1.0, 1.0, 3, 1, 1)
            GO TO 100
          END IF
        END DO
  100   K = MP(I)
        DO L = 1, NMS
          IF (MK(K, L) == MP(1)) THEN
            CALL GEN078 (SIM, XO, VD, L, K, 3)
            CALL GEN073 (VD, VD, VD, 1.0, 1.0, 3, 2, 2)
            GO TO 110
          END IF
        END DO
  110 CONTINUE
      VD(3, 1) = 0.0
      VD(3, 2) = 0.0
      CALL GEN082 (VD, 1)
      CALL GEN082 (VD, 2)
      COST = COS (36.1 / RAD)
      DO I = 1, 5
        CALL GEN078 (SIM, VD, VD, 2, 2, 2)
        CALL GEN075 (VD, VD, COSA, 1, 2, 1)
        IF (COSA >= COST) GO TO 120
      END DO
  120 CALL GEN073 (VD, VD, A, 1.0, 1.0, 1, 2, 1)
      CALL GEN082 (A, 1)
      A(3, 3) = 1.0
      CALL GEN076 (A, A, A, 3, 1, 2)
      CALL GEN082 (A, 2)
      CALL GEN076 (A, A, A, 2, 3, 1)
      CALL GEN082 (A, 1)
      CALL GEN081 (A, A, 1, 1)
      CALL PLA214 (A, N)
      CALL GEN074 (B, 1, 9, 0.0)
      B(1, 1) =  1.0
      B(2, 2) = -1.0
      B(3, 3) = -1.0
      CALL PLA212 (B, MV, N)
      IF (MV /= 1) THEN
        CALL GEN081 (A, A, 1, 1)
        CALL PLA214 (A, N)
        CALL GEN074 (A, 1, 9, 0.0)
        A(1, 2) = -1.0
        A(2, 1) =  1.0
        A(3, 3) =  1.0
        CALL PLA214 (A, N)
        CALL PLA212 (B, MV, N)
        IF (MV /= 1) THEN
          CALL GEN081 (A, A, 1,1)
          CALL PLA214 (A, N)
          GO TO 80
        END IF
      END IF
C * CONTROLLA IL CENTRO
      CALL GEN021 (B, -1.0)
      CALL PLA212 (B, MV, N)
C * COSTRUZIONE DELL'ASSE C5 A |X|=63.43494882 DA Z E LA CUI PRIEZIONE
C * E' A 18 DA X
      ROT = -63.434949 / RAD
  130 CALL GEN043 (1, A, - ROT)
C * ROTAZIONE 18 SU Z
      ROT18 = -18.0 / RAD
  140 CALL GEN043 (3, B, - ROT18)
      CALL GEN077 (B, A, A, 1, 1, 1)
      CALL GEN077 (SIM, A, B, 2, 1, 1)
      CALL GEN081 (A, A, 1, 1)
      CALL GEN077 (A, B, A, 1, 1, 1)
      CALL PLA212 (A, MV, N)
      IF (MV /= 1) THEN
        IF (ROT18 < 0.0) THEN
          ROT18 = - ROT18
          GO TO 140
        END IF
        IF (ROT > 0.0) RETURN
        ROT = - ROT
        GO TO 130
      END IF
      IER = 0
      CALL PLA215 (N, IER)
      IER = 1
      RETURN
      END SUBROUTINE PLA213
 
      SUBROUTINE PLA214 (COZ, N)
C * MOLSYM (4)
      USE symmol
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: N
      REAL                  :: DETER
      REAL, DIMENSION(3, 3) :: COZ
      DO I = 1, N
        CALL GEN078 (COZ, XO, XO, 1, I, I)
      END DO
      CALL GEN077 (COZ, ORX, ORX, 1, 1, 1)
      CALL GEN077 (COZ, OT, OT, 1, 1, 1)
      CALL GEN003 (OT,  OTI, DETER, 0)
      RETURN
      END SUBROUTINE PLA214
 
      SUBROUTINE PLA215 (N, IER)
C * MOLSYM (5) - COMPLETE THE GROUP
      USE symmol
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: K1
      INTEGER               :: JJ
      INTEGER               :: NN
      INTEGER               :: IER
      REAL                  :: GEN086
      REAL, DIMENSION(3, 3) :: COX
   10 NN = NMS
      DO I = 1, NN
        DO J = 1, NN
          CALL GEN077 (SIM, SIM, COX, I, J, 1)
          DO JJ = 1, NN
            L = NINT (GEN086 (COX, SIM, 1.E-2, 1, JJ))
            IF (L == 1) GO TO 20
          END DO
C * NEW MATRIX FOUND
          NMS = NMS + 1
C *m ERROR RETURN
          IF (NMS <= NMG) THEN
            CALL GEN079 (COX, SIM, 1, NMS)
            DO K = 1, N
              K1         = MK(K, J)
              MK(K, NMS) = MK(K1, I)
            END DO
            GO TO 10
          END IF
          IER = 1
          RETURN
C * GROUP MULTIPLICATION TABLE
   20     MTG(I, J) = JJ
        END DO
      END DO
C * GROUP COMPLETE
      RETURN
      END SUBROUTINE PLA215
 
      SUBROUTINE PLA216 (V3, N, IAX, LU6)
C * MOLSYM (6)
      USE symmol
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: IM
      INTEGER            :: NG
      INTEGER            :: IAX
      INTEGER            :: LU6
      INTEGER            :: IOST
      REAL               :: DI
      REAL               :: DIMX
      REAL               :: DIS
      REAL               :: DISM
      REAL               :: COST
      REAL               :: ABCOS
      REAL               :: ABSABCOS
      REAL               :: GEN084
      REAL, DIMENSION(3) :: V3
      REAL, DIMENSION(3) :: VS
C * FA IN MODO CHE GLI LA SOMMA DELLE DISTANZE DALL'ELEMENTO DI SIMMETRIA IAX
C * SIA MINIMO
      CALL GEN097 (IV, 1, N, 0)
      NG   = 0
      COST = GEN084 (SIM, IAX)
   10 DO I = 1, N
        IF (IV(I) == 0) GO TO 20
      END DO
      GO TO 30
   20 NG = NG + 1
C * NG = NUMERO DEL GRUPPO DI ATOMI EQUIVALENTE RISPETTO ALL'OPERAZIONE IAX
      IV(I) = NG
      DO J = 1, 3
        COY(J, NG) = XO(J, I)
      END DO
      WWW(NG) = WGHT(I)
      NGE(NG) = 1
      K = I
      DO
        L = MK(K, IAX)
        IF (L == I) GO TO 10
        IV(L) = NG
C * SOMMA TUTTI GLI ATOMI DEL GRUPPO CON SEGNO OPPORTUNO
        DO J = 1, 3
          COY(J, NG) = COY(J, NG) + COST * XO(J, L)
        END DO
        WWW(NG) = WWW(NG) + WGHT(L)
        NGE(NG) = NGE(NG) + 1
        K = L
      END DO
C * HA ASSEGNATO TUTTI GLI ATOMI AD UN GRUPPO ED IL WGHT AI GRUPPI
   30 DO I = 1, NG
        WWW(I) = WWW(I) / NGE(I)
      END DO
      CALL GEN074 (V3, 1, 3, 0.0)
      DISM = 0.0
C * CERCA IL GRUPPO PIU' LONTANO DALL'ELEMENTO DI SIMMETRIA (IM)
      DO I = 1, NG
        CALL GEN078 (SIM, COY, VS, IAX, I, 1)
        CALL GEN073 (COY, VS, VS, 1.0, COST, I, 1, 1)
        CALL GEN075 (VS, VS, DIS, 1, 1, 1)
        IF (DIS > DISM) THEN
          DISM = DIS
          IM = I
        END IF
      END DO
      CALL GEN074 (V3, 1, 3, 0.0)
      IF (IM <= 0 .OR. IM > NMA) THEN
        WRITE (LU6, 99998, IOSTAT = IOST) IM
      ELSE
        CALL GEN075 (COY, COY, DIMX, IM, IM, 2)
C * SOMMA FRA LORO TUTTI I GRUPPI CON UN SEGNO DETERMINATO DALL'ANGOLO
C * FRA IL GRUPPO IN ESAME ED IL GRUPPO IM
        IF (NG > NMA) THEN
          WRITE (LU6, 99999, IOSTAT = IOST) NG
        ELSE
          DO I = 1, NG
            CALL GEN075 (COY, COY, ABCOS, IM, I, 1)
            CALL GEN075 (COY, COY, DI, I, I, 2)
            ABSABCOS = ABS (ABCOS)
            IF (ABSABCOS > 1.E-5) THEN
              COST = WWW(I) * ABCOS / ABSABCOS
              CALL GEN073 (V3, COY, V3, 1.0, COST, 1, I, 1)
            END IF
          END DO
C * IL VETTORE RISULTANTE E' NORMALIZZATO E DIVENTERA' UNA RIGA DELLA
C * MATRICE DI ROTAZIONE DEFINITIVA
          CALL GEN082 (V3, 1)
          IF (V3(1) <= 0.0) THEN
            V3(1) = - V3(1)
            V3(2) = - V3(2)
            V3(3) = - V3(3)
          END IF
        END IF
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT ('NG = ', I10)
99998 FORMAT ('IM = ', I10)
      END SUBROUTINE PLA216
 
      SUBROUTINE PLA217 (XCSM, NES, N)
C * MOLSYM (7)
      USE symmol
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: NES
      INTEGER            :: NAZ
      REAL               :: COM
      REAL               :: COST
      REAL               :: XCSM
      REAL, DIMENSION(3) :: V3
C * CALCULATE SYMMETRIZED COORDINATES
      NAZ = 3 * N
      CALL GEN074 (CO,   1, NAZ, 0.0)
      CALL GEN074 (XS,   1, NAZ, 0.0)
      CALL GEN074 (RMSX, 1, NAZ, 0.0)
      CALL GEN074 (DEL,  1,   4, 0.0)
      CALL GEN074 (DELM, 1,   4, 0.0)
      CALL GEN074 (CF,   1,   N, 0.0)
C * ISU = INDEX OF SUBGROUP MATRIC UNDER CONSIDERATION
C * NES = NUMBER OF SYMMETRY ELEMENTS IN SUBGROUP
      DO I = 1, N
        CALL GEN075 (XO, XO, D(I), I, I, 2)
        DO J = 1, NES
          K = MK(I, ISU(J))
          CALL GEN078 (SIM, XO, V3, ISU(J), I, 1)
          CALL GEN073 (XS, V3, XS, 1.0, 1.0, K, 1, K)
        END DO
      END DO
      DO I = 1, N
        DO J = 1, 3
          XS(J, I) = XS(J, I) / FLOAT (NES)
        END DO
        CALL GEN075 (XS, XS, DC(I), I, I, 2)
      END DO
      DO I = 1, N
        DO J = 1, NES
          K = MK(I, ISU(J))
          CF(I) = CF(I) + D(K)
        END DO
C * NOTE CHANGE CRIT FROM -1 TO -4 (ALS)
        IF (DC(I) > 1.E-04) CF(I) = CF(I) / (DC(I) * NES)
        DO J = 1, 3
          XS(J, I) = XS(J, I) * CF(I)
        END DO
      END DO
C * IL FATTORE DI CORREZIONE CF=MEDIA DELLE DISTANZE ATOMI EQUIVALENTI
C * BARICENTRO, CORREGGE LE COORDINATE SIMMETRIZZATE FACENDO SI CHE QUESTE
C * EQUIVALGANO ALLA MEDIA PER PURA ROTAZIONE DEGLI ATOMI EQUIVALENTI
C * CALCOLA LE RMS E GLI SCOSTAMENTI MEDI (DEL) E MASSIMI DLM
      DO I = 1, N
        DO J = 1, 3
          V3(J)  = XO(J, I) - XS(J, I)
          COM    = ABS (V3(J))
          DEL(J) = DEL(J) + COM
          IF (COM > DELM(J)) DELM(J) = COM
        END DO
C * MASSIMA DEVIAZIONE DALLA SIMMETRIA IN ANGSTROM
        CALL GEN075 (V3, V3, COM, 1, 1, 2)
        DEL(4) = DEL(4) + COM
        IF (DELM(4) < COM) DELM(4) = COM
      END DO
C * CALCULATE THE  CONTINUOUS SYMMETRY MEASURE (CSM)
      XCSM = 0.0
      DO J = 1, NES
        DO I = 1, N
          K = MK(I, ISU(J))
          CALL GEN078 (SIM, XO, V3, ISU(J), I, 1)
          CALL GEN073 (XS, V3, V3, 1.0, -1.0, K, 1, 1)
          DO L = 1, 3
            RMSX(L, K) = RMSX(L, K) + V3(L) ** 2
          END DO
          CALL GEN075 (V3, V3, COM, 1, 1, 1)
          XCSM = XCSM + COM
        END DO
      END DO
      COST = 1.0 / FLOAT (NES)
      RMST = 0.0
      DO I = 1, N
        DO J = 1, 3
          RMST       = RMST + RMSX(J, I)
          RMSX(J, I) = SQRT (RMSX(J, I) * COST)
        END DO
      END DO
      RMST = SQRT (RMST / FLOAT (NES * N))
      XCSM = XCSM * 100.0 / FLOAT (NES * N)
      RETURN
      END SUBROUTINE PLA217
 
      MODULE conpuc
      SAVE
      INTEGER, PARAMETER  :: NP5 = 250
      REAL, DIMENSION(20) :: XA
      REAL, DIMENSION(20) :: XB
      REAL, DIMENSION(20) :: XXA
      REAL, DIMENSION(20) :: XXB
      END MODULE conpuc
 
      SUBROUTINE PLA218 (Q, PHI, AAZ, NR, LU7)
C * CONPUC - BOEYENS Y EVANS
C * THIS PROGRAM-LINK EXPRESSES ANY CONFORMATION AS A LINEAR COMBINATION
C * OF PRIMITIVE FORMS- AS DEFINED BY THE CREMER-POPLE EQUATIONS.
C * THE PROGRAM IS DESIGNED TO HANDLE UP TO 8-MEMBERED RINGS.
      USE conpuc
      IMPLICIT NONE
      INTEGER              :: N
      INTEGER              :: IC
      INTEGER              :: NR
      INTEGER              :: LU7
      INTEGER              :: IOST
      REAL                 :: R
      REAL                 :: AAZ
      REAL, DIMENSION(NP5) :: Q
      REAL, DIMENSION(NP5) :: PHI
      IF (NR <= 18) THEN
        N = (NR - 1) / 2
C * WRITE OUTPUT HEADER
        CALL PLA262 (3)
        WRITE (LU7, 99999, IOSTAT = IOST)
C * DISTINGUISH BETWEEN ODD AND EVEN MEMBERED RINGS
        IF (NR / 2 > N) THEN
          IC    = NR / 2
          Q(IC) = AAZ
          R     = Q(IC)
          IF (NR <= 8) THEN
            CALL PLA219 (Q, PHI, N, NR, R, LU7)
          ELSE
            CALL PLA220 (Q, PHI, N, NR, R, LU7)
          END IF
        ELSE
          CALL PLA221 (Q, PHI, N, NR, LU7)
        END IF
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT(/, 'Conformational Analysis (G.G. Evans & ',
     1 'J.A. Boeyens, Acta Cryst. (1989), B45, 581-590)', /)
      END SUBROUTINE PLA218
 
      SUBROUTINE PLA219 (Q, PHI, N, NR, R, LU7)
C * THIS ROUTINE GENERATES THE PRIMITIVE FORMS FOR 6 AND 8 MEMBERED RINGS
      USE conpuc
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: M
      INTEGER                         :: N
      INTEGER                         :: NR
      INTEGER                         :: LU7
      INTEGER                         :: IOST
      REAL                            :: R
      REAL                            :: V
      REAL                            :: VV
      REAL                            :: RZ
      REAL                            :: AA
      REAL                            :: RL
      REAL                            :: YXX
      REAL                            :: RLA
      REAL                            :: RLL
      REAL                            :: QXX
      REAL                            :: ANG
      REAL                            :: QXXA
      REAL                            :: ANGA
      REAL                            :: ANGL
      REAL, DIMENSION(NP5)            :: Q
      REAL, DIMENSION(8)              :: QX
      REAL, DIMENSION(8)              :: QXA
      REAL, DIMENSION(NP5)            :: PHI
      REAL, DIMENSION(6)              :: TF1
      REAL, DIMENSION(6)              :: TF2
      REAL, DIMENSION(6)              :: TF3
      REAL, DIMENSION(15)             :: UF1
      REAL, DIMENSION(15)             :: UF2
      REAL, DIMENSION(15)             :: UF3
      REAL, DIMENSION(15)             :: UF4
      REAL, DIMENSION(15)             :: UF5
      REAL, DIMENSION(15)             :: YXZ
      REAL, DIMENSION(50)             :: KMIN
      REAL, DIMENSION(50)             :: LMIN
      CHARACTER(len=1), DIMENSION(6)  :: NAMEY
      CHARACTER(len=3), DIMENSION(15) :: NAMEX
      NAMEY = (/ 'B', 'T', 'C', 'E', 'S', 'H'/)
      TF1   = (/ 1.0, 0.0, 0.0, 0.586, 0.0,   0.0/)
      TF2   = (/ 0.0, 1.0, 0.0, 0.0,   0.707, 0.551/)
      TF3   = (/ 0.0, 0.0, 1.0, 0.414, 0.293, 0.449/)
C * DATA FOR THE CLASSICAL FORMS
      NAMEX = (/ 'BB ', 'BB ', 'CR ', 'TC ', 'TC ', 'C  ', 'B  ',
     1 'S  ', 'S  ', 'CC ', 'CC ', 'TCC', 'BC ', 'BC ', 'TBC'/)
      UF1   = (/ 1.0, 0.0,   0.0,   0.0, 0.0, 0.0, 0.5, 0.707, 0.293,
     1  0.352, 0.0, 0.234, 0.530, 0.0, 0.229/)
      UF2   = (/ 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.5, 0.293, 0.707, 0.0,
     1  0.352, 0.234, 0.0, 0.530, 0.229/)
      UF3   = (/ 0.0, 0.0, 0.0, 1.0, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0,
     1  0.0, 0.0, 0.298, 0.0, 0.213/)
      UF4 = (/ 0.0, 0.0, 0.0, 0.0, 1.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0,
     1  0.0, 0.0, 0.298, 0.213/)
      UF5 = (/ 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.648,
     1  0.648, 0.533, 0.172, 0.172, 0.116/)
C * THIS FINDS THE CROWN FORM CLOSEST TO THE RING
      IF (R <= 0) THEN
        AA = -1.0
      ELSE
        AA =  1.0
      END IF
      V = ABS (R)
C * THIS DETERMINES THE ANGULAR VALUES OF PRIMITIVE FORMS OF 6-M RINGS
      IF (NR == 6) THEN
        DO M = 2, N
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, 7, 4)
        END DO
        CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
        WRITE (LU7, 99997, IOSTAT = IOST) NR / 2, VV, AA
C * THIS FINDS OUT IF THE 6-M RING IS A CLASSICAL FORM
C * DATA FOR 6-M CLASSICAL FORMS
        DO I = 1, 6
          YXX = ABS (TF1(I) - XXA(2)) + ABS (TF2(I) - XXB(2))
     1        + ABS (TF3(I) - VV)
          IF (YXX <= 0.2 .AND. YXX > 0.1)
     1        WRITE (LU7, 99998, IOSTAT = IOST) NAMEY(I)
          IF (YXX <= 0.1) THEN
            CALL PLA262 (3)
            WRITE (LU7, 99999, IOSTAT = IOST) NAMEY(I)
          END IF
        END DO
C * THE PRIMITIVE FORMS OF EIGHT MEMBERED RINGS
      ELSE
        DO M = 2, N
C * PRIMITIVE FORMS ARE AT DIFFERENT PHI VALUES FOR M = 2 AND 3
          IF (M == 2) THEN
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 3, 16)
          ELSE
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 5, 8)
          END IF
        END DO
        CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
        WRITE (LU7, 99997, IOSTAT = IOST) NR / 2, VV, AA
C * THIS FINDS OUT IF THE  8-M RING IS A CLASSICAL FORM
        DO I = 1, 15
          YXZ(I) = ABS (XXA(2) - UF1(I)) + ABS (XXB(2) - UF2(I))
     1           + ABS (XXA(3) - UF3(I)) + ABS (XXB(3) - UF4(I))
     2           + ABS (VV - UF5(I))
        END DO
        DO I = 1, 12
          IF (YXZ(I) <= 0.2 .AND. YXZ(I) > 0.1) THEN
            CALL PLA262 (3)
            WRITE (LU7, 99998, IOSTAT = IOST) NAMEX(I)
          END IF
          IF (YXZ(I) <= 0.1) THEN
            CALL PLA262 (3)
            WRITE (LU7, 99999, IOSTAT = IOST) NAMEX(I)
          END IF
        END DO
        DO I = 2, N
          RZ = ABS (PHI(I) - 360)
          IF (RZ < 5) PHI(I) = 360 - PHI(I)
        END DO
        IF (YXZ(13) <= 0.2 .OR. YXZ(14) <= 0.2) THEN
          DO J = 1, 8
            ANG  = FLOAT (      (8 * 180 * (J - 1)) / 16)
            ANGA = FLOAT (180 + (8 * 180 * (J - 1)) / 16)
            ANGL = FLOAT (180 + (4 * 180 * (J - 1)) / 16)
            CALL PLA223 (1, ANG,  PHI, RL,  2)
            CALL PLA223 (1, ANGA, PHI, RLA, 2)
            CALL PLA223 (4, ANGL, PHI, RLL, 3)
            QX(J)  = RL  + RLL
            QXA(J) = RLA + RLL
          END DO
          QXX  = 10.03
          QXXA = 10.03
          DO J = 1, 8
            IF (QX(J)  <= 10 .AND. AA == -1.0) QXX  = QX(J)
            IF (QXA(J) <= 10 .AND. AA ==  1.0) QXXA = QXA(J)
          END DO
          IF (QXX <= 10) THEN
            IF (YXZ(13) <= 0.1 .OR. YXZ(14) <= 0.1) THEN
              CALL PLA262 (3)
              WRITE (LU7, 99999, IOSTAT = IOST) NAMEX(13)
            END IF
          END IF
          IF (QXXA <= 10) THEN
            IF (YXZ(13) > 0.1 .OR. YXZ(14) > 0.1) THEN
              CALL PLA262 (3)
              WRITE (LU7, 99998, IOSTAT = IOST) NAMEX(13)
            END IF
          END IF
        ELSE IF (YXZ(15) <= 0.2) THEN
          DO J = 1, 8
            ANG  = FLOAT (      45 + (8 * 180 * (J - 1)) / 16)
            ANGA = FLOAT (180 + 45 + (8 * 180 * (J - 1)) / 16)
            ANGL = FLOAT (180 + 22 + (4 * 180 * (J - 1)) / 16)
            CALL PLA223 (1, ANG,  PHI, RL,  2)
            CALL PLA223 (1, ANGA, PHI, RLA, 2)
            CALL PLA223 (4, ANGL, PHI, RLL, 3)
            QX(J)  = RL  + RLL
            QXA(J) = RLA + RLL
          END DO
          QXX  = 10.03
          QXXA = 10.03
          DO J = 1, 8
            IF (QX(J)  <= 10 .AND. AA == -1.0) QXX  = QX(J)
            IF (QXA(J) <= 10 .AND. AA ==  1.0) QXXA = QXA(J)
          END DO
          IF (QXX <= 10 .OR. QXXA <= 10) THEN
            CALL PLA262 (3)
            IF (YXZ(15) <= 0.1) THEN
              WRITE (LU7, 99999, IOSTAT = IOST) NAMEX(15)
            ELSE
              WRITE (LU7, 99998, IOSTAT = IOST) NAMEX(15)
            END IF
          END IF
        END IF
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (/, ':: Note: This is a ', A, '-Form', /)
99998 FORMAT (/, ':: Note: This is Very Similar to a ', A,'-Form')
99997 FORMAT (10X, I2, 21X, F5.3, 8X, F4.1)
      END SUBROUTINE PLA219
 
      SUBROUTINE PLA220 (Q, PHI, N, NR, R, LU7)
C * CONPUC (3)
      USE conpuc
      IMPLICIT NONE
      INTEGER              :: M
      INTEGER              :: N
      INTEGER              :: NR
      INTEGER              :: LU7
      INTEGER              :: IOST
      REAL                 :: R
      REAL                 :: V
      REAL                 :: AA
      REAL                 :: VV
      REAL, DIMENSION(NP5) :: Q
      REAL, DIMENSION(NP5) :: PHI
      REAL, DIMENSION(50)  :: KMIN
      REAL, DIMENSION(50)  :: LMIN
C * THIS SUBROUTINE FINDS THE PRIMITIVE FORMS OF EVEN RINGS
C * WITH MORE THAN 10 RING ATOMS
      IF (R <= 0) THEN
        AA = -1.0
      ELSE
        AA =  1.0
      END IF
      V = ABS (R)
      IF (NR == 10) THEN
        DO M = 2, N
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, 11, 4)
        END DO
      ELSE IF (NR == 12) THEN
        DO M = 2, N
          IF (M == 3) THEN
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 3, 24)
          ELSE
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 13, 8)
          END IF
        END DO
      ELSE IF (NR == 14) THEN
        DO M = 2, N
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, 15, 4)
        END DO
      ELSE IF (NR == 16) THEN
        DO M = 2, N
          IF (M == 2 .OR. M == 6) THEN
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 5, 16)
          ELSE IF (M == 4) THEN
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 3, 32)
          ELSE
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 9, 8)
          END IF
        END DO
      ELSE
        DO M = 2, N
          IF (M == 3 .OR. M == 6) THEN
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 7, 12)
          ELSE
            CALL PLA225 (M, KMIN, LMIN, PHI, NR, 19, 4)
          END IF
        END DO
      END IF
      CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
      WRITE (LU7, 99999, IOSTAT = IOST) NR / 2, VV, AA
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (10X, I2, 21X, F5.3, 8X, F4.1)
      END SUBROUTINE PLA220
 
      SUBROUTINE PLA221 (Q, PHI, N, NR, LU7)
C * CONPUC (4) - THIS FINDS THE PRIMITIVE FORMS OF ODD MEMBERED RINGS
      USE conpuc
      IMPLICIT NONE
      INTEGER                          :: I
      INTEGER                          :: J
      INTEGER                          :: M
      INTEGER                          :: N
      INTEGER                          :: NR
      INTEGER                          :: NRR
      INTEGER                          :: LU7
      INTEGER                          :: IOST
      REAL                             :: V
      REAL                             :: VV
      REAL                             :: YX
      REAL                             :: RH
      REAL                             :: RL
      REAL                             :: RM
      REAL                             :: RZ
      REAL                             :: RLA
      REAL                             :: RLL
      REAL                             :: RLM
      REAL                             :: RMA
      REAL                             :: QXX
      REAL                             :: RMM
      REAL                             :: QYY
      REAL                             :: ANG
      REAL                             :: QXX1
      REAL                             :: QXX2
      REAL                             :: QXX3
      REAL                             :: QXX4
      REAL                             :: QXXA
      REAL                             :: QYYA
      REAL                             :: ANGA
      REAL                             :: ANGL
      REAL                             :: ANGM
      REAL                             :: ANGLM
      REAL                             :: ANGMA
      REAL,             DIMENSION(50)  :: KMIN
      REAL,             DIMENSION(50)  :: LMIN
      REAL,             DIMENSION(NP5) :: Q
      REAL,             DIMENSION(NP5) :: PHI
      REAL,             DIMENSION(2)   :: SF1
      REAL,             DIMENSION(2)   :: SF2
      REAL,             DIMENSION(9)   :: XF1
      REAL,             DIMENSION(9)   :: XF2
      REAL,             DIMENSION(9)   :: XF3
      REAL,             DIMENSION(9)   :: XF4
      REAL,             DIMENSION(16)  :: XN1
      REAL,             DIMENSION(16)  :: XN2
      REAL,             DIMENSION(16)  :: XN3
      REAL,             DIMENSION(16)  :: XN4
      REAL,             DIMENSION(16)  :: XN5
      REAL,             DIMENSION(16)  :: XN6
      REAL,             DIMENSION(16)  :: YZZ
      REAL,             DIMENSION(19)  :: QX
      REAL,             DIMENSION(14)  :: QY
      REAL,             DIMENSION(14)  :: QXA
      REAL,             DIMENSION(14)  :: QYA
      REAL,             DIMENSION(18)  :: QX1
      REAL,             DIMENSION(18)  :: QX2
      REAL,             DIMENSION(18)  :: QX3
      REAL,             DIMENSION(18)  :: QX4
      CHARACTER(len=1), DIMENSION(2)   :: NAMEY
      CHARACTER(len=2), DIMENSION(9)   :: NAMEX
      CHARACTER(len=4), DIMENSION(16)  :: NAMX
C * DATA FOR 5-M CLASSICAL FORMS
      NAMEY = (/'E', 'T'/)
      SF1   = (/1.0, 0.0/)
      SF2   = (/0.0, 1.0/)
C * DATA FOR 7-M CLASSICAL FORMS
      NAMEX = (/ 'B ', 'TB', 'C ', 'TC', 'BS', 'S ', 'TS', 'H ', 'T '/)
      XF1   = (/ 1.00, 0.0, 0.0, 0.0, 0.783, 0.5, 0.0, 0.417, 0.0/)
      XF2   = (/ 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.444, 0.0, 0.46/)
      XF3   = (/ 0.0, 0.0, 1.0, 0.0, 0.217, 0.5, 0.0, 0.583, 0.0/)
      XF4   = (/ 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.555, 0.0, 0.54/)
      NAMX  = (/ 'BB  ', 'TBB ', 'BC  ', 'TBC ', 'CC  ', 'TCC ', 'BC" ',
     1 'TBC"', 'B   ', 'CC" ', 'TB  ', 'TCC"', 'C   ', 'CB  ',
     2 'TC  ', 'TCB '/)
      XN1   = (/ 1.00, 0.0, 0.0, 0.0, 0.0, 0.0, 0.308, 0.0, 0.582,
     1 0.401, 0.0, 0.0, 0.280, 0.601, 0.0, 0.0/)
      XN2   = (/ 0.0, 1.00, 0.0, 0.0, 0.0, 0.0, 0.0, 0.317, 0.0, 0.0,
     1 0.584, 0.397, 0.0, 0.0, 0.340, 0.498/)
      XN3   = (/ 0.0, 0.0, 1.0, 0.0, 0.379, 0.0, 0.563, 0.0, 0.168,
     1 0.189, 0.0, 0.0, 0.617, 0.245, 0.0, 0.0/)
      XN4   = (/ 0.0, 0.0, 0.0, 1.0, 0.0, 0.379, 0.0, 0.564, 0.0, 0.0,
     1 0.168, 0.192, 0.0, 0.0, 0.515, 0.319/)
      XN5   = (/ 0.0, 0.0, 0.0, 0.0, 0.621, 0.0, 0.129, 0.0, 0.250,
     1 0.410, 0.0, 0.0, 0.104, 0.154, 0.0, 0.0/)
      XN6   = (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.621, 0.0, 0.119, 0.0, 0.0,
     1 0.248, 0.411, 0.0, 0.0, 0.145, 0.183/)
      DO M = 2, N
        NRR = 2 * NR + 1
        IF (NR == 9 .AND. M == 3) THEN
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, 7, 6)
        ELSE IF (NR == 15 .AND. M == 5) THEN
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, 7, 10)
        ELSE IF (NR == 15 .AND. M == 3 .OR. NR == 15
     1           .AND. M == 6) THEN
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, 11, 6)
        ELSE
          CALL PLA225 (M, KMIN, LMIN, PHI, NR, NRR, 2)
        END IF
      END DO
      V = 0
      CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
C * CONPUC (5) - THIS DETERMINES IF A RING IS A CLASSICAL FORM
      IF (NR < 10) THEN
        IF (NR == 5) THEN
          DO I = 1, 2
            YX = ABS (SF1(I) - XXA(2)) + ABS (SF2(I) - XXB(2))
            IF (YX <= 0.1) WRITE (LU7, 99999, IOSTAT = IOST) NAMEY(I)
            IF (YX > 0.1 .AND. YX <= 0.2)
     1        WRITE (LU7, 99998, IOSTAT = IOST) NAMEY(I)
          END DO
        ELSE IF (NR == 7) THEN
          DO I = 1, 9
            YZZ(I) = ABS (XXA(2) - XF1(I)) + ABS (XXB(2) - XF2(I))
     1             + ABS (XXA(3) - XF3(I)) + ABS (XXB(3) - XF4(I))
          END DO
          DO I = 2, N
            RZ = ABS (PHI(I) - 360)
            IF (RZ < 5) PHI(I) = 360 - PHI(I)
          END DO
          IF (YZZ(5) <= 0.2) THEN
            DO J = 1, 14
              ANGA = FLOAT (180 + (6 * 180 * (J - 1)) / 14)
              ANGL = FLOAT (      (2 * 180 * (J - 1)) / 14)
              CALL PLA223 (3, ANGA, PHI, RLA, 2)
              RLL   = ABS (PHI(3) - ANGL)
              QX(J) = RLA + RLL
            END DO
            QXX = 10.03
            DO J = 1, 14
              IF (QX(J) <= 10) QXX = QX(J)
            END DO
            IF (QXX <= 10) THEN
              IF (YZZ(5) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) 'BS'
              ELSE
                WRITE (LU7, 99998, IOSTAT = IOST) 'BS'
              END IF
            END IF
          ELSE IF (YZZ(6) <= 0.2 .OR. YZZ(8) <= 0.2) THEN
            DO J = 1, 14
              ANG  = FLOAT (      (6 * 180 * (J - 1)) / 14)
              ANGA = FLOAT (180 + (6 * 180 * (J - 1)) / 14)
              ANGL = FLOAT (      (2 * 180 * (J - 1)) / 14)
              CALL PLA223 (1, ANG, PHI, RL, 2)
              CALL PLA223 (3, ANGA, PHI, RLA, 2)
              RLL    = ABS (PHI(3) - ANGL)
              QX(J)  = RL  + RLL
              QXA(J) = RLA + RLL
            END DO
            QXX  = 10.03
            QXXA = 10.03
            DO J = 1, 14
              IF (QX(J)  <= 10) QXX  = QX(J)
              IF (QXA(J) <= 10) QXXA = QXA(J)
            END DO
            IF (QXX <= 10) THEN
              IF (YZZ(6) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) 'S'
              ELSE IF (YZZ(6) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) 'S'
              ENDIF
            END IF
            IF (QXXA <= 10) THEN
              IF (YZZ(8) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) 'H'
              ELSE IF (YZZ(8) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) 'H'
              ENDIF
            ENDIF
          ELSE IF (YZZ(7) <= 0.2 .OR. YZZ(9) <= 0.2) THEN
            DO J = 1, 14
              ANGM =
     1         FLOAT(                   38 + ((6 * 180 * (J - 1)) / 14))
              ANGMA =
     1        FLOAT(180 +               38 + ((6 * 180 * (J - 1)) / 14))
              ANGLM =
     1       FLOAT(                     12 + ((2 * 180 * (J - 1)) / 14))
              CALL PLA223 (1, ANGM,  PHI, RM,  2)
              CALL PLA223 (3, ANGMA, PHI, RMA, 2)
              RMM    = ABS (PHI(3) - ANGLM)
              QY(J)  = RM  + RMM
              QYA(J) = RMA + RMM
            END DO
            QYY  = 10.03
            QYYA = 10.03
            DO J = 1, 14
              IF (QY(J)  <= 10) QYY  = QY(J)
              IF (QYA(J) <= 10) QYYA = QYA(J)
            END DO
            IF (QYY <= 10) THEN
              IF (YZZ(7) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) 'TS'
              ELSE IF (YZZ(7) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) 'TS'
              ENDIF
            ENDIF
            IF (QYYA <= 10) THEN
              IF (YZZ(9) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) 'T'
              ELSE IF (YZZ(9) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) 'T'
              END IF
            END IF
          ELSE
            DO I = 1, 9
              IF (YZZ(I) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMEX(I)
              ELSE IF (YZZ(I) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMEX(I)
              END IF
            END DO
          END IF
        ELSE
          DO I = 1, 16
            YZZ(I) = ABS (XXA(2) - XN1(I)) + ABS (XXB(2) - XN2(I))
     1             + ABS (XXA(3) - XN3(I)) + ABS (XXB(3) - XN4(I))
     2             + ABS (XXA(4) - XN5(I)) + ABS (XXB(4) - XN6(I))
          END DO
          DO I = 2, N
            RH = ABS (PHI(I) - 360.0)
            IF (RH < 5) PHI(I) = 360.0 - PHI(I)
          END DO
          IF (YZZ(5) <= 0.2) THEN
            DO J = 1, 18
              ANG  = FLOAT (180 + (6 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (      (2 * 180 * (J - 1)) / 18)
              CALL PLA223 (3, ANG, PHI, RL, 3)
              RLL   = ABS (PHI(4) - ANGL)
              QX(J) = RL + RLL
            END DO
            QXX = 10.03
            DO J = 1, 18
              IF (QX(J) <= 10) QXX = QX(J)
            END DO
            IF (QXX <= 10) THEN
              IF (YZZ(5) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(5)
              ELSE IF (YZZ(5) > 0.1) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(5)
              END IF
            END IF
          ELSE IF (YZZ(6) <= 0.2) THEN
            DO J = 1, 18
              ANG  = FLOAT (180 + 30 + (6 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (      10 + (2 * 180 * (J - 1)) / 18)
              CALL PLA223 (3, ANG, PHI, RL, 3)
              RLL   = ABS (PHI(4) - ANGL)
              QX(J) = RL + RLL
            END DO
            QXX = 10.03
            DO J = 1, 18
              IF (QX(J) <= 10) QXX = QX(J)
            END DO
            IF (QXX <= 10) THEN
              IF (YZZ(6) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(6)
              ELSE IF (YZZ(6) > 0.1)  THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(6)
              END IF
            END IF
          ELSE IF (YZZ(7) <= 0.2 .OR. YZZ(9) <= 0.2 .OR. YZZ(10)
     1      <= 0.2 .OR. YZZ(13) <= 0.2 .OR. YZZ(14) <= 0.2) THEN
            DO J = 1, 18
              ANG  = FLOAT (180 + (10 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (180 +  (6 * 180 * (J - 1)) / 18)
              ANGM = FLOAT (       (2 * 180 * (J - 1)) / 18)
              CALL PLA223 (2, ANG,  PHI, RL,  2)
              CALL PLA223 (3, ANGL, PHI, RLL, 3)
              CALL PLA223 (4, ANGM, PHI, RLM, 4)
              QX(J) = RL + RLL + RLM
            END DO
            QXX = 15.03
            DO J = 1, 18
              IF (QX(J) <= 15) QXX = QX(J)
            END DO
            IF (QXX <= 15) THEN
              IF (YZZ(7) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(7)
              ELSE IF (YZZ(7) > 0.1) THEN
                IF (YZZ(7) <= 0.2) THEN
                  WRITE (LU7, 99998, IOSTAT = IOST) NAMX(7)
                END IF
              END IF
            END IF
            DO J = 1, 18
              ANG  = FLOAT (      (10 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (180 + (6  * 180 * (J - 1)) / 18)
              ANGM = FLOAT (      (2  * 180 * (J - 1)) / 18)
              CALL PLA223 (2, ANG,  PHI, RL,  2)
              CALL PLA223 (3, ANGL, PHI, RLL, 3)
              CALL PLA223 (4, ANGM, PHI, RLM, 4)
              QX1(J) = RL + RLL + RLM
            END DO
            QXX1 = 15.03
            DO J = 1, 18
              IF (QX1(J) <= 15) QXX1 = QX1(J)
            END DO
            IF (QXX1 <= 15) THEN
              IF (YZZ(9) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(9)
              ELSE IF (YZZ(9) > 0.1) THEN
                IF (YZZ(9) <= 0.2) THEN
                  WRITE (LU7, 99998, IOSTAT = IOST) NAMX(9)
                END IF
              END IF
              IF (YZZ(10) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(10)
              ELSE IF (YZZ(10) > 0.1) THEN
                IF (YZZ(10) <= 0.2) THEN
                  WRITE (LU7, 99998, IOSTAT = IOST) NAMX(10)
                ENDIF
              END IF
            END IF
            DO J = 1, 18
              ANG  = FLOAT (180 + (10 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (       (6 * 180 * (J - 1)) / 18)
              ANGM = FLOAT (       (2 * 180 * (J - 1)) / 18)
              CALL PLA223 (2, ANG,  PHI, RL,  2)
              CALL PLA223 (3, ANGL, PHI, RLL, 3)
              CALL PLA223 (4, ANGM, PHI, RLM, 4)
              QX2(J) = RL + RLL + RLM
            END DO
            QXX2 = 15.03
            DO J = 1, 18
              IF (QX2(J) <= 15) QXX2 = QX2(J)
            END DO
            IF (QXX2 <= 15) THEN
              IF (YZZ(13) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(13)
              ELSE IF (YZZ(13) > 0.1) THEN
                IF (YZZ(13) <= 0.2) THEN
                  WRITE (LU7, 99998, IOSTAT = IOST) NAMX(13)
                END IF
              END IF
              IF (YZZ(14) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(14)
              ELSE IF (YZZ(14) > 0.1) THEN
                IF (YZZ(14) <= 0.2) THEN
                  WRITE (LU7, 99998, IOSTAT = IOST) NAMX(14)
                END IF
              END IF
            END IF
          ELSE IF (YZZ(8) <= 0.2 .OR. YZZ(11) <= 0.2 .OR. YZZ(12)
     1      <= 0.2 .OR. YZZ(15) <= 0.2 .OR. YZZ(16) <= 0.2) THEN
            DO J = 1, 18
              ANG  = FLOAT (180 + 50 + (10 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (180 + 30 +  (6 * 180 * (J - 1)) / 18)
              ANGM = FLOAT (      10 +  (2 * 180 * (J - 1)) / 18)
              CALL PLA223 (2, ANG,  PHI, RL,  2)
              CALL PLA223 (3, ANGL, PHI, RLL, 3)
              CALL PLA223 (4, ANGM, PHI, RLM, 4)
            END DO
            QXX = 15.03
            DO J = 1, 18
              IF (QX(J) <= 15) QXX = QX(J)
            END DO
            IF (QXX <= 15) THEN
              IF (YZZ(8) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(8)
              ELSE IF (YZZ(8) > 0.1) THEN
                IF (YZZ(8) <= 0.2) THEN
                  WRITE (LU7, 99998, IOSTAT = IOST) NAMX(8)
                END IF
              END IF
            END IF
            DO J = 1, 18
              ANG  = FLOAT (      50 + (10 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (180 + 30 + (6  * 180 * (J - 1)) / 18)
              ANGM = FLOAT (      10 + (2  * 180 * (J - 1)) / 18)
              CALL PLA223 (2, ANG,  PHI, RL,  2)
              CALL PLA223 (3, ANGL, PHI, RLL, 3)
              CALL PLA223 (4, ANGM, PHI, RLM, 4)
              QX3(J) = RL + RLL + RLM
            END DO
            QXX3 = 15.03
            DO J = 1, 18
              IF (QX3(J) <= 15) QXX3 = QX3(J)
            END DO
            IF (QXX3 <= 15) THEN
              IF (YZZ(11) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(11)
              ELSE IF (YZZ(11) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(11)
              ENDIF
              IF (YZZ(12) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(12)
              ELSE IF (YZZ(12) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(12)
              END IF
            ENDIF
            DO J = 1, 18
              ANG  = FLOAT (50 + 180 + (10 * 180 * (J - 1)) / 18)
              ANGL = FLOAT (30       +  (6 * 180 * (J - 1)) / 18)
              ANGM = FLOAT (10       +  (2 * 180 * (J - 1)) / 18)
              CALL PLA223 (2, ANG,  PHI, RL,  2)
              CALL PLA223 (3, ANGL, PHI, RLL, 3)
              CALL PLA223 (4, ANGM, PHI, RLM, 4)
              QX4(J) = RL + RLL + RLM
            END DO
            QXX4 = 15.03
            DO J = 1, 18
              IF (QX4(J) <= 15) QXX4 = QX4(J)
            END DO
            IF (QXX4 <= 15) THEN
              IF (YZZ(15) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(15)
              ELSE IF (YZZ(15) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(15)
              END IF
              IF (YZZ(16) <= 0.1) THEN
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(16)
              ELSE IF (YZZ(16) <= 0.2) THEN
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(16)
              ENDIF
            END IF
          ELSE
            DO I = 1, 4
              IF (YZZ(I) <= 0.2 .AND. YZZ(I) > 0.1) THEN
                CALL PLA262 (3)
                WRITE (LU7, 99998, IOSTAT = IOST) NAMX(I)
              END IF
              IF (YZZ(I) <= 0.1) THEN
                CALL PLA262 (3)
                WRITE (LU7, 99999, IOSTAT = IOST) NAMX(I)
              END IF
            END DO
          END IF
        END IF
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (/, ':: Note: This is a ', A, '-Form', /)
99998 FORMAT (/, ':: Note: This is Very Similar to a ', A,'-Form', /)
      END SUBROUTINE PLA221
 
      SUBROUTINE PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
C * CONPUC (5) - THIS FINDS THE COEFFICIENTS IN THE LINEAR EXPRESSION
      USE conpuc
      IMPLICIT NONE
      INTEGER              :: M
      INTEGER              :: N
      INTEGER              :: NR
      INTEGER              :: LU7
      INTEGER              :: IOST
      REAL                 :: V
      REAL                 :: VV
      REAL                 :: PI
      REAL                 :: TOTL
      REAL                 :: FACT
      REAL, DIMENSION(NP5) :: Q
      REAL, DIMENSION(20)  :: A
      REAL, DIMENSION(20)  :: B
      REAL, DIMENSION(20)  :: W
      REAL, DIMENSION(NP5) :: PHI
      REAL, DIMENSION(20)  :: RHI
      REAL, DIMENSION(50)  :: KMIN
      REAL, DIMENSION(50)  :: LMIN
C * THE EQUATIONS IN THE LINEAR COMBINATION ARE NOW SOLVED
      PI   = 4 * ATAN2 (1.0, 1.0)
      FACT = PI / 180.0
      DO M = 2, N
        A(M) = ((KMIN(M) * PI) / (2 * NR))
        B(M) = ((LMIN(M) * PI) / (2 * NR))
        W(M) = (SIN (A(M))) * (COS (B(M))) - (COS (A(M))) * (SIN (B(M)))
C * THE COEFFICIENTS IN THE EXPRESSION ARE NOW SOLVED
        IF (W(M) /= 0.0) THEN
          RHI(M) = PHI(M) * FACT
            XA(M)  = (1 / W(M)) * ((-Q(M)) * (COS(RHI(M))) * (SIN(B(M)))
     1             + Q(M) * (SIN (RHI(M))) * (COS (B(M))))
            XB(M)  = (1 / W(M)) * (Q(M) * (COS(RHI(M))) * (SIN(A(M)))
     1             - Q(M) * (SIN(RHI(M))) * (COS(A(M))))
        ELSE
          WRITE (LU7, 99996, IOSTAT = IOST)
          GO TO 10
        END IF
      END DO
C * THIS NORMALISES COEFFICIENTS AND WRITES THEM TO FILE
      TOTL = 0.0
      VV   = 0.0
      DO M = 2, N
        TOTL = TOTL + XA(M) + XB(M)
      END DO
      TOTL = TOTL + V
      IF (TOTL /= 0.0) THEN
        CALL PLA262 (2 * N + 4)
        WRITE (LU7, 99999, IOSTAT = IOST)
        DO M = 2, N
          XXA(M) = XA(M) / TOTL
          XXB(M) = XB(M) / TOTL
          WRITE (LU7, 99998, IOSTAT = IOST) M, XA(M), XXA(M), KMIN(M)
          WRITE (LU7, 99997, IOSTAT = IOST)    XB(M), XXB(M), LMIN(M)
        END DO
        VV = V / TOTL
      END IF
      IF (IOST /= 0) RETURN
   10 RETURN
99999 FORMAT (11X, 'Coefficients of Primitive and Normalised Forms',
     1      /, 11X, 'M      Primitive  Coefficient ',
     2          'Angular Value ', /, 11X, 43('-'))
99998 FORMAT ('CosForm',  3X, I2, 8X, F5.3, 8X, F5.3, 8X, F4.1)
99997 FORMAT ('SinForm', 13X,         F5.3, 8X, F5.3, 8X, F4.1)
99996 FORMAT ('Special Case: No CosForm/SinForm Reported')
      END SUBROUTINE PLA222
 
      SUBROUTINE PLA223 (MODE, ANG, PHI, RL, N)
C * CONPUC (6)
      USE conpuc
      IMPLICIT NONE
      INTEGER              :: MODE
      INTEGER              :: N
      REAL                 :: RL
      REAL                 :: ANG
      REAL, DIMENSION(NP5) :: PHI
      IF (MODE == 1) THEN
        RL   = ABS (PHI(2) - ANG)
        IF (ANG >= 360 .AND. ANG < 720)
     1      RL = ABS (PHI(N) + 360 - ANG)
        IF (ANG >= 720) RL = ABS (PHI(N) + 720 - ANG)
      ELSE IF (MODE == 2) THEN
        RL   = ABS (PHI(N) - ANG)
        IF (ANG >=  360 .AND. ANG <  720)
     1      RL = ABS (PHI(N) +  360 - ANG)
        IF (ANG >=  720 .AND. ANG < 1080)
     1      RL = ABS (PHI(N) +  720 - ANG)
        IF (ANG >= 1080 .AND. ANG < 1440)
     1      RL = ABS (PHI(N) + 1080 - ANG)
        IF (ANG >= 1440 .AND. ANG < 1800)
     1      RL = ABS (PHI(N) + 1440 - ANG)
        IF (ANG >= 1800) RL = ABS (PHI(N) + 1800 - ANG)
      ELSE IF (MODE == 3) THEN
        RL = ABS (PHI(N) - ANG)
        IF (ANG >=  360 .AND. ANG <  720)
     1      RL = ABS (PHI(N) + 360 - ANG)
        IF (ANG >=  720 .AND. ANG < 1080)
     1      RL = ABS (PHI(N) + 720 - ANG)
        IF (ANG >= 1080) RL = ABS (PHI(N) + 1080 - ANG)
      ELSE IF (MODE == 4) THEN
        RL = ABS (PHI(N) - ANG)
        IF (ANG >= 360) RL = ABS (PHI(N) + 360 - ANG)
      END IF
      RETURN
      END SUBROUTINE PLA223
 
      SUBROUTINE PLA224 (N, XKK, KM, NR, PHI)
C * CINPUC (7) - THIS SUBROUTINE FINDS THE PHI VALUES OF THE PRIMITIVE FORMS
C * CLOSEST TO THE RING
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: N
      INTEGER             :: NR
      REAL                :: Y
      REAL                :: YM
      REAL                :: KM
      REAL                :: PHI
      REAL, DIMENSION(50) :: XKK
      YM = 380
      DO I = 1, N
        Y = ABS (((XKK(I) * 180) / (2 * NR)) - PHI)
        IF (Y < YM) THEN
          YM = Y
          KM = XKK(I)
        END IF
      END DO
      RETURN
      END SUBROUTINE PLA224
 
      SUBROUTINE PLA225 (M, KMIN, LMIN, PHI, NR, N, N0)
C * CONPUC (8)
      USE conpuc
      IMPLICIT NONE
      INTEGER              :: I
      INTEGER              :: M
      INTEGER              :: N
      INTEGER              :: NR
      INTEGER              :: N0
      REAL, DIMENSION(50)  :: XK
      REAL, DIMENSION(50)  :: XL
      REAL, DIMENSION(50)  :: KMIN
      REAL, DIMENSION(50)  :: LMIN
      REAL, DIMENSION(NP5) :: PHI
      DO I = 1, N
        XK(I) = N0 * (I - 1)
        XL(I) = FLOAT (N0 * (I - 1) + N0 / 2)
      END DO
      CALL PLA224 (N, XK, KMIN(M), NR, PHI(M))
      CALL PLA224 (N, XL, LMIN(M), NR, PHI(M))
      RETURN
      END SUBROUTINE PLA225
 
      SUBROUTINE PLA226 (MTYPE, ANGLE)
C * ORIENTATION PARAMETERS
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: K
      INTEGER :: L
      INTEGER :: IDET
      INTEGER :: IROTX
      INTEGER :: IROTY
      INTEGER :: IROTZ
      INTEGER :: MTYPE
      REAL    :: YANK
      REAL    :: ANGLE
      IPR(201) = 0
      IGBL(67) = 1
C * GENERATE UNIT MATRIX (DET = 1.0)
      IF (MTYPE >= 0) CALL GEN021 (RMAT, 1.0)
      IF (MTYPE /= 0 .AND. IABS (MTYPE) <= 3) THEN
        CALL GEN051 (0, RMAT, ANGLE, IABS (MTYPE))
      ELSE IF (MTYPE == -4) THEN
        DO L = 1, 3
          DO K = 1, 3
            RMAT(L, K) = - RMAT(L, K)
          END DO
        END DO
      END IF
      CALL GEN005 (RMAT, DUMV)
C * RECOVER NEW ORIENTATION PARAMETERS (XROT, YROT, ZROT, IDET)
      CALL GEN096 (DUMV, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM)
      WRITE (LU6, 99999, IOSTAT = IOST) IROTX, IROTY, IROTZ, IDET
      RGBL(28) = IROTX
      RGBL(29) = IROTY
      RGBL(30) = IROTZ
      IGBL(87) = IDET
      IPR(330) = (1 - IDET) / 2
      RETURN
99999 FORMAT (':: NEW Xrot, Yrot, Zrot =', 3I5, ', Idet =', I2)
      END SUBROUTINE PLA226
 
      SUBROUTINE PLA227 (IAT, JAT, V)
C * CALCULATE THE UNIT VECTOR ALONG IAT TO JAT
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: K
      INTEGER            :: IAT
      INTEGER            :: JAT
      REAL               :: D
      REAL               :: GEN017
      REAL, DIMENSION(*) :: V
      DO K = 1, 3
        V(K) = XXO(JAT, K + 3) - XXO(IAT, K + 3)
      END DO
C * NORMALIZE
      D = GEN017 (V)
C * DUMMY STATEMENT
      D = D + 0.0
      RETURN
      END SUBROUTINE PLA227
 
      SUBROUTINE PLA228
C * AUTO-RENUMBER
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: M
      INTEGER :: N
      INTEGER :: N1
      INTEGER :: N2
      INTEGER :: M1
      INTEGER :: NC
      INTEGER :: NUM
      INTEGER :: NAT
      INTEGER :: NBUT
      INTEGER :: IVAL
C * IMPLEMENT AUTO-RENUM
      IPR(759) = 0
      NAT      = IPR(37)
      CALL GEN097 (IENLB, 1, NP10, 0)
C * INIT FLAGS
      DO I = 1, NAT
        CALL GEN048 (2, IFG(1, I), 1, 0)
      END DO
   10 N   = 0
      M   = 0
      NUM = 0
      DO I = 1, NAT
C * TEST FOR 'COMPLETELY DONE BIT # 2' TO START NEW RESIDUE
        CALL GEN048 (-1, IFG(1, I), 2, IVAL)
        IF (IVAL == 0) THEN
          CALL GEN048 (-1, IFG(1, I), 1, IVAL)
          IF (IVAL == 0) THEN
            CALL GEN048 (-10, IFG(2, I), 14, NBUT)
            IF (NBUT > M) THEN
              M = NBUT
              N = I
            END IF
          END IF
        END IF
      END DO
C * NEW STARTING POINT
      IF (N > 0) THEN
        CALL PLA229 (NUM, N, N2)
   20   NC = - NINT (CON(N, 9))
        IF (NC < 0) NC = 9
        N1 = 0
        M1 = 0
        DO J = 1, NC
          K = NINT (CON(N, J))
C * TEST FOR 'NOT-WORKING-ON-YET'
          CALL GEN048 (-1, IFG(1, K), 1, IVAL)
          IF (IVAL == 0) THEN
            CALL GEN048 (-10, IFG(2, K), 14, NBUT)
            IF (NBUT > M1) THEN
              M1 = NBUT
              N1 = K
            END IF
          END IF
        END DO
        IF (N1 > 0) THEN
          CALL PLA229 (NUM, N1, N2)
C * REDEFINE 'VIEWING-POINT'
          N   = N1
          GO TO 20
        ELSE
C * SET 'DONE'
          CALL GEN048 (1, IFG(1, N), 2, 1)
          N2 = N2 - 1
          IF (N2 > 0) THEN
            N = JR(N2)
            GO TO 20
          END IF
          GO TO 10
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA228
 
      SUBROUTINE PLA229 (NUM, NR, N2)
C * RENUMBER SUPPORT
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: NR
      INTEGER          :: N2
      INTEGER          :: K0
      INTEGER          :: NO
      INTEGER          :: NUM
      INTEGER          :: IDUM
      INTEGER          :: IENR
      INTEGER          :: NUM0
      CHARACTER(len=2) :: NQ
      NUM     = NUM + 1
      N2      = NUM
      JR(NUM) = NR
C * SET 'WORKING-ON'
      CALL GEN048 ( 1, IFG(1, NR), 1, 1)
C * GET ELEMENT # IN IEN
      CALL GEN048 (-4, IFG(1, NR), 15, NO)
      NO        = NO + 1
      NQ        = LMT(NO, 1)
      IENLB(NO) = IENLB(NO) + 1
      NUM0      = IENLB(NO)
      IF (NQ(1:1) == ' ') THEN
        NQ2 = NQ(2:2)
        K0  = 2
      ELSE
        NQ2 = NQ
        K0  = 3
      END IF
      IF (NUM0 < 10) THEN
        WRITE(NQ2(K0:), 99999, IOSTAT = IOST) NUM0
      ELSE IF (NUM0 < 100) THEN
        WRITE(NQ2(K0:), 99998, IOSTAT = IOST) NUM0
      ELSE IF (NUM0 < 1000) THEN
        WRITE(NQ2(K0:), 99997, IOSTAT = IOST) NUM0
      ELSE
        WRITE(NQ2(K0:), 99996, IOSTAT = IOST) NUM0
      END IF
      IF (IOST == 0) THEN
        CALL PLA047 (LABA(NR), NQ1, IDUM, IENR, IGBL(55), IPR(71),
     1    0, 0)
        CALL PLA282 (1, NQ2, NQ1, LU6)
      END IF
      RETURN
99999 FORMAT (I1, 1X)
99998 FORMAT (I2, 1X)
99997 FORMAT (I3, 1X)
99996 FORMAT (I4, 1X)
      END SUBROUTINE PLA229
 
      SUBROUTINE PLA230 (MODE)
C * IUCr checkCIF ROUTINE
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE mentry
      USE cggt
      USE cif
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: LU
      INTEGER          :: LUX
      INTEGER          :: NEXP
      INTEGER          :: JUNK
      INTEGER          :: MODE
      INTEGER          :: NAENTRY
      INTEGER          :: IVALTYPE
      CHARACTER(len=4) :: CHK
      JUNK = 0
C * LU   - CHECK-OUTPUT LISTFILE (LU7 OR LU10)
C * LU12 - check.def
C * LU14 - Summary Listing
C * LU68 - scratch check-output
C * MODE = 0 - REPORT ALERTS
C * MODE = 1 - SUMMARY
      IF (MODE == 0) THEN
C * CHECK FOR/CREATE check.def (CIF-Validation)
        IF (IGBL(12) == 0) THEN
          OPEN (UNIT = LU12, FILE = 'check.def', FORM = 'FORMATTED',
     1      STATUS = 'OLD', IOSTAT = IOST)
          IF (IOST == 0) THEN
            REWIND (UNIT = LU12, IOSTAT = IOST)
C * CHECK check.def VERSION: CREATE UPDATED VERSION FROM MEMORY
            READ (LU12, 99982, IOSTAT = IOST) LINE
            IF (IOST == 0) THEN
              IF (LINE(1:1) == '!') THEN
                READ (LINE(19:25), *) IGBL(21)
                IF (IGBL(20) > IGBL(21)) THEN
                  CLOSE (UNIT = LU12, STATUS = 'DELETE', IOSTAT = IOST)
C * UNPACK/CREATE check.def version from source embedded data
                  CALL CHECK (1, JUNK)
                  IGBL(21) = IGBL(20)
                END IF
              END IF
            END IF
          ELSE
C * UNPACK/CREATE check.def version from source embedded data
            CALL CHECK (1, JUNK)
            IGBL(21) = IGBL(20)
          END IF
          IGBL(12) = 1
        END IF
C * LAST MINUTE CHECKS/ALERTS
        CALL PLA232
C * INITIALIZE
C * SET MENU #
        IGBL(6) = 10
        V1(1)   = - 1000.0
        CALL GEN097 (NALV,   1, 5, 0)
        CALL GEN097 (IATYPE, 1, 5, 0)
        CALL GEN097 (ICOUNT, 1, 4, 0)
        CALL GEN097 (JCOUNT, 1, 4, 0)
        CALL GEN097 (KCOUNT, 1, 4, 0)
C * ENDFILE/REWIND
        CALL GEN108 (LU68, 1)
C * TEST CHECK MODE AND SET OUTPUT UNIT
        IF (IGBL(36) > 0) THEN
          LU = LU10
        ELSE
          LU = LU7
          PAGET = 'CHECKCIF'
          CALL PLA262 (0)
          CALL PLA262 (20)
        END IF
C * CHECK FOR ACTA/CHEM CHECKCIF
        IF (IGBL(132) == 1) THEN
          TTYPE = 'I'
          VTYPE = 'Chem'
        ELSE
          TTYPE = ' '
          VTYPE = 'Acta'
        END IF
C * CREATE TO REVIEW PAGE
        CALL PLA237 (LU)
C * REPORT ALERTS
        CALL PLA231 (LU)
C * REMOVE SOME LEFT OVER FILES
        OPEN (UNIT = LU24, FILE = NAMEFIL(1:KNMFIL)//'_sx.ins',
     1    STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST == 0) CLOSE (UNIT = LU24, STATUS = 'DELETE')
        OPEN (UNIT = LU25, FILE = NAMEFIL(1:KNMFIL)//'_sx.hkl',
     1    STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST == 0) CLOSE (UNIT = LU25, STATUS = 'DELETE')
        OPEN (UNIT = LU26, FILE = NAMEFIL(1:KNMFIL)//'_sx.fab',
     1    STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST == 0) CLOSE (UNIT = LU26, STATUS = 'DELETE')
        OPEN (UNIT = LU28, FILE = NAMEFIL(1:KNMFIL)//'_sx.fcf',
     1    STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST == 0) CLOSE (UNIT = LU28, STATUS = 'DELETE')
C * REPORT RESULTS
        IF (IGBL(36) <= 0) CALL PLA262 (1)
        WRITE (LU, 99988, IOSTAT = IOST)
C * SEND OUT CONGRATULATIONS FOR NO (A,B,C) TYPE ALERTS
        IF (NALV(1) + NALV(2) + NALV(3) == 0) THEN
          IF (IGBL(140) == 0) THEN
            IF (NALV(4) == 0) THEN
              WRITE (LU, 99995, IOSTAT = IOST)
            ELSE
              WRITE (LU, 99998, IOSTAT = IOST)
            ENDIF
          END IF
        ELSE
          IF (IGBL(36) <= 0) CALL PLA262 (5)
          WRITE (LU, 99994, IOSTAT = IOST)
          DO I = 1, 4
            IF (NALV(I) > 0) THEN
              IF (IGBL(36) <= 0) CALL PLA262 (1)
              WRITE (LU, 99993, IOSTAT = IOST) NALV(I), ALEVEL(I)
            END IF
          END DO
          WRITE (LU, 99981, IOSTAT = IOST)
          DO I = 1, 5
            IF (IATYPE(I) > 0) THEN
              IF (IGBL(36) <= 0) CALL PLA262 (1)
              WRITE (LU, 99996, IOSTAT = IOST) IATYPE(I), I, ATYPE(I)
            END IF
          END DO
C * REPORT PERCENTAGE SATISFIED TESTS (NON-CSD ONLY)
          IF (IGBL(94) == 0) THEN
            DO I = 1, 4
              KCOUNT(I) =
     1          NINT (100.0 * (JCOUNT(I) - ICOUNT(I)) / JCOUNT(I))
            END DO
            WRITE (LU, 99988, IOSTAT = IOST)
            WRITE (LU, 99999, IOSTAT = IOST)
     1        (ICOUNT(I), JCOUNT(I), KCOUNT(I), I = 1, 4)
          END IF
        END IF
        IF (IGBL(36) <= 0) CALL PLA262 (1)
        WRITE (LU, 99989, IOSTAT = IOST)
        IF (LU == LU10) THEN
          IF (IGBL(25) * IGBL(32) == 1) THEN
            WRITE (BCD, 99983, IOSTAT = IOST)
     1        JID(1:9), (NALV(I), I = 1, 4), CHAR (0)
            CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 80.0, 112)
C * FLUSH
            CALL GGIP (0.0, 0.0, 0.0, 6)
          END IF
          IGBL(53) = IGBL(53) + 1
          IF (IGBL(53) <= NP65) THEN
            JENTRY(IGBL(53))     = IGBL(54)
            BNDTP(IGBL(53)  + 1) = BNDTP(1)
            DO K = 1, 5
              NALV(IGBL(53) * 5 + K) = NALV(K)
            END DO
          END IF
        END IF
C * SUMMARY MODE
      ELSE IF (MODE == 1) THEN
C * ALERT SUMMARY FOR TEXT WINDOW
        NAENTRY = MIN (NP65, IGBL(53))
        DO J = 1, NAENTRY
          WRITE (LU6, 99992, IOSTAT = IOST)
     1      POISSON(J), JENTRY(J), (NALV(J * 5 + I), I = 1, 4),
     2      BNDTP(J + 1), NALV(J * 5 + 5) / 10000.0
        END DO
        IF (IGBL(53) > NP65)
     1    WRITE (LU6, 99997, IOSTAT = IOST) IGBL(53)
C * VALIDATION-DOC (COMMENT/HINTS) (IGBL(83) /= 0
        IF (IGBL(83) /= 0) THEN
          IF (IGBL(83) == -1) THEN
            LUX = 6
          ELSE
            LUX = LU10
          END IF
          REWIND (UNIT = LU12, IOSTAT = IOST)
          NEXP = 0
C * ALERT MESSAGE DOC LOOP
          DO 10 I = 2, 999
            IF (NDOC(I) > 0) THEN
              NEXP = NEXP + 1
C * HEADER
              IF (NEXP == 1) WRITE (LUX, 99991, IOSTAT = IOST)
C * MAKE SURE CHK WITH 3 NUMERICAL CHARACTERS
              IF (I < 10) THEN
                WRITE (CHK, 99984, IOSTAT = IOST) I
              ELSE IF (I < 100) THEN
                WRITE (CHK, 99985, IOSTAT = IOST) I
              ELSE
                WRITE (CHK, 99986, IOSTAT = IOST) I
              END IF
C * READ Check.def
              DO
                READ (LU12, 99982, IOSTAT = IOST) ICL(1:80)
                IF (IOST == 0) THEN
                  IF (ICL(1:4) == CHK) THEN
                    READ (ICL(20:21), 99987) IVALTYPE
                    READ (LU12, 99982) ICL(1:80)
                    READ (LU12, 99982) ICL(1:80)
                    IF (ICL(1:1) == '#') GO TO 10
                    IF (ICL(1:2) == '  ') THEN
                      WRITE (LUX, 99990, IOSTAT = IOST)
     1                  CHK, IVALTYPE, ATYPE(IVALTYPE)
C * COPY ALERT TEXT
                      DO
                        READ (LU12, 99982, IOSTAT = IOST) ICL(1:80)
                        IF (IOST == 0) THEN
                          IF (ICL(1:1) == '#') THEN
                            WRITE (LUX, 99981, IOSTAT = IOST)
                            GO TO 10
                          END IF
                          WRITE (LUX, 99982, IOSTAT = IOST) ICL(1:80)
                        ELSE
                          CALL GEN108 (LU68, 0)
                          RETURN
                        END IF
                      END DO
                    END IF
                  END IF
                ELSE
                  CALL GEN108 (LU68, 0)
                  RETURN
                END IF
              END DO
            END IF
   10     CONTINUE
C * END ALERT MESSAGE DOC LOOP
        END IF
        RETURN
      END IF
C * END MODE = 0/1
      CALL GEN108 (LU68, 0)
      RETURN
99999 FORMAT (/, I4, 1X, 'Missing  Experimental  Info Issue(s)',
     1        1X, '(Out of', I4, 1X, 'Tests) -', I5, ' % Satisfied',
     2        /, I4, 1X, 'Experimental  Data  Related Issue(s)',
     3        1X, '(Out of', I4, 1X, 'Tests) -', I5, ' % Satisfied',
     4        /, I4, 1X, 'Structural  Model   Related Issue(s)',
     5        1X, '(Out of', I4, 1X, 'Tests) -', I5, ' % Satisfied',
     6        /, I4, 1X, 'Unresolved or to be Checked Issue(s)',
     7        1X, '(Out of', I4, 1X, 'Tests) -', I5, ' % Satisfied', /)
99998 FORMAT (/, '#', 79('='), /, '! Congratulations ! :', 1X,
     1           'No (A,B,C) ALERT Conditions were Detected - ',
     2           'Check G-ALERTS')
99997 FORMAT (/, 24X, 'etc..    (', I5, ' Entries Total)')
99996 FORMAT (I3, 1X, 'ALERT_Type_', I1, 1X, A)
99995 FORMAT (/, '#', 79('='), /, '! Congratulations ! :', 1X,
     1           'No (A,B,C,G) ALERT Conditions were Detected')
99994 FORMAT ('#', 78X, '*', /, '#', 79('='), /, 15X,
     1        'ALERT_Level and ALERT_Type Summary', /, 15X, 34('='))
99993 FORMAT (I3, ' ALERT_Level_', A)
99992 FORMAT (3X, A, 3X, 'Entry #', I3, ' - ', I3, 'A,', I3, 'B,',
     1        I3, 'C,', I3, 'G-Alerts, BP ', A, ' =', F7.4)
99991 FORMAT (/, 'Explanation and Advice for the Reported ALERTS',
     1        /, 80('='), /)
99990 FORMAT (80('='), /, 'ALERT', A, ' Type_', I1, 1X, A, /, 80('='))
99989 FORMAT ('#', 78X, '*')
99988 FORMAT ('#', 79('='))
99987 FORMAT (I2)
99986 FORMAT ('_'  , I3)
99985 FORMAT ('_0' , I2)
99984 FORMAT ('_00', I1)
99983 FORMAT ('Entry ', A, ' - ', I3, 'A,', I3, 'B,',
     1        I3, 'C,', I3, 'G-Alerts', 34X, A)
99982 FORMAT (A)
99981 FORMAT (1X)
      END SUBROUTINE PLA230
 
      SUBROUTINE PLA231 (LU)
C * REPORT ALERTS
      USE files
      USE parameters
      USE cchar
      USE plato
      USE cif
 
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: LU
      INTEGER            :: LM
      INTEGER            :: NB
      INTEGER            :: NE
      INTEGER            :: NAL
      INTEGER            :: ICHK
      INTEGER            :: IDOC
      INTEGER            :: ISA1
      INTEGER            :: ISKP
      INTEGER            :: IVAR
      INTEGER            :: NDEC
      INTEGER            :: NDECM
      INTEGER            :: NDECX
      INTEGER            :: NDECY
      INTEGER            :: ITYPE
      INTEGER            :: NALERT
      INTEGER            :: NALOLD
      REAL               :: A1
      REAL               :: SA1
      REAL               :: VALUEX
      REAL               :: VALUE1
      REAL, DIMENSION(4) :: V1820
      CHARACTER(len=80)  :: L12
      CHARACTER(len=80)  :: L68
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=2)   :: CNT
      CHARACTER(len=4)   :: CHK
      CHARACTER(len=66)  :: MESS
      CHARACTER(len=1)   :: TYPEX
      CHARACTER(len=1)   :: OTYPE
      CHARACTER(len=18)  :: FORMX = '(F8.5,''('',I2,'') '')'
      CHARACTER(len=7)   :: FORMV = '(F10.0)'
      CHARACTER(len=1)   :: TYPE820
      CHARACTER(len=66)  :: MESS820
      CHARACTER(len=1)   :: CTYPE820
      CHARACTER(len=1)   :: OTYPE820
      NALOLD = 0
      NALERT = 0
C * LOOP OVER THE ALERT LEVELS (1 = A, 2 = B, 3 = C, 4 = G
      DO 40 NAL = 1, 4
        CALL GEN108 (LU12, 0)
C * LOOP OVER CheckCIF TESTS ON LU12 (check.def)
        DO
          READ (LU12, 99986, IOSTAT = IOST) L12
          IF (IOST /= 0) RETURN
C * SKIP LINES WITH A BLANK IN COLUMN ONE
          IF (L12(1:1) == CHAR (32)) CYCLE
          IF (L12(1:1) == '!') CYCLE
C * DETECT END-OF-FILE (check.def)
          IF (L12(1:1) /= '$') THEN
            IF (L12(1:1) == '#') THEN
              IF (L12(3:5) == '>>>') THEN
                READ (L12(2:2), 99989, IOSTAT = IOST) ISKP
              END IF
              CYCLE
            END IF
C * TEST CRITERIA ETC. RECORD
            READ (L12, 99998, IOSTAT = IOST) CHK, (V1(L), L = 2, 4),
     1        TYPEX, CTYPE, OTYPE, (KCOUNT(L), L = 1, 4)
            IF (IOST /= 0) RETURN
C * GET ALERT NUMBER
            READ (CHK, 99990, IOSTAT = IOST) ICHK
            IF (IOST /= 0) RETURN
            IF (NAL == 1) THEN
C * SAVE ALERT _820 INFO (PLATON READ PROBLEMS)
              IF (ICHK == 820) THEN
                READ (L12, 99998, IOSTAT = IOST)
     1            CHK, (V1820(L), L = 2, 4), TYPE820, CTYPE820,
     2            OTYPE820, (KCOUNT(L), L = 1, 4)
                IF (IOST /= 0) RETURN
                READ (CHK, 99990, IOSTAT = IOST) ICHK
              END IF
              DO L = 1, 4
                JCOUNT(L) = JCOUNT(L) + KCOUNT(L)
              END DO
            END IF
            IF (CTYPE == TTYPE .OR. (OTYPE == 'O' .AND.
     1        IGBL(134) == 1)) THEN
C * SKIP TO NEW ALERT ENTRY
              READ (LU12, 99986, IOSTAT = IOST) L12(1:80)
              IF (IOST /= 0) GO TO 40
              CYCLE
            END IF
            READ (TYPEX, 99989) ITYPE
            READ (LU12,  99986, IOSTAT = IOST) MESS
            IF (IOST /= 0) GO TO 40
C * SAVE 820 INFO RECORD
            IF (NAL == 1 .AND. ICHK == 820) MESS820 = MESS
            READ (CHK, 99990, IOSTAT = IOST) ICHK
            IF (IOST /= 0) RETURN
C * HANDLE 'CIF-ONLY ALERTS'
            IF (ISKP == 1 .AND. IABS (IGBL(8)) /= 3) CYCLE
C * TEST FOR (IN)COMMENSURATE STRUCTURE CIF
            IF (IGBL(140) == 1 .AND. ICHK /= 814) GO TO 30
C * TEST FOR IGNORE SETTINGS FOR LAUE
            IF (IPR(106) == 1) THEN
              SELECT CASE (ICHK)
                CASE (29, 50, 91, 195, 196)
C * GO TO NEXT TEST ON LU12
                  GO TO 30
                CASE (910, 911, 920, 921)
C * GO TO NEXT TEST ON LU12
                  GO TO 30
              CASE (940)
C * GO TO NEXT TEST ON LU12
                  GO TO 30
                CASE (950, 951, 952)
C * GO TO NEXT TEST ON LU12
                  GO TO 30
                CASE (971, 972, 975, 976)
C * GO TO NEXT TEST ON LU12
                  GO TO 30
              END SELECT
            END IF
C * READ ALERTS ON LU68 - REWIND LU68
            CALL GEN108 (LU68, 0)
C * LOOP TROUGH THE FILE WITH ALERT DATA TO BE REPORTED IN THE .chk FILE
            DO
              READ (LU68, 99986, IOSTAT = IOST) L68
              IF (IOST /= 0) THEN
                IF (IOST == -1) THEN
C * READ NEXT TEST FROM LU12
                  GO TO 30
                ELSE
                  GO TO 10
                END IF
              ELSE
                GO TO 20
              END IF
   10         IF (NAL == 4) THEN
                WRITE (6, 99995, IOSTAT = IOST) L68(1:77)
C * CREATE PSEUDO ALERT _820
                WRITE (L68, 99997, IOSTAT = IOST) L68(1:4)
                CHK   = '_820'
                ICHK  = 820
                MESS  = MESS820
                TYPEX = TYPE820
                CTYPE = CTYPE820
                OTYPE = OTYPE820
                DO K = 2, 4
                  V1(K) = V1820(K)
                END DO
              ELSE
                CYCLE
              END IF
C * CHECK FOR IDENTICAL ALERT AND TEST ID'S
   20         IF (L68(1:4) == CHK) THEN
C * FILTER ALERTS
C * IGNORE ALERT FOR INTRA POLYMER
                IF (ICHK == 790 .OR. ICHK == 791 .OR.
     1            ICHK == 792 .OR. ICHK == 793) THEN
                  IF (IPR(739) /= 0) CYCLE
C * IGNORE ALERT FOR HIGH COMPLETENESS
                ELSE IF (ICHK == 940) THEN
                  IF (PAR(313) > 0.989 .OR. PAR(314) > 0.989
     1            .OR. INDEX (CCIF(1), 'i>-') /= 0) CYCLE
C * IGNORE ALERTS 795,796,797 FOR MULTI RESIDUE STRUCTURES
                ELSE IF (ICHK == 795 .OR. ICHK == 796 .OR.
     1                   ICHK == 797) THEN
                  IF (IPR(75) > 1) CYCLE
                END IF
                READ (L68(5:70), 99991, IOSTAT = IOST)
     1            NDECX, VALUEX, VALUE1, NQ1, NQ2, CNT
                IF (IOST /= 0) GO TO 10
C * REMOVE () IF ANY
                IF (ICHK == 794) THEN
                  CALL GEN121 (NQ1, NP64)
                ELSE IF (ICHK /= 126 .AND. ICHK /= 127 .AND.
     1            ICHK /= 930 .AND. ICHK /= 931) THEN
                  CALL GEN121 (NQ1, NP64)
                  CALL GEN121 (NQ2, NP64)
                END IF
                NQ4 = ' '
                NB  = 1
                IF (ICHK == 126 .OR. ICHK == 127) THEN
                  NE = 10
                  CALL GEN039 (1, NQ1, 1, 10, NB, NE)
C * SHIFT CONTENT TO RIGHT
                  NQ4 (11 - NE : 10) = NQ1(1 : NE)
                ELSE
                  NE = 9
                  CALL GEN039 (1, NQ1, 1, 9, NB, NE)
C * SHIFT CONTENT TO RIGHT
                  NQ4 (10 - NE : 9) = NQ1(1 : NE)
                END IF
                IF (CNT == ' =') THEN
                  READ (LU68, 99986, IOSTAT = IOST) L68
                  IF (IOST /= 0) GO TO 10
                END IF
C * TEST VALUE AGAINST CRITERIA FROM RIGHT TO LEFT
                DO I = 1, NAL
                  IF (VALUEX > V1(5 - I))  THEN
                    IF (I >= NAL) THEN
                      IF (I /= 4 .OR. VALUEX <= -998.0) THEN
                        N = 5 - I
                        IF (NALOLD /= NAL) THEN
                          IF (IGBL(36) <= 0) CALL PLA262 (1)
                          WRITE (LU, 99993, IOSTAT = IOST)
                          NALOLD = NAL
                        END IF
                        NALV(I) = NALV(I) + 1
                        IF (ITYPE > 0 .AND. ITYPE < 6)
     1                    IATYPE(ITYPE) = IATYPE(ITYPE) + 1
                        IDM(1:14) =  CHK(2:4)//'_ALERT_'//TYPEX//'_'//
     1                    WLEVEL(N)//' '
                        IVAR = 0
                        L    = 14
                        DO K = 1, 66
                          ICH = MESS(K:K)
C * CHECK FOR SUBSTITUTIONS $I, $F, $A, $B
                          IF (IVAR == 0) THEN
                            IF (ICH == '$') THEN
                              IVAR = 1
                            ELSE
                              IF (L < 80) THEN
                                L = L + 1
                                IDM(L:L) = ICH
                              END IF
                            END IF
                          ELSE
C * $A STRING INSERT
                            IF (ICH == 'A') THEN
                              IF (L > 52 .AND. NQ2(1:9) ==
     1                          '         ' .OR. NQ2(9:9) == 'A' .AND.
     2                          NQ1(1:3) /= 'sp?') THEN
                                IF (IDM(1:3) == '126' .OR.
     1                            IDM(1:3) == '127') THEN
                                  IDM(L + 1:L + 10) = NQ4(1:10)
                                  L                 = L + 10
                                ELSE
                                  IDM(L + 1:L + 9) = NQ4(1:9)
                                  L                = L + 9
                                END IF
                              ELSE
                                IDM(L + 1:L + 9) = NQ1(1:9)
                                L                = L + 9
                              END IF
C * $B STRING INSERT
                            ELSE IF (ICH == 'B') THEN
                              LM = 9
                              IF (ICHK == 899) LM = 10
                              DO J = 1, LM
                                IF (L < 80) THEN
                                  L        = L + 1
                                  IDM(L:L) = NQ2(J:J)
                                END IF
                              END DO
C * $I INTEGER INSERT
                            ELSE IF (ICH == 'I') THEN
                              WRITE (IDM(L + 1:L + 10), 99987,
     1                        IOSTAT = IOST) NINT (VALUE1)
                              L = L + 10
C * $F REAL INSERT
                            ELSE IF (ICH == 'F') THEN
                              NDECY = 10
                              IF (NDECX > 9) THEN
                                NDECY = NDECX / 10
                                NDECX = MOD (NDECX, 10)
                              END IF
                              IF (NDECY == 10) THEN
                                WRITE (FORMV(2:6), 99994) NDECX
                              ELSE
                                WRITE (FORMV(2:6), 99996) NDECY, NDECX
                              END IF
                              WRITE (IDM(L + 1:L + NDECY), FORMV,
     1                          IOSTAT = IOST) VALUE1
                              L = L + NDECY
                            ELSE IF (ICH == 'X' .OR. ICH == 'Y') THEN
                              IF    (ICHK == 701 .OR. ICHK == 704
     1                          .OR. ICHK == 705 .OR. ICHK == 706
     2                          .OR. ICHK == 707 .OR. ICHK == 721
     3                          .OR. ICHK == 724 .OR. ICHK == 725
     4                          .OR. ICHK == 726 .OR. ICHK == 727
     5                          .OR. ICHK == 731 .OR. ICHK == 734
     6                          .OR. ICHK == 735 .OR. ICHK == 736
     7                          .OR. ICHK == 737 .OR. ICHK == 741
     8                          .OR. ICHK == 744 .OR. ICHK == 745
     9                          .OR. ICHK == 746 .OR. ICHK == 747
     *                          .OR. ICHK == 751 .OR. ICHK == 754
     1                          .OR. ICHK == 755 .OR. ICHK == 756
     2                          .OR. ICHK == 757) THEN
                                 NDECM = 5
                               ELSE IF (ICHK == 702
     1                          .OR.   ICHK == 708 .OR. ICHK == 722
     2                          .OR.   ICHK == 728 .OR. ICHK == 732
     3                          .OR.   ICHK == 738 .OR. ICHK == 742
     4                          .OR.   ICHK == 748 .OR. ICHK == 752
     5                          .OR.   ICHK == 758) THEN
                                NDECM = 2
                              ELSE IF (ICHK == 703
     1                          .OR.   ICHK == 723 .OR. ICHK == 733
     2                          .OR.   ICHK == 743 .OR. ICHK == 753)
     3                          THEN
                                NDECM = 2
                              END IF
                              IF (ICH == 'Y') THEN
                                READ (L68, 99988, IOSTAT = IOST) A1, SA1
                                IF (IOST /= 0) GO TO 10
                                IF (ICHK == 733) SA1 = MIN (99.4, SA1)
                                CALL GEN038 (L68, 1, 14)
                              ELSE
                                READ (NQ1, 99988, IOSTAT = IOST) A1
                                IF (IOST /= 0) GO TO 10
                                READ (NQ2, 99988, IOSTAT = IOST) SA1
                                IF (IOST /= 0) GO TO 10
                              END IF
                              CALL GEN041 (A1, SA1, ISA1, NDECM,
     1                          NDEC, 2)
                              FORMX(5:5) = CHAR (ICHAR ('0') + NDEC)
                              WRITE (PRBUF, FORMX, IOSTAT = IOST) A1,
     1                          ISA1
                              CALL GEN065 (0, PRBUF, 1, 13, 1)
                              IDM(L + 1:L + 12) = PRBUF(1:12)
                              L = L + 12
                            END IF
                            IVAR = 0
                          END IF
                        END DO
                        NALERT = NALERT + 1
                        IF (NALERT == 1) THEN
                          IF (IGBL(36) <= 0) CALL PLA262 (3)
                          WRITE (LU, 99992, IOSTAT = IOST) VTYPE
                          IF (IGBL(36) <= 0) CALL PLA262 (2)
                          WRITE (LU, 99999, IOSTAT = IOST)
                        END IF
                        READ (CHK, 99990, IOSTAT = IOST) IDOC
                        IF (IOST /= 0) GO TO 10
                        NDOC(IDOC) = 1
                        DO J = 1, 4
                          ICOUNT(J) = ICOUNT(J) + KCOUNT(J)
                        END DO
C * CREATE VRF RECORD
                        CALL PLA234 (LU, L, IDM, L68, CNT)
                      END IF
                    END IF
                    EXIT
                  END IF
                END DO
C * END OF CRITERIA TEST LOOP
 
              END IF
            END DO
C * END OF READ LU68 LOOP
            CYCLE
          END IF
          EXIT
   30     CONTINUE
        END DO
C * END OF LOOP OVER check.def
   40 CONTINUE
C * END OF LOOP OVER ALERT LEVELS
99999 FORMAT (5X, 'Format: alert-number_ALERT_alert-type_alert-level',
     4        ' text', /)
99998 FORMAT (A, 3F5.0, 3(1X, A), 4I2)
99997 FORMAT ('_820 2    -999.0       1.0', A)
99996 FORMAT ('F',I1,'.', I1, 1X)
99995 FORMAT (':: Read Problem in PLA231', /, ':: ' ,A, /)
99994 FORMAT ('F10.', I1)
99993 FORMAT ('#', 79('='))
99992 FORMAT ('#', 78X, '*', /, '#', 79('='), /, '#>>> ',
     1 'The Following Improvement and Query ALERTS were generated ',
     2 '- (', A, '-Mode) <<<', /, '#', 79('='))
99991 FORMAT (I2, 2F10.0, 3A)
99990 FORMAT (1X, I3)
99989 FORMAT (I1)
99988 FORMAT (2F7.0)
99987 FORMAT (I10)
99986 FORMAT (A)
      RETURN
      END SUBROUTINE PLA231
 
      SUBROUTINE PLA232
C * IUCR-CHECK  (CIF-VALIDATION) (3)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE mentry
      USE sgxyz
      USE cif
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: NERR
      REAL                  :: RR
      REAL                  :: RRP
      REAL                  :: VERS
      REAL                  :: YUNK
      REAL                  :: YUNK1
      REAL                  :: YUNK2
      REAL                  :: VERS1
      REAL                  :: TMIDMU
      REAL                  :: SIGMA
      REAL                  :: RMXMI
      REAL                  :: RATIO
      REAL                  :: DEVIA
      REAL                  :: RATIO1
      REAL, DIMENSION(7, 6) :: TABT
      CHARACTER(len=1)      :: ICH
      CHARACTER(len=1)      :: JCH
C * ADD LAST MINUTE ALERTS
      TABT = RESHAPE ((/
     1   1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,
     2   1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,
     3   1.0, 1.01, 1.04, 1.09, 1.15, 1.25, 1.4,
     4   1.0, 1.05, 1.15, 1.25, 1.5,  1.9,  2.5,
     5   1.0, 1.05, 1.15, 1.25, 1.5,  1.9,  2.5,
     6   1.0, 1.05, 1.15, 1.25, 1.5,  1.9,  2.5/), (/7, 6/))
C * AUDIT TOOL INFO
      IF (CCIF(23) == ' ?' .AND. NCIF23 > 0) THEN
        CCIF(23)(1:NCIF23) = CCIF23(1:NCIF23)
        NCIF(23)           = NCIF23
      END IF
      IF (INDEX (CCIF(23)(1:NCIF(23)), 'SHELXL-97') /= 0 .OR.
     1    INDEX (CCIF(23)(1:NCIF(23)), 'SHELXL97')  /= 0) THEN
        IF (IPR(725) /= 1) THEN
          IPR(725) = 1
C * ALERT _899
          CALL PLA236 (899, 0, -999.0, 2019.0, '   2019/3',
     1      'SHELXL-97 ')
        END IF
        XLDTP = '97'
      END IF
C * ALERT _699 - MISSING CRYSTAL DECRIPTION (NOT FOR POWDER)
      IF (INDEX(CCIF(5), '?') /= 0 .AND. IPR(105) == 0)
     1  CALL PLA236 (699, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _970 CHECK FOR ELECTRON DIFFRACTION DATA
      IF (IPR(493) == 8 .AND. IPR(761) .EQ. 0) CALL
     1  PLA236 (970, 0, -999.0, 0.0, ' ', ' ')
C * CHECK FOR .bodd
      IF (IPR(738) < 0) THEN
        INQUIRE(FILE = INCLUDEFILE, EXIST = EXST)
        IF (EXST) THEN
          IPR(738) = 1
        ELSE
          WRITE (LU6, 99999) INCLUDEFILE
        END IF
      END IF
      IF (IPR(741) > 0) THEN
        RATIO = PAR(555) / IPR(741)
        SIGMA = 0.0
        ENDFILE (UNIT = LU67, IOSTAT = IOST)
        REWIND  (UNIT = LU67, IOSTAT = IOST)
        IF (IOST == 0) THEN
          DO I = 1, IPR(741)
            READ (LU67, IOSTAT = IOST) RATIO1
            IF (IOST == 0) THEN
C * CHECK FOR UNUSUAL (CALCULATED) DATA
              SIGMA = SIGMA + (RATIO - RATIO1)**2
            END IF
          END DO
          ICH = ' '
          SIGMA = SQRT (SIGMA / IPR(741))
C * ALERT _949
          IF (ABS (1.0 - RATIO) < 0.015 .AND. SIGMA < 0.06) THEN
              CALL PLA236 (949, 0, -999.0, 1.0, ' ', ' ')
            ICH = '!'
          END IF
          IF (IGBL(53) + 1 <= NP65) THEN
            WRITE (POISSON(IGBL(53) + 1),
     1        '(F5.2, ''('', F5.2, '')'', A)')
     2        MIN (99.0, RATIO), MIN (99.0, SIGMA), ICH
          END IF
        END IF
      ELSE
        IF (IGBL(53) + 1 <= NP65) THEN
          POISSON(IGBL(53) + 1) = ' '
        END IF
      END IF
C * ALERT _609 - Check for missing SQUEEZE or MASK data
      IF (IPR(766) > 0) THEN
        IF (MOD (IPR(651), 10) == 0)
     1 CALL PLA236 (609, 0, 1.0, 1.0, ' ', ' ')
      END IF
C * _816 - Report on possible refinement on detwinned data
      IF (IPR(781) > 0 .AND. IPR(782) > 0 .AND. IPR(619) == 0)
     1  CALL PLA236 (816, 0, -999.0, 0.0, 'HKLF 4 ', ' ')
C * _979 - REPORT REFINEMENT WITH NON-SPHERICAL SCATTERING FACTORS (NoSpherA2)
      IF (IPR(775) > 0) CALL PLA236 (979, 0, -999.0, 0.0, ' ', ' ')
C * _769 - REPORT ON NON-STANDARD SCATTERING FACTORS IN THE CIF
      IF (IPR(762) > 0) CALL PLA236 (769, 0, -999.0, 0.0, ' ', ' ')
C * _768 - REPORT ON NON-STANDARD SCATTERING FACTORS IN THE CIF
      IF (IPR(763) > 0) CALL PLA236 (768, 0, -999.0, 0.0, ' ', ' ')
C * _993 - REPORT MISSING BODD INCLUDE FILE
      IF (IPR(738) < 0) CALL PLA236 (993, 0, 1.0, 1.0, ' ', ' ')
C * CHECK FOR NON-CSD CIF (IGBL(94)
      IF (IGBL(94) == 0) THEN
        IF (IPR(105) == 0) THEN
C * ALERT _183 - MISSING CELL_MEASUREMENT_REFLNS_USED VALUE
          IF (IPR(601) <= 0)
     1      CALL PLA236 (183, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _184 - MISSING CELL_MEASUREMENT_THETA_MIN VALUE
          IF (PAR(227) <= 0.0)
     1      CALL PLA236 (184, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _185 - MISSING CELL_MEASUREMENT_THETA-MAX VALUE
          IF (PAR(228) <= 0.0)
     1      CALL PLA236 (185, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _880 - MISSING _DIFFRN_REFLNS_NUMBER VALUE
          IF (IPR(262) <= 0)
     1      CALL PLA236 (880, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _881 - MISSING _diffrn_reflns_av_R_equivalents VALUE
          IF (IPR(648) /= 5) THEN
            IF (PAR(197) < -1.0) THEN
              CALL PLA236 (881, 0, 1.0, 1.0, ' ', ' ')
            ELSE IF (PAR(197) == 0.0) THEN
              CALL PLA236 (881, 0, -999.0, 0.0, ' ', ' ')
      ELSE IF (PAR(197) > 0.0) THEN
C * ALERT _020 - Check R(int) for R1 > 0.07)
              IF (PAR(173) > 0.07) THEN
                CALL PLA236 (20, 3, PAR(197), PAR(197), ' ', ' ')
              ELSE
                IF (PAR(197) > 0.12)
     1            CALL PLA236 (20, 3, -999.0, PAR(197), ' ', ' ')
              END IF
            END IF
          END IF
C * ALERT _882 - MISSING _diffrn_reflns_av_unetI/netI or _sigmaI/netI
          IF (PAR(198) <= 0.0)
     1      CALL PLA236 (882, 0, -999.0, 0.0, ' ', ' ')
C * ALERT _883 _ MISSING _atom_sites_solution_primary info
          IF (IPR(740) == 0)
     1      CALL PLA236 (883, 0, -999.0, 0.0, ' ', ' ')
        END IF
      END IF
C * ALERT _802
      IF (IPR(544) > 0)
     1  CALL PLA236 (802, 0, -999.0, FLOAT (IPR(544)), ' ', ' ')
C * ALERT _870
      IF (IPR(619) == 1) CALL PLA236 (870, 0, -999.0, 0.0, ' ', ' ')
C * TEST FOR THE NEED FOR A BASF/TWIN REFINEMENT
      IF (IPR(193) < 101 .AND. IPR(663) /= 0) THEN
C * COMPARE FLACK VALUE WITH SIGMA
        IF (PAR(433) > 3.0 * PAR(434)) THEN
C * TEST F' & F'' VALUES
          IF (ABS(PAR(513)) > 0.3 .OR. ABS(PAR(514)) > 0.3) THEN
C * TEST FLACK PARAMETER VALUE
            IF (PAR(433) > 0.01) THEN
C * ALERT _987 - TEST FOR ORGANIC = 0
              IF (IPR(325) == 0) THEN
                YUNK = 1.0
              ELSE
                YUNK = 2.0
              END IF
              CALL PLA236 (987, 0, YUNK, YUNK, ' ', ' ')
            END IF
          END IF
        END IF
      END IF
C * TEST FOR CIF & EMBEDDED RES SHELXL WEIGHT PARAMETERS
      IF (IPR(725) == 2) THEN
C * ALERT _964 - TEST FOR SHELXL WEIGHT PARAMETER CONSISTENCY
        IF (ABS (PAR(559) - PAR(493)) > 0.001 .OR.
     1      ABS (PAR(560) - PAR(494)) > 0.001) THEN
          CALL PLA236 (964, 0,    0.5, 0.0, ' ', ' ')
        END IF
C * ALERT _965 - TEST FOR SHELXL WEIGHT PARAMETER CONVERGENCE
        IF (ABS(PAR(563)) < 0.001) THEN
          IF (ABS (PAR(559) - PAR(561)) > 0.01 .OR.
     1        ABS (PAR(560) - PAR(562)) > 0.01) THEN
            CALL PLA236 (965, 0, -999.0, 0.0, ' ', ' ')
          END IF
        END IF
      END IF
C * TEST FOR H PRESENCE NEXT TO C
C * ALERT _040
      IF (IPR(484) == 0 .AND. IPR(483) > 0) THEN
        CALL PLA236 (40, 0, -999.0, 1.0, ' ', ' ')
      END IF
C * ALERT _002 DISTANCE/ANGLE RESTRAINTS ON ATOM SITE
      IF (IPR(643) > 0)
     1  CALL PLA236 (2, 0, -999.0, FLOAT (IPR(643)), ' ', ' ')
C * ALERT _003 UISO/UIJ RESTRAINTS FOR ATOM SITE
      IF (IPR(644) > 0)
     1  CALL PLA236 (3, 0, -999.0, FLOAT(IPR(644)), ' ', ' ')
C * ALERT _780 - CHECK FOR NON-CONNECTED SET (IPR(124) /= 0)
      IF (IPR(124) /= 0 .AND. IGBL(97) == 1) THEN
        IF (IPR(124) > 0) THEN
          CALL PLA236 (780, 0, 1.0, 1.0, ' ', ' ')
        ELSE
          CALL PLA236 (780, 0, -999.0, 1.0, ' ', ' ')
        END IF
      END IF
C * ALERT _822 - REPORT ON NEGATIVE PART NUMBERS
      IF (IPR(780) > 0)
     1  CALL PLA236 (822, 0, -999.0, FLOAT (IPR(780)), ' ', ' ')
C * ALERT _168 - REPORT ON EADP RECORD(S)
      IF (IPR(684) > 0)
     1  CALL PLA236 (168, 0, -999.0, FLOAT (IPR(684)), ' ', ' ')
C * ALERT _171 - REPORT ON EADP RECORD(S)
      IF (IPR(685) > 0)
     1  CALL PLA236 (171, 0, -999.0, FLOAT (IPR(685)), ' ', ' ')
C * ALERT _172 - REPORT ON DFIX RECORDS
      IF (IPR(686) > 0)
     1  CALL PLA236 (172, 0, -999.0, FLOAT (IPR(686)), ' ', ' ')
C * ALERT _173 - REPORT ON DANG RECORD(S)
      IF (IPR(687) > 0)
     1  CALL PLA236 (173, 0, -999.0, FLOAT (IPR(687)), ' ', ' ')
C * ALERT _174 - REPORT ON FLAT RECORD(S)
      IF (IPR(688) > 0)
     1  CALL PLA236 (174, 0, -999.0, FLOAT (IPR(688)), ' ', ' ')
C * ALERT _175 - REPORT ON SAME RECORD(S)
      IF (IPR(689) > 0)
     1  CALL PLA236 (175, 0, -999.0, FLOAT (IPR(689)), ' ', ' ')
C * ALERT _176 - REPORT ON SADI RECORD(S)
      IF (IPR(690) > 0)
     1  CALL PLA236 (176, 0, -999.0, FLOAT (IPR(690)), ' ', ' ')
C * ALERT _177 - REPORT ON DELU RECORD(S)
      IF (IPR(691) > 0)
     1  CALL PLA236 (177, 0, -999.0, FLOAT (IPR(691)), ' ', ' ')
C * ALERT _178 - REPORT ON SIMU RECORD(S)
      IF (IPR(692) > 0)
     1  CALL PLA236 (178, 0, -999.0, FLOAT (IPR(692)), ' ', ' ')
C * ALERT _179 - REPORT ON CHIV RECORD(S)
      IF (IPR(693) > 0)
     1  CALL PLA236 (179, 0, -999.0, FLOAT (IPR(693)), ' ', ' ')
C * ALERT _186 - REPORT ON ISOR RECORD(S)
      IF (IPR(694) > 0)
     1  CALL PLA236 (186, 0, -999.0, FLOAT (IPR(694)), ' ', ' ')
C * ALERT _187 - REPORT ON RIGU RECORD(S)
      IF (IPR(710) > 0)
     1  CALL PLA236 (187, 0, -999.0, FLOAT (IPR(710)), ' ', ' ')
C * ALERT _650 - Report the use of SWAT
      IF (IPR(698) > 0)
     1  CALL PLA236 (650, 0, -999.0, 0.0, ' ', ' ')
C * ALERT _933 - REPORT OMIT (REFLECTION) RECORD(S)
      IF (IPR(714) > 0) THEN
        CALL PLA236 (-933, 0, -999.0, FLOAT (IPR(714)), ' ', ' ')
        N = MIN (IPR(714), NP78)
        DO I = 1, N, 6
          K = MIN (5, N - I)
          WRITE (PRBUF, 99998) ((NOMIT(L, I + J), L = 1, 3), J = 0, K)
          WRITE (LU68,  99999) PRBUF(1:79)
        END DO
      END IF
C * ALERT _937 - REPORT EXP TERM IN SHELXL WEIGHT EXPRESSION
      IF (PAR(495) /= 0.0)
     1  CALL PLA236 (937, 3, ABS(PAR(495)), PAR(495), ' ', ' ')
C * ALERT _169 - REPORT ON AFIX 1 RECORD(S)
      IF (IPR(709) > 0)
     1  CALL PLA236 (169, 0, -999.0, FLOAT (IPR(709)), ' ', ' ')
C * ALERT _789 - REPORT THE NUMBER OF ATOMS with A NEGATIVE VALUE
C *              OF _atom_site_disorder_group
      IF (IPR(695) > 0)
     1  CALL PLA236 (789, 0, -999.0, FLOAT (IPR(695)), ' ', ' ')
C * ALERT _994 - REPORT MISSING MERG INSTRUCTION (SHELXL)
C * GENERAL CHECK FOR MISSING OR UNUSUAL CIF DATA
      IF (IGBL(94) == 0) THEN
C * ALERT _197  - Report Missing _cell_measurement_temperature
        IF (IPR(261) <= 0) CALL PLA236 (197, 0, 1.0, 0.0, ' ', ' ')
      END IF
C * ALERT _198  - Report Missing _diffrn_ambient_temperature
      IF (IPR(310) <= 0) CALL PLA236 (198, 0, 1.0, 0.0, ' ', ' ')
C * ALERT _199 - Check for SHELXL97 Roomtemperature Default (Cell)
C *              Also check for near zero K and zero C
      IF (IGBL(94) == 0) THEN
        IF (IPR(261) /= -999999) THEN
          YUNK = 0.5
          IF (IPR(261) < 2 .OR. IPR(261) == 293 .OR.
     1        IPR(261) == 273) THEN
            IF (ABS (IPR(310)) < 2 .OR. IPR(310) == 273)
     1        YUNK = -999.0
            IF (IPR(725) /= 1 .AND. IPR(261) == 293) YUNK = -999.0
            IF (IPR(105) == 0)
     1        CALL PLA236 (199, 0, YUNK, FLOAT (IPR(261)), ' ', ' ')
          END IF
        END IF
      END IF
C * ALERT _200 - Check for SHELXL97 Roomtemperature Default (Datacollection)
C *              Also check for near zero K and zero C
 
      IF (IPR(310) > -999999) THEN
        YUNK = 0.5
        IF (IPR(310) < 2 .OR. IPR(310) == 293 .OR.
     1      IPR(310) == 273) THEN
          IF (ABS (IPR(310)) < 2 .OR. IPR(310) == 273) YUNK = -999.0
          IF (IPR(725) /= 1     .AND. IPR(310) == 293) YUNK = -999.0
          IF (IPR(105) == 0)
     1      CALL PLA236 (200, 0, YUNK, FLOAT (IPR(310)), ' ', ' ')
        END IF
      END IF
C * ALERT _193 - Check Consistency Cell & Datacollection Temperatures
      IF (IPR(261) > 0 .AND. IPR(310) > 0) THEN
        YUNK = ABS (IPR(310) - IPR(261))
          IF (YUNK > 0.0) CALL PLA236 (193, 0, YUNK, YUNK, ' ', ' ')
      END IF
C * ALERT _871 - Report suppression Laue technique related ALERTS
      IF (IPR(106) == 1) CALL PLA236 (871, 0, -999.0, 0.0, ' ', ' ')
C * ALERT _872 - Report suppression of ALERTS related to Anharmonic Refinement
      IF (IPR(756) > 0) CALL PLA236 (872, 0, -999.0, 0.0, ' ', ' ')
C * ABSORPTION CORRECTION & FLACK RELATED CHECKS
      IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7) THEN
        IF (IGBL(94) == 0 .AND. IPR(105) == 0) THEN
C * ALERT _050 : CHECK FOR NON-ZERO MU
          IF (PAR(301) == 0.0 .AND. IPR(493) /= 8) THEN
            CALL PLA236 (50, 2, 1.0, 1.0, ' ', ' ')
C * ALERT _051
          ELSE IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7)
     1      THEN
            IF (ABS (PAR(162) - PAR(301)) > 0.03) THEN
              DEVIA = ABS (1.0 - PAR(162) / PAR(301)) * 100.0
              IF (IPR(651) == 0) THEN
                CALL PLA236 (51, 2, DEVIA, DEVIA, ' ', ' ')
              ELSE
                CALL PLA236 (51, 2, -999.0, DEVIA, ' ', ' ')
              END IF
            END IF
C * ALERT _052 : CHECK FOR ABS-CORRECTION METHOD
            IF (IPR(485) < 0) THEN
              CALL PLA236 (52, 2, 1.0, 1.0, ' ', ' ')
            ELSE IF (IPR(485) > 0) THEN
C * ALERT _058 : CHECK FOR MAXIMUM TRANSMISSION FACTOR PRESENT
              IF (PAR(306) == 999999.0)
     1          CALL PLA236 (58, 2, 1.0, 1.0, ' ', ' ')
C * ALERT _059 : CHECK FOR MINIMUM TRANSMISSION FACTOR PRESENT
              IF (PAR(307) == 999999.0)
     1          CALL PLA236 (59, 2, 1.0, 1.0, ' ', ' ')
C * ALERT _064 : CHECK FOR TMAX >= TMIN
              IF (PAR(306) < 999999.0 .AND. PAR(307) < 999999.0
     1           .AND. PAR(307) > PAR(306))
     2          CALL PLA236 (64, 2, 1.0, 1.0, ' ', ' ')
            END IF
C * ALERT _068 : CHECK CALCULATED (F000 or F000') / REPORTED F000
            YUNK1 = ABS (PAR(157) - PAR(324))
            YUNK2 = ABS (PAR(426) - PAR(324))
C * SUPPRESS IN CASE OF SQUEEZE/MASK BASED REFINEMENT
            IF (IPR(651) == 0) THEN
              IF (YUNK1 > 0.1 .AND. YUNK2 > 0.1) THEN
                IF ((YUNK1 < 1.0 .OR. YUNK2 < 1.0) .OR.
     1            IPR(651) > 0) THEN
                  CALL PLA236 (68, 2, -999.0, 1.0, ' ', ' ')
                ELSE
                  CALL PLA236 (68, 2, 1.0, 1.0, ' ', ' ')
                END IF
              END IF
            END IF
C * ALERT _056 : SPHERE OR CYLINDER
            IF (IPR(485) == 7 .AND. PAR(305) <= 0.0 .AND. IPR(105) == 0)
     1        THEN
              CALL PLA236 (56, 2, 1.0, 1.0, ' ', ' ')
            END IF
            IF ((IPR(485) == 7 .AND. PAR(305) > 0.0) .OR.
     1           IPR(486) == 8) THEN
              V1(1) = 2 * PAR(305)
              V1(2) = V1(1)
              V1(3) = V1(1)
C * CHECK FOR NON-NEUTRON
              IF (IABS(IPR(493)) < 7) THEN
C * ALERT _063 - Large Crystal
                IF (V1(3) > 1.0)
     1            CALL PLA236 (63, 2, -999.0, V1(3), ' ', ' ')
              END IF
            ELSE
              IF (PAR(305) <= 0.0 .OR. IPR(485) /= 7) THEN
                NERR  = 0
                V1(1) = PAR(304)
                V1(2) = PAR(303)
                V1(3) = PAR(302)
C * ALERT _067
                IF (V1(1) > 0.0 .AND. V1(3) > 0.0) THEN
                   IF (V1(1) > V1(3)) THEN
                     CALL PLA236 (67, 2, 1.0, 1.0, ' ', ' ')
                       NERR = 1
                   END IF
                END IF
                IF (IPR(105) == 0) THEN
C * ALERT _053
                  IF (V1(1) <= 0.0 .AND. PAR(305) <= 0.0) THEN
                    CALL PLA236 (53, 2, 1.0, 1.0, ' ', ' ')
                    NERR = 1
                  END IF
C * ALERT _054
                  IF (V1(2) <= 0.0 .AND. PAR(305) <= 0.0) THEN
                    CALL PLA236 (54, 2, 1.0, 1.0, ' ', ' ')
                    NERR = 1
                  END IF
C * ALERT _055
                  IF (V1(3) <= 0.0 .AND. PAR(305) <= 0.0) THEN
                    CALL PLA236 (55, 2, 1.0, 1.0, ' ', ' ')
                    NERR = 1
                  ELSE
C * ALERT _063
                    IF (V1(3) > 9.999) THEN
                      CALL PLA236 (63, 0, V1(3), V1(3), ' ', ' ')
                    ELSE IF (V1(3) > 0.6) THEN
                      CALL PLA236 (63, 2, -999.0, V1(3), ' ', ' ')
                    END IF
                  END IF
                END IF
              END IF
            END IF
C * ESTIMATE TRANSMISSION RANGE
            IF (NERR == 0 .AND. V1(1) * V1(2) * V1(3) > 0.0) THEN
              IF (IABS(IPR(493)) > 0 .AND. IABS(IPR(493)) < 7)
     1          THEN
                TMIDMU   = V1(2) * PAR(301)
                J        = MAX (1, IABS (IPR(493)))
                I        = MIN (7, 1 + INT ((TMIDMU + 0.25) * 2))
                V1(4)    = MAX (V1(2), MIN (1.2 * V1(2), V1(3)))
C * Tmax(shape)
                PAR(317) = EXP (-V1(1) * PAR(301))
 
C * Tmin(shape)
                PAR(315) = EXP (-V1(4) * PAR(301)) * TABT(I, J)
C * Tmin(shape)'
                PAR(316) = EXP (-V1(3) * PAR(301)) / TABT(I, J)
                V3(1)    = 1.0
C * RT(exp)
                IF (PAR(315) /= 0.0) THEN
                  V3(2) = PAR(317) / PAR(315)
                ELSE
                  V3(2) = 0.0
                END IF
C * RT(exp)'
                IF (PAR(316) /= 0.0) THEN
                  V3(3) = PAR(317) / PAR(316)
                ELSE
                  V3(3) = 0.0
                END IF
C * ALERT _057
                IF (IPR(485) < 1)
     1            CALL PLA236 (57, 2, V3(2), V3(2), ' ', ' ')
C * CHECK FOR 'SIZE-TRICK'
                VERS  = ABS (PAR(317) - PAR(306)) + ABS (PAR(316)
     1                - PAR(307))
                VERS1 = ABS (PAR(317) - PAR(306)) + ABS (PAR(315)
     1                - PAR(307))
C * ALERT _066
                IF (VERS < 0.011 .OR. VERS1 < 0.011)
     1            CALL PLA236 (66, 2, -999.0, 1.0, ' ', ' ')
C * TEST FOR APPLICABILITY OF (SEMI-)EMPIRICAL CORRECTION METHODS
                IF (IPR(485) < 1 .OR. IPR(485) > 3) THEN
C * ALERT _065
                  IF (TMIDMU > 1.0)
     1              CALL PLA236 (65, 2, TMIDMU, TMIDMU, ' ', ' ')
                END IF
                IF (IPR(485) >= 0) THEN
                  IF (IPR(485) > 3) THEN
                    IF (PAR(306) * PAR(307) /= 0.0 .AND. PAR(306)
     1                 < 99999 .AND. PAR(307) < 99999) THEN
                      V3(1) = PAR(306) / PAR(307)
                      RR    = V3(2) / V3(1)
                      RRP   = MIN (99999.0, V3(3) / V3(1))
C * ALERT _060
                      CALL PLA236 (60, 3, RR, RR, ' ', ' ')
C * ALERT _061
                      CALL PLA236 (61, 3, 1.0 - RRP, RRP, ' ', ' ')
C * ALERT _062
                      IF (ABS(PAR(317) - PAR(306)) > 0.01)
     1                  CALL PLA236 (
     2                     62, 3, -999.0, PAR(317) / PAR(306), ' ', ' ')
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
C * 4 SERIES
C * ALERT _077
      IF (IPR(215) > 0) CALL PLA236 (77, 2, 0.5, 0.5, ' ', ' ')
C * TEST FOR NUMBER OF H-ATOMS
      IF (IPR(484) <= 0) THEN
C * ALERT _078
        IF (CCIF(12)(1:NCIF(12)) == 'geom')
     1    CALL PLA236 (78, 0, 1.0, 1.0, '   geom', ' ')
C * ALERT _079
        IF (CCIF(13)(1:NCIF(13)) == 'mixed')
     1    CALL PLA236 (79, 0, 1.0, 1.0, '  mixed', ' ')
      ELSE
C * ALERT _007 - REPORT ON NUMBER OF UN-REFINED D-H ATOMS
        IF (IPR(658) > 0) THEN
          CALL PLA236 (-7, 0, -999.0, FLOAT (IPR(658)), ' ', ' ')
          N = MIN (IPR(658), NP85)
          DO I = 1, N, 11
            K = MIN (10, N - I)
            WRITE (PRBUF, 99997)
     1        (CNRH(I + J), J = 0, K)
            WRITE (LU68, 99999) PRBUF(1:79)
          END DO
        END IF
C * TEST FOR NUMBER OF REFINED H ATOMS
        IF (IPR(564) == 0) THEN
C * ALERT _093
          IF (CCIF(13)(1:NCIF(13)) == 'mixed')
     1      CALL PLA236 (93, 0, -999.0, 1.0, '  mixed', ' ')
        ELSE
C * ALERT _073
          IF (CCIF(13)(1:NCIF(13)) == 'constr') THEN
C * CHECK FOR olex2.refine
            IF (IPR(725) == 8) THEN
              CALL PLA236 (73, 0, -999.0, 0.0, ' constr', ' ')
            ELSE
              CALL PLA236 (73, 0, 1.0, 1.0, ' constr', ' ')
            END IF
          END IF
        END IF
      END IF
C * VALIDATE REFINEMENT PARAMETERS
C * NO Hall SPACEGROUP SPECIFIED
      IF (IGBL(94) == 0) THEN
C * ALERT _125
        IF (CCIF(16)(1:1) == '?' .OR. CCIF(16)(1:1) == ' ') THEN
          CALL PLA236 (125, 0, 1.0, 1.0, ' ', ' ')
        ELSE
          IF (SPGRNM(3)(1:1) == CHAR (32)) THEN
            I = 1
          ELSE
            I = 0
          END IF
C * ALERT _127
          IF (SPGRNM(3)(I+1:I+1) == ' ') THEN
            CALL PLA236 (127, 2, 1.0, 1.0, CCIF(16)(1:10), ' ')
            GO TO 30
          END IF
          J = 0
   10     I = I + 1
          IF (I > 17) GO TO 30
          ICH = SPGRNM(3)(I:I)
          IF (ICH == '_' .OR. ICH == CHAR (32)) GO TO 10
   20     J = J + 1
          IF (J < 18) THEN
            JCH = CCIF(16)(J:J)
            IF (JCH == '_' .OR. JCH == CHAR (32)) GO TO 20
            IF (ICH == JCH) GO TO 10
          END IF
C * ALERT _127
          IF (IPR(673) == 0) CALL PLA236 (127, 2, 1.0, 1.0,
     1      CCIF(16)(1:10), ' ')
        END IF
      END IF
C * SHIFT/ERROR TEST
   30 IF (IGBL(94) == 0) THEN
C * ALERT _080
        IF (PAR(178) > -999999.0) THEN
          CALL PLA236 (80, 2, ABS (PAR(178)), ABS (PAR(178)) , ' ', ' ')
        ELSE
C * ALERT _081
          IF (IPR(105) == 0)
     1      CALL PLA236 (81, 2, 1.0, 1.0, ' ', ' ')
        END IF
      END IF
C * ALERT _082 : TEST R1 & wR2 VALUES
      CALL PLA236 (82, 2, PAR(173), PAR(173), ' ', ' ')
C * ALERT _084
      CALL PLA236 (84, 2, PAR(174), PAR(174), ' ', ' ')
C * CHECK FOR F**2 REFINEMENT WITH ALL DATA
      IF (IPR(309) == 2 .AND. IPR(105) == 0) THEN
C * ALERT _940
        IF (IPR(265) == IPR(264)) THEN
          IF (PAR(314) < 0.95) THEN
            CALL PLA236 (940, 0, 1.0, 1.0, ' ', ' ')
          ELSE
            CALL PLA236 (940, 0, -999.0, 1.0, ' ', ' ')
          END IF
        END IF
      END IF
C * ALERT _808  - No Parseable weight function
      IF (PAR(493) < 0.0 .AND. PAR(494) == 0.0 .AND.
     1  IGBL(94) == 0 .AND. IPR(105) == 0 .AND. IGBL(9) /= 5 .AND.
     2  IGBL(9) /= 17 .AND. IGBL(9) /= 18) THEN
          CALL PLA236 (808, 0, -999.0, 0.0, ' ', ' ')
      END IF
      IF (IPR(266) > 0 .AND. IPR(105) == 0) THEN
C * RATIO NREF / NPAR
        IF (IPR(377) > 0) THEN
C * From FCF/ASYM
          IF (IGBL(9) == 17 .OR. IGBL(9) == 18) THEN
            PAR(505) = FLOAT (IPR(265)) / FLOAT (IPR(266))
          ELSE
            PAR(505) = FLOAT (IPR(377)) / FLOAT (IPR(266))
          END IF
        ELSE
C * ESTIMATE (FRACTION_THETA_MAX/ASYM)
          PAR(505) = (FLOAT (IPR(559)) * PAR(168)) / FLOAT (IPR(266))
        END IF
C * SEPARATE CENTRO FROM NON-CENTRO
        IF (PAR(505) > 0.001) THEN
          IF (IPR(275) == 2) THEN
C * ALERT _088
            IF (IPR(105) == 0)
     1        CALL PLA236 (88, 2, 100 / PAR(505), PAR(505), ' ', ' ')
          ELSE
C * ALERT _089 & _090
            IF (IPR(22) <= 18) THEN
              CALL PLA236 (89, 2, 100 / PAR(505), PAR(505), ' ', ' ')
            ELSE
              CALL PLA236 (90, 2, 100 / PAR(505), PAR(505), ' ', ' ')
            END IF
          END IF
        END IF
      END IF
C * CHECK S-Value
      IF (IGBL(94) == 0) THEN
        IF (PAR(299) < 0.99) THEN
C * ALERT _086
          IF (IPR(105) == 0)
     1      CALL PLA236 (86, 2, 1.0 - PAR(299),
     2      MAX (0.0, PAR(299)), ' ', ' ')
C * SHELXL ONLY !
        ELSE IF (PAR(299) > 1.01 .AND. IPR(632) == 1) THEN
C * ALERT _087
          CALL PLA236 (87, 2, PAR(299), PAR(299), ' ', ' ')
        END IF
      END IF
C * RESIDUAL DENSITY TESTS (SUPPRESSED FOR POWDER STUDY)
      IF (IGBL(94) == 0 .AND. IPR(105) == 0) THEN
        IF (PAR(177) < -1000.0) THEN
C * ALERT _095
          IF (IPR(105) == 0)
     1      CALL PLA236 (95, 2, 1.0, 1.0, ' ', ' ')
        ELSE
C * ALERT _097
          IF (IPR(22) /= 0 .AND. IABS (IPR(493)) < 7) THEN
            CALL PLA236 (97, 2, 10 * PAR(177) / IPR(22),
     1        PAR(177), ' ', ' ')
          END IF
C * ALERT _094
          IF (PAR(176) /= 0.0 .AND. PAR(177) > 0.40) THEN
            RMXMI = PAR(177) /  ABS (PAR(176))
            CALL PLA236 (94, 2, RMXMI, RMXMI, ' ', ' ')
          END IF
        END IF
C * ALERT _096
        IF (PAR(176) > 1000.0) THEN
          IF (IPR(105) == 0)
     1      CALL PLA236 (96, 2, 1.0, 1.0, ' ', ' ')
        ELSE IF (PAR(176) < -0.1) THEN
C * ALERT _098
          IF (IPR(22) /= 0 .AND. IABS (IPR(493)) < 7) THEN
            CALL PLA236 (98, 2, - 10 * PAR(176) / IPR(22),
     1        PAR(176), ' ', ' ')
          END IF
        ELSE IF (PAR(176) >= 0.0) THEN
C * ALERT _099
          CALL PLA236 (99, 2, 1.0, PAR(176), ' ', ' ')
        END IF
      END IF
C * ALERT _001 & _005 - REPORT ABSENCE OF '_iucr_refine_instructions_details'
C *                                    OR '_shelx_res_file'
C * CHECK FOR NO POWDER DATA AND NO CSD-CIF
      IF (IPR(105) == 0 .AND. IGBL(94) == 0) THEN
        IF (IPR(663) == 0) THEN
          IF (IPR(653) < 5) THEN
            IF (IPR(725) == 2) THEN
              YUNK = 1
            ELSE
              YUNK = -999.0
            END IF
            CALL PLA236 (5, 0, YUNK, 0.0, ' ', ' ')
          END IF
C * ALERT _012 - Check for CheckSum present
        ELSE
C * CHECK FOR 'NON-EMPTY' (i.e. with < 5 records) embedded RES file
          IF (IPR(653) < 5) THEN
C * ALERT _005
            IF (IPR(725) == 2) THEN
              YUNK = 1.0
            ELSE
              YUNK = -999.0
            END IF
            CALL PLA236 (5, 0, YUNK, 0.0, ' ', ' ')
          ELSE
            IF (IPR(701) == 2 .AND. IPR(702) == 1) THEN
C * ALERT__001 - _shelx_res_file present ?
              CALL PLA236 (1, 0, 1.0, 0.0, ' ', ' ')
            END IF
          END IF
          NQ4  = '      '
          YUNK = -999.0
C * CHECK FOR SHELXL20xx (or used via OLEX2)
          IF (IPR(725) == 2 .OR. IPR(677) > 0 .OR.
     1      (IPR(725) == 8 .AND. IPR(666) == 0)) THEN
C * TEST FOR shelx_res checksum
            IF (IPR(677) < 0) THEN
              NQ4 = 'No    '
            ELSE IF (IPR(677) > 0) THEN
              IF (IPR(721) /= IPR(677)) NQ4 = 'N.O.K.'
            END IF
C * ALERT _012
            IF (NQ4(1:6) /= '      ')
     1        CALL PLA236 (12, 0, YUNK, YUNK, NQ4, ' ')
          END IF
        END IF
      END IF
C * ALERT _697 - REMOVED NUMBER OF BLANK RECORDS FROM CIF EMBEDDED HKL
      IF (IPR(770) > 0)
     1  CALL PLA236 (697, 0, -999.0, FLOAT(IPR(770)), ' ', ' ')
C * ALERT _010 - No Structure Factors[IPR(676) or  IPR(321)],
C *              No CSD-CIF [IGBL(94)], No Powder [IPR(105)],
C *              No SHELXL201n [IPR(725)]
      IF (IGBL(54) <= NP54) THEN
        IF (IENTRY(IGBL(54), 4) > 0) IPR(676) = 1
      END IF
      IF (IPR(676) == 0 .AND. IPR(321) == 0 .AND. IGBL(94) == 0
     1    .AND. IPR(105) == 0 .AND. IPR(725) /= 2) THEN
        CALL PLA236 (10, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _013 - CHECKSUM _shelx_hkl (SHELXL20xx or OLEX EMBEDDED)
      ELSE
        NQ4  = '       '
        YUNK = -999.0
        IF (IPR(725) == 2 .OR.  IPR(678) > 0 .OR.
     1     (IPR(725) == 8 .AND. IPR(666) == 0)) THEN
          IF (IPR(678) < 0) THEN
            NQ4 = 'No     '
          ELSE IF (IPR(678) > 0) THEN
            IF (IPR(722) /= IPR(678)) NQ4 = 'N.O.K. '
          END IF
          IF (NQ4 /= '       ')
     1      CALL PLA236 (13, 0, YUNK, YUNK, NQ4, ' ')
        END IF
      END IF
C * ALERT _008 - REPORT ABSENSE OF '_iucr_refine_reflections_details
C * ALERT _015                          OR '_shelx_hkl_file
      IF (IPR(664) == 0 .AND. IPR(105) == 0) THEN
        IF (IPR(660) < 5 .AND. IGBL(94) == 0 .AND.
     1      IPR(105) == 0) THEN
          IF (IPR(725) == 2) THEN
            CALL PLA236 (15, 0, 1.0, 1.0, ' ', ' ')
          ELSE
            IF (IGBL(9) /= 5) THEN
              IF (IPR(321) == 0 .AND. IPR(753) == 0) THEN
                CALL PLA236 (8, 0, 1.0, 0.0, ' ', ' ')
              END IF
            END IF
          END IF
        END IF
      END IF
C * ALERT _014 - Missing FAB CheckSum
      IF (IPR(651) /= 12) THEN
        NQ4  = '       '
        YUNK = -999.0
        IF (IPR(725) == 2 .OR.
     1     (IPR(725) == 8 .AND. IPR(666) == 0)) THEN
          IF (IPR(665) /= 0 .AND. IPR(679) < 0) THEN
            NQ4 = 'No     '
          ELSE IF (IPR(679) > 0 .OR. IPR(723) > 0) THEN
            IF (IPR(723) /= IPR(679)) NQ4 = 'N.O.K. '
          END IF
          IF (NQ4 /= '       ')
     1      CALL PLA236 (14, 0, YUNK, YUNK, NQ4, ' ')
        END IF
      END IF
C * ALERT _016 - REPORT ABSENCE OF '_shelx_fab_file
      IF (IPR(665) == 0 .AND. IPR(651) > 10)
     1  CALL PLA236 (16, 0, 1.0, 1.0, ' ', ' ')
C * ALERT_990 - Report old style RES based SQUEEZE (for non-CRYSTALS)
      IF (IPR(665) == 0 .AND. IPR(651) == 1) THEN
        IF (IPR(725) /= 5) THEN
          CALL PLA236 (990, 0, 1.0, 1.0, ' ', ' ')
        END IF
      END IF
C * ALERT _009 CHECK FOR CONSISTENCY of radiation_wavelength and radiation_type
      IF (IGBL(94) == 0 .AND. IPR(105) == 0) THEN
        IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7) THEN
          IF (IPR(493) /= IPR(671)) THEN
            CALL PLA236 (9, 0, -999.0, 1.0, ' ', ' ')
          END IF
        END IF
      END IF
C * ALERT _104 : CHECK REPORTED CRYSTAL SYSTEM AGAINST REPORTED SYMMETRY
      IF (KRSYST(1) /= KRSYST(2))
     1  CALL PLA236 (104, 0, -999.0, 0.0, ZSPG, ' ')
C * REPORT THE NUMBER OF ARU-OUT-OF-RANGE CASES
      IF (IPR(600) > 0) THEN
C * ALERT _804
        CALL PLA236 (804, 0,  -999.0, FLOAT (IPR(600)), ' ', ' ')
      END IF
C * ALERT _868 & _869 - REPORT SUPPRESSION OF ALERTS RELATED TO THE USE
      IF (IPR(651) > 0) THEN
        IF (MOD (IPR(651), 10) == 1) THEN
          CALL PLA236 (869, 0, -999.0, 0.0, ' ', ' ')
        ELSE IF (IPR(651) == 12) THEN
          CALL PLA236 (868, 0, -999.0, 0.0, ' ', ' ')
        END IF
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT (14X, 6(3I3, ', '))
99997 FORMAT (14X, 11A)
      END SUBROUTINE PLA232
 
      SUBROUTINE PLA233
C * IUCR-CHECK  (CIF-VALIDATION) (4) - INCLUDE SOME ADDITIONAL CHECKS
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IRATIO
      REAL    :: P168
      REAL    :: P312
      REAL    :: P313
      REAL    :: P314
      REAL    :: YUNK
      REAL    :: RATMAX
      REAL    :: RATIO
      REAL    :: RESOL
      REAL    :: RTEST
      REAL    :: RESOL1
      REAL    :: RATIOTEST
C * MERR = 2 SERIES
C * FRACTION MAX
      P313   = MAX (0.0, PAR(313))
C * FRACTION FULL
      P314   = MAX (0.0, PAR(314))
C * THETA MAX FROM
      P168   = MAX (0.0, PAR(168), PAR(312))
C * THETA FULL
      P312   = MAX (0.0, PAR(312))
      RESOL  = SIN (P168 / RGBL(6)) / PAR(17)
      RESOL1 = SIN (P312 / RGBL(6)) / PAR(17)
C * ALERT _030 - TEST FOR UNIQUE # REFL > TOTAL MEASURED
      IF (IPR(262) > 0) THEN
        IF (IPR(263) > IPR(262) .AND. IPR(105) == 0)
     1    CALL PLA236 (30, 0, 1.0, 1.0, ' ', ' ')
      END IF
C * ALERT _018 COMPARE _fraction_full with _fraction_max
      IF (P314 > 0.0 .AND. P313 > 0.0) THEN
        IF (ABS (P168 - P312) < 0.005 .AND.
     1      ABS (P314 - P313) > 0.002) THEN
          CALL PLA236 (18, 3, 1.0, 1.0, ' ', ' ')
C * ALERT _019 - Check _diffrn_measured_fraction_theta_max/full consistency
        ELSE IF (P314 - P313 < -0.002) THEN
          IF (RESOL < 0.6) THEN
            CALL PLA236 (19, 3, (P313 - P314), P314 / P313, ' ', ' ')
          ELSE
            CALL PLA236 (19, 3, -999.0, P314 / P313, ' ', ' ')
          END IF
        END IF
      END IF
      IF (P168 > 0.0) THEN
C * CHECK RATIO OF REPORTED # UNIQUE / # EXPECTED REFLECTIONS
        IF (IPR(559) /= 0) THEN
          RATIO  = FLOAT (MAX (0, IPR(263))) / FLOAT (IPR(559))
          RATMAX = 3.0 - IPR(275)
          IF (RATIO > RATMAX) THEN
C * ALERT _021 = check with expected number of reflections
            RATIOTEST = (RATIO - RATMAX) / RATMAX
C * HANDLE HKLF 5 DATA
            IF (IPR(619) == 0)
     1        CALL PLA236 (-21, 3, RATIOTEST, RATIO, ' ', ' ')
              WRITE (LINE, 99999) MAX (0, IPR(263)), IPR(559)
              CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
          ELSE IF (RATIO < 1.0) THEN
            RTEST = 1.0 - P313
            IF (RESOL >= 0.594) THEN
              IF (RESOL1 >= 0.594) THEN
                IF (P314 > 0.98 .AND. RTEST > 0.05)
     1              RTEST = -999.0
              END IF
            END IF
C * ALERT _022 - check for completness
            END IF
          END IF
          IF (IPR(263) /= 0) THEN
            IRATIO = NINT (MAX (0, IPR(264)) / FLOAT (IPR(263)) * 100.0)
          ELSE
            IRATIO = 0
          END IF
C * ALERT _026 - Check for weak data set
          IF (IPR(105) == 0) THEN
            CALL PLA236 (26, 2, FLOAT (100 - IRATIO), FLOAT (IRATIO),
     1                 ' ', ' ')
          ENDIF
        END IF
C * CHECK RESOLUTION
        IF (IGBL(94) == 0 .AND. IPR(105) == 0) THEN
C * ALERT _023 : CHECK THETA-MAX (RESOL)
          IF (PAR(17) > 0.0 .AND. IPR(105) == 0)
     1      CALL PLA236 (23, 2, 0.6 - RESOL, RESOL, ' ', ' ')
C * ALERT _038 : CHECK FRACT-THETA-MAX
          IF (IGBL(9) /= 11 .AND. IPR(105) == 0) THEN
            IF (P313 == 0.0) CALL PLA236 (38, 0, 1.0, 1.0, ' ', ' ')
          END IF
C * ALERT _037 : CHECK FOR THETA-FULL
          IF (P312 == 0.0 .AND. IPR(105) == 0)
     1      CALL PLA236 (37, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _039 : CHECK FOR FRACT-THETA-FULL
          IF (P314 == 0.0) CALL PLA236 (39, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _029 : DETERMINE WHETHER TO USE P313 OR P314
          IF (IPR(106) == 0 .AND. IPR(105) == 0) THEN
            IF (P314 >= P313) THEN
              CALL PLA236 (29, 3, 1.0 - P314, P314, ' ', ' ')
C * ALERT _027 - Check _diffrn_reflns_theta_full
            IF (RESOL1 < RESOL .AND. IPR(105) == 0) THEN
              YUNK = (0.6 - RESOL1) * 10.0
              CALL PLA236 (27, 2, YUNK, P312, ' ', ' ')
            END IF
          ELSE
C * ALERT _028 - Check the reported _diffrn_measured_fraction_theta_max
            IF (IPR(105) == 0)
     1        CALL PLA236 (28, 3, 1.0 - P313, P313, ' ', ' ')
          END IF
        END IF
C * ALERT _025 : CHECK FOR Hmin..Lmax
        IF (IPR(105) == 0) THEN
          DO I = 267, 272
            IF (IABS(IPR(I)) == 999999) THEN
              CALL PLA236 (25, 3, 1.0, 1.0, ' ', ' ')
              EXIT
            END IF
          END DO
        END IF
C * CHECK FOR NoSpherA2 AND _ANHARM_
        IF (IPR(775) == 0 .AND. IPR(756) == 0) THEN
C * SHELXL ONLY
          IF (((IPR(725) > 0 .AND. IPR(725) < 5)
     1        .OR. IGBL(9) == 1) .AND. IGBL(9) == 1) THEN
 
C * ALERT _924
 
            IF (IPR(493) /= 7 .AND. IPR(651) == 0) THEN
              IF (PAR(176) < 0.0 .AND. IPR(619) == 0) THEN
                YUNK = ABS (PAR(176) - PAR(329))
                IF (YUNK > 0.5) THEN
                  IF (IPR(725) /= 9) THEN
                    CALL PLA236 (924, 2, YUNK, YUNK, ' ', ' ')
                  ELSE
                    CALL PLA236 (924, 2, -999.0, YUNK, ' ', ' ')
                  END IF
                END IF
              END IF
C * ALERT _925
              IF (PAR(177) > 0.0 .AND. IPR(619) == 0 .AND.
     1            IPR(651) == 0 .AND. IPR(756) == 0) THEN
                YUNK = ABS (PAR(177) - PAR(330))
                IF (YUNK > 0.5) THEN
                  IF (IPR(725) /= 9) THEN
                    CALL PLA236 (925, 2, YUNK, YUNK, ' ', ' ')
                  ELSE
                    CALL PLA236 (925, 2, -999.0, YUNK, ' ', ' ')
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (14X, '# Unique Refl = ', I8, ' / # Expected Refl =', I8)
      END SUBROUTINE PLA233
 
      SUBROUTINE PLA234 (LU, L, A, B, CNT)
C * IUCR-CHECK  (CIF-VALIDATION) - CREATE VRF RECORDS
      USE files
      USE parameters
      USE cchar
      USE mentry
      IMPLICIT NONE
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: LU
      CHARACTER(len=*) :: A
      CHARACTER(len=*) :: B
      CHARACTER(len=1) :: LVL
      CHARACTER(len=2) :: CNT
C * OUTPUT ON LU (LU7 OR LU10)
      IF (IGBL(36) <= 0) CALL PLA262 (1)
      L = MIN (L, 80)
      WRITE (LU, 99997, IOSTAT = IOST) A(1:L)
      IF (IGBL(54) <= NP54) THEN
        IF (LU == LU10) THEN
          READ (A, 99999) N, LVL
          IF (LVL == 'A' .OR. LVL == 'B') THEN
            IGBL(141) = IGBL(141) + 1
            IF (IGBL(141) == 1) THEN
              OPEN (LU66, FILE = NAMEFIL(1:KNMFIL)//'.vrf',
     1          STATUS = 'UNKNOWN', IOSTAT = IOST)
              WRITE (LU66, 99996)
            END IF
            WRITE (LU66, 99998) N, CENTRY(IGBL(54))(1:66), A(15:L)
          END IF
        END IF
      END IF
C * HANDLE SUPPLEMENTARY INFORMATION
      IF (CNT == ' =') THEN
C * COPY FIRST INFO RECORD READ IN PLA231
        WRITE (LU, 99995, IOSTAT = IOST) B(15:80)
        DO
          READ (LU68, 99997, IOSTAT = IOST) B
C * CHECK FOR UNDERSCORE (I.E. NEW ALERT RECORD, COPY INFO OTHERWISE)
          IF (B(1:1) == '_') THEN
            BACKSPACE LU68
            EXIT
          END IF
          IF (IGBL(36) <= 0) CALL PLA262 (1)
          WRITE (LU, 99997, IOSTAT = IOST) B
        END DO
      END IF
      RETURN
99999 FORMAT (I3, 9X, A)
99998 FORMAT ('_vrf_PLAT', I3.3, '_', A, /, ';', /,
     1        'PROBLEM: ', A, /, 'RESPONSE: ...', /, ';')
99997 FORMAT (A)
99996 FORMAT ('# start Validation Reply Form')
99995 FORMAT (14X, A)
      END SUBROUTINE PLA234
 
      SUBROUTINE PLA235 (MODE)
C * DISPLAY VALIDATION RESULT
      USE files
      USE parameters
      USE xwdw
      USE ccom
      USE cggt
      IMPLICIT NONE
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: LU
      INTEGER           :: MODE
      INTEGER           :: IGBL6SAVE = 0
      CHARACTER(len=80) :: LIJN
C * MODE = 0 - List Contents LU10
C * MODE = 1 - List Contents File valid.chk
C * MODE = 2 - List Contents File tm/sg/valid/valid.chk
C * GET VALIDATION chk SOURCE
      IF (MODE == 0) THEN
        LU = LU10
        CALL GEN108 (LU, 0)
      ELSE IF (MODE == 1) THEN
        LU = LU65
        OPEN (UNIT = LU, FILE = 'valid.chk',  STATUS = 'UNKNOWN')
      ELSE IF (MODE == 2) THEN
        LU = LU65
        OPEN (UNIT = LU, FILE = 'tm/sg/valid/valid.chk',
     1        STATUS = 'UNKNOWN')
      END IF
C * TEMPORARILY INACTIVATE DISPLAY OF CLICKABLE MENU-OPTIONS
      IGBL6SAVE = IGBL(6)
      IGBL(6)   = 0
C * READ & DISPLAY LOOP
      N = 0
      DO
        CALL GGIP (HORS, VERT, 0.0, 1)
C * REPORT HEADER
        IF (N == 0) THEN
          VRT = VERT - 0.7
          LIJN = 'VALIDATION REPORT FOR CURRENT CIF'
          CALL PLA439 (0.0, LIJN, 33, 0.375, 5 + IGBL(68), 2, 7.0, VRT)
        ELSE
          VRT = VERT - 0.1
        END IF
        N = N + 1
C * LOOP OVER REPORT FILE
        DO
          READ (LU, 99999, IOSTAT = IOST) LIJN
C * ERROR HANDLING
          IF (IOST /= 0) THEN
            CALL PLA297 (0)
            CLOSE (UNIT = LU)
            IGBL(6) = IGBL6SAVE
            RETURN
          END IF
C * CHECK FOR FORCED NEW WINDOW
          IF (LIJN(80:80) == '*') EXIT
C * SET ALERT LEVEL COLOR RED, ORANGE, YELLOW WHITE
          M     = 1
          IF (LIJN(5:9) == 'ALERT') THEN
            IF (LIJN(13:13) == 'A' .OR.
     1          LIJN(11:17) == 'Level_A') THEN
              M = 2
            ELSE IF (LIJN(13:13) == 'B' .OR.
     1               LIJN(11:17) == 'Level_B') THEN
              M = 6
            ELSE IF (LIJN(13:13) == 'C' .OR.
     1               LIJN(11:17) == 'Level_C') THEN
              M = 5
            END IF
          END IF
          VRT = VRT - 0.5
          CALL PLA439 (0.0, LIJN, 80, 0.35, M, 2, 1.0, VRT)
          IF (VRT < 0.5) EXIT
        END DO
C * WHAT NEXT ?
        CALL PLA012 (1, 1)
        IF (IGGT(1:4) == 'CALC' .OR. IGGT(1:1) == 'Y' .OR.
     1      IGGT(1:1) == '!') THEN
   20     READ (LU, 99999, IOSTAT = IOST) LIJN
C * ERROR HANDLING
          IF (IOST /= 0) THEN
            CALL PLA297 (0)
            CLOSE (UNIT = LU)
            IGBL(6) = 10
            IGBL(6) = IGBL6SAVE
            RETURN
          ELSE
            IF (LIJN(15:15) == ' ') GO TO 20
            IF (LIJN(80:80) == '*') GO TO 20
            BACKSPACE LU
            CYCLE
          END IF
        ELSE
          IF (IGGT(1:4) == 'EXIT') EXIT
          IF (IGGT(1:1) /= ' ' .AND. IGGT(1:1) /= '!') THEN
            IF (IGGT(1:1) == 'N') EXIT
            IF (LRET == 2) THEN
              CALL GEN108 (LU, 0)
              CYCLE
            ELSE
              LINE = IGGT
              CALL GEN038 (IGGT, 1, 80)
            END IF
          END IF
        END IF
      END DO
      CLOSE (UNIT = LU)
C * RESTORE SIDE MENU DISPLAY OPTIONS
      IGBL(6) = IGBL6SAVE
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA235
 
      SUBROUTINE PLA236 (NR, NDEC, VAL1, VAL2, STR1, STR2)
C * SAVE ALERTS TO LU68
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER             :: NR
      INTEGER             :: NUM
      INTEGER             :: NDEC
      INTEGER             :: IVAL1
      INTEGER             :: IVAL2
      INTEGER             :: NDECX
      REAL                :: VAL1
      REAL                :: VAL2
      CHARACTER(len=23)   :: FORMX
      CHARACTER(len=*)    :: STR1
      CHARACTER(len=*)    :: STR2
      CHARACTER(len=NP64) :: STRA
      CHARACTER(len=NP64) :: STRB
      CHARACTER(len=2)    :: CNT
C * OPEN CHECK-OUTPUT FILES (.chk, .ckf)
      IF (IGBL(10) == 0) THEN
        OPEN (UNIT = LU10, FILE = NAMEFIL(1:KNMFIL)//'.chk',
     1    STATUS = 'UNKNOWN')
        OPEN (UNIT = LU13, FILE = NAMEFIL(1:KNMFIL)//'.ckf',
     1    STATUS = 'UNKNOWN', IOSTAT = IOST)
        WRITE (LU13, 99998)
        IGBL(10) = 1
      END IF
      FORMX = '(''_'',I3.3,I2,2F10.2,3A)'
      NUM  = NR
      IF (NUM == 0) THEN
        WRITE (LU68, 99999, IOSTAT = IOST) STR1
      ELSE
        STRA = STR1
        STRB = STR2
C * HANDLE CONTINUATION LINE REQUEST
        IF (NUM > 0) THEN
          CNT = '  '
        ELSE
          NUM  = IABS (NUM)
          CNT = ' ='
        END IF
        IF (NDEC > 0) THEN
          NDECX = MOD (NDEC, 10)
          FORMX(14:19) = '2F10.'//CHAR (ICHAR ('0') + NDECX)
          WRITE (LU68, FORMX, IOSTAT = IOST)
     1      NUM, NDEC, VAL1,  VAL2, STRA, STRB, CNT
        ELSE
          IVAL1 = NINT (VAL1)
          IVAL2 = NINT (VAL2)
          FORMX(14:19) = '2I10 '
          WRITE (LU68, FORMX, IOSTAT = IOST)
     1      NUM, NDEC, IVAL1, IVAL2, STRA, STRB, CNT
        END IF
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT ('PLATON/checkCIF FCF Validation Document', /, 80('='))
      END SUBROUTINE PLA236
 
      SUBROUTINE PLA237 (LU)
C * VALIDATION OVERVIEW
      USE files
      USE parameters
      USE cchar
      USE plato
      USE mentry
      USE cif
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: N
      INTEGER :: LU
      INTEGER                        :: NB
      INTEGER                        :: NE
      INTEGER                        :: N0
      INTEGER                        :: N1
      INTEGER                        :: N2
      INTEGER                        :: MH
      INTEGER                        :: MK
      INTEGER                        :: ML
      INTEGER                        :: JUNK
      INTEGER                        :: IVAL1
      INTEGER                        :: IVAL2
      REAL                           :: WGR
      REAL                           :: YUNK
      REAL                           :: RATIO1
      REAL                           :: RATIO2
      CHARACTER(len=6)               :: CBLNK
      CHARACTER(len=5)               :: WR
      CHARACTER(len=5)               :: SIZE1
      CHARACTER(len=5)               :: SIZE2
      CHARACTER(len=5)               :: SIZE3
      CHARACTER(len=4)               :: TWIN
      CHARACTER(len=10)              :: ZREP
      CHARACTER(len=12)              :: SPLC
      CHARACTER(len=5)               :: TXT0 = '# w=1'
      CHARACTER(len=17)              :: TXT1 = '/[sigma**2(Fo**2)'
      CHARACTER(len=21)              :: TXT2 = ', P=(Fo**2+2*Fc**2)/3'
      CHARACTER(len=9)               :: TXT3 = ', P=Fo**2'
      CHARACTER(len=8)               :: TXT4 = '# w=exp['
      CHARACTER(len=24)              :: TXT5 ='*(sin(theta)/lambda)**2]'
      CHARACTER(len=106)             :: FORMC
      CHARACTER(len=97)              :: FORMD
      CHARACTER(len=17)              :: FPARSU
      CHARACTER(len=24)              :: CIFFCF
      CHARACTER(len=18)              :: RADIATION
      FORMC( 1:38)  = '(''# Cell'',F8.4,''('',I2,'')'',F8.4,''('',I2,'
      FORMC(39:74)  = ''')'',F8.4,''('',I2,'')'',F9.3,''('',I2,'')'','
      FORMC(75:106) = 'F9.3,''('',I2,'')'',F8.3,''('',I2,'')'')'
      FORMC(14:14)  = CHAR (ICHAR ('0') + IPR(287))
      FORMC(30:30)  = CHAR (ICHAR ('0') + IPR(288))
      FORMC(46:46)  = CHAR (ICHAR ('0') + IPR(289))
      FORMC(62:62)  = CHAR (ICHAR ('0') + IPR(290))
      FORMC(78:78)  = CHAR (ICHAR ('0') + IPR(291))
      FORMC(94:94)  = CHAR (ICHAR ('0') + IPR(292))
      FORMD(1:36)   = '(''# Wavelength'',F8.5,2X,''Volume'',1X,'
      FORMD(37:67)  = '''Reported'',F10.3,''('',I4,'')'',1X,'
      FORMD(68:97)  = '''Calculated'',F10.3,''('',I4,'')'')'
      FORMD(52:52)  = CHAR (ICHAR ('0') + IPR(314))
      FORMD(85:85)  = CHAR( ICHAR ('0') + IPR(294))
      FPARSU        = '(F6.2,''('',I2,'')'')'
      CBLNK         = '      '
      IF (IPR(667) == 0) THEN
        CIFFCF = '(From CIF+FCF data)'
      ELSE
        CIFFCF = '(From CIF+FCF-bodd data)'
      END IF
C * LIST HEADER MESSAGE PLATON/CHECK
      WRITE (LU, 99961, IOSTAT = IOST)
      N = MIN (INDEX (JID, ' ') - 1, 16)
      WRITE (LU, 99979) IGBL(4), IGBL(21), JID(1:N)
C * REPORT THE SOURCE OF THE XTAL DATA
      N = MAX (1, KNMFIL + KXT + 1)
      LINE(1:N) = NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT)
      WRITE (PRBUF, 99982, IOSTAT = IOST)
     1  LINE(1:N), DTYPE(IABS (IGBL(8)))(1:3)//XLDTP
      WRITE (PRBUF(50:), 99976, IOSTAT = IOST) BNDTP(1), PAR(318)
      WRITE (LU, 99962, IOSTAT = IOST) PRBUF(1:80)
C * REPORT THE SOURCE OF THE REFLECTION DATA
      WRITE (PRBUF, 99965, IOSTAT = IOST) MAX (0, IPR(310))
      IF (IGBL(36) <= 0) CALL PLA262 (1)
      IF (IGBL(9) > 0 .AND. IGBL(9) < 26) THEN
        WRITE (PRBUF(1:67), 99981, IOSTAT = IOST)
     1    FNLU16(1:KNM16), RDTYP(IGBL(9))
      END IF
      WRITE (LU, 99962, IOSTAT = IOST) PRBUF(1:80)
C * AUDIT
      WRITE (LU, 99972) CCIF(23)(1:NCIF(23))
C * REFIN
      WRITE (LU, 99973) CCIF(22)(1:NCIF(22))
      IF (IABS (IPR(493)) < 6) THEN
        RADIATION = 'X-ray '//KRAD
      ELSE IF (IABS (IPR(493)) == 6) THEN
        IF (KRAD(3:4) == 'Kb') THEN
          RADIATION = 'X-ray '//KRAD
        ELSE
          RADIATION = 'X-ray Synchrotron'
        END IF
      ELSE IF (IABS (IPR(493)) == 7) THEN
        RADIATION = 'Neutron'
      ELSE IF (IABS (IPR(493)) == 8) THEN
        RADIATION = 'Electron'
      END IF
      IF (PAR(197) > 0.0) THEN
        YUNK = MIN (99.99, MAX (PAR(174), PAR(310))) / PAR(197)
      ELSE
        YUNK = 0.0
      END IF
C * CHECK FOR CSD CIF
      IF (IGBL(94) == 0) THEN
        WRITE (LU, 99960, IOSTAT = IOST)
     1    RADIATION, MAX (0.0, PAR(197)), YUNK, PAR(505)
      ELSE
        WRITE (LU, 99952) RADIATION, PAR(173)
      END IF
      NALV(5) = NINT (10000.0 * PAR(318))
C * REPORT THE UNIT CELL DATA AND WAVELENGTH
      WRITE (PRBUF, FORMC, IOSTAT = IOST) PAR(101), IPR(281),
     1  PAR(102), IPR(282), PAR(103), IPR(283), PAR(104),
     2  IPR(284), PAR(105), IPR(285), PAR(106), IPR(286)
      CALL GEN065 (LU, PRBUF, 7, 80, 3)
      WRITE (PRBUF, FORMD, IOSTAT = IOST) MAX (PAR(17), 0.0),
     1  PAR(164), IPR(313), PAR(98), IPR(293)
      CALL GEN065 (LU, PRBUF, 1, 80, 3)
C * REPORT SPACE GROUP DATA
      IF (SPGRNM(3)(1:1) == ' ') THEN
        N0 = 2
      ELSE
        N0 = 1
      END IF
      IF (IGBL(140) == 0) THEN
        SPLC = SPGRNM(1)(15:26)
      ELSE
        SPLC = '?'
      END IF
      CALL GEN020 (-1, SPLC, 2, 12)
      IF (SPLC(1:7) == 'R 3 c r') SPLC(1:7) = 'R 3 c R'
      WRITE (LU, 99980, IOSTAT = IOST) SPLC, SPGRNM(3)(N0:17),
     1  CBLNK(1:4+N0),KRSYST(2), CCIF(6)(1:12),
     2  CCIF(16)(1:18-N0), CBLNK(1:4+N0), KRSYST(1)
C * REPORT MOIETY FORMULA
      CALL PLA283 (0, 1.0, N, CFORM)
      DO N1 = 1, 65
        IF (RLWS(4)(N1:N1) == '''') EXIT
      END DO
      IF (N <= NP52 .AND. N1 > 1) THEN
        IF (IPR(651) == 0) THEN
          WRITE (LU, 99978, IOSTAT = IOST)
     1      CFORM(N:NP52), RLWS(4)(1 : N1 - 1)
        ELSE
          WRITE (LU, 99978, IOSTAT = IOST)
     1      CFORM(N:NP52)//' [+ solvent]', RLWS(4)(1 : N1 - 1)
        END IF
      END IF
C * REPORT SUM FORMULA
      CALL PLA283 (2, FLOAT (IPR(260)), N, CFORM)
      DO N1 = 1, 65
        IF (RLWS(5)(N1:N1) == '''') EXIT
      END DO
      IF (N <= NP52 .AND. N1 > 1) THEN
        IF (IPR(651) == 0) THEN
          WRITE (LU, 99977, IOSTAT = IOST)
     1      CFORM(N:NP52), RLWS(5)(1 : N1 - 1)
        ELSE
          WRITE (LU, 99977, IOSTAT = IOST)
     1      CFORM(N:NP52)//' [+ solvent]', RLWS(5)(1 : N1 - 1)
        END IF
      END IF
C * REPORT MOLECULAR WEIGHT & VOLUME/NonHATOM
      IF (PAR(548) /= 0.0) THEN
        YUNK = PAR(98) / PAR(548)
      ELSE
        YUNK = 0.0
      END IF
      WRITE (LU, 99989, IOSTAT = IOST)
     1  PAR(163) / IPR(260), PAR(308), NINT (YUNK)
C * REPORT DENSITY & VOLUME/ATOM (CORRECTED FOR VOID)
      IF (YUNK /= 0.0) THEN
        WRITE (PRBUF, 99987, IOSTAT = IOST) PAR(160), PAR(267),
     1    NINT ((PAR(98) - MAX (PAR(549), PAR(437))) / PAR(548))
      END IF
C * CHECK FOR LARGEST VOID
      IF (PAR(289) > 20.0 .OR. PAR(437) > 0.0) THEN
        WRITE (LU, 99962) PRBUF(1:80)
      ELSE
        WRITE (LU, 99962) PRBUF(1:46)
      END IF
C * REPORT Z
      IF (ABS (PAR(568) - IPR(276)) > 0.001) THEN
        WRITE (ZREP, 99963) PAR(568)
      ELSE
        WRITE (ZREP, 99964) IPR(276)
      END IF
      WRITE (PRBUF, 99988, IOSTAT = IOST) IPR(260), ZREP,
     1  NINT (MAX (PAR(549), PAR(437)) * 100.0 / PAR(98))
      IF (PAR(289) > 20.0 .OR. PAR(437) > 0.0) THEN
        WRITE (LU, 99962) PRBUF(1:80)
      ELSE
        WRITE (LU, 99962) PRBUF(1:47)
      END IF
C * REPORT MU (CALC AND REPORTED)  AND CRYSTAL SIZE
      IF (PAR(302) < 10.0 .AND. PAR(303) < 10.0 .AND. PAR(304) < 10.0)
     1  THEN
        WRITE (SIZE1, 99950) MAX(PAR(304), 0.0)
        WRITE (SIZE2, 99950) MAX(PAR(303), 0.0)
        WRITE (SIZE3, 99950) MAX(PAR(302), 0.0)
      ELSE
        WRITE (SIZE1, 99949) NINT(MAX(PAR(304), 0.0))
        WRITE (SIZE2, 99949) NINT(MAX(PAR(303), 0.0))
        WRITE (SIZE3, 99949) NINT(MAX(PAR(302), 0.0))
      END IF
      WRITE (LU, 99998, IOSTAT = IOST) PAR(162), PAR(301), SIZE1,
     1 SIZE2, SIZE3
C * REPORT F(000)
      WRITE (LU, 99975, IOSTAT = IOST) PAR(157), PAR(324), PAR(426)
C * REPORTED TRANSMISSIONS
      IF (PAR(306) < 99998.0 .AND.
     1    PAR(307) < 99998.0) THEN
        IF (IGBL(36) <= 0) CALL PLA262 (1)
        N = INDEX (RLWS(3)(2:15), '''')
        IF (N > 1) THEN
          N1 = 2
          N2 = N
        ELSE
          N1 = 1
          N2 = 2
        END IF
C * TEST FOR LAUE EXPERIMENT (=1)
        IF (IPR(106) == 0) WRITE (LU, 99997, IOSTAT = IOST)
     1    PAR(307), PAR(306), RLWS(3)(N1:N2)
      END IF
C * CALCULATED TRANSMISSIONS (FOR NON-CSD CIF ONLY)
      IF (IGBL(94) == 0 .AND. IPR(105) == 0 .AND.
     1    IPR(106) .EQ.0) THEN
        IF (IGBL(36) <= 0) CALL PLA262 (1)
        IF (PAR(315) == 0.0) THEN
          IF (PAR(229) > 0.0) WRITE (LU, 99983) PAR(229)
        ELSE IF (PAR(315) > 0.0) THEN
          IF (PAR(229) > 0.0) THEN
            WRITE (LU, 99999, IOSTAT = IOST)
     1        PAR(315), PAR(316), PAR(317), PAR(229)
          ELSE
            WRITE (LU, 99971, IOSTAT = IOST)
     1      PAR(315), PAR(316), PAR(317)
          END IF
        END IF
      END IF
C * REPORT ON TWINNING [RES AND/OR CIF]
      IF (IPR(619) == 1 .OR. (IPR(781) > 0 .AND. IPR(782) > 0)) THEN
        TWIN = 'TWIN'
      ELSE
        TWIN = '    '
      END IF
C * REPORT NUMBER OF MEASURED REFLECTIONS
      IF (IPR(321) > 0 .OR. IPR(753) > 0) THEN
        WRITE (LU, 99990) MAX (IPR(262), 0),
     1    ', CIF-loop', MAX (IPR(321), IPR(753)), PAR(558), TWIN
      ELSE
        IF (IGBL(94) == 0) WRITE (LU, 99990) MAX (IPR(262), 0),
     1    ', Embedded', IPR(742), PAR(558), TWIN
      END IF
C * REPORT ON REPORTED H,K,L-MAX
      MH = MAX (0, -IPR(267), IPR(268))
      MK = MAX (0, -IPR(269), IPR(270))
      ML = MAX (0, -IPR(271), IPR(272))
      IF (IGBL(94) == 0 .AND. IPR(263) > 0) THEN
      IF (IGBL(36) <= 0) CALL PLA262 (1)
        WRITE (LU, 99986, IOSTAT = IOST) MH, MK, ML,
     1    MAX (0, IPR(263)), MAX (0.0, PAR(168))
      END IF
C * REPORT ON OBSERVED AND CALCULATED H,K,L RANGES
      IF (IPR(559) /= 0) THEN
        RATIO1 = FLOAT (MAX (0, IPR(263))) / IPR(559)
      ELSE
        RATIO1 = 0.0
      END IF
      IF (IPR(559) + IPR(560) /= 0) THEN
        RATIO2 = FLOAT (MAX (0, IPR(263))) / (IPR(559) + IPR(560))
      ELSE
        RATIO2 = 0.0
      END IF
      IF (IGBL(9) > 0 .AND. IPR(373) > 0) THEN
        IF (IGBL(9) < 26) THEN
          IF (IGBL(36) <= 0) CALL PLA262 (1)
          WRITE (LU, 99968, IOSTAT = IOST) (MIN (999, IPR(584 + I)),
     1      I = 1, 3), IPR(373), IPR(377), PAR(446)
        END IF
      END IF
C * CHECK FOR 'NON-CSD' CIF
      IF (IGBL(94) == 0 .AND. IPR(559) > 0) THEN
C * CHECK FOR LAUE
        IF (IPR(106) == 0) THEN
C * ICENTR CHECK
          IF (IPR(257) == 1 .AND. IPR(275) /= 2) THEN
                    IF (IGBL(36) <= 0) CALL PLA262 (1)
            WRITE (LU, 99985, IOSTAT = IOST) IPR(561), IPR(562),
     1        IPR(563), IPR(559) + IPR(560), IPR(559), RATIO1, RATIO2
          ELSE
            WRITE (LU, 99969, IOSTAT = IOST)
     1        IPR(561), IPR(562), IPR(563), IPR(559), RATIO1
          END IF
        END IF
      END IF
C * REPORT ON Refinement Data
C * CHECK TOTAL SQUEEZE VOLUME (PLATON & OLEX2
      IF (PAR(437) > 0.0 .OR. PAR(469) > 0.0) THEN
        IF (IGBL(36) <= 0) CALL PLA262 (1)
        JUNK = MOD (IPR(651), 10)
        IF (JUNK == 1) THEN
          PRBUF = '# SQUEEZE:  Total SQUEEZED Volume = '
          IVAL1 = NINT (PAR(437))
          IVAL2 = NINT (PAR(438))
        ELSE IF (JUNK == 2) THEN
          PRBUF = '# OLEX2/_smtbx_masks Total Volume = '
          IVAL1 = NINT (PAR(469))
          IVAL2 = NINT (PAR(470))
        ENDIF
        IF (JUNK > 0 .AND. JUNK < 3)
     1    WRITE (LU, 99957, IOSTAT = IOST) PRBUF(1:36), IVAL1, IVAL2
      END IF
      IF (ABS (PAR(173)) < 100.0) THEN
        IF (IPR(309) == 2) THEN
          WR  = ' wR2='
          WGR = MIN (99.99, PAR(174))
        ELSE
          WR  = '  wR='
          WGR = MIN (99.99, MAX (PAR(174), PAR(310)))
        END IF
        FPARSU(5:5) = CHAR (ICHAR ('0') + IPR(280))
        WRITE (PRBUF, FPARSU, IOSTAT = IOST) PAR(433), IPR(279)
        CALL GEN065 (0, PRBUF, 1, 10, 1)
        WRITE (IDM, 99984, IOSTAT = IOST) PAR(173), MAX (0, IPR(264)),
     1    WR, WGR, MAX (0, IPR(265), IPR(765)),
     2    MAX (0.0, MIN (99.99, PAR(299))), MAX (0, IPR(266)),
     3    PRBUF(1:10)
C * TEST FOR CSD-CIF
        IF (IGBL(94) == 0) THEN
          IF (IGBL(36) <= 0) CALL PLA262 (2)
        IF (PAR(176) <= 0.0 .AND. PAR(177) >= 0.0)
     1    WRITE (LU, 99958, IOSTAT = IOST)
     2      MIN (0.0, PAR(176)), MAX (0.0, PAR(177))
        IF (IGBL(9) > 0 .AND. IGBL(9) < 26) THEN
          IF (PAR(330) > 0.0) THEN
C * CHECK FOR TWINNING (IPR(619) =1) OR non Cu, Ga, Mo, Ag, In, (IPR(493) > 6)
            IF (IPR(619) == 0) THEN
              CALL PLA262 (1)
              WRITE (LU, 99967, IOSTAT = IOST) PAR(329), PAR(330),
     1          CIFFCF
            END IF
          END IF
        END IF
        IF (IPR(698) /= 0) THEN
          IF (PAR(501) > 99999.0) THEN
            WRITE (LU, 99951) PAR(501), PAR(502)
          ELSE
            WRITE (LU, 99974) PAR(501), PAR(502)
          END IF
        END IF
C * TEST FOR SHELXL=1,JANA=2,CRYSTALS=3, MOPRO=4
        IF (IPR(632) > 0) THEN
C * REPORT WEIGHTING SCHEME (SHELXL OR JANA)
          IF (IABS(IPR(632)) == 1) THEN
            PRBUF = RLWS(1)(1:132)
            N  = INDEX (PRBUF(2:), '''')
            CALL GEN020 (1, PRBUF, 1, N)
            NB = INDEX (PRBUF, 'CALC ')
            IF (NB == 0) THEN
              NB = 2
            ELSE
              NB = 7
            END IF
            RLWS(0)(1:N - NB + 1) = PRBUF(NB:N)
            N = N - (NB - 1)
            NW = INDEX (RLWS(0), ' WHERE ')
            PRBUF = '# '//RLWS(0)(1:NW-1)//', '//
     1                    RLWS(0)(NW+7:N)
            N  = MIN (80, N - 3)
            NW = INDEX (PRBUF, 'W')
            IF (NW > 0) PRBUF(NW:NW) = 'w'
            NW = INDEX (PRBUF, 'S^')
            IF (NW > 0) PRBUF(NW:NW) = 's'
            NW = INDEX (PRBUF, 'Q')
            IF (NW > 0) PRBUF(NW:NW) = 'q'
            NW = INDEX (PRBUF, 'Q')
            IF (NW > 0) PRBUF(NW:NW) = 'q'
            NW = INDEX (PRBUF, 'L')
            IF (NW > 0) PRBUF(NW:NW) = 'l'
            NW = INDEX (PRBUF, 'L')
            IF (NW > 0) PRBUF(NW:NW) = 'l'
            NW = INDEX (PRBUF, 'FO')
            IF (NW > 0) PRBUF(NW:NW + 1) = 'Fo'
            NW = INDEX (PRBUF, 'FO')
            IF (NW > 0) PRBUF(NW:NW + 1) = 'Fo'
            NW = INDEX (PRBUF, 'FC')
            IF (NW > 0) PRBUF(NW:NW + 1) = 'Fc'
            NW = INDEX (PRBUF, 'EXP')
            IF (NW > 0) PRBUF(NW:NW + 2) = 'exp'
            NW = INDEX (PRBUF, 'SIN')
            IF (NW > 0) PRBUF(NW:NW + 2) = 'sin'
            NW = INDEX (PRBUF, 'SIN')
            IF (NW > 0) PRBUF(NW:NW + 2) = 'sin'
            RLWS(0)(1:N) = PRBUF(1:N)
            WRITE (LU, 99962) RLWS(0)(1:N)
C * CRYSTALS
          ELSE IF (IPR(632) == 3) THEN
            IF (PAR(498) == 1.0) TXT2 = TXT3
            IF (PAR(493) > 0.0) THEN
              IF (PAR(494) /= 0.0) THEN
                IF (PAR(495) > 0.0) THEN
                  WRITE (LU, 99955, IOSTAT = IOST) TXT4, PAR(495), TXT5,
     1              TXT1, PAR(493), PAR(494)
                ELSE
                  WRITE (LU, 99992, IOSTAT = IOST)
     1              TXT0, TXT1, PAR(493), PAR(494), TXT2
                END IF
              ELSE
                IF (PAR(495) > 0.0) THEN
                  WRITE (LU, 99956, IOSTAT = IOST)
     1              TXT4, PAR(495), TXT5, TXT1, PAR(493), TXT2
                ELSE
                  WRITE (LU, 99993, IOSTAT = IOST)
     1              TXT0, TXT1, PAR(493), TXT2
                END IF
              END IF
            ELSE IF (PAR(493) == 0.0) THEN
              IF (PAR(494) > 0.0) THEN
                WRITE (LU, 99994, IOSTAT = IOST)
     1            TXT0, TXT1, PAR(494), TXT2
              ELSE
                WRITE (LU, 99996, IOSTAT = IOST)
     1            TXT0, TXT1, TXT2
              END IF
            END IF
C * JANA WEIGHT PARAMETER
          ELSE IF (IPR(632) == 2) THEN
            WRITE (LU, 99959, IOSTAT = IOST) PAR(493)
C * MOPRO WEIGHT
          ELSE IF (IPR(632) == 4) THEN
            NE = INDEX(RLWS(1), '''')
            WRITE (LU, 99995, IOSTAT = IOST) RLWS(1)(1:NE-1)
C * CRYSTALS _refln_refinement_weight
          ELSE IF (IPR(632) == 5) THEN
            WRITE (LU, 99991, IOSTAT = IOST)
          ENDIF
C * TEST 'R1 from FCF' VALUE
          IF (PAR(477) /= 0.0) THEN
C * CHECK FOR TWINNING (IPR(619) = 1)
            IF (IPR(619) == 0  .AND. IPR(779) == 0 .AND.
     1         (IPR(725) > 0 .OR. IGBL(9) == 1)) THEN
C * CHECK FOR JANA WEIGHT (2) OR NO EXTINCTION
              CALL PLA262 (1)
              IF (IPR(651) == 0 .OR. IPR(665) < 0) THEN
C * TEMP SOLUTION
                IF (PAR(480) > 0.0) THEN
                  WRITE (LU, 99970, IOSTAT = IOST) PAR(480), IPR(625),
     1              MIN (99.9999, PAR(481)), IPR(626), MIN (99.999,
     2              PAR(482)), CIFFCF
                END IF
              END IF
C * FCF-CHECK
              IF (IGBL(129) /= 0 .AND. IPR(651) == 0 .OR.
     1          IPR(665) < 0) THEN
                WRITE (LU13, 99961, IOSTAT = IOST)
                WRITE (LU13, 99970, IOSTAT = IOST)
     1          PAR(480), IPR(625), MIN (99.9999,
     2          PAR(481)), IPR(626), MIN (99.999,
     3          PAR(482)), CIFFCF
              END IF
            END IF
            CALL PLA262 (1)
            WRITE (LU, 99970, IOSTAT = IOST) PAR(477),
     1        IPR(623), MIN (99.9999, PAR(478)), IPR(624),
     2        MIN (99.999, PAR(479)), '(From FCF data only)'
            IF (IGBL(129) /= 0) WRITE (LU13, 99970, IOSTAT = IOST)
     1        PAR(477), IPR(623), MIN (99.9999, PAR(478)), IPR(624),
     2        MIN (99.999, PAR(479)), '(From FCF data only)'
          END IF
        END IF
C * CHECK FOR SUPPLIED FLACK VALUE AND OFFSET FROM INVERSION CENTER
        IF (PAR(433) < 999999 .AND. IPR(257) == 1 .AND.
     1    IPR(275) /= 2) THEN
          WRITE (LU, 99962, IOSTAT = IOST) IDM(1:80)
          IF (IGBL(129) /= 0)
     1      WRITE (LU13, 99962, IOSTAT = IOST) IDM(1:80)
        ELSE
          WRITE (LU, 99962, IOSTAT = IOST) IDM(1:63)
          IF (IGBL(129) /= 0)
     1      WRITE (LU13, 99962, IOSTAT = IOST) IDM(1:63)
          END IF
        END IF
      END IF
C * PARSONS-Z
      IF (PAR(503) < 999999.0) THEN
        FPARSU(5:5) = CHAR (ICHAR ('0') + IPR(670))
        WRITE (PRBUF, FPARSU, IOSTAT = IOST) PAR(503), IPR(669)
        CALL GEN065 (0, PRBUF, 1, 10, 1)
C * CHECK FOR TWINNING AND BIJVOET PAIR COVERAGE
        IF (IPR(619) == 0 .AND. PAR(464) > PAR(476)) THEN
          WRITE (LINE, 99954, IOSTAT = IOST) IPR(668),
     1      NINT (PAR(464)), IPR(750),  PRBUF(1:10)
          WRITE (LU, 99962, IOSTAT = IOST) LINE(1:80)
          IF (IGBL(129) /= 0)
     1      WRITE (LU13, 99962, IOSTAT = IOST) LINE(1:80)
        END IF
      END IF
C * HOOFT Y
      IF (PAR(435) < 999999.0) THEN
        FPARSU(5:5) = CHAR (ICHAR ('0') + IPR(616))
        WRITE (PRBUF, FPARSU, IOSTAT = IOST) PAR(435), IPR(615)
        CALL GEN065 (0, PRBUF, 1, 10, 1)
C * CHECK FOR TWINNING AND BIJVOET PAIR COVERAGE
        IF (IPR(619) == 0 .AND. PAR(464) > PAR(476)) THEN
          WRITE (LINE, 99966, IOSTAT = IOST)
     1      PAR(506), PAR(507), PAR(508), NINT (PAR(487)), PRBUF(1:10)
C * CHECK FOR P2(true)
          IF (PAR(506) < 0.0 .OR. PAR(507) < 0.001)
     1      CALL GEN038 (LINE, 2, 15)
C * CHECK FOR P3(true) - HANDLE (n/a)
          IF (PAR(507) < 0.0) CALL GEN038 (LINE, 16, 28)
C * CHECK FOR P3(tw)   - HANDLE (n/a)
          IF (PAR(508) < 0.0) CALL GEN038 (LINE, 29, 43)
          WRITE (LU, 99962, IOSTAT = IOST) LINE(1:80)
          IF (IGBL(129) /= 0) THEN
            WRITE (LU13, 99962, IOSTAT = IOST) LINE(1:80)
            WRITE (LU13, 99961, IOSTAT = IOST)
          END IF
        END IF
      END IF
C * DOCUMENTATION NOTE
      WRITE (LU, 99953, IOSTAT = IOST) HTTPSERVER(1:IGBL(135))
 
      RETURN
99999 FORMAT ('# Calculated T Limits: Tmin=', F5.3, ' Tmin''=', F5.3,
     1       '  Tmax=', F5.3, 2X, 'Exti    =', F12.5)
99998 FORMAT ('# Mu (mm-1) =', F10.3, '[Calc],', F10.3, '[Rep]', 2X,
     1        'Xtal Size =  ', A, 'x', A, 'x', A, ' mm')
99997 FORMAT ('# Reported   T Limits: Tmin=', F5.3,
     1       14X, 'Tmax=', F5.3, 2X, 'AbsCorr = ', A)
99996 FORMAT (3A)
99995 FORMAT ('#', A)
99994 FORMAT (2A, '+', F9.4,'P]', A)
99993 FORMAT (2A, '+(', F6.4, 'P)**2]', A)
99992 FORMAT (2A, '+(', F6.4, 'P)**2+', F8.4,'P]', A)
99991 FORMAT ('# Reflection weights from _refln_refinement_weight')
99990 FORMAT ('# Measured   HKL: Reported', I7, A, I7,
     1        ', <Mult>', F5.1, 13X, A)
99989 FORMAT ('# Mr        =', F10.2, '[Calc],', F10.2, '[Rep]', 7X,
     1 'Volume/NonHatoms =', I3, ' Ang**3')
99988 FORMAT ('# Z         =', I10  , '[Calc],',   A,   '[Rep]', 2X,
     1 'Solvent Accessible Volume =', I5,'%')
99987 FORMAT ('# Dx,gcm-3  =', F10.3, '[Calc],', F10.3, '[Rep]', 1X,
     1 'Model_Volume/NonHatoms =', I3, ' Ang**3')
99986 FORMAT ('# Reported   Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I7, 8X, ', Th(max)=', F7.3)
99985 FORMAT ('# Expected   Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I7, '[', I6, '], Ratio=', F4.2, '/', F4.2)
99984 FORMAT ('# R=', F7.4, '(', I6, '),', A, F7.4, '(', I6, '), S =',
     1        F6.3, ', Npar=', I5, ', Flack', A)
99983 FORMAT ('#',58X, 'Exti    =', F12.5)
99982 FORMAT ('# Data: ', A, ' - Type: ', A)
99981 FORMAT ('# Refl: ', A, ' - Type: ', A)
99980 FORMAT ('# SpaceGroup from Symmetry ', A, 1X, 'Hall: ', 3A,
     1     /, '#                 Reported ', A, 7X, 3A)
99979 FORMAT ('# PLATON/CHECK-(', I6, ') versus check.def version',
     1        I7, ', Entry: ', A)
99978 FORMAT ('# MoietyFormula ', A, /, '#      Reported ', A)
99977 FORMAT ('#    SumFormula ', A, /, '#      Reported ', A)
99976 FORMAT ('Bond Precision ', A, ' =', F7.4, ' A')
99975 FORMAT ('# F000      =', F10.1, '[Calc],', F10.1, '[Rep]',
     1        '  or F000'' =', F10.2, '[Calc]')
99974 FORMAT ('# SWAT ', 2F12.6)
99973 FORMAT ('# Refin:', A)
99972 FORMAT ('# Audit:', A)
99971 FORMAT ('# Calculated T Limits: Tmin=', F5.3, ' Tmin''=', F5.3,
     1       '  Tmax=', F5.3)
99970 FORMAT ('# R=', F7.4, '(', I6, '), wR2=', F7.4, '(', I6, '), S =',
     1        F6.3, 5X, A)
99969 FORMAT ('# Expected   Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I7, 8X, ', Ratio  =', F7.3)
99968 FORMAT ('# Obs in FCF Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I7, '[', I6, '], Th(max)=', F7.3)
99967 FORMAT ('# Calculated Rho(min) =', F6.2, ', Rho(max) =', F5.2,
     1        ' e/Ang**3 ', A )
99966 FORMAT ('# P2(tr)', F6.3, ', P3(tr)', F6.3, ', P3(tw)', F6.3,
     1 ', Student-T Nu = ', I3, ',  Hooft', A)
99965 FORMAT ('#', 67X, 'Temp =', I4, ' K')
99964 FORMAT (I10)
99963 FORMAT (F10.3)
99962 FORMAT (A)
99961 FORMAT ('#', 79('='))
99960 FORMAT ('# ', A,  6X, 'R(int) =', F6.3 , ',', 2X, 'wR2/R(int) =',
     1        F5.1, ',', 2X, 'Nref/Npar =', F6.1)
99959 FORMAT ('# w=1/(sigma**2(I)+', F7.4, 'I**2) - (JANA)')
99958 FORMAT ('# Reported   Rho(min) =', F6.2, ', Rho(max) =', F5.2,
     1        ' e/Ang**3 (From CIF)')
99957 FORMAT (A, I8, ' Ang**3, Total El.Count =', I8, ' e-')
99956 FORMAT (A, F6.4, 2A, '+(', F6.4, 'P)**2]', A)
99955 FORMAT (A, F6.4, 2A, '+(', F6.4, 'P)**2+', F8.4,'P]')
99954 FORMAT ('# Number Bijvoet Pairs =', I5, ' (', I3, '%),', 5X,
     1 I5, ' Selected for:  Parsons', A)
99953 FORMAT ('#', 79('='), /, '# For Documentation:',
     1 A, 'CIF-VALIDATION.pdf')
99952 FORMAT ('# ', A, 6X, 'R =', F6.3)
99951 FORMAT ('# SWAT ', F12.2, F12.6)
99950 FORMAT (F5.3)
99949 FORMAT (I5)
      END SUBROUTINE PLA237
 
 
 
 
 
 
 
 
 
 
 
C STRIP_END
 
      MODULE map
      SAVE
      INTEGER, PARAMETER                :: NCT0 = 5000
      INTEGER, PARAMETER                :: NCT1 = 1000000
      INTEGER, PARAMETER                :: NCT2 = 6
      INTEGER, PARAMETER                :: NCT4 = 200
      INTEGER, PARAMETER                :: NCT5 = 2000
      INTEGER, PARAMETER                :: NCT6 = 100
      INTEGER, PARAMETER                :: NCT7 = NCT6 + 1
      INTEGER, PARAMETER                :: NCT8 = 5000
      INTEGER, PARAMETER                :: NCT9 = 2000
      INTEGER                           :: NN
      INTEGER                           :: NS
      INTEGER                           :: NT
      INTEGER                           :: NE
      INTEGER                           :: MX
      INTEGER                           :: MY
      INTEGER                           :: IX
      INTEGER                           :: IY
      INTEGER                           :: IV
      INTEGER                           :: IC
      INTEGER                           :: L7
      INTEGER                           :: N7
      INTEGER                           :: NST
      INTEGER                           :: NAX
      INTEGER                           :: NAT
      INTEGER                           :: JVX
      INTEGER                           :: JVY
      INTEGER                           :: INX
      INTEGER                           :: IXY
      INTEGER                           :: NS7
      INTEGER                           :: NE7
      INTEGER                           :: NXP
      INTEGER                           :: NXM
      INTEGER                           :: NYP
      INTEGER                           :: NYM
      INTEGER                           :: IHM
      INTEGER                           :: IKM
      INTEGER                           :: ILM
      INTEGER                           :: MODE
      INTEGER                           :: LRTN
      INTEGER                           :: ICENT
      INTEGER                           :: NRSECT
      INTEGER                           :: NSECTIONS
      INTEGER, DIMENSION(3, NCT0)       :: IFLG
      INTEGER, DIMENSION(4, NCT8)       :: IMPC
      INTEGER, DIMENSION(2, NCT4, NCT4) :: IEXX
      INTEGER, DIMENSION(NCT0)          :: LATOM
      INTEGER, DIMENSION(12) :: IRANGE =
     1 (/10, 20, 50, 100, 200, 500, 1000, 2000, 5000, 10000, 20000,
     2   50000/)
      INTEGER, DIMENSION(6, 6, 2) :: ID = RESHAPE
     1 ((/ 0, 0, 0, 1, 2, 4,   0,-1, 0, 0, 2, 6,   0,-1, 1,-1, 1, 6,
     2     1,-1, 1, 0, 2, 1,   1, 0, 1, 1, 2, 3,   0, 1, 1, 1, 1, 3,
     3    -1, 1, 0, 1, 1, 4,  -1, 0,-1, 1, 2, 5,  -1, 0, 0, 0, 1, 5,
     4     0, 0, 1, 0, 1, 1,   1, 0, 1, 1, 2, 2,   0, 1, 1, 1, 1, 2/),
     5    (/6, 6, 2/))
      REAL                            :: X
      REAL                            :: Y
      REAL                            :: Z
      REAL                            :: PXS
      REAL                            :: PYS
      REAL                            :: PHI
      REAL                            :: OFF
      REAL                            :: XPOS
      REAL                            :: YPOS
      REAL                            :: STEP
      REAL                            :: F000
      REAL                            :: SCHAAL
      REAL,    DIMENSION(3, 5)        :: FC
      REAL,    DIMENSION(3, 4)        :: XN
      REAL,    DIMENSION(3)           :: XFO
      REAL,    DIMENSION(3)           :: ULC
      REAL,    DIMENSION(3)           :: DXF
      REAL,    DIMENSION(3)           :: DYF
      REAL,    DIMENSION(12, NCT6)    :: PAX
      REAL,    DIMENSION(2, NCT5)     :: QAX
      REAL,    DIMENSION(NCT6, NCT7)  :: SMA
      REAL,    DIMENSION(NCT8, NCT2)  :: XMPC
      REAL,    DIMENSION(NCT4, NCT4)  :: FMAP
      REAL,    DIMENSION(4, NCT9)     :: XMCT
      REAL,    DIMENSION(3, NCT0)     :: ATOM
      REAL,    DIMENSION(4)           :: VLAK
      REAL,    DIMENSION(3, 3)        :: FMAT
      REAL,    DIMENSION(3, 3)        :: CMAT
      REAL,    DIMENSION(NCT1)        :: COEF
      REAL,    DIMENSION(3)           :: RANDS
      CHARACTER(len=255)              :: PLPATH
      CHARACTER(len=62), DIMENSION(8) :: TXT = (/
     1 'Key/Click Point (Label or x,y,z)  def. the map x-axis [1 0 0] ',
     2 'Key/Click Point (Label or x,y,z)  def. the map origin [0 0 0] ',
     3 'Key/Click 3rd point (Label or x,y,z) in the map plane [0 1 0] ',
     4 'Key/Click 1st point (Label or x,y,z)    on the normal [0 0 0] ',
     5 'Key/Click 2nd point (Label or x,y,z)    on the normal [0 1 0] ',
     6 'Key/Click 3rd point (Label or x,y,z)    in the plane  [0 0 0] ',
     7 'Give the 4 coeff. of the equation ax + by + cz = d [fract.]   ',
     8 'The Ax-System must now be def. (Opt. Excl. Atoms from SF-Calc)'
     9 /)
      END MODULE map
 
      SUBROUTINE PLA250
C * CREATE CONTOURED ELECTRON (DIFFERENCE) DENSITY MAP FOR GENERAL SECTIONS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE map
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IB
      INTEGER :: IS
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: IENM
      INTEGER :: NTXT
      INTEGER :: IVAL
      INTEGER :: INQNR
      INTEGER :: NASUP
      INTEGER :: JYDUM
      INTEGER :: IPR414
      INTEGER :: IPR416
      REAL    :: D2
      REAL    :: DET
      REAL    :: ANGL
      REAL    :: XLNG
      REAL    :: GEN017
      REAL    :: GEN009
      WRITE (LU6, 99995)
      M         = 0
      LRTN      = 0
      MODE      = 0
      NRSECT    = 0
      NSECTIONS = 0
      CALL GEN038 (PLPATH, 1, 255)
C * THE CONTOUR MAP INSTRUCTION/PLOTTING LOOP
      DO
        CALL PLA251
C * MODE = 1 - INTERPRETE NEW (INTERACTIVE) INSTRUCTION
        IF (MODE == 1) THEN
          SELECT CASE (LRTN)
C * LRTN = 1 - END, QUIT, EXIT
            CASE (1)
              EXIT
C * LRTN = 2 -UP, DOWN, NONE
            CASE (2)
              GO TO 70
C * LRTN = 3 - PT, FO, FS, SQ
            CASE (3)
              GO TO 40
C * LRTN = 4 - PLANE TYPE DEFINITION
            CASE (4)
C * LRTN = 5 - GET NEW INSTRUCTION
            CASE (5)
              CYCLE
C * LRTN = 6 - USER SET CONTOUR LEVEL
            CASE (6)
              CYCLE
C * LRTN = 7 - Fourier3D File Generation
            CASE (7)
              GO TO 70
C * Other
            CASE DEFAULT
              EXIT
          END SELECT
        END IF
C * PLANE DEFAULTS
C * IPR(415) = 0/1 - USE ORTEP FOR PLANE DEFINITION ?
   10   IF (IPR(415) >= 0) THEN
C * FOR NON-SQUEEZE-MAP CASE ..
          IF (IPR(414) /= 4) THEN
C * SET ENVELOPE ELLIPSOID OUTLINE
            IPR(211) = 1
C * COLOR ON
            IPR(346) = 1
C * SET CONTOUR OPTEP ON
            IPR(415) = 1
C * LABELS ON
            IGBL(75) = 1
C * ORTEP DISPLAY/INPUT - NOT FOR PATT
            IF (IPR(414) /= 5) THEN
C * CALL ORTEP
              CALL PLA106
            ELSE
              CALL GGIP (HORS, VERT, 0.0, 1)
            END IF
          END IF
C * RECOVER ROR (MODIFIED IN PLA106)
          CALL GEN003 (OR, ROR, DET, 0)
        END IF
C * INIT
        CALL GEN021 (FMAT, 0.0)
        CALL GEN074 (VLAK, 1, 4, 0.0)
C * SELECT Q/Z/Y/X (COORDINATES AS COLUMNS
        SELECT CASE (IPR(420))
C * Q - TO BE DEFINED EXPLICITLY BELOW
          CASE (0)
            FMAT(1, 1) = 1.0
            FMAT(2, 3) = 1.0
            VLAK(3)    = 1.0
            IB         = 1
C *  X-O-Y PLANE SELECTED
          CASE (1)
            FMAT(1, 1) = 1.0
            FMAT(2, 3) = 1.0
            VLAK(3)    = 1.0
            IB         = 4
C *  X-O-Z PLANE SELECTED
          CASE (2)
            FMAT(1, 1) = 1.0
            FMAT(3, 3) = 1.0
            VLAK(2)    = 1.0
            IB         = 4
C *  Y-O-Z PLANE SELECTED
          CASE DEFAULT
            FMAT(2, 1) = 1.0
            FMAT(3, 3) = 1.0
            VLAK(1)    = 1.0
            IB         = 4
        END SELECT
C * SAVE SETTINGS TO DETECT CHANGES
        IPR416 = IPR(416)
        IPR414 = IPR(414)
C * DEFINE THE PLANE TYPE
   20   DO I = IB, 4
   30     SELECT CASE (IPR(416))
C * 0 - PLANE DEFINED BY 3 POINTS (HORIZ)
            CASE (0)
              IF (I < 4) THEN
                M    = I
                NTXT = I
              ELSE
                CYCLE
              END IF
C * 1 - Plane defined by ax + by + cz = d
            CASE (1)
              SELECT CASE (I)
                CASE (1)
                  NTXT = 7
                CASE (2)
                  M    = 1
                  NTXT = 1
                CASE (3)
                  M    = 2
                  NTXT = 2
                CASE DEFAULT
                 CYCLE
              END SELECT
C * 2 -  Rt. bisector of line between 2 pts. $ 3rd pt. for x-axis
            CASE (2)
              SELECT CASE (I)
                CASE (1)
                  M    = 1
                  NTXT = 1
                CASE (2)
                  M    = 2
                  NTXT = 4
                CASE (3)
                  M    = 3
                  NTXT = 5
                CASE DEFAULT
                  CYCLE
              END SELECT
C * 3 - Plane through 2 points, normal defined by a 3rd point
            CASE (3)
              SELECT CASE (I)
                CASE (1)
                  M    = 1
                  NTXT = 1
                CASE (2)
                  M    = 2
                  NTXT = 6
                CASE (3)
                  M    = 3
                  NTXT = 3
                CASE DEFAULT
                  CYCLE
              END SELECT
C * 4 - Plane XY/YZ/XZ
            CASE (4)
              CYCLE
C * CATCH OTHER
            CASE DEFAULT
              GO TO 20
          END SELECT
C * CHECK FOR ATOM-OMIT STATUS
          IF (IPR(182) == 0) THEN
            IF (IGBL(25) * IGBL(32) == 1) THEN
              SBCD = TXT(8)//CHAR (0)
              CALL GGIP (-999.0, 3.0, 79.0, 112)
              SBCD = TXT(NTXT)//CHAR (0)
            ELSE
              WRITE (LU6, 99999, ADVANCE = 'NO', IOSTAT = IOST)
     1          TXT(NTXT)
            END IF
          END IF
C * Find out if the input is an atom name, an atom number or atom coords
          IPR(439) = 0
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          IF (LRET == 3) GO TO 10
          SELECT CASE (IGGT(1:4))
            CASE ('****')
              GO TO 30
            CASE ('PLOT', 'EPS ')
              GO TO 10
            CASE ('Q   ', 'QUIT', 'END ', 'EXIT')
              IGBL(6) = 10
              RETURN
          END SELECT
C * CHECK FOR CHANGED MAP TYPE
          IF (IPR(414) /= IPR414) GO TO 10
C * CHECK FOR CHANGED PLANE TYPE
          IF (IPR(416) /= IPR416) GO TO 10
          CALL PLA006 (0, IS)
C * CHECK FOR ROTATION (ORTEP)
          IF (IFL(1)(2:4) == 'ROT') THEN
            IF (IFL(1)(1:1) == 'X') THEN
              N = -1
            ELSE IF (IFL(1)(1:1) == 'Y') THEN
              N = -2
            ELSE
              N = -3
            END IF
            IF (IPR(221) > 0) THEN
              ANGL = - FN(1) / RGBL(6)
            ELSE
              ANGL = - 10.0  / RGBL(6)
            END IF
C * GENERATE UNIT MATRIX (DET = IGBL(87))
            CALL GEN021 (RMAT, FLOAT(IGBL(87)))
C * RECREATE ORIENTATION MATRIX
            DO L = 1, 3
              CALL GEN051 (0, RMAT, - RGBL(27 + L) / RGBL(6), L)
            END DO
            CALL PLA226 (N, ANGL)
            GO TO 10
          END IF
          IF (IPR(220) > 0) THEN
            NAMS(1, M) = IFL(1)(1:7)
            FMAT(1, M) = -10000.0
          ELSE IF (IPR(221) == 3) THEN
C * x, y, z given.
            DO J = 1, 3
              FMAT(J, M) = FN(J)
            END DO
C * PLANE A,B,C,D (fractional)
          ELSE IF (IPR(221) == 4) THEN
            DO J = 1, 3
              XPV(J) = FN(J)
            END DO
            VLAK(4) = FN(4)
            CALL GEN002 (-1, ROR, XPV(1), VLAK, XLNG)
          END IF
        END DO
C * RESTORE FROM (SUPPORT) ORTEP
        NASUP = IPR(39) + IPR(64)
        CALL PLA269 (-1, NASUP)
C * SAVE ATOM INFO FOR F3D UTILITY
        DO I = 1, IPR(39)
          DO J = 1, 3
            XMCT(J, I) = XXO(I, J)
          END DO
          CALL GEN048 (-4, IFG(1, I), 15, IVAL)
          XMCT(4, I) = IVAL
        END DO
C * GET THE COORDINATES OF THE THREE SELECTED ATOMS
        DO I = 1, 3
          IF (FMAT(1, I) < -9999.0) THEN
            NQ1 = NAMS(1, I)(1:7)
            CALL GEN020 (1, NQ1, 1, 7)
C * GET/CHECK FOR NON-ZERO SERIAL NUMBER OF THIS LABEL
            CALL PLA046 (3, NQ1, IENM, LBB, LBC, LBD, INQNR, JYDUM, L)
            IF (L > 0) THEN
              DO J = 1, 3
                FMAT(J, I) = XXO(L, J)
              END DO
            ELSE
C * Incorrect Plane Definition Message
              CALL PLA015 (0, 42)
              GO TO 20
            END IF
          END IF
        END DO
C * CREATE/CHECK VALIDITY OF THE PLANE DEFINITION
        CALL GEN004 (OR, FMAT, CMAT)
        SELECT CASE (IPR(416))
C * THREE POINT DEFINITION CASE
          CASE (0)
C * GET NON-ZERO 1-2 VECTOR DIFFERENCE
            CALL GEN015 (CMAT(1, 1), CMAT(1, 2), V3, -1.0)
C * GET NON-ZERO 2-3 VECTOR DIFFERENCE
            CALL GEN015 (CMAT(1, 3), CMAT(1, 2), V2, -1.0)
            IF (GEN017 (V3) == 0.0 .OR. GEN017 (V2) == 0.0) THEN
              CALL PLA015 (0, 42)
              GO TO 20
            ELSE
C * VECTOR PRODUCT
              CALL GEN008 (V3, V2, VLAK, 0)
C * NORMALIZE
              IF (GEN017 (VLAK) == 0.0) THEN
C * Incorrect Plane Definition Message
                CALL PLA015 (0, 42)
                GO TO 20
              ELSE
C * CMAT(1, 1) should be on the plane
                VLAK(4) = GEN009 (VLAK, CMAT(1, 1))
              END IF
            END IF
C * AB CASE
          CASE (1)
C * BISECT CASE - WORK OUT VLAK AND CMAT(I, 1)
          CASE (2)
            CALL GEN015 (CMAT(1, 3), CMAT(1, 2), V2, -1.0)
            D2 = 1.0 / SQRT (V2(1)**2 + V2(2)**2 + V2(3)**2)
            DO J = 1, 3
              VLAK(J) = D2 * V2(J)
            END DO
            CALL GEN015 (CMAT(1, 2), CMAT(1, 3), V2, 1.0)
            VLAK(4) = GEN009 (V2, VLAK) / 2.0
            CMAT(1, 3) = 0.0
            CMAT(2, 3) = 0.0
            CMAT(3, 3) = 0.0
C * PERP CASE
          CASE (3)
            DO J = 1, 3
              V1(J) = (CMAT(J, 1) + CMAT(J, 2)) / 2
            END DO
            DO J = 1, 3
              CMAT(J, 2) = V1(J)
            END DO
            CALL GEN015 (CMAT(1, 1), CMAT(1, 2), V1, -1.0)
            CALL GEN015 (CMAT(1, 3), CMAT(1, 2), V2, -1.0)
            IF (GEN017 (V1) == 0.0 .OR. GEN017 (V2) < 0.0) THEN
C * Incorrect Plane Definition Message
              CALL PLA015 (0, 42)
              GO TO 20
C * XY/YZ/XZ & PATT CASES
            ELSE
              CALL GEN008 (V1, V2, V3, 0)
              IF (GEN017 (V3) == 0.0) THEN
C * Incorrect Plane Definition Message
                CALL PLA015 (0, 42)
                GO TO 20
              ELSE
                CALL GEN008 (V3, V1, VLAK, 0)
                IF (GEN017 (VLAK) == 0.0) THEN
C * Incorrect Plane Definition Message
                  CALL PLA015 (0, 42)
                  GO TO 20
                ELSE
                  VLAK(4) = GEN009 (VLAK, CMAT(1, 1))
                END IF
              END IF
            END IF
        END SELECT
C * FMAT & CMAT (= OR * FMAT) MATRICES
        WRITE (LU6, 99997) ((FMAT(I, J), I = 1, 3), J = 1, 3)
        WRITE (LU6, 99996) ((CMAT(I, J), I = 1, 3), J = 1, 3)
C * REPORT PLANE EQUATION
        WRITE (LU6, 99998) (VLAK(I),I = 1, 4)
C * READ REFLECTION DATA
   40   CALL PLA258
C * GENERATE THE COORDINATES OF ALL ATOMS IN THE UNIT CELL
        CALL PLA259
C * DEFINE PLANE & GRID
   70   CALL PLA260
        MODE = 1
      END DO
      IGBL(6) = 10
      RETURN
99999 FORMAT (A)
99998 FORMAT (/, ':: PLANE EQUATION:', F8.4, 'X', F8.4, 'Y',
     1  F8.4, 'Z =', F8.4)
99997 FORMAT (/, ':: FMAT(I,1) FMAT(I,2) FMAT(I,3) Fract', 3(/, 3F10.5))
99996 FORMAT (/, ':: CMAT(I,1) CMAT(I,2) CMAT(I,3) Ang  ', 3(/, 3F10.5))
99995 FORMAT (/, ':: PLA250 - Main Contour Routine')
      END SUBROUTINE PLA250
 
      SUBROUTINE PLA251
C * DENSITY CONTOUR MAP (4) - GET/INTERPRETE INSTRUCTIONS
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE atomdata
      USE cchar
      USE map
      IMPLICIT NONE
      INTEGER      :: I
      INTEGER      :: IS
      REAL         :: XMX
      REAL         :: XMY
      REAL         :: XMZM
      REAL         :: XMZP
      REAL         :: XOUT
      REAL         :: YOUT
      CHARACTER(3) :: SKEY
      WRITE (LU6, 99994)
C * CONTOUR-MAP TYPE
C * IPR(414) : 1 = Fo-map
C *            2 = 2Fo-Fc-map
C *            3 = (Fo-Fc)-map
C *            4 = Squeeze-map
C *            5 = Patterson-map
C * PLANE DEFINITION TYPE
C * IPR(416) : 0 = HORIZ  - Define Plane with 3 Points
C *            1 = AB
C *            2 = BISECT
C *            3 = PERP
C *            4 = XY/YZ/XZ
C *            5 = PATT
C * MODE = 0 = GET INSTRUCTIONS FROM CALLING INSTRUCTION RECORD
C *            AND RUN CALC UNIQUE
C *      = 1 = PLOT CYCLE WITH INTERACTIVE INSTRUCTIONS
      IF (MODE == 0) THEN
C * SET FO-FC -MAP AS DEFAULT
        IPR(414) = 3
C * SET PLANE DEFINED BY THREE POINTS DEFAULT
        IPR(416) = 0
C * SET ORIGIN DEFAULTS
        PAR(274) = 0.0
        PAR(275) = 0.0
        PAR(276) = 0.0
        IF (IPR(220) > 1) THEN
          DO I = 2, IPR(220)
            SELECT CASE (IFL(I)(1:2))
C * FO-MAP
              CASE ('FO')
                IPR(414) = 1
C * 2Fo-Fc map
              CASE ('FS')
                IPR(414) = 2
C * DIFFERENCE MAP (Fo-Fc)
              CASE ('DI')
                IPR(414) = 3
C * SOLVENT MAP (SQUEEZE)
              CASE ('SQ')
                IF (IGBL(9) < 0) THEN
                  IPR(414) = 4
                ELSE
                  IPR(414) = 3
                END IF
C * FO**2 PATTERSON
              CASE ('PT')
                IPR(414) = 5
C * TN - PLANE DEFINITION BY THREE POINTS
              CASE ('TN')
                IPR(416) = 0
C * ABCD PLANE CONSTANTS
              CASE ('AB')
                IPR(416) = 1
C * BISECT
              CASE ('BI')
                IPR(416) = 2
C * PERP
              CASE ('PE')
                IPR(416) = 3
              CASE DEFAULT
                CYCLE
            END SELECT
          END DO
        END IF
        IF (IPR(221) > 0) THEN
C * GET MAP SIZE (Angstrom)
          IF (FN(1) > 0.0) THEN
            PAR(273) = FN(1)
            PAR(272) = FN(1) * 4.0 / 3.0
          END IF
C * X,Y Origin shift in A. +ve left and down (0,0)
          IF (FN(2) /= 0.0) PAR(274) = FN(2)
          IF (FN(3) /= 0.0) PAR(275) = FN(3)
C * Axial system rotation in deg. +ve clockwise (0)
          IF (FN(4) /= 0.0) PAR(276) = FN(4)
C * F000
          IF (FN(5) > 0.0) PAR(277) = FN(5)
        END IF
C * CHECK FOR 'PREPARED' IN PREVIOUS 'CALC UNIQUE' (NO = 0) RUN
        IF (IPR(30) == 0) THEN
          IF (IPR(37) == 0) THEN
            IPR(2) = 42
            LRTN   = -1
            RETURN
          END IF
          IGBL(52) = MAX (IGBL(52), IPR(23))
C * SETUP CONNECTIONS
          CALL PLA287 (0, 1, 0)
        END IF
C * CHECK FOR U/UIJ ERROR COUNT
        IF (IPR(498) > 0) THEN
          IPR(2) = 45
          LRTN   = -1
          RETURN
        ELSE
C * SET SIDE MENU TO 'CONTOUR'
          IGBL(6) = 22
          CALL PLA262 (0)
        END IF
C * MODE = 1
      ELSE IF (MODE == 1) THEN
C * Main Routine for Contour Map Plotting
        CALL PLA252
   10   LRTN = 0
C * WHAT NEXT ?
        CALL PLA012 (0, 1)
        IF (LRET == 2) THEN
          LRTN = 6
          RETURN
        END IF
        CALL PLA006 (0, IS)
        SKEY = IFL(2)(1:3)
        IF (IPR(220) > 0) THEN
          SELECT CASE (IFL(1)(1:3))
C * LIST IPR/PAR/IGBL/RGBL
            CASE ('LIS')
              IF (SKEY == 'PAR' .OR. SKEY == 'IPR' .OR.
     1          SKEY == 'IGB' .OR. SKEY == 'RGB')
     2          CALL PLA206 (-1, SKEY)
              GO TO 10
C * DI
            CASE ('DI ')
              LRTN = 3
C * CONTOUR MAP CLICK POSITION
            CASE ('CPS')
              XOUT = (FN(1) - PXS) / SCHAAL - FLOAT ((MX - 1) / 2)
              YOUT = (FN(2) - PYS) / SCHAAL - FLOAT ((MY - 1) / 2)
              WRITE (6, '(''CPS'', 4F10.3)', IOSTAT = IOST)
     1          XOUT, YOUT, FN(1), FN(2)
              LRTN = 5
C * SET META TYPE
            CASE ('SET')
              IF (IFL(2)(1:3) == 'MET' .AND. IPR(220) > 2) THEN
                MEDIUM = 2
                CALL GGIP (-999.0, 0.0, 0.0, 6)
C * SET IPR/PAR/IGBL/RGBL
              ELSE IF (IPR(221) == 2 .AND. IPR(220) == 2) THEN
                IF (SKEY == 'PAR' .OR. SKEY == 'IPR' .OR.
     1            SKEY == 'IGB' .OR. SKEY == 'RGB')
     2            CALL PLA206 (1, SKEY)
              END IF
              LRTN = 5
C * XR(OT)
            CASE ('XR ', 'XRO')
              LRTN = 5
C * YR(OT)
            CASE ('YR ', 'YRO')
              LRTN = 5
C * ZR(OT)
            CASE ('ZR ', 'ZRO')
              PAR(276) = PAR(276) + FN(1)
              IPR(417) = 0
              IPR(221) = 0
C * END
            CASE ('END')
              LRTN = 1
C * EXIT
            CASE ('EXI')
              LRTN = 1
C * PT
            CASE ('PT ')
              LRTN = 3
C * FO
            CASE ('FO ')
              LRTN = 3
C * FS
            CASE ('FS ')
              LRTN = 3
C * SQ
            CASE ('SQ ')
              LRTN = 3
C * OMIT
            CASE ('OMI')
              LRTN = 3
C * QUIT
            CASE ('QUI')
              LRTN = 1
C * UP
            CASE ('U  ', 'UP ')
              IPR(417) = 1
C * DOWN
            CASE ('D  ', 'DOW')
              IPR(417) = -1
C * CONTINUE
            CASE ('CON')
              IPR(417) = 0
C * PLOT
            CASE ('PLO')
              IPR(417) = 0
C * SCALE
            CASE ('SCA')
              IPR(417) = 0
              IPR(418) = 0
C * F3D
            CASE ('F3D')
              IPR(580) = 1
              VLAK(4) = VLAK(4) - PAR(278) * IPR(577)
              NSECTIONS = IPR(577) + IPR(578) + 1
              NRSECT    = 1
              OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'.fou',
     1                                STATUS = 'UNKNOWN')
              WRITE (LU65, 99999, IOSTAT = IOST)
              WRITE (LU65, 99997, IOSTAT = IOST) 1.0, 0.0, 0.0, 0.0,
     1          1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0
              WRITE (LU65, 99998, IOSTAT = IOST) (PAR(I), I = 101, 106)
              XMX  = (MX - 1) * PAR(271) / 2
              XMY  = (MY - 1) * PAR(271) / 2
              XMZM = IPR(577) * PAR(278)
              XMZP = IPR(578) * PAR(278)
              WRITE (LU65, 99996, IOSTAT = IOST)
     1          -XMX,  PAR(271), XMX,  1.0,
     2          -XMY,  PAR(271), XMY,  1.0,
     3          -XMZM, PAR(278), XMZP, 1.0
              WRITE (LU65, 99995, IOSTAT = IOST) MX, MY, NSECTIONS
              LRTN     = 7
C * PLAN
            CASE ('PLA')
              LRTN = 4
              IPR(415) = 1
              IPR(201) = 0
C * COPY FROM BACKUP (BUP) TO VOID
              CALL PLA269 (3, 0)
C * USER-SET CONTOUR LEVEL
            CASE ('CL ')
              IF (IPR(221) == 1) THEN
                IPR(419) = MAX (5, NINT (FN(1) * 100))
                IPR(221) = 0
                LRTN     = 6
              END IF
          END SELECT
        END IF
        IF (LRTN == 0) THEN
          IPR(416) = 1
          IF (IPR(221) > 0) THEN
            PAR(278) = ABS (FN(1))
            IPR(417) = NINT (SIGN (1.0, FN(1)))
          END IF
          VLAK(4) = VLAK(4) + PAR(278) * IPR(417)
          LRTN = 2
        END IF
      END IF
      RETURN
99999 FORMAT ('INFO  DOWN, ACROSS AND SECTION', /, 'TRAN')
99998 FORMAT ('CELL', 6(/, F15.8))
99997 FORMAT (F15.8)
99996 FORMAT ('L14', 12(/, F15.8))
99995 FORMAT ('SIZE', 3(/, I8))
99994 FORMAT (/, ':: PLA251 - Get Instructions')
      END SUBROUTINE PLA251
 
      SUBROUTINE PLA252
C * Main Routine for Contour Plotting of Best-Plane Fourier Maps
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE map
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: I0
      INTEGER            :: J0
      INTEGER            :: JC
      INTEGER            :: JX
      INTEGER            :: JY
      INTEGER            :: IS
      INTEGER            :: KX
      INTEGER            :: KY
      INTEGER            :: LC
      INTEGER            :: MC
      INTEGER            :: N2
      INTEGER            :: N3
      INTEGER            :: N4
      INTEGER            :: N5
      INTEGER            :: N6
      INTEGER            :: NS0
      INTEGER            :: ICH
      INTEGER            :: JCH
      INTEGER            :: JUC
      INTEGER            :: JV0
      INTEGER            :: IX1
      INTEGER            :: IX2
      INTEGER            :: IX6
      INTEGER            :: IX7
      INTEGER            :: IX8
      INTEGER            :: IX9
      INTEGER            :: IY1
      INTEGER            :: IY2
      INTEGER            :: IY6
      INTEGER            :: IY7
      INTEGER            :: IY8
      INTEGER            :: IY9
      INTEGER            :: IN6
      INTEGER            :: IN7
      INTEGER            :: IDT
      INTEGER            :: IUC
      INTEGER            :: IXY6
      INTEGER            :: IXY7
      INTEGER            :: ICH9
      INTEGER            :: IDUM1
      INTEGER            :: IDUM2
      INTEGER            :: ITMAX
      INTEGER            :: ITMIN
      INTEGER            :: JCYCLE
      REAL               :: XS
      REAL               :: YS
      REAL               :: X7
      REAL               :: Y7
      REAL               :: CH
      REAL               :: DX
      REAL               :: DY
      REAL               :: R6
      REAL               :: R7
      REAL               :: RA
      REAL               :: SL
      REAL               :: XP
      REAL               :: YP
      REAL               :: RA9
      REAL               :: DIS
      REAL               :: XST
      REAL               :: YST
      REAL               :: TMAX
      REAL               :: TMIN
      REAL               :: DENS
      REAL               :: XLNG
      REAL               :: XLOW
      REAL               :: YLOW
      REAL               :: XHIGH
      REAL               :: YHIGH
      REAL               :: RESX1
      REAL               :: RESOL
      REAL               :: GEN009
      REAL, DIMENSION(3) :: XT
      WRITE (LU6, 99992)
      IN7  = 0
      IXY7 = 0
      IX7  = 0
      IY7  = 0
      X7   = 0.0
      Y7   = 0.0
C * Set up map values and screen scale
C * Projections on plane, deviations from plane
      RESX1 = PAR(279) / PAR(271)
      XLOW  = NXM - RESX1
      XHIGH = NXP + RESX1
      YLOW  = NYM - RESX1
      YHIGH = NYP + RESX1
      NAT   = 0
C * CHECK FOR ATOMS IN THE RANGE -1, 0, 1 CELLS
      DO M = 1, NAX
        DO I = -1, 1, 1
          XT(1) = ATOM(1, M) + I
          DO J = -1, 1, 1
            XT(2) = ATOM(2, M) + J
            DO K = -1, 1, 1
              XT(3) = ATOM(3, M) + K
C * HANDLE OVERFLOW OF ARRAYS XMPC, IMPC
              IF (NAT < NCT8) THEN
C * GET ANGSTROM COORDINATES FROM FRACTIONAL COORDINATES
                CALL GEN002 (1, OR, XT, V3, XLNG)
C * COPY TO ATOM LIST (ANGSTROM)
                DO L = 1, 3
                  XMPC(NAT + 1, L + 3) = V3(L)
                END DO
C * GET DISTANCE TO PLANE
                DIS = GEN009 (VLAK, V3) - VLAK(4)
                DO L = 1, 3
                  V1(L) = DIS * VLAK(L)
                END DO
C * SUBSTRACT V1 FROM V3
                CALL GEN015 (V3, V1, V2, -1.0)
C * SUBSTRACT XN FROM V2
                CALL GEN015 (V2, XN(1, 4), V1, -1.0)
C * SCALAR PRODUCTS
                DO L = 1, 3
                  V3(L) = GEN009 (V1, XN(1, L)) / PAR(271)**2
                END DO
C * WITHIN WINDOW TEST
                IF (V3(1) > XLOW .AND. V3(1) < XHIGH .AND.
     1              V3(2) > YLOW .AND. V3(2) < YHIGH .AND.
     2              ABS (DIS) < PAR(279)) THEN
                  CALL PLA047 (LATOM(M), NQ1, IDUM1, IDUM2, 0,
     1                         IGBL(55), 0, 0)
                  NAT = NAT + 1
                  DO L = 1, 3
                    XMPC(NAT, L) = V3(L)
                  END DO
C * WITHIN STEP RESOLUTION ?
                  IF (ABS (DIS) < PAR(271)) THEN
                    IMPC(4, NAT) = - LATOM(M)
                  ELSE
                    IMPC(4, NAT) = LATOM(M)
                  END IF
                  DO L = 1, 3
                    IMPC(L, NAT) = IFLG(L, M)
                  END DO
                END IF
              ELSE
                WRITE (LU6, 99993, IOSTAT = IOST) NAT, NCT8, NAX
                GO TO 10
              END IF
            END DO
          END DO
        END DO
      END DO
C * Read in Fourier map values and find min and max density
   10 TMIN =  100000.0
      TMAX = -100000.0
      DO J = 1, MY
        DO I = 1, MX
          DENS = FMAP(I, J)
          TMIN = MIN (TMIN, DENS)
          TMAX = MAX (TMAX, DENS)
        END DO
      END DO
C * Work out reasonable contour intervals
      ITMAX = NINT (TMAX)
      ITMIN = NINT (TMIN) - 1
      IF (IPR(418) == 0) THEN
        IDT   = ITMAX - ITMIN
        DO I = 1, 12
          IF (IRANGE(I) >= IDT) THEN
            IPR(419) = MAX (10, IRANGE(I) / 20)
            GO TO 20
          END IF
        END DO
        IPR(419) = 100
      END IF
   20 NE = ((ITMAX / IPR(419)) + 1) * IPR(419)
      NS = ((ITMIN / IPR(419)) - 1) * IPR(419)
      IF (IPR(418) == 0 .AND. IGBL(25) /= 1) THEN
        WRITE (LU6, 99998, ADVANCE = 'NO', IOSTAT = IOST)
     1    TMIN / 100.0, TMAX / 100.0, IPR(419) / 100.0
        IGBL(24) = 0
        READ (LU5, 99996) IGGT(6:80)
        CALL PLA280 ('CONT')
        CALL PLA006 (0, IS)
        IF (IPR(221) == 1) THEN
          IPR(419) = MAX (10, NINT (FN(1) * 100.0))
        END IF
      END IF
C * Ensure that contouring will hit the start value, as contouring
C * begins at the top and works down
      I  = (NE - NS) / IPR(419)
      J  =  NE - NS  - IPR(419) * I
      NE = NS + IPR(419) * I
      IF (J /= 0) NE = NE + IPR(419)
C * If map value .eq. contour level, then plus or minus 0.01
      DO J = 1, MY
        DO I = 1, MX
          DENS = FMAP(I, J)
          CH   = DENS / IPR(419) - INT (DENS / IPR(419))
          IF (CH == 0.0) FMAP(I, J) = DENS + SIGN (0.01, DENS)
        END DO
      END DO
C * Set up absolute scale and shift map to center of screen by PXS, PYS.
C * Keep the basic scale of a given map and only rescale when a new map
C * is to be plotted.
      XS = HORS * 0.88
      SL = XS / 100.0
      IF (IPR(418) == 0) THEN
        SCHAAL = XS / (MX - 1)
        PYS = (VERT - SCHAAL * (MY - 1)) / 2.0
        PXS = (HORS - XS) / 2
        YS = VERT * 0.88
        IF ((MY - 1) * SCHAAL > YS) THEN
          SCHAAL = YS / (MY - 1)
          PXS = (HORS - SCHAAL * (MX - 1)) / 2.0
          PYS = (VERT - YS) / 2
        END IF
        STEP = SCHAAL / PAR(271)
        IPR(418) = 1
      END IF
C * Clear the screen and plot the atoms as + and the name
      CALL GGIP (HORS, VERT, 0.0, 1)
C * Draw frame around plot
      OFF  = 0.25
      XPOS = HORS - PXS
      YPOS = VERT - PYS
      CALL GGIP (PXS,  PYS,  0.0, 3)
      CALL GGIP (XPOS, PYS,  0.0, 2)
      CALL GGIP (XPOS, YPOS, 0.0, 2)
      CALL GGIP (PXS,  YPOS, 0.0, 2)
      CALL GGIP (PXS,  PYS,  0.0, 2)
C * DRAW ANGSTROM SCALES
      XST = PXS
      DO WHILE (XST < XPOS)
        CALL GGIP (XST, PYS,      0.0, 3)
        CALL GGIP (XST, PYS - SL, 0.0, 2)
        XST = XST + STEP
      END DO
      YST = PYS
      DO WHILE (YST < YPOS)
        CALL GGIP (PXS,      YST, 0.0, 3)
        CALL GGIP (PXS - SL, YST, 0.0, 2)
        YST = YST + STEP
      END DO
      CALL PLA439 (0.0, 'Ang', 3, 0.3, 1, 2, XPOS + OFF, PYS - OFF)
C * CHECK FOR DECORATION ON/OFF
      IF (IGBL(103) == 1) THEN
C * TRANSFORM PLANE DEFINITION TO fractional COORDINATES
        CALL GEN002 (-1, OR, VLAK, XPV(5), XLNG)
        XPV(8) = VLAK(4)
        WRITE (ICL, 99999, IOSTAT = IOST) (XPV(I), I = 5, 8),
     1        (NS + IPR(419)) / 100.0, (NE - IPR(419)) / 100.0,
     2        IPR(419) / 100.0
        CALL PLA439 (0.0, ICL, 80, 0.3, 1, 2, 1.5, VERT - 0.5)
        SELECT CASE (IPR(414))
          CASE (1)
            NQ1 = ' Fo-Map'
          CASE (2)
            NQ1 = ' 2Fo-Fc'
          CASE (3)
            NQ1 = 'Dif-Map'
          CASE (4)
            NQ1 = 'SQZ-Map'
          CASE (5)
            NQ1 = 'PAT-Map'
        END SELECT
        CALL PLA439 (0.0, NQ1, 7, 0.30, 1, 2, HORS - 3.5,
     1               VERT - 0.5)
        RESOL = MIN (PAR(166),
     1                 ASIN (MIN (PAR(412) * PAR(17), 1.0)) * RGBL(6))
        WRITE (ICL, 99997, IOSTAT = IOST)
     1    PAR(279), PAR(278) * IPR(417), RESOL, IPR(515)
        CALL PLA439 (0.0, ICL, 80, 0.3, 1, 2, 2.0, VERT - 0.95)
        CALL PLA110 (HORS, VERT, -1)
C * R-VALUES
        CALL PLA439 (0.0, 'R1  =', 5, 0.3, 1, 2, XPOS + 0.2, YPOS - 0.5)
        WRITE (ICL, 99994, IOSTAT = IOST) RANDS(1)
        CALL PLA439 (0.0,  ICL,    5, 0.3, 1, 2, XPOS + 0.2, YPOS - 1.0)
        CALL PLA439 (0.0, 'wR2 =', 5, 0.3, 1, 2, XPOS + 0.2, YPOS - 1.7)
        WRITE (ICL, 99994, IOSTAT = IOST) RANDS(2)
        CALL PLA439 (0.0,  ICL,    5, 0.3, 1, 2, XPOS + 0.2, YPOS - 2.2)
        CALL PLA439 (0.0, 'S   =', 5, 0.3, 1, 2, XPOS + 0.2, YPOS - 2.9)
        WRITE (ICL, 99994, IOSTAT = IOST) RANDS(3)
        CALL PLA439 (0.0,  ICL,    5, 0.3, 1, 2, XPOS + 0.2, YPOS - 3.4)
      END IF
C * PLOT ATOMS/BONDS
C * Search all contours and plot on screen
C **********************************************************************
C *                                                                    *
C *                                                              I-6-I *
C * Direction of search                                          I   I *
C *     ID (6,6,2)                    I-1--I--6-I                1   5 *
C *                                   I    I    I                I   I *
C *                            IXY=2  2    *    5         IXY=1  O-*-I *
C * O is the position of              I    I    I                I   I *
C *   the search centre               I-3--O--4-I                2   4 *
C *                                                              I   I *
C *                                                                    *
C **********************************************************************
C * Set up contour level loop
      DO 100 JV0 = NS, NE, IPR(419)
        IV = NE - JV0 + NS
C * Zero IEXX(2, MX, MY),  IEXX = 0 for not found yet
C * IEXX = 1 for found already
        DO K = 1, 2
          DO J = 1, MX
            DO I = 1, MY
              IEXX(K, J, I) = 0
            END DO
          END DO
        END DO
C * Search starting point, bottom righthand corner
        DO KX = 1, MX - 1
          JX = MX - KX
          DO KY = 2, MY - 1
            JY = MY - KY + 1
C * If RA .lt. 0 then there is an IV contour level in the range
            RA = (FMAP(JX, JY) - IV) * (FMAP(JX + 1, JY) - IV)
            IF (RA <= 0.0) THEN
              IF (IEXX(1, JX, JY) == 0) THEN
C * IUC = 0   counterclockwise search,  JC = 0 for closed contour
C * IUC = 1   clockwise search,         JC > 0 for  open  contour
C * NT        number of points found in one round
C * IX,IY     position of search center
C * INX       direction of search
                IUC = 0
                JUC = 0
                JC  = 0
                LC  = 0
                NT  = 0
                QAX(1, 1) = 0.0
                QAX(2, 1) = 0.0
   30           IXY = 1
                INX = 6
                IX  = JX
                IY  = JY
C * POLYNOMIAL FIT
                CALL PLA255
                XP = X
                YP = Y
                IEXX(1, JX, JY) = 2
C * End of starting point search
                N5 = 6
                N  = 1
C * Continue search for a closed contour; Five direction search
   40           IF (IUC == 0) THEN
C * IUC = 0, outside expand search; IUC = 1, inside close search
                  I = INX + N
                  IF (I > 6) I = I - 6
                ELSE
C * IUC = 0, inside close search; IUC = 1, outside expand search
                  I = INX - N
                  IF (I < 1) I = I + 6
                END IF
                IX1 = ID(1, I, IXY) + IX
                IF (IX1 /= 0) THEN
                  IY1 = ID(2, I, IXY) + IY
                  IF (IY1 /= 0) THEN
                    IX2 = ID(3, I, IXY) + IX
                    IY2 = ID(4, I, IXY) + IY
                    RA  = (FMAP(IX1, IY1) - IV) * (FMAP(IX2, IY2) - IV)
                    IF (RA < 0.0) GO TO 70
                  END IF
                END IF
                N = N + 1
                IF (N <= N5) GO TO  40
C * Second time can't find a point, end this round
   60           IF (JUC == 1) GO TO 90
                JUC = 1
                JC  = NT
                IUC = MOD (IUC + 1, 2)
C * First time can't find a point, go back to starting point,
C * find clockwise
                GO TO 30
   70           ICH = ID(5, I, IXY)
C * Found before, go back next search direction
                IF (IEXX(ICH, IX1, IY1) == 1) THEN
                  N = N + 1
                  IF (N <= N5) THEN
                    GO TO 40
                  ELSE
                    GO TO 60
                  END IF
                END IF
C * Store found direction
                IN6  = ID(6, I, IXY)
                IXY6 = ICH
                IX6  = IX1
                IY6  = IY1
                MC   = 0
                N    = N + 1
C * Find another point, if possible.
                IF (LC /= 2) THEN
                  IF (N /= 6) THEN
                    DO L = N, 5
                      IF (IUC == 1) THEN
                        J = INX - L
                        IF (J < 1) J = J + 6
                      ELSE
                        J = INX + L
                        IF (J > 6) J = J - 6
                      END IF
                      IX9 = ID(1, J, IXY) + IX
                      IF (IX9 /= 0) THEN
                        IY9 = ID(2, J, IXY) + IY
                        IF (IY9 /= 0) THEN
                          IX8 = ID(3, J, IXY) + IX
                          IY8 = ID(4, J, IXY) + IY
                          RA9 = (FMAP(IX9, IY9) - IV) *
     1                          (FMAP(IX8, IY8) - IV)
                          IF (RA9 < 0.0) THEN
                            ICH9 = ID(5, J, IXY)
                            IF (IEXX(ICH9, IX9, IY9) /= 1) THEN
                              IF ((ICH9 == 2 .AND. IY9 /= MY) .OR.
     1                            (ICH9 /= 2 .AND. IX9 /= MX)) THEN
                                IN7  = ID(6, J, IXY)
                                IXY7 = ICH9
                                IX7  = IX9
                                IY7  = IY9
                                MC   = 1
                              END IF
                            END IF
                          END IF
                        END IF
                      END IF
                    END DO
                    IXY = IXY7
                    IX  = IX7
                    IY  = IY7
C * POLYNOMIAL FIT
                    CALL PLA255
                    NT = NT - 1
                    X7 = X
                    Y7 = Y
                  END IF
                END IF
                IXY = IXY6
                IX  = IX6
                IY  = IY6
C * POLYNOMIAL FIT
                CALL PLA255
                IF (MC /= 0) THEN
C * Calculate both point distances
                  DX = X - XP
                  DY = Y - YP
                  R6 = SQRT (DX**2 + DY**2)
                  DX = X7 - XP
                  DY = Y7 - YP
                  R7 = SQRT (DX**2 + DY**2)
C * Compare length difference and adopt probable one
                  IF ((R6 / R7) >= 2.5) THEN
                    INX               = IN7
                    IXY               = IXY7
                    IX                = IX7
                    IY                = IY7
                    IEXX(IXY, IX, IY) = 1
                    QAX(1, NT)        = X7
                    QAX(2, NT)        = Y7
                    X                 = X7
                    Y                 = Y7
                    LC                = 1
C * Change search direction clockwise or countclockwise
                    IUC = MOD (IUC + 1, 2)
                    GO TO 80
                  END IF
                END IF
                IEXX(IXY, IX, IY) = 1
                INX = IN6
                LC  = 0
   80           XP  = X
                YP  = Y
                LC  = LC + 1
C * Change back search clockwise or counterclockwise, if changed in
                IF (LC == 4) THEN
                  IUC = MOD (IUC + 1, 2)
                  LC  = 1
                END IF
C * If this is a closed contour then end this round
                IF (QAX(1, 1) /= X .OR. QAX(2, 1) /= Y) THEN
C * Check if contour end on border then go back to starting point,
C * find clockwise
                  IF (IXY == 1) THEN
                    IF (IY == 1 .OR. IY == MY) GO TO 60
                  ELSE
                    IF (IX == 1 .OR. IX == MX) GO TO 60
                  END IF
                  N5 = 5
                  N  = 1
                  GO TO 40
                END IF
C * Output all points of this round in the correct sequence
   90           IF (JC > 0) THEN
C * Open contour, for correct sequence divided into two parts
C * First part, invert output sequence
                  JCH = JC / 2
                  DO I0 = 1, JCH
                    J0 = JC - I0 + 1
                    CALL GEN018 (QAX(1, I0), QAX(1, J0))
                    CALL GEN018 (QAX(2, I0), QAX(2, J0))
                  END DO
C * Second part, reject one redundant point
                  NS0 = JC + 2
                  IF (NS0 <= NT) THEN
                    DO I0 = NS0, NT
                      QAX(1, I0 - 1) = QAX(1, I0)
                      QAX(2, I0 - 1) = QAX(2, I0)
                    END DO
                  END IF
                  NT = NT - 1
                END IF
 
C * Smooth contours found by SEARCH routine
                IF (NT /= 1) THEN
                  JVY = IV
                  IF (JVY == 0) THEN
                    NN = 8
                  ELSE
                    NN = 4
                  END IF
                  JVX = 0
C * Closed contour, IC = 3, JCYCLE = 1
                  IF (QAX(1, 1) == QAX(1, NT) .AND.
     1                QAX(2, 1) == QAX(2, NT)) THEN
                    IC = 3
                    JCYCLE = 1
                  ELSE
                    IC = 2
                    JCYCLE = 0
                  END IF
                  IF (NT <= 30) THEN
                    DO J = 1, NT
                      PAX(1, J) = QAX(1, J)
                      PAX(2, J) = QAX(2, J)
                    END DO
                    NS7 = 1
                    NE7 = NT
                    N7  = NT
                    CALL PLA254
                    CYCLE
                  END IF
C * Contour points exceed 30, divided into N2 sections for smoothing
                  N2 = NINT (NT / 20.0)
                  IC = 2
                  N3 = INT (NT / N2)
                  N4 = NT - N2 * N3 + N3
                  DO J = 1, N3 + 2
                    PAX(1, J) = QAX(1, J)
                    PAX(2, J) = QAX(2, J)
                  END DO
                  N7  = N3 + 2
                  NS7 = 1
                  NE7 = N7 - 2
C * CHECK FOR CYCLE
                  IF (JCYCLE /= 0) THEN
C * ADD TWO POINTS FORWARD FOR SMOOTHING
                    DO J = 1, N3 + 2
                      PAX(1, J + 2) = QAX(1, J)
                      PAX(2, J + 2) = QAX(2, J)
                    END DO
                    DO I = 1, 2
                      PAX(I, 1) = QAX(I, NT - 2)
                      PAX(I, 2) = QAX(I, NT - 1)
                    END DO
                    N7  = N7 + 2
                    NS7 = 3
                    NE7 = NE7 + 2
                  END IF
                  CALL PLA254
C * Smoothing the middle points of contor
                  IF (N2 /= 2) THEN
                    DO N = 1, N2 - 2
                      N5 = N * N3 - 3
                      DO J = 1, N3 + 5
                        PAX(1, J) = QAX(1, N5 + J)
                        PAX(2, J) = QAX(2, N5 + J)
                      END DO
                      N7  = N3 + 5
                      NS7 = 3
                      NE7 = N7 - 2
                      CALL PLA254
                    END DO
                  END IF
C * Smoothing the last section
                  N6 = N3 * (N2 - 1) - 3
                  IF (N6 + N4 + 3 <= NCT5) THEN
                    DO J = 1, N4 + 3
                      PAX(1, J) = QAX(1, N6 + J)
                      PAX(2, J) = QAX(2, N6 + J)
                    END DO
                  ELSE
                    WRITE (LU6, 99995, IOSTAT = IOST)
                    GO TO 100
                  END IF
                  N7  = N4 + 3
                  NS7 = 3
                  NE7 = N7
C * Check for cycle
                  IF (JCYCLE /= 0) THEN
C * Append two points
                    DO I = 1, 2
                      PAX(I, N4 + 4) = QAX(I, 2)
                      PAX(I, N4 + 5) = QAX(I, 3)
                    END DO
                    N7 = N7 + 2
                  END IF
                  CALL PLA254
                END IF
              END IF
            END IF
C * Search for another starting point on the same contour level
          END DO
        END DO
C * CHANGE TO ANOTHER CONTOUR LEVEL
  100 CONTINUE
      CALL PLA257
      CALL GGIP (0.0, 0.0, 0.0,  3)
      CALL GGIP (0.0, 0.0, 0.0, -1)
      IF (IGBL(25) /= 1)
     1  CALL GEN125 (1, LU6, 'Next section (Up/Down/Quit/+,-dist)')
C * SET CONTOUR-POS
      IPR(439) = 1
      RETURN
99999 FORMAT ('Plane:', F8.4, 'x', F8.4, 'y', F8.4, 'z =', F8.4,
     1 4X, 'Cont-Lev(eA-3):', 3F6.2)
99998 FORMAT (/, 'Density values in the map range from',
     1  F7.2, ' to ', F7.2, ' eA-3', /,
     2 'New Interval[', F5.2, '] Contour Levels ')
99997 FORMAT ('Tol =', F5.1, ' Ang', 13X, 'Step =', F8.4, ' Ang',
     1 2X, 'Resolution', F5.1, ' Deg.', 2x, 'Omit', I2, '*SigI')
99996 FORMAT (A)
99995 FORMAT ('PROBLEM WITH QAX IN PLA252')
99994 FORMAT (F5.3)
99993 FORMAT ('W: NAT =', I5, ' > NCT8=', I5, ' [NA =', I4, ']')
99992 FORMAT (/, ':: PLA252 - Setup Map')
      END SUBROUTINE PLA252
 
      SUBROUTINE PLA253
C * STRUCTURE FACTOR CALCULATION FOR CONTOUR MAPS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE reflex
      USE map
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IS
      INTEGER :: NSX
      INTEGER :: IHT
      INTEGER :: IKT
      INTEGER :: ILT
      INTEGER :: MPK
      INTEGER :: MPL
      INTEGER :: NRF
      INTEGER :: NRF1
      INTEGER :: NATO
      INTEGER :: NREF
      INTEGER :: IHTN
      INTEGER :: IKTN
      INTEGER :: ILTN
      INTEGER :: IHKL
      INTEGER :: IADR
      INTEGER :: KMAX
      INTEGER :: LMAX
      INTEGER :: MAPR
      INTEGER :: MHKL
      INTEGER :: NADR
      INTEGER :: NSYMC
      INTEGER :: MHKLH
      INTEGER :: IHKL0
      INTEGER :: IHKLN
      INTEGER :: IADR1
      INTEGER :: HMAX
      REAL    :: AI0
      REAL    :: AN0
      REAL    :: BI0
      REAL    :: PXX
      REAL    :: SCF
      REAL    :: PHIX
      REAL    :: SGIK
      REAL    :: SIGI
      REAL    :: COSA
      REAL    :: DANO
      REAL    :: XCAL
      REAL    :: XOBS
      REAL    :: FCAL
      REAL    :: FOBS
      REAL    :: PCAL
      REAL    :: ACAL
      REAL    :: BCAL
      REAL    :: SINA
      REAL    :: STHL
      REAL    :: STLK
      REAL    :: SUM1
      REAL    :: SUM2
      REAL    :: SUM3
      REAL    :: SUM4
      REAL    :: SUMN
      REAL    :: SUMT
      REAL    :: WGHT
      REAL    :: XOBS1
      REAL    :: XOBS2
      REAL    :: WGTI1
      REAL    :: WGTI2
      REAL    :: WGTIS
      REAL    :: UCINT
      REAL    :: STHLK
      REAL    :: SOMXC
      REAL    :: SOMXO
      REAL    :: SN2TH
      REAL    :: SNTHA
      REAL    :: SIGIW
      REAL    :: SIGI1
      REAL    :: SIGI2
      REAL    :: PCALN
      REAL    :: ACALA
      REAL    :: BCALA
      REAL    :: ACALS
      REAL    :: BCALS
      REAL    :: ACALAF
      REAL    :: BCALAF
      REAL    :: GEN095
C * LOAD ATOMS AND EXPAND (EXCLUDING BRAVAIS CENTERING)
      WRITE (LU6, 99992)
      WRITE (LU6, 99993)
      CALL PLA023 (0)
      NATO = IPR(589)
C * CHECK FOR 'ANY ATOMS?'
      IF (NATO <= 0) THEN
        IPR(1) = 1
        IPR(2) = 42
        RETURN
      END IF
      NSYMH = IPR(255)
      ICNTR = IPR(257)
      AN0   = 0.0
      IND1  = 1
      IND2  = 2
      IND3  = 3
C * READ SHELX(L).HKL - TYPE 4 OR FCF
      NREF  = 0
      SOMXO = 0.0
      SOMXC = 0.0
C * TRANSFORM REFLECTIONS FOR SF-CALCULATION (EXCLUDE NON-INTEGRAL H,K,L)
      CALL GEN108 (LU9, 0)
      HMAX = -999
      KMAX = -999
      LMAX = -999
      INQUIRE (UNIT = LU27, OPENED = OPEND)
      IF (OPEND) CLOSE (UNIT = LU27, IOSTAT = IOST)
      OPEN (UNIT = LU27, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      IHT  = 0
      IKT  = 0
      ILT  = 0
      IEND = -1
      DO
        CALL PLA134 (IH, IK, IL, IHT, IKT, ILT, XOBS, SIGI,
     1    SIGIW, UCINT, ACALS, BCALS)
C * END_OF_DATA HANDLING
        IF (IEND == 1) THEN
          IF (NREF == 0) THEN
            WRITE (LU6, 99999, IOSTAT = IOST)
            IPR(210) = 0
            RETURN
          ELSE
C * DATA-SET THETA-MAX (DETERMINED IN PLA134)
            PAR(166) = ASIN (SQRT (PAR(166)) * PAR(17)) * RGBL(6)
C * HEXAGONAL LATTICE
            IF (IPR(259) == 5 .OR. IPR(259) == 6) THEN
              HMAX = MAX (KMAX, HMAX, IABS (IHT + IKT))
              KMAX = HMAX
C * TETRAGONAL LATTICE
            ELSE IF (IPR(259) == 4) THEN
              HMAX = MAX (HMAX, KMAX)
              KMAX = HMAX
C * CUBIC LATTICE
            ELSE IF (IPR(259) == 7) THEN
              HMAX = MAX (HMAX, KMAX, LMAX)
              KMAX = HMAX
              LMAX = HMAX
            END IF
          END IF
          WRITE (LU6, 99994) NREF, PAR(166), HMAX, KMAX, LMAX
          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
C * CALCULATE ADDRESS OF 0,0,0
          IADR     = NVDR - MHKLH
          IADR1    = NVDR - MHKL
          IF (IADR1 < NREF * 7) THEN
            WRITE (LU6, 99997, IOSTAT = IOST)
            RETURN
          END IF
          DO I = 1, MHKL
            VOID(IADR1 + I) = - 1.0
          END DO
          EXIT
        ELSE
          HMAX = MAX (HMAX, IABS (IHT))
          KMAX = MAX (KMAX, IABS (IKT))
          LMAX = MAX (LMAX, IABS (ILT))
          NREF = NREF + 1
          ACAL = 0.0
          BCAL = 0.0
C * CHECK FOR 'LONG' HKLF FORMAT (FCF-MODE)
          IF (IGBL(9) == -1) THEN
            IF (IPR(414) == 4) THEN
C * SOLVENT CONTRIBUTION
              ACAL = ACALS
              BCAL = BCALS
C * 'PSEUDO'-XOBS
              XOBS = ACAL **2 + BCAL ** 2
            END IF
          END IF
          WRITE (LU27) IHT, IKT, ILT, XOBS, SIGI
        END IF
      END DO
      REWIND (UNIT = LU27, IOSTAT = IOST)
      DO I = 1, NREF
        READ (LU27) IHT, IKT, ILT, XOBS, SIGI
C * CALCULATE STRUCTURE FACTOR
        CALL PLA137 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA,
     1    ACALAF, BCALAF, SNTHA)
C * SHELXL LIST 3 FCF
        IF (IGBL(9) == 21) THEN
          ACALA = (ACALA + ACALAF) / 2.0
          ACAL  = ACAL + ACALA
          ACALA = 0.0
          BCALA = 0.0
          XCAL = ACAL ** 2 + BCAL ** 2
        ELSE
C * ADD ANOMALOUS (F' & F") CONTRIBUTION FOR XCAL
          ACAL = ACAL + ACALA
          BCAL = BCAL + BCALA
          XCAL = ACAL ** 2 + BCAL ** 2
C * EXTINCTION CORRECTION
          IF (IGBL(9) == 0 .AND. PAR(229) > 0.0) THEN
            SN2TH = 2 * SNTHA * SQRT (1.0 - MIN (SNTHA, 1.0) ** 2)
            XOBS = XOBS *
     1     (1.0 + 0.001 * PAR(229) * XCAL * PAR(17)**3 / SN2TH) ** 0.5
          END IF
C * TAKE SWAT CORRECTION TO XCAL INTO ACCOUNT
          IF (IPR(698) /= 0) THEN
C * CALCULATE (SIN(THETA) / LAMBDA)**2
            STLK  = GEN095 (PAR(191), IHT, IKT, ILT)
            XCAL = XCAL * (1.0 - PAR(501) *
     1        EXP (- RGBL(8) * PAR(502) * STLK))**2
          END IF
          IF (XOBS > 5 * SIGI) THEN
            SOMXO = SOMXO + XOBS / SIGI**2
            SOMXC = SOMXC + XCAL / SIGI**2
          END IF
        END IF
C * WRITE REFLECTION DATA TO SCRATCH FILE
        WRITE (LU9) IHT, IKT, ILT, XOBS, XCAL, SIGI,
     1    ACAL, BCAL, ACALA, BCALA, ACALAF, BCALAF
      END DO
C * END HKL READ/CALC LOOP
C * PATTERSON + CONTOUR
      IF (IPR(414) == 5) THEN
        SCF = 100.0 / (SOMXO * PAR(240))
C * SQUEEZE + CONTOUR
      ELSE IF (IPR(414) == 4) THEN
        SCF = 1.0 / PAR(240)
C * TEST FOR FCF SCALING [IPR(516)=0] AND LIST 4, 3 OR 8 STYLE SHELXL FCF DATA
      ELSE IF ((IGBL(9) == 1 .OR. IGBL(9) == 21 .OR.
     1  IGBL(9) == 25) .AND. IPR(516) == 0) THEN
        SCF = PAR(240) / PAR(230)
      ELSE
        SCF = SOMXC / (SOMXO * PAR(240))
      END IF
      WRITE (LU6, 99995, IOSTAT = IOST) SCF, IGBL(9)
      WRITE (LU7, 99995, IOSTAT = IOST) SCF, IGBL(9)
      CALL GEN108 (LU9,  0)
C * READ SCRATCH I(obs), I(calc) REFLECTION FILE
      DO I = 1, NREF
        READ (LU9) IHT, IKT, ILT, XOBS, XCAL, SIGI,
     1             ACAL, BCAL, ACALA, BCALA, ACALAF, BCALAF
        XOBS = MAX (0.0, XOBS) * SCF
        SIGI = SIGI * SCF
        XCAL = XCAL / PAR(240)
C * TEST FOR MAP-TYPE
        IF (IPR(414) > 0) THEN
C * HANDLE CONTOUR 'REAL MAP' CASE - TEST FOR NOT SHELXL LIST 3
          IF (IGBL(9) /= 21) THEN
C * THREE CORRECTION OPTIONS
            MAPR = 1
            IF (MAPR == 1) THEN
              XOBS =
     1          (SQRT (XOBS) * ACAL / SQRT (XCAL) - ACALA) ** 2 +
     2          (SQRT (XOBS) * BCAL / SQRT (XCAL) - BCALA) ** 2
              ACAL = ACAL - ACALA
              BCAL = BCAL - BCALA
C * NRCVAX TYPE
            ELSE IF (MAPR == 2) THEN
              ACAL = ACAL - ACALA
              BCAL = BCAL - BCALA
              FCAL = SQRT (ACAL**2 + BCAL**2)
              SINA = BCAL / FCAL
              COSA = ACAL / FCAL
              DANO = ACALA * SINA - BCALA * COSA
              DANO = SQRT (MAX (0.0, XOBS - DANO**2))
              XOBS = (DANO - ACALA * COSA - BCALA * SINA)**2
            ELSE IF (MAPR == 3) THEN
              BCAL = BCAL - BCALA
              XOBS = (ACAL**2 + BCAL**2) * XOBS / XCAL
            END IF
            XCAL = ACAL**2 + BCAL**2
          END IF
          IF (ACAL == 0.0 .AND. BCAL == 0.0) THEN
            PCAL = 0.0
          ELSE
            PCAL = ATAN2 (BCAL, ACAL) * RGBL(6)
          END IF
        END IF
        N           = (I - 1) * 7
        VOID(N + 1) = IHT
        VOID(N + 2) = IKT
        VOID(N + 3) = ILT
        VOID(N + 4) = XOBS * PAR(240)
        VOID(N + 5) = XCAL * PAR(240)
        VOID(N + 6) = SIGI * PAR(240)
        VOID(N + 7) = PCAL
      END DO
C * LOAD REFLECTION DATA
      SUM1 = 0.0
      SUM2 = 0.0
      SUM3 = 0.0
      SUM4 = 0.0
C * HANDLE DUPLICATIONS
      DO I = 1, NREF
        M    = (I - 1) * 7
        IHT  = NINT (VOID(M + 1))
        IKT  = NINT (VOID(M + 2))
        ILT  = NINT (VOID(M + 3))
        IHKL = ILT * MHK + IKT * MPH + IHT
        N    = NINT (VOID(IADR + IHKL))
C * CHECK FOR NULL REFERENCE TO REFLECTION DATA
        IF (N < 0) THEN
          VOID(IADR + IHKL) = I
C * NON-EMPTY reference to REFLECTION DATA
        ELSE
          N = (N - 1) * 7
          XOBS1 = VOID(N + 4)
          SIGI1 = VOID(N + 6)
          IF (SIGI1 > 0.0) THEN
            WGTI1 = 1.0 / SIGI1**2
          ELSE
            WGTI1 = 1.0
          END IF
          XOBS2 = VOID(M + 4)
          SIGI2 = VOID(M + 6)
          IF (SIGI2 > 0.0 .AND. WGTI1 /= 1.0) THEN
            WGTI2 = 1.0 / SIGI2**2
          ELSE
            WGTI2 = 1.0
          END IF
          WGTIS = WGTI1 + WGTI2
          VOID(N + 4) = (WGTI1 * XOBS1 + WGTI2 * XOBS2) / WGTIS
          VOID(N + 6) = 1.0 / SQRT (WGTIS)
        END IF
      END DO
C * AVERAGE
      NSYMC = NSYMH * 2
      DO I = 1, MHKL
        J = MHKL + 1 - I
        K = NINT (VOID(IADR1 + J))
        IF (K > 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 /= 0.0) THEN
            SUMT  = XOBS / SIGI**2
            SUMN  = 1.0  / SIGI**2
          ELSE
            SUMT = XOBS
            SUMN = 1.0
          END IF
          DO L = 2, NSYMC
            SGY(1) = IHT
            SGY(2) = IKT
            SGY(3) = ILT
            SGY(4) = PCAL
            IF (L > NSYMH) THEN
              NSX = L - NSYMH
              IS  = -1
            ELSE
              NSX = L
              IS  = 1
            END IF
            CALL SGSM (5, ICL, SGY, NSX, LU7, IERR)
            IH   = NINT (SGY(7))
            IK   = NINT (SGY(8))
            IL   = NINT (SGY(9))
            IHKL = (IL * MHK + IK * MPH  + IH) * IS
            IF (IHKL > IHKLN) THEN
              IHKLN = IHKL
              IHTN  = IH
              IKTN  = IK
              ILTN  = IL
              PCALN = SGY(10)
            END IF
            IF (IHKL /= IHKL0) THEN
              N = NINT (VOID(IADR + IHKL))
              IF (N > 0) THEN
                NADR = (N - 1) * 7
                XOBS = VOID(NADR + 4)
                SIGI = VOID(NADR + 6)
                IF (SIGI /= 0.0) THEN
                  WGHT = 1.0 / SIGI**2
                ELSE
                  WGHT = 1.0
                END IF
                SUMT = SUMT + XOBS * WGHT
                SUMN = SUMN + WGHT
                VOID(IADR + IHKL) = - 1.0
              END IF
            END IF
          END DO
          VOID(IADR + IHKLN) = K
          NADR           = (K - 1) * 7
          VOID(NADR + 1) = IHTN
          VOID(NADR + 2) = IKTN
          VOID(NADR + 3) = ILTN
          VOID(NADR + 4) = SUMT / SUMN
          VOID(NADR + 6) = 1.0  / SQRT (SUMN)
          VOID(NADR + 7) = PCALN
        END IF
      END DO
C * GENERATE UNIQUE LIST FOR CONTOUR
      NRF  = 0
      NRF1 = 0
      CALL GEN108 (LU9, 0)
      DO I = 1, MHKL
        N = NINT (VOID(IADR1 + I))
        IF (N > 0) THEN
          NADR = N * 7
          IH   = NINT (VOID(NADR - 6))
          IK   = NINT (VOID(NADR - 5))
          IL   = NINT (VOID(NADR - 4))
          XOBS = VOID(NADR - 3)
          XCAL = VOID(NADR - 2)
          SIGI = VOID(NADR - 1)
          PCAL = VOID(NADR)
C * AVOID SYSTEMATIV ABSENCES
          SGX(1)  = IH
          SGX(2)  = IK
          SGX(3)  = IL
          SGX(12) = 0.0
          CALL SGSM (27, LINE, SGX, 0, 0, IERR)
          IF (NINT (SGX(12)) == 0) THEN
            NRF1 = NRF1 + 1
            IF (XOBS >= 2 * SIGI) THEN
              SUM1 = SUM1 + ABS (SQRT (XOBS) - SQRT (XCAL))
              SUM2 = SUM2 + SQRT (XOBS)
              NRF  = NRF  + 1
            END IF
C * SHELXL WEIGHT
            SGIK  = SIGI ** 2
            STHLK = GEN095 (PAR(191), IH, IK, IL)
            IF (PAR(493) >= 0.0) THEN
              PXX = (MAX (0.0, XOBS) + 2.0 * XCAL) / 3.0
              IF (PAR(495) > 0.0) THEN
                SGIK = (SGIK + (PAR(493) * PXX)**2 + PAR(494) * PXX) /
     1            EXP (PAR(495) * STHLK)
              ELSE
                SGIK = SGIK + (PAR(493) * PXX)**2 + PAR(494) * PXX
              END IF
            END IF
            SUM3 = SUM3 + ((XOBS - XCAL) ** 2) / SGIK
            SUM4 = SUM4 + (XOBS ** 2) / SGIK
            STHL = SQRT (STHLK)
            FOBS = SQRT (MAX (0.0, XOBS))
            FCAL = SQRT (MAX (0.0, XCAL))
            IF (ICNTR == 2) THEN
              SINA = 0.0
              IF (ABS (PCAL) < 90.0) THEN
                COSA = 1.0
              ELSE
                COSA = -1.0
              END IF
            ELSE
              PHIX = PCAL / RGBL(6)
              SINA = SIN (PHIX)
              COSA = COS (PHIX)
            END IF
C * FO-MAP
            IF (IPR(414) == 1) THEN
              AN0 = FOBS
C * 2Fo-Fc Map
            ELSE IF (IPR(414) == 2) THEN
              AN0 = 2 * FOBS - FCAL
C * Fo - Fc Map
            ELSE IF (IPR(414) == 3) THEN
              AN0 = FOBS - FCAL
C * SQUEEZE Map
            ELSE IF (IPR(414) == 4) THEN
              AN0 = FOBS
C * FO**2 PATTERSON
            ELSE IF (IPR(414) == 5) THEN
              AN0  = FOBS **2
              COSA = 1.0
              SINA = 0.0
            END IF
            AI0 = AN0 * COSA
            BI0 = AN0 * SINA
            IF (AI0 /= 0.0 .OR. BI0 /= 0 .AND.
     1         AN0**2 > SIGI)
     1        WRITE (LU9) IH, IK, IL, AI0, BI0, XCAL / SIGI, STHL
          END IF
        END IF
      END DO
C * R-VALUES (NOT FOR SQUEEZE_CONTOUR AND PATTERSON MAPS)
      IF (IPR(414) < 4) THEN
        N = 0
        IF (PAR(493) >= 0) THEN
          N = INDEX (RLWS(1)(2:80), '''')
          IF (N >= 2) WRITE (LU6, 99996, IOSTAT = IOST) RLWS(1)(2:N)
        END IF
        RANDS(1) = SUM1 / SUM2
        RANDS(2) = SQRT (SUM3 / SUM4)
        RANDS(3) = SQRT (SUM3 / (NRF1 - IPR(226)))
        WRITE (LU6, 99998, IOSTAT = IOST)
     1    RANDS(1), NRF, RANDS(2), NRF1, RANDS(3)
        IF (N >= 2) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99996, IOSTAT = IOST) RLWS(1)(2:N)
        END IF
        CALL PLA262 (6)
        WRITE (LU7, 99998, IOSTAT = IOST)
     1    RANDS(1), NRF, RANDS(2), NRF1, RANDS(3)
      END IF
      RETURN
99999 FORMAT (/, ':: However, no reflection data found (NREF=0)', /)
99998 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, /)
99997 FORMAT (/, 'NVDR too Small in PLA253', /)
99996 FORMAT (/, ':: ', A)
99995 FORMAT (':: SCF =', F10.6, ' (IGBL(9) =', I3,')')
99994 FORMAT (':: Nref', I8, ', Th(max)', F8.2, ', Hmax', I4,
     1        ', Kmax', I4, ', Lmax', I4, /)
99993 FORMAT (/, ':: Load ATOMS and EXPAND')
99992 FORMAT (/, ':: PLA253 - STRUCTURE FACTOR CALCULATION')
      END SUBROUTINE PLA253
 
      SUBROUTINE PLA254
C * DENSITY CONTOUR MAP (5)
C * Smooth contour. Use cubic splines fitting method
C * Reference: D.F. Rogers & J.A. Adams,  Mathematical Elements for
C *            Computer Graphics  (1976), p. 119-133 & 220-223.
      USE files
      USE map
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: NM
      INTEGER               :: IPEN
      REAL                  :: T
      REAL                  :: T2
      REAL                  :: T3
      REAL                  :: C0
      REAL                  :: D0
      REAL                  :: P1
      REAL                  :: P2
      REAL                  :: P3
      REAL                  :: PN
      REAL                  :: TT
      REAL                  :: U1
      REAL                  :: U2
      REAL                  :: SSX
      REAL                  :: SSY
      REAL                  :: STP
      REAL                  :: VAL
      REAL                  :: TEMP
      REAL, DIMENSION(NCT6) :: TAX
C * Calculate span chord lengths,  TAX
      DO I = 2, N7
        P1         = PAX(1, I) - PAX(1, I - 1)
        P2         = PAX(2, I) - PAX(2, I - 1)
        TAX(I - 1) = SQRT (P1**2 + P2**2)
      END DO
C * Zero M-matrix
      DO K = 1, 2
        DO I = 1, N7
          DO J = 1, N7
            SMA(I, J) = 0.0
          END DO
        END DO
C * End conditions for cubic splines
C * ICB = 1  for clamped,   IC = 3  for cyclic
C * ICB = 2  for relaxed,   IC = 4  for anti-cyclic
        IF (IC == 1) THEN
C * Clamped case
          SMA(1, 1)   = 1.0
          SMA(N7, N7) = 1.0
          DO I = 1, 2
            PAX(I + 2,  1) = 1.0
            PAX(I + 2, N7) = 1.0
          END DO
        ELSE IF (IC == 2) THEN
C * Relaxed case
          SMA(1, 1)       = 1.0
          SMA(N7, N7 - 1) = 2.0
          SMA(1, 2)       = 0.5
          SMA(N7, N7)     = 4.0
          DO I = 1, 2
            PAX(I + 2, 1)  = 3.0 * (PAX(I, 2)  - PAX(I, 1)) /
     1                       (2.0 * TAX(1))
            PAX(I + 2, N7) = 6.0 * (PAX(I, N7) - PAX(I, N7 - 1)) /
     1                       TAX(N7 - 1)
          END DO
        ELSE
C * (Anti)Cyclic case
          PN              =  1.0
          IF (IC == 4) PN = -1.0
          T               = TAX(N7 - 1) / TAX(1)
          SMA(1, 1)       = 2.0 + 2.0 * T
          SMA(1, 2)       = T
          SMA(1, N7 - 1)  = PN
          TEMP            = 3.0 / TAX(1)
          DO I = 1, 2
            PAX(I + 2, 1) = TEMP * (T * (PAX(I, 2) - PAX(I, 1))
     1                    + PN * (PAX(I, N7) - PAX(I, N7 - 1)) / T)
          END DO
        END IF
C * Set up main M-matrix
        DO I = 3, N7
          T3                = TAX(I - 1)
          T2                = TAX(I - 2)
          SMA(I - 1, I - 2) = T3
          SMA(I - 1, I - 1) = 2.0 * (T3 + T2)
          SMA(I - 1, I    ) = T2
          DO J = 1, 2
            P1 = PAX(J, I - 2)
            P2 = PAX(J, I - 1)
            P3 = PAX(J, I)
            IF (T2 /= 0.0 .AND. T3 /= 0) THEN
              VAL = 3.0 * (T2 * (P3 - P2) / T3 + T3 * (P2 - P1) / T2)
            ELSE
              VAL = 0.0
            END IF
            PAX(J + 2, I - 1) = VAL
          END DO
        END DO
        L7 = N7
        IF (IC >= 3) L7 = N7 - 1
        L = L7 + 1
        DO I = 1, L7
          SMA(I, L) = PAX(K + 2, I)
        END DO
C * Solution of simultaneous linear equation Gauss-elimination method
        N = L7 + 1
        DO I = 1, L7
          C0 = SMA(I, I)
          IF (C0 /= 1) THEN
            DO J = I, N
              SMA(I, J) = SMA(I, J) / C0
            END DO
          END IF
          DO J = 1, L7
            IF (I /= J) THEN
              C0 = SMA(J, I)
              IF (C0 /= 0.0) THEN
                DO M = I, N
                  D0 = SMA(I, M)
                  SMA(J, M) = SMA(J, M) - C0 * D0
                END DO
              END IF
            END IF
          END DO
        END DO
C * Set up all segments of the piecewise cubic equation,
C * Ax**3 + Bx*x + Cx + D = y
        IF (IC >= 3) SMA(L, L) = SMA(1, L)
        DO I = 2, N7
          P1 = PAX(K, I - 1)
          P2 = PAX(K, I)
          U1 = SMA(I - 1, L)
          U2 = SMA(I, L)
          T  = TAX(I - 1)
          IF (T == 0.0) T = 0.00001
          PAX(K + 10, I - 1) = P1
          PAX(K +  8, I - 1) = U1
          PAX(K +  6, I - 1) = (3.0 * (P2 - P1) / T - 2.0 * U1 - U2) / T
          PAX(K +  4, I - 1) = (2.0 * (P1 - P2) / T + U1 + U2) / (T * T)
        END DO
      END DO
C * Plot smoothed contour on screen
      DO I = NS7, NE7 - 1
        TT = TAX(I)
C * Set up number of intermediate points per span.
C * Coincides with max. resolution of display instrument
        NM  = INT (TT * ABS (SCHAAL * 50)) + 1
        STP = TT / NM
        T   = 0.0
        DO WHILE (T <= TT)
          IF (I == NS7 .AND. T == 0.0) THEN
C * First point, equation x, y = at**3 + bt*t + ct + d, a = b = c = 0
            X = PAX(11, I)
            Y = PAX(12, I)
C * Move to x,y
            IPEN = 3
          ELSE
C * Reject attachment point between segments
            IF (T == 0.0) THEN
              T = STP
              CYCLE
            END IF
            T2 = T  * T
            T3 = T2 * T
            X  = PAX(5,  I) * T3 + PAX(7,  I) * T2
     1         + PAX(9,  I) * T  + PAX(11, I)
            Y  = PAX(6,  I) * T3 + PAX(8,  I) * T2
     1         + PAX(10, I) * T  + PAX(12, I)
C * Draw to x,y
            IPEN = 2
          END IF
          SSX = (X - 1) * SCHAAL + PXS
          SSY = (Y - 1) * SCHAAL + PYS
C * Contour level .le. zero, plot using dashed line
          IF (JVY > 0) THEN
            CALL GGIP (0.0, 3.0, 0.0, 0)
            CALL GGIP (SSX, SSY, 0.0, IPEN)
          ELSE
            IF (IPEN == 3) THEN
              IF (NN == 4) THEN
                CALL GGIP (0.0, 2.0, 0.0, 0)
              ELSE
                CALL GGIP (0.0, 4.0, 0.0, 0)
              END IF
              CALL GGIP (SSX, SSY, 0.0, 3)
C * Dashed line type dependent on  NN
            ELSE
              JVX = JVX + 1
              IF (JVX < NN) THEN
                CALL GGIP (SSX, SSY, 0.0, 2)
              ELSE
                IF (JVX == 2 * NN) JVX = 0
                CALL GGIP (SSX, SSY, 0.0, 3)
              END IF
            END IF
          END IF
          T = T + STP
        END DO
      END DO
      RETURN
      END SUBROUTINE PLA254
 
      SUBROUTINE PLA255
C * DENSITY CONTOUR MAP (6) - INTERPOLATION
C * For 4 pts., fit a 3rd order polynomial, Ax**3 + Bx**2 + Cx + D = IV,
C * and solve it to find contour position.
C * On map border case, only a second order polynomial is used.
      USE files
      USE map
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: ISW
      REAL                  :: A
      REAL                  :: B
      REAL                  :: C
      REAL                  :: D
      REAL                  :: P
      REAL                  :: Q
      REAL                  :: R
      REAL                  :: U
      REAL                  :: V
      REAL                  :: XX
      REAL                  :: V3
      REAL                  :: U3
      REAL                  :: R1
      REAL                  :: R2
      REAL                  :: R3
      REAL                  :: RR
      REAL                  :: SB
      REAL                  :: PF
      REAL                  :: PI
      REAL                  :: PQ
      REAL                  :: PT
      REAL                  :: AA
      REAL                  :: BB
      REAL                  :: EE
      REAL                  :: TH
      REAL, DIMENSION(4, 5) :: CAX
      REAL, DIMENSION(4)    :: YFMP
      L  = 0
      NT = NT + 1
C * CALL EXIT/STOP
      IF (NT > NCT5) CALL GEN127 ('NT Out-of-Range-PROBLEM')
C * IXY .NE. 2 CASE
      IF (IXY /= 2) THEN
C * On left map border, L = 1
        IF (IX == 1) L = 1
C * Set up four points to find a third order polynomial
        DO I = 1, 4
          J = IX + I - 2 + L
C * On right map border, L = 2
          IF (J == MX + 1) L = 2
          IF (L /= 2) THEN
            IF (J > 0 .AND. IY > 0) THEN
              YFMP(I) = FMAP(J, IY)
            ELSE
              YFMP(I) = 0.0
            END IF
          END IF
        END DO
      ELSE
C * IXY = 2 case, condition same as IXY = 1
        IF (IY == 1) L = 1
        DO I = 1, 4
          J = IY + I - 2 + L
          IF (J == MY + 1) L = 2
          IF (L /= 2) THEN
            IF (J > 0 .AND. IY > 0) THEN
              YFMP(I) = FMAP(IX, J)
            ELSE
              YFMP(I) = 0.0
            END IF
          END IF
        END DO
      END IF
      IF (L /= 0) THEN
C * Solve the 2nd order polynomial for 3 pts
        N = 3
C * Set up normal equation matrix 3x4 for Gauss-elimination
        DO I = 1, 3
          X         = I
          CAX(I, 1) = X * X
          CAX(I, 2) = X
          CAX(I, 3) = 1.0
          CAX(I, 4) = YFMP(I)
        END DO
C * Solve Ax*x + Bx + C = y
      ELSE
C * Solve the 3rd order polynomial with 4 pts
        N = 4
C * Set up normal equation matrix 4x5 for Gauss-elimination
        DO I = 1, 4
          X         = I
          CAX(I, 1) = X * X * X
          CAX(I, 2) = X * X
          CAX(I, 3) = X
          CAX(I, 4) = 1.0
          CAX(I, 5) = YFMP(I)
        END DO
      END IF
C * Solution of simultaneous equation using Gauss-elimination method
      M = N + 1
      DO I = 1, N
        C = CAX(I, I)
        DO J = I, M
          CAX(I, J) = CAX(I, J) / C
        END DO
        DO J = 1, N
          IF (I /= J) THEN
            C = CAX(J, I)
            DO K = I, M
              D         = CAX(I, K)
              CAX(J, K) = CAX(J, K) - C * D
            END DO
          END IF
        END DO
      END DO
C * For IXY = 2 case, condition same as IXY = 1
      IF (L /= 0) THEN
        RR = L
        A  = CAX(1, 4)
        B  = CAX(2, 4)
        C  = CAX(3, 4) - IV
C * Solution of the equation, Ax*x + Bx + C = IV
        IF (ABS (A) < 1.E-25) THEN
          R2 = - C / B
        ELSE
          SB = SQRT (ABS (B * B - 4 * A * C))
          R1 = (- B + SB) / (2.0 * A)
          R2 = (- B - SB) / (2.0 * A)
          IF (R1 >= L .AND. R1 <= L + 1) R = R1 - RR
        END IF
        IF (R2 >= L .AND. R2 <= L + 1) R = R2 - RR
      ELSE
C * Solution of equation of third degree,  Ax**3 + Bx*x + Cx + D = IV
C * This routine solves this equation by  Cardan's solution
C * A = CAX(1, 5), B = CAX(2, 5), C = CAX(3, 5), D = CAX(4, 5)
C * The solution is R1,R2,R3 ,but we want it between 2 and 3.
        PI  = 3.141592
        PT  = 1.0 / 3.0
        PF  = 0.5
        EE  = 1.E-20
        AA  = CAX(1, 5)
        BB  = CAX(2, 5)
        ISW = 1
        IF (ABS (AA) <= 1.E-5) THEN
          AA  = 1.0
          ISW = 2
          IF (ABS (BB) <= 1.E-20) ISW = 3
        END IF
        A = BB / AA / 3
        B = CAX(3, 5) / AA
        C = (CAX(4, 5) - IV) / AA
C * If coefficient A .lt. 1.e-5, reduce to second order solution
C * If coefficient A .lt. 1.e-5 & B .lt.1.e-25, reduce to first order
        IF (ISW == 1) THEN
          P  = B / 3.0 - A * A
          Q  = C - A * B + 2.0 * A * A * A
          PQ = Q * Q + 4 * P * P * P
          IF (ABS (PQ) >= EE) THEN
            IF (PQ <= 0.0) THEN
              R  = 2.0 * SQRT (-P)
              XX = Q / P / R
              IF ((1.0 - XX**2) == 0) THEN
                TH = 0
              ELSE
                TH = - ATAN (XX / SQRT (- XX * XX + 1.0)) + 1.5708
                TH = TH / 3.0
              END IF
              R1 =   R * SIN (PI / 2.0 - TH) - A
              R2 = - R * SIN (PI / 6.0 + TH) - A
              R3 = - R * SIN (PI / 6.0 - TH) - A
              IF (R1 >= 2.0 .AND. R1 <= 3.0) R = R1 - 2.0
              IF (R2 >= 2.0 .AND. R2 <= 3.0) R = R2 - 2.0
              IF (R3 >= 2.0 .AND. R3 <= 3.0) R = R3 - 2.0
              GO TO 10
            ELSE
              PQ = SQRT (PQ)
              U3 =   PF * (PQ - Q)
              V3 = - PF * (PQ + Q)
              U  = (ABS (U3)) ** PT * SIGN (1.0, U3)
              V  = (ABS (V3)) ** PT * SIGN (1.0, V3)
              R  = U + V - A - 2.0
              GO TO 10
            END IF
          ELSE
            IF (EE >= ABS (P)) THEN
              R = - A - 2.0
              GO TO 10
            ELSE
              R  = - 1.0 * ABS (PF * Q) ** PT * SIGN (1.0, Q)
              R1 = 2.0 * R - A
              R2 = - R - A
            END IF
          END IF
          IF (R1 >= 2.0 .AND. R1 <= 3.0) R = R1 - 2.0
C * Solution of second order equation
        ELSE IF (ISW == 2) THEN
          A  = A * 3.0
          SB = B * B - 4 * A * C
          IF (SB < 0.0) SB = 0.0
          SB = SQRT (SB)
          R1 = (- B + SB) / (2.0 * A)
          R2 = (- B - SB) / (2.0 * A)
          IF (R1 >= 2.0 .AND. R1 <= 3.0) R = R1 - 2.0
C * Solution of first order equation
        ELSE
          IF (B /= 0.0) THEN
            R2 = - C / B
          ELSE
            R2 = 0.0
          END IF
        END IF
        IF (R2 >= 2.0 .AND. R2 <= 3.0) R = R2 - 2.0
   10   IF (R < 0.0 .OR. R > 1.0)
     1      R = (IV - YFMP(2)) / (YFMP(3) - YFMP(2))
      END IF
      IF (IXY /= 2) THEN
        X = IX + R
        Y = IY
      ELSE
        X = IX
        Y = IY + R
      END IF
      QAX(1, NT) = X
      QAX(2, NT) = Y
      RETURN
      END SUBROUTINE PLA255
 
      SUBROUTINE PLA256
C * DENSITY CONTOUR MAP (7) - HANDLE SQUEEZE SOLV PLOT WITH CONTOUR
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: HMAX
      INTEGER :: KMAX
      INTEGER :: LMAX
      REAL    :: ASOLV
      REAL    :: BSOLV
      REAL    :: STHLK
      REAL    :: GEN095
      CALL PLA023 (0)
      HMAX = -999
      KMAX = -999
      LMAX = -999
      REWIND (LU9,  IOSTAT = IOST)
      REWIND (LU26, IOSTAT = IOST)
      DO
        READ (LU26, *, IOSTAT = IOST) IH, IK, IL, ASOLV, BSOLV
        IF (IOST /= 0) EXIT
        IF (IH == 0 .AND. IK == 0 .AND. IL == 0) EXIT
        HMAX = MAX (HMAX, ABS (IH))
        KMAX = MAX (KMAX, ABS (IK))
        LMAX = MAX (LMAX, ABS (IL))
        STHLK = GEN095 (PAR(191), IH, IK, IL)
        WRITE (LU9) IH, IK, IL, ASOLV, BSOLV, 5.0, STHLK
      END DO
      REWIND (LU9)
C * HEXAGONAL LATTICE
      IF (IPR(259) == 5 .OR. IPR(259) == 6) THEN
        HMAX = MAX (KMAX, HMAX, IABS (HMAX + KMAX))
        KMAX = HMAX
C * TETRAGONAL LATTICE
      ELSE IF (IPR(259) == 4) THEN
        HMAX = MAX (HMAX, KMAX)
        KMAX = HMAX
C * CUBIC LATTICE
      ELSE IF (IPR(259) == 7) THEN
        HMAX = MAX (HMAX, KMAX, LMAX)
        KMAX = HMAX
        LMAX = HMAX
      END IF
      IPR(411) = HMAX
      IPR(412) = KMAX
      IPR(413) = LMAX
      REWIND (LU9, IOSTAT = IOST)
      RETURN
      END SUBROUTINE PLA256
 
      SUBROUTINE PLA257
C * DENSITY CONTOUR MAP (8) - SHOW ATOMS, BONDS & LABELS IN CONTOUR MAP
      USE files
      USE parameters
      USE atomdata
      USE map
      USE cggt
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: NO1
      INTEGER :: NO2
      INTEGER :: MX2
      INTEGER :: MY2
      INTEGER :: IVAL
      INTEGER :: IDUM1
      INTEGER :: IDUM2
      REAL    :: XXA
      REAL    :: XXB
      REAL    :: YYA
      REAL    :: YYB
      REAL    :: XXP
      REAL    :: YYP
      REAL    :: DIST
      REAL    :: DISTI
      REAL    :: DISTMX
      WRITE (LU6, 99999)
C * CHECK FOR NON-PATTERSON MAP AND NON-ZERO NUMBER OF ATOMS
      IF (IPR(414) < 5 .AND. NAT > 0) THEN
C * CHECK FOR BONDS(OFF/ON) OR LABELS (OFF/ON)IN CONTOUR PLOT
        IF (IPR(458) /= 0 .OR. IGBL(75) /= 0) THEN
C * CALCULATE ATOM LOCATION IN CONTOUR PLOT SECTION
          MX2 = (MX - 1) / 2
          MY2 = (MY - 1) / 2
          DO I = 1, NAT
            XXA = PXS + SCHAAL * (XMPC(I, 1) + MX2)
            YYA = PYS + SCHAAL * (XMPC(I, 2) + MY2)
C * CHECK LOCATION WITH PLOT BOUNDARIES
            IF (XXA > PXS .AND. XXA < XPOS) THEN
              IF (YYA > PYS .AND. YYA < YPOS) THEN
C * COLOR CODE ATOM POSITIONS FOR 'IN' OR 'NEAR' CONTOURED SECTION
                IF (IMPC(4, I) < 0.0) THEN
                  CALL GGIP (0.0, 1.0, 0.0, 0)
                ELSE
                  CALL GGIP (0.0, 4.0, 0.0, 0)
                END IF
C * DRAW MARKER ON ATOM POSITION
                XXP = XXA - OFF
                CALL GGIP (XXP, YYA, 0.0, 3)
                XXP = XXA + OFF
                CALL GGIP (XXP, YYA, 0.0, 2)
                YYP = YYA - OFF
                CALL GGIP (XXA, YYP, 0.0, 3)
                YYP = YYA + OFF
                CALL GGIP (XXA, YYP, 0.0, 2)
                CALL GGIP (0.0, 1.0, 0.0, 0)
C * LABEL MARKED ATOMS
                IF (IGBL(75) == 1) THEN
                  CALL GEN048 (-4, IMPC(1, I), 15, NO1)
                  NO1 = IEN(NO1 + 1)
C * CHECK FOR INCLUSION OF H-ATOM LABELS
                  IF (NO1 /= 1 .OR. (NO1 == 1 .AND.
     1                IPR(232) == 1)) THEN
                    XGGIP = XXA + OFF
                    YGGIP = YYA + OFF
C * HANDLE PLOT BOUNDARY
                    IF (YGGIP + 0.3 > YPOS) YGGIP = YGGIP - 2.0 * OFF
                    IF (XGGIP + 1.2 > XPOS)
     1                  XGGIP = XGGIP - 2.0 * OFF - 1.2
                    CALL PLA047 (ABS (IMPC(4, I)), NQ1, IDUM1,
     1               IDUM2, 0, IGBL(55), 0, 0)
                    CALL GEN048 (-1, IMPC(1, I), 30, IVAL)
                    CALL PLA439 (0.0, NQ1, 5, 0.3, 1 + IVAL * 4, 2,
     1                           XGGIP, YGGIP)
                  END IF
                END IF
              END IF
            END IF
          END DO
        END IF
C * SHOW STICK BONDS
        IF (IPR(458) /= 0) THEN
          DO I = 1, NAT - 1
            CALL PLA047 (ABS (IMPC(4, I)), NQ1, IDUM1, IDUM2, 0,
     1        IGBL(55), 0, 0)
            CALL GEN048 (-4, IMPC(1, I), 15, NO1)
            DISTI = REL(IEN(NO1 + 1)) + 0.4
            DO J = I + 1, NAT
              CALL PLA047 (ABS (IMPC(4, J)), NQ2, IDUM1, IDUM2, 0,
     1                     IGBL(55), 0, 0)
              CALL GEN048 (-4, IMPC(1, J), 15, NO2)
              DISTMX = DISTI + REL(IEN(NO2 + 1))
              DIST = 0
              DO K = 4, 6
                DIST = DIST + (XMPC(I, K) - XMPC(J, K))**2
              END DO
              IF (SQRT (DIST) < DISTMX) THEN
                XXA = PXS + SCHAAL * (XMPC(I, 1) + MX2)
                YYA = PYS + SCHAAL * (XMPC(I, 2) + MY2)
C * CHECK BOUNDARIES
                IF (XXA > PXS .AND. XXA < XPOS) THEN
                  IF (YYA > PYS .AND. YYA < YPOS) THEN
                    XXB = PXS + SCHAAL * (XMPC(J, 1) + MX2)
                    YYB = PYS + SCHAAL * (XMPC(J, 2) + MY2)
                    IF (XXB > PXS .AND. XXB < XPOS) THEN
                      IF (YYB > PYS .AND. YYB < YPOS) THEN
                        CALL GGIP (XXA, YYA, 0.0, 3)
                        CALL GGIP (XXB, YYB, 0.0, 2)
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END DO
        END IF
      END IF
      RETURN
99999 FORMAT (/, ':: PLA257 - CONTOUR PLOT OUTPUT')
      END SUBROUTINE PLA257
 
      SUBROUTINE PLA258
C * SETUP REFLECTION DATA
      USE files
      USE parameters
      USE plato
      USE map
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: M
      INTEGER                :: J1
      INTEGER                :: J2
      INTEGER                :: J3
      INTEGER                :: J4
      INTEGER                :: IH
      INTEGER                :: IK
      INTEGER                :: IL
      INTEGER                :: JH = 0
      INTEGER                :: JK = 0
      INTEGER                :: JL = 0
      INTEGER                :: JS
      INTEGER                :: JC
      INTEGER                :: NC
      INTEGER                :: N48
      INTEGER                :: ILE
      INTEGER                :: ILS
      INTEGER                :: NUL
      INTEGER                :: NFR
      INTEGER                :: IND
      INTEGER                :: INDA
      INTEGER                :: IOD4
      INTEGER                :: IOD8
      INTEGER                :: NFOR
      INTEGER                :: NPAS
      INTEGER                :: NEQV
      INTEGER                :: IHKM
      INTEGER                :: MHKL
      INTEGER                :: NPASS
      INTEGER                :: LAYPP
      INTEGER                :: LIMIT
      INTEGER, DIMENSION(24) :: MH
      INTEGER, DIMENSION(24) :: MK
      INTEGER, DIMENSION(24) :: ML
      INTEGER, DIMENSION(4)  :: IOFF
      REAL                   :: FSC
      REAL                   :: FASE
      REAL                   :: STHL  = 0.0
      REAL                   :: ATRM
      REAL                   :: BTRM
      REAL                   :: ATERM = 0.0
      REAL                   :: BTERM = 0.0
      REAL                   :: RSIGI = 0.0
      WRITE (LU6, 99998)
C * READ REFLECTION DATA
      IF (IPR(414) /= 4 .AND. IPR(665) == 0) THEN
        CALL PLA253
      ELSE
        CALL PLA256
      END IF
      IPR(415) = -1
      IPR(418) = 0
      PAR(278) = PAR(271)
      IPR(417) = 1
C * ICENT 1 = NONCENTRO, 2 = CENTRO
      ICENT = IPR(257)
      NEQV  = IPR(255)
      NST   = IPR(48)
      IHM   = IPR(411) + 1
      IKM   = IPR(412) + 1
      ILM   = IPR(413) + 1
      IHKM  = IHM * IKM
      IOD8  = INT(DBLE(NVDR) / 8.0)
      IOD4  = IOD8 * 2
C * CHECK coefficients array LIMIT of NCT1
      LIMIT = 4 * (3 - ICENT) * IHKM * ILM
      IF (LIMIT > NCT1) THEN
        WRITE (LU6, 99999, IOSTAT = IOST) LIMIT
C * CALL EXIT/STOP
        CALL GEN127 (' ')
      END IF
C * CALCULATE & SORT FOURIER COEFFICIENTS (SENSITIVE CODE)
      DO I = 1, 4
        IOFF(I) = (I - 1) * IOD4
      END DO
      N48 = 8 / ICENT
C * DETERMINE HOW MANY LAYERS
      LAYPP = ICENT * IOD8 / IHKM
C * DETERMINE HOW MANY PASSES
      NPASS = ILM / LAYPP
      IF (ILM > NPASS * LAYPP) NPASS = NPASS + 1
C * START AND END VALUES OF H(3) - SUMMED LAST - NORMAL TP PAGE
      ILS = 0
      ILE = LAYPP - 1
C * LOOP FOR REQUIRED NUMBER OF PASSES
      DO NPAS = 1, NPASS
        IF (NPAS == NPASS) ILE = ILM - 1
        M = 4 * IOD4
        CALL GEN074 (VOID, 1, M, 0.0)
        CALL GEN108 (LU9, 0)
C * REFLECTION READ LOOP
        DO
          READ (LU9, IOSTAT = IOST) JH, JK, JL, ATERM, BTERM, RSIGI,
     1                              STHL
          IF (IOST /= 0) EXIT
          IF (RSIGI > FLOAT (IPR(515)) .AND. STHL <= PAR(412)) THEN
            SGY(1) = JH
            SGY(2) = JK
            SGY(3) = JL
            SGY(4) = 0.0
            DO 10 K = 1, NEQV
              CALL SGSM (5, ICL, SGY, K, LU6, IERR)
              IH   = NINT (SGY(7))
              IK   = NINT (SGY(8))
              IL   = NINT (SGY(9))
              MHKL = IABS (IL)
              IF (MHKL >= ILS .AND. MHKL <= ILE) THEN
C * REMOVE DUPLICATIONS
                MH(K) = IH
                MK(K) = IK
                ML(K) = IL
                IF (K > 1) THEN
                  DO J = 1, K - 1
                    IF ((IH ==  MH(J) .AND. IK ==  MK(J) .AND.
     1                   IL ==  ML(J)) .OR.
     2                  (IH == -MH(J) .AND. IK == -MK(J) .AND.
     3                   IL == -ML(J))) GO TO 10
                  END DO
                END IF
C * Calculate code number for reflections (NUL) and sign (NFOR)
C * IH  must not be negative, use Friedel's law with NFR=-1
C * NUL   1=hkl  2=0kl  3=h0l  4=00l  5=hk0  6=0k0  7=h00
C * NFOR  1=+h+k+l, 2= +h-k+l, 3=+h+k-l, 4=+h-k-l
                NUL  = 1
                NFOR = 1
                NFR  = 1
                FSC  = 1.0
                IF (IH < 0) THEN
                  NFR = -1
C * 0kl = 2
                ELSE IF (IH == 0) THEN
                  NUL = NUL + 1
                  FSC = FSC * 0.5
                END IF
                IH = NFR * IH
                IK = NFR * IK
                IL = NFR * IL
                IF (IK < 0) THEN
                  NFOR = NFOR + 1
                  IK   = - IK
C * h0l = 3, 00l = 4
                ELSE IF (IK == 0) THEN
                  NUL = NUL + 2
                  FSC = FSC * 0.5
                END IF
                IF (IL < 0) THEN
                  NFOR = NFOR + 2
                  IL = - IL
C * hk0 = 5, 0k0 = 6, h00 = 7
                ELSE IF (IL == 0) THEN
                  NUL = NUL + 4
                  FSC = FSC * 0.5
                END IF
C * CALCULATE PHASES FOR SYMMETRY EQUIVALENT REFLECTIONS.
                IF (IPR(414) /= 5) THEN
                  FASE = SGY(10) / RGBL(6)
                  ATRM = ( ATERM * COS (FASE) + BTERM * SIN (FASE))
     1                 * FSC
                  BTRM = (-ATERM * SIN (FASE) + BTERM * COS (FASE))
     1                 * FSC * NFR
                ELSE
                  FASE = 0.0
                  ATRM = ATERM * FSC
                  BTRM = BTERM * FSC * NFR
                END IF
                NC  = 1
                IND = IK + 1 + IH * IKM + IHKM * (IL - ILS)
C * hkl REFLECTIONS
                IF (NUL == 1) THEN
                  INDA       = IND  + IOFF(NFOR)
                  VOID(INDA) = ATRM
                  IF (ICENT == 1) VOID(INDA + IOD8) = BTRM
C * 0kl REFLECTIONS
                ELSE IF (NUL == 2) THEN
                  DO I = 1, 2
                    INDA       = IND + IOFF(NFOR)
                    VOID(INDA) = ATRM
                    IF (ICENT == 1) VOID(INDA + IOD8) = BTRM * NC
                    NFOR = 5 - NFOR
                    NC   = -1
                  END DO
C * h0l REFLECTIONS
                ELSE IF (NUL == 3) THEN
                  DO I = 1, 2
                    INDA       = IND + IOFF(NFOR)
                    VOID(INDA) = ATRM
                    IF (ICENT == 1) VOID(INDA + IOD8) = BTRM
                    NFOR = NFOR + 1
                  END DO
C * hk0 REFLECTIONS
                ELSE IF (NUL == 5) THEN
                  DO I = 1, 2
                    INDA       = IND + IOFF(NFOR)
                    VOID(INDA) = ATRM
                    IF (ICENT == 1) VOID(INDA + IOD8) = BTRM
                    NFOR = NFOR + 2
                  END DO
C * 00l REFLECTIONS
                ELSE IF (NUL == 4) THEN
                  DO J = 1, 2
                    DO I = 1, 2
                      INDA       = IND + IOFF(NFOR)
                      VOID(INDA) = ATRM
                      IF (ICENT == 1) VOID(INDA + IOD8) = BTRM * NC
                      NFOR = NFOR + 1
                    END DO
                    NFOR = 6 - NFOR
                    NC   = -1
                  END DO
C * 0k0 REFLECTIONS
                ELSE IF (NUL == 6) THEN
                  DO J = 1, 2
                    DO I = 1, 2
                      INDA     = IND + IOFF(NFOR)
                      VOID(INDA) = ATRM
                      IF (ICENT == 1) VOID(INDA + IOD8) = BTRM * NC
                      NFOR = NFOR + 2
                    END DO
                    NFOR = 7 - NFOR
                    NC   = -1
                  END DO
C * h00 REFLECTIONS
                ELSE IF (NUL == 7) THEN
                  DO J = 1, 4
                    INDA       = IND + IOFF(J)
                    VOID(INDA) = ATRM
                    IF (ICENT == 1) VOID(INDA + IOD8) = BTRM
                  END DO
                END IF
              END IF
   10       CONTINUE
          END IF
        END DO
C * CALCULATE THE FINAL FOURIER COEFFICIENTS
        DO I = ILS, ILE
          JS = (I - ILS) * IHKM
          JC = I  * IHKM * N48 + 1
          DO J = JS + 1, JS + IHKM
            J1 = J
            J2 = J1 + IOD4
            J3 = J2 + IOD4
            J4 = J3 + IOD4
C * THE NEXT 4 LINES ARE THE TERMS ACCC, ASSC, ASCS, ACSS
 
            COEF(JC)     =   VOID(J1) + VOID(J2) + VOID(J3) + VOID(J4)
            COEF(JC + 1) = - VOID(J1) + VOID(J2) - VOID(J3) + VOID(J4)
            COEF(JC + 2) = - VOID(J1) - VOID(J2) + VOID(J3) + VOID(J4)
            COEF(JC + 3) = - VOID(J1) + VOID(J2) + VOID(J3) - VOID(J4)
            IF (ICENT == 1) THEN
              J1 = J1 + IOD8
              J2 = J2 + IOD8
              J3 = J3 + IOD8
              J4 = J4 + IOD8
C * The next 4 lines are the terms BCCS, BSSS, BSCC, BCSC
              COEF(JC + 4) =   VOID(J1) + VOID(J2) - VOID(J3) - VOID(J4)
              COEF(JC + 5) = - VOID(J1) + VOID(J2) + VOID(J3) - VOID(J4)
              COEF(JC + 6) =   VOID(J1) + VOID(J2) + VOID(J3) + VOID(J4)
              COEF(JC + 7) =   VOID(J1) - VOID(J2) + VOID(J3) - VOID(J4)
            END IF
            JC = JC + N48
          END DO
        END DO
        ILS = ILS + LAYPP
        ILE = ILE + LAYPP
        IF (ILE > ILM - 1) ILE = ILM - 1
      END DO
      RETURN
99999 FORMAT ('Job too large for COEFF array. ',I6,' needed ')
99998 FORMAT (/, ':: PLA258 -Read reflection data and prepare for',
     1 ' Fourier Map')
      END SUBROUTINE PLA258
 
      SUBROUTINE PLA259
C * GENERATE THE COORDINATES OF ALL ATOMS IN THE UNIT CELL
      USE files
      USE parameters
      USE plato
      USE map
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      WRITE (LU6, 99999)
C * NUMBER OF ATOMS IN ATOM ARRAY COUNTER
      NAX = 0
      DO I = 1, IPR(39)
        DO J = 1, 3
          SGY(J)     = XXO(I, J)
          SGY(J + 3) = 0.0
        END DO
C * CHECK FOR ENOUGH SPACE IN ATOM ARRAY
        IF (NAX + NST <= NCT0) THEN
          M = NAX + 1
          DO 20 J = 1, NST
            CALL SGSM (3, ICL, SGY, J, LU6, IERR)
            DO K = 1, 3
              ATOM(K, NAX + 1) = MOD (SGY(6 + K) + 5.0, 1.0)
            END DO
C * GET RID OF REDUNDANT COORDINATES
            IF (J /= 1) THEN
              DO 10 L = M, NAX
                DO K = 1, 3
                  IF (ABS(ATOM(K, NAX + 1) - ATOM(K, L)) > 1.0E-6)
     1              GO TO 10
                END DO
                GO TO 20
   10         CONTINUE
            END IF
            NAX        = NAX + 1
            LATOM(NAX) = LABA(I)
            DO K = 1, 3
              IFLG(K, NAX) = IFG(K, I)
            END DO
   20     CONTINUE
        ELSE IF (NAX + NST > NCT0) THEN
          CALL PLA015 (0, 56)
          EXIT
        ENDIF
      END DO
99999 FORMAT (':: PLA259 - Generate Coordinates in Unit Cell')
      RETURN
      END SUBROUTINE PLA259
 
      SUBROUTINE PLA260
C * DEFINE PLANE & GRID
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE map
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: N
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      INTEGER            :: IVAL
      INTEGER            :: NEXIT
      INTEGER            :: FINDEXE
      REAL               :: R
      REAL               :: CX
      REAL               :: CY
      REAL               :: CZ
      REAL               :: SX
      REAL               :: SY
      REAL               :: SZ
      REAL               :: CX1
      REAL               :: CY1
      REAL               :: CZ1
      REAL               :: SX1
      REAL               :: SY1
      REAL               :: SZ1
      REAL               :: CXT
      REAL               :: CYT
      REAL               :: CZT
      REAL               :: CXCZ
      REAL               :: CXSZ
      REAL               :: SXCZ
      REAL               :: SXSZ
      REAL               :: UPL1
      REAL               :: UPL2
      REAL               :: UPL3
      REAL               :: DIST
      REAL               :: XLNG
      REAL               :: SINPHI
      REAL               :: COSPHI
      REAL               :: GEN009
      REAL, DIMENSION(3) :: V0
      NEXIT = 0
      WRITE (LU6, 99989)
      DO
        PHI = PAR(276) / RGBL(6)
        MX  = NINT (PAR(272) / PAR(271) + 0.5) + 1
        MY  = NINT (PAR(273) / PAR(271) + 0.5) + 1
        NXP = MX / 2
        NXM = 1 + NXP - MX
        NYP = MY / 2
        NYM = 1 + NYP - MY
C * Frame of reference XN(I, 1)=x-axis; XN(I, 2)=y-axis; XN(I, 4)=origin
        DO I = 1, 3
          DIST = GEN009 (VLAK, CMAT(1, I)) - VLAK(4)
          DO J = 1, 3
            V1(J) = DIST * VLAK(J)
          END DO
          CALL GEN015 (CMAT(1, I), V1, V2, -1.0)
          DO J = 1, 3
            CMAT(J, I) = V2(J)
          END DO
        END DO
        CALL GEN015 (CMAT(1, 1), CMAT(1, 2), V1, -1.0)
        DIST = SQRT (GEN009(V1, V1))
        DO I = 1, 3
          XN(I, 1) = V1(I) / DIST
        END DO
        CALL GEN008 (VLAK, XN(1, 1), XN(1, 2), 0)
        DO I = 1, 3
          XN(I, 4) = PAR(274) * XN(I, 1) + PAR(275) * XN(I, 2)
     1             + CMAT(I, 2)
        END DO
        CALL GEN002 (1, ROR, XN(1, 4), XFO, XLNG)
        SINPHI = SIN (PHI)
        COSPHI = COS (PHI)
        DO I = 1, 3
          V1(I) =  COSPHI * XN(I, 1) + SINPHI * XN(I, 2)
          V2(I) = -SINPHI * XN(I, 1) + COSPHI * XN(I, 2)
        END DO
        DO I = 1, 3
          XN(I, 1) = PAR(271) * V1(I)
          XN(I, 2) = PAR(271) * V2(I)
        END DO
C * Unit translations in x and y directions
        CALL GEN002 (1, ROR, XN(1, 1), DXF, XLNG)
        CALL GEN002 (1, ROR, XN(1, 2), DYF, XLNG)
C * Fractional coordinates of corners of map
        CALL GEN002 (1, ROR, XN(1, 4), FC(1,5), XLNG)
        DO I = 1, 3
          V0(I) = NYM * DYF(I)
          V1(I) = NYP * DYF(I)
          V2(I) = NXM * DXF(I)
          V3(I) = NXP * DXF(I)
        END DO
        CALL GEN015 (V2, V1, FC(1, 1), 1.0)
        CALL GEN015 (V3, V1, FC(1, 2), 1.0)
        CALL GEN015 (V3, V0, FC(1, 3), 1.0)
        CALL GEN015 (V2, V0, FC(1, 4), 1.0)
        DO I = 1, 4
          CALL GEN015 (FC(1, I), FC(1, 5), V1, 1.0)
          DO J = 1, 3
            FC(J, I) = V1(J)
          END DO
        END DO
C * Write width and height of map for scaling
        WRITE (LU7, 99996, IOSTAT = IOST)
        WRITE (LU7, 99995, IOSTAT = IOST) (XFO(I), I = 1, 3)
        WRITE (LU7, 99994, IOSTAT = IOST) (FC(I, 1), I = 1, 3),
     1    NXM, NYP
        WRITE (LU7, 99993, IOSTAT = IOST) (FC(I, 2), I = 1, 3),
     1    NXP, NYP
        WRITE (LU7, 99992, IOSTAT = IOST) (FC(I, 3), I = 1, 3),
     1    NXP, NYM
        WRITE (LU7, 99991, IOSTAT = IOST) (FC(I, 4), I = 1, 3),
     1    NXM, NYM
        DO I = 1, 3
         ULC(I) = FC(I, 1)
        END DO
C * DO THE FOURIER SUMMATION
        IF (IPR(414) == 3) THEN
C * DIFF-Map
          F000 = 0.0
        ELSE
          IF (PAR(277) /= 0.0) THEN
            F000 = PAR(277)
          ELSE
            F000 = PAR(157)
          END IF
        END IF
C * Calculate the MX * MY map from the sorted coeficients
C * Calculate the map by evaluating the P1 or P-1 form
        DO J = 1, MY
          UPL1 = ULC(1) - DXF(1) - (J - 1) * DYF(1)
          UPL2 = ULC(2) - DXF(2) - (J - 1) * DYF(2)
          UPL3 = ULC(3) - DXF(3) - (J - 1) * DYF(3)
          DO I = 1, MX
            X   = (UPL1 + I * DXF(1)) * RGBL(5)
            Y   = (UPL2 + I * DXF(2)) * RGBL(5)
            Z   = (UPL3 + I * DXF(3)) * RGBL(5)
            SX1 = SIN (X)
            CX1 = COS (X)
            SY1 = SIN (Y)
            CY1 = COS (Y)
            SZ1 = SIN (Z)
            CZ1 = COS (Z)
            CZ  = CZ1
            SZ  = -SZ1
            R   = F000 / 2.0
            K   = 0
C * CALC COS(LX) FROM COS((L-1)X + X) = C((L-1)X)C(X) - S((L-1)X)S(X) ETC.
            DO IL = 1, ILM
              CZT = CZ * CZ1 - SZ * SZ1
              SZ  = SZ * CZ1 + CZ * SZ1
              CZ  = CZT
              CX  = CX1
              SX  = -SX1
              DO IH = 1, IHM
                CXT  = CX * CX1 - SX * SX1
                SX   = SX * CX1 + CX * SX1
                CX   = CXT
                CXCZ = CX * CZ
                CXSZ = CX * SZ
                SXCZ = SX * CZ
                SXSZ = SX * SZ
                CY   = CY1
                SY   = -SY1
                DO IK = 1, IKM
                  CYT = CY * CY1 - SY * SY1
                  SY  = SY * CY1 + CY * SY1
                  CY  = CYT
                  K = K + 4
                  R   = R + COEF(K - 3) * CXCZ * CY
     1                    + COEF(K - 2) * SXCZ * SY
     2                    + COEF(K - 1) * SXSZ * CY
     3                    + COEF(K)     * CXSZ * SY
                  IF (ICENT == 1) THEN
                    K = K + 4
                    R   = R + COEF(K - 3) * CXSZ * CY
     1                      + COEF(K - 2) * SXSZ * SY
     2                      + COEF(K - 1) * SXCZ * CY
     3                      + COEF(K)     * CXCZ * SY
                  END IF
                END DO
              END DO
            END DO
            FMAP(I, MY - J + 1) = R * 200 / PAR(98)
          END DO
        END DO
C * INPUT FOR MARCHING CUBE
        IF (IPR(580) == 1) THEN
          WRITE (LU65, 99998, IOSTAT = IOST) MX * MY
          WRITE (LU65, 99997, IOSTAT = IOST)
     1          ((FMAP(I, J) * 0.01, J = 1, MY), I = 1, MX)
          NRSECT = NRSECT + 1
          IF (NRSECT > NSECTIONS) THEN
            LRTN    = 2
            VLAK(4) = VLAK(4) - IPR(578) * PAR(278)
C * ADD ANGSTROM COORDINATES FOR MCT
            CALL GEN008 (XN(1, 1), XN(1, 2), XN(1, 3), 1)
            DO I = 1, 3
              RORO(3, I) = XN(I, 3)
            END DO
            DO I = 1, 2
              DO J = 1, 3
                RORO(I, J) = XN(J, I) / PAR(271)
              END DO
            END DO
            WRITE (LU65, 99990, IOSTAT = IOST) IPR(39), 14
            DO I = 1, IPR(39)
              IVAL = NINT (XMCT(4, I)) + 1
              NQ1  = LMT(IVAL, 1)
              CALL GEN020 (1, NQ1, 2, 2)
              N = 0
              IF (NQ1(1:1) == ' ') N = 1
              DO J = 1, 3
                V1(J) = XMCT(J, I)  - FMAT(J, 2)
              END DO
              CALL GEN002 (1, OR, V1, V2, XLNG)
              CALL GEN002 (1, RORO, V2, V3, XLNG)
              V3(1) = V3(1) - PAR(274)
              V3(2) = V3(2) - PAR(275)
              WRITE (LU65, 99999, IOSTAT = IOST)
     1          NQ1(1 + N:4 + N), CHAR (0), FLOAT (I), 1.0, 0.0,
     2          (V3(J), J = 1, 3), 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0
            END DO
            CLOSE (UNIT = LU65)
C * F3D
            NE = FINDEXE ('F3DEXE', PLPATH, 'f3d')
            IF (NE > 0) THEN
              PLPATH(NE + 1:) = ' '//NAMEFIL(1:KNMFIL)//'.fou &'
              CALL SPAWN (PLPATH, LU6, .true., KERR)
            END IF
            IPR(580) = -1
          ELSE
            VLAK(4) = VLAK(4) + PAR(278)
          END IF
          CYCLE
        END IF
        IF (NEXIT == 0) EXIT
      END DO
      RETURN
99999 FORMAT (A, A, 13(/, F15.8))
99998 FORMAT ('BLOCK', /, I8)
99997 FORMAT (F15.8)
99996 FORMAT (/, 20X, 'Origin and Map Corners')
99995 FORMAT ('Origin', 11X, 3F9.5, 6X, '0', 4X, '0')
99994 FORMAT ('UpperLeftCorner  ', 3F9.5, 2X, 2I5)
99993 FORMAT ('UpperRightCorner ', 3F9.5, 2X, 2I5)
99992 FORMAT ('LowerRightCorner ', 3F9.5, 2X, 2I5)
99991 FORMAT ('LowerLeftCorner  ', 3F9.5, 2X, 2I5)
99990 FORMAT ('LIST5', 2(/, I8))
99989 FORMAT (':: PLA260 - Define Plane and Grid')
      END SUBROUTINE PLA260
 
      SUBROUTINE PLA261 (NFILE)
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: IB
      INTEGER           :: IE
      INTEGER           :: KB
      INTEGER           :: KD
      INTEGER           :: KE
      INTEGER           :: KNMM
      INTEGER           :: KXTM
      INTEGER           :: JARG
      INTEGER           :: NFILE
      CHARACTER(len=80) :: DUM
      IF (NFILE > 0) THEN
C * GET FILENAME ROOT AND EXTENSION
        IB   = 1
        IE   = 80
        KNMM = 70
        KXTM = 9
C * SEARCH FOR FILENAME EXTENSION
        KXT = 3
        KB  = IB
        KE  = IE
C *STRIP HEADER AND TRAILER BLANKS
        CALL GEN039 (0, FILENAMES(1), IB, IE, KB, KE)
        IF (KE >= KB) THEN
          KD = 0
          DO I = KB, KE
            IF (FILENAMES(1)(I:I) == '.') KD = I
          END DO
          IF (KD /= 0) THEN
            IF (KB + KD - 1 == KE) THEN
              KE  = KE - 1
            ELSE
              EXTENS = FILENAMES(1)(KB + KD : KE)
              KXT    = KE - KB - KD + 1
              KE     = KB + KD - 2
            END IF
          ELSE
            JARG = COMMAND_ARGUMENT_COUNT()
            DUM = FILENAMES(1)
            CALL GEN020 (1, DUM, 1, 80)
C * PLATON SPGR name or PLATON HALL name (in '') COMMAND
            IF (INDEX (DUM, 'SPGR') /= 0 .OR.
     1          INDEX (DUM, 'HALL') /= 0) THEN
              CALL PLA348
              STOP
C * PLATON ANOM value COMMAND
            ELSE IF (INDEX (DUM, 'ANOM') /= 0 .AND. JARG == 2) THEN
              CALL GET_COMMAND_ARGUMENT (2, DUM)
              READ (DUM, *, IOSTAT = IOST) FN(1)
              IF (IOST == 0) THEN
                IGBL(25) = 0
                IPR(220) = 0
                IPR(221) = 1
                CALL PLA385 (1)
              END IF
              STOP
            ELSE
C * CALL EXIT/STOP
              CALL GEN127 ('No Filename Extension Found on Filename')
            END IF
          END IF
        END IF
        IF (KB <= KE) THEN
          KNMFIL = KE - KB + 1
C * CALL EXIT/STOP
          IF (KNMFIL > KNMM) CALL GEN127 ('Filename too long')
C * CALL EXIT/STOP
          IF (KXT > KXTM) CALL GEN127 ('File-extention too long')
C * CALL EXIT/STOP
          IF (EXTENS(1:3) == 'eld')
     1      CALL GEN127 ('name.eld not allowed')
          NAMEFIL = FILENAMES(1)(KB : KE)
          IF (FILENAMES(1)(KB:KE + 1) == 'check.') THEN
            CALL GEN127 ('Filename with Root check NOT allowed')
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA261
 
      SUBROUTINE PLA262 (N)
C * SUBROUTINE KEEPS TRACK OF LINE-NUMBER AND INSERTS NEW-PAGE WHEN
C * NL > IGBL(102)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: N
      IF (N == -999) THEN
        IF (IGBL(63) > 2) THEN
          WRITE (LU7, 99998, IOSTAT = IOST)
          DO I = 1, INDP
            WRITE (LU7, 99997, IOSTAT = IOST) INDEXP(I), PAGEIND(I)
          END DO
          WRITE (LU7, 99996, IOSTAT = IOST)
          IPR(83) = INDP + 4
        END IF
      ELSE
C * TRAILER LISTING
        IF (IGBL(7) == 0) THEN
          IF (IPR(210) == 1) THEN
            OPEN (UNIT = LU7, FILE = NAMEFIL(1:KNMFIL) //'_sq.lis',
     1                STATUS = 'UNKNOWN')
            IGBL(7) = 2
          ELSE
            OPEN (UNIT = LU7, FILE = NAMEFIL(1:KNMFIL) //'.lis',
     1                STATUS = 'UNKNOWN')
            IGBL(7) = 1
          END IF
        END IF
C * TEST WHETHER THERE ARE /N/ LINES AVAILABLE. IF NOT EJECT NEW PAGE.
        IF (N > 0) THEN
          IPR(83) = IPR(83) + N
          IF (IPR(83) <= IGBL(102)) RETURN
        END IF
C * INITIALIZE AND GIVE NEW PAGE (N <= 0)
        IPR(83) = IABS (N) + 3
        IF (IGBL(63) > 2) THEN
          IGBL(49) = IGBL(49) + 1
C * CHECK FOR PAGE HEADER
          IF (IGBL(137) == 1) THEN
            WRITE (LU7, 99999, IOSTAT = IOST)
     1        CHAR (12), JID(1:10), PAGET, IGBL(49)
          ENDIF
          IF (INDP == 0) THEN
            INDP       = 1
            PAGEIND(1) = PAGET
            INDEXP(1)  = IGBL(49)
          ELSE
            IF (PAGET /= PAGEIND(INDP)) THEN
              INDP = INDP + 1
              PAGEIND(INDP) = PAGET
              INDEXP(INDP)  = IGBL(49)
            END IF
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (A, 92X, '"', A, '"  ', 'PLATON-', A, 2X, 'Page', I5,
     1 /, 132('='))
99998 FORMAT ('Page - Index', /, 80('='), /)
99997 FORMAT ('Page', I4, ' --- ', A)
99996 FORMAT (/)
      END SUBROUTINE PLA262
 
      SUBROUTINE PLA263 (LU, PRBUF, JBUFL, NLINE, JSUBST)
      IMPLICIT NONE
      INTEGER          :: LU
      INTEGER          :: JBUFL
      INTEGER          :: NLINE
      INTEGER          :: JSUBST
      CHARACTER(len=*) :: PRBUF
      IF (NLINE > 0) CALL PLA262 (NLINE)
      CALL GEN065 (LU, PRBUF, 1, JBUFL, JSUBST)
      RETURN
      END SUBROUTINE PLA263
 
      SUBROUTINE PLA265 (NPC, LU)
C * DELAUNEY-REDUCTION
      USE files
      USE parameters
      USE xwdw
      USE cggt
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: L
      INTEGER                        :: M
      INTEGER                        :: N
      INTEGER                        :: IC
      INTEGER                        :: ID
      INTEGER                        :: II
      INTEGER                        :: IK
      INTEGER                        :: LU
      INTEGER                        :: IS
      INTEGER                        :: IZ
      INTEGER                        :: JD
      INTEGER                        :: KD
      INTEGER                        :: M1
      INTEGER                        :: M2
      INTEGER                        :: MX
      INTEGER                        :: N1
      INTEGER                        :: N2
      INTEGER                        :: MC
      INTEGER                        :: INO
      INTEGER                        :: ISE
      INTEGER                        :: ISJ
      INTEGER                        :: IST
      INTEGER                        :: NBR
      INTEGER                        :: NCP
      INTEGER                        :: ISYS
      INTEGER                        :: INL1
      INTEGER                        :: INL2
      INTEGER                        :: INL3
      INTEGER                        :: IYUNK
      INTEGER, DIMENSION(27)         :: Q
      INTEGER, DIMENSION(3)          :: KJ
      INTEGER, DIMENSION(4, 4)       :: IG
      INTEGER, DIMENSION(7)          :: NQ
      INTEGER, DIMENSION(7)          :: MQ
      INTEGER, DIMENSION(4, 4)       :: GC
      INTEGER, DIMENSION(3, 3, 85)   :: TR
      INTEGER, DIMENSION(7, 7)       :: IV
      INTEGER, DIMENSION(4)          :: NL
      INTEGER, DIMENSION(4, 4, 7)    :: TP
      INTEGER, DIMENSION(20, 14)     :: TT
      INTEGER, DIMENSION(30)         :: SB
      INTEGER, DIMENSION(30)         :: NCL
      INTEGER, DIMENSION(8, 30)      :: SKI
      INTEGER, DIMENSION(3, 7)       :: INC
      INTEGER, DIMENSION(8)          :: NVV
      INTEGER, DIMENSION(8)          :: MVV
      INTEGER, DIMENSION(8)          :: LVV
      INTEGER, DIMENSION(13)         :: IDT
      REAL                           :: XM
      REAL                           :: YM
      REAL                           :: ZM
      REAL                           :: ZW
      REAL                           :: ZW1
      REAL                           :: ZW2
      REAL                           :: ZW3
      REAL                           :: ZW4
      REAL,    DIMENSION(4, 4)       :: A
      REAL,    DIMENSION(4, 4)       :: G
      REAL,    DIMENSION(4, 4)       :: E
      REAL,    DIMENSION(7, 7)       :: O
      REAL,    DIMENSION(4, 4)       :: GN
      REAL,    DIMENSION(3, 3)       :: AW
      REAL,    DIMENSion(4, 4)       :: AV
      REAL,    DIMENSION(4, 4, 6)    :: PP
      REAL,    DIMENSION(3, 3)       :: GW
      REAL,    DIMENSION(3, 3)       :: GG
      REAL,    DIMENSION(6)          :: AC
      REAL,    DIMENSION(4, 4)       :: GV
      REAL,    DIMENSION(7, 7)       :: GS
      REAL,    DIMENSION(4, 4)       :: AD
      CHARACTER(len=1), DIMENSION(6) :: Y
      CHARACTER(len=1), DIMENSION(7) :: HT
      CHARACTER(len=1)               :: NPC
      CHARACTER(len=132)             :: PRBUF
      Y  = (/ 'a', 'm', 'o', 't', 'h', 'c'/)
      HT = (/ 'P', 'A', 'B', 'C', 'F', 'I', 'R'/)
      GC = RESHAPE ((/ 0, 12, 13, 14, 12, 0, 23, 24, 13, 23, 0, 34, 14,
     1                24, 34, 0/), (/4, 4/))
      Q  = (/ 1, 1, 4, 1, 1, 2, 3, 2, 2, 1, 1, 3, 1, 1, 4, 4, 2, 2, 2,
     1        3, 3, 4, 2, 3, 4, 4, 1/)
      PP = RESHAPE ( (/
     1 -1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  1.0,  0.0,
     2  0.0,  1.0,  0.0,  0.0,  1.0, -1.0,  0.0,  0.0,  0.0,  1.0,  1.0,
     3  0.0,  0.0,  0.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,  1.0, -1.0,
     4  0.0,  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,  0.0,  0.0,  0.0,  1.0,
     5  1.0,  0.0,  1.0,  0.0,  0.0, -1.0,  0.0,  0.0,  1.0,  1.0,  0.0,
     6  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  1.0,  0.0,  1.0,  0.0, -1.0,
     7  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,  0.0,  0.0,  0.0,  1.0,  0.0,
     8  1.0,  1.0,  0.0,  0.0,  0.0, -1.0,  0.0,  1.0,  0.0,  1.0,  0.0,
     9  0.0,  0.0,  0.0,  1.0,  0.0,  1.0,  1.0,  0.0/), (/4, 4, 6/))
       NVV = (/ 14, 15, 19, 14, 14, 17, 18, 16/)
       IV  = RESHAPE ((/
     1 0, 5, 6, 7, 2, 3, 4, 5, 0, 7, 6, 1, 4, 3, 6, 7, 0, 5, 4, 1, 2, 7,
     2 6, 5, 0, 3, 2, 1, 2, 1, 4, 3, 0, 0, 0, 3, 4, 1, 2, 0, 0, 0, 4, 3,
     3 2, 1, 0, 0, 0/), (/7, 7/))
       INC = RESHAPE ((/1 1, 0, 0, 0, 1, 0, 0, 0, 1, -1, -1, -1, 1, 1,
     1   0, 1, 0, 1, 0, 1, 1/), (/3, 7/))
       SKI = RESHAPE ((/
     1  0,  0, 14,  0, 14, 14,  1, 61,  0,  0, 14, 14, 14,  0,  2, 61,
     2  0, 13, 13, 13, 13,  0,  3, 65, 12, 12, 12, 12, 12, 12,  4, 66,
     3 12,  0, 12,  0, 12, 34,  1, 51,  0, 13, 13, 13, 24,  0,  5, 57,
     4 12, 12, 14, 12, 14, 14,  6, 57,  0,  0, 14,  0, 14, 34,  1, 41,
     5  0,  0, 14, 14, 24,  0,  2, 41,  0,  0, 14, 23,  0, 23, 13, 41,
     6  0, 13, 13, 13, 13, 34,  7, 46, 12, 13, 13, 13, 13, 12,  4, 46,
     7  0,  0, 14,  0, 24, 34,  1, 31,  0,  0, 14, 23, 24,  0,  2, 31,
     8  0, 13, 14, 14, 13,  0,  4, 36,  0, 13, 13, 23, 23,  0,  7, 36,
     9 12,  0, 14,  0, 12, 34,  8, 34, 12,  0, 14,  0, 14, 34,  9, 34,
     *  0, 13, 13, 23, 23, 34,  7, 36, 12, 13, 14, 14, 13, 12,  4, 36,
     1 12, 13, 13, 13, 13, 34,  3, 35,  0, 13, 14,  0, 24, 34,  1, 21,
     2  0, 13, 14, 23, 23,  0, 10, 26,  0, 13, 14, 23, 13,  0, 28, 26,
     3  0, 13, 14, 14, 13, 34, 11, 26,  0, 13, 14, 13, 14, 34, 12, 26,
     4  0, 13, 14, 23, 23, 34, 10, 26, 12, 13, 14, 14, 13, 34, 11, 26,
     5 12, 13, 14, 13, 14, 34, 12, 26, 12, 13, 14, 23, 24, 34,  1, 11
     6 /), (/8, 30/))
      TR = RESHAPE ((/
     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, 1, 0, 1, 0, 1, 0,-1, 0, 0,
     2 1, 0, 1, 0,-1, 0, 0, 0,-1, 1, 0, 0, 0, 1, 0, 0, 0, 1,
     3 1, 0, 0, 0,-1, 0, 0, 0,-1,-1, 0, 0, 0, 1, 0, 0, 0,-1,
     4-1, 0, 0, 0,-1, 0, 0, 0, 1, 1, 1, 0, 0,-1,-1,-1, 0,-1,
     5 1, 1, 0, 0,-1, 1, 1,-1,-1,-1,-1, 0, 0, 1, 1,-1, 1,-1,
     6-1, 1, 0, 0,-1,-1,-1,-1, 1, 1, 0, 1, 1, 0,-1, 0, 1, 0,
     7 0, 1, 1, 0,-1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0,-1, 1,-1,
     8 0, 0, 1, 1,-1, 0, 1, 1,-1, 1, 0, 0, 0, 1, 1,-1,-1, 1,
     9 1, 0, 0, 0,-1, 1,-1,-1,-1, 0, 1, 0, 1, 0, 1, 1,-1,-1,
     * 0, 1, 0, 1, 0,-1,-1,-1,-1,-1, 1, 0, 0, 0, 1, 1, 0, 0,
     1 1, 0, 0, 0, 1, 0,-1, 0, 1, 0,-1, 1, 1, 0, 0, 0, 0, 1,
     2 0, 1, 0, 0, 0, 1, 1,-1, 0, 0, 1, 1, 1, 0, 0, 0, 0,-1,
     3 1, 0,-1, 0, 1, 0, 0, 0, 1, 1, 0, 0, 1, 2, 0, 0, 0, 1,
     4 0, 1, 0,-2,-1, 0, 0, 0, 1, 1, 2, 1, 1, 0, 0, 0, 0,-1,
     5 1, 0,-1, 1, 2, 0, 0, 0, 1,-1, 1, 1, 1, 1, 0, 0, 0,-1,
     6 1, 1,-1,-1, 1, 0, 0, 0, 1, 2, 1, 1, 0, 1, 0, 0, 0, 1,
     7 0, 0, 1, 2, 1, 0, 0, 1,-1, 6,-6, 0, 0, 6,-6, 3, 3, 3,
     8 6, 6, 0, 0,-6, 6, 3,-3,-3,-6,-6, 0, 0, 6, 6,-3, 3,-3,
     9-6, 6, 0, 0,-6,-6,-3,-3, 3, 3,-3, 3, 6, 6, 0,-3, 3, 3,
     *-3,-3, 3, 6,-6, 0, 3, 3, 3,-3, 3, 3, 6, 0, 6, 3, 3,-3,
     1 3, 3, 3, 6, 0,-6,-3, 3,-3, 3, 3,-3, 0, 6, 6, 3,-3, 3,
     2 3,-3,-3, 0, 6,-6, 3, 3, 3, 3,-3, 0, 3, 3, 0, 0, 0, 6,
     3 3, 0, 3, 3, 0,-3, 0, 6, 0, 0, 3, 3, 0,-3, 3, 6, 0, 0,
     4 3,-3, 0, 0, 3,-3, 6, 6, 6, 3, 3, 0, 0,-3, 3, 6,-6,-6,
     5-3,-3, 0, 0, 3, 3,-6, 6,-6,-3, 3, 0, 0,-3,-3,-6,-6, 6,
     6 0, 0, 6, 3, 3, 0,-3, 3, 0, 0, 0, 6, 3,-3, 0, 3, 3, 0,
     7 6, 0, 0, 0, 3, 3, 0,-3, 3, 6, 0, 0, 0,-3, 3, 0,-3,-3,
     8 0, 6, 0, 3, 0, 3, 3, 0,-3, 0, 6, 0, 3, 0,-3,-3, 0,-3,
     9 0, 0, 6, 6, 0, 0, 2, 4,-2, 2,-2,-2, 6, 6, 0, 0, 0, 6,
     * 4, 2,-4, 0, 6, 0, 0, 0, 6, 0,-3, 3, 6, 0, 0, 0, 3, 3,
     1 3, 0,-3, 0, 6, 0, 3, 0, 3, 3, 3, 0, 0, 0, 6, 3,-3, 0,
     2-4,-8,-2, 6, 0, 0,-2,-4, 2, 2,-2,-2, 6, 6, 0, 4,-4, 2,
     3 8, 4,-2, 0, 6, 0, 4, 2, 2/), (/3, 3, 85/))
      MVV = (/ 14, 15, 14, 17, 19, 14, 18, 16/)
      LVV = (/ 14, 14, 20, 22, 16, 21, 14, 23/)
      TT  = RESHAPE ((/
     1  141, 1741, 1841,  657, 2957, 3057, 3157,  131,  934, 3234, 3334,
     2  121, 1721, 1821, 3426, 3526, 3626, 3726, 3826, 3926,  146, 1746,
     3 1846, 5457, 5557, 5657, 5757,  136,  935, 3235, 3335,  126, 1726,
     4 1826, 5826, 5926, 6026, 6126, 6226, 6326, 6446, 6546, 6646, 6757,
     5 6857, 6957, 7057,  135, 6436, 6536, 6636, 6426, 6526, 6626, 7126,
     6 7226, 7326, 7426, 7526, 7626,  131,  934,  121, 1721, 1821, 3426,
     7 3526,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     8    0,    0,    0,  136,  935,  126, 1726, 1826, 5826, 5926,    0,
     9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     *    0, 4634,  934, 4734,  121, 4826, 4926, 5026, 5126, 5226, 5326,
     1    0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 7726,
     2 7826, 7926,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     3    0,    0,    0,    0,    0,    0,    0,    0,  121, 1721, 1821,
     4    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     5    0,    0,    0,    0,    0,    0, 8021, 4026, 4126,    0,    0,
     6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     7    0,    0,    0,    0, 8121, 4226, 4326,    0,    0,    0,    0,
     8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     9    0,    0, 8221, 4426, 4526,    0,    0,    0,    0,    0,    0,
     *    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     1 8026, 8126, 8226,    0,    0,    0,    0,    0,    0,    0,    0,
     2    0,    0,    0,    0,    0,    0,    0,    0,    0,  126, 1726,
     3 1826,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     4    0,    0,    0,    0,    0,    0,    0, 8326, 8426, 8526,    0,
     5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     6    0,    0,    0,    0,    0/), (/20, 14/))
      SB = (/
     1 21, 21, 21, 21, 11, 4, 4, 8, 8, 8, 8, 8, 4, 4, 4, 4, 4,
     2  4,  4,  4,  4,  1, 1, 1, 1, 1, 1, 1, 1, 1/)
      IDT = (/61, 66, 65, 41, 46, 51, 57, 31, 32, 33, 34, 35, 36/)
      TP  = RESHAPE ((/
     1 6, 0, 0, 0, 0, 6, 0, 0, 0, 0, 6, 0, 0, 0, 0, 6, 6, 0, 0, 0, 0, 3,
     2 3, 0, 0,-3, 3, 0, 0, 6, 0, 6, 3, 0,-3, 0, 0, 6, 0, 0, 3, 0, 3, 0,
     3 0, 0, 6, 6, 3, 3, 0, 0,-3, 3, 0, 0, 0, 0, 6, 0, 6, 0, 0, 6, 0, 3,
     4 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 0, 0, 0, 6,-3, 3, 3, 0, 3,-3, 3, 0,
     5 3, 3,-3, 0, 3, 3, 3, 6, 4, 2, 2, 0,-2, 2, 2, 0,-2,-4, 2, 0, 6, 6,
     6 0, 6/), (/4, 4, 7/))
      IPR(772) = 1
      BCD(1:24) = 'Delaunay Cell Reduction'//CHAR (0)
      CALL GGIP (HORS, VERT, 0.0, 1)
      CALL PLA439 (0.0,  BCD, 24, 1.2, 4, 8, 0.6, VERT - 1.8)
      CALL PLA439 (0.0,  BCD, 24, 1.2, 2, 8, 0.5, VERT - 1.9)
      PAGET = 'DELRED'
      M     = 0
      ZW4   = 0.0
      ISYS  = 1
      NBR   = 1
      ISE   = 1
      NCP   = 0
      IZ    = 1
      INO   = 0
      IK    = 0
      CALL GEN074 (AW, 1, 9, 0.0)
      CALL GEN097 (NCL, 1, 30, 0)
      DO I = 1, 6
        AC(I) = PAR(100 + I)
      END DO
      DO I = 1, 7
        NQ(I) = I
      END DO
      CALL PLA262 (0)
      VRT  = VERT - 5.0
C * REPORT TOLERANCES ON CELL AXES AND ANGLES
      WRITE (PRBUF, 99999, IOSTAT = IOST) PAR(382), PAR(381)
C * DUMMY
      IF (IOST == -999) RETURN
      WRITE (LU, 99986, IOSTAT = IOST) PRBUF(1:80)
      CALL PLA439 (0.0, PRBUF, 80, 0.45, 1, 2, 0.2, VRT)
      WRITE (PRBUF, 99998, IOSTAT = IOST)
      WRITE (LU, 99985, IOSTAT = IOST) PRBUF(1:80)
      VRT = VRT - 1.5
      CALL PLA439 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
      WRITE (PRBUF, 99997, IOSTAT = IOST) NPC, AC
      WRITE (LU, 99987, IOSTAT = IOST) PRBUF(1:80)
      VRT = VRT - 1.5
      CALL PLA439 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68), 2, 0.2, VRT)
C * METRIC
      CALL GEN026 (1, GG, PAR(101))
      DO I = 1, 7
        IF (NPC == HT(I)) M = I
      END DO
      DO I = 1, 4
        DO J = 1, 4
          G(I, J)  = 0.0
          AV(I, J) = 0.0
          AD(I, J) = TP(I, J, M) / 6.0
          IF (I < 4 .AND. J < 4) GW(I, J) = AD(I, J)
        END DO
      END DO
C * TRANSFORM TO PRIMITIVE CELL
      CALL GEN001 (-1, GW, GG, GG)
      DO I = 1, 3
        DO J = 1, 3
          G(I, J) = GG(I, J)
          G(4, 4) = G(4, 4) + GG(I, J)
          G(I, 4) = G(I, 4) - GG(I, J)
        END DO
        G(4, I) = G(I, 4)
      END DO
      CALL GEN074 (GW, 1, 9, 0.0)
C * SEARCH FOR POSITIVE ELEMENT IN G
      MC = -1 0
      DO WHILE (MC /= 0)
        MC = 0
        DO I = 1, 4
          DO J = 1, 4
            A(I, J)  = AD(I, J)
            GN(I, J) = G(I, J)
            IF (ABS (G(I, J)) < 0.00006) G(I, J) = 0.0
            IF (MC == 0 .AND. J > I .AND. G(I, J) > 0.0)
     1        MC = J + 2 * I - 3 - I / 3
          END DO
        END DO
        IF (MC /= 0) THEN
C * TRANSFORMATION OF MATRIX AD AND METRIC TENSOR G
          DO I = 1, 4
            DO J = 1, 4
              G(I, J) = 0.0
              AD(I, J) = 0.0
              DO K = 1, 4
                AD(I, J) = AD(I, J) + A(I, K) * PP(K, J, MC)
                DO L = 1, 4
                  G(I, J) = G(I, J) +
     1                      GN(K, L) * PP(K, I, MC) * PP(L, J, MC)
                END DO
              END DO
            END DO
          END DO
          CYCLE
        END IF
      END DO
C * CONSTRUCTION OF IDENTIFICATION MATRIX IG
      DO IST = 0, 10
        DO I = 1, 4
          DO J = 1, 4
            IG(I, J) = GC(I, J)
            A(I, J)  = AD(I, J)
          END DO
        END DO
        DO I = 1, 3
          DO J = I, 4
            ZW1 = 0.0025 * (G(I, I) + G(J, J)) * IST
            IF (ABS (G(I, J)) < ZW1) IG(I, J) = 0
            DO K = 1, 3
              DO L = K, 4
                IF (IG(K, L) == 10 * K + L .AND.
     1              (K > I .OR. L > J) .AND.
     2              ABS (G(I, J) - G(K, L)) < 3.0 *
     3             (ZW1 + 0.0025 * (G(K, K) + G(L, L)) * IST))
     4              IG(K, L) = IG(I, J)
              END DO
            END DO
            IG(J, I) = IG(I, J)
          END DO
        END DO
C * IDENTIFICATION OF DELAUNAY TYPE
        DO IC = 1, 30
          DO INL1 = 1, 4
            NL(1) = INL1
            DO INL2 = 1, 4
              NL(2) = INL2
              IF (NL(1) /= NL(2)) THEN
                DO 40 INL3 = 1, 4
                  NL(3) = INL3
                  IF (NL(3) == NL(1) .OR. NL(3) == NL(2)) GO TO 40
                  NL(4) = 10 - NL(1) - NL(2) - NL(3)
                  DO 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 > 0) THEN
                      GO TO 40
                    ELSE IF (IYUNK < 0) THEN
                      N1 = NL(SKI(MX, IC) / 10)
                      N2 = NL(SKI(MX, IC) - 10 * (SKI(MX, IC) / 10))
                      IF (IG(M1, M2) /= IG(N1, N2)) GO TO 40
                    END IF
                  END DO
                  IF (NCP > 0) THEN
                    DO I = 1, NCP
                      IF (IC == NCL(I)) GO TO 40
                    END DO
                  END IF
                  NCP = NCP + 1
                  NCL(NCP) = IC
                  ISE = SB(IC)
                  DO IS = 1, ISE
                    IF (IC /= 30) THEN
 
C * TRANSFORMATION TO STANDARD DELAUNAY TYPE
                      IF (IS <= 1) THEN
                        DO I = 1, 4
                          DO J = 1, 4
                            GV(J, I) = 0.0
                            E(J, I)  = 0.0
                          END DO
                          E(NL(I), I) = 1.0
                        END DO
                        DO I = 1, 4
                          DO 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 K = 1, 4
                              DO L = 1, 4
                                GV(I, J) = GV(I, J)
     1                                   + G(K, L) * E(L, J) * E(K, I)
                              END DO
                            END DO
                          END DO
                        END DO
C * REDUCTION TO 3*3-MATRIX
                        DO I = 1, 3
                          DO J = 1, 3
                            GN(I, J) = GV(I, J)
                            A(I, J)  = A(I, J) - A(4, J)
                          END DO
                        END DO
                      END IF
C * TRANSFORMATION TO CONVENTIONAL CELL
                      ISYS = SKI(8, IC) / 10
                      NBR  = SKI(8, IC) - 10 * ISYS
                      N    = SKI(7, IC)
                      IF (IS /= 1) THEN
                        DO I = 1, 3
                          DO J = 1, 3
                            A(I, J)  = AW(I, J)
                            GN(I, J) = GW(I, J)
                          END DO
                        END DO
                        N = TT(IS - 1, IK) / 100
                        ISYS = (TT(IS - 1, IK) - 100 * N) / 10
                        NBR  = TT(IS - 1, IK) - 100 * N - 10 * ISYS
                      END IF
                      ZW1 = 1.0 - 5.0 * FLOAT (N / 54) / 6.0
                      DO I = 1, 3
                        DO J = 1, 3
                          AV(I, J) = 0.0
                          GV(I, J) = 0.0
                          DO K = 1, 3
                            AV(I, J) = AV(I, J)
     1                               + A(I, K) * ZW1 * TR(K, J, N)
                            DO L = 1, 3
                              GV(I, J) = GV(I, J) + ZW1 * ZW1 * GN(K, L)
     1                                 * TR(L, J, N) * TR(K, I, N)
                            END DO
                          END DO
                        END DO
                      END DO
                      IZ = 1
                      IF (ISYS < 3) THEN
C * MONOCLINIC CASE
                        ZW = GV(1, 1) + GV(3, 3) - GV(1, 3)
     1                     * SIGN (2.0, GV(1, 3))
                        IF (ZW < GV(1, 1)) IZ = IZ + 1
                        IF (ZW < GV(3, 3)) IZ = IZ + 2
                        IF (GV(3, 3) < GV(1, 1)) IZ = IZ + 4
                        IF (NBR == 6) NBR = 2 * (MOD (IZ + 2, 4)
     1                                      + (IZ / 6) * (6 / IZ))
                        DO I = 1, 3
                          DO J = 1, 3
                            E(I, J) = TR(I, J, LVV(IZ))
                            IF (I /= 3) E(I, J) = - E(I, J)
     1                                            * SIGN (1.0, GV(1, 3))
                          END DO
                        END DO
                      ELSE IF (ISYS > 3) THEN
                        GO TO 10
                      ELSE
C * ORTHORHOMBIC CASE
                        IF (GV(1, 1) > GV(2, 2)) IZ = IZ + 1
                        IF (GV(1, 1) > GV(3, 3)) IZ = IZ + 2
                        IF (GV(2, 2) > GV(3, 3)) IZ = IZ + 4
                        DO L = 1, 3
                          DO M = 1, 3
                            E(L, M) = TR(L, M, MVV(IZ))
                          END DO
                        END DO
                        IF (NBR > 1 .AND. NBR < 5)
     1                    NBR = 4 - IZ / 3
                      END IF
                    ELSE
C * TRICLINIC CASE, SEARCH FOR A BASIS OF SHORTEST VECTORS
                      DO I = 1, 7
                        DO J = 1, 7
                          IF (I < 4 .AND. J < 4) A(I, J) =
     1                                       A(I, J) - A(4, J)
                          GS(I, J) = 0.0
                          DO K = 1, 3
                            DO L = 1, 3
                              GS(I, J) = GS(I, J) + G(K, L)
     1                                 * INC(K, I) * INC(L, J)
                            END DO
                          END DO
                        END DO
                      END DO
                      DO I = 1, 6
                        DO J = I, 7
                          O(I, J) = GS(I, I) * GS(J, J)
     1                            - GS(I, J) * GS(I, J)
                          IF (GS(I, I) > GS(J, J)) THEN
                            NQ(I) = NQ(I) + 1
                            NQ(J) = NQ(J) - 1
                          END IF
                          O(J, I) = O(I, J)
                        END DO
                      END DO
                      DO I = 1, 7
                        MQ(NQ(I)) = I
                      END DO
C * TEST OF SURFACE CONDITION
                      ZW1 = GS(MQ(1), MQ(1))
                      ZW2 = GS(MQ(2), MQ(2))
                      ZW3 = GS(MQ(3), MQ(3))
                      IF (IV(MQ(1), MQ(2)) == MQ(3))
     1                    ZW3 = GS(MQ(4), MQ(4))
                      DO I = 1, 5
                        ID = MQ(I)
                        IF (ZW1 >= GS(ID, ID)) THEN
                          DO J = I, 6
                            JD = MQ(J)
                            IF (J /= I .AND. ZW2 >= GS(JD, JD)) THEN
                              DO K = J, 7
                                KD = MQ(K)
                                IF (K /= J .AND. ZW3 >= GS(KD, KD)
     1                            .AND. KD /= IV(ID, JD)) THEN
                                  IF (O(ID, JD) + O(JD, KD)
     1                                        + O(ID, KD) >= ZW4) THEN
                                    KJ(1) = ID
                                    KJ(2) = JD
                                    KJ(3) = KD
                                    ZW4   = O(ID, JD) + O(ID, KD)
     1                                    + O(JD, KD)
                                  END IF
                                END IF
                              END DO
                            END IF
                          END DO
                        END IF
                      END DO
C * STANDARDIZATION
                      DO M = 1, 3
                        DO L = 1, 3
                          GV(M, L) = GS(KJ(M), KJ(L))
                          GN(M, L) = 0.0
                          IF (GV(M, L) /= 0.0) GN(M, L) =
     1                        GV(M, L) / ABS (GV(M, L))
                          DO J = 1, 3
                            AV(L, M) =
     1                      AV(L, M) + A(L, J) * INC(J, KJ(M))
                          END DO
                        END DO
                      END DO
                      N = INT (14.5 + GN(1, 2) + 3.0 * GN(1, 3)
     1                  + 9.0 * GN(2, 3))
                      IF (GV(1, 1) == GV(2, 2) .AND.
     1                   ABS (GV(2, 3)) > ABS (GV(1, 3))) IZ = IZ + 1
                      IF (GV(3, 3) == GV(2, 2) .AND.
     1                   ABS (GV(1, 3)) > ABS (GV(1, 2))) IZ = IZ + 2
                      IF (GV(1, 1) == GV(3, 3) .AND.
     1                   ABS (GV(2, 3)) > ABS (GV(1, 2))) IZ = IZ + 4
                      DO I = 1, 3
                        DO J = 1, 3
                          E(I, J) = 0.0
                          DO K = 1, 3
                            E(I, J) = E(I, J) + TR(I, K, 23 + Q(N))
     1                              * TR(K, J, NVV(IZ))
                          END DO
                        END DO
                      END DO
                    END IF
                    DO I = 1, 3
                      DO J = 1, 3
                        A(I, J)  = AV(I, J)
                        GN(I, J) = GV(I, J)
                      END DO
                    END DO
                    DO I = 1, 3
                      DO 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 K = 1, 3
                          DO L = 1, 3
                            GV(I, J) = GV(I, J)
     1                               + GN(K, L) * E(L, J) * E(K, I)
                          END DO
                        END DO
                      END DO
                    END DO
                    IF (ISYS == 2 .AND. GV(1, 3) > 0.0) THEN
                      DO I = 1, 3
                        AV(I, 3) = - AV(I, 3)
                      END DO
                      GV(1, 3) = - GV(1, 3)
                      GV(3, 1) =   GV(1, 3)
                    END IF
C * INVERSION OF AV
   10               DO I = 1, 2
                      II = I + 1
                      DO 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)
                      END DO
                    END DO
                    ZW1 = A(1, 1) * AV(1, 1) + A(1, 2) * AV(2, 1)
     1                  + A(1, 3) * AV(3, 1)
C * PREPARATION OF OUTPUT
                    DO I = 1, 3
                      DO J = 1, 3
                        AV(I, J) = AV(I, J) * SIGN (1.0, ZW1)
                        IF (IS == 1) THEN
                          AW(I, J) = AV(I, J)
                          GW(I, J) = GV(I, J)
                        END IF
                        A(J, I) = A(J, I) / ABS (ZW1)
                      END DO
                      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)
                    END DO
                    IF (ISYS == 2) THEN
                      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 /= 1) THEN
                        ZW = GV(3, 3) + FLOAT (NBR / 4)
     1                     * (GV(1, 1) - GV(3, 3))
     2                     + FLOAT (NBR / 6) * (GV(3, 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
                      END IF
                    END IF
                    IF (IS == 1) THEN
   20                 CALL PLA015 (0, 39)
C * WHAT NEXT ?
                      CALL PLA012 (1, 1)
                      CALL GEN020 (1, IGGT, 1, 80)
                      IF (IGGT(1:4) == 'PLOT') THEN
                        GO TO 20
                      ELSE IF (IGGT(1:4) == 'EXIT' .OR.
     1                         IGGT(1:1) == 'N') THEN
                        CALL GEN038 (IGGT, 1, 80)
                        RETURN
                      END IF
                      CALL PLA262 (0)
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      WRITE (PRBUF, 99993, IOSTAT = IOST)
     1                  NCP, IC, IST, Y(ISYS), HT(NBR)
                      WRITE (LU, 99987, IOSTAT = IOST) PRBUF(1:80)
                      VRT = VERT - 0.7
                      CALL PLA439 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68),
     1                             2, 0.2, VRT)
                      VRT = VRT - 0.2
                    END IF
                    ISJ = IS - 1
                    IF (IS /= 1) THEN
                      WRITE (PRBUF, 99991, IOSTAT = IOST)
     1                  ISJ, Y(ISYS), HT(NBR)
                      WRITE (LU, 99988, IOSTAT = IOST) PRBUF(1:80)
                      VRT = VRT - 0.7
                      CALL PLA439 (0.0, PRBUF, 80, 0.40, 3, 2, 0.2, VRT)
                    END IF
                    IF (ISYS == 2) THEN
                      WRITE (PRBUF, 99989, IOSTAT = IOST) XM, YM, ZM
                      WRITE (LU, 99988, IOSTAT = IOST) PRBUF(1:80)
                    END IF
                    IF ((ISYS /= 1 .AND. ISYS /= 5 .AND.
     1                (ABS (AC(4) - 90.0) >= PAR(381) .OR.
     2                 ABS (AC(6) - 90.0) >= PAR(381))) .OR.
     3                 (ISYS > 2 .AND. ABS (AC(5) - 90.0)
     4                 >= PAR(381))
     5                 .OR. (ISYS == 5 .AND. (ABS (AC(6) - 120.0) .GE.
     6                 PAR(381) .OR. ABS (AC(4) - 90.0) >= PAR(381)))
     7                 .OR. (ISYS > 3 .AND. ABS (AC(1) - AC(2)) .GE.
     8                 PAR(382)) .OR. (ISYS == 6
     9                .AND. (ABS (AC(1) - AC(3)) >= PAR(382) .OR.
     *                 ABS(AC(2) - AC(3)) >= PAR(382)))) THEN
                      WRITE (PRBUF, 99990, IOSTAT = IOST)
     1                  (AC(I), I = 1, 6)
                      VRT = VRT - 0.40
                      CALL PLA439 (0.0, PRBUF, 80, 0.30, 2, 2, 0.2, VRT)
                      WRITE (LU, 99988, IOSTAT = IOST) PRBUF(1:80)
                      IF (INO /= 1) GO TO 30
                    END IF
                    WRITE (PRBUF, 99996, IOSTAT = IOST)
     1                (AC(I), I = 1, 3)
                    VRT = VRT - 0.7
                    CALL PLA439 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
                    WRITE (LU, 99988, IOSTAT = IOST) PRBUF(1:80)
                    WRITE (PRBUF, 99995, IOSTAT = IOST)
     1                (AC(I), I = 4, 6)
                    VRT = VRT - 0.55
                    CALL PLA439 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
                    WRITE (LU, 99987, IOSTAT = IOST) PRBUF(1:80)
                    WRITE (PRBUF, 99994, IOSTAT = IOST)
                    VRT = VRT - 0.7
                    CALL PLA439 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68),
     1                           2, 0.2, VRT)
                    WRITE (LU, 99988, IOSTAT = IOST) PRBUF(1:80)
                    DO I = 1, 3
                      WRITE (PRBUF, 99992, IOSTAT = IOST)
     1                  (GV(I, J), J = 1, 3),
     2                  (AV(I, K), K = 1, 3), (A(I, L), L = 1, 3)
                      WRITE (LU, 99987, IOSTAT = IOST) PRBUF(1:80)
                      VRT = VRT - 0.55
                      CALL PLA439 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
                    END DO
   30               DO I = 1, 13
                      IF (IS == 1 .AND. 10 * ISYS + NBR == IDT(I))
     1                    IK = I
                    END DO
                    IF (IK == 7 .AND. IC == 6) IK = 14
                  END DO
   40           CONTINUE
              END IF
            END DO
          END DO
        END DO
      END DO
      IPR(772) = 0
      CALL PLA015 (0, 39)
C * WHAT NEXT ?
      CALL PLA012 (1, 1)
      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)
99986 FORMAT (A, /, 80('='), /)
99985 FORMAT (A, /)
      END SUBROUTINE PLA265
 
      SUBROUTINE PLA266 (N)
C * CELL REDUCTION, SEE KRIVY & GRUBER, ACTA CRYST (1976), A32, 297-298)
      USE parameters
      USE plato
      USE latice
      USE sgxyz
      IMPLICIT NONE
      INTEGER                :: J
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: N
      REAL                   :: DET
      REAL,  DIMENSION(3, 3) :: YUNK
C * GET LATTICE TYPE = NLT (P, A, B, C, F, I, R, X)
C * GET TRANSFORMATION MATRIX TO PRIMITIVE LATTICE
      IF (N == 1) THEN
        L = IPR(241)
      ELSE
        L = 128
      END IF
      DO J = 1, 3
        DO K = 1, 3
          TRNS(J, K) = TRNSX(J, K, L)
        END DO
      END DO
C * TRANSFORM METRICAL MATRIX
      CALL GEN001 (1, TRNS, AA, DUMV)
C * KRIVY & GRUBER
      CALL PLA267 (DUMV, TRNS, PAR(440))
C * AVOID TRIVIAL TRANSFORMATIONS
C * SAVE REDUCED CELL (NIGGLI) PARAMETERS
      CALL GEN025 (DUMV, PAR(151), 1)
C * RECOVER CELL PARAMETERS FROM METRIC
      CALL GEN026 (-1, DUMV, PAR(123))
C * TRANSPOSE INPUT TO REDUCED CELL TRANSFORMATION MATRIX
      CALL GEN005 (TRNS, YUNK)
C * COPY MATRIX
      CALL GEN052 (YUNK, TRNS)
C * GET INVERTED MATRIX
      CALL GEN003 (TRNS, TRNSM1, DET, 0)
      PAR(99) = PAR(98) * DET
C * DESCRIBE THE REDUCED DIRECT AND RECIPROCAL CELLS BY THEIR CARTESIAN
C * COORDINATES ADIR AND AINV.
      CALL GEN044 (PAR(123), ADIR, 1)
C * INVERT
      CALL GEN003 (ADIR, AINV, DET, 0)
      RETURN
      END SUBROUTINE PLA266
 
      SUBROUTINE PLA267 (DUMV, TRNS, SCL)
C * CELL REDUCTION, SEE KRIVY & GRUBER, ACTA CRYST (1976), A32, 297-298)
      USE latice
      IMPLICIT NONE
      INTEGER               :: IA
      INTEGER               :: IB
      INTEGER               :: IC
      INTEGER               :: IETA
      INTEGER               :: IKSI
      INTEGER               :: IZETA
      INTEGER               :: NLOOP
      REAL                  :: SCL
      REAL, DIMENSION(3, 3) :: TRNS
      REAL, DIMENSION(3, 3) :: DUMV
      REAL, DIMENSION(3, 3) :: YUNK
      IA    = NINT (DUMV(1, 1) * SCL)
      IB    = NINT (DUMV(2, 2) * SCL)
      IC    = NINT (DUMV(3, 3) * SCL)
      IKSI  = NINT (2.0 * SCL * DUMV(2, 3))
      IETA  = NINT (2.0 * SCL * DUMV(1, 3))
      IZETA = NINT (2.0 * SCL * DUMV(1, 2))
C * LIMIT NUMBER OF ITERATION LOOPS
      DO NLOOP = 1, 25
C * REDUCTION STEP 1
        IF ((IA > IB) .OR. ((IA == IB) .AND.
     1      (IABS (IKSI) > IABS (IETA)))) THEN
          CALL GEN014 (IA, IB)
          CALL GEN014 (IKSI, IETA)
          IETA = - IETA
          IKSI = - IKSI
          CALL GEN004 (TRNSX(1, 1, 8), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
        END IF
C * REDUCTION STEP 2
        IF ((IB > IC) .OR. ((IB == IC) .AND.
     1     (IABS (IETA) > IABS (IZETA)))) THEN
          CALL GEN014 (IB, IC)
          CALL GEN014 (IETA, IZETA)
          IETA  = - IETA
          IZETA = - IZETA
          CALL GEN004 (TRNSX(1, 1, 9), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
          CYCLE
        END IF
C * REDUCTION STEP 3
        IF (FLOAT (IKSI) * FLOAT (IETA) * FLOAT (IZETA) > 0.0) THEN
          TRNSX(1, 1, 10) = ISIGN (1, IKSI)
          TRNSX(2, 2, 10) = ISIGN (1, IETA)
          TRNSX(3, 3, 10) = ISIGN (1, IZETA)
          IKSI            = IABS (IKSI)
          IETA            = IABS (IETA)
          IZETA           = IABS (IZETA)
          CALL GEN004 (TRNSX(1, 1, 10), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
C * REDUCTION STEP 4
        ELSE
          TRNSX(1, 1, 11) = - ISIGN (1, IKSI)
          TRNSX(2, 2, 11) = - ISIGN (1, IETA)
          TRNSX(3, 3, 11) = - ISIGN (1, IZETA)
          IF (IKSI == 0)
     1       TRNSX(1, 1, 11) = TRNSX(2, 2, 11) * TRNSX(3, 3, 11)
          IF (IETA == 0)
     1       TRNSX(2, 2, 11) = TRNSX(1, 1, 11) * TRNSX(3, 3, 11)
          IF (IZETA == 0)
     1       TRNSX(3, 3, 11) = TRNSX(1, 1, 11) * TRNSX(2, 2, 11)
          IKSI  = - IABS (IKSI)
          IETA  = - IABS (IETA)
          IZETA = - IABS (IZETA)
          CALL GEN004 (TRNSX(1, 1, 11), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
        END IF
C * REDUCTION STEP 5
        IF ((IABS (IKSI) > IB) .OR. ((IKSI == IB) .AND.
     1    (2 * IETA < IZETA)) .OR. ((IKSI == -IB) .AND.
     2    (IZETA < 0))) THEN
          TRNSX(3, 2, 12) = - ISIGN (1, IKSI)
          IC   = IB   + IC - IKSI * ISIGN (1, IKSI)
          IETA = IETA - IZETA * ISIGN (1, IKSI)
          IF (IABS (IETA) == 1) IETA = 0
          IKSI = IKSI - 2 * IB * ISIGN (1, IKSI)
          IF (IABS (IKSI) == 1) IKSI = 0
          CALL GEN004 (TRNSX(1, 1, 12), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
          CYCLE
        END IF
C * REDUCTION STEP 6
        IF ((IABS (IETA) > IA) .OR. ((IETA == IA) .AND.
     1    (2 * IKSI < IZETA)) .OR. ((IETA == -IA) .AND.
     2    (IZETA < 0))) THEN
          TRNSX(3, 1, 13) = - ISIGN (1, IETA)
          IC   = IA + IC - IETA * ISIGN (1, IETA)
          IKSI = IKSI - IZETA * ISIGN (1, IETA)
          IETA = IETA - 2 * IA * ISIGN (1, IETA)
          CALL GEN004 (TRNSX(1, 1, 13), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
          CYCLE
        END IF
C * REDUCTION STEP 7
        IF ((IABS (IZETA) > IA) .OR. ((IZETA == IA) .AND.
     1    (2 * IKSI < IETA)) .OR. ((IZETA == -IA) .AND.
     2    (IETA < 0))) THEN
          TRNSX(2, 1, 14) = - ISIGN (1, IZETA)
          IB    = IA + IB - IZETA * ISIGN (1, IZETA)
          IKSI  = IKSI - IETA * ISIGN (1, IZETA)
          IZETA = IZETA - 2 * IA * ISIGN (1, IZETA)
          CALL GEN004 (TRNSX(1, 1, 14), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
          CYCLE
        END IF
C * REDUCTION STEP 8
        IF ((IKSI + IETA + IZETA + IA + IB < 0) .OR.
     1     ((IKSI + IETA + IZETA + IA + IB == 0) .AND.
     2      (2 * (IA + IETA) + IZETA > 0))) THEN
          IC   = IA + IB + IC + IKSI + IETA + IZETA
          IKSI = 2 * IB + IKSI + IZETA
          IETA = 2 * IA + IETA + IZETA
          CALL GEN004 (TRNSX(1, 1, 15), TRNS, YUNK)
          CALL GEN052 (YUNK, TRNS)
          CYCLE
        END IF
        EXIT
      END DO
      DUMV(1, 1) = IA / SCL
      DUMV(2, 2) = IB / SCL
      DUMV(3, 3) = IC / SCL
      DUMV(1, 2) = IZETA * 0.5 / SCL
      DUMV(1, 3) = IETA  * 0.5 / SCL
      DUMV(2, 3) = IKSI  * 0.5 / SCL
      DUMV(3, 2) = DUMV(2, 3)
      DUMV(3, 1) = DUMV(1, 3)
      DUMV(2, 1) = DUMV(1, 2)
      RETURN
      END SUBROUTINE PLA267
 
      SUBROUTINE PLA268 (IAT, JAT, MODE, DASH)
C * BOND IN SCRATCH VOID LIST MANAGEMENT
C * MODE =  1  : ADD BOND TO LIST
C * MODE = -1  : DELETE BOND FROM LIST
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: IA
      INTEGER :: JA
      INTEGER :: NA
      INTEGER :: NB
      INTEGER :: NC
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: IPP
      INTEGER :: JPP
      INTEGER :: NAK
      INTEGER :: NAN
      INTEGER :: MODE
      INTEGER :: IHAT
      INTEGER :: JHAT
      INTEGER :: METI
      INTEGER :: METJ
      INTEGER :: NANB
      REAL    :: DASH
      REAL    :: DASH0
      REAL    :: XBND
      DASH0 = DASH
      NA    = IPR(298)
C * GET NUMBER OF BONDS IN BOND ARRAY
      NB = IPR(131)
      NC = NB
      I  = IAT
      J  = JAT
      N  = 0
      IF (I > J) CALL GEN014 (I, J)
C * TEST FOR PREVIOUS OCCURRENCE OF THIS BOND
      IF (NB > 0) THEN
        DO K = 1, NB
          NAK = NA + K * 3
          IA  = NINT (VOID(NAK - 2))
          JA  = NINT (VOID(NAK - 1))
          IF (I == IA .AND. J == JA) THEN
C * BOND FOUND
            IF (MODE == -1) THEN
C * REPLACE THIS ENTRY WITH THE LAST ENTRY FROM THE LIST
              NANB          = NA + NB * 3
              IF (NANB /= NAK) THEN
                VOID(NAK - 2) = VOID(NANB - 2)
                VOID(NAK - 1) = VOID(NANB - 1)
                VOID(NAK)     = VOID(NANB)
              END IF
              NC = NC - 1
            ELSE
              N = K
            END IF
            EXIT
          END IF
        END DO
      END IF
      IF (MODE > 0) THEN
        IF (N == 0) THEN
          NC = NC + 1
          N  = NC
        END IF
C * NORMAL BOND RADIUS CODE
        XBND = 1.0
C * TO METAL BOND RADIUS CODE
        CALL GEN048 (-1, IFG(1, I), 19, METI)
        CALL GEN048 (-1, IFG(1, J), 19, METJ)
        IF (METI == 1 .OR. METJ == 1) XBND = 5.0
C * TO H BOND RADIUS CODE
        CALL GEN048 (-1, IFG(1, I), 7, IHAT)
        CALL GEN048 (-1, IFG(1, J), 7, JHAT)
        IF (IHAT == 1 .OR. JHAT == 1) XBND = 3.0
        IF (DASH0 < 2.0) THEN
C * DISORDER DETAILS
          CALL GEN048 (-8, IFG(2, I), 1, IPP)
          CALL GEN048 (-8, IFG(2, J), 1, JPP)
          IPP = IPPR(IPP + 1, 1) / 5000
          JPP = IPPR(JPP + 1, 1) / 5000
          IF (IPP < 2 .OR. JPP < 2) THEN
            XBND = 7.0
            IF (IPP * JPP == 0) DASH0 = -1.0
          END IF
        ELSE
          DASH0 = 1.0
        END IF
        IF (DASH0 < -1.0) THEN
          DASH0 = -1.0
          XBND  = 7.0
        END IF
        NAN           = NA + N * 3
        VOID(NAN - 2) = I
        VOID(NAN - 1) = J
        VOID(NAN)     = SIGN (XBND, DASH0)
      END IF
      IPR(131) = NC
      IPR(299) = NA + NC * 3
      RETURN
      END SUBROUTINE PLA268
 
      SUBROUTINE PLA269 (MODE, NAT)
C * SAVE/RESTORE XXO, XSD, CON TO/FROM SCRAT/VOID
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: K
      INTEGER                         :: MODE
      INTEGER                         :: NAT
      REAL, SAVE, DIMENSION(NP1*NP71) :: BUP
      K = 0
C * SAVE CONTENTS OF XXO, XSD, CON TO VOID  (SCRATCH)
      IF (MODE == 1) THEN
        DO I = 1, NAT
          DO J = 1, 6
            VOID(K + J)     = XXO(I, J)
            VOID(K + J + 6) = XSD(I, J)
          END DO
          DO J = 1, 9
            VOID(K + J + 12) = CON(I, J)
          END DO
          K = K + NP71
        END DO
        CALL GEN113 (VOID, BUP, NP71 * NAT)
C * SAVE ORTHOGONAL COORDINATES FOR HIRSHFELD R-B TEST
      ELSE IF (MODE == 2) THEN
        DO I = 1, NAT
          DO J = 1, 3
            VOID(K + J + 21) = XXO(I, J)
          END DO
          K = K + NP71
        END DO
C * COPY DATA FROM BUP TO VOID
      ELSE IF (MODE == 3) THEN
        CALL GEN113 (BUP, VOID, NP1 * NP71)
C * RESTORE XXO, XSD AND CON ARRAYS FROM SCRATCH COMMON
      ELSE IF (MODE == -1) THEN
        DO I = 1, NAT
          DO J = 1, 6
            XXO(I, J) = VOID(K + J)
            XSD(I, J) = VOID(K + J + 6)
          END DO
          DO J = 1, 9
            CON(I, J) = VOID(K + J + 12)
          END DO
          K = K + NP71
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA269
 
      SUBROUTINE PLA270 (XM1, XM2, XM3)
C * MULTIPLY OR GET INVERSE SYMMETRY OPERATION(S)
      USE files
      USE parameters
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: MR3
      INTEGER :: MS1
      INTEGER :: MS2
      INTEGER :: ISW
      INTEGER :: MT11
      INTEGER :: MT12
      INTEGER :: MT13
      INTEGER :: MT21
      INTEGER :: MT22
      INTEGER :: MT23
      REAL    :: XM1
      REAL    :: XM2
      REAL    :: XM3
      IPR(2) = 0
C * UNPACK ARU XM1
      ISW    = 9
      M1     = NINT (XM1 * PAR(42))
      CALL GEN098 (M1, PAR(42), MS1, MT11, MT12, MT13, MR3)
      SGX(1) = MS1
      SGX(2) = MT11
      SGX(3) = MT12
      SGX(4) = MT13
C * UNPACK XM2
      M2     = NINT (XM2 * PAR(42))
      IF (M2 /= 0) THEN
        ISW    = 8
        CALL GEN098 (M2, PAR(42), MS2, MT21, MT22, MT23, MR3)
        SGX(5) = MS2
        SGX(6) = MT21
        SGX(7) = MT22
        SGX(8) = MT23
      END IF
C * MULTIPLY OR INVERT
      CALL SGSM (ISW, ICL, SGX, 0, LU6, IERR)
      IF (IERR == 0) THEN
C * TEST FOR ARU-OUT-OF-RANGE STATUS
        DO I = 10, 12
          IF (ABS (SGX(I)) > 4.1) THEN
            WRITE (LU6, 99999, IOSTAT = IOST)
     1        XM1, XM2, (SGX(J), J = 9, 12)
            IF (IGBL(63) > 2) WRITE (LU7, 99999, IOSTAT = IOST)
     1        XM1, XM2, (SGX(J), J = 9, 12)
C * REGISTER/COUNT ARU-OUT-OF-RANGE CASES
            IPR(600) = IPR(600) + 1
            XM3      = 0.0
C * SET NO SQUEEZE
            IPR(210) = 0
            RETURN
          END IF
        END DO
        XM3 = (((SGX(9) * 10 + SGX(10)) * 10 + SGX(11)) * 10 + SGX(12))
        XM3 = NINT (XM3) + 555 + FLOAT (MR3) / PAR(42)
      ELSE
C * ERROR
        IPR(600) = IPR(600) + 1
        XM3      = 0.0
C * SET NO SQUEEZE
        IPR(210) = 0
      END IF
      RETURN
99999 FORMAT (':: ARU-Pack Problem :', 2F10.2, 4F5.0, /,
     1        ':: IPR(210) Reset to ZERO i.e. no SQUEEZE etc.')
      END SUBROUTINE PLA270
 
      SUBROUTINE PLA271
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: J
C * LAST MINUTE SYMMETRY UPDATE
C * GET SPACE GROUP INFO
      CALL SGSM (18, ICL, SGZ, 0, 0, IERR)
      SPGRNM(1) = ICL(1:26)
      SPGRNM(3) = ICL(44:60)
      SPGRNM(4) = ICL(15:26)
      IF (ICL(73:73) /= ' ') THEN
        ZSPG = ICL(73:79)
        J    = INDEX (ZSPG(2:7), 'r')
        IF (J /= 0) ZSPG(J+1:J+1) = 'R'
      END IF
      KRSYST(2) = ICL(27:38)
      LAUEGR    = ICL(39:43)
      CHSG      = ICL(72:72)
C * LOWER CASE HANDLING
      CALL GEN020 (-1, SPGRNM(1), 16, 24)
      CALL GEN020 (-1, KRSYST(2), 1,  12)
      IPR(202) = NINT (SGZ(1))
      IPR(241) = NINT (SGZ(7))
      IPR(242) = NINT (SGZ(8))
      IPR(255) = NINT (SGZ(4))
      IPR(256) = NINT (SGZ(6))
      IPR(257) = NINT (SGZ(5))
      IPR(258) = NINT (SGZ(3))
      IPR(259) = NINT (SGZ(2))
      IPR(48)  = NINT (SGZ(9))
      IPR(137) = NINT (SGZ(13))
      IPR(783) = NINT (SGZ(14))
C * CHECK FOR CIF-DATA
      IF (IGBL(8) == 3) THEN
C * CCIF(6) = H-M SYMBOL (SUPPLIED)
C * CCIF(7) = H-M SYMBOL (AS UNDERSTOOD)
C * CCIF(8) = FROM EXPLICIT SYMMETRY
        IF (CCIF(7)(1:1) == ' ') THEN
          CCIF(7) = SPGRNM(4)(1:11)
        ELSE
          CCIF(8) = SPGRNM(4)(1:11)
        END IF
      END IF
C * GET (A)CENTRIC INFO (DIFFERS FRPM IPR(257) FOR SHIFTED ORIGIN)
      CALL SGSM (13, ICL, SGZ, 0, 0, IERR)
      IPR(275) = NINT (SGZ(1))
      RETURN
      END SUBROUTINE PLA271
 
      SUBROUTINE PLA272
C * ROUTINE CHECKS THE GEOMETRY DATA AS REPORTED IN THE CIF AGAINST VALUES
C * CALCULATED FROM THE COORDINATES REPORTED IN THE CIF
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE pl273
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: IX
      INTEGER               :: M7
      INTEGER               :: M8
      INTEGER               :: N3
      INTEGER               :: N4
      INTEGER               :: N5
      INTEGER               :: N6
      INTEGER               :: N7
      INTEGER               :: IER
      INTEGER               :: INR
      INTEGER               :: ISA
      INTEGER               :: LBB
      INTEGER               :: LBC
      INTEGER               :: LBD
      INTEGER               :: NAT
      INTEGER               :: NO1
      INTEGER               :: NO2
      INTEGER               :: IAT1
      INTEGER               :: IAT2
      INTEGER               :: IDIS
      INTEGER               :: IEN1
      INTEGER               :: IEN2
      INTEGER               :: IENM
      INTEGER               :: IVAL
      INTEGER               :: ISP2
      INTEGER               :: ISP3
      INTEGER               :: NDEC
      INTEGER               :: NHAT
      INTEGER               :: NPOP
      INTEGER               :: IRAT2
      INTEGER               :: IGAT2
      INTEGER               :: IEN12
      INTEGER               :: IDAR2
      INTEGER               :: INQNR
      INTEGER               :: JNQNR
      INTEGER               :: IYUNK
      INTEGER               :: NAHAT
      INTEGER               :: NBHAT
      INTEGER               :: NCSYM
      INTEGER               :: NRTORS
      INTEGER, DIMENSION(4) :: NRAT
      REAL                  :: A
      REAL                  :: Y
      REAL                  :: A1
      REAL                  :: A2
      REAL                  :: SA
      REAL                  :: SB
      REAL                  :: RX
      REAL                  :: YUNK
      REAL                  :: RATIO
      REAL                  :: RATIO1
C * SYMMETRY CODES, BONDS, ANGLES, TORSIONS, CONTACTS,HBONDS HAVE BEEN COPIED
C * FROM THE CIF TO FILE LU11 IN ROUTINE PLA181
      A       = 0.0
      SA      = 0.0
      ISA     = 0
      NDEC    = 0
      NRAT(3) = 0
      NRAT(4) = 0
      N3      = 0
      N4      = 0
      N5      = 0
      N6      = 0
      N7      = 0
      NAT     = IPR(39) + IPR(64)
      NAHAT   = 0
      NBHAT   = 0
      NSCF    = 0
      NRTORS  = 0
      CALL GEN108 (LU11, 0)
C * READ SYMM AND GEOMETRY DATA RECOVERED FROM CIF
      DO
        READ (LU11, IOSTAT = IOST) LINE, (IFL(I), I = 1, 4),
     1    (FN(I), I = 1, 6)
        IF (IOST /= 0) EXIT
        NHAT = 0
        IER  = 0
        SELECT CASE (LINE(1:4))
C * SYMM FROM SAVED FROM CIF
          CASE ('SYMM')
            CALL SGSM (22, LINE, SGY, 0, 0, IERR)
            NSCF = NSCF + 1
            DO I = 1, 4
              NSCIF(I, NSCF) = NINT (SGY(I + 8))
            END DO
            IF (NSID(NSCF) == 0) NSID(NSCF) = NSCF
            CYCLE
C * ALERT _701 BOND TEST [LABEL1, LABEL2, DIST, SIGMA, SYMM1, SYMM2]
          CASE ('BOND')
C * COUNT BOND SEQUENCE #
            N5 = N5 + 1
            N7 = N5
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (2)
            N  = 2
            M7 = 1
C * ALERT _702 ANGLE TEST [LAB1, LAB2, LAB3, DIST, SIGMA, SYM1, SYM2, SYM3]
          CASE ('ANGL')
C * COUNT ANGLE SEQUENCE #
            N4 = N4 + 1
            N7 = N4
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (3)
            N  = 3
            M7 = 2
C * ALERT _703 TORSION ANGLE TEST
          CASE ('TORS')
C * COUNT TORSION SEQUENCE #
            N3 = N3 + 1
            N7 = N3
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (4)
            N  = 4
            M7 = 3
C * ALERT _704 CONTACT DISTANCE TEST
          CASE ('CONT')
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (2)
            N  = 2
            M7 = 4
C * ALERT _705 DONOR-H DISTANCE TEST
          CASE ('D-H ')
            N6 = N6 + 1
            N7 = N6
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (2)
            N  = 2
            M7 = 5
C * ALERT _706 H..ACCEPTOR DISTANCE TEST
          CASE ('H..A')
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (2)
            N  = 2
            M7 = 6
C * ALERT _707 DONOR..ACCEPTOR DISTANCE TEST
          CASE ('D..A')
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (2)
            N  = 2
            M7 = 7
C * ALERT _708 DONOR-H..ACCEPTOR ANGLE TEST
        CASE ('D-H.')
C * REMOVE '_$1' FROM LABEL                                 *
            CALL PLA391 (3)
            N  = 3
            M7 = 8
          CASE DEFAULT
            CYCLE
        END SELECT
        NPOP  = 0
        NCSYM = 0
        IDAR2 = 0
        IRAT2 = 0
        IGAT2 = 0
        IER   = 0
C * LOOP OVER SYMMETRY CODES IN GEOMETRY RECORD (BOND, ANGLE etc.)
        DO I = 1, N
          RX = FN(I + 2)
          IX = INT (ABS (RX))
          IF (IX == 0) THEN
            RX = 1.555
          ELSE IF (ABS (RX) - FLOAT (IX) < 0.01) THEN
            IF (RX > 0.0) THEN
              RX = RX + 0.555
            ELSE
              RX = RX - 0.555
            END IF
          END IF
          FN(I + 2) = RX
C * CHANGE s.ijk CODE INTO s_ijk STRING
          WRITE (IFL(I + 10), 99987) RX
          IFL(I + 10)(5:5) = '_'
C * ANALYSE CIF-SYMMETRY CODE(S)
          CALL PLA273 (0, FN(I + 2), IPR(54), ITR(1), ITR(2),
     1                 ITR(3), IER)
          IF (IER /= 0) EXIT
          NQ2 = IFL(I)
          IF (NQ2(1:1) == '?') THEN
            IER = -1
            EXIT
          END IF
C * GET SERIAL NUMBER IN ATOM ARRAY
          CALL PLA046 (-2, NQ2, IENM, LBB, LBC, LBD, INQNR, JNQNR, L)
          IF (L > 0) THEN
            NRAT(I) = L
C * CHECK FOR 'D' Restraint
            CALL GEN048 (-1, IFG(3, L), 7, IVAL)
            IDAR2 = MAX (IDAR2, IVAL)
C * CHECK FOR 'R' Constraint
            CALL GEN048 (-1, IFG(3, L), 6, IVAL)
            IRAT2 = MAX (IRAT2, IVAL)
C * CHECK FOR 'G' Constraint
            CALL GEN048 (-1, IFG(3, L), 5, IVAL)
            IGAT2 = MAX (IGAT2, IVAL)
C * COUNT H-ATOMS
            CALL GEN048 (-1, IFG(1, L), 7, IVAL)
            NHAT = NHAT + IVAL
            IF (M7 == 1) NBHAT = NBHAT + IVAL
            IF (M7 == 2) NAHAT = NAHAT + IVAL
C * ADDRESS POPULATION
            CALL GEN048 (-8, IFG(2, L), 1, IDIS)
            NPOP = NPOP + IPPR(IDIS + 1, 1) / 10000
          ELSE
            IF (NQ2(1:2) /= 'Cg'.AND. NQ2(1:2) /= 'CG') THEN
C * ALERT _710 (+M7)
              CALL PLA236 (-(710 + M7), 2, 1.0, 1.0, NQ2, ' ')
              WRITE (LINE, 99995, IOSTAT = IOST) (IFL(J), J = 1, N)
              CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
            END IF
            IER = -1
            EXIT
          END IF
          IF (FN(I + 2) /= 1.555) THEN
            NCSYM   = NCSYM + 1
            K       = NAT + I
            NRAT(I) = K
            LABA(K) = LABA(L)
C * ORTHOGONALIZE (USES ITR() & IPR(54) CONTENT
            CALL PLA059 (L, K)
            DO J = 1, 3
              IFG(J, K) = IFG(J, L)
            END DO
            CALL GEN048 (1, IFG(1, K), 5, 1)
          END IF
        END DO
        IF (IER == 0) THEN
C * DISTANCES
          IF (N == 2) THEN
C * CHECK ABSOLUTE BOND-DISTANCE VALUES SUPPLIED IN CIF
            INR = 0
            IF (M7 == 1) THEN
              YUNK = 1.0
              CALL GEN048 (-4, IFG(1, NRAT(1)), 15, NO1)
              CALL GEN048 (-4, IFG(1, NRAT(2)), 15, NO2)
              IEN1 = IEN(NO1 + 1)
              IEN2 = IEN(NO2 + 1)
              IAT1 = IATNR(IEN1)
              IAT2 = IATNR(IEN2)
              IF (IAT1 < IAT2) THEN
                CALL GEN014 (IEN1, IEN2)
                CALL GEN014 (IAT1, IAT2)
              END IF
              IEN12 = IEN1 * 1000 + IEN2
              INR   = 0
C * RANGE CHECK C - H (XRAY)
              IF (IEN12 == 2001) THEN
                IF (FN(1) > 1.3) INR = 770
C * RANGE CHECK N - H (XRAY)
              ELSE IF (IEN12 == 4001) THEN
                IF (FN(1) > 1.3) THEN
                  CALL GEN048 (-4, IFG(3, NRAT(2)), 28, IYUNK)
                  IF (IYUNK == 1) THEN
                    YUNK = FN(1)
                    INR = 771
                  ELSE
                    YUNK = -999.0
                    INR = 777
                  END IF
                END IF
C * RANGE CHECK O - H (XRAY)
              ELSE IF (IEN12 == 3001) THEN
                IF (FN(1) > 1.3) THEN
                  CALL GEN048 (-4, IFG(3, NRAT(2)), 28, IYUNK)
                  IF (IYUNK == 1) THEN
                    YUNK = FN(1)
                    INR  = 772
                  ELSE
                    YUNK = -999.0
                    INR  = 778
                  END IF
                END IF
C * RANGE CHECK C - C (XRAY)
              ELSE IF (IEN12 == 2002) THEN
                IF (FN(1) > 1.7) INR = 773
                YUNK = -999.0
C * 'BOND' CHECK FOR LONG/ERRONEOUS BOND [(METAL)ORGANIC ONLY]
              ELSE IF (FN(1) > 4.0) THEN
                IF (IGBL(97) == 1) THEN
                  YUNK = -999.0
                  INR  = 774
                END IF
              END IF
C * 'CONT' CHECK FOR LONG/ERRONEOUS CONTACT
            ELSE IF (M7 == 4) THEN
              IF (FN(1) > 4.0) THEN
                YUNK = FN(1)
                INR  = 775
              END IF
C * 'D-H'  CHECK FOR LONG/ERRONEOUS D-H
            ELSE IF (M7 == 5) THEN
              IF (FN(1) > 1.3 .AND. IFL(2)(1:1) == 'H') THEN
                YUNK = FN(1)
                INR  = 776
              END IF
            END IF
C * ALERT _77x
            IF (INR > 0) THEN
              CALL GEN020 (-1, IFL(1), 2, 2)
              CALL GEN020 (-1, IFL(2), 2, 2)
              CALL PLA236 (INR, 2, YUNK, FN(1), IFL(1), IFL(2))
            END IF
            M8 = M7
            IF (M7 == 1 .AND. NHAT == 0) IPR(316) = IPR(316) + 1
            CALL PLA053 (NRAT(1), NRAT(2), 0, 0, A, SA, ISA, NDEC, IER)
            IF (IER /= 0) CYCLE
            SB = MAX (0.0, SA)
            RATIO = ABS (FN(1) - A)
            IF (FN(2) <= 0.0 .OR. SA <= 0.0) THEN
              M8     = M8 + 20
              IF (FN(2) <= 0.0 .AND. SA <= 0) THEN
                RATIO1 = -999.0
              ELSE
                RATIO1 = RATIO * 100
              END IF
            ELSE
              RATIO  = RATIO / SA
              RATIO1 = RATIO
            END IF
C * ALERT _70x,_72x
            IF (RATIO1 > 1.0 .OR.
     1        (RATIO1 == -999.0 .AND. RATIO > 0.01)) THEN
              IF (A < 9.9) THEN
                WRITE (NQ3, 99997, IOSTAT = IOST) A
                WRITE (NQ4, 99997, IOSTAT = IOST) SB
                CALL PLA236 (-(700 + M8), 2, RATIO1, RATIO, NQ3, NQ4)
                WRITE (LINE, 99993, IOSTAT = IOST) (FN(I), I = 1, 2),
     1            (IFL(I)(1:9), I = 1, 2), (IFL(I)(1:8), I = 11, 12),
     2            N7
                CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
              ELSE IF (A < 99.9) THEN
                WRITE (NQ3, 99998, IOSTAT = IOST) A
                WRITE (NQ4, 99997, IOSTAT = IOST) SB
                CALL PLA236 (-(700 + M8), 2, RATIO1, RATIO, NQ3, NQ4)
                WRITE (LINE, 99988, IOSTAT = IOST) (FN(I), I = 1, 2),
     1            (IFL(I)(1:9), I = 1, 2), (IFL(I)(1:8), I = 11, 12),
     2            N7
                CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
              END IF
            END IF
C * CHECK BOND SU's
            IF (NPOP == 2) THEN
              IF (SA > 0.0) THEN
                IF (FN(2) > 0) THEN
                  RATIO  = MIN (9.9, FN(2) / SA)
                  IF (RATIO > 1.5) THEN
                    M7 = M7 + 30
C * ALERT _73x
                    IF (IDAR2 == 0) THEN
                      Y = ABS (FN(3) - FN(4))
                      IF (M7 /= 31 .OR. Y == 0.0 .OR. Y >= 1.0)
     1                  THEN
                        IF (A < 9.9) THEN
                          WRITE (NQ3, 99997, IOSTAT = IOST) A
                          WRITE (NQ4, 99997, IOSTAT = IOST) SB
                          CALL PLA236 (-(700 + M7), 1, RATIO, RATIO,
     1                      NQ3, NQ4)
                          WRITE (LINE, 99993, IOSTAT = IOST)
     1                      (FN(I), I = 1, 2), (IFL(I)(1:9), I = 1, 2),
     2                      (IFL(I)(1:8), I = 11, 12), N7
                          CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                        ELSE IF (A < 99.9) THEN
                          WRITE (NQ3, 99998, IOSTAT = IOST) A
                          WRITE (NQ4, 99997, IOSTAT = IOST) SB
                          CALL PLA236 (-(700 + M7), 2, RATIO, RATIO,
     1                      NQ3, NQ4)
                          WRITE (LINE, 99990, IOSTAT = IOST)
     1                      (FN(I), I = 1, 2), (IFL(I)(1:9), I = 1, 2),
     2                      (IFL(I)(1:8), I = 11, 12), N7
                          CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                       END IF
                      END IF
                    END IF
                  END IF
                ELSE
                  IF (IRAT2 + IDAR2 + IGAT2 + IPR(639) == 0) THEN
                    M7 = M7 + 40
C * ALERT _74x
                    IF (A < 9.9) THEN
                      WRITE (NQ3, 99997, IOSTAT = IOST) A
                      WRITE (NQ4, 99997, IOSTAT = IOST) SB
                      CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                      WRITE (LINE, 99993, IOSTAT = IOST)
     1                  (FN(I), I = 1, 2), (IFL(I)(1:9), I = 1, 2),
     2                  (IFL(I)(1:8), I = 11, 12), N7
                      CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                    ELSE IF (A < 99.9) THEN
                      WRITE (NQ3, 99998, IOSTAT = IOST) A
                      WRITE (NQ4, 99997, IOSTAT = IOST) SB
                      CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                      WRITE (LINE, 99990, IOSTAT = IOST)
     1                  (FN(I), I = 1, 2), (IFL(I)(1:9), I = 1, 2),
     2                  (IFL(I)(1:8), I = 11, 12), N7
                      CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                    END IF
                  END IF
                END IF
C * TEST FOR SENSELESS SU (NOT FOR POWDER)
              ELSE IF (FN(2) > 0.0 .AND. IPR(105) == 0) THEN
                M7 = M7 + 50
C * ALERT _75x
                IF (A < 9.9) THEN
                  WRITE (NQ3, 99997, IOSTAT = IOST) A
                  WRITE (NQ4, 99997, IOSTAT = IOST) SB
                  CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                  WRITE (LINE, 99993, IOSTAT = IOST) (FN(I), I = 1, 2),
     1              (IFL(I)(1:9), I = 1, 2), (IFL(I)(1:8), I = 11, 12),
     2              N7
                  CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                ELSE IF (A < 99.9) THEN
                  WRITE (NQ3, 99998, IOSTAT = IOST) A
                  WRITE (NQ4, 99997, IOSTAT = IOST) SB
                  CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                  WRITE (LINE, 99990, IOSTAT = IOST) (FN(I), I = 1, 2),
     1              (IFL(I)(1:9), I = 1, 2), (IFL(I)(1:8), I = 11, 12),
     2              N7
                CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                END IF
              END IF
            END IF
C * CHECK ANGLES
          ELSE IF (N == 3) THEN
C * CHECK FOR METAL [(METAL)ORGANIC ONLY]
            IF (FN(1) < 45.0 .AND. IGBL(97) == 1) THEN
              CALL GEN048 (-1, IFG(1, NRAT(2)), 19, IVAL)
              IF (IVAL == 0) THEN
C * ALERT _779
                WRITE (NQ3, 99999, IOSTAT = IOST) FN(1)
                CALL PLA236 (-779, 2, -999.0, 0.0, NQ3, ' ')
                WRITE (LINE, 99989, IOSTAT = IOST)
     1            (IFL(I)(1:5), I = 1, 3), (IFL(I)(1:8), I = 11, 13),
     2             N7
                CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
              END IF
            END IF
C * CHECK ABSOLUTE BOND ANGLE VALUES
            M8 = M7
            CALL PLA053 (NRAT(1), NRAT(2), NRAT(3), 0, A, SA, ISA,
     1        NDEC, IER)
            IF (IER /= 0) CYCLE
            SB    = MAX (0.0, SA)
            RATIO = ABS (FN(1) - A)
            IF (FN(2) <= 0.0 .OR. SA <= 0.0) THEN
              M8 = M8 + 20
              IF (FN(2) <= 0.0 .AND. SA <= 0.0) THEN
                RATIO1 = -999.0
              ELSE
                RATIO1 = RATIO
              END IF
            ELSE
              RATIO  = RATIO / SA
              RATIO1 = RATIO
            END IF
            IF (RATIO1 > 1.0 .OR.
     1        (RATIO1 == -999.0 .AND. RATIO > 1.0)) THEN
              WRITE (NQ3, 99999, IOSTAT = IOST) A
              WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _70x,_72x
              CALL PLA236 (-(700 + M8), 2, RATIO1, RATIO, NQ3, NQ4)
              WRITE (LINE, 99994, IOSTAT = IOST) (FN(I), I = 1, 2),
     1          (IFL(I)(1:8), I = 1, 3), (IFL(I)(2:8), I = 11, 13), N7
              CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
            END IF
C * CHECK BOND ANGLE SU's
            IF (NPOP == 3) THEN
              IF (NCSYM == 0) THEN
                IF (SA > 0.0 .AND. ABS(A) < 179.95) THEN
                  IF (FN(2) > 0.0) THEN
                    RATIO  = MIN (9.9, FN(2) / SA)
C * CHECK FOR RIDING H'S
                    CALL GEN048 (-1, IFG(1, NRAT(1)), 7, IVAL)
                    IF (IVAL /= 0) THEN
                      CALL GEN048 (-1, IFG(3, NRAT(1)), 6, IVAL)
                      IF (IVAL /= 0) CYCLE
                    END IF
                    CALL GEN048 (-1, IFG(1, NRAT(3)), 7, IVAL)
                    IF (IVAL /= 0) THEN
                      CALL GEN048 (-1, IFG(3, NRAT(3)), 6, IVAL)
                      IF (IVAL /= 0) CYCLE
                    END IF
                    IF (SA > 0.01 .AND. FN(2) > 0.007) THEN
                      IF (RATIO > 1.5) THEN
                        M7 = M7 + 30
                        IF (IDAR2 == 0) THEN
                          WRITE (NQ3, 99999, IOSTAT = IOST) A
                          WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _73x
                          CALL PLA236 (-(700 + M7), 2, RATIO, RATIO,
     1                      NQ3, NQ4)
                          WRITE (LINE, 99994, IOSTAT = IOST)
     1                      (FN(I), I = 1, 2), (IFL(I)(1:8), I = 1, 3),
     2                      (IFL(I)(2:8), I = 11, 13), N7
                          CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                        END IF
                      END IF
                    END IF
                  ELSE
                    IF (IRAT2 + IGAT2 + IDAR2 + IPR(639) == 0) THEN
                      M7 = M7 + 40
                      WRITE (NQ3, 99999, IOSTAT = IOST) A
                      WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _74x
                      CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                      WRITE (LINE, 99994, IOSTAT = IOST)
     1                  (FN(I), I = 1, 2), (IFL(I)(1:8), I = 1, 3),
     2                  (IFL(I)(2:8), I = 11, 13), N7
                      CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                    END IF
                  END IF
C * TEST FOR SENSELESS SU (NOT FOR POWDER)
                ELSE IF (FN(2) > 0.0 .AND. ABS (A) < 179.95 .AND.
     1            IPR(105) == 0) THEN
                  M7 = M7 + 50
                  WRITE (NQ3, 99999, IOSTAT = IOST) A
                  WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _75x
                  CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                  WRITE (LINE, 99994, IOSTAT = IOST) (FN(I), I = 1, 2),
     1              (IFL(I)(1:8), I = 1, 3), (IFL(I)(2:8), I = 11, 13),
     2              N7
                  CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                END IF
              END IF
            END IF
C * TORSIONS
          ELSE IF (N == 4) THEN
            NRTORS = NRTORS + 1
C * CHECK ABSOLUTE TORSION ANGLE VALUES
            M8 = M7
            CALL PLA050 (NRAT(1), NRAT(2), NRAT(3), 0, A1)
            CALL PLA050 (NRAT(2), NRAT(3), NRAT(4), 0, A2)
            IF (A1 < 170 .AND. A2 < 170) THEN
              CALL PLA053 (NRAT(1), NRAT(2), NRAT(3), NRAT(4), A, SA,
     1          ISA, NDEC, IER)
              IF (IER /= 0) CYCLE
              SB = MAX (0.0, SA)
              RATIO = ABS (FN(1) - A)
              IF (RATIO > 180.0) RATIO = 360.0 - RATIO
              IF (FN(2) <= 0.0 .OR. SA <= 0.0) THEN
                M8 = M8 + 20
                RATIO1 = RATIO
              ELSE
                RATIO  = RATIO / SA
                RATIO1 = RATIO
              END IF
              IF (RATIO > 1.0) THEN
                WRITE (NQ3, 99999, IOSTAT = IOST) A
                WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _70x,_72x
                CALL PLA236 (-(700 + M8), 2, RATIO1, RATIO, NQ3, NQ4)
                WRITE (LINE, 99992, IOSTAT = IOST)
     1            (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2          (IFL(I)(2:8), I = 11, 14), N7
                CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
              END IF
C * CHECK TORSION ANGLE SU's
              IF (NPOP == 4) THEN
                CALL GEN048 (-1, IFG(1, NRAT(2)), 6, ISP2)
                CALL GEN048 (-1, IFG(1, NRAT(3)), 6, ISP3)
                IF (ABS (A) > 0.05 .AND. ABS (A) < 179.95 .AND.
     1             ABS (ABS (A) - 60.0) > 0.01) THEN
                  IF (SA > 0.0) THEN
                    IF (ISP2 == 0 .AND. ISP3 == 0) THEN
                      IF (FN(2) > 0.0) THEN
                        RATIO = MIN (9.9, MAX (FN(2) / SA, SA / FN(2)))
C * CHECK FOR MOPRO
                        IF (RATIO > 1.5 .AND. IPR(725) /= 9) THEN
                          M7 = M7 + 30
                          WRITE (NQ3, 99999, IOSTAT = IOST) A
                          WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _73x
                          CALL PLA236 (-(700 + M7), 2, RATIO, RATIO,
     1                      NQ3, NQ4)
                          WRITE (LINE, 99992, IOSTAT = IOST)
     1                      (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2                      (IFL(I)(2:8), I = 11, 14), N7
                          CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                        END IF
                      ELSE
                        IF (IRAT2 + IDAR2 + IGAT2 == 0) THEN
                          M7 = M7 + 40
                          WRITE (NQ3, 99999, IOSTAT = IOST) A
                          WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _74x
                          CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3,
     1                      NQ4)
                          WRITE (LINE, 99992, IOSTAT = IOST)
     1                      (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2                      (IFL(I)(2:8), I = 11, 14), N7
                          CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                        END IF
                      END IF
                    END IF
C * TEST FOR SENSELESS SU (NOT FOR POWDER)
                  ELSE IF (FN(2) > 0.0 .AND. IPR(105) == 0) THEN
                    M7 = M7 + 50
                    WRITE (NQ3, 99999, IOSTAT = IOST) A
                    WRITE (NQ4, 99999, IOSTAT = IOST) SB
C * ALERT _75x
                    CALL PLA236 (-(700 + M7), 2, 1.0, 1.0, NQ3, NQ4)
                    WRITE (LINE, 99992, IOSTAT = IOST)
     1                (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2                (IFL(I)(2:8), I = 11, 14), N7
                    CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
                  END IF
                END IF
              END IF
            ELSE
              WRITE (LINE, 99996, IOSTAT = IOST) N7
C * ALERT _710
              CALL PLA236 (-710, 0, -999.0, 0.0, LINE(1:7), ' ')
              WRITE (LINE, 99991, IOSTAT = IOST)
     1          (IFL(I)(1:4), I = 1, 4), (FN(I), I = 1, 2),
     2          (IFL(I)(1:8), I = 11, 14)
              CALL PLA236 (0, 0, 0.0, 0.0, LINE, ' ')
            END IF
          END IF
        END IF
      END DO
C * CHECK FOR NON-CSD CIF
      IF (IGBL(94) == 0) THEN
C * CHECK FOR ORGANIC
        IF (IGBL(97) == 1) THEN
C * ALERT _760
          IF (NRTORS == 0 .AND. IPR(105) == 0)
     1      CALL PLA236 (760, 1, -999.0, 1.0, ' ', ' ')
C * CHECK H-PRESENT
          IF (IPR(484) > 0) THEN
C * ALERT _761
            IF (NBHAT == 0) CALL PLA236 (761, 0, 1.0, 1.0, ' ', ' ')
C * ALERT _762
            IF (NAHAT == 0) CALL PLA236 (762, 0, 1.0, 1.0, ' ', ' ')
          END IF
        END IF
      END IF
      CALL GEN108 (LU11, 0)
99999 FORMAT (F7.2)
99998 FORMAT (F7.4)
99997 FORMAT (F7.5)
99996 FORMAT (I5, 2X)
99995 FORMAT (20X, 4A)
99994 FORMAT (2F7.2, 2(A, '-'), A, 1X, 3A, 5X, '#', I5,
     1       ' Check')
99993 FORMAT (F7.5, F7.5, A, '-', A, 4X, 2A, 1X, 8('.'), 5X, '#',
     1        I5, ' Check')
99992 FORMAT (2F7.2, 3(A, '-'), A, 4A, 6X, '#', I5, ' Check')
99991 FORMAT (14X, 3(A, '-'), A, F8.2, F6.2, 4A)
99990 FORMAT (F7.4, F7.5, A, '-', A, 4X, 2A, 1X, 8('.'), 5X, '#',
     1       I5, ' Check')
99989 FORMAT (14X, 2(A, '-'), A, 3A, 1X, 6('.'), 5X, '#', I5, ' Check')
99988 FORMAT (F7.4, F7.5, A, '-', A, 4X, 2A, 1X, 8('.'), 5X, '#',
     1        I5, ' Check')
99987 FORMAT (F8.3)
      RETURN
      END SUBROUTINE PLA272
 
      SUBROUTINE PLA273 (MODE, CODE, NS, IT1, IT2, IT3, IER)
C * SAVE ORIGINAL SYMMETRY CODES AS SUPPLIED IN CIF
      USE pl273
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IX
      INTEGER :: NS
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: M3
      INTEGER :: MS
      INTEGER :: IT1
      INTEGER :: IT2
      INTEGER :: IT3
      INTEGER :: IER
      INTEGER :: MODE
      REAL    :: Z
      REAL    :: RX
      REAL    :: CODE
C * HANDLE/STORE EXPLICIT SYMMETRY CODES IN CIF
      RX  = CODE
      IER = 0
 
C * MODE = 0 - ANALYSE CIF-SYMMETRY CODE
      IF (MODE == 0) THEN
C * HANDLE SYMMETRY CODES 'X':  ('.' = DEFAULT = 1.555)
        IF (RX == 0.0) THEN
          CODE = 1.555
          NS   = 1
          IT1  = 0
          IT2  = 0
          IT3  = 0
        ELSE
          IX = INT (ABS (RX))
          IF (ABS (RX) - FLOAT (IX) < 0.01) THEN
            IF (RX > 0.0) THEN
              RX = RX + 0.555
            ELSE
              RX = RX - 0.555
            END IF
          END IF
C * REPLACE SYMM ID BY SEQUENCE NUMBER
          IF (RX >= 0.0) THEN
            N = INT (RX)
            Z = RX - N
          ELSE
            N = - INT (ABS (RX))
            Z = ABS(RX) + N
          END IF
          DO I = 1, NSCF
            IF (NSID(I) == N) THEN
              RX = Z + I
              EXIT
            END IF
          END DO
          M  = NINT (RX  * 1000.0)
          MS = M  / 1000
          IF (MS <= 0 .OR. MS > NSCF) THEN
            IER = 1
            RETURN
          END IF
          M    = M  - MS * 1000
          M1   = M  / 100
          M    = M  - M1 * 100
          M1   = M1 - 5
          M2   = M  / 10
          M3   = M  - M2 * 10 - 5
          M2   = M2 - 5
          CODE = RX
          NS   = NSCIF(1, MS)
          IT1  = M1 + NSCIF(2, MS)
          IT2  = M2 + NSCIF(3, MS)
          IT3  = M3 + NSCIF(4, MS)
        END IF
C * MODE = 1 - GET CIF-SYMMETRY CODE
      ELSE IF (MODE == 1) THEN
        M  = INT (RX)
        MS = M  / 1000
        M  = M  - MS * 1000
        M1 = M  / 100
        M  = M  - M1 * 100
        M1 = M1 - 5
        M2 = M  / 10
        M3 = M  - M2 * 10 - 5
        M2 = M2 - 5
        IF (NSCF > 0) THEN
          DO I = 1, NSCF
            IF (MS == NSCIF(1, I)) THEN
              NS  = NSID(I)
              IT1 = M1 - NSCIF(2, I)
              IT2 = M2 - NSCIF(3, I)
              IT3 = M3 - NSCIF(4, I)
              RETURN
            END IF
          END DO
        END IF
        IER = 1
        RETURN
      END IF
      RETURN
      END SUBROUTINE PLA273
 
      SUBROUTINE PLA274
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      CHARACTER(len=1) :: ICH
C * LIST SYMMETRY
      IF (IWIN == 1) THEN
        VRT = VERT - 0.2
        CALL GGIP (HORS, VERT, 0.0, 1)
        OPEN (LU61, FILE = 'srcsrc', STATUS = 'UNKNOWN')
        CALL SGSM (2, ICL, SGX, 0, LU61, IERR)
        CALL GEN108 (LU61, 0)
        DO
          READ (LU61, 99999, IOSTAT = IOST) ICL(1:80)
          IF (IOST /= 0) EXIT
          IF (VRT - 0.5 < 0.0) THEN
C * WHAT NEXT ?
            CALL PLA012 (1, 1)
            ICH = IGGT(1:1)
            CALL GGIP (HORS, VERT, 0.0, 1)
            IF (ICH /= 'Y' .AND. ICH /= '!') EXIT
            VRT = VERT
          END IF
          VRT = VRT - 0.5
          CALL PLA439 (0.0, ICL, 80, 0.35, 1, 2, 1.0, VRT)
        END DO
        CLOSE (UNIT = LU61, STATUS = 'DELETE')
        CALL PLA297 (0)
      ELSE
        CALL SGSM (2, ICL, SGX, 0, LU6, IERR)
      END IF
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA274
 
      SUBROUTINE PLA275
C * PACK check.def FILE CONTENT INTO FORTRAN CODE: check.f ( = CHECK)
C * check.def SOURCE LOCATION TAKEN FROM THE 'CHECKDEF' VARIABLE
C * The check.f FILE IS PUT IN THE CURRENT DIRECTORY AND SHOULD BE APPENDED
C * TO THE FORTRAN SOURCE OR REPLACE THE PREVIOUS VERSION OF THE CHECK ROUTINE
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER                             :: I
      INTEGER                             :: J
      INTEGER                             :: K
      INTEGER                             :: L
      INTEGER                             :: M
      INTEGER                             :: N
      INTEGER                             :: N0
      INTEGER                             :: N1
      INTEGER                             :: N2
      INTEGER                             :: N3
      INTEGER                             :: N4
      INTEGER                             :: NUM
      INTEGER                             :: ICKVERS
      INTEGER,           DIMENSION(4)     :: IC
      INTEGER,           DIMENSION(6)     :: IBUF
      CHARACTER(len=80)                   :: LINE
      CHARACTER(len=72), DIMENSION(50)    :: BUF
      CHARACTER(len=1),  DIMENSION(4, 20) :: A
      DO I = 1, 4
        IC(I) = 256**(I - 1)
      END DO
C * DEFAULT: /usr/local/lib/platon/check.def
      OPEN (UNIT = LU12, FILE = CHECKDEF, STATUS = 'OLD', IOSTAT = IOST)
      IF (IOST == 0) THEN
        OPEN  (LU61, FILE = 'check.f', STATUS = 'UNKNOWN')
C * IBUF() =  0 : END-OF-FILE
C *        = -1 : #==== RECORD
C *        = -2 : BLANK RECORD
C *        = -3 : END-OF-RECORD
        N2 = 0
C * L      =  0 : DETERMINE REQUIRED SIZE OF ARRAY BUF
C *        =  1 : FILL BUF WITH ENCODED check.def CONTENT
        DO L = 0, 1
          REWIND (LU12)
          IF (L > 0) WRITE (LU61, 99997) N2
          ICKVERS = 0
          N0      = 0
          N1      = 1
          N2      = 0
          M       = 0
          DO
            READ (LU12, 99998, IOSTAT = IOST) LINE
            IF (IOST /= 0) THEN
              M       = M + 1
              IBUF(M) = 0
              CALL PLA276 (L, N0, N1, N2, BUF, IBUF, 1)
              IF (L > 0) WRITE (LU61, 99996)
              EXIT
C * GET VERSION # IN check.def (yymmdd)
            ELSE IF (LINE(1:6) == '!check') THEN
              N = INDEX (LINE, 'version')
              IF (N > 0) THEN
                READ (LINE(N + 7:N + 14), *) ICKVERS
                M = M + 1
                IBUF(M) = - ICKVERS
              ELSE
                EXIT
              END IF
            ELSE IF (LINE(1:5) == '#====') THEN
              M       = M + 1
              IBUF(M) = -1
              IF (M == 6) THEN
                CALL PLA276 (L, N0, N1, N2, BUF, IBUF, 0)
                M = 0
              END IF
            ELSE
              K  = 20
              N3 = 77
              N4 = 80
              DO
                IF (LINE(N3:N4) == '    ') THEN
                  K = K - 1
                  IF (K == 0) THEN
                    M       = M + 1
                    IBUF(M) = -2
                    IF (M == 6) THEN
                      CALL PLA276 (L, N0, N1, N2, BUF, IBUF, 0)
                      M = 0
                    END IF
                    EXIT
                  ELSE
                    N3 = N3 - 4
                    N4 = N4 - 4
                  END IF
                ELSE
                  EXIT
                END IF
              END DO
C * REGULAR TEXT RECORD
              IF (K > 0) THEN
                READ (LINE, 99999, IOSTAT = IOST)
     1            ((A(J, I), J = 1, 4), I = 1, K)
                DO I = 1, K
                  NUM = 0
                  DO J = 1, 4
                    NUM = NUM + ICHAR (A(J, I)) * IC(5 - J)
                  END DO
                  M       = M + 1
                  IBUF(M) = NUM
                  IF (M == 6) THEN
                    CALL PLA276 (L, N0, N1, N2, BUF, IBUF, 0)
                    M = 0
                  END IF
                END DO
C * EARLY END-OF-RECORD
                IF (K < 20) THEN
                  M = M + 1
                  IBUF(M) = -3
                  IF (M == 6) THEN
                    CALL PLA276 (L, N0, N1, N2, BUF, IBUF, 0)
                    M = 0
                  END IF
                END IF
              END IF
            END IF
          END DO
        END DO
        WRITE (LU6, 99995) ICKVERS, N2
      ELSE
        WRITE (LU6, 99994) 'No '//CHECKDEF(1:70)//' found'
      END IF
      RETURN
99999 FORMAT (80A)
99998 FORMAT (A)
99997 FORMAT (6X, 'SUBROUTINE CHECK (MODE, IVERS)', /,
     1        'C', /,
     2        'C * EMBEDDED ENCODED check.def FILE', /,
     3        'C', /,
     4        6X, 'IMPLICIT NONE', /,
     5        6X, 'INTEGER                            :: MODE', /,
     6        6X, 'INTEGER                            :: IVERS', /,
     7        6X, 'INTEGER, ALLOCATABLE, DIMENSION(:) :: ICK', /,
     8        6X, 'ALLOCATE (ICK(', I6, '))')
99996 FORMAT (6X, 'IF (MODE == 0) THEN', /,
     1        'C * GET VERSION NUMBER yymmdd', /,
     2        6X, '  IVERS = - ICK(1)', /,
     3        6X, 'ELSE', /,
     4        'C * RE-CREATE check.def FILE', /,
     5        6X, '  CALL PLA277 (ICK)', /,
     6        6X, 'END IF', /,
     7        6X, 'RETURN', /,
     8        6X, 'END SUBROUTINE CHECK')
99995 FORMAT ('Create check.f for check.def version =', I7, 5X,
     1        '[', I6,']')
99994 FORMAT (/, A, /)
      END SUBROUTINE PLA275
 
      SUBROUTINE PLA276 (L, N0, N1, N2, BUF, IBUF, M)
C * PACK check.def > check.f
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER                          :: I
      INTEGER                          :: L
      INTEGER                          :: M
      INTEGER                          :: N0
      INTEGER                          :: N1
      INTEGER                          :: N2
      INTEGER, DIMENSION(*)            :: IBUF
      CHARACTER(len=72), DIMENSION(50) :: BUF
      CHARACTER(len=72)                :: LINE
      IF (L > 0) WRITE (LINE, 99999) (IBUF(I), I = 1, 6)
      N0 = N0 + 1
      N2 = N2 + 6
      IF (N0 == 50 .OR. M == 1) THEN
        LINE (72:72) = '/'
        BUF(N0) = LINE
        IF (L > 0) THEN
          WRITE (LU61, 99997) N1, N2
          WRITE (LU61, 99998) (BUF(I), I = 1, N0)
          WRITE (LU61, 99996)
        END IF
        N0 = 0
        N1 = N1 + 300
      ELSE
        BUF(N0) = LINE
      END IF
      RETURN
99999 FORMAT (5X, '*', 6(I10, ','))
99998 FORMAT (A)
99997 FORMAT (6X, 'ICK(', I6,':', I6, ') = (/')
99996 FORMAT (5X, '* )')
      END SUBROUTINE PLA276
 
      SUBROUTINE PLA277 (ICK)
      USE files
      USE parameters
C * RE-CREATE A check.def FROM THE PACKED VERSION IN ARRAY ICK
C * check.def IS PUT IN THE CURRENT DIRECTORY
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: K
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: M1
      INTEGER               :: ICKVERS
      INTEGER, DIMENSION(4) :: IC
      INTEGER, DIMENSION(*) :: ICK
      CHARACTER(len=80)     :: LINE
      INQUIRE (UNIT = LU12, OPENED = OPEND)
      IF (OPEND) CLOSE (UNIT = LU12, IOSTAT = IOST)
      OPEN (UNIT = LU12, FILE = 'check.def', STATUS = 'UNKNOWN',
     1  IOSTAT = IOST)
      IF (IOST /= 0) CALL GEN127 ('check.def file open problem')
      ICKVERS = 0
      LINE    = ' '
      DO I = 1, 4
        IC(I) = 256**(I - 1)
      END DO
      N  = 0
      I  = 0
C * LOOP OVER ARRAY WITH PACKED CHECK.DEF CONTENT
      DO
        I  = I + 1
        M  = ICK(I)
C * GENERAL ENTRIES
        IF (M > 0) THEN
          DO K = 1, 4
            M1 = M / IC(5 - K)
            N  = N + 1
            LINE(N:N) = CHAR (M1)
            M  = M - M1 * IC(5 - K)
          END DO
          IF (N == 80) THEN
            WRITE (LU12, 99997, IOSTAT = IOST) LINE
            N = 0
          END IF
C * SPECIAL KEYWORD ENTRIES
        ELSE
C * CHECK FOR END-OF-FILE
          IF (M == 0) THEN
            IF (ICKVERS > 0) WRITE (LU6, 99996) ICKVERS
            RETURN
C * CHECK FOR SEPARATOR RECORD
          ELSE IF (M == -1) THEN
            WRITE (LU12, 99999, IOSTAT = IOST)
C * CHECK FOR BLANK RECORD
          ELSE IF (M == -2) THEN
            WRITE (LU12, 99998, IOSTAT = IOST)
C * CHECK FOR 'END-OF-RECORD' RECORD
          ELSE IF (M == -3) THEN
            WRITE (LU12, 99997, IOSTAT = IOST) LINE(1:N)
            N = 0
          ELSE
            ICKVERS = - M
            WRITE (LU12, 99995, IOSTAT = IOST) ICKVERS
          END IF
        END IF
      END DO
      IGBL(21) = ICKVERS
      RETURN
99999 FORMAT ('#', 77('='))
99998 FORMAT (80X)
99997 FORMAT (A)
99996 FORMAT (/, ':: check.def version', I7,
     1 ' created from embedded data')
99995 FORMAT ('!check.def version', I7, 1X, 51('='))
      END SUBROUTINE PLA277
 
      SUBROUTINE PLA278
C * GENERATE platon_special.f from platon.f
      USE files
      IMPLICIT NONE
      INTEGER           :: NB = 1
      INTEGER           :: NE = 80
      INTEGER           :: ISKIP = 0
      CHARACTER(len=80) :: LINE
      OPEN (UNIT = LU60, FILE = 'platon.f', STATUS = 'OLD',
     1  IOSTAT = IOST)
      IF (IOST == 0) THEN
        OPEN  (LU61, FILE = 'platon_special.f', STATUS = 'UNKNOWN')
        DO
          READ (LU60, 99999, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          IF (LINE(1 : 11) == 'C STRIP_BEG') THEN
            ISKIP = 1
          ELSE IF (LINE(1 : 11) == 'C STRIP_END') THEN
            ISKIP = 0
          END IF
          CALL GEN039 (1, LINE, 1, 80, NB, NE)
          IF (ISKIP ==0) WRITE (LU61, 99999, IOSTAT = IOST) LINE (1:NE)
        END DO
      ELSE
        CALL GEN127 ('No platon.f file found in this directory')
      END IF
        STOP 'platon_special.f created from platon.f'
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA278
 
      SUBROUTINE PLA279 (IAT, N)
C * PROGRAM TO CALCULATE POLYHEDRAL VOLUMES AND DISTORTION PARAMETERS (4 & 6)
C * See R.M.Hazen & L.W.Finger, Comparative Crystal Chemistry, 1982, p86 AND
C *   APPENDIX III (Original Fortran Source Code by L.W. Finger 9/21/71)
C * ORIGINAL PROGRAM VOLCAL CODE ADAPTED AND EXTENDED FOR USE IN PLATON
      USE files
      USE parameters
      USE atomdata
      USE plato
      USE xwdw
      USE sgxyz
      IMPLICIT NONE
      INTEGER                               :: I
      INTEGER                               :: J
      INTEGER                               :: K
      INTEGER                               :: L
      INTEGER                               :: M
      INTEGER                               :: N
      INTEGER                               :: NA
      INTEGER                               :: NM
      INTEGER                               :: MN
      INTEGER                               :: NP
      INTEGER                               :: IAT
      INTEGER                               :: NPMN
      INTEGER                               :: NPMX
      INTEGER                               :: IDUM
      INTEGER                               :: JDUM
      INTEGER,             DIMENSION(3)     :: IH
      REAL                                  :: Z
      REAL                                  :: ZO
      REAL                                  :: QE
      REAL                                  :: VLO
      REAL                                  :: VOL
      REAL                                  :: SOM4
      REAL                                  :: SOM6
      REAL                                  :: SIGA
      REAL                                  :: ANG1
      REAL                                  :: ANG2
      REAL                                  :: AREA
      REAL                                  :: CONS
      REAL                                  :: TEMP
      REAL                                  :: SUMTH
      REAL                                  :: SUMTH2
      REAL                                  :: FACTOR
      REAL                                  :: GEN009
      REAL,                DIMENSION(3)     :: D
      REAL,                DIMENSION(3, 12) :: XP
      REAL,                DIMENSION(20)    :: DM
      CHARACTER(len=80)                     :: LINE
      CHARACTER(len=11)                     :: POLY
      CHARACTER(len=132)                    :: PRBUF
      CHARACTER(len=NP64), DIMENSION(12)    :: CXP
C * EXCLUDE SOME CENTRAL ELEMENT TYPES
      CALL GEN048 (-4, IFG(1, IAT), 15, K)
      K = IEN(K + 1)
      IF (ELB(K) /= 'O ') THEN
C * CALCULATE NP COORDINATION DISTANCES (CENTRE AT 0,0,0)
        L    = 0
        SOM4 = 0.0
        SOM6 = 0.0
        DO J = 1, N
C * EXCLUDE 'COORDINATING' METALS
          CALL GEN048 (-1, IFG(1, IATC(J)), 19, K)
          IF (K == 0) THEN
            L    = L + 1
            TEMP = 0.0
            DO I = 1, 3
              XP(I, L) = XXO(IATC(J), I + 3) - XXO(IAT, I + 3)
              TEMP = TEMP + XP(I, L)**2
            END DO
            IF (L <= 4) SOM4 = SOM4 + TEMP
            IF (L <= 6) SOM6 = SOM6 + TEMP
            DM(L)  = SQRT (TEMP)
C * GET ATOM LABEL
            CALL PLA047 (LABA(IATC(J)), CXP(L), IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
          END IF
        END DO
        IF (L >= 4) THEN
          NPMX = L
          NPMN = L
          IF (IGBL(144) > 0) THEN
            NPMN = 4
            WRITE (LU6, 99988)
          END IF
          DO NP = NPMN, NPMX
            NA     = 0
            VOL    = 0.0
            ANG1   = 0.0
            ANG2   = 0.0
            SUMTH  = 0.0
            SUMTH2 = 0.0
C * FIND TRIANGULAR FACES, CHOOSE ANY THREE POINTS
C * LOOP OVER FIRST VERTEX
            DO I = 1, NP - 2
              IH(1) = I
C * LOOP OVER SECOND VERTEX
              DO J = I + 1, NP - 1
                IH(2) = J
                DO K = 1, 3
                  V1(K) = XP(K, J) - XP(K, I)
                END DO
C * LOOP OVER THIRD VERTEX
                DO K = J + 1, NP
                  IH(3) = K
                  DO N = 1, 3
                    V2(N) = XP(N, K) - XP(N, I)
                  END DO
C * VECTOR PRODUCT. PLANE EQUATION. DISTANCE ORIGIN
                  CALL GEN008 (V1, V2, D, 0)
                  AREA = SQRT (GEN009 (D, D))
                  ZO   = (XP(1, I) * D(1) + XP(2, I) * D(2)
     1                 +  XP(3, I) * D(3)) / AREA
C * CHECK FOR AND AVOID PLANE THROUGH ORIGIN
                  IF (ABS(ZO) >= 0.0025) THEN
                    FACTOR = 6.0
                    DO L = 1, NP
                      IF (L /= I .AND. L /= J .AND. L /= K) THEN
C * CALCULATE DISTANCE OF POINT L FROM PLANE OF I,J,K
                        Z = ((XP(1, I) - XP(1, L)) * D(1)
     1                    +  (XP(2, I) - XP(2, L)) * D(2)
     2                    +  (XP(3, I) - XP(3, L)) * D(3)) / AREA
C * Z AND ZO MUST HAVE THE SAME SIGN
                        IF (Z * ZO < -0.001) THEN
                          FACTOR = 0.0
                          EXIT
                        ELSE
C * IF MORE THAN 3 CORNERS ON THIS FACE, THE AREA WILL BE COUNTED TWICE.
C * CHANGE FACTOR TO HANDLE THIS CASE.
                          IF (ABS (Z * ZO) < 0.001) FACTOR = 12.0
                        END IF
                      END IF
                    END DO
                    IF (FACTOR > 0.0) THEN
                      VOL = VOL + AREA * ABS (ZO) / FACTOR
                      DO L = 1, 2
                        NM = IH(L)
                        DO M = L + 1, 3
                          MN   = IH(M)
                          TEMP = 0.0
                          DO N = 1, 3
                            TEMP = TEMP + XP(N, NM) * XP(N, MN)
                          END DO
                          TEMP   = TEMP / (DM(NM) * DM(MN))
                          TEMP   = RGBL(6)
     1                      * ATAN2 (SQRT (ABS (1.0 - TEMP**2)), TEMP)
                          SUMTH  = SUMTH  + TEMP
                          SUMTH2 = SUMTH2 + TEMP**2
                        END DO
                      END DO
                      NA = NA + 3
                    END IF
                  END IF
                END DO
              END DO
            END DO
C * ALL FACES FOUND, CALCULATE QUADRATIC ELONGATION FOR TETRA- AND OCTAHEDRON
            NA     = (NA + 1) / 2
            QE     = 0.0
            VLO    = 0.0
            SIGA   = 0.0
            SUMTH2 = SUMTH2 / 2
            SUMTH  = SUMTH / 2
            IF (NP == 4) THEN
C * SET UP FOR TETRAHEDRON
              CONS = 9.0 * SQRT(3.0) / 8.0
C * CALC LO**2 (= VLO) OF EQUIVALENT VOLUME TETRAEDER
              IF (VOL > 0.0) THEN
                VLO = EXP (2.0 * ALOG (CONS * VOL) / 3.0)
C * CALC LAMBDA (QUADRATIC ELONGATION)
                QE   = SOM4 / (4.0 * VLO)
                SIGA = (SUMTH2 - 2.0 * 109.45 * SUMTH + NA * 109.45**2)
     1               / (NA - 1)
                POLY = 'Tetrahedral'
              ELSE
                POLY = 'Planar'
              END IF
C * TAU(4) CALCULATION
              DO I = 1, 3
                DO J = I + 1, 4
                  TEMP = 0.0
                  DO N = 1, 3
                    TEMP = TEMP + XP(N, I) * XP(N, J)
                  END DO
                  TEMP = TEMP / (DM(I) * DM(J))
                  TEMP = RGBL(6)
     1                 * ATAN2 (SQRT (ABS (1.0 - TEMP * TEMP)), TEMP)
C * REGISTER LARGEST ANGLES
                  IF (TEMP >= ANG1) THEN
                    IF (ANG1 > ANG2) ANG2 = ANG1
                    ANG1 = TEMP
                  ELSE IF (TEMP > ANG2) THEN
                    ANG2 = TEMP
                  END IF
                END DO
              END DO
            ELSE IF (NP == 6) THEN
C * SET UP FOR OCTAHEDRON
              CONS  = 0.75
C * CALC LO**2 (= VLO) OF EQUIVALENT VOLUME OCTAHEDRON
              IF (VOL > 0.0) THEN
                VLO = EXP (2.0 * ALOG (CONS * VOL) / 3.0)
C * CALC LAMBDA (QUADRATIC ELONGATION)
                QE   = SOM6 / (6 * VLO)
                SIGA = (SUMTH2 - 2.0 * 90.0 * SUMTH + NA * 90.0**2)
     1             / (NA - 1)
                POLY = 'Octahedral '
              ELSE
                POLY = 'Planar'
              END IF
            ELSE
              CALL PLA262 (2)
              WRITE (LU7, 99998, IOSTAT = IOST) VOL, NP
            END IF
            IF (IGBL(144) > 0) WRITE (LU6, 99997, IOSTAT = IOST)
     1        NAMS(1, 1)(1:8), VOL, NP
            IF (NP == 4 .OR. NP == 6) THEN
              IF (VOL > 1.0) THEN
                CALL PLA262 (2)
                WRITE (LU7, 99999, IOSTAT = IOST) POLY, VOL, QE, SIGA
                IF (IGBL(144) > 0) WRITE (LU6, 99987, IOSTAT = IOST)
     1            QE, SIGA
                IF (IWIN == 1) THEN
                  VRT = 3.0
                  HRT = 17.0
                  WRITE (LINE, 99991, IOSTAT = IOST) POLY
                  CALL PLA439 (0.0, LINE, 34, 0.30, 5 + IGBL(68), 2,
     1                         HRT, VRT)
                  VRT = VRT - 0.5
                  WRITE (LINE, 99996, IOSTAT = IOST) VOL
                  CALL PLA439 (0.0, LINE, 34, 0.30, 5 + IGBL(68), 2,
     1                         HRT, VRT)
                  VRT = VRT - 0.5
                  WRITE (LINE, 99995, IOSTAT = IOST) QE
                  CALL PLA439 (0.0, LINE, 34, 0.30, 5 + IGBL(68), 2,
     1                         HRT, VRT)
                  VRT = VRT - 0.5
                  WRITE (LINE, 99994, IOSTAT = IOST) SIGA
                  CALL PLA439 (0.0, LINE, 34, 0.30, 5 + IGBL(68), 2,
     1                         HRT, VRT)
                END IF
              END IF
C * 4-COORDINATION - TAU(4)
              IF (NP == 4) THEN
                IF (IGBL(63) > 2) THEN
                  CALL PLA262 (5)
                  WRITE (LU7,   99993, IOSTAT = IOST)
                  WRITE (PRBUF, 99992, IOSTAT = IOST)
     1                   (360.0 - (ANG1 + ANG2)) /  141.0
                  IF (IGBL(144) > 0) WRITE (LU6, 99986, IOSTAT = IOST)
     1                   (360.0 - (ANG1 + ANG2)) /  141.0
                  WRITE (LU7, 99991, IOSTAT = IOST) PRBUF
                  IF (IWIN == 1) THEN
                    VRT = VRT - 0.6
                    CALL PLA439 (0.0, PRBUF, 132, 0.25, 5 + IGBL(68),
     1                    2, 0.2, VRT)
                  END IF
                END IF
              END IF
            END IF
C * LIST COORDINATING ATOM DATA
            IF (IGBL(144) > 0) THEN
              IF (NP .EQ. NPMX) THEN
                WRITE (LU6, 99989)
                DO J = 1, NP
                  WRITE (LU6, 99990) J, CXP(J), (XP(K, J), K = 1, 3),
     1              DM(J)
                END DO
              END IF
            END IF
          END DO
        END IF
      END IF
      RETURN
99999 FORMAT(/, A, ' Volume', F7.3, ' Ang**3, Quadratic Elongation',
     1       F7.3, ', Angle Variance', F7.2, ' Deg**2',
     2       ' [K.Robinson +, Science 1971,172,567-570]')
99998 FORMAT (/, 'Polyhedral Volume', F7.3, ' Ang**3 - Coordn = ', I3)
99997 FORMAT (/, ':: ', A, ' - Polyhedral Volume', F10.3, 1X,
     1        'Ang**3 - Coordn =', I2)
99996 FORMAT ('Volume', 14X, F7.3, ' Ang**3')
99995 FORMAT ('Quadratic Elongation', F7.3)
99994 FORMAT ('Angle Variance', 6X, F7.2, ' Deg**2')
99993 FORMAT (/, 'Tau(4)-Descriptor for 4-Coordination (L.Yang, D.R.',
     1 'Powell, R.P.Houser, Dalton Trans. (2007), 955-964)', /,
     2 132('-'))
99992 FORMAT ('Tau(4) = (360 - (Beta + Alpha)) / 141 =' , F5.2, ' :: ',
     1 '(Extreme Forms: 0.00 for SQP and 1.00 for TET; 0.85 for TRP)')
99991 FORMAT (A)
99990 FORMAT (I5, 2X,  A, 3F10.4, F12.4)
99989 FORMAT (/, 3X, 'Nr', 2X, 'Label', 16X, 'X', 9X, 'Y', 9X, 'Z', 8X,
     1 'Dist')
99988 FORMAT (/, 61('='))
99987 FORMAT ('::', 12X, 'Quadratic Elongation', F7.3, /,
     1        '::', 12X, 'I-O-J Angle Variance', F7.2, ' Deg**2')
99986 FORMAT ('::', 12X, 'Tau(4)', 16X , F5.2)
      END SUBROUTINE PLA279
 
      SUBROUTINE PLA280 (STR)
C * AUTO INSTRUCTIONS
      USE cggt
      IMPLICIT NONE
      INTEGER          :: LENM
      CHARACTER(len=*) :: STR
      LENM = MIN (80, LEN (STR))
      IGGT = STR(1:LENM)
      RETURN
      END SUBROUTINE PLA280
 
      SUBROUTINE PLA281 (MODE, NQ, MSUBST)
C * ALIAS SUBSTITUTION
      USE parameters
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: MODE
      INTEGER             :: MSUBST
      INTEGER             :: NALIAS
      CHARACTER(len=NP64) :: NQ
C * HANDLE ALIASES
      MSUBST = 0
      NALIAS = IPR(759)
      IF (NALIAS > 0) THEN
        CALL GEN020 (-1, NQ, 2, 2)
C * TRANSLATE NQ TO ALAB
        IF (MODE == -1) THEN
          DO I = 1, NALIAS
            IF (BLAB(I) == NQ) THEN
              NQ     = ALAB(I)
              MSUBST = MODE
              EXIT
            END IF
          END DO
C * TRANSLATE NQ TO BLAB
        ELSE IF (MODE == 1) THEN
          DO I = 1, NALIAS
            IF (ALAB(I) == NQ) THEN
              NQ     = BLAB(I)
              MSUBST = MODE
              EXIT
            END IF
          END DO
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA281
 
      SUBROUTINE PLA282 (MODE, NQA, NQB, LU)
C * ALIAS SUBSTITUTION (REGISTER & LISTING)
      USE parameters
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: M
      INTEGER             :: N
      INTEGER             :: LU
      INTEGER             :: MODE
      CHARACTER(len=NP64) :: NQA
      CHARACTER(len=NP64) :: NQB
C * GET # OF LABEL ALIASES
      N = IPR(759)
C * ADD ALIAS RELATION
      IF (MODE == 1) THEN
        N        = N + 1
        IPR(759) = N
        NQ1      = NQA
        CALL GEN020 (-1, NQ1, 2, 2)
        ALAB(N) = NQ1
        BLAB(N) = NQB
C * LIST ALIASES
      ELSE IF (MODE == -1 .AND. N > 0) THEN
        WRITE (LU, 99999)
        DO I = 1, N, 3
          M = MIN (2, N - I)
          WRITE (LU, 99998)
     1      (I + J, ALAB(I + J), BLAB(I + J)(1:6), J = 0, M)
        END DO
        WRITE (LU, 99997)
      END IF
99999 FORMAT (/, 80('='), /,
     1':: Temp. ALIASES used for ATOM labels that',
     2 ' are unsuitable for PLATON/checkCIF', /, 80('='))
99998 FORMAT (3(I4, 1X, A, ' > ', A))
99997 FORMAT (/)
      RETURN
      END SUBROUTINE PLA282
 
      SUBROUTINE PLA283 (MODE, XMZ, N, CDUMMY)
C * GENERATE MOIETY & SUM STRINGS
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: K
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: K0
      INTEGER                  :: N0
      INTEGER                  :: N1
      INTEGER                  :: N2
      INTEGER                  :: K1
      INTEGER                  :: KB
      INTEGER                  :: KE
      INTEGER                  :: KZ
      INTEGER                  :: IP
      INTEGER                  :: KZZ
      INTEGER                  :: IP0
      INTEGER                  :: IOST
      INTEGER                  :: MINT
      INTEGER                  :: MODE
      INTEGER                  :: INTT
      INTEGER                  :: INTTA
      INTEGER                  :: INTTB
      INTEGER                  :: IMODE
      INTEGER, DIMENSION(NP10) :: IENSS
      REAL                     :: XKZ
      REAL                     :: XMZ
      REAL                     :: CKK1
      CHARACTER(NP52)          :: JDM
      CHARACTER(NP52)          :: CDUMMY
      XKZ = 0.0
      KZ  = 0
C * MODE = 0 - MOIETY  FORMULA
C * MODE = 1 - RESIDUE FORMULA
C * MODE = 2 - SUM     FORMULA
      N = NP52 + 1
C * SPECIFIC 'MOIETY' NUMBER
      IF (MODE /= 0) THEN
        KB = MODE
        KE = MODE
C * MOIETY FORMULA MODE
      ELSE IF (MODE == 0) THEN
        KB = 4
        KE = IPR(488)
      END IF
      DO K0 = KB, KE
        K1 = KB + KE - K0
C * CHECK FOR CARBON /NON-CARBON FORMULA MODE
        IMODE = 0
        DO I = 1, IAN
          IF (IEN(I) == 2) THEN
            IF (CONT(I, K1) > 0.001) THEN
              IMODE = 1
              EXIT
            END IF
          END IF
        END DO
C * ORDER ELEMENTS IN FORMULA
        CALL GEN123 (IMODE, IEN, IENSS, IEL, IAN)
        N0 = NP52 + 1
        DO I = 1, IAN
          K = IENSS(IAN + 1 - I)
C * EXCLUDE 'Cg'
          IF (LMT(K, 1) /= 'Cg') THEN
            CKK1 = CONT(K, K1)
            IF (CKK1 > 0.001) THEN
              M = NINT (CKK1 / XMZ)
              IF (ABS (M * XMZ - CKK1) > XMZ * PAR(331)) THEN
C * ROUND UP
                CKK1 = CKK1 / XMZ
                INTT = INT (CKK1 * 1000.0 + 0.01)
                MINT = MOD (INTT, 10)
                IF (MINT > 4) INTT = INTT + 10 - MINT
                INTTA = INTT / 1000
                INTTB = MOD (INTT, 1000) / 10
                WRITE (NQ1, 99998, IOSTAT = IOST) INTTA, INTTB
                IF (CKK1 < 10.0) THEN
                  IP = 4
                ELSE IF (CKK1 < 100.0) THEN
                  IP = 5
                ELSE
                  IP = 6
                END IF
                N0 = N0 - IP
                JDM(N0:N0 + IP - 1) = NQ1 (8 - IP:7)
              ELSE
                IP = 0
                IF (M > 1) THEN
                  CALL GEN040 (M, NQ1, IP)
                  N0 = N0 - IP
                  JDM(N0:N0 + IP - 1) = NQ1(1:IP)
                END IF
              END IF
              N0 = N0 - 1
              JDM(N0:N0) = LMT(K, 1)(2:2)
              IF (LMT(K, 1)(1:1) /= CHAR (32)) THEN
                N0 = N0 - 1
                JDM(N0:N0) = LMT(K, 1)(1:1)
              END IF
              N0         = N0 - 1
              JDM(N0:N0) = CHAR (32)
            END IF
          END IF
        END DO
        IF (N0 < NP52 + 1) THEN
          IF (JDM(N0:N0) == CHAR (32)) N0 = N0 + 1
        END IF
        IF (MODE == 0) THEN
          XKZ = CONT(NP10 + 1, K1) * 2 / IPR(260)
          KZ  = NINT (CONT(NP10 + 1, K1) * 2) / IPR(260)
          IF (ABS (XKZ - KZ) > 0.0015 * KZ) THEN
            KZ = 0
          END IF
          IF (KZ /= 2) THEN
            IF (N == 1) RETURN
            N = N - 1
            CDUMMY(N:N) = ')'
          END IF
        END IF
        DO N1 = N0, NP52
          N2 = NP52 + N0 - N1
          IF (N == 1) RETURN
          N  = N  - 1
          CDUMMY(N:N) = JDM(N2:N2)
        END DO
        IF (MODE == 0) THEN
          IP0 = 1
          IF (KZ /= 2) THEN
            IF (KZ == 0) THEN
              IP = 6
              IF (XKZ / 2.0 < 10.0) IP0 = 2
              WRITE (NQ1(1:IP), 99999, IOSTAT = IOST) XKZ / 2.0
              IF (NQ1(5:6) == '00') THEN
                IP = 4
              ELSE IF (NQ1(6:6) == '0') THEN
                IP = 5
              END IF
            ELSE IF (MOD (KZ, 2) == 1) THEN
              IP = 3
              WRITE (NQ1(1:IP), 99997, IOSTAT = IOST)
     1         (KZ + 0.00001) / 2.0
            ELSE
              KZZ = KZ / 2
              CALL GEN040 (KZZ, NQ1, IP)
            END IF
            IF (N < IP + 2) RETURN
            N = N - 1
            CDUMMY(N:N) = '('
            CDUMMY(N - IP + IP0 - 1:N - 1) = NQ1(IP0:IP)
            N = N - IP + IP0 - 1
          END IF
          IF (K0 /= KE) THEN
            IF (N <= 2) RETURN
            N = N - 1
            CDUMMY(N:N) = CHAR (32)
            N = N - 1
            CDUMMY(N:N) = ','
          END IF
        END IF
      END DO
      IF (N > 1) CALL GEN038 (CDUMMY, 1, N - 1)
      RETURN
99999 FORMAT (F6.3)
99998 FORMAT (I4, '.', I2.2)
99997 FORMAT (F3.1)
      END SUBROUTINE PLA283
 
      MODULE strain2
      SAVE
      REAL, DIMENSION(12)   :: C
      REAL, DIMENSION(3, 3) :: Q
      REAL, DIMENSION(13)   :: S
      REAL, DIMENSION(2, 6) :: VC
      REAL, DIMENSION(3, 3) :: QI
      REAL, DIMENSION(13)   :: FO
      REAL, DIMENSION(3, 3) :: DC
      END MODULE strain2
 
      SUBROUTINE PLA284 (MORT, JID)
C ******************************************************************
C * STRAIN TENSOR CALCULATION PROGRAM FROM TWO SETS OF CELL PARAMETERS
C * VERSION 1 (1972). CODED BY Y.OHASHI, GEOPHYSICAL LABORATORY,
C * CARNEGIE INSTITUTION C OF WASHINGTON. ADAPTED FOR PLATON 2015
C ******************************************************************
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE strain1
      USE strain2
      IMPLICIT NONE
      INTEGER                            :: I
      INTEGER                            :: J
      INTEGER                            :: K
      INTEGER                            :: LU
      INTEGER                            :: MODE
      INTEGER                            :: MORT
      INTEGER                            :: MORTH
      INTEGER                            :: ITEMP
      REAL                               :: EX
      REAL                               :: PX
      REAL                               :: PY
      REAL                               :: RHO
      REAL                               :: PHI
      REAL                               :: RAD
      REAL                               :: DET
      REAL                               :: DTEM
      REAL                               :: TEMP
      REAL                               :: TEMP1
      REAL,              DIMENSION(3, 3) :: E
      REAL,              DIMENSION(3)    :: AN
      REAL,              DIMENSION(3, 3) :: EVC
      REAL,              DIMENSION(3, 3) :: DUM
      REAL,              DIMENSION(3)    :: EVL
      REAL,              DIMENSION(3, 3) :: YUNK
      CHARACTER(len=*)                   :: JID
      CHARACTER(len=1)                   :: IZ
      CHARACTER(len=2),  DIMENSION(6)    :: IAX
      CHARACTER(len=80)                  :: LINE
      CHARACTER(len=70)                  :: TXT1
      CHARACTER(len=70)                  :: TXT2
      CHARACTER(len=54), DIMENSION(2)    :: TXT3
      IAX = (/ '+X', '+Y', '+Z', '+A', '+B', '+C'/)
      TXT1 = 'Axis      Strain  Unit Strain (* 1000000)   Angle With'
      TXT2 =
     1'                                     +A         +B         +C'
      TXT3(1) =
     1 'x//a, z//c*, y//z^x (Dunitz p236)'
      TXT3(2) =
     1 'z//c, x//a*, y//z^x (Hazen & Finger, Comp.Cryst.Chem.)'
      PAGET = 'STRAIN'
      RAD   = RGBL(6)
C * MORT = 1 - DUNITZ STYLE ORTHOGONALIZATION
C *      = 2 - HAZEN & FINGER STYLE ORTHOGONALISATION
      MORTH = - IABS(MORT)
      DO MODE = 1, 2
        IF (MODE == 1) THEN
          LU = LU6
        ELSE
          LU = LU7
          CALL PLA262 (0)
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA110 (HORS, VERT, -1)
          CALL GGIP (0.0, 0.0, 0.0, 6)
          BCD = 'Strain Analysis'//CHAR (0)
          CALL PLA439 (0.0,  BCD, 15, 1.4, 4, 8, 4.0, VERT - 1.8)
          CALL PLA439 (0.0,  BCD, 15, 1.4, 2, 8, 3.8, VERT - 1.9)
        END IF
C * WRITE JOB-NAME
        WRITE (LU, 99999, IOSTAT = IOST) JID, TXT3(MORT)
C * WRITE CELL PARAMETERS (+ CELLSU) AND TEMPERATURES
        DO K = 1, 2
          WRITE (LINE, 99998, IOSTAT = IOST)
     1      NINT (TEMPAB(K)), (CELAB(K, I), I = 1, 6)
          WRITE (LU, 99983, IOSTAT = IOST) LINE(1:78)
          IF (MODE == 2) THEN
            IF (K == 1) THEN
              VRT = VERT - 3.0
              CALL PLA439 (0.0, 'Cell Parameters - Orth: '//TXT3(MORT),
     1                     78, 0.37, 5 + IGBL(68), 2, 1.0, VRT)
            END IF
            VRT = VRT - 1.0
            CALL PLA439 (0.0, LINE, 78, 0.3, 1, 2, 1.0, VRT)
          END IF
          IF (ICV(K) == 1) THEN
            WRITE (LINE, 99986, IOSTAT = IOST) (VCAB(K, J), J = 1, 6)
            WRITE (LU, 99983, IOSTAT = IOST) LINE(1:78)
            IF (MODE == 2) THEN
              VRT = VRT - 1.0
              CALL PLA439 (0.0, LINE, 78, 0.3, 1, 2, 1.0, VRT)
            END IF
          END IF
        END DO
        DO I = 1, 3
          C(I)     = CELAB(1, I)
          C(I + 3) = COS (CELAB(1, I + 3) / RAD)
          C(I + 6) = CELAB(2, I)
          C(I + 9) = COS (CELAB(2, I + 3) / RAD)
        END DO
        DO I = 1, 2
          IF (ICV(I) == 1) THEN
            DO J = 1, 3
              VC(I, J + 3) = (VCAB(I, J + 3) / RAD)**2
              VC(I, J)     = VCAB(I, J)**2
            END DO
          END IF
        END DO
        DTEM = TEMPAB(2) - TEMPAB(1)
C * INVERSE ORTHOGONALISATION MATRIX FOR FIRST CELL
        CALL GEN044 (C(1), DC, MORTH)
C * TRANSPOSE DC => Q
        CALL GEN005 (DC, Q)
C * INVERT
        CALL GEN003 (Q, QI, DET, 0)
C * ORTHOGONALISATION MATRIX FOR SECOND CELL
        CALL GEN044 (C(7), Q, MORTH)
C * TRANSPOSE MATRIX
        CALL GEN005 (Q, YUNK)
C * COPY MATRIX
        CALL GEN052 (YUNK, Q)
C * E =  QI * Q
        CALL GEN004 (QI, Q, E)
C * ASYMMETRIC STRAIN TENSOR: E = QI * Q - I
        DO I = 1, 3
          E(I, I) = E(I, I) - 1.0
        END DO
        WRITE (LU, 99981, IOSTAT = IOST)
     1    NINT (TEMPAB(1)), NINT (TEMPAB(2)), ((DC(I, J), J = 1, 3),
     2    (Q(J, I),  J = 1, 3), (E(I, J) * 1.0E+6, J = 1, 3), I = 1, 3)
        DO I = 1, 3
          DO J = 1, 3
            DC(I, J) = DC(I, J) / C(J)
          END DO
        END DO
C * SYMMETRIC STRAIN TENSOR Epsilon
        DO I = 1, 3
          DO J = I, 3
            E(I, J) = 0.5 * (E(I, J) + E(J, I))
            E(J, I) = E(I, J)
          END DO
        END DO
C * Write angles between XYZ and ABC systems & (Unit)Strain Tensor
        DO K = 1, 2
          IF (K == 1) THEN
            WRITE (LU, 99992, IOSTAT = IOST) '     '
          ELSE
            WRITE (LU, 99992, IOSTAT = IOST) 'Unit '
          END IF
          WRITE (LU, 99982, IOSTAT = IOST)
          DO I = 1, 3
            DO J = 1, 3
              AN(J) = RAD * ACOS (DC(I, J))
            END DO
            IF (K == 1) THEN
              WRITE (LU, 99991, IOSTAT = IOST)
     1          IAX(I), AN, (E(I, J) * 1.0E+6, J = 1, 3)
            ELSE
              WRITE (LU, 99980, IOSTAT = IOST)
     1        IAX(I), AN, (E(I, J) * 1.0E+6 / DTEM, J = 1, 3)
            END IF
          END DO
        END DO
C * EIGEN VECTOR/VALUE
        CALL GEN024 (E, EVC, EVL, DUM)
        WRITE (LU, 99993, IOSTAT = IOST)
        DO I = 1, 3
          DO J = 1, 3
            AN(J) = RAD * ACOS (EVC(I, J))
          END DO
C * RHO-PHI AND PROJECTION COORDINATES
          RHO = AN(3)
          PHI = ATAN2 (EVC(I, 2), EVC(I, 1))
          IF (EVC(I, 3) < 0.0) THEN
            IZ   = '-'
            TEMP = TAN ((180.0 - RHO) / (2.0 * RAD)) * 100.0
          ELSE
            IZ   = '+'
            TEMP = TAN (RHO / (2.0 * RAD)) * 100.0
          END IF
          PX  = TEMP * COS (PHI)
          PY  = TEMP * SIN (PHI)
          PHI = PHI  * RAD
          EX  = EVL(I) / DTEM
          WRITE (LU, 99996, IOSTAT = IOST)
     1      I, EVL(I) * 1.0E+6, EX * 1.0E+6, AN, RHO, PHI, PX, PY, IZ
        END DO
C * CALCULATE DIRECTIONS OF A,B,C AXES WITH RESPECT TO X,Y,Z AXES
        WRITE (LU, 99988, IOSTAT = IOST)
        DO K = 1, 3
          DO J = 1, 3
            AN(J) = ACOS (DC(J, K)) * RAD
          END DO
          RHO = AN(3)
          IF (ABS (DC(2, K)) < 0.0000001 .AND.
     1        ABS (DC(1, K)) < 0.0000001) THEN
            PHI = ATAN2 (DC(2, K), DC(1, K))
          ELSE
            PHI = 0.0
          END IF
          IF (DC(3, K) < 0.0) THEN
            IZ   = '-'
            TEMP = TAN ((180.0 - RHO) / (2.0 * RAD)) * 100.0
          ELSE
            IZ   = '+'
            TEMP = TAN (RHO / (2.0 * RAD)) * 100.0
          END IF
          PX  = TEMP * COS (PHI)
          PY  = TEMP * SIN (PHI)
          PHI = PHI * RAD
          WRITE (LU, 99990, IOSTAT = IOST)
     1      IAX(3 + K), AN, RHO, PHI, PX, PY, IZ
        END DO
C * RESULT ANALYSIS
        IF (MODE == 2) CALL PLA262 (0)
        WRITE (LU, 99994, IOSTAT = IOST) TXT1, TXT2
        IF (MODE == 2) THEN
          VRT = VRT - 2.0
          CALL PLA439 (0.0, TXT1, 70, 0.3, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 1.0
          CALL PLA439 (0.0, TXT2, 70, 0.3, 5 + IGBL(68), 2, 1.0, VRT)
        END IF
        DO I = 1, 3
          DO J = 1, 3
            TEMP = 0.0
            DO K = 1, 3
              TEMP = TEMP + EVC(I, K) * DC(K, J)
            END DO
            FO(3 * J + I) = ACOS (TEMP)
          END DO
          FO(I) = EVL(I)
        END DO
        TEMP   = EVL(1) + EVL(2) + EVL(3)
        FO(13) = TEMP
        ITEMP  = ICV(1) + ICV(2)
C * GET SU'S
        IF (ITEMP /= 0) CALL PLA285 (MORTH)
        DO I = 1, 3
          DO J = 1, 3
            AN(J) = RAD * FO(3 * J + I)
          END DO
          TEMP  = EVL(I) / DTEM
          TEMP1 = S(I)   / DTEM
          WRITE (LINE, 99995, IOSTAT = IOST)
     1      I, EVL(I) * 1.0E+6, TEMP * 1.0E+6, (AN(J), J = 1, 3)
          WRITE (LU, 99983, IOSTAT = IOST) LINE
          IF (MODE == 2) THEN
            VRT = VRT - 1.0
            CALL PLA439 (0.0, LINE, 78, 0.3, 1, 2, 1.0, VRT)
          END IF
          IF (ITEMP /= 0) THEN
            WRITE (LINE, 99997, IOSTAT = IOST)
     1        S(I) * 1.0E+6, TEMP1 * 1.0E+6, (S(3 * J + I), J = 1, 3)
            WRITE (LU, 99983, IOSTAT = IOST) LINE
            IF (MODE == 2) THEN
              VRT = VRT - 1.0
              CALL PLA439 (0.0, LINE, 78, 0.3, 1, 2, 1.0, VRT)
            END IF
          END IF
        END DO
        TEMP  = FO(13) / DTEM
        TEMP1 = S(13)  / DTEM
        WRITE (LU, 99987, IOSTAT = IOST)
     1   FO(13) * 1.0E+6, S(13) * 1.0E+6, TEMP * 1.0E+6, TEMP1 * 1.0E+6
C * LIST EXPLANATION
        IF (MODE == 2) THEN
          IF (MORT == 1) THEN
            CALL PLA262 (0)
            WRITE (LU, 99985, IOSTAT = IOST)
          END IF
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
        END IF
      END DO
      RETURN
99999 FORMAT ('Titl: ', A, /, 'Cell Parameters - Orth: ', A, /,
     1  78('='))
99998 FORMAT ('At', I6, 'C:', 6(F11.5))
99997 FORMAT (6X, '(', F9.2, ')  (', F9.4, ')',
     1        3(4X, '(', F5.2, ')'))
99996 FORMAT (2X, I1, F13.2, F11.4, 3F6.1, 2X, F5.1,
     1        F7.1, 2F7.1, 4X, A)
99995 FORMAT (2X, I1, F13.2, F13.4, 3(F11.2))
99994 FORMAT (/, A, /, 78('='), /, A)
99993 FORMAT (/, 'Strain Ellipsoid (Strain values multiplied by 10^6)',
     1 /, 51('='), /, 'Axis', 6X,
     1 'Strain', 2X, 'Unit Strain', 4X, 'Angle With', 6X,
     2 'Rho', 4X, 'Phi', 1X, 'Proj.X Proj.Y Hemi', /, 78('='), /,
     3 31X, '+X', 4X, '+Y', 4X, '+Z')
99992 FORMAT (/, 'Angles Between XYZ and ABC Systems', 5X, A,
     1           'Strain Tensor * 10^6 Based on XYZ')
99991 FORMAT (A, 1X, 3F9.2, 10X, '(', 3F9.2, ')')
99990 FORMAT (A, '-Axis', 20X, 3F6.1, F7.1, F7.1, 2F7.1, 4X, A)
99988 FORMAT (/, 'Crystallographic Axes', /, 78('='))
99987 FORMAT (/, 'Volume * 1000000', 1X, F10.2, '(', F10.2, ')', /,
     1            '(Unit Vol)', 7X, F10.4, '(', F10.4, ')', /)
99986 FORMAT (11X, 6(2X, '(', F7.5, ')'))
99985 FORMAT ('Explanation of the Printout', //, 'See:', /,
     1'Y.Ohashi & C.W. Burnham (1973). Amer. Mineralogist, 58, 843-849'/
     2'R.M. Hazen & L.W. Finger (1982). Comparative Crystal Chemistry,'/
     3'Wiley & Sons, Chapter #5.', /,
     4'**************************************************************'//
     5'1. ABC and XYZ coordinate systems:', /,
     6'   Direction of principle axis of strain ellipsoid is given in',/
     7'   terms of two coordinate systems. A,B and C are the', /
     8'   crystallographic axes and can be oblique. X,Y and Z are', /,
     9'   orthogonal axes set up in the program. angular relations,', /,
     *'   between ABC and XYZ systems are printed.', //,
     1'2. Dimensions of strain and unit strain:', /,
     2'   Strain is dimensionless (change in length original length),',/
     3'   and unit strain is (strain per unit change of temperature', /,
     4'   or composition)', //,
     5'3. Polar coordinates and stereographic projection coordinates:',/
     6'   System XYZ is used for stereo projection axes with Z', /,
     7'   being the azimuthal axis.', /,
     8'   RHO is an azimuthal angle and PHI is a longitudinal angle,', /
     9'   Thus X(RHO=90, PHI=0), Y(RHO=90, PHI=90) and Z(RHO=0).', /,
     *'   Proj.X and Proj.Y are projected components on a stereo-', /,
     1'   graphic projection plane and scaled as RADIUS=100.', /,
     2'   + and - denote upper and lower hemispheres respectively.', //,
     3'   To obtain stereographic projection of principle axes and', /,
     4'   also of crystallographic axes, plot Proj.X and Proj.Y on', /,
     5'   graph paper and draw a circle with radius 100.')
99983 FORMAT (A)
99982 FORMAT (77('='), /, 9X, '+A', 7X, '+B', 7X, '+C')
99981 FORMAT (/, 'Orth.', I9, 'C', 19X, I4, 'C', 14X,
     1 'Asymmetric Tensor * 10^6', /, 78('='),
     2 3(/, '(', 3F7.3, ') (', 3F7.3, ')  (', 3F9.2, ')'))
99980 FORMAT (A, 1X, 3F9.2, 10X, '(', 3F9.4, ')')
      END SUBROUTINE PLA284
 
      SUBROUTINE PLA285 (MORTH)
C * STRAIN
      USE parameters
      USE strain1
      USE strain2
      IMPLICIT NONE
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: K
      INTEGER                 :: L
      INTEGER                 :: N
      INTEGER                 :: II
      INTEGER                 :: IJ
      INTEGER                 :: JJ
      INTEGER                 :: IP
      INTEGER                 :: LP
      INTEGER                 :: MORTH
      REAL                    :: RAD
      REAL                    :: DEL
      REAL                    :: DET
      REAL                    :: TEMP
      REAL, DIMENSION(13)     :: F
      REAL, DIMENSION(12, 13) :: D
      REAL, DIMENSION(3, 3)   :: A
      REAL, DIMENSION(3, 3)   :: B
      REAL, DIMENSION(3, 3)   :: R
      REAL, DIMENSION(3, 3)   :: E
      REAL, DIMENSION(3)      :: XX
      REAL, DIMENSION(3, 3)   :: VV
      REAL, DIMENSION(3, 3)   :: DUM
      REAL, DIMENSION(3, 3)   :: YUNK
      RAD   = RGBL(6)
C * DETERMINE DERIVATIVES OF EIGEN VALUES AND DIRECTION COSINES WITH RESPECT
C * TO CELL CONSTANTS
      DO I = 1, 2
        DO J = 1, 6
          IJ = (I - 1) * 6 + J
          IF (VC(I, J) <= 1.E-10) THEN
            DO K = 1, 13
              D(IJ, K) = 0.0
            END DO
          ELSE
            DEL = 0.1 * SQRT (VC(I, J))
            IF (J <= 3) THEN
              C(IJ) = C(IJ) + DEL
            ELSE
              C(IJ) = COS (ACOS (C(IJ)) + DEL)
            END IF
C * CHANGE OF QI OR Q MATRICES
            IF (I. EQ. 1) THEN
C * ORTHOGONALIZE
              CALL GEN044 (C(1), R, MORTH)
              CALL GEN005 (R, DUM)
C * INVERT
              CALL GEN003 (DUM, A, DET, 0)
              CALL GEN052 (Q, B)
              DO II = 1, 3
                DO JJ = 1, 3
                  R(II, JJ) = R(II, JJ) / C(JJ)
                END DO
              END DO
            ELSE
C * ORTHOGONALIZE
              CALL GEN044 (C(7), B, MORTH)
C * TRANSPOSE MATRIX
              CALL GEN005 (B, YUNK)
C * COPY MATRIX
              CALL GEN052 (YUNK, B)
              CALL GEN052 (QI, A)
              CALL GEN052 (DC, R)
            END IF
            CALL GEN004 (A, B, E)
            DO L = 1, 3
              E(L, L) = E(L, L) - 1.0
            END DO
            DO L = 1, 3
              DO N = L, 3
                E(L, N) = 0.5 * (E(L, N) + E(N, L))
                E(N, L) = E(L, N)
              END DO
            END DO
C * EIGENVECTOR/EIGENVALUE
            CALL GEN024 (E, VV, XX, DUM)
            DO L = 1, 3
              F(L) = XX(L)
              DO N = 1, 3
                TEMP = 0.0
                DO K = 1, 3
                  TEMP = TEMP + VV(L, K) * R(K, N)
                END DO
                F(3 * N + L) = ACOS (TEMP)
              END DO
            END DO
            F(13) = F(1) + F(2) + F(3)
            DO K = 1, 13
              D(IJ, K) = (F(K) - FO(K)) / DEL
            END DO
C * RESTORE TO ORIGINAL CELL PARAMETER VALUE
            IF (J <= 3) THEN
              C(IJ) = C(IJ) - DEL
            ELSE
              C(IJ) = COS (ACOS (C(IJ)) - DEL)
            END IF
          END IF
        END DO
      END DO
      CALL GEN074 (S, 1, 13, 0.0)
C * VARIANCE CALCULATION
      DO I = 1, 2
        L = 6 * (I - 1)
        IF (ICV(I) == 1) THEN
C * ZERO COVARIANCE CASE
          DO K = 1, 13
            TEMP = 0.0
            DO IP = 1, 6
              LP   = L + IP
              TEMP = TEMP + D(LP, K)**2 * VC(I, IP)
            END DO
            S(K) = S(K) + TEMP
          END DO
C * NON-ZERO COVARIANCE CASE
        END IF
      END DO
      DO K = 1, 3
        S(K) = SQRT (S(K))
      END DO
      DO K = 4, 12
        S(K) = RAD * SQRT (S(K))
      END DO
      S(13) = SQRT (S(13))
      RETURN
      END SUBROUTINE PLA285
 
      SUBROUTINE PLA286 (MODE)
C * RESET INPUT FOR THIS ENTRY
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER :: MODE
      WRITE (LU6, 99999) MODE
C * DELETE THE COPIES OF THE EMBEDDED FILES
      IF (IPR(663) /= 0) THEN
        CLOSE (LU24, STATUS = 'DELETE', IOSTAT = IOST)
        IPR(663) = 0
      END IF
      IF (IPR(664) /= 0 .OR. IPR(321) /= 0) THEN
        CLOSE (LU25, STATUS = 'DELETE', IOSTAT = IOST)
        IPR(664) = 0
      END IF
      IF (IPR(665) /= 0) THEN
        CLOSE (LU26, STATUS = 'DELETE', IOSTAT = IOST)
        IPR(665) = 0
      END IF
C * CHECK FOR SPF OR CIF FILE
      IF (IABS (IGBL(8)) == 1 .OR. IABS (IGBL(8)) == 3) THEN
        IPR(220) = 0
        IPR(221) = 1
        FN(1)    = IGBL(54)
C * SEARCH AND LOAD ENTRY
        CALL PLA007
        IGBL(24) = 0
        CALL PLA280 ('END')
        IF (MODE /= 0) IGBL(1) = 1
      ELSE
        IGBL(54) = 0
        CALL PLA280 ('RESTART')
        IF (MODE /= 0) IGBL(1) = 2
      END IF
C * REWIND CHECK-SCRATCH FILE
      IF (MODE == 0) THEN
        CALL GEN108 (LU20, 0)
        IGBL(31) = 0
      END IF
      RETURN
99999 FORMAT (/, ':: Reset Input, Mode =', I3)
      END SUBROUTINE PLA286
 
      SUBROUTINE PLA287 (MODE1, MODE2, MODE3)
      USE parameters
      IMPLICIT NONE
      INTEGER :: MODE1
      INTEGER :: MODE2
      INTEGER :: MODE3
C * SETUP CONNECTED SET
      CALL PLA067
      IF (IPR(2) == 0) THEN
C * OUTPUT COORDINATES AND CONNECTION TABLES
        IF (MODE2 /= 0) CALL PLA073 (-1, 1)
C * LIST ANISOTROPIC PARAMETERS
        IF (IPR(85) == 0) THEN
          CALL PLA024
        END IF
C * LOAD & EXPAND COORDINATE DATA
        IF (MODE1 /= 0) CALL PLA023 (MODE3)
      END IF
      RETURN
      END SUBROUTINE PLA287
 
      SUBROUTINE PLA288 (MODE)
C * DEFINE BOND
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: IP
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: NCG
      INTEGER :: NFN
      INTEGER :: IENM
      INTEGER :: ICGA
      INTEGER :: MODE
      INTEGER :: NIEN
      INTEGER :: INQNR
      INTEGER :: JNQNR
      REAL    :: DASH
      DASH = 1.0
      NCG  = 0
      NFN  = 0
C * DEFINE BOND
      DO I = 2, IPR(220)
        IF (IFL(I) == 'DASH') THEN
          DASH = -1.0
        ELSE IF (IFL(I) == 'NODASH') THEN
          DASH = 2.0
        ELSE IF (IFL(I) == 'LDASH') THEN
          DASH = -2.0
        ELSE IF (IFL(I) == 'TO') THEN
          NCG  = 1
          IPR(64) = IPR(64) + 1
          ICGA = IPR(39) + IPR(64)
          DO J = 1, 6
            XXO(ICGA, J) = 0.0
            XSD(ICGA, J) = 0.0
          END DO
        ELSE
C * LOOK IN EXPANDED + CG ATOM LIST
          CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD,
     1                 INQNR, JNQNR, NIEN)
          IF (NIEN < 0) THEN
            CALL PLA015 (0, 28)
            RETURN
          END IF
          NFN       = NFN + 1
          IATC(NFN) = NIEN
        END IF
      END DO
      DO J = 2, NFN
        CALL PLA268 (IATC(1), IATC(J), MODE, DASH)
        IF (NCG == 1) THEN
          DO K = 1, 6
            XXO(ICGA, K) =  XXO(ICGA, K) + XXO(IATC(J), K)
            XSD(ICGA, K) =  XSD(ICGA, K) + XSD(IATC(J), K)
          END DO
        END IF
      END DO
      IF (NCG == 1) THEN
        DO K = 1, 3
          IFG(K, ICGA) = IFG(K, IATC(2))
        END DO
C * GENERATE NEW LABEL CGnm
        CALL GEN040 (IPR(64), NQ2, IP)
        NQ1           = 'CG'
        NQ1(3:2 + IP) = NQ2(1:IP)
        CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD,
     1               INQNR, JNQNR, NIEN)
        LABA(ICGA) = INQNR
C * STORE COORDINATES (ALSO IN BACKING STORE)
        DO K = 1, 6
          XXO(ICGA, K) = XXO(ICGA, K) / (NFN - 1)
          XSD(ICGA, K) = XSD(ICGA, K) / ((NFN - 1)**2)
          VOID((IPR(39) + IPR(64) - 1) * NP71 + K) =
     1              XXO(ICGA, K)
          VOID((IPR(39) + IPR(64) - 1) * NP71 + K + 6) =
     1              XSD(ICGA, K)
        END DO
        WRITE (LU6, 99999, IOSTAT = IOST)
     1    NQ1(1:7), (XXO(ICGA, K), K = 1, 6),
     2    (SQRT (XSD(ICGA, K)), K = 1, 6)
        WRITE (LU7, 99999, IOSTAT = IOST)
     1    NQ1(1:7), (XXO(ICGA, K), K = 1, 6),
     2    (SQRT (XSD(ICGA, K)), K = 1, 6)
        CALL PLA268 (IATC(1), ICGA, 1, -1.0)
      END IF
      RETURN
99999 FORMAT (/, ':: ', A, 6F10.5, /, 10X, 6F10.5)
      END SUBROUTINE PLA288
 
      SUBROUTINE PLA289 (X, Y, R, N)
C * PLOT CIRCLE
      USE parameters
      USE cggt
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: N
      REAL    :: X
      REAL    :: Y
      REAL    :: R
      REAL    :: RT0
      RT0 = RGBL(5) / N
      CALL GGIP (X + R, Y, 0.0, 3)
      DO I = 1, N
        XGGIP = X + R * COS (I * RT0)
        YGGIP = Y + R * SIN (I * RT0)
        CALL GGIP (XGGIP, YGGIP, 0.0, 2)
      END DO
      CALL GGIP (0.0, 0.0, 0.0, 3)
      RETURN
      END SUBROUTINE PLA289
 
 
      SUBROUTINE PLA292
C * FILE OPEN ON UNIT LU2
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      CHARACTER(len=80) :: FNLU2
      CHARACTER(len=80) :: FILEN
C * IGBL(31) =  -3 :  _sx.ins
C *             -2 :  _pl.res
C *             -1 :  _pl.res
C *              1 :     .ome
C *              3 :  _pl.spf
C *              4 :     .que
C *              5 :     .par
C *              6 :     .res
C *              7 :  _pl.pdb
C *              8 : -acc.cif
C *             10 : _sqd.sqz or _sq.sqz
C *             11 :     .dif
      IF (IGBL(31) /= IPR(437)) THEN
        SELECT CASE (IGBL(31))
          CASE (-3)
            FNLU2 = NAMEFIL(1:KNMFIL)//'_sx.ins'
            INQUIRE (UNIT = LU24, OPENED = OPEND)
            IF (OPEND) CLOSE (UNIT = LU24)
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (-2)
            INQUIRE (UNIT = LU2, OPENED = OPEND)
            IF (OPEND) CLOSE (UNIT = LU2)
            INQUIRE (UNIT = LU21, OPENED = OPEND)
            IF (OPEND) CLOSE (UNIT = LU21)
            FNLU2 = NAMEFIL(1:KNMFIL)//'_pl.res'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (-1)
            FNLU2 = NAMEFIL(1:KNMFIL)//'_pl.res'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (1)
            IPR(438) = 1
            FNLU2 = NAMEFIL(1:KNMFIL)//'.ome'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (3)
            IF (IPR(777) /= 1) THEN
              FNLU2   = NAMEFIL(1:KNMFIL)//'_pl.spf'
              WRITE (LU6, 99998) FNLU2
              IGBL(2) = IGBL(2) + 1
              INQUIRE (UNIT = LU2, OPENED = OPEND)
C * WORK-AROUND FOR THE SALFORD-COMPILER
              FILEN = ' '
              IF (OPEND) THEN
                INQUIRE (UNIT = LU2, NAME = FILEN)
              END IF
              IF (OPEND .AND. FILEN /= 'UNDEFINED') THEN
                WRITE (LU2, 99999, IOSTAT = IOST)
              ELSE
                OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
              END IF
            END IF
          CASE (4)
            FNLU2 = NAMEFIL(1:KNMFIL)//'.que'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (5)
            FNLU2 = NAMEFIL(1:KNMFIL)//'.par'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (6)
            FNLU2 = NAMEFIL(1:KNMFIL)//'.res'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (7)
            FNLU2 = NAMEFIL(1:KNMFIL)//'_pl.pdb'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (8)
            FNLU2 = NAMEFIL(1:KNMFIL)//'_acc.cif'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
            IPR(438) = 1
C * OPEN DIFFERENCE MAP PEAK LIST
          CASE (10)
            IF (IPR(663) == 0) THEN
              FNLU2 = NAMEFIL(1:KNMFIL)//'_sqd.sqz'
            ELSE
              FNLU2 = NAMEFIL(1:KNMFIL)//'_sq.sqz'
            END IF
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          CASE (11)
            FNLU2 = NAMEFIL(1:KNMFIL)//'.dif'
            OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        END SELECT
        IPR(437) = IGBL(31)
        IF (IGBL(2) <= 1) THEN
           REWIND (UNIT = LU2, IOSTAT = IOST)
           IF (IOST /= 0) CALL GEN148 (LU2, 1)
        END IF
C * WRITE ENDS
      ELSE
        WRITE (LU2, 99999, IOSTAT = IOST)
      END IF
      RETURN
99999 FORMAT ('ENDS')
99998 FORMAT (/, ':: Create ', A)
      END SUBROUTINE PLA292
 
      SUBROUTINE PLA293 (WAVEL)
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      REAL    :: WL
      REAL    :: WAVEL
C * CHECK WAVELENGTH
      WL = WAVEL
C * ASSUME ELECTRON DIFFRACTION
      IF (WL > 0.0 .AND. WL <= 0.1) THEN
        IPR(493) = 8
        IPR(671) = 8
        IPR(630) = 2
      END IF
C * DEFAULT MOKa RADIATION
      IF (WL <= 0.0 .AND. IPR(493) < 7) THEN
        WL       = STWL(3)
        IPR(493) = -3
        KRAD     = CSTWL(3)
      ELSE
        IF (IABS (IPR(493)) == 8) THEN
          KRAD = 'elec'
        ELSE IF (IABS (IPR(493)) == 7) THEN
          KRAD = 'neut'
C * DEFAULT SYNCHROTRON RADIATION
        ELSE IF (IPR(493) == 0) THEN
          IPR(493) = 6
          KRAD     = 'sync'
        ELSE
C * TEST FOR InKa, AgKa, MoKa, GaKa or CuKa
          DO I = 1, 5
            IF (ABS (WL - STWL(6 - I)) < PAR(63)) THEN
              IPR(493) = I
              KRAD     = CSTWL(6 - I)
              EXIT
            END IF
          END DO
        END IF
      END IF
      PAR(17) = WL
      IF (PAR(168) > 0.0) THEN
        PAR(287) = SIN (PAR(168) / RGBL(6)) / PAR(17)
      END IF
      RETURN
      END SUBROUTINE PLA293
 
      SUBROUTINE PLA294 (MODE)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: NE
      INTEGER :: IOK
      INTEGER :: NENT
      INTEGER :: NRES
      INTEGER :: MODE
      INTEGER :: FINDEXE
      IGBL(70) = 0
      IF (MODE == 1) THEN
        IF (SPGRNM(1)(13:13) /= ' ') THEN
          CLOSE (UNIT = LU2, IOSTAT = IOST)
          IGBL(31) = 4
          IPR(437) = 0
C * FILE OPEN #2
          CALL PLA292
          LINE = ' '
          WRITE (IDM, 99998, IOSTAT = IOST) (PAR(122 + I), I = 1, 6),
     1    PAR(28)
C * REMOVE MULTIPLE SEPARATING SPACES
          J = 14
          LINE(1:14) = IDM(1:14)
          DO I = 15, 68
            IF (LINE(J:J) /= ' ') THEN
              J = J + 1
              LINE(J:J) = IDM(I:I)
            ELSE IF (IDM(I:I) /= ' ') THEN
              J = J + 1
              LINE(J:J) = IDM(I:I)
            END IF
          END DO
          WRITE (LU2, 99995) LINE
          WRITE (LU2, 99999, IOSTAT = IOST)
        ELSE
          BCD = 'No SPGR info Given ...'//CHAR (0)
          CALL GGIP (-999.0, 2.0, 30.0, 111)
          RETURN
        END IF
      ELSE
        WRITE (LU2, 99997, ADVANCE = 'NO', IOSTAT = IOST)
C * GET NUMBER OF RESIDUES
        NRES = IPR(75)
        IF (NRES > 1) THEN
          DO I = 2, NRES
            IF (RCONT(I) >= IPR(735)) THEN
              WRITE (LU2, 99996, ADVANCE = 'NO', IOSTAT = IOST) I
            END IF
          END DO
        END IF
        WRITE (LU2, 99993, IOSTAT = IOST)
      END IF
      CLOSE (UNIT = LU2, IOSTAT = IOST)
C * FIND CONQUEST (cqbatch)
      CALL GEN038 (CGETENV, 1, 80)
      NE = FINDEXE ('QUESTEXE', CGETENV, 'cqbatch')
      IF (NE > 0) THEN
        CGETENV(NE + 1:) =
     1' -j cqbatch -rerun '//NAMEFIL(1:KNMFIL)//'.que'//' -export cif'
        KERR = 0
        CALL SPAWN (CGETENV, LU6, .true., KERR)
        NENT = 0
        OPEN (LU61, FILE = 'cqbatch.cif', STATUS = 'UNKNOWN',
     1        IOSTAT = IOK)
        IF (IOK == 0) THEN
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_cq.cif',
     1              STATUS = 'UNKNOWN')
          DO
            READ (LU61, 99995, IOSTAT = IOST) LINE
            IF (IOST /= 0) EXIT
            WRITE (LU62, 99995, IOSTAT = IOST) LINE
            IF (LINE(1:12) == 'data_CSD_CIF') NENT = NENT + 1
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          CLOSE (UNIT = LU62)
          BCD = 'Number of Hits =      '//CHAR (0)
          WRITE (BCD(17:21), 99994, IOSTAT = IOST) NENT
          CALL GGIP (-999.0, 2.0, 30.0, 111)
          IF (IGBL(80) * NENT > 0) THEN
            KERR = 0
            CALL SPAWN
     1      (PLAPATH(1:IGBL(80))//' -a '//NAMEFIL(1:KNMFIL)//'_cq.cif',
     2        LU6, .true., KERR)
          END IF
          OPEN (UNIT = LU61, FILE = 'cqbatch.cqs', STATUS = 'UNKNOWN',
     1      IOSTAT = IOST)
          IF (IOST == 0) CLOSE (LU61, STATUS = 'DELETE')
          OPEN (UNIT = LU61, FILE = NAMEFIL(1:KNMFIL)//'_cq.eld',
     1      IOSTAT = IOST)
          IF (IOST == 0) CLOSE (LU61, STATUS = 'DELETE')
          OPEN (UNIT = LU61, FILE = NAMEFIL(1:KNMFIL)//'_cq.lis',
     1      IOSTAT = IOST)
          IF (IOST == 0) CLOSE (LU61, STATUS = 'DELETE')
        END IF
      ELSE
        CALL PLA015 (0, 9)
      END IF
      RETURN
99999 FORMAT ('QUESTION T1')
99998 FORMAT ('T1 *PCELL TRIC', 3F9.3, 3F7.2, F6.3)
99997 FORMAT ('QUESTION T1')
99996 FORMAT (' .OR. T', I1)
99995 FORMAT (A)
99994 FORMAT (I5)
99993 FORMAT (1X)
      END SUBROUTINE PLA294
 
      SUBROUTINE PLA295
C * MANAGE MOL-LIST FOR ORTEP
      USE files
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: KN
      INTEGER :: NS
      INTEGER :: MLS
      INTEGER :: NMOL
      KN   = IPR(221)
      NMOL = IPR(53)
      IF (KN > 0) THEN
        DO 10 I = 1, KN
          NS = INT (ABS (FN(I)) / 1000.0)
          IF (NS <= IPR(48)) THEN
            MLS = NINT (FN(I) * PAR(42))
            IF (NINT (FN(I)) * NINT (PAR(42)) == MLS) THEN
              IF (MLS > 0) THEN
                MLS = MLS + 1
              ELSE
                MLS = MLS - 1
              END IF
            END IF
C * SKIP/DELETE ARU
            IF (NMOL > 0) THEN
              DO J = 1, NMOL
                IF (IABS (MLS) == MOLS(J)) THEN
                  IF (MLS > 0) THEN
                    GO TO 10
                  ELSE
                    IF (J . LT. NMOL) THEN
                      DO K = J + 1, NMOL
                        MOLS(K - 1) = MOLS(K)
                      END DO
                    END IF
                    NMOL = NMOL - 1
                    GO TO 10
                  END IF
                END IF
              END DO
            END IF
C * ADD ARU
            NMOL       = NMOL + 1
            MOLS(NMOL) = MLS
          END IF
   10   CONTINUE
      END IF
      IPR(53) = NMOL
      DO I = 1, IPR(53)
        MOL(I) = MOLS(I)
      END DO
      IPR(13) = IPR(53)
      IF (IPR(17) /= 0) THEN
        IPR(17) = 0
C * SET FLAGS ETC
        CALL PLA087
      END IF
      IPR(39) = IPR(37)
C * GENERATE ATOMS FOR SYMMETRY RELATED UNIT
      CALL PLA072 (-1)
C * OUTPUT CONNECTED SET
      CALL PLA024
C * SYMMETRY CODE LISTING
      CALL PLA043 (0, -2, LU6, 0)
C * REPOSITION LABELS
      IPR(201) = 0
C * RESET # OF CENTROIDS
      IPR(64)  = 0
      RETURN
      END SUBROUTINE PLA295
 
      SUBROUTINE PLA296 (LU, LINE)
      USE xwdw
      IMPLICIT NONE
      INTEGER          :: LU
      INTEGER          :: IOST
      CHARACTER(len=*) :: LINE
      IF (LU /= 0) THEN
        WRITE (LU, 99999, IOSTAT = IOST) LINE
      ELSE
        VRT = VRT - 0.5
        CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA296
 
      SUBROUTINE PLA297 (MODE)
      USE parameters
      USE cggt
      IMPLICIT NONE
      INTEGER :: MODE
C * WHAT NEXT ?
      CALL PLA012 (2, 5)
      IF (IPR(736) == 1) THEN
        CALL PLA280 ('RESET')
      ELSE
        IF (IGGT(1:4) == 'PLOT') THEN
          IF (MODE == 2) IGGT(1:4) = 'CALC'
        END IF
        IF (IGGT(1:4) /= 'CALC') CALL GEN038 (IGGT, 1, 80)
        IF (MODE == 1) THEN
          IF (IGBL(6) == 10) THEN
            CALL PLA280 ('!')
          ELSE
            CALL PLA280 ('PLOT')
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA297
 
      MODULE man
      SAVE
      CHARACTER(len=29), DIMENSION(131) :: MANUAL = (/
     1 'NOMOVE (OFF (x, y,z [0 0 0]))', 'CALC (ALL)                   ',
     2 'END                          ', 'STOP                         ',
     3 'QUIT                         ', 'EXIT                         ',
     4 'ROUND ON/OFF (range)         ', 'PARENTHESES ON/OFF           ',
     5 'INCLUDE el1 (el2 .. )        ', 'EXCLUDE el1 (el2 .. )        ',
     6 'INCLUDE METALS               ', 'EXCLUDE METALS               ',
     7 'DOAC el1 (el2 ..)            ', 'HBOND  (NORM) p1 p2 p3       ',
     8 'GEOM at1                     ', 'RING at1 at2 at3 (at4 ..)    ',
     9 'LINE at1 at2                 ', 'FIT at11 at21 .. at1n at2n   ',
     * 'INORG                        ', 'ORGA                         ',
     1 'ORMA r11 r12 r13 .. r32 r33  ', 'CALC INTRA                   ',
     2 '     el1 p1 el2 p2 ..        ', '     (A/U/E)WLSPL            ',
     3 '     TOLA  p1                ', '     TOLEA p1                ',
     4 '     TOLM  p1                ', '     NOTMA                   ',
     5 '     NOBOND                  ', '     NOANG                   ',
     6 '     NOTOR                   ', '     NOLSP                   ',
     7 '     NORING                  ', '     MAXRING P1              ',
     8 '     NOSTD                   ', '     NOMOVE                  ',
     9 '     NOSYMM                  ', '     TOLP p1                 ',
     * '     MAXDEV p1               ', '     NOSORT                  ',
     1 'CALC INTER (NOMOVE) TOLR p1  ', '     TOLR p1                 ',
     2 '     el1 p1 (el2 p2 ..)      ', 'CALC HBONDS (NONA) P1 P2 P3  ',
     3 'LIST RADII/CELL/SYMM         ', 'INFO RADII/CELL/SYMM         ',
     4 'LIST ATOMS/BONDS (attyp)(res)', 'INFO ATOMS/BONDS (attyp)(res)',
     5 'LIST UIJ                     ', 'INFO UIJ                     ',
     6 'LIST IPR/PAR/IGBL (nr1 (nr2))', 'INFO IPR/PAR/IGBL (nr1 (nr2))',
     7 'LIST FLAGS                   ', 'INFO FLAGS                   ',
     8 'LIST GRAPHICS                ', 'INFO GRAPHICS                ',
     9 'CALC GEOM (OMEGA/CSD/        ', '     SPF/SHELXL/PDB)         ',
     * '     (NOMOVE) (EXPAND)       ', '     (BOND) (ANGLE) (TORSION)',
     1 'CALC TMA (CART)(HINC)        ', '         (Rmax)              ',
     2 '         (Atmin)             ', 'SAVE                         ',
     3 'CALC ADDSYM (el/EQUAL)(SAVE) ', '     (ang d1 d2)             ',
     4 'CALC NONSYM                  ', 'CALC NEWSYM                  ',
     5 'LEPAGE                       ', 'EXPT                         ',
     6 'CALC COORDN (p1)             ', '     (FIVE (tba))            ',
     7 '     (el1 p1 el2 p2 ..)      ', '     (NOANG)                 ',
     8 'CALC COORDN at1 p1 (NOANG)   ', 'CALC METAL (p1)              ',
     9 'CALC DIST el (p1)            ', 'DIST at1 at2                 ',
     * 'ANGL at1 at2 at3 (at4)       ', 'TORS at1 at2 at3 at4         ',
     1 'LSPL at1 at2 at3 (at4 ..)    ', '     (DIST at3 ..)           ',
     2 'PLOT (RING/PLAN/LSPL/RESD)   ', '     (PERP/ALONG)            ',
     3 '     (DISPLAY/META)          ', 'PLOT ADP                     ',
     4 '     (COLOR)                 ', '     (ENVE/HETE/OCTA)        ',
     5 '     (HATOM/NOHATOM)         ', '     (LABEL/NOLABEL)         ',
     6 '     (PAREN/NOPAREn)         ', '     (MARGIN marg)           ',
     7 '     (RESIDUE resd)          ', '     (DISPLAY/META)          ',
     8 'PLOT NEWMAN (at1 at2)        ', '     (DISPLAY/META)(COLR)    ',
     9 'BOX (ON/OFF) (RATIO p1)      ', 'VIEW                         ',
     * 'VIEW (UNIT) XR p1 YR p2 ZR p3', 'VIEW MIN                     ',
     1 'VIEW INVERT                  ', 'SET PROB (10<-->90)          ',
     2 'SET IPR/PAR/IGBL/GL nr val   ', 'SET PRINTER LEVEL lev        ',
     3 'SET LABEL SIZE (size)        ', 'SET WINDOW fraction          ',
     4 'CALC SOLV                    ', '     (LIST)                  ',
     5 'CALC VOID (PROBE r) (PSTEP n)', '     (LIST)                  ',
     6 'CALC SQUEEZE (ncyc)          ', 'CALC FCF                     ',
     7 'ABSG mu (n1 n2 n3) (NOCHECK) ', 'ABST mu (NOCHECK)            ',
     8 'TABLE (SU/CIF/AC/JA/IC)      ', '     (NOHATOM)               ',
     9 '     (NORESIDUE)             ', 'JOIN  at1 at2 (DASH/LDASH)   ',
     * 'DETACH at1 at2               ', 'DEFINE at1 TO at2 ..aTn      ',
     1 '    (DASH/LDASH)             ', 'RADII BONDS (NORMAL bt r/    ',
     2 '     TO METAL bt r/          ', '     TO H bt r/              ',
     3 '     ALL bt r/LIST)          ', '                             ',
     4 'MENU (ON/OFF)                ', 'ELLIPSOID (C/H/Other)        ',
     5 '          type (lines)       ', 'CONTOUR (FO/DIFF/SQUEEZE)    ',
     6 '  HORIZ/abcd/BIS/PERP        '/)
      CHARACTER(len=62), DIMENSION(116)  :: PLUMAN = (/
     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)    ',
     9 'CROT(X/Y/Z)(M) (step (nstep)) (COLOR[off])                    ',
     * 'DEFINE Me# TO atom-name1 atom-name2 atom-name3 ...            ',
     1 'DEFINE TO/CG atom-name1 atom-name2 atom-name3 ...             ',
     2 'DELETE atom-type/atom-name .../aru                            ',
     3 'DETACH (atom-name/atom-type (TO) atom-name/atom-type)         ',
     4 'DIR                                                           ',
     5 'DIST atom-name1 atom-name2 (aru)                              ',
     6 'END/ENDS                                                      ',
     7 'ENTRY (nr/refcode)                                            ',
     8 'EXCLUDE atom-names/atom-types/ALL/NONE/ORIG/UNIQUE/           ',
     9 '  INTER/ZOMBIES/aru/resd                                      ',
     * 'GEOM atom-name                                                ',
     1 'INCLUDE atom-names/atom-types/ALL/NONE/ORIG/UNIQUE/           ',
     2 '  INTER/ZOMBIES/aru/resd                                      ',
     3 'INORG                                                         ',
     4 'JOIN RADII (UNIQUE (EXPAND) (NOMOVE)) (TOLE tole)             ',
     5 '  ((TOL tol)/(n1 r1 n2 r2 ...))                               ',
     6 'JOIN RADII INTER (HBONDS/XBONDS)(EXPAND)                      ',
     7 '  (TOL tol)/(n1 r1 n2 r2 ...)                                 ',
     8 'JOIN atom-name TO atom-name(s) (aru)                          ',
     9 'JOIN atom-names/atom-types                                    ',
     * 'JOIN (NONE/INTRA)                                             ',
     1 'LABEL atname1(aru) (atname2(aru)) (...) (attype3(aru)) (..)   ',
     2 'LABEL (ON/OFF)/ALL/NONE/(UNITCELL) (ATOMS) (ARU)              ',
     3 '  ((NO)PARENTHESES) (FULL/NUM)                                ',
     4 'LATT (P/A/B/C/I/F) (C/A)                                      ',
     5 'LIST (ATOMS)(BONDS)(GRAPHICS)(LINES)(MATR)(ARU)(STATUS)(TYPES)',
     6 'LIST ATOM (atom-name/atom-type/INTER)/(RESD nr)               ',
     7 'LIST BOND (atom-name1 atom-name2/INTER)/(RESD nr)             ',
     8 'LIST CELL/SYMM/FLAGS                                          ',
     9 'LIST PAR (nr1 (nr2))                                          ',
     * 'LIST IPR (nr1 (nr2))                                          ',
     1 'MONO (PERSP d)                                                ',
     2 'NOMOVE (OFF)                                                  ',
     3 'NOSORT                                                        ',
     4 'OMIT OUTSIDE (xmin xmax ymin ymax zmin zmax/atom-name rad/0)  ',
     5 'OMIT aru ...(resd)                                            ',
     6 'ORGA                                                          ',
     7 'OVERLAP (MARGIN mrg) (SHADOW shad)((ON/OFF)/BA/BB[ON])        ',
     8 'PACK PLAN h k l d1 d2 RANGE xmin .. zmax (atom-name)          ',
     9 'PACK (RANGE xmin xmax ymin ymax zmin zmax (atom-name))        ',
     * 'PLOT (DISPLAY/META) (LIST) (3/2)                              ',
     1 'PUT ARU/ATOM/atom-name/atom-type/OR/OA/OB/OC pos.             ',
     2 '(atom-name/atom-type/OR/OA/OB/OC position .. )                ',
     3 ' position: N, NE, E, SE, S, SW, W, NW, NUCL, AUTO             ',
     4 'QUIT/EXIT                                                     ',
     5 'RADII ATOMS COVALENT/CPK/AUTO/ALL r                           ',
     6 'RADII ATOMS atom-type1 r1 (atom-type2 r2 ... )                ',
     7 'RADII ATOMS atom-name1 r1 (atom-name2 r2 ... )                ',
     8 'RADII BONDS (DASH) ALL r n                                    ',
     9 'RADII BONDS (DASH) TO atom-name/atom-type r n                 ',
     * 'RADII BONDS (DASH) atom-name1 atom-name2 r n                  ',
     1 'RADII BONDS (DASH) INTER/NORMAL r n                           ',
     2 'RADII BONDS TAPER t                                           ',
     3 'RENAME (atom-name/atom-type)/(at1 at2 (at3 at4 ..))           ',
     4 'RESET                                                         ',
     5 'RETRACE LABELS ((n) (d))                                      ',
     6 'ROD   (NUCL/SHADE (a1 a2 (d))/                                ',
     7 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR/SEGMENT/              ',
     8 '  BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)            ',
     9 'SAVE (AUTO)                                                   ',
     * 'SEGMENT (plotstep (substep))                                  ',
     1 'SET (IPR/PAR) nr val                                          ',
     2 'SET WINDOW fraction                                           ',
     3 'SIZE sz (RATIO ra) (SCALE sc) (CHAR ch) (TITLE ti)            ',
     4 'SOLID (NUCL/SHADE (a1 a2 (d))/                                ',
     5 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/          ',
     6 '  BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)            ',
     7 'SPGR space-group-name                                         ',
     8 'STEREO (SMALL) (RG/GR/RB/BR/CROSSED) (PERSP d)                ',
     9 'STICK (COLOR)                                                 ',
     * 'STRAW (NUCL/SHADE (a1 a2 (d))/                                ',
     1 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/          ',
     2 'BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)              ',
     3 'STOP                                                          ',
     4 'SYMM symmetry-operator                                        ',
     5 'TITL text                                                     ',
     6 'TORSION atom-name1 atom-name2 atom-name3 atom-name4           ',
     7 'UNITCELL (OFF/ON) (rbo nli)                                   ',
     8 'UNLABEL (atom-names/atom-types/ALL/(UNITCELL) (ATOMS) (ARU)   ',
     9 'VIEW MATRIX r11,r12, .. ,r33 (rotations)                      ',
     * 'VIEW MIN (rotations)                                          ',
     1 'VIEW UNIT (rotations)                                         ',
     2 'VIEW XO/YO/ZO (rotations)                                     ',
     3 'VIEW AFACE/BFACE/CFACE (rotations)                            ',
     4 'VIEW ALIGN atom-name1 atom-name2 (ARU) WITH XP/YP (rotations) ',
     5 'VIEW DIRECTION x y z (rotations)                              ',
     6 'VIEW LINE atom-name1 atom-name2 (ARU/rotations)               ',
     7 'VIEW BISECT atom-name1 atom-name2 atom-name3 (rotations)      ',
     8 'VIEW PERP atom-name1 atom-name2 atom-name3 (rotations)        ',
     9 'VIEW CURRENT (rotations)                                      ',
     * 'VIEW INVERT (rotations)                                       ',
     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                                                       '/
     7 )
      END MODULE man
 
      SUBROUTINE PLA299 (MODE)
      USE files
      USE xwdw
      USE cggt
      USE man
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: MODE
      IF (IWIN == 1) CALL GGIP (HORS, VERT, 0.0, 1)
      VRT = VERT
      HRT = HORS / 2.0
C * PLATON INSTRUCTIONS
      IF (MODE == 1) THEN
        DO I = 1, 131
          WRITE (LU6, 99999, IOSTAT = IOST) MANUAL(I)
        END DO
        IF (IWIN == 1) THEN
          DO I = 1, 70
            VRT = VRT - 0.25
            CALL PLA439 (0.0, MANUAL(I), 29, 0.2, 1, 1, 0.2, VRT)
          END DO
          VRT = VERT
          DO I = 71, 131
            VRT = VRT - 0.25
            CALL PLA439 (0.0, MANUAL(I), 29, 0.2, 1, 1, HRT, VRT)
          END DO
C * WHAT NEXT ?
          CALL PLA012 (1, 1)
          IGGT = '!'
        END IF
C * PLUTON INSTRUCTIONS
      ELSE
        DO I = 1, 70
          VRT = VRT - 0.25
          CALL PLA439 (0.0, PLUMAN(I), 62, 0.2, 1, 1, 0.2, VRT)
        END DO
        IF (IWIN == 1) THEN
          VRT = VERT
          DO I = 71, 116
            VRT = VRT - 0.25
            CALL PLA439 (0.0, PLUMAN(I), 62, 0.2, 1, 1, HRT, VRT)
          END DO
          DO I = 1, 116
            WRITE (LU6, 99999, IOSTAT = IOST) PLUMAN(I)
          END DO
C * WHAT NEXT ?
          CALL PLA012 (1, 1)
          IGGT = '!'
        END IF
      END IF
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA299
 
      SUBROUTINE PLA300 (M1, M2, M3)
C * GET WEB-PAGE - BROWSER-HTML HELP
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE menus
      USE cggt
      IMPLICIT NONE
      INTEGER           :: M1
      INTEGER           :: M2
      INTEGER           :: M3
      INTEGER           :: NA
      INTEGER           :: NB
      INTEGER           :: NC
      INTEGER           :: NX
      INTEGER           :: NF
      INTEGER           :: NE
      INTEGER           :: LNX
      INTEGER           :: IER
      CHARACTER(len=2)  :: N1
      CHARACTER(len=2)  :: N2
      CHARACTER(len=2)  :: N3
      CHARACTER(len=11) :: MOPTION
      NA      = M1
      NB      = M2
      NC      = M3
C * LENGTH OF BROWSER PATH (MacOS & LINUX ONLY - ZERO FOR MS-WINDOWS)
      NF      = IGBL(47)
      MOPTION = ' '
C * CLICK ON CANVAS = AREA #1
      IF (NA == 1) THEN
C * CHECK FOR MAIN PLATON SIDE MENU's 10, 11 & 12
        IF (IGBL(6) >= 10 .AND. IGBL(6) <= 12) THEN
          N1 = '00'
          IF (NC > NP46) THEN
            IF (NF > 0 .OR. DOS) THEN
              IF (NB == 1) THEN
                PRBUF = HTTPSERVER(1:IGBL(135))//
     1                  'PLATON-MANUAL.pdf'
              ELSE IF (NB == 2) THEN
                PRBUF = HTTPSERVER(1:IGBL(135))//
     1                  'PLATON_HOW_TO.pdf'
              ELSE
                NB = 0
                NC = 0
              END IF
C STRIP_END
            END IF
          END IF
        ELSE
          RETURN
        END IF
        WRITE (N2, 99997, IOSTAT = IOST) NB
C * CLICK ON SIDE MENU  = AREA #2
      ELSE IF (NA == 2) THEN
        WRITE (N1, 99997, IOSTAT = IOST) IGBL(6)
        MOPTION = MENUSUB(NC)
        N2 = '02'
C * CLICK IN AREA #3
      ELSE IF (NA == 3) THEN
        N1 = '10'
        N2 = '03'
        N3 = '00'
C * CLICK ELSEWHERE
      ELSE IF (NA == 0) THEN
        WRITE (N1, 99997, IOSTAT = IOST) NB
        N2      = '00'
      END IF
      WRITE (N3, 99997, IOSTAT = IOST) MAX (0, NC)
C * PREPARE URL IN PRBUF
      CALL GET_ENVIRONMENT_VARIABLE ('PLAHTM', VALUE = LINE)
      IF (LINE(1:1) == ' ') THEN
        PRBUF = HTTPSERVER(1:IGBL(135))//'platon/'
      ELSE
        PRBUF = 'file:'//LINE
      END IF
      NX = 1
      CALL GEN039 (1, PRBUF, 1, 132, NX, NE)
      PRBUF(NE + 1:) = 'pl'//N1//N2//N3//'.html'
      LNX = NE + 13
      WRITE(LINE, 99998) MOPTION, PRBUF(1:LNX)
      LNX = LNX + 25
C * REPORT INFO LOCATION
      WRITE (LU6, 99999) LINE(1:LNX)
C STRIP_END
C * PREPARE BROWSER COMMAND LINE IN CGETENV
      IF (NF > 0) THEN
        IER = 0
        BROWSER(NF + 1: )  = ' '//PRBUF(1:NE + 13)
        WRITE (LU6, 99999) BROWSER(1:NF+NE+15)
        CALL SPAWN ('sh -c '''//BROWSER(1:NF + NE + 15)//' '' ',
     1    LU6, .false., IER)
        IGGT(1:1) = CHAR (12)
      ELSE
C * REPORT INFO LOCATION
        BCD = LINE(1:LNX)//CHAR (0)
        CALL GGIP (-999.0, 3.0, 80.0, 111)
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT ('Info for ', A, ' at: ', A)
99997 FORMAT (I2.2)
      END SUBROUTINE PLA300
 
      MODULE stidy
      SAVE
      INTEGER, PARAMETER                    :: NUMAT = 150
      INTEGER, PARAMETER                    :: NELTS = 16
      INTEGER, PARAMETER                    :: NTOT  = 1000
      INTEGER, PARAMETER                    :: NSETX = 120
      INTEGER, PARAMETER                    :: NDIF  = 30
      INTEGER,          DIMENSION(14)       :: ISX =
     1  (/1, 5, 6, 7, 11, 18, 13, 17, 21, 22, 28, 24, 31, 29/)
      INTEGER                               :: IW
      INTEGER                               :: NW
      INTEGER                               :: MU
      INTEGER                               :: NEL
      INTEGER                               :: NBR
      INTEGER                               :: IAT
      INTEGER                               :: MINI
      INTEGER                               :: NSH
      INTEGER                               :: NGO
      INTEGER                               :: NOR
      INTEGER                               :: NFL
      INTEGER                               :: NGR
      INTEGER                               :: IGO
      INTEGER                               :: IERR
      INTEGER                               :: IRED
      INTEGER                               :: NEWN
      INTEGER                               :: IFSH
      INTEGER                               :: NABC
      INTEGER                               :: KORD
      INTEGER                               :: KSET
      INTEGER                               :: IPOL
      INTEGER                               :: IHEX
      INTEGER                               :: NATOM
      INTEGER                               :: ITYPE
      INTEGER                               :: IOCFL
      INTEGER                               :: IFLAG
      INTEGER                               :: NTEXT
      INTEGER                               :: KOUNT
      INTEGER                               :: ITHRU
      INTEGER                               :: NSPEC
      INTEGER                               :: NPOLX
      INTEGER                               :: MINSH
      INTEGER                               :: IFPLUS
      INTEGER                               :: ICOORD
      INTEGER                               :: IPOLAR
      INTEGER                               :: LOWLET
      INTEGER                               :: NSHTRA
      INTEGER,          DIMENSION(NTOT)     :: NAT
      INTEGER,          DIMENSION(27)       :: IS
      INTEGER,          DIMENSION(26)       :: NS
      INTEGER,          DIMENSION(NDIF)     :: NRZ
      INTEGER,          DIMENSION(NUMAT)    :: MUL
      INTEGER,          DIMENSION(NUMAT)    :: LET
      INTEGER,          DIMENSION(NUMAT)    :: MULR
      INTEGER,          DIMENSION(NUMAT)    :: LETR
      INTEGER,          DIMENSION(8)        :: NSET
      INTEGER,          DIMENSION(15)       :: MULT
      INTEGER,          DIMENSION(48, 3, 3) :: NROT
      INTEGER,          DIMENSION(NUMAT)    :: KKORD
      INTEGER,          DIMENSION(48, 3)    :: NTRAN
      INTEGER,          DIMENSION(NDIF)     :: MAXNR
      INTEGER,          DIMENSION(2)        :: IFNG
      INTEGER,          DIMENSION(192)      :: KORDER
      REAL                                  :: A
      REAL                                  :: B
      REAL                                  :: C
      REAL,             DIMENSION(9)        :: U9
      REAL,             DIMENSION(9)        :: T9
      REAL,             DIMENSION(9)        :: P9
      REAL                                  :: E1
      REAL                                  :: AL
      REAL                                  :: BE
      REAL                                  :: GA
      REAL                                  :: ALF
      REAL                                  :: BET
      REAL                                  :: GAM
      REAL                                  :: RRX
      REAL                                  :: VOL
      REAL                                  :: SF11
      REAL                                  :: SF22
      REAL                                  :: SF33
      REAL                                  :: SF23
      REAL                                  :: SF13
      REAL                                  :: SF12
      REAL                                  :: SMIN
      REAL                                  :: FNUM
      REAL                                  :: COSA
      REAL                                  :: COSB
      REAL                                  :: COSG
      REAL                                  :: GMIN
      REAL                                  :: DMIN
      REAL                                  :: VOLRAT
      REAL,             DIMENSION(3)        :: SH
      REAL,             DIMENSION(3, NTOT)  :: XP
      REAL,             DIMENSION(3, NUMAT) :: XA
      REAL,             DIMENSION(9)        :: UVW
      REAL,             DIMENSION(NSETX)    :: SXY
      REAL,             DIMENSION(NSETX)    :: SXZ
      REAL,             DIMENSION(NSETX)    :: SYZ
      REAL,             DIMENSION(3, NUMAT) :: XXX
      REAL,             DIMENSION(3, 192)   :: XYZ
      REAL,             DIMENSION(3)        :: POS
      REAL,             DIMENSION(3)        :: SHIF
      REAL,             DIMENSION(3)        :: ORGA
      REAL,             DIMENSION(3, 3)     :: XMAT
      REAL,             DIMENSION(3, NUMAT) :: XMIN
      REAL,             DIMENSION(192)      :: DIST
      REAL,             DIMENSION(3)        :: PLUS
      REAL,             DIMENSION(3, NSETX) :: SUMX
      REAL,         DIMENSION(NUMAT, NSETX) :: HORSUM
      REAL,             DIMENSION(3, 8)     :: ORGADD
      REAL,             DIMENSION(3, 3)     :: XMSAVE
      CHARACTER(len=5)                      :: FFF
      CHARACTER(len=47)                     :: AXS
      CHARACTER(len=10)                     :: SPGR
      CHARACTER(len=2)                      :: ELT1
      CHARACTER(len=4)                      :: ELT2
      CHARACTER(len=40)                     :: INTXT
      CHARACTER(len=1), DIMENSION(14)       :: HS =
     1  (/'M','A','B','C','N','D','-','1','2','3','4','5','6','/'/)
      CHARACTER(len=1), DIMENSION(16)       :: NT
      CHARACTER(len=2), DIMENSION(NELTS)    :: ELT
      CHARACTER(len=1), DIMENSION(2)        :: CODE
      CHARACTER(len=2), DIMENSION(NUMAT)    :: ATOM1
      CHARACTER(len=4), DIMENSION(NUMAT)    :: ATOM2
      CHARACTER(len=5), DIMENSION(NUMAT)    :: FOCCU
      CHARACTER(len=2), DIMENSION(NDIF)     :: FINELT
C * LIST OF CODE NUMBERS OF SYMM. OP. FOR EACH POINT GROUP
      INTEGER, DIMENSION(216) :: LLF = (/
     1   1,  1, -2,  1, -3,  1, -4,  1,  2,  1,  3,  1,  4,  1,  2, -3,
     2  -4,  1,  3, -2, -4,  1,  4, -2, -3,  1,  4,  2,  3,  1,  4,-15,
     3 -14,  1,  4, 15, 14,  1,  4, 15, 14, -2, -3,-13,-16,  1,  4,  2,
     4   3,-13,-16,-14,-15,  1,  4, 13, 16, -2, -3,-14,-15,  1,  4,  2,
     5   3, 13, 16, 14, 15,  1,  3,  5,  1,  3,  5, -9,-11, -7,  1,  3,
     6   5,-10, -8,-12,  1,  3,  5,  9, 11,  7,  1,  3,  5, 10,  8, 12,
     7   1,  3,  5, -4, -2, -6,  1,  4,  3,  5,  2,  6,  1,  4,  3,  5,
     8   2,  6, -9,-11, -7,-10, -8,-12,  1,  3,  5, 10,  8, 12, -9,-11,
     9  -7, -4, -2, -6,  1,  3,  5,  9, 11,  7,-10, -8,-12, -4, -2, -6,
     *   1,  4,  3,  5,  2,  6,  9, 11,  7, 10,  8, 12,  1,  4,  2,  3,
     1   5,  9,  7, 12,  8, 10,  6, 11,  1,  4,  2,  3,  5,  9,  7, 12,
     2   8, 10,  6, 11,-13,-16,-14,-15,-17,-21,-19,-24,-20,-22,-18,-23,
     3   1,  4,  2,  3,  5,  9,  7, 12,  8, 10,  6, 11, 13, 16, 14, 15,
     4  17, 21, 19, 24, 20, 22, 18, 23/)
      INTEGER, DIMENSION(20, 18) :: MM4 = RESHAPE ((/
     1   1,  2,  3,  0,  4,  5,  0,  6,  7,  0,  0,  0,  8,  9, 10, 11,
     2  12, 13, 14, 15, 16, 17, 18, 19, 20, 21,  0, 22, 23, 24, 25,  0,
     3   0,  0,  0,  0,  0,  0,  0,  0, 26, 27, 28,  0, 29, 30,  0, 31,
     4  32,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 33, 34, 35,  0,
     5  36, 37,  0, 38, 39,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     6  40, 41,  0, 42, 43, 44,  0, 45, 46, 47, 48,  0,  0,  0,  0,  0,
     7   0,  0,  8,  0, 49, 50, 51,  0, 52, 53,  0, 54, 55, 56, 57,  0,
     8   0,  0,  0,  0,  0,  0,  0,  0,  0, 58,  0,  0, 59,  0, 60, 61,
     9   0, 62, 63,  0,  0,  0,  0,  0,  0,  0,  0,  0, 64, 65, 66, 67,
     *  68, 69, 70, 71, 72, 73,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     1  74, 75, 76,  0, 77, 78,  0, 79, 80,  0,  0,  0,  0,  0,  0,  0,
     2   0,  0,  0,  0,  0, 81,  0,  0, 82,  0,  0, 83,  0, 84, 85, 86,
     3   0,  0,  0,  0,  0,  0,  0,  0, 87,  0,  0,  0,  0,  0,  0,  0,
     4   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 88,  0,  0,  0,
     5   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     6  89,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     7   0,  0,  0,  0, 90,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     8   0,  0,  0,  0,  0,  0,  0,  0, 91,  0,  0,  0,  0,  0,  0,  0,
     9   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 92,  0,  0,  0,
     *   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     1  93,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     2   0,  0,  0,  0, 94,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     3   0,  0,  0,  0,  0,  0,  0,  0/), (/20, 18/))
      INTEGER, DIMENSION(3, 4, 5) :: NNQ = RESHAPE ((/
     1   0,  0,  0,  0, 12, 12,  0,  0,  0,  0,  0,  0,  0,  0,  0, 12,
     2   0, 12,  0,  0,  0,  0,  0,  0,  0,  0,  0, 12, 12,  0,  0,  0,
     3   0,  0,  0,  0,  0,  0,  0,  0, 12, 12, 12,  0, 12, 12, 12,  0,
     4   0,  0,  0, 12, 12, 12,  0,  0,  0,  0,  0,  0/), (/3, 4, 5/))
      INTEGER, DIMENSION(3, 45) :: LGN = RESHAPE ((/
     1   1,  0,  0,  2,  0,  0,  2,  0,  0,  2,  0,  0,  2,  0,  0,  2,
     2   0,  0,  2,  0,  0,  3,  4,  0,  3,  4,  0,  3,  4,  0,  3,  4,
     3   0,  3,  0,  0,  3,  0,  0,  5,  7,  0,  5,  3,  0,  5,  3,  0,
     4   3,  5,  0,  2,  0,  0,  2,  4,  0,  2,  4,  0,  2,  6,  0,  2,
     5   5,  0,  5,  0,  0,  5,  0,  0,  7, 10,  0,  7,  4,  0,  4,  7,
     6   0, 10,  7,  0,  2,  5,  0,  5, 14,  0,  5, 14,  0,  2,  0,  0,
     7   4,  2,  0,  4,  2,  0,  4,  2,  0,  7,  8,  6,  5,  0,  0,  3,
     8   6,  0, 10, 11, 13,  8, 10,  0,  8, 10,  0, 14, 19, 22,  5,  8,
     9   0, 26,  5, 37, 14,  5,  0/), (/3, 45/))
      INTEGER, DIMENSION(43, 3) :: MM5 = RESHAPE ((/
     1     1,    2,    3,    4,    5,    8,    9,  129,  444, 6654, 669,
     2 10029,  894,13404, 1119,16779, 1344,20154,    6,  172,   11, 131,
     3   146,  161,  446, 6671,10031, 1346,20171,  157,   10,  127, 130,
     4   145,  202,   13,  133,  148,  163,  178,  193,  448, 6688,   8,
     5     1,    2,    3,    4,    5,    6,    9,  129,   10,  157,   0,
     6   444,  669, 1119, 1344, 6654,10029,16779,20154,   -1,   -1,  -1,
     7    -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  -1,
     8    -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,    8,   1,
     9     2,    3,    4,    5,    6,    9,  129,    0,  444,  669, 894,
     *  1344, 6654,10029,13404,20154,   -1,   -1,   -1,   -1,   -1,  -1,
     1    -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  -1,
     2    -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1/), (/43, 3/))
      INTEGER, DIMENSION(45) :: ISY = (/
     1  1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5,
     2  5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 1, 2, 2, 2, 3, 5, 4, 4, 5, 5, 5,
     3  5, 6, 6/)
      INTEGER, DIMENSION(45) :: NT2 = (/
     1   0,   1,  14,  40,  53,  58,  68,  73, 107, 141, 175, 192, 194,
     2 200, 212, 218, 224, 234, 238, 242, 244, 248, 251, 252, 258, 262,
     3 264, 266, 272, 277, 283, 291, 292, 309, 343, 360, 467, 469, 475,
     4 495, 499, 501, 505, 507, 527/)
C * SEMINVARIANCE CONDITIONS
      INTEGER, DIMENSION(3, 3, 18) :: NSEM = RESHAPE ((/
     1  1,  0,  0,  0,  1,  0,  0,  0,  1, 96,  0,  0,  0,  1,  0,  0,
     2  0,  1,  1,  0,  0,  0, 96,  0,  0,  0,  1,  1,  0,  0,  0,  1,
     3  0,  0,  0, 96,  1,  0,  0,  0, 96,  0,  0,  0, 96, 96,  0,  0,
     4  0,  1,  0,  0,  0, 96, 96,  0,  0,  0, 96,  0,  0,  0,  1, 96,
     5  0,  0,  0, 96,  0,  0,  0, 96, 96, 96,  0,  0,  0,  1,  0,  0,
     6  0, 96, 96,  0,  0,  0, 96,  0,  0,  0,  0,  0, 96,  0,  0,  0,
     7  0,  0,  0, 96, 96, 96,  0,  0,  0,  0,  0,  0,  0,  0,  1,  0,
     8  0,  0,  0,  0,  0, 64,128, 32,  0,  0,  0,  0,  0,  0,128, 64,
     9  0,  0,  0,  1,  0,  0,  0,128, 64,  0,  0,  0, 96,  0,  0,  0,
     * 48, 48, 48, 96,  0,  0,  0, 96,  0, 96, 96,  0,  0, 96, 48,  0,
     1  0, 96/), (/3, 3, 18/))
      INTEGER, DIMENSION(3, 3, 36) :: IGES = RESHAPE ((/
     1   1,  0,  0,  0,  1,  0,  0,  0,  1,  1,  0,  0,  0, -1,  0,  0,
     2   0, -1, -1,  0,  0,  0,  1,  0,  0,  0, -1, -1,  0,  0,  0, -1,
     3   0,  0,  0,  1,  0,  1,  0,  0,  0,  1,  1,  0,  0,  0,  1,  0,
     4   0,  0, -1, -1,  0,  0,  0, -1,  0,  0,  0,  1, -1,  0,  0,  0,
     5  -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  1,  1,  0,  0,  0,  1,
     6   0,  0,  0,  1, -1,  0,  0,  0, -1,  0,  0,  0, -1,  1,  0,  0,
     7   0, -1,  0,  0,  0, -1, -1,  0,  0,  0,  1,  0,  0, -1,  0, -1,
     8   0,  0,  0,  0, -1,  0, -1,  0,  1,  0,  0,  0,  0,  1,  0,  1,
     9   0, -1,  0,  0,  0,  0,  1,  0,  1,  0,  1,  0,  0,  0,  0, -1,
     *  -1,  0,  0,  0,  0, -1,  0, -1,  0, -1,  0,  0,  0,  0,  1,  0,
     1   1,  0,  1,  0,  0,  0,  0, -1,  0,  1,  0,  1,  0,  0,  0,  0,
     2   1,  0, -1,  0,  0,  0, -1,  0, -1,  0, -1,  0,  0,  0,  0, -1,
     3   0,  1,  0,  1,  0,  0,  0,  0,  1,  0, -1,  0,  1,  0,  0,  0,
     4   0,  1,  0,  1,  0, -1,  0,  0,  1,  0,  0,  0,  1,  0,  0,  0,
     5   1,  1,  1,  0, -1,  0,  0,  0,  0,  1,  0,  1,  0, -1, -1,  0,
     6   0,  0,  1, -1,  0,  0,  0, -1,  0,  0,  0,  1, -1, -1,  0,  1,
     7   0,  0,  0,  0,  1,  0, -1,  0,  1,  1,  0,  0,  0,  1,  0,  1,
     8   0,  1,  0,  0,  0,  0, -1,  1,  1,  0,  0, -1,  0,  0,  0, -1,
     9   1,  0,  0, -1, -1,  0,  0,  0, -1,  0, -1,  0, -1,  0,  0,  0,
     *   0, -1, -1, -1,  0,  0,  1,  0,  0,  0, -1, -1,  0,  0,  1,  1,
     1   0,  0,  0, -1/), (/3, 3, 36/))
      INTEGER, DIMENSION(3, 25) :: NGET = RESHAPE ((/
     1   0,  0,  0, 12,  0,  0,  0, 12,  0,  0,  0, 12,  0, 12, 12, 12,
     2   0, 12, 12, 12,  0, 12, 12, 12,  0,  6,  6,  6,  0,  6,  6,  6,
     3   0,  6,  6,  6, 18,  6,  6,  0,  0,  4,  0,  0,  6,  0,  0,  8,
     4   0, 12,  6,  0,  0, 16,  0,  0, 18,  0,  0, 20, 12,  0,  6, 12,
     5  12, 18, 12, 12,  6,  6, 18, 18,  6,  6, 18/), (/3, 25/))
      INTEGER, DIMENSION(230) :: NLST = (/
     1   1, 292,  59,  67,  63,  15,  29,  19,  31, 310, 336, 314, 324,
     2 340, 326, 176, 182, 188, 191, 183, 179, 181, 180, 192, 142, 152,
     3 168, 148, 163, 170, 174, 158, 165, 172, 145, 153, 169, 143, 155,
     4 149, 160, 147, 175, 146, 159, 150, 361, 438, 412, 411, 384, 439,
     5 373, 430, 451, 434, 409, 461, 392, 455, 456, 465, 372, 374, 364,
     6 416, 378, 431, 366, 467, 365, 413, 457, 368, 195, 197, 198, 199,
     7 196, 200, 193, 194, 470, 472, 473, 474, 471, 475, 225, 227, 228,
     8 229, 230, 231, 232, 233, 226, 234, 201, 203, 204, 205, 206, 208,
     9 209, 210, 202, 207, 211, 212, 213, 215, 216, 217, 219, 221, 223,
     * 224, 220, 222, 214, 218, 476, 478, 480, 481, 482, 483, 484, 485,
     1 486, 487, 488, 489, 490, 491, 492, 493, 477, 479, 494, 495, 235,
     2 237, 238, 236, 468, 469, 249, 245, 250, 247, 251, 248, 246, 239,
     3 243, 241, 244, 240, 242, 500, 501, 496, 498, 497, 499, 253, 254,
     4 255, 256, 257, 258, 252, 506, 507, 267, 268, 269, 270, 271, 272,
     5 259, 260, 261, 262, 263, 264, 265, 266, 502, 503, 504, 505, 273,
     6 274, 275, 276, 277, 529, 535, 533, 541, 531, 537, 539, 284, 288,
     7 286, 291, 285, 289, 287, 290, 278, 279, 280, 281, 282, 283, 509,
     8 515, 517, 521, 513, 519, 523, 525, 511, 527/)
      INTEGER, DIMENSION(1623)     :: NNT1
      INTEGER, DIMENSION(3)        :: KPOL
      INTEGER, DIMENSION(NUMAT)    :: NRSET
      INTEGER, DIMENSION(8, NUMAT) :: NNSET
      INTEGER, DIMENSION(230)      :: NCENT = (/
     1  1,  1,  1,  1,  3,  1,  1,  3,  3,  1,  1,  3,  1,  1,  3,  1,
     2  1,  1,  1,  3,  3,  4,  5,  5,  1,  1,  1,  1,  1,  1,  1,  1,
     3  1,  1,  3,  3,  3,  2,  2,  2,  2,  4,  4,  5,  5,  5,  1,  1,
     4  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  3,  3,
     5  3,  3,  3,  3,  4,  4,  5,  5,  5,  5,  1,  1,  1,  1,  5,  5,
     6  1,  5,  1,  1,  1,  1,  5,  5,  1,  1,  1,  1,  1,  1,  1,  1,
     7  5,  5,  1,  1,  1,  1,  1,  1,  1,  1,  5,  5,  5,  5,  1,  1,
     8  1,  1,  1,  1,  1,  1,  5,  5,  5,  5,  1,  1,  1,  1,  1,  1,
     9  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  5,  5,  5,  5,  1,  1,
     *  1,  6,  1,  6,  1,  1,  1,  1,  1,  1,  6,  1,  1,  1,  1,  6,
     1  6,  1,  1,  1,  1,  6,  6,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     3  1,  1,  1,  4,  5,  1,  5,  1,  1,  4,  4,  5,  1,  5,  1,  1,
     4  4,  4,  5,  1,  1,  5,  1,  4,  5,  1,  4,  5,  1,  1,  1,  1,
     5  4,  4,  4,  4,  5,  5/)
      INTEGER, DIMENSION(5593) :: ISETS
      INTEGER, DIMENSION(541)  :: ITGRP = (/
     1   1,  6,  8,  8,  8,  7,  9,  9,  7,  9,  9,  7,  9,  9,  6,  6,
     2   8,  8,  8,  8,  8,  8,  7,  7,  9,  9,  9,  9,  7,  7,  9,  9,
     3   9,  9,  7,  7,  9,  9,  9,  9,  6,  8,  8,  8,  7,  9,  9,  7,
     4   9,  9,  7,  9,  9,  3,  5,  5,  5,  4,  3,  3,  5,  5,  5,  5,
     5   5,  5,  4,  4,  3,  5,  5,  5,  4, 25, 35, 38, 38, 44, 42, 28,
     6  40, 46, 39, 26, 36, 28, 39, 40, 46, 32, 41, 41, 45, 29, 29, 33,
     7  33, 26, 36, 27, 37, 30, 30, 34, 31, 31, 43, 25, 38, 35, 38, 44,
     8  42, 28, 40, 46, 39, 26, 36, 28, 39, 40, 46, 32, 45, 41, 41, 29,
     9  29, 33, 33, 26, 36, 27, 37, 30, 30, 34, 31, 31, 43, 25, 38, 38,
     *  35, 44, 42, 28, 40, 46, 39, 26, 36, 28, 39, 40, 46, 32, 45, 41,
     1  41, 29, 29, 33, 33, 26, 36, 27, 37, 30, 30, 34, 31, 31, 43, 16,
     2  21, 21, 21, 23, 22, 17, 20, 17, 20, 17, 20, 18, 18, 18, 19, 24,
     3  81, 82, 75, 79, 76, 77, 76, 80, 99,107,100,101,102,103,108,104,
     4 105,106,109,110,111,121,112,113,114,122,115,119,116,120,117,118,
     5  89, 97, 90, 91, 92, 93, 94, 91, 92, 98,143,146,144,144,156,160,
     6 158,161,157,159,150,155,152,152,149,151,151,174,168,169,169,171,
     7 171,173,183,184,185,186,187,188,189,190,177,178,178,180,180,182,
     8 195,196,197,198,199,215,216,217,218,219,220,207,211,209,213,208,
     9 213,214,210,  2, 10, 12, 12, 12, 13, 15, 15, 13, 15, 15, 13, 15,
     *  15, 11, 14, 14, 14, 10, 10, 12, 12, 12, 12, 12, 12, 13, 13, 15,
     1  15, 15, 15, 13, 13, 15, 15, 15, 15, 13, 13, 15, 15, 15, 15, 11,
     2  11, 14, 14, 14, 14, 14, 14, 10, 12, 12, 12, 13, 15, 15, 13, 15,
     3  15, 13, 15, 15, 11, 14, 14, 14, 47, 65, 65, 65, 71, 69, 51, 74,
     4  63, 51, 74, 63, 53, 64, 53, 49, 72, 67, 67, 66, 55, 64, 58, 51,
     5  74, 63, 51, 74, 63, 57, 57, 59, 59, 62, 62, 49, 72, 67, 67, 66,
     6  51, 74, 63, 52, 54, 68, 54, 68, 57, 60, 50, 49, 72, 67, 67, 66,
     7  51, 74, 63, 52, 54, 68, 54, 68, 57, 60, 50, 61, 53, 54, 68, 55,
     8  64, 56, 57, 60, 62, 48, 52, 52, 53, 64, 53, 64, 56, 59, 50, 53,
     9  54, 68, 55, 64, 56, 57, 60, 61, 73, 62, 52, 52, 58, 58, 60, 60,
     *  62, 62, 70,147,148, 83, 87, 84, 85, 86, 88,123,139,124,140,125,
     1 126,127,128,129,130,131,132,133,134,135,136,137,138,141,142,164,
     2 166,165,167,162,163,191,192,193,194,175,176,221,221,229,229,225,
     3 225,222,222,223,223,226,226,224,224,227,227,228,228,230,230,200,
     4 200,204,204,202,202,201,201,205,205,206,206,203,203/)
 
      INTEGER, DIMENSION(44)     :: IFORM = (/
     1 14, 12, 13, 12, 15, 10, 10, 8, 12, 3, 9, 11, 6, 3, 10, 7, 3, 10,
     2  8,  3,  9, 11,  6, 12,  3, 7,  3, 3, 3,  3, 1, 5,  2, 2, 2,  6,
     3  3,  6,  3,  6,  3,  8,  4, 1/)
      INTEGER, DIMENSION(3, 146) :: KSPEC = RESHAPE ((/
     1  2,2,2,  1,2,2,  2,1,2,  2,2,1,  2,1,1,  1,2,1,  1,1,2,  1,1,1,
     2  3,3,2,  3,3,1,  3,3,4,  3,3,3,  3,4,3,  4,3,3,  2,2,3,  1,2,3,
     3  2,1,3,  1,1,3,  3,3,2,  4,3,2,  4,3,1,  3,3,1,  3,4,1,  3,1,1,
     4  3,1,2,  1,3,3,  1,3,4,  5,5,5,  3,1,3,  5,5,7,  1,2,4,  3,4,2,
     5  1,3,5,  1,3,7,  3,4,4,  4,3,4,  1,4,5,  1,3,6, 9,10,1, 9,10,2,
     6 10,9,1, 10,9,2, 9,10,3, 10,9,3, 9,10,4,  4,4,4,  7,7,7,  3,2,1,
     7  6,6,6,  8,8,8,  5,1,3,  7,1,3,  6,1,3,  8,1,3,  1,4,3,  2,3,4,
     8  8,5,5,  0,2,2,  0,2,1,  0,1,2,  0,1,1,  0,3,3,  0,1,3,  0,3,4,
     9  0,2,3,  0,3,2,  0,3,1,  0,5,5,  0,3,5,  0,4,3,  0,1,9, 0,1,12,
     * 0,1,10, 0,1,11,  2,0,2,  1,0,2,  2,0,1,  1,0,1,  2,0,3,  1,0,3,
     1  3,0,3,  3,0,1,  4,0,3,  3,0,2,  5,0,5,  2,2,0,  1,2,0,  2,1,0,
     2  1,1,0,  3,3,0,  1,3,0,  3,4,0,  3,2,0,  3,1,0,  5,5,0,  4,3,0,
     3 9,10,0, 10,9,0,  0,0,2,  0,0,1,  0,0,3,  0,2,0,  0,1,0,  0,3,0,
     4  2,0,0,  1,0,0,  3,0,0,  0,0,1,  0,0,2,  0,0,3,  0,0,4,  0,0,6,
     5  0,0,7,  0,0,1,  0,0,2,  0,0,3,  0,0,9, 0,0,10, 0,0,11, 0,0,12,
     6  0,0,3,  0,0,2,  0,0,1,  0,0,3,  0,0,5,  0,0,8,  0,0,1,  0,0,2,
     7  0,0,3,  0,0,4,  1,0,0,  2,0,0,  3,0,0,  1,0,0,  3,0,0,  3,0,0,
     8  3,0,0,  2,0,0,  2,0,0,  5,0,0,  5,0,0,  0,0,0,  0,0,0,  0,0,0,
     9  0,0,0,  0,0,0/), (/3, 146/))
      INTEGER, DIMENSION(230) :: NPSPGR = (/
     1    0,   7,  31,  47,  54,  66,  78,  85,  95, 102, 140, 159, 188,
     2  209, 225, 245, 296, 313, 325, 332, 345, 379, 410, 441, 457, 483,
     3  495, 511, 526, 533, 545, 555, 567, 574, 586, 607, 617, 632, 652,
     4  667, 680, 690, 709, 719, 737, 749, 762, 828, 864, 911, 947, 981,
     5  999,1026,1046,1072,1089,1107,1131,1154,1169,1181,1196,1223,1247,
     6 1297,1336,1380,1410,1461,1487,1530,1564,1586,1618,1633,1640,1655,
     7 1662,1675,1685,1709,1730,1764,1797,1820,1843,1873,1893,1936,1959,
     8 1974,1984,2028,2051,2066,2076,2111,2134,2157,2173,2191,2207,2222,
     9 2235,2255,2268,2287,2303,2316,2326,2367,2406,2427,2445,2479,2509,
     * 2537,2565,2594,2621,2653,2671,2727,2769,2810,2845,2881,2911,2945,
     1 2970,3020,3067,3103,3145,3176,3211,3238,3270,3317,3360,3389,3414,
     2 3428,3435,3442,3452,3475,3495,3527,3550,3562,3574,3586,3598,3618,
     3 3635,3651,3665,3678,3691,3701,3737,3767,3798,3823,3851,3873,3889,
     4 3896,3903,3916,3929,3942,3974,4010,4040,4081,4094,4107,4140,4173,
     5 4203,4225,4241,4257,4273,4313,4347,4383,4413,4465,4508,4548,4587,
     6 4617,4641,4663,4673,4686,4721,4748,4778,4801,4829,4844,4862,4895,
     7 4934,4966,4992,5026,5044,5062,5090,5121,5148,5176,5205,5230,5248,
     8 5289,5320,5358,5396,5434,5468,5497,5525,5565/)
 
      INTEGER, DIMENSION(541) :: ITRAFO = (/
     1  0,  4,  4,  2,  7,  2,  2, 27,  4,  4,  7,  6, 22, 24,  0,  0,
     2  5,  5,  0,  0,  9,  9,  5,  5,  5,  5,  9,  9,  0,  0,  0,  0,
     3 29, 29,  8,  8, 25, 25, 20, 20,  1,  1,  3, 11,  1,  1, 31,  3,
     4  3, 11, 10, 21, 23,  4,  4,  2,  7,  4,  0,  0,  5,  5,  0,  0,
     5  9,  9,  0,  0,  1,  1,  3, 11,  1,  1,  1,  1,  5,  1,  1,  1,
     6  1,  1,  5,  1,  1,  5,  1,  5,  5,  1,  1,  5,  1,  5,  1,  5,
     7  1,  5,  5,  1,  5,  1,  5,  1,  5,  1,  1,  2,  3,  2,  2,  2,
     8  2,  2,  2,  2,  3,  3,  3,  3,  2,  3,  3,  2,  2,  2,  3,  3,
     9  2,  3,  2,  2,  2,  2,  2,  2,  3,  2,  3,  2,  2,  0,  0,  4,
     *  0,  0,  0,  0,  0,  0,  4,  0,  0,  4,  0,  4,  4,  0,  0,  0,
     1  4,  4,  0,  4,  0,  4,  4,  0,  0,  0,  4,  0,  4,  0,  0,  0,
     2  1,  2,  0,  0,  0,  0,  0,  1,  1,  2,  2,  0,  2,  1,  0,  0,
     3  0,  0,  0,  0,  0,  0, -1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     4  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     5  0,  0,  0,  0,  0,  0,  0, -1, -1,  0,  0,  0,  0, -1,  0,  0,
     6  0,  0,  0,  0,  0,  0,  0, -1,  0,  0, -1,  0,  0,  0, -1,  0,
     7 -1,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, -1,  0, -1,  0,
     8  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     9 -1,  0,  0,  0,  4,  2,  4,  7,  2,  2, 47,  4,  4,  7,  6, 42,
     * 44,  4,  2,  4,  6,  0,  0,  5,  5,  0,  0,  9,  9,  5,  5,  5,
     1  5,  9,  9,  0,  0,  0,  0, 49, 49,  8,  8, 45, 45, 40, 40,  0,
     2  0,  5,  5,  0,  0,  8,  8,  1,  1,  3, 11,  1,  1, 51,  3,  3,
     3 11, 10, 41, 43,  1,  1,  3, 10,  0,  1,  2,  0,  0,  0,  4,  0,
     4  3,  2,  3,  0,  0,  0,  3,  1,  1,  0,  3,  1,  1,  3,  1,  0,
     5  4,  1,  3,  2,  5,  1,  5,  0,  2,  4,  2,  2,  2,  1,  4,  2,
     6  1,  5,  2,  1,  1,  1,  2,  2,  0,  2,  0,  0,  0,  2,  5,  0,
     7  5,  1,  4,  5,  4,  4,  5,  5,  3,  4,  2,  3,  5,  0,  0,  2,
     8  1,  0,  4,  3,  5,  0,  0,  3,  4,  4,  2,  2,  1,  1,  1,  1,
     9  3,  3,  0,  5,  2,  2,  0,  0,  0,  1,  4,  2,  0,  2,  1,  5,
     *  0,  3,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     1  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     2  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     3  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     4  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
      REAL, DIMENSION(3, NUMAT) :: XROT
      REAL, DIMENSION(3, NTOT)  :: XPOL
      REAL, DIMENSION(9, 30)    :: XABC = RESHAPE ((/
     1  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,
     2  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,
     3  1.0,  0.0,  0.0,  0.0,  0.0, -1.0,  0.0,  1.0,  0.0,
     4  0.0,  1.0,  0.0, -1.0,  0.0,  0.0,  0.0,  0.0,  1.0,
     5  0.0,  0.0,  1.0,  0.0, -1.0,  0.0,  1.0,  0.0,  0.0,
     6  0.0, -1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,  1.0,
     7  0.0, -1.0, -1.0,  1.0,  0.0,  0.0,  0.0,  0.0,  1.0,
     8  0.0,  0.0, -1.0,  0.0,  1.0,  0.0,  1.0,  0.0,  1.0,
     9 -1.0,  0.0, -1.0,  0.0,  1.0,  0.0,  1.0,  0.0,  0.0,
     * -1.0,  0.0,  0.0,  0.0,  0.0,  1.0,  1.0,  1.0,  0.0,
     1 -1.0, -1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  1.0,  0.0,
     2  0.0,  0.0, -1.0, -1.0,  0.0,  0.0,  0.0,  1.0,  1.0,
     3  0.0, -1.0, -1.0, -1.0,  0.0,  0.0,  0.0,  1.0,  0.0,
     4 -1.0,  0.0,  0.0,  0.0, -1.0,  0.0,  1.0,  0.0,  1.0,
     5 -1.0,  0.0, -1.0,  0.0, -1.0,  0.0,  0.0,  0.0,  1.0,
     6  0.0, -1.0,  0.0,  0.0,  0.0, -1.0,  1.0,  1.0,  0.0,
     7 -1.0, -1.0,  0.0,  0.0,  0.0, -1.0,  1.0,  0.0,  0.0,
     8  0.0,  1.0,  0.0, -1.0,  0.0,  0.0,  0.0, -1.0,  1.0,
     9  0.0,  1.0, -1.0, -1.0,  0.0,  0.0,  0.0,  0.0,  1.0,
     *  0.0,  0.0,  1.0,  0.0, -1.0,  0.0,  1.0,  0.0, -1.0,
     1 -1.0,  0.0,  1.0,  0.0, -1.0,  0.0,  1.0,  0.0,  0.0,
     2  1.0,  0.0,  0.0,  0.0,  0.0, -1.0, -1.0,  1.0,  0.0,
     3  1.0, -1.0,  0.0,  0.0,  0.0, -1.0,  0.0,  1.0,  0.0,
     4  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,  0.0,  1.0, -1.0,
     5  0.0, -1.0,  1.0,  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,
     6  1.0,  0.0,  0.0,  0.0,  1.0,  0.0, -1.0,  0.0,  1.0,
     7  1.0,  0.0, -1.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     8  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,  1.0, -1.0,  0.0,
     9 -1.0,  1.0,  0.0,  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,
     * -1.0,  0.0,  0.0,  0.0, -1.0,  0.0,  0.0,  0.0, -1.0/),
     1 (/9, 30/))
 
      REAL, DIMENSION(9, 6) :: UVWX = RESHAPE((/
     1  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     2  0.0,  0.5, -0.5,  0.0,  0.5,  0.5,  1.0,  0.0,  0.0,
     3  0.5, -0.5,  0.0,  0.5,  0.5,  0.0,  0.0,  0.0,  1.0,
     4  0.5,  0.5,  0.0,  0.0,  0.5,  0.5,  0.5,  0.0,  0.5,
     5  0.5,  0.5, -0.5, -0.5,  0.5,  0.5,  0.5, -0.5,  0.5,
     6  0.333333, -0.333333, -0.333333, -0.666667, -0.333333,
     7 -0.333333,  0.333333,  0.666667, -0.333333/),(/9, 6/))
      REAL, DIMENSION(3, 11) :: XSHIFT = RESHAPE ((/
     1 0.75,  0.75, 0.75, 0.75, 0.75,  0.0, 0.0, 0.75, 0.75, 0.25, 0.75,
     2  0.0,  0.25, 0.25, 0.25, 0.25, 0.25, 0.0, 0.25, 0.75, 0.25,  0.0,
     3 0.75, 0.125,  0.0, 0.25, 0.125, 0.125, 0.125, 0.125, 0.375,
     4 0.375, 0.375/), (/3, 11/))
      REAL, DIMENSION(3,107) :: SPECIA = RESHAPE ((/
     1  0.5,   0.5,   0.5,   0.0,   0.5,   0.5,   0.5,    0.0,   0.5,
     2  0.5,   0.5,   0.0,   0.5,   0.0,   0.0,   0.0,    0.5,   0.0,
     3  0.0,   0.0,   0.5,   0.0,   0.0,   0.0,   0.25,  0.25,  0.5,
     4  0.25,  0.25,  0.0,   0.25,  0.25,  0.75,  0.25,  0.25,  0.25,
     5  0.25,  0.75,  0.25,  0.75,  0.25,  0.25,  0.5,   0.5,   0.25,
     6  0.0,   0.5,   0.25,  0.5,   0.0,   0.25,  0.0,   0.0,   0.25,
     7  0.25,  0.25,  0.5,   0.75,  0.25,  0.5,   0.75,  0.25,  0.0,
     8  0.25,  0.25,  0.0,   0.25,  0.75,  0.0,   0.25,  0.0,   0.0,
     9  0.25,  0.0,   0.5,   0.0,   0.25,  0.25,  0.0,   0.25,  0.75,
     *  0.125, 0.125, 0.125, 0.25,  0.0,   0.25,  0.125, 0.125, 0.625,
     1  0.0,   0.5,   0.75,  0.25,  0.75,  0.5,   0.0,   0.25,  0.125,
     2  0.0,   0.25,  0.625, 0.25,  0.75,  0.75,  0.75,  0.25,  0.75,
     3  0.0,   0.75,  0.125, 0.0,   0.25,  0.375,0.33333,0.66667, 0.0,
     4  0.33333,0.66667,0.5,0.66667,0.33333,0.0,0.66667,0.33333,0.5,
     5  0.33333, 0.66667,0.25,0.66667,0.33333,0.25,0.33333,0.66667,0.75,
     6  0.75,  0.75,  0.75,  0.625, 0.625, 0.625, 0.25,  0.5,   0.0,
     7  0.375, 0.375, 0.375, 0.875, 0.875, 0.875, 0.125, 0.0,   0.25,
     8  0.625, 0.0,   0.25,  0.375, 0.0,   0.25,  0.875, 0.0,   0.25,
     9  0.0,   0.75,  0.25,  0.5,   0.25,  0.75,  0.875, 0.125, 0.125,
     * -1.0,   0.5,   0.5,  -1.0,   0.5,   0.0,  -1.0,   0.0,   0.5,
     1 -1.0,   0.0,   0.0,  -1.0,   0.25,  0.25, -1.0,   0.0,   0.25,
     2 -1.0,   0.25,  0.75, -1.0,   0.5,   0.25, -1.0,   0.25,  0.5,
     3 -1.0,   0.25,  0.0,  -1.0,   0.125, 0.125,-1.0,   0.25,  0.125,
     4 -1.0,   0.75,  0.25, -1.0,   0.0, 0.33333,-1.0,   0.0,   0.83333,
     5 -1.0,   0.0, 0.66667,-1.0,   0.0, 0.16667, 0.5,  -1.0,   0.5,
     6  0.0,  -1.0,   0.5,   0.5,  -1.0,   0.0,   0.0,  -1.0,   0.0,
     7  0.5,  -1.0,   0.25,  0.0,  -1.0,   0.25,  0.25, -1.0,   0.25,
     8  0.25, -1.0,   0.0,   0.75, -1.0,   0.25,  0.25, -1.0,   0.5,
     9  0.125,-1.0,   0.125, 0.5,   0.5,  -1.0,   0.0,   0.5,  -1.0,
     *  0.5,   0.0,  -1.0,   0.0,   0.0,  -1.0,   0.25,  0.25, -1.0,
     1  0.0,   0.25, -1.0,   0.25,  0.75, -1.0,   0.25,  0.5,  -1.0,
     2  0.25,  0.0,  -1.0,   0.125, 0.125,-1.0,   0.75,  0.25, -1.0,
     3 0.33333,0.66667,-1.0,0.66667,0.33333,-1.0,-1.0,  -1.0,   0.5,
     4 -1.0,  -1.0,   0.0,  -1.0,  -1.0,   0.25, -1.0,   0.5,  -1.0,
     5 -1.0,   0.0,  -1.0,  -1.0,   0.25, -1.0,   0.5,  -1.0,  -1.0,
     6  0.0,  -1.0,  -1.0,   0.25, -1.0,  -1.0/), (/3, 107/))
      CHARACTER(len=1),  DIMENSION(7) :: HBR = (/
     1  'P','A','B','C','F','I','R'/)
      CHARACTER(len=10), DIMENSION(230) :: SPGP = (/
     1 'P 1       ', 'P -1      ', 'P 2       ', 'P 21      ',
     2 'C 2       ', 'P m       ', 'P c       ', 'C m       ',
     3 'C c       ', 'P 2/m     ', 'P 21/m    ', 'C 2/m     ',
     4 'P 2/c     ', 'P 21/c    ', 'C 2/c     ', 'P 2 2 2   ',
     5 'P 2 2 21  ', 'P 21 21 2 ', 'P 21 21 21', 'C 2 2 21  ',
     6 'C 2 2 2   ', 'F 2 2 2   ', 'I 2 2 2   ', 'I 21 21 21',
     7 'P m m 2   ', 'P m c 21  ', 'P c c 2   ', 'P m a 2   ',
     8 'P c a 21  ', 'P n c 2   ', 'P m n 21  ', 'P b a 2   ',
     9 'P n a 21  ', 'P n n 2   ', 'C m m 2   ', 'C m c 21  ',
     * 'C c c 2   ', 'A m m 2   ', 'A b m 2   ', 'A m a 2   ',
     1 'A b a 2   ', 'F m m 2   ', 'F d d 2   ', 'I m m 2   ',
     2 'I b a 2   ', 'I m a 2   ', 'P m m m   ', 'P n n n   ',
     3 'P c c m   ', 'P b a n   ', 'P m m a   ', 'P n n a   ',
     4 'P m n a   ', 'P c c a   ', 'P b a m   ', 'P c c n   ',
     5 'P b c m   ', 'P n n m   ', 'P m m n   ', 'P b c n   ',
     6 'P b c a   ', 'P n m a   ', 'C m c m   ', 'C m c a   ',
     7 'C m m m   ', 'C c c m   ', 'C m m a   ', 'C c c a   ',
     8 'F m m m   ', 'F d d d   ', 'I m m m   ', 'I b a m   ',
     9 'I b c a   ', 'I m m a   ', 'P 4       ', 'P 41      ',
     * 'P 42      ', '          ', 'I 4       ', 'I 41      ',
     1 'P -4      ', 'I -4      ', 'P 4/m     ', 'P 42/m    ',
     2 'P 4/n     ', 'P 42/n    ', 'I 4/m     ', 'I 41/a    ',
     3 'P 4 2 2   ', 'P 4 21 2  ', 'P 41 2 2  ', 'P 41 21 2 ',
     4 'P 42 2 2  ', 'P 42 21 2 ', '          ', '          ',
     5 'I 4 2 2   ', 'I 41 2 2  ', 'P 4 m m   ', 'P 4 b m   ',
     6 'P 42 c m  ', 'P 42 n  m ', 'P 4 c c   ', 'P 4 n c   ',
     7 'P 42 m c  ', 'P 42 b c  ', 'I 4 m m   ', 'I 4 c m   ',
     8 'I 41 m d  ', 'I 41 c d  ', 'P -4 2 m  ', 'P -4 2 c  ',
     9 'P -4 21 m ', 'P -4 21 c ', 'P -4 m 2  ', 'P -4 c 2  ',
     * 'P -4 b 2  ', 'P -4 n 2  ', 'I -4 m 2  ', 'I -4 c 2  ',
     1 'I -4 2 m  ', 'I -4 2 d  ', 'P 4/m m m ', 'P 4/m c c ',
     2 'P 4/n b m ', 'P 4/n n c ', 'P 4/m b m ', 'P 4/m n c ',
     3 'P 4/n m m ', 'P 4/n c c ', 'P 42/m m c', 'P 42/m c m',
     4 'P 42/n b c', 'P 42/n n m', 'P 42/m b c', 'P 42/m n m',
     5 'P 42/n m c', 'P 42/n c m', 'I 4/m m m ', 'I 4/m c m ',
     6 'I 41/a m d', 'I 41/a c d', 'P 3       ', 'P 31      ',
     7 '          ', 'R 3       ', 'P -3      ', 'R -3      ',
     8 'P 3 1 2   ', 'P 3 2 1   ', 'P 31 1 2  ', 'P 31 2 1  ',
     9 '          ', '          ', 'R 3 2     ', 'P 3 m 1   ',
     * 'P 3 1 m   ', 'P 3 c 1   ', 'P 3 1 c   ', 'R 3 m     ',
     1 'R 3 c     ', 'P -3 1 m  ', 'P -3 1 c  ', 'P -3 m 1  ',
     2 'P -3 c 1  ', 'R -3 m    ', 'R -3 c    ', 'P 6       ',
     3 'P 61      ', '          ', 'P 62      ', '          ',
     4 'P 63      ', 'P -6      ', 'P 6/m     ', 'P 63/m    ',
     5 'P 6 2 2   ', 'P 61 2 2  ', '          ', 'P 62 2 2  ',
     6 '          ', 'P 63 2 2  ', 'P 6 m m   ', 'P 6 c c   ',
     7 'P 63 c m  ', 'P 63 m c  ', 'P -6 m 2  ', 'P -6 c 2  ',
     8 'P -6 2 m  ', 'P -6 2 c  ', 'P 6/m m m ', 'P 6/m c c ',
     9 'P 63/m c m', 'P 63/m m c', 'P 2 3     ', 'F 2 3     ',
     * 'I 2 3     ', 'P 21 3    ', 'I 21 3    ', 'P m -3    ',
     1 'P n -3    ', 'F m -3    ', 'F d -3    ', 'I m -3    ',
     2 'P a -3    ', 'I a -3    ', 'P 4 3 2   ', 'P 42 3 2  ',
     3 'F 4 3 2   ', 'F 41 3 2  ', 'I 4 3 2   ', '          ',
     4 'P 41 3 2  ', 'I 41 3 2  ', 'P -4 3 m  ', 'F -4 3 m  ',
     5 'I -4 3 m  ', 'P -4 3 n  ', 'F -4 3 c  ', 'I -4 3 d  ',
     6 'P m -3 m  ', 'P n -3 n  ', 'P m -3 n  ', 'P n -3 m  ',
     7 'F m -3 m  ', 'F m -3 c  ', 'F d -3 m  ', 'F d -3 c  ',
     8 'I m -3 m  ', 'I a -3 d  '/)
      CHARACTER(len=14), DIMENSION(47) :: PSYM = (/
     1 '2             ', '21            ', 'M             ',
     2 'N             ', 'A             ', 'B             ',
     3 'C             ', '2/M           ', '21/M          ',
     4 '2/A           ', '2/B           ', '2/C           ',
     5 '2/N           ', '21/A          ', '21/B          ',
     6 '21/C          ', '21/N          ', '2             ',
     7 'M             ', 'N             ', 'A             ',
     8 '2/M           ', '2/A           ', '2/N           ',
     9 '2             ', 'M             ', 'N             ',
     * 'B             ', '2/M           ', '2/B           ',
     1 '2/N           ', '2             ', 'M             ',
     2 'N             ', 'C             ', '2/M           ',
     3 '2/C           ', '2/N           ', '2             ',
     4 'M             ', 'A             ', 'B             ',
     5 'C             ', '2/M           ', '2/A           ',
     6 '2/B           ', '2/C           '/)
      CHARACTER(len=2), DIMENSION(105) :: XELN = (/
     1 'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne','Na','Mg','Al',
     2 'Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti','V ','Cr','Mn','Fe',
     3 'Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y ',
     4 'Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te',
     5 'I ','Xe','Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb',
     6 'Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re','Os','Ir','Pt',
     7 'Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th','Pa',
     8 'U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md','No','Lr','Tu',
     9 'D '/)
      CHARACTER(len=11), DIMENSION(107) :: STAA = (/
     1 '1/2 1/2 1/2', '0   1/2 1/2', '1/2 0   1/2', '1/2 1/2 0  ',
     2 '1/2 0   0  ', '0   1/2 0  ', '0   0   1/2', '0   0   0  ',
     3 '1/4 1/4 1/2', '1/4 1/4 0  ', '1/4 1/4 3/4', '1/4 1/4 1/4',
     4 '1/4 3/4 1/4', '3/4 1/4 1/4', '1/2 1/2 1/4', '0   1/2 1/4',
     5 '1/2 0   1/4', '0   0   1/4', '1/4 1/4 1/2', '3/4 1/4 1/2',
     6 '3/4 1/4 0  ', '1/4 1/4 0  ', '1/4 3/4 0  ', '1/4 0   0  ',
     7 '1/4 0   1/2', '0   1/4 1/4', '0   1/4 3/4', '1/8 1/8 1/8',
     8 '1/4 0   1/4', '1/8 1/8 5/8', '0   1/2 3/4', '1/4 3/4/1/2',
     9 '0   1/4 1/8', '0   1/4 5/8', '1/4 3/4 3/4', '3/4 1/4 3/4',
     * '0   3/4 1/8', '0   1/4 3/8', '1/3 2/3 0  ', '1/3 2/3 1/2',
     1 '2/3 1/3 0  ', '2/3 1/3 1/2', '1/3 2/3 1/4', '2/3 1/3 1/4',
     2 '1/3 2/3 3/4', '3/4 3/4 3/4', '5/8 5/8 5/8', '1/4 1/2 0  ',
     3 '3/8 3/8 3/8', '7/8 7/8 7/8', '1/8 0   1/4', '5/8 0   1/4',
     4 '3/8 0   1/4', '7/8 0   1/4', '0   3/4 1/4', '1/2 1/4 3/4',
     5 '7/8 1/8 1/8', 'x   1/2 1/2', 'x   1/2 0  ', 'x   0   1/2',
     6 'x   0   0  ', 'x   1/4 1/4', 'x   0   1/4', 'x   1/4 3/4',
     7 'x   1/2 1/4', 'x   1/4 1/2', 'x   1/4 0  ', 'x   1/8 1/8',
     8 'x   1/4 1/8', 'x   3/4 1/4', 'x   0   1/3', 'x   0   5/6',
     9 'x   0   2/3', 'x   0   1/6', '1/2 y   1/2', '0   y   1/2',
     * '1/2 y   0  ', '0   y   0  ', '1/2 y   1/4', '0   y   1/4',
     1 '1/4 y   1/4', '1/4 y   0  ', '3/4 y   1/4', '1/4 y   1/2',
     2 '1/8 y   1/8', '1/2 1/2 z  ', '0   1/2 z  ', '1/2 0   z  ',
     3 '0   0   z  ', '1/4 1/4 z  ', '0   1/4 z  ', '1/4 3/4 z  ',
     4 '1/4 1/2 z  ', '1/4 0   z  ', '1/8 1/8 z  ', '3/4 1/4 z  ',
     5 '1/3 2/3 z  ', '2/3 1/3 z  ', 'x   y   1/2', 'x   y   0  ',
     6 'x   y   1/4', 'x   1/2 z  ', 'x   0   z  ', 'x   1/4 z  ',
     7 '1/2 y   z  ', '0   y   z  ', '1/4 y   z  '/)
      CHARACTER(len=15), DIMENSION(39) :: STBB = (/
     1 'x x 0          ', 'x x 1/2        ', 'x x 1/4        ',
     2 'x x 3/4        ', 'x x 3/8        ', 'x x 5/8        ',
     3 'x -x 0         ', 'x -x 1/2       ', 'x -x 1/4       ',
     4 'x -x 1/3       ', 'x -x 2/3       ', 'x -x 1/6       ',
     5 'x -x 5/6       ', 'x 1/2+x 1/4    ', 'x 1/2+x 1/2    ',
     6 'x 1/2+x 0      ', 'x 1/2-x 1/4    ', 'x 1/4+x 1/8    ',
     7 'x 1/4+x 7/8    ', 'x 2x 0         ', 'x 2x 1/2       ',
     8 'x 2x 1/4       ', 'x 2x 3/4       ', '0 y y          ',
     9 '1/2 y y        ', '1/4 y y        ', '0 y -y         ',
     * '1/4 y -y       ', '1/4 y 1/2+y    ', '1/4 y 1/2-y    ',
     1 '1/2 y 1/2+y    ', '1/2 y -y       ', '1/8 y 1/4+y    ',
     2 '1/8 y 1/4-y    ', 'x x x          ', 'x x z          ',
     1 'x -x z         ', 'x 1/2+x z      ', 'x 2x z         '/)
      CHARACTER(len=14), DIMENSION(17) :: STCSH = (/
     1 '3/4 3/4 3/4', '3/4 3/4 0  ', '0 3/4 3/4  ', '1/4 3/4 0  ',
     2 '1/4 1/4 1/4', '1/4 1/4 0  ', '1/4 3/4 1/4', '0 3/4 1/8  ',
     3 '0 1/4 1/8  ', '1/8 1/8 1/8', '3/8 3/8 3/8', '1/4 0 1/4  ',
     4 '1/4 1/4 3/4', '3/4 1/4 1/4', '0 1/4 1/4  ', '0 0 1/4    ',
     5 '0 1/4 0    '/)
      CHARACTER(len=16), DIMENSION(15) :: FORMS = (/
     1 'Triclinic aP    ', 'Monoclinic mP   ', 'Monoclinic mC   ',
     2 'Monoclinic mC(I)', 'Orthorhombic oP ', 'Orthorhombic oC ',
     3 'Orthorhombic oF ', 'Orthorhombic oI ', 'Tetragonal tP   ',
     4 'Tetragonal tI   ', 'Hexagonal hP    ', 'Rhombohedral hR ',
     5 'Cubic cP        ', 'Cubic cF        ', 'Cubic cI        '/)
      CHARACTER(len=8), DIMENSION(12) :: KOORD = (/
     1 ' 0     ',' 1/2   ',' 1/4   ',' 3/4   ',' 1/8   ', ' 3/8   ',
     2 ' 5/8   ',' 7/8   ',' 1/3   ',' 2/3   ',' 1/6   ', ' 5/6   '/)
      CHARACTER(len=3), DIMENSION(9) :: CHORI = (/
     1 '1/8', '1/4', '3/8', '1/2', '5/8', '3/4', '7/8', '1/3', '2/3'/)
      CHARACTER(len=17), DIMENSION(21)       :: STTEXT = (/
     1 'x,y,z            ', '-x,y,-z          ', '-x,-y,z          ',
     2 'x,-y,-z          ', 'y,x,-z           ', '-y,-x,-z         ',
     3 '1/4-y,1/4-x,1/4-z', '-x,1/2-y,-z      ', '-y,1/2-x,z       ',
     4 '1/4-x,1/4-y,1/4-z', '-x,-y,-z         ', 'x,-y,z           ',
     5 'x,y,-z           ', '-x,1/2-y,1/4-z   ', '-y,-x,z          ',
     6 'y,x,z            ', '1/4+y,1/4+x,1/4+z', 'x,-z,y           ',
     7 '-z,y,x           ', '-x,z,-y          ', 'z,-y,-x          '/)
 
      CHARACTER(len=1),  DIMENSION(6)        :: LATTICE = (/
     1 'a', 'm', 'o', 't', 'h', 'c'/)
 
      END MODULE stidy
 
      SUBROUTINE PLA301 (MODE)
C * STRUCTURE TIDY: Program to Standardize Structure Data.
C * See E. Parthe & L.M. Gelato (1984). Acta Cryst. A40, 169-183
C *     L.M. Gelato & E. Parthe (1987). J. Appl. Cryst. 20, 139-143.
C *     S-Z.Hu & E.Parthe (2004). Chinese J. Struct. Chem. 23, 1150-1160
      USE files
      USE parameters
      USE cchar
      USE xwdw
      USE cggt
      USE plato
      USE stidy
 
C * NUMAT = maximum number of atoms in asymmetric unit
C * NELTS = maximum number of different elements
C *         (for displacement and Pearson code)
C * NTOT  = maximum number of atoms
      IMPLICIT NONE
      INTEGER                      :: I
      INTEGER                      :: J
      INTEGER                      :: K
      INTEGER                      :: L
      INTEGER                      :: M
      INTEGER                      :: N
      INTEGER                      :: I1
      INTEGER                      :: IA
      INTEGER                      :: IC
      INTEGER                      :: IK
      INTEGER                      :: NP
      INTEGER                      :: KOR
      INTEGER                      :: IBL
      INTEGER                      :: IER
      INTEGER                      :: IFS
      INTEGER                      :: ISH
      INTEGER                      :: MIX
      INTEGER                      :: NCS
      INTEGER                      :: NIG
      INTEGER                      :: IORG
      INTEGER                      :: NOR2
      INTEGER                      :: NIGG
      INTEGER                      :: ISEQ
      INTEGER                      :: IDIS
      INTEGER                      :: IDUM
      INTEGER                      :: JDUM
      INTEGER                      :: MODE
      INTEGER                      :: IPOP
      INTEGER                      :: IROT
      INTEGER                      :: KEER
      INTEGER                      :: KELT
      INTEGER                      :: NTIO
      INTEGER                      :: NSAVE
      INTEGER                      :: MKORD
      INTEGER                      :: KSAVE
      INTEGER                      :: ISMIN
      INTEGER                      :: NTRANS
      INTEGER                      :: IPEARS
      INTEGER                      :: IFSHIF
      INTEGER                      :: IMPCEL
      INTEGER                      :: NAGAIN
      INTEGER                      :: LRET319
      INTEGER                      :: LRET330
      INTEGER, DIMENSION(NUMAT)    :: NSP
      INTEGER, DIMENSION(4)        :: IARX   = (/6, 5, 3, 1/)
      INTEGER, DIMENSION(4)        :: NIGAR1 = (/19, 18, 5, 1/)
      INTEGER, DIMENSION(4)        :: NIGAR2 = (/21, 20, 15, 11/)
      REAL                         :: V
      REAL                         :: AH
      REAL                         :: CH
      REAL                         :: DET
      REAL                         :: FMU
      REAL                         :: FNX
      REAL                         :: EPS
      REAL                         :: XSUM
      REAL                         :: VOL1
      REAL                         :: EPS1
      REAL                         :: PMIN
      REAL,    DIMENSION(3)        :: PL
      REAL,    DIMENSION(NELTS)    :: PEAR
      REAL,    DIMENSION(3)        :: ORIG
      REAL,    DIMENSION(3, 3)     :: SSAVE
      REAL,    DIMENSION(3)        :: TOTSH
      REAL,    DIMENSION(3, NUMAT) :: FINXYZ
      CHARACTER(len=1)             :: KO
      CHARACTER(len=50)            :: DAT
      CHARACTER(len=1)             :: ANSR
      CHARACTER(len=80)            :: INTEXT
C * LOAD INTERNAL TABULATED DATA
      CALL PLA327
C * RUN STIDY ON .sty FILE CREATED BY PLATON
      IF (MODE > 0) THEN
C * SET NOMOVE ON
        IGBL(30) = 1
C * ROUND OFF
        IPR(68)  = 0
        EXTENS   = 'sty'
        KXT      = 3
C * SET UP CONNECTED SET
        CALL PLA067
        IF (IPR(2) /= 0) RETURN
C * CREATE .sty FILE
        OPEN (UNIT = LU64,
     1    FILE = NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT),
     2    STATUS = 'UNKNOWN')
C * SPGR
        IDM = SPGRNM(1)(15:26)
        CALL GEN020 (1, IDM, 1, 16)
        WRITE (LU64, 99956, IOSTAT = IOST) IDM(1:16), JID(1:40)
C * CELL
        WRITE (LU64, 99955, IOSTAT = IOST) (PAR(I), I = 101, 106)
C * HANDLE ORIGIN CHOICE (1, 2) CASES
        IF (IPR(202) /= 0) THEN
          IW = ISETS (NPSPGR(IPR(202) + 1))
          IF (IW < 0 .OR. IW == 15) THEN
            WRITE (LU64, 99951, IOSTAT = IOST)
          END IF
        END IF
C * ATOMS
        DO I = 1, IPR(37)
          CALL GEN048 (-8, IFG(2, I), 1, IPOP)
          IDIS = IPPR (IPOP + 1, 1)
          CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, 0, 0, 0, 0)
          IF (IDIS < 10000) THEN
            WRITE (LU64, 99954, IOSTAT = IOST) NQ1(1:6),
     1        (XXO(I, J), J = 1, 3), IDIS / 10000.0
          ELSE
            WRITE (LU64, 99954, IOSTAT = IOST) NQ1(1:6),
     1        (XXO(I, J), J = 1, 3)
          END IF
        END DO
        WRITE (LU64, 99953, IOSTAT = IOST)
        REWIND (UNIT = LU64, IOSTAT = IOST)
        WRITE (LU6, 99952, IOSTAT = IOST)
     1    NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT)
C * RUN STIDY ON EXTERNALLY SUPPLIED .sty FILE
      ELSE
        IF (EXTENS(1:3) /= 'sty' .AND. EXTENS(1:3) /= 'STY') THEN
          WRITE (LU6, 99964, IOSTAT = IOST)
          WRITE (LU7, 99996, IOSTAT = IOST)
          RETURN
        END IF
        OPEN (UNIT = LU64, FILE = NAMEFIL(1:KNMFIL)//'.'//EXTENS(1:KXT),
     1        STATUS = 'UNKNOWN')
      END IF
C * FILE HANDLING
      INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.lis', OPENED = OPEND)
      IF (.NOT. OPEND) THEN
        OPEN (LU7, FILE = NAMEFIL(1:KNMFIL)//'.lis', STATUS = 'UNKNOWN')
      END IF
      OPEN (UNIT = LU21, FILE = NAMEFIL(1:KNMFIL)//'_stidy.spf',
     1 STATUS = 'UNKNOWN')
      OPEN (UNIT = LU60, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      OPEN (UNIT = LU61, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      OPEN (UNIT = LU63, STATUS = 'SCRATCH')
C * OPEN GRAPHICS WINDOW
      IWIN = IGBL(25) * IGBL(32)
      IF (IWIN == 1) THEN
        BCD = 'Stucture Tidy'//CHAR (0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL PLA439 (0.0,  BCD, 14, 1.0, 4, 6, 7.6, VERT - 1.5)
        CALL PLA439 (0.0,  BCD, 14, 1.0, 2, 6, 7.5, VERT - 1.6)
        VRT = VERT - 2.0
      END IF
      PAGET = 'STR-TIDY'
      CALL PLA262 (0)
      WRITE (LU7, 99966, IOSTAT = IOST)
      CALL PLA262 (6)
C * INITIALIZE SOME FLAGS. IMPCEL = 1 IF IMPOSED CELL (+ BEFORE SPGR)
      IMPCEL = 0
      NIG    = 0
      IC     = 0
      MIX    = 0
      RRX    = RGBL(6)
      NIGG   = 0
      IFSHIF = 0
      IPOL   = 0
      INTXT  = ' '
C * BLANK SPGR NAME STRING
      CALL GEN126 (NT, 1, 16)
C * READ TECHNICAL DETAILS ABOUT INPUT/OUTPUT:
      READ (LU64, 99995, IOSTAT = IOST) INTEXT
      IF (IOST /= 0) GO TO 70
C * CONVERT TO UPPER CASE
      CALL GEN020 (1, INTEXT, 1, 16)
C * MIX = 1 will indicate mixed atom-site has been read.
      N   = 0
      IBL = 0
      DO J = 1, 80
        IF (INTEXT(J:J) == '*') THEN
          NIG         = 1
          INTEXT(J:J) = ' '
        ELSE IF (INTEXT(J:J) == '+') THEN
          IMPCEL      = 1
          INTEXT(J:J) = ' '
        ELSE IF (INTEXT(J:J) == ' ') THEN
          IF (N /= 0) THEN
            IBL = IBL + 1
            IF (IBL == 2) EXIT
            N     = N + 1
            NT(N) = ' '
          END IF
        ELSE
C * COLLECT SPACE GROUP NAME
          N = N + 1
          IF (N > 16) GO TO 70
          NT(N)       = INTEXT(J:J)
          INTEXT(J:J) = ' '
          IBL         = 0
        END IF
      END DO
      MKORD = 28
C * COPY/REPORT TITL TEXT AND SPACE GROUP NAME
      INTXT(1:40) = INTEXT(16:55)
      WRITE (LU7, 99999, IOSTAT = IOST) INTXT, NT
      CALL PLA262 (2)
C * CHECK/REPORT IMPOSED CELL
      IF (IMPCEL == 1) THEN
        CALL PLA262 (3)
        WRITE (LU7,  99993, IOSTAT = IOST)
        WRITE (LU6,  99993, IOSTAT = IOST)
        WRITE (LU63, 99992, IOSTAT = IOST)
      END IF
      WRITE (LU63, 99991, IOSTAT = IOST) INTXT
C * INITIALISATIONS:
      CALL GEN021 (XMAT,  1.0)
      CALL GEN074 (PLUS,  1, 3, 0.0)
      CALL GEN074 (SH,    1, 3, 0.0)
      CALL GEN074 (PEAR,  1, NELTS, 0.0)
      CALL GEN097 (NRSET, 1, NUMAT, 0)
      CALL GEN126 (FOCCU, 1, NUMAT)
      CALL GEN074 (UVW,   1, 9, 0.0)
      UVW(1)   = 1.0
      UVW(5)   = 1.0
      UVW(9)   = 1.0
      KO       = ' '
      CODE(1)  = ' '
      CODE(2)  = ' '
      IPEARS   = 0
      GMIN     = 1000000.0
      PMIN     = 0.0
      VOLRAT   = 0.0
      AXS      = 'abc'
      IFSH     = 0
      IFPLUS   = 0
      IFNG(1)  = 0
      IHEX     = 0
      IOCFL    = 0
      NABC     = 0
      NSH      = 0
      NSHTRA   = 0
C * NFL = 1 indicates that setting -x,-y,-z is not considered
C * (case of enantiomorphic space group reduced to P1)
      NFL = 0
      IF (IFSHIF == 1) IFSH = 1
      IF (NIGG   == 1) NIG  = 1
C * READ/REPORT CELL PARAMETERS
      READ  (LU64, 99998, IOSTAT = IOST) A, B, C, AL, BE, GA
      IF (IOST /= 0) GO TO 70
      CALL PLA262 (1)
      WRITE (LU7, 99997, IOSTAT = IOST) A, B, C, AL, BE, GA
C * SPGR
      IER = 0
      CALL PLA302 (NCS, NTRANS, LU7, LU63, IER)
      IF (IER /= 0) THEN
        WRITE (LU6, 99967, IOSTAT = IOST)
        GO TO 80
      END IF
C * REPORT ORIGIN SHIFT WHERE APPROPRIATE
      IF (NSHTRA > 0) THEN
        CALL PLA262 (1)
        WRITE (LU7, 99990, IOSTAT = IOST) STCSH(NSHTRA)
        WRITE (LU6, 99990, IOSTAT = IOST) STCSH(NSHTRA)
      END IF
      N     = NPSPGR(NGR)
      IW    = ISETS (N + 1)
      IROT  = ISETS (N + 2)
      NTIO  = ISETS (N + 3)
      NSPEC = ISETS (N + 4)
      NW    = ISETS (N + 5)
      ISH   = ISETS (N + 6)
      DO J = 1, NSPEC
        NS(J) = ISETS(N + J + 6)
        IS(J) = ISETS(N + J + NSPEC + 6)
      END DO
      DO J = 1, NW
        MULT(J) = ISETS(N + J + 2 * NSPEC + 6)
      END DO
      IS(NSPEC + 1) = NW
      IF (IMPCEL == 0) THEN
C * BACK TO CELL PARAMETERS : RHOMBOHEDRAL SETTING ?
        IF (IW == 16) THEN
          IF (AL > 0.0 .AND. AL /= 90.0) THEN
            CALL PLA262 (1)
            WRITE (LU7, 99989, IOSTAT = IOST) A, AL
C * COMPUTE HEXAGONAL CELL PARAMETERS FROM RHOMBOHEDRAL INPUT
            AL   = AL / RRX
            AH   = 2.0 * A * SIN (0.5 * AL)
            CH   = 1.73205 * A * SQRT (1.0 + 2.0 * COS (AL))
            IHEX = 1
            A    = AH
            C    = CH
            AXS  = 'a-b,b-c,a+b+c'
            CALL PLA262 (1)
            WRITE (LU7, 99988, IOSTAT = IOST) A, C
            IFNG(2)   = 2
            UVW(1) =  1.0
            UVW(2) = -1.0
            UVW(3) =  0.0
            UVW(4) =  0.0
            UVW(5) =  1.0
            UVW(6) = -1.0
            UVW(7) =  1.0
            UVW(8) =  1.0
            UVW(9) =  1.0
            CALL GEN003 (UVW, XMAT, DET, -2)
          END IF
          IF (IFNG(2) > 0) THEN
            CALL PLA262 (1)
            WRITE (LU7, 99987, IOSTAT = IOST) NGR, SPGR
          END IF
        END IF
      END IF
C * Adjust cell parameters and compute volume of unit cell
C * ic = 1..6 means: a,m,o,t,h,c
      VOL  = 0.0
      ALF  = AL / RRX
      BET  = BE / RRX
      GAM  = GA / RRX
      COSB = COS (BET)
      IF (NGR <= 2) THEN
        IC   = 1
        COSA = COS (ALF)
        COSG = COS (GAM)
        V = 1.0 - COSA**2 - COSB**2 - COSG**2 + 2.0 * COSA * COSB * COSG
        IF (V > 0.0001) VOL = A * B * C * SQRT (V)
      ELSE
        AL   = 90.0
        GA   = 90.0
        COSA = 0.0
        COSG = 0.0
        ALF  = 90.0 / RRX
        GAM  = ALF
        IF (NGR >= 3 .AND. NGR <= 15) THEN
          IC  = 2
          VOL = A * B * C * SIN (BET)
          IF (IMPCEL == 1) GO TO 10
          IF (BE < 90.0) THEN
            BE    = 180.0 - BE
            BET   = BE / RRX
            COSB  = - COSB
            IFNG(2) = 2
            CALL GEN074 (U9, 1, 9, 0.0)
            U9(1) = -1.0
            U9(5) = -1.0
            U9(9) =  1.0
            CALL GEN004 (UVW, U9, P9)
C * COPY VECTOR
            CALL GEN113 (P9, UVW, 9)
            CALL PLA262 (2)
            WRITE (LU7, 99963, IOSTAT = IOST) BE
          END IF
        ELSE
          BE   = 90.0
          COSB = 0.0
          BET  = 90.0 / RRX
          IF (NGR >= 16 .AND. NGR <= 74) THEN
            IC  = 3
            VOL = A * B * C
          ELSE
            B = A
            IF (NGR >= 75 .AND. NGR <= 142) THEN
              IC  = 4
              VOL = A * A * C
            ELSE IF (NGR >= 143 .AND. NGR <= 194) THEN
              GA   = 120.0
              GAM  = GA / RRX
              COSG = -0.5
              IC   = 5
              VOL  = 0.86603 * A * A * C
            ELSE IF (NGR >= 195) THEN
              C   = A
              IC  = 6
              VOL = A**3
            END IF
          END IF
        END IF
      END IF
      IF (VOL < 0.0001) THEN
        CALL PLA262 (1)
        WRITE (LU7, 99962, IOSTAT = IOST)
        GO TO 80
      END IF
      IF (IMPCEL == 0) THEN
        IF (IFNG(2) == 2) THEN
          CALL GEN003 (UVW, XMAT, DET, -2)
C * CONVERT UVW INTO CHARACTER STRING
          CALL PLA309 (UVW)
        END IF
        IAT = 0
C * OPTION FOR NIGGLI-REDUCED CELL :
        IF (NIG == 1) THEN
          VOL1 = VOL
          ISH  = 0
          IW   = 1
          IROT = 1
C * COPY MATRICES
          CALL GEN052 (UVW,   SSAVE)
          CALL GEN052 (XMAT, XMSAVE)
          WRITE (LU63, 99986, IOSTAT = IOST)
          IFNG(1) = 0
          CALL PLA311 (1)
          IF (IFNG(1) == 2) THEN
            CALL GEN003 (UVW, XMAT, DET, -2)
C * CONVERT UVW INTO CHARACTER STRING
            CALL PLA309 (UVW)
          END IF
C * If originally changed from enantiomorphic space group, adjust UVW :
          IF (IFNG(2) == 1) THEN
            DO K = 1, 9
              UVW(K) = - UVW(K)
            END DO
          END IF
C * ADJUST TRANSFORMATION MATRIX
          DO K = 1, 9
            U9(K) = UVW(K)
          END DO
          DO I = 1, 3
            DO J = 1, 3
              K    = (I - 1) * 3 + J
              T9(K) = SSAVE(J, I)
            END DO
          END DO
          CALL GEN004 (T9, U9, P9)
C * CONVERT 'P' INTO CHARACTER STRING
          CALL PLA309 (P9)
          CALL PLA262 (2)
          WRITE (LU7, 99983, IOSTAT = IOST) AXS
          CALL PLA320 (ISEQ, LU7)
          CALL PLA262 (5)
          WRITE (LU7, 99982, IOSTAT = IOST) ISEQ, FORMS(IFORM(ISEQ))
          IF (ABS (A - B) < 0.005) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99981, IOSTAT = IOST) 'a', 'b'
            IF (ABS (A - C) < 0.005) THEN
              CALL PLA262 (4)
              WRITE (LU7, 99981, IOSTAT = IOST) 'b', 'c'
              WRITE (LU7, 99981, IOSTAT = IOST) 'a', 'c'
            END IF
          ELSE IF (ABS (B - C) < 0.005) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99981, IOSTAT = IOST) 'b', 'c'
          ELSE IF (ABS (A - C) < 0.005) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99981, IOSTAT = IOST) 'a', 'c'
          END IF
          IER = 0
          CALL PLA303 (PEAR, IPEARS, PMIN, KELT, NCS, NTIO, IER)
          IF (IER == 1) GO TO 80
          IS(NSPEC + 1) = NW
          VOL = A * B * C * SQRT (1.0 - COSG**2 - COSB**2 - COSA**2
     1        + 2.0 * COSA * COSB * COSG)
          VOLRAT = VOL / VOL1
          GO TO 40
        END IF
      END IF
C * FIRST LETTER OF PEARSON SYMBOL
   10 CODE(1) = LATTICE(IC)
C * SECOND LETTER OF PEARSON SYMBOL
      KO = SPGR(1:1)
      IF (KO == 'A' .OR. KO == 'C') KO = 'S'
      CODE(2) = KO
      IF (IMPCEL == 0) THEN
        IF (IW /= 0 .AND. IW /= 16) CALL PLA314
        IF (IFNG(2) == 2) THEN
          CALL GEN003 (UVW, XMAT, DET, -2)
C * CONVERT UVW INTO CHARACTER STRING
          CALL PLA309 (UVW)
        END IF
        IF (NSH > 0) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99984, IOSTAT = IOST) STCSH(NSH)
        END IF
        IF (NABC > 0) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99985, IOSTAT = IOST) STCSH(NABC)
        END IF
C * If for a triclinic structure the axes are similar, give warning:
        IF (IW == 1) THEN
          IF (ABS(A - B) < 0.005) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99981, IOSTAT = IOST) 'a', 'b'
            IF (ABS (A - C) < 0.005) THEN
              CALL PLA262 (4)
              WRITE (LU7, 99981, IOSTAT = IOST) 'b', 'c'
              WRITE (LU7, 99981, IOSTAT = IOST) 'a', 'c'
            END IF
          ELSE IF (ABS (B - C) < 0.005) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99981, IOSTAT = IOST) 'b', 'c'
          ELSE IF (ABS (A - C) < 0.005) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99981, IOSTAT = IOST) 'a', 'c'
          END IF
        END IF
C * extra originshift if structure not in setting with origin at centre
        IF (IFSH > 0) THEN
          DO J = 1, 3
            SH(J) = XSHIFT(J, ISH)
          END DO
          CALL PLA262 (4)
          WRITE (LU7, 99978, IOSTAT = IOST) STCSH(ISH)
        END IF
      END IF
      CALL PLA306 (NGR)
      NATOM = 0
      KELT  = 0
C * ATOM READ LOOP
   20 IER = 0
      CALL PLA304 (NIG, IER)
      IF (IER == 0) THEN
C * control element name for mixed site (only if not already found):
        IF (MIX /= 1) THEN
          DO I = 1, 105
            IF (ELT1 == XELN(I)) EXIT
          END DO
          MIX = 1
        END IF
C * Generates all atompositions for given space group
        CALL PLA322
        KSET = 0
        IF (NSPEC == 0) THEN
          MU   = MULT(1)
          KORD = 1
          CALL PLA262 (1)
          WRITE (LU7, 99977, IOSTAT = IOST) MU, CHAR (97)
        ELSE
          CALL PLA324 (NIG)
        END IF
C * mkord gives highest symmetry site of structure.
        IF (KORD < MKORD) MKORD = KORD
C * number of atoms for Pearson code :
        FMU    = FLOAT (MU)
        FNX    = FNUM * FMU
        PMIN   = PMIN + FMU - FNX
        IPEARS = IPEARS + MU
        IF (KELT > 0) THEN
          DO I = 1, KELT
            IF (ELT1 == ELT(I)) GO TO 30
          END DO
        END IF
        KELT = KELT + 1
        IF (KELT > NELTS) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99976, IOSTAT = IOST) NELTS
          KELT = KELT - 1
        END IF
        ELT(KELT) = ELT1
        I         = KELT
   30   PEAR(I)   = PEAR(I) + FNX
        NATOM     = NATOM + 1
        IF (NATOM <= NUMAT) THEN
          KKORD(NATOM) = KORD
          ATOM1(NATOM) = ELT1
          ATOM2(NATOM) = ELT2
          FOCCU(NATOM) = FFF
          DO J = 1, 3
            XA(J, NATOM) = XYZ(J, 1)
          END DO
          NRSET(NATOM) = KSET
          IF (KSET > 0) THEN
            DO I = 1, KSET
              NNSET(I, NATOM) = NSET(I)
            END DO
          END IF
C * next atom:
          GO TO 20
        ELSE
C * the program allows only NUMAT atoms in input.
          CALL PLA262 (1)
          WRITE (INTEXT, 99975, IOSTAT = IOST) NUMAT
          IF (IWIN == 1)
     1      CALL PLA439 (0.0, INTEXT, 70, 0.35, 1, 3, 1.0, 12.5)
          WRITE (LU6, 99980, IOSTAT = IOST) INTEXT
          WRITE (LU7, 99980, IOSTAT = IOST) INTEXT
          GO TO 80
        END IF
C * POLAR group ?
      END IF
      IPOL   = 1
      ICOORD = 0
C * NOR < 0 if polar group:
      IF (NOR < 0) THEN
        IPOL = 0
        DAT  = ' '
        ANSR = 'N'
        IF (ANSR == 'N' .or. ANSR == 'n') THEN
          IF (DAT == ' ') THEN
            ORGA(1) = 0.0
            ORGA(2) = 0.0
            ORGA(3) = 0.0
          ELSE
            READ (DAT, *) (ORGA(L), L = 1, 3)
          END IF
          IPOL = 1
          NOR  = 1
          DO J = 1, 3
            ORGADD(J, 1) = ORGA(J)
          END DO
          CALL PLA262 (1)
          WRITE (LU7, 99972, IOSTAT = IOST) ORGA
        END IF
      END IF
C * compute origin shifts for polar groups:
   40 IF (NOR < 0) THEN
        NOR2   = - NOR
        M      = NOR2 / 10
        NOR    = NOR2 - 10 * M
        ICOORD = M + 1
      END IF
      NSAVE = NOR
      REWIND (UNIT = LU61, IOSTAT = IOST)
C * Compute number of rotations of coordinate system
      NAGAIN = 0
      KEER   = 1
      IF (IROT > 1 .AND. IROT < 8) KEER = 2
      IF (IROT == 8) KEER = 4
      KSAVE = KEER
C * Rotation/inversion of coordinate system:
   50 IF (NAGAIN == 0) THEN
        IF (IROT < 8) THEN
          IF (KEER == 2) THEN
            NTEXT = 1
          ELSE
            NTEXT = IROT
          END IF
        ELSE IF (IROT == 18 .OR. IROT == 19) THEN
          NTEXT = IROT
          IF (KEER == 2) NTEXT = 1
        ELSE IF (IROT == 20) THEN
          NTEXT = NIGAR1(KEER)
        ELSE
         NTEXT = IARX(KEER)
        END IF
      ELSE
        IF (NTIO == 1) THEN
          IF (IROT < 8) THEN
            IF (KEER == 2) THEN
              NTEXT = 11
            ELSE
              NTEXT = 10 + IROT
            END IF
          ELSE IF (IROT == 18 .OR. IROT == 19) THEN
            NTEXT = IROT + 2
            IF (KEER == 2) NTEXT = 11
          ELSE IF (IROT == 20) THEN
            NTEXT = NIGAR2(KEER)
          ELSE
            NTEXT = IARX(KEER) + 10
          END IF
        ELSE IF (NTIO == 2) THEN
          NTEXT = 8
          IF (KEER == 2) NTEXT = 9
        ELSE IF (NTIO == 3) THEN
          NTEXT = 10
          IF (KEER == 2) NTEXT = 17
        ELSE IF (NTIO == 4) THEN
          NTEXT = 14
        END IF
      END IF
      DO J = 1, 3
        PL(J) = 2 * PLUS(J)
        DO WHILE (PL(J) > 0.99999)
          PL(J) = PL(J) - 1.0
        END DO
      END DO
C * for space groups 85, 86 & 88 settings yx-z & x-y-z give problem
C * if originshift for centrosymmetric setting: take negative shift.
C * put sh in shif in order to preserve original shift.
      IF (NTEXT > 17) CALL GEN113 (SH, SHIF, 3)
C * 1: x y z
      IF (NTEXT == 1 .OR. NTEXT > 17) THEN
        DO IA = 1, NATOM
          CALL GEN080 (XA, XROT, IA, IA)
        END DO
C * 2: -x y -z
      ELSE IF (NTEXT == 2) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0 - XA(1, IA) + PL(1)
          XROT(3, IA) = 1.0 - XA(3, IA) + PL(3)
          XROT(2, IA) = XA(2, IA)
        END DO
C * 3: -x -y z
      ELSE IF (NTEXT == 3) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0 - XA(1, IA) + PL(1)
          XROT(2, IA) = 1.0 - XA(2, IA) + PL(2)
          XROT(3, IA) = XA(3, IA)
        END DO
C * 4: x -y -z
      ELSE IF (NTEXT == 4) THEN
        SHIF(2) = 1.0 - SH(2)
        SHIF(3) = 1.0 - SH(3)
        DO IA = 1, NATOM
          XROT(2, IA) = 1.0 - XA(2, IA) + PL(2)
          XROT(3, IA) = 1.0 - XA(3, IA) + PL(3)
          XROT(1, IA) = XA(1, IA)
        END DO
C * 5: y x -z
      ELSE IF (NTEXT == 5) THEN
        SHIF(1) = SH(2)
        SHIF(2) = SH(1)
        SHIF(3) = 1.0 - SH(3)
        DO IA = 1, NATOM
          XROT(1, IA) = XA(2, IA)
          XROT(2, IA) = XA(1, IA)
          XROT(3, IA) = 1.0 - XA(3, IA) + PL(3)
        END DO
C * 6: -y -x -z
      ELSE IF (NTEXT == 6) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0 - XA(2, IA) + PL(1)
          XROT(2, IA) = 1.0 - XA(1, IA) + PL(2)
          XROT(3, IA) = 2.0 - XA(3, IA) + PL(3)
        END DO
C * 7: 1/4-y 1/4-x 1/4-z
      ELSE IF (NTEXT == 7) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 0.25 - XA(2, IA) + PL(1)
          XROT(2, IA) = 0.25 - XA(1, IA) + PL(2)
          XROT(3, IA) = 1.25 - XA(3, IA) + PL(3)
        END DO
C * 8: -x 1/2-y -z
      ELSE IF (NTEXT == 8) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0 - XA(1, IA) + PL(1)
          XROT(2, IA) = 0.5 - XA(2, IA) + PL(2)
          XROT(3, IA) = 1.0 - XA(3, IA) + PL(3)
        END DO
C * 9: -y 1/2-x z
      ELSE IF (NTEXT == 9) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0 - XA(2, IA) + PL(2)
          XROT(2, IA) = 0.5 - XA(1, IA) + PL(3)
          XROT(3, IA) = XA(3, IA)
        END DO
C * 10: 1/4-x 1/4-y 1/4-z
      ELSE IF (NTEXT == 10) THEN
        DO IA = 1, NATOM
          DO J = 1, 3
            XROT(J, IA) = 0.25 - XA(J, IA) + PL(J)
          END DO
        END DO
C * 11: -x -y -z
      ELSE IF (NTEXT == 11) THEN
        DO IA = 1, NATOM
          DO J = 1, 3
            XROT(J, IA) = 1.0 - XA(J, IA) + PL(J)
          END DO
        END DO
C * 12: x -y z
      ELSE IF (NTEXT == 12) THEN
        DO IA = 1, NATOM
          DO J = 1, 3, 2
            XROT(J, IA) = XA(J, IA)
          END DO
          XROT(2, IA) = 1.0 - XA(2, IA) + PL(2)
        END DO
C * 13: x y -z
      ELSE IF (NTEXT == 13) THEN
        DO IA = 1, NATOM
          DO J = 1, 2
            XROT(J, IA) = XA(J, IA)
          END DO
          XROT(3, IA) = 1.0 - XA(3, IA) + PL(3)
        END DO
C * 14: -x 1/2-y 1/4-z
      ELSE IF (NTEXT == 14) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0  - XA(1, IA) + PL(1)
          XROT(2, IA) = 0.5  - XA(2, IA) + PL(2)
          XROT(3, IA) = 0.25 - XA(3, IA) + PL(3)
        END DO
C * 15: -y -x z
      ELSE IF (NTEXT == 15) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 1.0 - XA(2, IA) + PL(2)
          XROT(2, IA) = 1.0 - XA(1, IA) + PL(1)
          XROT(3, IA) = XA(3, IA)
        END DO
C * 16: y x z
      ELSE IF (NTEXT == 16) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = XA(2, IA)
          XROT(2, IA) = XA(1, IA)
          XROT(3, IA) = XA(3, IA)
        END DO
C * 17: 1/4+y 1/4+x 1/4+z
      ELSE IF (NTEXT == 17) THEN
        DO IA = 1, NATOM
          XROT(1, IA) = 0.25 + XA(2, IA)
          XROT(2, IA) = 0.25 + XA(1, IA)
          XROT(3, IA) = 0.25 + XA(3, IA)
        END DO
      END IF
C * SET COORDINATES WITHIN THE 0.0 TO 1.0 RANGE
      DO J = 1, NATOM
        DO i = 1, 3
          IF (XROT(I, J) > 0.99999) XROT(I, J) = XROT(I, J) - 1.0
          IF (XROT(I, J) <     0.0) XROT(I, J) = XROT(I, J) + 1.0
        END DO
      END DO
      IF (NTEXT > 0) THEN
        CALL PLA262 (0)
        CALL PLA262 (2)
        WRITE (LU7, 99971, IOSTAT = IOST) STTEXT(NTEXT)
      END IF
      NOR = NSAVE
      IF (IPOL == 0) THEN
C * This routine prepares data for PLA319 where origin shifts for
C * polar space groups are computed.
        CALL GEN097 (NAT, 1, NTOT, 0)
        ISMIN = IS(MKORD)
C * Find which is 'lowest' Wyckoff letter in set ismin:
        LOWLET = 27
        DO J = 1, 27
          IF (IS(J) == ISMIN) THEN
            IF (J < LOWLET) LOWLET = J
          END IF
        END DO
C * put coordinates of atoms in with highest symmetry in array xp :
        NPOLX = 0
        DO IA = 1, NATOM
          DO J = 1, 3
            POS(J) = XROT(J, IA)
          END DO
C * Generates all atompositions for given space group
          CALL PLA322
          KOR = KKORD(IA)
          N   = IS(KOR)
          IF (N == ISMIN) THEN
            DO J = 1, KOUNT
              NPOLX = NPOLX + 1
              IF (NPOLX > NTOT) THEN
                WRITE (LU7, 99958, IOSTAT = IOST)
                GO TO 80
              END IF
              NAT(NPOLX) = IA
              DO K = 1, 3
                XP(K, NPOLX) = XYZ(K, J)
              END DO
            END DO
          END IF
        END DO
        CALL PLA262 (4)
        WRITE (LU7, 99961, IOSTAT = IOST)
        WRITE (LU7, 99960, IOSTAT = IOST)
     1    (I, (XP(J, I), J = 1, 3), I = 1, NPOLX)
C * ik is number of degenerate directions.
        IK = ICOORD - 1
        IF (IK == 0) IK = 1
C * i1 indicates degenerate direction we are treating
        I1 = 3
        IF (ICOORD == 2) I1 = 2
C * for all nor origins, find origin in degenerate direction(s) :
C * copy orgadd into orga :
        DO IORG = 1, NOR
          DO J = 1, 3
            ORGA(J) = ORGADD(J, IORG)
          END DO
          CALL PLA262 (4)
          WRITE (LU7, 99959, IOSTAT = IOST) STTEXT(NTEXT), ORGA
          LRET319 = 0
          CALL PLA319 (I1, IK, LRET319)
          IF (LRET319 == 1) GO TO 80
        END DO
      ELSE
C * APPLY ORIGIN SHIFTS
        DO 60 IORG = 1, NOR
          IF (IPR(83) > 5) CALL PLA262 (0)
          CALL PLA262 (2)
          WRITE (LU7, 99969, IOSTAT = IOST)
     1      IORG, (ORGADD(J, IORG), J = 1, 3)
          XSUM = 0.0
          DO IA = 1, NATOM
            ELT1 = ATOM1(IA)
            ELT2 = ATOM2(IA)
            DO j = 1, 3
              POS(J) = XROT(J, IA) - ORGADD(J, IORG)
              EPS    = -0.000001
              EPS1   = 1.0 + eps
              IF (POS(J) < EPS)   POS(J) = POS(J) + 1.0
              IF (POS(J) >= EPS1) POS(J) = POS(J) - 1.0
            END DO
C * GENERATE ALL ATOM POSITIONS FOR THE GIVEN SPACEGROUP
            CALL PLA322
            CALL PLA262 (4)
            WRITE (LU7, 99970, IOSTAT = IOST) ELT1, ELT2
C * CHOOSE REPRESENTATIVE TRIPLET.
            KORD    = 0
            IPOLAR  = 0
            LRET330 = 0
            CALL PLA326 (IA, NP, LU7, LRET330)
            IF (LRET330 == 0) NSP(IA) = NP
            IF (IFLAG == 1) THEN
              CALL PLA262 (5)
              WRITE (LU7, 99970, IOSTAT = IOST) ELT1, ELT2
              WRITE (LU7, 99994, IOSTAT = IOST)
              GO TO 60
            END IF
            DO J = 1, 3
              FINXYZ(J, IA) = XYZ(J, MINI)
            END DO
            MUL(IA) = MU
            LET(IA) = KORD
            XSUM    = XSUM + DMIN
          END DO
          DO I = 1, 3
            ORIG(I) = ORGADD(I, IORG)
          END DO
C * take care of total originshift: for some groups shif and not sh:
          IFS = 1
          IF (NGR == 85 .or. NGR == 86 .or. NGR == 88) THEN
            IF (STTEXT(NTEXT)(1:7) == 'x,-y,-z' .or.
     1          STTEXT(NTEXT)(1:6) == 'y,x,-z') IFS = 2
          ELSE
            IFS = 1
          END IF
          IF (IFSH > 0 .OR. IFPLUS > 0) THEN
            DO I = 1, 3
              IF (IFS == 1) TOTSH(I) = PLUS(I) + SH(I)
              IF (IFS == 2) TOTSH(I) = PLUS(I) + SHIF(I)
              IF (TOTSH(I) >= .9999) TOTSH(I) = TOTSH(I) - 1.0
              ORIG(I) = ORIG(I) + TOTSH(I)
              IF (ORIG(I) >= 0.9999) ORIG(I) = ORIG(I) - 1.0
            END DO
            IF (MINSH > 0) THEN
              ORIG(MINSH) = ORIG(MINSH) - 2 * TOTSH(MINSH)
              DO WHILE (ORIG(MINSH) < 0.0)
                ORIG(MINSH) = ORIG(MINSH) + 1.0
              END DO
            END IF
          END IF
C * MINIMUM GAMMA
          IF (XSUM < GMIN) GMIN = XSUM
          CALL PLA323 (1, IORG, XSUM, FINXYZ, LU7)
          IF (NTEXT > 0) WRITE (LU61, IOSTAT = IOST)
     1      XSUM, STTEXT(NTEXT), (ORIG(K), K = 1, 3)
            IF (IOST /= 0) THEN
              WRITE (LU7, 99968, IOSTAT = IOST)
              GO TO 80
            END IF
          DO I = 1, NATOM
            WRITE (LU61, IOSTAT = IOST) NSP(I),
     1        (FINXYZ(J, I), J = 1, 3), MUL(I), LET(I), FOCCU(I)
            IF (IOST /= 0) THEN
              WRITE (LU7, 99968, IOSTAT = IOST)
              GO TO 80
            END IF
          END DO
   60   CONTINUE
      END IF
      KEER = KEER - 1
      IF (KEER > 0) GO TO 50
      IF (NTIO /= 0 .AND. NAGAIN /= 1) THEN
        KEER   = KSAVE
        NAGAIN = 1
        GO TO 50
      END IF
      CALL PLA318 (IPEARS, PMIN, PEAR, KELT)
      GO TO 80
   70 WRITE (LU6, 99965, IOSTAT = IOST)
C * END-OF-STIDY
   80 WRITE (LU6, 99996, IOSTAT = IOST)
      WRITE (LU7, 99996, IOSTAT = IOST)
      IF (IWIN == 1) THEN
C * WHAT NEXT ?
        CALL PLA012 (1, 1)
      END IF
      CLOSE (UNIT = LU21)
      CLOSE (UNIT = LU60)
      CLOSE (UNIT = LU61)
      CLOSE (UNIT = LU63)
      CLOSE (UNIT = LU64)
      RETURN
99999 FORMAT ('Input Data for     :', A, /,
     1        'Space Group Symbol : ', 16A)
99998 FORMAT (6F10.4)
99997 FORMAT ('Cell Parameters    : ', 3F9.5, 3F8.3)
99996 FORMAT (//, 'End of STRUCTURE TIDY Routine', /)
99995 FORMAT (A)
99994 FORMAT ('No permitted choice of coordinate triplet.')
99993 FORMAT (42('-'), /, 'Standardization with imposed unit cell', /,
     1        42('-'))
99992 FORMAT ('OTHER Standardization with Non-Standard Cell:')
99991 FORMAT ('DATA', 3X, A)
99990 FORMAT ('Origin shift due to change of setting : ', A)
99989 FORMAT ('Rhombohedral cell with a = ', F8.4,'   alpha = ', F8.4)
99988 FORMAT ('Transformed to hexagonal cell : a =', F9.4,
     1        '  c =', F9.4)
99987 FORMAT ('Transformed to setting ', I3, 2X, A, '.')
99986 FORMAT ('REMARK Niggli-reduced cell')
99985 FORMAT ('Extra origin shift due to interchange of axes : ', A, /)
99984 FORMAT ('Extra origin shift due to cell reduction : ', A, /)
99983 FORMAT ('Total transformation = ', A, /)
99982 FORMAT (/, 'Reduced form', I3, ' , which means metrically ',
     1   A, /, ' Transformation matrix to a conventional basis is',
     2 ' given in', /, ' International Tables for Crystallography',
     3 '  Vol.A, Table 9.3.1 (page 742)', /)
99981 FORMAT ('WARNING: Axes ', A, ' and ', A, ' of reduced cell are',
     1 ' very similar.', /)
99980 FORMAT (/, A)
99978 FORMAT (/, 'Origin shift of ', A14, ' is applied in order to',
     1   ' have', /, ' the symmetry centre at the origin.', /)
99977 FORMAT ('General Position ', I3, A1)
99976 FORMAT ('More than', I4, ' different elements in structure,', /,
     1' giving wrong Pearson code and displacements in output.')
99975 FORMAT (' **** Too many atoms in input; the arrays are ',
     1 'limited to', I4, ' atoms ***')
99974 FORMAT (2A)
99972 FORMAT ('Polar group; Imposed origin : ', 3F9.5)
99971 FORMAT (A, /, 17('-'))
99970 FORMAT (/, 12('='), /, 'Atom ', A2, 1X, A4, /, 12('='))
99969 FORMAT (/, 'Origin Shift #', I2, 5X, '(', 3F9.5, ')')
99968 FORMAT (//, 'ERROR  in MAIN while writing on unit LU61')
99967 FORMAT (/, 'ERROR in SPACE GROUP ROUTINE', /)
99966 FORMAT ('Structure Tidy: Standardisation of Inorganic Crystal',
     1        ' Structure Data', /, 80('='), /, 'References: ',
     2 'E.Parthe & L.M.Gelato (1984). Acta Cryst., A40, 169-183.', /,
     3 12X, 'L.M.Gelato & E.Parthe (1987). J. Appl. Cryst. 20, 139-143.'
     4 , /, 12X, 'S-Z.Hu & E.Parthe (2004). Chinese J. Struct. Chem. '
     5 , '23, 1150-1160.', /)
99965 FORMAT (/, ':: Input Error in .sty File.', /)
99964 FORMAT (/, ':: ** .sty Style Files and Extension Allowed Only ',
     1        ' with -Y Option.' /)
99963 FORMAT ('In order to Obtain Obtuse Angle beta, Transform Axes',
     1' by -a,-b,c', /, ' new beta =', F9.3)
99962 FORMAT ('Parameters DO not Define Valid Cell ')
99961 FORMAT (/, 'Coordinates of Atoms for Finding Origin : ', /,
     1        41('='))
99960 FORMAT (4(I4, 3F9.5, 3X))
99959 FORMAT (//, 'Origin Shift for Setting ', A, 3F9.5, /)
99958 FORMAT ('DIMENSION of XPOL is too small')
99957 FORMAT ('Special Read (Check ! )', 2A)
99956 FORMAT (2A)
99955 FORMAT (6F10.4)
99954 FORMAT (A, 4F10.5)
99953 FORMAT ('END', /, 'END')
99952 FORMAT (//, 'Generated INPUT for Structure Tidy on: ', A, /)
99951 FORMAT ('N')
      END SUBROUTINE PLA301
 
      SUBROUTINE PLA302 (NCS, NTRANS, LU, LUA, IER)
C * adapted from program SYMOP (H.Burzlaff & H.Zimmermann (1984),
C * Z. Kristallogr. 167, pp 89-102)
      USE stidy
      IMPLICIT NONE
      INTEGER                              :: I
      INTEGER                              :: J
      INTEGER                              :: K
      INTEGER                              :: L
      INTEGER                              :: M
      INTEGER                              :: N
      INTEGER                              :: MC
      INTEGER                              :: NB
      INTEGER                              :: LT
      INTEGER                              :: KL
      INTEGER                              :: II
      INTEGER                              :: ID
      INTEGER                              :: IZ
      INTEGER                              :: LU
      INTEGER                              :: ND
      INTEGER                              :: IZZ
      INTEGER                              :: NSE
      INTEGER                              :: NGC
      INTEGER                              :: NBL
      INTEGER                              :: MD4
      INTEGER                              :: NCS
      INTEGER                              :: LUA
      INTEGER                              :: IER
      INTEGER                              :: IRC
      INTEGER                              :: ISYS
      INTEGER                              :: IOST
      INTEGER                              :: NTRANS
      INTEGER,           DIMENSION(3, 3)   :: SC
      INTEGER,           DIMENSION(3)      :: MS
      INTEGER,           DIMENSION(7)      :: INX
      INTEGER,           DIMENSION(3)      :: NET
      INTEGER,           DIMENSION(48, 48) :: NGT
      INTEGER,           DIMENSION(48)     :: LGTZ
      CHARACTER(len=1),  DIMENSION(16)     :: NT3
      CHARACTER(len=17)                    :: AUX
      CHARACTER(len=14)                    :: NTT
C * INITIALISATIONS
      CALL GEN074 (PLUS, 1,  3, 0.0)
      CALL GEN097 (MS,   1,  3,   0)
      CALL GEN097 (LGTZ, 1, 48,   0)
      IRC = 72
      NBR = 0
      IZZ = 0
      IZ  = 0
      NGC = 0
      NGO = 0
      ID  = 0
      LT  = 0
      DO I = 1, 3
        DO J = 1, 3
          DO K = 1, 48
            NROT(K, J, I) = 0
            IF (I == 1) THEN
              NTRAN(K, J) = 0
            END IF
          END DO
        END DO
      END DO
C * CHECK THE SYMBOL, DETERMINE BRAVAIS LATTICE
   10 DO I = 1, 7
        INX(I)                   = 0
        IF (NT(1) == HBR(I)) NBR = I
      END DO
      IF (NBR == 0 .OR. NT(2) /= ' ') THEN
C * SPACE GROUP SYMBOL NOT ACCEPTED
        IER = 1
        RETURN
      END IF
      N = 0
      DO I = 2, 16
        IF (NT(I) == ' ') THEN
          K = 0
          N = N + 1
        ELSE
          M = 0
C * CHECK FOR M,A,B,...,4,6
          DO J = 1, 14
            IF (NT(I) == HS(J)) M = J
          END DO
          IF (M == 0 .OR. K > 3) THEN
            IER = 1
            RETURN
          END IF
          INX(N + 1) = INX(N + 1) + M * 15**K
          K          = K + 1
        END IF
      END DO
      DO I = 1, 3
        NET(I) = 0
        DO J = 1, 43
          IF (MM5(J, I) == INX(I + 1)) NET(I) = J
        END DO
        IF (NET(I) == 0) THEN
          IER = 1
          RETURN
        END IF
      END DO
      MD4 = MM4(NET(2), NET(3))
      IF (MD4 == 0) THEN
        IER = 1
        RETURN
      END IF
      MC = MD4 + NET(1) * 95 + (NBR - 1) * 4085
      DO I = 1, 541
        IF (MC == NNT1(I)) IZZ = I
      END DO
C * symbol may not be accepted if it is short monoclinic symbol
C * or if the space group is Icab (nr.73)
      IF (NT(1) == 'I' .AND. NT(3) == 'C' .AND. NT(5) == 'A'
     1   .AND. NT(7) == 'B') THEN
        CALL GEN074 (PLUS, 1, 3, 0.25)
        NGR    = 73
        IFPLUS = 1
        NTRANS = -2
        NSHTRA = 5
        GO TO 80
      END IF
C * changes short spacegroup symbol which is not accepted by subroutine
C * PLA302 into the corresponding long symbol (only for monoclinic)
      IF (IZZ == 0) THEN
C * check if monoclinic short symbol :
        NTT = ' '
        DO I = 1, 14
          WRITE (NTT(I:I), 99992, IOSTAT = IOST) NT(I + 2)
        END DO
        SELECT CASE (NBR)
C * P LATTICE
          CASE (1)
            DO I = 1, 17
              IF (NTT == PSYM(I)) GO TO 20
            END DO
C * A LATTICE
          CASE (2)
            DO I = 18, 24
              IF (NTT == PSYM(I)) GO TO 20
            END DO
C * B LATTICE
          CASE (3)
            DO I = 25, 31
              IF (NTT == PSYM(I)) GO TO 20
            END DO
C * C LATTICE
          CASE (4)
            DO I = 32, 38
              IF (NTT == PSYM(I)) GO TO 20
            END DO
C * F or R lattice are not monoclinic :
          CASE (5, 7)
C * I LATTICE
          CASE (6)
            DO I = 39, 47
              IF (NTT == PSYM(I)) GO TO 20
            END DO
        END SELECT
C * impossible combination :
        IER = 1
        RETURN
   20   CALL GEN126 (NT3, 1, 16)
C * information in nt starts in 1st column
        II = 1
        IF (AL /= 0.0 .AND. AL /= 90.0) II = 2
        IF (BE /= 0.0 .AND. BE /= 90.0) II = II + 2
        IF (GA /= 0.0 .AND. GA /= 90.0) II = II + 4
C * for monoclinic normally II = 2, 3, 5
C * if ii=1, all angles = 90; in this case we shall suppose that
C * b-axis setting, cellchoice 1 was meant.
        SELECT CASE (II)
          CASE (1)
            WRITE (LU, 99993, IOSTAT = IOST)
            GO TO 30
          CASE (2)
C * a-axis unique
            DO I = 3, 16
              IF (NT(I) == ' ') THEN
                NT(I + 1) = '1'
                NT(I + 2) = ' '
                NT(I + 3) = '1'
                GO TO 40
              END IF
            END DO
            WRITE (LU, 99993, IOSTAT = IOST)
            GO TO 30
          CASE (3)
            GO TO 30
          CASE (4)
C * impossible combination
            IER = 1
            RETURN
          CASE (5)
C * c-axis unique
            NT3(3) = '1'
            NT3(5) = '1'
            DO I = 3, 12
              NT3(I + 4) = NT(I)
            END DO
            DO I = 3, 16
              NT(I) = NT3(I)
            END DO
            GO TO 40
          CASE DEFAULT
C * impossible combination
            IER = 1
            RETURN
        END SELECT
C * b-axis unique
   30   NT3(3) = '1'
        DO I = 3, 16
          IF (NT(I) == ' ') EXIT
          NT3(I + 2) = NT(I)
        END DO
        NT3(I + 3) = '1'
        DO I = 3, 16
          NT(I) = NT3(I)
        END DO
   40   CALL PLA262 (1)
        WRITE (LU, 99994, IOSTAT = IOST) NT
        GO TO 10
      END IF
C * transform to standard space group setting
      NTRANS = ITRAFO(IZZ)
      IF (NTRANS > 0) THEN
C * TRANSFORM -> LOWER CASE LETTERS
        NBL      = 0
        AUX      = ' '
        AUX(1:1) = NT(1)
        K        = 2
        DO I = 3, 16
          K = K + 1
          AUX(K:K) = NT(I)
          IF (NT(I) == ' ') THEN
            NBL = NBL + 1
            IF (NBL == 2) EXIT
            CYCLE
          ELSE
            NBL = 0
          END IF
          AUX(K:K) = NT(I)
          CALL GEN020 (-1, AUX, K, K)
        END DO
        DO I = 16, 1, -1
          IF (AUX(I:I) /= ' ') THEN
            K        = I + 1
            AUX(K:K) = '.'
            EXIT
          END IF
        END DO
        WRITE (LUA, 99995, IOSTAT = IOST) AUX, SPGP(ITGRP(IZZ))
      END IF
      NGR = ITGRP(IZZ)
      IZ  = IZZ
C * Give warnings for groups 17 & 20:
   80 IF (IZZ == 182 .OR. IZZ == 183) THEN
        CALL PLA262 (2)
        WRITE (LU, 99998, IOSTAT = IOST)
      ELSE IF (IZZ == 184 .OR. IZZ == 185) THEN
        CALL PLA262 (2)
        WRITE (LU, 99997, IOSTAT = IOST)
      ELSE IF (IZZ == 186 .OR. IZZ == 187) THEN
        CALL PLA262 (2)
        WRITE (LU, 99996, IOSTAT = IOST)
      END IF
      IZZ  = NLST(NGR)
      SPGR = SPGP(NGR)
      NBR  = NCENT(NGR)
      NB   = NBR
      IF (NBR > 2) NB = NBR + 1
      CALL PLA262 (1)
      WRITE (LU, 99999, IOSTAT = IOST) NGR
      DO I = 1, 45
        IF (NT2(I) < IZZ) NGC = I
      END DO
      ISYS   = ISY(NGC)
      N      = IZZ + 541
      M      = IZZ + 2 * 541
      NSE    = NNT1(M)
      NET(3) = NNT1(N) / 900 + 1
      NET(2) = (NNT1(N) - 900 * (NET(3) - 1)) / 30 + 1
      NET(1) = MOD (NNT1(N), 30) + 1
      NCS    = 1 - NGC / 32
      ND     = NGC
      IF (ND > 31) ND = ISX(NGC - 31)
C * ROTATION PARTS
      DO I = 1, 216
        IF (LLF(I) == 1) ID = ID + 1
        IF (ID == ND) THEN
          M = LLF(I) * ISIGN (1, LLF(I)) + 24 * (5 / ISYS) * (ISYS / 5)
          NGO = NGO + 1
          DO K = 1, 3
            DO L = 1, 3
              NROT(NGO, K, L) = IGES(K, L, M) * ISIGN (1, LLF(I))
            END DO
          END DO
        ELSE IF (ID > ND) THEN
          EXIT
        END IF
      END DO
C * MULTIPLICATION TABLE
      DO I = 1, NGO
        DO J = 1, 3
          DO K = 1, 3
            IF (NCS == 0) NROT(NGO + I, J, K) = - NROT(I, J, K)
          END DO
        END DO
        DO 100 J = 1, NGO
          DO K = 1, 3
            DO L = 1, 3
              SC(K, L) = NROT(I, K, 1) * NROT(J, 1, L)
     1                 + NROT(I, K, 2) * NROT(J, 2, L)
     2                 + NROT(I, K, 3) * NROT(J, 3, L)
            END DO
          END DO
          DO 90 K = 1, NGO
            DO L = 1, 3
              DO M = 1, 3
                IF (SC(L, M) /= NROT(K, L, M)) GO TO 90
              END DO
            END DO
            NGT(I,             J) = K
            NGT(NGO + I,       J) = (K + NGO) * (1 - NCS)
            NGT(I,       NGO + J) = (K + NGO) * (1 - NCS)
            NGT(NGO + I, NGO + J) = K * (1 - NCS)
            GO TO 100
   90     CONTINUE
  100   CONTINUE
      END DO
      NGO = NGO + NGO * (1 - NCS)
C * FIX SEMINVARIANT CONDITIONS, TRANSLATION PARTS FOR GENERATORS
      DO I = 1, 3
        ID = LGN(I, NGC)
        DO J = 1, 3
          IF (ID /= 0) NTRAN(ID, J) = NGET(J, NET(I))
          SC(I, J) = NSEM(I, J, NSE)
        END DO
      END DO
C * COMPLETE TRANSLATION PARTS
      DO I = 1, 3
        IF (LGN(I, NGC) /= 0) THEN
          LT       = LT + 1
          LGTZ(LT) = LGN(I, NGC)
        END IF
      END DO
      DO WHILE (LT /= NGO)
        N = 0
        DO I = 1, LT
          DO 110 J = 1, LT
            KL = NGT(LGTZ(I), LGTZ(J))
            DO M = 1, NGO
              IF (LGTZ(M) == KL) GO TO 110
            END DO
            DO K = 1, 3
              DO L = 1, 3
                NTRAN(KL, K) = NTRAN(KL, K)
     1                       + NROT(LGTZ(I), K, L) * NTRAN(LGTZ(J), L)
              END DO
              NTRAN(KL, K) = MOD (NTRAN(KL, K)
     1                     + NTRAN(LGTZ(I), K) + 48, 24)
            END DO
            N            = N + 1
            LGTZ(LT + N) = KL
  110     CONTINUE
        END DO
        LT = LT + N
      END DO
      DO I = 1, NGO
        DO J = 1, 3
          NTRAN(I, J) = NTRAN(I, J) + NROT(I, J, 1) * MS(1)
     1      + NROT(I, J, 2) * MS(2) + NROT(I, J, 3) * MS(3) - MS(J)
          NTRAN(I, J) = MOD (NTRAN(I, J) + 48, 24)
        END DO
        IF (NB /= 1 .AND. NB /= 7) THEN
          DO L = 1, 4
            DO K = 1, 3
              NET(K) = MOD (NTRAN(I, K) + NNQ(K, L, NB - 1), 24)
            END DO
            IF (IRC > NET(1) + NET(2) + NET(3)) THEN
              IRC = NET(1) + NET(2) + NET(3)
              DO K = 1, 3
                NTRAN(I, K) = NET(K)
              END DO
            END IF
          END DO
        END IF
        IRC = 72
      END DO
C * TRANSFORMATION MATRIX
      IFNG(2) = 0
      N       = MOD (NTRANS, 20)
      IF (NTRANS == -2) N       = 30
      IF (NTRANS == -1) IFNG(2) = 1
      IF (N > 0) THEN
        IFNG(2) = 2
        IF (NTRANS > 0) THEN
          IER = 0
C * TRANSFORMATION OF CELL PARAMETERS TO STANDARD SPACE GROUP SETTING
          CALL PLA307 (N, IER)
          IF (IER == 1) RETURN
        END IF
        DO K = 1, 9
          UVW(K) = XABC(K, N)
        END DO
      END IF
      IF (NTRANS == -2) RETURN
C * some transformations require a different origin shift from that
C * indicated in data in trafo :
      SELECT CASE (N)
        CASE (13, 25)
          IF (IZ == 8 .OR. IZ == 299) THEN
            NTRANS = 7
          ELSE IF (IZ == 11)  THEN
            NTRANS = 27
          ELSE IF (IZ == 302) THEN
            NTRANS = 47
          END IF
        CASE (15, 27)
          IF (IZ == 28)  THEN
            NTRANS = 29
          ELSE IF (IZ == 34 .OR. IZ == 329) THEN
            NTRANS = 9
          ELSE IF (IZ == 323) THEN
            NTRANS = 49
          END IF
        CASE (17, 29)
          IF (IZ == 47 .OR. IZ == 350) THEN
            NTRANS = 11
          ELSE IF (IZ == 50) THEN
            NTRANS = 31
          ELSE IF (IZ == 353) THEN
            NTRANS = 51
          END IF
      END SELECT
      IF (NTRANS >= 20) THEN
        IFPLUS  = 1
        PLUS(2) = 0.25
        IF (NTRANS >= 40) THEN
          PLUS(1) = 0.25
          NSHTRA  = 6
        ELSE
          NSHTRA = 17
        END IF
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT ('Number in IT       :', I4)
99998 FORMAT ('WARNING : The origin should be at  2 1 21;', /,
     1' if the origin is at  1 2 21, substract 1/4 from z-coordinates.')
99997 FORMAT ('WARNING : The origin should be at  21 2 1;', /,
     1' if the origin is at  21 1 2, substract 1/4 from x-coordinates.')
99996 FORMAT ('WARNING : The origin should be at  1 21 1;', /,
     1' if the origin is at  2 21 1, substract 1/4 from y-coordinates.')
99995 FORMAT ('REMARK Transformed from setting  ', A, ' to ', A)
99994 FORMAT ('Complete Symbol for Space Group Setting : ', 16A1)
99993 FORMAT ('Input of monoclinic space group with all angles = 90 ',
     1' may lead to difficulties.', /, ' The program assumes b-axis',
     2' unique. If different setting,'/
     3' rerun program with monoclinic angle=90.0001')
99992 FORMAT (A1)
      END SUBROUTINE PLA302
 
      SUBROUTINE PLA303 (PEAR, IPEARS, PMIN, KELT, NCS, NTIO, LRET325)
C * changes space group to P1 or P-1; reads atom coordinates and puts
C * them into the appropriate array
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER                      :: I
      INTEGER                      :: J
      INTEGER                      :: K
      INTEGER                      :: IA
      INTEGER                      :: KNT
      INTEGER                      :: NCS
      INTEGER                      :: IER
      INTEGER                      :: NIG
      INTEGER                      :: NTIO
      INTEGER                      :: KELT
      INTEGER                      :: IPEARS
      INTEGER                      :: LRET325
      INTEGER, DIMENSION(11)       :: NENT
      REAL                         :: EP
      REAL                         :: FN
      REAL                         :: FMU
      REAL                         :: PMIN
      REAL,    DIMENSION(3)        :: Y
      REAL,    DIMENSION(NUMAT)    :: FF
      REAL,    DIMENSION(3, NUMAT) :: XX
      REAL,    DIMENSION(3, 3)     :: SAV
      REAL,    DIMENSION(NELTS)    :: PEAR
      NENT   = (/76, 91, 92, 144, 151, 152, 169, 171, 178, 180, 213/)
      NIG    = 1
      KNT    = 0
      NBR    = 1
      KELT   = 0
      NATOM  = 0
      IPEARS = 0
      EP     = 0.000001
      PMIN   = 0.0
      DO J = 1, NUMAT
        DO I = 1, 3
          XX(I, J) = 0.0
        END DO
      END DO
C * COPY MATRICES
      CALL GEN052 (XMAT,   SAV)
      CALL GEN052 (XMSAVE, XMAT)
C * if centric group, take only half of positions :
      IF (NCS == 0) NGO = NGO / 2
C * set centring as for primitive cell :
C * loop over atoms
      DO
        IER = 0
        CALL PLA304 (NIG, IER)
        IF (IER == 0) THEN
C * Generates all atompositions for given space group
          CALL PLA322
C * transform atompositions according to cellreduction and get out doubles
          DO 10 I = 1, KOUNT
            IF (IFNG(1) == 2) THEN
              DO J = 1, 3
                POS(J) = XYZ(1, I) * SAV(1, J) + XYZ(2, I) * SAV(2, J)
     1                 + XYZ(3, I) * SAV(3, J)
              END DO
C * put positions between 0.0 and 1.0 :
              DO J = 1, 3
                DO WHILE (POS(J) < - 0.000001)
                  POS(J) = POS(J) + 1.0
                END DO
                DO WHILE (POS(J) >= 0.999999)
                  POS(J) = POS(J) - 1.0
                END DO
              END DO
            ELSE
              DO J = 1, 3
                POS(J) = XYZ(J, I)
              END DO
            END IF
C * remove doubles caused by transformation :
            IF (KNT > 0) THEN
              DO J = 1, KNT
                IF (ABS (POS(1) - XX(1, J)) < EP .AND.
     1              ABS (POS(2) - XX(2, J)) < EP .AND.
     2              ABS (POS(3) - XX(3, J)) < EP) GO TO 20
              END DO
C * for P-1 eliminate also positions -x,-y,-z :
              IF (NCS == 0) THEN
                DO J = 1, KNT
                  DO K = 1, 3
                    Y(K) = POS(K) + XX(K, J)
                    IF (Y(K) > 0.999999) Y(K) = Y(K) - 1.0
                  END DO
                  IF (ABS (Y(1)) < EP .AND. ABS (Y(2)) < EP .AND.
     1                ABS (Y(3)) < EP) GO TO 10
                END DO
              END IF
            END IF
            KNT        = KNT + 1
            ATOM1(KNT) = ELT1
            ATOM2(KNT) = ELT2
            FOCCU(KNT) = FFF
            FF(KNT)    = FNUM
            DO J = 1, 3
              XX(J, KNT) = POS(J)
            END DO
   10     CONTINUE
          IF (KNT >= NUMAT) THEN
            WRITE (LU7, 99995, IOSTAT = IOST)
            LRET325 = 1
            RETURN
          END IF
        ELSE
          EXIT
        END IF
      END DO
      NATOM = KNT
      WRITE (LU7, 99998, IOSTAT = IOST)
      DO I = 1, NATOM
        WRITE (LU7, 99997, IOSTAT = IOST)
     1    ATOM1(I), ATOM2(I), (XX(J, I), J = 1, 3)
      END DO
C * new symmetry factors :
      DO I = 1, 3
        DO J = 1, 3
          DO K = 1, 48
            NROT(K, J, I) = 0
          END DO
        END DO
      END DO
      DO I = 1, 3
        DO J = 1, 48
          NTRAN(J, I) = 0
        END DO
      END DO
      DO I = 1, 8
        DO J = 1, 3
          ORGADD(J, I) = 0.0
        END DO
      END DO
      NT(1)   = 'P'
      NT(2)   = ' '
      CODE(1) = 'a'
      CODE(2) = 'P'
      IF (NCS == 0) THEN
C * centric group; change to P -1 .
        NT(3) = '-'
        NT(4) = '1'
        SPGR  = 'P -1'
        NGR   = 2
        NSPEC = 8
        NW    = 2
        NTIO  = 0
        DO I = 1, 8
          IS(I) = 1
          NS(I) = 9 - i
        END DO
        MULT(1) = 1
        MULT(2) = 2
        DO I = 1, 3
          NROT(1, I, I) = 1
          NROT(2, I, I) = -1
        END DO
        NGO  = 2
        NOR  = 8
        IPOL = 1
        ORGADD(1, 2) = 0.5
        ORGADD(2, 3) = 0.5
        ORGADD(3, 4) = 0.5
        ORGADD(2, 5) = 0.5
        ORGADD(3, 5) = 0.5
        ORGADD(1, 6) = 0.5
        ORGADD(3, 6) = 0.5
        ORGADD(1, 7) = 0.5
        ORGADD(2, 7) = 0.5
        ORGADD(1, 8) = 0.5
        ORGADD(2, 8) = 0.5
        ORGADD(3, 8) = 0.5
      ELSE
        NROT(1, 1, 1) = 1
        NROT(1, 2, 2) = 1
        NROT(1, 3, 3) = 1
        SPGR          = 'P 1'
        IPOL          = 0
        NOR           = -31
        NT(3)         = '1'
        NT(4)         = ' '
        NSPEC         = 0
        NW            = 1
        IS(1)         = 1
        NTIO          = 1
        MULT(1)       = 1
        NGO           = 1
        NGR           = 1
C * in the case of one of the enantiomorphic space group pairs,
C * setting -x,-y,-z should NOT be considered :
        DO I = 1, 11
          IF (NGR == NENT(I)) THEN
            NTIO = 0
            NFL  = 1
            GO TO 20
          END IF
        END DO
      END IF
   20 CALL GEN126 (NT, 5, 16)
      WRITE (LU7, 99996, IOSTAT = IOST) NGR, SPGR
C * transform atompositions according to cellreduction; THEN generate
C * all positions with PLA322
      DO IA = 1, NATOM
        DO J = 1, 3
          POS(J) = XX(J, IA)
        END DO
        CALL PLA322
        KSET = 0
        IF (NSPEC == 0) THEN
          MU   = MULT(1)
          KORD = 1
        ELSE
          CALL PLA324 (NIG)
        END IF
C * number of atoms for Pearson code :
        FMU    = FLOAT (MU)
        FN     = FF(IA) * FMU
        IPEARS = IPEARS + MU
        PMIN   = PMIN + FMU - FN
        ELT1   = ATOM1(IA)
        IF (KELT > 0) THEN
          DO I = 1, KELT
            IF (ELT1 == ELT(I)) GO TO 30
          END DO
        END IF
        KELT = KELT + 1
        IF (KELT > NELTS) THEN
          WRITE (LU7, 99999, IOSTAT = IOST) NELTS
          KELT = KELT - 1
        END IF
        ELT(KELT) = ELT1
        I         = KELT
   30   PEAR(I)   = PEAR(I) + FN
        DO J = 1, 3
          XA(J, IA) = XYZ(J, 1)
        END DO
        IF (KSET /= 0) THEN
          DO J = 1, KSET
            NNSET(J, IA) = NSET(J)
          END DO
          NRSET(IA) = KSET
        END IF
      END DO
      RETURN
99999 FORMAT ('More than ', I3,' different elements in structure,', /,
     1 ' giving wrong Pearson code and displacements in output.')
99998 FORMAT (//, 'Atoms in asymmetric unit of new space group :')
99997 FORMAT (A2, A4, 5X, 3F9.5)
99996 FORMAT (/, 'Niggli reduced cell option; new space group:',
     1        I2, 5X, A, /)
99995 FORMAT ('too many atoms for Niggli option; stop job')
      END SUBROUTINE PLA303
 
      SUBROUTINE PLA304 (NIG, IER)
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: K
      INTEGER                         :: L
      INTEGER                         :: M
      INTEGER                         :: N
      INTEGER                         :: I1
      INTEGER                         :: I2
      INTEGER                         :: J1
      INTEGER                         :: J2
      INTEGER                         :: K1
      INTEGER                         :: II
      INTEGER                         :: JJ
      INTEGER                         :: KK
      INTEGER                         :: IJ
      INTEGER                         :: IE
      INTEGER                         :: ISL
      INTEGER                         :: NIG
      INTEGER                         :: IER
      INTEGER                         :: NEG
      INTEGER                         :: NUM1
      INTEGER                         :: NUM2
      INTEGER,          DIMENSION(2)  :: NUMB
      REAL                            :: F1
      REAL                            :: F2
      REAL,             DIMENSION(3)  :: X3
      CHARACTER(len=1), DIMENSION(70) :: T
      CHARACTER(len=1), DIMENSION(30) :: DAT
      CHARACTER(len=10)               :: AUX
      CHARACTER(len=4)                :: LAB
      CHARACTER(len=1)                :: TIM1
      ELT1 = ' '
      ELT2 = ' '
      FFF  = ' '
      ISL  = 0
      FNUM = 1.0
      CALL GEN126 (DAT, 1, 30)
      IF (IAT == 0) THEN
        CALL PLA262 (12)
        WRITE (LU7, 99993, IOSTAT = IOST)
      END IF
   10 READ (LU64, 99999) T
      IAT = IAT + 1
      DO I = 1, 4
        LAB(I:I) = T(I)
      END DO
      IF (LAB == 'DEFI') THEN
        WRITE (LU63, 99999, IOSTAT = IOST) T
        GO TO 10
      END IF
      DO 30 I = 1, 70
        IF (I > 1) THEN
          TIM1 = T(I - 1)
        ELSE
          TIM1 = ' '
        ENDIF
        IF (T(I) == '.' .OR. T(I) == '/' .OR. T(I) == '0'
     1   .AND. TIM1 == ' ')  THEN
          IF (I < 3) THEN
            CALL PLA262 (1)
            WRITE (LU7, 99998, IOSTAT = IOST) T
            GO TO 10
          END IF
          IF (T(I) == '.') THEN
            IJ = I - 1
            IF (T(I - 1) == '0') IJ = I - 2
            IF (T(I - 2) == '+' .OR. T(I - 2) == '-') IJ = I - 3
            IF (T(I - 1) == '-' .OR. T(I - 1) == '+') IJ = I - 2
          ELSE IF (T(I) == '/') THEN
            I1 = I - 1
            DO J = 1, I1
              K = I - J
              IF (T(K) == ' ') GO TO 20
            END DO
            WRITE (LU6, 99988, IOSTAT = IOST)
            GO TO 10
   20       IJ = K
          ELSE
            IJ = I - 1
          END IF
        ELSE
          GO TO 30
        END IF
        GO TO 40
   30 CONTINUE
      IJ = 70
C * Atom identification (element name)
   40 IE = 1
      DO 50 I = 1, IJ
        IF (T(I) /= ' ') THEN
          KK = ICHAR (T(I))
          IF (KK < 65 .OR. KK > 90) THEN
            IF (KK >= 97 .AND. KK <= 122) THEN
              KK   = KK - 32
              T(I) = CHAR (KK)
            ELSE
              GO TO 50
            END IF
          END IF
          ELT1(1:1) = T(I)
          KK = ICHAR (T(I + 1))
          IF (KK < 97 .OR. KK > 122) THEN
            IF (KK >= 65 .AND. KK <= 90) THEN
              KK       = KK + 32
              T(I + 1) = CHAR (KK)
            ELSE
              ELT1(2:2) = ' '
              I1        = I + 1
              GO TO 60
            END IF
          END IF
          ELT1(2:2) = T(I + 1)
          I1        = I + 2
          IF (ELT1 /= 'En') GO TO 60
          IER = 1
          RETURN
        END IF
   50 CONTINUE
      WRITE (LU6, 99998, IOSTAT = IOST) T
      WRITE (LU7, 99998, IOSTAT = IOST) T
      GO TO 10
C * Atom identification (number or other, but no . and no /)
   60 IF (IJ == 70) THEN
C * no . or / in inputrecord, which means that all coordinates =0.
C * Look for atomidentifier:
        DO I = I1, 70
          IF (T(I) == '0' .AND. T(I - 1) == ' ') GO TO 70
        END DO
        GO TO 80
   70   IJ = I - 2
      END IF
   80 DO I = I1, IJ
        IF (T(I) /= ' ') GO TO 90
      END DO
      IF (IJ == 70) GO TO 110
      GO TO 100
   90 ELT2(1:1) = T(I)
      DO J = 1, 3
        K = I + J
        IF (T(K) == ' ') GO TO 100
        IE = J + 1
        ELT2(IE:IE) = T(K)
      END DO
C * right-adjust elt-number:
  100 DO J = 4, 1, -1
        IF (ELT2(J:J) /= ' ') THEN
          IF (J /= 4) THEN
            DO K = 1, J
              L           = J + 1 - K
              KK          = 5 - K
              ELT2(KK:KK) = ELT2(L:L)
            END DO
            ELT2(1:KK-1) = ' '
          END IF
          GO TO 110
        END IF
      END DO
C * ATOMIC POSITIONS
  110 IF (IJ == 70) THEN
        CALL GEN074 (POS, 1, 3, 0.0)
        FNUM = 1.0
        CALL PLA262 (2)
        WRITE (LU7, 99992, IOSTAT = IOST)
        WRITE (LU7, 99997, IOSTAT = IOST) ELT1, ELT2
      ELSE
        J  = 0
        IJ = IJ + 1
        DO K = 1, 3
          DO I = IJ, 70
            IF (T(I) .NE.' ') THEN
              J      = J + 1
              DAT(J) = T(I)
              I2     = I + 1
              DO II = I2, 70
                IF (T(II) == ' ') GO TO 120
                J      = J + 1
                DAT(J) = T(II)
              END DO
              GO TO 140
            ENDIF
          END DO
          K1 = (K - 1) * 10 + 2
          DO
            DAT(K1) = '0'
            IF (K1 > 20) GO TO 130
            K1 = K1 + 10
          END DO
  120     J1 = J + 1
          J2 = (J1 / 10 + 1) * 10
          IF (J1 < J2) THEN
            DO I = J1, J2
              DAT(I) = ' '
            END DO
          END IF
          IJ = II + 1
          J  = J2
        END DO
C * LOOK FOR OCCUPATION FACTOR
  130   DO II = IJ, 70
          IF (T(II) /= ' ') THEN
            I1 = II + 4
            J  = 0
            DO I = II, I1
              IF (T(I) == '/') ISL = I
              J = J + 1
              FFF(J:J) = T(I)
            END DO
            EXIT
          END IF
        END DO
        CALL PLA262 (2)
        WRITE (LU7, 99992, IOSTAT = IOST)
        WRITE (LU7, 99996, IOSTAT = IOST) ELT1, ELT2, DAT, FFF
C * numerical value of occupation factor -> fnum
  140   IF (ISL == 0) THEN
          READ (FFF, 99991) FNUM
        ELSE
          NUM1 = 0
          NUM2 = 0
          DO I = II, ISL - 1
            READ (T(I), 99990, IOSTAT = IOST) N
            IF (IOST /= 0) THEN
              CALL PLA262 (1)
              WRITE (LU7, 99995, IOSTAT = IOST) FFF
              FNUM = 1.0
              GO TO 150
            END IF
            NUM1 = 10 * NUM1 + N
          END DO
          DO I = ISL + 1, I1
            IF (T(I) == ' ') EXIT
            READ (T(I), 99990, IOSTAT = IOST) N
            IF (IOST /= 0) THEN
              CALL PLA262 (1)
              WRITE (LU7, 99995, IOSTAT = IOST) FFF
              FNUM = 1.0
              GO TO 150
            END IF
            NUM2 = 10 * NUM2 + N
          END DO
          FNUM = FLOAT (NUM1) / FLOAT (NUM2)
        END IF
        IF (FNUM == 0.0) FNUM = 1.0
C * ATOM RECORDS:
  150   DO 160 I = 1, 3
          J1  = (I - 1) * 10 + 1
          J2  = J1 + 9
          AUX = ' '
          JJ  = 0
          DO L = J1, J2
            if (DAT(L) == '/') THEN
C * SLASH FOUND
              M       = 1
              NUMB(1) = 0
              NUMB(2) = 0
              NEG     = 1
              DO K = J1, J2
                IF (DAT(K) /= ' ') THEN
                  IF (DAT(K) /= '/') THEN
                    IF (DAT(K) == '-') THEN
                      NEG = -1
                      CYCLE
                    END IF
                    KK = ICHAR (DAT(K)) - ICHAR ('0')
                    IF (KK < 0 .OR. KK > 9) THEN
                      WRITE (LU7, 99987, IOSTAT = IOST) DAT(K), DAT
                      RETURN
                    END IF
                    NUMB(M) = KK + 10 * NUMB(M)
                  ELSE
                    M = 2
                  END IF
                END IF
              END DO
              F1     = NUMB(1) * NEG
              F2     = NUMB(2)
              POS(I) = F1 / F2
              GO TO 160
            END IF
            JJ         = JJ + 1
            AUX(JJ:JJ) = DAT(L)
          END DO
          READ (AUX, 99989) POS(I)
  160   CONTINUE
      END IF
C * Eventually add shift to obtain origin at centre of symmetry
      IF (IFSH == 1) THEN
        DO J = 1, 3
          POS(J) = POS(J) - SH(J)
        END DO
      END IF
C * Apply MATRIX to input positions
      IF (IFNG(2) == 2) THEN
        DO J = 1, 3
          X3(J) = POS(1) * XMAT(1, J) + POS(2) * XMAT(2, J)
     1          + POS(3) * XMAT(3, J) - PLUS(J)
       END DO
       DO J = 1, 3
         POS(J) = X3(J)
       END DO
      END IF
C * If enantiomorphic space group, change sign of all coordinates
      IF (IFNG(2) == 1) THEN
         DO J = 1, 3
           POS(J) = 1.0 - POS(J)
         END DO
      END IF
C * Put positions between 0 and 1 :
      DO J = 1, 3
        DO WHILE (POS(J) < -0.000001)
          POS(J) = POS(J) + 1.0
        END DO
        DO WHILE (POS(J) >= 0.999999)
          POS(J) = POS(J) - 1.0
        END DO
      END DO
C * Coordinates < 0.001 are considered = 0 when transformed from
C *    rhombohedral setting :
      IF (IHEX == 1) THEN
        DO J = 1, 3
          IF (ABS (POS(J)) < 0.001) POS(J) = 0.0
        END DO
      END IF
      IF (NIG == 0) THEN
        IF (IFNG(2) > 0 .OR. IFSH == 1 .OR. IHEX == 1) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99994, IOSTAT = IOST) ELT1, ELT2, POS, FFF
        END IF
      END IF
      RETURN
99999 FORMAT (70A)
99998 FORMAT ('Error, no element name; Write this line again',
     1        /, 70A)
99997 FORMAT ('         ', 2A, 2X, '0         0         0')
99996 FORMAT ('Input  : ', 2A, 2X, 30A1, 5X, A)
99995 FORMAT ('WARNING : Error in reading occupation factor', A,
     1 ' we take value F=1')
99994 FORMAT ('Changed: ', A, A4, 1X, 3F9.5, 5X, A5, /)
99993 FORMAT (/, 'Coordinate Data Input:', /, 80('='), /,
     1 'Atom identification (1 or 2 letters and as option',
     2 ' a number),', /, 'the 3 coordinates (fractions are allowed)',
     3 ' and the occupation factor (if < 1).', /,
     4 'One record for each atom site in the asymmetric unit.', /,
     5 'For recognition of special positions, non-rational numbers',
     6 ' should', /, 'be given with at least 5 decimals, or as',
     7 ' fractions. The order', /, 'in which the sites of different',
     8 ' elements are entered determines', /, 'the indenting in the',
     9 ' final atom site list. Coordinates for mixed', /, 'sites',
     * ' should be entered only once, with a dummy element name.', /,
     1 'The program will THEN ask you to define the actual',
     2 ' occupation.')
99992 FORMAT (80('='))
99991 FORMAT (F5.1)
99990 FORMAT (I1)
99989 FORMAT (F10.5)
99988 FORMAT ('Items should by separated by at least one blank.',
     1 ' Write this line again')
99987 FORMAT (' Unrecognized number in SUBROUTINE PLA304 : ',
     1        A1, 2X, 30A1)
      END SUBROUTINE PLA304
 
      SUBROUTINE PLA305 (IG, IK, NELT, AX, TEXT, O1, O2, O3,
     1                   NSP)
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER                               :: I
      INTEGER                               :: J
      INTEGER                               :: K
      INTEGER                               :: L
      INTEGER                               :: M
      INTEGER                               :: N
      INTEGER                               :: IX
      INTEGER                               :: IY
      INTEGER                               :: IZ
      INTEGER                               :: I1
      INTEGER                               :: IG
      INTEGER                               :: NN
      INTEGER                               :: MX
      INTEGER                               :: MY
      INTEGER                               :: MZ
      INTEGER                               :: IK
      INTEGER                               :: KT
      INTEGER                               :: KN
      INTEGER                               :: II
      INTEGER                               :: JJ
      INTEGER                               :: KK
      INTEGER                               :: LAX
      INTEGER                               :: MEQ
      INTEGER                               :: KTY
      INTEGER                               :: KTZ
      INTEGER                               :: NBL
      INTEGER                               :: IPR
      INTEGER                               :: IGOX
      INTEGER                               :: IPOS
      INTEGER                               :: KEER
      INTEGER                               :: LORI
      INTEGER                               :: LXYZ
      INTEGER                               :: NELT
      INTEGER                               :: NSPOS
      INTEGER                               :: KOUNTY
      INTEGER                               :: KOUNTZ
      INTEGER                               :: MAXORD
      INTEGER,          DIMENSION(NUMAT)    :: KY
      INTEGER,          DIMENSION(NUMAT)    :: KZ
      INTEGER,          DIMENSION(NUMAT)    :: NP
      INTEGER,          DIMENSION(NUMAT)    :: NSP
      INTEGER,          DIMENSION(NUMAT)    :: KATOM
      INTEGER,          DIMENSION(27)       :: NWYCK
      REAL                                  :: O1
      REAL                                  :: O2
      REAL                                  :: O3
      REAL                                  :: V
      REAL                                  :: CG
      REAL                                  :: EPS
      REAL                                  :: FFOC
      REAL                                  :: XMINX
      REAL                                  :: YMINY
      REAL                                  :: ZMINZ
      REAL,             DIMENSION(3, NUMAT) :: T
      REAL,             DIMENSION(3)        :: OR
      REAL,             DIMENSION(9)        :: ORI
      REAL,             DIMENSION(3)        :: XX
      CHARACTER(len=47)                     :: AX
      CHARACTER(len=3)                      :: AUX
      CHARACTER(len=1), DIMENSION(108)      :: WSEQ
      CHARACTER(len=17)                     :: TEXT
      CHARACTER(len=6)                      :: AUX1
      CHARACTER(len=8), DIMENSION(3)        :: COORD
      CHARACTER(len=37)                     :: ORTXT
      CHARACTER(len=11)                     :: NWELT
      CHARACTER(len=69)                     :: TRATXT
      CHARACTER(len=11)                     :: NEWELT
C * orders atoms for output.
C * ig denotes number of descriptions with minimum gamma:
C * if ig = 0 or 1, only ordering and printing is needed;
C * if ig > 1, horizontal sum are to be computed
C * NELTS is maximum number of different elements (only NELTS elements
C * displaced in final output list). NELT is number of different
C * elements present in structure.
C * FINELT contains reordered elements.
C * NEWELT will contain (displaced) elementname
      ORI = (/
     1  0.125, 0.25, 0.375, 0.5, 0.625, 0.75, 0.875, 0.3333, 0.6667/)
c * offset for conversion number -> CHARACTER :
c * ik is index in arrays sum,sxy,sxz,syz :
      CALL GEN097 (NRZ,    1, NDIF, 0)
      CALL GEN097 (MAXNR,  1, NDIF, 0)
      CALL GEN097 (NWYCK,  1, 27,   0)
      CALL GEN126 (FINELT, 1, NDIF)
      CALL GEN126 (WSEQ,   1, 108)
      IF (IG < 0) THEN
        KN = -IG
      ELSE
        KN = 1
      END IF
      NN     = 0
      EPS    = 0.0001
      KOUNTY = 0
      KOUNTZ = 0
      KTY    = 0
      KTZ    = 0
      NSPOS  = 0
      NEL    = 0
      MX     = 1
      MY     = 1
      MZ     = 1
      MAXORD = NSPEC + 1
C * Start ordering with highest multiplicity :
      DO II = 1, MAXORD
        K = MAXORD + 1 - II
        KT = 0
        DO I = 1, NATOM
          KK = LETR(I)
          IF (KK == K) THEN
            KT = KT + 1
            DO J = 1, 3
              T(J, KT) = XXX(J, I)
            END DO
            NP(KT)    = NSP(I)
            NSPOS     = NP(KT)
            KATOM(KT) = I
          END IF
        END DO
        IF (KT /= 0) THEN
          KOUNT = 0
   10     XMINX = 2.0
          MEQ   = 0
          DO 30 IX = 1, KT
            DO J = 1, 3
              IF (T(J, IX) > 9.0) GO TO 30
            END DO
            IF (ABS (T(1, IX) - XMINX) >= EPS) THEN
              IF (T(1, IX) < XMINX) THEN
                XMINX = T(1, IX)
                MX    = IX
                MEQ   = 0
              ELSE IF (T(1, IX) == XMINX) THEN
                GO TO 20
              END IF
              GO TO 30
            END IF
   20       MEQ = 1
            MX  = IX
   30     CONTINUE
          IGOX = 1
          IF (MEQ /= 1) THEN
            L = KATOM(MX)
            CALL PLA321 (L)
            IPOS = LETR(L)
            IF (IG <= 1) THEN
              DO J = 1, 3
                XX(J) = T(J, MX)
              END DO
              NSPOS = NP(MX)
              IPR   = 1
            ELSE
              NN = NN + 1
              HORSUM(NN, IK) = T(1, MX) + T(2, MX) + T(3, MX)
              IPR = 0
            END IF
            KOUNT    = KOUNT + 1
            T(1, MX) = 10.0
            IF (KOUNT < KT) IGOX = 2
            GO TO 80
          END IF
C * get here if 2 x-positions equal; look for all equal x
          KTY = 0
          DO IY = 1, KT
            IF (ABS (T(1, IY) - T(1, MX)) <= EPS) THEN
              KTY     = KTY + 1
              KY(KTY) = IY
            END IF
          END DO
          KOUNTY = 0
   40     YMINY  = 2.0
          MEQ    = 0
          DO J = 1, KTY
            IY = KY(J)
            IF (ABS (T(2, IY) - YMINY) >= EPS) THEN
              IF (T(2, IY) < YMINY) THEN
                YMINY = T(2, IY)
                MY    = IY
                MEQ   = 0
              ELSE IF (T(2, IY) == YMINY) THEN
                GO TO 50
              END IF
              CYCLE
            END IF
   50       MEQ = 1
            MY  = IY
          END DO
          IF (MEQ /= 1) THEN
            L = KATOM(MY)
            CALL PLA321 (L)
            IPOS = LETR(L)
            IF (IG <= 1) THEN
              IPR   = 1
              DO J = 1, 3
                XX(J) = T(J, MY)
              END DO
              NSPOS = NP(MY)
            ELSE
              IPR = 0
              NN  = NN + 1
              HORSUM(NN, IK) = T(1, MY) + T(2, MY) + T(3, MY)
            END IF
            KOUNT    = KOUNT  + 1
            KOUNTY   = KOUNTY + 1
            T(2, MY) = 10.0
            IGOX     = 1
            IF (KOUNTY < KTY) THEN
              IGOX = 3
            ELSE IF (KOUNT < KT) THEN
              IGOX = 2
            END IF
            GO TO 80
          END IF
C * x- and y-coordinates are equal
          KTZ = 0
          DO IZ = 1, KT
            IF (ABS (T(1, MX) - T(1, IZ)) <= EPS) THEN
              IF (ABS (T(2, IZ) - T(2, MY)) <= EPS) THEN
                KTZ     = KTZ + 1
                KZ(KTZ) = IZ
              END IF
            END IF
          END DO
          KOUNTZ = 0
   70     ZMINZ  = 2.0
          MEQ    = 0
          DO J = 1, KTZ
            IZ = KZ(J)
            IF (ABS (T(3, IZ) - ZMINZ) >= EPS) THEN
              IF (T(3, IZ) < ZMINZ) THEN
                ZMINZ = T(3, IZ)
                MZ    = IZ
                MEQ   = 0
              END IF
            END IF
          END DO
          L = KATOM(MZ)
          CALL PLA321 (L)
          IPOS = LETR(L)
          IF (IG <= 1) THEN
            IPR   = 1
            DO J = 1, 3
              XX(J) = T(J, MZ)
            END DO
            NSPOS = NP(MZ)
          ELSE
            IPR = 0
            NN  = NN + 1
            HORSUM(NN, IK) = T(1, MZ) + T(2, MZ) + T(3, MZ)
          END IF
          KOUNT    = KOUNT + 1
          KOUNTY   = KOUNTY + 1
          KOUNTZ   = KOUNTZ + 1
          T(3, MZ) = 10.0
          T(2, MZ) = 10.0
          IGOX     = 1
          IF (KOUNTZ < KTZ) THEN
            IGOX = 4
          ELSE IF (KOUNTY < KTY) THEN
            IGOX = 3
          ELSE IF (KOUNT < KT) THEN
            IGOX = 2
          END IF
   80     IF (IPR == 1) THEN
            NEWELT = ' '
            AUX    = ' '
            NWYCK(IPOS) = NWYCK(IPOS) + 1
C * if atom X, put at beginning:
            IF (ATOM1(L)(1:1) == 'X') THEN
              NEWELT(1:2) = ATOM1(L)
              JJ = 2
              IF (NEWELT(2:2) == ' ') JJ = 1
              GO TO 100
            END IF
C * print one line :
            DO I = 1, NELT
              IF (ATOM1(L) == ELT(I)) THEN
C * look if X-atom(s) before element i:
                K = 0
                DO J = 1, I
                  IF (ELT(J)(1:1) /= 'X') K = K + 1
                END DO
                K             = K + 1
                NEWELT(K:K+1) = ELT(I)
                JJ = K + 1
                IF (NEWELT(K + 1:K + 1) == ' ') JJ = K
                GO TO 90
              END IF
            END DO
C * arrive here if error :
            WRITE (LU7, 99991, IOSTAT = IOST) ATOM1(L), NELT
            NEWELT(1:2) = ATOM1(L)
            JJ = 1
   90       WRITE (AUX, 99989, IOSTAT = IOST) NEWN
C * left-adjust aux:
            K = 0
            DO J = 1, 3
              IF (AUX(J:J) /= ' ') THEN
                K = K + 1
                AUX(K:K) = AUX(J:J)
              END IF
            END DO
            IF (K < 3) AUX(K+1:3) = ' '
            NEWELT(JJ + 1:JJ + 3) = AUX
C * edit atomcoordinates for final results with fractions or 0
C * where indicated by special position
            IF (NSPOS > 0) THEN
              DO I = 1, 3
                IF (KSPEC(I, NSPOS) == 0) THEN
                  WRITE (COORD(I), 99998, IOSTAT = IOST) XX(I)
                ELSE
                  COORD(I) = KOORD(KSPEC(I, NSPOS))
                END IF
              END DO
            ELSE
              DO I = 1, 3
                WRITE (COORD(I), 99998, IOSTAT = IOST) XX(I)
                COORD(I)(1:1) = ' '
              END DO
            END IF
C * round foc if necessary (only if dot present)
            DO J = 1, 5
              IF (FOCCU(L)(J:J) == '.') THEN
                READ (FOCCU(L), 99988) FFOC
                FOCCU(L) = ' '
                WRITE (FOCCU(L)(1:4), 99987, IOSTAT = IOST) FFOC
                GO TO 100
              END IF
            END DO
  100       WRITE (LU63, 99993, IOSTAT = IOST)
     1        NEWELT, MULR(L), CHAR (96 + IPOS),
     1        COORD, FOCCU(L), ATOM2(L)
            WRITE (LU6,  99992, IOSTAT = IOST) NEWELT, MULR(L),
     1        CHAR (96 + IPOS), COORD, FOCCU(L), ATOM1(L), ATOM2(L)
            NWELT = ' '
            M = 0
            DO N = 1, 11
              IF (NEWELT(N:N) /= ' ') THEN
                M = M + 1
                NWELT(M:M) = NEWELT(N:N)
              END IF
            END DO
            WRITE (LU21, 99984, IOSTAT = IOST) NWELT, (XX(N), N = 1, 3)
          END IF
          IF (IGOX == 1) THEN
            CYCLE
          ELSE IF (IGOX == 2) THEN
            GO TO 10
          ELSE IF (IGOX == 3) THEN
            GO TO 40
          ELSE IF (IGOX == 4) THEN
            GO TO 70
          END IF
        END IF
      END DO
      IF (IG > 1) RETURN
C * Wyckoff sequence :
      J = 0
      DO I = 27, 1, -1
        IF (NWYCK(I) /= 0) THEN
          J       = J + 1
          WSEQ(J) = CHAR (96 + I)
C * conversion nwyck -> CHARACTERs :
          N = NWYCK(I)
          IF (N > 1) THEN
            WRITE (AUX, 99989, IOSTAT = IOST) N
            DO K = 1, 3
              IF (AUX(K:K) /= ' ') THEN
                J = J + 1
                WSEQ(J) = AUX(K:K)
              END IF
            END DO
          END IF
          J       = J + 1
          WSEQ(J) = ' '
        END IF
      END DO
      WRITE (LU6,  99990, IOSTAT = IOST) WSEQ
      WRITE (LU63, 99994, IOSTAT = IOST) NGR, SPGR, (WSEQ(K), K = 1, 47)
      DO J = 48, 94
        IF (WSEQ(J) /= ' ') THEN
          WRITE (LU63, 99995, IOSTAT = IOST) (WSEQ(K), K = 48, 94)
          EXIT
        END IF
      END DO
      DO J = 95, 108
        IF (WSEQ(J) /= ' ') THEN
          WRITE (LU63, 99995, IOSTAT = IOST) (WSEQ(K), K = 95, 108)
          EXIT
        END IF
      END DO
      AUX1   = ' '
      ORTXT  = ' '
      TRATXT = ' '
      OR(1)  = O1
      OR(2)  = O2
      OR(3)  = O3
C * LENGTH AX
      LAX = 47
      IF (AX == 'abc' .OR. AX == 'a,b,c') THEN
        LAX = 0
      ELSE
        NBL = 0
        DO I = 1, 47
          IF (AX(I:I) == ' ') THEN
            NBL = NBL + 1
            IF (NBL == 2) THEN
              LAX = I - 2
              GO TO 120
            END IF
          END IF
        END DO
      END IF
C * LENGTH OF TEXT
  120 LXYZ = 17
      IF (TEXT == 'x,y,z') THEN
        LXYZ = 0
      ELSE
        NBL = 0
        DO I = 1, 17
          IF (TEXT(I:I) == ' ') THEN
            NBL = NBL + 1
            IF (NBL == 2) THEN
              LXYZ = I - 2
              GO TO 130
            END IF
          END IF
        END DO
      END IF
  130 I1 = 1
      IF (LAX > 0) THEN
        TRATXT(I1:LAX + 4) = AX(1:LAX)//'     '
        I1 = I1 + LAX + 5
      END IF
      IF (LXYZ > 0) THEN
        TRATXT(I1: LXYZ + 4) = TEXT(1:LXYZ)//'     '
        I1 = I1 + LXYZ + 5
      END IF
      I1 = I1 -1
C * ORIGIN
      LORI = 1
      IF (O1 == 0. .AND. O2 == 0. .AND. O3 == 0.) THEN
        IF (LAX == 0 .AND. LXYZ == 0) GO TO 170
        GO TO 160
      ELSE
        IF (LAX == 0 .AND. LXYZ == 0) THEN
          ORTXT(LORI:LORI+6) = 'Origin '
        ELSE
          ORTXT(LORI:LORI+6) = 'origin '
        END IF
        LORI                 = LORI + 7
      END IF
      DO 150 KEER = 1, 3
        IF ((ICOORD == 1 .AND. KEER == 3) .OR.
     1      (ICOORD == 2 .AND. KEER == 2) .OR.
     2      (ICOORD == 3 .AND. KEER == 1) .OR.
     3      (ICOORD == 3 .AND. KEER == 3)) GO TO 140
        IF (ICOORD /= 4) THEN
          IF (OR(KEER) == 0.0) THEN
            ORTXT(LORI:LORI+1) = ' 0'
            LORI               = LORI + 2
          ELSE
            DO I = 1, 9
              IF (ABS (OR(KEER) - ORI(I)) <= 0.0001) THEN
                ORTXT(LORI:LORI + 3) = ' '//CHORI(I)(1:3)
                LORI                 = LORI + 4
                GO TO 150
              END IF
            END DO
            GO TO 140
          END IF
          GO TO 150
        END IF
C * ORIGIN NOT IN LIST; WRITE DECIMALS
  140   ORTXT(LORI:LORI) = ' '
        AUX1 = ' '
        WRITE (AUX1, 99985, IOSTAT = IOST) OR(KEER)
        ORTXT(LORI + 1:LORI + 6) = AUX1(1:6)
        LORI                     = LORI + 7
  150 CONTINUE
  160 IF (I1 > 0) THEN
        WRITE (LU63, 99986, IOSTAT = IOST) TRATXT(1:I1), ORTXT(1:LORI)
      ELSE
        WRITE (LU63, 99986, IOSTAT = IOST) ORTXT(1:LORI)
      END IF
C * CENTRE OF GRAVITY
  170 CG = 0.0
      IF (VOL > 0.0001) THEN
        V = VOL**0.333333
        WRITE (LU6, 99996, IOSTAT = IOST) VOL
        IF (VOLRAT > 0.0) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99997, IOSTAT = IOST) VOLRAT
        END IF
        CG = SQRT ((A * SUMX(1, KN))**2 + (B * SUMX(2, KN))**2
     1     + (C * SUMX(3, KN))**2 + 2.0 * (A * B * SXY(KN) * COSG
     2     + A * C * COSB * SXZ(KN) + B * C * COSA * SYZ(KN)))
     3     / (NATOM * V)
      END IF
      WRITE (LU63, 99999, IOSTAT = IOST) CG
      RETURN
99999 FORMAT ('CG', F8.4)
99998 FORMAT (F8.5)
99997 FORMAT ('Ratio volume Niggli-reduced cell/original cell : ',f5.2)
99996 FORMAT ('Volume of Unit Cell : ', F10.2)
99995 FORMAT ('SPCGRP', 27x, 47A1)
99994 FORMAT ('SPCGRP (', I3, ') ', A, ' - ', 47A1)
99993 FORMAT ('ATOM', 3X, A, I3, '(', A, ')', 2X, 3A, 1X, A, 13X, A)
99992 FORMAT (5X, A, I3, '(', A, ')', 1X, 3A, 1X, A, 20X, 2A)
99991 FORMAT ('Element ', A2, ' is not in list of first ', I2,
     1 /' elements so it will not have the correct indentation.')
99990 FORMAT (/, 'Wyckoff sequence : ', 108a1)
99989 FORMAT (I3)
99988 FORMAT (F5.3)
99987 FORMAT (F4.3)
99986 FORMAT ('TRANS  ', 2A)
99985 FORMAT (F6.5)
99984 FORMAT (A, 3F10.4)
      END SUBROUTINE PLA305
 
      SUBROUTINE PLA306 (NUM)
C * called by main program of STIDY
C * contains information about originshifts.
      USE stidy
      IMPLICIT NONE
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: NUM
      INTEGER, DIMENSION(230) :: IGROUP
      IGROUP = (/
     1 10,  1, 17, 17, 18, 19, 19, 20, 20,  1,  1,  6,  1,  1,  6,  1,
     2  1,  1,  1,  6,  6,  7,  6,  6, 11, 11, 11, 11, 11, 11, 11, 11,
     3 11, 11, 12, 12, 12, 13, 13, 13, 13, 14, 14, 12, 12, 12,  1,  1,
     4  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  6,  6,
     5  6,  6,  6,  6,  4,  4,  6,  6,  6,  6, 15, 15, 15, 15, 14, 14,
     6  2,  8,  2,  2,  2,  2,  3,  3,  2,  2,  2,  2,  2,  2,  2,  2,
     7  3,  3, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 14, 14,  2,  2,
     8  2,  2,  2,  2,  2,  2,  8,  8,  3,  3,  2,  2,  2,  2,  2,  2,
     9  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  3,  3,  3,  3, 16, 16,
     * 16, 14,  3,  3,  5,  3,  5,  3,  5,  3,  3, 16, 14, 16, 14, 14,
     1 14,  3,  3,  3,  3,  3,  3, 14, 14, 14, 14, 14, 14,  5,  3,  3,
     2  3,  3,  3,  3,  3,  3, 14, 14, 14, 14,  5,  5,  3,  3,  3,  3,
     3  3,  3,  4,  7,  9,  4,  9,  4,  4,  4,  4,  9,  4,  9,  4,  4,
     4  4,  4,  9,  4,  4,  9,  4,  7,  9,  4,  7,  9,  4,  4,  4,  4,
     5  4,  4,  4,  4,  9,  9/)
      DO I = 1, 8
        DO J = 1, 3
          ORGADD(J, I) = 0.0
        END DO
      END DO
      SELECT CASE (IGROUP(NUM))
C * 0 0 0, 1/2 0 0, 0 1/2 0, 0 0 1/2, 0 1/2 1/2, 1/2 0 1/2, 1/2 1/2 0,
C * 1/2 1/2 1/2
        CASE (1)
          NOR          = 8
          ORGADD(1, 2) = 0.5
          ORGADD(2, 3) = 0.5
          ORGADD(3, 4) = 0.5
          ORGADD(2, 5) = 0.5
          ORGADD(3, 5) = 0.5
          ORGADD(1, 6) = 0.5
          ORGADD(3, 6) = 0.5
          ORGADD(1, 7) = 0.5
          ORGADD(2, 7) = 0.5
          ORGADD(1, 8) = 0.5
          ORGADD(2, 8) = 0.5
          ORGADD(3, 8) = 0.5
c * 0 0 0, 0 0 1/2, 1/2 1/2 0, 1/2 1/2 1/2
        CASE (2)
          NOR          = 4
          ORGADD(3, 2) = 0.5
          ORGADD(1, 3) = 0.5
          ORGADD(2, 3) = 0.5
          ORGADD(1, 4) = 0.5
          ORGADD(2, 4) = 0.5
          ORGADD(3, 4) = 0.5
C * 0 0 0, 0 0 1/2
        CASE (3)
          NOR          = 2
          ORGADD(3, 2) = 0.5
C * 0 0 0, 1/2 1/2 1/2
        CASE (4)
          NOR          = 2
          ORGADD(1, 2) = 0.5
          ORGADD(2, 2) = 0.5
          ORGADD(3, 2) = 0.5
C * 0 0 0, 0 0 1/2, 1/3 2/3 0, 1/3 2/3 1/2, 2/3 1/3 0, 2/3 1/3 1/2
        CASE (5)
          NOR          = 6
          ORGADD(3, 2) = 0.5
          ORGADD(1, 3) = 1.0 / 3.0
          ORGADD(2, 3) = 2.0 / 3.0
          ORGADD(1, 4) = 1.0 / 3.0
          ORGADD(2, 4) = 2.0 / 3.0
          ORGADD(3, 4) = 0.5
          ORGADD(1, 5) = 2.0 / 3.0
          ORGADD(2, 5) = 1.0 / 3.0
          ORGADD(1, 6) = 2.0 / 3.0
          ORGADD(2, 6) = 1.0 / 3.0
          ORGADD(3, 6) = 0.5
C * 0 0 0, 0 0 1/2, 0 1/2 0, 0 1/2 1/2
        CASE (6)
          NOR          = 4
          ORGADD(3, 2) = 0.5
          ORGADD(2, 3) = 0.5
          ORGADD(2, 4) = 0.5
          ORGADD(3, 4) = 0.5
C * 0 0 0, 1/4 1/4 1/4, 1/2 1/2 1/2, 3/4 3/4 3/4
        CASE (7)
          NOR          = 4
          ORGADD(1, 2) = 0.25
          ORGADD(2, 2) = 0.25
          ORGADD(3, 2) = 0.25
          ORGADD(1, 3) = 0.5
          ORGADD(2, 3) = 0.5
          ORGADD(3, 3) = 0.5
          ORGADD(1, 4) = 0.75
          ORGADD(2, 4) = 0.75
          ORGADD(3, 4) = 0.75
C * 0 0 0, 0 0 1/2, 0 1/2 1/4, 0 1/2 3/4
        CASE (8)
          NOR          = 4
          ORGADD(3, 2) = 0.5
          ORGADD(2, 3) = 0.5
          ORGADD(3, 3) = 0.25
          ORGADD(2, 4) = 0.5
          ORGADD(3, 4) = 0.75
C * 0 0 0
        CASE (9)
          NOR = 1
c * x y z
        CASE (10)
          NOR = -31
C * 0 0 z, 0 1/2 z, 1/2 0 z, 1/2 1/2 z
        CASE (11)
          NOR          = -4
          ORGADD(2, 2) = 0.5
          ORGADD(1, 3) = 0.5
          ORGADD(1, 4) = 0.5
          ORGADD(2, 4) = 0.5
C * 0 0 z, 0 1/2 z
        CASE (12)
          NOR          = -2
          ORGADD(2, 2) = 0.5
C * 0 0 z, 1/2 0 z
        CASE (13)
          NOR          = -2
          ORGADD(1, 2) = 0.5
C * 0 0 z
        CASE (14)
          NOR = -1
C * 0 0 z, 1/2 1/2 z
        CASE (15)
          NOR          = -2
          ORGADD(1, 2) = 0.5
          ORGADD(2, 2) = 0.5
C * 0 0 z, 1/3 2/3 z, 2/3 1/3 z
        CASE (16)
          NOR          = -3
          ORGADD(1, 2) = 1.0 / 3.0
          ORGADD(2, 2) = 2.0 / 3.0
          ORGADD(1, 3) = 2.0 / 3.0
          ORGADD(2, 3) = 1.0 / 3.0
C * 0 y 0, 0 y 1/2, 1/2 y 0, 1/2 y 1/2
        CASE (17)
          NOR          = -14
          ORGADD(3, 2) = 0.5
          ORGADD(1, 3) = 0.5
          ORGADD(1, 4) = 0.5
          ORGADD(3, 4) = 0.5
c * 0 y 0, 0 y 1/2
        CASE (18)
          NOR          = -12
          ORGADD(3, 2) = 0.5
C * x 0 z, x 1/2 z
        CASE (19)
          NOR          = -22
          ORGADD(2, 2) = 0.5
c * x 0 z
        CASE (20)
          NOR = -21
      END SELECT
      RETURN
      END SUBROUTINE PLA306
 
      SUBROUTINE PLA307 (N, IER)
C * TRANSFORMATION OF CELL PARAMETERS TO STANDARD SPACE GROUP SETTING
C * CALLED FROM PLA302
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER          :: N
      INTEGER          :: IER
      REAL             :: AN
      REAL             :: BN
      REAL             :: CN
      REAL             :: EPS
      REAL             :: AN2
      REAL             :: CN2
      REAL             :: BEN
      CHARACTER(len=9) :: AXES
      EPS  = 0.0001
      ALF  = AL / RRX
      BET  = BE / RRX
      GAM  = GA / RRX
      COSA = COS (ALF)
      COSB = COS (BET)
      COSG = COS (GAM)
C * b,c,a
   10 SELECT CASE (N)
        CASE (1)
          AXES = 'b,c,a'
          AN   = B
          BN   = C
          CN   = A
          BEN  = GA
C * c,a,b
        CASE (2)
          AXES = 'c,a,b'
          AN   = C
          BN   = A
          CN   = B
          BEN  = AL
C * a,-c,b
        CASE (3)
          AXES = 'a,-c,b'
          AN   = A
          BN   = C
          CN   = B
          BEN  = GA
C * b,-a,c
        CASE (4)
          AXES = 'b,-a,c'
          AN   = B
          BN   = A
          CN   = C
          BEN  = AL
C * c,-b,a
        CASE (5)
          AXES = 'c,-b,a'
          AN   = C
          BN   = B
          CN   = A
          BEN  = BE
C * -b,a,b+c
        CASE (6)
          IF (AL < 90.0) THEN
            N = 18
            GO TO 10
          END IF
          IF (C < B) THEN
            N = 12
            GO TO 10
          END IF
          AXES = '-b,a,b+c'
          AN   = B
          BN   = A
          CN   = SQRT (B**2 + C**2 + 2.0 * B * C * COSA)
          IF (B < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((B**2 + CN**2 - C**2) / (2.0 * B * CN)))
C * -b-c,a,c
        CASE (7)
          IF (AL < 90.0) THEN
            N = 19
            GO TO 10
          END IF
          IF (B < C) THEN
            N = 13
            GO TO 10
          END IF
          AXES = '-b-c,a,c'
          AN2  = B**2 + C**2 + 2.0 * B * C * COSA
          AN   = SQRT (AN2)
          BN   = A
          CN   = C
          IF (C < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + C**2 - B**2) / (2.0 * AN * C)))
C * -c,b,a+c
        CASE (8)
          IF (BE < 90.0) THEN
            N = 20
            GO TO 10
          END IF
          IF (A < C) THEN
            N = 14
            GO TO 10
          END IF
          AXES = '-c,b,a+c'
          AN   = C
          BN   = B
          CN2  = A**2 + C**2 + 2.0 * A * C * COSB
          CN   = SQRT (CN2)
          IF (C < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((C**2 + CN2 - A**2) / (2.0 * C * CN)))
C * -(a+c),b,a
        CASE (9)
          IF (BE < 90.0) THEN
            N = 21
            GO TO 10
          END IF
          IF (C < A) THEN
            N = 15
            GO TO 10
          END IF
          AXES = '-a-c,b,a'
          AN2  = A**2 + C**2 + 2.0 * A * C * COSB
          AN   = SQRT (AN2)
          BN   = B
          CN   = A
          IF (A < EPS .OR. AN < EPS) GO TO 20
          BEN = RRX * ACOS (-((AN2 + A**2 - C**2) / (2.0 * AN * A)))
C * -a,c,a+b
        CASE (10)
          IF (GA < 90.0) THEN
            N = 22
            GO TO 10
          END IF
          IF (B < A) THEN
            N = 16
            GO TO 10
          END IF
          AXES = '-a,c,a+b'
          AN   = A
          BN   = C
          CN2  = A**2 + B**2 + 2.0 * A * B * COSG
          CN   = SQRT (CN2)
          IF (A < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((CN2 + A**2 - B**2) / (2.0 * CN * A)))
C * -(a+b),c,b
        CASE (11)
          IF (ga < 90.0) THEN
            N = 23
            GO TO 10
          END IF
          IF (A < B) THEN
            N = 17
            GO TO 10
          END IF
          AXES = '-a-b,c,b'
          AN2  = A**2 + B**2 + 2.0 * A * B * COSG
          BN   = C
          CN   = B
          AN   = SQRT (AN2)
          IF (B < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + B**2 - A**2) / (2.0 * AN * B)))
C * -c,-a,b+c
        CASE (12)
          AXES = '-c,-a,b+c'
          AN   = C
          BN   = A
          CN2  = B**2 + C**2 + 2.0 * B * C * COSA
          CN   = SQRT (CN2)
          IF (C < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((C**2 + CN2 - B**2) / (2.0 * CN * C)))
C * -b-c,-a,b
        CASE (13)
          AXES = '-b-c,-a,b'
          AN2  = B**2 + C**2 + 2.0 * B * C * COSA
          AN   = SQRT (AN2)
          BN   = A
          CN   = B
          IF (B < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + B**2 - C**2) / (2.0 * AN * B)))
C * -a,-b,a+c
        CASE (14)
          AXES = '-a,-b,a+c'
          AN   = A
          BN   = B
          CN2  = A**2 + C**2 + 2.0 * A * C * COSB
          CN   = SQRT (CN2)
          IF (A < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((A**2 + CN2 - C**2) / (2.0 * A * CN)))
C * -a-c,-b,c
        CASE (15)
          AXES = '-a-c,-b,c'
          AN2  = A**2 + C**2 + 2.0 * A * C * COSB
          AN   = SQRT (AN2)
          BN   = B
          CN   = C
          IF (C < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + C**2 - A**2) / (2.0 * AN * C)))
C * -b,-c,a+b
        CASE (16)
          AXES = '-b,-c,a+b'
          AN   = B
          BN   = C
          CN2  = A**2 + B**2 + 2.0 * A * B * COSG
          CN   = SQRT (CN2)
          IF (B < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((CN2 + B**2 - A**2) / (2.0 * CN * B)))
C * -(a+b),-c,a
        CASE (17)
          AXES = '-a-b,-c,a'
          AN2  = A**2 + B**2 + 2.0 * A * B * COSG
          BN   = C
          CN   = A
          AN   = SQRT (AN2)
          IF (A < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + A**2 - B**2) / (2.0 * AN * A)))
C * b,-a,c-b
        CASE (18)
          IF (C < B) THEN
            N = 24
            GO TO 10
          END IF
          AXES = 'b,-a,c-b'
          AN   = B
          BN   = A
          CN2  = B**2 + C**2 - 2.0 * B * C * COSA
          CN   = SQRT (CN2)
          IF (B < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((B**2 + CN2 - C**2) / (2.0 * B * CN)))
C * b-c,-a,c
        CASE (19)
          IF (B < C) THEN
            N = 25
            GO TO 10
          END IF
          AXES = 'b-c,-a,c'
          AN2  = B**2 + C**2 - 2.0 * B * C * COSA
          AN   = SQRT (AN2)
          BN   = A
          CN   = C
          IF (C < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + C**2 - B**2) / (2.0 * AN * C)))
C * c,-b,a-c
        CASE (20)
          IF (A < C) THEN
            N = 26
            GO TO 10
          END IF
          AXES = 'c,-b,a-c'
          AN   = C
          BN   = B
          CN2  = A**2 + C**2 - 2.0 * A * C * COSB
          CN   = SQRT (CN2)
          IF (C < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((C**2 + CN2 - A**2) / (2.0 * C * CN)))
C * c-a,-b,a
        CASE (21)
          IF (C < A) THEN
            N = 27
            GO TO 10
          END IF
          AXES = 'c-a,-b,a'
          AN2  = A**2 + C**2 - 2.0 * A * C * COSB
          AN   = SQRT (AN2)
          BN   = B
          CN   = A
          IF (A < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + A**2 - C**2) / (2.0 * AN * A)))
C * a,-c,b-a
        CASE (22)
          IF (B < A) THEN
            N = 28
            GO TO 10
          END IF
          AXES = 'a,-c,b-a'
          AN   = A
          BN   = C
          CN2  = A**2 + B**2 - 2.0 * A * B * COSG
          CN   = SQRT (CN2)
          IF (A < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((CN2 + A**2 - B**2) / (2.0 * CN * A)))
C * a-b,-c,b
        CASE (23)
          IF (A < B) THEN
            N = 29
            GO TO 10
          END IF
          AXES = 'a-b,-c,b'
          AN2  = A**2 + B**2 - 2.0 * A * B * COSG
          BN   = C
          CN   = B
          AN   = SQRT (AN2)
          IF (B < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + B**2 - A**2) / (2.0 * AN * B)))
C * c,a,b-c
        CASE (24)
          AXES = 'c,a,b-c'
          AN   = C
          BN   = A
          CN2  = B**2 + C**2 - 2.0 * B * C * COSA
          CN   = SQRT (CN2)
          IF (C < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((C**2 + CN2 - B**2) / (2.0 * C * CN)))
C * c-b,a,b
        CASE (25)
          AXES = 'c-b,a,b'
          AN2  = B**2 + C**2 - 2.0 * B * C * COSA
          AN   = SQRT (AN2)
          BN   = A
          CN   = B
          IF (B < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + B**2 - C**2) / (2.0 * AN * B)))
c * a,b,c-a
        CASE (26)
          AXES = 'a,b,c-a'
          AN   = A
          BN   = B
          CN2  = A**2 + C**2 - 2.0 * A * C * COSB
          CN   = SQRT (CN2)
          IF (A < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((A**2 + CN2 - C**2) / (2.0 * A * CN)))
c * a-c,b,c
        CASE (27)
          AXES = 'a-c,b,c'
          AN2  = A**2 + C**2 - 2.0 * A * C * COSB
          AN   = SQRT (AN2)
          BN   = B
          CN   = C
          IF (C < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + C**2 - A**2) / (2.0 * AN * C)))
c * b,c,a-b
        CASE (28)
          AXES = 'b,c,a-b'
          AN   = B
          BN   = C
          CN2  = A**2 + B**2 - 2.0 * A * B * COSG
          CN   = SQRT (CN2)
          IF (B < EPS .OR. CN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((CN2 + B**2 - A**2) / (2.0 * CN * B)))
C * b-a,c,a
        CASE (29)
          AXES = 'b-a,c,a'
          AN2  = A**2 + B**2 - 2.0 * A * B * COSG
          BN   = C
          CN   = A
          AN   = SQRT (AN2)
          IF (A < EPS .OR. AN < EPS) GO TO 20
          BEN  = RRX * ACOS (-((AN2 + A**2 - B**2) / (2.0 * AN * A)))
      END SELECT
      A  = AN
      B  = BN
      C  = CN
      BE = BEN
      IF (be == 0.0) be = 90.0
      IFNG(2) = 2
      CALL PLA262 (2)
      WRITE (LU7, 99999, IOSTAT = IOST) SPGR, AXES, A, B, C, BE
      RETURN
   20 CALL PLA262 (1)
      WRITE (LU7, 99998, IOSTAT = IOST)
      IER = 1
      RETURN
99999 FORMAT ('Transformation of axes into standard setting ',
     1 A, ' : ', A, /, 'New axes :', 3F8.4, 5X, 'beta=', F6.2)
99998 FORMAT ('Division by 0; no transformation performed.')
      END SUBROUTINE PLA307
 
      SUBROUTINE PLA308
C * called by PLA314; interchanges axes for orthorhombic groups
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: IAB
      INTEGER            :: IBC
      REAL               :: X
      REAL               :: AXTOL
      REAL, DIMENSION(3) :: PL
      CHARACTER(len=6)   :: AXES
c
      AXES  = 'a,b,c'
      AXTOL = 0.005
      IAB   = 0
      IBC   = 0
      CALL GEN074 (PL, 1, 3, 0.0)
C * minsh indicates which coordinate is going to be negative ->
C * change sign of eventual shift.
      MINSH = 0
      J     = IW - 6
      CALL GEN074 (U9, 1, 9, 0.0)
      IF (J == 1 .OR. J == 4 .OR. J == 7 .OR. J == 8) THEN
C * a < b < c
        IF (ABS (A - B) < AXTOL) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99998, IOSTAT = IOST) A, B
          IAB = 1
        END IF
        IF (ABS (B - C) < AXTOL) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99997, IOSTAT = IOST) B, C
          IBC = 1
        END IF
        IF (IAB == 1 .AND. IBC == 1) RETURN
        IF (A < B) THEN
          IF (B > C) THEN
            IF (A < C) THEN
              IF (IW == 14) RETURN
c * a-cb
              AXES  = 'a,-c,b'
              CALL GEN018 (B, C)
              U9(1)  = 1.0
              U9(6)  =-1.0
              U9(8)  = 1.0
              MINSH = 2
c * x-1/4 -z-1/4 y-1/4
              IF (IW == 10) THEN
                PL(1) = 0.25
                PL(2) = 0.25
                PL(3) = 0.25
                NABC  = 5
              END IF
C * x-1/4 -z y-1/4
              IF (IW == 13) THEN
                PL(1) = 0.25
                PL(3) = 0.25
                NABC  = 12
              END IF
            ELSE
C * cab
              AXES = 'c,a,b'
              X    = C
              C    = B
              B    = A
              A    = X
              U9(3) = 1.0
              U9(4) = 1.0
              U9(8) = 1.0
            END IF
          END IF
C * a > b
        ELSE
          IF (B < C) THEN
            IF (A < C) THEN
              IF (IW == 14) THEN
c * bca  (for Pbca, IW=14)
                AXES = 'b,c,a'
                X    = B
                B    = C
                C    = A
                A    = X
                U9(2) = 1.0
                U9(6) = 1.0
                U9(7) = 1.0
                GO TO 10
              END IF
C * ba-c
              AXES  = 'b,a,-c'
              CALL GEN018 (A, B)
              U9(2)  = 1.0
              U9(4)  = 1.0
              U9(9)  =-1.0
              MINSH = 3
C * y-1/4 x-1/4 3/4-z
              IF (IW == 10) THEN
                PL(1) = 0.25
                PL(2) = 0.25
                PL(3) = 0.25
                NABC  = 5
              END IF
C * y-1/4 x-1/4 -z
              IF (IW == 13) THEN
                PL(1) = 0.25
                PL(2) = 0.25
                NABC  = 6
              END IF
            ELSE
C * bca
              AXES = 'b,c,a'
              X    = B
              B    = C
              C    = A
              A    = X
              U9(2) = 1.0
              U9(6) = 1.0
              U9(7) = 1.0
            END IF
          ELSE
            IF (IW == 14) THEN
C * cab  (for Pbca, IW=14)
              AXES = 'c,a,b'
              X    = C
              C    = B
              B    = A
              A    = X
              U9(3) = 1.0
              U9(4) = 1.0
              U9(8) = 1.0
              GO TO 10
            END IF
C * -cba
            AXES  = '-c,b,a'
            CALL GEN018 (A, C)
            U9(3)  =-1.0
            U9(5)  = 1.0
            U9(7)  = 1.0
            MINSH = 1
C * 3/4-z y-1/4 x-1/4
            IF (IW == 10) THEN
              PL(1) = 0.25
              PL(2) = 0.25
              PL(3) = 0.25
              NABC  = 5
            END IF
c * -z y-1/4 x-1/4
            IF (IW == 13) THEN
              PL(2) = 0.25
              PL(3) = 0.25
              NABC  = 15
            END IF
          END IF
        END IF
        GO TO 10
      ELSE IF (J == 2 .OR. J == 3 .OR. J == 5 .OR. J == 6)
     1 THEN
c * a<b
        IF (ABS (A - B) < AXTOL) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99998, IOSTAT = IOST) A, B
          RETURN
        END IF
C * ba-c
        IF (A > B) THEN
          AXES  = 'b,a,-c'
          CALL GEN018 (A, B)
          U9(2)  = 1.0
          U9(4)  = 1.0
          U9(9)  =-1.0
          MINSH = 3
C * y x 3/4-z
          IF (IW == 9) THEN
            PL(3) = 0.25
            NABC  = 16
          END IF
c * y-1/4 x-1/4 3/4-z
          IF (IW == 11) THEN
            PL(1) = 0.25
            PL(2) = 0.25
            PL(3) = 0.25
            NABC  = 5
          END IF
C * y-1/4 x-1/4 -z
          IF (IW == 12) THEN
            PL(1) = 0.25
            PL(2) = 0.25
            NABC  = 6
          END IF
        END IF
        GO TO 10
      END IF
C * update transformation matrix :
   10 IF (AXES == 'a,b,c') RETURN
      DO I = 1, 3
        PLUS(I) = PLUS(I) + PL(I)
        IF (PLUS(I) > 1.0) PLUS(I) = PLUS(I) - 1.0
      END DO
      IF (IFNG(2) == 2) THEN
        CALL GEN004 (UVW, U9, P9)
C * COPY VECTOR
        CALL GEN113 (P9, UVW, 9)
      ELSE
        CALL GEN113 (U9, UVW, 9)
      END IF
      IFNG(2) = 2
      IF (NABC > 0) IFPLUS = IFPLUS + 2
      CALL PLA262 (1)
      WRITE (LU7, 99999, IOSTAT = IOST) AXES, A, B, C
      RETURN
99999 FORMAT ('Axes are changed to ', A6, 6x,'new axes: ', 3F9.4)
99998 FORMAT (/, 'WARNING : axes a & b are very similar:', 2F10.4)
99997 FORMAT (/, 'WARNING : axes b & c are very similar:', 2F10.4)
      END SUBROUTINE PLA308
 
      SUBROUTINE PLA309 (S)
      USE stidy
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: M
      INTEGER                        :: M1
      INTEGER                        :: II
      INTEGER                        :: KK
      INTEGER                        :: MM
      INTEGER                        :: IOST
      INTEGER,          DIMENSION(9) :: IVLAG
      REAL                           :: EP
      REAL                           :: SK
      REAL                           :: SABS
      REAL,             DIMENSION(9) :: S
      CHARACTER(len=1), DIMENSION(3) :: CC
      CC = (/ 'a', 'b', 'c'/)
C * SUBROUTINE WRITES CHARACTER VARIABLE 'AX' (e.g. 'b,a,-c')
      AXS = ' '
      EP  = 0.00001
C * LOOK FOR REAL COEFFICIENTS IN MATRIX S
      DO I = 1, 9
        IVLAG(I) = 0
        SABS     = ABS (S(I))
        K        = INT (SABS + EP)
        IF (ABS (FLOAT (K) - SABS) > 0.0001) IVLAG(I) = 1
      END DO
C * LOOK AT AXES
      K = 0
      M = 1
      DO I = 1, 3
        MM = M
        DO J = 1, 3
          M1 = M
          K  = K + 1
          KK = 0
          SK = ABS (S(K))
          IF (SK > EP) THEN
            IF (IVLAG(K) == 0) KK = INT (SK + EP)
            IF (S(K) < 0.0) THEN
              AXS(M:M) = '-'
              M       = M + 1
            ELSE IF (M > MM) THEN
              AXS(M:M) = '+'
              M       = M + 1
            END IF
            IF (IVLAG(K) == 0) THEN
              IF (KK == 1) THEN
                M1 = M1 - 1
              ELSE IF (KK > 1) THEN
                WRITE (AXS(M:M), 99999, IOSTAT = IOST) KK
                M = M + 1
              END IF
            ELSE
C * WRITE FLOATING POINT VARIABLE INTO CHARACTER VARIABLES, SK IS ALWAYS POSITIV
              II = INT (SK + EP)
              WRITE (AXS(M:M), 99999, IOSTAT = IOST) II
              AXS(M + 1:M + 1) = '.'
              WRITE (AXS(M + 2:M + 2), 99999, IOSTAT = IOST)
     1          INT ((SK + 0.05 - FLOAT (II)) * 10)
              M = M + 3
            END IF
            IF (M /= M1 .OR. KK /= 0) THEN
              AXS(M:M) = CC(J)
              M       = M + 1
            END IF
          END IF
        END DO
        IF (I < 3) THEN
          AXS(M:M) = ','
          M        = M + 1
        END IF
      END DO
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (I1)
      END SUBROUTINE PLA309
 
      SUBROUTINE PLA310 (LU)
C * find 'best' unit cell for monoclinic groups
C * see Parthe & Gelato, Acta Cryst (1985) A41, 142-151.
      USE stidy
      IMPLICIT NONE
      INTEGER, PARAMETER             :: NSIZ = 50
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: L
      INTEGER                        :: I1
      INTEGER                        :: J1
      INTEGER                        :: K1
      INTEGER                        :: L1
      INTEGER                        :: L2
      INTEGER                        :: LU
      INTEGER                        :: IPZ
      INTEGER                        :: IQZ
      INTEGER                        :: IRZ
      INTEGER                        :: ISZ
      INTEGER                        :: IFA
      INTEGER                        :: IFC
      INTEGER                        :: IFK
      INTEGER                        :: NEG
      INTEGER                        :: JMAX
      INTEGER                        :: IOST
      INTEGER                        :: IMAX
      INTEGER                        :: IFTRA
      INTEGER                        :: IGROUP
      INTEGER, DIMENSION(NSIZ)       :: II
      INTEGER, DIMENSION(NSIZ)       :: JJ
      REAL                           :: B1
      REAL                           :: B2
      REAL                           :: BB
      REAL                           :: CS
      REAL                           :: AX
      REAL                           :: CX
      REAL                           :: VV
      REAL                           :: V2
      REAL                           :: DET
      REAL                           :: AX2
      REAL                           :: CSA
      REAL                           :: CSC
      REAL                           :: SINB
      REAL                           :: ANEW
      REAL                           :: CNEW
      REAL                           :: VMIN
      REAL                           :: VMAX
      REAL                           :: V2MAX
      REAL                           :: VLIMIT
      REAL,    DIMENSION(NSIZ, NSIZ) :: V
      REAL,    DIMENSION(NSIZ)       :: VS
c * remember if axes have already been transformed :
      IFTRA = 0
      IF (IFNG(2) == 2) IFTRA = 1
      CALL GEN074 (U9, 1, 9, 0.0)
      BB   = BE
      ANEW = A
      CNEW = C
      L1   = 0
      L2   = 1
      SINB = SIN (BET)
      DO I = 1, NSIZ
        DO J = 1, NSIZ
          V(J, I) = - 0.5
        END DO
      END DO
      IPZ    = 1
      IQZ    = 0
      IRZ    = 0
      ISZ    = 1
      CSA    = COSB
      CSC    = COSB
      VMAX   = AMAX1 (A, C)
      VLIMIT = VMAX / SINB
      V2MAX  = VMAX**2
      IMAX   = INT (VLIMIT / A + 1.0)
      JMAX   = INT (VLIMIT / C + 1.0)
      IF (IMAX >= NSIZ .OR. JMAX >= NSIZ) THEN
        WRITE (LU, 99991, IOSTAT = IOST) IMAX, JMAX
        RETURN
      END IF
C * change value of nsiz in routine PLA310
      DO I = 1, IMAX
        AX = I * A
        AX2 = AX**2
        DO J = 1, JMAX
          CX = J * C
          V2 = AX2 + CX**2 + 2.0 * AX * CX * COSB
          IF (V2 <= V2MAX) THEN
            VV              = SQRT (V2)
            V(I + 1, J + 1) = VV
          END IF
        END DO
      END DO
C * a and c also in v : to all indices is added 1
      V(2, 1) = A
      V(1, 2) = C
C * sort vectors v:
      K    = 0
   10 VMIN = VMAX
      IFK  = 0
      K    = K + 1
C * Change parameter NSIZ in SUBROUTINE SHORT
      IF (K > NSIZ) THEN
        WRITE (LU, 99992, IOSTAT = IOST)
        RETURN
      END IF
      IMAX = IMAX + 1
      JMAX = JMAX + 1
      DO J = 1, JMAX
        DO I = 1, IMAX
          IF (V(I, J) >= 0.0) THEN
            IF (V(I, J) <= VMIN) THEN
              VMIN = V(I, J)
              II(K) = I
              JJ(K) = J
              IFK   = 1
            END IF
          END IF
        END DO
      END DO
      IF (IFK == 0) THEN
        K = K - 1
      ELSE
        VS(K)   = VMIN
        I       = II(K)
        J       = JJ(K)
        V(I, J) = -VMIN
        GO TO 10
      END IF
C * for IW = 2 we should take relabelled Niggli cell; take two
C * shortest vectors for a and c without parity restrictions :
      IF (IW == 2) THEN
        IF (VS(1) == VS(2)) THEN
          WRITE (LU, 99993, IOSTAT = IOST)
        END IF
        IFA  = 1
        IFC  = 1
        ANEW = VS(1)
        CNEW = VS(2)
        IPZ  = II(1) - 1
        IQZ  = II(2) - 1
        IRZ  = JJ(1) - 1
        ISZ  = JJ(2) - 1
        GO TO 30
      END IF
c
      IGROUP = IW - 2
      IFA    = 0
      IFC    = 0
      IF (IGROUP == 1) THEN
        K1 = 1
      ELSE IF (IGROUP == 2) THEN
c * group 1 : C-groups ; q even, s odd
c * group 2 : P-groups ; p odd, r even
        L1 = 1
        L2 = 0
        K1 = 1
      ELSE IF (IGROUP == 3 .OR. IGROUP == 4) THEN
C * C c  and C 2/c  ; p odd, q even, s odd
        K1 = 1
        DO
          DO I = K1, K
            I1 = II(I) - 1
            J1 = JJ(I) - 1
            IF (MOD (J1, 2) == 0) THEN
C * may be new a
              IF (MOD (I1, 2) == 1) THEN
                IF (IFC == 0 .OR. ABS (I1 * ISZ - J1 * IRZ) == 1) THEN
                  IPZ  = I1
                  IQZ  = J1
                  IFA  = I
                  ANEW = VS(I)
                END IF
              END IF
            ELSE
              IF (IFA == 0 .OR. ABS (I1 * IQZ - J1 * IPZ) == 1) THEN
                ISZ  = J1
                IRZ  = I1
                CNEW = VS(I)
                IFC  = I
              END IF
            END IF
            IF (IFA > 0 .AND. IFC > 0) GO TO 20
            IF (IFA > 0 .OR.  IFC > 0) EXIT
          END DO
          IF (IFA > 0) THEN
C * look for c : s odd
            DO J = 1, K
              IF (J /= IFA) THEN
                I1 = II(J) - 1
                J1 = JJ(J) - 1
                IF (MOD (J1, 2) == 1) THEN
                  IF (ABS (I1 * IQZ - J1 * IPZ) == 1) THEN
                    ISZ  = J1
                    IRZ  = I1
                    CNEW = VS(J)
                    IFC  = J
                    GO TO 20
                  END IF
                END IF
              END IF
            END DO
            IF (K1 == K) GO TO 40
            IFA = 0
            IFC = 0
            K1  = K1 + 1
          ELSE
C * look for a : p odd , q even
            DO J = 1, K
              IF (J /= IFC) THEN
                I1 = II(J) - 1
                J1 = JJ(J) - 1
                IF (MOD (I1, 2) == 1 .AND. MOD (J1, 2) == 0) THEN
                  IF (ABS (I1 * ISZ - J1 * IRZ) == 1) THEN
                    IPZ  = I1
                    IQZ  = J1
                    IFA  = J
                    ANEW = VS(J)
                    GO TO 20
                  END IF
                END IF
              END IF
            END DO
            IF (K1 == K) GO TO 40
            IFA = 0
            IFC = 0
            K1  = K1 + 1
          END IF
        END DO
      END IF
      DO
        DO I = K1, K
          I1 = II(I) - 1
          J1 = JJ(I) - 1
          L  = I1
          IF (IGROUP == 1) L = J1
          IF (MOD (L, 2) == L1) THEN
            IF (IFC == 0 .or. ABS (I1 * ISZ - J1 * IRZ) == 1) THEN
              IPZ  = I1
              IQZ  = J1
              IFA  = I
              ANEW = VS(I)
            END IF
          ELSE
            IF (IFA == 0 .OR. ABS (I1 * IQZ - J1 * IPZ) == 1) THEN
              ISZ  = J1
              IRZ  = I1
              CNEW = VS(I)
              IFC  = I
            END IF
          END IF
          IF (IFA > 0 .AND. IFC > 0) GO TO 30
          IF (IFA > 0 .OR.  IFC > 0) EXIT
        END DO
        IF (IFA > 0) THEN
C * look for c: r even for P-group; s odd for C-group
          DO J = 1, K
            IF (J /= IFA) THEN
              I1 = II(J) - 1
              J1 = JJ(J) - 1
              L  = I1
              IF (IGROUP == 1) L = J1
              IF (MOD (L, 2) == L2) THEN
                IF (ABS (I1 * IQZ - J1 * IPZ) == 1) THEN
                  ISZ  = J1
                  IRZ  = I1
                  CNEW = VS(J)
                  IFC  = J
                  GO TO 30
                END IF
              END IF
            END IF
          END DO
          IF (K1 == K) GO TO 40
          IFA = 0
          IFC = 0
          K1  = K1 + 1
        ELSE
C * look for a (p odd for P-group; q even for C-group)
          DO J = 1, K
            IF (J /= IFC) THEN
              I1 = II(J) - 1
              J1 = JJ(J) - 1
              L  = I1
              IF (IGROUP == 1) L = J1
              IF (MOD (L, 2) == L1) THEN
                IF (ABS (I1 * ISZ - J1 * IRZ) == 1) THEN
                  IPZ  = I1
                  IQZ  = J1
                  IFA  = J
                  ANEW = VS(J)
                  GO TO 30
                END IF
              END IF
            END IF
          END DO
          IF (K1 == K) GO TO 40
          IFA = 0
          IFC = 0
          K1  = K1 + 1
        END IF
      END DO
   20 IF (MOD (IRZ, 2) == 1) THEN
        IF (IGROUP == 3) THEN
          PLUS(2) = PLUS(2) + 0.25
          NSH     = 17
        ELSE
          PLUS(1) = PLUS(1) + 0.25
          PLUS(2) = PLUS(2) + 0.25
          NSH     = 6
        END IF
        IFPLUS = IFPLUS + 4
      END IF
   30 IF (IPZ /= 1 .OR. IQZ /= 0 .OR. IRZ /= 0 .OR. ISZ /= 1) THEN
        IFNG(2) = 2
        IF (IPZ == 0 .OR. IQZ == 0) IFA = 0
        IF (IRZ == 0 .OR. ISZ == 0) IFC = 0
        U9(5) = 1.0
        U9(1) = FLOAT (IPZ)
        U9(3) = FLOAT (IQZ)
        CSC  = 1.0
        IF (IQZ /= 0) CSC = (ANEW**2 + (IQZ * C)**2 - (IPZ * A)**2) /
     1     (2.0 * ANEW * IQZ * C)
        U9(7) = FLOAT (IRZ)
        U9(9) = FLOAT (ISZ)
        CSA = 1.0
        IF (IRZ /= 0) CSA = (CNEW**2 + (IRZ * A)**2 - (ISZ * C)**2) /
     1     (2.0 * CNEW * IRZ * A)
C * compute new angle beta :
C * (we cannot use the simple formula based on constant volume :
C * a'c'sin(beta') = acsin(beta) because this does not tell us the
C * sign of the new axes ).
        NEG = 1
        IF (IFA > 0 .AND. IFC > 0) THEN
          B1 = RRX * ACOS (CSA)
          B2 = RRX * ACOS (CSC)
          BB = BE - B1 - B2
          IF (BB < 0.0) THEN
            BB  = 180.0 + BB
            NEG = - 1
          END IF
          if (BB < 90.0) THEN
            BB = 180.0 - BB
            NEG = - NEG
          END IF
        ELSE IF (IFA > 0) THEN
          IF (IRZ == 0) THEN
            CS = CSC
          ELSE
            CS = ((IPZ * A)**2 + ANEW**2 - (IQZ * C)**2) /
     1           (2.0 * IPZ * A * ANEW)
          END IF
          IF (CS > 0.0) NEG = -1
          BB = RRX * ACOS (NEG * CS)
        ELSE IF (IFC > 0) THEN
          IF (IQZ == 0) THEN
            CS = CSA
          ELSE
            CS = ((ISZ * C)**2 + CNEW**2 - (IRZ * A)**2) /
     1           (2.0 * ISZ * C * CNEW)
          END IF
          IF (CS > 0.0) NEG = -1
          COSB = NEG * CS
          BB   = RRX * ACOS (NEG * CS)
        END IF
        CALL PLA262 (4)
        WRITE (LU, 99999, IOSTAT = IOST) IPZ, A, IQZ, C, ANEW
        WRITE (LU, 99998, IOSTAT = IOST) IRZ, A, ISZ, C, CNEW
        WRITE (LU, 99997, IOSTAT = IOST) BB
        U9(1) = NEG * U9(1)
        U9(3) = NEG * U9(3)
        DET   = U9(1) * U9(9) - U9(3) * U9(7)
        IF (DET < 0.0) U9(5) = - U9(5)
C * CONVERT U INTO CHARACTER STRING
        CALL PLA309 (U9)
        WRITE (LU, 99996, IOSTAT = IOST) AXS
        CALL GEN004 (UVW, U9, P9)
C * COPY VECTOR
        CALL GEN113 (P9, UVW, 9)
        A  = ANEW
        C  = CNEW
        BE = BB
        IF (IFTRA == 1) THEN
C * CONVERT S INTO CHARACTER STRING
          CALL PLA309 (UVW)
          CALL PLA262 (1)
          WRITE (LU, 99995, IOSTAT = IOST) AXS
        END IF
        CALL PLA262 (3)
        WRITE (LU, 99994, IOSTAT = IOST) A, B, C, AL, BE, GA
      END IF
      RETURN
   40 WRITE (LU, 99993, IOSTAT = IOST)
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (/, 'New a = ', I2, ' *', F8.4, ' +', I2, ' *', F8.4,
     1        ' = ', F8.4)
99998 FORMAT ('New c = ', I2, ' *', F8.4, ' +', I2, ' *', F8.4,
     1        ' = ', F8.4)
99997 FORMAT ('New angle beta = ', f8.4)
99996 FORMAT ('Transformation of Axes due to Cell Reduction : ', A)
99995 FORMAT ('Total transformation of axes : ', A)
99994 FORMAT ('Cell parameters after reduction :', /, 6F9.4)
99993 FORMAT ('No cell reduction found ')
99992 FORMAT ('WARNING : cell has not been reduced due to too ',
     1 ' small array size.')
99991 FORMAT ('WARNING : array size too small in routine for PLA310', /,
     1 'cell needed are : ', 2I4)
      END SUBROUTINE PLA310
 
      SUBROUTINE PLA311 (IFM)
C * called by PLA301 and PLA314
C * calls routines for Niggli-reduced cell.
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: IFM
      INTEGER               :: GEN135
      REAL                  :: C1
      REAL                  :: C2
      REAL                  :: C3
      REAL                  :: C4
      REAL                  :: C5
      REAL                  :: C6
      REAL,    DIMENSION(6) :: DOT
      REAL,    DIMENSION(6) :: AXF
      REAL,    DIMENSION(3) :: UX1
      REAL,    DIMENSION(3) :: UX2
      E1   = 0.000001
      IERR = 0
C * transformation to primitive cell (P, A, C, I, F, R)
      DO I = 1, 9
        UVW(I) = UVWX(I, NBR)
      END DO
C * TRANSFORMS THE INITIAL CELL BY UVW
C * CALCULATE THE 6 DOT PRODUCTS (DOT(1)...DOT(6))
      DO N = 1, 6
        DO I = 1, 3
          J = I
          M = I
          IF (N == 2) THEN
            M = I + 3
            J = I + 3
          ELSE IF (N == 3) THEN
            M = I + 6
            J = I + 6
          ELSE IF (N == 4) THEN
            J = I + 3
          ELSE IF (N == 5) THEN
            J = I + 6
          ELSE IF (N == 6) THEN
            M = I + 3
            J = I + 6
          END IF
          UX1(I) = UVW(M)
          UX2(I) = UVW(J)
        END DO
        C1 = UX1(1) * UX2(1)
        C2 = UX1(2) * UX2(2)
        C3 = UX1(3) * UX2(3)
        C4 = UX1(3) * UX2(2) + UX1(2) * UX2(3)
        C5 = UX1(3) * UX2(1) + UX1(1) * UX2(3)
        C6 = UX1(1) * UX2(2) + UX1(2) * UX2(1)
C * CALCULATE DOT PRODUCTS AND PARTIALS OF THE DOT PRODUCTS WITH
C * RESPECT TO A, B, C, ALF, BET, GAM (IN RADIANS)
        DOT(N) = C1 * (A**2) + C2 * (B**2) + C3 * (C**2)
     1         + C4 * C * B * COS (ALF) + C5 * C * A * COS (BET)
     2         + C6 * A * B * COS (GAM)
      END DO
      DO I = 1, 3
        AXF(I) = SQRT (DOT(I))
      END DO
      COSA   = DOT(6) / (AXF(2) * AXF(3))
      COSB   = DOT(5) / (AXF(1) * AXF(3))
      COSG   = DOT(4) / (AXF(1) * AXF(2))
      AXF(4) = ACOS (COSA) * RRX
      AXF(5) = ACOS (COSB) * RRX
      AXF(6) = ACOS (COSG) * RRX
      A      = AXF(1)
      B      = AXF(2)
      C      = AXF(3)
      ALF    = AXF(4) / RRX
      BET    = AXF(5) / RRX
      GAM    = AXF(6) / RRX
      AL     = AXF(4)
      BE     = AXF(5)
      GA     = AXF(6)
C * REDUCE THE CELL
      CALL PLA317
C * Write final matrix:
      WRITE (LU7, 99999, IOSTAT = IOST) UVW
C * IS UVW THE UNIT MATRIX ?
      IF (GEN135 (UVW) == 0) THEN
        IFNG(IFM) = 2
        A     = SQRT (SF11)
        B     = SQRT (SF22)
        C     = SQRT (SF33)
        COSA  = SF23 / (B * C)
        COSB  = SF13 / (A * C)
        COSG  = SF12 / (A * B)
        ALF   = ACOS (COSA)
        BET   = ACOS (COSB)
        GAM   = ACOS (COSG)
        AL    = ALF * RRX
        BE    = BET * RRX
        GA    = GAM * RRX
        WRITE (LU7, 99998, IOSTAT = IOST) A, B, C, AL, BE, GA
C * CONVERT UVW INTO CHARACTER STRING
        CALL PLA309 (UVW)
      ELSE
C * if axes not changed, keep input values:
        WRITE (LU7, 99997, IOSTAT = IOST) A, B, C, AL, BE, GA
        IFNG(IFM) = 0
      END IF
      RETURN
99999 FORMAT (//, 'Transformation matrix for Niggli cell : ',
     1 /, (' ', 3F4.1))
99998 FORMAT (//, 'Cell parameters after reduction :', /, 6F10.4)
99997 FORMAT ('No cell reduction; keep original cell parameters :', /,
     1 6F10.4)
      END SUBROUTINE PLA311
 
      SUBROUTINE PLA312
      USE files
      USE xwdw
      USE stidy
      IMPLICIT NONE
      INTEGER                            :: I
      INTEGER                            :: K
      INTEGER                            :: N
      INTEGER                            :: JJ
      INTEGER                            :: KK
      INTEGER                            :: IOTH
      INTEGER                            :: NATPR
      INTEGER                            :: NRREM
      CHARACTER(len=17)                  :: SP
      CHARACTER(len=38)                  :: WS
      CHARACTER(len=2)                   :: CH
      CHARACTER(len=73)                  :: DEF
      CHARACTER(len=10)                  :: NUMS
      CHARACTER(len=73)                  :: DATAX
      CHARACTER(len=73)                  :: DATAS
      CHARACTER(len=14)                  :: PEARS
      CHARACTER(len=24)                  :: PARAMS
      CHARACTER(len=2),  DIMENSION(NDIF) :: KEL
      CHARACTER(len=73), DIMENSION(5)    :: REMS
      NUMS = '1234567890'
C * LOOK FOR ATOM TYPES THAT OCCUR ONLY ONCE
      CALL GEN126 (KEL, 1, NDIF)
      KK = 0
      DO I = 1, NDIF
        IF (MAXNR(I) <= 1) THEN
          KK = KK + 1
          KEL(KK) = FINELT(I)
        END IF
      END DO
C * read file LU63, write file LU7
      IOTH   = 0
      PARAMS = ' '
      DATAS  = ' '
      DEF    = ' '
      PEARS  = ' '
      SP     = ' '
      WS     = ' '
      NRREM  = 0
      CALL GEN126 (REMS, 1, 5)
      REWIND (UNIT = LU63, IOSTAT = IOST)
C * READ FIRST RECORD (DATA or OTHER), THEN START LOOP
      READ (LU63, 99999, IOSTAT = IOST) DATAX
      IF (IOST == 0) THEN
        IF (DATAX(1:3) == 'OTH') IOTH = 1
        DO
          READ (LU63, 99999, IOSTAT = IOST) DATAX
          IF (IOST /= 0) EXIT
          IF (DATAX(1:2) == 'CG') PARAMS(14:24) = ', CG='//DATAX(5:10)
          IF (DATAX(1:2) == 'ga') PARAMS(1:13)  = 'Gamma='//DATAX(7:13)
          IF (DATAX(1:6) == 'SPCGRP') THEN
            DATAS = DATAX
C * SPACE GROUP
            SP    = DATAX(8:24)
C * WYCKOFF SEQUENCE
            WS    = DATAX(27:64)
          END IF
C * PEARSON CODE
          IF (DATAX(1:5) == 'PCODE') PEARS = DATAX(8:21)
          IF (DATAX(1:6) == 'REMARK') THEN
            NRREM       = NRREM + 1
            REMS(NRREM) = DATAX
          END IF
          IF (DATAX(1:6) == 'DEFINE') DEF = DATAX
        END DO
      END IF
C * WRITE HEADING FOR RESULTS
      IF (IOTH == 0) THEN
        CALL PLA262 (3)
        WRITE (DATAX, 99997, IOSTAT = IOST) SP, WS, PEARS
        WRITE (LU7, 99999, IOSTAT = IOST) DATAX
        IF (IWIN == 1) THEN
          VRT = VRT - 0.55
          CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
        END IF
        IF (DATAS(65:73) .NE.' ')  THEN
          CALL PLA262 (1)
          WRITE (DATAX, 99996, IOSTAT = IOST) DATAS(65:73)
          WRITE (LU7, 99999, IOSTAT = IOST) DATAX
          IF (IWIN == 1) THEN
            VRT = VRT - 0.45
            CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
          END IF
        END IF
C * WRITE SEPARATION LINE
        WRITE (DATAX, 99995, IOSTAT = IOST)
        WRITE (LU7, 99999, IOSTAT = IOST) DATAX
        IF (IWIN == 1) THEN
          VRT = VRT - 0.45
          CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
        END IF
      END IF
      REWIND (UNIT = LU63, IOSTAT = IOST)
      NATPR = 0
      DO
        READ (LU63, 99999, IOSTAT = IOST) DATAX
        IF (IOST /= 0) EXIT
        IF (DATAX(1:4) == 'DATA' .OR. DATAX(1:4) == 'OTHE') THEN
          DATAX(50:73) = PARAMS
          IF (DATAX(1:4) == 'OTHE') THEN
            CALL PLA262 (3)
            WRITE (LU7, 99998, IOSTAT = IOST)
            WRITE (LU7, 99999, IOSTAT = IOST) DATAX
            IF (IWIN == 1) THEN
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
              WRITE (LU7, 99999, IOSTAT = IOST) DATAS
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAS, 73, 0.35, 1, 2, 1.0, VRT)
            END IF
          ELSE
            CALL PLA262 (1)
            WRITE (LU7, 99999, IOSTAT = IOST) DATAX
            IF (IWIN == 1) THEN
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
            END IF
          END IF
        ELSE IF (DATAX(1:5) == 'PCODE') THEN
          IF (IOTH == 1) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99999, IOSTAT = IOST) DATAS
            IF (IWIN == 1) THEN
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAS, 73, 0.35, 1, 2, 1.0, VRT)
              WRITE (LU7, 99999, IOSTAT = IOST) DATAX
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
            END IF
          END IF
        ELSE IF (DATAX(1:2) == 'ga' .OR. DATAX(1:6) == 'SPCGRP' .OR.
     1           DATAX(1:3) == 'DEF') THEN
          CYCLE
        ELSE IF (DATAX(1:5) == 'OTHER') THEN
           EXIT
        ELSE IF (DATAX(1:4) == 'ATOM') THEN
          NATPR = NATPR + 1
          IF (DEF /= ' ') THEN
            CALL PLA262 (1)
            WRITE (LU7, 99999, IOSTAT = IOST) DEF
            IF (IWIN == 1) THEN
              IF (NATPR < 31) THEN
                VRT = VRT - 0.45
                CALL PLA439 (0.0, DEF, 73, 0.35, 1, 2, 1.0, VRT)
              ELSE IF (NATPR == 31) THEN
                VRT = VRT - 0.45
                CALL PLA439 (0.0, '... (Etc. - See Listing) ...', 28,
     1                       0.35, 5, 2, 8.0, VRT)
                VRT = VRT - 0.15
              END IF
            END IF
          END IF
          DEF = ' '
          IF (KK > 0) THEN
C * PARSE DATA TO FIND ATOM TYPE NAME
            JJ = 8
            DO I = 8, 13
              IF (DATAX(I:I) /= ' ') THEN
                CH = DATAX(I:I + 1)
                JJ = I + 2
                K  = INDEX (NUMS, CH(2:2))
                IF (K > 0) THEN
                  CH(2:2) = ' '
                  JJ      = I + 1
                END IF
                DO N = 1, KK
                  IF (CH == KEL(N)) THEN
                    KEL(N)          = ' '
                    DATAX(JJ:JJ + 2) = ' '
                    EXIT
                  END IF
                END DO
                EXIT
              END IF
            END DO
          END IF
          CALL PLA262 (1)
          WRITE (LU7, 99999, IOSTAT = IOST) DATAX
          IF (IWIN == 1) THEN
            IF (NATPR < 31) THEN
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
            ELSE IF (NATPR == 31) THEN
              VRT = VRT - 0.45
              CALL PLA439 (0.0, '... (Etc. - See Listing) ...', 28,
     1                     0.35, 1, 2, 8.0, VRT)
              VRT = VRT - 0.15
            END IF
          END IF
          CYCLE
        ELSE IF (DATAX(1:2) == 'CG') THEN
          DO I = 1, NRREM
            IF (REMS(I) /= ' ')  THEN
              CALL PLA262 (1)
              WRITE (LU7, 99999, IOSTAT = IOST) REMS(I)
              IF (IWIN == 1) THEN
                VRT = VRT - 0.45
                CALL PLA439 (0.0, REMS(I), 73, 0.35, 1, 2, 1.0, VRT)
              END IF
            END IF
          END DO
          EXIT
        ELSE
          IF (DATAX(1:6) /= 'REMARK')  THEN
            CALL PLA262 (1)
            WRITE (LU7, 99999, IOSTAT = IOST) DATAX
            IF (IWIN == 1) THEN
              VRT = VRT - 0.45
              CALL PLA439 (0.0, DATAX, 73, 0.35, 1, 2, 1.0, VRT)
            END IF
          END IF
        END IF
      END DO
      REWIND (UNIT = LU63, IOSTAT = IOST)
      RETURN
99999 FORMAT (A)
99998 FORMAT (1X)
99997 FORMAT (A, ' - ', A, 1X, A)
99996 FORMAT (19X, A9)
99995 FORMAT (73('-'))
      END SUBROUTINE PLA312
 
      SUBROUTINE PLA313 (II, IG, K, NR, NEWNR)
      USE stidy
      IMPLICIT NONE
      INTEGER                   :: I
      INTEGER                   :: J
      INTEGER                   :: K
      INTEGER                   :: L
      INTEGER                   :: M
      INTEGER                   :: II
      INTEGER                   :: KK
      INTEGER                   :: IG
      INTEGER, DIMENSION(NSETX) :: NR
      INTEGER, DIMENSION(NSETX) :: NEW
      INTEGER, DIMENSION(NSETX) :: NEWNR
      REAL                      :: S
C * makes final choice between various standardizations
C * IG is number of possible settings (max nset).
C * if ii=1 minimum of 'sum' should be found; if ii=2, of 'horsum'
      CALL GEN097 (NEW,   1, NSETX, 0)
      CALL GEN097 (NEWNR, 1, NSETX, 0)
      KK = 1
      IF (II /= 2) THEN
C * find minimum sum
        DO I = 1, 3
          S = 1000000.0
          DO J = 1, IG
            M = NR(J)
C * look if this setting is in array newnr (only possible if i>1):
            IF (I > 1) THEN
              DO L = 1, KK
                IF (M == NEWNR(L)) GO TO 10
              END DO
              CYCLE
            END IF
   10       IF (S > SUMX(I, M)) S = SUMX(I, M)
          END DO
C * is this minimum sum unique ?
          K = 0
          DO J = 1, IG
            L = NR(J)
C * look if this setting is in array newnr
            IF (I > 1) THEN
              DO M = 1, KK
                IF (L == NEWNR(M)) GO TO 20
              END DO
              CYCLE
            END IF
   20       IF (ABS (SUMX(I, L) - S) < 0.0001) THEN
              K = K + 1
              NEWNR(K) = l
            END IF
          END DO
          IF (K <= 1) RETURN
C * k > 1 ; more than one minimum sum. Look at next sum for the
C * settings whose numbers are in  newnr(1..k)
          KK = K
        END DO
C * if we get here, it means we RETURN with several possibilities.
      ELSE
C * come here for ii=2 : horizontal sums after ordering of atoms
        DO I = 1, NATOM
          S = 1000000.0
          DO J = 1, IG
            M = NR(J)
C * look if this setting is in array new (only possible if i>1):
            IF (I > 1) THEN
              DO L = 1, KK
                IF (M == NEWNR(L)) GO TO 30
              END DO
              CYCLE
            END IF
   30       IF (S > HORSUM(I, J)) S = HORSUM(I, J)
          END DO
C * is this minimum sum unique ?
          K = 0
          DO J = 1, IG
            L = NR(J)
C * look if this setting is in array newnr
            IF (I > 1) THEN
              DO M = 1, KK
                IF (J == NEW(M)) GO TO 40
              END DO
              CYCLE
            END IF
   40       IF (ABS (HORSUM(I, J) - S) < 0.0001) THEN
              K        = K + 1
              NEW(K)   = J
              NEWNR(K) = L
            END IF
          END DO
          IF (K <= 1) RETURN
C * k > 1 ; more than one minimum sum. Look at next sum for the
C * settings whose numbers are in  newnr(1..k)
          KK = K
        END DO
      END IF
      RETURN
      END SUBROUTINE PLA313
 
      SUBROUTINE PLA314
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER          :: IFBEST
      REAL             :: CA
      REAL             :: CS
      REAL             :: CS1
      REAL             :: CSB
      REAL             :: CSS
      REAL             :: RT1
      REAL             :: RT2
      REAL             :: CSS2
      REAL             :: ROOT
      CHARACTER(len=1) :: ANSR
      IFBEST = 0
      ROOT   = 1.0
      CSB    = - COSB
      CS     = 1.0 / 2.0 * CSB
      CSS    = CSB
      CA     = C / A
      IF (IW < 0) THEN
        WRITE (LU7, 99998, IOSTAT = IOST)
        IW = -IW
        ANSR = 'N'
        IF (ANSR == 'Y'.OR. ANSR == 'y') IFSH = 1
      END IF
      SELECT CASE (IW)
        CASE (1)
          GO TO 10
        CASE (2)
C * P2  P21  Pm  P2/m  P21/m
          CALL PLA262 (1)
          WRITE (LU7, 99999, IOSTAT = IOST)
          IF (A > C) GO TO 30
          ROOT = 1.0
          CS   = 1.0 / (2.0 * CSB)
        ANSR = 'N'
          IF (CA >= 1.0 .AND. CA >= CS)  GO TO 30
          CSS = 2.0 * CSB
          IF (CA <= 1.0 .AND. CA <= CSS) GO TO 30
          WRITE (LU7, 99981, IOSTAT = IOST)
          IF (ABS (A - C) < 0.001 * A) THEN
            WRITE (LU7, 99982, IOSTAT = IOST)
          END IF
          GO TO 40
C * C2  Cm  C2/m  Cc  C2/c
        CASE (3, 5, 6)
          ROOT = 1.0 / SQRT (2.0)
          CS   = 1.0 / (2.0 * CSB)
          CSS  = CSB
          IF (CA >= ROOT .AND. CA >= CS)  GO TO 20
          IF (CA <= ROOT .AND. CA <= CSS) GO TO 20
          WRITE (LU7, 99981, IOSTAT = IOST)
          GO TO 40
C * Pc  P2/c  P21/c
        CASE (4)
          ROOT = SQRT (2.0)
          CS   = 1.0 / CSB
          IF (CA >= ROOT .AND. CA >= CS)  GO TO 20
          CSS = 2.0 * CSB
          IF (CA <= ROOT .AND. CA <= CSS) GO TO 20
          WRITE (LU7, 99981, IOSTAT = IOST)
          GO TO 40
        CASE (7)
          WRITE (LU7, 99990, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (8)
          WRITE (LU7, 99989, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (9)
          WRITE (LU7, 99988, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (10)
          WRITE (LU7, 99987, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (11)
          WRITE (LU7, 99986, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (12)
          WRITE (LU7, 99985, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (13)
          WRITE (LU7, 99984, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (14)
          WRITE (LU7, 99983, IOSTAT = IOST)
          CALL PLA308
          RETURN
        CASE (15)
          WRITE (LU7, 99998, IOSTAT = IOST)
          ANSR = 'N'
          IF (ANSR == 'Y' .OR. ANSR == 'y') IFSH = 1
          RETURN
        CASE (16)
          RETURN
      END SELECT
   10 WRITE (LU7, 99992, IOSTAT = IOST)
      CALL PLA311 (2)
      RETURN
   20 WRITE (LU7, 99991, IOSTAT = IOST)
   30 CALL PLA310 (LU7)
      IFBEST = 1
C * RECOMPUTE PARAMETERS
      CA  = C / A
      CSB = - COS (BE * 3.1415926 / 180.0)
      IF (IW == 2) THEN
        ROOT = 1.0
        CS   = 1.0 / (2.0 * CSB)
        CSS  = 2.0 * CSB
      ELSE IF (IW == 3 .OR. IW == 5 .OR. IW == 6) THEN
        ROOT = 1.0 / SQRT (2.0)
        CS   = 1.0 / (2.0 * CSB)
        CSS  = CSB
      ELSE IF (IW == 4) THEN
        ROOT = SQRT (2.0)
        CS   = 1.0 / CSB
        CSS  = 2.0 * CSB
      END IF
C * if test for best cell gives values within 1%, give warning:
   40 RT1  = ROOT - 0.01 * ROOT
      RT2  = ROOT + 0.01 * ROOT
      CS1  = CS   - 0.01 * CS
      CSS2 = CSS  + 0.01 * CSS
      IF (CA >= RT1 .AND. CA >= CS1) THEN
        IF (IFBEST == 0) THEN
          WRITE (LU7, 99996, IOSTAT = IOST)
        ELSE
          WRITE (LU7, 99995, IOSTAT = IOST)
        END IF
      ELSE IF (CA <= RT2 .AND. CA <= CSS2) THEN
        IF (IFBEST == 0) THEN
          WRITE (LU7, 99996, IOSTAT = IOST)
        ELSE
          WRITE (LU7, 99995, IOSTAT = IOST)
        END IF
      END IF
C * test on c/a only for groups P2, P21, Pm, P2/m, P21/m:
      IF (CA >= 0.97 .AND. CA <= 1.03 .AND. IW == 2) THEN
        WRITE (LU7, 99994, IOSTAT = IOST)
      END IF
      IF (BE <= 90.3) THEN
        WRITE (LU7, 99993, IOSTAT = IOST)
      END IF
      RETURN
99999 FORMAT ('Take Reset Niggli Reduced Cell with  a < c.')
99998 FORMAT ('Take setting with origin in centre of symmetry')
99997 FORMAT (A)
99996 FORMAT (55('-'), /,
     1 'WARNING : slightly different cell parameters may give', /,
     2 'a different BEST cell.', /, 55('-'))
99995 FORMAT (55('-'), /,
     1'WARNING : the found "best" cell is very near a border line.'/
     2'A slight difference in c/a or beta may give a different'/
     3'BEST cell.'/
     4 55('-'))
99994 FORMAT (55('-'), /,
     1'WARNING : c/a value near to 1. Slightly different cell'/
     2'parameters may give a different BEST cell.'/
     3 55('-'))
99993 FORMAT (55('-'), /,
     1'WARNING : beta near to 90 deg. A slight difference'/
     2'in beta may give a different BEST cell.'/
     3 55('-'))
99992 FORMAT ('Take Niggli reduced cell with  a < b < c.')
99991 FORMAT ('a & c should be shortest translation vectors possible.')
99990 FORMAT ('Axial Order        : a < b < c')
99989 FORMAT (' a < b')
99988 FORMAT (' a < b , for ba-c origin shift of 0 0 1/4 after',
     1 ' permutation'/)
99987 FORMAT (' a < b < c, for ba-c , a-cb , -cba'/' origin shift of',
     1'  1/4 1/4 1/4  after permutation of axes', /)
99986 FORMAT (' a < b , for ba-c  origin shift of 1/4 1/4 1/4', /)
99985 FORMAT (' a < b , for ba-c  origin shift of 1/4 1/4 0', /)
99984 FORMAT (' a < b < c , for ba-c , a-cb , -cba'/'  origin shift ',
     1 'of resp.  1/4 1/4 0 , 1/4 0 1/4 , 0 1/4 1/4 after permutation'/)
99983 FORMAT (' a < b < c   only if possible by cyclic permutation; ',
     1 'otherwise  a < b'/)
99982 FORMAT (/, 'WARNING : a & c are very similar.', /)
99981 FORMAT (/, 'No cell reduction possible.')
      END SUBROUTINE PLA314
 
      SUBROUTINE PLA315
C * Called from PLA317, CHECK TO SEE IF THE CELL IS NIGGLI REDUCED
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER :: IMAIN1
      REAL    :: Q
      REAL    :: Q1
      REAL    :: Q2
      REAL    :: Q3
      REAL    :: QQ
      REAL    :: X1
      REAL    :: X2
      REAL    :: X3
      REAL    :: ER
      REAL    :: X11
      REAL    :: X22
      REAL    :: X33
      REAL    :: TS1
      REAL    :: TS2
      REAL    :: TS3
      REAL    :: TS4
      REAl    :: TS5
      REAL    :: TS6
      REAL    :: TEM1
      REAL    :: TEM2
      REAL    :: TEMP1
      REAL    :: TEMP2
      IGO    = 0
      IRED   = 0
      IMAIN1 = 0
      ER     = 0.000001
      Q      = 0.0005
      QQ     = 0.0005
      IF (ITHRU == 1) THEN
C * TEST FOR SPECIAL CONDITIONS FOR TYPE 1 CELL(+++)
        IF (ITYPE == 1) THEN
          TS1 = ABS (SF11 - SF22)
          TS2 = ABS (SF22 - SF33)
          TS3 = ABS ((2.0 * SF23) - SF22)
          TS4 = ABS ((2.0 * SF13) - SF11)
          TS5 = ABS ((2.0 * SF12) - SF11)
          IF ((TS1 / SF11) <= QQ) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '+++ A', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((SF13 + ER) < SF23) THEN
C * FAILED SPECIAL CONDITION ONE (+++)
              IGO = 1
              RETURN
            END IF
          END IF
          IF ((TS2 / SF22) <= QQ) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '+++ B', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((SF12 + ER) < SF13) THEN
C * FAILED SPECIAL CONDITION TWO(+++)
              IGO = 2
              RETURN
            END IF
          END IF
          IF ((TS3 / SF22) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '+++ C', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((2.0 * SF13 + ER) < SF12) THEN
C * FAILED SPECIAL CONDITION THREE(+++)
              IGO = 3
              RETURN
            END IF
          END IF
          IF ((TS4 / SF11) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '+++ D', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((2.0 * SF23 + ER) < SF12) THEN
C * FAILED SPECIAL CONDITION FOUR(+++)
              IGO = 4
              RETURN
            END IF
          END IF
          IF ((TS5 / SF11) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '+++ E', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((2.0 * SF23 + ER) < SF13) THEN
C * FAILED SPECIAL CONDITION FIVE(+++)
              IGO = 5
              RETURN
            END IF
          END IF
          IRED = 1
C * CELL REDUCED IF IRED = 1
          RETURN
C * TEST FOR SPECIAL CONDITIONS FOR TYPE 2 CELL(---)
        ELSE IF (ITYPE == 2) THEN
          TS1  = ABS (SF11 - SF22)
          TS2  = ABS (SF22 - SF33)
          TS3  = ABS (ABS (2.0 * SF23) - SF22)
          TS4  = ABS (ABS (2.0 * SF13) - SF11)
          TS5  = ABS (ABS (2.0 * SF12) - SF11)
          TEM1 = SF11 + SF22
          TEM2 = 2.0 * (ABS (SF23) + ABS (SF13) + ABS (SF12))
          TS6  = ABS (TEM1 - TEM2)
          IF ((TS1 / SF11) <= QQ) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '--- A', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((ABS (SF13) + ER) < ABS (SF23)) THEN
C * FAILED SPECIAL CONDITION ONE(---)
              IGO = 1
              RETURN
            END IF
          END IF
          IF ((TS2 / SF22) <= QQ) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '--- B', SF11, SF22, SF33, SF23, SF13, SF12
            IF ((ABS (SF12) + ER) < ABS (SF13)) THEN
C * FAILED SPECIAL CONDITION TWO(---)
              IGO = 2
              RETURN
            END IF
          END IF
          IF ((TS3 / SF22) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '--- C', SF11, SF22, SF33, SF23, SF13, SF12
            IF (Q < ABS (SF12)) THEN
C * FAILED SPECIAL CONDITION THREE(---)
              IGO = 6
              RETURN
            END IF
          END IF
          IF ((TS4 / SF11) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '--- D', SF11, SF22, SF33, SF23, SF13, SF12
            IF (Q < ABS (SF12)) THEN
              IGO = 7
              RETURN
            END IF
          END IF
          IF ((TS5 / SF11) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '--- E', SF11, SF22, SF33, SF23, SF13, SF12
            IF (Q < ABS(SF13)) THEN
C * FAILED SPECIAL CONDITION FIVE(---)
              IGO = 8
              RETURN
            END IF
          END IF
          IF ((TS6 / (SF11 + SF22)) <= Q) THEN
            WRITE (LU7, 99998, IOSTAT = IOST)
     1        '--- F', SF11, SF22, SF33, SF23, SF13, SF12
            X1 = ABS (SF13)
            X2 = ABS (SF12)
            X3 = 2.0 * X1 + X2
            IF ((X3 + ER) < SF11) THEN
C * FAILED SPECIAL CONDITION SIX(---)
              IGO = 9
              RETURN
            END IF
          END IF
          IRED = 1
          RETURN
        END IF
      END IF
C * CHECK NIGGLI'S MAIN CONDITIONS FOR REDUCTION
C * THE THREE SHORTEST LATTICE TRANSLATIONS
      Q1  = 2.0 * ABS (SF23)
      Q2  = 2.0 * ABS (SF13)
      Q3  = 2.0 * ABS (SF12)
      X11 = SF11 + ER
      X22 = SF22 + ER
      X33 = SF33 + ER
      IF (X11 <= X22 .AND. X22 <= X33 .AND. Q1 <= X22 .AND.
     1 Q2 <= X11 .AND. Q3 <= X11) IMAIN1 = 1
      IF (ITYPE /= 1) THEN
C * TYPE2 CELL SO CHECK THE SECOND PART OF THE MAIN CONDITIONS
        TEMP1 = SF11 + SF22 + ER
        TEMP2 = 2.0 * (ABS (SF23) + ABS (SF13) + ABS (SF12))
        IF (TEMP1 < TEMP2) IMAIN1 = 0
      END IF
      ITHRU = 1
      E1    = 0.00001
      IF (IMAIN1 == 0) THEN
        WRITE (LU7, 99999, IOSTAT = IOST)
        IERR = IERR + 1
      END IF
C * CELL REDUCED IF IRED=1
      RETURN
99999 FORMAT (//,'**ERROR** Failed Main Conditions for Reduction')
99998 FORMAT ('NIGGLI ', A, 2X, 6F15.6)
      END SUBROUTINE PLA315
 
      SUBROUTINE PLA316
c * This routine was adapted from NBS*AIDS80 (Mighell, Hubbard & Stali
C * PUT THE CELL IN NORMAL REPRESENTATION
      USE files
      USE stidy
      IMPLICIT NONE
      REAL :: Z
      REAL :: COSAX
      REAL :: COSBX
      REAL :: COSGX
      REAL :: ACOSA
      REAL :: ACOSB
      REAL :: ACOSG
C * THE CELL IS SET AS A TYPE 1 OR TYPE 2 CELL-
C * TYPE 1 CELL (+++) ALL ANGLES LESS THAN 90 DEGREES,
C * TYPE 2 CELL (---) ALL ANGLES = OR GREATER THAN 90 DEGREES.
C * IF NECESSARY, THIS SUBROUTINE CHANGES THE SIGNS ON THE UNSYMMETRIC
C * SCALARS (SF23,SF13,SF12) SO THAT THEY ARE ALL POSITIVE, ALL
C * NEGATIVE, OR ZERO AND NEGATIVE.  ALSO THE TOTAL TRANSFORMATION
C * MATRIX IS UPDATED.
      ITYPE = 0
C * COPY VECTOR
      CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      Z     = 0
      COSAX = SF23 / (SQRT (SF22) * SQRT (SF33))
      ACOSA = ABS (COSAX)
      COSBX = SF13 / (SQRT (SF11) * SQRT (SF33))
      ACOSB = ABS (COSBX)
      COSGX = SF12 / (SQRT (SF11) * SQRT (SF22))
      ACOSG = ABS (COSGX)
      IF (ACOSA <= E1 .OR. ACOSB <= E1 .OR. ACOSG <= E1) THEN
C * ONE OR MORE ANGLES 90 DEGREES- TYPE 2 CELL
C * IF COMBINATIONS OF 0 AND - (0--,-0-,--0,00-,0-0,-00,000,---)
C * THE CELL IS IN NORMAL REPRESENTATION AND NOR FURTHER TRANSFORMATIO
C * IS REQUIRED.
        IF (COSAX <= E1 .AND. COSBX <= E1 .AND. COSGX <= E1)
     1      ITYPE = 2
        IF (COSAX <= E1 .AND. COSBX <= E1 .AND. COSGX <= E1) GO TO 10
C * CONVERT    0+0  TO   0-0     BY REVERSING VECTORS B AND C
        IF (ACOSA <= E1 .AND. COSBX  > E1 .AND. COSGX  > E1 .OR.
     1      ACOSA <= E1 .AND. COSBX  > E1 .AND. ACOSG <= E1 .OR.
     2      ACOSA  > E1 .AND. COSAX  < Z  .AND.
     3      COSBX  > E1 .AND. ACOSG <= E1 .OR.
     4      ACOSA  > E1 .AND. COSAX  < Z  .AND.
     5      ACOSB <= E1 .AND. COSGX  > E1) THEN
          U9(1) =  1.0
          U9(5) = -1.0
          U9(9) = -1.0
C * CONVERT    00+  TO   00-     BY REVERSING VECTORS A AND C
        ELSE IF (COSAX  > E1 .AND. ACOSB <= E1 .AND.
     1           COSGX  > E1 .OR.  ACOSA <= E1 .AND.
     2           ACOSB <= E1 .AND. COSGX  > E1 .OR.
     3           COSAX  > E1 .AND. ACOSB  > E1 .AND.
     4           COSBX  < Z  .AND. ACOSG <= E1 .OR.
     5           ACOSA <= E1 .AND. ACOSB  > E1 .AND.
     6           COSBX  < Z  .AND. COSGX  > E1) THEN
          U9(1) = -1.0
          U9(5) =  1.0
          U9(9) = -1.0
C * CONVERT    +00  TO   -00     BY REVERSING VECTORS A AND B
        ELSE IF (COSAX  > E1 .AND. COSBX  > E1 .AND.
     1           ACOSG <= E1 .OR.  COSAX  > E1 .AND.
     2           ACOSB <= E1 .AND. ACOSG <= E1 .OR.
     3           COSAX  > E1 .AND. ACOSB <= E1 .AND.
     4           ACOSG  > E1 .AND. COSGX  < Z  .OR.
     5           ACOSA <= E1 .AND. COSBX  > E1 .AND.
     6           ACOSG  > E1 .AND. COSGX  < Z) THEN
          U9(1) = -1.0
          U9(5) = -1.0
          U9(9) =  1.0
        ELSE
C * ERROR
          GO TO 10
        END IF
        SF23 = - ABS (SF23)
        SF13 = - ABS (SF13)
        SF12 = - ABS (SF12)
        CALL GEN004 (T9, U9, P9)
        ITYPE = 2
C * ALPHA, BETA, AND GAMMA ALL DIFFERENT FROM 90 DEGREES
C * SET CELL AS A TYPE 1 CELL (+++) - ALL ANGLES LESS THAN 90 DEGREES
C * OR AS A TYPE 2 CELL (---) - ALL ANGLES GREATER THAN 90 DEGREES.
      ELSE
        IF (SF23  > Z .AND. SF13 > Z .AND. SF12 > Z) ITYPE = 1
        IF (SF23  <= Z .AND. SF13 <= Z .AND. SF12 <= Z) ITYPE = 2
        IF (ITYPE == 1 .OR.  ITYPE == 2) GO TO 10
C * NON-STANDARD(+--) TO (+++)
        IF (SF23 > Z .AND. SF13 <= Z .AND. SF12 <= Z) THEN
          SF23 = ABS (SF23)
          SF13 = ABS (SF13)
          SF12 = ABS (SF12)
          U9(1) =  1.0
          U9(5) = -1.0
          U9(9) = -1.0
          CALL GEN004 (T9, U9, P9)
          ITYPE = 1
C * NON-STANDARD(-+-) TO (+++)
        ELSE IF (SF23 <= Z .AND. SF13 > Z .AND. SF12 <= Z) THEN
          SF23 = ABS (SF23)
          SF13 = ABS (SF13)
          SF12 = ABS (SF12)
          U9(1) = -1.0
          U9(5) =  1.0
          U9(9) = -1.0
          CALL GEN004 (T9, U9, P9)
          ITYPE = 1
C * NON-STANDARD(--+) TO (+++)
        ELSE IF (SF23 <= Z .AND. SF13 <= Z .AND. SF12 > Z) THEN
          SF23 = ABS (SF23)
          SF13 = ABS (SF13)
          SF12 = ABS (SF12)
          U9(1) = -1.0
          U9(5) = -1.0
          U9(9) =  1.0
          CALL GEN004 (T9, U9, P9)
          ITYPE = 1
C * NON-STANDARD(++-) TO (---)
        ELSE IF (SF23 > Z .AND. SF13 > Z .AND. SF12 <= Z) THEN
          SF23 = -ABS (SF23)
          SF13 = -ABS (SF13)
          SF12 = -ABS (SF12)
          U9(1) = -1.0
          U9(5) = -1.0
          U9(9) =  1.0
          CALL GEN004 (T9, U9, P9)
          ITYPE = 2
C * NON-STANDARD(+-+) TO (---)
        ELSE IF (SF23 > Z .AND. SF13 <= Z .AND. SF12 > Z) THEN
          SF23 = -ABS (SF23)
          SF13 = -ABS (SF13)
          SF12 = -ABS (SF12)
          U9(1) = -1.0
          U9(5) = 1.0
          U9(9) = -1.0
          CALL GEN004 (T9, U9, P9)
          ITYPE = 2
C * NON-STANDARD(-++) TO (---)
        ELSE IF (SF23 <= Z .AND. SF13 > Z .AND. SF12 > Z) THEN
          SF23 = -ABS (SF23)
          SF13 = -ABS (SF13)
          SF12 = -ABS (SF12)
          U9(1) =  1.0
          U9(5) = -1.0
          U9(9) = -1.0
          CALL GEN004 (T9, U9, P9)
          ITYPE = 2
        ELSE
          GO TO 10
        END IF
      END IF
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
   10 IF (ITYPE == 0) THEN
        WRITE (LU6, 99999, IOSTAT = IOST)
        IERR = IERR + 1
      END IF
      RETURN
99999 FORMAT(//, '**ERROR**SUBROUTINE NORM FAILED TO TYPE CELL')
      END SUBROUTINE PLA316
 
 
      SUBROUTINE PLA317
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER :: ICT
      INTEGER :: ICOUNT
      REAL    :: T1
      REAL    :: T2
      REAL    :: T3
      REAL    :: XN
      REAL    :: XN1
      REAL    :: A12
      REAL    :: A13
      REAL    :: A23
      REAL    :: E12
      REAL    :: E13
      REAL    :: E23
      REAL    :: R12
      REAL    :: R13
      REAL    :: R23
      REAL    :: S11
      REAL    :: S12
      REAL    :: S13
      REAL    :: S22
      REAL    :: S23
      REAL    :: S33
      REAL    :: TX1
      REAL    :: TX2
      REAL    :: SSF12
      REAL    :: SSF13
      REAL    :: SSF23
      ITHRU = 0
      ICT   = 0
C * REDUCE THE CELL
C * CALCULATE SCALARS
      S11 = A**2
      S22 = B**2
      S33 = C**2
      IF (ABS (AL - 90.0) < 0.0001) THEN
        S23 = 0
      ELSE
        S23 = B * C * COS (ALF)
      END IF
      IF (ABS (GA - 90.0) < 0.0001) THEN
        S12 = 0
      ELSE
        S12 = A * B * COS (GAM)
      END IF
      IF (ABS (BE - 90.0) < 0.0001) THEN
        S13 = 0
      ELSE
        S13 = A * C * COS (BET)
      END IF
      A23 = ABS (S23)
      A13 = ABS (S13)
      A12 = ABS (S12)
   10 IF (2.0 * A23 > S22 .OR. 2.0 * A23 > S33) THEN
        IF (S23 < 0.0) THEN
          XN  = 1.0
          XN1 = 0.0
          GO TO 40
        ELSE IF (S23 > 0.0) THEN
          XN  = -1.0
          XN1 = 0.0
          GO TO 40
        END IF
      END IF
   20 IF (2.0 * A13 > S11 .OR. 2.0 * A13 > S33) THEN
        IF (S13 > 0.0) THEN
          XN = -1.0
        ELSE
          XN  = 1.0
        END IF
        XN1 = 0.0
        R13 = ABS (S13 + XN * S11)
        GO TO 50
      END IF
      IF (2.0 * A12 > S11 .OR. 2.0 * A12 > S22) THEN
        IF (S12 <= 0.0) THEN
          XN = 1.0
        ELSE
          XN = -1.0
        END IF
        XN1 = 0.0
        GO TO 70
      END IF
      A    = SQRT (S11)
      B    = SQRT (S22)
      C    = SQRT (S33)
      COSA = S23 / (B * C)
      COSB = S13 / (A * C)
      COSG = S12 / (A * B)
      GO TO 90
   30 R23 = ABS (S23 + XN * S22)
      IF (R23 <= A23) THEN
        IF (S23 < 0.0) THEN
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ELSE
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        END IF
        A23 = R23
        GO TO 30
      END IF
      S33 = S33 + (XN1**2) * S22 + 2.0 * XN1 * S23
      S23 = S23 + XN1 * S22
      S13 = S13 + XN1 * S12
      A23 = ABS (S23)
      A13 = ABS (S13)
C * COPY VECTOR
      CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      U9(1) = 1.0
      U9(5) = 1.0
      U9(8) = XN1
      U9(9) = 1.0
      CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
      IF (S23 < 0.0) THEN
        XN  = 1.0
        XN1 = 0.0
      ELSE IF (S23 > 0.0) THEN
        XN  = -1.0
        XN1 = 0.0
      ELSE
        GO TO 20
      END IF
   40 R23 = ABS (S23 + XN * S22)
      IF (R23 <= A23) THEN
        IF (S23 < 0.0) THEN
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ELSE
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        END IF
        A23 = R23
        GO TO 40
      END IF
      S22 = S22 + (XN1**2) * S33 + 2.0 * XN1 * S23
      S23 = S23 + XN1  * S33
      S12 = S12 + (XN1 * S13)
      A23 = ABS (S23)
      A12 = ABS (S12)
C * COPY VECTOR
      CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      U9(1) = 1.0
      U9(5) = 1.0
      U9(6) = XN1
      U9(9) = 1.0
      CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
      GO TO 10
   50 IF (R13 <= A13) THEN
        IF (S13 >= 0.0) THEN
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ELSE
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        END IF
        A13 = R13
        R13 = ABS (S13 + XN * S11)
        GO TO 50
      END IF
      S33 = S33 + (XN1**2) * S11 + 2.0 * XN1 * S13
      S13 = S13 + XN1 * S11
      S23 = S23 + XN1 * S12
      A13 = ABS (S13)
      A23 = ABS (S23)
C * COPY VECTOR
      CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      U9(1) = 1.0
      U9(5) = 1.0
      U9(7) = XN1
      U9(9) = 1.0
      CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
      IF (S13 > 0.0) THEN
        XN = -1.0
      ELSE
        XN  = 1.0
      END IF
      XN1 = 0.0
   60 R13 = ABS (S13 + XN * S33)
      IF (R13 > A13) THEN
        S11 = S11 + (XN1**2) * S33 + 2.0 * XN1 * S13
        S13 = S13 + XN1 * S33
        S12 = S12 + XN1 * S23
        A13 = ABS (S13)
        A12 = ABS (S12)
C * COPY VECTOR
        CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
        U9(1) = 1.0
        U9(3) = XN1
        U9(5) = 1.0
        U9(9) = 1.0
        CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
        CALL GEN113 (P9, UVW, 9)
        GO TO 10
      END IF
      IF (S13 < 0.0) THEN
        XN  = XN  + 1.0
        XN1 = XN1 + 1.0
      ELSE
        XN  = XN  - 1.0
        XN1 = XN1 - 1.0
      END IF
      A13 = R13
      GO TO 60
   70 R12 = ABS (S12 + XN * S11)
      IF (R12 <= A12) THEN
        IF (S12 < 0.0) THEN
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ELSE
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        END IF
        A12 = R12
        GO TO 70
      END IF
      S22 = S22 + (XN1**2) * S11 + 2.0 * XN1 * S12
      S12 = S12 + XN1 * S11
      S23 = S23 + XN1 * S13
      A12 = ABS (S12)
      A23 = ABS (S23)
C * COPY VECTOR
      CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      U9(1) = 1.0
      U9(4) = XN1
      U9(5) = 1.0
      U9(9) = 1.0
      CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
      IF (S12 > 0.0) THEN
        XN = -1.0
      ELSE
        XN = 1.0
      END IF
      XN1 = 0.0
   80 R12 = ABS (S12 + XN * S22)
      IF (R12 <= A12) THEN
        IF (S12 >= 0.0) THEN
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ELSE
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        END IF
        A12 = R12
        GO TO 80
      END IF
      S11 = S11 + (XN1**2) * S22 + 2.0 * XN1 * S12
      S12 = S12 + XN1 * S22
      S13 = S13 + XN1 * S23
      A12 = ABS (S12)
      A13 = ABS (S13)
C * COPY VECTOR
      CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      U9(1) = 1.0
      U9(2) = XN1
      U9(5) = 1.0
      U9(9) = 1.0
      CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
      GO TO 10
C * ARRANGE SO A <= B AND B <= C
C * COPY VECTOR
   90 CALL GEN113 (UVW, T9, 9)
      CALL GEN074 (U9, 1, 9, 0.0)
      IF (A <= B) THEN
        IF (A > C) THEN
          T1   = C
          T2   = A
          T3   = B
          E12  = COSB
          E13  = COSA
          E23  = COSG
          U9(3) = 1.0
          U9(4) = 1.0
          U9(8) = 1.0
          GO TO 100
        END IF
        T1  = A
        IF (B > C) THEN
          T2   = C
          T3   = B
          E12  = COSB
          E13  = -COSG
          E23  = -COSA
          U9(1) = 1.0
          U9(6) = 1.0
          U9(8) = -1.0
          GO TO 100
        END IF
        T2  = B
        T3  = C
        E23 = COSA
        E13 = COSB
        E12 = COSG
        GO TO 110
      END IF
      IF (A > C) THEN
        T3   = A
        IF (B > C) THEN
          T1   = C
          T2   = B
          E12  = COSA
          E13  = -COSB
          E23  = -COSG
          U9(3) = 1.0
          U9(5) = 1.0
          U9(7) = -1.0
        ELSE
          T1   = B
          T2   = C
          E12  = COSA
          E13  = COSG
          E23  = COSB
          U9(2) = 1.0
          U9(6) = 1.0
          U9(7) = 1.0
        END IF
      ELSE
        T1   = B
        T2   = A
        T3   = C
        E12  = COSG
        E13  = -COSA
        E23  = -COSB
        U9(2) =  1.0
        U9(4) =  1.0
        U9(9) = -1.0
      END IF
  100 CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
      CALL GEN113 (P9, UVW, 9)
  110 A    = T1
      B    = T2
      C    = T3
      COSA = E23
      COSB = E13
      COSG = E12
      SF11 = A**2
      SF22 = B**2
      SF33 = C**2
      SF23 = B * C * COSA
      SF13 = A * C * COSB
      SF12 = A * B * COSG
C * PUT CELL IN NORMAL REPRESENTATION
      CALL PLA316
      IF (ITYPE == 2) THEN
C * TYPE 2 CELL.  NOW CHECK PART 2 OF MAIN CONDITIONS.
C * COPY VECTOR
        CALL GEN113 (UVW, T9, 9)
        CALL GEN074 (U9, 1, 9, 0.0)
        TX1 = SF11 + SF22
        TX2 = 2.0 * (ABS (SF23) + ABS (SF13) + ABS (SF12))
        ICT = ICT + 1
        IF (ICT <= 2) THEN
          IF (TX1 < TX2) THEN
            SF33 = SF11 + SF22 + SF33 + 2.0 * SF12 + 2.0 * SF13
     1           + 2.0 * SF23
            SF23 = SF12 + SF23 + SF22
            SF13 = SF11 + SF12 + SF13
            U9(1) = 1.0
            U9(2) = 0.0
            U9(3) = 0.0
            U9(4) = 0.0
            U9(5) = 1.0
            U9(6) = 0.0
            U9(7) = 1.0
            U9(8) = 1.0
            U9(9) = 1.0
            CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
            CALL GEN113 (P9, UVW, 9)
            A    = SQRT (SF11)
            B    = SQRT (SF22)
            C    = SQRT (SF33)
            COSA = SF23 / (B * C)
            COSB = SF13 / (A * C)
            COSG = SF12 / (A * B)
            GO TO 90
          END IF
        END IF
      END IF
      CALL PLA315
      ICOUNT = 0
C * CELL BASED ON 3 SHORTEST VECTORS - CHECK SPECIAL CONDITIONS
  120 CALL PLA316
      CALL PLA315
      IF (IRED /= 1) THEN
        IF (IGO >= 1 .AND. IGO <= 9) THEN
C * CELL NOT REDUCED. *IGO* TELLS PROGRAM WHERE TO GO IN *PLA319* TO
C * SATISFY SPECIAL CONDITION.
C * This routine was adapted from NBS*AIDS80 (Mighell, Hubbard & Stali
C * TRANSFORMS CELL SO THAT THE SPECIAL CONDITIONS ARE SATISFIED
C * COPY VECTOR
          CALL GEN113 (UVW, T9, 9)
          CALL GEN074 (U9, 1, 9, 0.0)
          SSF23 = SF23
          SSF13 = SF13
          SSF12 = SF12
          IF (IGO == 1) THEN
            SF23 = SSF13
            SF13 = SSF23
            SF12 = SSF12
            U9(2) = -1.0
            U9(4) = -1.0
            U9(9) = -1.0
          ELSE IF (IGO == 2) THEN
            SF23 = SSF23
            SF13 = SSF12
            SF12 = SSF13
            U9(1) = -1.0
            U9(6) = -1.0
            U9(8) = -1.0
          ELSE IF (IGO == 3) THEN
            SF23 = SSF23
            SF13 = SSF12 - SSF13
            SF12 = SSF12
            U9(1) = -1.0
            U9(5) = -1.0
            U9(8) = -1.0
            U9(9) =  1.0
          ELSE IF (IGO == 4) THEN
            SF23 = SSF12 - SSF23
            SF13 = SSF13
            SF12 = SSF12
            U9(1) = -1.0
            U9(5) = -1.0
            U9(7) = -1.0
            U9(9) =  1.0
          ELSE IF (IGO == 5) THEN
            SF23 = SSF13 - SSF23
            SF13 = SSF13
            SF12 = SSF12
            U9(1) = -1.0
            U9(4) = -1.0
            U9(5) =  1.0
            U9(9) = -1.0
          ELSE IF (IGO == 6) THEN
            SF23 = ABS (SSF23)
            SF13 = ABS (SSF13) + ABS (SSF12)
            SF12 = ABS (SSF12)
            U9(1) =  1.0
            U9(5) = -1.0
            U9(8) = -1.0
            U9(9) = -1.0
          ELSE IF (IGO == 7) THEN
            SF23 = ABS (SSF23) + ABS (SSF12)
            SF13 = ABS (SSF13)
            SF12 = ABS (SSF12)
            U9(1) = -1.0
            U9(5) =  1.0
            U9(7) = -1.0
            U9(9) = -1.0
          ELSE IF (IGO == 8) THEN
            SF23 = ABS (SSF23) + ABS (SSF13)
            SF13 = ABS (SSF13)
            SF12 = ABS (SSF12)
            U9(1) = -1.0
            U9(4) = -1.0
            U9(5) = -1.0
            U9(9) =  1.0
          ELSE IF (IGO == 9) THEN
            SF23 = ABS (SSF12) + ABS (SSF23) - SF22
            SF13 = ABS (SSF12) + ABS (SSF13) - SF11
            SF12 = SSF12
            U9(1) = -1.0
            U9(5) = -1.0
            U9(7) =  1.0
            U9(8) =  1.0
            U9(9) =  1.0
          END IF
          CALL GEN004 (T9, U9, P9)
C * COPY VECTOR
          CALL GEN113 (P9, UVW, 9)
          ICOUNT = ICOUNT + 1
          IF (ICOUNT < 20) GO TO 120
        END IF
        WRITE (LU7, 99999, IOSTAT = IOST)
        IERR = IERR + 1
      END IF
      RETURN
99999 FORMAT('ERROR - PROGRAM FAILS AT END OF SUBROUTINE PLA317')
      END SUBROUTINE PLA317
 
      SUBROUTINE PLA318 (IPEARS, PMIN, PEAR, NELT)
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER                               :: I
      INTEGER                               :: J
      INTEGER                               :: K
      INTEGER                               :: L
      INTEGER                               :: N
      INTEGER                               :: K1
      INTEGER                               :: IK
      INTEGER                               :: II
      INTEGER                               :: KK
      INTEGER                               :: IG
      INTEGER                               :: KFL
      INTEGER                               :: IGG
      INTEGER                               :: ISUM
      INTEGER                               :: NRRES
      INTEGER                               :: IPEARS
      INTEGER                               :: NELT
      INTEGER,          DIMENSION(NSETX)    :: KEQ
      INTEGER,          DIMENSION(NUMAT)    :: NSP
      INTEGER,          DIMENSION(NSETX)    :: KRES
      INTEGER,          DIMENSION(NSETX)    :: NEWNR
      INTEGER,          DIMENSION(NSETX)    :: NRFILE
      INTEGER,          DIMENSION(NSETX)    :: NCHOIC
      REAL                                  :: FAC
      REAL                                  :: PMIN
      REAL                                  :: GAMMAX
      REAL,             DIMENSION(3)        :: SM
      REAL,             DIMENSION(3)        :: ORG
      REAL,             DIMENSION(NELTS)    :: PEAR
      REAL,             DIMENSION(3, NSETX) :: ORSAVE
      CHARACTER(len=17)                     :: TEXT
      CHARACTER(len=1)                      :: STAR
      CHARACTER(len=10)                     :: CPEARS
      CHARACTER(len=7), DIMENSION(NELTS)    :: CPEAR
      CHARACTER(len=8)                      :: CA
      CHARACTER(len=8)                      :: CB
      CHARACTER(len=8)                      :: CC
      CHARACTER(len=9)                      :: CAL
      CHARACTER(len=9)                      :: CBE
      CHARACTER(len=9)                      :: CGA
      CHARACTER(len=6)                      :: AUX1
      CHARACTER(len=7)                      :: AUX
C * reads data from scratchfile on unit 61, prints various settings,
C * requested, and prepares for final choice.
      IF (IFNG(2) == 1) AXS = '-a,-b,-c'
      KFL   = 0
      IG    = 0
      KOUNT = 0
      NRRES = 1
      CALL GEN074 (SXY, 1, NSETX, 0.0)
      CALL GEN074 (SXZ, 1, NSETX, 0.0)
      CALL GEN074 (SYZ, 1, NSETX, 0.0)
C * SUMS OF ALL X-COORDINATES, Y-COORDINATES AND Z-COORDINATES
      DO I = 1, NSETX
        DO J = 1, 3
          SUMX(J, I) = 0.0
        END DO
      END DO
      DO I = 1, NUMAT
        DO J = 1, NSETX
          HORSUM(I, J) = 0.0
        END DO
      END DO
      REWIND (UNIT = LU61, IOSTAT = IOST)
      CALL PLA262 (3)
      WRITE (LU7, 99987, IOSTAT = IOST) GMIN
      CALL PLA262 (0)
      CALL PLA262 (2)
      WRITE (LU7, 99986, IOSTAT = IOST)
      IF (IPOL == 0) THEN
        CALL PLA262 (4)
        WRITE (LU7, 99985, IOSTAT = IOST)
      END IF
C * convert values of CODE record into CHARACTER variables:
C * writes abundances nearer to elements
C * Pearson code
      CPEARS = ' '
      AUX    = ' '
      AUX1   = ' '
      WRITE (AUX1, 99963, IOSTAT = IOST) IPEARS
      K = 0
      DO J = 1, 6
        IF (AUX1(J:J) /= ' ') THEN
          K           = K + 1
          CPEARS(K:K) = AUX1(J:J)
        END IF
      END DO
      IF (PMIN /= 0.0) THEN
        K           = K + 1
        CPEARS(K:K) = '-'
        WRITE (AUX1, 99964, IOSTAT = IOST) PMIN
        DO J = 1, 6
          IF (AUX1(J:J) /= ' ') THEN
            K           = K + 1
            CPEARS(K:K) = AUX1(J:J)
          END IF
        END DO
      END IF
C * ABUNDANCES OF ELEMENTS
      DO I = 1, NELT
        K        = 0
        CPEAR(I) = ' '
        WRITE (AUX, 99965, IOSTAT = IOST) PEAR(I)
        DO J = 1, 7
          IF (AUX(J:J) /= ' ') THEN
            IF (AUX(J:J) /= '.') THEN
              K             = K + 1
              CPEAR(I)(K:K) = AUX(J:J)
            ELSE
              K             = K + 1
              CPEAR(I)(K:K) = '.'
              EXIT
            END IF
          END IF
        END DO
        DO L = J + 1, 7
          IF (AUX(L:L) /= '0') THEN
C * come here if digits after decimal point :
            DO N = J + 1, 7
              IF (AUX(N:N) == ' ') EXIT
              K = K + 1
              CPEAR(I)(K:K) = AUX(N:N)
            END DO
            EXIT
          END IF
        END DO
C * nothing after decimal point; go on with next element
      END DO
C * first reading of unit LU61
      DO
        READ (LU61, IOSTAT = IOST) GAMMAX, TEXT, ORG
        IF (IOST /= 0) EXIT
        KOUNT = KOUNT + 1
        IF (GMIN > 0.0001) THEN
          FAC = GAMMAX / GMIN
        ELSE
          IF (GAMMAX < 0.0001) THEN
            FAC = 1.0
          ELSE
            FAC = GAMMAX
          END IF
        END IF
c
c * count settings with gamma = gmin
        ISUM = 0
        IF (ABS (FAC - 1.0) <= 0.00001) THEN
          ISUM = 1
          IG   = IG + 1
          DO I = 1, 3
            ORSAVE(I, IG) = ORG(I)
          END DO
          NRFILE(IG) = KOUNT
C * INITIATE KRES
          KRES(IG) = IG
        END IF
C * FLAG FOR SETTINGS NEAR MIN. GAMMX
        IF (FAC > 1.00001 .AND. FAC <= 1.0025) THEN
          KFL      = KFL + 1
          KEQ(KFL) = KOUNT
        END IF
        CALL PLA262 (4)
        WRITE (LU7, 99984, IOSTAT = IOST) TEXT, ORG, GAMMAX, FAC
        WRITE (LU7, 99983, IOSTAT = IOST) A, B, C, AL, BE, GA
        DO I = 1, NATOM
          READ (LU61, IOSTAT = IOST) NSP(I), (XXX(J, I), J = 1, 3),
     1          MULR(I), LETR(I), FOCCU(I)
          IF (IOST /= 0) GO TO 10
          IF (ISUM == 1) THEN
            DO J = 1, 3
              SUMX(J, IG) = SUMX(J, IG) + XXX(J, I)
            END DO
C * MIXED SUMS
            SXY(IG) = SXY(IG) + XXX(1, I) * XXX(2, I)
            SXZ(IG) = SXZ(IG) + XXX(1, I) * XXX(3, I)
            SYZ(IG) = SYZ(IG) + XXX(2, I) * XXX(3, I)
          END IF
        END DO
        DO I = 1, NATOM
          K = LETR(I)
          CALL PLA262 (1)
          WRITE (LU7, 99993, IOSTAT = IOST)
     1      ATOM1(I), ATOM2(I), (XXX(J, I), J = 1, 3),
     2      FOCCU(I), MULR(I), CHAR (96 + K)
        END DO
        IF (ISUM == 1) THEN
          CALL PLA262 (3)
          WRITE (LU7, 99994, IOSTAT = IOST) (SUMX(K, IG), K = 1, 3)
        END IF
      END DO
   10 IF (KOUNT > NSETX) THEN
        CALL PLA262 (3)
        WRITE (LU7, 99992, IOSTAT = IOST) KOUNT, NSETX
      END IF
C * WRITE HEADINGS FOR RESULT
      WRITE (LU21, 99959, IOSTAT = IOST) INTXT
      CALL PLA262 (0)
      CALL PLA262 (3)
      WRITE (LU7, 99960, IOSTAT = IOST)
      WRITE (LU7, 99991, IOSTAT = IOST) INTXT
      WRITE (LU7, 99960, IOSTAT = IOST)
      WRITE (LU6, 99960, IOSTAT = IOST)
      WRITE (LU6, 99991, IOSTAT = IOST) INTXT
      WRITE (LU6, 99960, IOSTAT = IOST)
      IF (IOCFL == 1) THEN
        CALL PLA262 (2)
        WRITE (LU7, 99990, IOSTAT = IOST)
        WRITE (LU6, 99990, IOSTAT = IOST)
      END IF
      IF (NFL == 1) THEN
        CALL PLA262 (4)
        WRITE (LU7, 99989, IOSTAT = IOST)
      END IF
      IF (IFNG(2) == 1) THEN
        WRITE (LU6,  99979, IOSTAT = IOST)
        WRITE (LU63, 99978, IOSTAT = IOST)
      END IF
      IF (IFSH > 0) THEN
        WRITE (LU63, 99971, IOSTAT = IOST)
        WRITE (LU6, 99972, IOSTAT = IOST) sh
      END IF
      IF (IHEX == 1) THEN
        WRITE (LU63, 99977, IOSTAT = IOST)
        WRITE (LU6,  99976, IOSTAT = IOST)
        CALL PLA262 (1)
        WRITE (LU7, 99995, IOSTAT = IOST) A, A, C
      END IF
      STAR = ' '
      IF (IFNG(2) > 0 .OR. IHEX == 1 .OR. IFNG(1) == 2) THEN
        WRITE (LU6, 99980, IOSTAT = IOST) AXS
        STAR = '*'
      END IF
      IF (PMIN == 0) THEN
        WRITE (LU6, 99970, IOSTAT = IOST)
     1    CODE, IPEARS, (ELT(I), PEAR(I), I = 1, NELT)
      ELSE
        WRITE (LU6, 99969, IOSTAT = IOST)
     1    CODE, IPEARS, PMIN, (ELT(I), PEAR(I), I = 1, NELT)
      END IF
      IF (NELT < 5) THEN
        CALL GEN126 (ELT,   NELT + 1, 5)
        CALL GEN126 (CPEAR, NELT + 1, 5)
      END IF
C * prepare cell parameters
      IF (IFNG(2) > 0 .OR. IHEX == 1 .OR. IFNG(1) == 2)
     1   WRITE (LU6, 99980, IOSTAT = IOST) AXS
C * make CHARACTER variables out of cell parameters for writing
      WRITE (CA,  99962, IOSTAT = IOST) A
      WRITE (CB,  99962, IOSTAT = IOST) B
      WRITE (CC,  99962, IOSTAT = IOST) C
      WRITE (CAL, 99961, IOSTAT = IOST) AL
      WRITE (CBE, 99961, IOSTAT = IOST) BE
      WRITE (CGA, 99961, IOSTAT = IOST) GA
      IF (NGR >= 3 .AND. NGR <= 15) THEN
        CAL = '   90    '
        CGA = '   90    '
      ELSE IF (NGR >= 16 .AND. NGR <= 142) THEN
        CAL = '   90    '
        CBE = '   90    '
        CGA = '   90    '
      ELSE IF (NGR >= 143 .AND. NGR <= 194) THEN
        CAL = '   90    '
        CBE = '   90    '
        CGA = '  120    '
      ELSE IF (NGR >= 195) THEN
        CAL = '   90    '
        CBE = '   90    '
        CGA = '   90    '
      END IF
      WRITE (LU63, 99988, IOSTAT = IOST) CA, CB, CC, CAL, CBE, CGA, STAR
      WRITE (LU21, 99958, IOSTAT = IOST) A, B, C, AL, BE, GA
      WRITE (LU6,  99983, IOSTAT = IOST) A, B, C, AL, BE, GA
      WRITE (LU63, 99968, IOSTAT = IOST)
     1  CODE, CPEARS, (ELT(I), CPEAR(I), I = 1, 5)
      IF (NELT > 5) WRITE (LU63, 99967, IOSTAT = IOST)
     1  (ELT(I), CPEAR(I), I = 6, NELT)
      WRITE (LU6,  99966, IOSTAT = IOST) SPGR, NGR
      WRITE (LU21, 99957, IOSTAT = IOST) SPGR
      IF (IFPLUS > 5) THEN
        CALL PLA262 (1)
        WRITE (LU7, 99996, IOSTAT = IOST)
      END IF
      IF (IFPLUS == 1 .OR. IFPLUS == 3 .OR. IFPLUS == 5) THEN
        WRITE (LU6, 99974, IOSTAT = IOST) STCSH(NSHTRA)
        IF (IFPLUS == 3) THEN
          WRITE (LU6, 99975, IOSTAT = IOST) STCSH(NABC)
        ELSE IF (IFPLUS == 5) THEN
          WRITE (LU6, 99973, IOSTAT = IOST) STCSH(NSH)
        END IF
      ELSE IF (IFPLUS == 2) THEN
        WRITE (LU6, 99975, IOSTAT = IOST) STCSH(NABC)
      ELSE IF (IFPLUS == 4) THEN
        WRITE (LU6, 99973, IOSTAT = IOST) STCSH(NSH)
      END IF
      IF (IG > 0) THEN
C * ORDER RESULTS, MAKE FINAL CHOICE AND PRINT
        IGG = IG
        IF (IG > NSETX) IGG = NSETX
C * if several settings with min. gamma, look at vertical sums :
        IF (IGG == 1) THEN
          NRRES    = 1
          KRES(1)  = 1
          NEWNR(1) = IG
        ELSE
          CALL PLA313 (1, IGG, NRRES, KRES, NEWNR)
          IF (NRRES == 0) THEN
            WRITE (LU7, 99999, IOSTAT = IOST)
            RETURN
          END IF
        END IF
        REWIND (UNIT = LU61, IOSTAT = IOST)
C * reread unit 10 for ordering of settings with min. gamma
        KOUNT = 0
        IK    = 0
        DO II = 1, NRRES
          K1 = NEWNR(II)
          KK = NRFILE(K1)
   20     READ (LU61, IOSTAT = IOST) GAMMAX, TEXT, ORG
          IF (IOST /= 0) GO TO 30
          KOUNT = KOUNT + 1
          DO I = 1, NATOM
            READ (LU61, IOSTAT = IOST) NSP(I), (XXX(J, I), J = 1, 3),
     1                       MULR(I), LETR(I), FOCCU(I)
            IF (IOST /= 0) GO TO 30
          END DO
          IF (KOUNT == KK) THEN
            IF (NRRES == 1) THEN
              CALL PLA262 (2)
              WRITE (LU7, 99998, IOSTAT = IOST)
     1          TEXT, (ORSAVE(K, K1), K = 1, 3), GAMMAX
              WRITE (LU63, 99997, IOSTAT = IOST) GAMMAX
            END IF
            IK = IK + 1
            CALL PLA305 (NRRES, IK, NELT, AXS, TEXT,
     1        ORSAVE(1, K1), ORSAVE(2, K1), ORSAVE(3, K1), NSP)
C * read unit LU63, and rewrite on unit 9 :
            IF (NRRES == 1) CALL PLA312
          ELSE
            GO TO 20
          END IF
        END DO
C * if only 1 standardization, the work is done.
   30   IF (NRRES /= 1) THEN
C * look at horizontal sums :
          IGG = IK
          CALL PLA313 (2, IGG, NRRES, NEWNR, NCHOIC)
          IF (NRRES == 0) THEN
            WRITE (LU7, 99999, IOSTAT = IOST)
            RETURN
          END IF
          REWIND (UNIT = LU61, IOSTAT = IOST)
          K  = 0
          IK = 0
          DO II = 1, NRRES
            K1    = NCHOIC(II)
            KOUNT = NRFILE(K1)
   40       READ (LU61, IOSTAT = IOST) GAMMAX, TEXT, ORG
            IF (IOST /= 0) GO TO 50
            K = K + 1
            DO I = 1, NATOM
              READ (LU61, IOSTAT = IOST) NSP(I), (XXX(J, I), J = 1, 3),
     1              MULR(I), LETR(I), FOCCU(I)
              IF (IOST /= 0) RETURN
            END DO
            IF (K == KOUNT) THEN
              IF (IK > 0) THEN
                WRITE (LU63, 99981, IOSTAT = IOST)
                WRITE (LU6,  99982, IOSTAT = IOST)
              END IF
              WRITE (LU6,  99998, IOSTAT = IOST)
     1          TEXT, (ORSAVE(L, K1), L = 1, 3), GAMMAX
              WRITE (LU63, 99997, IOSTAT = IOST) GAMMAX
              IK = IK + 1
              CALL PLA305 (-II, IK, NELT, AXS, TEXT,
     1          ORSAVE(1, K1), ORSAVE(2, K1), ORSAVE(3, K1), NSP)
              CALL PLA312
            ELSE
              GO TO 40
            END IF
          END DO
        END IF
   50   IF (KFL > 0) THEN
          REWIND (UNIT = LU61, IOSTAT = IOST)
          K  = 0
          KK = 0
          DO I = 1, KFL
            WRITE (LU6,  99982, IOSTAT = IOST)
            WRITE (LU63, 99981, IOSTAT = IOST)
            KOUNT = KEQ(I)
            DO WHILE (K /= KOUNT - 1)
              READ (LU61, IOSTAT = IOST) GAMMAX, TEXT, ORG
              IF (IOST /= 0) RETURN
              K = K + 1
              DO J = 1, NATOM
                READ (LU61, IOSTAT = IOST) NSP(J),
     1            (XXX(L, J), L = 1, 3), MULR(J), LETR(J), FOCCU(J)
                IF (IOST /= 0) RETURN
              END DO
            END DO
            KK = KK + 1
C * COMPUTE VERTICAL SUMS
            CALL GEN074 (SM, 1, 3, 0.0)
            DO J = 1, NATOM
              DO L = 1, 3
                SM(L) = SM(L) + XXX(L, J)
              END DO
            END DO
            WRITE (LU6,  99998, IOSTAT = IOST) TEXT, ORG, GAMMAX
            WRITE (LU63, 99997, IOSTAT = IOST) GAMMAX
            CALL PLA305 (1, KK, NELT, AXS, TEXT, ORG(1), ORG(2),
     1        ORG(3), NSP)
            CALL PLA262 (3)
            WRITE (LU63, 99994, IOSTAT = IOST) SM
            CALL PLA312
          END DO
        END IF
      END IF
      RETURN
99999 FORMAT ('ERROR in SUBROUTINE PLA313 ')
99998 FORMAT (/, 'Setting ', A, ' Origin (', 3F7.4, ')', 2X,
     1        'Gamma = ', F7.4, /)
99997 FORMAT ('gamma', F8.4)
99996 FORMAT ('SUBROUTINE PLA318 : error in value of IFPLUS (too many',
     1 ' extra shifts')
99995 FORMAT ('New cell parameters : ', 3F8.4, ' 90  90  120')
99994 FORMAT (/, 'Sums :    ',3F9.5, /)
99993 FORMAT (A, 1X, A, 3X, 3F9.5, 5X, A, 5X, I3, '(', A, ')')
99992 FORMAT (/, 'WARNING ]]] ',/, I4, ' different settings;',
     1' only', I4, ' will be considered in printing results.')
99991 FORMAT ('Structure Tidy Results for ', A)
99990 FORMAT (/, 'WARNING : occupation factor not = 1')
99989 FORMAT (/, 'WARNING : setting -x,-y,-z has NOT been',
     1 ' considered since this would correspond to ',
     2 /, ' a space group with different chirality', /)
99988 FORMAT ('CELL', 9X, 3A, 1X, 3A, 7X, A)
99987 FORMAT (//, 'Minimum Standardization Parameter Gamma = ', F8.4)
99986 FORMAT ('All Possible Settings :', /, 23('='))
99985 FORMAT ('For every Setting, Origin Shifts Giving up to 1.0025',
     1 /, 'times the Minimum Gamma have been retained.', //)
99984 FORMAT (/, 'Setting ', A, 2X, 'Origin (', 3F8.5, ')', 3X,
     1        'Gamma = ', F8.4, /, 52X, 'Gamma/min(Gamma) = ', F8.4)
99983 FORMAT ('Cell : ', 3F8.4, 3F9.3)
99982 FORMAT (//, 'OTHER Standardization with Similar Gamma :')
99981 FORMAT ('OTHER Standardization with Similar Gamma :')
99980 FORMAT (/, 'Axes changed to : ', A)
99979 FORMAT ('Transformed from enantiomorphic space group')
99978 FORMAT ('REMARK Transformed from enantiomorphic space group.')
99977 FORMAT ('REMARK Transformed from rhombohedral cell.')
99976 FORMAT ('Transformation from rhombohedral cell to triple ',
     1 'hexagonal cell')
99975 FORMAT ('Extra origin shift, due to interchange of axes : ', A)
99974 FORMAT ('Extra origin shift, due to change of setting : ', A)
99973 FORMAT ('Extra origin shift, due to cell reduction : ', A)
99972 FORMAT ('Extra origin shift of ',3F7.3, /,' due to transformation'
     1 , ' to setting with centre of symmetry at the origin')
99971 FORMAT ('REMARK Transformed from non-centrosymmetric setting.')
99970 FORMAT ('Pearson code : ', 2A, I4, 2X, 10(A, F5.1, 2X))
99969 FORMAT ('Pearson code : ', 2A, I4, '(-', F6.2, ')', 2X,
     1         10(A, F5.1, 2X))
99968 FORMAT ('PCODE', 2X, 2A, A10, 4X, 5(A, 1X, A))
99967 FORMAT ('PCODE', 18X            , 5(A, 1X, A))
99966 FORMAT ('Space group : ', A, ' Number in IT : ', I3)
99965 FORMAT (F7.3)
99964 FORMAT (F6.2)
99963 FORMAT (I6)
99962 FORMAT (F8.4)
99961 FORMAT (F9.3)
99960 FORMAT (79('='))
99959 FORMAT ('TITL ', A)
99958 FORMAT ('CELL ', 6F10.4)
99957 FORMAT ('SPGR ', A)
      END SUBROUTINE PLA318
 
      SUBROUTINE PLA319 (LCASE, IK, IER)
C * This routine computes best values for origin in polar groups
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER                      :: I
      INTEGER                      :: J
      INTEGER                      :: K
      INTEGER                      :: M
      INTEGER                      :: N
      INTEGER                      :: I1
      INTEGER                      :: I2
      INTEGER                      :: I3
      INTEGER                      :: IA
      INTEGER                      :: IK
      INTEGER                      :: KT
      INTEGER                      :: NR
      INTEGER                      :: NP
      INTEGER                      :: KT1
      INTEGER                      :: IER
      INTEGER                      :: IIA
      INTEGER                      :: KNT
      INTEGER                      :: IORG
      INTEGER                      :: LCASE
      INTEGER                      :: LRET330
      INTEGER, DIMENSION(NUMAT)    :: NSP
      INTEGER, DIMENSION(NTOT)     :: NAT2
      REAL                         :: S
      REAL                         :: EP
      REAL                         :: SS
      REAL                         :: ZZ
      REAL,    DIMENSION(3, NUMAT) :: XS
      REAL,    DIMENSION(3, NTOT)  :: XM
      REAL,    DIMENSION(3)        :: XX
      REAL,    DIMENSION(3)        :: ORG
      REAL,    DIMENSION(3, 50)    :: SADD
      REAL,    DIMENSION(3)        :: ZMIN
      DO I = 1, 3
        ZMIN(I) = ORGA(I)
        ORG(I)  = ORGA(I)
      END DO
      DO J = 1, NTOT
        NAT2(J) = 0
        DO K = 1, 3
          XM(K, J) = 0.0
        END DO
      END DO
      REWIND (UNIT = LU60, IOSTAT = IOST)
      SMIN = 1000.0
C * nr is record number on unit 8 of result.
      S  = 0.0
      EP = -0.000001
C * npol atoms in unit cell, coordinates in xpol, errors in e :
      DO I = 1, NPOLX
        DO J = 1, 3
          XPOL(J, I) = XP(J, I) - ORGA(J)
          IF (XPOL(J, I) < 0.0) XPOL(J, I) = XPOL(J, I) + 1.0
        END DO
      END DO
      KNT = 0
      NR  = 0
      IF (IK == 1) THEN
        IF (LCASE == 2) THEN
          I1 = 2
        ELSE
          I1 = 3
        END IF
        I2 = 0
        I3 = 0
      ELSE IF (IK == 2) THEN
        I1 = 1
        I2 = 3
        I3 = 0
      ELSE IF (IK == 3) THEN
        I1 = 1
        I2 = 2
        I3 = 3
      END IF
      KPOL(1) = I1
      KPOL(2) = I2
      KPOL(3) = I3
      KT      = 0
      DO 20 K = 1, NPOLX
        CALL GEN074 (XX, 1, 3, 0.0)
        XX(I1) = XPOL(I1, K)
        IF (I2 > 0) XX(I2) = XPOL(I2, K)
        IF (I3 > 0) XX(I3) = XPOL(I3, K)
C * Take every shift with same atom only once...
        IF (K /= 1) THEN
          DO 10 N = 1, KT
            DO M = 1, 3
              IF (XX(M) == 0.0) THEN
                IF (M /= I1 .AND. M /= I2 .AND. J /= I3)
     1            CYCLE
              END IF
              IF (ABS (XX(M) - XM(M, N)) > 0.0001) GO TO 10
            END DO
            IF (NAT2(N) /= NAT(K)) GO TO 10
            GO TO 20
   10     CONTINUE
        END IF
        KT       = KT + 1
        NAT2(KT) = NAT(K)
        DO J = 1, 3
          XM(J, KT) = XX(J)
        END DO
C * find standardization parameter corresponding to this origin :
        S = 0.0
C * we DO not want too much output from SUBROUTINE PLA326 :
C * atom iia should have polar coordinate(s) = 0
        IIA = NAT(K)
C * compute nsp for originshift 0
        IPOLAR = 0
        DO IA = 1, NATOM
          DO J = 1, 3
            POS(J) = XROT(J, IA) - ORGA(J)
          END DO
          DO J = 1, 3
            IF (POS(J) < EP) POS(J) = POS(J) + 1.0
          END DO
C * Generates all atompositions for given space group
          CALL PLA322
          LRET330 = 0
          CALL PLA326 (IA, NP, LU7, LRET330)
          IF (LRET330 == 0) NSP(IA) = NP
        END DO
        DO IA = 1, NATOM
          DO J = 1, 3
            POS(J) = XROT(J, IA) - ORGA(J) - XX(J)
          END DO
          DO J = 1, 3
            IF (POS(J) < EP) POS(J) = POS(J) + 1.0
          END DO
C * Generates all atompositions for given space group
          CALL PLA322
          IPOLAR = 0
          IF (IA == IIA) IPOLAR = 1
          LRET330 = 0
          CALL PLA326 (IA, NP, LU7, LRET330)
          S = S + DMIN
        END DO
        IF (S > 99) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99998, IOSTAT = IOST) ORGA, XX
          GO TO 20
        ELSE
          CALL PLA262 (3)
          WRITE (LU7, 99999, IOSTAT = IOST) ORGA, XX, S
        END IF
        WRITE (LU60) XX, S
C * look for minimum S-value
        KNT = KNT + 1
        IF (S < SMIN) THEN
          SMIN = S
          NR   = KNT
          DO J = 1, 3
            ZZ = XX(J) + ORGA(J)
            IF (ZZ > 0.99999) ZZ = ZZ - 1.0
            ZMIN(J) = ZZ
          END DO
          DO IA = 1, NATOM
            DO J = 1, 3
              XS(J, IA) = XMIN(J, IA)
            END DO
          END DO
        END IF
   20 CONTINUE
C * RETURN WHEN  NO SETTING POSSIBLE
      IF (SMIN > 99) THEN
        WRITE (LU7, 99997, IOSTAT = IOST) ORGA, XX
        RETURN
      END IF
      DO J = 1, 3
        ORGA(J) = ZMIN(J)
      END DO
      IF (IFSH > 0 .OR. IFPLUS > 0) THEN
        DO J = 1, 3
          ORGA(J) = ORGA(J) + PLUS(J)
        END DO
      END IF
C * write results on unit LU61 :
      WRITE (LU61, IOSTAT = IOST) SMIN, STTEXT(NTEXT), ORGA
      IF (IOST /= 0) GO TO 30
      DO IA = 1, NATOM
        WRITE (LU61, IOSTAT = IOST) NSP(IA), (XS(J, IA), J = 1, 3),
     1     MUL(IA), LET(IA), FOCCU(IA)
        IF (IOST /= 0) GO TO 30
      END DO
      CALL PLA323 (2, IORG, SMIN, XS, LU7)
C * find minimum gamma :
      IF (SMIN < GMIN) GMIN = SMIN
C * remember shifts giving slightly greater sum :
      KT1 = 0
      IF (KNT /= 0) THEN
        SS = 1.0025 * SMIN
        REWIND (UNIT = LU60, IOSTAT = IOST)
        KT = 0
        DO I = 1, KNT
          READ (LU60, IOSTAT = IOST) XX, S
          IF (IOST /= 0) EXIT
          KT = KT + 1
          IF (KT /= NR) THEN
            IF (S < SS) THEN
              KT1 = KT1 + 1
              DO J = 1, 3
                ZZ = XX(J) + ORG(J)
                IF (ZZ > 0.99999) ZZ = ZZ - 1.0
                SADD(J, KT1) = ZZ
              END DO
            END IF
          END IF
        END DO
      END IF
      CALL PLA262 (4)
      WRITE (LU7, 99996, IOSTAT = IOST) STTEXT(ntext), smin, zmin
C * write also these higher values on unit 10 :
      IF (KT1 > 0) THEN
        WRITE (LU7, 99995, IOSTAT = IOST)
        WRITE (LU7, 99994, IOSTAT = IOST)
     1    ((SADD(I, J), I = 1, 3), J = 1, KT1)
        DO I = 1, KT1
          S = 0.0
          DO IA = 1, NATOM
            DO J = 1, 3
              POS(J) = XROT(J, IA) - SADD(J, I)
              IF (POS(J) < EP) POS(J) = POS(J) + 1.0
            END DO
C * Generates all atompositions for given space group
            CALL PLA322
            IPOLAR  = 0
            LRET330 = 0
            CALL PLA326 (IA, NP, LU7, LRET330)
            S = S + DMIN
          END DO
          DO J = 1, 3
            ORGA(J) = SADD(J, I)
          END DO
          WRITE (LU61, IOSTAT = IOST) S, STTEXT(NTEXT), ORGA
          IF (IOST /= 0) GO TO 30
          DO IA = 1, NATOM
            WRITE (LU61, IOSTAT = IOST) NSP(IA),
     1         (XMIN(J, IA), J = 1, 3), MUL(IA), LET(IA), FOCCU(IA)
            IF (IOST /= 0) GO TO 30
          END DO
          CALL PLA323 (2, IORG, SMIN, XMIN, LU7)
        END DO
      END IF
C * if no minimum found, error RETURN :
      IF (NR == 0) WRITE (LU7, 99993, IOSTAT = IOST)
      RETURN
   30 WRITE (LU7, 99992, IOSTAT = IOST)
      IER = 1
      RETURN
99999 FORMAT (/, 'Shift of ', 3F8.5, ' + ', 3F8.5,
     1        ' Gave Sum ', F10.4, /)
99998 FORMAT ('Shift of ', 3F8.5, ' + ', 3F8.5, ' no triplet possible')
99997 FORMAT ('No Setting Possible for ', 6F9.5)
99996 FORMAT (//, 'Result for setting : ', A, /
     1 'Standardization parameter', F9.4, ' is Attained for Shift ',
     2 3f8.4)
99995 FORMAT ('Shifts giving slightly higher standardidation :')
99994 FORMAT (12F8.5)
99993 FORMAT (/, 'ERROR in SUBROUTINE PLA319')
99992 FORMAT (//, 'ERROR  in PLA319 while writing on unit 10')
      END SUBROUTINE PLA319
 
      SUBROUTINE PLA320 (ISEQ, LU)
C * This routine was adapted from NBS*AIDS80 (Mighell, Hubbard & Stali)
C * SYMTST TESTS FOR EQUALITY OF DOT PRODUCTS BASED ON DIFFERENCES
C * BEING SMALLER THAT A PRESET VALUE FOR THE RELATIVE ERROR IN A*A
C * B*B, C*C, B*C, A*C OR A*B.
      USE stidy
      IMPLICIT NONE
      INTEGER :: ISEQ
      INTEGER :: LU
      INTEGER :: NEG
      INTEGER :: IOST
      INTEGER :: IFLAG1
      INTEGER :: IFLAG2
      INTEGER :: IFLAG3
      REAL    :: Q
      REAL    :: X
      REAL    :: Y
      REAL    :: Z
      REAL    :: DQ
      REAL    :: EX1
      REAL    :: E2
      REAL    :: E3
      REAL    :: E4
      REAL    :: E5
      REAL    :: E6
      REAL    :: ONE
      REAL    :: TWO
      REAL    :: THREE
C * THE RELATIVE ERROR Q IS SET TO 0.004
C * THE INCREMENT DQ INSURES THAT Q*E>0 NEAR 90 DEG
C * FLAGS 1,2,3 TO TEST WHAT IS EQUAL
C * NEG INDICATES THE REDUCED FORM TYPE (- OR +)
      Q      = 0.004
      DQ     = 0.04
      IFLAG1 = 0
      IFLAG2 = 0
      IFLAG3 = 0
      NEG    = 1
      ISEQ   = 0
      EX1    = A**2
      E2     = B**2
      E3     = C**2
      E4     = COSA * B * C
      E5     = COSB * A * C
      E6     = COSG * A * B
      ONE    = ABS (EX1 - E3)
      TWO    = ABS (EX1 - E2)
      THREE  = ABS (E2  - E3)
C * TEST FOR A=B=C
      IF (ONE < (Q * E3)) IFLAG1 = 1
C * TEST FOR A=B
      IF (TWO < (Q * E2)) IFLAG2 = 1
C * TEST FOR B=C
      IF (THREE < (Q * E3)) IFLAG3 = 1
C * DETERMINE REDUCED FORM TYPE (- OR +) BASED ON TRUE REDUCED CELL
      IF (E4 < Q .AND. E5 < Q .AND. E6 <= Q) NEG = -1
      IF (E4 > Q .AND. E5 > Q .AND. E6 >= Q) NEG = 0
      IF (NEG == 1) THEN
        NEG = -1
        IF (AL < 89.99 .OR. BE < 89.99 .OR. GA < 89.99) NEG = 0
        WRITE (LU, 99999, IOSTAT = IOST)
      END IF
      IF (IFLAG1 == 1) THEN
C * REDUCED FORM WITH A=B=C    (NUMBERS 1 TO 8)
        IF (NEG /= -1) THEN
          X = EX1 / 2.0
          IF (ABS (E4 - X) < (E4 * Q + DQ) .AND.
     1        ABS (E5 - X) < (E5 * Q + DQ) .AND.
     2        ABS (E6 - X) < (E6 * Q + DQ)) THEN
            ISEQ = 1
          ELSE IF (ABS (E4 - E5) < (E4 * Q + DQ) .AND.
     1        ABS(E5 - E6) < (E5 * Q + DQ)) THEN
            ISEQ = 2
          ELSE IF (ISEQ == 0) THEN
            GO TO 10
          END IF
          RETURN
        END IF
        Z = EX1 / 3.0
        IF ((ABS (E4) + ABS (E5) + ABS (E6)) < (DQ * 3.0)) THEN
          ISEQ = 3
        ELSE IF (ABS (E4 + Z) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E5 + Z) < (ABS (E5 * Q) + DQ) .AND.
     2      ABS (E6 + Z) < (ABS (E6 * Q) + DQ)) THEN
          ISEQ = 5
        ELSE IF (ABS (E4 - E5) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E5 - E6) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 4
        ELSE IF (ABS (E4 - E5) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS ((E6 + EX1) / 2.0 + E4) < (ABS (E4 * Q) + DQ)) THEN
          ISEQ = 6
        ELSE IF (ABS (E5 - E6) < (ABS (E5 * Q) + DQ) .AND.
     1      ABS ((E4 + EX1) / 2.0 + E5) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 7
        ELSE IF (ABS (EX1 + E4 + E5 + E6) < (ABS (E6 * Q) + DQ)) THEN
          ISEQ = 8
        ELSE IF (ISEQ == 0) THEN
          GO TO 30
        END IF
        RETURN
      END IF
      IF (IFLAG2 /= 1) THEN
        IF (IFLAG3 == 1) GO TO 40
        GO TO 60
      END IF
C * REDUCED FORMS WITH A=B   (NUMBERS 9 TO 17)
   10 IF (NEG /= -1) THEN
        X = EX1 / 2.0
        IF (ABS (E4 - X) < (E4 * Q + DQ) .AND.
     1      ABS (E5 - X) < (E5 * Q + DQ) .AND.
     2      ABS (E6 - X) < (E6 * Q + DQ)) THEN
          ISEQ = 9
        ELSE IF (ABS (E4 - E5) < (ABS (E4 * Q) + DQ)) THEN
          ISEQ = 10
        ELSE IF (ISEQ == 0) THEN
          GO TO 40
        END IF
        RETURN
      END IF
   30 X = EX1 / 2.0
      IF (ABS (E4 + E5) < (DQ * 2.0) .AND.
     1    ABS (E6 + X)  < (ABS (E6 * Q) + DQ)) THEN
        ISEQ = 12
      ELSE IF ((ABS (E4) + ABS (E5) + ABS (E6)) < (DQ * 3.0)) THEN
        ISEQ = 11
      ELSE IF (ABS (E4 - E5) < (ABS (E4 * Q) + DQ) .AND.
     1    ABS (E4 + X)  < (ABS (E4 * Q) + DQ)) THEN
        ISEQ = 15
      ELSE IF (ABS (E4 + E5) < (DQ * 2.0)) THEN
        ISEQ = 13
      ELSE IF (ABS (E4 - E5) < (ABS (E4 * Q) + DQ) .AND.
     1    ABS (EX1 + 2.0 * E4 + E6) < (ABS (E6 * Q)  + DQ)) THEN
        ISEQ = 16
      ELSE IF (ABS (EX1 + E4 + E5 + E6) < (ABS (E6 * Q) + DQ)) THEN
        ISEQ = 17
      ELSE IF (ABS (E4 - E5) < (ABS (E4 * Q) + DQ)) THEN
        ISEQ = 14
      ELSE IF (ISEQ == 0) THEN
        GO TO 50
      END IF
      RETURN
C * REDUCED FORMS WITH B=C    (NUMBERS 18 TO 25)
   40 IF (ABS (B - C) > ABS (B * Q)) GO TO 60
      IF (NEG /= -1) THEN
        X = EX1 / 2.0
        IF (ABS (E4 - X / 2.0) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E5 - E6) < (ABS (E5 * Q) + DQ) .AND.
     2      ABS (E5 - X)  < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 18
        ELSE IF (ABS (E5 - E6) < (ABS (E5 * Q) + DQ) .AND.
     1      ABS (E5 - X)  < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 19
        ELSE IF (ABS (E5 - E6) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 10
        ELSE IF (ISEQ == 0) THEN
          GO TO 60
        END IF
        RETURN
      END IF
   50 IF (ABS (B - C) <= ABS (B * Q)) THEN
        Y = E2 / 2.0
        IF (ABS (((E2 - EX1 / 3.0) / 2.0) + E4) < (ABS (E4 * Q) + DQ)
     1    .AND. ABS (E5 - E6) < (ABS (E5 * Q) + DQ)
     2    .AND. ABS (E5 + EX1 / 3.0) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 24
        ELSE IF (ABS (E6 + E5) < (DQ * 2.0) .AND.
     1      ABS (E4 + Y)  < (ABS (E4 * Q) + DQ)) THEN
          ISEQ = 22
        ELSE IF ((ABS (E4) + ABS (E5) + ABS (E6)) < (DQ * 3.0)) THEN
          ISEQ = 21
        ELSE IF (ABS (E6 + E5) < (DQ * 2.0)) THEN
          ISEQ = 23
        ELSE IF (ABS (E5 - E6) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 25
        END IF
        IF (ISEQ /= 0) RETURN
      END IF
      GO TO 70
C * REDUCED FORMS WITH A.NE.B.NE.C   (NUMBERS 26 TO 44)
   60 IF (NEG /= -1) THEN
        X = EX1 / 2.0
        Y = E2  / 2.0
        IF (ABS (E4 - X / 2.0) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E5 - E6) < (ABS (E5 * Q) + DQ) .AND.
     2      ABS (E5 - X) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 26
        ELSE IF (ABS (E5 - E6) < (ABS (E5 * Q) + DQ) .AND.
     1      ABS (E5 - X)  < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 27
        ELSE IF (ABS (E4 - E6 / 2.0) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E5 - X) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 28
        ELSE IF (ABS (E4 - E5 / 2.0) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E6 - X) < (ABS (E6 * Q) + DQ)) THEN
          ISEQ = 29
        ELSE IF (ABS (E4 - Y) < (ABS (E4 * Q) + DQ) .AND.
     1      ABS (E5 - E6 / 2.0) < (ABS (E5 * Q) + DQ)) THEN
          ISEQ = 30
        ELSE IF (ISEQ == 0) THEN
          ISEQ = 31
        END IF
        RETURN
      END IF
   70 X = EX1 / 2.0
      Y = E2  / 2.0
      IF ((ABS (E4) + ABS (E5) + ABS (E6)) < (DQ * 3.0)) THEN
        ISEQ = 32
      ELSE IF (ABS (E6 + E4) < (DQ * 2.0) .AND.
     1    ABS (E5 + X)  < (ABS (E5 * Q) + DQ)) THEN
        ISEQ = 36
      ELSE IF (ABS (E5 + E4) < (DQ * 2.0) .AND.
     1    ABS (E6 + X)  < (ABS (E6 * Q) + DQ)) THEN
        ISEQ = 38
      ELSE IF (ABS (E6 + E5) < (DQ * 2.0) .AND.
     1    ABS (E4 + Y)  < (ABS (E4 * Q) + DQ)) THEN
        ISEQ = 40
      ELSE IF (ABS (E6) < DQ .AND. ABS (E4 + Y) < (ABS (E4 * Q) + DQ)
     1   .AND. ABS (E5 + X) < (ABS (E5 * Q) + DQ)) THEN
        ISEQ = 42
      ELSE IF (ABS (E4 + E6) < (DQ * 2.0)) THEN
        ISEQ = 33
      ELSE IF (ABS (E4 + E5) < (DQ * 2.0)) THEN
        ISEQ = 34
      ELSE IF (ABS (E6 + E5) < (DQ * 2.0)) THEN
        ISEQ = 35
      ELSE IF (ABS (E5 + X) < (ABS (E5 * Q) + DQ) .AND.
     1    ABS(E6) < DQ) THEN
        ISEQ = 37
      ELSE IF (ABS (E6 + X) < (ABS (E6 * Q) + DQ) .AND.
     1    ABS(E5) < DQ) THEN
        ISEQ = 39
      ELSE IF (ABS (E4 + Y) < (ABS (E4 * Q) + DQ) .AND.
     1    ABS(E6) < DQ) THEN
        ISEQ = 41
      ELSE IF (ABS (E4 + (E2 + E6) / 2.0) < (ABS (E4 * Q) + DQ) .AND.
     1    ABS (E5 + (EX1 + E6) / 2.0) < (ABS (E5 * Q) + DQ)) THEN
        ISEQ = 43
      ELSE IF (ISEQ == 0) THEN
        ISEQ = 44
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT(//,'**WARNING** REDUCED FORM MAY NOT BE CORRECT')
      END SUBROUTINE PLA320
 
      SUBROUTINE PLA321 (L)
      USE stidy
C * called from PLA305; renumbers atoms in final outputlist of STIDY
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: L
      IF (NEL == 0) THEN
        FINELT(1) = ATOM1(l)
        NEL       = 1
        NEWN      = 1
        NRZ(1)    = 1
      ELSE
        I = 1
        DO J = 1, NEL
          I = J
          IF (ATOM1(L) == FINELT(J)) THEN
            NRZ(J) = NRZ(J) + 1
            NEWN   = NRZ(J)
            IF (NEWN > MAXNR(J)) MAXNR(J) = NEWN
            RETURN
          END IF
        END DO
        NEL         = NEL + 1
        NEWN        = 1
        FINELT(NEL) = ATOM1(L)
        NRZ(NEL)    = 1
        IF (NEWN > MAXNR(I)) MAXNR(I) = NEWN
      END IF
      RETURN
      END SUBROUTINE PLA321
 
      SUBROUTINE PLA322
C * Generates all atompositions for given space group
      USE stidy
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: I1
      INTEGER :: K1
      INTEGER :: NG
      INTEGER :: NG1
      REAL    :: S
      REAL    :: D1
      REAL    :: D2
      REAL    :: D3
      REAL    :: P1
      REAL    :: P2
      REAL    :: XX
      REAL    :: YY
      REAL    :: ZZ
      REAL    :: EPS
      REAL    :: EPS1
      REAL    :: XSUM
      NG = NGO
      K  = NG
      P1 = 1.0 / 3.0
      P2 = 2.0 / 3.0
C * generation of coordinates
      DO I = 1, NG
        DO J = 1, 3
          S = FLOAT (NTRAN(I, J)) / 24.0
          XYZ(J, I) = NROT(I, J, 1) * POS(1) + NROT(I, J, 2) * POS(2)
     1              + NROT(I, J, 3) * POS(3) + S
        END DO
      END DO
C * centrings (nbr = 1 -> 6  corresponds to centrings P,A,C,F,I,R) :
      IF (NBR == 1) THEN
        GO TO 20
      ELSE IF (NBR == 3) THEN
        GO TO 10
      ELSE IF (NBR == 5) THEN
        DO I = 1, NG
          K = NG + I
          DO J = 1, 3
            XYZ(J, K) = XYZ(J, I) + 0.5
          END DO
        END DO
        NG = K
        GO TO 20
      ELSE IF (NBR == 6) THEN
        DO I = 1, NG
          K         = NG + I
          XYZ(1, K) = XYZ(1, I) + P2
          XYZ(2, K) = XYZ(2, I) + P1
          XYZ(3, K) = XYZ(3, I) + P1
        END DO
        K1 = NG + NG
        DO I = 1, NG
          K         = K1 + I
          XYZ(1, K) = XYZ(1, I) + P1
          XYZ(2, K) = XYZ(2, I) + P2
          XYZ(3, K) = XYZ(3, I) + P2
        END DO
        NG = K
        GO TO 20
      ELSE IF (NBR == 2 .OR. NBR == 4) THEN
        DO I = 1, NG
          K         = NG + I
          XYZ(1, K) = XYZ(1, I)
          XYZ(2, K) = XYZ(2, I) + 0.5
          XYZ(3, K) = XYZ(3, I) + 0.5
        END DO
        NG = K
        IF (nbr /= 4) GO TO 20
      END IF
   10 DO I = 1, NG
        K         = NG + I
        XYZ(1, K) = XYZ(1, I) + 0.5
        XYZ(2, K) = XYZ(2, I) + 0.5
        XYZ(3, K) = XYZ(3, I)
      END DO
      NG = K
c * Put positions between 0 and 1:
   20 DO J = 1, NG
        DO I = 1, 3
          EPS  = - 0.000001
          EPS1 = 1.0 + EPS
   30     IF (XYZ(I, J) < EPS) THEN
            XYZ(I, J) = XYZ(I, J) + 1.0
            GO TO 30
          END IF
   40     IF (XYZ(I, J) >= EPS1) THEN
            XYZ(I, J) = XYZ(I, J) - 1.0
            GO TO 40
          END IF
        END DO
      END DO
c * Get out doubles
      EPS = 0.0001
      NG1 = NG - 1
      DO I = 1, NG1
        XX = XYZ(1, I)
        IF (XX <= 1.0) THEN
          YY = XYZ(2, I)
          ZZ = XYZ(3, I)
          I1 = I + 1
          DO J = I1, NG
            IF (XYZ(1, J) <= 1.0) THEN
              D1 = ABS (XYZ(1, J) - XX)
              D2 = ABS (XYZ(2, J) - YY)
              D3 = ABS (XYZ(3, J) - ZZ)
              IF (D1 < EPS .AND. D2 < EPS .AND. D3 < EPS)
     1           XYZ(1, J) = 10.0
            END IF
          END DO
        END IF
      END DO
      KOUNT = 0
      DO I = 1, NG
        IF (XYZ(1, I) <= 1.0) THEN
          KOUNT = KOUNT + 1
          XSUM   = 0.0
          DO J = 1, 3
            XSUM = XSUM + XYZ(J, I)**2
          END DO
          DIST(KOUNT) = SQRT (XSUM)
          DO J = 1, 3
            XYZ(J, KOUNT) = XYZ(J, I)
          END DO
        END IF
      END DO
      RETURN
      END SUBROUTINE PLA322
 
      SUBROUTINE PLA323 (NN, IORX, XSUM, FINXYZ, LU)
      USE stidy
      IMPLICIT NONE
      INTEGER                   :: I
      INTEGER                   :: J
      INTEGER                   :: K
      INTEGER                   :: LU
      INTEGER                   :: NN
      INTEGER                   :: IORX
      INTEGER                   :: IOST
      REAL                      :: XSUM
      REAL, DIMENSION(3, NUMAT) :: FINXYZ
C * CALLED FROM PLA301(NN = 1) AND FROM PLA319(NN = 2)
      IF (NTEXT > 0) THEN
        CALL PLA262 (0)
        CALL PLA262 (3)
        IF (NN == 1) THEN
          WRITE (LU, 99999, IOSTAT = IOST)
     1      STTEXT(NTEXT), (ORGADD(J, IORX), J = 1, 3)
        ELSE IF (NN == 2) THEN
          WRITE (LU, 99999, IOSTAT = IOST) STTEXT(NTEXT), ORGA
        END IF
      END IF
      CALL PLA262 (3)
      WRITE (LU, 99998, IOSTAT = IOST)
      DO I = 1, NATOM
        K = LET(I)
        CALL PLA262 (1)
        WRITE (LU, 99996, IOSTAT = IOST) ATOM1(I), ATOM2(I),
     1    (FINXYZ(J, I), J = 1, 3), FOCCU(I), MUL(I), CHAR(K + 96)
      END DO
      CALL PLA262 (2)
      WRITE (LU, 99997, IOSTAT = IOST) XSUM
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT ('Chosen Positions for Setting ', A, /, 45('='), /,
     1 'Origin Shift (', 3f8.5, ')')
99998 FORMAT (/, 'Atom ',9X, 'x', 9X, 'y', 9X, 'z', 5X, 'Occupancy',
     1        /, 58('='))
99997 FORMAT (/, 'Standardization Parameter Gamma =', F9.4)
99996 FORMAT (A, 1X, A, 3F10.5, 5X, A, 5X, I3, '(', A, ')')
      END SUBROUTINE PLA323
 
      SUBROUTINE PLA324 (NIG)
C * SUBROUTINE DETECTS SPECIAL POSITIONS FROM ATOMIC COORDINATES
      USE files
      USE stidy
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: NN
      INTEGER            :: NIG
      INTEGER            :: NPOS
      INTEGER            :: IFOUND
      REAL               :: EPS = 0.0001
      REAL, DIMENSION(3) :: POSIT
C * DOES ONE OF THE POSITIONS CORRESPOND TO A SPECIAL WYCKOFF POSITION ?
      N = 1
      DO NPOS = 1, KOUNT
        DO J = 1, 3
          POSIT(J) = XYZ(J, NPOS)
        END DO
        DO 10 I = 1, NSPEC
          K = NS(I)
          IF (K >= 0) THEN
            DO J = 1, 3
              IF (SPECIA(J, K) >= 0.0) THEN
                IF (ABS (POSIT(J) - SPECIA(J, K)) > EPS) GO TO 10
              END IF
            END DO
            IF (KSET /= 0) THEN
              IF (IS(I) >= KSET) GO TO 10
            END IF
          ELSE
C * Look at 'special' special positions in SUBROUTINE PLA325
            IFOUND = 0
            CALL PLA325 (POSIT, IFOUND, K)
            IF (IFOUND == 0) GO TO 10
            IF (KSET /= 0) THEN
              IF (IS(I) >= KSET) GO TO 10
            END IF
          END IF
          KSET  = IS(I)
          N     = NPOS
          KORD  = I
   10   CONTINUE
      END DO
      IF (KSET == 0) THEN
        MU   = MULT(NW)
        KORD = NSPEC + 1
        IF (NIG == 0) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99996, IOSTAT = IOST) MU, CHAR (96 + KORD)
        END IF
        RETURN
      END IF
      MU = MULT(KSET)
      IF (N > 1) THEN
        DO J = 1, 3
          XYZ(J, 1) = XYZ(J, N)
        END DO
      END IF
      K = NS(KORD)
      IF (NIG == 0) THEN
        CALL PLA262 (1)
        IF (K > 0) THEN
          WRITE (LU7, 99999, IOSTAT = IOST) STAA(K), MU,
     1      CHAR (96 + KORD)
        ELSE
          K = -K
          WRITE (LU7, 99999, IOSTAT = IOST) STBB(K), MU,
     1      CHAR (96 + KORD)
        END IF
      END IF
      L  = 0
      NN = IS(KORD)
      DO I = 1, NSPEC
        IF (NN == IS(I)) THEN
          L       = L + 1
          NSET(L) = NS(I)
        END IF
      END DO
      KSET = L
      IF (L > 0) THEN
        CALL PLA262 (1 + L)
        WRITE (LU7, 99997, IOSTAT = IOST)
        DO J = 1, L
          K = NSET(J)
          IF (K > 0) THEN
            WRITE (LU7, 99998, IOSTAT = IOST) STAA(K)
          ELSE
            K = - K
            WRITE (LU7, 99998, IOSTAT = IOST) STBB(K)
          END IF
        END DO
      END IF
      RETURN
99999 FORMAT ('Special Position : ', A, ' Multiplicity ', I3,
     1'  Wyckoff Letter: ', A)
99998 FORMAT (A)
99997 FORMAT ('All Possible Special Positions for this Atom :')
99996 FORMAT ('General Position ', I3, A)
      END SUBROUTINE PLA324
 
      SUBROUTINE PLA325 (X, IFOUND, K)
      IMPLICIT NONE
      INTEGER            :: K
      INTEGER            :: IFOUND
      REAL               :: A
      REAL               :: EPS   = 0.0001
      REAL               :: EPS1  = 0.9999
      REAL               :: SMALL = 0.0005
      REAL, DIMENSION(3) :: X
      K = - K
      IF (K < 7 .OR. K == 35 .OR. K == 36) THEN
        IF (ABS (X(1) - X(2)) <= SMALL) THEN
          IF (K == 36) THEN
            IFOUND = 1
          ELSE IF (K == 35) THEN
            IF (ABS (X(2) - X(3)) < SMALL) IFOUND = 1
          ELSE IF (K == 1) THEN
            IF (ABS (X(3))          < SMALL) THEN
              IFOUND = 1
            ELSE IF (ABS (X(3) - 1.0) < SMALL) THEN
               IFOUND = 1
            END IF
          ELSE IF (K == 2) THEN
            IF (ABS (X(3) - 0.5)    < SMALL) IFOUND = 1
          ELSE IF (K == 3) THEN
            IF (ABS (X(3) - 0.25)   < SMALL) IFOUND = 1
          ELSE IF (K == 4) THEN
            IF (ABS (X(3) - 0.75)   < SMALL) IFOUND = 1
          ELSE IF (K == 5) THEN
            IF (ABS (X(3) - 0.375)  < SMALL) IFOUND = 1
          ELSE IF (K == 6) THEN
            IF (ABS (X(3) - 0.625)  < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF ((K > 6 .AND. K < 14) .OR. K == 37) THEN
        A = 1.0 - X(2)
        IF (A < EPS) A = A + 1.0
        IF (ABS (A - X(1)) <= SMALL) THEN
          IF (K == 37) THEN
            IFOUND = 1
          ELSE IF (K == 7) THEN
            IF (ABS (X(3))          < SMALL) THEN
              IFOUND = 1
            ELSE IF (ABS (X(3) - 1.0) < SMALL) THEN
              IFOUND = 1
            END IF
          ELSE IF (K == 8) THEN
            IF (ABS (X(3) - 0.5)    < SMALL) IFOUND = 1
          ELSE IF (K == 9) THEN
            IF (ABS (X(3) - 0.25)   < SMALL) IFOUND = 1
          ELSE IF (K == 10) THEN
            IF (ABS (X(3) - 0.3333) < SMALL) IFOUND = 1
          ELSE IF (K == 11) THEN
            IF (ABS (X(3) - 0.6667) < SMALL) IFOUND = 1
          ELSE IF (K == 12) THEN
            IF (ABS (X(3) - 0.1667) < SMALL) IFOUND = 1
          ELSE IF (K == 13) THEN
            IF (ABS (X(3) - 0.8333) < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF (K > 23 .AND. K < 27) THEN
        IF (ABS (X(2) - X(3)) <= SMALL) THEN
          IF (K == 24) THEN
            IF (ABS (X(1))          < SMALL) IFOUND = 1
          ELSE IF (K == 25) THEN
            IF (ABS (X(1) - 0.5)    < SMALL) IFOUND = 1
          ELSE IF (K == 26) THEN
            IF (ABS (X(1) - 0.25)   < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF (K == 27 .OR. K == 28) THEN
        A = 1.0 - X(2)
        IF (A < EPS) A = A + 1.0
        IF (ABS (A - X(3)) <= SMALL) THEN
          IF (K == 27) THEN
            IF (ABS (X(1))          < SMALL) IFOUND = 1
          ELSE IF (K == 28) THEN
            IF (ABS (X(1) - 0.25)   < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF ((K > 13 .AND. K < 17) .OR. K == 38) THEN
        A = X(1) + 0.5
        IF (A > EPS1) A = A - 1.0
        IF (ABS (A - X(2)) <= SMALL) THEN
          IF (K == 38) THEN
            IFOUND = 1
          ELSE IF (K == 14) THEN
            IF (ABS (X(3) - 0.25)   < SMALL) IFOUND = 1
          ELSE IF (K == 15) THEN
            IF (ABS (X(3) - 0.5)    < SMALL) IFOUND = 1
          ELSE IF (K == 16) THEN
            IF (ABS (X(3))          < SMALL) THEN
              IFOUND = 1
            ELSE IF (ABS (X(3) - 1.0) < SMALL) THEN
              IFOUND = 1
            END IF
          END IF
        END IF
      ELSE IF (K == 17) THEN
        A = 0.5 - X(1)
        IF (A < EPS) A = A + 1.0
        IF (ABS (A - X(2)) < SMALL .AND.
     1    ABS(X(3) - 0.25) <  SMALL) IFOUND = 1
      ELSE IF (K == 18 .OR. K == 19) THEN
        A = X(1) + 0.25
        IF (A > EPS1) A = A - 1.0
        IF (ABS (A - X(2)) <= SMALL) THEN
          IF (K == 18) THEN
            IF (ABS (X(3) - 0.125) < SMALL) IFOUND = 1
          ELSE IF (K == 19) THEN
            IF (ABS (X(3) - 0.875) < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF ((K > 19 .AND. K < 24) .OR. K == 39) THEN
        A = X(1) + X(1)
        IF (A > EPS1) A = A - 1.0
        IF (ABS (A - X(2)) <= SMALL) THEN
          IF (K == 39) THEN
            IFOUND = 1
          ELSE IF (K == 20) THEN
            IF (ABS (X(3)) < SMALL) THEN
              IFOUND = 1
            ELSE IF (ABS (X(3) - 1.0) < SMALL) THEN
              IFOUND = 1
            END IF
          ELSE IF (K == 21) THEN
            IF (ABS (X(3) - 0.5)  < SMALL) IFOUND = 1
          ELSE IF (K == 22) THEN
            IF (ABS (X(3) - 0.25) < SMALL) IFOUND = 1
          ELSE IF (K == 23) THEN
            IF (ABS (X(3) - 0.75) < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF (K == 29 .OR. K == 30) THEN
        IF (ABS (X(1) - 0.25) <= SMALL) THEN
          IF (K == 30) THEN
            A = 0.5 - X(2)
            IF (A < EPS) A = A + 1.0
            IF (ABS (A - X(3)) < SMALL) IFOUND = 1
          ELSE IF (K == 29) THEN
            A = 0.5 + X(2)
            IF (A > EPS1) A = A - 1.0
            IF (ABS (A - X(3)) < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF (K == 31 .OR. K == 32) THEN
        IF (ABS (X(1) - 0.5) < SMALL) THEN
          IF (K == 32) THEN
            A = 1.0 - X(2)
            IF (A < EPS) A = A + 1.0
            IF (ABS (X(3) - A) < SMALL) IFOUND = 1
          ELSE IF (K == 31) THEN
            A = 0.5 + X(2)
            IF (A > EPS1) A = A - 1.0
            IF (ABS (X(3) - A) < SMALL) IFOUND = 1
          END IF
        END IF
      ELSE IF (K == 33 .OR. K == 34) THEN
        IF (ABS (X(1) - 0.125) < SMALL) THEN
          IF (K == 34) THEN
            A = 0.25 - X(2)
            IF (A < EPS) A = A + 1.0
            IF (ABS (X(3) - A) < SMALL) IFOUND = 1
          ELSE IF (K == 33) THEN
            A = 0.25 + X(2)
            IF (A > EPS1) A = A - 1.0
            IF (ABS (X(3) - A) < SMALL) IFOUND = 1
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLA325
 
      SUBROUTINE PLA326 (IA, NP, LU, IER)
C * FIND COORDINATE TRIPLET WITH MINIMUM 'DISTANCE':
      USE stidy
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: K1
      INTEGER               :: IA
      INTEGER               :: KK
      INTEGER               :: NP
      INTEGER               :: LU
      INTEGER               :: MX
      INTEGER               :: MY
      INTEGER               :: MZ
      INTEGER               :: MEQ
      INTEGER               :: IER
      INTEGER               :: IOST
      INTEGER               :: KLOW
      INTEGER               :: IFOUND
      INTEGER, DIMENSION(8) :: MULSET
      REAL                  :: EX1
      REAL                  :: E2
      REAL                  :: E3
      REAL                  :: XSUM
      REAL                  :: XMINX
      REAL                  :: YMINY
      REAL                  :: ZMINZ
      REAL,    DIMENSION(3) :: Y
      CALL GEN097 (KORDER, 1, KOUNT, NSPEC + 1)
      KORD  = 0
      NP    = 0
      EX1   = 0.0001
      E2    = 0.0001
      E3    = 0.0001
      IFLAG = 0
      MEQ   = 0
      KSET  = NRSET(IA)
      IF (KSET > 0) THEN
C * EXCLUDE ATOM IF NOT IN PERMITTED SPECIAL POSITION:
        DO 20 I = 1, KOUNT
          DO 10 M = 1, KSET
            K = NNSET(M, IA)
            IF (K > 0) THEN
              DO J = 1, 3
                IF (SPECIA(J, K) >= 0) THEN
                  IF (ABS (XYZ(J, I) - SPECIA(J, K)) > 0.001) GO TO 10
                END IF
              END DO
              DO J = 1, NSPEC
                IF (NS(J) == K) THEN
                  KORDER(I) = J
                  GO TO 20
                END IF
              END DO
            ELSE
              DO J = 1, 3
                Y(J) = XYZ(J, I)
              END DO
              IFOUND = 0
              CALL PLA325 (Y, IFOUND, K)
              IF (IFOUND == 0) GO TO 10
              DO J = 1, NSPEC
                KK = - K
                IF (KK == NS(J)) THEN
                  KORDER(I) = J
                  GO TO 20
                END IF
              END DO
            END IF
            WRITE (LU, 99994, IOSTAT = IOST) (XYZ(J, I), J = 1, 3)
            IFLAG = 1
            IER   = 1
            RETURN
   10     CONTINUE
          DIST(I) = 100.0
          CALL PLA262 (1)
          WRITE (LU, 99989, IOSTAT = IOST) I, (XYZ(J, I), J = 1, 3)
   20   CONTINUE
      END IF
      IF (IPOLAR == 1) THEN
        KLOW = 27
        DO J = 1, KOUNT
          IF (KORDER(J) < KLOW) KLOW = KORDER(J)
        END DO
        IF (KLOW /= LOWLET) THEN
          CALL PLA262 (1)
          WRITE (LU, 99988, IOSTAT = IOST)
     1      XYZ(1, 1), XYZ(2, 1), XYZ(3, 3)
          DMIN = 100.0
          RETURN
        END IF
      END IF
C * COMPUTE 'DISTANCE' OF PERMITTED POSITION
      CALL PLA262 (3)
      WRITE (LU, 99998, IOSTAT = IOST)
      DO 30 I = 1, KOUNT
        IF (DIST(I) <= 99.0) THEN
C * Exclude atom if it is the 'polar one' and coordinate(s) not = 0
          IF (IPOLAR == 1) THEN
            DO J = 1, 3
              K = KPOL(J)
              IF (K /= 0) THEN
                IF (XYZ(K, I) /= 0.0) THEN
                  DIST(I) = 100.0
                  CALL PLA262 (3)
                  WRITE (LU, 99996, IOSTAT = IOST)
     1               I, (XYZ(N, I), N = 1, 3)
                  GO TO 30
                END IF
              END IF
            END DO
          END IF
          XSUM    = XYZ(1, I)**2 + XYZ(2, I)**2 + XYZ(3, I)**2
          DIST(I) = SQRT (XSUM)
          KK      = KORDER(I)
          K1      = IS(KK)
          CALL PLA262 (1)
          WRITE (LU, 99995, IOSTAT = IOST)
     1      I, (XYZ(J, I), J = 1, 3), DIST(I), MULT(K1),
     1      CHAR(96 + KK)
        END IF
   30 CONTINUE
C * FIND SMALLEST 'DISTANCE'
      DMIN = 100.0
      DO I = 1, KOUNT
        IF (DIST(I) < DMIN) THEN
          DMIN = DIST(I)
          MINI  = I
        END IF
      END DO
      IF (DMIN >= 99.99) THEN
        CALL PLA262 (1)
        WRITE (LU, 99987, IOSTAT = IOST)
        IFLAG = 1
        IER   = 1
        RETURN
      END IF
C * LOOK FOR OTHER COORDINATE TRIPLETS WITH SAME 'DISTANCE':
      KK        = 1
      MULSET(1) = MINI
      EX1       = 0.0001
      E2        = 0.0001
      E3        = 0.0001
      DO I = 1, KOUNT
        IF (I /= MINI) THEN
          IF (ABS (DIST(I) - DMIN) <= EX1) THEN
            KK = KK + 1
            IF (KK > 8) THEN
              CALL PLA262 (1)
              WRITE (LU, 99991, IOSTAT = IOST)
              GO TO 70
            END IF
            MULSET(KK) = I
          END IF
        END IF
      END DO
      IF (KK == 1) GO TO 80
      MX    = MULSET(1)
      XMINX = XYZ(1, MINI)
      DO K = 2, KK
        I = MULSET(K)
        IF (ABS (XYZ(1, I) - XMINX) >= EX1) THEN
          IF (XYZ(1, I) < XMINX) THEN
            XMINX = XYZ(1, I)
            MEQ   = 0
            MX    = I
            CYCLE
          ELSE IF (XYZ(1, I) > XMINX) THEN
            CYCLE
          END IF
        END IF
        MEQ = 1
        MX  = I
      END DO
      MINI = MX
      IF (MEQ /= 0) THEN
        YMINY = XYZ(2, MX)
        MEQ   = 0
        MY    = MX
        DO 50 K = 1, KK
          I = MULSET(K)
          IF (I /= MX) THEN
            IF (ABS (XYZ(1, I) - XYZ(1, MX)) <= EX1) THEN
              IF (ABS (XYZ(2, I) - YMINY) >= E2) THEN
                IF (XYZ(2, I) < YMINY) THEN
                  YMINY = XYZ(2, I)
                  MEQ   = 0
                  MY    = I
                  GO TO 50
                ELSE IF (XYZ(2, I) == YMINY) THEN
                  GO TO 40
                ELSE
                  GO TO 50
                END IF
              END IF
   40         IF (I /= MY) THEN
                MEQ = 1
                MY  = I
              END IF
            END IF
          END IF
   50   CONTINUE
        MINI = MY
        IF (MEQ /= 0) THEN
          MEQ   = 0
          MZ    = MY
          ZMINZ = XYZ(3, MY)
          DO 60 K = 1, KK
            I = MULSET(K)
            IF (I /= MY) THEN
              IF (ABS (XYZ(1, I) - XYZ(1, MX)) > EX1 .OR.
     1            ABS (XYZ(2, I) - XYZ(2, MY)) > E2) GO TO 60
              IF (ABS (XYZ(3, I) - ZMINZ) >= E3) THEN
                IF (XYZ(3, I) < ZMINZ) THEN
                  ZMINZ = XYZ(3, I)
                  MEQ   = 0
                  MZ    = I
                  GO TO 60
                END IF
              END IF
              IF (XYZ(3, I) == ZMINZ) THEN
                IF (I /= MZ) THEN
                  MEQ = 1
                  MZ  = I
                END IF
              END IF
            END IF
   60     CONTINUE
          IF (MEQ == 1) THEN
            CALL PLA262 (1)
            WRITE (LU, 99992, IOSTAT = IOST)
            GO TO 80
          END IF
          MINI = MZ
        END IF
      END IF
   70 CALL PLA262 (2)
      WRITE (LU, 99990, IOSTAT = IOST) DMIN
      DO K = 1, KK
        I = MULSET(K)
        CALL PLA262 (1)
        WRITE (LU, 99993, IOSTAT = IOST) I, (XYZ(J, I), J = 1, 3)
      END DO
   80 KORD = KORDER(MINI)
      IF (KORD <= NSPEC) NP = NS(KORD)
      IF (NP < 0) NP = 107 - NP
      K1 = IS(KORD)
      MU = MULT(K1)
      CALL PLA262 (2)
      WRITE (LU, 99999, IOSTAT = IOST)
     1   MINI, (XYZ(J, MINI), J = 1, 3), DMIN, MU, CHAR (96 + KORD)
C * SAVE RESULTS FOR PLA319
      DO J = 1, 3
        XMIN(J, IA) = XYZ(J, MINI)
      END DO
      MUL(IA) = MU
      LET(IA) = KORD
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (/, 'Chosen :', I3, 5X, 3F9.5, 5X,
     1        F8.4, 8X, I3, '(', A1, ')')
99998 FORMAT (/, 'Permitted Positions', 3X, 'x', 8X, 'y', 8X, 'z', 12X,
     1  'D', /, 80('='))
99996 FORMAT (/, 'We Exclude', I3, 3X, 3F9.5,
     1        ': Polar Coordinate(s) not = 0', /)
99995 FORMAT (6X, I5, 5X, 3F9.5, 5X, F8.4, 8X, I3, '(', A1, ')')
99994 FORMAT ('Trouble in Finding Special Position for ', 3F9.5)
99993 FORMAT (I3, 3F9.5)
99992 FORMAT ('SUBROUTINE PLA326: all coordinates equal: IMPOSSIBLE')
99991 FORMAT ('ERROR : more than 8 possibilities for equal "distance"',
     1 '(subroutine PLA326)')
99990 FORMAT (/, 'Several Choices give same Minimum "Distance"', F8.4)
99989 FORMAT ('Exclude: ',I2, 5X, 3F9.5)
99988 FORMAT ('Exclude Atom ', 3F8.5, ' : not Lowest Wyckoff Letter')
99987 FORMAT ('No permitted choice of coordinate triplet')
      END SUBROUTINE PLA326
 
      SUBROUTINE PLA327
      USE stidy
      IMPLICIT NONE
      ISETS(1:209) = (/
     1   1,  1,  1,  0,  1,  0,  1,  1,  1,  0,  8,  2,  0,  8,  7,  6,
     2   5,  4,  3,  2,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  2,  2,
     3   1,  1,  4,  2,  0, 78, 76, 77, 75,  1,  1,  1,  1,  1,  2,  2,
     4   1,  1,  0,  1,  0,  2,  3,  1,  1,  2,  2,  0, 78, 76,  1,  1,
     5   2,  4,  2,  1,  1,  2,  2,  0,103,102,  1,  1,  1,  2,  4,  1,
     6   1,  0,  1,  0,  2,  3,  1,  1,  1,  2,  0,103,  1,  2,  4,  5,
     7   1,  1,  0,  1,  0,  4,  2,  1,  0, 14,  4,  0,  8,  6,  7,  5,
     8   4,  2,  3,  1, 78, 77, 76, 75,103,102,  1,  1,  1,  1,  1,  1,
     9   1,  1,  2,  2,  2,  2,  3,  3,  1,  2,  2,  4,  2,  1,  0,  5,
     *   3,  0,  8,  5,  7,  3,104,  1,  1,  1,  1,  2,  2,  2,  4,  3,
     1   1,  0,  9,  5,  0,  8,  6,  7,  2, 10,  9, 78, 76,103,  1,  1,
     2   1,  1,  2,  2,  3,  3,  4,  2,  4,  4,  4,  8,  4,  1,  0,  6,
     3   3,  0,  8,  4,  6,  5, 80, 79,  1,  1,  1,  1,  2,  2,  2,  2,
     4   4/)
      ISETS(210:495) = (/
     1   4,  1,  0,  4,  2,  0,  8,  5,  7,  3,  1,  1,  1,  1,  2,  4,
     2   6,  1,  0,  5,  4,  0,  8,  6, 10,  9, 80,  1,  1,  2,  2,  3,
     3   4,  4,  4,  8,  7,  1,  1, 20,  5,  0,  8,  5,  6,  7,  4,  3,
     4   2,  1, 61, 60, 59, 58, 78, 76, 77, 75, 89, 88, 87, 86,  1,  1,
     5   1,  1,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3,  4,  4,
     6   4,  4,  1,  2,  2,  2,  4,  9,  1,  1,  4,  3,  0, 61, 59, 80,
     7  79,  1,  1,  2,  2,  2,  2,  4,  8,  1,  1,  2,  2,  0, 89, 87,
     8   1,  1,  2,  4, 10,  1,  1,  0,  1,  0,  4,  9,  1,  1,  2,  3,
     9   0, 61, 80,  1,  2,  4,  4,  8,  8,  1,  1, 11,  6,  0,  8,  6,
     *   3,  7, 61, 60, 78, 76, 89, 87, 90,  1,  1,  1,  1,  2,  2,  3,
     1   3,  4,  4,  5,  2,  4,  4,  4,  4,  8,  7,  1,  1, 10,  5,  0,
     2   8,  7, 12, 11, 61, 78, 89, 90, 81, 62,  1,  1,  1,  1,  2,  3,
     3   4,  4,  3,  2,  4,  8,  8,  8, 16,  7,  1,  1, 10,  5,  0,  8,
     4   5,  7,  6, 61, 60, 78, 77, 89, 87,  1,  1,  1,  1,  2,  2,  3,
     5   3,  4,  4,  2,  4,  4,  4,  8, 10,  1,  1,  3,  4,  0, 63, 82,
     6  91,  1,  2,  3,  4,  4,  4,  8,  8,  1,  1,  8,  4,  0, 89, 87,
     7  88, 86,103,102,106,105,  1,  1,  1,  1,  2,  2,  3,  3,  1,  2,
     8   2,  4,  0,  1,  1,  2,  2,  0,106,105,  1,  1,  2,  4/)
      ISETS(496:667) = (/
     1   8,  1,  1,  4,  2,  0, 89, 87, 88, 86,  1,  1,  1,  1,  2,  4,
     2   0,  1,  1,  3,  3,  0, 89, 87,107,  1,  1,  2,  2,  2,  4,  0,
     3   1,  1,  0,  1,  0,  4,  0,  1,  1,  2,  2,  0, 89, 88,  1,  1,
     4   2,  4,  0,  1,  1,  1,  2,  0,106,  1,  2,  4,  8,  1,  1,  2,
     5   2,  0, 89, 87,  1,  1,  2,  4,  0,  1,  1,  0,  1,  0,  4,  8,
     6   1,  1,  2,  2,  0, 89, 87,  1,  1,  2,  4,  8,  1,  1,  5,  5,
     7   0, 89, 87, 90,103,106,  1,  1,  2,  3,  4,  2,  4,  4,  4,  8,
     8   0,  1,  1,  1,  2,  0,106,  1,  4,  8,  8,  1,  1,  3,  3,  0,
     9  89, 87, 90,  1,  1,  2,  4,  4,  8,  0,  1,  1,  5,  4,  0, 89,
     *  88,103,106,105,  1,  1,  2,  3,  3,  2,  4,  4,  8,  0,  1,  1,
     1   3,  3,  0, 89, 88,104,  1,  1,  2,  4,  4,  8/)
      ISETS(668:999) = (/
     1   0,  1,  1,  2,  3,  0, 89,107,  1,  2,  4,  4,  8,  0,  1,  1,
     2   1,  2,  0, 89,  1,  4,  8,  8,  1,  1,  4,  5,  0, 89, 90,106,
     3 103,  1,  2,  3,  4,  4,  8,  8,  8, 16, 11,  1,  3,  1,  2,  0,
     4  89,  1,  8, 16,  8,  1,  1,  4,  4,  0, 89, 87,103,106,  1,  1,
     5   2,  3,  2,  4,  4,  8,  8,  1,  1,  2,  2,  0, 89, 87,  1,  1,
     6   4,  8,  0,  1,  1,  2,  3,  0, 89,107,  1,  2,  4,  4,  8,  7,
     7   1,  0, 26,  8,  0,  8,  5,  7,  3,  6,  4,  2,  1, 61, 60, 59,
     8  58, 78, 76, 77, 75, 89, 87, 88, 86,106,105,103,102,100, 99,  1,
     9   1,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3,  4,
     *   4,  4,  4,  5,  5,  6,  6,  7,  7,  1,  2,  2,  2,  4,  4,  4,
     1   8, -7,  1,  0, 12,  6,  1, 12, 14, 11, 13,  1,  8, 62, 64, 81,
     2  83, 90, 92,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  2,
     3   4,  4,  4,  4,  8,  8,  1,  0, 17,  7,  0,  8,  4,  6,  5, 18,
     4  17, 16, 15, 63, 65, 80, 79, 89, 86, 87, 88,100,  1,  1,  1,  1,
     5   2,  2,  2,  2,  3,  3,  4,  4,  5,  5,  5,  5,  6,  2,  2,  4,
     6   4,  4,  4,  8, -8,  1,  0, 12,  6,  2, 22, 21, 20, 19,  8,  7,
     7  67, 66, 82, 84, 90, 92,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,
     8   5,  5,  2,  4,  4,  4,  4,  8,  0,  1,  0, 11,  6,  0,  8,  6,
     9   7,  2, 94, 93, 78, 76,103,102,107,  1,  1,  1,  1,  2,  2,  3,
     *   3,  4,  4,  5,  2,  2,  4,  4,  4,  8,  0,  1,  0,  4,  4,  0,
     1   8,  7, 94, 62,  1,  1,  2,  3,  4,  4,  4,  8/)
      ISETS(1000:1297) = (/
     1   0,  1,  0,  8,  5,  0,  8,  5,  4,  6, 61, 59, 81,106,  1,  1,
     2   1,  1,  2,  2,  3,  4,  2,  4,  4,  4,  8,  0,  1,  0,  5,  4,
     3   0,  8,  6, 80, 94, 93,  1,  1,  2,  3,  3,  4,  4,  4,  8,  8,
     4   1,  0,  8,  4,  0,  8,  7,  6,  2, 89, 87,100, 99,  1,  1,  1,
     5   1,  2,  2,  3,  3,  2,  4,  4,  8,  8,  1,  0,  4,  3,  0,  8,
     6   7, 90, 92,  1,  1,  2,  2,  4,  4,  8,  0,  1,  0,  4,  4,  0,
     7   8,  5, 67,101,  1,  1,  2,  3,  4,  4,  4,  8,  8,  1,  0,  7,
     8   4,  0,  8,  7,  6,  2, 89, 87,100,  1,  1,  1,  1,  2,  2,  3,
     9   2,  4,  4,  8, -8,  1,  0,  6,  5,  2, 90, 92,  8,  7,107,104,
     *   1,  1,  2,  2,  3,  4,  2,  4,  4,  4,  8,  0,  1,  0,  3,  3,
     1   0,  8,  6, 80,  1,  1,  2,  4,  4,  8, 14,  1,  0,  2,  2,  0,
     2   8,  7,  1,  1,  4,  8,  0,  1,  0,  3,  3,  0,  8,  7,104,  1,
     3   1,  2,  4,  4,  8,  0,  1,  0,  7,  7,  0,  8,  6, 80, 22, 61,
     4 106,101,  1,  1,  2,  3,  4,  5,  6,  4,  4,  8,  8,  8,  8, 16,
     5   0,  1,  0,  6,  6,  0,  8,  5, 22, 61, 81,106,  1,  1,  2,  3,
     6   4,  5,  4,  8,  8,  8,  8, 16,  8,  1,  0, 17, 10,  0,  8,  5,
     7   3,  7, 22, 19, 61, 60, 78, 76, 89, 87, 90,106,103,100, 99,  1,
     8   1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  6,  7,  8,  9,  9,
     9   2,  4,  4,  4,  4,  8,  8,  8,  8, 16/)
      ISETS(1298:1662) = (/
     1   8,  1,  0, 12,  9,  0, 18, 16,  8,  6, 22, 23, 63, 80, 89, 87,
     2  90,100,  1,  1,  2,  2,  3,  3,  4,  5,  6,  6,  7,  8,  4,  4,
     3   4,  8,  8,  8,  8,  8, 16, 12,  1,  0, 14, 10,  0, 24, 25,  8,
     4   7, 22, 19, 91, 61, 60, 82, 84, 94,106,104,  1,  1,  2,  2,  3,
     5   3,  4,  5,  5,  6,  6,  7,  8,  9,  4,  4,  4,  4,  8,  8,  8,
     6   8,  8, 16,-12,  1,  0,  8,  8,  3, 26, 27, 23,  8, 62, 80, 91,
     7  94,  1,  1,  2,  3,  4,  5,  6,  7,  4,  8,  8,  8,  8,  8,  8,
     8  16,  7,  1,  0, 15, 15,  0,  8,  7, 26, 29, 22, 12, 61, 78, 89,
     9  90, 81, 62,106,103,100,  1,  1,  2,  3,  4,  5,  6,  7,  8,  9,
     *  10, 11, 12, 13, 14,  4,  8,  8,  8,  8,  8,  8,  8, 16, 16, 16,
     1  16, 16, 16, 32,-13,  1,  0,  7,  6, 10, 28, 30,  8,  1, 68, 85,
     2  95,  1,  1,  2,  2,  3,  4,  5,  8, 16, 16, 16, 16, 32,  7,  1,
     3   0, 14,  9,  0,  8,  2,  4,  3, 61, 59, 78, 76, 89, 88, 12,106,
     4 103,100,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  6,  7,  8,
     5   2,  4,  4,  4,  8,  8,  8,  8, 16,  8,  1,  0, 10,  8,  0, 18,
     6  17,  8,  5, 12, 63, 80, 89, 87,100,  1,  1,  2,  2,  3,  4,  5,
     7   6,  6,  7,  4,  4,  8,  8,  8,  8,  8, 16, 10,  1,  0,  5,  6,
     8   0,  8, 12, 63, 82, 91,  1,  2,  3,  4,  5,  8,  8,  8,  8,  8,
     9  16, 11,  1,  0,  9,  8,  0,  8,  7, 12, 11, 91, 61, 81,106,104,
     *   1,  1,  2,  2,  3,  4,  5,  6,  7,  4,  4,  4,  8,  8,  8,  8,
     1  16,  0,  2,  1,  3,  3,  0, 89, 86, 87,  1,  1,  2,  1,  2,  4,
     2   0,  2,  0,  0,  1,  0,  4,  0,  2,  1,  3,  3,  0, 89, 86, 87,
     3   1,  1,  2,  2,  2,  4, 20,  2,  0,  0,  1,  0,  4/)
      ISETS(1663:1974) = (/
     1   0,  2,  1,  2,  3,  0, 89, 87,  1,  2,  2,  4,  8,  0,  5,  2,
     2   1,  2,  0, 89,  1,  4,  8,  0,  6,  1,  7,  4,  0,  8,  7,  4,
     3   1, 89, 86, 87,  1,  1,  1,  1,  2,  2,  3,  1,  2,  2,  4,  0,
     4   6,  1,  6,  3,  0,  8,  7, 16, 31, 89, 87,  1,  1,  1,  1,  2,
     5   2,  2,  4,  8,  0,  2,  0, 11,  6,  0,  8,  7,  4,  1,  6,  2,
     6  89, 86, 87,100, 99,  1,  1,  1,  1,  2,  2,  3,  3,  4,  5,  5,
     7   1,  2,  2,  4,  4,  8,  0,  2,  0, 10,  7,  0,  8,  4,  6,  2,
     8  18, 15, 89, 86, 87,100,  1,  1,  2,  2,  3,  3,  4,  4,  5,  6,
     9   2,  2,  2,  4,  4,  4,  8, 15,  5,  0,  6,  5,  4, 23, 32, 90,
     *   8,  7, 92,  1,  1,  2,  3,  3,  4,  2,  2,  4,  4,  8, 15,  5,
     1   0,  6,  5,  5, 12, 11,  8,  7, 96, 90,  1,  1,  2,  2,  3,  4,
     2   2,  4,  4,  4,  8,  0,  2,  0,  8,  8,  0,  8,  7,  6, 16, 89,
     3  12, 87,100,  1,  1,  2,  3,  4,  5,  6,  7,  2,  4,  4,  4,  8,
     4   8,  8, 16, 15,  4,  0,  5,  4,  9, 33, 34,  8,  7, 91,  1,  1,
     5   2,  2,  3,  4,  8,  8, 16,  0,  1,  1, 15,  7,  0,  8,  7,  4,
     6   1,  5,  3, 89, 86, 87, -1, -2, 61, 58, 60, 59,  1,  1,  1,  1,
     7   2,  2,  3,  3,  4,  5,  5,  6,  6,  6,  6,  1,  2,  2,  4,  4,
     8   4,  8,  0,  1,  1,  6,  5,  0,  8,  7, 87, 89, -1, -2,  1,  1,
     9   2,  3,  4,  4,  2,  2,  4,  4,  8,  0,  1,  0,  3,  3,  0, 78,
     *  77, -5,  1,  1,  2,  4,  4,  8/)
      ISETS(1975:2235) = (/
     1   0,  1,  0,  1,  2,  0, -1,  1,  4,  8,  0,  1,  1, 15,  8,  0,
     2   8,  4,  6,  2, 18, 15, 89, 86, 87, 61, 58, 60, 59, -3, -4,  1,
     3   1,  2,  2,  3,  3,  4,  4,  5,  6,  6,  6,  6,  7,  7,  2,  2,
     4   2,  4,  4,  4,  4,  8,  0,  1,  1,  6,  5,  0,  8,  7, 89, 87,
     5  -1, -2,  1,  1,  2,  3,  4,  4,  2,  4,  4,  4,  8, 20,  1,  0,
     6   3,  3,  0, 78, 77, -6,  1,  1,  2,  4,  4,  8, 20,  1,  0,  1,
     7   2,  0, -1,  1,  4,  8,  0,  1,  1, 10,  9,  0,  8,  7,  6, 16,
     8  89, 87, -1, 61, 60,-14,  1,  1,  2,  3,  4,  5,  6,  7,  7,  8,
     9   2,  4,  4,  4,  8,  8,  8,  8, 16,  0,  1,  4,  6,  5,  0,  8,
     *   7, 89, -1, -7, 69,  1,  1,  2,  3,  3,  4,  4,  8,  8,  8, 16,
     1   0,  1,  1,  6,  5,  0, 89, 86, 88,-36,103,102,  1,  1,  2,  3,
     2   4,  4,  1,  2,  4,  4,  8,  0,  1,  1,  3,  4,  0, 89, 88,-38,
     3   1,  2,  3,  2,  2,  4,  8,  0,  1,  1,  4,  4,  0, 89, 86, 87,
     4 -36,  1,  1,  2,  3,  2,  4,  4,  8,  0,  1,  1,  3,  4,  0, 89,
     5  87, 36,  1,  2,  3,  2,  4,  4,  8,  0,  1,  1,  3,  3,  0, 89,
     6  86, 87,  1,  1,  2,  2,  4,  8,  0,  1,  1,  2,  3,  0, 89, 87,
     7   1,  2,  2,  4,  8/)
      ISETS(2236:2537) = (/
     1   0,  1,  1,  5,  4,  0, 89, 86, 87,103,102,  1,  1,  2,  3,  3,
     2   2,  2,  4,  8,  0,  1,  1,  2,  3,  0, 89, 87,  1,  2,  4,  4,
     3   8,  0,  1,  1,  4,  5,  0, 89, 87,-36,103,  1,  2,  3,  4,  2,
     4   4,  8,  8, 16,  0,  1,  1,  3,  4,  0, 89, 88,-38,  1,  2,  3,
     5   4,  4,  8, 16,  0,  1,  2,  2,  3,  0, 89,106,  1,  2,  4,  8,
     6  16,  0,  1,  2,  1,  2,  0, 89,  1,  8, 16,  0,  1,  1, 14,  7,
     7   0,  8,  1,  7,  4,  5,  3, 89, 86, 61, 58, 60, 59, 87,-36,  1,
     8   1,  1,  1,  2,  2,  3,  3,  4,  4,  4,  4,  5,  6,  1,  2,  2,
     9   4,  4,  4,  8,  0,  1,  1, 13,  7,  0, 18, 17, 15, 16,  8,  4,
     *  63, 79, 65, 80, 89, 86, 87,  1,  2,  1,  2,  3,  3,  4,  4,  4,
     1   4,  5,  5,  6,  2,  2,  2,  4,  4,  4,  8,  0,  1,  1,  5,  5,
     2   0,  8,  7, 87, 89,-38,  1,  1,  2,  3,  4,  2,  2,  4,  4,  8,
     3   0,  1,  1,  4,  4,  0,  8,  7, 89, 87,  1,  1,  2,  3,  2,  4,
     4   4,  8,  0,  1,  1, 11,  6,  0,  8,  4,  1,  7, 89, 86, 87, -1,
     5  -2,103,102,  1,  1,  1,  1,  2,  2,  3,  4,  4,  5,  5,  1,  2,
     6   2,  4,  4,  8,  0,  1,  1,  9,  6,  0, 18, 15,  8,  4, -3, -4,
     7  89, 86, 87,  1,  1,  2,  2,  3,  3,  4,  4,  5,  2,  2,  4,  4,
     8   4,  8,  0,  1,  1,  8,  6,  0,  8,  7,  6,  2, 89, 87,-16,-15,
     9   1,  1,  2,  2,  3,  4,  5,  5,  2,  2,  4,  4,  4,  8/)
      ISETS(2538:2970) = (/
     1   0,  1,  1,  8,  6,  0,  8,  7, 16, 31, 89,-17,-14, 87,  1,  1,
     2   2,  2,  3,  4,  4,  5,  2,  2,  4,  4,  4,  8,  0,  1,  1,  9,
     3   5,  0,  8,  7, 16, 31, 89, 87, -1,-14,103,  1,  1,  1,  1,  2,
     4   2,  3,  3,  4,  2,  4,  8,  8, 16,  0,  1,  1,  8,  5,  0, 18,
     5   8, 16,  6, -3, 89, 87,-16,  1,  2,  2,  1,  3,  4,  4,  3,  4,
     6   4,  8,  8, 16,  0,  1,  1,  9,  8,  0,  8,  7,  6, 16, 89, 61,
     7  60, 87,-36,  1,  1,  2,  3,  4,  5,  5,  6,  7,  2,  4,  4,  4,
     8   8,  8,  8, 16,  0,  1,  4,  4,  4,  0,  8,  7, 89, 69,  1,  1,
     9   2,  3,  4,  8,  8, 16,  0,  1,  0, 20, 10,  0,  8,  7,  4,  1,
     *   2,  6, 89, 86, 87, -1, -2, 61, 60, 59, 58,100, 99,-36,103,102,
     1   1,  1,  1,  1,  2,  2,  3,  3,  4,  5,  5,  6,  6,  6,  6,  7,
     2   7,  8,  9,  9,  1,  2,  2,  4,  4,  4,  8,  8,  8, 16,  0,  1,
     3   0, 13, 10,  0, 18,  8, 15,  4,  6, 16, 89, 86, 87, -3, 63, 65,
     4 100,  1,  2,  1,  2,  3,  4,  5,  5,  6,  7,  8,  8,  9,  2,  2,
     5   4,  4,  4,  8,  8,  8,  8, 16, 15,  1,  0, 13,  9,  6, 22, 19,
     6  21, 20,  8,  7, 90, 96, -1, -2, 67, 66,-37,  1,  1,  2,  2,  3,
     7   3,  4,  5,  6,  6,  7,  7,  8,  2,  2,  4,  4,  4,  8,  8,  8,
     8  16, 15,  1,  0, 10,  9,  5, 12, 11, 35, 23, 90,  8, 92, -3, 62,
     9  70,  1,  1,  2,  3,  4,  5,  6,  7,  8,  8,  2,  4,  4,  4,  8,
     *   8,  8,  8, 16,  0,  1,  0, 11,  8,  0,  8,  7,  2,  6, 89, 87,
     1 -16,-15,100, 99,-38,  1,  1,  2,  2,  3,  4,  5,  5,  6,  6,  7,
     2   2,  2,  4,  4,  4,  8,  8, 16,  0,  1,  0,  8,  8,  0,  8,  7,
     3   6, 16, 89, 87,-14,100,  1,  1,  2,  3,  4,  5,  6,  7,  2,  4,
     4   4,  4,  8,  8,  8, 16, 15,  1,  0, 10,  8,  4, 21, 20, 90,  8,
     5   7, 96, -7, -8,107,-36,  1,  1,  2,  3,  3,  4,  5,  5,  6,  7,
     6   2,  2,  4,  4,  8,  8,  8, 16, 15,  1,  0,  6,  7,  4, 14, 21,
     7  90,  8, 96, -9,  1,  2,  3,  4,  5,  6,  4,  4,  4,  8,  8,  8,
     8  16/)
      ISETS(2971:3428) = (/
     1   0,  1,  0, 17, 10,  0,  8,  4,  6,  2, 18, 15, 89, 86, 87, 61,
     2  58, 60, 59, -3,106,105,100,  1,  1,  2,  2,  3,  3,  4,  4,  5,
     3   6,  6,  6,  6,  7,  8,  8,  9,  2,  2,  2,  4,  4,  4,  8,  8,
     4   8, 16,  0,  1,  0, 15, 11,  0,  8, 18,  4, 15, 16,  6, 89, 86,
     5  -1, -2, 87, 63, 65,100,-36,  1,  2,  1,  2,  3,  4,  5,  5,  6,
     6   6,  7,  8,  8,  9, 10,  2,  2,  4,  4,  4,  4,  8,  8,  8,  8,
     7  16, 15,  1,  0, 10, 10,  7, 22, 21, 12, 36,  8, 90, 96, 67, 66,
     8  -3,  1,  2,  3,  4,  5,  6,  7,  8,  8,  9,  4,  4,  4,  4,  8,
     9   8,  8,  8,  8, 16, 15,  1,  0, 13, 10,  7, 13, 14, 12, 22,  7,
     *   8, 96, 90, 64, 62, -1, -2,-37,  1,  1,  2,  3,  4,  4,  5,  6,
     1   7,  7,  8,  8,  9,  2,  4,  4,  4,  4,  8,  8,  8,  8, 16,  0,
     2   1,  0,  8,  9,  0,  8, 18,  6, 16, 89, 87,-14,100,  1,  2,  3,
     3   4,  5,  6,  7,  8,  4,  4,  4,  4,  8,  8,  8,  8, 16,  0,  1,
     4   0, 10,  9,  0,  8,  7,  6, 16, 89, -1, -7, 87,100,-36,  1,  1,
     5   2,  3,  4,  5,  5,  6,  7,  8,  2,  4,  4,  4,  4,  8,  8,  8,
     6  16, 15,  1,  0,  7,  7,  7, 36, 14, 96, 90,  8, -9,107,  1,  1,
     7   2,  3,  4,  5,  6,  2,  4,  4,  8,  8,  8, 16, 15,  1,  0,  9,
     8   8,  7, 21, 36,  7,  8, 90, 96, -8, -7,-36,  1,  2,  3,  3,  4,
     9   5,  6,  6,  7,  4,  4,  4,  4,  8,  8,  8, 16,  0,  1,  0, 14,
     *  13,  0,  8,  7,  6, 16, 89, 12, 87, -1, 61, 59,-14,100,-36,106,
     1   1,  1,  2,  3,  4,  5,  6,  7,  8,  8,  9, 10, 11, 12,  2,  4,
     2   4,  4,  8,  8,  8,  8, 16, 16, 16, 16, 32,  0,  1,  0, 12, 13,
     3   0, 18, 16,  8,  6, 12, 89, 87,-16, -3, 63,100,-38,  1,  2,  3,
     4   4,  5,  6,  7,  8,  9, 10, 11, 12,  4,  4,  4,  4,  8,  8,  8,
     5   8, 16, 16, 16, 16, 32, 15,  1,  0,  8,  7,  8, 37, 38,  8,  7,
     6  91, 61,-19,106,  1,  1,  2,  2,  3,  4,  5,  6,  4,  8,  8, 16,
     7  16, 16, 32, 15,  1,  0,  6,  7,  8, 38, 33,  8, 91, 63,-18,  1,
     8   2,  3,  4,  5,  6,  8,  8, 16, 16, 16, 16, 32,  0,  8,  1,  3,
     9   2,  0, 89, 97, 98,  1,  1,  1,  1,  3/)
      ISETS(3429:3635) = (/
     1   0,  8,  0,  0,  1,  0,  3, 20,  8,  0,  0,  1,  0,  3, 16,  5,
     2   1,  1,  2,  0, 89,  1,  3,  9,  0,  8,  0,  6,  5,  0,  8,  7,
     3  89, 97,  5,  3,  1,  1,  2,  3,  4,  4,  1,  2,  2,  3,  6, 16,
     4   5,  0,  5,  4,  0,  8,  7, 89,  3,  5,  1,  1,  2,  3,  3,  3,
     5   6,  9, 18,  0,  3,  1, 11,  4,  0,  8,  7, 39, 40, 41, 42, 89,
     6  97, 98, -7, -8,  1,  1,  1,  1,  1,  1,  2,  2,  2,  3,  3,  1,
     7   2,  3,  6,  0,  3,  1,  6,  5,  0,  8,  7, 89, 97, 61, 60,  1,
     8   1,  2,  3,  4,  4,  1,  2,  2,  3,  6,  0,  3,  0,  2,  2,  0,
     9 -10,-13,  1,  1,  3,  6,  0,  3,  0,  2,  2,  0, 71, 72,  1,  1,
     *   3,  6, 20,  3,  0,  2,  2,  0,-11,-12,  1,  1,  3,  6, 20,  3,
     1   0,  2,  2,  0, 74, 73,  1,  1,  3,  6, 16,  1,  1,  5,  4,  0,
     2   8,  7, 89, 61, 60,  1,  1,  2,  3,  3,  3,  6,  9, 18,  0,  3,
     3   1,  4,  3,  0, 89, 97, 98,-37,  1,  1,  1,  2,  1,  3,  6/)
      ISETS(3636:3896) = (/
     1   0,  3,  1,  3,  4,  0, 89, 97,103,  1,  2,  3,  1,  2,  3,  6,
     2   0,  3,  1,  3,  2,  0, 89, 97, 98,  1,  1,  1,  2,  6,  0,  3,
     3   1,  2,  3,  0, 89, 97,  1,  2,  2,  2,  6, 16,  1,  1,  2,  3,
     4   0, 89,-37,  1,  2,  3,  9, 18, 16,  1,  1,  1,  2,  0, 89,  1,
     5   6, 18,  0,  3,  0, 11,  8,  0,  8,  7, 39, 40, 89,  5,  3, 97,
     6  -7, -8,103,  1,  1,  2,  2,  3,  4,  4,  5,  6,  6,  7,  1,  2,
     7   2,  3,  4,  6,  6, 12,  0,  3,  0,  8,  8,  0, 18,  8, 43, 44,
     8  89, 97,  5, -9,  1,  2,  3,  3,  4,  5,  6,  7,  2,  2,  2,  4,
     9   4,  6,  6, 12,  0,  3,  0,  9,  7,  0,  8,  7, 89, 97,  5,  3,
     *  61, 60,-37,  1,  1,  2,  3,  4,  4,  5,  5,  6,  1,  2,  2,  3,
     1   6,  6, 12,  0,  3,  0,  6,  7,  0, 18,  8, 89, 97,  5, 63,  1,
     2   2,  3,  4,  5,  6,  2,  2,  4,  4,  6,  6, 12, 16,  1,  0,  8,
     3   6,  0,  8,  7, 89,  3,  5, 61, 60,-37,  1,  1,  2,  3,  3,  4,
     4   4,  5,  3,  6,  9, 18, 18, 36, 16,  1,  0,  5,  6,  0, 18,  8,
     5  89,  5, 63,  1,  2,  3,  4,  5,  6,  6, 12, 18, 18, 36,  0,  5,
     6   1,  3,  4,  0, 89, 97, 88,  1,  2,  3,  1,  2,  3,  6,  0,  5,
     7   0,  0,  1,  0,  6/)
      ISETS(3897:4203) = (/
     1  20,  5,  0,  0,  1,  0,  6,  0,  5,  0,  2,  3,  0, 89, 86,  1,
     2   2,  3,  3,  6, 20,  5,  0,  2,  3,  0, 89, 86,  1,  2,  3,  3,
     3   6,  0,  5,  1,  2,  3,  0, 89, 97,  1,  2,  2,  2,  6,  0,  6,
     4   1, 11,  4,  0,  8,  7, 39, 40, 41, 42, 89, 97, 98,100, 99,  1,
     5   1,  1,  1,  1,  1,  2,  2,  2,  3,  3,  1,  2,  3,  6,  0,  5,
     6   0, 11,  8,  0,  8,  7, 39, 40, 89,  5,  3, 97, 88,100, 99,  1,
     7   1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  1,  2,  2,  3,  4,  6,
     8   6, 12,  0,  5,  0,  8,  8,  0, 18,  8, 43, 44, 89, 97,  5,101,
     9   1,  2,  3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,  6,  6, 12,
     *   0,  1,  1, 13,  9,  0,  8,  7, 39, 40, 89,  5,  3, 97, 88, 61,
     1  60, -7, -8,  1,  1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  8,  8,
     2   1,  2,  2,  3,  4,  6,  6,  6, 12,  0,  1,  0,  2,  3,  0, 61,
     3 -22,  1,  2,  6,  6, 12, 20,  1,  0,  2,  3,  0, 61,-23,  1,  2,
     4   6,  6, 12,  0,  1,  0, 10,  7,  0,  8,  7,  5,  3, 89, 88, 61,
     5  60,-20,-21,  1,  1,  2,  2,  3,  4,  5,  5,  6,  6,  3,  3,  6,
     6   6,  6,  6, 12, 20,  1,  0, 10,  7,  0,  8,  7,  5,  3, 89, 88,
     7  61, 60,-20,-21,  1,  1,  2,  2,  3,  4,  5,  5,  6,  6,  3,  3,
     8   6,  6,  6,  6, 12,  0,  1,  1,  8,  8,  0,  8, 18, 43, 45, 89,
     9  97, 61,-22,  1,  2,  3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,
     *   6,  6, 12/)
      ISETS(4204:4617) = (/
     1   0,  1,  1,  5,  6,  0, 89, 97, 88,103,-37,  1,  2,  3,  4,  5,
     2   1,  2,  3,  6,  6, 12,  0,  1,  1,  3,  4,  0, 89, 97, 88,  1,
     3   2,  3,  2,  4,  6, 12,  0,  1,  1,  3,  4,  0, 89, 97,103,  1,
     4   2,  3,  2,  4,  6, 12,  0,  1,  1,  3,  4,  0, 89, 97,-37,  1,
     5   2,  3,  2,  2,  6, 12,  0,  1,  1, 14,  6,  0,  8,  7, 39, 40,
     6  41, 42, 89, 97, 98, -7, -8,100, 99,-37,  1,  1,  1,  1,  1,  1,
     7   2,  2,  2,  3,  3,  4,  4,  5,  1,  2,  3,  6,  6, 12,  0,  1,
     8   1, 11,  6,  0,  8, 18, 39, 43, 41, 44, 89, 97, 98, -7,101,  1,
     9   2,  1,  2,  1,  2,  3,  3,  3,  4,  5,  2,  2,  4,  6,  6, 12,
     *   0,  1,  1, 11,  8,  0,  8,  7, 39, 40, 89, 61, 60, 97,103,100,
     1  99,  1,  1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  1,  2,  2,  3,
     2   4,  6,  6, 12,  0,  1,  1,  8,  8,  0,  8, 18, 43, 44, 89, 97,
     3  61,101,  1,  2,  3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,  6,
     4   6, 12,  0,  1,  0, 17, 12,  0,  8,  7, 39, 40, 89,  5,  3, 97,
     5  88, 61, 60,-20,-21,103,-39,100, 99,  1,  1,  2,  2,  3,  4,  4,
     6   5,  6,  7,  7,  8,  8,  9, 10, 11, 11,  1,  2,  2,  3,  4,  6,
     7   6,  6, 12, 12, 12, 24,  0,  1,  0, 12, 13,  0, 18,  8, 43, 39,
     8  89, 17,  5, 97, 88, 63,-22,100,  1,  2,  3,  4,  5,  6,  7,  8,
     9   9, 10, 11, 12,  2,  2,  4,  4,  4,  6,  6,  8, 12, 12, 12, 12,
     *  24,  0,  1,  0, 11, 12,  0, 18,  8, 43, 39, 89,  5, 63, 97,-20,
     1 101,103,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11,  2,  2,  4,
     2   4,  4,  6,  6,  8, 12, 12, 12, 24,  0,  1,  0, 11, 11,  0,  8,
     3  18, 43, 45, 89, 97,  5,-22, 61,101,-39,  1,  2,  3,  3,  4,  5,
     4   6,  7,  8,  9, 10,  2,  2,  2,  4,  4,  6,  6, 12, 12, 12, 24,
     5   0,  5,  1,  9,  6,  0,  8,  1,  2,  5,-35, 61, 60, 59, 58,  1,
     6   1,  2,  2,  3,  4,  5,  5,  4,  1,  3,  4,  6,  6, 12/)
      ISETS(4618:4934) = (/
     1   0,  5,  1,  7,  4,  0,  8,  1, 12, 46,-35, 61, 62,  1,  1,  1,
     2   1,  2,  3,  3,  4, 16, 24, 48,  0,  5,  1,  5,  6,  0,  8,  2,
     3 -35, 61, 59,  1,  2,  3,  4,  5,  2,  6,  8, 12, 12, 24,  0,  7,
     4   1,  1,  2,  0,-35,  1,  4, 12,  0,  7,  1,  2,  3,  0,-35, 63,
     5   1,  2,  8, 12, 24,  0,  5,  0, 11,  7,  0,  8,  1,  2,  5, 61,
     6  60, 59, 58,-35,106,105,  1,  1,  2,  2,  3,  4,  4,  3,  5,  6,
     7   6,  1,  3,  6,  6,  8, 12, 24, 15,  6,  0,  7,  7,  5, 12,  8,
     8   1, 35,-35, 62, 70,  1,  2,  2,  3,  4,  5,  6,  2,  4,  6,  8,
     9  12, 12, 24,  0,  5,  0,  8,  8,  0,  8,  1, 12, 26, 61,-35, 62,
     * 106,  1,  1,  2,  3,  4,  5,  6,  7,  4,  8, 24, 24, 32, 48, 48,
     1  96, 15,  6,  0,  6,  5, 10, 28, 47,  8,  1,-35, 68,  1,  1,  2,
     2   2,  3,  4,  8, 16, 32, 48, 96,  0,  5,  0,  7,  8,  0,  8,  2,
     3  12, 61, 60,-35,106,  1,  2,  3,  4,  5,  6,  7,  2,  6,  8, 12,
     4  12, 16, 24, 48,  0,  1,  0,  3,  3,  0,  8,  1,-35,  1,  1,  2,
     5   4,  8, 24,  0,  7,  0,  4,  4,  0,  8, 12,-35, 63,  1,  1,  2,
     6   3,  8, 16, 24, 48,  0,  1,  1, 10,  7,  0,  8,  1,  2,  5, 61,
     7  58,-35, 59,-24,-25,  1,  1,  2,  2,  3,  3,  4,  5,  6,  6,  1,
     8   3,  6,  8, 12, 12,  24, 0,  1,  1, 12,  9,  0,  8, 12, 46,  2,
     9  25, 48,-35, 61, 60, 59,-30,-29,  1,  2,  2,  3,  4,  4,  5,  6,
     *   7,  7,  8,  8,  2,  4,  6,  6,  8, 12, 12, 12, 24/)
      ISETS(4935:5289) = (/
     1   0,  1,  1,  9,  8,  0,  8,  1, 12, 26, 61,-35,-24,-25, 62,  1,
     2   1,  2,  3,  4,  5,  6,  6,  7,  4,  8, 24, 24, 32, 48, 48, 96,
     3   0,  1,  3,  7,  6,  0,  8,  1, 28, 47,-35, 61,-34,  1,  1,  2,
     4   2,  3,  4,  5,  8, 16, 32, 48, 48, 96,  0,  1,  1,  9, 10,  0,
     5   8,  2, 12, 48, 61,-35, 59,-24,-30,  1,  2,  3,  4,  5,  6,  7,
     6   8,  9,  2,  6,  8, 12, 12, 16, 24, 24, 24, 48, 20,  1,  0,  4,
     7   4,  0, 28, 47,-35,-34,  1,  1,  2,  3,  4,  8, 12, 24,  0,  1,
     8   0,  4,  4,  0, 49, 50,-35,-33,  1,  1,  2,  3,  4,  8, 12, 24,
     9   0,  1,  1,  8,  6,  0, 28, 50, 51, 52,-35, 63,-33,-34,  1,  1,
     *   2,  2,  3,  4,  5,  5,  8, 12, 16, 24, 24, 48,  0,  1,  1,  9,
     1   7,  0,  8,  1,  2,  5,-35, 61, 58, 59,-36,  1,  1,  2,  2,  3,
     2   4,  4,  5,  6,  1,  3,  4,  6, 12, 12, 24,  0,  1,  1,  8,  5,
     3   0,  8,  1, 12, 46,-35, 61, 62,-36,  1,  1,  1,  1,  2,  3,  3,
     4   4,  4, 16, 24, 48, 96,  0,  1,  1,  7,  8,  0,  8,  2,-35, 48,
     5  61, 59,-36,  1,  2,  3,  4,  5,  6,  7,  2,  6,  8, 12, 12, 24,
     6  24, 48,  0,  1,  1,  8,  7,  0,  8,  2, 48, 25,-35, 61, 59, 60,
     7   1,  2,  3,  3,  4,  5,  6,  6,  2,  6,  6,  8, 12, 12, 24,  0,
     8   1,  1,  7,  5,  0,  8, 12, 26, 24,-35, 61, 62,  1,  1,  2,  2,
     9   3,  4,  4,  8, 24, 32, 48, 96,  0,  1,  1,  4,  4,  0, 53, 54,
     * -35, 63,  1,  1,  2,  3, 12, 16, 24, 48,  0,  1,  0, 13,  9,  0,
     1   8,  1,  2,  5, 61, 58,-35, 59,-24,-25,106,105,-36,  1,  1,  2,
     2   2,  3,  3,  4,  5,  6,  6,  7,  7,  8,  1,  3,  6,  8, 12, 12,
     3  24, 24, 48/)
      ISETS(5290:5593) = (/
     1  15,  1,  0,  8,  9,  5, 12, 14,  8, 55, 62,-35, 70,-26,  1,  2,
     2   3,  4,  5,  6,  7,  8,  2,  6,  8, 12, 12, 16, 24, 24, 48,  0,
     3   1,  0, 11, 10,  0,  8,  2, 25, 48, 12, 61, 60, 59,-35,-29,106,
     4   1,  2,  3,  3,  4,  5,  6,  6,  7,  8,  9,  2,  6,  6,  8, 12,
     5  12, 16, 24, 24, 48, 15,  1,  0, 11, 10,  5, 12,  8,  1, 35,-35,
     6  56, 62, 64,-32,-31,-36,  1,  2,  2,  3,  4,  5,  6,  7,  8,  8,
     7   9,  2,  4,  6,  8, 12, 12, 24, 24, 24, 48,  0,  1,  0, 11, 10,
     8   0,  8,  1, 12, 26, 61,-35, 62,-24,-25,106,-36,  1,  1,  2,  3,
     9   4,  5,  6,  7,  7,  8,  9,  4,  8, 24, 24, 32, 48, 48, 96, 96,
     * 192,  0,  1,  0,  9, 10,  0, 12,  8, 24, 26, 61, 62,-35,-26,106,
     1   1,  2,  3,  4,  5,  6,  7,  8,  9,  8,  8, 24, 24, 48, 48, 64,
     2  96, 96,192, 15,  1,  0,  8,  7, 10, 28, 49,  8,  1,-35, 68,-36,
     3 -27,  1,  1,  2,  2,  3,  4,  5,  6,  8, 16, 32, 48, 96, 96,192,
     4  15,  1,  0,  7,  8, 11, 28, 12,  8, 57,-35, 68,-28,  1,  2,  3,
     5   4,  5,  6,  7, 16, 32, 32, 48, 64, 96, 96,192,  0,  1,  0, 11,
     6  12,  0,  8,  2, 12, 25, 61,-35, 60,-24,-30,106,-36,  1,  2,  3,
     7   4,  5,  6,  7,  8,  9, 10, 11,  2,  6,  8, 12, 12, 16, 24, 24,
     8  48, 48, 48, 96,  0,  1,  0,  7,  8,  0,  8, 28, 51, 53,-35, 63,
     9 -34,  1,  2,  3,  4,  5,  6,  7, 16, 16, 24, 24, 32, 48, 48, 96/)
 
      NNT1(1:249) = (/
     1   656,    96, 12351,  8266, 20521,   286,  8456, 20711,   381,
     2 12636, 20806,   476,  8646, 12731,     0,   572,     0,  4657,
     3     0, 12827,     0, 20997,     0,   573,     0,  4658,     0,
     4 20998,     0,   574,     0, 12829,     0, 20999,     0,   575,
     5     0,  4660,     0, 12830,   586,  4671,  8756, 21011,   596,
     6  4681, 21021,   603,  8773, 21028,   619,  4704,  8789,   666,
     7 12921,  8836, 21091,   761,     0,   576,     0,  4661,     0,
     8 12831,     0, 21001,     0,   577,   634,  4719,  8804, 21059,
     9   644,   682,  4767,  8852, 12937, 21107, 17022,   699,  8869,
     * 21124, 12954,   787,  4872,   685,  8855, 12940, 21110,   701,
     1  8871, 12956, 21126,   789,   795,   812,   797,   778,  4863,
     2   693,  4778,   695,   716,   718,   781,   810, 17065,   117,
     3  4202,  8287, 12372, 20542, 16457,   402, 12657, 20827,  4487,
     4   134,  8304,   126, 12381,  4211, 20551,   411, 20836, 12666,
     5  4496,   317,   419,   507,   435,   308,  8478,   323,  8493,
     6   339,   513,   529,   150,   498, 18206,   160,  4245,  8330,
     7 12415, 20585, 16500,   161,  4246, 20586,  8331,   172, 12427,
     8   350,  4435,  8520, 20775,   351, 20776,  4436,  8521,   362,
     9   456,   363,   551,   455, 12710,   448, 12703,   543,   449,
     *   544,   550,   173, 18215,   736,  4821,  8906, 12991, 21161,
     1 17076,   744, 12999,   831,  4916,   737,  8907,   832,   839,
     2   745,   840, 21265,  1986, 22411,  2081, 22506,  2176,  2271,
     3  2366, 22601,  2012, 22437,  2014,  2205,  2206,  2038, 22440,
     4  2039,  2226,  2227, 22573, 22574,  1922, 22347,  1945,  1923,
     5  1946, 22386,  1965, 22390,  1968, 22393,  1967,  1969,  2066,
     6 22491,  2067,  2161,  2162,  2256,  2257,  2351,  2352, 22586,
     7  3031, 27541,  3221,  3316,  2947, 27536,  2949, 27537,  2961,
     8  2985,  2951, 27538,  3141,  3236,  3009/)
       NNT1(250:500) = (/
     1  3199,  3294,  3411,  3506,  3601,  3981,  3696,  3886,  3791,
     2  3437,  3463,  3725,  3746,  3390,  3393,  3347,  3370,  3491,
     3  3586,  3966,  3681,  3871,  3776,   749, 17089, 21174,   844,
     4 21269,  1924, 18264, 22349,  1956, 18287, 22387,  2068, 22493,
     5 18408,  2163,  2258,  2353, 22588, 18503,  3126,   856,  9026,
     6 13111, 21281,  1236,  9406, 21661,  1426, 13681, 21851,  1616,
     7  9786, 13871,   951,  1331,  1521,  1711,     0,   578,     0,
     8  4663,     0, 12833,     0, 21003,     0,   579,     0,  4664,
     9     0, 21004,     0,   580,     0, 12835,     0, 21005,     0,
     *   581,     0,  4666,     0, 12836,     0,   582,     0,   583,
     1     0,   584,     0,   585,   657,  4742,  8827, 21082,   658,
     2  4743, 21083,   659,  8829, 21084,   660,  4745,  8830,   661,
     3   662,   663,   664,   112,  4197,  8282, 12367, 20537, 16452,
     4   129, 20547,  8299,   115, 20538, 12370,   125, 12379,   146,
     5   123, 20556, 12377,  8283,  4208,   131,  8300,   148,   122,
     6 20554,  4207,   113, 20540,  4198,   124,   130,   145,   116,
     7   132,   147,   319, 20832,  4387, 12384,  8489,   302, 20822,
     8  8472,   338,   313,  4398,   321,  8491,   305,   315,   336,
     9   400, 20728,  8285,  4482, 12655,   397, 20727, 12652,   433,
     *   416, 12671,   408,  4493,   414,   431,   410,   415,   401,
     1   409, 12664,   407,  4397,   432,   398,   417,   430,   528,
     2   505,   526,   509, 12669,   495,  8475,   503,   492,   511,
     3   335,   320,  8490,   303,  4483,   322,   312,   337,   314,
     4 20739,   306,   512,   527,   496,   525,   504,   510,   502,
     5   493, 18205,  2936, 27446,  2461, 22886,  2556,  2746,  2841,
     6 23076,  2392, 22817,  2418, 22820,  2679,  2704,  2394,  2419,
     7  2677,  2703,  2511,  2490,  2797,  2776,  2512,  2491,  2796,
     8  2775, 23048, 23049,  2852, 27441,  2854, 27442,  2866/)
      NNT1(501:1000) = (/
     1  2890,  4007,  4033,  4105,  4126,  4076,  4171,   119,   120,
     2 20544, 20545, 16459, 16460,   531,   532,   151,   152, 16482,
     3 16483,   499,   500, 18169, 18170, 18192, 18193, 20677, 20678,
     4   179,   180, 20604, 20605, 16519, 16520,   559,   560,   274,
     5   275, 20699, 20700, 18229, 18230,     0,     0,     0,     0,
     6     0,     2,     2,     2,     3,     3,     3,     4,     4,
     7     4,     0,     0,     0,     0,     0,     0,     0,     0,
     8     1,     1,     1,     1,     1,     1,     3,     3,     3,
     9     3,     3,     3,     5,     5,     5,     5,     5,     5,
     *     0,     0,     0,     0,     1,     1,     1,     2,     2,
     1     2,     6,     6,     6,     0,     0,     0,     0,     1,
     2     0,     0,     0,     0,     0,     0,     0,     0,     2,
     3     2,     0,     0,     0,     0,     3,     0,     0,     0,
     4     0,     0,     0,    62,    62,    62,    62,    30,    30,
     5    93,    93,    93,    93,   124,   124,   124,   124,   153,
     6    66,   214,   127,     1,     1,    31,    31,   155,   186,
     7   217,     5,   180,   341,     0,     0,     0,     0,     0,
     8     0,    93,    93,    93,    93,    60,    60,    31,    31,
     9    31,    31,   155,   155,   155,   155,    36,   123,   157,
     *   215,     2,     2,    62,    62,   186,   124,   217,   180,
     1     4,   341,     0,     0,     0,     0,     0,     0,    31,
     2    31,    31,    31,    90,    90,    62,    62,    62,    62,
     3   186,   186,   186,   186,   122,    35,   216,   187,     3,
     4     3,    93,    93,   124,   155,   217,     4,   150,   341,
     5     0,     0,     0,     0,     0,     0,    90,    90,     1,
     6     1,    62,    62,   186,     5,   120,   126,   126,     0,
     7     0,     0,     0,    14,     3,    18,    16,     0,     0,
     8   186,     3,     7,    93,    93,   217,    90,   216,   480,
     9   606,     0,     0,    93,   186,   217,   496,     0,     0,
     *    93,    93,   186,   217,     0,     0,     6,   423,   111,
     1    90,     7,   543,   112,    16,     0,     0,    15,    17,
     2     0,     0,    90,    90,     0,    90,     0,     0,    15,
     3    17,     0,    15,    17,     0,     0,    13,    19,    15,
     4    17,     3,     0,    93,     3,    90,     0,     3,     0,
     5    90,     0,    19,    13,    17,    15,     3,     0,     0,
     6     0,     5,     5,     0,     0,     0,   210,   210,   360,
     7     0,     0,     0,   360,   210,   690,   690,   690,     0,
     8     0,     0,     0,     0,    62,    62,    62,    93,    93,
     9    93,   124,   124,   124,    31,   186,   155,   217,     0,
     *     0,     0,     0,     0,     0,     0,     0,    31,    31,
     1    31,    31,    31,    31,    93,    93,    93,    93,    93,
     2    93,   155,   155,   155,   155,   155,   155,    62,    62,
     3   186,   186,   124,   124,   217,   217,     0,     0,     0,
     4     0,    31,    31,    31,    62,    62,    62,   186,   186,
     5   186,    93,   155,   124,   217,     0,     0,     0,     0,
     6     0,     0,  1860,  1860,  1860,  2790,  2790,  2790,  4650,
     7  4650,  5580,   930,   930,   930,   930,   930,  3720,  3720,
     8  6510,   901,   901,   901,    31,    31,    31,  4591,  1981,
     9  5461,  2851,  3811,  6421,  1802,  1802,  1802,  1802,  1802,
     *    62,    62,    62,  6452,  1082,  1082,  3692,  3692,  2822,
     1  4712,  5432,    93,    93,    93,    93,    93,  2703,  2703,
     2  2703,  5613,  1923,  1923,  4533,  4533,  3663,  6483,  1053,
     3  3785,   155,   995,   995,  4505,  4505,  5525,  2735,  2015,
     4  6365,  5554,  1114,  6334,  3604,  3604,   124,   124,  4684,
     5  2764,  1894,  5406,  1836,  1836,   186,   186,  3756,   966,
     6  6396,  4626,  4626,  2916,  1957/)
      NNT1(1001:1623) = (/
     1  5497,   217,  6307,  1027,  3637,  4567,  2887,  9278,     0,
     2     0,     0,     0,     3,   181,   184,   162,     0,     0,
     3  2790,  2790,  5466,  6426,  5580,  6510,    36,  2856,  2700,
     4    90,  6366,  5526,  6480,   210,  2736,   156, 21602,  9992,
     5     0,     0,    90,    90,     0,    90,     0,  2790,    93,
     6  2703,     0,    93,     0,     0,     0,     0,     0,     0,
     7  6306,  6306,  6300,  6300,  6300,  6300,     6,     6,    10,
     8    10,  6310,  6310,  9902,  9902,     0,     0,     0,     0,
     9     0,     0,     6,     6,     5,     5,     5,     5,    10,
     *    10,     1,     2,     2,     2,     2,     2,     2,     2,
     1     2,     2,     2,     2,     2,     2,     3,     3,     3,
     2     3,     3,     3,     3,     3,     3,     3,     3,     3,
     3     3,     3,     3,     3,     3,     3,     3,     3,     3,
     4     3,     3,     3,     3,     3,     4,     4,     4,     4,
     5     4,     4,     4,     4,     4,     4,     4,     4,     4,
     6     5,     5,     5,     5,     5,     6,     6,     6,     6,
     7     6,     6,     6,     6,     6,     6,     7,     7,     7,
     8     7,     7,     5,     5,     5,     5,     5,     5,     5,
     9     5,     5,     5,     5,     5,     5,     5,     5,     5,
     *     5,     5,     5,     5,     5,     5,     5,     5,     5,
     1     5,     5,     5,     5,     5,     5,     5,     5,     5,
     2     6,     6,     6,     6,     6,     6,     6,     6,     6,
     3     6,     6,     6,     6,     6,     6,     6,     6,     6,
     4     6,     6,     6,     6,     6,     6,     6,     6,     6,
     5     6,     6,     6,     6,     6,     6,     6,     7,     7,
     6     7,     7,     7,     7,     7,     7,     7,     7,     7,
     7     7,     7,     7,     7,     7,     7,     7,     7,     7,
     8     7,     7,     7,     7,     7,     7,     7,     7,     7,
     9     7,     7,     7,     7,     7,     8,     8,     8,     8,
     *     8,    17,     8,     8,     8,     8,     8,     8,     8,
     1     8,     8,     8,     8,    10,    18,     9,     9,     9,
     2     9,     9,     9,     9,     9,     9,     9,     9,     9,
     3     9,     9,     9,     9,     9,     9,    10,    10,    10,
     4    10,    10,    10,    10,    18,    10,    18,    10,    10,
     5    10,    10,    10,    10,    10,    10,    10,    10,    10,
     6    10,    15,    15,    15,    15,    15,    15,    15,    15,
     7    13,    13,    11,    14,    11,    11,    16,    16,    16,
     8    16,    13,    13,    13,    13,    13,    13,    13,    13,
     9    13,    13,    16,    16,    11,    11,    11,    11,    11,
     *    11,    11,    11,    12,    17,    12,    12,    12,    12,
     1    17,    12,    12,    17,    12,    12,    12,     8,    12,
     2    12,    12,    12,     8,     8,     8,     8,     8,     8,
     3     8,     8,     8,     8,     8,     8,     8,     8,     8,
     4     8,     8,     8,     8,     8,     8,     8,     8,     8,
     5     8,     8,     8,     8,     8,     8,     8,     8,     8,
     6     8,     8,     8,     8,     8,     8,     8,     8,     8,
     7     8,     8,     8,     8,     8,     8,     8,     8,     8,
     8     8,     8,     8,     8,     8,     8,     8,     8,     8,
     9     8,     8,     8,     8,     8,     8,     8,     8,     8,
     *     8,     8,     8,     8,     8,     8,     8,     8,     8,
     1     8,     8,     8,     8,     8,     8,     8,     8,     8,
     2     8,     8,     8,     8,     8,     8,     8,     8,     8,
     3     8,     8,     8,     8,     8,     8,     8,     8,     8,
     4     8,     8,     8,     8,     8,     8,     8,     8,     8,
     5     8,     8,     8,     8,     8,     8,     8,     8,     8,
     6     8,     8,     8,     8,     8,     8,     8,     8,     8,
     7     8,     8,     8,     8,     8,     8,     8,     8,     8,
     8     8,     8,     8,     8,     8,     8,     8,     8,     8,
     9     8,     8,     8,     8,     8,     8,     8,     8,     8,
     *     8,     8,     8,     8,     8,     8,     8,     8,     8,
     1     8,     8,     8,     8,     8,     8,     8,     8,     8,
     2    11,    14,    10,    10,    10,    10,    10,    10,    10,
     3    10,    10,    10,    10,    10,    10,    10,    10,    10,
     4    10,    10,    10,    10,    10,    10,    10,    10,    10,
     5    10,    11,    14,    11,    14,    11,    11,    11,    11,
     6    11,    11,    11,    11,    12,    12,    12,    12,     8,
     7     8,    12,    12,    12,    12,     8,     8,    12,    12,
     8     8,     8,     8,     8,    12,    12,    12,    12,    12,
     9    12,     8,     8,    12,    12,    12,    12,    12,    12,
     *     8,     8/)
      RETURN
      END SUBROUTINE PLA327
 
      SUBROUTINE PLA330
C * APPLY HKL-FILE TRANSFORMATION (AND DIRECTION COSINES)
      USE files
      USE parameters
      USE plato
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: N
      INTEGER               :: N1
      INTEGER               :: N2
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: IHT
      INTEGER               :: IKT
      INTEGER               :: ILT
      REAL                  :: DET
      REAL                  :: XLNG
      REAL                  :: GEN050
      REAL, DIMENSION(3, 3) :: YUNK
      CHARACTER(len=20)     :: CH
      OPEN (UNIT = LU61, FILE = NAMEFIL(1:KNMFIL)//'_trans.hkl',
     1    STATUS = 'UNKNOWN')
C * HKL + DIRECTION COSINE TRANSFORMATION
      CALL GEN003 (QQ, DUMV, DET, 0)
      IF (ABS (DET) < 0.01) THEN
        IPR(2) = 73
        RETURN
      END IF
      IHT = 0
      IKT = 0
      ILT = 0
C * TRANSPOSE MATRIX
      CALL GEN005 (QQ, YUNK)
C * COPY MATRIX
      CALL GEN052 (YUNK, QQ)
      WRITE (LU6, 99996, IOSTAT = IOST) DET
      WRITE (LU6, 99997, IOSTAT = IOST)
     1  ((DUMV(I, J), J = 1, 3), I = 1, 3)
      WRITE (LU6, 99995, IOSTAT = IOST)
      WRITE (LU6, 99997, IOSTAT = IOST) ((QQ(I, J), J = 1, 3), I = 1, 3)
C * ZERO ARRAYS
      CALL GEN074 (PAC,  1, 9, 0.0)
      CALL GEN074 (UIJC, 1, 9, 0.0)
      PAC(1, 1)  = PAR(135)
      PAC(2, 2)  = PAR(136)
      PAC(3, 3)  = PAR(137)
      UIJC(1, 1) = 1.0 / PAR(113)
      UIJC(2, 2) = 1.0 / PAR(114)
      UIJC(3, 3) = 1.0 / PAR(115)
      CALL GEN132 (UIJC, QQ, PAC, PAT)
      WRITE (LU6, 99994, IOSTAT = IOST)
      WRITE (LU6, 99997, IOSTAT = IOST)
     1  ((PAT(I, J), J = 1, 3), I = 1, 3)
      IF (IGBL(37) == 0) WRITE (LU6, 99992, IOSTAT = IOST)
      N = 0
C * CHECK FOR XML AFTER DUMMY REFLECTION
      DO
        READ (LU16, 99999, IOSTAT = IOST) IH, IK, IL, CH,
     1     (V1(K), V2(K), K = 1, 3)
        IF (IOST /= 0) GO TO 10
        IF (IH == 0 .AND. IK == 0 .AND. IL == 0) THEN
          WRITE (LU61, 99990, IOSTAT = IOST)
          READ (LU16, 99998, IOSTAT = IOST) PRBUF
          IF (IOST == -1) GO TO 10
          IF (INDEX (PRBUF, '<?') /= 0) GO TO 10
          BACKSPACE LU16
          CYCLE
        END IF
        IF (GEN050 (DUMV, IH, IK, IL, IHT, IKT, ILT) > 0.0) THEN
          N = N + 1
          IF (IGBL(37) == 1) THEN
            CALL GEN002 (1, PAT,  V1, V4, XLNG)
            CALL GEN002 (1, PAT,  V2, V5, XLNG)
            WRITE (LU61, 99999, IOSTAT = IOST) IHT, IKT, ILT, CH,
     1          (V4(K), V5(K), K = 1, 3)
          ELSE
            WRITE (LU61, 99999, IOSTAT = IOST) IHT, IKT, ILT, CH
          END IF
        END IF
      END DO
   10 WRITE (LU61, 99990, IOSTAT = IOST)
      WRITE (LU6,  99991, IOSTAT = IOST) N
      CLOSE (UNIT = LU61)
C * COPY, ADAPT INS FILE
      OPEN (UNIT = LU61, FILE = NAMEFIL(1:KNMFIL)//'_trans.ins',
     1    STATUS = 'UNKNOWN')
      REWIND (UNIT = LU1, IOSTAT = IOST)
      DO
        READ (LU1, 99998, IOSTAT = IOST) PRBUF
        IF (IOST == -1) GO TO 20
        IF (PRBUF(1:4) == 'HKLF') THEN
          READ (PRBUF(5:10), *) N1
          WRITE (PRBUF, 99993) N1
        ELSE IF (PRBUF(1:4) == 'HKLT') THEN
          CYCLE
        END IF
        N2 = LEN_TRIM (PRBUF)
        WRITE (LU61, 99998) PRBUF(1:N2)
      END DO
   20 CLOSE (UNIT = LU61)
      RETURN
99999 FORMAT (3I4,  A, 6F8.5)
99998 FORMAT (A)
99997 FORMAT (3F10.4)
99996 FORMAT (/, 'Direct Cell axes and HKL Transformation Matrix',
     1           ' (Determinant = ', F5.2, /)
99995 FORMAT (/, 'Coordinate Transformation Matrix', /)
99994 FORMAT (/, 'Transformation Matrix for SHELX Direction Cosines', /)
99993 FORMAT ('HKLF', I2, ' 1')
99992 FORMAT (/, ':: No Direction Cosines on INPUT/OUTPUT', /)
99991 FORMAT (/, ':: Number of Reflections processed = ', I7, /)
99990 FORMAT (1X)
      END SUBROUTINE PLA330
 
      SUBROUTINE PLA340
C * ANOMALOUS SCATTERING AND ABSORPTION CONTRIBUTIONS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: IENSI
      INTEGER :: IATNUM
      REAL    :: YUNK1
      REAL    :: YUNK2
      REAL    :: YUNK3
      REAL    :: YUNK4
      IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7) THEN
        DO I = 1, IAN
          IENSI = IENS(I)
C * NON-In,Ag, Mo, Ga, Cu WAVELENGTH (f' AND f'')
          IF (IABS(IPR(493)) == 6) THEN
            IATNUM = IATNR(IEN(IENSI))
            CALL PLA386 (IATNUM, PAR(17), ANOM(IENSI, 1),
     1      ANOM(IENSI, 2), ANOM(IENSI, 3), 0)
C * CuKa, GaKa, MoKa, AgKa or InKa  WAVELENGTH (f' AND f'')
C * 5     4     3     2       1     = IPR(493)
          ELSE IF (IABS (IPR(493)) < 6) THEN
            DO K = 1, 2
              J = IEN(IENSI) * 19 + K - 2 * IABS (IPR(493))
              ANOM (IENSI, K) = SFAC(J)
              PAR(512 + K) = MAX (PAR(512 + K), SFAC(J))
            END DO
            ANOM(IENSI, 3) = AMR(IEN(IENSI), IABS (IPR(493)))
          ELSE
            ANOM(IENSI, 3) = 0.0
          END IF
        END DO
        IF (IPR(761) > 0 .AND. IGBL(104) /= 1) THEN
          YUNK1 = 0
          YUNK2 = 0
          DO I = 1, IPR(761)
            YUNK1 = YUNK1 + ABS (DISPVAL(I, 1))
            YUNK2 = YUNK2 + ABS (DISPVAL(I, 2))
          END DO
C * ALERT _986 - No 'NON-ZERO f's' FOUND
          IF (YUNK1 == 0.0)
     1      CALL PLA236 (986, 0, -999.0, 0.0, ' ', ' ')
C * ALERT _981 - No 'NON-ZERO f"s' FOUND
          IF (YUNK2 == 0.0)
     1      CALL PLA236 (981, 0, -999.0, 0.0, ' ', ' ')
          DO I = 1, IAN
            IENSI = IENS(I)
            DO K = 1, IPR(761)
              IF (LMT(IENSI, 1) == DISPTYPE(K)) THEN
                NQ1 = ' '//DISPTYPE(K)(1:2)//'-f''='
                NQ2 = ' '//DISPTYPE(K)(1:2)//'-f"='
                WRITE (NQ3, 99995, IOSTAT = IOST) ANOM(IENSI, 1)
                WRITE (NQ4, 99995, IOSTAT = IOST) ANOM(IENSI, 2)
C * Check for NoSpherA2
                IF (IPR(775) == 0) THEN
                  YUNK3 = ABS (DISPVAL(K, 1) - ANOM(IENSI, 1))
                  IF (YUNK1 > 0.001 .AND. YUNK3 > 0.001) THEN
C * ALERT _982 - F' (SKIP IN & GA & Synchrotron)
                    IF (IPR(493) /= 1 .AND. IPR(493) /= 4 .AND.
     1                IPR(493) /= 6) THEN
                      CALL PLA236 (982, 84, -999.0, DISPVAL(K, 1), NQ1,
     1                             NQ3)
                    ELSE
C * ALERT _984
                      IF (ANOM(IENSI, 1) /= 0.0) THEN
                        CALL PLA236 (984, 84, -999.0, DISPVAL(K, 1),
     1                    NQ1, NQ3)
                      ELSE
C * ALERT _988
                        CALL PLA236 (988, 3, -999.0, DISPVAL(K, 1),
     1                    NQ1(2:6), ' ')
                        ANOM(IENSI, 1) = DISPVAL(K, 1)
                      END IF
                    END IF
                  END IF
                  YUNK4 = ABS (DISPVAL(K, 2) - ANOM(IENSI, 2))
                  IF (YUNK2 > 0.001 .AND. YUNK4 > 0.001) THEN
C * ALERT _983 - F'' (SKIP In & Ga & Synchrotron)
                    IF (IPR(493) /= 1 .AND. IPR(493) /= 4 .AND.
     1                IPR(493) /= 6) THEN
                      CALL PLA236 (983, 84, -999.0, DISPVAL(K, 2), NQ2,
     1                             NQ4)
                    ELSE
C * ALERT _985
                      IF (ANOM(IENSI, 2) /= 0.0) THEN
                        CALL PLA236 (985, 84, -999.0, DISPVAL(K, 2),
     1                      NQ2, NQ4)
                      ELSE
C * ALERT _989
                        CALL PLA236 (989, 3, -999.0, DISPVAL(K, 2),
     1                     NQ2(2:6), ' ')
                        ANOM(IENSI, 2) = DISPVAL(K, 2)
                      END IF
C * HANDLE MISSING ABSORPTION CONTRIBUTION
                      IF (ANOM(IENSI, 3) == 0.0) THEN
                        ANOM(IENSI, 3) = DISPVAL(K, 3)
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END DO
        ELSE
C * ALERT _980 - Anomalous Scattering Factors
          IF (IGBL(104) /= 1 .AND. IPR(105) == 0) THEN
            CALL PLA236 (980, 0, -999.0, 0.0, ' ', ' ')
          END IF
        END IF
C * TEST FOR PRINT LEVEL
        IF (IGBL(63) > 3) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99997, IOSTAT = IOST)
     1      (ANOM(IENS(I), 1), I = 1, IAN)
          WRITE (LU7, 99996, IOSTAT = IOST)
     1      (ANOM(IENS(I), 2), I = 1, IAN)
        END IF
      END IF
C * MASS ABSORPTION COEFFICIENTS
      IF (IABS (IPR(493)) > 0 .AND. IABS (IPR(493)) < 7) THEN
        DO I = 1, IAN
          IF (SATWT(IENS(I)) > 0.1) THEN
            FN(I) = ANOM(IENS(I), 3) / (SATWT(IENS(I)) * 1.66054)
          ELSE
            FN(I) = 0.0
          END IF
        END DO
        IF (IGBL(63) > 3) THEN
          CALL PLA262 (2)
          WRITE (LU7, 99998, IOSTAT = IOST) KRAD, (FN(I), I = 1, IAN)
          WRITE (LU7, 99999, IOSTAT = IOST)
     1      (LMT(IENS(I), 2), I = 1, IAN)
        END IF
      END IF
      IPR(704) = 1
      RETURN
99999 FORMAT ('Elem. Type  : ', 16(4X, A, 1X))
99998 FORMAT ('Mu(a) (', A, '):', 16F7.2)
99997 FORMAT ('Scat.Fact.f'':', 16F7.3)
99996 FORMAT ('Scat.Fact.f":',  16F7.3)
99995 FORMAT (F9.4)
      END SUBROUTINE PLA340
 
      SUBROUTINE PLA343
C * RECOVER ORIGINAL HKL FILE HKLF5 FILE
      USE files
      USE cchar
      INTEGER           :: I
      INTEGER           :: N
      INTEGER           :: M
      INTEGER           :: IH
      INTEGER           :: IK
      INTEGER           :: IL
      CHARACTER(len=16) :: A
      N = 0
      M = 0
      IF (COMMAND_ARGUMENT_COUNT() >= 2) THEN
        CALL GET_COMMAND_ARGUMENT (2, FILENAMES(1))
        N = INDEX (FILENAMES(1), '.hkl')
      END IF
      IF (N /= 0) THEN
        OPEN (LU60, FILE = FILENAMES(1)(1:N-1)//'.hkl',
     1    STATUS = 'UNKNOWN', IOSTAT = IOST)
        IF (IOST /= 0) THEN
          WRITE (LU6, 99997, IOSTAT = IOST) FILENAMES(1)(1:N-1)//'.hkl'
          RETURN
        END IF
        OPEN (LU61, FILE = FILENAMES(1)(1:N - 1)//'_org.hkl',
     1    STATUS = 'UNKNOWN', IOSTAT = IOST)
        DO
          READ (LU60, 99999, IOSTAT = IOST) IH, IK, IL, A, I
          IF (IOST /= 0) EXIT
          IF (IH /= 0 .OR. IK /= 0 .OR. IL /= 0) THEN
            IF (I > 0) THEN
              M = M + 1
              WRITE (LU61, 99999, IOSTAT = IOST) IH, IK, IL, A, I
            END IF
          ELSE
            EXIT
          END IF
        END DO
      END IF
      WRITE (LU6, 99998) M, FILENAMES(1)(1:N - 1)//'_org.hkl'
      RETURN
99999 FORMAT (3I4, A, I4)
99998 FORMAT (/, I8, ' Reflections on ', A)
99997 FORMAT (/, 'FILE: ', A, ' NOT FOUND')
      END SUBROUTINE PLA343
 
      SUBROUTINE PLA344
C * RECOVER original hkl file from solvent contribution subtracted Iobs file
      USE files
      USE cchar
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      INTEGER            :: ISIG
      INTEGER            :: IINT
      REAL, DIMENSION(6) :: DIR
      IF (COMMAND_ARGUMENT_COUNT() >= 2) THEN
        CALL GET_COMMAND_ARGUMENT (2, FILENAMES(1))
        N = INDEX (FILENAMES(1), '.hkl')
      END IF
      IF (N /= 0) THEN
        OPEN (LU60, FILE = FILENAMES(1)(1:N-1)//'.hkl',
     1    STATUS = 'UNKNOWN', IOSTAT = IOST)
        OPEN (LU61, FILE = FILENAMES(1)(1:N - 1)//'_org.hkl',
     1    STATUS = 'UNKNOWN', IOSTAT = IOST)
        M = 0
        DO
          READ (LU60, 99999, IOSTAT = IOST)
     1      IH, IK, IL, IINT, ISIG, (DIR(I), I = 1, 6), IINT
          IF (IOST /= 0) EXIT
          IF (IH /= 0 .OR. IK /= 0 .OR. IL /= 0) M = M + 1
          IF (DIR(1) /= 0.0) THEN
            WRITE (LU61, 99998)
     1        IH, IK, IL, IINT, ISIG, (DIR(I), I = 1, 6)
          ELSE
            WRITE (LU61, 99998) IH, IK, IL, IINT, ISIG
          END IF
        END DO
      END IF
      WRITE (LU6, 99997) M, FILENAMES(1)(1:N - 1)//'_org.hkl'
      RETURN
99999 FORMAT (3I4, 2I8, 4X, 6F8.5, I8)
99998 FORMAT (3I4, 2I8, 4X, 6F8.5)
99997 FORMAT (/, I8, ' Reflections on ', A)
      END SUBROUTINE PLA344
 
      SUBROUTINE PLA345
C * GENERATE _sx.ins AND _sx.hkl
C * FROM .cif AND .fcf for L.S. refinement
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
C * SHELXL201n CASE
      IF (IPR(663) == -1) IPR(663) = -2
      IF (IPR(664) == -1) IPR(664) = -2
      IF (IPR(665) == -1) IPR(665) = -2
C * SHELXL97 CASE, CHECK FOR HKL CIF LOOP
      IF (IPR(753) == 0) THEN
        IF (IPR(664) == 0 .AND. IPR(321) == 0)  THEN
          OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sx.hkl',
     1     STATUS = 'UNKNOWN', IOSTAT = IOST)
          IF (IOST == 0) CALL PLA139 (LU6, LU16, LU61, IPR(384))
          CLOSE (UNIT = LU61)
          IGBL(131) = 1
          PAR(74)   = 10.0
          IPR(675)  = 1
          IPR(664)  = -3
        END IF
      ELSE
        CLOSE (UNIT = LU25, IOSTAT = IOST)
        IPR(664) = -3
      END IF
      IF (IPR(663) == 0) CALL PLA280 ('CALC SHELX NOSF')
      RETURN
      END SUBROUTINE PLA345
 
      SUBROUTINE PLA346
C * CREATE FCF FROM SHELXL20xy BASED CIF (With EMBEDDED .ins & .hkl (.fab))
C * OR COPY-ATTACH IN CASE OF CIF-EMBEDDED FCF FILE
      USE files
      USE parameters
      USE cchar
      USE mentry
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER, SAVE     :: M
      IGBL(9) = IENTRY(IGBL(54), 3)
      IF (IGBL(9) == 1) THEN
        WRITE (LU6, 99997)
        RETURN
      END IF
C * TEST FOR CIF INPUT, A MAXIMUM OF NP54 ENTRIES STORED
      IF (IABS(IGBL(8)) == 3 .AND. IGBL(54) <= NP54) THEN
        NKAR = MIN(INDEX (CENTRY(IGBL(54)), ' ') - 1, 16)
C * CHECK FOR ELECTRON DIFFRACTION [IPR(493)=8]
C * CHECK FOR EXTERNALLY STORED SCATTERING FACTORS IN CIF [IPR(762>0]
        IGBL(9) = IENTRY(IGBL(54), 3)
        FNLU16(KNM16-2:KNM16) = 'fcf'
        IF ((IENTRY(IGBL(54), 4) == 0 .OR. IPR(762) > 0)) THEN
C * Check for shelx/iucr_fcf_details (=+-1)
          IF (IABS(IPR(666)) /= 1) THEN
C * CREATE *_sx.fcf file USING EMBEDDED *_sx.ins, *_sx.hkl (*_sx.fab)
            IF (IPR(663) /= 0 .AND. IPR(664) /= 0) THEN
              CALL PLA347
              CLOSE (UNIT = LU16, IOSTAT = IOST)
            END IF
          END IF
C * COPY/APPEND/DELETE _sx.fcf AND MAKE DATANAMES CONSISTENT
C * CHECK FOR NEW _sx.fcf TO BE APPENDED
          INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'_sx.fcf', EXIST = EXST61)
          IF (EXST61) THEN
C * OPEN _sx.fcf FILE ON LU61 TO BE APPENDED TO FILE LU16
            OPEN (UNIT = LU61, FILE = NAMEFIL(1:KNMFIL)//'_sx.fcf',
     1        STATUS = 'UNKNOWN')
C * CHECK FOR EXISTING fcf FILE ON LU16
            INQUIRE (FILE = NAMEFIL(1:KNMFIL)//'.fcf', EXIST = EXST16)
C * APPEND FCF
            IF (.NOT. EXST16) THEN
              OPEN (UNIT = LU16, FILE = NAMEFIL(1:KNMFIL)//'.fcf',
     1        STATUS = 'NEW')
              M = 0
            ELSE
              CLOSE (UNIT = LU16, IOSTAT = IOST)
              OPEN (UNIT = LU16, FILE = NAMEFIL(1:KNMFIL)//'.fcf',
     1        STATUS = 'OLD')
              OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'.copy',
     1          STATUS = 'UNKNOWN')
C * COPY (EXISTING?) FCF FILE
              M = 0
              DO
                READ (LU16, 99999, IOSTAT = IOST) IDM
                IF (IOST /= 0) EXIT
                M = M + 1
                WRITE (LU65, 99999, IOSTAT = IOST) IDM
              END DO
              REWIND (UNIT = LU65, IOSTAT = IOST)
              REWIND (UNIT = LU16, IOSTAT = IOST)
              DO I = 1, M
                READ  (LU65, 99999, IOSTAT = IOST) IDM
                WRITE (LU16, 99999, IOSTAT = IOST) IDM
              END DO
              CLOSE (UNIT = LU65, STATUS = 'DELETE', IOSTAT = IOST)
            END IF
C * APPEND
            DO
              READ (LU61, 99999, IOSTAT = IOST) IDM
              IF (IOST /= 0) EXIT
              M = M + 1
              IF (IDM(1:5) == 'data_') THEN
                IDM(1:) = 'data_'//CENTRY(IGBL(54))
                IENTRY(IGBL(54), 3) = 1
                IENTRY(IGBL(54), 4) = M
              END IF
              WRITE (LU16, 99999, IOSTAT = IOST) IDM
            END DO
            CLOSE  (UNIT = LU61, STATUS = 'DELETE')
            REWIND (UNIT = LU16, IOSTAT = IOST)
            IGBL(9)  = 1
            IF (IPR(725) /= 7 .AND. IPR(725) /= 8 .AND.
     1        IPR(725) /= 2) IPR(725) = 1
            IGBL(15) = 1
          ELSE
C * CHECK FOR POWDER OR CRYSTL1 BASED REFINEMENT
            IF (IPR(105) == 0 .AND. IGBL(9) /= 5) THEN
              WRITE(LINE, 99998) CENTRY(IGBL(54))(1:NKAR)
              CALL PRINTX (LU6, LINE, 1, 1)
C * ALERT _995
              CALL PLA236 (995, 0, 1.0, 1.0, ' ', ' ')
            END IF
          END IF
C * REMOVE SOME LEFT-OVER FILES
          OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'_sx.cif',
     1      STATUS = 'OLD', IOSTAT = IOST)
          IF (IOST == 0) CLOSE (UNIT = LU65, STATUS = 'DELETE')
          OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'_sx.lst',
     1      STATUS = 'OLD', IOSTAT = IOST)
          IF (IOST == 0) CLOSE (UNIT = LU65, STATUS = 'DELETE')
          OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'_sx.res',
     1      STATUS = 'OLD', IOSTAT = IOST)
          IF (IOST == 0) CLOSE (UNIT = LU65, STATUS = 'DELETE')
        END IF
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT ('** PROBLEM to Recreate FCF for ', A,
     1        '(Native SHELXL20xy Job Needed) **')
99997 FORMAT (/, '** FCF Present: No FCF Generation Needed')
      END SUBROUTINE PLA346
 
      SUBROUTINE PLA347
C * CREATE FCF FROM SHELXL20xy BASED CIF (With EMBEDDED .ins & .hkl (.fab))
      USE files
      USE parameters
      USE cchar
      USE mentry
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: N
      INTEGER           :: KL
      INTEGER           :: KN
      INTEGER           :: IEND
      CHARACTER(len=80) :: DUM
C * CHECK FOR SHELXL20xy AVAILABLE (i.e. IGBL(139) = 1)
      CALL PLA428
      IF (IGBL(139) == 1) THEN
C * REPORT FCF FROM .INS + .HKL
        WRITE (LU13, 99996) CENTRY(IGBL(54))(1:NKAR)
        WRITE (LU13, 99995)
C * OPEN DUMMY FILE FOR EDITED _shelx.ins
        OPEN (UNIT = LU65, FILE = NAMEFIL(1:KNMFIL)//'.junk',
     1    STATUS = 'UNKNOWN')
C * EDIT _sx.ins FILE
        REWIND (UNIT = LU24, IOSTAT = IOST)
        IEND = 0
        DO
          READ (LU24, 99999, IOSTAT = IOST) DUM
          IF (IOST /= 0) EXIT
          IF (DUM(1:1) /= '+') CALL GEN020 (1, DUM, 1, 4)
          IF (DUM(1:4) == 'L.S.') THEN
            CALL GEN072 (DUM, IFL, FN, KL, KN, 0, 0, 1, 5, 80, 7, NP17)
            FN(1) = IGBL(93)
            WRITE (DUM,  99998) 'L.S.', (NINT (FN(I)), I = 1, KN)
            WRITE (LU65, 99999) DUM(1:70)
            WRITE (LU13, 99999)
     1       'Substituted SHELXL Instruction: '//DUM(1:48)
          ELSE IF (DUM(1:4) == 'SFAC') THEN
            WRITE (LU65, 99999) DUM
            N = INDEX (DUM, '=')
            IF (N > 0) DUM(N:N) = ' '
            CALL GEN072 (DUM, IFL, FN, KL, KN, 0, 0, 1, 5, 80, 7, NP17)
          ELSE IF (DUM(1:4) == 'LIST') THEN
            WRITE (DUM, 99999) 'LIST 4'
            WRITE (LU65, 99999) DUM
            WRITE (LU13, 99999) 'Substituted SHELXL Instruction: LIST 4'
          ELSE IF (DUM(1:3) == 'END') THEN
            WRITE (LU65, 99999) DUM
            IEND = 1
          ELSE IF (DUM(1:4) == 'WGHT') THEN
            WRITE (LU65, 99999) DUM
          ELSE IF (DUM(1:4) == 'DAMP') THEN
            WRITE (LU13, 99999) 'Deleted:    '//DUM(1:65)
          ELSE IF (DUM(1:4) == 'FMAP') THEN
            WRITE (LU13, 99999) 'Deleted:    '//DUM(1:65)
          ELSE IF (DUM(1:4) == 'WPDB') THEN
            WRITE (LU13, 99999) 'Deleted:    '//DUM(1:65)
          ELSE IF (DUM(1:4) == 'MORE') THEN
            WRITE (LU13, 99999) 'Deleted:    '//DUM(1:65)
          ELSE IF (DUM(1:4) == 'BIND') THEN
            CALL GEN072 (DUM, IFL, FN, KL, KN, 0, 0, 1, 1, 80, 7, NP17)
            IF (KL == 2 .OR. KN == 2) THEN
              WRITE (LU65, 99999) DUM
            ELSE
              N = KL / 2
              DO I = 1, N
                WRITE (LU65, 99993)
     1            IFL(1), IFL(I*2), IFL(I * 2 + 1)
              END DO
            END IF
          ELSE IF (DUM(1:4) == 'FREE') THEN
            CALL GEN072 (DUM, IFL, FN, KL, KN, 0, 0, 1, 1, 80, 7, NP17)
            IF (KL == 3 .OR. KN == 2) THEN
              WRITE (LU65, 99999) DUM
            ELSE
              N = KL / 2
              DO I = 1, N
                WRITE (LU65, 99993)
     1            IFL(1), IFL(I*2), IFL(I * 2 + 1)
              END DO
            END IF
          ELSE
            WRITE (LU65, 99999) DUM
          END IF
        END DO
C * COPY EDITED _shelx_ins BACK TO LU24
        REWIND (UNIT = LU24, IOSTAT = IOST)
        REWIND (UNIT = LU65, IOSTAT = IOST)
        DO
          READ (LU65, 99999, IOSTAT = IOST) DUM
          IF (IOST /= 0) EXIT
          WRITE (LU24, 99999) DUM
        END DO
        CLOSE (UNIT = LU65, STATUS = 'DELETE')
C * CLOSE FILES *_sx.ins, *_sx.hkl (*_sx.fab)
        CLOSE (UNIT = LU24, IOSTAT = IOST)
        CLOSE (UNIT = LU25, IOSTAT = IOST)
        IF (IPR(665) /= 0) ENDFILE (UNIT = LU26, IOSTAT = IOST)
C * RUN SHELXL20nm
        DUM(1:9) = ' -b5000  '
        DO I = 1, 5
          KERR = 0
          CALL SPAWN (
     1      SHLPATH(1:IGBL(110))//DUM(1:9)//
     2      NAMEFIL(1:KNMFIL)//'_sx > '//NAMEFIL(1:KNMFIL)//
     3      '_sx.log', LU6, .true., KERR)
C * CHECK MESSAGES FROM SHELXL
          OPEN (UNIT = LU65, FILE =
     1      NAMEFIL(1:KNMFIL)//'_sx.log', IOSTAT = IOST)
          IF (IOST == 0) THEN
C * READ-LOOP OF SHELXL LOGFILE
            DO
              READ (LU65, 99999, IOSTAT = IOST) DUM
              IF (IOST == 0) THEN
                IF (INDEX (DUM, 'INCREASE -b') > 0) THEN
                  WRITE (DUM(1:9), 99997) (I + 1) * 5000
                  EXIT
                END IF
              ELSE
                RETURN
              END IF
            END DO
C * END READ-LOOP OF SHELXL LOGFILE
          ELSE
            RETURN
          END IF
          CLOSE (UNIT = LU65, STATUS = 'DELETE', IOSTAT = IOST)
        END DO
      ELSE
        WRITE (LINE, 99994)
        CALL PRINTX (LU6, LINE, 1, 1)
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT (A, I3, 10I5)
99997 FORMAT (' -b', I5, 1X)
99996 FORMAT ('Create FCF from embedded  *.ins, *.hkl (& *.fab) for:',
     1        A)
99995 FORMAT (80('='))
99994 FORMAT (' ** SHELXL20xy Type Executable Required! **')
99993 FORMAT (A, A, 1X, A)
      END SUBROUTINE PLA347
 
      SUBROUTINE PLA348
C * PROGRAM SPGR
C * THIS TOOL IS DESIGNED TO TEST THE FUNCTIONS OF THE GENERAL SPACE GROUP
C * SYMMETRY HANDLING ROUTINE - SGSM - IN ADDITION IT MAY BE USED INTERACTIVELY
C * FOR SYMMETRY RELATED EXERCISES
      USE files
      USE parameters
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: KL
      INTEGER                  :: KN
      INTEGER                  :: IBV
      INTEGER                  :: ISM
      INTEGER                  :: ISW
      INTEGER                  :: ISWX
      INTEGER                  :: JARG
      INTEGER                  :: NRSM
      INTEGER                  :: ICNTR
      INTEGER                  :: ITRNS
      INTEGER                  :: NSYMP
      INTEGER                  :: NSYMR
      INTEGER, DIMENSION(192)  :: ICRD
      REAL,    DIMENSION(192)  :: CRD
      REAL,    DIMENSION(3, 3) :: TM1
      REAL,    DIMENSION(3)    :: OSHFT
      CHARACTER(len=80)        :: LINE
      CHARACTER(len=4)         :: IFL21
      WRITE (LU6, 99993)
      LINE(1:4) = 'LATT'
      ITRNS     = 0
      JARG      = COMMAND_ARGUMENT_COUNT()
      KL        = 1
      KN        = 0
      ISW  = 0
      ISWX = 1
      IF (JARG == 2) THEN
        CALL GET_COMMAND_ARGUMENT (1, LINE)
        CALL GET_COMMAND_ARGUMENT (2, LINE(6:80))
        JARG = -1
        KL = 2
        KN = 0
      END IF
      GO TO 20
   10 IF (JARG > 1) THEN
        CALL GET_COMMAND_ARGUMENT (1, LINE(6:80))
        LINE(1:5) = 'SPGR'
        JARG      = -1
      ELSE IF (JARG < 0) THEN
        LINE = 'LIST'
        JARG = 0
      ELSE
        WRITE (LU6, 99992, ADVANCE = 'NO')
        READ (LU5, 99997) LINE
      ENDIF
      ISW  = 0
      ISWX = 1
      CALL GEN020 (1, LINE, 1, 4)
      CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
      IF (LINE(1:4) == 'HELP') THEN
        CALL SGSM(14, LINE, SGX, 5, LU6, IERR)
        GO TO 10
      ELSE IF (LINE(1:4) == 'SYMM' .AND. KN == 12) THEN
        CALL SGSM (15, LINE, FN, 0, 0, IERR)
        GOTO 10
      ELSE IF (LINE(1:4) == 'INFO') THEN
        CALL SGSM (18, LINE, SGX, 0, LU6, IERR)
        GOTO 10
      ELSE IF (LINE(1:4) == 'SITE') THEN
        SGX(1)  = FN(1)
        SGX(2)  = FN(2)
        SGX(3)  = FN(3)
        SGX(10) = FN(4)
        CALL SGSM (19, LINE, SGX, 0, LU6, IERR)
        WRITE (LU6, 99999) LINE(1:5), NINT (SGX(11)), SGX(10),
     1                    SGX(7), SGX(8), SGX(9)
      ELSE IF (LINE(1:3) == 'END') THEN
        RETURN
      ELSE IF (LINE(1:4) == 'STOP') THEN
        RETURN
      ELSE IF (LINE(1:4) == 'QUIT') THEN
        RETURN
      ELSE IF (LINE(1:4) == 'TRNS' .OR.
     1         LINE(1:4) == 'TRMX') THEN
        K = 0
        DO I = 1, 3
          OSHFT(I) = FN(I + 9)
          DO J = 1, 3
            K = K + 1
            TM1(I, J) = FN(K)
          END DO
        END DO
        ITRNS = 1
        GOTO 10
      ENDIF
C * LAUE/PATT
      IFL21 = IFL(2)(1:4)
      IF ((IFL21 == 'PATT' .OR. IFL21 == 'LAUE').AND.
     1 KL > 1) ISWX = -1
      NRSM = NINT (FN(1))
   20 CALL GEN020 (1, LINE, 1, 4)
      IF (LINE(1:4) == 'LATT' .AND. KN == 0 .AND. KL == 1) THEN
        ISW = 1
      ELSE IF (LINE(1:4) == 'LIST') THEN
        ISW = 2 * ISWX
      ELSE IF (LINE(1:4) == 'DMAT') THEN
        ISW = 6
      ELSE IF (LINE(1:4) == 'GSNR') THEN
        ISW = 7
        LINE(1:4) = 'SYMM'
        ISW = 22
        CALL SGSM (22, LINE, SGX, 0, 0, IERR)
        WRITE (LU6, 99995) SGX(9), SGX(10), SGX(11), SGX(12)
        GOTO 10
      ELSE IF (LINE(1:4) == 'MULT') THEN
        ISW = 8
      ELSE IF (LINE(1:4) == 'INVT') THEN
        ISW = 9
      ELSE IF (LINE(1:4) == 'ATOM' .OR. LINE(1:3) == 'HKL') THEN
        IF (LINE(1:4) == 'ATOM') THEN
          ISW = 3 * ISWX
        ELSE
          ISW = 5 * ISWX
        END IF
        CALL SGSM (18, LINE, SGX, 0, 0, IERR)
        NSYMP = NINT (SGX(4))
        ICNTR = NINT (SGX(5))
        IBV   = NINT (SGX(6))
        DO I = 1, 6
          SGX(I) = 0
          IF (I <= KN) SGX(I) = FN(I)
        END DO
        NSYMR = NSYMP * ICNTR
        IF (IABS (ISW) < 4) NSYMR = NSYMR * IBV
        IF (ICNTR == 1 .AND. ISW < 0) NSYMR = NSYMR * 2
        IF (IABS (ISW) /= 5) THEN
          DO I = 1, NSYMR
            CRD(I)  = 0
            ICRD(I) = I
            CALL SGSM (ISW, LINE, SGX, I, LU6, IERR)
            DO J = 7, 9
              CRD(I) = CRD(I) + MOD (SGX(J) + 10.0, 1.0) * 100**(9-J)
            END DO
          END DO
          CALL GEN036 (CRD, ICRD, 1, NSYMR)
          DO K = 1, NSYMR
            I = ICRD(K)
            CALL SGSM (ISW, LINE, SGX, I, LU6, IERR)
            DO J = 7, 9
              SGX(J) = MOD (SGX(J) + 10.0, 1.0)
            END DO
            IF (ISW > 0) THEN
              CALL SGSM (2,  LINE, SGX, I, 0, IERR)
            ELSE
              CALL SGSM (-2, LINE, SGX, I, 0, IERR)
            ENDIF
            WRITE (LU6, 99991) I, SGX(7), SGX(8), SGX(9), LINE(1:45)
          END DO
        ELSE
          DO I = 1, NSYMR
            CALL SGSM (ISW, LINE, SGX, I, LU6, IERR)
            WRITE (LU6, 99994) I, SGX(7), SGX(8), SGX(9), SGX(10)
          END DO
        ENDIF
        GO TO 10
      ELSE IF (LINE(1:4) == 'VECT') THEN
        ISW = -3
      ELSE IF (LINE(1:4) == 'RLST') THEN
        ISW = 4 * ISWX
C * SHELX-TYPE SYMM
      ELSE IF (LINE(1:4) == 'SHEL') THEN
        ISM = NINT (FN(1))
        CALL SGSM (17, LINE, SGX, ISM, LU6, IERR)
        GOTO 10
C * RTM
      ELSE IF (LINE(1:3) == 'RTM') THEN
        ISW = 15
      END IF
C * LATT/SYMM/LIST/RLST/SPGR/DMAT/GSNR INSTRUCTION
      IF (ISW >= 7) THEN
        DO I = 1, 12
          IF (I > KN) FN(I) = 0.0
          SGX(I) = FN(I)
        END DO
      END IF
      IF (LINE(1:4) == 'LATT' .OR. LINE(1:4) == 'SPGR'
     1   .OR. LINE(1:4) == 'SYMM' .OR. LINE(1:4) == 'HALL') THEN
        IF (ITRNS == 1) THEN
          ISW = 16
          K   = 0
          DO I = 1, 3
            SGX(I + 9) = OSHFT(I)
            DO J = 1, 3
              K      = K + 1
              SGX(K) = TM1(I, J)
            END DO
          END DO
        ENDIF
      ENDIF
C * SPGR
      IF (LINE(1:4) == 'SPGR') THEN
        IF (KL == 1 .AND. KN == 0) GO TO 10
      ENDIF
      CALL SGSM (ISW, LINE, SGX, NRSM, LU6, IERR)
      IF (ISW == 6) WRITE (LU6, 99990)
     1 (SGX(J), J = 1, 3), SGX(10), (SGX(J), J = 4, 6),
     2  SGX(11), (SGX(J), J = 7, 9), SGX(12)
      IF (ISW > 6 .AND. ISW < 15)
     1  WRITE (LU6, 99998) NINT (SGX(9)), SGX(10), SGX(11), SGX(12)
      GO TO 10
99999 FORMAT('site: ', A, I10, ' mult ', F10.4, ' pos:', 3F8.4)
99998 FORMAT ('SYMM NR', I4, ' UNIT TRANSL.', 3F5.0)
99997 FORMAT (A)
99995 FORMAT (4F10.2)
99994 FORMAT (I5, 6X, F10.0, 3(7X, F10.0))
99993 FORMAT (/, 20X, 36('='),
     1        /, 20X, '=== SPACE GROUP EXERCISE PROGRAM ===',
     2        /, 20X, 36('='),
     3       //, 20X, 'TYPE <HELP> FOR HELP OR INSTRUCTION', /)
99992 FORMAT (/,'>>')
99991 FORMAT (I4, 3(F8.4), 2X, A)
99990 FORMAT (2X, 3F10.0, F10.5)
      END SUBROUTINE PLA348
 
      SUBROUTINE PLA349
C * RELOAD SPACE-GROUP BY NAME FOR CONSISTENCY
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER NRXX
      IF (SPGRNM(1)(1:1) /= ' ') THEN
        NRXX = 0
        IF (INDEX (SPGRNM(1)(1:11), ':') /= 0) THEN
          WRITE (ICL, 99999, IOSTAT = IOST) SPGRNM(1)(1:11)
        ELSE
          WRITE (ICL, 99998, IOSTAT = IOST)
     1      SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11)
          IF (SPGRNM(1)(13:13) /= ' ') ICL(13:13) = '.'
        END IF
        CALL SGSM (0, ICL, SGY, NRXX, LU6, IERR)
      END IF
      RETURN
99999 FORMAT ('SPGR ', A, 64X)
99998 FORMAT ('SPGR ' , A, 63X)
      END SUBROUTINE PLA349
 
      MODULE cflip
      SAVE
      INTEGER               :: NTRY
      INTEGER               :: MTRY
      INTEGER               :: NTEL
      INTEGER               :: IPEN
      INTEGER               :: NREF
      INTEGER               :: MXSOL
      INTEGER               :: MFTRY
      INTEGER               :: NLOOP
      INTEGER               :: NSPGR
      INTEGER               :: NSOLVED
      INTEGER               :: NSOLVMIN
      INTEGER, DIMENSION(4) :: MLOOP
      INTEGER, DIMENSION(3) :: IHKLMAX
      REAL                  :: UISO
      REAL                  :: VRTY
      REAL                  :: RVAL0
      REAL                  :: RVMIN
      REAL                  :: PFLIP
      REAL                  :: FACTOR
      REAL                  :: FOBSMIN
      END MODULE cflip
 
      SUBROUTINE PLA350
C * CHARGE FLIPPING DRIVER ROUTINE
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE cflip
      USE exor
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: KL
      INTEGER :: KN
      REAL    :: VRTYI
      IWIN = IGBL(25) * IGBL(32)
C * DEFAULTS
      MLOOP(1) = 5000
      MLOOP(2) = 500
      MLOOP(3) = 1000
      MLOOP(4) = 2000
      FACTOR   = PAR(475)
      PFLIP    = 0.25
      UISO     = 0.02
      MXSOL    = 3
      NSOLVED  = 0
C * CHECK FOR CLOSED LU7
      INQUIRE (UNIT = LU7, OPENED = OPEND)
      IF (.NOT. OPEND)
     1  OPEN (UNIT = LU7, FILE = 'flip_dummy.lis', FORM = 'FORMATTED',
     2        IOSTAT = IOST)
C * CLOSE CHECK.DEF (NOT NEEDED FOR CHARGE FLIPPING)
      INQUIRE (UNIT = LU12, OPENED = OPEND)
      IF (OPEND) CLOSE (UNIT = LU12)
C * CLOSE <NAME>.DEF (NOT NEEDED FOR CHARGE FLIPPING)
      INQUIRE (UNIT = LU23, OPENED = OPEND)
      IF (OPEND) CLOSE (UNIT = LU23)
C * DELETE previous _sol.res
      CALL GEN129 (LU62, NAMEFIL(1:KNMFIL)//'_sol.res')
C * DELETE previous _res.res
      CALL GEN129 (LU62, NAMEFIL(1:KNMFIL)//'_res.res')
C * DELETE previous _res.new
      CALL GEN129 (LU62, NAMEFIL(1:KNMFIL)//'_res.new')
C * OPEN FILE FOR THE COLLECTION OF RAW SOLUTIONS
      OPEN (LU60, FILE = NAMEFIL(1:KNMFIL)//'_flp.res',
     1        STATUS = 'UNKNOWN')
C * OPEN FILE FOR THE COLLECTION OF CONVERGED SOLUTIONS
      OPEN (LU63, FILE = NAMEFIL(1:KNMFIL)//'_sol.res',
     1        STATUS = 'UNKNOWN')
C * COPY (HKL OR FCF FILE TYPE) REFLECTION FILE FOR EXOR RUN
      OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_xor.hkl',
     1      STATUS = 'UNKNOWN')
      REWIND (UNIT = LU16, IOSTAT = IOST)
C * CHECK FOR NON-HKLF4 FILE
      IF (IGBL(9) > 0) THEN
        CALL PLA139 (LU6, LU16, LU61, IPR(384))
      ELSE
        DO
          READ  (LU16, 99999, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          WRITE (LU61, 99999, IOSTAT = IOST) LINE
        END DO
      END IF
      CLOSE (UNIT = LU61)
C * INSTRUCTIONS
      KL = IPR(220)
      DO I = 1, KL
C * IPR(640) = 0 - FLIPPER MODE (25 RANDOM TRIAL)
        IF (IFL(I)(1:4) == 'FLIP') THEN
          NTRY     = 25
C * RVMIN TERMINATE R
          PAR(570) = 0.0
          IPR(640) = 0
C * IPR(640) = 1 - 'STRUCTURE' MODE
        ELSE IF (IFL(I)(1:4) == 'STRU') THEN
          NTRY     = 25
C * RVMIN TERMINATE R
          PAR(570) = 0.25
          IPR(640) = 1
C * PATT MODE (ONE TRY ONLY STARTING WITH PHASES ZERO)
        ELSE IF (IFL(I)(1:4) == 'PATT') THEN
          NTRY     = 1
C * RVMIN TERMINATE R
          PAR(570) = 0.0
          IPR(640) = 0
C * DISPLAY OPTION
        ELSE IF (IFL(I)(1:4) == 'SHOW') THEN
          IPR(614) = 1
        ELSE IF (IFL(I)(1:4) == 'MENU') THEN
          IF (IWIN == 1) IGBL(6) = 31
        END IF
      END DO
      IF (NTRY > 1) MLOOP(1) = 250
C * HANDLE FLIP ARGUMENTS
      KN = IPR(221)
      IF (KN > 0) THEN
C * GET NUMBER OF ATTEMPTS
        IF (FN(1) < 0.0) THEN
C * SET TO PHASES FROM F-CALC
          IPR(604) = 1
          UISO     = 0.0
          MLOOP(1) = 500
        END IF
        NTRY = MAX (1, MIN (25, NINT (ABS(FN(1)))))
C * GET # OF FLIP CYCLES
        IF (KN > 1) THEN
          IF (FN(2) /= 0.0) THEN
            MLOOP(1) = NINT (FN(2))
            MLOOP(2) = MLOOP(1)
            MLOOP(3) = MLOOP(1)
            MLOOP(4) = MLOOP(1)
          END IF
C * GET MAX # OF SOLUTIONS
          IF (KN > 2) THEN
            IF (FN(3) > 0) MXSOL = NINT (FN(3))
C * GET FLIP FACTOR
            IF (KN > 3) THEN
              FACTOR = MIN (0.05, FN(4))
C * PHASE FLIP
              IF (KN > 4) THEN
                PFLIP = MIN (0.50, FN(5) / 100.0)
C * GET 'NORMALIZING' U
                IF (KN > 5) THEN
                  UISO = MIN (0.06, FN(6))
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
C * PARAMETER CHANGE MENU MODE
      IF (IGBL(6) == 31) THEN
        NTRY     = 1
        IPR(640) = 0
        DO WHILE (.TRUE.)
          VRT  = VERT - 1.5
          LINE = 'Flipper Menu - Current Settings'
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA439 (0.0, LINE, 31, 0.85, 5, 2, 1.0, VRT)
          VRT = VRT - 3.0
          WRITE (LINE,
     1      '(''NTRY   - Number of Trials           '', I10)',
     2      IOSTAT = IOST) NTRY
          CALL PLA439 (0.0, LINE, 46, 0.5, 1, 2, 1.0, VRT)
          VRT = VRT - 1.0
          WRITE (LINE,
     1      '(''NLOOP  - Maximum Number of Flips    '', I10)',
     2      IOSTAT = IOST) MLOOP(1)
          CALL PLA439 (0.0, LINE, 46, 0.5, 1, 2, 1.0, VRT)
          VRT = VRT - 1.0
          WRITE (LINE,
     1      '(''NSOLVE - Maximum Number of Solutions'', I10)',
     2      IOSTAT = IOST) MXSOL
          CALL PLA439 (0.0, LINE, 46, 0.5, 1, 2, 1.0, VRT)
          VRT = VRT - 1.0
          WRITE (LINE,
     1      '(''DELTA  - Flip Factor Delta          '', F10.3)',
     2      IOSTAT = IOST) FACTOR
          CALL PLA439 (0.0, LINE, 46, 0.5, 1, 2, 1.0, VRT)
          VRT = VRT - 1.0
          WRITE (LINE,
     1      '(''PERC   - Phase Shift Percentage     '', F10.3)',
     2      IOSTAT = IOST) PFLIP
          CALL PLA439 (0.0, LINE, 46, 0.5, 1, 2, 1.0, VRT)
          VRT = VRT - 1.0
          WRITE (LINE,
     1      '(''UISO   - Normalizing Uiso           '', F10.3)',
     2      IOSTAT = IOST) UISO
          CALL PLA439 (0.0, LINE, 46, 0.5, 1, 2, 1.0, VRT)
          VRT = VRT - 3
          WRITE (LINE,
     1      '(''Enter New Parameter Data Values, Continue or END'')',
     2      IOSTAT = IOST)
          CALL PLA439 (0.0, LINE, 50, 0.5, 5, 2, 1.0, VRT)
C * CHANGE PARAMETER VALUE LOOP
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          CALL GEN072 (IGGT, IFL, FN, IPR(220), IPR(221), 0, LU6,
     1               1, 1, 80, 7, NP17)
          KN = IPR(221)
          IF (IFL(1)(1:4) == 'UISO') THEN
            IF (KN > 0) UISO = FN(1)
          ELSE IF (IFL(1)(1:5) == 'NLOOP') THEN
            IF (KN > 0) THEN
              MLOOP(1) = NINT (FN(1))
              MLOOP(2) = MLOOP(1)
              MLOOP(3) = MLOOP(2)
              MLOOP(4) = MLOOP(3)
            END IF
          ELSE IF (IFL(1)(1:4) == 'NTRY') THEN
            IF (KN > 0) NTRY = NINT (FN(1))
          ELSE IF (IFL(1)(1:6) == 'NSOLVE') THEN
            IF (KN > 0) MXSOL = NINT (FN(1))
          ELSE IF (IFL(1)(1:5) == 'DELTA') THEN
            IF (KN > 0) FACTOR = FN(1)
          ELSE IF (IFL(1)(1:4) == 'PERC') THEN
            IF (KN > 0) PFLIP = FN(1)
          ELSE IF (IFL(1)(1:4) == 'SHOW') THEN
            IPR(614) = 1
          ELSE IF (IFL(1)(1:3) == 'END') THEN
            EXIT
          ELSE IF (IFL(1)(1:4) == 'CONT') THEN
            EXIT
          ELSE IF (IFL(1)(1:4) == 'STRU') THEN
            IPR(640) = 1
          ELSE IF (IFL(1)(1:4) == 'EXIT') THEN
            GOTO 80
          END IF
        END DO
        KN   = 0
      END IF
C * CHECK FOR SF-CALCULATION (TEST OPTION)
      IF (IPR(604) > 0 .AND. IPR(37) > 0) THEN
C * ANALYSES OF ANIS. TEMP. AND OUTPUT OF CONNECTED SET
        CALL PLA024
C * LOAD AND EXPAND COORDINATE DATA TO UNIT CELL CONTENTS
C * (EXCLUDING BRAVAIS CENTERING)
        CALL PLA023 (0)
      END IF
C * SETUP BINARY F(obs) REFLECTION FILE
      IGBL(16) = 0
      WRITE (LU6, 99993)
      CALL PLA151 (-1)
C * CHECK FOR NON-ZERO NUMBER OF REFLECTIONS
      IF (IPR(602) > 0) THEN
        DO I = 1, 3
          J          = 2 * I
          IHKLMAX(I) = MAX (-IPR(265 + J), IPR(266 + J))
        END DO
C * SORT REFLECTIONS ON F(OBS) AND COPY
        CALL GEN108 (LU19, 0)
        NREF = 0
   50   READ (LU19) F
        DO I = 1, 79, 6
          IF (NINT (F(I)) == 0) GO TO 70
          NREF       = NREF + 1
          VOID(NREF) = - F(I + 1)
        END DO
        GO TO 50
C * SORT RELECTIONS AND DETERMINE 'WEAK' LEVEL
   70   CALL GEN034 (VOID, 1, NREF)
        FOBSMIN  = - VOID(NINT (PFLIP * NREF))
C * OPEN GRAPHICS
        IGBL(6) = 31
        WRITE (LINE, 99998, IOSTAT = IOST)
        WRITE (LU6,  99997, IOSTAT = IOST) LINE
        WRITE (LU7,  99997, IOSTAT = IOST) LINE
        IF (IWIN == 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA110 (HORS, VERT, -1)
          BCD = 'Click on Window to STOP Loops'//CHAR (0)
          CALL GGIP (-999.0, 2.0, 33.0, 111)
          VRT = VERT - 1.1
          IF (NTRY == 1) THEN
            VRTY = 0.80 * VERT
          ELSE
            VRTY = 0.38 * VERT
          END IF
          CALL PLA439 (0.0, LINE, 80, 0.55, 5, 2, 3.0, VRT)
          CALL GGIP (1.0,   0.0, 0.0, 3)
          CALL GGIP (HORS,  0.0, 0.0, 2)
          CALL GGIP (HORS, VRTY, 0.0, 2)
          CALL GGIP (1.0,  VRTY, 0.0, 2)
          CALL GGIP (1.0,   0.0, 0.0, 2)
          DO I = 1, 7
            VRTYI = (I - 1) * VRTY / 7.0
            CALL GGIP (1.0, VRTYI, 0.0, 3)
            CALL GGIP (1.3, VRTYI, 0.0, 2)
            WRITE (NQ1, 99995, IOSTAT = IOST) I * 10
            CALL PLA439 (0.0, NQ1, 2, 0.15, 1, 1, 1.05, VRTYI + 0.08)
          END DO
          CALL PLA439 (90.0, 'R-Value' , 7, 0.35, 1, 2, 1.8, 0.2)
          CALL PLA439 (0.0,  'Log(N)-Iteration', 16, 0.35, 1, 2,
     1                 HORS -5.2, 0.1)
          CALL PLA439 (0.0, 'Experimental !', 14, 0.6, 2, 2, 2.1, 1.2)
          WRITE (LINE, 99996, IOSTAT = IOST)
     1      FACTOR, PFLIP * 100.0, UISO, PAR(466), PAR(467)
          CALL PLA439 (0.0, LINE, 80, 0.25, 5, 1, 3.0, VRTY - 0.3)
          CALL PLA439 (0.0, 'Spgr    Rexor Frq Nsl Try', 25, 0.25,
     1                 5, 1, HORS - 5.5, VRTY - 0.35)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
        WRITE (LU6, 99994, IOSTAT = IOST)
     1    NTRY, (MLOOP(I), I = 1, 4), MXSOL, FACTOR, PFLIP * 100.0, UISO
        WRITE (LU7, 99994, IOSTAT = IOST)
     1    NTRY, (MLOOP(I), I = 1, 4), MXSOL, FACTOR, PFLIP * 100.0, UISO
C * FLIP
        CALL PLA351
C * VIEW/REFINE RESULT
        IF (NSOLVED > 0) THEN
C * FLIPPER MODE
          IF (IPR(640) == 0) THEN
            CALL GEN129 (LU23, 'satom.def')
C * RUN PLUTON
            KERR = 0
            IF (DOS) THEN
              CALL SPAWN (PLAPATH(1:IGBL(80))//' -r +0pluton.log '//
     1          NAMEFIL(1:KNMFIL)//'_res.res', LU6, .true., KERR)
            ELSE
              CALL SPAWN (PLAPATH(1:IGBL(80))//' -r '//
     1          NAMEFIL(1:KNMFIL)//'_res.res', LU6, .true., KERR)
            END IF
C * STRUCTURE? MODE
          ELSE IF (IPR(640) == 1) THEN
            IF (IGBL(110) > 0) CALL PLA353
          END IF
        END IF
C * CLEANUP .bin, INTERMEDIATE AND NEXT FILES
        IF (IGBL(16) == 1) THEN
          CLOSE (UNIT = LU19, STATUS = 'DELETE')
          IGBL(16) = 0
        END IF
        CLOSE (UNIT = LU7, STATUS = 'DELETE')
        CALL GEN129 (LU64, 'NEXT')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_res.pjn')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_xor.ins')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_xor.hkl')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_xor.bin')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'.def')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_ads_pl.spf')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_ads.ins')
        CALL GEN129 (LU64, NAMEFIL(1:KNMFIL)//'_ads.lis')
        CALL GEN129 (LU64, 'satom.spf')
      END IF
   80 IGBL(6) = 10
      RETURN
99999 FORMAT (A)
99998 FORMAT ('Charge Flipping Ab Initio Structure Solution')
99997 FORMAT (/, A, /)
99996 FORMAT ('Delta =', F7.3, ', Perc =', F5.1, ', UISO =',
     1         F6.3, ', RFLMX =', F5.2, ', REXMX =', F5.2)
99995 FORMAT (I2)
99994 FORMAT ('Number of Trials ....... =', I6, /,
     1        'Max Number of Flips .... =', 4I6, /,
     2        'Max Mumber of Solutions  =', I6, /,
     3        'Flip Factor Delta ...... =', F6.3, /,
     4        'Phase Shift Percentage . =', F6.1, /,
     5        'Normalizing U .......... =', F6.2, /)
99993 FORMAT (/, '** SETUP BINARY F(OBS) REFLECTION FILE **', /)
      END SUBROUTINE PLA350
 
      SUBROUTINE PLA351
C * THIS ROUTINE IMPLEMENTS THE CHARGE FLIPPING CONCEPT - Oszlanyi et al.
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE cflip
      USE comdrie
      USE exor
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: M1
      INTEGER          :: M2
      INTEGER          :: M3
      INTEGER          :: IH
      INTEGER          :: IK
      INTEGER          :: IL
      INTEGER          :: IHT
      INTEGER          :: IKT
      INTEGER          :: ILT
      INTEGER          :: ISN
      INTEGER          :: LOC
      INTEGER          :: IDUM
      INTEGER          :: ITOP1
      INTEGER          :: ITOP2
      INTEGER          :: NSYMH
      INTEGER          :: NTITLE
      REAL             :: PHI
      REAL             :: PHIA
      REAL             :: YUNK
      REAL             :: AOBS
      REAL             :: BOBS
      REAL             :: FOBS
      REAL             :: ACAL
      REAL             :: BCAL
      REAL             :: ACALA
      REAL             :: BCALA
      REAL             :: FS000
      REAL             :: ACALAF
      REAL             :: BCALAF
      REAL             :: GEN013
      CHARACTER(len=7) :: SPGRSAV
C * GET # OF TRIALS
      RVMIN    = 1.0
      NSOLVMIN = 0
      IPEN     = 4
      NSPGR    = 0
      MFTRY    = 0
C * INITIALIZE RANDOM NUMBER GENERATOR
      IDUM     = -1
      PHI      = GEN013 (IDUM)
C * GET SPGR NAME (FOR DATA EXPANSION TO P1)
      CALL SGSM (18, IDM, SGX, 0, 0, IERR)
      SPGRSAV = IDM(1:7)
      CALL GEN038 (PRBUF, 1, 132)
      IPR(409) = 1
C * GET SUITABLE FFT-GRID
      DO I = 1, 3
        DO J = 4, 8
          IPR(I + 394) = 2**J
          IF (PAR(I + 100) * 3.0 < IPR(I + 394)) EXIT
        END DO
      END DO
      DO I = 1, 3
        J = IPR(394 + I)
        IF (2 * IHKLMAX(I) >= IPR(J)) IPR(J) = IPR(J) * 2
      END DO
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      NGRID = M1 * M2 * M3
      WRITE (LU6, 99999, IOSTAT = IOST) M1, M2, M3
      WRITE (LU7, 99999, IOSTAT = IOST) M1, M2, M3
C * FFT
      ITOP  = NGRID * 2
      ITOP1 = 2 * ITOP
      ITOP2 = ITOP1 + 3 * (M1 + 2) * (M2 + 2)
C * CHECK FOR SCRATCH OVERRUN (2*FFT + R3D)
      IF (ITOP2 > NVDR) THEN
        IPR(2) = 49
      ELSE
        WRITE (LINE, 99997, IOSTAT = IOST)
        WRITE (LU6,  99998, IOSTAT = IOST) LINE
        WRITE (LU7,  99998, IOSTAT = IOST) LINE
        IF (IWIN == 1) THEN
          VRT = VRT - 0.7
          CALL PLA439 (0.0, LINE, 80, 0.32, 5, 2, 1.0, VRT)
          VRT = VRT - 0.2
        END IF
        CALL GGIP (0.0, 0.0, 0.0, 6)
        NSYMH   = IPR(255)
        NSOLVED = 0
        NLOOP   = MLOOP(1)
        NTEL    = 0
C * LOOP FOR NTRY TRIALS
        DO M = 1, NTRY
          IF (CC) GO TO 40
          IDM = 'SPGR '//SPGRSAV
          CALL SGSM (0, IDM, SGX, 0, LU6, IERR)
          IPEN = MOD (IPEN + 1, 5) + 1
          MTRY = M
          IF (NSOLVED == 0) THEN
            IF (M > 3) THEN
              NLOOP = MLOOP(2)
              IF (M > 6) THEN
                NLOOP = MLOOP(3)
                IF (M > 10) THEN
                  NLOOP = MLOOP(4)
                END IF
              END IF
            END IF
          ELSE IF (NSOLVED == 1) THEN
            IF (M > 5) THEN
              NLOOP = MLOOP(2)
              IF (M > 10) THEN
                NLOOP = MLOOP (3)
                IF (M > 15) THEN
                  NLOOP = MLOOP(4)
                END IF
              END IF
            END IF
          END IF
          VRT = VRT - 0.4
C * LOAD SAVE-FFT array from data in .bin
C * F(I)     = PACKED HKL (0 = END)
C * F(I + 1) = F(OBS)
C * F(I + 2) = SIGMA**2(F)
C * F(I + 3) = 8*PI**2*(SINTH/LAMBDA)**2
C * F(I + 4) = ACALC
C * F(I + 5) = BCALC
C * ZERO ARRAY
          CALL GEN074 (VOID, 1, ITOP1, 0.0)
          RVAL0   = 1.0
          FS000   = 0.0
          VOID(1) = FS000
          CALL GEN108 (LU19, 0)
   20     READ (LU19) F
          DO I = 1, 79, 6
            IF (NINT (F(I)) == 0) GO TO 30
            CALL GEN046 (F(I), SGX(1), SGX(2), SGX(3))
            FOBS = F(I + 1) * EXP (UISO * F(I + 3))
            PHI  = 0.0
C * TEST for PHASES TO BE CALCULATES FROM INPUT MODEL
            IF (IPR(604) /= 0) THEN
              ACAL = 0.0
              BCAL = 0.0
              CALL PLA137 (NINT (SGX(1)), NINT (SGX(2)), NINT (SGX(3)),
     1          ACAL, BCAL, ACALA, BCALA, ACALAF, BCALAF, YUNK)
              ACAL = ACAL + ACALA
              BCAL = BCAL + BCALA
              PHI  = ATAN2 (BCAL, ACAL) * RGBL(6)
            END IF
C * EXPAND
            DO N = 1, NSYMH
              SGX(4) = PHI
              CALL SGSM (5, LINE, SGX, N, LU6, IERR)
              IHT = NINT (SGX(7))
              IKT = NINT (SGX(8))
              ILT = NINT (SGX(9))
C * ASSIGN RANDOM PHASE (FOR MTRY > 1)
              IF (MTRY > 1 .OR. NTRY > 1) THEN
C * GET RANDOM PHASE
                PHI  = GEN013(IDUM) * RGBL(5)
                AOBS = FOBS * COS (PHI)
                BOBS = FOBS * SIN (PHI)
              ELSE
                IF (IPR(604) == 0) THEN
                  AOBS = FOBS
                  BOBS = 0.0
                ELSE
                  PHIA = SGX(10) / RGBL(6)
                  AOBS = FOBS * COS (PHIA)
                  BOBS = FOBS * SIN (PHIA)
                END IF
              END IF
              ISN  = -1
              DO J = 1, 2
                ISN = - ISN
                IH = ISN * IHT
                IK = ISN * IKT
                IL = ISN * ILT
                IF (IH < 0) IH = IH + M1
                IF (IK < 0) IK = IK + M2
                IF (IL < 0) IL = IL + M3
                LOC = 2 * ((IL * M2 + IK) * M1 + IH + 1)
                VOID(LOC - 1)        = ISN * ABS (FOBS)
                VOID(LOC)            = 4 * SQRT (F(I + 2))
                VOID(ITOP + LOC - 1) = AOBS
                VOID(ITOP + LOC)     = ISN * BOBS
              END DO
            END DO
          END DO
          GO TO 20
   30     IDM = 'SPGR '//SPGRSAV(1:1)//'1'
          CALL SGSM (0,  IDM, SGX, 0, 0, IERR)
          CALL SGSM (18, IDM, SGX, 0, 0, IERR)
          IPR(48) = NINT (SGX(9))
C * FLIP ROUTINE
          CALL PLA352 (VOID(1), VOID(ITOP + 1), VOID(ITOP1 + 1))
          IF ( RVMIN < PAR(570)) EXIT
        END DO
   40   CLOSE (UNIT = LU60)
        CLOSE (UNIT = LU63)
        IF (NSOLVED > 0) THEN
C * SELECT/COPY THE MOST PROMISING SOLUTION
          OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_sol.res',
     1          STATUS = 'UNKNOWN')
          OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_res.res',
     1          STATUS = 'UNKNOWN')
          NTITLE = 0
   50     READ (LU61, 99998, IOSTAT = IOST) LINE
          IF (IOST == -1) GO TO 70
          IF (LINE(1:4) == 'TITL') THEN
            NTITLE = NTITLE + 1
            IF (NTITLE /= NSOLVMIN) GO TO 50
            WRITE (LU62, 99998, IOSTAT = IOST) LINE
   60       READ (LU61, 99998, IOSTAT = IOST) LINE
            IF (IOST == -1) GO TO 70
            IF (LINE(1:4) == 'SFAC') THEN
              WRITE (LU62, 99998, IOSTAT = IOST) LINE
            ELSE IF (LINE(1:4) == 'UNIT') THEN
              WRITE (LU62, 99998, IOSTAT = IOST) LINE
            ELSE IF (LINE(1:4) == '    ') THEN
            ELSE IF (LINE(1:4) == 'TITL') THEN
              GO TO 70
            ELSE
              WRITE (LU62, 99998, IOSTAT = IOST) LINE
            END IF
            GO TO 60
          ELSE
            GO TO 50
          END IF
   70     CLOSE (UNIT = LU61)
          CLOSE (UNIT = LU62)
        END IF
      END IF
      RETURN
99999 FORMAT ('FFT grid =', 3I5, /)
99998 FORMAT (A)
99997 FORMAT ('Try Loop(  max) Delta Phi Rho(min) Rho(max) F000 ',
     1        ' R(F) DeltaR Npk Rexor Nat Spgr')
      END SUBROUTINE PLA351
 
      SUBROUTINE PLA352 (FFT1, FFT2, R3D)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE cflip
      USE comdrie
      USE exor
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: IG
      INTEGER            :: NAT
      INTEGER            :: ISN
      INTEGER            :: NPK
      INTEGER            :: NSP
      INTEGER            :: NPK0
      INTEGER            :: ITEL
      INTEGER            :: MTEL
      INTEGER            :: ISKIP
      INTEGER            :: NCURC
      INTEGER            :: NCOUNT
      INTEGER            :: NCURVE
      REAL               :: XG
      REAL               :: YG
      REAL               :: XP
      REAL               :: YP
      REAL               :: ZG
      REAL               :: ACAL
      REAL               :: BCAL
      REAL               :: DELR
      REAL               :: DELT
      REAL               :: DENS
      REAL               :: F000
      REAL               :: FCAL
      REAL               :: FFTX
      REAL               :: FOBS
      REAL               :: RMAX
      REAL               :: RMIN
      REAL               :: RVAL
      REAL               :: SUMX
      REAL               :: SXSQ
      REAL               :: TERM
      REAL               :: XPOLD
      REAL               :: YPOLD
      REAL               :: SUMDL
      REAL               :: SUMFC
      REAL               :: SUMFO
      REAL               :: REXOR
      REAL               :: VRT20
      REAL               :: RHOMIN
      REAL               :: SCHAAL
      REAL, DIMENSION(*) :: R3D
      REAL, DIMENSION(*) :: FFT1
      REAL, DIMENSION(*) :: FFT2
      CHARACTER(len=4)   :: SFT
      CHARACTER(len=7)   :: SPGR
      CHARACTER(len=80)  :: SLINE
C * RES-STYLE OUTPUT
      IF (ABS(IGBL(8)) == 3) THEN
        M = 2
      ELSE
        M = 3
      END IF
      RHOMIN = 2.0 * PAR(98)
      RVAL   = 1.0
      DELR   = 1.0
      REXOR  = 0.0
      TERM   = 1.0
      ITEL   = 0
      MTEL   = 0
      NCURVE = 0
      NCURC  = 0
C * FLIP CYCLE ITERATION
      DO N = 1, NLOOP
C * FIRST CHECK FOR INTERRUPT RETURNED IN IG
        XG = 0.0
        YG = 0.0
        ZG = 0.0
        IG = 9
        CALL GGIP (XG, YG, ZG, IG)
        IF (IG == 1) THEN
C * INQUIRE ON HOW TO PROCEED
          CALL PLA012 (0, 1)
          CALL GEN072 (IGGT, IFL, FN, IPR(220), IPR(221), 0, LU6,
     1                   1, 1, 80, 7, NP17)
          IF (IGGT(1:1) == 'N' .OR. IGGT(1:3) == 'END' .OR.
     1        IGGT(1:4) == 'EXIT') THEN
            CC   = .TRUE.
            GO TO 20
          ELSE IF (IGGT(1:4) == 'CONV') THEN
            CC   = .TRUE.
            TERM = 0.0
          ELSE IF (IGGT(1:4) == 'CONT') THEN
            CC   = .FALSE.
          ELSE IF (IFL(1)(1:4) == 'FACT') THEN
            FACTOR = FN(1)
            CC   = .FALSE.
          END IF
          IF (IWIN == 1) THEN
            CALL PLA439 (0.0, SLINE, 80, 0.32, 1, 2, 1.0, VRT)
            CALL GGIP (0.0, 0.0, 0.0, 6)
          END IF
        END IF
C * TRANSFORM TO DIRECT SPACE
        CALL GEN028 (FFT2, IPR(395), 3, -1)
C * GET DENSITY EXTREMA
        RMIN = 0.0
        RMAX = 0.0
        F000 = 0.0
        SXSQ = 0.0
        SUMX = 0.0
        DO I = 1, ITOP - 1, 2
          FFTX = FFT2(I)
          SXSQ = SXSQ + FFTX ** 2
          SUMX = SUMX + FFTX
          RMIN = MIN (RMIN, FFTX)
          RMAX = MAX (RMAX, FFTX)
        END DO
C * DETERMINE ACTUAL FLIP FRACTION AND FLIP DENSITY
        DENS = TERM * FACTOR * RMAX
        DO I = 1, ITOP -1, 2
          IF (TERM > 0) THEN
            IF (FFT2(I) < DENS) FFT2(I) = - FFT2(I)
          ELSE
            IF (FFT2(I) < FACTOR * RMAX) FFT2(I) = 0.0
          END IF
          FFT2(I + 1) = 0.0
        END DO
C * PEAK-SEARCH
        IF (IPR(614) > 0) THEN
            CALL PLA140 (FFT2, R3D, 0, RHOMIN, 1, NPK0, 1, 1)
            NPK = MIN (999, MIN (NPK0, NINT (PAR(98) / 14.0)))
            CALL PLA355 (0, LU60, NPK, M, N, RVAL)
          CALL PLA355 (1, LU61, NPK, M, N, RVAL)
        END IF
C * TRUNCATE HIGHEST DENSITIES
        IF (RVAL > PAR(468)) THEN
          DO I = 1, ITOP -1, 2
            IF (FFT2(I) > RMAX + 0.25 * RMIN) THEN
              FFT2(I) = 0.5 * FFT2(I)
            END IF
          END DO
        END IF
C * TRANSFORM BACK TO STRUCTURE FACTOR SPACE
        CALL GEN028 (FFT2, IPR(395), 3, 1)
C * DETERMINE SCALING FACTOR
        SUMFO = 0.0
        SUMFC = 0.0
        DO I = 3, ITOP, 2
          FOBS = ABS (FFT1(I))
          IF (FOBS > 0.0) THEN
            FCAL  = SQRT (FFT2(I) ** 2 + FFT2(I + 1) ** 2) / NGRID
            SUMFO = SUMFO + FOBS
            SUMFC = SUMFC + FCAL
          END IF
        END DO
        SCHAAL = SUMFC / SUMFO
        SUMDL  = 0.0
C * F000
        F000  = FFT2(1) / (SCHAAL * NGRID)
C * APPLY UPDATED PHASES TO FOBS
        FFT2(1) = 0.0
        FFT2(2) = 0.0
        DO 10 I = 3, ITOP, 2
          ISN = 1
          FOBS = FFT1(I)
          IF (FOBS /= 0.0) THEN
            IF (FOBS < 0.0) THEN
              FOBS = - FOBS
              ISN  = -1
            END IF
            ACAL = FFT2(I)     / (SCHAAL * NGRID)
            BCAL = FFT2(I + 1) / (SCHAAL * NGRID)
            FCAL = SQRT (ACAL ** 2 + BCAL ** 2)
            SUMDL = SUMDL + ABS (FOBS - FCAL)
C * SHIFT PHASES BY 90 DEGREES FOR WEAK REFLECTIONS
            SFT = ' '
            IF (PFLIP > 0.0) THEN
              IF (RVAL > 0.40 .AND. N > 100) THEN
                SFT = '  90'
                IF (FOBS < FOBSMIN) THEN
                  FFT2(I)     = - BCAL
                  FFT2(I + 1) =   ACAL * ISN
                  GO TO 10
                END IF
              END IF
            END IF
            FFT2(I)     = FOBS * ACAL / FCAL
            FFT2(I + 1) = FOBS * BCAL / FCAL
          ELSE
            FFT2(I)     = 0.0
            FFT2(I + 1) = 0.0
          END IF
   10   CONTINUE
C * REPORT STATUS AND RESULTS FOR THIS CYCLE
        RVAL  = SUMDL / SUMFO
        RMIN  = RMIN  / (2.0 * PAR(98))
        RMAX  = RMAX  / (2.0 * PAR(98))
        DELT  = DENS  / (2.0 * PAR(98))
        DELR  = RVAL0 - RVAL
        RVAL0 = RVAL
        IF (IWIN == 1) THEN
          IF (IPR(614) == 1) THEN
            VRT20 = 0.2
          ELSE
            VRT20 = VRT
            CALL PLA439 (0.0, SLINE, 80, 0.32, 0, 2, 1.0, VRT20)
          END IF
          WRITE (SLINE, 99991, IOSTAT = IOST)
     1      MTRY, N, NLOOP, DELT, SFT, RMIN, RMAX, NINT (F000), RVAL,
     2      DELR
          CALL PLA439 (0.0, SLINE, 80, 0.32, IPEN, 2, 1.0, VRT20)
          CALL GGIP (0.0, FLOAT (IPEN), 0.0, 0)
          XP = 1.0 + (HORS - 1.0) * LOG (FLOAT(N)) / LOG (FLOAT (NLOOP))
          YP = VRTY * (MIN (0.8, RVAL) - 0.1) / 0.7
          IF (IPR(614) == 0) THEN
            IF (N > 1) THEN
              CALL GGIP (XPOLD, YPOLD   , 0.0, 3)
              CALL GGIP (XP,    YP      , 0.0, 2)
            END IF
            XPOLD             = XP
            YPOLD             = YP
          ELSE
            IF (NCURVE < 5001) THEN
              NCURVE            = NCURVE + 1
              RCURVE(NCURVE, 1) = XP
              RCURVE(NCURVE, 2) = YP
              IF (RVAL < PAR(467) .AND. NCURC == 0) NCURC = NCURVE
            END IF
            CALL GGIP (0.0, 2.0, 0.0, 0)
            IF (NCURVE > 1) THEN
              CALL GGIP (RCURVE(1, 1), RCURVE(1, 2), 0.0, 3)
              DO I = 2, NCURVE
                IF (I == NCURC) CALL GGIP (0.0, 3.0, 0.0, 0)
                CALL GGIP (RCURVE(I, 1), RCURVE(I, 2), 0.0, 2)
              END DO
            END IF
          END IF
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
        WRITE (LU7, 99996, IOSTAT = IOST) LINE
C * CHECK FOR LOOP TERMINATION
        IF (N < NLOOP - 10) THEN
          IF (RVAL < 0.35) THEN
            IF (RVAL < PAR(467)) THEN
              IF (ABS (DELR) < 0.005) THEN
                ITEL = ITEL + 1
                IF (ITEL > 5) TERM = 0.0
                IF (ITEL > 20) GO TO 20
              ELSE
                ITEL = 0
              END IF
            ELSE
              IF (ABS (DELR) < 0.005) THEN
                MTEL = MTEL + 1
                IF (MTEL > 25) THEN
                  TERM = TERM * 0.5
                  MTEL = 0
                  ITEL = 0
                END IF
                IF (TERM < 0.01) TERM = 0.0
              ELSE
                MTEL = 0
                ITEL = 0
              END IF
            END IF
          END IF
        ELSE
          TERM = 0.0
          RETURN
        END IF
      END DO
   20 WRITE (LU6, 99996, IOSTAT = IOST) LINE
      IF (RVAL < PAR(466)) THEN
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_ads.ins',
     1        STATUS = 'UNKNOWN')
C * FINAL MAP
        CALL GEN028 (FFT2, IPR(395), 3, -1)
C * PEAK-SEARCH
        CALL PLA140 (FFT2, R3D, 0, RHOMIN, 1, NPK0, 1, 1)
        NPK = MIN (999, MIN (NPK0, NINT (PAR(98) / 14.0)))
        CALL PLA355 (0, LU60, NPK, M, N, RVAL)
        CALL PLA355 (0, LU61, NPK, M, N, RVAL)
        CLOSE (UNIT = LU61)
        CALL GEN129 (LU61, NAMEFIL(1:KNMFIL)//'_xor.bin')
        SPGR   = ' '
C * RUN ADDSYM
        KERR = 0
        IF (DOS) THEN
          CALL SPAWN (PLAPATH(1:IGBL(80))//' -N +0addsym.log '//
     1      NAMEFIL(1:KNMFIL)//'_ads.ins', LU6, .true., KERR)
        ELSE
          CALL SPAWN (PLAPATH(1:IGBL(80))//' -N '//
     1      NAMEFIL(1:KNMFIL)//'_ads.ins', LU6, .true., KERR)
        END IF
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_ads_pl.res',
     1      STATUS = 'UNKNOWN')
C * FILTER TO EXOR INPUT
        OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_xor.ins',
     1      STATUS = 'UNKNOWN')
        ISKIP = 0
   30   READ (LU61, 99996, IOSTAT = IOST) LINE
        IF (IOST == -1) GO TO 40
        IF (LINE(1:4) == 'TITL') THEN
          SPGR = LINE(39:45)
        ELSE IF (LINE(1:4) == 'UNIT') THEN
          ISKIP = 0
          WRITE (LU62, 99983, IOSTAT = IOST)
     1      (LMT(IENS(K), 1), K = 1, IAN)
          WRITE (LU62, 99982, IOSTAT = IOST)
     1      (NINT (CONT(IENS(L), M)), L = 1, IAN)
          GO TO 30
        ELSE IF (LINE(1:4) == 'SFAC') THEN
          ISKIP = 1
        END IF
        IF (ISKIP == 0) WRITE (LU62, 99996, IOSTAT = IOST) LINE
        GO TO 30
   40   CLOSE (UNIT = LU61, STATUS = 'DELETE')
        CLOSE (UNIT = LU62)
C * RUN EXOR
        REXOR = 0.0
        KERR  = 0
        IF (DOS) THEN
          CALL SPAWN (PLAPATH(1:IGBL(80))//' -E +0exor.log '//
     1      NAMEFIL(1:KNMFIL)//'_xor.ins', LU6, .true., KERR)
        ELSE
          CALL SPAWN (PLAPATH(1:IGBL(80))//' -E '//
     1      NAMEFIL(1:KNMFIL)//'_xor.ins', LU6, .true., KERR)
        END IF
C * GET RESULT FROM LOG FILE
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_xor_log',
     1        STATUS = 'UNKNOWN')
        DO
          READ (LU61, 99996, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          N = INDEX (LINE, 'RVAL=')
          IF (N /= 0) READ (LINE(13:18), 99998) REXOR
        END DO
        CLOSE (UNIT = LU61, STATUS = 'DELETE')
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_xor.res',
     1        STATUS = 'UNKNOWN')
        OPEN (LU62, FILE = NAMEFIL(1:KNMFIL)//'_ads.ins',
     1      STATUS = 'UNKNOWN')
        DO
          READ (LU61, 99996, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          WRITE (LU62, 99996, IOSTAT = IOST) LINE
        END DO
        CLOSE (UNIT = LU61, STATUS = 'DELETE')
        CLOSE (UNIT = LU62)
C * RUN ADDSYM
        KERR = 0
        IF (DOS) THEN
          CALL SPAWN (PLAPATH(1:IGBL(80))//' -N +0addsym.log '//
     1      NAMEFIL(1:KNMFIL)//'_ads.ins', LU6, .true., KERR)
        ELSE
          CALL SPAWN (PLAPATH(1:IGBL(80))//' -N  '//
     1      NAMEFIL(1:KNMFIL)//'_ads.ins', LU6, .true., KERR)
        END IF
        OPEN (LU61, FILE = NAMEFIL(1:KNMFIL)//'_ads_pl.res')
        NAT    = 0
        NCOUNT = 0
        DO
          READ  (LU61, 99996, IOSTAT = IOST) LINE
          IF (IOST /= 0) EXIT
          IF (LINE(1:4) == 'TITL') THEN
C * GET PROPOSED NEW SPGR NAME FROM TITL RECORD
            I = INDEX (LINE, 'New:') + 4
            SPGR = LINE(I:I + 6)
          ELSE IF (LINE(1:4) == 'FVAR') THEN
            NCOUNT = 1
          ELSE IF (LINE(1:4) == 'HKLF') THEN
            NCOUNT = 0
          ELSE
            NAT = NAT + NCOUNT
          END IF
          WRITE (LU63, 99996, IOSTAT = IOST) LINE
        END DO
        CLOSE (UNIT = LU61, STATUS = 'DELETE')
        IF (IWIN == 1) CALL PLA439 (0.0, PRBUF, 25, 0.25, 0, 1,
     1    HORS - 5.5, VRTY - 0.7)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        NSOLVED = NSOLVED + 1
          IDM     = 'SPGR '//SPGR
          CALL SGSM (0,  IDM, SGY, 0, LU6,  IERR)
          CALL SGSM (18, IDM, SGY, 0,   0,  IERR)
          NSP = NINT (SGY(1))
          IF (REXOR < RVMIN) THEN
            IF (NSP > NSPGR) THEN
              PRBUF(1:7) = SPGR
              NSPGR      = NSP
              NTEL       = 0
            END IF
          END IF
          IF (NSP > NSPGR) THEN
            IF (REXOR < RVMIN) THEN
              PRBUF(1:7) = SPGR
              NSPGR      = NSP
              RVMIN      = REXOR
              NSOLVMIN   = NSOLVED
              MFTRY      = MTRY
              NTEL       = 1
            END IF
          ELSE IF (NSP == NSPGR) THEN
            NTEL = NTEL + 1
            IF (REXOR < RVMIN) THEN
              RVMIN    = REXOR
              NSOLVMIN = NSOLVED
              MFTRY    = MTRY
            END IF
          END IF
        WRITE (PRBUF(8:49), 99980, IOSTAT = IOST)
     1     RVMIN, NTEL, NSOLVMIN, MFTRY
        IF (IWIN == 1 .AND. RVMIN < 1.0) THEN
          CALL PLA439 (0.0, PRBUF, 25, 0.25, 1, 1, HORS - 5.5,
     1                 VRTY - 0.7)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
C * REPORT REXOR AND SPACE GROUP
        IF (IWIN == 1) THEN
          WRITE (LINE, 99981, IOSTAT = IOST) NPK
          IF (REXOR > 0.0) THEN
            WRITE (LINE(5:10), 99998, IOSTAT = IOST) REXOR
              WRITE (LINE(11:), 99997, IOSTAT = IOST) NAT, SPGR
              WRITE(6, 99996) LINE
          END IF
          CALL PLA439 (0.0, LINE(1:23), 23, 0.32, IPEN, 2, 17.8, VRT)
          CALL GGIP (0.0, FLOAT (IPEN), 0.0, 0)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
      END IF
      RETURN
99998 FORMAT (F6.3)
99997 FORMAT (I4, 1X, A)
99996 FORMAT (A)
99991 FORMAT (I3, I5, '(', I5, ')', F6.3, A, 2F9.3, I5, F6.3, F7.3)
99983 FORMAT ('SFAC', 16(1X, A))
99982 FORMAT ('UNIT ', 2I5, 14I4)
99981 FORMAT (I4)
99980 FORMAT (F6.3, 3I4)
      END SUBROUTINE PLA352
 
      SUBROUTINE PLA353
      USE files
      USE parameters
      USE cchar
      USE xwdw
      IMPLICIT NONE
      IF (IWIN == 1) THEN
        CALL PLA439 (0.0, 'RefinemenT', 10, 2.5, 2, 10, 3.0, 12.0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      END IF
C * SHELXL ISO
      CALL PLA354 (0, LU61, LU62, '_res.res', '_shx.ins')
      CALL PLA354 (0, LU61, LU62, '_xor.hkl', '_shx.hkl')
      KERR = 0
      CALL SPAWN (SHLPATH(1:IGBL(110))//' '//
     1            NAMEFIL(1:KNMFIL)//'_shx', LU6, .true., KERR)
C * SHELXL ANISO
      CALL PLA354 (1, LU61, LU62, '_shx.res', '_shx.ins')
      KERR = 0
      CALL SPAWN (SHLPATH(1:IGBL(110))//' '//
     1            NAMEFIL(1:KNMFIL)//'_shx', LU6, .true., KERR)
C * DIFFOURIER
      KERR = 0
      CALL SPAWN (PLAPATH(1:IGBL(80))//' -D '//
     1            NAMEFIL(1:KNMFIL)//'_shx.res', LU6, .true., KERR)
C * AUTO RENAME
      CALL PLA354 (0, LU61, LU62, '_shx.res', '_shx.ins')
      KERR = 0
      CALL SPAWN (PLAPATH(1:IGBL(80))//' -R '//
     1            NAMEFIL(1:KNMFIL)//'_shx.ins', LU6, .true., KERR)
C * RUN HFIX
      CALL PLA354 (0, LU61, LU62, '_shx.res', '_shx.ins')
      KERR = 0
      CALL SPAWN (PLAPATH(1:IGBL(80))//' -f '//
     1            NAMEFIL(1:KNMFIL)//'_shx.ins', LU6, .true., KERR)
C * RUN SHELXL HATOMS
      CALL PLA354 (0, LU61, LU62, '_shx.new', '_shx.ins')
      KERR = 0
      CALL SPAWN (SHLPATH(1:IGBL(110))//' '//
     1            NAMEFIL(1:KNMFIL)//'_shx', LU6, .true., KERR)
C * RUN ORTEP
      KERR = 0
      CALL SPAWN (PLAPATH(1:IGBL(80))//' -a '//
     1            NAMEFIL(1:KNMFIL)//'_shx.cif', LU6, .true., KERR)
 
      RETURN
      END SUBROUTINE PLA353
 
      SUBROUTINE PLA354 (MODE, LUA, LUB, EXTENA, EXTENB)
      USE files
      USE cchar
      INTEGER          :: MODE, LUA, LUB
      CHARACTER(len=8) :: EXTENA, EXTENB
      CHARACTER(len=4) :: KEY
      OPEN (LUA, FILE = NAMEFIL(1:KNMFIL)//EXTENA, STATUS = 'UNKNOWN')
      OPEN (LUB, FILE = NAMEFIL(1:KNMFIL)//EXTENB, STATUS = 'UNKNOWN')
      DO
        READ  (LUA, 99999, IOSTAT = IOST) KEY, LINE
        IF (IOST /= 0) EXIT
        IF (MODE == 1) THEN
          IF (KEY == 'L.S.') WRITE (LUB, 99998, IOSTAT = IOST) 1000
        END IF
        WRITE (LUB, 99999, IOSTAT = IOST) KEY, LINE
      END DO
      CLOSE (UNIT = LUA)
      CLOSE (UNIT = LUB)
      RETURN
99999 FORMAT (2A)
99998 FORMAT ('ANIS', I5)
      END SUBROUTINE PLA354
 
      SUBROUTINE PLA355 (MODE, LU, NPK, M, N, RVAL)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cflip
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: K1
      INTEGER                  :: LU
      INTEGER                  :: KEL
      INTEGER                  :: NPK
      INTEGER                  :: MODE
      INTEGER                  :: KNM1
      INTEGER                  :: IGBL8
      INTEGER                  :: IANSAVE
      INTEGER, DIMENSION(NP12) :: IPRSAVE
      REAL,    DIMENSION(NP13) :: PARSAVE
      REAL                     :: RVAL
      REAL                     :: SHORT
      REAL                     :: USIMUL
      CHARACTER(len=10)        :: PROJ
      CHARACTER(len=80)        :: NAME1
      CHARACTER(len=43)        :: FORMA
      FORMA(1:43) = '(A,I1,4X,I3,3F10.3,'' 11'',F10.4,'' ! '',F12.2)'
C * OPEN FOR SHOW MODE
      IF (MODE == 1) THEN
        OPEN (LU, FILE = 'satom.spf', STATUS = 'UNKNOWN')
      END IF
C * SELECT DEFAULT ATOM-TYPE
      DO K = 1, IAN
        IF (LMT(IENS(K), 1) == ' C') THEN
          KEL = K
          K1  = 2
          GO TO 10
        END IF
      END DO
      DO K = 1, IAN
        IF (LMT(IENS(K), 1) /= ' H') THEN
          KEL = K
          K1  = 1
          IF (LMT(IENS(K), 1)(1:1) == ' ') K1 = 2
          GO TO 10
        END IF
      END DO
   10 WRITE (LU, 99998, IOSTAT = IOST) MTRY, N, RVAL
      WRITE (LU, 99999, IOSTAT = IOST) PAR(17), (PAR(100 + I), I = 1, 6)
      WRITE (LU, 99992, IOSTAT = IOST) (PAR(106 + I), I = 1, 6)
      WRITE (LU, 99991, IOSTAT = IOST)  - IABS (IPR(242))
      WRITE (LU, 99990, IOSTAT = IOST) (LMT(IENS(K), 1), K = 1, IAN)
      WRITE (LU, 99995, IOSTAT = IOST)
     1  (NINT (CONT(IENS(L), M)), L = 1, IAN)
      WRITE (LU, 99993, IOSTAT = IOST)
      DO J = 1, NPK
        USIMUL = 0.05 * SQRT (XXO(J, 4) / XXO(1, 4))
        IF (J < 10) THEN
          FORMA(5:5) = '1'
        ELSE IF (J. LT. 100) THEN
          FORMA(5:5) = '2'
        ELSE IF (J < 1000) THEN
          FORMA(5:5) = '3'
        END IF
        WRITE (LU, FORMA, IOSTAT = IOST)
     1    LMT(IENS(KEL), 1)(K1:2), J, KEL,
     2    (XXO(J, K), K = 1, 3), USIMUL,  XXO(J, 4)
      END DO
      WRITE (LU, 99994, IOSTAT = IOST)
C * SHOW MODE
      IF (MODE == 1) THEN
        CLOSE (UNIT = LU61)
        IGBL(3)  = 8
        IGBL(92) = 1
        IGBL(50) = 1
        DO I = 1, NP12
          IPRSAVE(I) = IPR(I)
        END DO
        DO I = 1, NP13
          PARSAVE(I) = PAR(I)
        END DO
        IANSAVE = IAN
        OPEN (LU23, FILE='satom.def', STATUS = 'UNKNOWN')
        SHORT = MIN (PAR(101), PAR(102), PAR(103))
        IF (SHORT == PAR(101)) THEN
          IF (PAR(102) >= PAR(103)) THEN
            PROJ = 'XO'
          ELSE
            PROJ = 'XO ZROT 90'
          END IF
          WRITE (LU23, 99997, IOSTAT = IOST)
     1      -5.0, 5.0, -0.01, 1.01, -0.01, 1.01
        ELSE IF (SHORT == PAR(102)) THEN
          IF (PAR(103) > PAR(101)) THEN
            PROJ = 'YO'
          ELSE
            PROJ = 'YO ZROT 90'
          END IF
          WRITE (LU23, 99997, IOSTAT = IOST)
     1      -0.01, 1.01, -5.0, 5.0, -0.01, 1.01
        ELSE
          IF (PAR(101) > PAR(102)) THEN
            PROJ = 'ZO'
          ELSE
            PROJ = 'ZO ZROT 90'
          END IF
          WRITE (LU23, 99997, IOSTAT = IOST)
     1      -0.01, 1.01, -0.01, 1.01, -5.0, 5.0
        END IF
        WRITE (LU23, 99996, IOSTAT = IOST) PROJ
        CLOSE (UNIT = LU23)
        CLOSE (UNIT = LU1)
        NAME1   = NAMEFIL
        KNM1    = KNMFIL
        IGBL8   = IGBL(8)
        IGBL(8) = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL PLUTON (0)
        IGBL(8) = IGBL8
        NAMEFIL = NAME1
        KNMFIL  = KNM1
        CLOSE (UNIT = LU1)
        DO I = 1, NP12
          IPR(I) = IPRSAVE(I)
        END DO
        DO I = 1, NP13
          PAR(I) = PARSAVE(I)
        END DO
        IAN = IANSAVE
        CLOSE (UNIT = LU1)
      END IF
      RETURN
99999 FORMAT ('CELL ', F9.5, 3F10.4, 3F10.3)
99998 FORMAT ('TITL F', I2.2, I3.3, ' R =', F5.2)
99997 FORMAT ('OMIT OUTSIDE', 6F6.3)
99996 FORMAT ('JOIN RADII UNIQUE', /, 'SET IPR 231 1', /,
     1        'VIEW ', A, /, 'UNITCELL', /, 'STRAW', /,
     2        'BOX OFF', /, 'PACK RANGE -0.5 1.5 -0.5 1.5 -0.5 1.5', /,
     3        'PLOT')
99995 FORMAT ('UNIT ', 2I5, 14I4)
99994 FORMAT ('HKLF 4', /, 'END')
99993 FORMAT ('FVAR 1.0')
99992 FORMAT ('ZERR 1 ', 3F10.4, 3F10.3)
99991 FORMAT ('LATT ', I5)
99990 FORMAT ('SFAC', 16(1X, A))
      END SUBROUTINE PLA355
 
      SUBROUTINE PLA360
C * Subroutine Analyses the Refinement results with a Difference Fourier
      USE files
      USE parameters
      USE reflex
      USE pl127
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: M
      INTEGER :: N
      INTEGER :: M1
      INTEGER :: M2
      INTEGER :: M3
      INTEGER :: HMAX
      INTEGER :: KMAX
      INTEGER :: LMAX
      INTEGER :: NSEL
      INTEGER :: NREF
      INTEGER :: IADR
      INTEGER :: IBOT
      INTEGER :: ITOP
      INTEGER :: NGRID
      INTEGER :: NREFA
      INTEGER :: NREFB
      REAL    :: FO
      REAL    :: FC
      REAL    :: SCF
      REAL    :: ACAL
      REAL    :: BCAL
      REAL    :: SIGF
      REAL    :: SUMFO
      REAL    :: SUMFC
C * PLA360 - PLA024 (CONNECTED COORD SET)
C *        - PLA023 (EXPAND COORD SET)
C *        - PLA133 (GET REFNS, H-,K-,LMAX) - PLA134 - PLA132
C *        - PLA130                         - PLA136 - PLA137
C * CHECK FOR NON-ZERO NUMBER OF ATOMS
      IF (IPR(37) > 0) THEN
C * ANALYSES OF ADP's AND OUTPUT OF CONNECTED SET
        IF (IPR(85) == 0) CALL PLA024
C * LOAD AND EXPAND COORDINATE DATA TO UNIT CELL CONTENTS
C * (EXCLUDING BRAVAIS CENTERING)
        CALL PLA023 (0)
C * TOTAL NUMBER OF OF EXPANDED ATOM SET
C * TOTAL NUMBER OF SYMMETRY OPERATIONS
        NSYM  = IPR(48)
C * GET NUMBER OF OPERATIONS EXCLUDING INVERSION AND BRAVAIS CENTERING
        NSYMH = IPR(255)
C * GET CENTER OF SYMMETRY NUMBER
        ICNTR = IPR(257)
 
C * GET REFLECTION DATA
C * IGBL(15) =  1 - fcf/FCF
C *          =  0 - hkl/HKL
C *          = -1 - no hkl or fcf reflection file association found
C * CHECK FOR TWINNING (i.e. IPR(619) = 1)
        IF (IGBL(15) >= 0 .AND. IPR(619) == 0) THEN
          PAGET = 'DiffFour'
          IF (IGBL(63) > 0) THEN
            CALL PLA262 (0)
            WRITE (LU7, 99995, IOSTAT = IOST)
          END IF
          NREF  = 0
          HMAX  = -999
          KMAX  = -999
          LMAX  = -999
C * GET NR OF REFLECTIONS (SHELX(L) HKLF4 OR FCF FORMAT
C * GET HMAX, KMAX, LMAX
C * WRITE REFLECTIONS TO LU27
          CALL PLA133 (NREF, HMAX, KMAX, LMAX)
          IF (IPR(2) == 0) THEN
C * GET SUITABLE FFT-GRID
            DO I = 1, 3
              DO J = 4, 8
                IPR(394 + I) = 2**J
                IF (PAR(100 + I) * 3.0 < IPR(394 + I)) EXIT
              END DO
            END DO
            IF (IPR(395) <= 2 * HMAX) IPR(395) = IPR(395) * 2
            IF (IPR(396) <= 2 * KMAX) IPR(396) = IPR(396) * 2
            IF (IPR(397) <= 2 * LMAX) IPR(397) = IPR(397) * 2
            M1 = IPR(395)
            M2 = IPR(396)
            M3 = IPR(397)
            IF (IGBL(63) > 0) THEN
              WRITE (LU6, 99998, IOSTAT = IOST) (IPR(I), I = 395, 397)
            END IF
C * ADAPT GRID-PARAMETERS TO NEW FFT GRID
            NGRID   = M1 * M2 * M3
            PAR(79) = PAR(98) / NGRID
C * GET/STORE REFLECTION DATA - SHELX(L) HKLF 4 FORMAT OR REFL.CIF
            CALL PLA130 (HMAX, KMAX, LMAX, NREF, IADR, NREFA, NREFB)
C * NO DIFMAP FOR SQUEEZE (TO BE CHANGED)
C * CHECK FOR ERROR RETURN
            IF (NREFB > 0) THEN
C * GET SCALING AND R- FACTOR FOR NON-FCF FILE
C * (OR REQUESTED WITH IPR(516))
              SCF = 1.0
              IF (IGBL(9) /= 1 .OR. IPR(516) /= 0) THEN
                M     = 0
                SUMFO = 0.0
                SUMFC = 0.0
                DO N = 1, NREFB
                  IF (VOID(M + 1) > 6.0 * VOID(M + 2)) THEN
                    ACAL  = VOID(M + 3)
                    BCAL  = VOID(M + 4)
                    SUMFO = SUMFO + VOID(M + 1)
                    SUMFC = SUMFC + SQRT (ACAL**2 + BCAL**2)
                  END IF
                  M = M + NP69
                END DO
                SCF = SUMFC / SUMFO
              END IF
C * GENERATE DIFFERENCE FOURIER COEFFICIENTS
              M    = 0
              NSEL = 0
              DO N = 1, NREFB
                FO   = VOID(M + 1) * SCF
                ACAL = VOID(M + 3)
                BCAL = VOID(M + 4)
                FC   = SQRT (ACAL**2 + BCAL**2)
                SIGF = MAX (VOID(M + 2) * SCF, 0.0001)
                IF (FC > 2 * IPR(515) * SIGF .AND. FC /= 0.0) THEN
                  VOID(M + 7) = FO * ACAL / FC - ACAL
                  VOID(M + 8) = FO * BCAL / FC - BCAL
                  NSEL        = NSEL + 1
                ELSE
                  VOID(M + 7) = 0.0
                  VOID(M + 8) = 0.0
                END IF
                VOID(M + 5) = 0.0
                VOID(M + 6) = 0.0
                M           = M + NP69
              END DO
              IF (IGBL(63) > 0) THEN
                WRITE (LU6, 99997, IOSTAT = IOST) SCF, NSEL,
     1            2 * IPR(515)
                CALL PLA262 (3)
                WRITE (LU7, 99997, IOSTAT = IOST) SCF, NSEL,
     1            2 * IPR(515)
              END IF
C * FFT
              IBOT = NREFA * NP69
              ITOP = IBOT + NGRID * 2
C * CHECK FOR SCRATCH OVERRUN (FFT + R3D)
              IF (ITOP + 3 * (M1 + 2) * (M2 + 2) > IADR) THEN
                IF (IGBL(63) > 0) THEN
                  WRITE (LU6, 99996, IOSTAT = IOST) 2, CHAR (IPR(223))
                  WRITE (LU7, 99996, IOSTAT = IOST) 2, CHAR (IPR(223))
                END IF
              ELSE
C * SET CUT-OFF DENSITY, TEST FOR FCF-CHECK MODE
                IF (IGBL(129) <= 0) THEN
                  PAR(269) = 0.25
                ELSE
                  PAR(269) = 0.05
                END IF
C * CALCULATE DIFFERENCE DENSITY MAP
                CALL PLA142 (-3, VOID(1), VOID(IBOT + 1),
     1                         VOID(ITOP + 1), NREFB, 0.0)
                IF (IGBL(63) > 0) THEN
                  IF (PAR(329) /= 0.0 .AND. PAR(330) /= 0.0) THEN
                    CALL PLA262 (1)
                    WRITE (LU6, 99999, IOSTAT = IOST)
     1                PAR(329), PAR(330), PAR(269)
                    WRITE (LU7, 99999, IOSTAT = IOST)
     1                PAR(329), PAR(330), PAR(269)
                  END IF
                END IF
              END IF
            END IF
          END IF
          IPR(1) = 1
        END IF
      END IF
      RETURN
99999 FORMAT ('PeaksCloseToAtoms: Rho(min) =', F10.2, ', Rho(max) =',
     3        F10.2, ', RhoCutOff =', F6.2)
99998 FORMAT (':: FFT-grid:', 11X,  3I5)
99997 FORMAT (/, ':: Fo-scale =', E14.6, /,
     1        ':: # Selected Refl.=', I6,
     2       ', with Fo > ', I2, ' * sig(Fo)', /)
99996 FORMAT (/, 'F: Scratch Array Overrun Code', I2, ' (Fatal)', /,
     1        '    Use larger program version i.e. larger NVDR', A, /)
99995 FORMAT ('Analysis of the (Final) Difference Fourier Map', /,
     1        80('='))
      END SUBROUTINE PLA360
 
      SUBROUTINE PLA361 (DMX, N1, N2, IPOSNEG)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: N1
      INTEGER          :: N2
      INTEGER          :: NS
      INTEGER          :: NAT
      INTEGER          :: NPK
      INTEGER          :: NSYM
      INTEGER          :: IDUM
      INTEGER          :: JDUM
      INTEGER          :: JTEST
      INTEGER          :: NPKM1
      INTEGER          :: IPOSNEG
      REAL             :: DIST
      REAL             :: DMX
      REAL             :: XDENS
      CHARACTER(len=6) :: MAXMIN
      IF (N2 >= N1) THEN
C * GET NUMBER OF SYMMETRY OPERATIONS
        NSYM = IPR(48)
C * GET NUMBER OF INDEPENDENT ATOMS
        NAT  = IPR(37)
C * FIND DISTANCES BETWEEN ATOMS - ROLLETT, COMP. METH. IN CRYST. 1965
        V2(1) = DMX / (PAR(101) * SIN (PAR(105) / RGBL(6)) * PAR(121))
        V2(2) = DMX / (PAR(102) * SIN (PAR(106) / RGBL(6)) * PAR(119))
        V2(3) = DMX / (PAR(103) * SIN (PAR(104) / RGBL(6)) * PAR(120))
        IF (IPOSNEG > 0) THEN
          MAXMIN   = 'Maxima'
          REWIND (UNIT = LU2, IOSTAT = IOST)
          IF (IOST /= 0) CALL GEN148 (LU2, 1)
        ELSE
          MAXMIN   = 'Minima'
        END IF
        WRITE (LINE, 99999, IOSTAT = IOST) MAXMIN, DMX,
     1      MAX (0.10, PAR(269)) * IPOSNEG
        IF (IGBL(129) /= 0) THEN
          CALL PRINTX (LU13, LINE, 1, 0)
          WRITE (LU13, 99995)
          WRITE (LU13, 99998)
          WRITE (LU13, 99995)
        END IF
        IF (IGBL(63) > 0) THEN
          CALL PLA262 (4)
          CALL PRINTX (LU6, LINE, 0, 0)
          CALL PRINTX (LU7, LINE, 0, 0)
          WRITE (LINE, 99995)
          CALL PRINTX (LU6, LINE, 0, 0)
          CALL PRINTX (LU7, LINE, 0, 0)
          WRITE (LINE, 99998)
          CALL PRINTX (LU6, LINE, 0, 0)
          CALL PRINTX (LU7, LINE, 0, 0)
          WRITE (LINE, 99995)
          CALL PRINTX (LU6, LINE, 0, 0)
          CALL PRINTX (LU7, LINE, 0, 0)
        END IF
C * LOOP OVER ATOMS
        DO I = 1, NAT
          CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0)
          NPK = 0
C * LOOP OVER ADDITIONAL MAXIMA
          DO J = N1, N2
            DO N = 1, NSYM
              DO K = 1, 3
                SGY(K)     = XXO(J, K)
                SGY(K + 3) = 0.0
              END DO
              NS = N
              CALL SGSM (3, LINE, SGY, NS, LU6, IERR)
              K = 1
              GO TO 20
   10         SGY(6 + K) = SGY(6 + K) - 1.0
   20         IF ((XXO(I, K) - SGY(6 + K)) <= V2(K)) GO TO 10
              GO TO 40
   30         IF (ABS (XXO(I, K)  - SGY(6 + K)) <= V2(K)) THEN
                K = K + 1
                IF (K > 3) THEN
                  DO L = 1, 3
                    V3(L) = XXO(I, L) - SGY(6 + L)
                  END DO
                  CALL GEN002 (2, OR, V3, V4, DIST)
                  IF (DIST < DMX) THEN
                    IF (NPK == 0) THEN
                      JTEST = 0
                    ELSE
                      JTEST = IATC(NPK)
                    END IF
                    IF (J /= JTEST) THEN
                      NPK       = NPK + 1
                      DATC(NPK) = DIST
                      IATC(NPK) = J
                    ELSE
                      IF (DIST < DATC(NPK)) DATC(NPK) = DIST
                    END IF
                  END IF
                  K = K - 1
                  GO TO 40
                END IF
                GO TO 20
              END IF
   40         SGY(6 + K) = SGY(6 + K) + 1.0
              IF ((XXO(I, K)  - SGY(6 + K)) >= - V2(K)) GO TO 30
              K = K - 1
              IF (K /= 0) GO TO 40
            END DO
          END DO
          CALL GEN036 (DATC, IATC, 1, NPK)
          NPKM1 = MIN (NPK, MIN (4, 9))
          IF (NPKM1 > 0) THEN
            DO J = 1, NPKM1
              XDENS = IPOSNEG * XXO(IATC(J), 4) / PAR(98)
              WRITE (NAMS(J, 1), 99996, IOSTAT = IOST) XDENS
            END DO
            WRITE (LINE, 99997, IOSTAT = IOST)
     1        NQ1(1:11), (IATC(J) - N1 + 1, NAMS(J, 1)(1:6),
     2        DATC(J), J = 1, NPKM1)
            IF (IGBL(129) /= 0)
     1        CALL PRINTX (LU13, LINE, 0, 0)
            IF (IGBL(63) > 0) THEN
              CALL PLA262 (1)
              CALL PRINTX (LU6, LINE, 0, 0)
              CALL PRINTX (LU7, LINE, 0, 0)
            END IF
          END IF
        END DO
        IF (IGBL(63) > 0) THEN
          CALL PLA262 (1)
          WRITE (LINE, 99994)
          CALL PRINTX (LU6, LINE, 0, 0)
          CALL PRINTX (LU7, LINE, 0, 0)
        END IF
      END IF
      RETURN
99999 FORMAT ('Density ', A, ' within', F5.1, ' Angstrom from Atoms',
     1 ' (CutOff level =', F9.2, ' eA-3)')
99998 FORMAT ( 'Atom', 7X, 4(3X, '# e/A^3   Ang '))
99997 FORMAT (A, 4(I4, A, F6.2, ':'))
99996 FORMAT (F6.2)
99995 FORMAT (80('='))
99994 FORMAT (' ')
      END SUBROUTINE PLA361
 
      SUBROUTINE PLA362 (FFT)
C * ANALYSE DIFFERENCE MAP GRID DENSITY DISTRIBUTION
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER, PARAMETER             :: NPOINT = 200
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: M
      INTEGER                        :: N
      INTEGER                        :: M1
      INTEGER                        :: M2
      INTEGER                        :: M3
      INTEGER                        :: MM
      INTEGER                        :: LOC
      INTEGER                        :: NAT
      INTEGER                        :: IHAT
      INTEGER                        :: NSTATM
      INTEGER, DIMENSION(NPOINT + 1) :: NSTAT
      REAL                           :: D
      REAL                           :: V
      REAL                           :: RHO
      REAL                           :: FFTI
      REAL                           :: AVER
      REAL                           :: XMAX
      REAL                           :: XMIN
      REAL                           :: SMXI
      REAL                           :: SMXIK
      REAL                           :: SIGMA
      REAL, DIMENSION(*)             :: FFT
      CHARACTER(len=60)              :: BALK
      CHARACTER(len=NP64)            :: LAB
      CALL GEN097 (NSTAT, 1, NPOINT + 1, 0)
      NAT   = IPR(37)
      V     = PAR(98)
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      N     = 2 * M1 * M2 * M3
      IHAT  = 0
      XMIN  = 0.0
      XMAX  = 0.0
      SMXI  = 0.0
      SMXIK = 0.0
 
C * REPORT MIN/MAX RESIDUAL DENSITY DISTRIBUTION
      DO I = 1, N, 2
        FFTI  = FFT(I) / V
        SMXI  = SMXI  + FFTI
        SMXIK = SMXIK + FFTI**2
        IF (FFTI > XMAX) XMAX = FFTI
        IF (FFTI < XMIN) XMIN = FFTI
        M = NINT (FFTI * 20) +  NPOINT / 2 + 1
        IF (M > 0 .AND. M < NPOINT + 2) NSTAT(M) = NSTAT(M) + 1
      END DO
      AVER  = 2 * SMXI / N
      SIGMA = SQRT (2 * SMXIK / N + AVER**2)
      WRITE (LU13, 99999, IOSTAT = IOST) XMIN, XMAX
C * REPORT RESIDUAL DENSITY (+/-) ON ATOM SITES
      MM  = 0
      LOC = 0
      DO I = 1, NAT
        J = I
        CALL PLA363 (J, LAB, LOC, IHAT)
        RHO = FFT(LOC - 1) / PAR(98)
        IF (ABS (RHO) > 0.25) THEN
          MM = MM + 1
          IF (MM == 1) THEN
            WRITE (LU13, 99996)
          END IF
          WRITE (LU13, 99995) LAB, RHO
C * ALERT _977 - NEGATIVE DENSITY ON H-POSITION (Check for NoSpherA2, MOPRO)
          IF (IHAT == 1) THEN
            IF (IPR(775) == 0 .AND. IPR(725) /= 9) THEN
              CALL PLA236 (977, 2, -RHO, RHO, LAB, ' ')
            ELSE
              CALL PLA236 (977, 2, -999.0, RHO, LAB, ' ')
            END IF
          END IF
        END IF
      END DO
      IF (MM > 0) WRITE (LU13, 99994)
C * REPORT DIFFERENCE MAP DENSITY DISTRIBUTION
      WRITE (LU13, 99998, IOSTAT = IOST) AVER, SIGMA
      NSTATM = 0
      DO I = 1, NPOINT + 1
        IF (NSTAT(I) > NSTATM) NSTATM = NSTAT(I)
      END DO
      DO I = 1, NPOINT + 1
        N = I - (NPOINT / 2 + 1)
        D = N * 0.05
        K = NINT (SQRT (FLOAT (NSTAT(I))) * 60.0 /
     1      SQRT (FLOAT (NSTATM)))
        DO M = 1, 60
          IF (M > K) THEN
            BALK(M:M) = ' '
          ELSE
            BALK(M:M) = '*'
          END IF
        END DO
        IF (D > XMIN - 0.1 .AND. D < XMAX + 0.1) THEN
          WRITE (LU13, 99997, IOSTAT = IOST) D, NSTAT(I), BALK
        END IF
      END DO
      RETURN
99999 FORMAT (/, 'Section 10:', /, 80('='), /,
     1 'Analysis of Difference Map Grid Point Density - (MIN =',
     2 F6.2, ', MAX = ', F6.2, ' eA-3)', /, 80('='))
99998 FORMAT ('Frequency Plot Sqrt(Frequency) - Average =', F7.3,
     4 ', Sigma =', F7.3, ' eA-3', /, 79('='), /,
     5 31X, 'Note: F(obs) from FCF and F(calc) from CIF model')
99997 FORMAT (F6.2, I10, 1X, A)
99996 FORMAT ('Atomic sites with Residual Density Maxima/Minima',
     1 ' > 0.25 eA-3, (misplaced H''s?)', /, 80('-'))
99995 FORMAT (A, 1X, F8.2, ' eA-3')
99994 FORMAT (80('='))
      END SUBROUTINE PLA362
 
      SUBROUTINE PLA363 (I, NQQ, LOC, IHAT)
      USE parameters
      USE plato
      USE sgxyz
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: M1
      INTEGER             :: M2
      INTEGER             :: M3
      INTEGER             :: LOC
      INTEGER             :: IHAT
      INTEGER             :: IDUM
      INTEGER             :: JDUM
      INTEGER             :: IX
      INTEGER             :: IY
      INTEGER             :: IZ
      REAL                :: X
      REAL                :: Y
      REAL                :: Z
      CHARACTER(len=NP64) :: NQQ
      CALL GEN048 (-1, IFG(1, I), 7, IHAT)
      CALL PLA047 (LABA(I), NQQ, IDUM, JDUM, IPR(71), IGBL(55), 0,
     1  1 - IGBL(55))
      M1  = IPR(395)
      M2  = IPR(396)
      M3  = IPR(397)
      X   = MOD (10.0 + XXO(I, 1), 1.0)
      Y   = MOD (10.0 + XXO(I, 2), 1.0)
      Z   = MOD (10.0 + XXO(I, 3), 1.0)
      IX  = MOD (NINT (X * M1), M1)
      IY  = MOD (NINT (Y * M2), M2)
      IZ  = MOD (NINT (Z * M3), M3)
      LOC = 2 * ((IZ * M2 + IY) * M1 + IX + 1)
      RETURN
      END SUBROUTINE PLA363
 
      MODULE normal
      SAVE
      INTEGER                      :: NB
      INTEGER                      :: MM
      INTEGER                      :: MZ
      INTEGER                      :: IND
      INTEGER                      :: NZR
      INTEGER                      :: MULT
      INTEGER                      :: NSYM
      INTEGER                      :: KSYS
      INTEGER                      :: LATT
      INTEGER                      :: NREF
      INTEGER                      :: ICENT
      INTEGER, DIMENSION(2, 3, 24) :: IS
      INTEGER, DIMENSION(5)        :: NST
      REAL                         :: TH
      REAL                         :: EN
      REAL                         :: ER
      REAL                         :: SC
      REAL                         :: UT
      REAL                         :: BT
      REAL                         :: THM
      REAL                         :: PTS
      REAL                         :: DEL
      REAL                         :: FLGK
      REAL                         :: TMUL
      REAL                         :: SLOPE
      REAL                         :: RHOMAX
      REAL,    DIMENSION(10)       :: EE
      REAL,    DIMENSION(25, 9)    :: ZT
      REAL,    DIMENSION(3, 24)    :: TS
      REAL,    DIMENSION(142)      :: GIW
      REAL,    DIMENSION(10, 5)    :: VST
      REAL,    DIMENSION(50)       :: DCV
      REAL,    DIMENSION(30)       :: AVR
      REAL,    DIMENSION(8)        :: SCAL
      REAL,    DIMENSION(30)       :: FLGD
      REAL,    DIMENSION(30)       :: FLGW
      END MODULE normal
 
      SUBROUTINE PLA370 (MODE)
C * WILSON-PLOT & E-STATISTICS ROUTINE (MODELLED ON PROGRAM NORMAL)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE normal
      USE sgxyz
      IMPLICIT NONE
      INTEGER                              :: I
      INTEGER                              :: J
      INTEGER                              :: K
      INTEGER                              :: L
      INTEGER                              :: M
      INTEGER                              :: N
      INTEGER                              :: KL
      INTEGER                              :: KN
      INTEGER, SAVE                        :: NAT
      INTEGER                              :: MODE
      INTEGER                              :: IYUNK
      REAL                                 :: T
      REAL                                 :: TT
      REAL                                 :: FNCH
      REAL,             DIMENSION(NP10, 9) :: SFC
      DOUBLE PRECISION                     :: FZ
      CHARACTER(len=1)                     :: ICH
      CHARACTER(len=2)                     :: ACH
      CHARACTER(len=9)                     :: NCH
      CHARACTER(len=2), DIMENSION(NP10)    :: NN
C * TEST FOR FORMULA PRESENT
      IF (IAN == 0) RETURN
      IWIN = IGBL(25) * IGBL(32)
      HORS = 26.0
      VERT = 19.5
C * CREATE MERGED UNIQUE REFLECTION FILE
      IPR(408) = 0
      IPR(392) = 0
      IPR(393) = 1
      IPR(220) = 0
      CALL PLA145 (0)
      CALL PLA262 (0)
      WRITE (LU7, 99999)
C * SET UP INITIAL VALUES
      RHOMAX = 0.0
      TH     = 1.0
      EN     = 1.2
      ER     = 0.3
      MZ     = 100
      MM     = 0
      NSYM   = 0
      NB     = 0
      BT     = 0.0
C * LOAD/LIST SYMMETRY
      CALL PLA371
C * LOAD SFAC/UNIT CONTENT
      IF (IABS (IGBL(8)) == 3) THEN
        ICH = RLWS(5)(1:1)
        IF (ICH == CHAR(32) .OR. ICH == CHAR(39)) RETURN
        CALL GEN020 (1, RLWS(5), 1, NP52)
        M = 0
        DO
          K   = 0
          ACH = '  '
          L   = 0
          NCH = '         '
          DO I = M + 1, NP52
            ICH = RLWS(5)(I:I)
            DO J = 65, 90
              IF (ICH == CHAR (J)) THEN
                K = K + 1
                IF (K == 1) ACH(K + 1:K + 1) = ICH
                IF (K == 2) THEN
                  ACH(1:1) = ACH(2:2)
                  ACH(2:2) = ICH
                  CALL GEN020 (-1, ACH, 2, 2)
                END IF
                EXIT
              END IF
            END DO
            IF (ICH == '.') THEN
              L = L + 1
              NCH(L:L) = ICH
            ELSE
              DO J = 48, 57
                IF (ICH == CHAR (J)) THEN
                  L = L + 1
                  NCH(L:L) = ICH
                  EXIT
                END IF
              END DO
            END IF
            IF (ICH == CHAR (32) .OR. ICH == CHAR (39)) THEN
              IF (L == 0) NCH = '1'
              READ (NCH, *) FNCH
              DO N = 1, IAN
                IF (ACH == LMT(N, 1)) THEN
                  CONT(N, 3) = FNCH
                  EXIT
                END IF
              END DO
              M = I
              EXIT
            END IF
          END DO
          IF (ICH == CHAR (39)) THEN
            EXIT
          END IF
        END DO
      END IF
      DO I = 1, IAN
        NN(I) = LMT(IENS(I), 1)
        NWX(I) = NINT (CONT(IENS(I), 3))
        K     = (IEN(IENS(I)) - 1) * 19
        DO J = 1, 9
          SFC(I, J) = SFAC(K + J)
        END DO
      END DO
      NAT = 0
      DO I = 1, IAN
        NOX(I) = INT (SFC(I, 1) + SFC(I, 3) + SFC(I, 5) + SFC(I, 7)
     1        + SFC(I, 9) + 0.5)
        IF (NOX(I) /= 1) NAT = NAT + NWX(I)
      END DO
      WRITE (LU7, 99998) (NN(I), NWX(I), NOX(I), (SFC(I, J), J = 1, 9),
     1  I = 1, IAN)
      DO I = 1, 142
        T      = 0.01 * FLOAT (I - 1)
        TT     = T * T
        GIW(I) = 0.0
        DO J = 1, IAN
          FZ = DBLE (SFC(J, 9))
          DO K = 1, 7, 2
            FZ = FZ + DBLE (SFC(J, K)) * DEXP (-DBLE (SFC(J, K + 1))
     1         * DBLE(TT))
          END DO
          GIW(I) = GIW(I) + SNGL (FZ * FZ) * FLOAT (NWX(J))
        END DO
      END DO
C * READ REFLECTION DATA FROM BINARY FILE
      CALL PLA372
      IF (NREF == 0) RETURN
C * OBTAIN SUMS FOR WILSON PLOT AND FIT LEAST SQUARES STRAIGHT LINE
      CALL PLA373
C * PLOT WILSON CURVE AND LEAST SQUARES STRAIGHT LINE
      CALL PLA374
      BT = 2.0 * BT
C * CALCULATE SCALE FACTORS FOR APPROPRIATE REFLECTION GROUPS
      CALL PLA375
      CALL PLA376
      WRITE (GRAPH(5)(20:32), '(A, '' - '')') JID(1:10)
      WRITE (GRAPH(7)(20:30 + KNMFIL + KXT + 1), '(''FormData = '', A)')
     1  FNLU1(1 : KNMFIL + KXT + 1)
      WRITE (GRAPH(9)(20:30 + KNM16), '(''ReflData = '', A)')
     1  FNLU16(1 : KNM16)
      IF (IABS (IGBL(8)) == 3) THEN
        IYUNK = INDEX (RLWS(5)(1:65), CHAR (39)) - 1
        WRITE (GRAPH(11)(20:30 + IYUNK), '(''Content  = '', A)')
     1    RLWS(5)(1:IYUNK)
      END IF
      IF (MODE == 0)
     1  WRITE (GRAPH(13)(20:37), '(''SpaceGroup '',    A)') ZSPG
      WRITE (GRAPH(15)(20:37), '(''ThetaMax = '', F7.3)') THM
      WRITE (GRAPH(17)(20:37), '(''Nr Refln = '',   I7)') NREF
      WRITE (GRAPH(19)(20:38), '(''Temp     = '',   I7,''K'')')
     1  MAX (IPR(261), 0)
      WRITE (GRAPH(21)(20:37), '(''Wilson U = '', F7.3)') UT
      IF (MODE /= 0) THEN
        WRITE (GRAPH(40)(85:), '(''Space Group  Determination Steps'')')
        WRITE (GRAPH(41)(85:), '(''==============================='')')
        WRITE (GRAPH(42)(85:), '(''1 - (A)Centric Tests (Optional)'')')
        WRITE (GRAPH(43)(85:), '(''2 - Check Resolution/Decay'')')
        WRITE (GRAPH(44)(85:), '(''3 - Get Bravais Lattice Type'')')
        WRITE (GRAPH(45)(85:), '(''4 - Select Laue Group'')')
        WRITE (GRAPH(46)(85:), '(''5 - Inspect Systematic Ext.Refln'')')
        WRITE (GRAPH(47)(85:), '(''6 - Select Space Group from Set'')')
      END IF
      IGBL(6) = 35
   10 CALL GGIP (HORS, VERT, 0.0, 1)
      VRT = VERT - 0.5
      DO I = 1, 55
        VRT = VRT - 0.34
        CALL PLA439 (0.0, GRAPH(I), 120, 0.25, 1, 1, 0.0, VRT)
      END DO
      CALL GGIP (0.0, 0.0, 0.0, 6)
      DO
C * WHAT NEXT ?
        CALL PLA012 (2, 1)
        CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
        IF (IGGT(1:1) == '!') EXIT
        SELECT CASE (IFL(1)(1:6))
          CASE ('END   ', 'EXIT  ')
            EXIT
          CASE ('PLOT')
            GO TO 10
          CASE ('NZSTAT')
            CALL PLA379 (1)
          CASE ('NZPLOT')
            CALL PLA379 (2)
          CASE DEFAULT
            IGBL(1) = 4
        END SELECT
      END DO
      RETURN
99999 FORMAT ('Wilson Plot and E-Value Statistics Modelled on the ',
     1 'NORMAL Program Code of the Multan80 Package', /, 120('='), /)
99998 FORMAT(//, 51X, 'UNIT CELL CONTENTS', //,
     1 'ATOM',2X, 'NUMBER IN CELL', 2X, 'ATOMIC NUMBER', 2X,
     2 'SCATTERING FACTOR CONSTANTS', 5X,
     3 '(F = A*EXP(-B*RHO)+C*EXP(-D*RHO)+E*EXP(-F*RHO)+G*EXP(-H*RHO)+K)'
     4 , /, (1X, A, I12, I12, 6X, 9F11.5))
      END SUBROUTINE PLA370
 
      SUBROUTINE PLA371
 
      USE files
      USE parameters
      USE spgrdata
      USE normal
      USE sgxyz
      IMPLICIT NONE
      INTEGER                          :: I
      INTEGER                          :: J
      INTEGER                          :: K
      INTEGER                          :: L
      INTEGER                          :: IC
      INTEGER                          :: INZ
      INTEGER                          :: ISN
      INTEGER                          :: IIMX
      REAL                             :: TRV
      CHARACTER(len=80)                :: ICLL
      CHARACTER(len=1),  DIMENSION(14) :: KX
      CHARACTER(len=3),  DIMENSION(2)  :: ICAP
      KX = (/'1','2','3','4','5','6','X','Y','Z',' ',',','+','-','/'/)
      ICAP = (/'NON','   '/)
C * DETERMINE LATTICE MULTIPLICITY (PTS) AND CRYSTAL SYSTEM (KSYS)
      LATT  = IPR(241)
      ICENT = IPR(257) - 1
      NSYM  = 0
      IIMX  = IPR(255)
      WRITE (LU7, 99999) ICAP(ICENT + 1), IIMX, LAT(LATT)
      DO L = 1, IIMX
        CALL SGSM (2, ICLL, SGX, L, 0, IERR)
        WRITE (LU7, 99998) ICLL
        NSYM = NSYM + 1
        IC   = 1
        ISN  = 1
        TRV  = -1.0
        INZ  = 1
        DO I = 1, 80
          DO J = 1, 14
            IF (ICLL(I:I) == KX(J)) EXIT
          END DO
C * CHECK FOR ','
          IF (J == 11) THEN
            IF (INZ == 2) IS(2, IC, NSYM) = 0
            IF (TRV < 0.0) TS(IC, NSYM) = 0.0
            INZ = 1
            TRV = -1.0
            IC  = IC + 1
C * CHECK FOR '-'
          ELSE IF (J == 13) THEN
            ISN = -1
C * CHECK FOR 'X', 'Y' OR 'Z'
          ELSE IF (J >= 7 .AND. J <= 9) THEN
            IS(INZ, IC, NSYM) = ISN * (J - 6)
            ISN = 1
            INZ = INZ + 1
C * CHECK FOR '1' TO '6'
          ELSE IF (J < 7) THEN
            IF (TRV < 0.0) TRV = FLOAT (J)
            IF (TRV > 0.0) TS(IC, NSYM) = TRV / FLOAT (J)
          END IF
        END DO
      END DO
C * DETERMINE LATTICE MULTIPLICITY
C * PRIMITIVE
      PTS = 1.0
      IF (LATT /= 7) THEN
C * A, B, C OR I CENTRED
        IF (LATT /= 1) PTS = 2.0
C * F CENTRED
        IF (LATT == 5) PTS = 4.0
      ELSE
C * CENTRED HEXAGONAL
        PTS = 3.0
        DO I = 1, NSYM
C * PRIMITIVE RHOMBOHEDRAL  (PTS=1.0)
          IF (IABS(IS(1, 1, I)) == 3) THEN
            PTS = 1.0
            EXIT
          END IF
        END DO
      END IF
C * DETERMINE CRYSTAL SYSTEM
      DO I = 1, 2
        DO J = 1, NSYM
          DO INZ = 1, 2
            IF (IABS (IS(INZ, 1, J)) == 4 - I) THEN
              IF (I /= 1) THEN
C * TETRAGONAL
                KSYS = 4
                IF (NSYM /= 4 .AND. NSYM /= 8) THEN
C * TRIGONAL OR RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES
                  KSYS = 5
C * TEST FOR 6-FOLD AXIS - GENERAL FORM -X, -Y, Z + T
                  DO K = 2, NSYM
                    IF (IABS (IS(1, 1, K)) > 1  .OR. IABS (IS(2, 1, K))
     1                 > 1) CYCLE
                    IF (IABS (IS(1, 2, K)) == 1 .OR. IABS (IS(2, 2, K))
     1                 == 1) CYCLE
C * HEXAGONAL
                    KSYS = 6
                  END DO
                END IF
              ELSE
C * CUBIC
                KSYS = 8
C * PRIMITIVE RHOMBOHEDRAL
                IF (LATT == 7) KSYS = 7
                IF (KSYS == 7) LATT = 1
              END IF
              RETURN
            END IF
          END DO
        END DO
      END DO
C * 1 - TRICLINIC, 2 - MONOCLINIC, 3 - ORTHORHOMBIC
      KSYS = MIN0(NSYM, 3)
      RETURN
99999 FORMAT (/, 'THE STRUCTURE IS ', A3, 'CENTROSYMMETRIC', 8X, I3, 3X,
     1 'GENERAL EQUIVALENT POSITIONS', 10X, 'LATTICE IS OF TYPE',
     2  3X, A1, /)
99998 FORMAT (30X, A)
      END SUBROUTINE PLA371
 
      SUBROUTINE PLA372
      USE files
      USE parameters
      USE atomdata
      USE normal
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: ID
      INTEGER           :: IG
      INTEGER           :: K1
      INTEGER           :: K2
      INTEGER           :: KG
      INTEGER           :: JG
      INTEGER           :: IH
      INTEGER           :: IK
      INTEGER           :: IL
      INTEGER           :: LG
      INTEGER           :: IK1
      INTEGER           :: MLT
      REAL              :: AF
      REAL              :: BF
      REAL              :: FF
      REAL              :: FK
      REAL              :: FO
      REAL              :: EW
      REAL              :: EPS
      REAL              :: RHO
      REAL              :: SIG
      REAL              :: SFK
      REAL              :: FRAC
      REAL              :: SINTH
      REAL              :: FORMX
      REAL              :: GEN095
      CHARACTER(len=80) :: LINE
C * SCRATCH FILE
      OPEN (LU65, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      REWIND (UNIT = LU17, IOSTAT = IOST)
      REWIND (UNIT = LU65, IOSTAT = IOST)
      DO
        READ (LU17, 99999, IOSTAT = IOST) IH, IK, IL, FK, SFK
        IF (IOST /= 0 .OR.
     1    IH == 0 .AND. IK == 0 .AND. IL == 0) THEN
          FO = -1.0
        ELSE
          IF (FK > 0.0) THEN
            FO  = SQRT (FK)
            SIG = SFK / (2.0 * FO)
          ELSE
            FO  = 0.0
            SIG = 0.0
          END IF
        END IF
C * CALCULATE RHO, EPSILON, MULTIPLICITY AND SCATTERING FACTOR
C * FOR EACH REFLECTION AND CREATE THE SCRATCH TAPE (LU65)
        IF (FO >= 0.0) THEN
          NREF   = NREF + 1
          RHO    = GEN095 (PAR(191), IH, IK, IL)
          RHOMAX = AMAX1 (RHOMAX, RHO)
C * COMPUTE EPSILON AND MULTIPLICITY BY GENERATING EQUIVALENT REFLECTIONS
C * EPSILON = NUMBER OF TIMES SAME REFLECTION APPEARS IN LIST
C * MULTIPLICITY = NUMBER DIFFERENT REFLECTIONS IN LIST
          EPS = 1.0
          MLT = 1
C * IN TRICLINIC SPACE GROUPS EPS = 1.0 AND MLT = 1
          IF (NSYM > 1) THEN
            SGX(1) = IH
            SGX(2) = IK
            SGX(3) = IL
            SGX(4) = 0.0
            K1      = 65536 * IH + 256 * (IK + 128) + IL + 128
            IK1     = 65792 - K1
            DO J = 2 ,NSYM
              CALL SGSM (5, LINE, SGX, J, LU6, IERR)
              K2 = 65536 * NINT (SGX(7)) + 256 * (NINT (SGX(8)) + 128)
     1           + NINT (SGX(9)) + 128
              IF (K2 == K1) EPS = EPS + 1.0
              IF (ICENT /= 0 .AND. K2 == IK1) EPS = EPS + 1.0
              IF (K2 == K1 .OR. K2 == IK1) MLT = MLT + 1
            END DO
          END IF
          FF = FO * FO / PTS
          ID = NSYM / MLT
C * DETERMINE INDEX GROUP (FOR RESCALING)
          IF (KSYS < 7) THEN
            LG = MOD (IABS (IL), 2)
            IF (KSYS < 5) THEN
              KG = MOD (IABS (IK), 2)
              JG = MOD (IABS (IH), 2)
C * TRICLINIC, MONCLINIC AND ORTHORHOMBIC
              IF (KSYS <= 3) IG = JG + 2 * KG + 4 * LG
C * TETRAGONAL
              IF (KSYS == 4) IG = JG + KG + 3 * LG
            ELSE
C * TRIGONAL, HEXAGONAL AND RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES
              IG = 3 * LG
              IF (MOD (IH, 3) == 0) IG = IG + 1
              IF (MOD (IK, 3) == 0 .OR. MOD (IH + IK, 3) == 0)
     1          IG = IG + 1
            END IF
          ELSE
C * CUBIC AND PRIMITIVE RHOMBOHEDRAL
            IG = 3 * MOD (IABS (IH + IK + IL), 2)
            IF (MOD (IH - IL, 3) == 0) IG = IG + 1
            IF (MOD (IK - IL, 3) == 0 .OR. MOD (IH - IK, 3) == 0)
     1        IG = IG + 1
          END IF
C * PACK SYMMETRY FUNCTIONS FOR LATER USE
          ID = 10000 * ID + 100 * INT (EPS + 0.5) + IG + 1
C * LOOK UP SCATTERING FACTOR TABLES GENERATED BY ATREC
          SINTH = 100.0 * SQRT (RHO)
          I     = MAX0 (2, INT (SINTH + 1.5))
          FRAC  = SINTH - FLOAT (I - 1)
          BF    = 0.5 * (GIW(I + 1) - GIW(I - 1))
          AF    = BF + GIW(I - 1) - GIW(I)
          FORMX = AF * FRAC * FRAC + BF * FRAC + GIW(I)
C * 'WILSON' STRUCTURE FACTOR
          EW    = FF / (FORMX * EPS)
        END IF
C * CREATE SCRATCH TAPE
        WRITE (LU65) IH, IK, IL, FO, ID, EW, RHO, SIG
        IF  (FO < 0) EXIT
      END DO
      THM = ASIN (SQRT (RHOMAX) * PAR(17)) * RGBL(6)
      RETURN
99999 FORMAT (3I4, 2F8.0)
      END SUBROUTINE PLA372
 
      SUBROUTINE PLA373
C * LEAST SQUARES PLOT, INCLUDING SUMMATION OVER NB RANGES OF RHO
      USE files
      USE normal
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: N
      INTEGER                :: ID
      INTEGER                :: IE
      INTEGER                :: MLT
      INTEGER                :: KYUNK
      INTEGER                :: NUMBERX
      INTEGER, DIMENSION(30) :: NSUM
      REAL                   :: T
      REAL                   :: Q
      REAL                   :: R
      REAL                   :: S
      REAL                   :: EW
      REAL                   :: FO
      REAL                   :: PI
      REAL                   :: PP
      REAL                   :: RR
      REAL                   :: WT
      REAL                   :: ED
      REAL                   :: ADD
      REAL                   :: AVI
      REAL                   :: EPS
      REAL                   :: DIV
      REAL                   :: RHO
      REAL                   :: ENDX
      REAL                   :: TMULX
      REAL                   :: START
      REAL                   :: ESQAV
      REAL,    DIMENSION(30) :: SW
      REAL,    DIMENSION(30) :: SD
      REAL,    DIMENSION(30) :: SR
      REAL,    DIMENSION(30) :: SI
      NB = INT (8.0 * ALOG10 (0.05 * FLOAT (MAX0 (NREF, 100)) + 0.5))
C * MAXIMUM OF 30 POINTS ON WILSON PLOT
      IF (NB > 30) NB = 30
      WRITE (LU7, 99995) NREF, RHOMAX, NB
      WRITE (LU7, 99999)
C * SET INITIAL VALUES
      PI      = 4.0 * ATAN (1.0)
      PP      = 0.0
      Q       = 0.0
      R       = 0.0
      S       = 0.0
      T       = 0.0
      NUMBERX = 0
      ADD     = RHOMAX / FLOAT (NB)
      START   = -ADD
      ENDX    = ADD
      RR      = FLOAT (NB) / RHOMAX
      DO I = 1, 30
        SW(I)   = 0.0
        SD(I)   = 0.0
        SR(I)   = 0.0
        SI(I)   = 0.0
        NSUM(I) = 0
      END DO
      REWIND (UNIT = LU65, IOSTAT = IOST)
C * READ SCRATCH TAPE
      DO
        READ (LU65) KYUNK, KYUNK, KYUNK, FO, ID, EW, RHO
        ED = EW
C * TAPE ENDS WITH FO < 0.0
        IF (FO < 0.0) THEN
          KYUNK = 0
          EXIT
        END IF
C * N STORES RANGE OF RHO
        N     = MIN0 (INT (1.0 + RR * RHO), NB)
        MLT   = ID / 10000
        IE    = (ID - 10000 * MLT) / 100
        EPS   = FLOAT (IE)
        TMULX = FLOAT (MLT)
C * WEIGHTED SUMS
C * NUMBER OF REFLECTIONS
        NSUM(N) = NSUM(N) + MLT
C * WILSON
        SW(N) = SW(N) + EW * TMULX
C * DEBYE
        SD(N) = SD(N) + ED * TMULX
C * RHO
        SR(N) = SR(N) + RHO * TMULX
C * INTENSITY
        SI(N) = SI(N) + TMULX * FO * FO / (EPS*PTS)
      END DO
      IF (KYUNK == 0) THEN
        DO I = 1, NB
C * SMOOTH CURVE BY ADDING ADJACENT RANGES
          NUMBERX = NUMBERX + NSUM(I)
          NSUM(I) = NSUM(I) + NSUM(I + 1)
          SW(I)   = SW(I)   + SW(I + 1)
          SD(I)   = SD(I)   + SD(I + 1)
          SR(I)   = SR(I)   + SR(I + 1)
          SI(I)   = SI(I)   + SI(I + 1)
C * CALCULATE WEIGHTED AVERAGES AND LOGS
          WT      = FLOAT (NSUM(I))
          DIV     = 1.0 / AMAX1 (1.0, WT)
          ESQAV   = SD(I) * DIV
          FLGD(I) = ALOG (ESQAV)
          AVI     = SI(I) * DIV
          AVR(I)  = SR(I) * DIV
          FLGW(I) = ALOG (SW(I) * DIV)
          START   = START + ADD
          ENDX    = AMIN1 (ENDX + ADD, RHOMAX)
          WRITE (LU7, 99998) I, START, ENDX, NSUM(I), AVR(I), AVI,
     1      ESQAV, FLGW(I)
C * COEFFICIENTS OF NORMAL EQUATIONS
          PP = PP + WT * AVR(I) * AVR(I)
          Q  = Q  + WT * AVR(I)
          R  = R  + WT * AVR(I) * FLGD(I)
          S  = S  + WT * FLGD(I)
          T  = T  + WT
        END DO
      END IF
      WRITE (LU7, 99997) PP, Q, R, Q, T, S
C * LEAST SQUARES
      DIV   =  PP * T - Q * Q
      SLOPE = (R  * T - Q * S) / DIV
      FLGK  = (PP * S - Q * R) / DIV
      SC    = EXP (-FLGK)
      BT    = -0.5 * SLOPE
      UT    = BT / (8 * PI**2)
      WRITE (LU6, 99994) UT
      WRITE (LU7, 99996) SLOPE, FLGK, BT, UT, SC
      RETURN
99999 FORMAT (//, 20X, 'LEAST SQUARES PLOT', //, 'RANGE', 6X,
     1 'RHO=(SINTH/LAM)**2', 6X, 'NUMBER', 6X, 'MEAN RHO', 7X,
     2 'MEAN I', 7X, 'MEAN EXP(-2*B*RHO)*E**2', 7X, 'WILSON')
99998 FORMAT (I3, F15.4, '  -', F8.4, I11, F14.4, F14.1, F23.4,
     1 7X, F13.4)
99997 FORMAT (/, 'NORMAL EQUATIONS', /, (E11.3, ' * SLOPE +', E11.3,
     1 ' * INTERCEPT =', E11.3))
99996 FORMAT (/, 'SLOPE =', F8.4, 4X, 'INTERCEPT =', F8.4, 4X,
     1 'TEMPERATURE FACTOR (B) =', F8.4, 4X, 'U =', F8.4, 4X, 'SCALE =',
     2 F8.4, /, 51X, 'F(ABSOLUTE)**2 = SCALE*F(OBSERVED)**2')
99995 FORMAT (//, 'NUMBER OF REFLECTIONS =', I6, 8X,
     1 'MAXIMUM (SIN(THETA)/LAMBDA)**2 =', F7.4, 8X,
     2 'NUMBER OF POINTS ON WILSON PLOT =', I3)
99994 FORMAT (/, ':: Wilson U = ', F10.4, //)
      END SUBROUTINE PLA373
 
      SUBROUTINE PLA374
      USE files
      USE cchar
      USE normal
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: JP
      INTEGER            :: IL
      INTEGER            :: IR
      INTEGER            :: ITEMP
      REAL               :: Q
      REAL               :: SK
      REAL               :: FD
      REAL               :: FN
      REAL               :: FX
      REAL               :: RX
      REAL, DIMENSION(4) :: R
      REAL, DIMENSION(6) :: FH
      REAL, DIMENSION(6) :: RH
      REAL, DIMENSION(4) :: AW
C * LINE PRINTER PLOT AT 50 VALUES OF RHO
C * DETERMINE RANGES OF LOGS
      RX = AVR(NB)
      FX = FLGK
      FN = SLOPE * RX + FLGK
      DO I = 1, NB
        FX = AMAX1 (FX, FLGW(I), FLGD(I))
        FN = AMIN1 (FN, FLGW(I), FLGD(I))
      END DO
      FD = FX - FN
      DO I = 1, 6
        RH(I) = 0.2 * FLOAT (I - 1) * RX
        FH(I) = FN + 0.2 * FLOAT (I - 1) * FD
      END DO
C * TOP FRAME
      WRITE (LU7, 99993)
      WRITE (GRAPH(1), 99999)
      WRITE (GRAPH(2), 99998) FH
      WRITE (GRAPH(3), 99997) RH(1)
      J  = 1
      IR = 2
      DO I = 1, 50
        DCV(I) = -1000000.0
C * SIDE FRAME
        IF (MOD (I, 10) /= 0) THEN
          WRITE (GRAPH(I + 3), 99996)
        ELSE
          WRITE (GRAPH(I + 3), 99995) RH(IR)
          IR = IR + 1
        END IF
C * INTERPOLATION
        Q = 0.02 * FLOAT (I) * RX
        IL = INT ((SLOPE * Q + FLGK - FN) * 100.0 / FD + 16.5)
        IF (IL > 117) IL = 117
        IF (IL < 1)   IL = 1
C * STRAIGHT LINE OUTPUT (*)
        GRAPH(I + 3)(IL:IL) = '*'
        IF (Q >= AVR(1)) THEN
          IF (J == 1 .OR.
     1        J /= 1 .AND. J /= NB - 2 .AND. Q >= AVR(J + 1)) THEN
            J = J + 1
            DO K = 1, 4
              ITEMP = J - 2 + K
              R(K)  = AVR(ITEMP)
            END DO
            CALL GEN153 (R, FLGW(J - 1), FLGW(J), FLGW(J + 1),
     1        FLGW(J + 2), AW)
          END IF
C * WILSON PLOT INTERPOLATION
          IL =
     1      INT (100.0 * (AW(4) + Q * (AW(3) + Q * (AW(2) + Q * AW(1)))
     2      - FN) / FD + 16.5)
          IF (IL > 117) IL = 117
          IF (IL < 1)   IL = 1
C * WILSON PLOT OUTPUT (W)
          GRAPH(I + 3)(IL:IL) = 'W'
C * STORE K-CURVE
          DCV(I) = EXP (AW(4) + Q * (AW(3) + Q * (AW(2) + Q * AW(1))))
        END IF
        IF (I == 2)   GRAPH(I + 3)(40:91) =
     1    'PLOT OF WILSON CURVE AND LEAST SQUARES STRAIGHT LINE'
        IF (I == 25) GRAPH(I + 3)(1:14) = '(sin(TH)/L)**2'
      END DO
      WRITE (LU7, 99994) (GRAPH(I), I = 1, 53)
C * K-CURVE PARAMETERS
      DEL = 50.0 / AVR(NB)
      J   = 0
      JP  = 0
      DO I = 1, 50
        SK = EXP (SLOPE * FLOAT (I) / DEL + FLGK)
        IF (DCV(I) >= (-999999.0)) THEN
          JP = -1
          IF (DCV(I) > SK) JP = 1
          IF (J == (-JP)) EXIT
          J = JP
        END IF
        DCV(I) = SK
      END DO
      RETURN
99999 FORMAT (50X, 'LN(F(OBS)**2/SIGFSQ)')
99998 FORMAT (F18.3, 5F20.3)
99997 FORMAT (F12.3, 2X, '-', 5('I', 19('-')), 'I-')
99996 FORMAT (15X, 'I')
99995 FORMAT (F11.3, 3X, '-I-')
99994 FORMAT (A)
99993 FORMAT(/, 26X, 'PLOT OF WILSON CURVE AND LEAST SQUARES',
     1 ' STRAIGHT LINE', //)
      END SUBROUTINE PLA374
 
      SUBROUTINE PLA375
C * INDEX GROUP RESCALING
      USE files
      USE normal
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: ID
      INTEGER               :: IG
      INTEGER               :: NN
      INTEGER               :: NW
      INTEGER               :: MLT
      INTEGER               :: KYUNK
      INTEGER, DIMENSION(8) :: NG
      REAL                  :: ED
      REAL                  :: EW
      REAL                  :: FO
      REAL                  :: RHO
      REAL                  :: ESQ
      REAL                  :: TOT
      REAL                  :: TMULX
      REAL,    DIMENSION(8) :: SCS
      TOT = 0.0
      NW  = 0
      DO I = 1, 8
        SCS(I) = 0.0
        NG(I)  = 0
      END DO
      REWIND (UNIT = LU65, IOSTAT = IOST)
      DO
        READ (LU65) KYUNK, KYUNK, KYUNK, FO, ID, EW, RHO
        ED = EW
        IF (FO < 0.0) THEN
          KYUNK = 0
          EXIT
        END IF
        CALL PLA377 (ESQ, RHO, ED)
C * UNPACK SYMMETRY FUNCTIONS
        MLT     = ID / 10000
        TMULX   = FLOAT(MLT)
        TOT     = TOT + ESQ * TMULX
        NW      = NW  + MLT
        IG      = MOD(ID, 100)
        SCS(IG) = SCS(IG) + ESQ * TMULX
        NG(IG)  = NG(IG)  + MLT
      END DO
      IF (KYUNK == 0) TOT = TOT / FLOAT(NW)
C * 8 PARITY GROUPS FOR TRICLINIC, MONOCLINIC AND ORTHORHOMBIC
      NN = 8
C * 6 MODIFIED PARITY GROUPS FOR TETRAGONAL
C * 6 INDEX GROUPS IN OTHER SYSTEMS
      IF (KSYS >= 4) NN = 6
      DO I = 1, NN
        IF (NG(I) > 0) SCS(I) = SCS(I) / FLOAT (NG(I))
      END DO
      WRITE (LU7, 99999)
      IF (KSYS <= 3) WRITE (LU7, 99998)
      IF (KSYS == 4) WRITE (LU7, 99997)
      IF (KSYS > 4) THEN
        WRITE (LU7, 99996)
        IF (KSYS <= 6) WRITE (LU7, 99995)
        IF (KSYS >= 7) WRITE (LU7, 99994)
        WRITE (LU7, 99993)
      END IF
      WRITE (LU7, 99992) TOT, (SCS(I), I = 1, NN)
      WRITE (LU7, 99991) NW,  (NG(I),  I = 1, NN)
      TOT = 1.0 / TOT
      DO I = 1, NN
        IF (NG(I) > 0 .AND. ABS(SCS(I)) > 0.0001) SCAL(I) = 1.0 / SCS(I)
      END DO
      RETURN
99999 FORMAT (/, 27X, 'AVERAGE E**2 ACCORDING TO APPROPRIATE INDEX ',
     1 'GROUP BEFORE RESCALING')
99998 FORMAT (53X, 'PARITY GROUPS', /, 18X, 'ALL', 9X, 'EEE', 9X,
     1 'OEE', 9X, 'EOE', 9X, 'OOE', 9X, 'EEO', 9X, 'OEO', 9X, 'EOO',
     2 9X, 'OOO')
99997 FORMAT (49X,'MODIFIED PARITY GROUPS', /, 18X, 'ALL', 9X, 'EEE',
     1 7X, 'EOE', 'OEE', 7X, 'OOE', 9X, 'EEO', 7X, 'EOO', 'OEO', 7X,
     2 'OOO')
99996 FORMAT ('INDEX GROUPS DIVIDED ON -')
99995 FORMAT ('+', 30X, '1) MOD(H,3)', 4X, '2) MOD(K,3)', 4X,
     1 '3) MOD(H+K,3)',4X, '4) MOD(L,2)')
99994 FORMAT ('+', 30X, '1) MOD(H-L,3)', 4X, '2) MOD(K-L,3)', 4X,
     1 '3) MOD(H-K,3)', 4X, '4) MOD(H+K+L,2)')
99993 FORMAT (30X, 'E - ZERO REMAINDER', 4X, 'O - NON-ZERO REMAINDER',/,
     1 '0', 18X, 'ALL', 9X, 'OOOE', 5X, 'OOEE,OEOE', 6X, 'EEEE', 8X,
     2 'OOOO', 5X, 'OOEO,OEOO', 6X, 'EEEO', /, ' ', 42X, 'EOOE', 32X,
     3 'EOOO')
99992 FORMAT (2X, 'E**2', 3X, 9F12.3)
99991 FORMAT (1X, 'NUMBER', 2X, 9I12)
      END SUBROUTINE PLA375
 
      SUBROUTINE PLA376
C * WILSON PLOT - PART 7
      USE files
      USE parameters
      USE cchar
      USE normal
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: N
      INTEGER                  :: ID
      INTEGER                  :: IE
      INTEGER                  :: IG
      INTEGER                  :: LH
      INTEGER                  :: LK
      INTEGER                  :: LL
      INTEGER                  :: NC
      INTEGER                  :: NL
      INTEGER                  :: NS
      INTEGER                  :: LIM
      INTEGER                  :: NRW
      INTEGER                  :: NET
      INTEGER                  :: INP
      INTEGER, DIMENSION(1000) :: IX
      INTEGER, DIMENSION(25)   :: NU
      INTEGER, DIMENSION(10)   :: NHR
      REAL                     :: E
      REAL                     :: T
      REAL                     :: ED
      REAL                     :: ZZ
      REAL                     :: XX
      REAL                     :: EW
      REAL                     :: FO
      REAL                     :: RRX
      REAL                     :: SIG
      REAL                     :: SCF
      REAL                     :: RHO
      REAL                     :: ESQ
      REAL,    DIMENSION(1000) :: EX
      REAL,    DIMENSION(1000) :: FX
      REAL,    DIMENSION(10)   :: RHR
      REAL,    DIMENSION(10)   :: STL
      REAL,    DIMENSION(10)   :: AVA
      REAL,    DIMENSION(10)   :: AVC
      REAL,    DIMENSION(10)   :: AVH
      CHARACTER(len=1)         :: NOB
      CHARACTER(len=1)         :: IOBS
      CHARACTER(len=1)         :: IUNOBS
      CHARACTER(len=120)       :: RECORD
C * TABLES OF THEORETICAL DISTRIBUTIONS
      ZT(1:25, 9) = (/
     1 0.368, 0.463, 0.526, 0.574, 0.612, 0.643, 0.670, 0.694, 0.715,
     2 0.733, 0.765, 0.791, 0.813, 0.832, 0.848, 0.863, 0.875, 0.886,
     3 0.896, 0.905, 0.913, 0.920, 0.926, 0.932, 0.938/)
      AVA = (/0.886, 1.0, 1.329, 2.0, 3.323, 6.0, 0.736, 1.0, 2.0,
     1        2.415/)
      AVC = (/0.798, 1.0, 1.596, 3.0, 6.383, 15.0, 0.968, 2.0, 8.0,
     1        8.691/)
      AVH = (/0.718, 1.0, 1.916, 4.5, 12.26, 37.5, 1.145, 3.5, 26.0,
     1        26.903/)
      IOBS   = ' '
      IUNOBS = 'U'
C * CALCULATE FINAL E-VALUES AND RESCALED F'S
C * CREATE NEW LU65 IF REQUIRED
C * PREPARE TABLES OF STATISTICS
C * SET INITIAL VALUES
      CALL GEN097 (NST, 1,  5, 0)
      CALL GEN097 (NU,  1, 25, 0)
      CALL GEN097 (NHR, 1, 10, 0)
      DO I = 1, 10
        RHR(I) = 0.0
        DO J = 1, 5
          VST(I, J) = 0.0
        END DO
      END DO
      DO I = 1, 8
        DO J = 1, 25
          ZT(J, I) = 0.0
        END DO
      END DO
      NRW = 0
      LIM = 1000
      NC  = 0
      NS  = 0
      NL  = 0
      SCF = SQRT (SC)
      RRX = 10.0 / SQRT (RHOMAX)
      REWIND (UNIT = LU65, IOSTAT = IOST)
      DO
        READ (LU65) LH, LK, LL, FO, ID, EW, RHO, SIG
        ED  = EW
        INP = 32896
C * TEST FOR END OF DATA
        IF (FO < 0.0) EXIT
C * SPECIAL TEST OPTION  (GENERALLY, ALL REFLECTION SHOULD BE INCLUDED)
        IF (FO < PAR(550) * SIG) CYCLE
        MULT =  ID / 10000
        IE   = (ID - 10000 * MULT) / 100
        IG   =  ID - 10000 * MULT - 100 * IE
C * CALCULATE E
        CALL PLA377 (ESQ, RHO, ED)
        ESQ = ESQ * SCAL(IG)
        E   = SQRT (ESQ)
        ED  = E
C * CALCULATE RESCALED F
        FO = FO * SCF
C * PACK INDICES FOR TAPE LU65
        INP = 65536 * LH + 256 * (LK + 128) + LL + 128
C * SET OBS/UNOBS FLAG
        NOB = IOBS
        IF (SIG < 0.0) NOB = IUNOBS
C * (DUMMY)
        NOB = ' '
        IF (NOB == ' ') GO TO 20
        IF (RHO > TH) GO TO 20
C * STORE REFLECTIONS FOR MULTAN
        IF (SIG >= 0.0) THEN
          NL = NL + 1
          IF (E > EN) GO TO 10
          NL = NL - 1
        END IF
        E  = E + 0.2 * RHO
        IF (E > ER) GO TO 20
        NS     = NS + 1
   10   NC     = NC + 1
        IX(NC) = INP
        EX(NC) = E
        FX(NC) = FO
        IF (NC == LIM) THEN
C * SORT
          CALL GEN154 (EX, FX, IX, 1000)
          IF (MZ > 0) ER = AMIN1 (ER, EX(1001 - MZ))
          EN  = AMAX1 (EN, EX(MM))
          NC  = MIN0 (MM, NL)
          LIM = 1000 - MZ
        END IF
C * WORK OUT FINAL STATISTICS
 
   20   TMUL = FLOAT(MULT)
C * DISTRIBUTION OF E WITH SIN(THETA)/LAMBDA
        N      = MIN0 (10, INT (1.0 + RRX * SQRT (RHO)))
        NHR(N) = NHR(N) + MULT
        RHR(N) = RHR(N) + ESQ * TMUL
        NZR    = INT (10.0 * ESQ) + 1
        IF (NZR > 10) NZR = 10 + (NZR - 9) / 2
        EE(1) = ED
        DO J = 2, 6
          EE(J) = EE(J - 1) * ED
        END DO
        EE(7)  = ESQ - 1.0
        EE(8)  = EE(7) * EE(7)
        EE(9)  = EE(8) * EE(7)
        EE(10) = ABS (EE(9))
        EE(7)  = ABS (EE(7))
        DO J = 1, 10
          EE(J) = TMUL * EE(J)
        END DO
C * ADD FUNCTIONS OF E TO APPROPRIATE ZONES
        IND = 1
        J   = LH
        K   = LK
        L   = LL
        CALL PLA378 (1)
C * TRICLINIC, MONOCLINIC AND ORTHORHOMBIC
        IF (KSYS <= 3) THEN
          IF (J == 0) CALL PLA378 (3)
          IF (K == 0) CALL PLA378 (4)
          IF (L == 0) CALL PLA378 (5)
C * TETRAGONAL
        ELSE IF (KSYS == 4) THEN
          IF (J == 0 .OR. K == 0) CALL PLA378 (3)
          IF (IABS (J) == IABS (K)) CALL PLA378 (4)
          IF (L == 0) CALL PLA378 (5)
C * TRIGONAL, HEXAGONAL AND RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES
        ELSE IF (KSYS == 5 .OR. KSYS == 6) THEN
          IF (J == 0 .OR. K == 0 .OR. J + K == 0)
     1      CALL PLA378 (3)
          IF (J == K .OR. J + 2 * K == 0 .OR. 2 * J + K == 0)
     1      CALL PLA378 (4)
          IF (L == 0) CALL PLA378 (5)
C * PRIMITIVE RHOMBOHEDRAL
        ELSE IF (KSYS == 7) THEN
          IF (J == K .OR. J == L .OR. K == L) CALL PLA378 (3)
          IF (L == 2 * K - J .OR. K == 2 * J - L .OR. J .EQ.
     1      2 * L - K) CALL PLA378 (4)
          IF (J + K + L == 0) CALL PLA378 (5)
C * CUBIC
        ELSE IF (KSYS == 8) THEN
          IF (J == 0 .OR. K == 0 .OR. L == 0) CALL PLA378 (3)
          IF (IABS (J) == IABS (K) .OR. IABS (J) == IABS (L) .OR.
     1     IABS (K) == IABS (L)) CALL PLA378 (4)
C * H,H,2H IS IN TWO PRINCIPAL ZONES BUT NOT ON A PRINCIPAL AXIS
          IF (IND == 4) IND = 0
          IF (IABS (L) == IABS (J + K) .OR. IABS (K) == IABS (J + L)
     1      .OR.  IABS (J) == IABS (K + L)) CALL PLA378 (5)
        END IF
C * REFLECTIONS NOT BELONGING TO PRINCIPAL ZONES
        IF (IND == 1) CALL PLA378 (2)
C * DISTRIBUTION OF E FOR COMPLETE DATA
        NET = MIN0 (25, INT (10.0 * ED))
        IF (NET /= 0) NU(NET) = NU(NET) + 1
        NRW = NRW + MULT
      END DO
C * OUTPUT STATISTICS
      RRX = 1.0 / RRX
      DO I = 1, 10
        STL(I) = RRX * FLOAT (I)
        IF (NHR(I) > 0) RHR(I) = RHR(I) / FLOAT (NHR(I))
        DO J = 1, 5
          IF (NST(J) > 0) VST(I, J) = VST(I, J) / FLOAT (NST(J))
        END DO
      END DO
      WRITE (LU7, 99997) STL, RHR, NHR
      WRITE (LU7, 99996)
      WRITE (LU7, 99995)
      WRITE (RECORD, 99980)
      WRITE (RECORD(5:11), 99994)
C * CAPTION ACCORDING TO CRYSTAL SYSTEM
      IF (KSYS /= 7) WRITE (RECORD(51:53), 99993)
      IF (KSYS == 7) WRITE (RECORD(48:55), 99992)
      IF (KSYS <= 3) WRITE (RECORD(63:65), 99991)
      IF (KSYS >= 4) WRITE (RECORD(63:65), 99990)
      IF (KSYS <= 6) WRITE (RECORD(75:77), 99989)
      IF (KSYS >= 7) WRITE (RECORD(72:79), 99988)
      WRITE (LU7, 99979) RECORD
      GRAPH(54) = RECORD
      WRITE (LU7, 99987)
     1 ((VST(I, J), J = 1, 5), AVA(I), AVC(I), AVH(I), I = 1, 6)
      WRITE (RECORD, 99986)
     1 ((VST(I, J), J = 1, 5), AVA(I), AVC(I), AVH(I), I = 7, 7)
      WRITE (LU7, 99979) RECORD
      GRAPH (55)(2:120) = RECORD(2:116)
      WRITE (LU7, 99985)
     1 ((VST(I, J), J = 1, 5), AVA(I), AVC(I), AVH(I), I = 8, 10)
      WRITE (LU7, 99977) NST
      WRITE (LU7, 99984)
      WRITE (LU7, 99995)
      WRITE (RECORD, 99980)
      WRITE (RECORD(6:6), 99978)
C * CAPTION ACCORDING TO CRYSTAL SYSTEM
      IF (KSYS /= 7) WRITE (RECORD(51:53), 99993)
      IF (KSYS == 7) WRITE (RECORD(48:55), 99992)
      IF (KSYS <= 3) WRITE (RECORD(63:65), 99991)
      IF (KSYS >= 4) WRITE (RECORD(63:65), 99990)
      IF (KSYS <= 6) WRITE (RECORD(75:77), 99989)
      IF (KSYS >= 7) WRITE (RECORD(72:79), 99988)
      WRITE (LU7, 99979) RECORD
      DO I = 1, 25
        DO J = 2, 6
          IF (NST(J - 1) > 0) ZT(I, J) = ZT(I, J) / FLOAT (NST(J - 1))
          IF (I /= 1) ZT(I, J) = ZT(I, J) + ZT(I - 1, J)
        END DO
C * THEORETICAL DISTRIBUTION
        ZZ = 0.1 * FLOAT (I)
        IF (I > 10) ZZ = 2.0 * ZZ - 1.0
        ZT(I, 1) = ZZ
C * ACENTRIC DISTRIBUTION
        ZT(I, 7) = 1.0 - EXP(-ZZ)
C * CENTRIC DISTRIBUTION
        XX       = SQRT (0.5 * ZZ)
        T        = 1.0 / (1.0 + 0.47047 * XX)
        ZT(I, 8) = 1.0 - ((0.74786 * T -0.09588) * T + 0.34802) * T *
     1     EXP (-0.5 * ZZ)
        WRITE (LU7, 99983) (ZT(I, J), J = 1, 9)
      END DO
C * WEIGHTED SAMPLE SIZE
      WRITE (LU7, 99977) NST
      DO I = 1, 24
        J     = 25 - I
        NU(J) = NU(J) + NU(J + 1)
      END DO
      WRITE (LU7, 99982)
      DO I = 1, 25
        AVR(I) = 0.1 * FLOAT (I)
      END DO
      WRITE (LU7, 99981) (AVR(I), I = 7, 25), (NU(I), I = 7, 25)
      RETURN
99997 FORMAT (///, 52X, 'FINAL STATISTICS', //, 38X,
     1 'DISTRIBUTION OF E**2 WITH SIN(THETA)/LAMBDA', /, 'SINTH/LAM',
     2 10F10.4, /, 3X, 'E**2', 2X, 10F10.4, /, 2X, 'NUMBER', 10I10)
99996 FORMAT (//, 53X, 'AVERAGE VALUES', /)
99995 FORMAT (45X, 'EXPERIMENTAL', 39X, 'THEORETICAL')
99994 FORMAT('AVERAGE')
99993 FORMAT('0KL')
99992 FORMAT('H,K,2K-H')
99991 FORMAT('H0L')
99990 FORMAT('HHL')
99989 FORMAT('HK0')
99988 FORMAT('H,K,-H-K')
99987 FORMAT(6X, '|E|', 9X, 5F12.3, 2X, 3F12.3, /,
     1 6X, 'E**2', 8X, 5F12.3, 2X, 3F12.3, /,
     2 6X, 'E**3', 8X, 5F12.3, 2X, 3F12.3, /,
     3 6X, 'E**4', 8X, 5F12.3, 2X, 3F12.3, /,
     4 6X, 'E**5', 8X, 5F12.3, 2X, 3F12.3, /,
     5 6X, 'E**6', 8X, 5F12.3, 2X, 3F12.3)
99986 FORMAT (6X, '|E**2-1|', 4X, 5F12.3, 2X, 3F12.3)
99985 FORMAT (6X, '(E**2-1)**2', 1X, 5F12.3, 2X, 3F12.3, /,
     1        6X, '(E**2-1)**3', 1X, 5F12.3, 2X, 3F12.3, /,
     2        6X, '|E**2-1|**3', 1X, 5F12.3, 2X, 3F12.3)
99984 FORMAT (//, 40X, 'N(Z) CUMULATIVE PROBABILITY DISTRIBUTION')
99983 FORMAT (F7.1, 11X, 5F12.3, 2X, 3F12.3)
99982 FORMAT (/, 38X, 'DISTRIBUTION OF E - NUMBER OF E''S > LIMIT', /)
99981 FORMAT (2X, 'E  ', 19F6.1, /, 1X, 'NO. ', 19I6)
99980 FORMAT (23X, 'ALL DATA', 7X, 'HKL', 9X, '0kl', 9X, 'h0l', 9X,
     1  'hk0', 8X, 'ACENTRIC', 5X, 'CENTRIC', 2X, 'HYPERCENTRIC')
99979 FORMAT (A)
99978 FORMAT ('Z')
99977 FORMAT ('Weighted Sample Size', I10, 4I12)
      END SUBROUTINE PLA376
 
      SUBROUTINE PLA377 (ESQ, RHO, ED)
C * K-CURVE INTERPOLATION
      USE normal
      IMPLICIT NONE
      INTEGER :: I
      REAL    :: EI
      REAL    :: ED
      REAL    :: SK
      REAL    :: ESQ
      REAL    :: RHO
      EI = RHO * DEL
      I  = INT (EI)
C * FOR SMALL RHO THE CURVE IS EXTRAPOLATED FROM THE FIRST POINT
C * USING THE LEAST SQUARES SLOPE
      IF (I == 0) SK = EXP (SLOPE * RHO + FLGK)
C * INTERPOLATION
      IF (I > 0 .AND. I < 50)
     1  SK = DCV(I) + (EI - FLOAT (I)) * (DCV(I + 1) - DCV(I))
C * FOR LARGE RHO THE CURVE IS EXTRAPOLATED FROM THE LAST POINT
      IF (I >= 50) SK = DCV(50) * EXP (SLOPE * (AVR(NB) - RHO))
      ESQ = ED / SK
      RETURN
      END SUBROUTINE PLA377
 
      SUBROUTINE PLA378 (N)
      USE normal
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: M
      INTEGER :: N
      REAL    :: S
C * SUMS FOR REFLECTION IN ZONE N
      M = 1
      J = N
      IF (N > 2 .AND. IND > 1) THEN
C * REFLECTION IS ON PRINCIPAL AXIS - THEREFORE IGNORE IT
        J = IND
        M = -1
      END IF
      S = FLOAT (M)
      DO I = 1, 10
        VST(I, J) = VST(I, J) + S * EE(I)
      END DO
      NST(J) = NST(J) + M * MULT
      IF (NZR <= 25) ZT(NZR, J + 1) = ZT(NZR, J + 1) + S * TMUL
      IND = N
      RETURN
      END SUBROUTINE PLA378
 
      SUBROUTINE PLA379 (MODE)
      USE xwdw
      USE normal
      USE cchar
      USE parameters
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: N
      INTEGER          :: MODE
      REAL             :: X
      REAL             :: Y
      REAL             :: Z
      REAL             :: ZZ
      REAL             :: SCALEX
      REAL             :: SCALEY
      CHARACTER(len=3) :: TXT
      CALL GGIP (HORS, VERT, 0.0, 1)
C * N(Z)-STATISTICS
      IF (MODE == 1) THEN
        VRT = VERT - 0.5
        WRITE (PRBUF, 99998)
        CALL PLA439 (0.0, PRBUF, 120, 0.25, 1, 1, 0.0, VRT)
        VRT = VRT - 0.5
        WRITE (PRBUF, 99997)
        CALL PLA439 (0.0, PRBUF, 120, 0.25, 1, 1, 0.0, VRT)
        VRT = VRT - 0.5
        WRITE (PRBUF, 99996)
        CALL PLA439 (0.0, PRBUF, 120, 0.25, 1, 1, 0.0, VRT)
        DO I = 1, 25
          WRITE (PRBUF, 99999) (ZT(I, J), J = 1, 9)
          VRT = VRT - 0.5
          CALL PLA439 (0.0, PRBUF, 120, 0.25, 1, 1, 0.0, VRT)
        END DO
        WRITE (PRBUF, 99994)
        VRT = VRT - 2.0
        CALL PLA439 (0.0, PRBUF, 80, 0.3, 1, 1, 1.0, VRT)
C * N(Z)-PLOT
      ELSE IF (MODE == 2) THEN
        VRT = VERT - 1.2
        CALL PLA439 (0.0, 'N(Z)-PLOT for '//JID(1:10), 24, 0.6, 5, 2,
     1    2.0, VRT)
        N = INDEX (RLWS(5), '''') - 1
C * SHOW SUMFORMULA
        IF (N > 0) THEN
          VRT = VRT - 1.0
          CALL PLA439 (0.0, 'SumFormula '//RLWS(5), N + 11, 0.30,
     1      5 + IGBL(68), 2, 2.0, VRT)
        END IF
        SCALEX = (HORS - 1.0) / 4.0
        SCALEY =  VERT - 1.0
        CALL GGIP (1.0, 1.0, 0.0, -3)
        CALL GGIP (0.0, 0.0, 0.0, 3)
C * LABEL AXES
        X = HORS - 1.0
        CALL GGIP (X, 0.0, 0.0, 2)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        CALL PLA439 (0.0, 'Z', 1, 0.5, 1, 2, X - 0.6, 0.6)
        DO I = 1, 4
          WRITE (TXT, 99995) FLOAT (I)
          X = SCALEX * I
          CALL GGIP (X, 0.0, 0.0, 3)
          CALL GGIP (X, -0.5, 0.0, 2)
          CALL PLA439 (0.0, TXT, 3, 0.4, 1, 2, X - 1.3, -0.5)
        END DO
        Y = VERT - 1.0
        CALL GGIP (0.0, 0.0, 0.0, 3)
        CALL GGIP (0.0, Y, 0.0, 2)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        DO I = 1, 10
          Z  = I * 0.1
          ZZ = Z * SCALEY
          WRITE (TXT, 99995) Z
          CALL PLA439 (0.0, TXT, 3, 0.3, 1, 2, -0.9, ZZ - 0.4)
          CALL GGIP ( 0.0, ZZ, 0.0, 3)
          CALL GGIP (-0.5, ZZ, 0.0, 2)
          CALL GGIP (0.0, 0.0, 0.0, 3)
        END DO
C * HYPER-CENTRIC
        CALL PLA439 (0.0, 'HYPER-CENTRIC', 13, 0.5, 4, 2, 16.0, 10.0)
        CALL GGIP (0.0, 4.0, 0.0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        DO I = 1, 25
          X = ZT(I, 1) * SCALEX
          Y = ZT(I, 9) * SCALEY
          CALL GGIP (X, Y, 0.0, 2)
        END DO
C * CENTRIC
        CALL PLA439 (0.0, 'CENTRIC', 7, 0.5, 2, 2, 16.0,  8.5)
        CALL GGIP (0.0, 2.0, 0.0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        DO I = 1, 25
          X = ZT(I, 1) * SCALEX
          Y = ZT(I, 8) * SCALEY
          CALL GGIP (X, Y, 0.0, 2)
        END DO
C * ACENTRIC
        CALL PLA439 (0.0, 'ACENTRIC', 8, 0.5, 3, 2, 16.0,  7.0)
        CALL GGIP (0.0, 3.0, 0.0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        DO I = 1, 25
          X = ZT(I, 1) * SCALEX
          Y = ZT(I, 7) * SCALEY
          CALL GGIP (X, Y, 0.0, 2)
        END DO
C * EXPERIMENTAL
        CALL PLA439 (0.0, 'EXPERIMENTAL', 12, 0.5, 1, 2, 16.0,  5.5)
        CALL GGIP (0.0, 1.0, 0.0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        DO I = 1, 25
          X = ZT(I, 1) * SCALEX
          Y = ZT(I, 3) * SCALEY
          CALL GGIP (X, Y, 0.0, 2)
        END DO
      END IF
      CALL GGIP (0.0, 0.0, 0.0, 6)
      RETURN
99999 FORMAT (F7.1, 11X, 5F12.3, 2X, 3F12.3)
99998 FORMAT (40X, 'N(Z) CUMULATIVE PROBABILITY DISTRIBUTION')
99997 FORMAT (45X, 'EXPERIMENTAL', 39X, 'THEORETICAL')
99996 FORMAT (23X, 'ALL DATA', 7X, 'HKL', 9X, '0kl', 9X, 'h0l', 9X,
     1  'hk0', 8X, 'ACENTRIC', 5X, 'CENTRIC', 2X, 'HYPERCENTRIC')
99995 FORMAT (F3.1)
99994 FORMAT ('N(Z): Howells, E.R., Phillips, D.C. & Rogers,D. (1950),',
     1 ' Acta Cryst., 3, 210-214')
      END SUBROUTINE PLA379
 
      SUBROUTINE PLA381 (MODE, LRETPDB)
C * PDB-READ
      USE files
      USE parameters
      USE atomdata
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: N1
      INTEGER :: N2
      INTEGER :: IP
      INTEGER :: NB
      INTEGER :: NE
      INTEGER :: NAT
      INTEGER :: IER
      INTEGER :: NAT2
      INTEGER :: NATC
      INTEGER :: NATH
      INTEGER :: NATN
      INTEGER :: NATO
      INTEGER :: NATS
      INTEGER :: NCRY
      INTEGER :: MODE
      INTEGER :: INQNR
      INTEGER :: LRETPDB
      REAL    :: ADD
      REAL    :: XADD
      IF (LRETPDB == 0) THEN
        NATC = 0
        NATO = 0
        NATN = 0
        NATS = 0
        NATH = 0
        NAT  = 0
        NAT2 = 0
        NCRY = 0
        XADD = 25.0
        ADD  = 0.0
        DO
          READ (IGBL(5), 99997, IOSTAT = IOST) ICL(1:80)
          IF (IOST /= 0) THEN
            IF (IOST == -1) THEN
              GO TO 20
            ELSE
              GO TO 30
            END IF
          END IF
          CALL GEN020 (1, ICL, 1, 80)
          IF (ICL(1:4) == 'ATOM' .OR. ICL(1:4) == 'HETA') THEN
            READ (ICL, 99998) NQ1(1:7), (FN(L), L = 1, 3)
            FN(1) = FN(1) + ADD
            NB    = 1
            NE    = 2
            N1    = 0
            N2    = 0
C * TEST FOR A-Z OF FIRST CHARACTER
            IF (ICHAR (NQ1(1:1)) > 64 .AND. ICHAR (NQ1(1:1)) < 91)
     1        N1 = 1
C * TEST FOR A-Z OF SECOND CHARACTER
            IF (ICHAR (NQ1(2:2)) > 64 .AND. ICHAR (NQ1(2:2)) < 91)
     1        N2 = 1
            IF (N1 == 1 .AND. N2 == 0) THEN
              NE = 1
            ELSE IF (N1 == 0 .AND. N2 == 1) THEN
              NB = 2
            ELSE IF (N1 == 1 .AND. N2 == 1) THEN
              NAT2 = NAT2 + 1
              N    = NAT2
              GO TO 10
            ELSE
              WRITE (LU6, 99995, IOSTAT = IOST) NQ1
              RETURN
            END IF
            IF (NQ1(NB:NE) == 'C') THEN
              NATC = NATC + 1
              N    = NATC
            ELSE IF (NQ1(NB:NE) == 'O') THEN
              NATO = NATO + 1
              N    = NATO
            ELSE IF (NQ1(NB:NE) == 'N') THEN
              NATN = NATN + 1
              N    = NATN
            ELSE IF (NQ1(2:2) == 'S') THEN
              NATS = NATS + 1
              N    = NATS
            ELSE IF (NQ1(2:2) == 'H') THEN
              NATH = NATH + 1
              N    = NATH
            ELSE
              NAT  = NAT + 1
              N    = NAT
            END IF
   10       N  = MOD (N, 1000)
            CALL GEN040 (N, NQ2, IP)
            IFL(1)   = NQ1(NB:NE)//NQ2(1:IP)
            IPR(473) = 1
            IPR(220) = 1
            IPR(221) = 3
            IF (MODE == 0) THEN
              CALL PLA022 (INQNR)
              IF (INQNR == 0) THEN
                IGBL(54) = IGBL(54) + 1
                GO TO 20
              END IF
            ELSE
              CALL PLUT03 (IER)
            END IF
C * ANISOU
          ELSE IF (ICL(1:6) == 'ANISOU') THEN
            READ (ICL(29:70), 99996)
     1      FN(1), FN(2), FN(3), FN(6), FN(5), FN(4)
            DO I = 1, 6
              FN(I) = FN(I) / 10000.0
            END DO
            FN(7) = 0.0
            FN(8) = 0.0
C * REGISTER (AN)ISO PARAMETER INPUT
            IPR(32) = MAX (IPR(32), 1)
            WRITE (LU4) 2, INQNR, (FN(K), K = 1, 8)
            CYCLE
          ELSE IF (ICL(1:3) == 'ADD') THEN
            XADD = FN(1)
          ELSE IF (ICL(1:5) == 'CRYST') THEN
            NCRY = NCRY + 1
            IF (NCRY == 2) ADD = XADD
          ELSE IF (ICL(1:3) == 'END') THEN
            IFL(1)   = 'ENDS'
            ICL      = 'ENDS'
            IPR(220) = 1
            IPR(221) = 0
            IGBL(8) = - IABS (IGBL(8))
            RETURN
          ELSE IF (ICL(1:5) == 'CONECT') THEN
          ELSE IF (ICL(1:5) == 'MASTER') THEN
          END IF
        END DO
      ELSE IF (LRETPDB == -1) THEN
C * CHECK FOR PDB-FILE-STRUCTURE (TRIGGERED BY KEYWORD HEADER ON LINE 1)
        IF (ICL(1:6) == 'HEADER' .OR.
     1      ICL(1:6) == 'REMARK' .OR.
     2      ICL(1:6) == 'COMPND') THEN
          IGBL(8) = 4
          IF (ICL(63:66) /= '    ') THEN
            JID(1:72) = ICL(63:66)
          ELSE
            JID(1:72) = ICL(8:50)
          END IF
          WRITE (LU6, 99999, IOSTAT = IOST)
          IPR(220) = 1
          IPR(221) = 0
C * GET NUMBER OF ENTRIES IN MENU MODE
          IF (IGBL(25) /= 0) THEN
            CALL PLA007
          ELSE
            CALL GEN108 (LU1, 0)
          END IF
          RETURN
        END IF
        IF (ICL(1:5) == 'CRYST') THEN
          IGBL(8) = 4
          WRITE (LU6, 99999, IOSTAT = IOST)
          RETURN
        END IF
      END IF
      RETURN
C * ERROR
   20 LRETPDB = 1
      RETURN
C * END
   30 LRETPDB = 2
      RETURN
99999 FORMAT (/, ':: PDB Type File Format Assumed (HEADER/CRYST)', /)
99998 FORMAT (12X, A, 11X, 3F8.0)
99997 FORMAT (A)
99996 FORMAT (6F7.0)
99995 FORMAT ('Atom ', A, ' - Skipped')
      END SUBROUTINE PLA381
 
      SUBROUTINE PLA382 (IRETN)
C * LIST OPTION(S) ON DISPLAY (ATOMS/BONDS/SYMM/PAR/IPR/IGBL/RADII/CELL)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
 
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: NAT
      INTEGER          :: IF1
      INTEGER          :: IF2
      INTEGER          :: IF3
      INTEGER          :: IF4
      INTEGER          :: IF5
      INTEGER          :: IF6
      INTEGER          :: IF7
      INTEGER          :: IF8
      INTEGER          :: IF9
      INTEGER          :: IF10
      INTEGER          :: IF11
      INTEGER          :: IF12
      INTEGER          :: IF13
      INTEGER          :: IF14
      INTEGER          :: IF15
      INTEGER          :: IF16
      INTEGER          :: IF17
      INTEGER          :: IF18
      INTEGER          :: IF19
      INTEGER          :: IF20
      INTEGER          :: IF21
      INTEGER          :: IF22
      INTEGER          :: IF23
      INTEGER          :: JMAX
      INTEGER          :: KMAX
      INTEGER          :: MODE
      INTEGER          :: IVAL
      INTEGER          :: IDUM
      INTEGER          :: JDUM
      INTEGER          :: IRETN
      CHARACTER(len=1) :: ICH
      IF (IGBL(8) /= 2 .OR. IGBL(5) == LU5) THEN
        IPR(84) = 0
        IPR(1)  = 4
        IWIN    = IGBL(25) * IGBL(32)
        IF (IPR(220) > 1) THEN
C * LIST IPR/PAR/IGBL/RGBL
          IF (IPR(220) >= 2) THEN
            SELECT CASE (IFL(2)(1:3))
              CASE ('IPR')
                CALL PLA206 (-1, 'IPR')
              CASE ('PAR')
                CALL PLA206 (-1, 'PAR')
              CASE ('IGB')
                CALL PLA206 (-1, 'IGB')
              CASE ('RGB')
                CALL PLA206 (-1, 'RGB')
              CASE ('CHK')
                CALL PLA206 (-1, 'CHK')
C * LIST FLAGS
              CASE ('FLA')
                NAT = IPR(39) + IPR(64)
                WRITE (PRBUF, 99995, IOSTAT = IOST)
                IF (IWIN == 1) THEN
                  CALL GGIP (HORS, VERT, 0.0, 1)
                  VRT = VERT - 0.6
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68),
     1              2, 1.0, VRT)
                  VRT = VRT - 0.2
                ELSE
                  WRITE (LU6, 99997, IOSTAT = IOST) PRBUF(1:80)
                END IF
                DO I = 1, NAT
                  CALL PLA047 (LABA(I), NQ1, IDUM, JDUM,
     1              IPR(71), IGBL(55), 0, 1 - IGBL(55))
                  CALL GEN048 (-3,  IFG(1, I), 1,  IF1)
                  CALL GEN048 (-1,  IFG(1, I), 4,  IF2)
                  CALL GEN048 (-1,  IFG(1, I), 5,  IF3)
                  CALL GEN048 (-1,  IFG(1, I), 6,  IF4)
C * H-ATOM
                  CALL GEN048 (-1,  IFG(1, I), 7,  IF5)
                  CALL GEN048 (-1,  IFG(1, I), 8,  IF6)
C * RESIDUE #
                  CALL GEN048 (-6,  IFG(1, I), 9,  IF7)
C * ATOM TYPE # IN IEN
                  CALL GEN048 (-4,  IFG(1, I), 15, IF8)
                  CALL GEN048 (-1,  IFG(1, I), 19, IF9)
                  CALL GEN048 (-1,  IFG(1, I), 20, IF10)
                  CALL GEN048 (-1,  IFG(1, I), 21, IF11)
                  CALL GEN048 (-1,  IFG(1, I), 22, IF12)
                  CALL GEN048 (-1,  IFG(1, I), 23, IF13)
                  CALL GEN048 (-4,  IFG(1, I), 24, IF14)
C * OMIT  (FROM SFCalc)
                  CALL GEN048 (-1,  IFG(1, I), 30, IF15)
C * C(O2), N(O3), S(O4), Cl(O4), P(O4)
                  CALL GEN048 (-1,  IFG(1, I), 31, IF16)
C * POP
                  CALL GEN048 (-8,  IFG(2, I),  1, IF17)
C * ISI(0/1)
                  CALL GEN048 (-1,  IFG(2, I), 10, IF18)
C * LABEL (0/1)
                  CALL GEN048 (-1,  IFG(2, I), 11, IF19)
C * HINC (0/1)
                  CALL GEN048 (-1,  IFG(2, I), 12, IF20)
C * LABUTTE #
                  CALL GEN048 (-10, IFG(2, I), 14, IF21)
C * # ATTACHED H
                  CALL GEN048 (-3,  IFG(2, I), 24, IF22)
C * PART
                  CALL GEN048 (-5,  IFG(3, I), 14, IF23)
                  WRITE (PRBUF, 99983, IOSTAT = IOST) I, NQ1, IF1,
     1              IF2, IF3, IF4, IF5, IF6, IF7, IF8, IF9, IF10,
     2              IF11, IF12, IF13, IF14, IF15, IF16, IF17, IF18,
     3              IF19, IF20, IF21, IF22, IF23 -16
                  IF (IWIN == 1) THEN
                    IF (VRT - 0.4 < 0) THEN
C * WHAT NEXT ?
                      CALL PLA012 (1, 1)
                      ICH = IGGT(1:1)
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      IF (ICH /= 'Y' .AND. ICH /= '!') RETURN
                      VRT = VERT
                    END IF
                    VRT = VRT - 0.4
                    CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                  ELSE
                    WRITE (LU6, 99994, IOSTAT = IOST) PRBUF(1:80)
                  END IF
                END DO
                IF (IWIN == 1) CALL PLA297 (1)
C * LIST/INFO SYMM
              CASE ('SYM')
                CALL PLA274
C * LIST/INFO CELL
              CASE ('CEL')
                WRITE (BCD, 99991, IOSTAT = IOST)
     1            (PAR(J), J = 101, 106), CHAR (0)
                IF (IWIN == 1) THEN
                  IF (ABS (IGBL(6)) >= 10 .AND.
     1                ABS (IGBL(6)) <= 12) IGBL(6) = - IABS (IGBL(6))
                  CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 66.0, 111)
                ELSE
                  WRITE (LU6, 99985, IOSTAT = IOST) BCD(1:65)
                END IF
C * LIST/INFO RADII
              CASE ('RAD')
                WRITE (PRBUF, 99998, IOSTAT = IOST)
                IF (IWIN == 1) THEN
                  CALL GGIP (HORS, VERT, 0.0, 1)
                  VRT = VERT - 2.0
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:75)
                END IF
                WRITE (PRBUF, 99982, IOSTAT = IOST)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.6
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:75)
                END IF
                WRITE (PRBUF, 99993, IOSTAT = IOST) PAR(2)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.9
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99985, IOSTAT = IOST) PRBUF(1:75)
                END IF
                WRITE (PRBUF, 99981, IOSTAT = IOST) PAR(542)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.6
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:75)
                END IF
                WRITE (PRBUF, 99980, IOSTAT = IOST) IGBL(97) * PAR(26)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.6
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:75)
                END IF
                WRITE (PRBUF, 99990, IOSTAT = IOST) PAR(3)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.6
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:75)
                END IF
                WRITE (PRBUF, 99999, IOSTAT = IOST)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.9
                  CALL PLA439 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2,
     1                         1.0, VRT)
                ELSE
                  WRITE (LU6, 99985, IOSTAT = IOST) PRBUF(1:75)
                END IF
                DO I = 1, IAN
                  WRITE (PRBUF, 99996, IOSTAT = IOST)
     1              LMT(I, 1), RADR(I, 3), RADR(I, 4), RADR(I, 2)
                  IF (IWIN == 1) THEN
                    VRT = VRT - 0.6
                    CALL PLA439 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                  ELSE
                    WRITE (LU6, 99984, IOSTAT = IOST) PRBUF(1:75)
                  END IF
                END DO
                IF (IWIN == 1) CALL PLA297 (1)
C * LIST/INFO U1, U2, U3, U(eq) and U3/U1 VALUES
 
              CASE ('UIJ','UEQ')
C * TEST FOR PREVIOUS CALC UNIQUE (NO = 0)
                IF (IFL(2)(1:3) == 'UIJ') THEN
                  MODE = 0
                ELSE
                  MODE = 1
                END IF
                IF (IPR(30) /= 0) THEN
                  IF (MODE == 0) THEN
                    WRITE (PRBUF, 99987, IOSTAT = IOST)
                  ELSE
                    WRITE (PRBUF, 99988, IOSTAT = IOST)
                  END IF
                  IF (IWIN == 1) THEN
                    CALL GGIP (HORS, VERT, 0.0, 1)
                    VRT = VERT - 0.6
                    CALL PLA439 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68),
     1                           2, 1.0, VRT)
                    VRT = VRT - 0.2
                  ELSE
                    WRITE (LU6, 99994, IOSTAT = IOST) PRBUF(1:75)
                  END IF
                  NAT = IPR(39)
                  DO I = 1, NAT
                    DO J = 1, 12
                      FN(J) = VOID(IPR(297) + (I - 1) * 21 + J)
                    END DO
                    CALL PLA047 (LABA(I), NQ1, IDUM, JDUM,
     1                IPR(71), IGBL(55), 0, 0)
C * TEST FOR (AN)ISOTROPIC
                    CALL GEN048 (-1, IFG(1, I), 4, IVAL)
                    IF (IVAL == 1) THEN
                      IF (MODE == 0) THEN
                        KMAX = 6
                        JMAX = 4
                      ELSE
                        JMAX  = 5
                        FN(4) = 0.0
                        DO J = 1, 3
                          FN(J) = FN(J + 9)**2
                          FN(4) = FN(4) + FN(J) / 3.0
                        END DO
                        FN(5) = FN(3) / FN(1)
                      END IF
                    ELSE
C * SKIP ISOTROPIC H-ATOMS
                      CALL GEN048 (-1, IFG(1, I), 7, IVAL)
                      IF (IVAL == 1) CYCLE
                      KMAX = 1
                      JMAX = 1
                      IF (MODE == 1) FN(1) = FN(10)**2
                    END IF
                    IF (MODE == 0) THEN
                      WRITE (PRBUF, 99986, IOSTAT = IOST)
     1                  NQ1(1:10), (ANIS(I, J), J = 1, KMAX)
                    ELSE
                      WRITE (PRBUF, 99989, IOSTAT = IOST)
     1                  NQ1, (FN(J), J = 1, JMAX)
                    END IF
                    IF (IWIN == 1) THEN
                      IF (VRT - 0.4 < 0.0) THEN
C * WHAT NEXT ?
                        CALL PLA012 (1, 1)
                        ICH = IGGT(1:1)
                        CALL GGIP (HORS, VERT, 0.0, 1)
                        IF (ICH /= 'Y' .AND. ICH /= '!') RETURN
                        VRT = VERT
                      END IF
                      VRT = VRT - 0.4
                      CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                    ELSE
                      WRITE (LU6, 99994, IOSTAT = IOST) PRBUF(1:80)
                    END IF
                  END DO
                  IF (IWIN == 1) CALL PLA297 (1)
                END IF
C * LIST ARU
              CASE ('ARU')
                CALL PLA043 (0, -2, LU6, 1)
                IF (IWIN == 1) CALL PLA297 (1)
C * LIST/INFO ATOMS AND BONDS
              CASE ('ATO')
                IF (IPR(39) > 0) THEN
                  IPR(84) = 1
                  IRETN   = 1
                  RETURN
                ELSE
                  WRITE (LU6, 99992, IOSTAT = IOST)
                ENDIF
              CASE ('BON')
                IF (IPR(39) > 0) THEN
                  IPR(84) = 2
                  IRETN   = 1
                  RETURN
                ELSE
                  WRITE (LU6, 99992, IOSTAT = IOST)
                END IF
            END SELECT
            RETURN
          END IF
        END IF
        IRETN = 1
      END IF
      RETURN
99999 FORMAT ('Element   Covalent(RC) van der Waals(RW) Current')
99998 FORMAT ('INTRA BONDS    for Dist(I-J) < RC(I) + RC(J)',
     1        ' + TOLA + (TOLEA/TOLCUO)')
99997 FORMAT (/, A, /)
99996 FORMAT (A, 1X, 4(4X, F10.2))
99995 FORMAT ('Atom Label', 8X, 'DFN A S P H C  R  T M P D A A  H O O',
     1        '  P U L H    L N PT')
99994 FORMAT (A)
99993 FORMAT ('TolA   [=PAR(2)]   = ', F5.2,
     1        ' Ang., current INTRA tolerance')
99992 FORMAT (':: No ATOMS supplied as yet')
99991 FORMAT ('CELL ', 3F10.4, 3F10.2, A)
99990 FORMAT ('TolR   [=PAR(3)]   = ', F5.2,
     1        ' Ang., current INTER tolerance')
99989 FORMAT (A, 1X, 3F8.4, 3X, F8.4, F10.2)
99988 FORMAT ('Atom', 13X , 'U1', 6X, 'U2', 6X, 'U3', 8X, 'U(eq)',
     1         5X, 'U3/U1')
99987 FORMAT ('Atom', 12X, 'U11', 6X, 'U22', 6X, 'U33', 6X, 'U23', 6X,
     1        'U13', 6X, 'U12')
99986 FORMAT (A, 6F9.4)
99985 FORMAT (/, ':: ', A)
99984 FORMAT (':: ', A)
99983 FORMAT (I4, 1X, A, I4, 5I2, 2I3, 5I2, I3, 2I2, I3, 3I2, I5, I2,
     1        I3)
99982 FORMAT ('INTER CONTACTS for Dist(I-J) < RW(I) + RW(J) + TOLR')
99981 FORMAT ('TolCuO [=PAR(542)] = ', F5.2,
     1        ' Ang., add for (Cu...O,N) Contacts')
99980 FORMAT ('TolEA  [=PAR(26)]  = ', F5.2,
     1        ' Ang., add for (Earth)Alkali- non-metal contacts')
      END SUBROUTINE PLA382
 
      SUBROUTINE PLA383 (IS)
C * HANDLE SHELXL TYPE INSTRUCTION RECORDS (.ins OR .res FILES)
      USE parameters
      USE files
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IS
      IF (IS > 0) THEN
        SELECT CASE (IS)
C * IS = 2: TITL RECORD
          CASE (2)
            M = 1
            N = 0
            CALL GEN039 (0, ICL, 5, 80, M, N)
            IF (N >= M) THEN
              JID = ICL(M:N)
              IF (N - M + 1 > 32) N = M + 31
              L = INDEX (ICL(M:N), ' ')
              IF (L /= 0) N = M + L - 2
              DATANM = ICL(M:N)
            ELSE
              DATANM = 'X'
            END IF
            CALL GEN020 (-1, DATANM, 1, 32)
            WRITE (LU6, 99999, IOSTAT = IOST) JID(1:50)
            IF (IGBL(100) == 0 .AND. (IABS (IGBL(8)) == 2 .OR.
     1                                IABS (IGBL(8)) == 1)) THEN
              IPR(220) = 1
              IPR(221) = 0
              IGBL(54) = -1
              CALL PLA007
            END IF
            IF (IGBL(100) > 0) THEN
              IGBL(54) = IGBL(54) + 1
            ELSE
              IGBL(54) = 1
            END IF
C * IS = 4: REM RECORD
          CASE (4)
C * IS = 29: LIST RECORD
          CASE (29)
            RETURN
C * IS = 30: CELL RECORD
          CASE (30)
            RETURN
C * IS = 32: SYMM RECORD
          CASE (32)
            RETURN
C * IS = 34: LATT RECORD
          CASE (34)
            RETURN
C * IS = 43: FVAR RECORD
          CASE (43)
            IGBL(8) = 2
            IF (IPR(109) + IPR(221) > NP25) THEN
              IPR(2) = 30
              IS     = 0
              RETURN
            END IF
C * STORE STRIPPED FREE VARIABLES
            DO I = 1, IPR(221)
              IF (IPR(109) + I == 1) THEN
                RP(1) = FN(1)
              ELSE
                RP(IPR(109) + I) = MOD (FN(I) + 5.0, 10.0) - 5.0
              END IF
            END DO
C * SAVE FVAR SCALE
            IF (IPR(109) == 0) THEN
              PAR(74) = RP(1)
              RP(1)   = 1.0
            END IF
            IPR(109) = IPR(109) + IPR(221)
C * IS = 47: AFIX RECORD
          CASE (47)
            IGBL(8) = 2
C * IS = 48: SFAC RECORD
          CASE (48)
            RETURN
C * IS = 49: UNIT RECORD (SHELX)
          CASE (49)
            IGBL(8) = 2
            DO I = 1, IPR(221)
              CONT(I, 3) = FN(I) * PAR(32)
            END DO
C * IS = 50: WGHT RECORD (SHELX)
          CASE (50)
            IGBL(8)  = 2
            IPR(632) = 1
            PAR(493) = FN(1)
            PAR(494) = FN(2)
            PAR(495) = FN(3)
C * IS = 54: BOND RECORD (SHELX)
          CASE (54)
            IGBL(8) = 2
C * IS = 55: ZERR RECORD (SHELXTL/SHELXL)
          CASE (55)
            DO I = 2, 7
              PAR(105 + I) = FN(I)
            END DO
            IGBL(8) = 2
C * IS = 57: L.S. RECORD (SHELX)
          CASE (57)
            IGBL(8) = 2
C * IS = 58: FMAP RECORD (SHELX)
          CASE (58)
            IGBL(8) = 2
C * IS = 62: BLOC RECORD (SHELX)
          CASE (62)
            IGBL(8) = 2
C * IS = 64: OMIT RECORD
          CASE (64)
            RETURN
C * IS = 65: GRID RECORD (SHELX)
          CASE (65)
            IGBL(8) = 2
C * IS = 66: DFIX RECORD (SHELX)
          CASE (66)
            IGBL(8) = 2
C * IS = 73: PART RECORD - SHELXL STYLE
          CASE (73)
            IPR(612) = NINT (FN(1))
            IGBL(30) = 1
C * IS = 76 : RTAB RECORD
          CASE (76)
            RETURN
C * IS = 77 : SIMU RECORD
          CASE (77)
            RETURN
C * IS = 81: EXTI RECORD (SHELXL)
          CASE (81)
            PAR(229) = FN(1)
C * IS = 98: PLAN RECORD
          CASE (98)
            RETURN
C * IS = 99: TWIN RECORD
          CASE (99)
            IF (IPR(221) == 0) THEN
              PAR(332) = -1.0
              PAR(336) = -1.0
              PAR(340) = -1.0
            ELSE
              DO I = 1, 9
                PAR(331 + I) = FN(I)
              END DO
            END IF
            IPR(193) = IPR(193) + 100
C * IS = 100: SPEC RECORD
          CASE (100)
            RETURN
C * IS = 101: MERG RECORD
          CASE (101)
            RETURN
C * IS = 102: SUMP RECORD
          CASE (102)
            RETURN
C * IS = 103: RESI RECORD
          CASE (103)
            IPR(538) = NINT (FN(1))
C * IS = 104: SHEL RECORD
          CASE (104)
            IF (IPR(221) == 2 .AND. FN(1) > 0.0) THEN
              IF (FN(2) /= 0.0) THEN
                PAR(165) = ASIN (PAR(17) / (2.0 * FN(2))) * RGBL(6)
              END IF
              IGBL(8)  = 2
            END IF
C * IS = 105: MORE RECORD
          CASE (105)
            RETURN
C * IS = 107: CGLS RECORD
          CASE (107)
            RETURN
C * IS = 108: ACTA RECORD
          CASE (108)
            RETURN
C * IS = 109: DAMP RECORD
          CASE (109)
            RETURN
C * IS = 110: DISP RECORD
          CASE (110)
            RETURN
C * IS = 112: CRYSTAL SIZE RECORD
          CASE (112)
            IF (IPR(221) == 3) THEN
              CALL GEN034 (FN, 1, 3)
              DO I = 1, 3
                PAR(301 + I) = FN(I)
              END DO
            END IF
C * IS = 113: EQIV RECORD
          CASE (113)
            RETURN
C * IS = 114: EXYZ RECORD
          CASE (114)
            RETURN
C * IS = 115: EADP RECORD
          CASE (115)
            RETURN
C * IS = 116: NCSY RECORD
          CASE (116)
C * IS = 117: FREE RECORD
          CASE (117)
            RETURN
C * IS = 118: BIND RRCORD
          CASE (118)
            RETURN
C * IS = 119: SAME RECORD
          CASE (119)
            RETURN
C * IS = 120: CONF RECORD
          CASE (120)
            RETURN
C * IS = 121: MPLA RECORD
          CASE (121)
            RETURN
C * IS = 122: FLAT RECORD
          CASE (122)
            RETURN
C * IS = 123: CHIV RECORD
          CASE (123)
            RETURN
C * IS = 124: DELU RECORD
          CASE (124)
            RETURN
C * IS = 125: ISOR RECORD
          CASE (125)
            RETURN
C * IS = 126: SADI RECORD
          CASE (126)
            RETURN
C * IS = 127: ANIS RECORD
          CASE (127)
            RETURN
C * IS = 129: HFIX RECORD
          CASE (129)
            RETURN
C * IS = 130: LAUE RECORD
          CASE (130)
            RETURN
C * IS = 131: BUMP RECORD
          CASE (131)
            RETURN
C * IS = 132: TEMP RECORD (SHELX ==> DEG. C) ([C]/K)
          CASE (132)
            IF (IFL(2)(1:1) == 'K') THEN
              IPR(261) = NINT (FN(1))
            ELSE
              IPR(261) = NINT (FN(1)) + 273
            END IF
C * IS = 133: DEFS RECORD
          CASE (133)
C * IS = 135: SWAT RECORD
          CASE (135)
C * IS = 141: WPDB RECORD
          CASE (141)
C * IS = 142: BASF RECORD
          CASE (142)
            IF (IPR(221) > 0) THEN
              DO I = 1, IPR(221)
                BASF(I) = FN(I)
              END DO
              IPR(513) = IPR(221)
              PAR(341) = FN(1)
              IPR(193) = IPR(193) + 1
            END IF
C * IS = 144: FRAG RECORD
          CASE (144)
C * IS = 189: ABIN RECORD (SHELXL COMMAND)
          CASE (189)
            IPR(766) = 1
C * IS = 190: ANSC RECORD (SHELXL COMMAND)
          CASE (190)
C * IS = 191: ANSR RECORD (SHELXL COMMAND)
          CASE (191)
C * IS = 192: NEUT RECORD (SHELXL COMMAND)
          CASE (192)
            IPR(493) = 7
C * IS = 193: PRIG RECORD (SHELXL COMMAND)
          CASE (193)
C * IS = 194: RIGU RECORD (SHELXL COMMAND)
          CASE (194)
C * IS = 195: STIR RECORD (SHELXL COMMAND)
          CASE (195)
C * IS = 196: TWST RECORD (SHELXL COMMAND)
          CASE (196)
C * IS = 197: WIGL RECORD (SHELXL COMMAND)
          CASE (197)
C * IS = 198: XNPD RECORD (SHELXL COMMAND))
          CASE (198)
C * IS = 201: DANG RECORD
          CASE (201)
            IGBL(8) = 2
C * IS = 207: PAIR RECORD
          CASE (207)
          CASE DEFAULT
            RETURN
        END SELECT
        IS = -4
      END IF
      RETURN
99999 FORMAT (':: Loaded Data Set: ', A, /)
      END SUBROUTINE PLA383
 
      SUBROUTINE PLA384
C * TEST FOR INORGANIC/ORGANIC/METALORGANIC
      USE parameters
      USE atomdata
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: NORGA
      INTEGER :: NORGB
      INTEGER :: NORGC
      NORGA    =  0
      NORGB    =  0
      NORGC    =  0
      IPR(325) = -1
      DO I = 1, IAN
        IF (IEN(I) == 2) THEN
          NORGA = 1
C * H/D/HW
        ELSE IF (IEN(I) ==  1 .OR. IEN(I) == 33 .OR.
     1    IEN(I) == 113) THEN
          NORGB = 1
C * F
        ELSE IF (IEN(I) == 38) THEN
          NORGB = 1
C * METAL
        ELSE IF (IATPR(IEN(I)) > 0) THEN
          NORGC = 1
        END IF
      END DO
      IF (NORGA + NORGB == 2) THEN
        IPR(325) = NORGC
C * TEST FOR _publ_requested_category 'FI,CI,OI'
        IF (IGBL(99) /= 1) IGBL(97) = 1
      END IF
      RETURN
      END SUBROUTINE PLA384
 
      SUBROUTINE PLA385 (IMODE)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: KL
      INTEGER                  :: KN
      INTEGER                  :: NB
      INTEGER                  :: NN
      INTEGER                  :: N12
      INTEGER                  :: JEL
      INTEGER                  :: MRK
      INTEGER                  :: NMX
      INTEGER                  :: NSTP
      INTEGER                  :: NBCD
      INTEGER                  :: NELM
      INTEGER                  :: MARK
      INTEGER                  :: MODE
      INTEGER                  :: IMODE
      INTEGER, DIMENSION(NP10) :: IZ
      REAL                     :: X1
      REAL                     :: X2
      REAL                     :: Y1
      REAL                     :: Y2
      REAL                     :: Z1
      REAL                     :: FP
      REAL                     :: WL
      REAL                     :: WLB
      REAL                     :: WLE
      REAL                     :: SGN
      REAL                     :: FPP
      REAL                     :: DWL
      REAL                     :: FMX
      REAL                     :: WDF
      REAL                     :: XMU
      REAL                     :: FMUM
      REAL                     :: HRTM
      REAL                     :: VRTH
      REAL                     :: VRTM
      REAL                     :: XMARK
      REAL                     :: SCALEM
      REAL                     :: SCALEV
      PAGET = 'ANOM'
      IF (IGBL(7) == 1) THEN
        CLOSE (UNIT = LU7)
      END IF
      OPEN (UNIT = LU7, FILE = 'ANOM_Brennan_Cowan.lis',
     1  STATUS = 'UNKNOWN')
      IGBL(7) = 1
      CALL PLA262(-2)
      MODE    = IMODE
      IGBL(6) = 33
      IWIN    = IGBL(25) * IGBL(32)
C * DETERMINE AND PLOT F', F'' AND MU-VALUES
C * MODE = 1 - ANOM (PLOT)
C * MODE = 2 - MU   (PLOT)
C * GENERAL INSTRUCTION LOOP
      DO
        FP    = 0.0
        FPP   = 0.0
        XMU   = 0.0
        N12   = 0
        IZ(1) = 0
        VRTM  = VERT - 1.0
        HRTM  = HORS - 1.0
        VRTH  = VRTM / 2.0
C * GET ATOM TYPE WHEN SPECIFIED
        IF (IPR(220) == 2) THEN
          DO I = 1, 27
C * QUIT LOOP WHEN NOT A..Z
            IF (I == 27) GO TO 20
            IF (IFL(2)(1:1) == CHAR (ICHAR ('A') + I - 1)) THEN
              N12 = I * 100
              IF (IFL(2)(2:2) /= ' ') THEN
                DO J = 1, 27
C * QUIT LOOP WHEN NOT A..Z
                  IF (J == 27) GO TO 20
                  IF (IFL(2)(2:2) == CHAR (ICHAR ('A') + J - 1)) THEN
                    N12 = N12 + J
                    EXIT
                  END IF
                END DO
              END IF
              DO K = 1, NP9 + 1
C * QUIT WHEN ELEMENT NOT IN RANGE H..U (1..92)
                IF (K == NP9 + 1) GO TO 20
                IF (IEL(K) == N12) THEN
                  IZ(1) = IATNR(K)
                  GO TO 10
                END IF
              END DO
            END IF
          END DO
        END IF
C * GET WAVELENGTH
   10   IF (IPR(221) == 1) THEN
          IF (IZ(1) /= 0) THEN
            CALL PLA386 (IZ(1), FN(1), FP, FPP, XMU, LU6)
            CALL GEN020 (-1, IFL(2), 2, 2)
            WRITE (SBCD, 99999, IOSTAT = IOST) IZ(1), IFL(2)(1:2),
     1        FN(1), FP, FPP, XMU, CHAR (0)
            WRITE (LU6, 99998, IOSTAT = IOST) SBCD(1:76)
C * LOOP OVER ALL ELEMENTS FOR THIS WAVELENGTH
          ELSE
            M    = 0
            FMX  = 0.0
            FMUM = 0.0
            JEL = 0
            WRITE (LU6, 99992)
            REWIND (UNIT = LU7, IOSTAT= IOST)
            WRITE (LU7, 99992)
            DO I = 1, 92
              IZ(1) = I
              DO J = 1, NP9
                IF (IATNR(J) == IZ(1)) THEN
                  JEL = J
                  EXIT
                ENDIF
              END DO
              CALL PLA386 (IZ(1), FN(1), FP, FPP, XMU, 0)
              WRITE (SBCD, 99999, IOSTAT = IOST) I, ELB(JEL), FN(1),
     1          FP, FPP, XMU, CHAR (0)
              WRITE (LU6, 99998, IOSTAT = IOST) SBCD(1:76)
              WRITE (LU7, 99998, IOSTAT = IOST) SBCD(1:76)
              VOID(M + 1) = FLOAT (JEL)
              VOID(M + 2) = FP
              VOID(M + 3) = FPP
              VOID(M + 4) = XMU
              M           = M + 4
              FMX         = MAX (FMX, ABS (FP), FPP)
              FMUM        = MAX (FMUM, XMU)
            END DO
C * PLOT f',f" & mu of elements 1:92 for give wavelength
            IF (IWIN /= 0) THEN
              SCALEV   = (VRTH - 1.0) / FMX
              SCALEM   = (VERT - 3.0) / FMUM
              IF (MODE == 1) THEN
                WRITE (BCD, 99994, IOSTAT = IOST) FN(1)
              ELSE
                WRITE (BCD, 99993, IOSTAT = IOST) FN(1)
              END IF
              CALL GGIP (HORS, VERT, 0.0, 1)
              CALL PLA439 (0.0, BCD, 35, 0.8, 4, 8, 1.0, VERT - 1.2)
              CALL PLA439 (0.0, BCD, 35, 0.8, 2, 8, 0.9, VERT - 1.3)
              CALL PLA110 (HORS, VERT, -1)
C * MOVE TO NEW ORIGIN
              X1 = 1.0
C * ANOM f',f'' PLOT
              IF (MODE == 1) THEN
                Y1 = VRTH
C * ANOM Mu PLOT
              ELSE IF (MODE == 2) THEN
                Y1 = 1.0
              END IF
              Z1 = 0.0
              CALL GGIP (X1, Y1, Z1, -3)
              CALL GGIP (0.0,  0.0, 0.0, 3)
              CALL GGIP (HRTM, 0.0, 0.0, 2)
              CALL GGIP (0.0,  0.0, 0.0, 3)
              IF (MODE == 1) THEN
                CALL PLA439 (0.0,
     1          'S.Brennan&P.L.Cowan(1992).Rev.Sci.Instr.,63,850-853',
     2          51, 0.30, 1, 1, 1.0, VRTH - 1.0)
                CALL PLA439 (0.0, 'o = f''',   6, 0.3, 1, 1, 1.0,
     1                       VRTH - 3.0)
                CALL PLA439 (0.0, 'x = f''''', 7, 0.3, 1, 1, 1.0,
     1                       VRTH - 4.0)
                DO I = -INT(FMX), INT (FMX), 1
                  CALL GGIP (HRTM,      I * SCALEV, 0.0, 3)
                  CALL GGIP (HRTM -0.2, I * SCALEV, 0.0, 2)
                END DO
 
              END IF
              DO I = 1, 92
                X1 = I * (HRTM - 0.5) / 92
                JEL = NINT (VOID((I - 1) * 4 + 1))
                IF (MODE == 1) THEN
                  Y1 = VOID((I - 1) * 4 + 2) * SCALEV
                  CALL PLA439 (-90.0, 'o '//ELB(JEL), 4, 0.2, 1, 1,
     1                X1 - 0.2, Y1)
                  Y1 = VOID((I - 1) * 4 + 3) * SCALEV
                  CALL PLA439 (90.0, 'x '//ELB(JEL), 4, 0.2, 1, 1, X1,
     1              Y1)
                ELSE IF (MODE == 2) THEN
                  Y1 = VOID((I - 1) * 4 + 4) * SCALEM
                  CALL PLA439 (90.0, 'x '//ELB(JEL), 4, 0.2, 1, 1, X1,
     1              Y1)
                END IF
              END DO
            END IF
          END IF
C * PLOT f' &  f'' as a function of Lambda for elements in CIF
        ELSE IF (IPR(221) == 0) THEN
          IF (IPR(220) == 1) THEN
            NELM = 0
            DO I = 1, IAN
              N = IATNR(IEN(I))
              IF (N > 6) THEN
                NELM = NELM + 1
                IFL(NELM + 1) = LMT(I, 1)
                IZ(NELM)      = N
              END IF
            END DO
            IF (NELM == 0) GO TO 20
          ELSE
            NELM = 1
          ENDIF
          N    = 0
          FMX  = 0.0
          FMUM = 0.0
          WLB  = 2.0
          WLE  = 0.1
          WDF  = WLB - WLE
          MRK  = NINT (WDF * 10)
          NSTP = 500
          DWL  = WDF / NSTP
          DO J = 1, NELM
            WL = WLB + DWL
            DO I = 1, NSTP + 1
              WL = WL - DWL
              CALL PLA386 (IZ(J), WL, FP, FPP, XMU, 0)
              VOID(N + 1) = WL
              VOID(N + 2) = FP
              VOID(N + 3) = FPP
              VOID(N + 4) = XMU
              N           = N + 4
              FMX         = MAX (FMX, ABS (FP), FPP)
              FMUM        = MAX (FMUM, XMU)
            END DO
          END DO
          SCALEV   = VRTH / FMX
          SCALEM   = (VERT - 3.0) / FMUM
          IF (MODE == 1) THEN
            XMARK = 1.0
            NMX   = INT (FMX / XMARK)
            IF (NMX < 3) THEN
              XMARK = XMARK / 2.0
              NMX   = INT (FMX / XMARK)
            END IF
          ELSE IF (MODE == 2) THEN
            NN = INT (LOG (FMUM) / LOG (10.0))
            MARK = 10**NN
            NMX  = INT (FMUM / MARK)
            IF (NMX < 3) THEN
              MARK = MARK / 2
              NMX  = INT (FMUM / MARK)
            END IF
          ENDIF
          IF (IWIN /= 0) THEN
            IF (MODE == 1) THEN
              NBCD = 21
              BCD(1:NBCD) = 'Anomalous Dispersion'//CHAR (0)
            ELSE
              NBCD = 23
              BCD(1:NBCD) = 'Mu-value versus Lambda'//CHAR (0)
            END IF
            CALL GGIP (HORS, VERT, 0.0, 1)
            CALL PLA439 (0.0, BCD, NBCD, 1.2, 4, 8, 3.0, VERT - 1.7)
            CALL PLA439 (0.0, BCD, NBCD, 1.2, 2, 8, 2.9, VERT - 1.8)
            CALL PLA110 (HORS, VERT, -1)
C * MOVE TO NEW ORIGIN
            X1 = 1.0
            IF (MODE == 1) THEN
              Y1 = VRTH
            ELSE IF (MODE == 2) THEN
              Y1 = 1.0
            END IF
            Z1 = 0.0
            CALL GGIP (X1, Y1, Z1, -3)
C * ELECTRON SCALE
            IF (MODE == 1) THEN
              SGN = 1.0
              DO J = 1, 2
                IF (J == 2) SGN = -1.0
                X1 = 0.0
                Y1 = 0.0
                CALL GGIP (X1, Y1, Z1, 3)
                DO I = 1, NMX
                  Y1 = I * XMARK * SCALEV * SGN
                  CALL GGIP (X1, Y1, Z1, 2)
                  X2 = 0.2
                  CALL GGIP (X2, Y1, Z1, 2)
                  WRITE (NQ1, 99996, IOSTAT = IOST) I * XMARK * SGN
                  CALL PLA439 (0.0, NQ1, 6, 0.2, 1, 1, 0.1, Y1 + 0.1)
                  CALL GGIP (X1, Y1, Z1, 3)
                END DO
                Y1 = VRTH * SGN
                CALL GGIP (X1, Y1, Z1, 2)
                Y1 = 0.0
                CALL GGIP (X1, Y1, Z1, 3)
              END DO
            ELSE
              DO I = 1, NMX
                X1 = 0.0
                Y1 = I * MARK * SCALEM
                CALL GGIP (X1, Y1, 0.0, 2)
                X2 = 0.2
                CALL GGIP (X2, Y1, 0.0, 2)
                WRITE (NQ1, 99995, IOSTAT = IOST) I * MARK
                CALL PLA439 (0.0, NQ1, 6, 0.2, 1, 1, 0.1, Y1 + 0.1)
                CALL GGIP (X1, Y1, Z1, 3)
              END DO
              Y1 = VERT - 2.0
              CALL GGIP (X1, Y1, 0.0, 2)
              Y1 = 0.0
              CALL GGIP (X1, Y1, 0.0, 3)
            END IF
C * ANGSTROM SCALE
            X1 = 0.0
            Y1 = 0.0
            X2 = WLB
            WRITE (NQ1, 99997, IOSTAT = IOST) WLB
            CALL PLA439 (0.0, NQ1, 3, 0.2, 1, 1, 0.1, -0.3)
            CALL GGIP (X1, Y1, Z1, 3)
            DO I = 1, MRK
              X1 = I * HRTM / MRK
              CALL GGIP (X1, Y1, Z1, 2)
              Y2 = Y1 - 0.2
              CALL GGIP (X1, Y2, Z1, 2)
              IF (I < MRK) THEN
                WLB = WLB - 0.1
                WRITE (NQ1, 99997, IOSTAT = IOST) WLB
                CALL PLA439 (0.0, NQ1, 3, 0.2, 1, 1, X1 + 0.1, -0.3)
              END IF
              CALL GGIP (X1, Y1, Z1, 3)
            END DO
            DO I = 1, 5
              X1 = HRTM * (1.0 - ((STWL(I) - WLE) / WDF))
              Y1 = 0.5
              CALL PLA439 (90.0, CSTWL(I), 4, 0.30, 1, 2, X1 + 0.15,
     1                     Y1 + 0.1)
              CALL GGIP (0.0, 5.0, 0.0, 0)
              CALL GGIP (X1, 0.0, 0.0, 3)
              CALL GGIP (X1, Y1, 0.0, 2)
              CALL GGIP (0.0, 0.0, 0.0, 3)
            END DO
            CALL PLA439 (0.0, 'Angstrom', 8, 0.25, 1, 1, HRTM - 1.8,
     1        -0.8)
            NB = 0
            DO K = 1, NELM
C * DISPLAY ELEMENT-NAME
              NQ2 = IFL(K + 1)(1:2)
              IF (NQ2(1:1) /= ' ') CALL GEN020 (-1, NQ2, 2, 2)
              CALL PLA439 (0.0, NQ2, 2, 0.3, K, 1, HRTM - 1.0,
     1            2.0 + K * 0.4)
              IF (MODE == 1) THEN
C * DISPLAY f'
                X1 = 0.0
                Y1 = VOID(NB + 2) * SCALEV
                CALL PLA439 (0.0, 'f''', 2, 0.3, K, 1, 1.4, Y1 - 1.0)
                CALL GGIP (0.0, FLOAT (K), 0.0, 0)
                CALL GGIP (X1, Y1, Z1, 3)
                DO I = 2, NSTP + 1
                  X1 = HRTM * (I - 1) / NSTP
                  Y1 = VOID(NB + I * 4 + 2) * SCALEV
                  CALL GGIP (X1, Y1, Z1, 2)
                END DO
                X1 = 0.0
                Y1 = 0.0
                CALL GGIP (X1, Y1, Z1, 3)
C * DISPLAY f''
                X1 = 0.0
                Y1 = VOID(NB + 3) * SCALEV
                CALL PLA439 (0.0, 'f''''', 3, 0.3, K, 1, 1.4, Y1 )
                CALL GGIP (0.0, FLOAT (K), 0.0, 0)
                CALL GGIP (X1, Y1, Z1, 3)
                DO I = 2, NSTP + 1
                  X1 = HRTM * (I - 1) / NSTP
                  Y1 = VOID(NB + I * 4 + 3) * SCALEV
                  CALL GGIP (X1, Y1, Z1, 2)
                END DO
              ELSE
                X1 = 0.0
                Y1 = 0.0
                CALL GGIP (X1, Y1, Z1, 3)
C * DISPLAY MU
                X1 = 0.0
                Y1 = VOID(NB + 4) * SCALEM
                CALL GGIP (0.0, FLOAT (K), 0.0, 0)
                CALL GGIP (X1, Y1, Z1, 3)
                DO I = 2, NSTP + 1
                  X1 = HRTM * (I - 1) / NSTP
                  Y1 = VOID(NB + I * 4 + 4) * SCALEM
                  CALL GGIP (X1, Y1, Z1, 2)
                END DO
              END IF
              CALL GGIP (0.0, 0.0, 0.0, 3)
              NB = NB + (NSTP + 1) * 4
            END DO
          END IF
        END IF
C * CHECK FOR 'WHAT NEXT ?'
   20   IF (IWIN /= 0) THEN
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          IF (IGGT(1:4) /= 'PLOT') THEN
            CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1,
     1        1, 80, 7, NP17)
            IPR(220) = KL
            IPR(221) = KN
            IF (IFL(1)(1:4) == 'ANOM') THEN
              MODE  = 1
              IZ(1) = 0
            ELSE IF (IFL(1)(1:2) == 'MU') THEN
              MODE  = 2
              IZ(1) = 0
            ELSE IF (IFL(1)(1:3) == 'END') THEN
              EXIT
            ELSE IF (IFL(1)(1:4) == 'EXIT') THEN
              EXIT
            END IF
          END IF
        ELSE
          IFL(1) = 'END'
          EXIT
        END IF
      END DO
      IF (IGBL(7) /= 0) THEN
        WRITE (LU6, 99991)
        IGBL(7) = 0
      END IF
      IGBL(6) = 10
      RETURN
99999 FORMAT ('Element', I3, ', ', A, ', WaveLength:', F8.5, ', f'':',
     1  F8.4, ', f":', F8.4, ', Mu:', F10.1, A)
99998 FORMAT (A)
99997 FORMAT (F3.1)
99996 FORMAT (F6.2)
99995 FORMAT (I6)
99994 FORMAT ('f'' and f" at Lambda =', F8.5, ' Ang.')
99993 FORMAT ('Mu-Values at Lambda =', F8.5, ' Ang.')
99992 FORMAT (/, 'f'', f" and Mu values based on:', /,
     1 'S. Brennan & P.L. Cowan (1992). Rev.Sci.Instr., 63, 850-853',
     2 /)
99991 FORMAT (/, 'Listing output on File: ANOM_Brennan_Cowan.lis', /)
      END SUBROUTINE PLA385
 
      MODULE danom
      SAVE
      DOUBLE PRECISION                        :: DENERGYAU
      DOUBLE PRECISION                        :: DBINDNRGAU
      DOUBLE PRECISION                        :: DXSECTBARNS
      DOUBLE PRECISION                        :: DXSECTEDGEAU
      DOUBLE PRECISION, DIMENSION(5)          :: DXSECTINT
      END MODULE danom
 
      SUBROUTINE PLA386 (IZED, WAVELENGTH, FP, FPP, MU, LU)
C * Calculate f', f'' and mu values for arbitrary wavelengths.
C * Calculations based on Cromer and Liberman and McMasters
C * Code adapted from S.Brennan & P.L.Cowan (1992). Rev.Sci.Instr.,63,850-853
C * This version is based on the Roger J. Dejus distribution (25-Jan-1996)
      USE danom
      IMPLICIT NONE
      INTEGER                                 :: I
      INTEGER                                 :: J
      INTEGER                                 :: K
      INTEGER                                 :: LU
      INTEGER                                 :: IRB
      INTEGER                                 :: IZED
      INTEGER                                 :: IOST
      INTEGER                                 :: NEDGE
      INTEGER                                 :: IZERO
      INTEGER                                 :: INXSECT
      INTEGER,          DIMENSION(92)         :: NORB
      INTEGER,          DIMENSION(92, 24)     :: NPARMS
      INTEGER,          DIMENSION(92, 24)     :: IFUNTYP
      REAL                                    :: MU
      REAL                                    :: LI
      REAL                                    :: LE
      REAL                                    :: FP
      REAL                                    :: FPP
      REAL                                    :: KA1
      REAL                                    :: KA2
      REAL                                    :: KB1
      REAL                                    :: KB3
      REAL                                    :: LB1
      REAL                                    :: LB2
      REAL                                    :: LB3
      REAL                                    :: LB4
      REAL                                    :: LA1
      REAL                                    :: LA2
      REAL                                    :: LG1
      REAL                                    :: LG3
      REAL                                    :: WAVELENGTH
      REAL,             DIMENSION(24)         :: ABSEDGE
      DOUBLE PRECISION, DIMENSION(92, 24, 11) :: XSC
      DOUBLE PRECISION, DIMENSION(92, 4)      :: DRAY
      DOUBLE PRECISION, DIMENSION(92, 4)      :: DCMP
      DOUBLE PRECISION, DIMENSION(24, 11)     :: YNRG
      DOUBLE PRECISION, DIMENSION(6,  24, 92) :: XNRG
      DOUBLE PRECISION, DIMENSION(11)         :: DNRGS
      DOUBLE PRECISION, DIMENSION(92)         :: RELCOR
      DOUBLE PRECISION, DIMENSION(92)         :: XKPCOR
      DOUBLE PRECISION, DIMENSION(92, 24)     :: BINDNRG
      DOUBLE PRECISION, DIMENSION(11)         :: DXSECTS
      DOUBLE PRECISION, DIMENSION(11)         :: DLOGNRG
      DOUBLE PRECISION, DIMENSION(5)          :: DNRGINT
      DOUBLE PRECISION, DIMENSION(11)         :: DLOGXSECT
      DOUBLE PRECISION                        :: P1
      DOUBLE PRECISION                        :: P2
      DOUBLE PRECISION                        :: P3
      DOUBLE PRECISION                        :: AU
      DOUBLE PRECISION                        :: PI
      DOUBLE PRECISION                        :: RAY
      DOUBLE PRECISION                        :: COMP
      DOUBLE PRECISION                        :: DVAR
      DOUBLE PRECISION                        :: FTOMU
      DOUBLE PRECISION                        :: FINEPI
      DOUBLE PRECISION                        :: PLA387
      DOUBLE PRECISION                        :: GEN149
      DOUBLE PRECISION                        :: ENERGY
      DOUBLE PRECISION                        :: DFPORB
      DOUBLE PRECISION                        :: DSUMFP
      DOUBLE PRECISION                        :: DFPPORB
      DOUBLE PRECISION                        :: DFPCORR
      DOUBLE PRECISION                        :: DENERGY
      DOUBLE PRECISION                        :: DSUMFPP
      DOUBLE PRECISION                        :: KEVPERRYD
      DOUBLE PRECISION                        :: DLOGENERGY
      DOUBLE PRECISION                        :: INVFINESTRUCT
      DOUBLE PRECISION                        :: BARNSTOELECTRONS
      COMMON /ANOMD/ XSC, XNRG, RELCOR, XKPCOR, IFUNTYP, NPARMS, DRAY,
     1 DCMP, NORB, BINDNRG
      FTOMU            = 0.420803153D+8
      BARNSTOELECTRONS = 1.43110541D-8 ! barns to f"
      AU               = 2.80022D+7
      KEVPERRYD        = 0.02721D0
      FINEPI           = 0.6942325D+1
      PI               = 3.1415927D0
      INVFINESTRUCT    = 1.37036D+2
      IF (IZED > 0 .AND. IZED < 93 .AND. WAVELENGTH > 0.0) THEN
C * Conversion E = hc/lambda = 41.3566733*299.792458/lambda
        ENERGY = 12398.52D0 / DBLE (WAVELENGTH)
C * bind_nrg(1) = K in keV
C * bind_nrg(2) = LI "  "
C * bind_nrg(5) = M1 "  "
        NEDGE = NORB(IZED)
        DO I = 1, NEDGE
          ABSEDGE(I) = SNGL (BINDNRG(IZED, I) * 1000.0D0)
        END DO
        IF (LU > 0) THEN
          WRITE (LU, 99971)
          IF (NEDGE == 1) THEN
            WRITE (LU, 99972, IOSTAT = IOST) ABSEDGE(1)
          ELSE IF (NEDGE == 2) THEN
            WRITE (LU, 99973, IOSTAT = IOST) (ABSEDGE(I), I = 1, 2)
          ELSE IF (NEDGE .eq. 3) THEN
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99974, IOSTAT = IOST) (ABSEDGE(I), I = 1, 3)
            WRITE (LU, 99975, IOSTAT = IOST) KA2
          ELSE IF (NEDGE == 4) THEN
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99977, IOSTAT = IOST) KA1, KA2
          ELSE IF (NEDGE == 5) THEN
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99979, IOSTAT = IOST) KA1, KA2
            WRITE (LU, 99980, IOSTAT = IOST) ABSEDGE(5)
          ELSE IF (NEDGE == 6) THEN
            KB3 = ABSEDGE(1) - ABSEDGE(6)
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99982, IOSTAT = IOST) KA1, KA2, KB3
            WRITE (LU, 99983, IOSTAT = IOST) (ABSEDGE(I), I = 5, 6)
          ELSE IF (NEDGE == 7) THEN
            KB1 = ABSEDGE(1) - ABSEDGE(7)
            KB3 = ABSEDGE(1) - ABSEDGE(6)
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99995, IOSTAT = IOST) KA1, KA2, KB1, KB3
            WRITE (LU, 99986, IOSTAT = IOST) (ABSEDGE(I), I = 5, 7)
          ELSE IF (NEDGE == 8) THEN
            LB1 = ABSEDGE(2) - ABSEDGE(8)
            KB1 = ABSEDGE(1) - ABSEDGE(7)
            KB3 = ABSEDGE(1) - ABSEDGE(6)
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99995, IOSTAT = IOST) KA1, KA2, KB1, KB3
            WRITE (LU, 99989, IOSTAT = IOST) (ABSEDGE(I), I = 5, 8), LB1
          ELSE IF ((NEDGE == 9) .AND. (NEDGE < 14)) THEN
            LB1 = ABSEDGE(2) - ABSEDGE(8)
            LA1 = ABSEDGE(3) - ABSEDGE(9)
            KB1 = ABSEDGE(1) - ABSEDGE(7)
            KB3 = ABSEDGE(1) - ABSEDGE(6)
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99995, IOSTAT = IOST) KA1, KA2, KB1, KB3
            WRITE (LU, 99996, IOSTAT = IOST) (ABSEDGE(I), I = 5, 9)
            WRITE (LU, 99993, IOSTAT = IOST) LB1, LA1
C * N_EDGE >13
          ELSE
            KA1 = ABSEDGE(1) - ABSEDGE(4)
            KA2 = ABSEDGE(1) - ABSEDGE(3)
            KB1 = ABSEDGE(1) - ABSEDGE(7)
            KB3 = ABSEDGE(1) - ABSEDGE(6)
            LB1 = ABSEDGE(3) - ABSEDGE(8)
            LB2 = ABSEDGE(4) - ABSEDGE(14)
            LB3 = ABSEDGE(2) - ABSEDGE(7)
            LB4 = ABSEDGE(2) - ABSEDGE(6)
            LA1 = ABSEDGE(4) - ABSEDGE(9)
            LA2 = ABSEDGE(4) - ABSEDGE(8)
            LG1 = ABSEDGE(3) - ABSEDGE(13)
            LG3 = ABSEDGE(2) - ABSEDGE(12)
            LI  = ABSEDGE(4) - ABSEDGE(5)
            LE  = ABSEDGE(3) - ABSEDGE(5)
            WRITE (LU, 99994, IOSTAT = IOST) (ABSEDGE(I), I = 1, 4)
            WRITE (LU, 99995, IOSTAT = IOST) KA1, KA2, KB1, KB3
            WRITE (LU, 99996, IOSTAT = IOST) (ABSEDGE(I), I = 5, 9)
            WRITE (LU, 99997, IOSTAT = IOST)
     1        LB1, LB2, LB3, LB4, LA1, LA2
            WRITE (LU, 99998, IOSTAT = IOST) (ABSEDGE(I), I = 10, 14)
            WRITE (LU, 99999, IOSTAT = IOST) LG1, LG3, LI, LE
          END IF
          WRITE (LU, 99971)
        END IF
C * LOAD DATA FOR ELEMENT NUMBER IZED FROM XNRG
        IF (IZED > 2) THEN
          DO J = 1, NORB(IZED)
            DO K = 1, 5
              YNRG(J, K) = XNRG(K, 1, 1)
            END DO
            DO K = 6, NPARMS(IZED, J)
              YNRG (J, K) = XNRG(K - 5, J, IZED)
            END DO
          END DO
        END IF
        P1         = DLOG (ENERGY / 1000.0D0)
        P2         = P1 * P1
        P3         = P1 * P2
C * Change to keV
        DENERGY    = ENERGY / 1000.0D0
        DLOGENERGY = DLOG (DENERGY)
        DENERGYAU  = DENERGY / KEVPERRYD
        DSUMFP     = 0.D0
        DSUMFPP    = 0.D0
C * RELCOR is the relativistic correction term
C * BARNS_TO ELECTRONS[is a constant that converts the cross section in
C * barns/atom into a cross-section in electrons/atom which is the same
C * as f''. It is calculated as:
C *   1/(10^8 [b/A^2]*2* rsube=2.8179^-5 * hc=12398.52)
        IF (IZED == 1) THEN
C * Hydrogen
          IF (ENERGY >= 14.0D-3) THEN
            FPP = SNGL (BARNSTOELECTRONS * ENERGY *
     1            DEXP (2.44964D0 - 3.34953D0 * P1 - 0.047137D0 * P2
     2                           + 0.0070996D0 * P3))
            FP  = 0.0
          END IF
        ELSE IF (IZED == 2) THEN
C * Helium
          IF (ENERGY >= 25.0D-3) then
            FPP = SNGL (BARNSTOELECTRONS * ENERGY *
     1            DEXP (6.06488D0 - 3.2905D0 * P1 - 0.107256D0 * P2
     2                           + 0.0144465D0 * P3))
            FP  = 0.0
          END IF
        ELSE
C * MAIN LOOP THROUGH THE ORBITALS
          DO IRB = 1, NORB(IZED)
            DFPORB      = 0.D0
            DFPCORR     = 0.D0
            DFPPORB     = 0.D0
            DXSECTBARNS = 0.D0
            DBINDNRGAU  = BINDNRG(IZED, IRB) / KEVPERRYD
            IF (NPARMS(IZED, IRB) == 11) THEN
              DXSECTEDGEAU = XSC(IZED, IRB, 11) / AU
            END IF
C * also copy subset into second array
            DO I = 6, 10
              DXSECTINT(I - 5) = XSC(IZED, IRB, I) / AU
              DNRGINT(I - 5)   = YNRG(IRB, I)
            END DO
C * the sorting routine messes up subsequent calls with same energy
C * so copy to second array before sorting.
            DO I = 1, NPARMS(IZED, IRB)
              DXSECTS(I) = XSC(IZED, IRB, I)
              DNRGS(I)   = YNRG(IRB, I)
            END DO
            CALL GEN150 (NPARMS(IZED, IRB), DNRGS, DXSECTS)
            CALL GEN150 (5, DNRGINT, DXSECTINT)
C * convert to log of energy, xsect
            DLOGNRG(11)   = 0.0D0
            DLOGXSECT(11) = 0.0D0
            DO I = 1, NPARMS(IZED, IRB)
              DLOGNRG(I) = DLOG (DNRGS(I))
              IF (DXSECTS(I) == 0.0D0) THEN
                DLOGXSECT(I) = 0.0D0
              ELSE
                DLOGXSECT(I) = DLOG (DXSECTS(I))
              END IF
            END DO
            IF (BINDNRG(IZED, IRB) <= DENERGY) THEN
              IZERO = 0
              I     = 1
              DO WHILE(DLOGXSECT(I) == 0.0D0)
                IZERO = IZERO + 1
                I     = I + 1
              END DO
              INXSECT     = NPARMS(IZED, IRB) - IZERO
              IZERO       = IZERO + 1
              DXSECTBARNS = GEN149 (DLOGENERGY, INXSECT,
     1                      DLOGNRG(IZERO), DLOGXSECT(IZERO))
              DXSECTBARNS = DEXP (DXSECTBARNS) / AU
              DFPPORB     = INVFINESTRUCT * DXSECTBARNS
     1                    * DENERGYAU / (4.0D0 * PI)
              DVAR        = DENERGYAU - DBINDNRGAU
              IF (DVAR == 0.0D0) DVAR = 1.0D0
              DFPCORR = -0.5D0 * DXSECTBARNS * DENERGYAU * FINEPI
     1                  * DLOG ((DENERGYAU + DBINDNRGAU) / DVAR)
            END IF
            IF (BINDNRG(IZED, IRB) > DENERGY .AND.
     1        IFUNTYP(IZED, IRB) == 0) THEN
                DFPORB  = PLA387 (3) * FINEPI
                DFPCORR = 0.5D0 * DXSECTEDGEAU * DBINDNRGAU**2
     1                  * DLOG ((-DBINDNRGAU + DENERGYAU) /
     2                      (-DBINDNRGAU - DENERGYAU)) /
     3                      DENERGYAU * FINEPI
            ELSE
              DFPORB = PLA387 (IFUNTYP(IZED, IRB)) * FINEPI
            END IF
            DSUMFP  = DSUMFP  + DFPORB + DFPCORR
            DSUMFPP = DSUMFPP + DFPPORB
          END DO
C * this is the end of the loop over orbits
          FPP = SNGL(DSUMFPP)
C * Kissel and Pratt give better corrections.  The relativistic correction
C * that Ludwig used is (5/3)(E_tot/mc^2).  Kissel and Pratt say that this
C * should be simply (E_tot/mc^2), but their correction (XKPCOR) apparently
C * takes this into account.  So we can use the old RELCOR and simply add
C * the (energy independent) XKPCOR term:
          FP = SNGL (DSUMFP - RELCOR(IZED) + XKPCOR(IZED))
        END IF
C * Calculate elastic and compton cross-sections (in electrons/atom)
C * BARNSTOELECTRONS is a constant that converts the cross section in
C * barns/atom into a cross-section in electrons/atom which is the same
C * as f''. It is calculated as
C * BARNSTOELECTRONS= 1/( 10^8 [b/A^2]*2* rsube=2.8179^-5* hc=12398.52)
        RAY  = BARNSTOELECTRONS * ENERGY *
     1         DEXP (DRAY(IZED, 1) + DRAY(IZED, 2) * P1 +
     2         DRAY(IZED, 3) * P2 + DRAY(IZED, 4) * P3)
        COMP = BARNSTOELECTRONS * ENERGY *
     1         DEXP (DCMP(IZED, 1) + DCMP(IZED, 2) * P1 +
     2         DCMP(IZED, 3) * P2 + DCMP(IZED, 4) * P3)
        MU   = SNGL (1.66043D0 * FTOMU * (DBLE (FPP) + RAY + COMP) /
     1         ENERGY)
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT ('Lg1:',f8.1,' Lg3:',f8.1,' Li: ',f8.1,' Le: ',f8.1)
99998 FORMAT ('N1: ',f8.1,' N2: ',f8.1,' N3: ',f8.1,' N4: ',f8.1,
     1 ' N5: ',f8.1)
99997 FORMAT ('Lb1:',f8.1,' Lb2:',f8.1,' Lb3:',f8.1,' Lb4:',f8.1,
     1 ' La1:',f8.1,' La2:',f9.1)
99996 FORMAT ('M1: ',f8.1,' M2: ',f8.1,' M3: ',f8.1,' M4: ',f8.1,
     1 ' M5: ',f8.1)
99995 FORMAT ('Ka1:',f8.1,' Ka2:',f8.1,' Kb1:',f8.1,' Kb3:',f8.1)
99994 FORMAT ('K:  ',f8.1,' L1: ',f8.1,' L2: ',f8.1,' L3: ',f8.1)
99993 FORMAT ('Lb1:',f8.1,' La1:',f8.1)
99989 FORMAT ('M1: ',f8.1,' M2: ',f8.1,' M3: ',f8.1,' M4: ',f8.1,
     1 ' Lb1:',f8.1)
99986 FORMAT ('M1: ',f8.1,' M2: ',f8.1,' M3: ',f8.1)
99983 FORMAT ('M1: ',f8.1,' M2: ',f8.1)
99982 FORMAT ('Ka1:',f8.1,' Ka2:',f8.1,' Kb3:',f8.1)
99980 FORMAT ('M1: ',f8.1)
99979 FORMAT ('Ka1:',f8.1,' Ka2:',f8.1)
99977 FORMAT ('Ka1:',f8.1,' Ka2:',f8.1)
99975 FORMAT ('Ka2:',f8.1)
99974 FORMAT ('K:  ',f8.1,' L1: ',f8.1,' L2: ',f8.1)
99973 FORMAT ('K:  ',f8.1,' L1: ',f8.1)
99972 FORMAT ('K-edge: ',f8.1)
99971 FORMAT (/)
      END SUBROUTINE PLA386
 
      DOUBLE PRECISION FUNCTION PLA387 (MODE)
      USE danom
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: IP
      INTEGER                        :: MODE
      DOUBLE PRECISION               :: A
      DOUBLE PRECISION               :: B
      DOUBLE PRECISION               :: C
      DOUBLE PRECISION               :: D
      DOUBLE PRECISION               :: E
      DOUBLE PRECISION               :: F
      DOUBLE PRECISION               :: P1
      DOUBLE PRECISION               :: P2
      DOUBLE PRECISION               :: P3
      DOUBLE PRECISION               :: P4
      DOUBLE PRECISION               :: DCONST
      DOUBLE PRECISION               :: DP
      DOUBLE PRECISION               :: SMALL
      DOUBLE PRECISION               :: SIGMA
      DOUBLE PRECISION, DIMENSION(2) :: DX
      DOUBLE PRECISION, DIMENSION(3) :: DA
      DX(1) = 0.04691007703067D0
      DX(2) = 0.23076534494716D0
      DA(1) = 0.11846344252810D0
      DA(2) = 0.23931433524968D0
      DA(3) = 0.28444444444444D0
      SMALL = 1.0D-31
      A     = 0.d0
      DO I = 1, 5
        P1     = 0.5D0
        DCONST = 0.D0
        IP     = I
C * IP limited to 1,2,3
        IF (IP > 3) THEN
          IP     = 6 - IP
          DCONST = -1.D0
        END IF
        IF (IP /= 3) P1 = - DCONST + DSIGN (DX(IP), DCONST)
        P2 = P1 * P1
        P3 = P1 * P2
        P4 = P1 * P3
        B  = DXSECTINT(6 - I)
        C  = DENERGYAU
        D  = DBINDNRGAU
        E  = DXSECTBARNS
        F  = DXSECTEDGEAU
        SELECT CASE (MODE)
          CASE (0)
            DP = C**2 * P2 - D**2
            IF (DABS (DP) < 1.D-30) THEN
              SIGMA = B * D / P2
            ELSE
              SIGMA = (B * D**3 / P2 - D * E * C**2) / DP
            END IF
          CASE (1)
            SIGMA = 0.5D0 * D**3 * B /
     1              (DSQRT (P1) * (C**2 * P2 - D**2 * P1))
          CASE (2)
            IF (DABS (P1) < SMALL) THEN
              SIGMA = 0.0D0
            ELSE IF (C < SMALL) THEN
              SIGMA = 0.0D0
            ELSE IF (DABS (B - E) < 1.0D-30) THEN
              SIGMA = -2.0D0 * B * D / P3
            ELSE
              DP = P3 * C**2 - D**2 / P1
              IF (DABS (DP) < SMALL) THEN
                SIGMA = -2.0D0 * B * D / P3
              ELSE
                SIGMA = 2.0D0 * (B * D**3 / P4 - D * E * C**2) / DP
              END IF
            ENDIF
          CASE (3)
            SIGMA = D**3 * (B - F * P2) / (P2 * (P2 * C**2 - D**2))
        END SELECT
        A = A + DA(IP) * SIGMA
      END DO
      PLA387 = A
      END FUNCTION PLA387
 
      SUBROUTINE PLA390 (MODE, NTYP, NRET)
C * PRE-GEOM LSPL REQUESTS
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: K
      INTEGER                         :: N
      INTEGER                         :: LBB
      INTEGER                         :: LBC
      INTEGER                         :: LBD
      INTEGER                         :: MODE
      INTEGER                         :: NTYP
      INTEGER                         :: NRET
      INTEGER                         :: IENM
      INTEGER                         :: NIEN
      INTEGER                         :: NMAX
      INTEGER                         :: IXLBL
      INTEGER                         :: INQNR
      INTEGER                         :: JNQNR
      INTEGER                         :: IJXLS
      INTEGER                         :: IATPI
      REAL                            :: VARDIST
      INTEGER, SAVE, DIMENSION(9, 25) :: IXLS
C * HANDLE PRE-CALC GEOMETRY REQUESTS
      IF (MODE == 1) THEN
        IF (IPR(145) < 25) THEN
          IPR(145)          = IPR(145) + 1
          IXLS(1, IPR(145)) = NTYP
          DO K = 2, 9
            IXLS(K, IPR(145)) = -1
          END DO
          IPR(146) = 1
          DO I = 2, IPR(220)
            CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD, INQNR, JNQNR,
     1        NIEN)
            IF (NIEN < 0) THEN
              IF (IFL(I)(1:3) == 'DIS') THEN
                IPR(220) = - IPR(220)
                NRET = 2
                RETURN
              ELSE IF (IFL(I)(1:4) == 'WITH') THEN
                IPR(220) = - IPR(220)
                NRET = 2
                RETURN
              ELSE
C * UNSUITABLE ATOM LABEL ERROR
                NQ0    = IFL(I)(1:7)
                IPR(2) = 3
                NRET   = 3
                RETURN
              END IF
            END IF
            IPR(146) = IPR(146) + 1
            IF (IPR(146) > 9) THEN
              IPR(145) = IPR(145) + 1
              IPR(146) = 2
              DO K = 1, 9
                IXLS(K, IPR(145)) = -1
              END DO
            END IF
            IXLS(IPR(146), IPR(145)) = INQNR
          END DO
          WRITE (LU6, 99999, IOSTAT = IOST)
        END IF
C * LOAD USER SPECIFIED FITS, RINGS AND PLANES FROM XLS-SCRATCH
      ELSE
C * NUMBER OF ATOMS IN SYMMETRY EXPANDED LIST
        NMAX = IPR(39)
        N    = 0
        DO WHILE (N < IPR(145))
          N       = N + 1
          IPR(12) = 0
          NTYP    = IXLS(1, N)
          IF (NTYP >= 0) THEN
            DO I = 1, NMAX
              IATPI = NP1 + I
              IXLBL = LABA(I)
              J    = N
              K    = 1
              DO
                K = K + 1
                IF (K > 9) THEN
                  J = J + 1
                  IF (IXLS(1, J) > 0) THEN
                    EXIT
                  ELSE
                    K = 1
                    CYCLE
                  END IF
                END IF
                IJXLS = IXLS(K, J)
                IF (IJXLS >= 0) THEN
                  IF (ABS (IXLBL - IJXLS) == 0) THEN
                    IPR(12)                 = IPR(12) + 1
                    JR((J - N) * 8 + K - 1) = I
                    IATPI                   = I
                    EXIT
                  ELSE
                    CYCLE
                  END IF
                ELSE
                  EXIT
                END IF
              END DO
              IATP(I) = IATPI
            END DO
            IF (IPR(12) < NP7) THEN
              IF (NTYP == 0) THEN
                IF (IPR(12) >= 2) THEN
C * QUATERNION FIT
                  VARDIST = 999.0
                  CALL PLA442 (0, VARDIST)
                ELSE
                  WRITE (LU6, 99998, IOSTAT = IOST)
                END IF
              ELSE
                IF (IPR(12) >= 3) THEN
                  CALL PLA045 (NTYP)
                ELSE
                  WRITE (LU6, 99998, IOSTAT = IOST)
                END IF
              END IF
            ELSE
              WRITE (LU6, 99998, IOSTAT = IOST)
            END IF
          END IF
        END DO
      END IF
      RETURN
99999 FORMAT (':: LSPL/RING/FIT/LINE calculation will be included in ',
     1        'next CALC GEOM/INTRA run', /)
99998 FORMAT ('W: User-specified Ring/Plane/Fit/Line not accepted', /)
      END SUBROUTINE PLA390
 
      SUBROUTINE PLA391 (N)
      USE parameters
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: M
      INTEGER             :: N
      CHARACTER(len=NP64) :: NQ
C * REMOVE '_$#'
      DO I = 1, N
        NQ = IFL(I)
        M  = INDEX (IFL(I), '_$')
        IF (M /= 0) IFL(I) = NQ(1:M - 1)
      END DO
      RETURN
      END SUBROUTINE PLA391
 
      SUBROUTINE PLA392 (N)
C * TEST/REMOVE '^' ISSUES
      USE parameters
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: M
      INTEGER :: N
      INTEGER :: LBB
      INTEGER :: LBC
      INTEGER :: LBD
      INTEGER :: IDUM
      INTEGER :: JDUM
      INTEGER :: IENM
      INTEGER :: NIEN
      DO I = 1, N
        M  = INDEX (IFL(I), '^')
        IF (M > 0) THEN
C * CHECK FOR ATOM LABELS CONTAINING '^'
          IF (IPR(768) .EQ. 0) THEN
            IFL(I)(M:M+1) = '  '
          ELSE
C * CHECK WHETHER THIS LABEL IS IN THE ATOM LIST, OTHERWISE REMOVE '^' PART
            CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD, IDUM, JDUM,
     1        NIEN)
            IF (NIEN < 0) IFL(I)(M:M+1) = '  '
          END IF
        END IF
      END DO
      RETURN
      END SUBROUTINE PLA392
 
      SUBROUTINE PLA393 (M, P, C)
C * CREATE CIF-STYLE SYMMETRY CODE
      USE files
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: N0
      INTEGER           :: N1
      INTEGER           :: N2
      INTEGER           :: N3
      INTEGER           :: M0
      INTEGER           :: M1
      INTEGER           :: M2
      INTEGER           :: M3
      INTEGER           :: IER
      INTEGER           :: IDUM
      REAL              :: P
      REAL              :: XML
      CHARACTER(len=80) :: C
      CHARACTER(len=80) :: D
C * BLANK STRING C
      CALL GEN038 (C, 1, 80)
C * SPLIT-UP ARU-CODE INTO COMPONENTS
      CALL GEN098 (M, P, M0, M1, M2, M3, IDUM)
      SGX(4) = M1
      SGX(5) = M2
      SGX(6) = M3
C * GET SYMMETRY OPERATION
      CALL SGSM (20, D, SGX, M0, 0, IERR)
      N = INDEX (D, ' ')
C * CONVERT TO LOWER CASE
      CALL GEN020 (-1, D, 1, N)
      C(61 - N:61) = D(1:N)
      XML = M / P
      CALL PLA273 (1, XML, N0, N1, N2, N3, IER)
      IF (IER == 0) THEN
        WRITE (C(62:80), 99999, IOSTAT = IOST)
     1    N0, N1 + 5, N2 + 5, N3 + 5
      ELSE
        WRITE (C(62:80), 99998, IOSTAT = IOST)
      END IF
      RETURN
99999 FORMAT ('=', I7,'_', 3I1, ' Check')
99998 FORMAT (12X, ' Check')
      END SUBROUTINE PLA393
 
      SUBROUTINE PLA394
C * (SOLVENT) ACCESSIBLE SURFACE AREA CALCULATION ROUTINE - SASA
C * LOOSELY BASED ON THE TOOL NONORTHOSA
C * T.DUREN ET Al. J. Phys. Chem C 2007, 111,15350-15356
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
      INTEGER, PARAMETER                :: NP87 = 100000
      INTEGER                           :: I
      INTEGER                           :: J
      INTEGER                           :: K
      INTEGER                           :: L
      INTEGER                           :: M
      INTEGER                           :: N
      INTEGER                           :: LU
      INTEGER                           :: NC
      INTEGER                           :: NS
      INTEGER                           :: NEL
      INTEGER                           :: NELA
      INTEGER                           :: NIEN
      INTEGER                           :: NADD
      INTEGER                           :: INEL
      INTEGER                           :: NSYML
      INTEGER                           :: ISEED
      INTEGER, DIMENSION(16)            :: NCOUNT
      REAL                              :: PI
      REAL                              :: ST
      REAL                              :: TH
      REAL                              :: XQ
      REAL                              :: YQ
      REAL                              :: ZQ
      REAL                              :: CTH
      REAL                              :: RAD
      REAL                              :: PHI
      REAL                              :: DIFF
      REAL                              :: TEST
      REAL                              :: SFRAC
      REAL                              :: DIST2
      REAL                              :: PROBE
      REAL                              :: STRED
      REAL                              :: SJREAL
      REAL                              :: GEN006
      DOUBLE PRECISION                  :: GEN160
      REAL, DIMENSION(16)               :: VDW
      REAL, ALLOCATABLE, DIMENSION(:,:) :: X
      CHARACTER(len=2), DIMENSION(16)   :: ELEM
      CHARACTER(len=2)                  :: ELM
      ALLOCATE (X(NP87, 4))
C * INIT COUNT OF ATOMS PER ATOM TYPE
      CALL GEN097 (NCOUNT, 1, 16, 0)
      DO I = 1, 16
        ELEM(I) = '  '
      END DO
      ISEED = -52907
      PI    = RGBL(5) / 2.0
      NS    = IPR(743)
      PROBE = PAR(557)
      NSYML = IPR(255) * IPR(256) * IPR(257)
C * ELEMENT NUMBER COUNTER
      NEL   = 0
C * GET AND EXPAND COORDINATE SET TO FILL THE WHOLE UNIT CELL
      N = 0
      DO I = 1, IPR(37)
        NELA = 1
C * GET ELEMENT TYPES AND VAN DER WAALS RADII
        CALL GEN048 (-4, IFG(1, I), 15, NIEN)
        RAD = ABS (VDWR(IEN(NIEN + 1)))
        ELM = ELB(IEN(NIEN + 1))
        IF (NEL > 0) THEN
          DO K = 1, NEL
            IF (ELM == ELEM(K)) THEN
              INEL = K
              NELA = 0
              EXIT
            END IF
          END DO
        END IF
        IF (NELA == 1) THEN
          NEL       = NEL + 1
          INEL      = NEL
          ELEM(NEL) = ELM
          VDW(NEL)  = RAD
        END IF
C * COMPLETE UNITCELL CONTENT
        DO K = 1, 3
          SGY(K)     = XXO(I, K)
          SGY(K + 3) = 0.0
        END DO
        M = 0
        DO L = 1, NSYML
          CALL SGSM (3, ICL, SGY, L, 0, IERR)
          IF (N >= NP87) THEN
            WRITE (LU6, 99994) NP87
            GO TO 10
          END IF
C * TEMPORARILY ADD THIS ATOM TO THE CELL CONTENT
          N            = N + 1
          M            = M + 1
          X(N, 4)      = RAD + PROBE
          NCOUNT(INEL) = NCOUNT(INEL) + 1
          DO K = 1, 3
            X(N, K) = MOD (SGY(K + 6) + 1.0, 1.0)
          END DO
C * CHECK FOR DUPLICATION
          IF (M > 1) THEN
            DO K = 1, M - 1
              DIFF = 0.0
              DO J = 1, 3
                DIFF = DIFF + ABS (X(N, J) - X(N - K, J))
              END DO
              IF (DIFF < 0.0001) THEN
                NCOUNT(INEL) = NCOUNT(INEL) - 1
                N = N  - 1
                M = M - 1
                EXIT
              END IF
            END DO
          END IF
        END DO
      END DO
C * SASA LOOPS
      ST = 0.0
C * LOOP OVER UNITCELL CONTENT ATOMS
      DO I = 1, N
C * MONTE CARLO LOOP OF TEST LOCATIONS ON SPHERE with RADIUS X(I, 4)
        NC = 0
        DO J = 1, NS
          PHI = SNGL(GEN160 (ISEED)) * 2.0 * PI
          CTH = 1.0 - SNGL(GEN160 (ISEED)) * 2.0
          TH  = ACOS (CTH)
          XQ  = X(I, 4) * SIN (TH) * COS (PHI)
          YQ  = X(I, 4) * SIN (TH) * SIN (PHI)
          ZQ  = X(I, 4) * CTH
          DO M = 1, 3
            V4(M) = (XQ * ROR(M, 1) + YQ * ROR(M, 2) + ZQ * ROR(M, 3))
          END DO
          DO M = 1, 3
            V3(M) = MOD (V4(M) + X(I, M) + 2.0, 1.0)
          END DO
C * CHECK THIS POINT TO BE OUTSIDE ANY OTHER ATOM ENVIRONMENT
          NADD = 1
          DO K = 1, N
            IF (K /= I) THEN
              TEST = (0.999 * X(K, 4))**2
C * HANDLE UNITCELL OUTLINE CROSSINGS
              DO M = 1, 3
                V2(M) = V3(M) - X(K, M)
              END DO
              DO M = 1, 3
                V2(M) = V2(M) - INT (2.0 * V2(M))
              END DO
              DIST2 = GEN006(V2, AA, V2)
              IF (DIST2 < TEST) THEN
                NADD = 0
                EXIT
              END IF
            END IF
          END DO
          NC = NC + NADD
        END DO
C * OUTPUT RESULT ON TERMINAL AND AS LISTING
        SFRAC  = FLOAT (NC) / NS
        SJREAL = 4 * PI * SFRAC * X(I, 4) ** 2
        ST     = ST + SJREAL
        STRED  = ST / PAR(98) * 1.0E4
      END DO
      DO I = 1, 2
        IF (I == 1) THEN
          LU = LU6
        ELSE
          LU = LU7
        END IF
        WRITE (LU, 99996) PROBE, NS, N, PAR(387)
        DO J = 1, IAN
          WRITE (LU, 99995) ELEM(J), VDW(J), NCOUNT(J)
        END DO
        WRITE (LU, 99999) NINT (ST)
        WRITE (LU, 99998) NINT (STRED)
        WRITE (LU, 99997) NINT (STRED / PAR(387))
      END DO
   10 DEALLOCATE (X)
      RETURN
99999 FORMAT (/, 'Total Surface Area            =', I8, ' Angstrom^2')
99998 FORMAT (   'Total Surface Area per Volume =', I8, ' m^2/cm^3')
99997 FORMAT (   'Total Surface Area per Mass   =', I8, ' m^2/g')
99996 FORMAT (/, '(Solvent) Accessible Surface Area Calculation', /,
     1 '(Loosely Implementing: T.Duren et al.,J.Chem.Phys.C,',
     2 '111(2007)15350-15356)', //,
     3 ':: Probe Radius     =', F6.3, ' Angstrom', /,
     4 ':: MonteCarlo #     =', I6,   ' Random Tests/atom', /,
     5 ':: Expanded # ATOMS =', I6,   ' in Unitcell', /,
     6 ':: Frame Density    =', F6.3, ' g/cm**3', /)
99995 FORMAT (':: vdW Radius ', A, 4X, '=', F6.3, I12, ' in Unitcell')
99994 FORMAT ('Number of atoms in unitcell exceeds ', I10)
      END SUBROUTINE PLA394
 
      REAL FUNCTION PLA395 (NELI, NELJ)
C * CHECK FOR CONTACTS NEEDING SPECIAL TOLERANCES
      IMPLICIT NONE
      INTEGER, PARAMETER       :: N = 21
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: NELI
      INTEGER                  :: NELJ
      INTEGER, DIMENSION(2, N) :: NTAB
      REAL,    DIMENSION(N)    :: XTAB
      DATA (NTAB(1, I), NTAB(2, I), XTAB(I), I = 1, N) /
     1  10,  10, -0.6,  10,  11, -9.9, 10,  60, -9.9, 11,  11, -9.9,
     2  26,  26, -9.9,  30,  30, -9.9, 54,  85, -9.9, 59,  59, -9.9,
     3  85,  94, -9.9, 103, 103, -9.9, 85, 104, -9.9, 69,  69, -0.74,
     4  10,  99, -9.9,  23,  23, -0.5, 13,  13,  0.0, 39,  39,  0.2,
     5  54,  87, 0.55,  42,  42,  0.2,  5,  82,  0.4,  7,  84,  0.2,
     6   5,  92, 0.20/
C *AVOID OR FORCE SPECIAL 'BOND' COMBINATIONS
C * CU-CU, CU-NI, CU-MO, NI-NI, CD-CD, CO-CO, LI-SI, MN-MN, TI-SI, ZN-ZN,
C * SI-ZR, PB-PB, CU-W , BI-BI, AG-AG, FE-FE, SN-LI, GA-GA, SB-CL, BR-SE.
C * CL-TE
C * CL =  5
C * BR =  7
C * CU = 10
C * NI = 11
C * AG = 13
C * BI = 23
C * CD = 26
C * CO = 30
C * FE = 39
C * GA = 42
C * LI = 54
C * MN = 59
C * MO = 60
C * PB = 69
C * SB = 82
C * SE = 84
C * SI = 85
C * SN = 87
C * TE = 92
C * TI = 94
C * W  = 99
C * ZN = 103
C * ZR = 104
      PLA395 = 0.0
C * IGNORE C, H, N, O
      IF (NELI > 4 .AND. NELJ > 4) THEN
        I = NELI
        J = NELJ
        IF (I > J) CALL GEN014 (I, J)
        DO K = 1, N
          IF (NTAB(1, K) == I .AND. NTAB(2, K) == J) THEN
            PLA395 = XTAB(K)
            EXIT
          END IF
        END DO
      END IF
      RETURN
      END FUNCTION PLA395
 
      SUBROUTINE PLA396
C * MolVolume
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE sgxyz
 
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: MX
      INTEGER            :: MY
      INTEGER            :: MZ
      INTEGER            :: IDUM
      INTEGER            :: JDUM
      INTEGER            :: KDUM
      INTEGER            :: IRES
      INTEGER            :: JRES
      INTEGER            :: LSYM
      INTEGER            :: NGRID
      INTEGER            :: NXMIN
      INTEGER            :: NYMIN
      INTEGER            :: NZMIN
      INTEGER            :: NXMAX
      INTEGER            :: NYMAX
      INTEGER            :: NZMAX
      REAL               :: XS
      REAL               :: YS
      REAL               :: ZS
      REAL               :: VDWK
      REAL               :: STEP
      REAL               :: XMIN
      REAL               :: XMAX
      REAL               :: YMIN
      REAL               :: YMAX
      REAL               :: ZMIN
      REAL               :: ZMAX
      REAL               :: TVOL
      REAL               :: VDWRX
      REAL               :: VOLUME
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IGRID
      REAL,    ALLOCATABLE, DIMENSION(:,:)   :: ATOMS
      TVOL = 0
      STEP = PAR(569)
      WRITE (LU6, 99995) STEP
C * GET CONNECTED SETS
      CALL PLA067
C * LIST UNITCELL CONTENT
      CALL PLA080
      ALLOCATE (ATOMS(4, IPR(39)))
C * LOOP OVER RESIDUES
      DO JRES = 1, IPR(75)
        WRITE (LU6, 99998) JRES
        WRITE (LU6, 99996)
C * LOAD ATOM DATA FOR THIS RESIDUE (Xort, Yort, Zort, vdW radius)
        N    = 0
        LSYM = 0
        KDUM = 0
        DO I = 1, IPR(39)
          CALL GEN048 (-6, IFG(1, I), 9, IRES)
          IF (IRES == JRES) THEN
            N = N + 1
            CALL PLA047 (LABA(I), NQ1, IDUM, JDUM,
     1        IPR(71), IGBL(55), 0, 0)
            ATOMS(4, N) = ABS (VDWR(JDUM))
            DO J = 1, 3
              ATOMS(J, N) = XXO(I, J + 3)
            END DO
C * GET SITE MULTIPLICITLY
            IF (IDUM /= KDUM) THEN
              LSYM = LSYM + 1
              KDUM = IDUM
            END IF
            WRITE (LU6, 99999) NQ1(1:8), (ATOMS(J, N), J = 1, 4)
          END IF
        END DO
C * GET MINIMUM AND MAXIMUM SIZE OF MOLECULE
 
        XMIN =  99999.0
        YMIN =  99999.0
        ZMIN =  99999.0
        XMAX = -99999.0
        YMAX = -99999.0
        ZMAX = -99999.0
        DO I = 1, N
          XMIN = MIN (XMIN, ATOMS(1, I) - ATOMS(4, I))
          YMIN = MIN (YMIN, ATOMS(2, I) - ATOMS(4, I))
          ZMIN = MIN (ZMIN, ATOMS(3, I) - ATOMS(4, I))
          XMAX = MAX (XMAX, ATOMS(1, I) + ATOMS(4, I))
          YMAX = MAX (YMAX, ATOMS(2, I) + ATOMS(4, I))
          ZMAX = MAX (ZMAX, ATOMS(3, I) + ATOMS(4, I))
        END DO
C * SHIFT ORIGIN
        DO I = 1, N
          ATOMS(1, I) = ATOMS(1, I) - XMIN
          ATOMS(2, I) = ATOMS(2, I) - YMIN
          ATOMS(3, I) = ATOMS(3, I) - ZMIN
        END DO
        XMAX = XMAX - XMIN
        YMAX = YMAX - YMIN
        ZMAX = ZMAX - ZMIN
C * SET-UP ANGSTROM GRID
        XS = XMAX / STEP
        YS = YMAX / STEP
        ZS = ZMAX / STEP
        MX = INT(XS) + 1
        MY = INT(YS) + 1
        MZ = INT(ZS) + 1
        ALLOCATE (IGRID(-1:MX, -1:MY, -1:MZ))
        DO I = -1, MX
          DO J = -1, MY
            DO K = -1, MZ
              IGRID(I, J, K) = 0
            END DO
          END DO
        END DO
C * ACCUMULATE GRIDPOINT IN MOLECULE/RESIDUE
        VOLUME = 0.0
        NGRID  = 0
        DO M = 1, N
          VDWRX = ATOMS(4, M)
          VDWK  = VDWRX ** 2
          NXMIN = MAX(-1, INT ((ATOMS(1, M) - VDWRX) / STEP))
          NYMIN = MAX(-1, INT ((ATOMS(2, M) - VDWRX) / STEP))
          NZMIN = MAX(-1, INT ((ATOMS(3, M) - VDWRX) / STEP))
          NXMAX = MIN(MX, INT ((ATOMS(1, M) + VDWRX) / STEP) + 1)
          NYMAX = MIN(MY, INT ((ATOMS(2, M) + VDWRX) / STEP) + 1)
          NZMAX = MIN(MZ, INT ((ATOMS(3, M) + VDWRX) / STEP) + 1)
          DO I = NXMIN, NXMAX
            DO J = NYMIN, NYMAX
              DO K = NZMIN, NZMAX
                L = IGRID (I, J, K)
                IF (L == 0) THEN
                  IF ((ATOMS(1, M) - I * STEP)**2 +
     1                (ATOMS(2, M) - J * STEP)**2 +
     2                (ATOMS(3, M) - K * STEP)**2 < VDWK) THEN
                    IGRID(I, J, K) = 1
                    NGRID          = NGRID + 1
                  END IF
                END IF
              END DO
            END DO
          END DO
        END DO
        DEALLOCATE (IGRID)
        VOLUME = NGRID * STEP ** 3
        WRITE (LU6, 99997) JRES, NGRID, VOLUME, RFORM(JRES)
        TVOL = TVOL + VOLUME * IPR(255) * IPR(256) * IPR(257) / LSYM
      END DO
      IF (IPR(43) == 0) THEN
        WRITE (LU6, 99994) 100.0 * TVOL / PAR(98)
        WRITE (LU6, 99993)
      ELSE
        WRITE (LU6, 99992)
      END IF
      DEALLOCATE (ATOMS)
      IPR(2)  = -1
      IGBL(1) = 3
      RETURN
99999 FORMAT (A, 3F8.3, F6.2)
99998 FORMAT (/, 'Molecular Volume (Ang**3) Calculation for Residue',
     1  I5, ' - (Grid Approach)', /, 80('='), /)
99997 FORMAT (/, 'Res   Ngrid  Volume Formula', /,
     1 I3, I8, F8.1, 1X, A)
99996 FORMAT ('Label       Xort    Yort    Zort  vdWR')
99995 FORMAT ('MOLVOL - GRID-STEP = ', F5.2, ' Ang', /, 80('='), /)
99994 FORMAT (/, 'Packing Index      =', F5.1, '% - (Expected range ',
     1        '65 to 77%)')
99993 FORMAT (/,
     1 'NOTE: The Packing Index is calculated assuming that the above ',
     2 'molecular volumes', /, 'do not overlap (i.e. with only van der',
     3 ' Waals contacts). In case of hydrogen', /, 'bonding, the',
     4 ' ''CALC K.P.I'' tool calculation of the Kitaigorodskii Packing',
     5 ' Index', /, 'should be used for a better estimate.')
99992 FORMAT (/, ':: No Packing Index calculated for disordered ',
     1        'structure')
      END SUBROUTINE PLA396
 
      MODULE mp
      SAVE
      INTEGER, PARAMETER               :: MP8 = 50
      INTEGER, PARAMETER               :: MP9 = 16
      INTEGER                          :: NLINES
      CHARACTER(4),  DIMENSION(20, 40) :: XLINE
      CHARACTER(len=12), DIMENSION(26) :: TARG
 
      END MODULE mp
 
      SUBROUTINE PLA400
C * MP.FOR (MidPoint.FOR): generates the "loci" (halfsums) and differences
C * between pairs of molecules.
C * Original version by Ricardo Baggio (Acta Cryst C75. (2019) 837-850.
C * Restructured version: A.L.Spek - 13-Jun-2019
C * INPUT FILE: COMMAND LINE ARGUMENT OR DEFAULT 'MP1.INS', a SHELXL style
C * RES file with one extra 'dummy' line (to be places before the first ATOMS
C * card), beginning with the flag "REM ****", and followed by six numbers in
C * free FORMAT, viz.: REM **** NATOM, NMOL, NWRITE, NSUCC, NRES, XLIM
C * where:
C * NATOM: number of atoms in the molecule (Max. MP8) (N Hs, only Uiso)
C * NMOL:  number of molecules (all sorted in the same way) (Max. MP9).
C * NSUCC: (MP_name.RES output filter) Expected to allow/filter some symmetry
C *        elements
C * = 0:  no filter (all MPs included)
C * = 1:  only inversion included (-1)
C * = 2:  only two fold/screw (2/21)
C * = 3:  only mirror/glide  (m/a/b/c)
C * = 4:  only A,B,C centering
C * = 12: only inversion and two fold included (-1 + 2/21)
C * = 13: only inversion and mirror/glide  (-1 + m/a/b/c)
C * = 14: only inversion and A,B,C centering   (-1 + A,B,C )
C * = 23: only two fold/screw and mirror/glide  (2/21 + m/a/b/c)
C * = 24: only two fold/screw and A,B,C centering   (2/21 + A,B,C)
C * = 34: only mirror/glide and A,B,C centering   (m/a/b/c + A,B,C)
C * = 123:only inversion, two fold and mirror/glide included
C *
C * Negative NSUCC: as above, but "EXCLUDED" instead of "INCLUDED"
C *
C * NOTE: this option should be used with care, as it only refers to
C *       symmetry elements "recognized" a priori by MP, a rather
C *       limiting option at present.
C *
C * NRES: output RES indicator
C * = 0, Restricted MP_name.RES file WITH all MPs but WITHOUT original atoms.
C *         NO short AB.RES output.
C * = 1, Restricted MP_name.RES file WITH all MPs but WITHOUT original atoms.
C *         ALL short AB.RES included.
C * = 2, Extended MP_name.RES file WITH all MPs and WITH all the original atoms.
C *         NO short AB.RES output.
C * = 3, Extended MP_name.RES file WITH all MPs and WITH all the original atoms.
C *         ALL short AB.RES included.
C *
C * XLIM: threshold to define the acceptance of a symmetry
C *          (The larger, the more stringent. Typical: 2)
C *
C * NWRITE: LST OUTPUT OPTIONS
C * = 0, Default Listing
C * = 2, Include Individual midpoint data
C *
C * If the problem requires changing dimensions, change in the appropriate
C *   lines: MP8: max.atoms, MP9: max.molecules
      USE mp
      IMPLICIT NONE
      REAL, ALLOCATABLE, DIMENSION(:,:,:)            :: A
      REAL, ALLOCATABLE, DIMENSION(:,:,:,:)          :: VP
      REAL, ALLOCATABLE, DIMENSION(:,:,:,:)          :: VM
      CHARACTER(len=80), ALLOCATABLE, DIMENSION(:,:) :: ZLINE
      INTEGER                                        :: I
      INTEGER                                        :: J
      INTEGER                                        :: K
      INTEGER                                        :: L
      INTEGER                                        :: N
      INTEGER                                        :: I1
      INTEGER                                        :: I2
      INTEGER                                        :: K1
      INTEGER                                        :: K2
      INTEGER                                        :: K5
      INTEGER                                        :: K6
      INTEGER                                        :: IJK
      INTEGER                                        :: IARG
      INTEGER                                        :: MARG
      INTEGER                                        :: NARG
      INTEGER                                        :: NMOL
      INTEGER                                        :: NRES
      INTEGER                                        :: I1I2
      INTEGER                                        :: IOST
      INTEGER                                        :: NATOM
      INTEGER                                        :: ISUCC
      INTEGER                                        :: NSUCC
      INTEGER                                        :: ICASE
      INTEGER                                        :: NWRITE
      INTEGER                                        :: ICOUNT1
      INTEGER                                        :: ICOUNT2
      REAL                                           :: X12
      REAL                                           :: XD
      REAL                                           :: XS
      REAL                                           :: XLIM
      REAL                                           :: YUNK
      REAL                                           :: DELTA1
      REAL                                           :: DELTA2
      REAL                                           :: SUCCESS
      REAL,              DIMENSION(3)                :: SUMM
      REAL,              DIMENSION(3)                :: DIFF
      REAL,              DIMENSION(3)                :: SUMSQDEV
      REAL,              DIMENSION(3)                :: DIFSQDEV
      REAL,              DIMENSION(6)                :: XSORTED
      CHARACTER(len=4)                               :: XK
      CHARACTER(len=2)                               :: AB
      CHARACTER(len=80)                              :: ARG
      CHARACTER(len=6)                               :: NAAM
      CHARACTER(len=12)                              :: XX12
      CHARACTER(len=8)                               :: CARTEL
      CHARACTER(len=40)                              :: XINPUT
      CHARACTER(len=28), DIMENSION(8)                :: CELL
      CHARACTER(80),     DIMENSION(MP8)              :: TMP
      CELL = (/
     1 'X000 1  0   0   0  11.00 .05', 'X100 1  1   0   0  11.00 .05',
     2 'X010 1  0   1   0  11.00 .05', 'X001 1  0   0   1  11.00 .05',
     3 'X011 1  0   1   1  11.00 .05', 'X101 1  1   0   1  11.00 .05',
     4 'X110 1  1   1   0  11.00 .05', 'X111 1  1   1   1  11.00 .05'/)
      TARG = (/
     1 '(    -1   ) ', '( .  .  2 ) ', '( .  .  21) ', '( .  2  . ) ',
     2 '( .  21 . ) ', '( 2  .  . ) ', '( 21 .  . ) ', '( m  .  . ) ',
     3 '( b  .  . ) ', '( c  .  . ) ', '( n  .  . ) ', '( .  m  . ) ',
     4 '( .  a  . ) ', '( .  c  . ) ', '( .  n  . ) ', '( .  .  m ) ',
     5 '( *  *  * ) ', '( *  *  . ) ', '( *  .  * ) ', '( *  .  . ) ',
     6 '( .  *  * ) ', '( .  .  a ) ', '( .  .  b ) ', '( .  .  n ) ',
     7 '( .  *  . ) ', '( .  .  * ) '/)
      ALLOCATE (A(3, MP8, MP9), Vp(3, MP8, MP9, MP9),
     1 VM(3, MP8, MP9, MP9))
      ALLOCATE (ZLINE(MP8, MP9))
      ICASE = 0
C * GET FILENAME FROM COMMAND LINE OR USE DEFAULT 'MP1'
      IARG  = COMMAND_ARGUMENT_COUNT()
      IF (IARG == 1) THEN
        CALL GET_COMMAND_ARGUMENT (1, ARG)
      ELSE
        ARG = 'MP1.INS'
      END IF
      NARG = INDEX (ARG, '.') - 1
      MARG = INDEX (ARG, ' ') - 1
C * a RES file with a dummy card added.
      OPEN (UNIT = 7,  FILE = ARG(1:MARG))
C * halfsums and differences table
      OPEN (UNIT = 8,  FILE = ARG(1:NARG)//'.LST')
C * a new RES, with renamed (real) atoms and halfsums (meant as further atoms)
      OPEN (UNIT = 10, FILE = ARG(1:NARG)//'.RES')
C *  Copy Input up and including REM record (NLINES)
      DO I = 1, 40
C * READ FROM name.INS
        READ   (7, 99999) (XLINE(J, I), J = 1, 20)
C * WRITE TO name.RES
        WRITE (10, 99999) (XLINE(J, I), J = 1, 20)
        IF ((XLINE(1, I) == 'REM ' ) .AND. (XLINE(2, I) == '****'))
     1    THEN
          NLINES = I
          WRITE (XINPUT, 99998) (XLINE(J, NLINES), J = 3, 12)
C * See at the top of the program the meaning of each variable
          READ (XINPUT, *) NATOM, NMOL, NWRITE, NSUCC, NRES, XLIM
          EXIT
        END IF
      END DO
C * STORE ATOM RECORDS
      DO I = 1, NMOL
C * WRITE TO name.RES (10)
      IF (IABS(NRES) > 1) WRITE (10, 99997) I
        DO J = 1, NATOM
          READ (7, 99996, IOSTAT = IOST) XK, L, (A(K, J, I), K = 1, 3)
          IF (IOST == -1) GO TO 40
          DO WHILE (XK == 'FVAR' .OR. XK == '    ')
            READ (7, 99996, IOSTAT = IOST) XK, L, (A(K, J, I), K = 1, 3)
            IF (IOST == -1) GO TO 40
          END DO
          WRITE (ZLINE(J, I), 99995)
     1      CHAR (64 + I), J, L, (A(K, J, I), K = 1, 3)
C * WRITE TO name.RES (10)
          IF (IABS(NRES) > 1) WRITE (10, 99994) ZLINE(J, I)
        END DO
      END DO
C * MOL1, MOL2 LOOPS
      I1I2 = 100
      DO I1 = 1, NMOL
        DO I2 = I1 + 1, NMOL
          AB = CHAR (64 + I1)//CHAR (64 + I2)
          I1I2 = I1I2 + 1
          DO K = 1, 3
            SUMM(K) = 0.0
            DIFF(K) = 0.0
            SumSqdev(K) = 0.0
            DifSqdev(K) = 0.0
          END DO
          DO J = 1, NATOM
            DO K = 1, 3
              Vp(K,J,I1,I2) =     (A(K,J,I1) + A(K,J,I2)) / 2
              Vm(K,J,I1,I2) = ABS (A(K,J,I1) - A(K,J,I2))
              SUMM(K)       = SUMM(K) + Vp(K,J,I1,I2)
              DIFF(K)       = DIFF(K) + Vm(K,J,I1,I2)
            END DO
          END DO
          DO K = 1, 3
            SUMM(K) = SUMM(K) / NATOM
            DIFF(K) = DIFF(K) / NATOM
          END DO
          DO J = 1, NATOM
            DO K = 1, 3
              Xs = ((A(K,J,I1) + A(K,J,I2)) / 2 - SUMM(K))**2
              Xd = (ABS (A(K,J,I1) - A(K,J,I2)) - DIFF(K))**2
              SumSqdev(K) = SumSqdev(K) + XS
              DifSqdev(K) = DifSqdev(K) + XD
            END DO
          END DO
          DO K = 1, 3
            SumSqdev(K) = sqrt (SumSqdev(K) / NATOM)
            Difsqdev(K) = sqrt (Difsqdev(K) / NATOM)
          END DO
          ICASE = ICASE + 1
          XX12 = '***  '//AB//'  ***'
          WRITE (8, 99993) ICASE,  XX12
          WRITE (XX12, 99992) 'Case', ICASE, '('//AB//')'
C * This block is meant to generate the "two-molecules" RES files, including
C * both molecules and the halfsums in between. Used for a simpler recognition.
          IF (IABS(NRES) == 1 .OR. IABS(NRES) == 3) THEN
C * generates the small RES, with pair of molecules and MP's
            NAAM = AB//'.RES'
            OPEN (UNIT = 12, FILE = ARG(1:NARG)//'_'//NAAM)
            DO K1 = 1, NLINES
              WRITE (12, 99999) (XLINE(K2, K1), K2 = 1, 20)
            END DO
            IF (NRES < 0) THEN
C * Negative code, include cell corners
              WRITE (12, 99991) 'PART 999'
              DO IJK = 1, 8
                WRITE (12, 99990) CELL(IJK)
              END DO
            ENDIF
C * Negative code, include cell corners
            WRITE (12, 99989) 'PART 1'
            DO K5 = 1, NATOM
              WRITE (12, 99994) ZLINE(K5, I1)
            END DO
            DO K6 = 1, NATOM
              WRITE (12, 99994) ZLINE(K6, I2)
            END DO
            WRITE (12, 99994)
            WRITE (12, 99989) "PART 2"
          ENDIF
C * generates the small RES, with pair of molecules and MP's
C * WRITE TO name.RES
          WRITE (10, 99997) I1I2
          DO J = 1, NATOM
C * iNWRITE = 2 - WRITE ON 8
            IF (NWRITE == 2) WRITE (8, 99988) AB, J,
     2        (Vp(K,J,I1,I2), K = 1, 3), (Vm(K,J,I1,I2), K = 1, 3)
C * WRITE ON TMP(J) (ATOMTYPE = H = 2)
            N = 2
            WRITE (TMP(J), 99987) AB, J, N, (Vp(K,J,I1,I2), K = 1, 3)
C * IABS(NRES) = 1 or 3 - WRITE on (12)
            IF (IABS (NRES) == 1 .OR. IABS (NRES) == 3)
     1        WRITE (12, 99994) TMP(J)
          END DO
          WRITE (8, 99986)
          WRITE (8, 99985) 'Average', (SUMM(I), I = 1, 3),
     1      (DIFF(I), I = 1, 3)
          WRITE (8, 99985) 'Sigma  ', (Sumsqdev(I), I = 1, 3),
     1      (Difsqdev(I), I = 1, 3)
          SUCCESS = 1
          DO I = 1, 3
            XSORTED(I)     = SumSqdev(I)
            XSORTED(I + 3) = DifSqdev(I)
          END DO
          DO J = 1, 6
C * SORT XSORTED FROM SMALL TO LARGE
            DO K = 1, J - 1
              IF (XSORTED(K) > XSORTED(J)) THEN
                YUNK = XSORTED(K)
                XSORTED(K) = XSORTED(J)
                XSORTED(J) = YUNK
              END IF
            END DO
          END DO
          IF (XSORTED(1) * XSORTED(2) * XSORTED(3) /= 0.0) THEN
            X12 = XSORTED(4) / XSORTED(3)
            IF (X12 < XLIM) THEN
              SUCCESS = 0
            ELSE IF (X12 > XLIM       .AND. X12 <= XLIM * 1.2) THEN
              CARTEL = '# POOR #'
            ELSE IF (X12 > XLIM * 1.2 .AND. X12 <= XLIM * 1.5) THEN
              CARTEL = '# FAIR #'
            ELSE IF (X12 > XLIM * 1.5 .AND. X12 <= XLIM * 2.0) THEN
              CARTEL = '# GOOD #'
            ELSE IF (X12 > XLIM * 2.0) THEN
              CARTEL = '# EXCEL#'
            ENDIF
          ENDIF
          DELTA1 = XSORTED(3) + 0.00001
          DELTA2 = XSORTED(4) - 0.00001
          ICOUNT1 = 0
          ICOUNT2 = 0
          DO I = 1, 3
            IF (SumSqdev(I) < 0.00000001) SumSqdev(I) = 0.0
            IF (SumSqdev(I) < delta1) ICOUNT1 = ICOUNT1 + 1
          END DO
          DO I = 1, 3
            IF (DifSqdev(I) < 0.00000001) DifSqdev(I) = 0.0
            IF (DifSqdev(I) < delta1) ICOUNT2 = ICOUNT2 + 1
          END DO
C * 'CHECK'
          CALL PLA401 (ICOUNT1, ICOUNT2, SUMM, Sumsqdev, DIFF, DifSqdev,
     1      DELTA1, DELTA2, SUCCESS, ISUCC, CARTEL, XX12)
          WRITE (8, 99984)
C * See at the top of the program the meaning of the Nsucc variable
          I = ISUCC
          IF (NSUCC == 0) THEN
            GOTO 20  ! pasan todas
          ELSE IF (NSUCC > 0) THEN
            N = NSUCC
            IF (I == 0) GOTO 30
            if (N == I) GOTO 20
            If (N == 12 .AND. (I == 1 .OR. I == 2)) GOTO 20
            If (N == 13 .AND. (I == 1 .OR. I == 3)) GOTO 20
            If (N == 14 .AND. (I == 1 .OR. I == 4)) GOTO 20
            If (N == 23 .AND. (I == 2 .OR. I == 3)) GOTO 20
            If (N == 24 .AND. (I == 2 .OR. I == 4)) GOTO 20
            If (N == 34 .AND. (I == 3 .OR. I == 4)) GOTO 20
            If (N == 123.AND. (I == 1 .OR. I == 2 .OR.
     1        I == 3)) GOTO 20
            goto 30
          ELSE IF (NSUCC < 0) THEN
            N = - NSUCC
            if (N == I)  goto 30
            If (N == 12 .AND. (I == 1 .OR. I == 2)) GOTO 30
            If (N == 13 .AND. (I == 1 .OR. I == 3)) GOTO 30
            If (N == 14 .AND. (I == 1 .OR. I == 4)) GOTO 30
            If (N == 23 .AND. (I == 2 .OR. I == 3)) GOTO 30
            If (N == 24 .AND. (I == 2 .OR. I == 4)) GOTO 30
            If (N == 34 .AND. (I == 3 .OR. I == 4)) GOTO 30
            if (N == 123.AND. (I == 1 .OR. I == 2 .OR.
     1        I == 3)) GOTO 30
            goto 20
          END IF
C * WRITE TO name.RES
  20      DO J = 1, NATOM
            WRITE (10, 99994) TMP(J)
          END DO
  30      CONTINUE
        END DO
      END DO
      CALL PLA402 (NWRITE)
  40  CLOSE (7)
      CLOSE (8)
      CLOSE (12)
      DEALLOCATE (A, VP, VM)
      DEALLOCATE (ZLINE)
      STOP
99999 FORMAT (20A)
99998 FORMAT (10A)
99997 FORMAT ('PART', I4)
99996 FORMAT (A, 2X, I1, 3F10.4)
99995 FORMAT (A, I2.2, I4, 3F10.4, ' 11.0 0.05')
99994 FORMAT (A)
99993 FORMAT ('Case # ', I3, 24X, A12, /, 20X, 'Halfsum', 26X,
     1  'Difference')
99992 FORMAT (A4, 1X, I3, A4)
99991 FORMAT (A8)
99990 FORMAT (A28)
99989 FORMAT (A6)
99988 FORMAT (A, I2.2, 3X, 3F10.4, 5x, 3F10.4)
99987 FORMAT (A, I2.2, I4, 3F10.4, ' 11.0 0.05')
99986 FORMAT (1X)
99985 FORMAT (A, 3F10.4, 5X, 3F10.4)
99984 FORMAT (79('#'), /)
      END SUBROUTINE PLA400
      SUBROUTINE PLA401 (ICOUNT1, ICOUNT2, SUMX, Sumsqdev, DIF,
     1 DifSqdev, DELTA1, DELTA2, SUCCESS, ISUCC, CARTEL, XX12)
      USE mp
      IMPLICIT NONE
      INTEGER            :: ICOUNT1
      INTEGER            :: ICOUNT2
      INTEGER            :: ISUCC
      REAL               :: ZERO
      REAL               :: TRUE1
      REAL               :: TRUE2
      REAL               :: DELTA2
      REAL               :: DELTA1
      REAL               :: SUCCESS
      REAL, DIMENSION(3) :: SUMX
      REAL, DIMENSION(3) :: SUMSQDEV
      REAL, DIMENSION(3) :: DIF
      REAL, DIMENSION(3) :: DIFSQDEV
      CHARACTER(len=96)  :: TXT
      CHARACTER(len=96)  :: TXT1
      CHARACTER(len=96)  :: TXT2
      CHARACTER(len=96)  :: TXT3
      CHARACTER(len=96)  :: TEXT
      CHARACTER(len=12)  :: XX12
      CHARACTER(len=8)   :: CARTEL
      CHARACTER(len=8)   :: CHAR1
      CHARACTER(len=8)   :: CHAR2
      DATA TXT2/
     1'# REAL #   *********  Real Symmetry operation   *******   '/
      DATA TXT3/
     1'     ***************   No local symmetry found  ***************'/
      CARTEL = '# POOR #'
      WRITE (CHAR1, 99999) DELTA1
      WRITE (CHAR2, 99999) DELTA2
      TXT1 = CARTEL//
     1 '                Delta1:'//CHAR1//',  Delta2:'//CHAR2
      ZERO  = 0.0
      TRUE1 = SumSqdev(1) * SumSqdev(2) * SumSqdev(3)
      TRUE2 = DifSqdev(1) * DifSqdev(2) * DifSqdev(3)
      TXT   = TXT1
      IF (ABS (TRUE1) < 0.00001 .OR. ABS (TRUE2) < 0.00001)
     1   TXT = TXT2
      WRITE (TEXT, 99998) TXT3
C * Here the big loop starts
      ISUCC = 0
      IF (SUCCESS == 0) THEN
C * It goes on:  Delta1 y Delta2 NO DO not seem to be reasonables)
      ELSE IF ((ICOUNT1 == 3) .AND. (ICOUNT2 == 0)) THEN
C * possible -1
        ISUCC = 1
        WRITE (TEXT, 99997) TARG(1), SUMX(1), SUMX(2), SUMX(3), XX12
      ELSE IF ((ICOUNT1 == 2) .AND. (ICOUNT2 == 1)) THEN
C * possible 2-2-Axis
        Isucc = 2
        IF ((SumSqdev(1) < delta1) .AND. (SumSqdev(2) < DELTA1)
     1    .AND. (DifSqdev(3) < DELTA1)) THEN
C * // <001>
        IF (ABS (DIF(3)) < DELTA2)
     1    WRITE (TEXT, 99996) TARG(2), SUMX(1), SUMX(2), XX12
        IF (ABS (DIF(3)) > DELTA2)
     1    WRITE (TEXT, 99995) TARG(3), SUMX(1), SUMX(2), DIF(3), XX12
      ELSE IF ((SumSqdev(1) < DELTA1) .AND. (SumSqdev(3) <
     1 DELTA1) .AND. (DifSqdev(2) < DELTA1)) THEN
C * // <010>
        IF (ABS (DIF(2)) < DELTA2) WRITE (TEXT, 99994)
     1    TARG(4), SUMX(1), SUMX(3), XX12
        IF (ABS (DIF(2)) > DELTA2) WRITE (TEXT, 99993)
     1    TARG(5), SUMX(1), SUMX(3), DIF(2), XX12
      ELSE IF ((SumSqdev(2) < DELTA1) .AND. (SumSqdev(3) <
     1 DELTA1) .AND. (DifSqdev(1) < DELTA1)) THEN
C * // <100>
        IF (ABS (DIF(1)) < DELTA2) WRITE (TEXT, 99992)
     1    TARG(6), SUMX(2), SUMX(3), XX12
        IF (ABS (DIF(1)) > DELTA2) WRITE (TEXT, 99991)
     1   TARG(7), SUMX(2), SUMX(3), DIF(1), XX12
        END IF
      ELSE IF ((ICOUNT1 == 1) .AND. (ICOUNT2 == 2)) THEN
C * posible plano
        ISUCC = 3
        IF ((SumSqdev(1) < DELTA1) .AND. (DifSqdev(2) < DELTA1)
     1    .AND. (DifSqdev(3) < DELTA1)) THEN
C * // (001)
          IF (ABS (DIF(2)) < DELTA2 .AND. ABS (DIF(3))
     1      < DELTA2 ) WRITE (TEXT, 99990) TARG(8), SUMX(1), XX12
          IF (ABS (DIF(2)) > DELTA2 .AND. ABS (DIF(3))
     1      < DELTA2 ) WRITE (TEXT, 99989) TARG(9), SUMX(1), DIF(2),
     2      XX12
          IF (ABS (DIF(2)) < DELTA2 .AND. ABS (DIF(3))
     1      > DELTA2 ) WRITE (TEXT, 99988) TARG(10), SUMX(1),
     2       DIF(3), XX12
          IF (ABS (DIF(2)) > DELTA2 .AND. ABS (DIF(3))
     1      > DELTA2 ) WRITE (TEXT, 99987) TARG(11), SUMX(1),
     2      DIF(2), DIF(3), XX12
        ELSE IF ((SumSqdev(2) < DELTA1) .AND. (DifSqdev(1)
     1    < DELTA1) .AND. (DifSqdev(3) < DELTA1)) THEN
C * // (010)
          IF (ABS (DIF(1)) < DELTA2 .AND. ABS (DIF(3))
     1      < DELTA2 ) WRITE (TEXT, 99986) TARG(12), SUMX(2), XX12
          IF (ABS (DIF(1)) > DELTA2 .AND. ABS (DIF(3))
     1      < DELTA2 ) WRITE (TEXT, 99985) TARG(13), SUMX(2),
     2      DIF(1), XX12
          IF (ABS (DIF(1)) < DELTA2 .AND. ABS (DIF(3))
     1      > DELTA2 ) WRITE (TEXT, 99984) TARG(14), SUMX(2),
     2      DIF(3), XX12
          IF (ABS (DIF(1)) > DELTA2 .AND. ABS (DIF(3))
     1      > DELTA2 ) WRITE (TEXT, 99983) TARG(15), SUMX(2),
     2      DIF(1), DIF(3),
     2      XX12
        ELSE IF ((SumSqdev(3) < delta1) .AND. (DifSqdev(1)
     1    < DELTA1) .AND. (DifSqdev(2) < DELTA1)) THEN
C * // (100)
          IF (ABS (DIF(1)) < DELTA2 .AND. ABS (DIF(2))
     1      < DELTA2 ) WRITE (TEXT, 99982) TARG(16), SUMX(3), XX12
          IF (ABS (DIF(1)) > DELTA2 .AND. ABS (DIF(2))
     1      < DELTA2 ) WRITE (TEXT, 99981) TARG(22), SUMX(3),
     2      DIF(1), XX12
          IF (ABS (DIF(1)) < DELTA2 .AND. ABS (DIF(2))
     1      > DELTA2 ) WRITE (TEXT, 99980) TARG(23), SUMX(3),
     2      DIF(2), XX12
          IF (ABS (DIF(1)) > DELTA2 .AND. ABS (DIF(2))
     1      > DELTA2 ) WRITE (TEXT, 99979) TARG(24), SUMX(3),
     2      DIF(1), DIF(2), XX12
          END IF
        ELSE IF ((ICOUNT2 == 3)) THEN
C * possible cell centering
          Isucc = 4
      IF (ABS (DIF(1)) > DELTA2) THEN
        IF (ABS (DIF(2)) > DELTA2) THEN
          IF (ABS (DIF(3)) > DELTA2) THEN
            WRITE (TEXT, 99978) TARG(17), DIF(1), DIF(2), DIF(3), XX12
          ELSE
            WRITE (TEXT, 99978) TARG(18), DIF(1), DIF(2), ZERO, XX12
          ENDIF
        ELSE IF (ABS (DIF(3)) > DELTA2) THEN
            WRITE (TEXT, 99978) TARG(19), DIF(1), ZERO, DIF(3), XX12
          ELSE
            WRITE (TEXT, 99978) TARG(20), DIF(1), ZERO, ZERO, XX12
          END IF
        ELSE IF (ABS (DIF(2)) > DELTA2) THEN
          IF (ABS (DIF(3)) > DELTA2 ) THEN
            WRITE (TEXT, 99978) TARG(21), ZERO, DIF(2), DIF(3), XX12
          ELSE
            WRITE (TEXT, 99978) TARG(25), ZERO, DIF(2), ZERO, XX12
          END IF
        ELSE IF (ABS (DIF(3)) > DELTA2) THEN
          WRITE (TEXT, 99978) TARG(26), ZERO, ZERO, DIF(3), XX12
        END IF
      END IF
      WRITE (8, 99971) TEXT
      if (TRUE1 == 0.0 .OR. TRUE2 == 0.0) TXT = TXT2
      if (TEXT == TXT3)  WRITE (TXT, 99970)
      WRITE (8, 99969) TXT
99999 FORMAT (F7.4)
99998 FORMAT (A)
99997 FORMAT (A, 'Possible inversion at (', 2(F8.4, ','), F8.4, ')',
     1        T75, A)
99996 FORMAT (A, 'Possible   twofold at (', 2(F8.4, ','), ' z)', T75, A)
99995 FORMAT (A, 'Possible     screw at (', 2(F8.4, ','), ' z)  shift:',
     1        F8.4, T75, A)
99994 FORMAT (A, 'Possible   twofold at (', F8.4, ', y, ',F8.4, ')',
     1        T75, A)
99993 FORMAT (A, 'Possible   screw  at (',
     1        F8.4,', y,', F8.4,'),   shift:', F8.4, T75, A)
99992 FORMAT (A, 'Possible   twofold at (',' x,', F8.4,',',F8.4,')',
     1        T75, A)
99991 FORMAT (A, 'Possible   screw at (',' x,',
     1        F8.4, ',', F8.4,'),   shift:', f8.4, T75, A)
99990 FORMAT (A, 'Possible   mirror at (', F8.4,', y',', z)', T75, A)
99989 FORMAT (A, 'Possible   glide at (',
     1        F8.4,', y',', z),         shift:', F8.4, T75, A)
99988 FORMAT (A, 'Possible   glide at (',
     1        F8.4,', y',', z),        shift: ', F8.4, T75, A)
99987 FORMAT (A, 'Possible   glide at (',
     1        F8.4,', y',', z), shift:', 2F8.4, T75, A)
99986 FORMAT (A, 'Possible   mirror at (',' x,', F8.4,', z)', T75, A)
99985 FORMAT (A, 'Possible   glide at (',' x,',
     1        F8.4,', z),         shift: ', F8.4, T75, A)
99984 FORMAT (A, 'Possible   glide at (',' x,',
     1        F8.4,', z),         shift:', F8.4, T75, A)
99983 FORMAT (A, 'Possible   glide at (',' x,',
     1        F8.4,', z), shift:', 2F8.4, T75, A)
99982 FORMAT (A, 'Possible   mirror at (',' x,',' y,', F8.4,')', T75, A)
99981 FORMAT (A, 'Possible   glide at (',' x,', ' y,',
     1        F8.4,'),       shift: ', F8.4, T75, A)
99980 FORMAT (A, 'Possible   glide at (',' x,', ' y,',
     1        F8.4,'),       shift: ', F8.4, T75, A)
99979 FORMAT (A, 'Possible   glide at (',' x,', ' y,',
     1        F8.4,'), shift:', 2F8.4, T75, A)
99978 FORMAT (A, 'Possible   cell centering', ' shift: ', 3F8.4, T75, A)
99971 FORMAT (/, A)
99970 FORMAT (96X)
99969 FORMAT (/, A, /)
      RETURN
      END SUBROUTINE PLA401
      SUBROUTINE PLA402 (NWRITE)
      USE mp
      IMPLICIT NONE
      INTEGER                          :: I
      INTEGER                          :: J
      INTEGER                          :: K
      INTEGER                          :: NL
      INTEGER                          :: IOST
      INTEGER                          :: IPUNCH
      INTEGER                          :: NWRITE
      CHARACTER(len=12), DIMENSION(10) :: XYLINE
      CHARACTER(8)                     :: CARTEL
      OPEN (UNIT = 14, status = 'SCRATCH')
      REWIND (UNIT = 8)
      NL = 0
      DO
        READ (8, 99999, IOSTAT = IOST) (XYLINE(J), J = 1, 8)
        IF (IOST /= 0) EXIT
        WRITE (14, 99999) (XYLINE(J), J = 1, 8)
        NL = NL + 1
      END DO
      REWIND (UNIT = 8)
      REWIND (UNIT = 14)
      IF (NWRITE == 2) THEN
        DO K = 1, NL
          READ (14, 99999) (XYLINE(J), J = 1, 8)
          WRITE (8, 99999) (XYLINE(J), J = 1, 8)
        END DO
      END IF
      DO J = 1, NLINES
        WRITE (8, 99996) (XLINE(I, J), I = 1, 20)
      END DO
      WRITE (8, 99995)
      OPEN (UNIT = 15, STATUS = 'SCRATCH')
      DO I = 1, 26
        IPUNCH = 0
        REWIND (UNIT = 14)
        DO
          READ (14, 99999, IOSTAT = IOST) (XYLINE(J), J = 1, 8)
          IF (IOST /= 0) EXIT
          IF (XYLINE(1) == TARG(I)) THEN
            READ (14, 99998)
            READ (14, 99997) CARTEL
            XYLINE(2)(1:8) = CARTEL
            WRITE (8, 99999) (XYLINE(J), J = 1, 8)
            IPUNCH = 1
          ENDIF
        END DO
        if (IPUNCH == 1) THEN
          WRITE (8, 99998)
        ELSE
          WRITE (8, 99997) TARG(I)//'No Match'
          WRITE (8, 99998)
        ENDIF
      END DO
      RETURN
99999 FORMAT (8A)
99998 FORMAT (1X)
99997 FORMAT (A)
99996 FORMAT (20A)
99995 FORMAT (//, '  ########  Sorted Summary of Results  ########', /)
      END SUBROUTINE PLA402
 
      SUBROUTINE PLA410 (MODE)
C * ANALYSIS OF VARIANCE + ANALYSIS FOR TWINNING + BIJVOET PAIR ANALYSIS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE reflex
      USE analysis
      USE pl127
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IHO
      INTEGER :: IKO
      INTEGER :: ILO
      INTEGER :: MODE
      INTEGER :: NFEXP
      INTEGER :: IHEXL
      INTEGER :: ITHETA
      REAL    :: TH
      REAL    :: ST
      REAL    :: STL
      REAL    :: SIG
      REAL    :: FCK
      REAL    :: FOK
      REAL    :: FOKM
      REAL    :: FCKP
      REAL    :: ACAL
      REAL    :: BCAL
      REAL    :: CALI
      REAL    :: SIGI
      REAL    :: SIGK
      REAL    :: YUNK
      REAL    :: SIGIW
      REAL    :: ACALA
      REAL    :: BCALA
      REAL    :: ACALS
      REAL    :: BCALS
      REAL    :: SCHAAL
      REAL    :: ACALAF
      REAL    :: BCALAF
      REAL    :: SUMFCK
      REAL    :: SUMFOK
      REAL    :: GEN050
      REAL    :: GEN095
      REAL    :: THETAMAX
C * MODE = -2 : Bijvoet Pair Analysis          - PLA421 (Validation Mode)
C *      = -1 : Bijvoet Pair Analysis          - PLA421 (Standard   Mode)
C *      =  0 : Analysis-of-Variance           - PLA412
C *      =  1 : TwinRotMat                     - PLA414
C *      =  2 : TwinRotMat (Non-Graphics Mode) - PLA414
C * REFLECTION DATA STORAGE SCHEME
C * VOID(NADR + 1)  = IH
C * VOID(NADR + 2)  = IK
C * VOID(NADR + 3)  = IL
C * VOID(NADR + 4)  = FOK
C * VOID(NADR + 5)  = FCK (FROM CIF)
C * VOID(NADR + 6)  = MAX (SIG, 0.0)
C * VOID(NADR + 7)  = TH
C * VOID(NADR + 8)  = (FOK - FCK) / SIGI
C * VOID(NADR + 9)  = (FOK - FCK) / SIGIW
C * VOID(NADR + 10) =
C * VOID(NADR + 11) = FCK' (FROM FCF)
C * VOID(NADR + 12) = SIGIW
C * NO ANALYSIS FOR JANA(F) REFLECTION DATA CASE
      IF (IGBL(9) == 14) THEN
        IGGT = ' '
        WRITE (LU6, 99991, IOSTAT = IOST)
        RETURN
      ENDIF
C * NO ANALYSIS WHEN PAR(493) < 0.0 (NEGATIVE WEIGHT-PAR-A)
      IF (PAR(493) < 0.0) THEN
        IF (IPR(725) /= 6 .AND. IPR(725) /= 9) THEN
          IGGT = ' '
          WRITE (LU6, 99990, IOSTAT = IOST)
          RETURN
C * JANA REFINEMENT
        ELSE
          PAR(493) = 0.0
          PAR(494) = 0.0
        END IF
      END IF
C * SET X-WINDOWS GRAPHICS MODE
      IWIN = IGBL(25) * IGBL(32)
      IH   = 0
      IK   = 0
      IL   = 0
C * PREPARE FOR THE CALCULATION OF FCALC (IGBL(9) = 0 => HKLF 4)
      IF (IGBL(9) == 0 .AND. MODE < 0) THEN
C * SET ASYM NORMAL MODE
        IPR(408) = 0
C * SET ASYM MODE TO 0 (LISTING OF SYMMETRY ABSENCES REFLECTIONS ONLY)
        IPR(392) = 0
C * RUN DEFAULT ASYM
        IPR(220) = 1
        CALL PLA145 (0)
        LU16 = LU17
        REWIND (UNIT = LU16, IOSTAT = IOST)
      ELSE
C * HANDLE CELL DATA
        CALL PLA100
C * LIST CELL DATA
        CALL PLA042 (2)
C * CHECK WAVELENGTH DATA
        CALL PLA293 (PAR(17))
      END IF
      IF (MODE < 2) THEN
C * MODE = -1 : BIJVOET PAIR ANALYSIS CASE
        IF (MODE == -1) THEN
          IF (IPR(220) > 1 .AND. IFL(2)(1:3) == 'FCF') IPR(594) = 0
C * IGNORE BASF/TWIN IN .RES
          IPR(193) = 0
          IPR(513) = 0
C * CHECK FOR EXPECTED BIJVOET PAIR NUMBER CALCULATION DONE
          NFEXP = IPR(560)
          IF (NFEXP <= 0) THEN
            IF (PAR(168) < 0.0) THEN
              WRITE (LU6, 99995, IOSTAT = IOST)
C * DETERMINE THETAMAX
              THETAMAX = 0.0
              IEND     = -1
              DO WHILE (IEND <= 0)
                CALL PLA132 (IHO, IKO, ILO, FOK, SIG, SIGIW, CALI, FCK,
     1                       ACALS, BCALS)
                IF (IEND == 2) STOP 'INCONSISTENT CIF/FCF (PLA410)'
                IF (IEND /= 1 .AND.
     1            (IHO /= 0 .OR. IKO /= 0 .OR. ILO /= 0)) THEN
                  IF (GEN050 (TRMX, IHO, IKO, ILO, IH, IK, IL) == -1.0)
     1              CYCLE
                  STL = SQRT (GEN095 (PAR(191), IH, IK, IL))
                  ST  = STL * PAR(17)
                  IF (ST < 1.0) THEN
                    THETAMAX = MAX (THETAMAX, ASIN (ST) * RGBL(6))
                  END IF
                END IF
              END DO
              PAR(168) = THETAMAX
              WRITE (LU6, 99994, IOSTAT = IOST) THETAMAX
            END IF
C * RUN ASYM: SET FOR EXPECT MODE - CHECK FOR THETA(MAX) VALUE
            IF (PAR(168) > 0.0) THEN
              CALL PLA145 (1)
              IPR(408) = 0
            END IF
          END IF
C * SETUP CONNECTED SET
          IF (IGBL(3) /= 1) THEN
            CALL PLA287 (1, 1, 0)
          END IF
C * SET PAGE HEADER FOR LISTING
          PAGET = 'BIJVOET'
          CALL PLA262 (0)
          IPR(2) = -1
C * MODE = 1 : TWINROTMAT CASE
        ELSE IF (MODE == 1) THEN
C * EXTRACT EMBEDDED .ins & .hkl
          CALL SGSM (25, ICL, SGX, J, 0, IERR)
          CALL PLA345
          CALL SGSM (26, ICL, SGX, J, 0, IERR)
          IF (IPR(664) /= 0) THEN
            CLOSE (UNIT = LU25, STATUS = 'DELETE')
            IPR(664) = 0
          END IF
C * NO FCAL FOR -T OPTION
          IF (IGBL(9) < 1 .OR.
     1      (IGBL(9) > 12 .AND. IGBL(9) /= 25)) THEN
            WRITE (LU6, 99993, IOSTAT = IOST)
            IGGT = ' '
            RETURN
          END IF
C * TEST FOR -T OPTION
          IF (IGBL(3) == 30) THEN
            IPR(594) = 0
          ELSE
            IF (ABS (IGBL(8)) /= 3) THEN
              WRITE (LU6, 99993, IOSTAT = IOST)
              IGGT = ' '
              RETURN
            END IF
            IPR(594) = 1
C * SETUP CONNECTED SET
            CALL PLA287 (1, 1, 0)
          END IF
C * SET PAGE HEADER FOR LISTING
          PAGET    = 'TWINROTM'
          IGBL(6) = 25
          CALL PLA262 (0)
          WRITE (LU7, 99998, IOSTAT = IOST)
C * MODE = 0 : ANALYSIS OF VARIANCE CASE
        ELSE IF (MODE == 0) THEN
C * SET PAGE HEADER FOR LISTING
          PAGET    = 'ANALVAR'
          IPR(594) = 0
C * SETUP CONNECTED SET
          IF (IGBL(9) <= 0) CALL PLA287 (1, 1, 0)
          CALL PLA262 (0)
          IPR(2) = -1
        END IF
C * REPORT ON WEIGHTING
        IF (PAR(493) >= 0.0)
     1    WRITE (LU6, 99997, IOSTAT = IOST) PAR(493), PAR(494)
        WRITE (LU7, 99996, IOSTAT = IOST) RLWS(1)
      END IF
C * INIT
      IPR(132) = -1
      IEND     = -1
      NADR     = 0
      FOKM     = 0.0
      IND1     = 1
      IND2     = 2
      IND3     = 3
      NSYM     = IPR(48)
      NSYMH    = IPR(255)
      ICNTR    = IPR(257)
      HMAX     = -999
      KMAX     = -999
      LMAX     = -999
      SUMFOK   = 0.0
      SUMFCK   = 0.0
      SIGK     = 0.0
      ACAL     = 0.0
      BCAL     = 0.0
      ACALA    = 0.0
      BCALA    = 0.0
      ACALAF   = 0.0
      BCALAF   = 0.0
      DO I = 1, 90
        DO J = 1, 5
          AVIOSIG(I, J) = 0.0
        END DO
      END DO
C * TEST FOR HEXAGONAL LATTICE TYPE
      IF (IPR(259) == 5 .OR. IPR(259) == 6) THEN
        IHEXL = 1
      ELSE
        IHEXL = 0
      END IF
C * INPUT REFLECTION DATA ARE STORED BOTTOM UP IN THE VOID SCRATCH ARRAY
C * 3D POINTERS TO THOSE DATA ARE STORED TOP DOWN IN THE VOID SCRATCH ARRAY
C * REFLECTION FILE READ LOOP
      DO WHILE (IEND <= 0)
        CALL PLA132 (IHO, IKO, ILO, FOK, SIGI, SIGIW, CALI, FCKP, ACALS,
     1               BCALS)
        IF (IEND == 2) STOP 'INCONSISTENT CIF/FCF (PLA410)'
        IF (IEND /= 1 .AND.
     1    (IHO /= 0 .OR. IKO /= 0 .OR. ILO /= 0)) THEN
C * TRANSFORM AND ELIMINATE REFLECTIONS WITH NON-INTEGER INDICES
          IF (GEN050 (TRMX, IHO, IKO, ILO, IH, IK, IL) > 0.0) THEN
C * CALCULATE FCALC**2 FOR HKL I SIGMA(I) DATA
            IF (IGBL(9) <= 0 .OR. IPR(594) /= 0) THEN
              CALL PLA137 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA,
     1          ACALAF, BCALAF, YUNK)
              FCK = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2
            END IF
            STL = SQRT (GEN095 (PAR(191), IH, IK, IL))
            ST  = STL * PAR(17)
            IF (ST < 1.0) THEN
              SIGI            = MAX (SIGI, 0.0)
              TH              = ASIN (ST) * RGBL(6)
              VOID(NADR + 1)  = IH
              VOID(NADR + 2)  = IK
              VOID(NADR + 3)  = IL
              VOID(NADR + 4)  = FOK
              VOID(NADR + 5)  = FCK
              VOID(NADR + 6)  = SIGI
              VOID(NADR + 7)  = TH
              VOID(NADR + 8)  = 0.0
              VOID(NADR + 9)  = 0.0
              VOID(NADR + 10) = 0.0
              VOID(NADR + 11) = MAX (0.0, FCKP)
              VOID(NADR + 12) = SIGIW
              SUMFOK          = SUMFOK + FOK
              SUMFCK          = SUMFCK + FCK
              NADR            = NADR   + NREC
C * COLLECT AV(I/SIGMA) VERSUS THETA STATISTICS
              IF (SIGI > 0.0) THEN
                ITHETA             = INT (TH) + 1
                AVIOSIG(ITHETA, 1) = AVIOSIG(ITHETA, 1) + FOK / SIGI
                AVIOSIG(ITHETA, 2) = AVIOSIG(ITHETA, 2) + 1.0
                AVIOSIG(ITHETA, 3) = AVIOSIG(ITHETA, 3) + FOK
                AVIOSIG(ITHETA, 4) = AVIOSIG(ITHETA, 4) + SIGI
              END IF
C * KEEP TRACK OF REFLECTION INDEX MAXIMA
              HMAX = MAX (HMAX, IABS (IH))
              KMAX = MAX (KMAX, IABS (IK))
C * HEXAGONAL LATTICE
              IF (IHEXL == 1) THEN
                HMAX = MAX (KMAX, HMAX, IABS (IH + IK))
                KMAX = HMAX
              END IF
              LMAX = MAX (LMAX, IABS (IL))
            END IF
          END IF
        END IF
      END DO
C * I / SIGMA AVERAGES
      DO I = 1, 90
        IF (AVIOSIG(I, 2) > 0.0) THEN
          AVIOSIG(I, 1) = AVIOSIG(I, 1) / AVIOSIG(I, 2)
          AVIOSIG(I, 3) = AVIOSIG(I, 3) / AVIOSIG(I, 2)
          AVIOSIG(I, 4) = AVIOSIG(I, 4) / AVIOSIG(I, 2)
          AVIOSIG(I, 5) = AVIOSIG(I, 3) / AVIOSIG(I, 4)
        END IF
      END DO
C * SCALE AND ADD WEIGHTS
      IF (NADR > 0) THEN
        NREF = NADR / NREC
C * SCALE FOBS**2 FOR HKL I SIG(I) DATA
        IF (IGBL(9) <= 0) THEN
          SCHAAL = SUMFCK / SUMFOK
        ELSE
          SCHAAL = 1.0
        END IF
        NADR = 0
        DO I = 1, NREF
          FOK  = VOID(NADR + 4) * SCHAAL
          FOKM = MAX (FOKM, FOK)
          FCK  = VOID(NADR + 5)
          SIG  = VOID(NADR + 6) * SCHAAL
          SIGK = VOID(NADR + 12)**2
          FCKP = VOID(NADR + 11)
C * INCLUDE L.S. WEIGHT PARAMETERS IN SIGMAI
          IF (SIG > 0.0) THEN
            VOID(NADR + 8) = MAX ((FOK - FCKP) / SIG, 0.0)
            VOID(NADR + 9) = (FOK - FCKP) / SQRT (SIGK)
          END IF
          VOID(NADR + 4) = FOK
          VOID(NADR + 6) = SIG
          NADR           = NADR + NREC
        END DO
C * TETRAGONAL LATTICE
        IF (IPR(259) == 4) THEN
          HMAX = MAX (HMAX, KMAX)
          KMAX = HMAX
C * CUBIC LATTICE
        ELSE IF (IPR(259) == 7) THEN
          HMAX = MAX (HMAX, KMAX, LMAX)
          KMAX = HMAX
          LMAX = HMAX
        END IF
        SCL = 10 ** (INT (ALOG (10000000 / FOKM) / ALOG (10.0)))
C * INCLUDE ANALYSIS OF VARIANCE
        CALL PLA412 (MODE)
        IF (MODE /= 0 .AND. IPR(493) .NE. 8) THEN
C * ANALYSE FOR TWINNING (+ BIJVOET PAIRS)
          IF (MODE > 0) THEN
            IF (MODE == 1) THEN
C * USE REFLECTION DATA CALCULATED FROM CIF DATA (GRAPHICS MODE)
              IPR(608) = 1
              CALL PLA414 (1)
            ELSE
C * USE REFLECTION DATA CALCULATED FROM CIF DATA (NON-GRAPHICS MODE)
              IPR(608) = 1
              CALL PLA414 (2)
C * CHECK FOR TWIN CORRECTED FCF (NON-GRAPHICS MODE)
              IF (IGBL(9) > 0 .AND. IGBL(9) < 13) THEN
                IPR(608) = 0
                CALL PLA414 (2)
              END IF
C * FCF BASED (=0) ON CIF DATA (=1)
              IPR(594) = 1
C * STUDENT-T MODE
              IPR(613) = 1
C * SLOPE
              IPR(593) = 1
C * RECYCLE STUDENT-T
              IPR(617) = 1
C * AUTO NU
              PAR(488) = 0.0
              CALL PLA421
            END IF
C * ANALYSIS OF BIJVOET-PAIRS
          ELSE IF (MODE == -1) THEN
C * HANDLE JANA & MOPRO
            IF (IGBL(9) > 0 .AND. IGBL(9) < 13) THEN
              CALL PLA421
            ELSE
              WRITE (LU6, 99992, IOSTAT = IOST)
            END IF
          END IF
        END IF
      ELSE
        WRITE (LU6, 99999, IOSTAT = IOST)
      END IF
      IGGT = ' '
      RETURN
99999 FORMAT (/, ':: No Reflections found')
99998 FORMAT (/, 'TwinRotMat: Analysis of the Fo/Fc CIF for Unaccounted'
     1        ,' (Non)Merohedral Twinning', /, 79('='), /)
99997 FORMAT (':: W1, W2 =', 2F10.4)
99996 FORMAT (/, A, /)
99995 FORMAT (/, ':: Determine Theta(max) Dataset')
99994 FORMAT (/, ':: Theta(max) =', F6.2)
99993 FORMAT (/, ':: Sorry: CIF & FCF (LIST 4 or 8) style data required'
     1        , ' for running TwinRotMat', /)
99992 FORMAT (/,
     1   ':: Bijvoet/Hooft Analysis with SHELXL/FCF(hklf4/LIST4)',
     2   ' Only !', /)
99991 FORMAT (/, ':: Sorry, No Analysis for JANA(F) data.', /)
99990 FORMAT (/, ':: Sorry, No Analysis when Weight Parameter A ',
     1        'Negative', /)
      END SUBROUTINE PLA410
 
      SUBROUTINE PLA411 (X, Y, DSH, PEN)
      IMPLICIT NONE
      REAL :: X
      REAL :: Y
      REAL :: DSH
      REAL :: PEN
      IF (PEN >= 0) CALL GGIP (0.0, PEN, 0.0, 0)
      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)
      RETURN
      END SUBROUTINE PLA411
 
      SUBROUTINE PLA412 (MODE)
C * ANALYSIS OF VARIANCE
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE analysis
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: N
      INTEGER :: LU
      INTEGER :: JB
      INTEGER :: JE
      INTEGER :: JH
      INTEGER :: JK
      INTEGER :: JL
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: LUX
      INTEGER :: MODE
      INTEGER :: NOBS
      INTEGER :: NOPT
      INTEGER :: NPLT
      INTEGER :: NTOT
      INTEGER :: IHEAD
      INTEGER :: NADRM
      INTEGER :: NFCAL
      INTEGER :: NOBSFRAC
      REAL    :: S
      REAL    :: R1
      REAL    :: R2
      REAL    :: FCK
      REAL    :: FOK
      REAL    :: SIG
      REAL    :: STL
      REAL    :: R2XX
      REAL    :: YUNK
      REAL    :: STON
      REAL    :: STOT
      REAL    :: SIGK
      REAL    :: SIGNX
      REAL    :: RESOL
      REAL    :: FCMAX
      REAL    :: SCHAAL
      REAL    :: SINTHL
      REAL    :: FCOFCM
      REAL    :: FACTOR
      REAL    :: R1TELL
      REAL    :: R2TELL
      REAL    :: R2TELN
      REAL    :: R2NOEM
      REAL    :: R2NOEN
      REAL    :: R1NOEM
      REAL    :: GEN095
      NFCAL  = 11
      IHEAD  = 0
      NOBS   = 0
      NTOT   = 0
      STOT   = 0.0
      STON   = 0.0
      R1TELL = 0.0
      R1NOEM = 0.0
      R2TELL = 0.0
      R2NOEM = 0.0
      R2TELN = 0.0
      R2NOEN = 0.0
      NADRM  = NREF * NREC
      IF (IGBL(22) < 0) THEN
        JB = 3
        JE = 3
      ELSE
        JB = 1
        JE = 2
      END IF
      FACTOR = 10 / (0.65**3 + 0.0001)
      DO I = 1, 20
        DO J = 1, 12
          STAT(I, J) = 0.0
        END DO
      END DO
      DO I = 1, 11
        DO J = 1, 5
          VSTATA (I, J) = 0.0
          VSTATB (I, J) = 0.0
          VSTATC (I, J) = 0.0
        END DO
      END DO
      DO I = 1, 14
        DO J = 1, 3
          NSTATH(I, J) = 0
          NSTATK(I, J) = 0
          NSTATL(I, J) = 0
        END DO
      END DO
C * GET 10 EQUALLY POPULATED BOXES AS A FUNCTION OF F/FMAX
      NADR = 0
      DO I = 1, NREF
        VOID(NADRM + I) = SQRT (VOID(NADR + NFCAL))
        NADR            = NADR + NREC
      END DO
C * SORT ON F(CALC)
      CALL GEN034 (VOID, NADRM + 1, NADRM + NREF)
      FCMAX = VOID(NADRM + 1)
      IF (FCMAX == 0.0) THEN
        WRITE (6, '('':: Problem in PLA412, SKIP'', /)')
        RETURN
      END IF
      VSTATA(1,  1) = 0.0
      VSTATA(11, 1) = 1.0
      DO I = 1, 9
        N = NINT (FLOAT (I * NREF) / 10.0) + NADRM
        VSTATA(11 - I, 1) = VOID(N) / FCMAX
      END DO
C * GET 10 EQUALLY POPULATED BOXES ORDERED ON RESOLUTION
      NADR = 0
      DO 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))
        VOID(NADRM + I) = 0.5 / STL
        NADR = NADR + NREC
      END DO
C * SORT ON RESOLUTION
      CALL GEN034 (VOID, NADRM + 1, NADRM + NREF)
      VSTATB(1,  1) = VOID(NADRM + NREF)
      VSTATB(11, 1) = VOID(NADRM + 1)
      VSTATC(1,  1) = VOID(NADRM + NREF)
      VSTATC(11, 1) = VOID(NADRM + 1)
      DO I = 1, 9
        N = NINT (FLOAT (I * NREF) / 10.0) + NADRM
        VSTATB(11 - I, 1) = VOID(N)
        VSTATC(11 - I, 1) = VOID(N)
      END DO
C * COLLECT STATISTICS
      OPEN (UNIT = LU60, FILE = 'scratch', STATUS = 'UNKNOWN')
      NADR = 0
      DO I = 1, NREF
        JH  = ABS (NINT (VOID(NADR + 1)))
        JK  = ABS (NINT (VOID(NADR + 2)))
        JL  = ABS (NINT (VOID(NADR + 3)))
        FOK = VOID(NADR + 4)
        FCK = VOID(NADR + NFCAL)
        SIG = VOID(NADR + 6)
C * COLLECT STATISTICS FOR ABS(H), ABS(K) & ABS(L)
        IF (JH < 14) THEN
          NSTATH(JH + 1, 1) = NSTATH(JH + 1, 1) + 1
          IF (FOK > 3.0 * SIG) THEN
            NSTATH(JH + 1, 2) = NSTATH(JH + 1, 2) + 1
          END IF
          IF (FCK > 3.0 * SIG) THEN
            NSTATH(JH + 1, 3) = NSTATH(JH + 1, 3) + 1
          END IF
        END IF
        IF (JK < 14) THEN
          NSTATK(JK + 1, 1) = NSTATK(JK + 1, 1) + 1
          IF (FOK > 3.0 * SIG) THEN
            NSTATK(JK + 1, 2) = NSTATK(JK + 1, 2) + 1
          END IF
          IF (FCK > 3.0 * SIG) THEN
            NSTATK(JK + 1, 3) = NSTATK(JK + 1, 3) + 1
          END IF
        END IF
        IF (JL < 14) THEN
          NSTATL(JL + 1, 1) = NSTATL(JL + 1, 1) + 1
          IF (FOK > 3.0 * SIG) THEN
            NSTATL(JL + 1, 2) = NSTATL(JL + 1, 2) + 1
          END IF
          IF (FCK > 3.0 * SIG) THEN
            NSTATL(JL + 1, 3) = NSTATL(JL + 1, 3) + 1
          END IF
        END IF
        SIGNX  = SIG**2
C * INCLUDE L.S. WEIGHT PARAMETERS IN SIGMAI
        SIGK       = VOID(NADR + 12)**2
        STL        = SIN ((VOID(NADR + 7) / RGBL(6))) / PAR(17)
        N          = MIN (20,  1 + INT (STL**3 * FACTOR))
        STAT(N, 1) = STAT(N, 1) + ABS (FOK)
        STAT(N, 2) = STAT(N, 2) + ABS (FCK)
        STAT(N, 3) = STAT(N, 3) + 1.0
        IF (FOK > 2 * SIG) THEN
          STAT(N, 10) = STAT(N, 10) + 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)))
        END IF
        IF (SIGK /= 0.0) THEN
          STAT(N,  6) = STAT(N,  6) + (FOK - FCK) ** 2 / SIGK
          STAT(N,  7) = STAT(N,  7) + FOK ** 2 / SIGK
        END IF
        IF (SIGNX /= 0.0) THEN
          STAT(N, 11) = STAT(N, 11) + (FOK - FCK) ** 2 / SIGNX
          STAT(N, 12) = STAT(N, 12) + FOK ** 2 / SIGNX
        END IF
        NADR   = NADR + NREC
        FCOFCM = SQRT (FCK) / FCMAX
        DO J = 2, 11
          IF (FCOFCM <= VSTATA(J, 1)) THEN
            VSTATA(J, 2) = VSTATA(J, 2) + 1.0
            IF (SIGK /= 0.0) THEN
              VSTATA(J, 3) = VSTATA(J, 3) + (FOK - FCK)**2 / SIGK
            END IF
            VSTATA(J, 4) = VSTATA(J, 4) + FOK
            VSTATA(J, 5) = VSTATA(J, 5) + FCK
C * LIST CONTRIBUTIONS TO FIRST BIN
            IF (I == 1) WRITE (LU60, 99987)
            IF (J == 2) WRITE (LU60, 99988) JH, JK, JL,
     1        FOK, FCK, SIG, VSTATA(2,4), VSTATA(2,5), STL
            IF (J <= 3) THEN
              RESOL = 0.5 / STL
              DO K = 2, 11
                IF (RESOL <= VSTATC(K, 1)) THEN
                  VSTATC(K, 2) = VSTATC(K, 2) + 1.0
                  IF (SIGK /= 0.0) THEN
                    VSTATC(K, 3) = VSTATC(K, 3) + (FOK - FCK)**2 / SIGK
                  END IF
                  VSTATC(K, 4) = VSTATC(K, 4) + FOK
                  VSTATC(K, 5) = VSTATC(K, 5) + FCK
                  EXIT
                END IF
              END DO
            END IF
            EXIT
          END IF
        END DO
        RESOL = 0.5 / STL
        DO J = 2, 11
          IF (RESOL <= VSTATB(J, 1)) THEN
            VSTATB(J, 2) = VSTATB(J, 2) + 1.0
            IF (SIGK /= 0.0) THEN
              VSTATB(J, 3) = VSTATB(J, 3) + (FOK - FCK)**2 / SIGK
            END IF
            VSTATB(J, 4) = VSTATB(J, 4) + FOK
            VSTATB(J, 5) = VSTATB(J, 5) + FCK
            EXIT
          END IF
        END DO
      END DO
      DO I = 2, 11
        YUNK = VSTATA(I, 2) - IPR(266) / 10.0
        IF (YUNK > 0.0) THEN
          VSTATA(I, 3) = SQRT (VSTATA(I, 3) / YUNK)
        ELSE
          VSTATA(I, 3) = 0.0
        END IF
        IF (VSTATA(I, 2) > 0.0 .AND. VSTATA(I, 5) /= 0.0) THEN
          VSTATA(I, 4) = VSTATA(I, 4) / VSTATA(I, 5)
        ELSE
          VSTATA(I, 4) = 0.0
        END IF
        IF (VSTATA(I, 4) > 2.0) THEN
          CALL PLA236 (906, 3, 0.5, VSTATA(I, 4), ' ', ' ')
        ELSE IF (VSTATA(I, 4) < 0.0) THEN
          CALL PLA236 (905, 3, 0.5, VSTATA(I, 4), ' ', ' ')
        END IF
        YUNK = VSTATB(I, 2) - IPR(266) / 10.0
        IF (YUNK > 0.0) THEN
          VSTATB(I, 3) = SQRT (VSTATB(I, 3) / YUNK)
        ELSE
          VSTATB(I, 3) = 0.0
        END IF
        IF (VSTATB(I, 2) > 0.0 .AND. VSTATB(I, 5) /= 0.0) THEN
          VSTATB(I, 4) = VSTATB(I, 4) / VSTATB(I, 5)
        ELSE
          VSTATB(I, 4) = 0.0
        END IF
        IF (VSTATB(I, 4) > 2.0) THEN
          CALL PLA236 (906, 3, 0.5, VSTATB(I, 4), ' ', ' ')
        ELSE IF (VSTATB(I, 4) < 0.0) THEN
          CALL PLA236 (905, 3, 0.5, VSTATB(I, 4), ' ', ' ')
        END IF
        YUNK = VSTATC(I, 2) - IPR(266) / 100.0
        IF (YUNK > 0.0) THEN
          VSTATC(I, 3) = SQRT (VSTATC(I, 3) / YUNK)
        ELSE
          VSTATC(I, 3) = 0.0
        END IF
        IF (VSTATC(I, 2) > 0.0 .AND. VSTATC(I, 5) /= 0.0) THEN
          VSTATC(I, 4) = VSTATC(I, 4) / VSTATC(I, 5)
        ELSE
          VSTATC(I, 4) = 0.0
        END IF
      END DO
      DO I = 1, 14
        IF (NSTATH(I, 1) /= 0) THEN
          NSTATH(I, 2) = NINT (100.0 * NSTATH(I, 2) / NSTATH(I, 1))
          NSTATH(I, 3) = NINT (100.0 * NSTATH(I, 3) / NSTATH(I, 1))
        END IF
        IF (NSTATK(I, 1) > 0) THEN
          NSTATK(I, 2) = NINT (100.0 * NSTATK(I, 2) / NSTATK(I, 1))
          NSTATK(I, 3) = NINT (100.0 * NSTATK(I, 3) / NSTATK(I, 1))
        END IF
        IF (NSTATL(I, 1) > 0) THEN
          NSTATL(I, 2) = NINT (100.0 * NSTATL(I, 2) / NSTATL(I, 1))
          NSTATL(I, 3) = NINT (100.0 * NSTATL(I, 3) / NSTATL(I, 1))
        END IF
      END DO
      DO J = JB, JE
C * TERMINAL WINDOW LISTING
        IF (J == 1) THEN
          LU = LU6
C * LIS LISTING FILE
        ELSE IF (J == 2) THEN
          LU = LU7
C * CKF LISTING FILE
        ELSE
          LU = LU13
        END IF
        WRITE (LU, 99993, IOSTAT = IOST) HMAX, KMAX, LMAX
        IF (J == 2) CALL PLA262 (2)
        CALL PLA413 (LU)
      END DO
      IF (IGBL(22) >= 0 .OR. IABS (IGBL(36)) == 1) THEN
        DO I = 1, 20
          IF (STAT(I, 3) /= 0.0 .AND. STAT(I, 7) /= 0.0 .AND.
     1        STAT(I, 4) /= 0.0) THEN
            R1TELL = R1TELL + STAT(I,  5)
            R1NOEM = R1NOEM + STAT(I,  4)
            R2TELL = R2TELL + STAT(I,  6)
            R2NOEM = R2NOEM + STAT(I,  7)
            R2TELN = R2TELN + STAT(I, 11)
            R2NOEN = R2NOEN + STAT(I, 12)
            R1   = STAT(I, 5) / STAT(I, 4)
            R2   = SQRT (STAT(I, 6) / STAT(I, 7))
            S    = SQRT (STAT(I, 6) /
     1             (STAT(I, 3) - IPR(266) * STAT(I, 3) / NREF))
            STOT = STOT + STAT(I, 6)
            STON = STON + STAT(I, 11)
            NTOT = NTOT + NINT (STAT(I, 3))
            NOBS = NOBS + NINT (STAT(I, 10))
            IF (IHEAD == 0) THEN
              WRITE (LU6, 99998, IOSTAT = IOST)
              WRITE (LU7, 99998, IOSTAT = IOST)
              IHEAD = 1
            END IF
            SINTHL   = (I / FACTOR) ** 0.333333
            NOBSFRAC = INT (STAT(I, 10) * 39.0 / STAT(I, 3)) + 1
            DO J = 1, 40
              IF (J > NOBSFRAC) THEN
                IDM(40 + J: 40 + J) = '.'
              ELSE
                IDM(40 + J: 40 + J) = '*'
              END IF
            END DO
            WRITE (IDM(1:40), 99994, IOSTAT = IOST) SINTHL,
     1        0.5 / SINTHL,
     2        NINT (STAT(I, 3)), NINT (STAT(I, 10)), R1, R2, S
            WRITE (LU6, 99999, IOSTAT = IOST) IDM
            WRITE (LU7, 99999, IOSTAT = IOST) IDM
          END IF
        END DO
        WRITE (LU6, 99992, IOSTAT = IOST)
        WRITE (LU7, 99992, IOSTAT = IOST)
        STOT = SQRT (STOT / (NTOT - MAX (0, IPR(266))))
        STON = SQRT (STON / (NTOT - MAX (0, IPR(266))))
        IF (R1NOEM /= 0.0) R1   = R1TELL / R1NOEM
        IF (R2NOEM /= 0.0) R2   = SQRT (R2TELL / R2NOEM)
        IF (R2NOEN /= 0.0) R2XX = SQRT (R2TELN / R2NOEN)
        IF (STOT < 99.999) THEN
          WRITE (LU6, 99997, IOSTAT = IOST)
     1      R1, R2, STOT, NTOT, NOBS, MAX (0, IPR(266))
          WRITE (LU7, 99997, IOSTAT = IOST)
     1      R1, R2, STOT, NTOT, NOBS, MAX (0, IPR(266))
        ELSE
          WRITE (LU6, 99990, IOSTAT = IOST)
     1      R1, R2, MIN (999.99, STOT), NTOT, NOBS, MAX (0, IPR(266))
          WRITE (LU7, 99990, IOSTAT = IOST)
     1      R1, R2, MIN (999.99, STOT), NTOT, NOBS, MAX (0, IPR(266))
        END IF
        IF (STON < 99.999) THEN
          WRITE (LU6, 99991, IOSTAT = IOST) R2XX, STON
        ELSE
          WRITE (LU6, 99989, IOSTAT = IOST) R2XX, MIN (999.99, STON)
        ENDIF
C * NORMAL PROBABILITY PLOT
C * CHECK FOR VALIDATION MODE
        IF (IABS(IGBL(36)) == 1) THEN
          LUX = LU
          WRITE (LU, 99995)
        ELSE
          LUX = LU7
          CALL PLA262 (0)
        END IF
C * COPY (Fo-Fc)/SigW TO SEPARATE SECTION IN VOID
        DO I = 1, NREF
          VOID(NADR + I) = VOID((I - 1) * NREC + 9)
        END DO
        CALL GEN116 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NREF,
     1     GRAPH, 0)
        GRAPH(5)(52:95) =
     1    'NPP for (Fobs**2 - Fcalc**2) / SigW(Fobs**2)'
        IF (PAR(493) >= 0.0)
     1    WRITE (GRAPH(7)(52:103), 99996, IOSTAT = IOST)
     2    PAR(493), PAR(494)
        WRITE (GRAPH(9)(52: 57 + KNM16), 99999)
     1    'Data: '//FNLU16(1:KNM16)
        WRITE (LUX, 99999) (GRAPH(I), I = 1, 44)
C * DISPLAY=OFF/META=ON MODE ONLY
        IF (IGBL(66) == 0 .AND. IGBL(3) == 1) THEN
          IGGT(2:80) = NAMEFIL(1:79)
C * GENERAL GRAPHICS OPEN
          CALL GGIP (-999.0, FLOAT(-KNMFIL), 0.0, 5)
C * SET FOR DISPLAY = OFF/META = ON
          CALL GGIP (-999.0, 0.0, 0.0, -2)
C * Normal Probability Plot
          CALL PLA204
C * I(obs) - I(calc) scatter plot
          IPR(633) = 0
          SCHAAL   = 1.0
          CALL PLA419 (0, SCHAAL, IGBL(9), 0, LU6)
C * Log(I(obs)) versus Log(I)calc)) scatter plot
          IPR(633) = 1
          SCHAAL   = 1.0
          CALL PLA419 (0, SCHAAL, IGBL(9), 0, LU6)
C * VARIANCE ANALYSIS RESULTS
          CALL PLA413 (0)
C * I/SIG VERSUS LOG(I) PLOT (Diederichs)
          CALL PLA420 (2)
C * I/SIGW VERSUS LOG(I) PLOT (Diederichs)
          CALL PLA420 (3)
C * AV(I/SIG) VERSUS THETA
          CALL PLA420 (7)
        END IF
        NOPT = -1
        NPLT = 0
   10   IF (MODE == 0) THEN
C * Normal Probability Plot
          IF (NOPT == 0) THEN
            CALL PLA204
C * I(obs) - I(calc) scatter plot
          ELSE IF (NOPT == 1) THEN
            SCHAAL = 1.0
            CALL PLA419 (0, SCHAAL, IGBL(9), 0, LU6)
C * I/SIG VERSUS LOG(I) PLOT
          ELSE IF (NOPT == 2) THEN
            CALL PLA420 (NOPT)
C * I/SIGW VERSUS LOG(I) PLOT
          ELSE IF (NOPT == 3) THEN
            CALL PLA420 (NOPT)
C * SIG & SIGW VERSUS LOG(I) PLOT
          ELSE IF (NOPT == 4) THEN
            CALL PLA420 (NOPT)
C * LOG(SIG) & LOG(SIGW) VERSUS LOG(I) PLOT
          ELSE IF (NOPT == 5) THEN
            CALL PLA420 (NOPT)
C * SIGMA(I)  VERSUS SQRT(I) PLOT
          ELSE IF (NOPT == 6) THEN
            CALL PLA420 (NOPT)
C * AV(I/SIG) VERSUS THETA
          ELSE IF (NOPT == 7) THEN
            CALL PLA420 (NOPT)
C * VARIANCE ANALYSIS RESULTS
          ELSE IF (NOPT == -1) THEN
            CALL PLA413 (0)
          END IF
C * WHAT NEXT ?
          DO
C * WHAT NEXT ?
            CALL PLA012 (0, 1)
            CALL GEN020 (1, IGGT, 1, 10)
            IF (LRET == 2) THEN
              IF (NPLT == 1) THEN
                IGGT(1:4) = 'NPP '
              ELSE IF (NPLT == 2) THEN
                IGGT(1:4) = 'LINE'
              ELSE IF (NPLT == 3) THEN
                IGGT(1:4) = 'LOGL'
              END IF
              LRET = 0
            END IF
            CALL GEN072 (IGGT, IFL, FN, IPR(220), IPR(221), 0, LU6,
     1        1, 1, 80, 7, NP17)
            SELECT CASE (IFL(1)(1:4))
C * END PLOT
              CASE ('END ')
                RETURN
C * EXIT
              CASE ('EXIT')
                RETURN
C * PLOT
              CASE ('PLOT')
                GO TO 10
C * PLOT
              CASE ('!   ')
                GO TO 10
C * NORMAL PROBABILITY PLOT
              CASE ('NPP ')
                NPLT = 1
                NOPT = 0
                GO TO 10
C * SCATTER-PLOT
              CASE ('SCAT')
                IPR(633) = 0
                NPLT = 2
                NOPT = 1
                GO TO 10
C * LOGLOG-SCATTER PLOT
              CASE ('LOGL')
                IPR(633) = 1
                NPLT     = 3
                NOPT     = 1
                GO TO 10
C * LINEAR-PLOT
              CASE ('LINE')
                IPR(633) = 0
                NPLT     = 2
                NOPT     = 1
                GO TO 10
C * I/SIGMA VERSUS LOG(I) PLOT DI
              CASE ('IOSL')
                NOPT = 2
                GO TO 10
C * I/SIGMAW VERSUS LOG(I) PLOT
              CASE ('IOSW')
                NOPT = 3
                GO TO 10
C * SIG(I) VERSUS LOG(I)
              CASE ('SIGL')
                NOPT = 4
                GO TO 10
C * LOG(SIG(I)) VERSUS LOG(I)
              CASE ('LSLI')
                NOPT = 5
                GO TO 10
C * SIGMA(I) VERSUS SQRT(I)
              CASE ('SIRI')
                NOPT = 6
                GO TO 10
C * AV(I/SIG) VERSUS THETA
              CASE ('ISST')
                NOPT = 7
                GO TO 10
              CASE ('STAN')
                GO TO 10
C * SET MAXIMUM VERTICAL I/SIGMA Y-COORDINATE
              CASE ('SET')
                IF (IFL(2)(1:3) == 'PAR') THEN
                  IF (IPR(221) > 0) PAR(485) = FN(1)
                END IF
                GO TO 10
C * VARIANCE ANALYSIS RESULTS
              CASE ('VARI')
                NOPT = -1
C * LIST CONTENT FIRST Fc/Fmax BIN
                IF (IPR(778) > 0) THEN
                  REWIND (LU60)
                  DO
                    READ (LU60, 99999, IOSTAT = IOST) ICL
                    IF (IOST /= 0) EXIT
                    WRITE (LU6, 99999) ICL(1:80)
                  END DO
                END IF
                GO TO 10
            END SELECT
          END DO
        END IF
      END IF
      CLOSE (LU60, STATUS = 'DELETE', IOSTAT = IOST)
      RETURN
99999 FORMAT (A)
99998 FORMAT (/, 'ST/L    d     #  Nobs    R1   wR2     S',
     1        ' 0  Percent Distr. for I .gt. 2*s(I)  100', /, 80('='))
99997 FORMAT (/, ':: R1 =', F6.3, ', wR2 =', F6.3, ', S =', F6.3,
     1        ', Nref =', I7, ', Nobs =', I7, ', Npar =', I5)
99996 FORMAT ('SigW Includes the SHELXL WGHT Par.', 2F9.4)
99995 FORMAT (//)
99994 FORMAT (F4.2, F5.2, 2I6, 3F6.3, 1X, A)
99993 FORMAT (/, ':: Hmax =', I5, ', Kmax =', I5, ', Lmax =', I5)
99992 FORMAT (39X, 'I', 19X, 'I', 19X, 'I', /,
     1        19X, 'Percent Observed:   0',18X, '50', 17X, '100')
99991 FORMAT ('::',13X, 'wR2 =', F6.3, ', S =', F6.3,
     1        ' (Non Optimized Weights)')
99990 FORMAT (/, ':: R1 =', F6.3, ', wR2 =', F6.3, ', S =', F6.2,
     1        ', Nref =', I7, ', Nobs =', I7, ', Npar =', I5)
99989 FORMAT ('::',13X, 'wR2 =', F6.3, ', S =', F6.2,
     1        ' (Non Optimized Weights)')
99988 FORMAT (3I4, 6F10.2)
99987 FORMAT (/, '   H   K   L    I(obs)    I(calc)    Sig(I)',
     1           '    SumObs   SumCalc   SinTh/L')
      END SUBROUTINE PLA412
 
      SUBROUTINE PLA413 (LU)
C * ANALYSIS OF VARIANCE LISTINGS
      USE files
      USE parameters
      USE xwdw
      USE analysis
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: LU
      INTEGER           :: HM
      INTEGER           :: KM
      INTEGER           :: LM
      INTEGER           :: IYELLOW
      CHARACTER(len=80) :: LINE
C * HANDLE POOR VISIBILITY OF YELLOW ON WHITE BACKGROUND
      IF (IGBL(68) == 1 .OR. IGBL(66) == 0) THEN
        IYELLOW = 6
      ELSE
        IYELLOW = 5
      END IF
      IF (LU == 0) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        LINE =
     1    'Analysis of Variance for data: '//FNLU16(1:KNM16)
        CALL PLA439 (0.0, LINE, 31 + KNM16, 0.45, IYELLOW,
     1    2, 2.5, VERT - 0.9)
        VRT = VERT - 1.0
      END IF
C * TEST FOR AND LIST SHELXL WEIGHT PARAMETERS
      IF (PAR(493) >= 0.0) THEN
        WRITE (LINE, 99999, IOSTAT = IOST)
C * DUMMY
        IF (IOST == -999) RETURN
        CALL PLA296 (LU, LINE)
        WRITE (LINE, 99998, IOSTAT = IOST) PAR(493), PAR(494)
        CALL PLA296 (LU, LINE)
      END IF
C * Goof & K as function of Fc/Fc(max)
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99991, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99997, IOSTAT = IOST) (VSTATA(I, 1), I = 1, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99996, IOSTAT = IOST)
     1  (NINT (VSTATA(I, 2)), I = 2, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99995, IOSTAT = IOST) (VSTATA(I, 3), I = 2, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99994, IOSTAT = IOST)
     1  MAX (-99.999, MIN (VSTATA(2, 4), 99.999)),
     2  (MAX (-9.999, MIN (9.999, VSTATA(I, 4))), I = 3, 11)
C * Goof & K as function of the resolution
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99993, IOSTAT = IOST) (VSTATB(I, 1), I = 1, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99996, IOSTAT = IOST)
     1  (NINT (VSTATB(I, 2)), I = 2, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99995, IOSTAT = IOST) (VSTATB(I, 3), I = 2, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99994, IOSTAT = IOST)
     1  MAX (-99.999, MIN (VSTATB(2, 4), 99.999)),
     2  (MAX (-9.999, MIN (9.999, VSTATB(I, 4))), I = 3, 11)
      CALL PLA296 (LU, LINE)
C * Goof & K as function of the resolution for FC/Fc(max) < 0.016
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99992, IOSTAT = IOST) VSTATA(3, 1)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99993, IOSTAT = IOST) (VSTATC(I, 1), I = 1, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99996, IOSTAT = IOST)
     1  (NINT (VSTATC(I, 2)), I = 2, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99995, IOSTAT = IOST) (VSTATC(I, 3), I = 2, 11)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99994, IOSTAT = IOST)
     1  MAX (-99.999, MIN (VSTATC(2, 4), 99.999)),
     2  (MAX (-9.999, MIN (9.999, VSTATC(I, 4))), I = 3, 11)
      CALL PLA296 (LU, LINE)
C * PerObs Fo2 & PerObs Fc2 as a function of H
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      HM = MIN (HMAX + 1, 14)
      WRITE (LINE, 99990, IOSTAT = IOST) 'H',   (I - 1, I = 1, HM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99989, IOSTAT = IOST) (NSTATH(I, 1), I = 1, HM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99988, IOSTAT = IOST) (NSTATH(I, 2), I = 1, HM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99987, IOSTAT = IOST) (NSTATH(I, 3), I = 1, HM)
      CALL PLA296 (LU, LINE)
C * PerObs Fo2 & PerObs Fc2 as a function of K
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      KM = MIN(KMAX + 1, 14)
      WRITE (LINE, 99990, IOSTAT = IOST) 'K',   (I - 1, I = 1, KM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99989, IOSTAT = IOST) (NSTATK(I, 1), I = 1, KM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99988, IOSTAT = IOST) (NSTATK(I, 2), I = 1, KM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99987, IOSTAT = IOST) (NSTATK(I, 3), I = 1, KM)
      CALL PLA296 (LU, LINE)
C * PerObs Fo2 & PerObs Fc2 as a function of L
      WRITE (LINE, 99999, IOSTAT = IOST)
      CALL PLA296 (LU, LINE)
      LM = MIN (LMAX + 1, 14)
      WRITE (LINE, 99990, IOSTAT = IOST) 'L',   (I - 1, I = 1, LM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99989, IOSTAT = IOST) (NSTATL(I, 1), I = 1, LM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99988, IOSTAT = IOST) (NSTATL(I, 2), I = 1, LM)
      CALL PLA296 (LU, LINE)
      WRITE (LINE, 99987, IOSTAT = IOST) (NSTATL(I, 3), I = 1, LM)
      CALL PLA296 (LU, LINE)
      IF (LU == 0) THEN
        CALL GGIP (0.0, 0.0, 0.0, -1)
      END IF
      RETURN
99999 FORMAT (1X)
99998 FORMAT (':: SigW(I) Includes the SHELXL WGHT a & b Parameter',
     1        ' Values', 2F9.4)
99997 FORMAT ('Fc/Fc(max)', 4X, 11F6.3)
99996 FORMAT ('Number in Group ', 10I6)
99995 FORMAT ('           GooF ', 10F6.3)
99994 FORMAT ('              K', F7.3, 9F6.3)
99993 FORMAT ('Resolution(A)', 1X, 11F6.2)
99992 FORMAT ('Resolution Dependence for Fc/Fc(max) .LT.', F7.3)
99991 FORMAT (':: K = Mean[Fo^2]/Mean[Fc^2] for Group - ',
     1        '(Fo^2, Fc^2 from FCF)')
99990 FORMAT ('Abs(', A, ')', 4X, 14I5)
99989 FORMAT ('Number    ', 14I5)
99988 FORMAT ('PerObs Fo2', 14I5)
99987 FORMAT ('PerObs Fc2', 14I5)
      END SUBROUTINE PLA413
 
      MODULE p414
      SAVE
      INTEGER :: HMAX0
      INTEGER :: KMAX0
      INTEGER :: LMAX0
      REAL    :: DELS
      END MODULE p414
 
 
      SUBROUTINE PLA414 (MODE)
C * TWINROTMAT - ANALYSE REFLECTION DATA FOR TWINNING BY REFLECTION OVERLAP
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE spgrdata
      USE reflex
      USE lepage
      USE analysis
      USE p414
      USE sgxyz
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: N1
      INTEGER                  :: N2
      INTEGER                  :: II
      INTEGER                  :: IH
      INTEGER                  :: IK
      INTEGER                  :: IL
      INTEGER                  :: JH
      INTEGER                  :: JK
      INTEGER                  :: JL
      INTEGER                  :: IS
      INTEGER                  :: LL
      INTEGER                  :: NS
      INTEGER                  :: NX
      INTEGER                  :: IHI
      INTEGER                  :: IHJ
      INTEGER                  :: IKI
      INTEGER                  :: IKJ
      INTEGER                  :: ILI
      INTEGER                  :: ILJ
      INTEGER                  :: ILP
      INTEGER                  :: ISN
      INTEGER                  :: LIV
      INTEGER                  :: NVC
      INTEGER                  :: MPK
      INTEGER                  :: MPL
      INTEGER                  :: NVCM
      INTEGER                  :: NMIN
      INTEGER                  :: NEQL
      INTEGER                  :: MHKL
      INTEGER                  :: LINV
      INTEGER                  :: MODE
      INTEGER                  :: IBLP
      INTEGER                  :: IBRV
      INTEGER                  :: MSEL
      INTEGER                  :: LOOP
      INTEGER                  :: NSYMR
      INTEGER                  :: IADR1
      INTEGER                  :: IHKLP
      INTEGER                  :: IIMAX
      INTEGER                  :: ISHOW
      INTEGER                  :: IYUNK
      INTEGER                  :: KSMAL
      INTEGER                  :: MHKLH
      INTEGER                  :: NEXIT
      INTEGER                  :: IHKLSUM
      INTEGER, DIMENSION(3)    :: IA
      INTEGER, DIMENSION(NP75) :: IB
      INTEGER, DIMENSION(NP75) :: IC
      INTEGER, DIMENSION(3)    :: IHKL
      REAL                     :: SCA
      REAL                     :: OME
      REAL                     :: PHI
      REAL                     :: DTH
      REAL                     :: CHI
      REAL                     :: DET
      REAL                     :: THI
      REAL                     :: THJ
      REAL                     :: SUMT
      REAL                     :: XHKL
      REAL                     :: XLNG
      REAL                     :: FCKI
      REAL                     :: FCKJ
      REAL                     :: FOKI
      REAL                     :: FOKJ
      REAL                     :: COSA
      REAL                     :: DELI
      REAL                     :: DELJ
      REAL                     :: ALFA
      REAL                     :: SIGI
      REAL                     :: SIGJ
      REAL                     :: SPRD
      REAL                     :: RDROP
      REAL                     :: RATIO
      REAL                     :: DELSJ
      REAL                     :: DELSIG
      REAL                     :: GEN009
      REAL,    DIMENSION(3)    :: V
      REAL,    DIMENSION(9)    :: TMT
      REAL,    DIMENSION(3)    :: TAU
      REAL,    DIMENSION(3, 3) :: ORT
      REAL,    DIMENSION(3, 3) :: YUNK
      REAL,    DIMENSION(3)    :: VTAU
      CHARACTER(len=3)         :: FCFMODE
C * MODE = 1 - GRAPHICS MODE
C * MODE = 2 - NON-GRAPHICS MODE
C * IPR(608) = 0 - FCF FCALC DATA SOURCE
C * IPR(608) = 1 - CIF FCALC DATA SOURCE
C * REFLECTION DATA ARE STORED BOTTOM-UP IN SCRATCH ARRAY VOID WITH TOTAL SIZE:
      NADR  = NREF * NREC
C * POINTERS TO REFLECTION DATA ARE STORED TOP-DOWN IN ScRATCH ARRAY VOID
C * INDEX TO REFLECTION RECORD (SIZE NREC)
C * VOID(N +  1) = H
C * VOID(N +  2) = K
C * VOID(N +  3) = L
C * VOID(N +  4) = FOK
C * VOID(N +  5) = FCK (FROM CIF PARAMETERS)
C * VOID(N +  6) = SIG
C * VOID(N +  7) = THETA
C * VOID(N +  8) = (FOK - FCK) / SIG
C * VOID(N +  9) =
C * VOID(N + 10) = FCKT (OVERLAPPING INTENSITY)
C * VOID(N + 11) = FCK (FROM FCF DATA)
C * VOID(N + 12) = SIGIW
      NX    = NP23 / 2
      NEXIT = 0
C * ZERO SGX ARRAY
      CALL GEN074 (SGX, 1, 13, 0.0)
C * GET ORTHOGONALISATION MATRIX FROM INPUT-CELL (ORT)
      CALL GEN044 (PAR(101), OR, 1)
C * GET TRANSPOSE
      CALL GEN005 (OR, ORT)
C * GET DE-ORTHOGONALISATION MATRIX (ROTQ)
      CALL GEN003 (ORT, ROTQ, DET, 0)
C * CHECK FOR -T OPTION (RL-PLOT)
   10 IF (IGBL(3) == 30) IPR(608) = 0
C * TOGGLE FOr FC FROM FCF (= 0) OR CIF (=1)
      ICALT    = 11 - IPR(608) * 6
C * INIT NUMBER OF SELECTED TWIN REFLECTION PAIR CANDIDATES
      NSEL     = 0
C * INIT NUMBER / OF POTENTIAL TWINLAWS
      IPR(771) = 0
C * NUMBER OF NON-BRAVAIS SYMMETRY OPERATIONS
      NSYMR = NSYMH * ICNTR
C * NUMBER OF BRAVAIS SYMMETRY OPERATIONS
      IBRV  = IPR(241)
C * CHECK FOR R-LATTICE (OBVERSE/REVERSE)
      IF (IBRV == 7) THEN
        IBLP = 2
      ELSE
        IBLP = 1
      END IF
C * CHECK IPR(259) FOR MONOCLINIC CLASS OR OTHERWISE
      IF (IPR(259) == 2) THEN
C * SET B AXIS UNIQUE
        IPR(394) = 2
      ELSE
C * SET C-AXIS UNIQUE
        IPR(394) = 3
      END IF
C * (A)CENTRO LOOP MAX (1 OR 2 TIMES)
      LINV = 3 - ICNTR
      CALL GEN097 (IB, 1, NP75, 0)
      CALL GEN097 (IC, 1, NP75, 0)
      MSEL = 0
      JH   = 0
      JK   = 0
      JL   = 0
C * CREATE H,K,L to REFLECTION DATA POINTER ARRAY (TOP-DOWN)
C * DETERMINE PACKING CONSTANTS AND ADDRESSES OF REFLECTION DATA HKL
      HMAX0 = MAX (HMAX, IPR(561))
      KMAX0 = MAX (KMAX, IPR(562))
      LMAX0 = MAX (LMAX, IPR(563))
      MPH   = 2 * HMAX0 + 1
      MPK   = 2 * KMAX0 + 1
      MPL   = 2 * LMAX0 + 1
      MHK   = MPH * MPK
      MHKL  = MPL * MHK
      MHKLH = (MHKL - 1) / 2
C * CALCULATE ADDRESS OF 0,0,0 REFLECTION
      IADR  = NVDR - MHKLH
      IADR1 = NVDR - MHKL
C * CHECK FOR OVERFLOW VOID SCRATCH
      IF (IADR1 < NADR) THEN
        WRITE (6, 99989)
        RETURN
      END IF
C * SET DEFAULTS IN HKL-ADDRESS ARRAY
      DO I = 1, MHKL
        IH = I - 1
        IL = IH / MHK
        IH = IH - IL * MHK
        IL = IL - LMAX0
        IK = IH / MPH
        IH = IH - IK * MPH - HMAX0
        IK = IK - KMAX0
C * MARK BRAVAIS AND SPACE GROUP ABSENCES (-2 OR -1), ALL OTHERS AS (0)
        SGX(1)  = IH
        SGX(2)  = IK
        SGX(3)  = IL
        SGX(12) = 0.0
        CALL SGSM (27, LINE, SGX, 0, 0, IERR)
        VOID(IADR1 + I) = - SGX(12)
      END DO
C * LOAD POINTERS TO STORED REFLECTION DATA IN HKL-ADDRESS ARRAY
C * THE REFLECTION SET IS EXPANDED FOLLOWING THE SPACE GROUP SYMMETRY
C * FOR NON-CENTRO STRUCTURES, MISSING SITES IN THE EWALD SPHERE ARE
C * FILLED UP IN A SECOND CYCLE WITH POINTERS TO INVERSION RELATED DATA.
      DO K = 1, LINV
        N = - NREC
        DO I = 1, NREF
          N = N + NREC
          DO J = 1, 3
            SGX(J) = VOID(N + J)
          END DO
C * LOOP OVER SYMMETRY RELATED REFLECTIONS (EXCLUDING BRAVAIS)
          DO NS = 1, NSYMR
            CALL SGSM (5, LINE, SGX, NS, LU7, IERR)
            IHKLP = NINT (SGX(9)) * MHK + NINT (SGX(8)) * MPH
     1            + NINT (SGX(7))
            IF (K == 1) THEN
              IF (VOID(IADR + IHKLP) == 0.0) VOID(IADR + IHKLP) = I
C * TAKE CARE OF NON-CENTRO CASE (TO COMPLETE MISSING DATA)
            ELSE
              IF (VOID(IADR - IHKLP) == 0.0) VOID(IADR - IHKLP) = I
            END IF
          END DO
        END DO
      END DO
C * FIND TWIN LAW LOOPS
   20 ISHOW = 0
C * SELECT SUFFICIENT TWIN-OVERLAPPED-CANDIDATES
C * NOTE: FRIEDEL REDUNDANCY NOT HANDLED
      DO LOOP = 1, IPR(774)
        IF (LOOP == 2) THEN
C * CHECK FOR SKIPPING ROW LOOP
          IF (MSEL == 0) THEN
            ISHOW = 1
            EXIT
          ELSE
C * New Attempt after Deleting Overlap Candidate
            WRITE (LU6, 99990) JH, JK, JL
          END IF
        END IF
C * INITIAL LOWER TARGET SETTING
        RATIO = 32.0
        DO
          NSEL = 0
          DO I = 1, NREF
            N    = (I - 1) * NREC
            THI  = VOID(N + 7)
            SIGI = VOID(N + 6)
C * TEST
            IF (LOOP == 2) THEN
              IH = NINT (VOID(N + 1))
              IK = NINT (VOID(N + 2))
              IL = NINT (VOID(N + 3))
              IF (JH * IH + JK * IK + JL * IL == 0) CYCLE
            END IF
C * TEST THETA > 0.0 AND SIGI > 0.0
            IF (THI > 0.0 .AND. SIGI > 0.0) THEN
              FOKI   = VOID(N + 4)
              FCKI   = VOID(N + ICALT)
              DELSIG = MIN ((FOKI - FCKI) / SIGI, 100000.0)
C * TEST THE RATIO: (FOK - FCK) / SIG
              IF (DELSIG > RATIO) THEN
                 DO J = 1, NREF
                  IF (J /= I) THEN
                    M = (J - 1) * NREC
                    IF (ABS (THI - VOID(M + 7)) < PAR(414)) THEN
                      IF (VOID(M + ICALT) > FCKI) THEN
                        IF (NSEL < NSMAX) THEN
                          NSEL        = NSEL + 1
C * PACK FOR SORTING
                          SDAT(NSEL)  = 100000.0 - DELSIG
                          ISDAT(NSEL) = I
                          EXIT
                        END IF
                      END IF
                    END IF
                  END IF
                END DO
              END IF
            END IF
          END DO
C * DECREASE CRITERIUM WHEN TARGET REFLECTION NUMBER IS NOT REACHED
          IF (NSEL >= IPR(550) .OR. RATIO < PAR(413)) EXIT
          RATIO = RATIO / 2.0
        END DO
C * SORT ON DELTA/SIGMA
        IF (NSEL >= 25) THEN
          CALL GEN036 (SDAT, ISDAT, 1, NSEL)
          NSEL = MIN (NSEL, IPR(550))
          IF (LOOP == 1) THEN
            MSEL = 0
            DO K = 1, NSEL
              I   = (ISDAT(K) - 1) * NREC
              IHI = NINT (VOID(I + 1))
              IKI = NINT (VOID(I + 2))
              ILI = NINT (VOID(I + 3))
              DO L = 1, NSEL
                IF (L >  K) THEN
                  I       = (ISDAT(L) - 1) * NREC
                  IHJ     = NINT (VOID(I + 1))
                  IKJ     = NINT (VOID(I + 2))
                  ILJ     = NINT (VOID(I + 3))
                  IHKL(1) = IKI * ILJ - ILI * IKJ
                  IHKL(2) = ILI * IHJ - IHI * ILJ
                  IHKL(3) = IHI * IKJ - IKI * IHJ
C * COPY ARRAY
                  CALL GEN133 (IHKL, IA, 3)
                  IF (IABS (IA(1)) < 10 .AND. IABS (IA(2)) < 10 .AND.
     1              IABS (IA(3)) < 10) THEN
                    IF (IA(1) < 0) THEN
                      IA(1) = - IA(1)
                      IA(2) = - IA(2)
                      IA(3) = - IA(3)
                    ELSE IF (IA(1) == 0) THEN
                      IF (IA(2) < 0) THEN
                        IA(2) = - IA(2)
                        IA(3) = - IA(3)
                      ELSE IF (IA(2) == 0) THEN
                        IA(3) = IABS (IA(3))
                      END IF
                    END IF
                    CALL GEN107 (IA, 3, M)
                    IC(MSEL + 1) =
     1                IA(1) * 62500 + (IA(2) + 125) * 250 + IA(3) + 125
                    IF (IC(MSEL + 1) /= 31375) THEN
                      IF (MSEL == 0) THEN
                        MSEL = MSEL + 1
                        IB(MSEL) = 1000
                      ELSE
                        DO J = 1, MSEL
                          IF (IC(MSEL + 1) == IC(J)) THEN
                            IB(J) = IB(J) + 1000
                            GO TO 30
                          END IF
                        END DO
                      ENDIF
                      IF (MSEL < NP75 - 1) THEN
                        MSEL     = MSEL + 1
                        IB(MSEL) = 1000
                      END IF
                    END IF
   30               CONTINUE
                  END IF
                END IF
              END DO
            END DO
C * SORT
            IF (MSEL > 0) THEN
              WRITE (LU6, 99992)
              CALL GEN033 (IB, IC, 1, MSEL)
              DO J = MSEL, 1, -1
                IHI = IC(J) / 62500
                ILI = IC(J) - IHI * 62500
                IKI = ILI / 250
                ILI = ILI - IKI * 250
                IKI = IKI - 125
                ILI = ILI - 125
                IF (J > MSEL - 5) THEN
C * COUNT NUMBER OF NSEL VECTORS PERPENDICULAR TO J
                  N = 0
                  DO K = 1, NSEL
                    I   = (ISDAT(K) - 1) * NREC
                    IHJ = NINT (VOID(I + 1))
                    IKJ = NINT (VOID(I + 2))
                    ILJ = NINT (VOID(I + 3))
                    IF (IHI * IHJ + IKI * IKJ + ILI * ILJ == 0)
     1                N = N + 1
                  END DO
                  IB(J) = IB(J) + N
                  WRITE (LU6, 99991) IHI, IKI, ILI, IB(J) / 1000, N
                END IF
                IF (J == MSEL) THEN
                  JH = IHI
                  JK = IKI
                  JL = ILI
                END IF
              END DO
            END IF
          END IF
C * TEST FOR/START GRAPHICS MODE WINDOW
          IF (MODE == 1) THEN
C * REPORT I(CALC) SOURCE
            IF (IPR(608) == 0) THEN
              FCFMODE = 'FCF'
            ELSE
              FCFMODE = 'CIF'
            END IF
            WRITE (LU6, 99998, IOSTAT = IOST) FCFMODE
            CALL PLA262 (0)
            IF (IPR(469) /= 0) THEN
              WRITE (LU7, 99994, IOSTAT = IOST)
              CALL PLA262 (2)
            END IF
            WRITE (LU7, 99999, IOSTAT = IOST)
            CALL PLA262 (3)
          END IF
          NVC = 0
C * LOOP OVER OVERLAPPED REFLECTION CANDIDATES
          DO K = 1, NSEL
            I    = (ISDAT(K) - 1) * NREC
            THI  = VOID(I + 7)
            IHI  = NINT (VOID(I + 1))
            IKI  = NINT (VOID(I + 2))
            ILI  = NINT (VOID(I + 3))
            FOKI = VOID(I + 4)
            FCKI = VOID(I + ICALT)
            SIGI = VOID(I + 6)
            DELI = FOKI - FCKI
            DELS = DELI / SIGI
C * TEST FOR GRAPHICS MODE AND LIST SELECTED REFLECTIONS
            IF (MODE == 1) THEN
              IF (FCKI /= 0.0) THEN
                SCA = MIN (FOKI / FCKI, 999999.0)
              ELSE
                SCA = 1.0
              END IF
              WRITE (LU6, 99993, IOSTAT = IOST) K, IHI, IKI, ILI, FOKI,
     1          FCKI, SIGI, DELS, THI, SCA
              IF (IPR(469) /= 0) THEN
                CALL PLA262 (3)
                WRITE (LU7, 99997, IOSTAT = IOST)
              ELSE
                CALL PLA262 (1)
              END IF
              WRITE (LU7, 99993, IOSTAT = IOST) K, IHI, IKI, ILI, FOKI,
     1          FCKI, SIGI, DELS, THI, SCA
              IF (IPR(469) /= 0) WRITE (LU7, 99995, IOSTAT = IOST)
            END IF
C * LOOK/SELECT ELIGABLE CANDIDATES FOR OVERLAP WITHIN THETA TOLERANCE
            J = - NREC
            DO L = 1, NREF
              J = J + NREC
              IHJ = NINT (VOID(J + 1))
              IKJ = NINT (VOID(J + 2))
              ILJ = NINT (VOID(J + 3))
              IF (IABS (IHI - IHJ) + IABS (IKI - IKJ)
     1          + IABS (ILI - ILJ) /= 0) THEN
                THJ = VOID(J + 7)
                IF (THJ > 0.0) THEN
                  DTH = ABS (THI - THJ)
                  IF (DTH < PAR(414)) THEN
                    SGX(1) = IHJ
                    SGX(2) = IKJ
                    SGX(3) = ILJ
                    SGX(4) = 0.0
                    FOKJ  = VOID(J + 4)
                    FCKJ  = VOID(J + ICALT)
                    SIGJ  = VOID(J + 6)
                    IF (SIGJ > 0.0) THEN
                      DELSJ = (FOKJ - FCKJ) / SIGJ
C * LOOP OVER SYMMETRY RELATED REFLECTIONS
                      DO NS = 1, NSYMR
                        CALL SGSM (5, LINE, SGX, NS, LU7, IERR)
                        DO ILP = 1, IBLP
                          IF (ILP == 1) THEN
                            IHJ = NINT (SGX(7))
                            IKJ = NINT (SGX(8))
                            ILJ = NINT (SGX(9))
                          ELSE
C * OBVERSE <> REVERSE
                            IHJ = - NINT (SGX(8))
                            IKJ =   NINT (SGX(7)) + NINT (SGX(8))
                            ILJ =   NINT (SGX(9))
                            IF (MOD (-IHJ + IKJ + ILJ, 3) == 0) CYCLE
                          END IF
C * SPECIAL LOOP FOR NON-CENTRO SPACEGROUPS
                          DO LIV = 1, LINV
                            IF (LIV == 2) THEN
                              IHJ = - IHJ
                              IKJ = - IKJ
                              ILJ = - ILJ
                            END IF
C * POTENTIAL ROTATION AXIS
                            IHKL(1) = IHI + IHJ
                            IHKL(2) = IKI + IKJ
                            IHKL(3) = ILI + ILJ
                            IF (IHKL(1) < 0) THEN
                              IHKL(1) = - IHKL(1)
                              IHKL(2) = - IHKL(2)
                              IHKL(3) = - IHKL(3)
                            ELSE IF (IHKL(1) == 0) THEN
                              IF (IHKL(2) < 0) THEN
                                IHKL(2) = - IHKL(2)
                                IHKL(3) = - IHKL(3)
                              ELSE IF (IHKL(2) == 0) THEN
                                IHKL(3) = IABS (IHKL(3))
                              END IF
                            END IF
C * REDUCE VECTOR
                            CALL GEN107 (IHKL, 3, IYUNK)
                            IHKLP = IHKL(1)
     1                            + 200 * (IHKL(2) + 200 * IHKL(3))
                            IF (IHKLP /= 0) THEN
C * ELIMINATE IN VERSION REDUNDANCY
                              IF (NVC > 0) THEN
C * CHECK FOR PRIOR OCCURRENCE OF THIS ROTATION
                                DO N = 1, NVC
                                  ISN = 1
C * TAKE CARE OF NON-CENTRO CASE
                                  DO M = 1, LINV
                                    IF (IHKLP == ISN * JNSC(2, NX + N))
     1                                GO TO 40
                                    ISN = -1
                                  END DO
                                END DO
                              END IF
                              IF (NVC < NX - 1) THEN
                                NVC               = NVC + 1
                                N                 = NVC
C * INIT SUPPORT FREQ COUNT ROTATION AXIS
                                JNSC(1, NVC)      = 10000
                                JNSC(2, NVC)      = NVC
                                JNSC(1, NX + NVC) = 0
                                JNSC(2, NX + NVC) = IHKLP
                              END IF
C * COUNT SUPPORT FOR THIS TWIN LAW
   40                         JNSC(1, N) = JNSC(1, N) - 1
C * CONSIDER REFLECTIONS WITH LARGER F(calc) ONLY
                              DELJ = FCKJ - FCKI
                              IF (DELJ /= 0.0) THEN
                                ALFA = MIN (DELI / DELJ, 1.0)
                              ELSE
                                ALFA = 1.0
                              END IF
                              IF (ALFA >= PAR(416)) THEN
                                IF (IPR(469) /= 0) THEN
                                  CALL PLA262 (1)
                                  WRITE (LU7, 99996, IOSTAT = IOST)
     1                              IHJ, IKJ, ILJ, FOKJ, FCKJ, SIGJ,
     2                              DELSJ, THJ, DTH, ALFA, IHKL(1),
     3                              IHKL(2), IHKL(3)
                                END IF
C * COUNT SUPPORT FREQ FOR ROTATION AXIS
                                JNSC(1, NX + N) = JNSC(1, NX + N)
     1                                          + NINT (ALFA * 100.0)
                              END IF
                            END IF
                          END DO
                        END DO
                      END DO
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END DO
C * ANALYSE RESULT OF ACCUMULATION
          IPR(771) = 0
          IF (NVC > 0) THEN
            IPR(543) = 0
C * SORT ROTATION AXES ON SUPPORT FREQUENCY
            CALL GEN037 (JNSC, 1, NVC)
            NMIN  = NSEL / 4
            NTWIN = 0
            CALL GEN097 (NTW, 1, MXTWN, 0)
            NVCM = MIN (IPR(607), NVC)
            DO I = 1, NVCM
              NFRQ(MXTWN) = 10000 - JNSC(1, I)
              IF (NFRQ(MXTWN) > NMIN) THEN
C * GET ORTHOGONAL COORDINATES (TAU) FOR () ROTATION AXIS IN H
                XHKL = JNSC(2, JNSC(2, I) + NX)
                CALL GEN046 (XHKL, H(1), H(2), H(3))
                IHKLSUM = 0
                DO J = 1, 3
                  IHKLR(J, MXTWN) = NINT (H(J))
                  IHKLSUM     = IHKLSUM + NINT (H(J))
                END DO
                CALL GEN002 (2, ROTQ, H, TAU, XLNG)
C * GET SUPPORT COUNT
                COSA = 0.0
C * GET MaxInd
                N1 = IPR(567)
                N2 = 2 * N1 + 1
                DO K = 1, N2
                  V(1) = K - N1 - 1
                  DO L = 1, N2
                    V(2) = L - N1 - 1
                    DO M = 1, N2
                      V(3) = M - N1 - 1
C * GET ORTHOGONAL COORDINATES (T)   FOR [] ROTATION AXIS IN V
                      IF (ABS (V(1)) + ABS (V(2)) + ABS (V(3)) > 0.5)
     1                  THEN
                        CALL GEN002 (2, OR, V, T, XLNG)
                        IF (XLNG /= 0) THEN
                          SPRD = GEN009 (T, TAU)
                          IF (SPRD > COSA) THEN
                            COSA = SPRD
                            DO J = 1, 3
                              IHKL(J) = NINT (V(J))
                              VTAU(J) = T(J)
                            END DO
                          END IF
                        END IF
                      END IF
                    END DO
                  END DO
                END DO
                ALPHA(5) = ACOS (MIN (1.0, COSA)) * RGBL(6)
C * REDUCE VECTOR
                CALL GEN107 (IHKL, 3, IYUNK)
                DO K = 1, 3
                  IHKLD(K, MXTWN) = IHKL(K)
                END DO
C * (NON)MEROHEDRAL TEST
                IF (ALPHA(MXTWN) > PAR(473)) THEN
                  IIMAX = 2
                ELSE
                  IIMAX = 1
                END IF
                DO 60 II = 1, IIMAX
                  IF (II == 2) CALL GEN113 (VTAU, TAU, 3)
C * FIND CORRESPONDING ROTATION MATRIX
                  IF (ABS(TAU(1)) + ABS(TAU(2)) < 0.0001) THEN
                    OME = 0.0
                    CHI = 90.0 / RGBL(6)
                  ELSE
                    OME = ATAN2 (TAU(2), TAU(1))
                    CHI = ATAN2 (TAU(3), SQRT (TAU(1)**2 + TAU(2)**2))
                  END IF
C * GET ROTATION MATRIX FOR OMEGA
                  CALL GEN043 (3, TP, OME)
C * GET ROTATION MATRIX FOR CHI
                  CALL GEN043 (2, TG, - CHI)
C * MULTIPLY
                  CALL GEN004 (TG, TP, TM)
                  PHI = 180.0 / RGBL(6)
                  CALL GEN043 (1, G, PHI)
C * MULTIPLY
                  CALL GEN004 (G, TM, TPS)
C * TRANSPOSE
                  CALL GEN005 (TM, YUNK)
C * COPY MATRIX
                  CALL GEN052 (YUNK, TM)
C * MULTIPLY
                  CALL GEN004 (TM, TPS, TPQ)
C * HANDLE ORTHOGONALISATION TRANSFORM
                  CALL GEN004 (TPQ, ROTQ, TPS)
C * MULTIPLY
                  CALL GEN004 (ORT, TPS, TWM(1, 1, MXTWN))
C * ELIMINATE SPACE GROUP SYMMETRY
                  IF (NSYMH > 1) THEN
                    N = 0
                    DO J = 1, 3
                      DO K = 1, 3
                        TM(J, K) = TWM(J, K, MXTWN)
                        N       = N + 1
                        TMT(N)  = TM(J, K)
                      END DO
                    END DO
                    DO J = 1, NSYMR
                      NS = J
                      CALL SGSM (6, LINE, SGX, NS, LU6, IERR)
                      IS = 1
                      DO N = 1, LINV
                        IF (N == 2) IS = -1
                        SUMT = 0.0
                        DO M = 1, 9
                          SUMT = SUMT + ABS(TMT(M) - IS * SGX(M))
                        END DO
                        IF (SUMT < 0.1) GO TO 60
                      END DO
                    END DO
C * ELIMINATE REDUNDANCY
                    DO J = 2, NSYMR
                      NS = J
C * GET TRANSPOSE OF SYMMETRY OPERATION
                      CALL SGSM (6, LINE, SGX, NS, LU6, IERR)
                      DO K = 1, 9
                        N = INT ((K - 1) / 3) + 1
                        M = MOD (K  - 1 ,  3) + 1
                        TPS(M, N) = SGX(K)
                      END DO
C * MULTIPLY
                      CALL GEN004 (TPS, TM, TPQ)
                      IS = 1
                      DO LL = 1, LINV
                        IF (LL == 2) IS = -1
                        DO 50 K = 1, IPR(771) + 1
                          DO N = 1, 3
                            DO M = 1, 3
                              IF (K <= IPR(771)) THEN
                                IF (ABS (TWM(N, M, K) - IS * TPQ(N, M))
     1                            > 0.05) GO TO 50
                              ELSE
                                IF (ABS (TWM(N, M, K) - IS * TPS(N, M))
     1                            > 0.05) GO TO 50
                              END IF
                            END DO
                          END DO
                          GO TO 60
   50                   CONTINUE
                      END DO
                    END DO
                  END IF
                  IF (MODE == 1) THEN
                    CALL PLA262 (1)
                    WRITE (LU7, 99997, IOSTAT = IOST)
                  END IF
C * ANALYSE EFFECT ON R (FUNCTION OF BASF)
                  CALL PLA415
C * CONSIDER THIS LAW AS SIGNIFICANT
                  IF (DRVAL(MXTWN) < -0.003) THEN
C * TEST FOR IDENTICAL RECIP AND DIRECT AXES
                    NEQL = 0
                    IF (IPR(771) > 0) THEN
                      DO N = 1, IPR(771)
                        NEQL = 0
                        DO M = 1, 3
                          IF (IHKLR(M, N) == IHKLR(M, MXTWN))
     1                      NEQL = NEQL + 1
                          IF (IHKLD(M, N) == IHKLD(M, MXTWN))
     1                      NEQL = NEQL + 1
                        END DO
                        IF (NEQL == 6) THEN
                          IF (DRVAL(MXTWN) < DRVAL(N)) THEN
                            KSMAL = N
                            RDROP = DRVAL(N)
                            EXIT
                          ELSE
                            GO TO 60
                          END IF
                        END IF
                      END DO
                    END IF
                    IF (NEQL < 6) THEN
                      IF (IPR(771) < 4) THEN
                        IPR(771) = IPR(771) + 1
                        KSMAL    = IPR(771)
                        RDROP    = 999.0
                      ELSE
C * REPLACE THE SMALLEST R-DROP ENTRY
                        RDROP = -999.0
                        KSMAL = 0
                        DO K = 1, 4
                          IF (DRVAL(K) > RDROP) THEN
                            RDROP = DRVAL(K)
                            KSMAL = K
                          END IF
                        END DO
                      END IF
                    END IF
                    IF (DRVAL(MXTWN) <= RDROP) THEN
                      IF (II == 1) THEN
                        NFRQ(KSMAL)  = NFRQ(MXTWN)
                      ELSE
                        NFRQ(KSMAL)  = - NFRQ(MXTWN)
                      END IF
                      NTW(KSMAL)           = NTW(MXTWN)
                      DRVAL(KSMAL)         = DRVAL(MXTWN)
                      BASFM(KSMAL)         = BASFM(MXTWN)
                      ALPHA(KSMAL)         = ALPHA(MXTWN)
                      MTWIN(KSMAL * 2 - 1) = MTWIN(2 * MXTWN - 1)
                      MTWIN(KSMAL * 2)     = KSMAL
                      DO K = 1, 3
                        IHKLR(K, KSMAL) = IHKLR(K, MXTWN)
                        IHKLD(K, KSMAL) = IHKLD(K, MXTWN)
                        DO L = 1, 3
                          TWM (K, L, KSMAL) = TWM(K, L, MXTWN)
                        END DO
                      END DO
                    END IF
                  END IF
                  NTW(MXTWN) = 0
   60           CONTINUE
              END IF
            END DO
C * SORT TWIN LAWS
            CALL GEN124 (MTWIN, 1, IPR(771) * 2)
          END IF
C * CHECK FOR NON-ZERO NUMBER OF TWIN LAWS
          IF (IPR(771) == 0 .AND. LOOP < IPR(774)) CYCLE
C * SHOW RESULTS
          ISHOW = 1
        END IF
        IF (NEXIT == 0) EXIT
      END DO
C * (ISHOW = 0) REPORT ABOUT TOO FEW TWIN OVERLAP CANDIDATES FOUND
   70 CALL PLA416 (ISHOW, MODE)
C * TEST FOR SILENT AUTO-TWIN ANALYSIS
      IF (MODE == 1) THEN
C * INSTRUCTION CYCLE
        DO
C * TEST FOR -M OPTION (FILTER MODE)
          IF (IGBL(3) /= 37) THEN
C * WHAT NEXT ?
            CALL PLA012 (0, 1)
            IF (IGGT(1:1) == '!' .OR. IGGT(1:4) == 'PLOT') GO TO 70
            CALL PLA006 (0, IS)
C * FIND TWIN LAWS
            IF (IS == 18) THEN
              GO TO 20
C * CALC HKLF (GENERATE HKLF 5 FILE)
            ELSE IF (IS == 70) THEN
              CALL PLA417
              RETURN
C * ICALC FROM CIF/FCF TOGGLE
            ELSE IF (IS == 177) THEN
              GO TO 10
C * END (RETURN)
            ELSE IF (IS == 19) THEN
              RETURN
C * LIST (IPR/PAR/IGBL/RGBL)
            ELSE IF (IS == 29) THEN
              CALL PLA206 (-1, IFL(2)(1:3))
              CYCLE
C * SET (IPR/PAR/IGBL/RGBL)
            ELSE IF (IS == 46) THEN
              CALL PLA206 (1, IFL(2)(1:3))
              CYCLE
C * EXIT
            ELSE IF (IS == 53) THEN
              RETURN
C * TWIN PLOT
            ELSE IF (IS == 99) THEN
              IF (IWIN == 1) THEN
                CALL PLA418
              END IF
              GO TO 70
            ELSE
              CYCLE
            END IF
          ELSE
C * GENERATE HKLF 5 FILE
            IF (IPR(771) > 0) THEN
              CALL PLA417
            END IF
            RETURN
          END IF
        END DO
      END IF
      RETURN
99999 FORMAT (' Nr    H  K  L         Iobs        Icalc     SigI',
     1        ' Delt/Sig  Theta', ' DTheta  Alpha     Rot Axis', /,
     2        94('='))
99998 FORMAT (/, 7X, 'Sorted List of Twin Overlap Candidates [',
     1 A, '-Mode]', /, 76('='), /,
     1 ' Nr    H  K  L         Iobs        Icalc     SigI',
     2 ' Delt/Sig  Theta Iobs/Icalc', /, 76('='))
99997 FORMAT (1X)
99996 FORMAT (5X, 3I3, 2F13.2, 2F9.2, 3F7.2, '  (', I3, 2I4, ')')
99995 FORMAT (65('='))
99994 FORMAT (/, 'Alpha = (Iobs - Icalc) / (Jcalc - Icalc)', /)
99993 FORMAT (I3, 2X, 3I3, 2F13.2, 2F9.2, F7.2, F11.3)
99992 FORMAT (/, 'Possible Twinning Direct Lattice Rows (Experimental)')
99991 FORMAT ('[', 3I5, '], Frequency = ', I5, ', Perp to', I5)
99990 FORMAT (/, '** No Significant Twinning Matrices Found for ',
     1        'Selected Overlap Set.', /
     2        '** New Attempt after Deleting Overlap Candidates ',
     1        'Perp to [', I4,',',I4,',',I4,']')
99989 FORMAT (/, '** NADR > IADR1, STORAGE OVERFLOW IN VOID SCRATCH', /)
      END SUBROUTINE PLA414
 
      SUBROUTINE PLA415
      USE files
      USE parameters
      USE reflex
      USE lepage
      USE analysis
      USE p414
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: IHT
      INTEGER               :: IKT
      INTEGER               :: ILT
      INTEGER               :: IHKLTP
      INTEGER, DIMENSION(3) :: IHKL
      REAL                  :: ST
      REAL                  :: TH
      REAL                  :: THT
      REAL                  :: ALF
      REAL                  :: FCK
      REAL                  :: FOK
      REAL                  :: SIG
      REAL                  :: STAL
      REAL                  :: RVAL
      REAL                  :: FCKS
      REAL                  :: FOKS
      REAL                  :: FCKT
      REAL                  :: BASF
      REAL                  :: XDUM
      REAL                  :: YUNK
      REAL                  :: TERM1
      REAL                  :: TERM2
      REAL                  :: FCKT0
      REAL                  :: SUMFO
      REAL                  :: GEN095
      REAL, DIMENSION(NP76) :: SUMT
      REAL, DIMENSION(NP76) :: SUMN
      REAL, DIMENSION(NP76) :: SCLA
      REAL, DIMENSION(NP76) :: SUMFC
C * ANALYSE EFFECT ON R AS A FUNCTION OF BASF
      DO K = 1, NREF
        I = (K - 1) * NREC
        DO J = 1, 3
          IHKL(J) = NINT (VOID(I + J))
          H(J)    = IHKL(J)
        END DO
        FOK = VOID(I + 4)
        FCK = VOID(I + ICALT)
        TH  = VOID(I + 7)
        CALL GEN002 (1, TWM(1, 1, MXTWN), H, T, XDUM)
        IHT = NINT (T(1))
        IKT = NINT (T(2))
        ILT = NINT (T(3))
C * DETERMINE F(CALC) OF OVERLAPPING TWIN COMPONENT
        FCKT = 0.0
        IF (ABS (T(1) - IHT) < PAR(415)) THEN
          IF (ABS (T(2) - IKT) < PAR(415)) THEN
            IF (ABS (T(3) - ILT) < PAR(415)) THEN
              IHKLTP = ILT * MHK + IKT * MPH + IHT
              L = IADR + IHKLTP
              IF (L <= NVDR) THEN
                J = NINT (VOID(L))
                IF (J <= 0) THEN
                  N = I + 10
                  VOID(N) = FCKT
                  CYCLE
                ELSE IF (J > 0) THEN
                  FCKT0 = VOID((J - 1) * NREC + ICALT)
                END IF
                ST  = SQRT (GEN095 (PAR(191), IHT, IKT, ILT)) * PAR(17)
                IF (ST < 1.0) THEN
                  THT = ASIN (ST) * RGBL(6)
                ELSE
                  THT = 0.0
                END IF
                IF (ABS (TH - THT) <= PAR(420)) THEN
                  IF (ABS (IHT) <= HMAX0 .AND. ABS (IKT) <= KMAX0 .AND.
     1                ABS (ILT) <= LMAX0) THEN
                    NTW(MXTWN) = NTW(MXTWN) + 1
                    FCKT       = FCKT0
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
        VOID(I + 10) = FCKT
      END DO
C * GET R-VALUE AS A FUNCTION OF BASF (0 to 1)
      SUMFO = 0.0
C * NP76 BASF TEST VALUES
      STAL  = 1.0 / (NP76 - 1)
C * ZERO SUMFC ARRAY
      CALL GEN074 (SUMFC, 1, NP76, 0.0)
C * LOOP OVER ALL REFLECTIONS TO DETERMINE NEW SCALING FACTOR
      DO K = 1, NREF
        J     = (K - 1) * NREC
        FOK   = VOID(J + 4)
        FCKT  = VOID(J + 10)
        FCK   = VOID(J + ICALT)
        SUMFO = SUMFO + FOK
        DO I = 1, NP76
          ALF = (I - 1) * STAL
          TERM1 = (1.0 - ALF) * FCK
          IF (FCKT > 0.0) THEN
            TERM2 = ALF * FCKT
          ELSE
            TERM2 = 0.0
          END IF
          SUMFC(I) = SUMFC(I) + TERM1 + TERM2
        END DO
      END DO
C * LOOP OVER ALL REFLECTIONS AND APPLY SCALING FACTOR
      DO I = 1, NP76
        SCLA(I) = SUMFC(I) / SUMFO
        SUMT(I) = 0.0
        SUMN(I) = 0.0
      END DO
      DO K = 1, NREF
        J   = (K - 1) * NREC
        FOK = VOID(J + 4)
        SIG = VOID(J + 6)
        IF (FOK > 2.0 * SIG) THEN
          FCKT = VOID(J + 10)
          FCK  = VOID(J + ICALT)
          DO I = 1, NP76
            ALF     = (I - 1) * STAL
            FCKS    = SQRT ((1.0 - ALF) * FCK + ALF * FCKT)
            FOKS    = SQRT (SCLA(I) * FOK)
            SUMT(I) = SUMT(I) + ABS (FOKS - FCKS)
            SUMN(I) = SUMN(I) + FOKS
          END DO
        END IF
      END DO
C * FIND MINIMUM RVAL/BASF VALUE
      BASF = 0.0
      IF (SUMN(1) > 0) THEN
        RVAL = SUMT(1) / SUMN(1)
        DRVAL(MXTWN) = - RVAL
        DO I = 2, NP76
          IF (SUMN(I) /= 0.0) THEN
            YUNK = SUMT(I) /SUMN(I)
            IF (YUNK < RVAL) THEN
              BASF = (I - 1) * STAL
              RVAL = YUNK
            END IF
          END IF
        END DO
      ELSE
        RVAL = 0.0
      END IF
C * STORE MINIMUM
      DRVAL(MXTWN)         = DRVAL(MXTWN) + RVAL
      BASFM(MXTWN)         = BASF
      MTWIN(MXTWN * 2 - 1) = NINT (DRVAL(MXTWN) * 1000.0)
      MTWIN(MXTWN * 2    ) = MXTWN
      RETURN
      END SUBROUTINE PLA415
 
      SUBROUTINE PLA416 (ISHOW, MODE)
C * SHOW TWINROTMAT RESULTS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE analysis
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: MODE
      INTEGER :: LOUT
      INTEGER :: NCOL
      INTEGER :: NCOL3
      INTEGER :: NLIST
      INTEGER :: ISHOW
      CHARACTER(len=9) :: LIST
C * ISHOW  0 = Report 'No Twinning Detected'
C *        1 = Show Twinning Laws
C * MODE   1 = GRAPHICS MODE
C *        2 = NON-GRAPHICS MODE
C * IPR(771) = Number of Twinning Laws for Display
      NLIST = 0
C * REPORT ABOUT TOO FEW TWIN CANDIDATES
      IF (ISHOW == 0) THEN
        IF (MODE == 2) THEN
          LOUT = LU13
        ELSE
          LOUT = LU6
          IF (IWIN == 1) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            CALL PLA439 (0.0,
     1 'Too Few Fobs > Fcalc Reflections for TwinRotMat Analysis',
     2   56, 0.45, 2, 2, 1.0, 8.0)
          END IF
        END IF
        WRITE (LOUT, 99984, IOSTAT = IOST) NSEL
        IF (ICALT == 5) THEN
          WRITE (LOUT, 99978, IOSTAT = IOST)
        ELSE
          WRITE (LOUT, 99986, IOSTAT = IOST)
        END IF
        WRITE (LOUT, 99982, IOSTAT = IOST)
      ELSE
        IF (MODE == 1) THEN
          IF (IWIN == 1) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            CALL PLA110 (HORS, VERT, -1)
C * FCF FILE TYPE
            LIST = ' '
            IF (IGBL(9) == 1) THEN
              LIST = 'FCF-LIST4'
            ELSE IF (IGBL(9) == 23) THEN
              LIST = 'FCF-LIST6'
            ELSE IF (IGBL(9) == 25) THEN
              LIST = 'FCF-LIST8'
            END IF
C * REPORT SOURCE OF F(calc)  (i.e. CIF or FCF)
            IF (ICALT == 5) THEN
              BCD  = 'Ical from Coordinates, Iobs from '//LIST
              NCOL = 1
            ELSE
              BCD  = 'Ical from FCF File, Iobs from '//LIST
              NCOL = 2
            END IF
            CALL PLA439 (90.0, BCD, 42, 0.35, NCOL, 1, 1.5, 0.8)
            CALL GGIP (0.0, 2.0, 0.0, 0)
            BCD = 'TwinRotMat'//CHAR (0)
            CALL PLA439 (0.0,  BCD, 10, 1.4, 4, 8, 7.0, VERT - 1.8)
            CALL PLA439 (0.0,  BCD, 10, 1.4, 2, 8, 6.8, VERT - 1.9)
            WRITE (BCD, 99996, IOSTAT = IOST) JID(1:14)
            VRT = VERT - 3.0
            CALL PLA439 (0.0,  BCD, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
            WRITE (BCD, 99991, IOSTAT = IOST)
     1        PAR(17), (PAR(100 + I), I = 1, 6), SPGRNM(1)(1:11)
            VRT = VRT - 1.0
            CALL PLA439 (0.0,  BCD, 80, 0.35, 1, 2, 1.0, VRT)
          END IF
        ELSE
          WRITE (LU13, 99984, IOSTAT = IOST) NSEL
          IF (ICALT == 5) THEN
            WRITE (LU13, 99978, IOSTAT = IOST)
          ELSE
            WRITE (LU13, 99986, IOSTAT = IOST)
          END IF
        END IF
        IF (MODE == 1) NLIST = NLIST + 1
C * LIST/DISPLAY SELECTION CRITERIA
        WRITE (BCD, 99990, IOSTAT = IOST) PAR(413), PAR(414), IPR(550)
        IF (NLIST == 1) THEN
          CALL PLA262 (0)
          CALL PLA262 (9)
          WRITE (LU6, 99997, IOSTAT = IOST)
          WRITE (LU7, 99997, IOSTAT = IOST)
          WRITE (LU6, 99998, IOSTAT = IOST) BCD
          WRITE (LU7, 99998, IOSTAT = IOST) BCD
        END IF
        IF (IWIN == 1 .AND. MODE == 1) THEN
          VRT = VRT - 0.7
          CALL PLA439 (0.0,  BCD, 80, 0.35, 1, 2, 1.0, VRT)
        END IF
        WRITE (BCD, 99983, IOSTAT = IOST)
     1    NREF, NSEL, IPR(567), PAR(415), PAR(420)
        IF (NLIST == 1) THEN
          WRITE (LU6, 99997, IOSTAT = IOST)
          WRITE (LU7, 99997, IOSTAT = IOST)
          WRITE (LU7, 99987, IOSTAT = IOST) PAR(17)
          WRITE (LU6, 99998, IOSTAT = IOST) BCD
          WRITE (LU7, 99998, IOSTAT = IOST) BCD
          WRITE (LU6, 99997, IOSTAT = IOST)
          WRITE (LU7, 99997, IOSTAT = IOST)
        END IF
        IF (IWIN == 1 .AND. MODE == 1) THEN
          VRT = VRT - 0.7
          CALL PLA439 (0.0,  BCD, 80, 0.35, 1, 2, 1.0, VRT)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        END IF
        IF (NSEL == 0) THEN
          IF (IWIN == 1 .AND. MODE == 1) THEN
            CALL PLA439 (0.0, 'No Refl Selected', 16, 1.2, 2, 10, 4.0,
     1                   8.0)
          END IF
          IF (MODE == 2) WRITE (LU13, 99985, IOSTAT = IOST)
          RETURN
        END IF
        IF (IPR(771) > 0) THEN
          IF (IWIN == 1 .AND. MODE == 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)
          END IF
          NCOL3 = 1
          DO J = 1, IPR(771)
            I = MTWIN(J * 2)
            IF (BASFM(I) > 0.0 .AND. DRVAL(I) <= -0.01 .AND.
     1        (NTW(I) > 0.5 * NTW(MTWIN(2)))) THEN
                NCOL         = 3
                IPR(570 + J) = NCOL3
                NCOL3        = 0
            ELSE
              NCOL = 4
            END IF
            WRITE (BCD, 99999, IOSTAT = IOST)
     1        (IHKLR(K, I), K = 1, 3), (IHKLD(K, I), K = 1, 3),
     2        ALPHA(I), IABS (NFRQ(I))
            IF (NFRQ(I) > 0) THEN
              WRITE (PRBUF, 99981, IOSTAT = IOST)
            ELSE
              WRITE (PRBUF, 99980, IOSTAT = IOST)
            END IF
            IF (NLIST == 1) THEN
              CALL PLA262 (2)
              WRITE (LU6, 99997, IOSTAT = IOST)
              WRITE (LU7, 99997, IOSTAT = IOST)
              WRITE (LU6, 99998, IOSTAT = IOST) BCD
              WRITE (LU7, 99998, IOSTAT = IOST) BCD
            END IF
            IF (NCOL == 3) THEN
              IF (MODE == 2) THEN
                WRITE (LU13, 99997, IOSTAT = IOST)
                WRITE (LU13, 99998, IOSTAT = IOST) BCD
                WRITE (LU13, 99998, IOSTAT = IOST) PRBUF(1:37)
                WRITE (LU13, 99997, IOSTAT = IOST)
              END IF
              WRITE (NQ1, 99989, IOSTAT = IOST) (IHKLR(K, I), K = 1, 3)
              WRITE (NQ2, 99988, IOSTAT = IOST) (IHKLD(K, I), K = 1, 3)
C * TEST FOR ROTATION ABOUT () or []
              IF (NFRQ(I) > 0) THEN
                NQ2 = ' '
              ELSE
                NQ1 = ' '
              END IF
C * ALERT _930 - TWINNING INDICATION IN FCF
              IF (ICALT == 11) THEN
                CALL PLA236 (930, 2, -999.0,   BASFM(I), NQ1, NQ2)
              ELSE
C * ALERT _931 - TWINNING INDICATION IN CIF/HKL
                CALL PLA236 (931, 2, -999.0, BASFM(I), NQ1, NQ2)
              END IF
            END IF
            IF (IWIN == 1 .AND. MODE == 1) THEN
              VRT = VRT - 1.0
              BCD(80:80) = CHAR (0)
              CALL PLA439 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
              VRT = VRT - 0.4
              CALL PLA439 (0.0,  PRBUF, 37, 0.3, NCOL, 2, 2.0, VRT)
            END IF
            IF (NLIST == 1) THEN
              CALL PLA262 (4)
              WRITE (LU6, 99998, IOSTAT = IOST) PRBUF(1:37)
              WRITE (LU7, 99998, IOSTAT = IOST) PRBUF(1:37)
            END IF
            WRITE (BCD, 99994, IOSTAT = IOST)
     1        (TWM(1, L, I), L = 1, 3), NTW(I)
            IF (NLIST == 1) THEN
              WRITE (LU6, 99998, IOSTAT = IOST) BCD
              WRITE (LU7, 99998, IOSTAT = IOST) BCD
            END IF
            IF (NCOL == 3 .AND. MODE == 2)
     1        WRITE (LU13, 99998, IOSTAT = IOST) BCD
            IF (IWIN == 1 .AND. MODE == 1) THEN
              VRT = VRT - 0.6
              CALL PLA439 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
            END IF
            WRITE (BCD, 99993, IOSTAT = IOST)
     1        (TWM(2, L, I), L = 1, 3), BASFM(I)
            IF (NLIST == 1) THEN
              WRITE (LU6, 99998, IOSTAT = IOST) BCD
              WRITE (LU7, 99998, IOSTAT = IOST) BCD
            END IF
            IF (NCOL == 3 .AND. MODE == 2)
     1        WRITE (LU13, 99998, IOSTAT = IOST) BCD
            IF (IWIN == 1 .AND. MODE == 1) THEN
              VRT = VRT - 0.6
              CALL PLA439 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
              WRITE (NQ1, 99995, IOSTAT = IOST) J
              CALL PLA439 (0.0, NQ1, 1, 1.5, 1, 2 , HORS - 2.5, VRT)
            END IF
            WRITE (BCD, 99992, IOSTAT = IOST)
     1        (TWM(3, L, I), L = 1, 3), DRVAL(I)
            IF (NLIST == 1) THEN
              WRITE (LU6, 99998, IOSTAT = IOST) BCD
              WRITE (LU7, 99998, IOSTAT = IOST) BCD
            END IF
            IF (NCOL == 3 .AND. MODE == 2)
     1        WRITE (LU13, 99998, IOSTAT = IOST) BCD
            IF (IWIN == 1 .AND. MODE == 1) THEN
              VRT = VRT - 0.6
              CALL PLA439 (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)
            END IF
          END DO
C * WARNING ABOUT SYMMETRY RELATED TWINLAWS
          IF (NLIST == 1) THEN
            WRITE (LU6, 99979, IOSTAT = IOST)
            WRITE (LU7, 99979, IOSTAT = IOST)
          ENDIF
        ELSE
          IF (MODE == 1) THEN
            IF (IWIN == 1) THEN
              CALL PLA439 (0.0, 'No Twin Law Detected', 20, 1.2, 2, 10,
     1                     3.0, 8.0)
            END IF
          END IF
        END IF
        IF (MODE == 2) THEN
          IF (MODE == 2) WRITE (LU13, 99985, IOSTAT = IOST)
          WRITE (LU13, 99997, IOSTAT = IOST)
        END IF
      END IF
      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 (' (', 3I2, ')')
99988 FORMAT ('[', 3I2, '] ')
99987 FORMAT ('Wavelength Used in this Analysis', F10.5, ' Ang.', /)
99986 FORMAT ('Note: This Analysis is Based on Fc Taken from Fo/Fc',
     1        ' File (FCF)', /, 79('='))
99985 FORMAT (/,
     1  'No Applicable Twin Law(s) Detected from Fo/Fc Analysis',
     2  '-or Already Accounted for')
99984 FORMAT (/, 'Section 8', /, 79('='), /,
     1 'Check for Unaccounted Twinning with the TwinRotMat Algorithm',
     2  ' - N(selec) =', I6, /, 79('='))
99983 FORMAT ('N(refl) =', I7, ', N(selected) =', I5, ', IndMax =',
     1        I3, ', CritI =', F4.1, ', CritT =', F5.2)
99982 FORMAT (/, ':: Too few Fobs >> Fcalc Reflections for',
     1        ' TwinRotMat Analysis', /)
99981 FORMAT (8X,  13('*'))
99980 FORMAT (24X, 13('*'))
99979 FORMAT (/, 'Note: Symmetry Equivalent Twin Laws are not Listed !',
     1        /)
99978 FORMAT ('Note: This Analysis is Based on Fc calculated from',
     1        ' Coordinates in the CIF.', /
     1        79('='))
      END SUBROUTINE PLA416
 
      SUBROUTINE PLA417
C * GENERATE HKLF5 FILE
      USE files
      USE parameters
      USE cchar
      USE reflex
      USE lepage
      USE analysis
      USE p414
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: N
      INTEGER               :: IHT
      INTEGER               :: IKT
      INTEGER               :: ILT
      INTEGER               :: IRT
      INTEGER               :: NTC
      INTEGER               :: NTX
      INTEGER               :: NTY
      INTEGER               :: NRTW
      INTEGER               :: ISIG
      INTEGER               :: IFOK
      INTEGER               :: IPRN
      INTEGER               :: NRTWIN
      INTEGER               :: IHKLTP
      INTEGER, DIMENSION(3) :: IHKL
      REAL                  :: ST
      REAL                  :: TH
      REAL                  :: THT
      REAL                  :: SIG
      REAL                  :: FCK
      REAL                  :: FOK
      REAL                  :: XDUM
      REAL                  :: FCKT
      REAL                  :: FCKT0
      REAL                  :: GEN095
      CHARACTER(len=4)      :: KEY
      CHARACTER(len=76)     :: JDM
      NTX = 0
      IRT = (2 - ICNTR) * IPR(575) + 1
      CALL PLA262 (0)
      CALL PLA262 (2)
      WRITE (LU7, 99999, IOSTAT = IOST)
      NTWIN = 0
C * SELECT/COPY ACTIVE TWIN MATRICES
      DO K = 1, MXTWN - 1
        IF (IPR(570 + K) == 1) THEN
          NTWIN       = NTWIN + 1
          MTW(NTWIN)  = MTWIN(K * 2)
          NTW0(NTWIN) = K
        END IF
      END DO
      IPR(2) = -11
      DO K = 1, NREF
        N = (K - 1) * NREC
        DO I = 1, 3
          IHKL(I) = NINT (VOID(N + I))
          H(I)    = IHKL(I)
        END DO
        FOK  = VOID(N + 4)
        FCK  = VOID(N + ICALT)
        SIG  = VOID(N + 6)
        TH   = VOID(N + 7)
        IFOK = NINT (FOK * SCL)
        ISIG = NINT (SIG * SCL)
        NTY  = 0
        DO 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) < PAR(415)) THEN
            IF (ABS (T(2) - IKT) < PAR(415)) THEN
              IF (ABS (T(3) - ILT) < PAR(415)) THEN
                IHKLTP = ILT * MHK + IKT * MPH + IHT
                J      = NINT (VOID(IADR + IHKLTP))
                IF (J < 0) THEN
                  WRITE (LU6, 99989) IHT,IKT,ILT
                  CYCLE
                ELSE IF (J > 0) THEN
                  FCKT0 = VOID((J - 1) * NREC + 5)
                ELSE
                  WRITE (LU6, 99993, IOSTAT = IOST)
     1              (IHKL(J), J = 1, 3), (NINT (T(J)), J = 1, 3)
                END IF
                ST = SQRT (GEN095 (PAR(191), IHT, IKT, ILT)) * PAR(17)
                IF (ST < 1.0) THEN
                  THT = ASIN (ST) * RGBL(6)
                ELSE
                  THT = 0.0
                END IF
                IF (ABS (TH - THT) <= PAR(420)) THEN
                  IF (ABS (IHT) <= HMAX0 .AND. ABS (IKT) <= KMAX0 .AND.
     1                ABS (ILT) <= LMAX0) THEN
                    NTY  = 1
                    FCKT = FCKT0
                    NTC  = - (NRTW + 1) * IRT
C * TEST FOR RACEMIC TWIN INCLUDE
                    IF (IPR(575) == 1) THEN
                      WRITE (LU17, 99998, IOSTAT = IOST)
     1                  -IHT, -IKT, -ILT, IFOK, ISIG, NTC
                    END IF
                    WRITE (LU17, 99998, IOSTAT = IOST)
     1                IHT,  IKT,  ILT, IFOK, ISIG, NTC + (IRT - 1)
                    IPRN = 1
                  END IF
                END IF
              END IF
            END IF
          END IF
        END DO
C * TEST FOR RACEMIC TWIN INCLUDE
        IF (IPR(575) == 1) THEN
          WRITE (LU17, 99998, IOSTAT = IOST)
     1      ( -NINT (H(J)), J = 1, 3), IFOK, ISIG, -2
        END IF
        WRITE (LU17, 99998, IOSTAT = IOST)
     1   (NINT (H(J)), J = 1, 3), IFOK, ISIG, 1
        NTX = NTX + NTY
        IF (IPR(469) /= 0) THEN
          CALL PLA262 (1)
          IF (IPRN /= 0) THEN
            WRITE (LU7, 99997, IOSTAT = IOST)
     1        NTX, (NINT (H(J)), J = 1, 3), FOK, FCK, SIG, IHT, IKT,
     2        ILT, FCKT, TH, THT, TH - THT
          ELSE
            WRITE (LU7, 99996, IOSTAT = IOST)
     1        (NINT (H(J)), J = 1, 3), FOK, FCK, SIG
          END IF
        END IF
        VOID(N + 10) = FCKT
      END DO
      WRITE (LU6, 99995, IOSTAT = IOST) (NTW0(K), K = 1, NTWIN)
      CALL PLA262 (0)
      WRITE (LU7, 99995, IOSTAT = IOST) (NTW0(K), K = 1, NTWIN)
      IF (IRT == 1) THEN
        WRITE (LU6, 99994, IOSTAT = IOST) NREF, NTX, (BASFM(MTW(I)),
     1                     I = 1, NTWIN)
        WRITE (LU7, 99994, IOSTAT = IOST) NREF, NTX, (BASFM(MTW(I)),
     1                     I = 1, NTWIN)
      ELSE
        WRITE (LU6, 99994, IOSTAT = IOST) 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, IOSTAT = IOST) NREF, NTX,
     1                     (BASFM(MTW(NTWIN + 1 - I)) / 2.0,
     2                      BASFM(MTW(NTWIN + 1 - I)) / 2.0,
     3                     I = 1, NTWIN)
      END IF
C * COPY/EDIT embedded .ins FILE
 
      IF (IPR(663) /= 0) THEN
        REWIND (UNIT = LU24, IOSTAT = IOST)
        OPEN (UNIT = LU62, FILE = NAMEFIL(1:KNMFIL)//'_tw.ins',
     1    STATUS = 'UNKNOWN')
        DO
          READ (LU24, 99990, IOSTAT = IOST) KEY, JDM
          IF (IOST /= 0) EXIT
          CALL GEN020 (1, KEY, 1, 4)
          IF (KEY == 'HKLF') THEN
            WRITE (LU62, 99992, IOSTAT = IOST) 'HKLF 5'
            CYCLE
          ELSE IF (KEY == 'FVAR') THEN
            WRITE (LU62, 99991) (BASFM(MTW(I)), I = 1, NTWIN)
          ELSE IF (KEY == 'BASF') THEN
            CYCLE
          ELSE IF (KEY == 'TWIN') THEN
            CYCLE
          ELSE IF (KEY == 'OMIT') THEN
            CYCLE
          ELSE IF (KEY == 'WGHT') THEN
            JDM = ' 0.1'
          END IF
          WRITE (LU62, 99990, IOSTAT = IOST) KEY, JDM
        END DO
        CLOSE (UNIT = LU24, STATUS = 'DELETE', IOSTAT = IOST)
        IPR(663) = 0
      END IF
C * COPY HKLF5 REFLECTION SET
      OPEN (UNIT = LU63, FILE = NAMEFIL(1:KNMFIL)//'_tw.hkl',
     1  STATUS = 'UNKNOWN')
      REWIND (UNIT = LU17, IOSTAT = IOST)
      DO
        READ  (LU17, 99992, IOSTAT = IOST) IDM
        IF (IOST /= 0) EXIT
        WRITE (LU63, 99992, IOSTAT = IOST) IDM
      END DO
      CLOSE (UNIT = LU63)
      CLOSE (UNIT = LU17, STATUS = 'DELETE')
      IF (IPR(2) == 0) IPR(2) = -11
      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 =', 8F6.2)
99993 FORMAT (':: Unobserved Partner for ', 3I5, ' : ', 3I5)
99992 FORMAT (A)
99991 FORMAT ('BASF', 9F6.3)
99990 FORMAT (A, A)
99989 FORMAT ('Missing', 3I5)
      END SUBROUTINE PLA417
 
      SUBROUTINE PLA418
C * PLOT TWIN LATTICE OVERLAP
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE spgrdata
      USE reflex
      USE lepage
      USE analysis
      USE p414
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: NV
      INTEGER               :: NADD
      INTEGER               :: IASJ
      INTEGER               :: IBRV
      INTEGER               :: IPEN
      INTEGER               :: IPLT
      INTEGER               :: IHKLP
      INTEGER               :: NSTEP
      INTEGER               :: NTPLT
      INTEGER, DIMENSION(3) :: IMX
      INTEGER, DIMENSION(3) :: JMX
      INTEGER, DIMENSION(8) :: IAS
      REAL                  :: HH
      REAL                  :: RD
      REAL                  :: VH
      REAL                  :: STL
      REAL                  :: SCF
      REAL                  :: OME
      REAL                  :: CHI
      REAL                  :: FOK
      REAL                  :: FCK
      REAL                  :: FCX
      REAL                  :: FCMX
      REAL                  :: BAS1
      REAL                  :: BAS2
      REAL                  :: SCPR
      REAL                  :: RADM
      REAL                  :: XDUM
      REAL                  :: XLNG
      REAL                  :: XTAU
      REAL                  :: YUNK
      REAL                  :: SCPR0
      REAL                  :: RADIUS
      REAL                  :: GEN009
      REAL                  :: SIGI
      REAL, DIMENSION(3, 8) :: AS
      REAL, DIMENSION(3)    :: XYZ
      REAL, DIMENSION(3)    :: TAU
      REAL, DIMENSION(3, 3) :: ROT
      REAL, DIMENSION(3, 3) :: YUNKAR
C * CHECK FOR AND DISPLAY OF TWINLAW IN THE RANGE (1, 2, 3, 4)
      IF (IPR(543) <= 0 .OR. IPR(543) > 4) RETURN
C * CHECK TWIN DATA
      NTPLT = MTWIN(IPR(543) * 2)
      IF (NTPLT == 0) RETURN
C * LOCATE ORIGIN IN CENTER WINDOW
      HH   = HORS / 2.0
      VH   = VERT / 2.0
      RD   = 0.9 * VH
      IBRV = IPR(241)
C * ZERO SGX ARRAY
      CALL GEN074 (SGX, 1, 13, 0.0)
      DO
C * GET REQUESTED RECIPROCAL LATTICE RESOLUTION (SIN(THETA) / LAMBDA)
        STL  = PAR(449)
        RADM = RD
        DO I = 1, 3
          IMX(I) = INT (2 * STL * PAR(100 + I))
          JMX(I) = 2 * IMX(I) + 1
          RADM   = MIN (RADM, RD / IMX(I))
        END DO
        RADM = RADM * 0.45
C * TOP STORED REFLECTION DATA FOR STORING LATTICE DATA
        NV   = NADR
        FCMX = 0.0
        DO I = 1, JMX(1)
          H(1) = I - IMX(1) - 1
          DO J = 1, JMX(2)
            H(2) = J - IMX(2) - 1
            DO K = 1, JMX(3)
              H(3) = K - IMX(3) - 1
C * CHECK FOR BRAVAIS LATTICE ABSENCE
              YUNK = 0.0
              IF (IBRV > 1) THEN
                SGX(1)  = H(1)
                SGX(2)  = H(2)
                SGX(3)  = H(3)
                SGX(12) = -1
                CALL SGSM (27, LINE, SGX, 0, 0, IERR)
                IF (NINT (SGX(12)) > 0) YUNK = -1.0
              END IF
C * COLLECT INFO FOR MAIN LATTICE & OVERLAPPING TWIN-LATTICE
              DO L = 1, 2
C * MAIN COMPONENT (L = 1)
                IF (L == 1) THEN
                  T(1) = H(1)
                  T(2) = H(2)
                  T(3) = H(3)
                  FCK  = 0.0
                  IPEN = 1
                  IF (IABS (NINT (T(1))) <= HMAX0 .AND.
     1                IABS (NINT (T(2))) <= KMAX0 .AND.
     2                IABS (NINT (T(3))) <= LMAX0) THEN
                    IHKLP = NINT (T(3)) * MHK + NINT (T(2)) * MPH
     1                    + NINT (T(1))
                    N     = NINT(VOID(IADR + IHKLP))
                    IF (N > 0) THEN
                      FOK  = VOID((N - 1) * NREC + 4)
                      FCK  = VOID((N - 1) * NREC + 5)
                      SIGI = VOID((N - 1) * NREC + 6)
C * REGISTER STRONG OVERLAP CANDIDATE 'SIZE'
                      IF (SIGI /= 0.0) THEN
                        IF ((FOK - FCK) / SIGI > DELS) THEN
                          IPEN = 5
                        END IF
                      END IF
                    END IF
                  END IF
                  IF (FCK > 0) THEN
                    FCX = LOG (FCK)
                  ELSE
                    FCX = 0.0
                  END IF
                  FCMX = MAX (FCMX, FCX)
C * TWIN COMPONENT (L = 2)
                ELSE
                  CALL GEN002 (1, TWM(1, 1, NTPLT), H, T, XDUM)
                  IPEN = 2
                END IF
                CALL GEN002 (1, ROTQ, T, XYZ, XDUM)
C * REGISTER STRONG OVERLAP CANDIDATE 'SIZE'
                IF (SQRT (GEN009 (XYZ, XYZ)) < 2 * STL) THEN
                  VOID(NV + 1)  = IPEN
                  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 + 9)  = YUNK
                  VOID(NV + 10) = FCX
                  NV            = NV + 10
                END IF
              END DO
            END DO
          END DO
        END DO
   10   CALL GEN097 (IAS, 1, 8, 0)
C * ROTATE ZONE AXIS (A, B or C) ALONG Z
   20   DO I = 1, 3
          TAU(I) = OR(I, IPR(394))
        END DO
        XTAU = SQRT (GEN009 (TAU, TAU))
        DO I = 1, 3
          TAU(I) = TAU(I) / XTAU
        END DO
        IF (ABS (TAU(1)) + ABS (TAU(2)) < 0.0001) THEN
          OME = 0.0
          CHI = 90.0 / RGBL(6)
        ELSE
          OME = ATAN2 (TAU(2), TAU(1))
          CHI = ATAN2 (TAU(3), SQRT(TAU(1)**2 + TAU(2)**2))
        END IF
C * ROTATION MATRIX FOR OMEGA
        CALL GEN043 (3, TP, OME)
C * GET ROTATION MATRIX FOR 90 - CHI
        CALL GEN043 (2, TG, 90.0 / RGBL(6) - CHI)
        CALL GEN004 (TG, TP, ROT)
        IF (IPR(394) == 2 .OR. IPR(394) == 3) THEN
          CALL GEN043 (3, TG, 180.0 / RGBL(6))
        ELSE
          CALL GEN043 (3, TG, 90.0 / RGBL(6))
        END IF
        CALL GEN004 (TG, ROT, YUNKAR)
        CALL GEN052 (YUNKAR, ROT)
        BCD = 'PlotTwinLat'//CHAR (0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL PLA439 (90.0,  BCD, 11, 1.2, 2, 8, 2.3, 2.5)
        CALL PLA110 (HORS, VERT, -1)
C * DISPLAY TWIN MATRIX
        VRT = VERT - 0.4
        CALL PLA439 (0.0, 'Twin Matrix', 11, 0.25, 5, 1, 2.0, VRT)
        VRT = VRT - 0.2
        DO I = 1, 3
          WRITE (LINE, 99999, IOSTAT = IOST)
     1      (TWM(I, J, NTPLT), J = 1, 3)
C * DUMMY
          IF (IOST == -999) RETURN
          VRT = VRT - 0.4
          CALL PLA439 (0.0, LINE, 21, 0.25, 1, 1, 0.5, VRT)
        END DO
C * DISPLAY (DIRECT) ROTATION AXIS
        VRT = VRT - 0.7
        WRITE (LINE, 99996, IOSTAT = IOST) (IHKLD(I, NTPLT), I = 1, 3)
        CALL PLA439 (0.0, LINE, 17, 0.30, 1, 1, 1.0, VRT)
C * DISPLAY (RECIPROCAL) ROTATION AXIS
        VRT = VRT - 0.6
        WRITE (LINE, 99998, IOSTAT = IOST) (IHKLR(I, NTPLT), I = 1, 3)
        CALL PLA439 (0.0, LINE, 17, 0.30, 1, 1, 1.0, VRT)
C * DISPLAY ZONE AXIS
        IF (IPR(394) == 1) THEN
          LINE = 'Zone - H ='
        ELSE IF (IPR(394) == 2) THEN
          LINE = 'Zone - K ='
        ELSE
          LINE = 'Zone - L ='
        END IF
C * DISPLAY LEVEL
        WRITE (LINE(11:13), 99997, IOSTAT = IOST) IPR(576)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 13, 0.35, 5, 1, 1.0, VRT)
C * DISPLAY RESOLUTION
        WRITE (LINE, '(''Resol = '', F5.1)', IOSTAT = IOST) PAR(449)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT)
C * DISPLAY BASF
        WRITE (LINE, '('' BASF ='', F6.2)', IOSTAT = IOST) BASFM(NTPLT)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT)
        WRITE (LINE, '(''DRVAL ='', F6.3)', IOSTAT = IOST) DRVAL(NTPLT)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT)
C * DISPLAY DIRECT CELL
        VRT = VERT
        WRITE (LINE, '(''SpGr '', A)', IOSTAT = IOST) SPGRNM(1)(1:7)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''a    '', F7.2)', IOSTAT = IOST) PAR(101)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''b    '', F7.2)', IOSTAT = IOST) PAR(102)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''c    '', F7.2)', IOSTAT = IOST) PAR(103)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''alpha'', F7.2)', IOSTAT = IOST) PAR(104)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''beta '', F7.2)', IOSTAT = IOST) PAR(105)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''gamma'', F7.2)', IOSTAT = IOST) PAR(106)
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 14, 0.35, 1, 1, HORS - 4.0, VRT)
        VRT = 2.0
        CALL PLA439 (0.0, 'Main Lattice', 12, 0.35, 1, 1,
     1    HORS - 4.0, VRT)
        VRT = VRT - 0.5
        CALL PLA439 (0.0, 'Twin Lattice', 12, 0.35, 2, 1,
     1    HORS - 4.0, VRT)
        VRT = VRT - 0.5
        CALL PLA439 (0.0, 'Iobs >> Ical', 12, 0.35, 5, 1,
     1    HORS - 4.0, VRT)
C * DRAW REFLECTION SPHERE
        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
C * LOOP OVER REFLECTIONS
        DO N = NADR, NV, 10
C * CHECK WHETHER REFLECTION INDEX MATCHES LEVEL # (SCALAR PRODUCT)
          SCPR = GEN009 (TAU, VOID(N + 5))
          IF (ABS (SCPR0 - SCPR) < 0.01) THEN
            IPEN = NINT (VOID(N + 1))
            I    = NINT (VOID(N + 2))
            J    = NINT (VOID(N + 3))
            K    = NINT (VOID(N + 4))
            IPLT = NINT (VOID(N + 9))
            DO L = 1, 3
              T(L) = VOID(N + L + 4) * SCF
            END DO
            IF (IPEN /= 2) THEN
              NADD = 0
            ELSE
              NADD = 4
            END IF
C * ZONE PERPENDICULAR TO A, B OR C
            IF (IPR(394) == 1) THEN
              IF (I == IPR(576) .AND. J == 0 .AND. K == 0)
     1          IAS(1 + NADD) = N
              IF (I == IPR(576) .AND. J == 1 .AND. K == 0)
     1          IAS(2 + NADD) = N
              IF (I == IPR(576) .AND. J == 1 .AND. K == 1)
     1          IAS(3 + NADD) = N
              IF (I == IPR(576) .AND. J == 0 .AND. K == 1)
     1          IAS(4 + NADD) = N
            ELSE IF (IPR(394) == 2) THEN
              IF (I == 0 .AND. J == IPR(576) .AND. K == 0)
     1          IAS(1 + NADD) = N
              IF (I == 1 .AND. J == IPR(576) .AND. K == 0)
     1          IAS(2 + NADD) = N
              IF (I == 1 .AND. J == IPR(576) .AND. K == 1)
     1          IAS(3 + NADD) = N
              IF (I == 0 .AND. J == IPR(576) .AND. K == 1)
     1          IAS(4 + NADD) = N
            ELSE IF (IPR(394) == 3) THEN
              IF (I == 0 .AND. J == 0 .AND. K == IPR(576))
     1          IAS(1 + NADD) = N
              IF (I == 1 .AND. J == 0 .AND. K == IPR(576))
     1          IAS(2 + NADD) = N
              IF (I == 1 .AND. J == 1 .AND. K == IPR(576))
     1          IAS(3 + NADD) = N
              IF (I == 0 .AND. J == 1 .AND. K == IPR(576))
     1          IAS(4 + NADD) = N
            END IF
            CALL GEN002 (1, ROT, T, XYZ, XLNG)
            IF (IPLT == 0) THEN
              RADIUS = RADM * VOID(N + 10) / FCMX
C * MAIN RECIPROCAL LATTICE
              IF (IPEN /= 2) THEN
                RADIUS = MAX (RADIUS, 0.02)
                NSTEP  = 12
C * OVERLAPPING RECIPROCAL LATTICE
              ELSE
                RADIUS = MAX (RADIUS * BAS2 / BAS1, 0.02)
                NSTEP  = 4
              END IF
C * DRAW LATTICE POINT (CIRCLE)
              CALL GGIP (0.0, FLOAT (IPEN), 0.0, 0)
              CALL PLA289 (XYZ(1), XYZ(2), RADIUS, NSTEP)
              IF (IPEN == 5) THEN
                CALL GGIP (0.0, FLOAT (IPEN), 0.0, 0)
                CALL PLA289 (XYZ(1), XYZ(2), RADIUS * 1.2, NSTEP)
              END IF
            END IF
          END IF
        END DO
        DO J = 1, 8
          DO I = 1, 3
            IASJ = IAS(J)
            IF (IASJ == 0) IASJ = IAS(2)
            T(I) = VOID(IASJ + I + 4) * SCF
          END DO
          CALL GEN002 (1, ROT, T, AS(1, J), XLNG)
        END DO
C * DRAW RECIPROCAL UNITCELL
        DO 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)
        END DO
        CALL PLA439 (0.0, 'O', 1, 0.25, 1, 2, AS(1, 1) -0.3,
     1    AS(2, 1) - 0.3)
        IF (IPR(394) == 1) THEN
          CALL PLA439 (0.0, 'K', 1, 0.25, 1, 2, AS(1, 2),
     1       AS(2, 2) + 0.1)
          CALL PLA439 (0.0, 'L', 1, 0.25, 1, 2, AS(1, 4) + 0.1,
     1       AS(2, 4))
        ELSE IF (IPR(394) == 2) THEN
          CALL PLA439 (0.0, 'H', 1, 0.25, 1, 2, AS(1, 2),
     1      AS(2, 2) + 0.1)
          CALL PLA439 (0.0, 'L', 1, 0.25, 1, 2, AS(1, 4) + 0.1,
     1      AS(2, 4))
        ELSE IF (IPR(394) == 3) THEN
          CALL PLA439 (0.0, 'H', 1, 0.25, 1, 2, AS(1, 2),
     1      AS(2, 2) + 0.1)
          CALL PLA439 (0.0, 'K', 1, 0.25, 1, 2, AS(1, 4) + 0.1,
     1      AS(2, 4))
        END IF
C * GET NEW INSTRUCTION
        CALL PLA012 (0, 1)
        SELECT CASE (IGGT(1:4))
          CASE ('!   ')
            GO TO 10
C * TWIN
          CASE ('TWIN')
C * NEXT
          CASE ('NEXT')
            IPR(576) = MAX (-IMX(IPR(394)), MIN (IMX(IPR(394)),
     1                 IPR(576) + IPR(389)))
            GO TO 20
C * ZONE
          CASE ('ZONE')
            GO TO 10
C * RESOLUTION
          CASE ('RESO')
C * LIST (IPR/PAR/IGBL/RGBL)
          CASE ('LIST')
            CALL PLA206 (-1, IFL(2)(1:3))
C * SET (IPR/PAR/IGBL/RGBL)
          CASE ('SET ')
            CALL PLA206 (1, IFL(2)(1:3))
          CASE DEFAULT
C * RESET DspTwinMat#
            IPR(543) = 0
            EXIT
        END SELECT
      END DO
      RETURN
99999 FORMAT (3F7.3)
99998 FORMAT ('(', I3, 2I5, ' )')
99997 FORMAT (I3)
99996 FORMAT ('[', I3, 2I5, ' ]')
      END SUBROUTINE PLA418
 
      MODULE npplot
      SAVE
      REAL :: YCC
      REAL :: YINT
      REAL :: YSLOPE
      END MODULE npplot
 
      SUBROUTINE PLA419 (MODUS, SCAL, IDTYP1, IDTYP2, LU)
C * SCATTER PLOT ROUTINE
      USE files
      USE parameters
      USE cchar
      USE analysis
      USE npplot
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: N
      INTEGER           :: LU
      INTEGER           :: MODE
      INTEGER           :: MODUS
      INTEGER           :: IDTYP1
      INTEGER           :: IDTYP2
      INTEGER           :: IYELLOW
      REAL              :: X
      REAL              :: Y
      REAL              :: YM
      REAL              :: YP
      REAL              :: XOR
      REAL              :: YOR
      REAL              :: PEN
      REAL              :: DSH
      REAL              :: FCK
      REAL              :: FOK
      REAL              :: VRT
      REAL              :: VAL4
      REAL              :: VAL5
      REAL              :: VAL6
      REAL              :: TICK
      REAL              :: FCKM
      REAL              :: FOKM
      REAL              :: SCAL
      REAL              :: HORS
      REAL              :: VERT
      REAL              :: SCHAAL
      REAL              :: SCALCAL
      REAL              :: SCALOBS
      CHARACTER(len=12) :: THOR
      CHARACTER(len=12) :: TVER
C * FCF REFLECTION DATA STORAGE SCHEME
C * VOID(NADR + 1)  = IH
C * VOID(NADR + 2)  = IK
C * VOID(NADR + 3)  = IL
C * VOID(NADR + 4)  = FOK
C * VOID(NADR + 5)  = FCK (FROM CIF)
C * VOID(NADR + 6)  = MAX (SIG, 0.0)
C * VOID(NADR + 7)  = TH
C * VOID(NADR + 8)  = (FOK - FCK) / SIGI
C * VOID(NADR + 9)  = (FOK - FCK) / SIGIW
C * VOID(NADR + 10) =
C * VOID(NADR + 11) = FCK' (FROM FCF)
C * VOID(NADR + 12) = SIGIW
C * HANDLE POOR VISIBILITY OF YELLOW ON WHITE BACKGROUND
      IF (IGBL(68) == 1 .OR. IGBL(66) == 0) THEN
        IYELLOW = 6
      ELSE
        IYELLOW = 5
      END IF
      MODE = MODUS
C * SECECT I OR F PLOTS
      IF (MODE == 0) MODE = - IPR(711)
C * DUMMY INSTRUCTION
      N = IDTYP1 + IDTYP2
C * MODE = -1: F(OBS)  VERSUS F(CALC)
C * MODE =  0: I(OBS)  VERSUS I(CALC)
C * MODE =  1: I(OBS)1 VERSUS I(OBS)2
      IF (MODE == -1) THEN
C * CHECK FOR 'LOGLOG' or 'LINEAR'
        IF (IPR(633) == 0) THEN
          THOR = 'F(calc)'
          TVER = 'F(obs)'
        ELSE
          THOR = 'log[F(calc)]'
          TVER = 'log[F(obs)]'
        END IF
      ELSE IF (MODE == 0) THEN
C * CHECK FOR 'LOGLOG' or 'LINEAR'
        IF (IPR(633) == 0) THEN
          THOR = 'I(calc)'
          TVER = 'I(obs)'
        ELSE
          THOR = 'log[I(calc)]'
          TVER = 'log[I(obs)]'
        END IF
      ELSE IF (MODE == 1) THEN
        IF (SPGRA /= SPGRB) THEN
          WRITE (LU, 99999, IOSTAT = IOST) SPGRA, SPGRB
C * DUMMY
          IF (IOST == -999) RETURN
        END IF
C * CHECK FOR 'LOGLOG' or 'LINEAR'
        IF (IPR(633) == 0) THEN
          THOR = 'I(obs)1'
          TVER = 'I(obs)2'
        ELSE
          THOR = 'log[I(obs)1]'
          TVER = 'log[I(obs)2]'
        END IF
      ELSE
        RETURN
      ENDIF
      LINE = TVER//' versus '//THOR//' Scatter Plot'
      HORS = 25.0
      VERT = 25.0
      XOR  = 1.0
      YOR  = 1.0
C * OPEN WINDOW
      CALL GGIP (HORS, VERT, 0.0, 1)
C * OUTLINE FRAME
      CALL PLA110 (HORS, VERT, -1)
      CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL PLA110 (HORS, VERT, -1)
      CALL PLA439 (0.0, LINE, 45, 0.35, IYELLOW, 2, 5.0,
     1  VERT - 0.6)
      IF (IPR(633) == 0) THEN
        CALL PLA439 (0.0,  THOR, 8, 0.35, 1, 1, HORS - 2.3, 0.4)
        CALL PLA439 (90.0, TVER, 8, 0.35, 1, 1, 0.6, VERT - 2.0)
      ELSE IF (IPR(633) == 1) THEN
        CALL PLA439 (0.0, 'RED dots for I(obs) < 2 * Sig(I(obs))',
     1               36, 0.35, 2, 2, 3.0, VERT - 3.0)
        CALL PLA439 (0.0,  THOR, 12, 0.35, 1, 1, HORS - 4.1,
     1               0.4)
        CALL PLA439 (90.0, TVER, 12, 0.35, 1, 1, 0.6, VERT - 3.8)
      END IF
C * MOVE ORIGIN
      CALL GGIP (XOR, YOR, 0.0, -3)
C * VERTICAL AND HORIZONTAL AXES
 
      CALL GGIP (0.0, VERT - YOR, 0.0, 2)
      CALL GGIP (0.0, 0.0, 0.0, 3)
      CALL GGIP (HORS - XOR, 0.0, 0.0, 2)
      DSH  = 0.06
      NADR = 0
      FOKM = 0.0
      FCKM = 0.0
C * GET MAXIMA OF FOK & FCK
      DO I = 1, NREF
        FOK  = VOID(NADR + 4)
        IF (MODE == 1) THEN
          FCK  = VOID(NADR + 5)
        ELSE
          FCK  = VOID(NADR + 11)
        END IF
        FOKM = MAX (FOKM, FOK)
        FCKM = MAX (FCKM, FCK)
        NADR = NADR + NREC
      END DO
C * CHECK FOR 'LOGLOG' or 'LINEAR'
      IF (IPR(633) == 0) THEN
        IF (MODE == -1) THEN
          FOKM = SQRT (FOKM)
          FCKM = SQRT (FCKM)
        END IF
        SCALOBS = (VERT - YOR) / FOKM
        SCALCAL = (HORS - XOR) / FCKM
      ELSE IF (IPR(633) == 1) THEN
        SCALOBS = (VERT - YOR) / (LOG10 (FOKM) + 1)
        SCALCAL = (HORS - XOR) / (LOG10 (FCKM) + 1)
      ENDIF
      SCHAAL = MIN (SCALOBS, SCALCAL)
C * TICKS
C * CHECK FOR 'LOGLOG' or 'LINEAR'
      IF (IPR(633) == 1) THEN
        TICK = 1.0
        DO WHILE (TICK * SCHAAL < HORS - XOR)
          N    = 10 ** (NINT (TICK - 1))
          X    = TICK * SCHAAL
          TICK = TICK + 1.0
          WRITE (LINE(1:8), 99996, IOSTAT = IOST) N
          CALL GGIP (X, 0.0, 0.0, 3)
          CALL GGIP (X, 0.3, 0.0, 2)
          CALL GGIP (0.0, X, 0.0, 3)
          CALL GGIP (0.3, X, 0.0, 2)
          IF (N > 10000000) EXIT
          CALL PLA439 (0.0,  LINE, 8, 0.3, 1, 1, X - 2.2, 0.1)
          CALL PLA439 (90.0, LINE, 8, 0.3, 1, 1, 0.4, X - 2.2)
        END DO
      END IF
C * SCALE = 1 LINE
      CALL GGIP (0.0, 2.0, 0.0, 0)
      CALL GGIP (0.0, 0.0, 0.0, 3)
      CALL GGIP (HORS - XOR, VERT - YOR, 0.0, 2)
      CALL GGIP (0.0, 1.0, 0.0, 0)
      NADR = 0
      DO I = 1, NREF
        VAL4 = VOID(NADR + 4)
        IF (MODE == 1) THEN
          VAL5 = VOID(NADR + 5)
        ELSE
          VAL5 = VOID(NADR + 11)
        END IF
        IF (IPR(634) == 1) THEN
          VAL6 = VOID(NADR + 6)
        ELSE
          VAL6 = 0.0
        END IF
        IF (MODE == -1) THEN
          VAL4 = SQRT (MAX (0.0, VAL4))
          VAL5 = SQRT (MAX (0.0, VAL5))
          IF (VAL5 > 0.0) THEN
            VAL6 = VAL6 / (2.0 * VAL5)
          ELSE
            VAL6 = 0.0
          END IF
        END IF
C * CHECK FOR 'LOGLOG' or 'LINEAR'
        IF (IPR(633) == 0) THEN
          X  =            VAL5         * SCHAAL
          Y  = MAX (0.0,  VAL4         * SCHAAL)
          YP = MAX (0.0, (VAL4 + VAL6) * SCHAAL)
          YM = MAX (0.0, (VAL4 - VAL6) * SCHAAL)
        ELSE IF (IPR(633) == 1) THEN
          IF (VAL4 > 0.0 .AND. VAL4 - VAL6 > 0.0 .AND.
     1        VAL5 > 0.0) THEN
            X  =           (1.0 + LOG10 (VAL5))        * SCHAAL
            Y  =           (1.0 + LOG10 (VAL4))        * SCHAAL
            YP = MAX (0.5, (1.0 + LOG10 (VAL4 + VAL6)) * SCHAAL)
            YM = MAX (0.5, (1.0 + LOG10 (VAL4 - VAL6)) * SCHAAL)
          ELSE
            X  = 0.0
            Y  = 0.0
            YP = 0.0
            YM = 0.0
          END IF
        ENDIF
        X = MIN (X,  HORS - XOR -0.1)
        Y = MIN (Y,  VERT - YOR -0.1)
        IF (X > 0.0 .AND. Y > 0.0) THEN
          IF (IPR(634) == 1) THEN
            CALL GGIP (X, YP, 0.0, 3)
            CALL GGIP (X, YM, 0.0, 2)
          END IF
C * CHECK FOR REVERSE DISPLAY (BLACK/WHITE BACKGROUND)
          IF (VOID(NADR + 4) < 2 * VOID(NADR + 6)) THEN
            PEN = 2
          ELSE
            PEN = FLOAT (IYELLOW)
          END IF
C * PLOT MARKER
          CALL PLA411 (X, Y, DSH, PEN)
          CALL GGIP (0.0, 1.0, 0.0, 0)
        END IF
        NADR = NADR + NREC
      END DO
      VRT = VERT
      CALL GGIP (-XOR, -YOR, 0.0, -3)
      VRT = VRT - 0.75
      CALL PLA439 (0.0, FILENAMES(1)(1:25), 25, 0.35, 1, 1, VERT + 0.2,
     1             VRT)
      IF (MODE == 1) THEN
        VRT = VRT - 0.75
        CALL PLA439 (0.0, FILENAMES(2)(1:25), 25, 0.35, 1, 1,
     1               VERT + 0.2, VRT)
      END IF
      VRT = VRT - 0.75
      IF (IPR(633) == 0) THEN
        WRITE (LINE, 99995, IOSTAT = IOST) THOR(1:8), FCKM
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.75
        WRITE (LINE, 99995, IOSTAT = IOST) TVER(1:8), FOKM
        CALL PLA439 (0.0, LINE(1:26), 25, 0.35, 1, 1, VERT + 0.2, VRT)
C * CHECK FOR 'LOGLOG'
      ELSE IF (IPR(633) == 1) THEN
        IF (MODE == 0) THEN
          WRITE (LINE, 99995, IOSTAT = IOST) 'I(calc) ', FCKM
          CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
          VRT = VRT - 0.75
          WRITE (LINE, 99995, IOSTAT = IOST) 'I(obs)  ', FOKM
          CALL PLA439 (0.0, LINE(1:26), 25, 0.35, 1, 1, VERT + 0.2, VRT)
          VRT = VRT - 0.75
        ELSE
          WRITE (LINE, 99995, IOSTAT = IOST) 'I(obs)1 ', FCKM
          CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
          VRT = VRT - 0.75
          WRITE (LINE, 99995, IOSTAT = IOST) 'I(obs)2 ', FOKM
          CALL PLA439 (0.0, LINE(1:26), 25, 0.35, 1, 1, VERT + 0.2, VRT)
          VRT = VRT - 0.75
        END IF
        WRITE (LINE, 99994, IOSTAT = IOST) THOR(1:12), LOG10 (FCKM)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.75
        WRITE (LINE, 99994, IOSTAT = IOST) TVER(1:12), LOG10 (FOKM)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
      END IF
      VRT = VRT - 0.75
      IF (MODE <= 0) THEN
        N = 16
        DO I = 1, 6
          CELLA(I) = PAR(100 + I)
        END DO
        CELLA(7) = PAR(98)
        NREFF1   = NREF
        SCAL     = 1.0
      ELSE
        N = 25
      END IF
      WRITE (LINE, '(''N(refl)'', 2I9)', IOSTAT = IOST) NREFF1, NREFF2
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.75
      WRITE (LINE, '(''N(plot) '',  I8)', IOSTAT = IOST) NREF
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.75
      WRITE (LINE, '(''Scale'', 12X, F8.4)', IOSTAT = IOST) SCAL
      CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.90
      WRITE (LINE, '(''NP-Plot-CC'', 7X, F8.4)', IOSTAT = IOST) YCC
      IF (MODE > 0) WRITE (6, 99998, IOSTAT = IOST) LINE(1:75)
      CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''NP-Plot-INTERCEPT'', F8.4)', IOSTAT = IOST) YINT
      IF (MODE > 0) WRITE (6, 99998, IOSTAT = IOST) LINE(1:75)
      CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, 99993, IOSTAT = IOST) YSLOPE
      IF (MODE > 0) WRITE (6, 99998) LINE(1:75)
      CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.90
      WRITE (LINE, '(''A       '', 2F8.4)', IOSTAT = IOST)
     1   CELLA(1), CELLB(1)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''B       '', 2F8.4)', IOSTAT = IOST)
     1  CELLA(2), CELLB(2)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''C       '', 2F8.4)', IOSTAT = IOST)
     1  CELLA(3), CELLB(3)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''Alpha   '', 2F8.2)', IOSTAT = IOST)
     1  CELLA(4), CELLB(4)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''Beta    '', 2F8.2)', IOSTAT = IOST)
     1  CELLA(5), CELLB(5)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''Gamma   '', 2F8.2)', IOSTAT = IOST)
     1  CELLA(6), CELLB(6)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      VRT = VRT - 0.70
      WRITE (LINE, '(''Volume  '', 2F8.1)', IOSTAT = IOST)
     1  CELLA(7), CELLB(7)
      CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
      IF (MODE <= 0) THEN
        VRT = VRT - 0.90
        WRITE (LINE, '(''R1  (CIF)'', F7.4)', IOSTAT = IOST) PAR(173)
        CALL PLA439 (0.0, LINE(1:26), 16, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.75
        WRITE (LINE, '(''wR2 (CIF)'', F7.4)', IOSTAT = IOST) PAR(174)
        CALL PLA439 (0.0, LINE(1:26), 16, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.75
        WRITE (LINE, '(''S   (CIF)'', F7.4)', IOSTAT = IOST) PAR(299)
        CALL PLA439 (0.0, LINE(1:26), 16, 0.35, 1, 1, VERT + 0.2, VRT)
        IF (PAR(197) > 0.0) THEN
          VRT = VRT - 0.75
          WRITE (LINE, '(''R(int)   '', F7.4)', IOSTAT = IOST) PAR(197)
          CALL PLA439 (0.0, LINE(1:16), 16, 0.35, 1, 1, VERT + 0.2, VRT)
        END IF
      ELSE
        VRT = VRT - 0.90
        WRITE (LINE, '(''SPGR1'', 4X, A)', IOSTAT = IOST) SPGRA
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''SPGR2'', 4X, A)', IOSTAT = IOST) SPGRB
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.90
        WRITE (LINE, '(''R_A     '', 2F8.4)', IOSTAT = IOST)
     1    RCELLA(1), RCELLB(1)
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''R_B     '', 2F8.4)', IOSTAT = IOST)
     1    RCELLA(2), RCELLB(2)
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''R_C     '', 2F8.4)', IOSTAT = IOST)
     1    RCELLA(3), RCELLB(3)
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''R_Alpha '', 2F8.2)', IOSTAT = IOST)
     1    RCELLA(4), RCELLB(4)
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''R_Beta  '', 2F8.2)', IOSTAT = IOST)
     1    RCELLA(5), RCELLB(5)
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''R_Gamma '', 2F8.2)', IOSTAT = IOST)
     1    RCELLA(6), RCELLB(6)
        CALL PLA439 (0.0, LINE(1:N), N, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.90
        WRITE (LINE, '(''('', 3F7.3, '')'')', IOSTAT = IOST)
     1    (TRNSA(1, J), J = 1, 3)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''('', 3F7.3, '') A'')', IOSTAT = IOST)
     1    (TRNSA(2, J), J = 1, 3)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''('', 3F7.3, '')'')', IOSTAT = IOST)
     1    (TRNSA(3, J), J = 1, 3)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.90
        WRITE (LINE, '(''('', 3F7.3, '')'')', IOSTAT = IOST)
     1    (TRNSB(1, J), J = 1, 3)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''('', 3F7.3, '') B'')', IOSTAT = IOST)
     1    (TRNSB(2, J), J = 1, 3)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        VRT = VRT - 0.70
        WRITE (LINE, '(''('', 3F7.3, '')'')', IOSTAT = IOST)
     1    (TRNSB(3, J), J = 1, 3)
        CALL PLA439 (0.0, LINE(1:25), 25, 0.35, 1, 1, VERT + 0.2, VRT)
        WRITE (LINE, '(''Pearsons-CC = '', F7.4)') PAR(565)
        CALL PLA439 (0.0, LINE(1:20), 20, 0.35, 5, 1, HORS -XOR - 5.5,
     1    2.0)
      END IF
      CALL GGIP (0.0, 0.0, 0.0, -1)
      RETURN
99999 FORMAT (/, ':: Space Groups Differ: ', A, ' & ', A, /)
99998 FORMAT (':: ', A)
99996 FORMAT (I8)
99995 FORMAT (A, '-Max', 3X, F10.2)
99994 FORMAT (A, '-Max', F9.4)
99993 FORMAT ('NP-Plot-SLOPE', 4X, F8.4)
      END SUBROUTINE PLA419
 
      SUBROUTINE PLA420 (MODE)
C * PLOT I/Sig(I) versus I etc.
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE analysis
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: N
      INTEGER            :: IY
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      INTEGER            :: NTH
      INTEGER            :: MODE
      INTEGER            :: IAVMX
      INTEGER            :: IYELLOW
      REAL               :: X
      REAL               :: Y
      REAL               :: YA
      REAL               :: YB
      REAL               :: PEN
      REAL               :: FOK
      REAL               :: VRT
      REAL               :: DSH
      REAL               :: SIG
      REAL               :: XORG
      REAL               :: YORG
      REAL               :: SIGA
      REAL               :: SIGB
      REAL               :: HORS
      REAL               :: VERT
      REAL               :: FOKM
      REAL               :: TICK
      REAL               :: YUNK
      REAL               :: XIOSM
      REAL               :: TICKM
      REAL               :: TICKS
      REAL               :: VERTO
      REAL               :: SIGMX
      REAL               :: HORSO
      REAL               :: SCALHOR
      REAL               :: SCALVER
      REAL, DIMENSION(5) :: AVMX
      REAL, DIMENSION(5) :: SKALVER
C * HANDLE POOR VISIBILITY OF YELLOW ON WHITE BACKGROUND
      IF (IGBL(68) == 1 .OR. IGBL(66) == 0) THEN
        IYELLOW = 6
      ELSE
        IYELLOW = 5
      END IF
      HORS = 25.0
      VERT = 25.0
      XORG = 1.0
      YORG = 1.0
      DSH  = 0.1
C * OPEN WINDOW
      CALL GGIP (HORS, VERT, 0.0, 1)
C * OUTLINE FRAME
      CALL PLA110 (HORS, VERT, -1)
      CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL PLA110 (HORS, VERT, -1)
      IF (MODE == 2) THEN
        LINE = 'I/Sig versus Log(I) Plot - (Diederichs Plot)'
      ELSE IF (MODE == 3) THEN
        LINE = 'I/SigW versus Log(I) Plot - (Diederichs Plot)'
      ELSE IF (MODE == 4) THEN
        LINE = 'Sig & SigW versus Log(I) Plot'
      ELSE IF (MODE == 5) THEN
        LINE = 'Log(Sig) versus Log(I) Plot'
      ELSE IF (MODE == 6) THEN
        LINE = 'Sig versus Sqrt(I) Plot'//
     1         ' + POISSON Sig(I) = SQRT(I) LINE'
      ELSE IF (MODE == 7) THEN
        LINE = '<I/Sig> and <I>/<Sig> versus Theta'
        NTH  = 90
        DO I = 90, 1, -1
          IF (AVIOSIG(I, 2) > 0.0) THEN
            NTH = I
            EXIT
          END IF
        END DO
        AVMX(1) = 0.0
        AVMX(5) = 0.0
        DO I = 1, NTH
          AVMX(1) = MAX (AVMX(1), AVIOSIG(I, 1))
          AVMX(5) = MAX (AVMX(5), AVIOSIG(I, 5))
        END DO
      ENDIF
      CALL PLA439 (0.0, LINE, 60, 0.35, IYELLOW, 2, 4.5,
     1  VERT - 0.6)
      VRT = VERT - 0.2
C * REPORT TITL
      WRITE (LINE, 99993, IOSTAT = IOST) JID(1:8)
      IF (IOST == 0) THEN
        VRT = VRT - 0.45
        CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, HORS + 0.1, VRT)
      END IF
C * REPORT FVAR
      IF (PAR(74) /= 0.0) THEN
        WRITE (LINE, 99992, IOSTAT = IOST) PAR(74)
        IF (IOST == 0) THEN
          VRT = VRT - 0.45
          CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, HORS + 0.1, VRT)
        END IF
      END IF
C * REPORT EXTI
      IF (PAR(229) > 0.0) THEN
        WRITE (LINE, 99991, IOSTAT = IOST) PAR(229)
        IF (IOST == 0) THEN
          VRT = VRT - 0.45
          CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, HORS + 0.1, VRT)
        END IF
      END IF
C * REPORT SHELXL A & B WEIGHT PARAMETERS
      IF (PAR(493) >= 0.0) THEN
        DO I = 0, 5
          WRITE (LINE, 99996, IOSTAT = IOST)
     1      CHAR (ICHAR ('a') + I), PAR(493 + I)
          IF (IOST == 0) THEN
            VRT = VRT - 0.45
            CALL PLA439 (0.0, LINE, 25, 0.35, 1, 1, HORS + 0.1, VRT)
          END IF
        END DO
      END IF
C * MOVE ORIGIN
      CALL GGIP (XORG, YORG, 0.0, -3)
      HORSO = HORS - XORG
      VERTO = VERT - YORG
C * VERTICAL AND HORIZONTAL AXES
      CALL GGIP (0.0, VERTO, 0.0, 2)
      CALL GGIP (0.0, 0.0,   0.0, 3)
      CALL GGIP (HORSO, 0.0, 0.0, 2)
      VRT = VERTO - 1.5
C * REPORT DIEDERICHS PLOT & REFERENCE
      IF (MODE == 2 .OR. MODE == 3) THEN
        LINE = 'See K. Diederichs (2010). Acta Cryst., D66, 733-740'
        CALL PLA439 (0.0, LINE, 51, 0.30, 1, 1, 0.75, VRT)
        VRT = VRT - 1.0
      END IF
C * REPORT DATA SET INFO
      LINE = 'Data ............... '//FNLU16(1:KNM16)
      CALL PLA439 (0.0, LINE, KNM16 + 21, 0.30, 1, 1, 0.75, VRT)
      VRT  = VRT - 0.5
      N    = MIN (NCIF(18), 59)
      LINE = 'Device Type ........ '//CCIF(18)(1:N)
      CALL PLA439 (0.0, LINE, N + 21, 0.30, 1, 1, 0.75, VRT)
      VRT  = VRT - 0.5
      N    = MIN (NCIF(20), 59)
      LINE = 'Data Collection .... '//CCIF(20)(1:N)
      CALL PLA439 (0.0, LINE, N + 21, 0.30, 1, 1, 0.75, VRT)
      VRT  = VRT - 0.5
      N    = MIN (NCIF(21), 59)
      LINE = 'Data Reduction ..... '//CCIF(21)(1:N)
      CALL PLA439 (0.0, LINE, N + 21, 0.30, 1, 1, 0.75, VRT)
      VRT  = VRT - 0.5
      N    = MIN (NCIF(19), 59)
      LINE = 'Absorb Details ..... '//CCIF(19)(1:N)
      CALL PLA439 (0.0, LINE, N + 21, 0.30, 1, 1, 0.75, VRT)
      VRT  = VRT - 0.5
      N    = MIN (NCIF(22), 59)
      LINE = 'Structure Refinement '//CCIF(22)(1:N)
      CALL PLA439 (0.0, LINE, N + 21, 0.30, 1, 1, 0.75, VRT)
      IF (MODE == 4 .OR. MODE == 5) THEN
        VRT  = VRT - 1.0
        LINE = 'Yellow Dots      = Sig(I)'
        CALL PLA439 (0.0, LINE, 25, 0.30, 1, 1, 0.75, VRT)
        CALL PLA439 (0.0, LINE, 11, 0.30, 5 + IGBL(68), 1, 0.75, VRT)
        VRT  = VRT - 0.5
        LINE = 'White/Black Dots = SigW(I)'
        CALL PLA439 (0.0, LINE, 26, 0.30, 1, 1, 0.75, VRT)
      END IF
C * <I/sigma> AND <I>/<sigma(I> VERSUS THETA PLOT
      VRT = VRT - 0.5
      IF (MODE == 7) THEN
        SCALHOR = VERTO / NTH
        DO J = 1, 5, 4
          SKALVER(J) = (VERTO - 6.0) / AVMX(J)
          IF (J == 1) THEN
            PEN = 1.0
          ELSE
            PEN = FLOAT (IYELLOW)
          END IF
          IY  = 0
          CALL GGIP (0.0, PEN, 0.0, 0)
          CALL GGIP (0.0, 0.0, 0.0, 3)
          DO I = 1, NTH
            X  = I * SCALHOR
            Y  = AVIOSIG(I, J) * SKALVER(J)
            IF (Y == 0.0) CYCLE
            IF (IY > 0) CALL GGIP (X, Y, 0.0, 2)
C * PLOT MARKER
            CALL PLA411 (X, Y, DSH, -1.0)
            CALL GGIP (X, Y, 0.0, 3)
            IF (Y > 0.0) IY = 1
          END DO
        END DO
C * PLOT TWO-SIGMA NOISE LEVEL
        Y = 2.0 * SKALVER(1)
        CALL GGIP (0.0, 2.0, 0.0, 0)
        CALL GGIP (0.0,   Y, 0.0, 3)
        CALL GGIP (VERTO, Y, 0.0, 2)
        LINE(1:21) = 'Two Sigma Noise Level'
        CALL PLA439 (0.0, LINE, 21, 0.3, 1, 1, 1.0, Y + 0.2)
C * HORIZONTAL IICKS
        CALL GGIP (0.0, 1.0, 0.0, 0)
        DO I = 5, NTH, 5
          X = I * SCALHOR
          Y = 0.0
          CALL GGIP (X, Y,       0.0, 3)
          CALL GGIP (X, Y - 0.3, 0.0, 2)
          WRITE (LINE(1:8), 99999, IOSTAT = IOST) I
          CALL PLA439 (0.0, LINE, 8, 0.25, 1, 1, X - 1.8, -0.3)
        END DO
        CALL PLA439 (0.0, 'Theta', 5, 0.3, 1, 1, VERTO - 1.3, - 0.8)
C * VERTICAL TICKS
        DO J = 1, 5, 4
          IF (J == 1) THEN
            CALL GGIP (0.0, 1.0, 0.0, 0)
          ELSE
            CALL GGIP (0.0, FLOAT (IYELLOW), 0.0, 0)
          END IF
 
          IAVMX = INT (AVMX(J) + 1)
          Y     = IAVMX * SKALVER(J)
          IF (J == 1) THEN
            X = 0.0
            LINE(1:11) = '<I/Sig>  '
            CALL PLA439 (0.0, LINE, 9, 0.4, J, 1, X + 0.1, Y + 1.0)
          ELSE
            X = VERTO
            LINE(1:20) = '<I>/<Sig>   R(sig)'
            CALL PLA439 (0.0, LINE, 18, 0.4, IYELLOW, 1, X + 0.1,
     1        Y + 1.0)
          END IF
          DO I = 10, IAVMX, 10
            Y = I * SKALVER(J)
            CALL GGIP (X,       Y, 0.0, 3)
            CALL GGIP (X + 0.3, Y, 0.0, 2)
            WRITE (LINE, 99990, IOSTAT = IOST) I, 1.0 / FLOAT (I)
            IF (J == 1) THEN
              CALL PLA439 (0.0, LINE,  3, 0.25, J, 1, X + 0.4, Y)
            ELSE
              CALL PLA439 (0.0, LINE, 23, 0.25, IYELLOW, 1, X + 0.4, Y)
            END IF
          END DO
        END DO
        CALL GGIP (0.0, 0.0, 0.0, -1)
        RETURN
      ELSE
        NADR  = 0
        FOKM  = 0.0
        XIOSM = 0.0
        SIGMX = 0.0
        N     = 0
        DO I = 1, NREF
          FOK = VOID(NADR + 4)
          SIG = 0.0
C * DETERMINE WHETHER TO SCALE USING  SIG(I) = 6 OR SIGW(I) = 12
          IF (MODE == 2) THEN
            SIG = VOID(NADR + 6)
          ELSE IF (MODE == 3) THEN
            SIG = VOID(NADR + 12)
          ELSE IF (MODE == 4) THEN
            SIG = VOID(NADR + 6)
          ELSE IF (MODE == 5) THEN
            SIG = VOID(NADR + 12)
          ELSE IF (MODE == 6) THEN
            SIG = VOID(NADR + 6)
          END IF
          IF (SIG > 0.0) THEN
            IF (MODE == 4) THEN
              SIGMX = MAX (SIGMX, SIG)
              FOKM  = MAX (FOKM, FOK)
            ELSE IF (MODE == 5) THEN
              SIGMX = MAX (SIGMX, SIG)
              FOKM  = MAX (FOKM, FOK)
            ELSE IF (MODE == 6) THEN
              SIGMX = MAX (SIGMX, SIG)
              FOKM  = MAX (FOKM, FOK)
            ELSE IF (MODE == 2 .OR. MODE == 3) THEN
              IF (FOK / SIG < PAR(485)) THEN
                XIOSM = MAX (XIOSM, FOK / SIG)
                FOKM  = MAX (FOKM, FOK)
              ELSE
                N = N + 1
                IF (N == 1) THEN
                  WRITE (LINE, 99994, IOSTAT = IOST) PAR(485)
                  VRT = VRT - 0.32
                  CALL PLA439 (0.0, LINE, 56, 0.25, 5, 1, 0.75, VRT)
                  VRT = VRT - 0.03
                END IF
                IF (N <= 50) THEN
                  IF (N == 50) THEN
                    WRITE (LINE, 99997, IOSTAT = IOST)
                  ELSE
                    IH = NINT (VOID(NADR + 1))
                    IK = NINT (VOID(NADR + 2))
                    IL = NINT (VOID(NADR + 3))
                    WRITE (LINE, 99998, IOSTAT = IOST)
     1                IH, IK, IL, FOK, SIG, FOK / SIG
                  END IF
                  VRT = VRT - 0.33
                  CALL PLA439 (0.0, LINE, 37, 0.25, 1, 1, 0.75, VRT)
                END IF
              END IF
            END IF
          END IF
          NADR = NADR + NREC
        END DO
      END IF
      IF (MODE == 6) THEN
        SCALHOR = (HORSO - 0.5) / SQRT (FOKM)
      ELSE
        SCALHOR = HORSO / (FLOAT (INT (LOG10 (FOKM) + 1)))
      END IF
      IF (MODE == 2 .OR. MODE == 3) THEN
        SCALVER = (VERT - YORG - 1.0) /
     1    MIN ((INT (XIOSM / 10.0) + 1) * 10.0, PAR(485))
      ELSE IF (MODE == 4) THEN
        SCALVER = 1.25 * (VERT - YORG - 1.0) / SIGMX
      ELSE IF (MODE == 5) THEN
        SCALVER = (VERT - YORG - 1.0) / (LOG10 (SIGMX) + 1.0)
      ELSE IF (MODE == 6) THEN
        SCALVER = (VERT - YORG - 1.0) / SIGMX
      END IF
      TICK = 0.0
      IF (MODE == 7) THEN
      ELSE IF (MODE == 6) THEN
        CALL GGIP (0.0, 0.0, 0.0, 3)
        X = SQRT (FOKM)
C * USE FVAR VALUE TO SCALE TO ACTUAL SIG(I) OF EMBEDDED HKL
        IF (PAR(74) /= 0.0) THEN
          Y = X * SCALVER / PAR(74)
        ELSE
          Y = X * SCALVER
        END IF
        X = X * SCALHOR
        IF (Y > 23.0) THEN
          YUNK = X / Y
          Y = 23.0
          X = Y * YUNK
        END IF
        CALL GGIP (X, Y, 0.0, 2)
        CALL GGIP (0.0, 0.0, 0.0, 3)
      ELSE
        IF (SCALHOR < 0.0) THEN
          CALL GGIP (0.0, 0.0, 0.0, -1)
          RETURN
        END IF
        DO WHILE (TICK * SCALHOR < HORSO + 0.001)
          N    = 10 ** (NINT (TICK))
          X    = TICK * SCALHOR
          TICK = TICK + 1.0
          CALL GGIP (X,  0.0, 0.0, 3)
          CALL GGIP (X, -0.3, 0.0, 2)
          WRITE (LINE(1:8), 99999, IOSTAT = IOST) N
          CALL PLA439 (0.0,  LINE, 8, 0.25, 1, 1, X - 1.8, -0.3)
        END DO
      END IF
      IF (MODE /= 4 .AND. MODE /= 6 .AND. MODE .NE. 7) THEN
        TICKM = (VERT - YORG) / SCALVER
        IF (TICKM < 16) THEN
          TICKS = 1.0
        ELSE IF (TICKM < 160.0) THEN
          TICKS = 10.0
        ELSE
          TICKS = 50.0
        END IF
        TICK = 0.0
        DO WHILE ((TICK + TICKS) * SCALVER < VERT - YORG)
          TICK = TICK + TICKS
          N    = NINT (TICK)
          X    = TICK * SCALVER
          WRITE (LINE(1:8), 99999, IOSTAT = IOST) N
          CALL GGIP (0.0, X, 0.0, 3)
          CALL GGIP (0.3, X, 0.0, 2)
          CALL PLA439 (90.0,  LINE, 8, 0.25, 1, 1, 0.4, X - 1.8)
        END DO
      END IF
      IF (MODE == 6) THEN
        CALL PLA439 (90.0, 'Sig', 3, 0.35, 1, 1, -0.2 , VERTO - 2.0)
        CALL PLA439 (0.0,  'sqrt(I)', 7, 0.35, 1, 1, HORSO - 2.2, -0.55)
      END IF
      PEN = FLOAT (IYELLOW)
      NADR = 0
      DO I = 1, NREF
        FOK  = VOID(NADR + 4)
        SIGA = VOID(NADR + 6)
        SIGB = VOID(NADR + 12)
        IF (MODE == 2) THEN
          SIG = SIGA
        ELSE IF (MODE == 3) THEN
          SIG = SIGB
        ELSE IF (MODE == 4) THEN
          SIG = SIGA
        ELSE IF (MODE == 5) THEN
        ELSE IF (MODE == 6) THEN
          SIG = SIGA
        END IF
        IF (FOK >= 1.0 .AND. SIG > 0.0) THEN
          IF (MODE == 2 .OR. MODE == 3) THEN
            X = LOG10 (FOK) * SCALHOR
            IF (X >= 0.0) THEN
              Y = FOK / SIG
              IF (Y < PAR(485)) THEN
                Y = Y * SCALVER
C * PLOT MARKER
                CALL PLA411 (X, Y, DSH, PEN)
              END IF
            END IF
C * SIGMA & SIGMAW VERSUS LOG10(I)
C * LOG10(SIGMA) & LOG10(SIGMAW) VERSUS LOG10(I)
          ELSE IF (MODE == 4 .OR. MODE == 5) THEN
            X = LOG10 (FOK) * SCALHOR
            IF (X >= 0.0) THEN
              IF (MODE == 4) THEN
                YA = SIGA * SCALVER
                YB = SIGB * SCALVER
              ELSE
                YA = (LOG10 (SIGA) + 1.0) * SCALVER
                YB = (LOG10 (SIGB) + 1.0) * SCALVER
              ENDIF
C * PLOT MARKER
              CALL PLA411 (X, YA, DSH, PEN)
C * PLOT MARKER
              CALL PLA411 (X, YB, DSH, 1.0)
            END IF
C * SIGMA(I) VERSUS SQRT(I)
          ELSE IF (MODE == 6) THEN
            IF (FOK > 0.0) THEN
              X  = SQRT (FOK) * SCALHOR
              YA = SIGA * SCALVER
              YB = SIGB * SCALVER
C * PLOT MARKER
              CALL PLA411 (X, YA, DSH, PEN)
C * PLOT MARKER
            END IF
          END IF
        END IF
        NADR = NADR + NREC
      END DO
      CALL GGIP (0.0, 0.0, 0.0, -1)
      RETURN
99999 FORMAT (I8)
99998 FORMAT (3I4, F9.1, 2F8.1)
99997 FORMAT (5X, '... etc ...')
99996 FORMAT ('SHELXL-weight-', A, F10.3)
99994 FORMAT ('   H   K   L     Iobs SigIobs  I/SigI',
     1  2X, '[I/SigI > ', F6.1, ']')
99993 FORMAT ('TITL', 13X, A)
99992 FORMAT ('FVAR', 11X,  F10.4)
99991 FORMAT ('EXTI', 11X,  F10.5)
99990 FORMAT (I3, 10X, F10.3)
      END SUBROUTINE PLA420
 
      MODULE bijvoet
      SAVE
      INTEGER          :: NFR
      INTEGER          :: NFH
      INTEGER          :: NSTP
      INTEGER          :: NSPT
      INTEGER          :: NSPP
      INTEGER          :: NSPM
      INTEGER          :: NPLS
      INTEGER          :: NMIN
      INTEGER          :: IPR615
      INTEGER          :: IPR616
      REAL             :: RCO
      REAL             :: RCT
      REAL             :: RCN
      REAL             :: DDM
      REAL             :: DDP
      REAL             :: SUMX
      REAL             :: SUMW
      REAL             :: PAR435
      REAL             :: PAR436
      REAL             :: FCKSLM
      REAL             :: FODIFMAX
      REAL             :: BIJVOETMAX
      DOUBLE PRECISION :: XG
      DOUBLE PRECISION :: XG0
      DOUBLE PRECISION :: XG1
      DOUBLE PRECISION :: XG2
      DOUBLE PRECISION :: DDIF
      DOUBLE PRECISION :: XPLLL
      DOUBLE PRECISION :: XMNLL
      DOUBLE PRECISION :: XPLL2
      DOUBLE PRECISION :: XTWLL
      DOUBLE PRECISION :: XSMLL
      DOUBLE PRECISION :: DPDATM
      DOUBLE PRECISION :: DPVALUE
      END MODULE bijvoet
 
      SUBROUTINE PLA421
C * Analysis of Bijvoet (Friedel) Pair Differences (1)
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE cggt
      USE reflex
      USE bijvoet
      USE analysis
      USE sgxyz
      IMPLICIT NONE
      INTEGER                                     :: I
      INTEGER                                     :: J
      INTEGER                                     :: K
      INTEGER                                     :: M
      INTEGER                                     :: N
      INTEGER                                     :: KL
      INTEGER                                     :: KN
      INTEGER                                     :: LU
      INTEGER                                     :: NS
      INTEGER                                     :: NF
      INTEGER                                     :: IH
      INTEGER                                     :: IK
      INTEGER                                     :: IL
      INTEGER                                     :: IH1
      INTEGER                                     :: IH2
      INTEGER                                     :: IK1
      INTEGER                                     :: IK2
      INTEGER                                     :: IL1
      INTEGER                                     :: IL2
      INTEGER                                     :: IMM
      INTEGER                                     :: MPK
      INTEGER                                     :: MPL
      INTEGER                                     :: NFP
      INTEGER                                     :: NSP1
      INTEGER                                     :: MHKL
      INTEGER                                     :: MHKLH
      INTEGER                                     :: IADR1
      INTEGER                                     :: IBPRM
      INTEGER                                     :: IHKLP
      INTEGER                                     :: ICRIT1
      INTEGER                                     :: NROUTL
      INTEGER                                     :: ISTATUS
      INTEGER                                     :: NOUTLIST
      INTEGER,      ALLOCATABLE, DIMENSION(:,:)   :: IBPR
      REAL                                        :: YK
      REAL                                        :: WP
      REAL                                        :: TH
      REAL                                        :: XNU
      REAL                                        :: SIG1
      REAL                                        :: SIG2
      REAL                                        :: STEP
      REAL                                        :: SIGM
      REAL                                        :: THMX
      REAL                                        :: XMXP
      REAL                                        :: BDIF
      REAL                                        :: BSUM
      REAL                                        :: CHIN
      REAL                                        :: CHIT
      REAL                                        :: FCK1
      REAL                                        :: FCK2
      REAL                                        :: FCKD
      REAL                                        :: FCKP
      REAL                                        :: FCKS
      REAL                                        :: FOK1
      REAL                                        :: FOK2
      REAL                                        :: FOKD
      REAL                                        :: FOKP
      REAL                                        :: FOKS
      REAL                                        :: PBOT
      REAL                                        :: PTOP
      REAL                                        :: RASD
      REAL                                        :: RASN
      REAL                                        :: YUNK
      REAL                                        :: YMXP
      REAL                                        :: XMAX
      REAL                                        :: YMAX
      REAL                                        :: RDFD
      REAL                                        :: RDFN
      REAL                                        :: SIG1K
      REAL                                        :: SIG2K
      REAL                                        :: PSUMW
      REAL                                        :: DIFFS
      REAL                                        :: PSUMWX
      REAL                                        :: PSUMWY
      REAL                                        :: PSUMWXK
      REAL                                        :: PSUMWXY
      REAL                                        :: PARSONSMAX
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DPDAT
C * CHECK FOR FCF VALID MODE
      IF (IPR(734) == 1) RETURN
C * CHECK FOR UNIQUE SET OF REFLECTIONS (INCLUDING THETA-MAX TOLERANCE)
C * CHECK FOR TWINNING
      IF (IPR(619) == 0) THEN
        IF (NREF > IPR(559) + IPR(560) + 10) THEN
C * _996 - ALERT
          CALL PLA236 (996, 0, -999.0, 1.0, ' ', ' ')
          WRITE (LU6, 99998)
          RETURN
        END IF
      END IF
      ISTATUS = 0
      IBPRM   = (NREF + 1)
      ALLOCATE (IBPR(3, IBPRM), DPDAT(401), STAT = ISTATUS)
C * MODE     = -1 (Standard Listing Mode on Terminal)
C * IPR(594) = 0 - FCALC FROM FCF
C *          = 1 - FCALC FROM CIF
C * NO BIJVOET ANALYSIS FOR NEUTRON DATA
      IF (IPR(493) > 6) THEN
        WRITE (LU6, 99991, IOSTAT = IOST)
C * NO BIJVOET PAIR ANALYSIS FOR CENTROSYMMETRIC STRUCTURE
      ELSE IF (IPR(275) == 2) THEN
        IF (IGBL(36) == 1 .AND. IPR(594) == 1)
     1    WRITE (LU6, 99999, IOSTAT = IOST)
C * CHECK MEMORY ALLOCATE STATUS
      ELSE IF (ISTATUS /= 0) THEN
        WRITE (LU6, 99990)
C * BIJVOET PAIR ANALYSIS
      ELSE
C * DEFAULT = s.u.-bar
        IPR(634) = 1
C * DEFAULT = HKL-Display
        IPR(636) = 1
C * IPR(613) - (0/1) Gaussian/Student-t
C * IPR(593) - (0/1) PP Slope Correction
C * IPR(617) - (0/n) Recycle Student-t
C * IPR(594) - (0/1) FCF/CIF BASED Fcalc data
C * PAR(488) - Nu-Value
 
C * CHECK MODE (=1)
        IF (IGBL(36) == 1) THEN
          LU = LU13
        ELSE
          LU = LU6
        END IF
        NADR = NREF * NREC
C * REFLECTION DATA FOR NREF REFLECTIONS ARE ALREADY STORED IN LOW VOID
C *  ARRAY MEMORY
C * CREATE ADDRESS ARRAY TO REFLECTION DATA IN HIGH VOID MEMORY
C * DETERMINE PACKING CONSTANTS AND ADDRESSES
        MPH   = 2 * HMAX + 1
        MPK   = 2 * KMAX + 1
        MPL   = 2 * LMAX + 1
        MHK   = MPH * MPK
        MHKL  = MPL * MHK
        MHKLH = (MHKL - 1) / 2
C * CALCULATE ADDRESS OF 0,0,0 REFLECTION
        IADR  = NVDR - MHKLH
        IADR1 = NVDR - MHKL
C * SET DEFAULTS IN HKL-ADDRESS ARRAY
        CALL GEN074 (VOID, IADR1 + 1, NVDR, 0.0)
C * LOAD POINTERS TO DATA IN HKL-ADDRESS ARRAY
C * ONLY THE LATEST REFERENCE IS KEPT
        DO I = 1, NREF
          J = (I - 1) * NREC
          DO K = 1, 3
            SGZ(K) = VOID(J + K)
          END DO
C * LOOP OVER SYMMETRY RELATED REFLECTIONS (EXCLUDING BRAVAIS)
          DO NS = 1, NSYMH
            CALL SGSM (5, LINE, SGZ, NS, LU6, IERR)
            K = NINT (SGZ(9)) * MHK + NINT (SGZ(8)) * MPH
     1        + NINT (SGZ(7))
            VOID(IADR + K) = I
          END DO
        END DO
C * OUTER  LOOP
        DO
C * TOGGLE DETERMINING THE LOCATION OF FC FROM FCF (= 0) OR CIF (=1)
          ICALT = 11 - IPR(594) * 6
C * DETERMINE MAXIMUM CALCULATED BIJVOET AND PARSONS PAIR DIFFERENCE
          IPR(706)   = 0
          BIJVOETMAX = 0.0
          PARSONSMAX = 0.0
          PAR(510)   = 999999.0
          PAR(512)   = 0.0
          DO I = 1, NREF
            J  = (I - 1) * NREC
            IH = NINT (VOID(J + 1))
            IK = NINT (VOID(J + 2))
            IL = NINT (VOID(J + 3))
            K  = IL * MHK + IK * MPH + IH
            N  = NINT (VOID(IADR - K))
C * CHECK FOR 'CENTRO PAIRS'
            IF (N == I) THEN
              IPR(706) = IPR(706) + 1
            ELSE IF (N > I) THEN
              M    = (N - 1) * NREC
              BDIF = ABS (VOID(J + ICALT) - VOID(M + ICALT))
              BSUM = VOID(J + ICALT) + VOID(M + ICALT)
              BIJVOETMAX = MAX (BDIF, BIJVOETMAX)
              IF (BSUM /= 0.0) THEN
                PARSONSMAX = MAX (BDIF / BSUM, PARSONSMAX)
              END IF
            END IF
          END DO
          NOUTLIST = 0
C * UPDATE LOOP ENTRY POINT
   10     IPR(668) = 0
          NFP      = 0
          NF       = 0
          NFR      = 0
          NFH      = 0
          NPLS     = 0
          NMIN     = 0
          STEP     = PAR(515)
          NSP1     = NINT (1.0 / STEP)
          NSTP     = 10 * NSP1 + 1
          NSPT     = 5  * NSP1 + 1
          NSPM     = NSPT - NSP1
          NSPP     = NSPT + NSP1
          DO I = 1, 401
            DPDAT(I) = 0.0D+0
          END DO
          CALL PLA262 (0)
C * OUTLIER HANDLING
          IF (IPR(611) == 0) THEN
            FODIFMAX = 99999.99
          ELSE
            FODIFMAX = IPR(611) * BIJVOETMAX
          END IF
C * TEST FOR STUDENT-T (=1)
          IF (IPR(613) == 1) THEN
C * NU VALUE FOR STUDENT T
            XNU = PAR(487)
          ELSE
            XNU = -1.0
          END IF
          NROUTL  = 0
          RASN    = 0.0
          RASD    = 0.0
          RDFN    = 0.0
          RDFD    = 0.0
          CHIT    = 0.0
          CHIN    = 0.0
          PSUMW   = 0.0
          PSUMWXY = 0.0
          PSUMWX  = 0.0
          PSUMWY  = 0.0
          PSUMWXK = 0.0
          DO I = 1, NREF
            IMM   = (I - 1) * NREC
            IH1   = NINT (VOID(IMM + 1))
            IK1   = NINT (VOID(IMM + 2))
            IL1   = NINT (VOID(IMM + 3))
            FOK1  = VOID(IMM + 4)
            FCK1  = VOID(IMM + ICALT)
            SIG1  = VOID(IMM + 6)
            TH    = VOID(IMM + 7)
            IHKLP = IL1 * MHK + IK1 * MPH + IH1
            N     = NINT (VOID(IADR - IHKLP))
            IF (N > I) THEN
C * COUNT # OF FRIEDEL PAIRS
              IPR(668) = IPR(668) + 1
              IF (IPR(617) > 1) THEN
                IF (IPR(668) == 1) THEN
                  IF (IPR(594) == 1) THEN
                    IF (IGBL(36) == 1) WRITE (LU, 99996, IOSTAT = IOST)
                    WRITE (LU, 99989, IOSTAT = IOST) 'CIF'
                  ELSE
                    WRITE (LU, 99989, IOSTAT = IOST) 'FCF'
                  END IF
                END IF
              END IF
              M     = (N - 1) * NREC
              IH2   = NINT (VOID(M + 1))
              IK2   = NINT (VOID(M + 2))
              IL2   = NINT (VOID(M + 3))
              FOK2  = VOID(M + 4)
              FCK2  = VOID(M + ICALT)
              SIG2  = VOID(M + 6)
              FOKD  = FOK1 - FOK2
              FCKD  = FCK1 - FCK2
              FOKS  = FOK1 + FOK2
              FCKS  = FCK1 + FCK2
              SIG1K = SIG1**2
              SIG2K = SIG2**2
              SIGM  = SQRT (SIG1K + SIG2K)
C * COLLECT DATA FOR RA & RD
              RDFN  = RDFN + ABS (FOKD - FCKD)
              RDFD  = RDFD + ABS (FOKD)
              RASN  = RASN + ABS (FOKS - FCKS)
              RASD  = RASD + ABS (FOKS)
              CHIT  = CHIT + ABS (FOKD) ** 2
              CHIN  = CHIN + ABS (FOKS) / 2.0
C * COLLECT DATA FOR PARSONS Z
              IF (FOKS /= 0.0 .AND. FCKS /= 0.0 .AND.
     1            ABS (FCKD) > 0.001) THEN
C * EXCLUDE OUTLIERS
                IF (SIG1 > 0.0 .AND. SIG2 > 0.0) THEN
                  IF (FOK1 > 3.0 * SIG1 .AND. FOK2 > 3.0 * SIG2)
     1              THEN
                    NFP     = NFP     + 1
                    FOKP    = FOKD / FOKS
                    FCKP    = FCKD / FCKS
                    WP      = 1.0 / ((2.0 * FOK2 * SIG1 / FOKS**2)**2 +
     1                               (2.0 * FOK1 * SIG2 / FOKS**2)**2)
                    PSUMW   = PSUMW   + WP
                    PSUMWX  = PSUMWX  + WP * FCKP
                    PSUMWY  = PSUMWY  + WP * FOKP
                    PSUMWXY = PSUMWXY + WP * FOKP * FCKP
                    PSUMWXK = PSUMWXK + WP * FCKP**2
                  END IF
                END IF
              END IF
              IF (ABS (FOKD) > FODIFMAX .OR. ABS (FCKD) < 0.001)
     1          THEN
                IF (NOUTLIST == 0) THEN
                  NROUTL = NROUTL + 1
                  IF (IPR(617) > 1) THEN
                    IF (NROUTL == 1) THEN
                      WRITE (LU, 99992, IOSTAT = IOST) FODIFMAX
                        IF (IGBL(36) == 0) THEN
                        WRITE (LU7, 99992, IOSTAT = IOST) FODIFMAX
                        CALL PLA262 (5)
                      END IF
                    END IF
                    IF (NROUTL < 51) THEN
                      IF (IPR(746) < 8) THEN
                        WRITE (LU, 99994, IOSTAT = IOST) NROUTL, IH1,
     1                    IK1, IL1, FOK1, IH2, IK2, IL2, FOK2, FOKD,
     2                    FCKD, SIGM
                      ELSE
                        WRITE (LU, 99993, IOSTAT = IOST) NROUTL, IH1,
     1                    IK1, IL1, INT (FOK1), IH2, IK2, IL2,
     2                    INT (FOK2), INT (FOKD), INT (FCKD), INT (SIGM)
                      END IF
                      IF (IGBL(36) == 0) THEN
                        IF (IPR(746) < 8) THEN
                          WRITE (LU7, 99994, IOSTAT = IOST) NROUTL, IH1,
     1                    IK1, IL1, FOK1, IH2, IK2, IL2, FOK2, FOKD,
     2                    FCKD, SIGM
                        ELSE
                          WRITE (LU7, 99993, IOSTAT = IOST) NROUTL, IH1,
     1                      IK1, IL1, INT (FOK1), IH2, IK2, IL2,
     2                      INT (FOK2), INT (FOKD), INT (FCKD), SIGM
                        END IF
                        CALL PLA262 (1)
                      END IF
                    ELSE IF (NROUTL == 51) THEN
                      WRITE (LU, 99995, IOSTAT = IOST)
                      IF (IGBL(36) == 0) THEN
                        WRITE (LU7, 99995, IOSTAT = IOST)
                        CALL PLA262 (3)
                      END IF
                    END IF
                  END IF
                END IF
                ICRIT1 = 0
              ELSE
                ICRIT1 = 1
C * COLLECT BIJVOET PAIRS FOR SORTING & DISPLAY
                IF (ABS (FCK1 - FCK2) > PAR(452) * SIGM) THEN
                  NF          = NF + 1
                  SIGM        = MAX (SIGM, 0.01)
                  IBPR(1, NF) = 100000000
     1                        - NINT (100.0 * ABS (FCK1 - FCK2) / SIGM)
                  IBPR(2, NF) = I
                  IBPR(3, NF) = N
                END IF
              END IF
C * COLLECT PROBABILITY DISTRIBUTION DATA FOR HOOFT (SU)
              IF (TH >= PAR(509)) THEN
                PAR(510) = MIN (TH, PAR(510))
                PAR(512) = MAX (TH, PAR(512))
                NFH      = NFH + 1
                DO J = 1, NSTP
                  YK = (J - NSPT) * STEP
                  DIFFS = ((YK * FCKD - FOKD) / SIGM)**2
C * CHECK FOR STUDENT-T NU VALUE
                  IF (XNU < 0.0) THEN
C * TEST FOR OUTLIER (= 0)
                    IF (ICRIT1 == 0) THEN
                      DPVALUE = 0.0D+0
                    ELSE
                      DPVALUE = - DBLE (DIFFS / 2.0)
                    END IF
                  ELSE
                    DPVALUE = - DLOG (DBLE (1.0 + DIFFS / XNU))
     1                        * DBLE (((XNU + 1.0) / 2.0))
                  END IF
                  DPDAT(J) = DPDAT(J) + DPVALUE
                END DO
              END IF
            END IF
          END DO
C * SELECTED # OF FRIEDEL PAIRS
          IPR(707) = NF
C * SAVE Parsons z data for CIF or RES Based SF ONLY
          IF (IPR(594) == 1 .OR. IABS (IGBL(8)) == 2) THEN
            IF (NFP > 0) THEN
              PTOP     = PSUMW * PSUMWXY - PSUMWX * PSUMWY
              PBOT     = PSUMW * PSUMWXK - PSUMWX**2
              PAR(503) = (1.0 - (PTOP / PBOT)) / 2.0
              PAR(504) = SQRT (PSUMW / PBOT) * 0.5
              CALL GEN041 (PAR(503), PAR(504), IPR(669), 3, IPR(670),
     1                     IPR(68))
            END IF
            IPR(750) = NFP
          END IF
          IF (IPR(668) > 0 .AND. CHIN > 0.0) THEN
            PAR(491) = 10000.0 * SQRT (CHIT / IPR(668)) /
     1        (CHIN / IPR(668))
          END IF
C * CHECK FOR NON-ZERO NUMBER OF SELECTED PAIRS
          IF (IPR(707) < 3) THEN
            IF (PAR(452) > 0.0) THEN
              PAR(452) = 0.0
              NOUTLIST = 1
              GO TO 10
            END IF
          END IF
          SUMX   = 0.0
          SUMW   = 0.0
          XMAX   = 0.0
          YMAX   = 0.0
          THMX   = 0.0
          XMXP   = 0.0
          XMXP   = 0.0
          YMXP   = 0.0
          YMXP   = 0.0
          RCT    = 0.0
          RCN    = 0.0
          FCKSLM = 0.0
          DDP    = -999999.0
          DDM    =  999999.0
          IF (IPR(707) > 0 .AND. RDFD /= 0.0 .AND. RASD /= 0)
     1      THEN
            PAR(489) = RASN / RASD
            PAR(490) = RDFN / RDFD
C * SET MENU
            IGBL(6) = 29
            CALL PLA426 (IBPR, XMAX, YMAX, THMX, XMXP, YMXP, LU)
            CALL PLA425 (DPDAT, LU)
          ELSE
C * NO BIJVOET PAIRS !
            IF (IPR(594) == 1) THEN
              CALL PLA015 (0, 58)
              WRITE (LU, 99988, IOSTAT = IOST)
C * TEST FOR FLACK PARAMETER VALUE GIVEN
C * ALERT _914
              IF (PAR(433) < 99999.0)
     1          CALL PLA236 (914, 0, 1.0, 1.0, ' ', ' ')
            ELSE
              WRITE (LU, 99997, IOSTAT = IOST)
            END IF
            EXIT
          END IF
 
C * PROBABILITY PLOT
          CALL PLA424
          IF (IPR(617) == 2) THEN
             GO TO 10
          END IF
C * SCATTER PLOT DISPLAY
          IF (IPR(707) > 0 .AND. IGBL(36) == 0) THEN
C * TEST FOR BIJVOET-DIFFERENCE/PARSONS-RATIO
   20       IF (IPR(635) == 0) THEN
              IF (XMAX /= 0.0 .AND. YMAX /= 0.0)
     1         CALL PLA422 (IBPR, XMAX, YMAX, THMX)
            ELSE
              IF (XMXP /= 0.0 .AND. YMXP /= 0.0)
     1          CALL PLA422 (IBPR, XMXP, YMXP, THMX)
            END IF
C * WHAT NEXT ?
C * CHECK FOR '-B' OPTION
   30       IF (IGBL(3) /= 46) THEN
C * WHAT NEXT ?
              CALL PLA012 (0, 1)
              CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7,
     1                     NP17)
              SELECT CASE (IFL(1)(1:6))
                CASE ('END   ', 'EXIT  ')
                EXIT
C * CHANGE SELECT CRITERIUM
                CASE ('SELECT')
                  GO TO 10
C * CHANGE NU CRITERIUM
                CASE ('NUVAL ', 'NUVALU')
                  IPR(617) = 0
                  IF (KN > 0) PAR(488) = FN(1)
                  GO TO 10
C * CHANGE SIGMA DELTA > SIGMA CRITERIUM
                CASE ('SIGMA ')
                  GO TO 10
C * APPLY SLOPE
                CASE ('SLOPE ')
                  GO TO 10
C * FCF/CIF SWITCH
                CASE ('FROM  ')
                  CYCLE
C * WGHT
                CASE ('WGHT  ')
                  IPR(621) = 0
                  GO TO 10
C * SWITCH
                CASE ('SWITCH')
                  IPR(617) = 1
                  GO TO 10
C * NPP
                CASE ('NPP   ')
                  CALL PLA204
                  IF (IPR(621) == 0) IPR(621) = 1
                  GO TO 30
C * SET
                CASE ('SET   ')
                  IF (IFL(2)(1:3) == 'IPR') THEN
                    IPR(656) = NINT (FN(2))
                    CALL GGIP (0.0, 0.0, 0.0, -1)
                    GO TO 20
                  END IF
C * (SCATTER) PLOT
                CASE DEFAULT
                  IPR(656) = 0
                  GO TO 20
              END SELECT
            END IF
          ELSE
            EXIT
          END IF
        END DO
C * CHECK FOR VALID FLACK PARAMETER VALUE
        IF (PAR(433) < 999999.0 .AND. PAR(435) < 999999.0) THEN
          YUNK = ABS(PAR(433) - PAR(435))
C * REPORT LARGE DIFFERENCE BETWEEN FLACK x AND HOOFT y VALUES
C * ALERT _916
          IF (YUNK > 0.10) THEN
            CALL PLA236 (916, 2, -999.0, YUNK, ' ', ' ')
          END IF
        END IF
        DEALLOCATE (IBPR, DPDAT)
      END IF
      RETURN
99999 FORMAT (/, ':: No Bijvoet Pair Analysis for Centrosymmetric',
     1        ' Structure')
99998 FORMAT (/, ':: No Bijvoet Analysis: # entries in FCF > ',
     1        '# unique reflections', /)
99997 FORMAT (/, ':: No Bijvoet Pairs with Significant Fcalc ',
     1 'Differences in FCF Found', /)
99996 FORMAT ('Section 9')
99995 FORMAT (/, 20X, 'etc.', /)
99994 FORMAT (I3, 2(2X, 3I3, F10.2), 4X,  3F10.2)
99993 FORMAT (I3, 2(2X, 3I3, I11), 4X,  3I10)
99992 FORMAT (/, 'Excluded Outliers with Observed Bijvoet Difference',
     1        ' >', F12.2, ', or FCKD=0.0', /, 79('='), /,
     2        'Nr    H1 K1 L1', 6X, 'FOK1   H2 K2 L2', 6X, 'FOK2',
     3        10X, 'FOKD', 6X, 'FCKD', 6X, 'SIGD',  /, 79('='))
99991 FORMAT (/, 'No BIJVOET/HOOFT Analysis for Neutron data')
99990 FORMAT (/, 'Memory Allocate Problem in PLA421', /)
99989 FORMAT (79('='), /, 'Bijvoet Pair Analysis - F(calc) from ',
     1        A, /, 79('='))
99988 FORMAT (/, ':: No Bijvoet Pairs Found', /)
      END SUBROUTINE PLA421
 
      SUBROUTINE PLA422 (IBPR, XMAX, YMAX, THMX)
C * Bijvoet Pair Analysis - SCATTER PLOT (2)
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE bijvoet
      USE analysis
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: M
      INTEGER                  :: N
      INTEGER                  :: IH
      INTEGER                  :: IK
      INTEGER                  :: IL
      INTEGER                  :: IMM
      INTEGER                  :: JMM
      INTEGER                  :: JUNK
      INTEGER, DIMENSION(3, *) :: IBPR
      REAL                     :: X
      REAL                     :: Y
      REAL                     :: DX
      REAL                     :: DY
      REAL                     :: TH
      REAL                     :: DX0
      REAL                     :: DY0
      REAL                     :: ADD
      REAL                     :: DSH
      REAL                     :: SIG
      REAL                     :: XORG
      REAL                     :: YORG
      REAL                     :: SIG1
      REAL                     :: SIG2
      REAL                     :: FCK1
      REAL                     :: FCK2
      REAL                     :: FCKD
      REAL                     :: FOK1
      REAL                     :: FOK2
      REAL                     :: FOKD
      REAL                     :: DSH1
      REAL                     :: XMAX
      REAL                     :: YMAX
      REAL                     :: THMX
      REAL                     :: SCLX
      REAL                     :: SCLY
      REAL                     :: XHOR
      REAL                     :: XHDR
      REAL                     :: FCKSM
      REAL                     :: FOKSM
      REAL                     :: FCKDF
      REAL                     :: FOKDF
      REAL                     :: COLOR
      REAL                     :: YMSIG
      REAL                     :: YPSIG
      REAL                     :: FRIEDIF
      CHARACTER(len=10)        :: FORMX
      ICALT = 11 - IPR(594) * 6
C * OBSERVED VERSUS CALCULATED DIFFERENCE PLOT
      IF (IPR(656) == 0) THEN
        SCLX = 0.90 * VERT / (2.0 * XMAX)
        SCLY = 0.90 * VERT / (2.0 * YMAX)
        XORG = VERT / 2.0
        YORG = VERT / 2.0
C * OBSERVED AND CALCULATED DIFFERENCE VERSUS THETA PLOT
      ELSE IF (ABS(IPR(656)) == 1) THEN
        SCLX = 0.90 * VERT / THMX
        SCLY = 0.90 * VERT / (2.0 * MAX (XMAX, YMAX))
        XORG = 0.05 * VERT
        YORG = VERT / 2.0
C * OBSERVED AND CALCULATED DIFFERENCE VERSUS FCKSL  PLOT
      ELSE IF (ABS(IPR(656)) == 2) THEN
        SCLX = 0.90 * VERT / FCKSLM
        SCLY = 0.90 * VERT / (2.0 * MAX (XMAX, YMAX))
        XORG = 0.05 * VERT
        YORG = VERT / 2.0
      END IF
C * CHECK FOR BIJVOET ANALYSIS
      IF (IGBL(3) == 46) CALL GGIP (-999.0, 0.0, 0.0, -2)
      CALL GGIP (HORS, VERT, 0.0, 1)
C * PLOT BOX AND DISPLAY PARAMETERS
      CALL PLA110 (VERT, VERT, -1)
      CALL PLA262 (0)
      IF (IPR(656) == 0) THEN
        IF (IPR(635) == 0) THEN
          LINE = 'BIJVOET-PAIR BIJVOET-DIFFERENCE SCATTER PLOT'
        ELSE
          LINE = 'BIJVOET-PAIR PARSONS-DIFFERENCE SCATTER PLOT'
        END IF
      ELSE IF (IPR(656) == 1) THEN
        LINE = 'BIJVOET-PAIR DIFFERENCE VERSUS THETA SCATTER PLOT'
      ELSE IF (IPR(656) == -1) THEN
        LINE = 'BIJVOET-PAIR DIF-DIF/SIG VERSUS THETA SCATTER PLOT'
      ELSE IF (IPR(656) == 2) THEN
        LINE = 'BIJVOET-PAIR DIFFERENCE VERSUS LOG(FC2) SCATTER PLOT'
      ELSE IF (IPR(656) == -2) THEN
        LINE = 'BIJVOET-PAIR DIF-DIF/SIG VERSUS LOG(FC2) SCATTER PLOT'
      END IF
      VRT = VERT - 0.6
      CALL PLA439 (0.0, LINE, 53, 0.35, 5 + IGBL(68), 2, 2.6, VRT)
      IF (IPR(656) /= 0) THEN
        VRT = VRT - 0.5
        LINE = 'RED = Difference Signs Disagree'
        CALL PLA439 (0.0, LINE, 31, 0.30, 1, 2, 1.1, VRT)
        VRT = VRT - 0.5
        LINE = 'OBS = Marked'
        CALL PLA439 (0.0, LINE, 12, 0.30, 1, 2, 1.1, VRT)
      END IF
      IF (IPR(656) == 0) THEN
        IF (IPR(594) == 0) THEN
          LINE = 'Fcalc from Fcalc Data in FCF'
        ELSE
          LINE = 'Fcalc from Model Data in '//DTYPE(IABS(IGBL(8)))
        END IF
        VRT = VRT - 0.6
        CALL PLA439 (0.0, LINE, 29, 0.25, 5 + IGBL(68), 2, 1.0, VRT)
C * SumFormula
        CALL PLA283 (2, FLOAT (IPR(260)), N, CFORM)
        JUNK = NP52 - N + 1
        VRT = VRT - 0.5
        CALL PLA439 (0.0, CFORM(N:NP52), JUNK, 0.25,
     1          5 + IGBL(68), 2, 1.0, VRT)
C * Parsons-Z
        CALL GEN146 (FORMX, PAR(503), IPR(669), IPR(670))
        WRITE (LINE, 99993, IOSTAT = IOST) FORMX, IPR(750)
C * DUMMY
        IF (IOST == -999) RETURN
        VRT = VRT - 0.5
        CALL PLA439 (0.0, LINE, 37, 0.25, 5 + IGBL(68), 2, 1.0, VRT)
C * Res.Scat.
        WRITE (LINE, 99996, IOSTAT = IOST) NINT (PAR(425) * 10000.0)
        VRT = VRT - 0.5
        CALL PLA439 (0.0, LINE, 30, 0.25, 5 + IGBL(68), 2, 1.0, VRT)
C * Friedif
        IF (PAR(434) < 999999.0) THEN
          FRIEDIF = PAR(474) * 10000.0
          IF (FRIEDIF > 10.0) THEN
            WRITE (LINE, 99997, IOSTAT = IOST)
     1        NINT (FRIEDIF), NINT (PAR(491))
          ELSE
            WRITE (LINE, 99992, IOSTAT = IOST)
     1        FRIEDIF, NINT (PAR(491))
          END IF
          VRT = VRT - 0.5
          CALL PLA439 (0.0, LINE, 34, 0.25, 5 + IGBL(68), 2, 1.0, VRT)
          WRITE (LINE, 99994, IOSTAT = IOST)
     1      PAR(474) * PAR(434) * 10000.0
          VRT = VRT - 0.5
          CALL PLA439 (0.0, LINE, 26, 0.25, 5 + IGBL(68), 2, 1.0, VRT)
        ENDIF
        WRITE (LINE, 99995, IOSTAT = IOST) PAR(489), PAR(490)
        VRT = VRT - 0.5
        CALL PLA439 (0.0, LINE, 22, 0.25, 5 + IGBL(68), 2, 1.0, VRT)
C * Slope applied Notice
        IF (IPR(593) /= 0) THEN
          VRT = VRT - 0.5
          IF (IPR(613) == 0) THEN
            CALL PLA439 (0.0, 'n-Probability Plot Slope Applied', 32,
     1                         0.25, 5 + IGBL(68), 2, 1.0, VRT)
          ELSE
            CALL PLA439 (0.0, 't-Probability Plot Slope Applied', 32,
     1                         0.25, 5 + IGBL(68), 2, 1.0, VRT)
          END IF
        END IF
        IF (IPR(635) == 0) THEN
          LINE = '      Diff(Fobs**2)'
        ELSE
          LINE = 'Dif(Iobs)/Sum(Iobs)'
        END IF
        CALL PLA439 (90.0, LINE, 19, 0.30, 1, 2, 0.6, VERT - 5.0)
        IF (IPR(635) == 0) THEN
          LINE = '     Diff(Fcalc**2)'
        ELSE
          LINE = 'Dif(Ical)/Sum(Ical)'
        END IF
        CALL PLA439 (0.0, LINE, 19, 0.30, 1, 2, VERT - 5.0, 0.2)
      END IF
C * REPORT PARAMETER VALUES
      CALL PLA423
C * MOVE ORIGIN
      CALL GGIP (XORG, YORG, 0.0, -3)
      CALL GGIP (0.0, FLOAT (5 + IGBL(68)), 0.0, 0)
      IF (IPR(656) == 0) THEN
        DX = 0.45 * VERT
        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 < 1.0) THEN
          DX0 = - DX
          DY0 = - DX * DY
        ELSE
          DX0 = - DX / DY
          DY0 = - DX
        END IF
        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, 99999, IOSTAT = IOST) XMAX
        CALL PLA439 (90.0, LINE, 9, 0.3, 1, 2, DX + 0.4, -1.2)
        WRITE (LINE, 99999, IOSTAT = IOST) YMAX
        CALL PLA439 (0.0, LINE, 9, 0.3, 1, 2, -2.8, DX - 0.3)
      ELSE IF (ABS (IPR(656)) == 1 .OR. ABS (IPR(656)) == 2) THEN
        DX = 0.90 * VERT
        DY = 0.45 * VERT
        CALL GGIP (0.0, 0.0, 0.0, 3)
        CALL GGIP (DX , 0.0, 0.0, 2)
        CALL GGIP (0.0, DY , 0.0, 3)
        CALL GGIP (0.0, -DY, 0.0, 2)
        CALL GGIP (0.0, 0.0, 0.0, 3)
      END IF
      DSH  = 0.05
      DSH1 = 0.075
C * PLOT SELECTED SET OF BIJVOET PAIR DATA
      DO N = 1, IPR(707)
        I     = IBPR(2, N)
        J     = IBPR(3, N)
        IMM   = (I - 1) * NREC
        JMM   = (J - 1) * NREC
        FOK1  = VOID(IMM + 4)
        FCK1  = VOID(IMM + ICALT)
        SIG1  = VOID(IMM + 6)
        TH    = VOID(IMM + 7)
        FOK2  = VOID(JMM + 4)
        FCK2  = VOID(JMM + ICALT)
        SIG2  = VOID(JMM + 6)
        FOKDF = FOK1 - FOK2
        FCKDF = FCK1 - FCK2
        FOKSM = FOK1 + FOK2
        FCKSM = FCK1 + FCK2
C * TEST FOR BIJVOET OR PARSONS DIFFERENCES
        IF (IPR(656) == 0) THEN
          IF (IPR(635) == 0) THEN
            FOKD = SCLY * FOKDF
            FCKD = SCLX * FCKDF
            SIG  = SCLY * SQRT (SIG1**2 + SIG2**2)
          ELSE
            IF (FOK1 + FOK2 /= 0.0) THEN
              FOKD = SCLY * FOKDF / FOKSM
              FCKD = SCLX * FCKDF / FCKSM
              SIG  = SCLY * SQRT ((2.0 * FOK2 * SIG1 / FOKSM**2)**2 +
     1                            (2.0 * FOK1 * SIG2 / FOKSM**2)**2)
            END IF
          END IF
        ELSE IF (ABS (IPR(656)) == 1) THEN
          FOKD = SCLY * FOKDF
          FCKD = SCLY * FCKDF
          XHOR = SCLX * TH
          SIG  = SCLY * SQRT (SIG1**2 + SIG2**2)
        ELSE IF (ABS (IPR(656)) == 2) THEN
          FOKD = SCLY * FOKDF
          FCKD = SCLY * FCKDF
          XHOR = SCLX * LOG (FCKSM)
          SIG  = SCLY * SQRT (SIG1**2 + SIG2**2)
        END IF
        IF (IPR(656) == 0) THEN
          IF (ABS (FOKD) <= 0.45 * VERT) THEN
            DO M = 1, 3, 2
              IF (FOKD * FCKD >= 0.0) THEN
                COLOR = 1.0
              ELSE
                COLOR = 2.0
              END IF
              X = (M - 2) * FCKD
              Y = (M - 2) * FOKD
C * PLOT MARKER
              CALL PLA411 (X, Y, DSH, COLOR)
              IF (X > 0.0) THEN
C * ADD SU BAR TO DATUM POINT
                IF (IPR(634) == 1) THEN
                  YPSIG = MIN ( 0.45 * VERT, Y + SIG)
                  YMSIG = MAX (-0.45 * VERT, Y - SIG)
                  CALL GGIP (X, YPSIG, 0.0, 3)
                  CALL GGIP (X, YMSIG, 0.0, 2)
                END IF
                IF (IPR(636) == 1) THEN
                  IF (X > DX / 2.0 .OR. Y < -DX / 2.0) THEN
                    IH = NINT (VOID(IMM + 1))
                    IK = NINT (VOID(IMM + 2))
                    IL = NINT (VOID(IMM + 3))
                    WRITE (LINE, 99998, IOSTAT = IOST) IH, IK, IL
                    IF (MOD (N, 2) == 1) THEN
                      ADD =  0.1
                    ELSE
                      ADD = -1.1
                    END IF
                    CALL PLA439 (-45.0, LINE, 9, 0.16, 5 + IGBL(68),
     1                                 1, X + ADD , Y - ADD)
                  END IF
                END IF
              END IF
            END DO
          END IF
        ELSE IF (ABS (IPR(656)) == 1 .OR. ABS (IPR(656)) == 2) THEN
          IF (FCKD * FOKD > 0.0) THEN
            COLOR = 3.0
          ELSE
            COLOR = 2.0
          END IF
          IF (IPR(656) < 0) THEN
            Y = FCKD + (FOKD - FCKD) / SIG
          ELSE
            Y = FOKD
          END IF
          CALL GGIP (0.0, COLOR, 0.0, 0)
          CALL GGIP (XHOR,        FCKD,     0.0, 3)
          CALL GGIP (XHOR,        Y,        0.0, 2)
C * PLOT MARKER
          CALL PLA411 (XHDR, Y, DSH1, -1.0)
        END IF
      END DO
      RETURN
99999 FORMAT (F9.2)
99998 FORMAT (3I3)
99997 FORMAT ('Friedif   =', I6, ' stat [', I5, ' obs]')
99996 FORMAT ('Res.Scat. =', I6, ' * 0.0001')
99995 FORMAT ('RA =', F6.3, ', RD =', F6.3)
99994 FORMAT ('Friedif * Flack(su) =', F5.1)
99993 FORMAT ('Parsons z =', A, ',', I5, ' Pairs')
99992 FORMAT ('Friedif   =', F6.1, ' stat [', I5, ' obs]')
      END SUBROUTINE PLA422
 
      SUBROUTINE PLA423
C * Bijvoet Pair Analysis (3) - PARAMETER DISPLAY
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE bijvoet
      USE npplot
      IMPLICIT NONE
      INTEGER           :: NB
      INTEGER           :: NE
      REAL              :: YUNK
      CHARACTER(len=10) :: FORMX
      VRT = VERT - 0.5
C * SPGR
      NB = 1
      NE = 7
      CALL GEN039 (1, SPGRNM(1)(1:7), 1, 7, NB, NE)
      LINE = 'Space Group'
      WRITE (LINE(22-NE:), 99984, IOSTAT = IOST) SPGRNM(1)(1:7)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * WAVELENGTH
      WRITE (LINE, 99993, IOSTAT = IOST) PAR(17)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * FLACK X
      IF (PAR(433) < 999999.0) THEN
        CALL GEN146 (FORMX, PAR(433), IPR(279), IPR(280))
        IF (IPR(705) == 2) THEN
          WRITE (LINE, 99998, IOSTAT = IOST) FORMX
        ELSE
          WRITE (LINE, 99992, IOSTAT = IOST) FORMX
        ENDIF
        WRITE (LU6,  99968, IOSTAT = IOST) LINE
        WRITE (LU7,  99968, IOSTAT = IOST) LINE
        CALL PLA439 (0.0, LINE, 22, 0.335, 1, 2, VERT + 0.2, VRT)
      END IF
      VRT = VRT - 0.6
C * PARSONS z
      IF (PAR(434) < 999999.0) THEN
        CALL GEN146 (FORMX, PAR(503), IPR(669), IPR(670))
        WRITE (LINE, 99980, IOSTAT = IOST) FORMX
        WRITE (LU6,  99968, IOSTAT = IOST) LINE
        WRITE (LU7,  99968, IOSTAT = IOST) LINE
        CALL PLA439 (0.0, LINE, 22, 0.335, 1, 2, VERT + 0.2, VRT)
      END IF
      VRT = VRT - 0.8
C * BIJVOET PAIRS
      WRITE (LU6,  99967, IOSTAT = IOST)
      WRITE (LU7,  99967, IOSTAT = IOST)
      WRITE (LINE, 99990, IOSTAT = IOST) IPR(668)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      CALL PLA439 (0.0, LINE, 14, 0.35, 5 + IGBL(68), 2,
     1                  VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * BIJVOET COVERAGE
      WRITE (LINE, 99959, IOSTAT = IOST) NINT (PAR(464))
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * DIFFCALCMAX
      WRITE (LINE, 99994, IOSTAT = IOST) BIJVOETMAX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * OUTLIER CRIT
      WRITE (LINE, 99983, IOSTAT = IOST) FODIFMAX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.8
C * SCATTER PLOT
      WRITE (LINE, 99969, IOSTAT = IOST)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 12, 0.35, 5 + IGBL(68), 2,
     1                  VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * SCATTER PLOT SIGMA CRIT
      WRITE (LINE, 99987, IOSTAT = IOST) PAR(452)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * SCATTER PLOT SELECTED NUMBER OF PAIRS
      WRITE (LINE, 99989, IOSTAT = IOST) IPR(707)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * SCATTER NUMBER PLUS
      WRITE (LINE, 99986, IOSTAT = IOST) NPLS
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * SCATTER NUMBER MINUS
      WRITE (LINE, 99985, IOSTAT = IOST) NMIN
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * SCATTER PLOT SLOPE
      WRITE (LINE, 99970, IOSTAT = IOST) RCO
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.8
C * PROB PLOT GAUSSIAN/STUDENT-T
      WRITE (LU6,  99967, IOSTAT = IOST)
      WRITE (LU7,  99967, IOSTAT = IOST)
      IF (IPR(613) == 0) THEN
        WRITE (LINE, 99966, IOSTAT = IOST)
      ELSE
        WRITE (LINE, 99999, IOSTAT = IOST)
      END IF
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 5 + IGBL(68), 2,
     1           VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * PROB PLOT SAMPLE SIZE
      WRITE (LINE, 99981, IOSTAT = IOST) NFR
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * PROB PLOT CORRELATION
      WRITE (LINE, 99965, IOSTAT = IOST) YCC
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      IF (YCC < 0.9) THEN
        WRITE (LINE, 99995, IOSTAT = IOST) YCC
        CALL PLA439 (0.0, LINE, 21, 0.35, 2, 2, VERT + 0.2, VRT)
      END IF
      VRT = VRT - 0.6
C * PROB PLOT INTERCEPT
      WRITE (LINE, 99964, IOSTAT = IOST) YINT
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * PROB PLOT SLOPE
      WRITE (LINE, 99963, IOSTAT = IOST) YSLOPE
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.8
C * BAYESIAN STATISTICS
      WRITE (LU6,  99967, IOSTAT = IOST)
      WRITE (LU7,  99967, IOSTAT = IOST)
      WRITE (LINE, 99974, IOSTAT = IOST)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 5 + IGBL(68), 2,
     1                  VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * GAUSSIAN /STUDENT-T NU
      IF (IPR(613) > 0) THEN
        WRITE (LINE, 99982, IOSTAT = IOST) NINT (PAR(487))
      ELSE
        WRITE (LINE, 99988, IOSTAT = IOST)
      END IF
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99973, IOSTAT = IOST) NFH
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * THETA-MIN BIJVOET PAIRS
      WRITE (LINE, 99956, IOSTAT = IOST) MAX (PAR(509), PAR(510))
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * THETA-MAX BIJVOET PAIRS
      WRITE (LINE, 99955, IOSTAT = IOST) MAX (PAR(509), PAR(512))
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * P2(True)
      IF (XPLL2 > 0.001D+0) THEN
        WRITE (FORMX, 99961, IOSTAT = IOST) XPLL2
      ELSE IF (XPLL2 < 0.0D+0) THEN
        WRITE (FORMX, 99957, IOSTAT = IOST)
        CALL PLA439 (0.0, 'Not Enantiopure', 15, 0.35, 1, 2,
     1                   VERT - 4.6, VRT)
      ELSE
        WRITE (FORMX, 99962, IOSTAT = IOST) XPLL2
      END IF
      WRITE (LINE, 99958, IOSTAT = IOST) FORMX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * P3(True)
      IF (XPLLL > 0.001D+0) THEN
        WRITE (FORMX, 99961, IOSTAT = IOST) XPLLL
      ELSE IF (XPLLL < 0.0D+0) THEN
        WRITE (FORMX, 99957, IOSTAT = IOST)
      ELSE
        WRITE (FORMX, 99962, IOSTAT = IOST) XPLLL
      END IF
      WRITE (LINE, 99979, IOSTAT = IOST) FORMX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
C * P3(Twin)
      VRT = VRT - 0.6
      IF (XTWLL > 0.001D+0) THEN
        WRITE (FORMX, 99961, IOSTAT = IOST) XTWLL
      ELSE IF (XTWLL < 0.0D+0) THEN
        WRITE (FORMX, 99957, IOSTAT = IOST)
      ELSE
        WRITE (FORMX, 99962, IOSTAT = IOST) XTWLL
      END IF
      WRITE (LINE, 99977, IOSTAT = IOST) FORMX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
C * P3(False)
      VRT = VRT - 0.6
      IF (XMNLL > 0.001D+0) THEN
        WRITE (FORMX, 99961, IOSTAT = IOST) XMNLL
      ELSE IF (XMNLL < 0.0D+0 .OR. XPLLL < 0.0D+0) THEN
        WRITE (FORMX, 99957, IOSTAT = IOST)
      ELSE
        WRITE (FORMX, 99962, IOSTAT = IOST) XMNLL
      END IF
      WRITE (LINE, 99978, IOSTAT = IOST) FORMX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * G
      WRITE (LINE, 99972, IOSTAT = IOST) XG
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * G (su)
      YUNK = SNGL (DSQRT (XG2 / XG0))
      IF (YUNK > 0.0001) THEN
        WRITE (FORMX, 99960, IOSTAT = IOST) YUNK
      ELSE
        WRITE (FORMX, 99962, IOSTAT = IOST) YUNK
      END IF
      WRITE (LINE, 99971, IOSTAT = IOST) FORMX
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
      VRT = VRT - 0.6
C * Hooft y
      CALL GEN146 (FORMX, PAR435, IPR615, IPR616)
      WRITE (LINE, 99976, IOSTAT = IOST) FORMX(2:10)
      WRITE (LU6,  99968, IOSTAT = IOST) LINE
      WRITE (LU7,  99968, IOSTAT = IOST) LINE
      CALL PLA439 (0.0, LINE, 22, 0.35, 1, 2, VERT + 0.2, VRT)
      IF (PAR(435) . LT. 999999.0) THEN
        IF (ABS (PAR(435) - PAR435) > 2.0 * PAR(436)) THEN
          LINE (1:12) = ' '
          CALL PLA439 (0.0, LINE, 21, 0.35, 2, 2, VERT + 0.2, VRT)
        END IF
      END IF
      VRT = VRT - 0.6
      RETURN
99999 FORMAT ('Student-T Prob. Plot')
99998 FORMAT ('Flack x TWIN', A)
99995 FORMAT ('            ', F9.3)
99994 FORMAT ('DiffCalcMax.', F9.2)
99993 FORMAT ('Wavelength ', F10.5)
99992 FORMAT ('Flack x ....', A)
99990 FORMAT ('Bijvoet Pairs', I8)
99989 FORMAT ('Select Pairs', I9)
99988 FORMAT ('Distribution Gaussian')
99987 FORMAT ('Sigma Crit..', F9.2)
99986 FORMAT ('Number Plus ', I9)
99985 FORMAT ('Number Minus', I9)
99984 FORMAT (A)
99983 FORMAT ('Outlier Crit', F9.2)
99982 FORMAT ('Student_T Nu', I9)
99981 FORMAT ('Sample Size.', I9)
99980 FORMAT ('Parsons z ..', A)
99979 FORMAT ('P3(true)....', A)
99978 FORMAT ('P3(false) ..', A)
99977 FORMAT ('P3(rac-twin)', A)
99976 FORMAT ('Hooft y ....', A)
99974 FORMAT ('Bayesian Statistics')
99973 FORMAT ('Select Pairs', I9)
99972 FORMAT ('G ..........', F9.4)
99971 FORMAT ('G (su) .....', A)
99970 FORMAT ('Slope ......', F9.3)
99969 FORMAT ('Scatter Plot')
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)
99962 FORMAT (E9.1)
99961 FORMAT (F9.3)
99960 FORMAT (F9.4)
99959 FORMAT ('Coverage ...', I9)
99958 FORMAT ('P2(true)....', A)
99957 FORMAT (6X, 'n/a')
99956 FORMAT ('Theta_Min ..', F9.2)
99955 FORMAT ('Theta_Max ..', F9.2)
      END SUBROUTINE PLA423
 
      SUBROUTINE PLA424
C * Bijvoet Pair Analysis (4)
C * COLLECT DATA FOR PROBABILITY PLOT
      USE files
      USE parameters
      USE cchar
      USE reflex
      USE bijvoet
      USE analysis
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: M
      INTEGER :: N
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      INTEGER :: IMM
      INTEGER :: LUX
      INTEGER :: IADD
      INTEGER :: IHKLP
      REAL    :: FCK1
      REAL    :: FCK2
      REAL    :: FOK1
      REAL    :: FOK2
      REAL    :: FOKD
      REAL    :: FCKD
      REAL    :: SIGM
      REAL    :: SIG1K
      REAL    :: SIG2K
      ICALT = 11 - IPR(594) * 6
        NFR = 0
C * INCLUDE L.S. WEIGHT PARAMETERS IN SIGMAI
        IF (PAR(493) * IPR(629) > 0.0) THEN
          IADD = 12
        ELSE
          IADD = 6
        END IF
        DO I = 1, NREF
          IMM   = (I - 1) * NREC
          IH    = NINT (VOID(IMM + 1))
          IK    = NINT (VOID(IMM + 2))
          IL    = NINT (VOID(IMM + 3))
          FOK1  = VOID(IMM + 4)
          FCK1  = VOID(IMM + ICALT)
          SIG1K = VOID(IMM + IADD)**2
          IHKLP = IL * MHK + IK * MPH + IH
          N     = NINT (VOID(IADR - IHKLP))
          IF (N > I) THEN
            M     = (N - 1) * NREC
            FOK2  = VOID(M + 4)
            FCK2  = VOID(M + ICALT)
            SIG2K = VOID(M + IADD)**2
            FOKD  = FOK1 - FOK2
            FCKD  = FCK1 - FCK2
            SIGM  = SQRT (MAX (SIG1K + SIG2K, 0.01))
C * DO NOT EXCLUDE OUTLIERS FOR STUDENT-T
            IF (ABS(FOKD) <= FODIFMAX .OR. IPR(613) == 1) THEN
C * COLLECT DATA FOR PP
              NFR = NFR + 1
              VOID(NADR + NFR) = (SNGL (XG) * FCKD - FOKD) / SIGM
            END IF
          END IF
        END DO
        IF (IABS (IGBL(36)) == 1) THEN
          LUX = LU13
        ELSE
          LUX = LU7
        END IF
C * NORMAL OR STUDENT-T PROBABILITY PLOT
        IF (NFR > 0 .AND. IGBL(36) >= 0) THEN
          IF (LUX == LU7) CALL PLA262 (0)
C * TEST NORMAL/STUDENT
          IF (IPR(613) == 0) THEN
            IF (IPR(652) == 1) THEN
C * TEST FOR WRITING .npp / OPENING
              OPEN (UNIT = 62, FILE = NAMEFIL(1:KNMFIL)//'.npp',
     1              STATUS = 'UNKNOWN')
            END IF
            CALL GEN116 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NFR,
     1                   GRAPH, 0)
          ELSE
C * TEST FOR WRITING .tpp / OPENING
            IF (IPR(652) == 1) THEN
              OPEN (UNIT = 62, FILE = NAMEFIL(1:KNMFIL)//'.tpp',
     1              STATUS = 'UNKNOWN')
            END IF
            PAR(487) = PAR(488)
            CALL GEN142 (VOID(NADR + 1), VOID(NADR + NREF + 1),
     1        PAR(487), NFR, GRAPH, 0)
            IPR(617) = IPR(617) + 1
            IF (IPR(617) == 2) THEN
              IPR(593) = 1
              RETURN
            END IF
          END IF
C * WRITE PROBABILITY PLOT DATA TO .npp or .tpp
          IF (IPR(652) == 1) THEN
            DO I = 1, NFR
              WRITE (LU62, 99995, IOSTAT = IOST)
     1          VOID(NADR + I), VOID(NADR + NREF + I)
            END DO
            CLOSE (UNIT = 62)
          END IF
          GRAPH(5)(52:103) =
     1      'PP for (delta(G * Fcalc**2) - delta(Fobs**2))/Sigma'
          GRAPH(6)(52:104) =
     1      'Sigma = sqrt(sigma(Fobs1**2)**2 + sigma(Fobs2**2)**2)'
          IF (PAR(493) * IPR(629) > 0.0)
     1       WRITE (GRAPH(7)(52:100), 99997, IOSTAT = IOST)
     2         PAR(493), PAR(494)
          IF (IPR(613) == 0) THEN
            WRITE (GRAPH(8)(52:), 99998, IOSTAT = IOST) XG
          ELSE
            WRITE (GRAPH(8)(52:), 99996, IOSTAT = IOST) XG, PAR(487)
          END IF
          WRITE (LUX, 99999, IOSTAT = IOST) (GRAPH(I), I = 1, 44)
          IF (LUX == LU7) CALL PLA262 (0)
        END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT ('G =', F9.4)
99997 FORMAT ('Sigma Includes SHELXL WGHT Par.', 2F9.4)
99996 FORMAT ('G =', F9.4, ' - nu =', F6.2)
99995 FORMAT (2G12.5)
      END SUBROUTINE PLA424
 
      SUBROUTINE PLA425 (DPDAT, LU)
C * Bijvoet Pair Analysis (5)
C * CALCULATE G, SIGMA(G), HOOFT AND SIGMA(HOOFT) WITH BAYESIAN STATISTICS
      USE files
      USE parameters
      USE bijvoet
      USE npplot
      IMPLICIT NONE
      INTEGER           :: J
      INTEGER           :: LU
      REAL              :: YK
      REAL              :: STEP
      CHARACTER(len=48) :: FORMA
      DOUBLE PRECISION  :: DPDAT(*)
C * APPLY NPP OR TPP SLOPE
      IF (IPR(593) /= 0) THEN
        DO J = 1, NSTP
          DPDAT(J) = DPDAT(J) / DBLE (YSLOPE)**2
        END DO
      END IF
      FORMA = '(//,''Hooft y Parameter Value .'',F9.3,''('',I2,'')'')'
      STEP  = PAR(515)
C * DETERMINE LARGEST LOG-PROBABILITY FOR SCALING
      DPDATM = DPDAT(1)
      DO J = 2, NSTP
        IF (DPDAT(J) > DPDATM) DPDATM = DPDAT(J)
      END DO
      XG0 = 0.0D+0
      XG1 = 0.0D+0
      XG2 = 0.0D+0
C * DETERMINE AVERAGE G VALUE OF THE POBABILITY DISTRIBUTION
      DO J = 1, NSTP
        YK   = (J - NSPT) * STEP
        DDIF = DPDAT(J) - DPDATM
        IF (DDIF > -500.0D+0) THEN
          XG1 = XG1 + DBLE (YK) * DEXP (DDIF)
          XG0 = XG0 +             DEXP (DDIF)
        END IF
      END DO
      XG  = XG1 / XG0
C * DETERMINE VARIANCE AND SIGMA(G) OF THE PROBABILITY DISTRIBUTION
      DO J = 1, NSTP
        YK   = (J - NSPT) * STEP
        DDIF = DPDAT(J) - DPDATM
        IF (DDIF > -500.0D+0) THEN
          XG2 = XG2 + (DBLE (YK) - DBLE (XG))**2 * DEXP (DDIF)
        END IF
      END DO
      PAR435 = (1.0 - SNGL (XG)) / 2.0
      PAR436 = SNGL(DSQRT (XG2 / XG0) / 2.0D+0)
C * ROUND
      CALL GEN041 (PAR435, PAR436, IPR615, 3, IPR616, IPR(68))
C * SAVE Hooft y data for CIF or RES Based SF ONLY
      IF (IPR(594) == 1 .OR. IABS (IGBL(8)) == 2) THEN
        PAR(435) = PAR435
        PAR(436) = PAR436
        IPR(615) = IPR615
        IPR(616) = IPR616
      ELSE IF (IPR(594) == 0) THEN
        PAR(471) = PAR435
        PAR(472) = PAR436
        IPR(715) = IPR615
        IPR(716) = IPR616
      END IF
C * CONDITIONALLY OUTPUT Hooft y PARAMETER VALUE
      IF (IPR(619) == 0 .AND. PAR(464) > PAR(476)) THEN
        IF (IPR616 > 0) THEN
          FORMA(36:36) = CHAR (ICHAR ('0') + IPR616)
          WRITE (LU, FORMA, IOSTAT = IOST) PAR435, IPR615
        ELSE
          WRITE (LU, 99999, IOSTAT = IOST) PAR435, PAR436
        END IF
C * TEST FOR FCF/CIF Based
        IF (IPR(594) == 0) THEN
C * CHECK FOR SIGNIFICANT NON-ZERO CIF-BASED HOOFT PARAMETER
          IF (PAR(435) > 5.0 * PAR(436)) THEN
            IF (PAR435 > 5.0 * PAR436 .AND.
     1        ABS (PAR(435) - PAR435) <= 2.0 * PAR(436)) THEN
              WRITE (LU, 99996, IOSTAT = IOST)
C * ALERT _917
              CALL PLA236 (917, 2, -999.0, 0.0, ' ', ' ')
            ELSE
              WRITE (LU, 99997, IOSTAT = IOST)
              WRITE (LU, 99995, IOSTAT = IOST)
            END IF
          END IF
        END IF
      ELSE
C * REPORT LOW FRIEDEL PAIR COVERAGE
        IF (IPR(617) > 1) WRITE (LU, 99994, IOSTAT = IOST)
      END IF
C * CALCULATE P3(0), P3(TW), P3(1)
      XPLLL = DPDAT(NSPP) - DPDATM
      XMNLL = DPDAT(NSPM) - DPDATM
      IF (XPLLL > -500.0D+0) THEN
        XPLLL = DEXP (XPLLL)
      ELSE
        XPLLL = 0.0D+0
      END IF
      IF (XMNLL > -500.0D+0) THEN
        XMNLL = DEXP (XMNLL)
      ELSE
        XMNLL = 0.0D+0
      END IF
      IF (XPLLL > 1.0D-99) THEN
        XPLL2 = 1.0D+0 / (1.0D+0 + XMNLL / XPLLL)
      ELSE
        XPLL2 = -1.0D+0
      END IF
C * TEST FOR F(CALC) FROM CIF
      IF (IPR(594) == 1) THEN
        IF (XPLL2 > -1.0D+0) THEN
          PAR(506) = SNGL (MAX (1.0D-35, XPLL2))
        ELSE
          PAR(506) = -1.0
        END IF
      END IF
      XTWLL = DPDAT(NSPT) - DPDATM
      IF (XTWLL > -500.0D+0) THEN
        XTWLL = DEXP (XTWLL)
      ELSE
        XTWLL = 0.0D+0
      END IF
      XSMLL = XPLLL + XTWLL + XMNLL
C * TEST FOR N/A
      IF (XSMLL > 1.0D-99) THEN
        XPLLL = XPLLL / XSMLL
        XMNLL = XMNLL / XSMLL
        XTWLL = XTWLL / XSMLL
      ELSE
        XPLLL = -1.0D+0
        XTWLL = -1.0D+0
        XSMLL = -1.0D+0
      END IF
      IF (IPR(594) == 1) THEN
        IF (XPLLL > -1.0D+0) THEN
          PAR(507) = SNGL (MAX (1.0D-35, XPLLL))
        ELSE
          PAR(507) = -1.0
        END IF
        IF (XTWLL > -1.0D+0) THEN
          PAR(508) = SNGL (MAX (1.0D-35, XTWLL))
        ELSE
          PAR(508) = -1.0
        END IF
      END IF
C * DO TWO VALUE TEST ONLY FOR y close to zero or one
      IF (ABS (ABS (PAR435 - 0.5) - 0.5) .GT.
     1  MAX (0.1, 3 * PAR436) .AND. XTWLL > 0.1D+0)
     2       XPLL2 = -1.0D+0
      IF (RCN /= 0.0) THEN
        RCO = RCT / RCN
      ELSE
        RCO = 0.0
      END IF
      IF (IGBL(36) == 0) THEN
        WRITE (LU6, 99998, IOSTAT = IOST) SUMX, IPR(707), IPR(668), DDM,
     1    DDP
        CALL PLA262 (3)
        WRITE (LU7, 99998, IOSTAT = IOST) SUMX, IPR(707), IPR(668), DDM,
     1    DDP
      END IF
      RETURN
99999 FORMAT (//, 'Hooft y Parameter Value .', F9.5, '(', F7.5, ')')
99998 FORMAT (/, 'Average Weighted Ratio =', F6.2, ' for', I5,
     1        ' Bijvoet Pairs (out of', I7, ')', /,
     2        ' MIN, MAX = ', 2F8.3, /)
99997 FORMAT (/, '*** Warning *** :', /,
     1           'This y value is invalid when an FCF',
     2        ' based on a BASF/TWIN Refinement is used.')
99996 FORMAT (/, 'Note: The supplied FCF is likely NOT based on a',
     1           ' TWIN/BASF Refinement')
99995 FORMAT (/, 'Note: The Supplied FCF is likely based on a',
     1           ' TWIN/BASF Refinement')
99994 FORMAT (/, 'Low Friedel Pair Coverage: No Hooft y Parameter',
     1           ' Reported in Validation', /)
      END SUBROUTINE PLA425
 
      SUBROUTINE PLA426 (IBPR, XMAX, YMAX, THMX, XMXP, YMXP, LU)
C * Bijvoet Pair Analysis (6)
      USE files
      USE parameters
      USE bijvoet
      USE analysis
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: N
      INTEGER                  :: LU
      INTEGER                  :: IH1
      INTEGER                  :: IK1
      INTEGER                  :: IL1
      INTEGER                  :: IH2
      INTEGER                  :: IK2
      INTEGER                  :: IL2
      INTEGER                  :: IMM
      INTEGER                  :: JMM
      INTEGER, DIMENSION(3, *) :: IBPR
      REAL                     :: TH
      REAL                     :: WGHT
      REAL                     :: FCK1
      REAL                     :: FCK2
      REAL                     :: FCKD
      REAL                     :: FCKS
      REAL                     :: FOK1
      REAL                     :: FOK2
      REAL                     :: FOKD
      REAL                     :: FOKS
      REAL                     :: XMAX
      REAL                     :: YMAX
      REAL                     :: THMX
      REAL                     :: XMXP
      REAL                     :: YMXP
      REAL                     :: SIG1
      REAL                     :: SIG2
      REAL                     :: SIGM
      REAL                     :: DCDOS
      REAL                     :: RATIO
      REAL                     :: RATIO1
      CHARACTER(len=49)        :: FORMB
      FORMB = '(/,''Flack Parameter Value (CIF)'',F8.3,''('',I2,'')'')'
      ICALT = 11 - IPR(594) * 6
C * SORT FRIEDEL (BIJVOET) PAIRS
      CALL GEN147 (IBPR, 3, 1, IPR(707))
      DO N = 1, IPR(707)
        I    = IBPR(2, N)
        J    = IBPR(3, N)
        IMM  = (I - 1) * NREC
        JMM  = (J - 1) * NREC
        IH1  = NINT (VOID(IMM + 1))
        IK1  = NINT (VOID(IMM + 2))
        IL1  = NINT (VOID(IMM + 3))
        FOK1 = VOID(IMM + 4)
        FCK1 = VOID(IMM + ICALT)
        SIG1 = VOID(IMM + 6)
        TH   = VOID(IMM + 7)
        IH2  = NINT (VOID(JMM + 1))
        IK2  = NINT (VOID(JMM + 2))
        IL2  = NINT (VOID(JMM + 3))
        FOK2 = VOID(JMM + 4)
        FCK2 = VOID(JMM + ICALT)
        SIG2 = VOID(JMM + 6)
        FOKD = FOK1 - FOK2
        FCKD = FCK1 - FCK2
        FOKS = FOK1 + FOK2
        FCKS = FCK1 + FCK2
        SIGM = MAX (SIG1**2 + SIG2**2, 0.01)
        RCT  = RCT + FOKD * FCKD / SIGM
        RCN  = RCN + FCKD**2 / SIGM
        SIGM = SQRT (SIGM)
        IF (FOKD * FCKD > 0.0) THEN
          NPLS = NPLS + 1
        ELSE
          NMIN = NMIN + 1
        END IF
        IF (ABS (FOKD) < 3.0 * ABS (FCKD)) THEN
C * SCALING FOR BIJVOET SCATTER PLOT
          XMAX   = MAX (XMAX, ABS (FCKD))
          YMAX   = MAX (YMAX, ABS (FOKD))
          THMX   = MAX (THMX, TH)
          FCKSLM = MAX (FCKSLM, LOG (FCKS))
C * SCALING FOR 'PARSONS' SCATTER PLOT
          IF (FCKS /= 0.0) THEN
            XMXP = MAX (XMXP, ABS (FCKD / FCKS))
          END IF
          IF (FOKS /= 0.0) THEN
            YMXP = MAX (YMXP, ABS (FOKD / FOKS))
          END IF
        END IF
        IF (FCKD /= 0.0) THEN
          RATIO  = FOKD / FCKD
          RATIO1 = ABS (FCKD) / FCKS
          DCDOS  = (FCKD - FOKD) / SIGM
          DDP    = MAX (DDP, DCDOS)
          DDM    = MIN (DDM, DCDOS)
          IF (SIGM > 0.0) THEN
            WGHT = ABS (FCKD) / SIGM
            SUMX = SUMX + WGHT * RATIO
            SUMW = SUMW + WGHT
          END IF
          IF (RATIO < -99.99) THEN
            RATIO = -99.99
          ELSE IF (RATIO > 999.99) THEN
            RATIO = 999.99
          END IF
        END IF
        IF (N == 1 .AND. IGBL(36) == 0) THEN
          WRITE (LU7, 99997, IOSTAT = IOST) PAR(452)
          CALL PLA262 (5)
        END IF
C * LIST LARGEST BIJVOET PAIR DIFFERENCES
        IF (N <= IPR(596)) THEN
          IF (N == 1) THEN
C * IPR(560) = # OF EXPECTED FRIEDEL PAIRS
            IF (PAR(433) /= 999999.0 .AND.
     1        PAR(434) /= 999999.0) THEN
              IF (IPR(280) > 0) THEN
                FORMB(37:37) = CHAR (ICHAR ('0') + IPR(280))
                IF (IPR(617) > 1) WRITE (LU, FORMB, IOSTAT = IOST)
     1            PAR(433), IPR(279)
              ELSE
C * REPORT FLACK PARAMETER VALUE
                IF (IPR(617) .GT. 1) WRITE (LU, 99994, IOSTAT = IOST)
     1            PAR(433), PAR(434)
              END IF
            END IF
            IF (IPR(617) > 1) THEN
            WRITE (LU, 99983, IOSTAT = IOST) IPR(668), IPR(560)
            WRITE (LU, 99979, IOSTAT = IOST) IPR(706)
            IF (IPR(560) > 0) THEN
              PAR(464) = IPR(668) * 100.0 / IPR(560)
              WRITE (LU, 99984, IOSTAT = IOST) NINT (PAR(464))
C * ALERT _915 - CHECK FOR LOW FRIEDEL PAIR COVERAGE
              IF (IPR(594) == 1 .AND. IPR(619) == 0) THEN
                IF (IPR(137) > 0) THEN
                  CALL PLA236 (915, 2, 100.0 - PAR(464), PAR(464),
     1              ' ', ' ')
                ELSE IF (IPR(137) < 0) THEN
                  IF (PAR(464) < PAR(476)) THEN
                    CALL PLA236 (915, 2, -999.0, PAR(464), ' ', ' ')
                  END IF
                END IF
              END IF
            END IF
            IF (PAR(425) > 0.0) THEN
              WRITE (LU, 99986, IOSTAT = IOST)
     1          PAR(425), NINT (PAR(474) * 10000.0)
            END IF
            WRITE (LU, 99993, IOSTAT = IOST)
            END IF
          END IF
          IF (IPR(617) .GT. 1) THEN
          IF (FOK1 > 99999.9 .OR. FOK2 > 99999.9  .OR.
     1        SIGM > 999.9) THEN
            WRITE (LU, 99982, IOSTAT = IOST) IH1, IK1, IL1,
     1        NINT (FOK1), IH2, IK2, IL2, NINT (FOK2), NINT (FOKD),
     2        NINT (FCKD), NINT (SIGM), WGHT, RATIO, RATIO1
          ELSE
            WRITE (LU, 99995, IOSTAT = IOST)
     1        IH1, IK1, IL1, FOK1, IH2, IK2, IL2,
     2        FOK2,  FOKD, FCKD, SIGM, WGHT, RATIO, RATIO1
          END IF
          END IF
        END IF
        IF (IGBL(36) == 0 .AND. IPR(617) > 1) THEN
          CALL PLA262 (1)
          WRITE (LU7, 99998, IOSTAT = IOST) IH1, IK1, IL1,
     1      FOK1, FCK1, SIG1, IH2, IK2, IL2, FOK2, FCK2, SIG2,
     2      FOKD, FCKD, SIGM, WGHT, RATIO, DCDOS, RATIO1
        END IF
      END DO
      SUMX = SUMX / SUMW
      RETURN
99998 FORMAT (2(3I3, 2F10.2, F8.2), 2F8.2, F9.2, 2F8.2, F8.3, F9.5)
99997 FORMAT ('Analyses of Bijvoet-Pair (Friedel-Pair) Differences',
     1        ' for abs(Fcalcl**2 - Fcalc2**2))/Sigma > ', F6.2, /,
     2        101('='), 24X, '|I+-I-|', /, 125X, 7('-'), /,
     3        ' H1 K1 L1    FO1**2    FC1**2  SIGMA1',
     4        ' H2 K2 L2    FO2**2    FC2**2  SIGMA2  DELOBS ',
     5        'DELCALC SIG(DEL) DLC/SIG DLO/DLC DC-DO/S  I+ + I-', /,
     6        132('='))
99995 FORMAT (2(3I3, F8.1, 1X), 2F8.1, F7.2, 2F6.2, F8.5)
99994 FORMAT (/, 'Flack Parameter Value ....', F8.3, '(', F6.3, ')')
99993 FORMAT (/, 62X, 'DLC   DLO |I+-I-|', /, 41X, 'DEL', 5X,
     1        'DEL    SIG   ---   --- -------', /,
     2        ' H1 K1 L1 I1(obs)  H2 K2 L2 I2(obs)      OBS',
     3        '    CALC    DEL   SIG   DLC I+ + I-', /, 79('='))
99986 FORMAT ('Res.Scat...................', F8.4, /,
     1        'Friedif_stat ..............', I8)
99984 FORMAT ('Friedel Pair Coverage .....', I8, '%')
99983 FORMAT ('Number of Bijvoet Pairs ...', I8, '[Expected', I6, ']')
99982 FORMAT (2(3I3, I8, 1X), 2I8, I7, 2F6.2, F8.5)
99979 FORMAT ('Number of Centro Reflns ...', I8)
      END SUBROUTINE PLA426
 
      SUBROUTINE PLA427
C * ROUTINE FOR COMPARING TWO FCF STYLE DATA SETS (-d)
      USE files
      USE parameters
      USE plato
      USE cchar
      USE mentry
      USE xwdw
      USE cggt
      USE analysis
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: M
      INTEGER :: N
      INTEGER :: NS
      INTEGER :: IER
      INTEGER :: NRF1
      INTEGER :: NRF2
      INTEGER :: NOPT
      INTEGER :: IHKL
      INTEGER :: JMAX
      INTEGER :: NTOT
      INTEGER :: NSET1
      INTEGER :: NREFM
      INTEGER :: JDAT1
      INTEGER :: JDAT2
      INTEGER :: IHKLM
      INTEGER :: IDAT1
      INTEGER :: IDAT2
      INTEGER :: NSYMH
      INTEGER :: IDTYP1
      INTEGER :: IDTYP2
      REAL    :: DET
      REAL    :: SUM1
      REAL    :: SUM2
      REAL    :: SUM3
      REAL    :: SUM4
      REAL    :: SUM5
      REAL    :: SUMB
      REAL    :: SUMT
      REAL    :: DUMMY
      REAL    :: SCHAAL
C * SET RETURN VALUE
      IGBL(1) = 4
C * CHECK FOR TWO SUPPLIED DATA SET NAMES ON CALLING LINE
      IF (IGBL(19) == 2) THEN
C * SET MAXIMUM NUMBER OF REFLECTIONS
        NREFM    = NP23 / 2
        PAR(440) = 1000.0
C * INIT GRAPHICS
        CALL PLA431
C * SET MENU NUMBER
        IGBL(6) = 34
        IWIN    = IGBL(25) * IGBL(32)
C * GET FIRST DATA SET
        OPEN (LU60, FILE = FILENAMES(1),  STATUS = 'UNKNOWN')
        OPEN (LU61, FILE = 'COMPAREFILE', STATUS = 'UNKNOWN')
C * DETERMINE REFLECTION FILE TYPE
        CALL PLA010 (LU60, IDTYP1, IER)
        IGBL(54)     = 1
        IENTRY(1, 3) = - IDTYP1
        IENTRY(1, 4) = 0
        NREFF1       = 0
C * CONVERT FCF TO HKL (SHELXL FCF STYLE ASSUMED)
        CALL PLA139 (LU6, LU60, LU61, NREFF1)
        IF (NREFF1 == 0) RETURN
        CLOSE  (UNIT = LU60, IOSTAT = IOST)
        REWIND (UNIT = LU61, IOSTAT = IOST)
C * TEST FOR SHELXL STYLE FCF
        IF (IDTYP1 == 1) THEN
C * GET DIRECT CELL DATA FOR FIRST STRUCTURE
          CALL GEN026 (1, AA, REFLCELL)
          CALL GEN003 (AA, BB, DET, 0)
          CALL GEN113 (REFLCELL, CELLA, 6)
          CELLA(7) = SQRT (DET)
          PAR(98)  = CELLA(7)
          NSYMHA   = IPR(255)
          SPGRA    = SPGRNAMF
C * GET REDUCED CELL DATA AND TRANSFORMATION FOR FIRST STRUCTURE
          CALL PLA266 (1)
          CALL GEN113 (PAR(123), RCELLA, 7)
          RCELLA(7) = PAR(99)
          CALL GEN005 (TRNS, TRNSA)
        END IF
C * LOAD REFLECTION DATA TOP DOWN IN VOID AND POINTERS TO THE DATA IN JNSC
C * IH, IK, IL, I, SIG(I)
        N     = NVDR
        NRF1  = 0
C * LIMIT NUMBER OF REFLECTIONS TO NP23/2 MAX
        NREFF1 = MIN (NREFF1, NREFM)
        DO I = 1, NREFF1
          READ  (LU61, 99999) (VOID(J), J = N - 4, N)
          IF (VOID(N) > 0.0) THEN
            NRF1 = NRF1 + 1
            N    = N - 5
          END IF
        END DO
        NREFF1 = NRF1
C * BOTTOM ADDRESS - 1 FOR DATA SET #1
        NSET1 = N
        CLOSE (UNIT = LU61, STATUS = 'DELETE')
C * GET SECOND DATA SET
        OPEN (LU60, FILE = FILENAMES(2),  STATUS = 'UNKNOWN')
        OPEN (LU61, FILE = 'COMPAREFILE', STATUS = 'UNKNOWN')
C * DETERMINE REFLECTION FILE TYPE
        CALL PLA010 (LU60, IDTYP2, IER)
        IGBL(54)     = 2
        IENTRY(2, 3) = -IDTYP2
        IENTRY(2, 4) = 0
        NREFF2       = 0
C * CONVERT FCF TO HKL (SHELXL STYLE ASSUMED)
        CALL PLA139 (LU6, LU60, LU61, NREFF2)
        IF (NREFF2 == 0) RETURN
        CLOSE  (UNIT = LU60, IOSTAT = IOST)
        REWIND (UNIT = LU61, IOSTAT = IOST)
C * TEST FOR SHELXL STYLE FCF
        IF (IDTYP2 == 1) THEN
C * GET DIRECT CELL DATA FOR SECOND STRUCTURE
          CALL GEN026 (1, AA, REFLCELL)
          CALL GEN003 (AA, BB, DET, 0)
          CALL GEN113 (REFLCELL, CELLB, 6)
          CELLB(7) = SQRT (DET)
          PAR(98)  = CELLB(7)
          NSYMHB   = IPR(255)
          SPGRB    = SPGRNAMF
C * GET REDUCED CELL DATA AND TRANSFORMATION FOR SECOND STRUCTURE
          CALL PLA266 (1)
          CALL GEN113 (PAR(123), RCELLB, 6)
          RCELLB(7) = PAR(99)
          CALL GEN005 (TRNS, TRNSB)
        END IF
C * LOAD SECOND DATA SET BELOW THE FIRST ONE
        NRF2   = 0
        NREFF2 = MIN (NREFF2, NREFM)
        DO I = 1, NREFF2
          READ  (LU61, 99999) (VOID(J), J = N - 4, N)
          IF (VOID(N) > 0.0) THEN
            NRF2 = NRF2 + 1
            N    = N - 5
          END IF
        END DO
        NREFF2 = NRF2
        CLOSE (UNIT = LU61, STATUS = 'DELETE')
        NTOT = NREFF1 + NREFF2
C * LOAD DATA TO BE COMPAIRED
   10   DO I = 1, 2
          IF (I == 1) THEN
            IDM = 'SPGR '//SPGRA
            CALL SGSM (0, IDM, SGY, 0, 0, IERR)
            CALL GEN052 (TRNSA, TM1)
            NSYMH = NSYMHA
            JMAX  = NREFF1
            N     = NVDR
            M     = 0
          ELSE
            IDM = 'SPGR '//SPGRB
            CALL SGSM (0, IDM, SGY, 0, 0, IERR)
            CALL GEN052 (TRNSB, TM1)
            NSYMH = NSYMHB
            JMAX  = NREFF2
            N     = NVDR - NREFF1 * 5
            M     = NREFF1
          END IF
          DO J = 1, JMAX
            N  = N - 5
            DO K = 1, 3
              SGY(K) = VOID(N + K)
            END DO
C * REDUCED CELL TOGGLE
            IF (IPR(657) == 0) THEN
              IHKLM = NINT (SGY(3)) * 62500 + NINT (SGY(2)) * 250
     1              + NINT (SGY(1))
            ELSE
              IHKLM = 0
              DO NS = 1, NSYMH
                CALL SGSM (5, IDM, SGY, NS, 0, IERR)
                CALL GEN002 (1, TM1, SGY(7), V2, DUMMY)
                IHKL = NINT (V2(3)) * 62500 + NINT (V2(2)) * 250
     1              + NINT (V2(1))
                IHKLM = MAX (IHKLM, IHKL, -IHKL)
              END DO
            END IF
C * PACK H,K,L IN ONE INTEGER (MAX INDEX 124)
            JNSC (1, M + J) = IHKLM
            JNSC (2, M + J) = N + 1
          END DO
        END DO
C * SORT POINTER TO DATA ARRAY ON PACKED HKL
        CALL GEN037 (JNSC, 1, NTOT)
C * LOAD REFLECTION DATA FOR PAIRED REFLECTIONS BOTTOM UP
        NREF = 0
        M    = 0
        SUMT = 0.0
        SUMB = 0.0
        IDAT1 = JNSC (1, 1)
        DO I = 2, NTOT
          IDAT2 = JNSC (1, I)
          IF (IDAT1 == IDAT2) THEN
            JDAT1 = JNSC (2, I - 1)
            JDAT2 = JNSC (2, I)
            IF (JDAT2 > NSET1) CALL GEN014 (JDAT1, JDAT2)
            VOID(M + 4) = MAX (0.0, VOID(JDAT1 + 3)) / 100.0
            VOID(M + 5) = MAX (0.0, VOID(JDAT2 + 3)) / 100.0
            VOID(M + 6) = MAX (0.0, VOID(JDAT1 + 4)) / 100.0
            VOID(M + 7) = MAX (0.0, VOID(JDAT2 + 4)) / 100.0
            SUMT        = SUMT + VOID(M + 4)
            SUMB        = SUMB + VOID(M + 5)
            NREF        = NREF + 1
            M           = M    + NREC
          ELSE
            IDAT1 = IDAT2
          END IF
        END DO
C * DETERMINE INTER DATA SET SCALE
        SCHAAL = SUMT / SUMB
C * SAVE TOP ADDRESS
        NADR  = M
C * SCALE AND COPY (Fo-Fc)/Sig TO SEPARATE SECTION IN VOID
        M = 0
        DO I = 1, NREF
          VOID(M + 5)    =  VOID(M + 5) * SCHAAL
          VOID(M + 7)    =  VOID(M + 7) * SCHAAL
          VOID(NADR + I) = (VOID(M + 4) - VOID(M + 5)) /
     1                 SQRT (VOID(M + 6)**2 + VOID(M + 7)**2)
          M = M + NREC
        END DO
 
C * CALC PEARSON's CC
        M = 0
        SUM1 = 0.0
        SUM2 = 0.0
        SUM3 = 0.0
        SUM4 = 0.0
        SUM5 = 0.0
        DO I = 1, NREF
          SUM1 = SUM1 + VOID(M + 4)
          SUM2 = SUM2 + VOID(M + 5)
          SUM3 = SUM3 + VOID(M + 4) * VOID(M + 5)
          SUM4 = SUM4 + VOID(M + 4) ** 2
          SUM5 = SUM5 + VOID(M + 5) ** 2
          M = M + NREC
        END DO
        PAR(565) = (NREF * SUM3 - SUM1 * SUM2) /
     1    SQRT ((NREF * SUM4 - SUM1 ** 2) * (NREF * SUM5 - SUM2 **2))
C * CREATE NORMAL PROBABILITY PLOT DATA
        CALL GEN116 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NREF,
     1    GRAPH, 0)
        GRAPH(5)(52:104) =
     1    'NPP for (Io1 - Io2) / sqrt(sig(Io1)**2 + sig(Io2)**2)'
C * SET LOG-LOG DEFAULT
        IPR(633) = 1
        NOPT     = 1
   20   IF (NREFF1 > 0 .AND. NREFF2 > 0) THEN
          IF (NOPT == 0) THEN
C * DISPLAY NPP DATA
            CALL PLA204
          ELSE IF (NOPT == 1) THEN
C * SCATTER PLOT
            CALL PLA419 (1, SCHAAL, IDTYP1, IDTYP2, LU6)
C * POSTSCRIPT OUTPUT MODE
            IF (IGBL(3) == 47) RETURN
          END IF
C * SCATTER PLOT
          DO
C * WHAT NEXT ?
   30       CALL PLA012 (0, 1)
            IF (LRET == 2) GO TO 20
            CALL GEN020 (1, IGGT, 1, 10)
            SELECT CASE (IGGT(1:4))
C * END
              CASE ('END ')
                RETURN
C * EXIT
              CASE ('EXIT')
                RETURN
C * PLOT
              CASE ('PLOT')
                GO TO 20
C * PLOT
              CASE ('!   ')
                 GO TO 20
C * NORMAL PROBABILITY PLOT
              CASE ('NPP ')
                NOPT = 0
                GO TO 20
C * SCATTER-PLOT
              CASE ('SCAT')
                NOPT = 1
                GO TO 20
C * LOGLOG-PLOT
              CASE ('LOGL')
                IPR(633) = 1
                IPR(634) = 0
                NOPT     = 1
                GO TO 20
C * LINEAR-PLOT
              CASE ('LINE')
                IPR(633) = 0
                IPR(634) = 0
                GO TO 20
              CASE ('STAN')
                GO TO 30
C * REDUCED CELL TOGGLE
              CASE ('REDU')
                IPR(657) = MOD (IPR(657) + 1, 2)
                GO TO 10
            END SELECT
          END DO
        END IF
      END IF
      RETURN
99999 FORMAT (3F4.0, 2F8.0)
      END SUBROUTINE PLA427
 
      SUBROUTINE PLA428
C * CHECK FOR SHELXL20XY AND NOT SHELXL97 (FOR HYBRID & FCFfromCIF)
      USE files
      USE parameters
      USE cchar
      IMPLICIT NONE
      INTEGER :: I
      IF (IGBL(110) > 0 .AND. IGBL(139) == 0) THEN
        KERR = 0
C * RUN DUMMY SHELXL JOB
        CALL SPAWN (SHLPATH(1:IGBL(110))//' > log', LU6, .true., KERR)
        IF (KERR == 0) THEN
          OPEN (UNIT = LU60, FILE = 'log', STATUS = 'UNKNOWN',
     1    IOSTAT = IOST)
          IF (IOST == 0) THEN
            DO I = 1, 5
              READ (LU60, 99999, IOSTAT = IOST) LINE
              IF (IOST == 0) THEN
                IF (INDEX (LINE, 'Version 20') /= 0) THEN
                  IGBL(139) = 1
                  EXIT
                END IF
              END IF
            END DO
            CLOSE (LU60, STATUS = 'DELETE', IOSTAT = IOST)
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (A)
      END SUBROUTINE PLA428
 
      SUBROUTINE PLA429
C * TEST FOR PLATON & SHELXL  ETC.                          *
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER :: FINDEXE
C * CHECK For PLATON
      PLAPATH  = ' '
      IGBL(80) = FINDEXE ('PLAEXE', PLAPATH, 'platon')
C * CHECK For SHELXL/XL (REFINEMENT) - VERSION 20xy
      SHLPATH = ' '
      IGBL(110) = FINDEXE ('SHLEXE', SHLPATH, 'shelxl')
      IF (IGBL(110) == 0)
     1    IGBL(110) = FINDEXE ('SHLEXE', SHLPATH, 'xl')
C * CHECK for SHELXT/XT (STRUCTURE SOLUTION)
      SHTPATH = ' '
      IGBL(119) = FINDEXE ('SHTEXE', SHTPATH, 'shelxt')
      IF (IGBL(119) == 0)
     1    IGBL(119) = FINDEXE ('SHTEXE', SHTPATH, 'xt')
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/CQBATCH
      IGBL(76) = FINDEXE ('QUESTEXE', CGETENV, 'cqbatch')
C * CHECK FOR PS2PDF CONVERSION UTILITY
      IGBL(116) = FINDEXE ('PS2PDF', CGETENV, 'ps2pdf')
C * HTTPSERVER LOCATION
      IGBL(135) = LEN_TRIM (HTTPSERVER)
C * CHECK FOR FIREFOX etc.  HELP
C * FIRST CHECK FOR FIREFOX ON MAC
      BROWSER = '/Applications/safari.app/Contents/MacOS/safari'
      INQUIRE (FILE = BROWSER, EXIST = EXST)
      IF (EXST) THEN
        BROWSER = 'open -a safari'
        IGBL(47) = 14
      ELSE
        IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'firefox')
      END IF
C * OPEN SCRATCH FILE FOR ALERTS (AND EXIT IN CASE OF SCRATCH OPEN ERROR)
        OPEN (UNIT = LU68, STATUS = 'SCRATCH', FORM = 'FORMATTED',
     1    IOSTAT = IOST)
        IF (IOST /= 0)
     1    CALL GEN127 ('OPEN ERROR ON ALERT SCRATCH FILE LU20')
        OPEN (UNIT = LU20, STATUS = 'SCRATCH', FORM = 'FORMATTED',
     1    IOSTAT = IOST)
        IF (IOST /= 0)
     1    CALL GEN127 ('OPEN ERROR ON ALERT SCRATCH FILE LU20')
C * SCRATCH I/SIGMA(I) (CALCULATED DATA)
        OPEN (UNIT = LU67, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1    IOSTAT = IOST)
        IF (IOST /= 0)
     1    CALL GEN127 ('OPEN ERROR ON ALERT SCRATCH FILE LU67')
      RETURN
      END SUBROUTINE PLA429
 
      SUBROUTINE PLA430 (UPDATE)
      USE files
      USE parameters
      IMPLICIT NONE
      INTEGER                         :: J
      INTEGER                         :: I1
      INTEGER                         :: I2
      INTEGER                         :: I3
      INTEGER                         :: J1
      INTEGER                         :: J2
      INTEGER                         :: J3
      INTEGER                         :: FINDEXE
      CHARACTER(len=*)                :: UPDATE
      CHARACTER(len=12)               :: UPDATE1
      CHARACTER(len=3)                :: MONTH
      CHARACTER(len=3), DIMENSION(12) :: MONTHS
      CHARACTER(len=255)              :: BUFFER
      MONTHS = (/ 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', 'JUL',
     1 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/)
      IF (UPDATE(1:1) /= ' ') RETURN
C STRIP_END
      RETURN
99999 FORMAT (A)
99998 FORMAT (/)
99997 FORMAT (/, '** curl NOT found; No current PLATON version shown',
     1 /)
99996 FORMAT (/, '** Can not download update-history file', /)
99995 FORMAT (':: Get Info on Latest UNIX PLATON Version on Server:',
     1 /, ':: ', A, /)
99994 FORMAT(':: Latest Update Version on Server: ', A, /)
      END SUBROUTINE PLA430
 
      SUBROUTINE PLA431
C * INIT GRAPHICS
      USE files
      USE parameters
      USE cchar
      USE cggt
      IMPLICIT NONE
      INTEGER :: N
      INTEGER :: N10
      INTEGER :: N11
      INTEGER :: N20
      INTEGER :: N21
      INTEGER :: KFIL
 
C * INIT GGIP GRAPHICS (NOT FOR -u and -V (-W))
      IF ((IGBL(3) /= 1 .AND. IGBL(3) /= 33 .AND. IGBL(3) /= 34)
     1  .AND. (IGBL(50) > -1 .AND. IGBL(50) < 2))  THEN
        KFIL = KNMFIL
        N10 = 1
        N11 = INDEX (FILENAMES(1), '.') - 1
        DO N = 1, N11
          IF (FILENAMES(1)(N:N) == '/') N10 = N + 1
        END DO
C * CREATE FILENAME FOR POSTSCRIPT RESULT OF FCF FILE COMPARISON (-d, -J)
        IF (IGBL(3) == 6 .OR. IGBL(3) == 47) THEN
          N20 = 1
          N21 = INDEX (FILENAMES(2), '.') - 1
          DO N = 1, N21
            IF (FILENAMES(2)(N:N) == '/') N20 = N + 1
          END DO
          NAMEFIL = FILENAMES(1)(N10:N11)//'_'//FILENAMES(2)(N20:N21)
          KFIL    = N11 - N10 + N21 - N20 + 3
        END IF
        IF (IGBL(3) == 5) THEN
          IGGT(2:80) = FILENAMES(1)(N10:N11)//'_sq'
          KFIL  = N11 + 3
        ELSE
          IGGT(2:80) = NAMEFIL(1:79)
        END IF
C * GENERAL GRAPHICS OPEN
        CALL GGIP (-999.0, FLOAT (-KFIL), 0.0, 5)
C * POSTSCRIPT GRAPHICS FOR SQUEEZE, ADP & POWDER ICALC (-q, -O, -J)
        IF (IGBL(3) == 5 .OR. IGBL(3) == 28 .OR. IGBL(3) == 47) THEN
          MEDIUM      = 1
          IGGT(16:22) = 'OFF    '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        END IF
C * CHECK FOR X11 (0/1)
        YGGIP = 0.0
        ZGGIP = 0.0
        CALL GGIP (-999.0, YGGIP, ZGGIP, 8)
        IGBL(32) = NINT (YGGIP)
      END IF
      RETURN
      END SUBROUTINE PLA431
 
      SUBROUTINE PLA432 (LRET0, TM, LU, LIS, ISPR47, YPAR, KNN)
C * TRMX - GRAPHICS
      USE files
      USE parameters
      USE xwdw
      USE cggt
      USE spgrdata
      USE lplat
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: LU
      INTEGER               :: KL
      INTEGER               :: KN
      INTEGER               :: LIS
      INTEGER               :: KNN
      INTEGER               :: ICOL
      INTEGER               :: IVAL
      INTEGER               :: NA12
      INTEGER               :: NA13
      INTEGER               :: NA23
      INTEGER               :: NALF
      INTEGER               :: NBET
      INTEGER               :: NGAM
      INTEGER               :: LRET0
      INTEGER               :: ISPR47
      REAL                  :: DET
      REAL, DIMENSION(3, 3) :: TM
      REAL, DIMENSION(3, 3) :: AA
      REAL, DIMENSION(3, 3) :: BB
      REAL, DIMENSION(3, 3) :: DUM
      REAL, DIMENSION(9)    :: FNN
      REAL, DIMENSION(*)    :: YPAR
      CHARACTER(len=1)      :: ICH
      CHARACTER(len=80)     :: LINE
      CHARACTER(len=80)     :: LIJN
      CHARACTER(len=1)      :: NSYS
C * SET MENU #
      IGBL(6) = 37
      EXST    = .FALSE.
      IF (KNN == 9) THEN
        DO I = 1, 9
          FNN(I) = FN(I)
        END DO
      END IF
C * LIST BRAVAIS LATTICE SELECTIONS
C * CHECK FOR AUTO-S MODE
   10 IF (IGBL(50) == 0) THEN
C * CHECK FOR SYSTEM-S MODE
        IF (IPR(548) == 1) 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 > 0) THEN
          LIJN = '(Pseudo)Extinctions Found in Input Reflection file'
          CALL PLA439 (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.45
          LIJN = '    Ex. Condition    av[I/sig(I)]  Number of Refl '//
     1           'I/sigI             .T./.F.'
          CALL PLA439 (0.0, LIJN, 80, 0.35, 5 + IGBL(68), 2, 0.1, VRT)
          VRT = VRT - 0.45
          LIJN = '                    .True. .False. .True. .False.'//
     1           '  Max.F    H  K  L   Ratio'
          CALL PLA439 (0.0, LIJN, 80, 0.35, 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
C * LIST GENERAL EXTINCTIONS (IF ANY)
          REWIND (UNIT = LU, IOSTAT = IOST)
          DO
            READ (LU, 99988, IOSTAT = IOST) LINE
            IF (IOST /= 0) EXIT
            IF (LINE(1:4) == 'EXTI') THEN
              CALL PLA439 (0.0, LINE(6:80), 75, 0.35, 1, 2, 0.1, VRT)
              VRT = VRT - 0.45
            END IF
          END DO
          BACKSPACE LU
          VRT = VRT + 0.3
          CALL GGIP (0.0,  VRT, 0.0, 3)
          CALL GGIP (HORS, VRT, 0.0, 2)
          VRT = VRT - 0.5
        END IF
C * LIST/DISPLAY POTENTIAL LATTICE / LAUE CLASS OPTIONS
        LIJN = 'Cell Transformations to Optional Crystal System, '//
     1         'Lattice Type and Laue Class'
        WRITE (LU6, 99986, IOSTAT = IOST) LIJN
        WRITE (LIS, 99986, IOSTAT = IOST) LIJN
        WRITE (LU6, 99984, IOSTAT = IOST)
        WRITE (LIS, 99984, IOSTAT = IOST)
        CALL PLA439 (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)
        IF (CLATT(1) == 'a' .AND. CLATT(2) == 'a') THEN
          IF (BLATT(1) /= 'P' .AND. BLATT(2) == 'P') THEN
            IF (RVAL(1, 1) == 0.0 .AND. RVAL(2, 2) /= 0.0) THEN
              DO I = 1, 3
                RVAL(1, I) = RVAL(2, I)
              END DO
            END IF
          ELSE IF (BLATT(1) == 'P' .AND. BLATT(2) == 'P') THEN
            IF (ABS (XCELL(7, 1) - XCELL(7, 2)) < 0.1) THEN
              IF (RVAL(2, 2) == 0.0 .AND. RVAL(1, 2) /= 0.0) THEN
                DO I = 1, 3
                  RVAL(2, I) = RVAL(1, I)
                END DO
              END IF
            END IF
          END IF
        END IF
        LIJN = ' # Latt  Laue Rav %Ct %Nav       '//
     1   'Transformation Matrix / Cell + Volume'
        WRITE (LU6, 99986, IOSTAT = IOST) LIJN
        WRITE (LIS, 99986, IOSTAT = IOST) LIJN
        VRT = VRT - 0.5
        CALL PLA439 (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
C * LOOP/LIST OVER BRAVAIS LATTICE OPTIONS
        DO K = 1, NRLT0
          VRT = VRT - 0.5
C * GREEN/RED TESTS ON RVAL, COMPLETENESS
          IF (RVAL(K, 1) < RMAX .AND. (RVAL(K, 2) > PAR(432) .OR.
     1        RVAL(K, 1) < 0.0001)) THEN
            ICOL = 3
          ELSE
            ICOL = 2
          END IF
          WRITE (LIJN, 99998, IOSTAT = IOST)
     1      K, ELATT(K), CLATT(K), BLATT(K), NLAUE(LLAUE(K)),
     2      (NINT (RVAL(K, J)), J = 1, 3), (TLATT(J, K), J = 1, 9)
          WRITE (LU6, 99988, IOSTAT = IOST) LIJN
          WRITE (LIS, 99988, IOSTAT = IOST) LIJN
C * MODIFY PRINT-BUFFER
          CALL GEN065 (0, LIJN, 1, 80, 5)
          CALL PLA439 (0.0, LIJN, 80, 0.35, ICOL, 2, 0.1, VRT)
          WRITE (LIJN, 99997, IOSTAT = IOST) (XCELL(J, K), J = 1, 7)
          WRITE (LU6, 99985, IOSTAT = IOST) LIJN(1:53)
          WRITE (LIS, 99985, IOSTAT = IOST) LIJN(1:53)
          VRT = VRT - 0.25
          CALL PLA439 (0.0, LIJN, 80, 0.20, 1, 1, 9.0, VRT)
        END DO
C * ASK FOR SELECTION NUMBER OR MATRIX (0, 1 OR 9 NUMBERS)
        ISPR47 = 0
        IF (KNN == 9) THEN
          DO I = 1, 9
            FN(I) = FNN(I)
          END DO
          KNN = 0
          KN  = 9
          KL  = 0
        END IF
        IF (KN == 9) GO TO 50
        INQUIRE (FILE = '.newsym.ntr', EXIST = EXST)
C * CHECK FOR ADDSYM GENERATED NEW SYMMETRY
        IF (EXST) THEN
          OPEN (LU61, FILE = '.newsym.ntr', STATUS = 'UNKNOWN')
          READ (LU61, 99988) LINE
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          ISPR47 = 1
          GO TO 40
        END IF
C * SELECT BRAVAIS LATTICE
   30   WRITE (SBCD, 99996, IOSTAT = IOST) NRLT, CHAR (0)
        IGBL(28) = 1
C * WHAT NEXT ?
        CALL PLA012 (0, 1)
        IGBL(28) = 0
        IF (IGGT(1:4) == 'PLOT') GO TO 10
        IF (IGGT(1:4) == 'EXIT') THEN
          LRET0 = 1
          RETURN
        END IF
        IF (IGGT(1:1) /= ' ' .AND. IGGT(1:1) /= '!') THEN
          LINE = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          WRITE (LINE, 99987, IOSTAT = IOST) NRLT
        END IF
C * PARSE SELECTION
   40   CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
   50   IF (KN == 1 .AND. FN(1) > 0 .AND. FN(1) <= NRLT0)  THEN
          NRLT = NINT (FN(1))
        ELSE IF (KN == 0 .AND. KL == 0) THEN
          GO TO 70
        ELSE IF (KN >= 9) THEN
C * CHECK DETERMINANT
          CALL GEN003 (FN(1), DUM, DET, 0)
          IF (ABS (DET) < 0.01) THEN
            WRITE (LU6, 99994, IOSTAT = IOST)
            GO TO 30
          END IF
          DO I = 1, 9
            TLATT(I, NP18) = FN(I)
            K = (I - 1) / 3 + 1
            J = MOD (I - 1, 3) + 1
            TM(K, J) = FN(I)
          END DO
          CLATT(NP18)    = ' '
          BLATT(NP18)    = ' '
          ELATT(NP18)    = ' '
          LLAUE(NP18)    = 13
          RVAL(NP18, 1)  = 0.0
          RVAL(NP18, 2)  = 0.0
          RVAL(NP18, 3)  = 0.0
          IF (KL > 0 .AND. IFL(KL)(1:4) /= 'TRMX') THEN
            CLATT(NP18) = IFL(KL)(1:1)
            BLATT(NP18) = IFL(KL)(2:2)
            ELATT(NP18) = ' '
            CALL GEN020 (-1, CLATT(NP18), 1, 1)
            CALL GEN020 (1,  BLATT(NP18), 1, 1)
          END IF
          DO 60 K = 1, NRLT0
            DO I = 1, 9
              IF (TLATT(I, K) /= TLATT(I, NP18)) GO TO 60
            END DO
            IF (BLATT(K) /= BLATT(NP18)) GO TO 60
            IF (CLATT(K) /= CLATT(NP18)) GO TO 60
            NRLT = K
            GO TO 30
   60     CONTINUE
          NRLT0 = NRLT0 + 1
C * TRANSFORM CELL-PARAMETERS
          CALL GEN026 (1, AA, YPAR(81))
          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))
          CALL GEN003 (BB, AA, DET, 0)
          YPAR(107) = SQRT (DET)
          DO I = 1, 9
            TLATT(I, NRLT0) = TLATT(I, NP18)
          END DO
          DO I = 1, 7
            XCELL(I, NRLT0) = YPAR(100 + I)
          END DO
          CLATT(NRLT0) = CLATT(NP18)
          BLATT(NRLT0) = BLATT(NP18)
          ELATT(NRLT0) = ELATT(NP18)
          LLAUE(NRLT0) = 13
          NRLT  = NRLT0
          IF (ISPR47 == 0) GO TO 10
        ELSE
          CALL PLA015 (0, 24)
          GO TO 30
        END IF
      END IF
C * CHECK FOR ALREADY KNOWN CRYSTAL SYSTEM
   70 IF (CLATT(NRLT) == ' ') THEN
        IF (ISPR47 == 1) THEN
          IFL(1) = IFL(2)
        ELSE
          DO
            WRITE (BCD, 99993, IOSTAT = IOST) CHAR (0)
            CALL GGIP (-999.0, 3.0, 80.0, 112)
C * GUESS DEFAULT CRYSTAL SYSTEM
            NALF = 0
            NBET = 0
            NGAM = 0
            NA12 = 0
            NA13 = 0
            NA23 = 0
            NSYS = 'a'
            IF (ABS (XCELL(4, NRLT) - 90.0)           < 0.05) NALF = 1
            IF (ABS (XCELL(5, NRLT) - 90.0)           < 0.05) NBET = 1
            IF (ABS (XCELL(6, NRLT) - 90.0)           < 0.05) NGAM = 1
            IF (ABS (XCELL(6, NRLT) - 120.0)          < 0.05) NGAM = 2
            IF (ABS (XCELL(1, NRLT) - XCELL(2, NRLT)) < 0.01) NA12 = 1
            IF (ABS (XCELL(1, NRLT) - XCELL(3, NRLT)) < 0.01) NA13 = 1
            IF (ABS (XCELL(2, NRLT) - XCELL(3, NRLT)) < 0.01) NA23 = 1
            IF (NALF + NBET + NGAM == 1) THEN
              NSYS = 'm'
            ELSE IF (NALF == 1 .AND. NBET == 1 .AND. NGAM == 2) THEN
              IF (NA12 == 1) THEN
                NSYS = 'h'
              ELSE
                NSYS = 'm'
              END IF
            ELSE IF (NALF == 1 .AND. NBET == 1 .AND. NGAM == 1) THEN
              IF (NA12 == 1 .AND. NA13 == 1 .AND. NA23 == 1) THEN
                NSYS = 'c'
              ELSE IF (NA12 == 1) THEN
                NSYS = 't'
              ELSE
                NSYS = 'o'
              END IF
            END IF
            WRITE (SBCD, 99987, IOSTAT = IOST) NRLT, NSYS, CHAR (0)
C * WHAT NEXT ?
            CALL PLA012 (0, 1)
            IF (IGGT(1:4) == 'EXIT') THEN
              LRET0 = 1
              RETURN
            END IF
            IF (IGGT(1:4) /= 'PLOT') EXIT
          END DO
          IF (IGGT(1:1) /= ' ' .AND. IGGT(1:1) /= '!') THEN
            LINE = IGGT
            CALL GEN038 (IGGT, 1, 80)
          ELSE
            LINE = NSYS
          END IF
          CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
        END IF
        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)
        GO TO 70
      END IF
C * CHECK FOR ALREADY KNOWN BRAVAIS LATTICE TYPE
      IF (BLATT(NRLT) == ' ') THEN
        DO
          WRITE (BCD, 99990, IOSTAT = IOST) CHAR (0)
          CALL GGIP (-999.0, 3.0, 80.0, 112)
          WRITE (SBCD, 99992, IOSTAT = IOST) NRLT, CHAR (0)
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
            IF (IGGT(1:4) == 'EXIT') THEN
            LRET0 = 1
            RETURN
          END IF
          IF (IGGT(1:4) /= 'PLOT') EXIT
        END DO
        IF (IGGT(1:1) /= ' ' .AND. IGGT(1:1) /= '!') THEN
          LINE = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          LINE = 'P '
        END IF
        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)
      END IF
C * CHECK FOR ALREADY KNOWN LAUE CLASS
      IF (LLAUE(NRLT) == 13) THEN
        IF (ISPR47 == 1) THEN
          FN(1) = FN(10)
        ELSE
          DO
            WRITE (BCD, 99989, IOSTAT = IOST) CHAR (0)
            CALL GGIP (-999.0, 3.0, 80.0, 112)
            ICH = CLATT(NRLT)
            SELECT CASE (ICH)
              CASE ('a')
                IVAL = 1
              CASE ('m')
                IVAL = 2
              CASE ('o')
                IVAL = 3
              CASE ('t')
                IVAL = 4
              CASE ('h')
                IF (BLATT(NRLT) == 'R') THEN
                  IVAL = 6
                ELSE
                  IVAL = 9
                END IF
              CASE ('c')
              IVAL = 11
            END SELECT
            WRITE (SBCD, 99991, IOSTAT = IOST) NRLT, IVAL, CHAR (0)
C * WHAT NEXT ?
            CALL PLA012 (0, 1)
            IF (IGGT(1:4) == 'EXIT') THEN
              LRET0 = 1
              RETURN
            END IF
            IF (IGGT(1:4) /= 'PLOT') EXIT
          END DO
          IF (IGGT(1:1) /= ' ' .AND. IGGT(1:1) /= '!') THEN
            LINE = IGGT
            CALL GEN038 (IGGT, 1, 80)
          ELSE
            WRITE (LINE, 99999, IOSTAT = IOST) IVAL
          END IF
          CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
          IF (KN == 0) FN(1) = 1.0
          IF (NINT (FN(1)) < 1 .OR. NINT (FN(1)) > 12) FN(1) = 1.0
        END IF
        LLAUE(NRLT) = NINT (FN(1))
        DO I = 1, 3
          RVAL(NRLT, I) = RVL(LLAUE(NRLT), I)
        END DO
        IF (ISPR47 == 0) GO TO 10
      END IF
      RETURN
99999 FORMAT (I3)
99998 FORMAT (I2, A,'= ', 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)
99986 FORMAT (/, A)
99985 FORMAT (25X, A)
99984 FORMAT (/, 'Note: %Ct  = percentage of Completeness', /,
     1           '      %Nav = Percentage of Symmetry Averaged ',
     2           'Reflections', /)
      END SUBROUTINE PLA432
 
      SUBROUTINE PLA439 (THETA, TEXT, NCHAR, HEIGHT, NCOL, LTHICK, X, Y)
C * PLOT TEXT STRING ROUTINE
C * THETA  = ROTATION ANGLE (DEGREES)
C * TEXT   = ASCII TEXT STRING
C * NCHAR  = NUMBER OF CHARACTERS IN TEXT
C * HEIGHT = CHARACTER HEIGHT
C * NCOL   = COLOUR
C * LTHICK = LINE THICKNESS
C * X      = X-POSITION OF LOWER LEFT CORNER OF FIRST TEXT CHARACTER
C * Y      = Y-POSITION OF LOWER LEFT CORNER OF FIRST TEXT CHARACTER
      USE cggt
      IMPLICIT NONE
      INTEGER          :: NCOL
      INTEGER          :: NCHAR
      INTEGER          :: LTHICK
      REAL             :: X
      REAL             :: Y
      REAL             :: XVAL
      REAL             :: YVAL
      REAL             :: ZVAL
      REAL             :: THETA
      REAL             :: HEIGHT
      CHARACTER(len=*) :: TEXT
      THET = THETA
      CHT  = HEIGHT
      NCHE = NCHAR
      BCD  = TEXT(1:NCHE)
      XVAL = X
      YVAL = Y
      ZVAL = 0.0
      IF (NCOL >= 0) CALL GGIP (0.0, FLOAT (NCOL), 0.0, 0)
      IF (LTHICK /= 0) THEN
        CALL GGIP (0.0, - FLOAT (LTHICK), 0.0, 0)
        CALL GGIP (XVAL, YVAL, ZVAL, 4)
        CALL GGIP (0.0, -1.0, 0.0, 0)
      ELSE
        CALL GGIP (XVAL, YVAL, ZVAL, 4)
      END IF
      IF (NCOL >= 0) CALL GGIP (0.0, 1.0, 0.0, 0)
      RETURN
      END SUBROUTINE PLA439
 
 
      SUBROUTINE PLA440 (MODE)
C * INTERACTIVE DIST, ANGLE, TORSION & FIT CALCULATION
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: J0
      INTEGER               :: K0
      INTEGER               :: NC
      INTEGER               :: NW
      INTEGER               :: NAT
      INTEGER               :: ISD
      INTEGER               :: NEX
      INTEGER               :: IER
      INTEGER               :: IFT
      INTEGER               :: ILP
      INTEGER               :: LBB
      INTEGER               :: LBC
      INTEGER               :: LBD
      INTEGER               :: IBEG
      INTEGER               :: ISO1
      INTEGER               :: ISO2
      INTEGER               :: LOOP
      INTEGER               :: NIEN
      INTEGER               :: ISVI
      INTEGER               :: ISVJ
      INTEGER               :: NSVI
      INTEGER               :: NSVJ
      INTEGER               :: MODE
      INTEGER               :: NMAX
      INTEGER               :: NDIJ
      INTEGER               :: IENM
      INTEGER               :: IEND
      INTEGER               :: IDUM
      INTEGER               :: NDEC
      INTEGER               :: JDUM
      INTEGER               :: IDIJ
      INTEGER               :: IATPI
      INTEGER               :: IDUM1
      INTEGER               :: IDUM2
      INTEGER               :: IMODE
      INTEGER               :: ISDIS
      INTEGER               :: NRES1
      INTEGER               :: NRES2
      INTEGER               :: NDIST
      INTEGER               :: ISANG
      INTEGER               :: NANAL
      INTEGER               :: INQNR
      INTEGER               :: JNQNR
      INTEGER, DIMENSION(8) :: ISPV
      REAL                  :: D
      REAL                  :: SD
      REAL                  :: VI
      REAL                  :: VJ
      REAL                  :: SVI
      REAL                  :: SVJ
      REAL                  :: ANG
      REAL                  :: DET
      REAL                  :: DIJ
      REAL                  :: DIS
      REAL                  :: ANG1
      REAL                  :: ANG2
      REAL                  :: DIS1
      REAL                  :: DIS2
      REAL                  :: DIS3
      REAL                  :: SDIJ
      REAL                  :: SDIS
      REAL                  :: SANG
      REAL                  :: YUNK
      REAL                  :: THIRSH
      REAL                  :: VARDIST
      CHARACTER(len=1)      :: INQ1
      CHARACTER(len=34)     :: FORMD
      CHARACTER(len=35)     :: FORMC
      CHARACTER(len=36)     :: FORMH
      CHARACTER(len=40)     :: FORME
      CHARACTER(len=47)     :: FORMR
      CHARACTER(len=48)     :: FORMA
      CHARACTER(len=48)     :: FORMB
      CHARACTER(len=48)     :: FORMT
      CHARACTER(len=58)     :: FORML
      CHARACTER(len=86)     :: FORMX
      IWIN = IGBL(25) * IGBL(32)
      FORMX(1:28)   = '(''P ='',F8.4,''('',I4,''), Q ='','
      FORMX(29:61)  = 'F8.4,''('',I4,''), R ='',F8.4,''('',I4,'
      FORMX(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,'')'')'
      FORMR( 1:26) = '(''Hirshfeld R-B Dif'',F8.5,'
      FORMR(27:47) = '''('',I3,''), Rat'',F5.1)'
      ANG   = 0.0
      SANG  = 0.0
      D     = 0.0
      SD    = 0.0
      ISANG = 0
      ISD   = 0
      PAGET = 'SelGeom'
C * MODE =  0 - LU7 PRINT ONLY
C * MODE =  1 - LU6 + LU7 PRINT
C * SELECTED BOND, ANGLE, TORSION, FIT AND LSPL GEOMETRY CALCULATIONS
C * GET NUMBER OF ATOMS
      NAT     = IPR(39)
C * GET TOTAL NUMBER OF ATOMS + CENTROIDS
      NMAX    = NAT + IPR(64)
      IPR(97) = IPR(97) + 1
      IF (IPR(97) == 1 .AND. IGBL(63) > 1 .AND. MODE == 1) THEN
C * NEWPAGE
        CALL PLA262 (-3)
        WRITE (LU7, 99997, IOSTAT = IOST)
      END IF
C * GET NUMBER OF SPECIFIED LABELS
      N = IPR(81)
      IF (N < 0) THEN
        IPR(12) = 0
        N       = - N
C * INTERACTIVE FIT
        IF (IFL(1) == 'FIT') THEN
           CALL PLA441 (N, NANAL, NRES1, NRES2)
           IF (IPR(2) /= 0) GO TO 30
C * QUATERNION FIT
          IF (IPR(12) >= IPR(28) * 2) THEN
            VARDIST = 999.0
            CALL PLA442 (1, VARDIST)
C * COMPARE BOND & ANGLES IN FITTED RESIDUES
            IF (NANAL /= 0) CALL PLA084 (NRES1, NRES2)
          ELSE
            CALL PLA015 (0, 31)
            WRITE (LU6, 99998, IOSTAT = IOST)
          END IF
        ELSE
          LOOP = 1
          NW   = 0
C * LOOK FOR DIHEDRAL ANGLE REQUEST
          DO I = 2, N
            IF (IFL(I) == 'WITH') THEN
              NW   = I
              LOOP = 2
            END IF
          END DO
          DO ILP = 1, LOOP
            IF (LOOP == 1) THEN
              IBEG = 2
              IEND = N
            ELSE
              IF (ILP == 1) THEN
                IBEG = 2
                IEND = NW - 1
              ELSE
                IBEG = NW + 1
                IEND = N
              END IF
            END IF
C * LEAST-SQUARES PLANE REQUESTED
            DO I = 1, NMAX
              IATP(I) = I + 2 * NP1
            END DO
            IMODE = 0
            NDIST = 0
            DO I = IBEG, IEND
C * DIST SUB-KEYWORD
              IF (IFL(I) == 'DIST') THEN
                IMODE = 1
              ELSE
C * ATOM-NAME
                CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD,
     1                       INQNR, JNQNR, NIEN)
                IF (NIEN < 0) THEN
C * UNKNOWN CARD ERROR
                  IF (NIEN == -4) THEN
                    IPR(2) = 7
                    GO TO 30
                  ELSE
                    NQ0    = IFL(I)(1:7)
                    IPR(2) = 3
                    GO TO 30
                  END IF
                END IF
                IPR(12)    = IPR(12) + 1 - IMODE
                NDIST      = NDIST + 1
                IATP(NIEN) = NIEN + IMODE * NP1
              END IF
            END DO
C * SORT IATP
            CALL GEN022 (IATP, 1, NMAX, 1)
C * CALCULATE PLANE
            IF (IEND - IBEG > 1) THEN
              CALL PLA055
              DO I = 1, 4
                XLS(I, ILP)     = XPV(I)
                XLS(I + 4, ILP) = XSPV(I)
              END DO
C * LIST PLANE DATA
              IFT = -10
              DO I = 5, 8
                CALL GEN041 (XPV(I), XSPV(I), ISPV(I), 4, NDEC, IPR(68))
                IFT = IFT + 21
                FORMX(IFT : IFT) = CHAR (ICHAR ('0') + NDEC)
              END DO
C * CALCULATE LINE
            ELSE
              CALL PLA227 (IATP(1), IATP(2), VECN)
              CALL PLA053 (IATP(1),IATP(2), 0, 0, D, SD, IDUM1,
     1          IDUM2, IER)
            END IF
C * X-WINDOW OUTPUT
            IF (IWIN == 1) THEN
              IF (ILP == 1) THEN
                CALL GGIP (HORS, VERT, 0.0, 1)
                VRT = VERT - 0.7
                WRITE (PRBUF, 99990, IOSTAT = IOST)
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
                VRT = VRT - 0.7
                WRITE (PRBUF, 99989, IOSTAT = IOST)
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
                WRITE (LU6, 99992, IOSTAT = IOST)
                WRITE (LU6, 99990, IOSTAT = IOST)
                WRITE (LU6, 99989, IOSTAT = IOST)
              ELSE
                VRT = VRT - 1.0
                WRITE (LU6, 99994, IOSTAT = IOST)
              END IF
C * PLANE CASE
              IF (IEND - IBEG > 1) THEN
                WRITE (PRBUF, FORMX, IOSTAT = IOST)
     1            (XPV(I), ISPV(I), I = 5, 8)
                VRT = VRT - 0.6
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                WRITE (PRBUF, 99991, IOSTAT = IOST)
                VRT = VRT - 0.7
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
C * LINE CASE
              ELSE IF (IEND - IBEG == 1) THEN
                CALL PLA439 (0.0, '  Bond', 6, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
              END IF
              VRT = VRT - 0.2
            END IF
C * PLANE CASE
            IF (IEND - IBEG > 1) THEN
              WRITE (LU6, FORMX, IOSTAT = IOST)
     1          (XPV(I), ISPV(I), I = 5, 8)
              WRITE (LU6, 99994, IOSTAT = IOST)
              WRITE (LU6, 99991, IOSTAT = IOST)
              IF (IGBL(63) > 1) THEN
                CALL PLA262 (8)
                WRITE (LU7, 99992, IOSTAT = IOST)
                WRITE (LU7, 99990, IOSTAT = IOST)
                WRITE (LU7, 99989, IOSTAT = IOST)
                WRITE (LU7, FORMX, IOSTAT = IOST)
     1            (XPV(I), ISPV(I), I = 5, 8)
                WRITE (LU7, 99994, IOSTAT = IOST)
                WRITE (LU7, 99991, IOSTAT = IOST)
              END IF
            END IF
C * TEMP GET OR-INVERT INTO UIJ
            CALL GEN003 (OR, UIJ, DET, 0)
C * CALL EXIT/STOP
            IF (DET <= 0.0) CALL GEN127 ('CANNOT INVERT OR')
C * PLANE CASE
            IF (IEND - IBEG > 1) THEN
              DO I = 1, NDIST
                IF (I > IPR(12)) THEN
                  INQ1 = ' '
                ELSE
                  INQ1 = '*'
                END IF
                IATPI = MOD (IATP(I), NP1)
                CALL PLA047 (LABA(IATPI), NQ1, IDUM, JDUM,
     1            IPR(71), 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 J = 1, 3
                  V2(J) = XXO(IATPI, J + 3)
                END DO
                CALL GEN002 (1, UIJ, V2, V1, YUNK)
                WRITE (PRBUF, FORME, IOSTAT = IOST)
     1            INQ1, NQ1(1:7), DIS, ISDIS,
     2            (V1(J), J = 1, 3), (V2(J), J = 1, 3)
                CALL GEN065 (LU6, PRBUF, 1, 80, 1)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.45
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                END IF
                IF (IGBL(63) > 1) THEN
                  CALL PLA262 (1)
                  WRITE (LU7, 99999, IOSTAT = IOST) PRBUF
                END IF
              END DO
C * LINE CASE
            ELSE IF (IEND - IBEG == 1) THEN
              DO I = 1, 2
                CALL PLA047 (LABA(IATP(I)), NQ1, IDUM, JDUM,
     1            IPR(71), IGBL(55), 0, 1 - IGBL(55))
                DO J = 1, 3
                  V2(J) = XXO(IATP(I), J + 3)
                END DO
                CALL GEN002 (1, UIJ, V2, V1, YUNK)
                WRITE (PRBUF, 99993, IOSTAT = IOST) NQ1(1:7),
     1                (V1(J), J = 1, 3), (V2(J), J = 1, 3)
                CALL GEN065 (LU6, PRBUF, 1, 80, 1)
                IF (IWIN == 1) THEN
                  VRT = VRT - 0.45
                  CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                END IF
                IF (IGBL(63) > 1) THEN
                  CALL PLA262 (1)
                  WRITE (LU7, 99999, IOSTAT = IOST) PRBUF
                END IF
              END DO
            END IF
          END DO
          IF (LOOP == 2) THEN
C * PLANE CASE
            IF (IEND - IBEG > 1) THEN
              ANG = RGBL(6) * 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 I = 5, 7
                SANG = SANG + XLS(I, 1)**2 + XLS(I, 2)**2
              END DO
              SANG = RGBL(6) * SQRT (SANG)
              FORMH(3:10) = 'Dihedral'
C * LINE CASE
            ELSE IF (IEND - IBEG == 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          RGBL(6)
              SANG = 0.0
              DO L = 1, 3
                SANG = SANG + XLS(L + 4, 1)**2 + (VECN(L) * SD / D)**2
              END DO
              SANG = RGBL(6) * SQRT (SANG)
              FORMH(3:10) = 'LsplBond'
            END IF
            IF (IEND - IBEG > 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, IOSTAT = IOST) ANG, ISANG
              WRITE (LU6, 99994)
              CALL GEN065 (LU6, PRBUF, 1, 80, 1)
              IF (IWIN == 1) THEN
                VRT = VRT - 1.00
                CALL PLA439 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
              END IF
            END IF
          END IF
          IF (IPR(41) == 0) THEN
            PRBUF = 'UNIT WEIGHTS'
          ELSE IF (IPR(41) == 1) THEN
            PRBUF = 'ATWT WEIGHTS'
          ELSE
            PRBUF = 'ESD/SU WEIGHTS'
          END IF
          WRITE (LU6, 99988, IOSTAT = IOST) PRBUF
          IF (IGBL(63) > 1) THEN
            CALL PLA262 (2)
            WRITE (LU7, 99988, IOSTAT = IOST) PRBUF
          END IF
          IF (IWIN == 1) THEN
            VRT = VRT - 1.0
            CALL PLA439 (0.0, PRBUF, 30, 0.35, 5 + IGBL(68), 2,
     1                   1.0, VRT)
            CALL PLA297 (0)
          END IF
        END IF
C * DISTANCES & ANGLES
      ELSE
        DO I = 2, N
C * PACK ASCII LABEL INTO NUMBER INCLUDING SYMMETRY CODE
          NQ2 = IFL(I)(1:7)
          DO 10 J = 1, 2
            CALL PLA046 (4, NQ2, IENM, LBB, LBC, LBD,
     1                   INQNR, JNQNR, NIEN)
            IF (NIEN < 0) THEN
              IF (NIEN == -4) THEN
C * NOT FOUND, INTRODUCE _ IN FRONT OF CHARACTER I.E C1A --> C1_A
                DO L = 1, 6
                  IF (NQ2(7-L:7-L) /= ' ') THEN
                    NQ2(8-L:8-L) = NQ2(7-L:7-L)
                    NQ2(7-L:7-L) = '_'
                    GO TO 10
                  END IF
                END DO
              END IF
              NQ0    = NQ2
              IPR(2) = 3
              GO TO 30
            END IF
            CALL PLA047 (INQNR, NQ1, IDUM, JDUM, IPR(71), IGBL(55),
     1                   0, 1 - IGBL(55))
            NAMS(I, 1) = ' '//NQ1(1:NP64-1)
            GO TO 20
   10     CONTINUE
C * UNSUITABLE LABEL ENCOUNTERED
          IPR(2) = 7
          GO TO 30
   20     JATC(I) = NIEN
        END DO
        IF (N == 2) THEN
          I   = JATC(2)
          NC  = - NINT (CON(I, 9))
          IF (NC < 0) NC = 9
          DO J = 1, NC
            J0 = NINT (CON(I, J))
            CALL PLA053 (I, J0, 0, 0, D, SD, ISD, NDEC, IER)
            IF (IER == 0) THEN
              FORMC(23:23) = CHAR (ICHAR ('0') + NDEC)
              ISD = MIN (999, ISD)
              CALL PLA047 (LABA(J0), NQ2, IDUM, JDUM, IPR(71),
     1                     IGBL(55), 0, 1 - IGBL(55))
              IF (MODE == 0) CALL PLA262 (1)
              WRITE (PRBUF, FORMC, IOSTAT = IOST) NQ2(1:7), NQ1(1:7),
     1          D, ISD
              IF (MODE == 1) CALL GEN065 (LU6, PRBUF, 1, 80, 1)
              IF (IGBL(63) > 1) CALL GEN065 (LU7, PRBUF, 1, 80, 1)
              DO K = J + 1, NC
                IF (K <= NC) THEN
                  K0 = NINT (CON(I, K))
                  CALL PLA053 (K0, I, J0, 0, ANG, SANG, ISANG, NDEC,
     1                         IER)
                  IF (IER == 0) THEN
                    FORMD(22:22) = CHAR (ICHAR ('0') + NDEC)
                    ISANG = MIN (999, ISANG)
                    CALL PLA047 (LABA(K0), NQ3, IDUM, JDUM,
     1                IPR(71), IGBL(55), 0, 1 - IGBL(55))
                    IF (MODE == 0) CALL PLA262 (1)
                    WRITE (PRBUF, FORMD, IOSTAT = IOST)
     1                NQ2(1:7), NQ1(1:7), NQ3(1:7), ANG, ISANG
                    IF (MODE == 1) CALL GEN065 (LU6, PRBUF, 1, 80, 1)
                    IF (IGBL(63) > 1)
     1                CALL GEN065 (LU7, PRBUF, 1, 80, 1)
                  END IF
                END IF
              END DO
            END IF
          END DO
C * BOND/DIST
        ELSE IF (N == 3) THEN
          IF (JATC(2) /= JATC(3)) THEN
            CALL PLA053 (JATC(2), JATC(3), 0, 0, D, SD, ISD, NDEC, IER)
          ELSE
            IER = 1
          END IF
          IF (IER == 0) THEN
            ISD          = MIN (99, ISD)
            FORMB(36:36) = CHAR (ICHAR ('0') + NDEC)
            WRITE (PRBUF, FORMB, IOSTAT = IOST)
     1        (NAMS(I, 1)(2:8), I = 2, 3), D, ISD
C * ADD HIRSHFELD RIGID BOND TEST INFO
            IF (IABS(IGBL(8)) == 3 .AND. IPR(5) == 1) THEN
              CALL GEN048 (-1, IFG(1, JATC(2)), 4, ISO1)
              CALL GEN048 (-1, IFG(1, JATC(3)), 4, ISO2)
              IF (ISO1 == 1 .AND. ISO2 == 1) THEN
C * GET ANGSTROM COORDINATES IN INIT SETTING AND UNIT DIRECTION OF BOND
                DO I = 1, 3
                  V7(I) = (VOID((JATC(3) - 1) * NP71 + 21 + I)
     1                  -  VOID((JATC(2) - 1) * NP71 + 21 + I)) / D
                END DO
                VI = 0.0
                VJ = 0.0
                DO K = 1, 3
                  DO L = 1, 3
                    M = K * L
                    IF (M == 6) M = 5
                    IF (M == 9) M = 6
                    VI = VI + V7(K) * SUAN(JATC(2), M) * V7(L)
                    VJ = VJ + V7(K) * SUAN(JATC(3), M) * V7(L)
                  END DO
                END DO
                SVI = SUAN(JATC(2), 7)
                CALL GEN041 (VI, SVI, ISVI, 5, NSVI, IPR(68))
                SVJ = SUAN(JATC(3), 7)
                CALL GEN041 (VJ, SVJ, ISVJ, 5, NSVJ, IPR(68))
                ISVI = MAX (0, MIN (99, ISVI))
                ISVJ = MAX (0, MIN (99, ISVJ))
                DIJ  = ABS(VI - VJ)
                NDIJ = 5
                IF (ISVI > 0 .AND. ISVJ > 0) THEN
                  SDIJ =
     1             SQRT (SUAN(JATC(2), 7)**2 + SUAN(JATC(3), 7)**2)
                  CALL GEN041 (DIJ, SDIJ, IDIJ, 5, NDIJ, IPR(68))
                  IDIJ   = MIN (99, IDIJ)
                  THIRSH = DIJ / SDIJ
                ELSE
                  IDIJ   = 0
                  THIRSH = 0.0
                END IF
                FORMR(25:25) = CHAR (ICHAR ('0') + NDIJ)
                WRITE (PRBUF(40:80), FORMR, IOSTAT = IOST)
     1            DIJ, IDIJ, THIRSH
              END IF
            END IF
            CALL GEN065 (LU6, PRBUF, 1, 80, 1)
          ELSE
C * REPORT INPUT ERROR
            WRITE (PRBUF, 99995, IOSTAT = IOST)
            WRITE (LU6,   99995, IOSTAT = IOST)
          END IF
          IF (IGBL(63) > 1) CALL PLA263 (LU7, PRBUF, 80, 1, 1)
C * ANGLE
        ELSE IF (N == 4) THEN
          CALL PLA053 (JATC(2), JATC(3), JATC(4), 0, ANG, SANG,
     1                 ISANG, NDEC, IER)
          IF (IER == 0) THEN
            ISANG        = MIN (999, ISANG)
            FORMA(36:36) = CHAR (ICHAR('0') + NDEC)
            WRITE (PRBUF, FORMA, IOSTAT = IOST)
     1        (NAMS(I, 1)(2:8), I = 2, 4), ANG, ISANG
            CALL GEN065 (LU6, PRBUF, 1, 80, 1)
            IF (IGBL(63) > 1) CALL PLA263 (LU7, PRBUF, 80, 1, 1)
          ELSE
            WRITE (LU6, 99995, IOSTAT = IOST)
          END IF
C * ANGLE BETWEEN BONDS
        ELSE IF (N == 5) THEN
          IF (IFL(1)(1:3) == 'ANG' .OR. IPR(341) == 5) THEN
            NEX = NMAX + 1
            DO 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)
            END DO
            CALL PLA053 (JATC(3), JATC(2), NEX, 0, ANG, SANG,
     1                   ISANG, NDEC, IER)
            IF (IER == 0) THEN
              ISANG        = MIN (999, ISANG)
              FORML(46:46) = CHAR (ICHAR('0') + NDEC)
              WRITE (PRBUF, FORML, IOSTAT = IOST)
     1          (NAMS(I, 1)(2:8), I = 2, 5), ANG, ISANG
              CALL GEN065 (LU6, PRBUF, 1, 80, 1)
              IF (IGBL(63) > 1) CALL PLA263 (LU7, PRBUF, 80, 1, 1)
            END IF
C * TORSION
          ELSE
            CALL PLA053 (JATC(2), JATC(3), JATC(4), JATC(5),
     1                   ANG, SANG, ISANG, NDEC, IER)
            IF (IER == 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, IOSTAT = IOST)
     1          (NAMS(I, 1)(2:8), I = 2, 5), ANG, ISANG
              CALL GEN065 (LU6, PRBUF, 1, 80, 1)
              WRITE (LU6, 99996, IOSTAT = IOST)
     1          ANG1, ANG2, DIS1, DIS2, DIS3
              IF (IGBL(63) > 1) THEN
                CALL PLA263 (LU7, PRBUF, 80, 1, 1)
                CALL PLA262 (2)
                WRITE (LU7, 99996, IOSTAT = IOST)
     1            ANG1, ANG2, DIS1, DIS2, DIS3
              END IF
            END IF
          END IF
        ELSE
          IPR(2) = 7
          GO TO 30
        END IF
      END IF
   30 IF (MODE == 1) THEN
        IF (IFL(1)(1:3) == 'DIS' .OR. IFL(1)(1:3) == 'ANG'
     1      .OR. IFL(1)(1:3) == 'TOR' .OR. IPR(341) /= 0) THEN
          IF (IPR(2) /= 0) THEN
            PRBUF = 'Label Error :  '//IFL(I)
            IPR(2) = 0
            WRITE (LU6, 99999, IOSTAT = IOST) PRBUF(1:50)
          END IF
          IF (IGBL(25) * IGBL(32) == 1) THEN
            IGBL(6) = - IABS (IGBL(6))
            SBCD = PRBUF(1:79)//CHAR (0)
          END IF
        END IF
      END IF
      RETURN
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 (1X)
99993 FORMAT (2X, A, 20X, 6F8.4)
99992 FORMAT (//)
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)
      END SUBROUTINE PLA440
 
      SUBROUTINE PLA441 (N, NANAL, NRES1, NRES2)
      USE files
      USE parameters
      USE plato
      USE sgxyz
      INTEGER :: I
      INTEGER :: J
      INTEGER :: N
      INTEGER :: N1
      INTEGER :: N2
      INTEGER :: NAT
      INTEGER :: IHAT
      INTEGER :: LBN1
      INTEGER :: LBN2
      INTEGER :: NRES0
      INTEGER :: NRES1
      INTEGER :: NRES2
      INTEGER :: NRESI
      INTEGER :: NRESJ
      INTEGER :: NANAL
C * CHECK FOR CASE OF NO LABELS GIVEN (CHECK MINIMUM NUMBER OF RESIDUES)
      NANAL = 0
   10 IF (N == 1 .AND. IPR(75) > 1) THEN
C * GET NUMBER OF ATOMS
        NAT = IPR(39)
C * SELECT TWO DEFAULT RESIDUE NUMBERS
        IF (IPR(221) == 0) THEN
          FN(1)    = 2
          FN(2)    = 1
          IPR(221) = 2
        END IF
        IF (IPR(221) == 2) THEN
          NRES1 = NINT (FN(1))
          NRES2 = NINT (FN(2))
          N2    = 0
C * FIND PAIRS OF UNIQUE ATOMS
          DO 20 I = 1, NAT
C * SKIP H-ATOMS
            CALL GEN048 (-1, IFG(1, I), 7, IHAT)
            IF (IHAT == 0) THEN
C * GET RESIDUE NUMBER RESD1
              CALL GEN048 (-6, IFG(1, I), 9, NRESI)
              IF (NRESI == NRES1) THEN
C * GET LABUTE NUMBER RESD1
                CALL GEN048 (-10, IFG(2, I), 14, LBN1)
                IF (I < NAT) THEN
                  DO J = 1, NAT
                    IF (J /= I) THEN
C * GET LABUTE NUMBER RESD2
                      CALL GEN048 (-10, IFG(2, J), 14, LBN2)
                      IF (LBN1 == LBN2) THEN
C * GET RESIDUE NUMBER RESD2
                        CALL GEN048 (-6, IFG(1, J), 9, NRESJ)
                        IF (NRESI == NRESJ) GO TO 20
                      END IF
                    END IF
                  END DO
                END IF
                DO J = 1, NAT
                  CALL GEN048 (-1, IFG(1, J), 7, IHAT)
                  IF (IHAT == 0) THEN
                    CALL GEN048 (-6, IFG(1, J), 9, NRESJ)
                    IF (NRESJ == NRES2) THEN
                      CALL GEN048 (-10, IFG(2, J), 14, LBN2)
                      IF (LBN1 == LBN2) THEN
                        N2         = N2 + 2
                        JR(N2 - 1) = I
                        JR(N2)     = J
                        GO TO 20
                      END IF
                    END IF
                  END IF
                END DO
              END IF
            END IF
   20     CONTINUE
          IF (N2 >= IPR(28) * 2) THEN
            IPR(12) = N2
            WRITE (LU6, 99999, IOSTAT = IOST) NRES1, NRES2, N2 / 2
          ELSE
            N = -3
            GO TO 10
          END IF
        ELSE
C * UNKNOWN CARD ERROR
          IPR(2) = 7
          RETURN
        END IF
C * SPECIAL RESIDUE FIT (TWO LABELS, ONE FROM EACH RESIDUE)
      ELSE IF (ABS (N) == 3) THEN
        NANAL = 1
        IF (N == 3) THEN
C * GET TWO RESIDUE NUMBERS FROM THE TWO LABELS
          CALL PLA046 (4, IFL(2), IENM, LBB, LBC, LBD,
     1                 INQNR, JNQNR, N1)
          IF (N1 < 0) THEN
C * UNKNOWN CARD ERROR
            IF (N1 == -4) THEN
              IPR(2) = 7
              RETURN
            ELSE
              NQ0    = IFL(2)(1:7)
              IPR(2) = 3
              RETURN
            END IF
          END IF
          CALL GEN048 (-6, IFG(1, N1), 9, NRES1)
          CALL PLA046 (4, IFL(3), IENM, LBB, LBC, LBD,
     1                 INQNR, JNQNR, N2)
          IF (N2 < 0) THEN
            IF (N2 == -4) THEN
C * UNKNOWN CARD ERROR
              IPR(2) = 7
              RETURN
            ELSE
              NQ0    = IFL(3)(1:7)
              IPR(2) = 3
              RETURN
            END IF
          END IF
          CALL GEN048 (-6, IFG(1, N2), 9, NRES2)
        END IF
        N1 = -1
        N2 =  0
C * ASSUME THE SAME LABEL ORDER IN BOTH SORTED RESIDUES
        DO I = 1, NAT
          CALL GEN048 (-1, IFG(1, I), 7, IHAT)
          IF (IHAT == 0) THEN
            CALL GEN048 (-6, IFG(1, I), 9, NRES0)
            IF (NRES0 == NRES1) THEN
              N1     = N1 + 2
              JR(N1) = I
C * REGISTER COMPANION IN JCA (FOR PLA084)
            ELSE IF (NRES0 == NRES2) THEN
              N2     = N2 + 2
              JR(N2) = I
C * REGISTER COMPANION IN JCA (FOR PLA084)
            END IF
          END IF
        END DO
        IF (N2 /= N1 + 1) THEN
          WRITE (LU6, 99998, IOSTAT = IOST)
          IPR(2) = -1
          RETURN
        END IF
        DO K = 1, N2 - 1, 2
          JCA(JR(K)) = JR(K + 1)
        END DO
        IPR(12) = N2
        WRITE (LU6, 99999, IOSTAT = IOST) NRES1, NRES2, N2 / 2
      ELSE
C * LOOP OVER SPECIFIED ATOM PAIRS
        DO I = 2, N
C * ATOM-NAME
          CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD,
     1                 INQNR, JNQNR, NIEN)
          IF (NIEN < 0) THEN
C * UNKNOWN CARD ERROR
            IF (NIEN == -4) THEN
              IPR(2) = 7
              RETURN
            ELSE
              NQ0    = IFL(I)(1:7)
              IPR(2) = 3
              RETURN
            END IF
          END IF
          IPR(12)     = IPR(12) + 1
          JR(IPR(12)) = NIEN
        END DO
      END IF
      RETURN
99999 FORMAT (/, ':: Fit for RESD =', I3,
     1        ' and RESD =', I3, ' [N(fit) =', I3, ']')
99998 FORMAT (/, ':: Residues contain unequal number of atoms, nofit!!')
      END SUBROUTINE PLA441
 
      SUBROUTINE PLA442 (LU, VARDIST)
C * QUATERNION-MOLFIT ROUTINE - CALLED FROM PLA440, PLA085, PLA390
      USE files
      USE parameters
      USE plato
      USE atomdata
      USE cchar
      USE sgxyz
      IMPLICIT NONE
 
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: LU
      INTEGER            :: NAT
      INTEGER            :: ISN
      INTEGER            :: ISN0
      INTEGER            :: ISN1
      INTEGER            :: ISN7
      INTEGER            :: ISNB
      INTEGER            :: ISNS
      INTEGER            :: NAT1
      INTEGER            :: NAT2
      INTEGER            :: NATC
      INTEGER            :: NADD
      INTEGER            :: IDUM
      INTEGER            :: JDUM
      INTEGER            :: IHAT
      INTEGER            :: NRES
      INTEGER            :: MBST
      INTEGER            :: NRES1
      INTEGER            :: NRES2
      INTEGER            :: NONHA
      INTEGER            :: MODNM
      REAL               :: F1
      REAL               :: F2
      REAL               :: F3
      REAL               :: F4
      REAL               :: TH
      REAL               :: DET
      REAL               :: DUM
      REAL               :: SHH
      REAL               :: THH
      REAL               :: VAL
      REAL               :: WGHT
      REAL               :: XLNG
      REAL               :: DIST
      REAL               :: STHH
      REAL               :: SUMW
      REAL               :: CTHH
      REAL               :: BEST
      REAL               :: RMSQ
      REAL               :: URMS
      REAL               :: V2MAX
      REAL               :: URMS1
      REAL               :: SUMW1
      REAL               :: RMSQ1
      REAL               :: THETA
      REAL               :: GEN009
      REAL               :: VARDIST
      REAL, DIMENSION(3) :: DUMW
      REAL, DIMENSION(3) :: V
      CHARACTER(len=8)   :: INVRT
      CHARACTER(len=1)   :: INCF
C * OUTPUT JOB-HEADER
      IF (LU == 1) WRITE (LU6, 99999, IOSTAT = IOST)
      CALL PLA262 (-3)
      WRITE (LU7, 99999, IOSTAT = IOST)
C * GENERATE FILE FOR PLUTON-DISPLAY
      IF (LU /= 0) OPEN (UNIT = LU60,
     1   FILE = NAMEFIL(1:KNMFIL)//'_fit.spf', STATUS = 'UNKNOWN')
C * TOTAL NUMBER OF ATOMS
      NAT  = IPR(39)
C * GET NUMBER OF ATOM PAIRS FOR FITTING
      NAT2 = IPR(12)
      NAT1 = NAT2 - 1
      NATC = NAT2 / 2
C * GET THE TWO RESIDUE NUMBERS FOR MOL1 & MOL2
      CALL GEN048 (-6, IFG(1, JR(1)), 9, NRES1)
      CALL GEN048 (-6, IFG(1, JR(2)), 9, NRES2)
C * GET CENTER OF GRAVITY OF MOL1 & MOL2 (UNIT WEIGHT)
      CALL GEN074 (DUMA, 1, 6, 0.0)
      DO I = 1, NAT
        NADD = 1
C * LOOP OVER ATOM PAIRS
        DO J = 1, NAT2
          IF (JR(J) == I) THEN
            K = MOD (J + 1, 2) * 3
            DO N = 1, 3
              DUMA(N + K) = DUMA(N + K) + XXO(JR(J), 3 + N) / NATC
            END DO
            NADD = 0
            EXIT
          END IF
        END DO
C * ADD OTHER ATOMS BELONGING TO RESIDUE 1 or 2 (BUT NOT IN THE FIT SET)
        IF (NADD == 1) THEN
          CALL GEN048 (-6, IFG(1, I), 9, NRES)
          IF (NRES == NRES1) THEN
            NAT1     = NAT1 + 2
            JR(NAT1) = I
          ELSE IF (NRES == NRES2) THEN
            NAT2     = NAT2 + 2
            JR(NAT2) = I
          END IF
        END IF
      END DO
      DO WHILE (NAT2 /= NAT1 + 1)
        IF (NAT2 > NAT1 + 1) THEN
          NAT1     = NAT1 + 2
          JR(NAT1) = 0
        ELSE IF (NAT2 < NAT1 + 1) THEN
          NAT2     = NAT2 + 2
          JR(NAT2) = 0
        END IF
      END DO
      ISN  = 0
      ISN1 = 1
      ISN7 = 7
      ISNS = 1
C * CHECK FOR (YES/NO) INVERT FIT
      IF (IPR(33) /= 0) THEN
        ISNS = 2
        IF (IPR(33) == 2) THEN
          ISN1 = 2
          ISN7 = 8
        END IF
      END IF
      TH   = 0.0
      BEST = 99999.0
      ISNB = 1
      MBST = 0
      DO ISN0 = ISN1, ISN7, ISNS
        IF (ISN0 == ISN7) THEN
          ISN = ISNB
          M   = MBST
          IF (ISN == -1) THEN
            IF (LU == 1) WRITE (LU6, 99994, IOSTAT = IOST)
     1        NRES1, NRES2
            CALL PLA262 (2)
            WRITE (LU7, 99994, IOSTAT = IOST) NRES1, NRES2
            CALL PLA262 (2)
            INVRT = '(INVERT)'
          ELSE
            INVRT = '        '
          END IF
          IF (LU /= 0) WRITE (LU60, 99991, IOSTAT = IOST)
     1      JID(1:8), NRES1, INVRT, NRES2, NATC
        ELSE
          M = INT ((ISN0 - 1) / 2)
          IF (MOD (ISN0, 2) == 0) THEN
            ISN = -1
          ELSE
            ISN = 1
          END IF
        END IF
        CALL GEN021 (DUMV, 0.0)
        CALL GEN074 (DUMW, 1, 3, 0.0)
        CALL GEN074 (V5,   1, 3, 0.0)
        CALL GEN074 (V6,   1, 3, 0.0)
        DO I = 1, IPR(12), 2
          DO 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)
          END DO
          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)
        END DO
        DUMV(2, 1) = DUMV(1, 2)
        DUMV(3, 1) = DUMV(1, 3)
        DUMV(3, 2) = DUMV(2, 3)
C * INVERT MATRIX
        CALL GEN003 (DUMV, RMAT, DET, 0)
C * MATRIX * VECTOR
        CALL GEN002 (1, RMAT, DUMW, V8, XLNG)
        THETA = 2 * ATAN (SQRT (GEN009(V8, V8)))
        TH    = THETA * RGBL(6)
C * CATCH IDENTITY CASE
        IF (ABS(TH) < 0.001) THEN
          CALL PLA262 (5)
          IF (LU == 1) THEN
            WRITE (LU6, 99993, IOSTAT = IOST)
            WRITE (LU6, 99998, IOSTAT = IOST) TH, V5, V6
          END IF
          WRITE (LU7, 99993, IOSTAT = IOST)
          WRITE (LU7, 99998, IOSTAT = IOST) TH, V5, V6
        END IF
        DO I = 1, 3
          V(I) = V8(I) / TAN (THETA / 2)
        END DO
        IF (ISN0 == ISN7) THEN
C * CORRECT FOR 'PRE-ROTATION OF RESD #1
          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 / RGBL(6)) / SQRT (3.0)
          CALL GEN074 (V6, 1, 3, VAL)
          VAL   = COS (-(M + 1) * 60.0 / RGBL(6))
          THH   = CTHH * VAL  - GEN009 (V5, V6)
          THH   = MAX (-1.0, MIN (THH, 1.0))
          TH    = MOD (2.0 * ACOS (THH) *  RGBL(6) + 360.0, 360.0)
          IF (TH > 180.0) TH = TH - 360.0
          CALL GEN008 (V5, V6, V1, 0)
          SHH   = SQRT (1.0 - THH **2)
          IF (SHH /= 0.0) THEN
            DO I = 1, 3
              V1(I) = (V1(I) + V5(I) * VAL + CTHH * V6(I)) / SHH
            END DO
          END IF
          CALL GEN002 (1, ROR, V1, V2, DUM)
          V2MAX = MAX (ABS (V2(1)), ABS (V2(2)), ABS (V2(3)))
          IF (V2MAX /= 0.0) THEN
            DO I = 1, 3
              V2(I) = V2(I) / V2MAX
            END DO
          END IF
          IF (LU == 1) WRITE (LU6, 99998, IOSTAT = IOST)
     1      TH, (V1(I), I = 1, 3), (V2(I), I = 1, 3)
          CALL PLA262 (8)
          WRITE (LU7, 99998, IOSTAT = IOST)
     1      TH, (V1(I), I = 1, 3), (V2(I), I = 1, 3)
        END IF
C * APPLY THE ROTATION FOUND TO ALL ATOMS OF RESD #1
        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 J = 1, NAT1, 2
          I    = JR(J)
          K    = JR(J + 1)
          WGHT = 0.0
          DO N = 1, 3
            IF (I == 0) THEN
              V1(N) = 0.0
            ELSE
              MODNM = MOD (N + M, 3)
              V1(N) =  (XXO(I, MODNM + 4) - DUMA(MODNM + 1)) * ISN
            END IF
            IF (K == 0) THEN
              V2(N) = 0.0
            ELSE
              V2(N) = XXO(K, N + 3) - DUMA(N + 3)
            END IF
            WGHT  = WGHT + V1(N)**2
          END DO
C * CALCULATE '2 * SIN(THETA/2)**2 (N.R)
          F4 = F3 * GEN009 (V, V1)
C * CALCULATE '(N x R)'
          CALL GEN008 (V, V1, V4, 0)
          DO N = 1, 3
            V3(N) = F1 * V1(N) + F2 * V4(N) + F4 * V(N)
          END DO
          DIST = (V2(1) - V3(1))**2 + (V2(2) - V3(2))**2
     1         + (V2(3) - V3(3))**2
C * STATISTICS FOR FITTED ATOMS ONLY
          IF (J < IPR(12)) THEN
            INCF = '*'
            RMSQ = RMSQ + WGHT * DIST
            SUMW = SUMW + WGHT
            URMS = URMS + DIST
          ELSE
            INCF = ' '
          END IF
C * STATISTICS FOR ALL NON-HYDROGEN ATOMS
          IF (I /= 0) THEN
            CALL GEN048 (-1, IFG(1, I), 7, IHAT)
            IF (IHAT == 0) THEN
              NONHA = NONHA + 1
              RMSQ1 = RMSQ1 + WGHT * DIST
              SUMW1 = SUMW1 + WGHT
              URMS1 = URMS1 + DIST
            END IF
            DIST = SQRT (DIST)
          END IF
          IF (ISN0 == ISN7) THEN
            IF (I /= 0) THEN
              CALL PLA047 (LABA(I), NQ1, IDUM, JDUM, IPR(71),
     1          IGBL(55), 0, 0)
              CALL PLA047 (LABA(I), NQ3, IDUM, JDUM, IPR(71),
     1          1, 0, 0)
            ELSE
              CALL GEN038 (NQ1, 1, 7)
              NQ3 = NQ1
            END IF
            IF (K /= 0) THEN
              CALL PLA047 (LABA(K), NQ2, IDUM, JDUM, IPR(71),
     1          IGBL(55), 0, 0)
            ELSE
              CALL GEN038 (NQ2, 1, 7)
            END IF
C * WRITE FITTED RESIDUE # 1 TO FIT-FILE
            IF (JR(J) /= 0 .AND. LU /= 0) THEN
              WRITE (LU60, 99992, IOSTAT = IOST)
     1          NQ1(1:7), NQ3(1:7), (V3(N), N = 1, 3)
            END IF
            WRITE (PRBUF, 99996, IOSTAT = IOST)
     1        NQ1(1:6), (V3(N), N = 1, 3),
     2        NQ2(1:6), (V2(N), N = 1, 3), DIST, INCF
            IF (I == 0) CALL GEN038 (PRBUF, 1, 32)
            IF (K == 0) CALL GEN038 (PRBUF, 35, 68)
            IF (I == 0 .OR. K == 0) CALL GEN038 (PRBUF, 70, 80)
            CALL PLA262 (1)
            IF (LU == 1) WRITE (LU6, 99989, IOSTAT = IOST) PRBUF(1:80)
            WRITE (LU7, 99989) PRBUF(1:80)
          END IF
        END DO
        URMS  = SQRT (URMS  / NATC)
        RMSQ  = SQRT (RMSQ  / SUMW)
        URMS1 = SQRT (URMS1 / NONHA)
        RMSQ1 = SQRT (RMSQ1 / SUMW1)
        IF (ISN0 == ISN7) THEN
          CALL PLA262 (5)
          IF (LU == 1)
     1      WRITE (LU6, 99995, IOSTAT = IOST) RMSQ, URMS, NATC,
     2        RMSQ1, URMS1, NONHA
          WRITE (LU7, 99995, IOSTAT = IOST)
     1      RMSQ, URMS, NATC, RMSQ1, URMS1, NONHA
        ELSE
          IF (RMSQ < BEST) THEN
            BEST = RMSQ
            ISNB = ISN
            MBST = M
          END IF
        END IF
      END DO
C * WRITE RESD # 2 TO FIT-FILE
      IF (LU /= 0) THEN
        WRITE (LU60, 99990, IOSTAT = IOST)
        DO I = 1, NAT2, 2
          K    = JR(I + 1)
          IF (K /= 0) THEN
            CALL PLA047 (LABA(K), NQ2, IDUM, JDUM, IPR(71),
     1        1, 0, 0)
            CALL PLA047 (LABA(K), NQ4, IDUM, JDUM, IPR(71),
     1        IGBL(55), 0, 0)
            WRITE (LU60, 99992, IOSTAT = IOST) NQ4(1:7), NQ2(1:7),
     1        (XXO(K, N) - DUMA(N), N = 4, 6)
          END IF
        END DO
        WRITE (LU60, 99997, IOSTAT = IOST)
        CLOSE (UNIT = LU60)
C * TEST FOR 'MENU ON' OR '-I MODE'
        IF (IGBL(25) /= 0 .OR. IGBL(3) == 41) THEN
          KERR = 0
C * RUN SPAWNED PLUTON JOB
          CALL SPAWN
     1    (PLAPATH(1:IGBL(80))//' -p '//NAMEFIL(1:KNMFIL)//'_fit.spf',
     2      LU6, .true., KERR)
        END IF
      END IF
      VARDIST = RMSQ
      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  = ',
     3 3F10.6, /, 'Components in crystal system', 20X, 3F10.6, //,
     4 'Starred Atom Pairs are those used for the FIT. ',
     5 'Other Atoms are Paired on Sequence Number and need not to ',
     6 'Correspond.', //,  'Transf. Orthogonal Coord. Mol2', 5X,
     8 'Orth. Coord. Mol1 with Resp. to C.G.', 1X,
     9 '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 ('ATOM', 1X, A, A, 3F10.3)
99991 FORMAT ('TITL ', A, ' - FIT RESD', I3, A, ' TO RESD', I3,
     1        ', N =', I3, /, 'RESD 1')
99990 FORMAT ('RESD 2')
99989 FORMAT (A)
      END SUBROUTINE PLA442
 
      SUBROUTINE PLA443 (FILEX)
C * Molecule FIT Following the KABSCH Algorithm
C * W. Kabsch: Acta Cryst. (1976). A32, 922 and (1978). A34, 827
C * Original Coding by  S.C.Nyburg (BMFIT)
C * This streamlined version for PLATON by A.L.Spek
      IMPLICIT NONE
      INTEGER,          PARAMETER        :: MB = 99
      INTEGER                            :: I
      INTEGER                            :: J
      INTEGER                            :: K
      INTEGER                            :: L
      INTEGER                            :: M
      INTEGER                            :: N
      INTEGER                            :: JX
      INTEGER                            :: NA
      INTEGER                            :: NB
      INTEGER                            :: NG
      INTEGER                            :: NP
      INTEGER                            :: NW
      INTEGER                            :: LU1
      INTEGER                            :: LU2
      INTEGER                            :: LU7
      INTEGER                            :: LU65
      INTEGER                            :: LU66
      INTEGER                            :: NAP
      INTEGER                            :: NBP
      INTEGER                            :: NUM
      INTEGER                            :: NWR
      INTEGER                            :: NSUM
      INTEGER                            :: NTOT
      INTEGER                            :: NMIR
      INTEGER                            :: NFIX
      INTEGER                            :: ITAP
      INTEGER                            :: NFIT
      INTEGER                            :: IOST
      DOUBLE PRECISION                   :: AN
      DOUBLE PRECISION                   :: BS
      DOUBLE PRECISION                   :: DS
      DOUBLE PRECISION                   :: XA
      DOUBLE PRECISION                   :: XB
      DOUBLE PRECISION                   :: XN
      DOUBLE PRECISION                   :: YA
      DOUBLE PRECISION                   :: YB
      DOUBLE PRECISION                   :: YN
      DOUBLE PRECISION                   :: ZA
      DOUBLE PRECISION                   :: ZB
      DOUBLE PRECISION                   :: ZN
      DOUBLE PRECISION                   :: A11
      DOUBLE PRECISION                   :: A12
      DOUBLE PRECISION                   :: A13
      DOUBLE PRECISION                   :: A21
      DOUBLE PRECISION                   :: A22
      DOUBLE PRECISION                   :: A23
      DOUBLE PRECISION                   :: A31
      DOUBLE PRECISION                   :: A32
      DOUBLE PRECISION                   :: A33
      DOUBLE PRECISION                   :: DPR
      DOUBLE PRECISION                   :: SES
      DOUBLE PRECISION                   :: DDET
      DOUBLE PRECISION                   :: DETA
      DOUBLE PRECISION                   :: DETR
      DOUBLE PRECISION                   :: FACS
      DOUBLE PRECISION, DIMENSION(2)     :: CA
      DOUBLE PRECISION, DIMENSION(2)     :: CB
      DOUBLE PRECISION, DIMENSION(2)     :: CG
      DOUBLE PRECISION, DIMENSION(2)     :: SG
      DOUBLE PRECISION, DIMENSION(2)     :: CR
      DOUBLE PRECISION, DIMENSION(2)     :: CP
      DOUBLE PRECISION, DIMENSION(3)     :: WV
      DOUBLE PRECISION, DIMENSION(9)     :: A
      DOUBLE PRECISION, DIMENSION(9)     :: R
      DOUBLE PRECISION, DIMENSION(MB)    :: D
      DOUBLE PRECISION, DIMENSION(MB)    :: W
      DOUBLE PRECISION, DIMENSION(2, 6)  :: RLC
      DOUBLE PRECISION, DIMENSION(3, 3)  :: CQ
      DOUBLE PRECISION, DIMENSION(3, 3)  :: U
      DOUBLE PRECISION, DIMENSION(3, 3)  :: ZZ
      DOUBLE PRECISION, DIMENSION(3, 3)  :: RC
      DOUBLE PRECISION, DIMENSION(3, 3)  :: B
      DOUBLE PRECISION, DIMENSION(2, MB) :: EX
      DOUBLE PRECISION, DIMENSION(2, MB) :: EY
      DOUBLE PRECISION, DIMENSION(2, MB) :: EZ
      DOUBLE PRECISION, DIMENSION(2, MB) :: FRX
      DOUBLE PRECISION, DIMENSION(2, MB) :: FRY
      DOUBLE PRECISION, DIMENSION(2, MB) :: FRZ
      DOUBLE PRECISION, DIMENSION(2, MB) :: XS
      DOUBLE PRECISION, DIMENSION(2, MB) :: YS
      DOUBLE PRECISION, DIMENSION(2, MB) :: ZS
      DOUBLE PRECISION, DIMENSION(2, MB) :: X
      DOUBLE PRECISION, DIMENSION(2, MB) :: Y
      DOUBLE PRECISION, DIMENSION(2, MB) :: Z
      CHARACTER(len=8), DIMENSION(2, MB) :: TYPEX
      CHARACTER(len=80)                  :: TITL
      CHARACTER(len=80)                  :: FILEX
C * INSTRUCTIONS    ON mol.ins    (LU1)
C * DATA FIRST MOL  ON mol.1      (LU65)
C * DATA SECOND MOL ON mol.2      (LU66)
C * RESULT          ON mol_bm.res (LU2)
C * LISTING         ON mol.lis    (LU7)
      LU1  = 1
      LU2  = 2
      LU7  = 7
      LU65 = 65
      LU66 = 66
      IOST = 0
      L = INDEX (FILEX, ' ') - 1
C * INSTRUCTION DATA
      OPEN (LU1, FILE = FILEX(1:L)//'.ins')
C * STRUCTURE 1 COORDINATES
      OPEN (LU65, FILE = FILEX(1:L)//'.1')
C * STRUCTURE 2 COORDINATES
      OPEN (LU66, FILE = FILEX(1:L)//'.2')
C * LISTING OUTPUT
      OPEN (LU7, FILE = FILEX(1:L)//'.lis')
C * FIT FILE
      OPEN (LU2, FILE = FILEX(1:L)//'_bm.res')
   10 READ (LU1, 99999, IOSTAT = IOST) TITL
      IF (IOST /= 0) RETURN
      DPR = 57.2957795D0
      DO I = 1, 9
        R(I) = 0.0D0
        A(I) = 0.0D0
      END DO
      DO I = 1, 3
        DO J = 1, 3
          CQ(I, J) = 0.0D0
        END DO
      END DO
      NMIR = 0
      NWR  = 0
      XA   = 0.0D0
      YA   = 0.0D0
      ZA   = 0.0D0
      DO I = 1, 2
        DO J = 1, MB
          X(I, J) = 0.0D0
          Y(I, J) = 0.0D0
          Z(I, J) = 0.0D0
        END DO
      END DO
      DS = 0.0D0
      JX = 0
C * N      # ATOMS TO BE FITTED (N <= MIN(NA,NB))
C * NFIX   SELECT ATOM AS ORIGIN             [0]
C * NFIT   (0/1) ANGSTROM / FRACTIOAL COORD FIT
C * NW     WEIGHT
      READ (LU1, *, IOSTAT = IOST) N, NFIX, NFIT, NW
C * READ THE DATA FOR THE TWO MOLECULES
      DO K = 1, 2
        IF (K == 1) THEN
          ITAP = LU65
        ELSE
          ITAP = LU66
        END IF
C * GET CELL PARAMETERS FOR BOTH MOLECULES
        READ (ITAP, *, IOSTAT = IOST) (RLC(K, I), I = 1, 6)
C * GET COS AND SIN VALUES OF THE CELL ANGLES
        CA(K) = COS (RLC(K, 4) / DPR)
        CB(K) = COS (RLC(K, 5) / DPR)
        CG(K) = COS (RLC(K, 6) / DPR)
        SG(K) = SQRT (1.0D0 - CG(K)**2)
        CR(K) = (CA(K) - CB(K) * CG(K)) / SG(K)
        CP(K) = SQRT (1.0D0 - CB(K) * CB(K) - CR(K) * CR(K))
        J    = 0
        DO
          J = J + 1
C * READ FRACTIONAL COORDINATES
          READ (ITAP, *, IOSTAT = IOST)
     1      TYPEX(K, J), FRX(K, J), FRY(K, J), FRZ(K, J)
          IF (IOST /= 0) EXIT
C * ORTHOGONALISE FRACTIONAL COORDINATES
          X(K, J) = FRX(K, J) * RLC(K, 1) + FRY(K, J) * RLC(K, 2) *
     1      CG(K) + FRZ(K, J) * RLC(K, 3) * CB(K)
          Y(K, J) = FRY(K, J) * RLC(K, 2) * SG(K) + FRZ(K, J) *
     1      RLC(K, 3) * CR(K)
          Z(K, J) = FRZ(K, J) * RLC(K, 3) * CP(K)
C * READ ASOCIATED WEIGHTS
          IF (NW > 0.0) THEN
            READ (ITAP, *) EX(K, J), EY(K, J), EZ(K, J)
C * ORTHOGONALISE WEIGHTS
            EX(K, J) = EX(K, J) * RLC(K, 1) + EY(K, J) * RLC(K, 2) *
     1        CG(K)  + EZ(K, J) * RLC(K, 3) * CB(K)
            EY(K, J) = EY(K, J) * RLC(K, 2) * SG(K) + EZ(K, J) *
     1        RLC(K, 3) * CR(K)
            EZ(K, J) = EZ(K, J) * RLC(K, 3) * CP(K)
            EX(K, J) = SQRT ((EX(K, J)**2 + EY(K, J)**2 +
     1        EZ(K, J)**2) / 3.0D0)
          ELSE
            W(J) = 1.0D0
          END IF
        END DO
        IF (K == 1) THEN
          NA = J - 1
        ELSE
          NB = J - 1
        END IF
      END DO
      NTOT = MAX (NA, NB)
C * FIND WEIGHT FOR EACH MATCHED ATOM PAIR
      IF (NW > 0) THEN
        SES = 0.0D0
        DO J = 1, N
          EX(1, J) = SQRT (EX(1, J)**2 + EX(2, J)**2)
          SES      = SES + (1.0D0 / (EX(1, J)**2))
        END DO
        AN = N
        AN = AN / SES
        DO J = 1, N
          W(J) = AN / (EX(1, J)**2)
        END DO
      END IF
C * LIST TITL AND CELL PARAMETER SETS
      WRITE (LU7, 99998) TITL
      IF (NW > 0) THEN
        WRITE (LU7, 99997)
      ELSE
        WRITE (LU7, 99996)
      END IF
      WRITE (LU7, 99995)
      WRITE (LU7, 99993) (RLC(1, L), L = 1, 3), (RLC(2, L), L = 1, 3)
      WRITE (LU7, 99992) (RLC(1, L), L = 4, 6), (RLC(2, L), L = 4, 6)
      DO
        IF (JX == 0) THEN
C * LIST ORTHOGOGONAL (ANGSTROM) COORDINATES
          WRITE (LU7, 99966) (K, TYPEX(1, K), X(1, K), Y(1, K), Z(1, K),
     1      TYPEX(2, K), X(2, K),Y(2, K), Z(2, K), K = 1, N)
        ELSE IF (JX > 0) THEN
          DS   = 0.0D0
          NSUM = MIN (NA, NB)
          DO K = 1, NSUM
            D(K) = (X(1, K) - X(2, K))**2 + (Y(1, K) - Y(2, K))**2 +
     1             (Z(1, K) - Z(2, K))**2
          END DO
          DO K = 1, N
            DS = DS + D(K)
          END DO
          DO K = 1, NSUM
            D(K) = SQRT (D(K))
          END DO
          WRITE (LU7, 99962)
          WRITE (LU7, 99980) (K, TYPEX(1, K), X(1, K), Y(1, K), Z(1, K),
     1      TYPEX(2, K), X(2, K), Y(2, K), Z(2, K), D(K), K = 1, N)
          WRITE (LU7, 99964) DS
        END IF
C * REPORT UNMATCHED ATOM PAIRS
        WRITE (LU7, 99963)
C * TYPE OF FORMAT
        IF (NA /= N) THEN
          IF ((NB == N)) THEN
C * OUTPUT ROUTINE F2
            NAP = N + 1
            WRITE (LU7, 99977) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1       Z(1, K), K = NAP, NA)
          ELSE
C * OUTPUT ROUTINE F5
            IF (NA < NB) THEN
              NP  = N + 1
              NAP = NA + 1
              IF (JX == 0) THEN
                WRITE (LU7, 99978) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1           Z(1, K), TYPEX(2, K), X(2, K), Y(2, K), Z(2, K),
     2           K = NP, NA)
                WRITE (LU7, 99979) (K, TYPEX(2, K), X(2, K), Y(2, K),
     1            Z(2, K), K = NAP, NB)
              ELSE
                WRITE (LU7, 99980) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1            Z(1, K), TYPEX(2, K), X(2, K), Y(2, K), Z(2, K),
     2           D(K), K = NP, NA)
                WRITE (LU7, 99979) (K, TYPEX(2, K), X(2, K), Y(2, K),
     1            Z(2, K), K = NAP, NB)
              END IF
            ELSE IF (NA == NB) THEN
C * OUTPUT ROUTINE F6
              NP = N + 1
              IF (JX == 0) THEN
                WRITE (LU7, 99978) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1           Z(1, K), TYPEX(2, K), X(2, K), Y(2, K), Z(2, K),
     2           K = NP, NA)
              ELSE
                WRITE (LU7, 99980) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1            Z(1, K), TYPEX(2, K), X(2, K), Y(2, K), Z(2, K),
     2            D(K), K = NP, NA)
              END IF
            ELSE IF (NA > NB) THEN
C * OUTPUT ROUTINE F4
              NP  = N + 1
              NBP = NB + 1
              IF(JX == 0) THEN
                WRITE (LU7, 99978) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1            Z(1, K), TYPEX(2, K), X(2, K), Y(2, K), Z(2, K),
     2            K  = NP, NB)
                WRITE (LU7, 99977) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1            Z(1, K), K = NBP, NA)
              ELSE
                WRITE (LU7, 99980) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1            Z(1, K), TYPEX(2, K), X(2, K), Y(2, K), Z(2, K),
     2            D(K), K = NP, NB)
                WRITE (LU7, 99977) (K, TYPEX(1, K), X(1, K), Y(1, K),
     1            Z(1, K), K = NBP, NA)
              END IF
            END IF
          END IF
        ELSE
          IF (NB == N) THEN
            WRITE (LU7, 99991)
          ELSE
C * OUTPUT ROUTINE
            NBP = N + 1
            WRITE (LU7, 99979) (K, TYPEX(2, K), X(2, K), Y(2, K),
     1        Z(2, K), K = NBP, NB)
          END IF
        END IF
        IF (JX > 0) THEN
C * THIS FINAL SECTION PERFORMS THE TRANSFORMATION OF 2ND MOLECULE INT
C * THE FRACTIONAL COORDINATES OF THE FIRST.
C * IF THIS IS REQUIRED, PUT NFIT=1.  OTHERWISE NFIT=0.
          IF (NFIT /= 0) THEN
C * BRING 2ND MOLECULE BACK TO SAME CRYSTAL FRAME AS 1ST MOLECULE
C * MOVE 2ND MOLECULE TO CENTROID OF 1ST MOLECULE IN ITS ORIGINAL POSI
            DO NG = 1, NB
              X(2, NG) = X(2, NG) + XA
              Y(2, NG) = Y(2, NG) + YA
              Z(2, NG) = Z(2, NG) + ZA
            END DO
C * INVERSE MATRIX TO BRING TO FRACTIONAL COORDS
            DO K = 1, NB
              X(2, K) = (X(2, K) - (Y(2, K) * CG(1) / SG(1))
     1                + (Z(2, K) / CP(1)) * ((CR(1) * CG(1) / SG(1)) -
     2                  CB(1))) / RLC(1, 1)
              Y(2, K) = (Y(2, K) / SG(1) - ((Z(2, K) * CR(1)) / (CP(1) *
     1                  SG(1)))) / RLC(1, 2)
              Z(2, K) = Z(2, K) / (CP(1) * RLC(1, 3))
            END DO
            WRITE (LU7, 99983)
            NUM = MIN (NA, NB)
C * CREATE (PSEUDO) RES FILE
            WRITE (LU2, 99970) TITL
            WRITE (LU2, 99969) 1.5418, (RLC(1, I), I = 1, 6)
            WRITE (LU2, 99999) 'LATT -1'
            WRITE (LU2, 99999) 'SET PAR 22 0.0001'
            WRITE (LU2, 99999) 'FVAR 1'
            WRITE (LU2, 99999) 'RESD 1'
            WRITE (LU2, 99999) 'PART 1'
            WRITE (LU2, 99971) (TYPEX(1, M), 1, FRX(1, M), FRY(1, M),
     1        FRZ(1, M), 11.0, 0.05, M = 1, NUM)
            WRITE (LU2, 99999) 'RESD 2'
            WRITE (LU2, 99999) 'PART 2'
            WRITE (LU2, 99971) (TYPEX(2, M), 1, X(2, M), Y(2, M),
     1        Z(2, M), 11.0, 0.05, M = 1, NUM)
            WRITE (LU2, 99961)
            WRITE (LU2, 99999) 'HKLF4'
            WRITE (LU2, 99999) 'ENDS'
            WRITE (LU7, 99975) (M, TYPEX(1, M), FRX(1, M), FRY(1, M),
     1        FRZ(1, M), TYPEX(2, M), X(2, M), Y(2, M), Z(2, M),
     2        M = 1, NUM)
            IF (NA < NB) THEN
              NAP = NA + 1
              WRITE (LU7, 99974) (M, TYPEX(2, M), X(2, M), Y(2, M),
     1          Z(2, M), M = NAP, NB)
            ELSE IF (NA > NB) THEN
              NBP = NB +1
              WRITE (LU7, 99973) (M, TYPEX(1, M), FRX(1, M), FRY(1, M),
     1         FRZ(1, M), M = NBP, NA)
            END IF
          END IF
          IF (NMIR == 1) GO TO 10
          NWR = NWR + 1
          IF (NWR == 2) GO TO 10
        ELSE
          WRITE (LU7, 99981)
          WRITE (LU7, 99989)
C * FIND PAIR-WEIGHTED CENTROIDS OF MOLECULES
          IF (NFIX == 0) THEN
            XA = 0.0D0
            YA = 0.0D0
            ZA = 0.0D0
            XB = 0.0D0
            YB = 0.0D0
            ZB = 0.0D0
            AN = N
            DO K  = 1, N
              XA = XA + X(1, K) * W(K) / AN
              YA = YA + Y(1, K) * W(K) / AN
              ZA = ZA + Z(1, K) * W(K) / AN
              XB = XB + X(2, K) * W(K) / AN
              YB = YB + Y(2, K) * W(K) / AN
              ZB = ZB + Z(2, K) * W(K) / AN
            END DO
          ELSE
            XA = X(1, NFIX)
            YA = Y(1, NFIX)
            ZA = Z(1, NFIX)
            XB = X(2, NFIX)
            YB = Y(2, NFIX)
            ZB = Z(2, NFIX)
          END IF
C * OUTPUT CENTROIDS
          WRITE (LU7, 99976) XA, YA, ZA, XB, YB, ZB
          IF (NW /= 0) THEN
            WRITE (LU7, 99997)
          ELSE
            WRITE (LU7, 99996)
          END IF
C * MOVE CENTROIDS TO ORIGIN
          DO K  = 1, NTOT
            X(1,  K) = X(1, K) - XA
            Y(1,  K) = Y(1, K) - YA
            Z(1,  K) = Z(1, K) - ZA
            X(2,  K) = X(2, K) - XB
            Y(2,  K) = Y(2, K) - YB
            Z(2,  K) = Z(2, K) - ZB
            XS(2, K) = X(2, K)
            YS(2, K) = Y(2, K)
            ZS(2, K) = Z(2, K)
          END DO
          DO I = 1, 3
            DO K = 1, 3
              CQ(I, K) = 0.0D0
            END DO
          END DO
C * CALCULATE MATRIX 'R'   (Kabsch Notation)
          DO I = 1, N
            CQ(1, 1) = CQ(1, 1) + X(1, I) * X(2, I) * W(I)
            CQ(1, 2) = CQ(1, 2) + Y(1, I) * X(2, I) * W(I)
            CQ(1, 3) = CQ(1, 3) + Z(1, I) * X(2, I) * W(I)
            CQ(2, 1) = CQ(2, 1) + X(1, I) * Y(2, I) * W(I)
            CQ(2, 2) = CQ(2, 2) + Y(1, I) * Y(2, I) * W(I)
            CQ(2, 3) = CQ(2, 3) + Z(1, I) * Y(2, I) * W(I)
            CQ(3, 1) = CQ(3, 1) + X(1, I) * Z(2, I) * W(I)
            CQ(3, 2) = CQ(3, 2) + Y(1, I) * Z(2, I) * W(I)
            CQ(3, 3) = CQ(3, 3) + Z(1, I) * Z(2, I) * W(I)
          END DO
C * CALCULATE MATRIX 'R~R'  (Kabsch Notation)
          A(1) = CQ(1, 1) * CQ(1, 1) + CQ(1, 2) * CQ(1, 2) +
     1           CQ(1, 3) * CQ(1, 3)
          A(2) = CQ(1, 1) * CQ(2, 1) + CQ(1, 2) * CQ(2, 2) +
     1           CQ(1, 3) * CQ(2, 3)
          A(4) = CQ(1, 1) * CQ(3, 1) + CQ(1, 2) * CQ(3, 2) +
     1           CQ(1, 3) * CQ(3, 3)
          A(3) = CQ(2, 1) * CQ(2, 1) + CQ(2, 2) * CQ(2, 2) +
     1           CQ(2, 3) * CQ(2, 3)
          A(5) = CQ(2, 1) * CQ(3, 1) + CQ(2, 2) * CQ(3, 2) +
     1           CQ(2, 3) * CQ(3, 3)
          A(6) = CQ(3, 1) * CQ(3, 1) + CQ(3, 2) * CQ(3, 2) +
     1           CQ(3, 3) * CQ(3, 3)
C * DOUBLE-PRECISION EIGENVECTOR AND EIGENVALUE CALCULATION
          CALL GEN161 (A, R)
          JX   = 1
          NWR  = 0
          NMIR = 0
          DETA = 0
        END IF
        DO I = 1, 3
          DO J = 1, 3
            U(I, J) = 0.0D0
          END DO
        END DO
        IF (NWR == 0) THEN
C * COPY EIGENVALUES
          WV(1)    = A(1)
          WV(2)    = A(3)
          WV(3)    = A(6)
C * COPY EIGENVECTORS
          ZZ(1, 1) = R(1)
          ZZ(1, 2) = R(2)
          ZZ(1, 3) = R(3)
          ZZ(2, 1) = R(4)
          ZZ(2, 2) = R(5)
          ZZ(2, 3) = R(6)
          ZZ(3, 1) = R(7)
          ZZ(3, 2) = R(8)
          ZZ(3, 3) = R(9)
          DO I = 1, 3
            DO J = 1, 3
              B(I, J)  = 0.0D0
              RC(I, J) = CQ(J, I)
            END DO
           END DO
C * MAKE SURE DET OF RC IS NOT EXACTLY ZERO
          DETR = RC(1, 1) * RC(2, 2) * RC(3, 3)
     1         - RC(1, 1) * RC(2, 3) * RC(3, 2)
     2         + RC(1, 2) * RC(2, 3) * RC(3, 1)
     3         - RC(1, 2) * RC(2, 1) * RC(3, 3)
     4         + RC(1, 3) * RC(2, 1) * RC(3, 2)
     5         - RC(1, 3) * RC(2, 2) * RC(3, 1)
C * CALCULATE MATRIX 'U'  (Kabsch Notation)
          WRITE (LU7, 99968) DETR
          IF (ABS (DETR) >= 0.0001D0) THEN
            DO K = 1, 3
              DO I = 1, 3
                DO J = 1, 3
                  B(K, I) = B(K, I) + RC(I, J) * ZZ(K, J)
                END DO
              END DO
            END DO
          ELSE
C * HANDLE SPECIAL 2 And 1 DIMENSIONAL CASES
            NMIR = 1
            IF (WV(2) < 1.0D-6) THEN
              DO I = 1, 3
                DO J = 1, 3
                  B(1, I) = B(1, I) + RC(I, J) * ZZ(1, J)
                END DO
              END DO
              FACS = 1.0D0 / (B(1, 1)**2 + B(1, 2)**2 + B(1,3)**2)
              DO J = 1, 3
                B(1, J) = SQRT (FACS) * B(1,J)
              END DO
              IF (B(1, 1) /= 0.0D0) THEN
                IF (B(1, 2) == 0.0D0) THEN
                  B(2, 1) = 0.0D0
                  B(2, 2) = 1.0D0
                  B(2, 3) = 0.0D0
                ELSE
                  B(2, 2) = B(1, 1) / SQRT (B(1, 1)**2 + B(1, 2)**2)
                  B(2, 1) = -(B(1, 2) * B(2, 2)) / B(1,1)
                  B(2, 3) = 0.0D0
                END IF
              ELSE
                B(2, 1) = 1.0D0
                B(2, 2) = 0.0D0
                B(2, 3) = 0.0D0
              END IF
              B(3, 1) = B(1, 2) * B(2, 3) - B(1, 3) * B(2, 2)
              B(3, 2) = B(1, 3) * B(2, 1) - B(1, 1) * B(2, 3)
              B(3, 3) = B(1, 1) * B(2, 2) - B(1, 2) * B(2, 1)
              GOTO 20
            ENDIF
            DO K = 1, 2
              DO I = 1, 3
                DO J = 1, 3
                  B(K, I) = B(K, I) + RC(I, J) * ZZ(K, J)
                END DO
              END DO
            END DO
            B(3, 1) = B(1, 2) * B(2, 3) - B(1, 3) * B(2, 2)
            B(3, 2) = B(1, 3) * B(2, 1) - B(2, 3) * B(1, 1)
            B(3, 3) = B(1, 1) * B(2, 2) - B(2, 1) * B(1, 2)
          END IF
          BS = B(1, 1)**2 + B(1, 2)**2 + B(1, 3)**2
          IF (BS /= 0.0D0) THEN
            FACS = 1.0D0 / (B(1, 1)**2 + B(1, 2)**2 + B(1, 3)**2)
            DO J = 1, 3
              B(1, J) = SQRT (FACS) * B(1, J)
            END DO
          END IF
          BS = B(2, 1)**2 + B(2, 2)**2 + B(2,3)**2
          IF (BS /= 0.0D0) THEN
            FACS = 1.0D0 / (B(2, 1)**2 + B(2, 2)**2 + B(2, 3)**2)
            DO J = 1, 3
              B(2, J) = SQRT (FACS) * B(2, J)
            END DO
          END IF
          BS = B(3, 1)**2 + B(3, 2)**2 + B(3, 3)**2
          IF (BS /= 0.0D0) THEN
            FACS = 1.0D0 / (B(3, 1)**2 + B(3, 2)**2 + B(3, 3)**2)
            DO J = 1, 3
              B(3, J) = SQRT (FACS) * B(3, J)
            END DO
          END IF
        ELSE
          B(3, 1) = - B(3, 1)
          B(3, 2) = - B(3, 2)
          B(3, 3) = - B(3, 3)
        END IF
   20   DO I = 1, 3
          DO J = 1, 3
            DO K = 1, 3
              U(I, J) = U(I, J) + B(K, I) * ZZ(K, J)
            END DO
          END DO
        END DO
        A(1) = U(1, 1)
        A(2) = U(1, 2)
        A(3) = U(1, 3)
        A(4) = U(2, 1)
        A(5) = U(2, 2)
        A(6) = U(2, 3)
        A(7) = U(3, 1)
        A(8) = U(3, 2)
        A(9) = U(3, 3)
C * IS A MATRIX ORTHOGONAL?
        A11 = A(1) * A(1) + A(2) * A(2) + A(3) * A(3)
        A12 = A(1) * A(4) + A(2) * A(5) + A(3) * A(6)
        A13 = A(1) * A(7) + A(2) * A(8) + A(3) * A(9)
        A21 = A(4) * A(1) + A(5) * A(2) + A(6) * A(3)
        A22 = A(4) * A(4) + A(5) * A(5) + A(6) * A(6)
        A23 = A(4) * A(7) + A(5) * A(8) + A(6) * A(9)
        A31 = A(7) * A(1) + A(8) * A(2) + A(9) * A(3)
        A32 = A(7) * A(4) + A(8) * A(5) + A(9) * A(6)
        A33 = A(7) * A(7) + A(8) * A(8) + A(9) * A(9)
        WRITE (LU7, 99967) A11, A12, A13
        WRITE (LU7, 99967) A21, A22, A23
        WRITE (LU7, 99967) A31, A32, A33
        DETA = A(1) * A(5) * A(9) - A(1 ) *A(6) * A(8) + A(2) * A(6) *
     1    A(7) - A(2) * A(4) * A(9) + A(3) * A(4) * A(8) -
     2    A(3) * A(5) * A(7)
        IF (NWR == 0) THEN
          IF (NMIR == 1) THEN
            WRITE (LU7, 99984)
          ELSE
            IF(DETA >= 0.0D0) THEN
              WRITE (LU7, 99988)
            ELSE
              WRITE (LU7, 99987)
            END IF
          END IF
          DDET = DETA
          GO TO 30
        END IF
        IF (DDET >= 0.0D0) THEN
          WRITE (LU7, 99986)
        ELSE
          WRITE( LU7, 99985)
        END IF
   30   DO I = 1, NB
          XN = A(1) * XS(2, I) + A(2) * YS(2, I) + A(3) * ZS(2, I)
          YN = A(4) * XS(2, I) + A(5) * YS(2, I) + A(6) * ZS(2, I)
          ZN = A(7) * XS(2, I) + A(8) * YS(2, I) + A(9) * ZS(2, I)
          X(2, I) = XN
          Y(2, I) = YN
          Z(2, I) = ZN
        END DO
      END DO
      CLOSE (UNIT = LU1)
      CLOSE (UNIT = LU2)
      CLOSE (UNIT = LU7)
      CLOSE (UNIT = LU65)
      CLOSE (UNIT = LU66)
      RETURN
99999 FORMAT (A)
99998 FORMAT (A, //)
99997 FORMAT (31X, 'THIS IS A WEIGHTED FIT', /)
99996 FORMAT (30X, 'THIS IS AN UNWEIGHTED FIT',/)
99995 FORMAT (25X, 'ORTHOGONAL COORDINATES OF ATOMS BEFORE MATCHING', /,
     1        21X, 'FIRST MOLECULE', 35X, 'SECOND MOLECULE', /)
99993 FORMAT (3X, 'A =', F9.4, ' B =', F9.4, ' C =', F9.4, 14X,
     1            'A =', F9.4, ' B =', F9.4, ' C =', F9.4)
99992 FORMAT (3X, 'AL=', F9.3, ' BE=', F9.3, ' GA=', F9.3, 14X,
     1            'AL=', F9.3, ' BE=', F9.3, ' GA=', F9.3, //)
99991 FORMAT (29X, 'NONE', /)
99989 FORMAT (22X, 'CENTROID', 31X, 'CENTROID', /)
99988 FORMAT (20X, 'THE BEST FIT IS GIVEN WITH THE SECOND MOLECULE',
     1        ' UN-MIRRORED', /)
99987 FORMAT (20X, 'THE BEST FIT IS GIVEN WITH THE SECOND MOLECULE',
     1        ' MIRRORED', /)
99986 FORMAT (35X, 'THIS IS THE MIRRORED FIT', //)
99985 FORMAT (20X, 'THIS IS THE FIT WITH THE SECOND MOLECULE',
     1        ' UN-MIRRORED', /)
99984 FORMAT (1X, 'EITHER ONE OF THE MOLECULES IS FLAT OR THE FIT IS',
     1        ' THE SAME WHETHER OR NOT THE 2ND MOLECULE IS MIRRORED',
     2        /)
99983 FORMAT (//,'   NO', 4X, ' ATOM ', 6X, 'FRACT. COORDINATES', 11X,
     1        ' ATOM   FRACT. COORDS. OF 2ND MOLECULE', /, 23X,
     2        'FIRST MOLECULE', 31X, 'IN CELL OF FIRST')
99981 FORMAT (/)
99980 FORMAT (I4, 1X,  A, 3F10.6, 3X, A, 4F10.6)
99979 FORMAT (I4, 39X, A, 3F10.6)
99978 FORMAT (I4, 1X,  A, 3F10.6, 3X, A, 3F10.6)
99977 FORMAT (I4, 1X,  A, 3F10.6)
99976 FORMAT (10X, 3F10.6, 9X, 3F10.6, /)
99975 FORMAT (I4, 5X,  A, 3F10.6, 5X, A, 3F10.6)
99974 FORMAT (I4, 46X, A, 3F10.6)
99973 FORMAT (I4, 5X,  A, 3F10.6)
99971 FORMAT (A, I3, 3F10.4, F8.1, F8.2)
99970 FORMAT ('TITL ', A)
99969 FORMAT ('CELL ', 7F10.4)
99968 FORMAT (/, '   VALUE OF DETERMINANT', E14.4)
99967 FORMAT (/, 20X, 3E14.4, /)
99966 FORMAT (I4, 1X, A, 3F10.6, 12X, A, 3F10.6)
99964 FORMAT (/, 35X, 'SUM OF DIFFERENCES SQUARED', 23X, F10.6, /)
99963 FORMAT (/, 41X, 'UNMATCHED ATOMS', /)
99962 FORMAT (89X, 'DELTA', /)
99961 FORMAT ('STRAW', /, 'COLOR RESD', /, 'OVERLAP MARGIN 0.0', /,
     1 'SET PAR 149 0.0', /, 'LABEL ON', /, 'PLOT')
      END SUBROUTINE PLA443
 
      SUBROUTINE PLA445
C * LOAD SFAC & BOND_VALENCE DATA IN MODULE atomdata
      USE atomdata
      IMPLICIT NONE
C * SCATTERING FACTORS ETC FOR ELEMENTS 1 - 103
C * INTERNATIONAL TABLES VOL C - Table 6.1.1.4 - p500-502
C * ANOMALOUS DISPERSION CORRECTIONS FOR CU, MO, Ag RADIATION FROM
C * INT. TABLES C, TABLE 4.2.6.8
C * ANOMALOUS DISPERSION CORRECTIONS FOR GA & IN FROM
C * Brennan & Cowtan (1992)
C * Order: CuKa, GaKa, MoKa, AgKa, InKa
C * ELEMENT  H     C     O     N     CL    S
      SFAC(1:570) = (/
     1   0.493000, 10.510910,  0.322910, 26.125731,  0.140190,
     2   3.142360,  0.040810, 57.799770,  0.003040,  0.000000,
     3   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     4   0.000000,  0.000000,    0.0000,    0.0000,
     5   2.310000, 20.843920,  1.020000, 10.207510,  1.588600,
     6   0.568700,  0.865000, 51.651249,  0.215600,  0.018100,
     7   0.009100,    0.0137,    0.0067,  0.003300,  0.001600,
     8   0.001500,  0.000900,    0.0008,    0.0008,
     9   3.048500, 13.277110,  2.286800,  5.701110,  1.546300,
     *   0.323900,  0.867000, 32.908939,  0.250800,  0.049200,
     1   0.032200,    0.0389,    0.0241,  0.010600,  0.006000,
     2   0.005600,  0.003600,    0.0044,    0.0030,
     3  12.212610,  0.005700,  3.132200,  9.893310,  2.012500,
     4  28.997540,  1.166300,  0.582600,-11.529010,  0.031100,
     5   0.018000,    0.0241,    0.0134,  0.006100,  0.003300,
     6   0.003000,  0.001900,  0.0021,   0.0016,
     7  11.460410,  0.010400,  7.196410,  1.166200,  6.255610,
     8  18.519421,  1.645500, 47.778461, -9.557410,  0.363900,
     9   0.701800,    0.3281,    0.5435,  0.148400,  0.158500,
     *   0.099800,  0.098400,    0.0860,    0.0829,
     1   6.905310,  1.467900,  5.203410, 22.215120,  1.437900,
     2   0.253600,  1.586300, 56.172070,  0.866900,  0.333100,
     3   0.556700,    0.2925,    0.4295,  0.124600,  0.123400,
     4   0.082600,  0.076300,    0.0703,    0.0642,
C * ELEMENT  BR    P     I     CU    NI    AC
     1  17.178921,  2.172300,  5.235810, 16.579620,  5.637710,
     2   0.260900,  3.985100, 41.432850,  2.955700, -0.676300,
     3   1.280500,   -0.9338,    1.0006, -0.290100,  2.459500,
     4   0.181100,  1.645200,    0.2498,    1.4201,
     5   6.434510,  1.906700,  4.179100, 27.157040,  1.780000,
     6   0.526000,  1.490800, 68.164574,  1.114900,  0.295500,
     7   0.433500,    0.2543,    0.3332,  0.102300,  0.094200,
     8   0.066700,  0.058000,    0.0564,    0.0488,
     9  20.147221,  4.347000, 18.994921,  0.381400,  7.513810,
     *  27.766041,  2.273500, 66.877670,  4.071200, -0.325700,
     1   6.836200,    0.0030,    5.4350, -0.474200,  1.811900,
     2  -0.891900,  1.186800,   -1.0514,    1.0181,
     3  13.338010,  3.582800,  7.167610,  0.247000,  5.615810,
     4  11.396610,  1.673500, 64.812668,  1.191000, -1.964600,
     5   0.588800,   -2.7974,    3.6876,  0.320100,  1.265100,
     6   0.324000,  0.825700,    0.3088,    0.7067,
     7  12.837610,  3.878500,  7.292010,  0.256500,  4.443800,
     8  12.176310,  2.380000, 66.342163,  1.034100, -3.002900,
     9   0.509100,   -1.3357,    3.2904,  0.339300,  1.112400,
     *   0.314700,  0.723200,    0.2960,    0.6182,
     1  35.659729,  0.589090, 23.103230,  3.651550, 12.597710,
     2  18.599010,  4.086550,117.02010 , 13.526610, -4.079400,
     3  11.799400,   -3.9501,    9.5298, -6.849400,  8.517800,
     4  -3.278400,  9.450200,   -2.0716,    8.2696,
C * ELEMENT  AG    AL    AM    AR    AS    AT
     1  19.280821,  0.644600, 16.688520,  7.472610,  4.804510,
     2  24.660540,  1.046300, 99.815697,  5.179000,  0.130600,
     3   4.282000,    0.0782,    3.3823, -0.897100,  1.101500,
     4  -1.647300,  0.716700,   -2.3608,    0.6136,
     5   6.420210,  3.038700,  1.900200,  0.742600,  1.593600,
     6  31.547239,  1.964600, 85.088676,  1.115100,  0.213000,
     7   0.245500,    0.1771,    0.1873,  0.064500,  0.051400,
     8   0.040600,  0.031300,    0.0335,    0.0262,
     9    36.6706,  0.483629,   24.0992,   3.20647,   17.3415,
     *    14.3136,   3.49331,   102.273,   13.3592,   -4.8483,
     1    15.0877,  -5.41724,  12.22512,   -7.8986,    4.5125,
     2    -6.7022,    7.3108,  -7.04323,  10.46545,
     3   7.484510,  0.907200,  6.772310, 14.840710,  0.653900,
     4  43.898350,  1.644200, 33.392929,  1.444500,  0.384300,
     5   0.871700,    0.3587,    0.6774,  0.174300,  0.200300,
     6   0.119100,  0.124900,    0.1036,    0.1054,
     7  16.672319,  2.634500,  6.070110,  0.264700,  3.431300,
     8  12.947910,  4.277900, 47.797260,  2.531000, -0.930000,
     9   1.005100,   -1.2701,    0.7845,  0.049900,  2.005800,
     *   0.275800,  1.331400,    0.3024,    1.1450,
     1  35.316330,  0.685870, 19.021120,  3.974580,  9.498880,
     2  11.382410,  7.425190, 45.471561, 13.710810, -3.958800,
     3   9.843300,   -4.1476,    7.9301, -7.912200,  9.977700,
     4  -1.803900,  7.950900,   -1.1864,    6.9348,
C * ELEMENT  AU    B     BA    BE    BI    BK
     1  16.881929,  0.461100, 18.591320,  8.621610, 25.558241,
     2   1.482600,  5.860010, 36.395630, 12.065810, -4.419700,
     3   7.298000,   -5.1040,    5.8603, -2.013300,  8.802200,
     4  -0.763800,  5.997800,   -0.5081,    5.2141,
     5   2.054500, 23.218519,  1.332600,  1.021000,  1.097900,
     6  60.349869,  0.706800,  0.140300, -0.193200,  0.009000,
     7   0.003900,    0.0070,    0.0029,  0.001300,  0.000700,
     8   0.000400,  0.000400,    0.0004,    0.0003,
     9  20.336121,  3.216000, 19.297029,  0.275600, 10.888010,
     *  20.207319,  2.695900,167.20219 ,  2.773100, -1.045600,
     1   8.461700,   -0.3132,    6.7527, -0.324400,  2.281900,
     2  -0.694000,  1.500400,   -0.8091,    1.2891,
     3   1.591900, 43.642750,  1.127800,  1.862300,  0.539100,
     4  103.48310,  0.702900,  0.542000,  0.038500,  0.003800,
     5   0.001400,    0.0024,    0.0010,  0.000500,  0.000200,
     6   0.000100,  0.000100,   -0.0004,    0.0001,
     7  33.368938,  0.704000, 12.951010,  2.923800, 16.587721,
     8   8.793710,  6.469210, 48.009350, 13.578210, -4.011100,
     9   8.931000,   -4.3533,    7.1873, -4.107700, 10.256600,
     *  -1.349400,  7.256600,   -0.8823,    6.3231,
     1    36.7881,  0.451018,   24.7736,   3.04619,   17.8919,
     2    12.8946,   4.23284,   86.0030,   13.2754,   -5.3481,
     3    16.3190,  -5.70411,  13.23428,   -6.8498,    4.9086,
     4    -6.3438,    7.9477,  -8.82053,   6.85013,
C * ELEMENT  CA    CD    CE    CF    CM    CO
     1   8.626610, 10.442110,  7.387310,  0.659900,  1.589900,
     2  85.748489,  1.021100,178.43720 ,  1.375100,  0.364100,
     3   1.285500,    0.3829,    1.0059,  0.226200,  0.306400,
     4   0.161100,  0.192600,    0.1411,    0.1629,
     5  19.221420,  0.594600, 17.644421,  6.908910,  4.461000,
     6  24.700840,  1.602900, 87.482567,  5.069410,  0.118500,
     7   4.653300,    0.1061,    3.6794, -0.807500,  1.202400,
     8  -1.439600,  0.783200,   -1.8800,    0.6708,
     9  21.167110,  2.812190, 19.769520,  0.226840, 11.851310,
     *  17.608320,  3.330490,127.11310 ,  1.862640, -1.848200,
     1   9.659600,   -0.6939,    7.7244, -0.248600,  2.633100,
     2  -0.589000,  1.735800,   -0.6838,    1.4935,
     3    36.9185,  0.437533,   25.1995,   3.00775,   18.3317,
     4    12.4044,   4.24391,   83.7881,   13.2674,   -5.5545,
     5    16.7428,  -5.86049,  13.60105,   -6.6561,    5.0785,
     6    -6.4144,    8.1930,  -7.77663,   7.06561,
     7    36.6488,  0.465154,   24.4096,   3.08997,   17.3990,
     8    13.4346,   4.21665,   88.4834,   13.2887,   -5.0611,
     9    15.6355,  -5.54866,  12.67997,   -7.3248,    4.6980,
     *    -6.2891,    7.6044,  -8.60485,   9.43198,
     1  12.284110,  4.279100,  7.340910,  0.278400,  4.003400,
     2  13.535910,  2.348800, 71.169273,  1.011800, -2.365300,
     3   3.614300,   -0.6628,    2.9049,  0.349400,  0.972100,
     4   0.305000,  0.629600,    0.2837,    0.5377/)
C * ELEMENT  CR    CS    D     DY    ER   ES
      SFAC(571:1026) = (/
     1  10.640610,  6.103810,  7.353710,  0.392000,  3.324000,
     2  20.262621,  1.492200, 98.739990,  1.183200, -0.163500,
     3   2.443900,    0.1560,    1.9394,  0.320900,  0.623600,
     4   0.249600,  0.399200,    0.2269,    0.3396,
     5  20.389219,  3.569000, 19.106220,  0.310700, 10.662010,
     6  24.387939,  1.495300,213.90421 ,  3.335200, -0.745700,
     7   7.905200,   -0.1739,    6.3004, -0.368000,  2.119200,
     8  -0.752700,  1.391600,   -0.8819,    1.1948,
     9   0.493000, 10.510910,  0.322910, 26.125731,  0.140190,
     *   3.142360,  0.040810, 57.799770,  0.003040,  0.000000,
     1   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     2   0.000000,  0.000000,  0.000000,  0.000000,
     3  26.507030,  2.180200, 17.638321,  0.202170, 14.559620,
     4  12.189910,  2.965770,111.87410 ,  4.297280, -9.804600,
     5   9.847700,   -5.9987,   12.4498, -0.189200,  4.409800,
     6  -0.330200,  2.940400,   -0.3667,    2.5387,
     7  27.656340,  2.073560, 16.428530,  0.223550, 14.977910,
     8  11.360410,  2.982330,105.70310 ,  5.920470, -9.436700,
     9   3.938000,  -10.7818,    8.7525, -0.258600,  4.957600,
     *  -0.309100,  3.315800,   -0.3236,    2.8653,
     1   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     2   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     4   0.000000,  0.000000,  0.000000,  0.000000,
C * ELEMENT  EU    F     FE    FM    FR   GA
     1  24.627439,  2.387900, 19.088619,  0.194200, 13.760310,
     2  13.754610,  2.922700,123.17410 ,  2.574500, -8.929400,
     3  11.185700,   -2.6997,   10.5010, -0.157800,  3.668200,
     4  -0.397700,  2.435100,   -0.4608,    2.1000,
     5   3.539200, 10.282510,  2.641200,  4.294400,  1.517000,
     6   0.261500,  1.024300, 26.147631,  0.277600,  0.072700,
     7   0.053400,    0.0583,    0.0400,  0.017100,  0.010300,
     8   0.009600,  0.006100,    0.0079,    0.0051,
     9  11.769510,  4.761110,  7.357310,  0.307200,  3.522200,
     *  15.353510,  2.304500, 76.880577,  1.036900, -1.133600,
     1   3.197400,   -0.2673,    2.5550,  0.346300,  0.844400,
     2   0.288600,  0.544800,    0.2662,    0.4648,
     3   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     4   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     5   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     6   0.000000,  0.000000,  0.000000,  0.000000,
     7  35.929932,  0.646450, 23.054720,  4.176190, 12.143910,
     8  23.105221,  2.112530,150.64510 , 13.724710, -3.968900,
     9  10.803800,   -4.0051,    8.7136, -7.222400,  7.784700,
     *  -2.412900,  8.683900,   -1.5549,    7.5792,
     1  15.235410,  3.066900,  6.700610,  0.241200,  4.359100,
     2  10.780510,  2.962300, 61.413570,  1.718900, -1.284600,
     3   0.776300,    -1.903,    0.6051,  0.230700,  1.608300,
     4   0.317900,  1.058900,    0.3190,    0.9084,
C * ELEMENT  GD    GE    HE    HF    HG   HO
     1  25.070940,  2.253410, 19.079821,  0.181950, 13.851810,
     2  12.933110,  3.545450,101.39810 ,  2.419600, -8.838000,
     3  11.915700,   -3.4578,   11.1283, -0.165300,  3.903500,
     4  -0.374100,  2.595400,   -0.4286,    2.2391,
     5  16.081619,  2.850900,  6.374710,  0.251600,  3.706800,
     6  11.446810,  3.683000, 54.762562,  2.131300, -1.088500,
     7   0.885500,   -1.5187,    0.6907,  0.154700,  1.800100,
     8   0.301600,  1.190300,    0.3146,    1.0222,
     9   0.873400,  9.103710,  0.630900,  3.356800,  0.311200,
     *  22.927629,  0.178000,  0.982100,  0.006400,  0.000000,
     1   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     2   0.000000,  0.000000,  0.000000,  0.000000,
     3  29.144039,  1.832620, 15.172610,  9.599910, 14.758610,
     4   0.275120,  4.300130, 72.029083,  8.581550, -6.179400,
     5   4.977600,   -9.4190,    3.9832, -0.583000,  6.185200,
     6  -0.354800,  4.164300,   -0.3049,    3.6053,
     7  20.680920,  0.545000, 19.041719,  8.448410, 21.657520,
     8   1.572900,  5.967610, 38.324631, 12.608910, -4.292300,
     9   7.684900,   -4.8790,    6.1759, -2.389400,  9.226600,
     *  -0.880100,  6.298900,   -0.5823,    5.4791,
     1  26.904940,  2.070510, 17.294020,  0.197940, 14.558310,
     2  11.440710,  3.638370, 92.656693,  4.567970,-14.973400,
     3   3.704600,   -7.4624,   11.3895, -0.217500,  4.678300,
     4  -0.316800,  3.124100,   -0.3432,    2.6984,
C * ELEMENT  IN    IR    K     KR    LA   LI
     1  19.162411,  0.547600, 18.559620,  6.377610,  4.294800,
     2  25.849930,  2.039600, 92.802994,  4.939110,  0.082200,
     3   5.044900,    0.1167,    3.9932, -0.727600,  1.310000,
     4  -1.284300,  0.854200,   -1.6042,    0.7318,
     5  27.304930,  1.592790, 16.729610,  8.865540, 15.611520,
     6   0.417920,  5.833780, 45.001141, 11.472210, -4.771000,
     7   6.566700,   -5.7005,    5.2682, -1.444200,  7.988700,
     8  -0.597700,  5.426900,   -0.4163,    4.7121,
     9   8.218610, 12.794910,  7.439810,  0.774800,  1.051900,
     * 213.18720 ,  0.865900, 41.684158,  1.422800,  0.386800,
     1   1.065700,    0.3778,    0.8310,  0.200900,  0.249400,
     2   0.139900,  0.156200,    0.1218,    0.1319,
     3  17.355511,  1.938400,  6.728610, 16.562321,  5.549310,
     4   0.226100,  3.537500, 39.397228,  2.825000, -0.565700,
     5   1.438500,   -0.8018,    1.1247, -0.557400,  2.707900,
     6   0.106700,  1.819200,    0.2026,    1.5719,
     7  20.578020,  2.948170, 19.599010,  0.244480, 11.372710,
     8  18.772610,  3.287190,133.12410 ,  2.146780, -1.409400,
     9   9.037600,   -0.4908,    7.2214, -0.287100,  2.452300,
     *  -0.641100,  1.614800,   -0.7475,    1.3884,
     1   1.128200,  3.954600,  0.750800,  1.052400,  0.617500,
     2  85.390579,  0.465300,168.26120 ,  0.037700,  0.000800,
     3   0.000300,    0.0011,    0.0002, -0.000300,  0.000100,
     4  -0.000400,  0.000000,    0.0002,    0.0000/)
C * ELEMENT  LU    LR    MD    MG    MN   MO
      SFAC(1027:1596) = (/
     1  28.947630,  1.901820, 15.220810,  9.985200, 15.100010,
     2   0.261030,  3.716010, 84.329880,  7.976290, -6.617900,
     3   4.693700,  -21.3766,    3.7544, -0.472000,  5.858400,
     4  -0.329900,  3.937700,   -0.2987,    3.4074,
     5   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     6   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     7   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     8   0.000000,  0.000000,  0.000000,  0.000000,
     9   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     *   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     1   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     2   0.000000,  0.000000,  0.000000,  0.000000,
     3   5.420410,  2.827500,  2.173500, 79.261177,  1.226900,
     4   0.380800,  2.307300,  7.193710,  0.858400,  0.171900,
     5   0.177100,    0.1421,    0.1346,  0.048600,  0.036300,
     6   0.029800,  0.022000,    0.0255,    0.0184,
     7  11.281910,  5.340910,  7.357310,  0.343200,  3.019300,
     8  17.867420,  2.244100, 83.754379,  1.089600, -0.529900,
     9   2.805200,   -0.0162,    2.2332,  0.336800,  0.728300,
     *   0.270400,  0.468100,    0.2462,    0.3989,
     1   3.702500,  0.277200, 17.235630,  1.095800, 12.887610,
     2  11.004010,  3.742900, 61.658459,  4.387500, -0.048300,
     3   2.733900,   -0.2130,    2.1496, -1.683200,  0.685700,
     4  -1.270300,  3.097800,   -0.6376,    2.6696,
C * ELEMENT  NA    NB    ND    NE    NO    NP
     1   4.762600,  3.285000,  3.173600,  8.842210,  1.267400,
     2   0.313600,  1.112800, 129.42410,  0.676000,  0.135300,
     3   0.123900,    0.1104,    0.0938,  0.036200,  0.024900,
     4   0.021800,  0.015000,    0.0182,    0.0125,
     5  17.614229,  1.188650, 12.014410, 11.766010,  4.041830,
     6   0.204790,  3.533460, 69.795761,  3.755910, -0.112100,
     7   2.482600,   -0.2894,    1.9494, -2.072700,  0.621500,
     8  -0.828200,  2.840400,   -0.4154,    2.4733,
     9  22.684521,  2.662480, 19.684719,  0.210630, 12.774010,
     *  15.885020,  2.851370, 137.90311,  1.984860, -3.180700,
     1  10.907900,   -1.2627,    8.7680, -0.194300,  3.017900,
     2  -0.501200,  1.995000,   -0.5840,    1.7185,
     3   3.955300,  8.404210,  3.112500,  3.426200,  1.454600,
     4   0.230600,  1.125100, 21.718410,  0.351500,  0.101900,
     5   0.083300,    0.0817,    0.0628,  0.025900,  0.016400,
     6   0.015200,  0.009800,    0.0119,    0.0082,
     7   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     8   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     9   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     *   0.000000,  0.000000,  0.000000,  0.000000,
     1  36.187439,  0.511930, 23.596420,  3.253960, 15.640220,
     2  15.362220,  4.185500, 97.490891, 13.357310, -4.505300,
     3  13.966600,  -5.21521,  11.30172,-11.493700,  4.149300,
     4  -6.999500,  9.587600,  -5.05809,  9.70513,
C * ELEMENT  OS    PA    PB    PD    PM    PO
     1  28.189440,  1.629030, 16.155010,  8.979490, 14.930510,
     2   0.382660,  5.675900, 48.164749, 11.000510, -4.980100,
     3   6.221600,   -6.0803,    4.9890, -1.216500,  7.603000,
     4  -0.528000,  5.155800,   -0.3773,    4.4739,
     5  35.884739,  0.547750, 23.294821,  3.415190, 14.189110,
     6  16.923519,  4.172870, 105.25110, 13.428710, -4.247300,
     7  12.868100,   -3.9435,   10.4050, -8.033400,  9.280700,
     8  -4.606700, 10.241300,   -2.8062,    8.9873,
     9  31.061741,  0.690200, 13.063710,  2.357600, 18.442020,
     1   8.618010,  5.969610, 47.257950, 13.411810, -4.075300,
     1   8.506000,   -4.4950,    6.8412, -3.394400, 10.111100,
     1  -1.167600,  6.928700,   -0.7650,    6.0338,
     3  19.331921,  0.698660, 15.501720,  7.989300,  5.295370,
     4  25.205231,  0.605840, 76.898682,  5.265930,  0.121500,
     5   3.933700,    0.0375,    3.1039, -0.998800,  1.007200,
     6  -1.955600,  0.654600,   -4.0056,    0.5602,
     7  23.340521,  2.562700, 19.609529,  0.202090, 13.123510,
     8  15.100910,  2.875160, 132.72110,  2.028760, -4.059800,
     9  11.552300,   -1.6454,    9.3260, -0.175300,  3.224900,
     *  -0.462600,  2.134700,   -0.5402,    1.8396,
     1  34.672642,  0.701000, 15.473310,  3.550780, 13.113810,
     2   9.556430,  7.025890, 47.004551, 13.677010, -3.967000,
     3   9.383400,   -4.2319,    7.5551, -5.121000, 11.049600,
     4  -1.561300,  7.598600,   -1.0198,    6.6253,
C * ELEMENT  PR    PT    PU    RA    RB    RE
     1  22.044020,  2.773930, 19.669720,  0.222090, 12.385610,
     2  16.766920,  2.824280,143.64410 ,  2.058300, -2.416400,
     3  10.282000,   -0.9513,    8.2366, -0.218000,  2.821400,
     4  -0.542400,  1.862400,   -0.6314,    1.6035,
     5  27.005939,  1.512930, 17.763920,  8.811750, 15.713120,
     6   0.424590,  5.783710, 38.610340, 11.688310, -4.593200,
     7   6.926400,   -5.3886,    5.5592, -1.703300,  8.390500,
     8  -0.681200,  5.708100,   -0.4643,    4.9594,
     9  36.525440,  0.499380, 23.808319,  3.263710, 16.770720,
     *  14.945510,  3.479470, 105.98010, 13.381210, -4.656300,
     1  14.372900,  -5.32739,  11.65104, -9.410000,  4.305600,
     2 -13.590500,  6.946800,  -5.70129,  10.01466,
     3  35.763031,  0.616340, 22.906420,  3.871350, 12.473910,
     4  19.988720,  3.210970, 142.32510, 13.621110, -4.008800,
     5  11.296900,   -3.9666,    9.1179, -6.770400,  8.143500,
     6  -2.808100,  9.061400,   -1.8076,    7.9167,
     7  17.178419,  1.788800,  9.643510, 17.315121,  5.139900,
     8   0.274800,  1.529200, 164.93420,  3.487300, -0.468800,
     9   1.607900,   -0.6884,    1.2581, -0.939300,  2.967600,
     *   0.006800,  2.002500,    0.1388,    1.7324,
     1  28.762131,  1.671910, 15.718920,  9.092280, 14.556410,
     2   0.350500,  5.441740, 52.086151, 10.472010, -5.208300,
     3   5.892300,   -6.5366,    4.7224, -1.018500,  7.231000,
     4  -0.469300,  4.894400,   -0.3499,    4.2443,
C * ELEMENT  RH    RN    RU    SB    SC    SE
     1  19.295719,  0.751540, 14.350110,  8.217590,  4.734250,
     2  25.874941,  1.289180, 98.606293,  5.328000,  0.092700,
     3   3.604500,   -0.0161,    2.8414, -1.117800,  0.918700,
     4  -2.528000,  0.596400,   -2.3015,    3.4014,
     5  35.563141,  0.663100, 21.281620,  4.069100,  8.003710,
     6  14.042210,  7.443310, 44.247341, 13.690510, -3.948700,
     7  10.318100,   -4.0632,    8.3167, -8.065900, 10.458000,
     8  -2.084700,  8.311200,   -1.3677,    7.2518,
     9  19.267429,  0.808520, 12.918210,  8.434680,  4.863370,
     *  24.799740,  1.567560, 94.292892,  5.378750,  0.055200,
     1   3.296000,   -0.0760,    2.5955, -1.259400,  0.836300,
     2  -5.363000,  3.650600,   -1.4223,    3.1379,
     3  19.641821,  5.303400, 19.045521,  0.460700,  5.037110,
     4  27.907440,  2.682700, 75.282578,  4.590910, -0.056200,
     5   5.894600,    0.1003,    4.6759, -0.586600,  1.546100,
     6  -1.054700,  1.010400,   -1.2641,    0.8662,
     7   9.189010,  9.021310,  7.367910,  0.572900,  1.640900,
     8 136.10809 ,  1.468000, 51.353149,  1.332900,  0.311900,
     9   1.533100,    0.3700,    1.2039,  0.251900,  0.371600,
     *   0.182900,  0.234800,    0.1609,    0.1987,
     1  17.000629,  2.409800,  5.819610,  0.272600,  3.973100,
     2  15.237210,  4.354300, 43.816349,  2.840900, -0.794300,
     3   1.137200,   -1.0833,    0.8881, -0.092900,  2.225900,
     4   0.236700,  1.483100,    0.2841,    1.2780/)
C * ELEMENT  SI    SM    SN    SR    TA    TB
      SFAC(1597:2242) = (/
     1   6.291510,  2.438600,  3.035300, 32.333740,  1.989100,
     2   0.678500,  1.541000, 81.693787,  1.140700,  0.254100,
     3   0.330200,    0.2153,    0.2529,  0.081700,  0.070400,
     4   0.052200,  0.043100,    0.0444,    0.0362,
     5  24.004240,  2.472740, 19.425831,  0.196450, 13.439610,
     6  14.399610,  2.896040, 128.00710,  2.209630, -5.323600,
     7  12.217800,   -2.1214,    9.9048, -0.163800,  3.441800,
     8  -0.428700,  2.281500,   -0.4997,    1.9667,
     9  19.188919,  5.830310, 19.100519,  0.503100,  4.458500,
     *  26.890930,  2.466300, 83.957176,  4.782110,  0.025900,
     1   5.459100,    0.1164,    4.3256, -0.653700,  1.424600,
     2  -1.158700,  0.929900,   -1.4108,    0.7969,
     3  17.566311,  1.556400,  9.818410, 14.098810,  5.422000,
     4   0.166400,  2.669400,132.37610 ,  2.506400, -0.352800,
     5   1.820000,   -0.5625,    1.4257, -1.530700,  3.249800,
     6  -0.117200,  2.202500,    0.0606,    1.9075,
     7  29.202440,  1.773330, 15.229310,  9.370470, 14.513510,
     8   0.295980,  4.764920, 63.364471,  9.243550, -5.795900,
     9   5.271800,   -7.9760,    4.2206, -0.705200,  6.522700,
     *  -0.383100,  4.399200,   -0.3124,    3.8106,
     1  25.897631,  2.242560, 18.218519,  0.196140, 14.316710,
     2  12.664810,  2.953540, 115.36210,  3.583240, -9.147200,
     3   9.189100,   -4.4782,   11.8047, -0.172300,  4.153700,
     4  -0.349600,  2.765400,   -0.3953,    2.3866,
C * ELEMENT  TC    TE    TH    TI    TL    TM
     1  19.130131,  0.864130, 11.094810,  8.144880,  4.649020,
     2  21.570721,  2.712630, 86.847267,  5.404290,  0.005700,
     3   3.004900,   -0.1426,    2.3642, -1.439000,  0.759300,
     4  -2.008700,  3.349000,   -0.9459,    2.8942,
     5  19.964420,  4.817420, 19.013821,  0.420890,  6.144880,
     6  28.528440,  2.523900, 70.840363,  4.352000, -0.175900,
     7   6.353100,    0.0584,    5.0452, -0.530800,  1.675100,
     8  -0.971000,  1.096000,   -1.1519,    0.9398,
     9  35.564529,  0.563360, 23.421921,  3.462040, 12.747310,
     *  17.830919,  4.807040, 99.172302, 13.431410, -4.149100,
     1  12.329600,   -3.9342,    9.9644, -7.240000,  8.897900,
     2  -3.853300,  9.840300,   -2.4084,    8.6253,
     3   9.759510,  7.850810,  7.355810,  0.500000,  1.699100,
     4  35.633831,  1.902100,116.10510 ,  1.280700,  0.219100,
     5   1.806900,    0.3343,    1.4243,  0.277600,  0.445700,
     6   0.206000,  0.283000,    0.1825,    0.2397,
     7  27.544630,  0.655150, 19.158421,  8.707520, 15.538020,
     8   1.963470,  5.525940, 45.814960, 13.174610, -4.162700,
     9   8.090000,   -4.6638,    6.5029, -2.835800,  9.668800,
     *  -1.011700,  6.609000,   -0.6648,    5.7520,
     1  28.181931,  2.028590, 15.885120,  0.238850, 15.154210,
     2  10.997510,  2.987060,102.96110 ,  6.756220, -8.039300,
     3   4.182100,   -8.6980,    9.2627, -0.313900,  5.248300,
     4  -0.308400,  3.515500,   -0.3092,    3.0391,
C * ELEMENT  U     V     W     XE    Y     YB
     1  36.022839,  0.529300, 23.412830,  3.325300, 14.949110,
     2  16.092730,  4.188000,100.61310 , 13.396610, -4.363800,
     3  13.409000,   -3.9641,   10.8496, -9.676700,  9.664600,
     4  -5.722500, 10.642800,   -3.2691,    9.3520,
     5  10.297110,  6.865710,  7.351110,  0.438500,  2.070300,
     6  26.893829,  2.057100, 102.47810,  1.219900,  0.068700,
     7   2.109700,    0.2663,    1.6689,  0.300500,  0.529400,
     8   0.227600,  0.337600,    0.2036,    0.2864,
     9  29.081829,  1.720290, 15.430010,  9.225910, 14.432710,
     *   0.321700,  5.119830, 57.056061,  9.887510, -5.473400,
     1   5.577400,   -7.1285,    4.4676, -0.849000,  6.872200,
     2  -0.420100,  4.643000,   -0.3261,    4.0239,
     3  20.293320,  3.928200, 19.029819,  0.344000,  8.976710,
     4  26.465940,  1.990000, 64.265869,  3.711800, -0.517900,
     5   7.350000,   -0.0772,    5.8499, -0.420500,  1.957800,
     6  -0.820000,  1.283800,   -0.9636,    1.1015,
     7  17.776020,  1.402900, 10.294610, 12.800610,  5.726300,
     8   0.125600,  3.265880,104.35410 ,  1.912130, -0.267000,
     9   2.024400,   -0.4654,    1.5873, -2.796200,  3.566700,
     *  -0.287900,  2.409900,   -0.0481,    2.0894,
     1  28.664141,  1.988900, 15.434510,  0.257120, 15.308710,
     2  10.664710,  2.989630,100.41710 ,  7.566730, -7.210800,
     3   4.432900,   -9.3530,    9.8114, -0.385000,  5.548600,
     4  -0.315700,  3.722900,   -0.3017,    3.2199,
C * ELEMENT  ZN    ZR   (RS)   (CG)  (ZA)  (ZB)
     1  14.074310,  3.265500,  7.031810,  0.233300,  5.165210,
     2  10.316310,  2.410000, 58.709759,  1.304100, -1.549100,
     3   0.677800,   -2.7473,    0.5279,  0.283900,  1.430100,
     4   0.324200,  0.937500,    0.3166,    0.8033,
     5  17.876530,  1.276180, 10.948010, 11.916010,  5.417330,
     6   0.117620,  3.657210, 87.662781,  2.069290, -0.186200,
     7   2.244900,   -0.3750,    1.7612, -2.967300,  0.559700,
     8  -0.536400,  2.614100,   -0.1887,    2.2812,
     9   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     *   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     1   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     2   0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     4   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     5   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     6   0.000000,  0.000000,  0.000000,  0.000000,
     7   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     8   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     9   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     *   0.000000,  0.000000,  0.000000,  0.000000,
     1   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     2   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     4   0.000000,  0.000000,  0.000000,  0.000000,
C * ELEMENT  (ZC)  OW    Q     X     HW   Z
     1   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     2   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     4   0.000000,  0.000000,  0.000000,  0.000000,
     5   3.048500, 13.277110,  2.286800,  5.701110,  1.546300,
     6   0.323900,  0.867000, 32.908939,  0.250800,  0.049200,
     7   0.032200,    0.0389,    0.0241,  0.010600,  0.006000,
     8   0.005600,  0.003600,  0.0044,   0.0030,
     9   2.310000, 20.843920,  1.020000, 10.207510,  1.588600,
     *   0.568700,  0.865000, 51.651249,  0.215600,  0.018100,
     1   0.009100,    0.0137,    0.0067,  0.003300,  0.001600,
     2   0.001500,  0.000900,  0.0008,   0.0008,
     3   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     4   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     5   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     6   0.000000,  0.000000,  0.000000,  0.000000,
     7   0.493000, 10.510910,  0.322910, 26.125731,  0.140190,
     8   3.142360,  0.040810, 57.799770,  0.003040,  0.000000,
     9   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     *   0.000000,  0.000000,  0.000000,  0.000000,
     1   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     2   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     4   0.000000,  0.000000,  0.000000,  0.000000,
C * ELEMENT  (OR) (OA) (OB) (OC)
     1   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     2   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     4   0.000000,  0.000000,  0.000000,  0.000000,
     5   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     6   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     7   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     8   0.000000,  0.000000,  0.000000,  0.000000,
     9   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     *   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     1   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     2   0.000000,  0.000000,  0.000000,  0.000000,
     3   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     4   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     5   0.000000,  0.000000,  0.000000,       0.0,       0.0,
     6   0.000000,  0.000000,  0.000000,  0.000000/)
C * ELECTRON SCATTERING FACTORS [Peng,L.-M, Micron 30 (1999) 625-648]
      PENG = (/
C * ELEMENT H C O N CL S
     1 0.0367, 0.5608, 0.1269, 3.7913, 0.2360, 13.5557, 0.1290, 37.7229,
     2 0.1361, 0.3731, 0.5482, 3.2814, 1.2266, 13.0456, 0.5971, 41.0202,
     3 0.1433, 0.3055, 0.5103, 2.2683, 0.9370,  8.2625, 0.3923, 25.6645,
     4 0.1372, 0.3287, 0.5344, 2.6733, 1.0862, 10.3165, 0.4547, 32.7631,
     5 0.3398, 0.3379, 0.8908, 2.6190, 2.3878, 11.0684, 1.2376, 33.5378,
     6 0.3478, 0.3652, 0.9158, 2.8915, 2.5066, 13.0522, 1.3884, 40.1848,
C * ELEMENT BR P I CU NI AC
     7 0.6216, 0.3216, 1.4943, 2.2338, 3.0763, 11.7075, 1.8642, 36.7639,
     8 0.3540, 0.3941, 0.9397, 3.1810, 2.6203, 15.6579, 1.5707, 49.5239,
     9 0.8912, 0.3150, 2.7442, 2.6616, 4.3316, 13.6958, 2.9328, 43.2296,
     * 0.5932, 0.3680, 1.8344, 2.8959, 1.8080, 15.6333, 1.3586, 70.6800,
     1 0.5785, 0.3704, 1.8679, 2.9964, 2.2229, 16.8507, 1.8940, 65.2843,
     2 1.7346, 0.3816, 4.5959, 3.7454, 7.0436, 21.1330, 7.0521,102.1159,
C * ELEMENT AG AL AM AR AS AT
     3 0.9085, 0.3541, 2.9433, 3.3319, 3.1021, 14.7723, 1.7092, 70.5441,
     4 0.3582, 0.4529, 0.9754, 3.7745, 2.6393, 23.3862, 1.9103, 80.5019,
     5 1.7519, 0.3654, 4.8096, 3.5215, 5.8155, 18.5120, 5.4119, 98.8221,
     6 0.3409, 0.3229, 0.8966, 2.4778, 2.2636,  9.7408, 1.0786, 28.9354,
     7 0.6504, 0.3550, 1.6706, 2.6169, 2.9930, 15.1100, 2.0018, 50.8113,
     8 1.4170, 0.3224, 3.4829, 2.7289, 5.0951, 13.4904, 3.4639, 46.2094,
C * ELEMENT AU B BA BE BI BK
     9 1.3413, 0.3262, 3.0559, 2.6076, 4.1659, 11.5043, 2.0022, 48.4954,
     * 0.1298, 0.4180, 0.5200, 3.9214, 1.3767, 16.6634, 0.7666, 51.7511,
     1 1.3111, 0.4432, 3.9542, 4.3226, 5.8693, 24.3857, 7.0998,128.5976,
     2 0.1180, 0.4599, 0.4394, 4.4816, 1.4273, 21.5831, 1.0661, 66.1150,
     3 1.4616, 0.3396, 3.6426, 2.9739, 4.7876, 14.8388, 3.1935, 56.7362,
     4 1.7298, 0.3554, 4.7198, 3.3269, 5.7527, 17.3659, 5.1576, 84.3294,
C * ELEMENT CA CD CE CF CM CO
     5 0.5474, 0.4700, 2.2793, 5.0494, 3.1934, 29.6928, 3.8824,109.5608,
     6 0.9056, 0.3466, 2.9430, 3.2215, 3.1814, 14.7749, 2.1946, 62.3544,
     7 1.3019, 0.4256, 3.8491, 4.0288, 5.8568, 22.0020, 6.3222,107.6524,
     8 1.6401, 0.3332, 4.3905, 2.9830, 5.4504, 14.6892, 5.4542, 73.0723,
     9 1.7284, 0.3577, 4.7162, 3.3776, 5.9338, 17.7168, 5.2896, 86.4936,
     * 0.5730, 0.3799, 1.9219, 3.1572, 2.3358, 17.8168, 2.0177, 68.4867,
C * ELEMENT CR CS D DY ER ES
     1 0.5478, 0.4032, 2.0737, 3.7014, 2.3527, 20.0893, 1.9866, 87.9230,
     2 1.2968, 0.4462, 3.8609, 4.3194, 5.6613, 24.1136, 5.6489,168.3481,
     3 0.0367, 0.5608, 0.1269, 3.7913, 0.2360, 13.5557, 0.1290, 37.7229,
     4 1.4104, 0.4076, 3.6934, 3.6339, 4.3012, 20.3594, 5.1904,103.6978,
     5 1.4391, 0.4038, 3.6351, 3.5707, 4.0572, 20.0727, 4.9059,100.4842,
     6 0.0   , 0.0   , 0.0   , 0.0   , 0.0   , 0.0    , 0.0   ,  0.0   ,
C * ELEMENT EU F FE FM FR GA
     7 1.3963, 0.4230, 3.8201, 3.8621, 4.6869, 21.4604, 5.6321,110.3872,
     8 0.1516, 0.2888, 0.5193, 2.0619, 0.8220,  7.2628, 0.3081, 22.0262,
     9 0.5627, 0.3859, 1.9685, 3.3103, 2.4527, 18.7003, 2.1750, 71.6638,
     * 0.0   , 0.0   , 0.0   , 0.0   , 0.0   ,  0.0   , 0.0   ,   0.0  ,
     1 1.7697, 0.3969, 4.6820, 3.9950, 6.6701, 23.0274, 5.5268,154.8886,
     2 0.6737, 0.3901, 1.8457, 3.0289, 2.6395, 19.0448, 1.9413, 74.1674,
C * ELEMENT GD GE HE HF HG HO
     3 1.3784, 0.4105, 3.7349, 3.7014, 4.8549, 20.2877, 5.2564, 96.0364,
     4 0.6660, 0.3741, 1.7662, 2.8390, 2.8876, 17.2911, 2.0510, 62.5149,
     5 0.0406, 0.3140, 0.1276, 2.0952, 0.1738,  7.1369, 0.0758, 19.4462,
     6 1.4209, 0.3772, 3.3984, 3.2109, 4.2315, 17.7720, 4.1000, 76.0916,
     7 1.3592, 0.3265, 3.1327, 2.6458, 4.1897, 11.6919, 2.2748, 47.9347,
     8 1.3805, 0.3938, 3.5395, 3.4131, 4.4117, 18.4989, 5.0148, 86.9074,
C * ELEMENT IN IR K KR LA LI
     9 0.9660, 0.3648, 3.1971, 3.4534, 3.6243, 18.3358, 2.6351, 75.8859,
     * 1.3783, 0.3440, 3.1637, 2.7975, 4.3549, 13.3640, 2.8050, 54.3356,
     1 0.5658, 0.5061, 2.4151, 5.7656, 2.4655, 31.9169, 3.5240,151.2590,
     2 0.6240, 0.3144, 1.4352, 2.1394, 3.0847, 10.6060, 1.7511, 32.4403,
     3 1.2872, 0.4283, 3.8478, 4.0782, 6.0581, 22.4363, 6.5606,109.8403,
     4 0.1198, 0.5908, 0.3952, 6.1114, 1.3794, 36.7672, 1.3889,117.0314,
C * ELEMENT LU LR MD MG MN MO
     5 1.4381, 0.3874, 3.4689, 3.3304, 4.0824, 18.8077, 4.4599, 84.5078,
     6 0.0   , 0.0   , 0.0   , 0.0   , 0.0   ,  0.0   , 0.0   ,  0.0   ,
     7 0.0   , 0.0   , 0.0   , 0.0   , 0.0   ,  0.0   , 0.0   ,  0.0   ,
     8 0.3248, 0.4455, 0.9243, 3.5744, 2.0039, 24.2702, 1.9507, 80.7304,
     9 0.5552, 0.3947, 2.0073, 3.4800, 2.5678, 19.5862, 2.3695, 74.9201,
     * 0.9334, 0.3996, 2.8581, 3.9476, 3.8278, 18.6153, 2.6302, 82.5062,
C * ELEMENT NA NB ND NE NO NP
     1 0.3319, 0.4950, 0.9857, 4.0855, 1.4885, 31.5107, 1.9657,118.4940,
     2 0.9337, 0.4074, 2.8218, 4.0572, 3.9092, 19.4778, 2.9880, 85.5042,
     3 1.3473, 0.4266, 3.8589, 3.9844, 5.1226, 21.8395, 6.2264,114.8891,
     4 0.1575, 0.2714, 0.5041, 1.8403, 0.7330,  6.3059, 0.2572, 19.1640,
     5 0.0   , 0.0   , 0.0   , 0.0   , 0.0   ,  0.0   , 0.0   ,  0.0   ,
     6 1.7327, 0.3683, 4.6782, 3.5375, 6.4465, 18.8556, 5.8528, 91.5521,
C * ELEMENT OS PA PB PD PM PO
     7 1.3877, 0.3502, 3.2082, 2.8796, 4.3731, 14.1535, 2.9958, 57.3692,
     8 1.7266, 0.3729, 4.6123, 3.6159, 6.7855, 19.6433, 6.3876, 95.2720,
     9 1.4700, 0.3452, 3.6387, 3.0340, 4.5674, 14.8562, 2.9103, 60.2174,
     * 0.7832, 0.3094, 2.1753, 2.5857, 3.2003,  9.8481, 1.4127, 37.4035,
     1 1.3631, 0.4253, 3.8462, 3.9386, 4.9578, 21.6330, 6.0228,112.8589,
     2 1.4255, 0.3274, 3.5214, 2.8031, 4.9058, 13.8305, 3.4925, 50.1382,
C * ELEMENT PR PT PU RA RB RE
     3 1.3354, 0.4305, 3.8652, 4.0368, 5.3000, 22.1273, 6.4296,117.0334,
     4 1.3489, 0.3322, 3.0674, 2.6601, 4.2095, 12.0128, 2.1738, 50.3882,
     5 1.7491, 0.3683, 4.7933, 3.5651, 5.9841, 18.8727, 5.6139,100.8062,
     6 1.7704, 0.3938, 4.6854, 3.9313, 6.8034, 22.4168, 7.2352,120.9717,
     7 1.0180, 0.4850, 2.8882, 5.1504, 3.5125, 26.1762, 4.3375,155.1291,
     8 1.3898, 0.3548, 3.2373, 2.9382, 4.3683, 14.8500, 3.2472, 60.6048,
C * ELEMENT RH RN RU SB SC SE
     9 0.9046, 0.3646, 2.8679, 3.4888, 3.3997, 15.5106, 2.0510, 71.3737,
     * 1.4001, 0.3153, 3.4082, 2.6261, 5.2516, 12.9003, 3.4250, 42.3929,
     1 0.9175, 0.3776, 2.8691, 3.6434, 3.5480, 16.4538, 2.2030, 74.4590,
     2 0.9323, 0.3405, 2.9938, 3.0545, 4.0829, 16.2843, 2.9578, 56.5387,
     3 0.5389, 0.4446, 2.2102, 4.5701, 3.1187, 26.4597, 3.4302, 98.1283,
     4 0.6343, 0.3374, 1.5698, 2.4000, 3.0362, 13.1385, 1.9607, 42.4344,
C * ELEMENT SI SM SN SR TA TB
     5 0.3626, 0.4281, 0.9737, 3.5570, 2.7209, 19.3905, 1.7660, 64.3334,
     6 1.3702, 0.4204, 3.8270, 3.8747, 4.8068, 21.3840, 5.8402,110.9527,
     7 0.9481, 0.3518, 3.1011, 3.2474, 3.8863, 17.4348, 2.9142, 66.0384,
     8 1.0127, 0.4721, 2.9403, 4.9802, 3.9920, 26.8565, 5.1441,116.0307,
     9 1.4163, 0.3714, 3.3456, 3.1289, 4.3281, 16.8719, 3.7406, 70.3632,
     * 1.4257, 0.4182, 3.7865, 3.7931, 4.4336, 21.3185, 5.2698,107.6330,
C * ELEMENT TC TE TH TI TL TM
     1 0.9282, 0.3894, 2.8832, 3.8131, 3.8985, 18.2715, 3.1237, 74.4844,
     2 0.9060, 0.3256, 2.8392, 2.8170, 4.1639, 14.6041, 3.0782, 48.0880,
     3 1.7012, 0.3704, 4.5007, 3.5712, 7.2504, 19.8632, 6.6077, 89.3562,
     4 0.5398, 0.4281, 2.1568, 4.2236, 2.9961, 24.1928, 3.0751, 90.6685,
     5 1.4735, 0.3500, 3.6368, 3.0849, 4.3950, 14.9338, 2.5803, 65.0072,
     6 1.4561, 0.4028, 3.6041, 3.5468, 3.9360, 19.9521, 4.7711, 98.6682,
C * ELEMENT U V W XE Y YB
     7 1.7417, 0.3729, 4.7063, 3.6337, 6.6509, 19.6579, 5.9929, 95.0805,
     8 0.5412, 0.4132, 2.1063, 3.9256, 2.8525, 22.3625, 2.7967, 84.4689,
     9 1.4109, 0.3653, 3.2997, 3.0517, 4.3698, 15.9630, 3.4408, 65.7545,
     * 0.8749, 0.3046, 2.6276, 2.4959, 4.4112, 12.5908, 2.8758, 38.5666,
     1 0.9722, 0.4427, 2.8705, 4.5552, 4.1571, 24.0646, 4.6466, 99.1688,
     2 1.4617, 0.3986, 3.5735, 3.4988, 3.8563, 19.9050, 4.6254, 97.9782,
C * ELEMENT ZN ZR
     1 0.5996, 0.3602, 1.7763, 2.7665, 2.0240, 15.5278, 1.6598, 60.2830,
     2 0.9592, 0.4279, 2.8531, 4.3237, 4.1761, 22.1510, 4.1491, 89.7694
     3 /)
      VALENCE(1:102) = (/
C * Data_BOND_VALENCE_PARAMETERS_2004_08_12  (I.D.Brown)
C * a 'Brown and Altermatt, (1985), Acta Cryst. B41, 244-247 (empirical)'
C * b 'Brese and O'Keeffe, (1991), Acta Cryst. B47, 192-197 (extrapolated)'
C * c 'Adams, 2001, Acta Cryst. B57, 278-287 (includes second neighbours)'
C * d 'Hu et al. (1995) Inorg. Chim. Acta, 232, 161-165. '
C * e 'I.D.Brown Private communication'
C * f 'Brown et al. (1984) Inorg. Chem. 23, 4506-4508'
C * g 'Palenik (1997) Inorg. Chem. 36 4888-4890'
C * h 'Kanowitz and Palenik (1998) Inorg. Chem. 37 2086-2088'
C * i 'Wood and Palenik (1998) Inorg. Chem. 37 4149-4151'
C * j 'Liu and Thorp (1993) Inorg. Chem. 32 4102-4105'
C * k 'Palenik (1997) Inorg. Chem. 36 3394-3397'
C * l 'Shields, Raithby, Allen and Motherwell (1999) Acta Cryst.B56, 455-465'
C * m 'Chen, Zhou and Hu (2002) Chinese Sci. Bul. 47, 978-980.'
C * n 'Kihlbourg (1963) Ark. Kemi 21 471; Schroeder 1975 Acta Cryst. B31, 2294'
C * o 'Allmann (1975) Monatshefte Chem. 106, 779'
C * p 'Zachariesen (1978) J.Less Common Metals 62, 1'
C * q 'Krivovichev and Brown (2001) Z. Krist. 216, 245'
C * r 'Burns, Ewing and Hawthorne (1997) Can. Miner. 35,1551-1570'
C * s 'Garcia-Rodriguez, et al. (2000) Acta Cryst. B56, 565-569'
C * t 'Mahapatra et al. (1996) J. Amer.Chem. Soc. 118, 11555'
C * u 'Wood and Palenik (1999) Inorg. Chem. 38, 1031-1034'
C * v 'Wood and Palenik (1999) Inorg. Chem. 38, 3926-3930'
C * w 'Wood, Abboud, Palenik and Palenik (2000) Inorg. Chem. 39, 2065-2068'
C * x 'Tytko, Mehnike and Kurad (1999) Structure and Bonding 93, 1-66'
C * y 'Gundemann, et al.(1999) J. Phys. Chem. A 103, 4752-4754'
C * z 'Zocchi (2000) Solid State Sci. 2 383-387'
C * aa 'Jensen, Palenik and Tiekiak (2001) Polyhedron 20, 2137'
C * ab 'Roulhac and Palenik (2002) Inorg. Chem. 42, 118-121'
C * ac 'Holsa et al.(2002) J.Solid State Chem 165, 48-55'
C * ae 'Trzesowska, Kruszynski & Bartezak (2004) Acta Cryst. B60, 174-178'
C * af 'Locock & Burns (2004) Z.Krist. 219, 267-271'
C * 'PLATON'
     1 'Ac3O -2 2.24 0.37b', 'Ac3O -2 2.29 0.35p', 'Ac3F -1 2.13 0.37b',
     2 'Ac3F -1 2.10 0.40p', 'Ac3Cl-1 2.63 0.37b', 'Ac3Cl-1 2.60 0.40p',
     3 'Ac3Br-1 2.75 0.40p', 'Ag1O -2 1.8420.37a', 'Ag1O -2 1.8050.37b',
     4 'Ag1S -2 2.1190.37a', 'Ag1F -1 1.80 0.37b', 'Ag1Cl-1 2.09 0.37b',
     5 'Ag2F -1 1.79 0.37e', 'Ag3F -1 1.83 0.37e', 'Ag9Br-1 2.22 0.37b',
     6 'Ag9I -1 2.38 0.37b', 'Ag9Se-2 2.26 0.37b', 'Ag9Te-2 2.51 0.37b',
     7 'Ag9N -3 1.85 0.37b', 'Ag9P -3 2.22 0.37b', 'Ag9As-3 2.30 0.37b',
     8 'Ag9H -1 1.50 0.37b', 'Al3O -2 1.6200.37e', 'Al3O -2 1.6440.38o',
     9 'Al3S -2 2.21 0.37e', 'Al3S -2 2.13 0.37b', 'Al3Se-2 2.27 0.37b',
     * 'Al3Te-2 2.48 0.37b', 'Al3F -1 1.5450.37a', 'Al3Cl-1 2.0320.37a',
     1 'Al3Br-1 2.20 0.37b', 'Al3I -1 2.41 0.37b', 'Al3N -3 1.79 0.37b',
     2 'Al3P -3 2.24 0.37b', 'Al3As-3 2.30 0.37b', 'Al3H -1 1.45 0.37b',
     3 'Am3O -2 2.11 0.37b', 'Am3O -2 2.13 0.35p', 'Am3F -1 2.00 0.37b',
     4 'Am3F -1 1.98 0.40p', 'Am3Cl-1 2.48 0.37b', 'Am3Cl-1 2.45 0.40p',
     5 'Am3Br-1 2.59 0.40p', 'Am4O -2 2.08 0.37p', 'Am4O -2 2.12 0.37e',
     6 'Am4F -1 1.96 0.40p', 'Am5O -2 2.07 0.35p', 'Am5F -1 1.95 0.40p',
     7 'Am6O -2 2.05 0.35p', 'Am6F -1 1.95 0.40p', 'Am5O -2 2.12 0.37e',
     8 'As2S -2 2.24 0.37e', 'As2Se-2 2.38 0.37e', 'As3O -2 1.7890.37a',
     9 'As3S -2 2.2720.37a', 'As3Se-2 2.40 0.37e', 'As3Te-2 2.65 0.37e',
     * 'As3F -1 1.70 0.37b', 'As3Cl-1 2.16 0.37b', 'As3Br-1 2.35 0.37e',
     1 'As3I -1 2.58 0.37e', 'As3C -4 1.93 0.37b', 'As5O -2 1.7670.37a',
     2 'As5S -2 2.28 0.37e', 'As5F -1 1.6200.37a', 'As5Cl-2 2.14 0.37b',
     3 'Au1Cl-1 2.02 0.37e', 'Au1I -1 2.35 0.37e', 'Au3O -2 1.89 0.37e',
     4 'Au3O -2 1.8330.37b', 'Au3S -2 2.39 0.35e', 'Au3F -1 1.89 0.37e',
     5 'Au3F -1 1.81 0.37b', 'Au3Cl-1 2.17 0.37b', 'Au3Br-1 2.32 0.37e',
     6 'Au3I -1 2.54 0.37e', 'Au3N -3 1.94 0.35e', 'Au5F -1 1.80 0.37e',
     7 'Au9S -2 2.03 0.37b', 'Au9Se-2 2.18 0.37b', 'Au9Te-2 2.41 0.37b',
     8 'Au9Br-1 2.12 0.37b', 'Au9I -1 2.34 0.37b', 'Au9N -3 1.72 0.37b',
     9 'Au9P -3 2.14 0.37b', 'Au9As-3 2.22 0.37b', 'Au9H -1 1.37 0.37b',
     * 'B 3O -2 1.3710.37a', 'B 3S -2 1.77 0.37e', 'B 3S -2 1.82 0.37b',
     1 'B 3Se-2 1.95 0.37b', 'B 3Te-2 2.20 0.37b', 'B 3F -1 1.2810.37a',
     2 'B 3F -1 1.31 0.37b', 'B 3Cl-1 1.74 0.37b', 'B 3Br-1 1.88 0.37b',
     3 'B 3I -1 2.10 0.37b', 'B 3N -3 1.47 0.37b', 'B 3P -3 1.88 0.37b',
     4 'B 3As-3 1.97 0.37b', 'B 3H -1 1.14 0.37b', 'B 3B  3 1.4020.37e'/
     5 )
      VALENCE(103:207) = (/
     5 'Ba2O -2 2.2850.37a', 'Ba2S -2 2.7690.37a', 'Ba2Se-2 2.88 0.37b',
     6 'Ba2Te-2 3.08 0.37b', 'Ba2F -1 2.1880.37a', 'Ba2Cl-1 2.69 0.37b',
     7 'Ba2Br-1 2.88 0.37b', 'Ba2I -1 3.13 0.37b', 'Ba2N -3 2.47 0.37b',
     8 'Ba2P -3 2.88 0.37b', 'Ba2As-3 2.96 0.37b', 'Ba2H -1 2.22 0.37b',
     9 'Be2O -2 1.3810.37a', 'Be2S -2 1.83 0.37b', 'Be2Se-2 1.97 0.37b',
     * 'Be2Te-2 2.21 0.37b', 'Be2F -1 1.2810.37a', 'Be2Cl-1 1.76 0.37b',
     1 'Be2Br-1 1.90 0.37b', 'Be2I -1 2.10 0.37b', 'Be2N -3 1.50 0.37b',
     2 'Be2P -3 1.95 0.37b', 'Be2As-3 2.00 0.37b', 'Be2H -1 1.11 0.37b',
     3 'Bi3O -2 2.0940.37a', 'Bi3S -2 2.5700.37a', 'Bi2Se-2 2.70 0.35e',
     4 'Bi3F -1 1.99 0.37b', 'Bi3Cl-1 2.48 0.37b', 'Bi3Cl-1 2.40 0.37e',
     5 'Bi3Br-1 2.59 0.37e', 'Bi3I -1 2.82 0.37e', 'Bi3N -3 2.02 0.35e',
     6 'Bi5O -2 2.06 0.37b', 'Bi5F -1 1.97 0.37b', 'Bi5Cl-1 2.44 0.37b',
     7 'Bi9Br-1 2.62 0.37b', 'Bi9I -1 2.84 0.37b', 'Bi9S -2 2.55 0.37b',
     8 'Bi9Se-2 2.72 0.37b', 'Bi9Te-2 2.87 0.37b', 'Bi9N -3 2.24 0.37b',
     9 'Bi9P -3 2.63 0.37b', 'Bi9As-3 2.72 0.37b', 'Bi9H -1 1.97 0.37b',
     * 'Bk3O -2 2.08 0.37b', 'Bk3O -2 2.10 0.35p', 'Bk3F -1 1.96 0.37b',
     1 'Bk3F -1 1.95 0.40p', 'Bk3Cl-1 2.35 0.37e', 'Bk3Cl-1 2.46 0.37b',
     2 'Bk3Cl-1 2.42 0.40p', 'Bk3Br-1 2.56 0.40p', 'Bk4O -2 2.07 0.35p',
     3 'Bk4F -1 1.93 0.40p', 'Br3O -2 1.90 0.37e', 'Br3F -1 1.75 0.37e',
     4 'Br5O -2 1.84 0.37e', 'Br5F -1 1.76 0.37e', 'Br7O -2 1.81 0.37b',
     5 'Br7F -1 1.72 0.37b', 'Br7Cl-1 2.19 0.37b', 'C 2O -2 1.3660.37e',
     6 'C 2Cl-1 1.4100.37e', 'C 4O -2 1.3900.37a', 'C 4O -2 1.40 0.26o',
     7 'C 4C  4 1.54 0.37e', 'C 4S -2 1.80 0.37e', 'C 4F -1 1.32 0.37b',
     8 'C 4F -1 1.41 0.37e', 'C 4Cl-1 1.76 0.37b', 'C 4Br-1 1.91 0.37e',
     9 'C 4N -3 1.4420.37a', 'C 9Se-2 1.97 0.37b', 'C 9I -1 2.12 0.37b',
     * 'C 9Br-1 1.90 0.37b', 'C 9S -2 1.82 0.37b', 'C 9Te-2 2.21 0.37b',
     1 'C 9N -3 1.47 0.37b', 'C 9P -3 1.89 0.37b', 'C 9As-3 1.99 0.37b',
     2 'C 9H -1 1.10 0.37b', 'Ca2O -2 1.9670.37a', 'Ca2O -2 1.8960.41o',
     3 'Ca2S -2 2.45 0.37b', 'Ca2Se-2 2.56 0.37b', 'Ca2Te-2 2.76 0.37b',
     4 'Ca2F -1 1.8420.37a', 'Ca2Cl-1 2.37 0.37b', 'Ca2Br-1 2.5070.37e',
     5 'Ca2Br-1 2.49 0.37b', 'Ca2I -1 2.72 0.37b', 'Ca2N -3 2.14 0.37b',
     6 'Ca2P -3 2.55 0.37b', 'Ca2As-3 2.62 0.37b', 'Ca2H -1 1.83 0.37b',
     7 'Cd2O -2 1.9040.37a', 'Cd2S -2 2.3040.37a', 'Cd2Se-2 2.40 0.37b',
     8 'Cd2Te-2 2.59 0.37b', 'Cd2F -1 1.8110.37b', 'Cd2Cl-1 2.2120.37a',
     9 'Cd2Cl-1 2.23 0.37b', 'Cd2Br-1 2.35 0.37b', 'Cd2I -1 2.57 0.37b'/
     * )
      VALENCE(208:312) = (/
     * 'Cd2I -1 2.60 0.37e', 'Cd2N -3 1.96 0.37b', 'Cd2P -3 2.34 0.37b',
     1 'Cd2As-3 2.43 0.37b', 'Cd2H -1 1.66 0.37b', 'Ce3O -2 2.1510.37b',
     2 'Ce3O -2 2.1210.37a', 'Ce3O -2 2.1160.37a', 'Ce3S -2 2.65 0.37e',
     3 'Ce3F -1 2.0360.37b', 'Ce3F -1 2.00 0.40p', 'Ce3Cl-1 2.52 0.37b',
     4 'Ce3Cl-1 2.49 0.40p', 'Ce3Br-1 2.65 0.35e', 'Ce3Br-1 2.65 0.40p',
     5 'Ce3I -1 2.87 0.40p', 'Ce4O -2 2.0280.37b', 'Ce4O -2 2.0680.37a',
     6 'Ce4S -2 2.65 0.35e', 'Ce4F -1 1.9950.37b', 'Ce4F -1 1.97 0.40p',
     7 'Ce9Cl-1 2.41 0.37b', 'Ce9Br-1 2.69 0.37b', 'Ce9I -1 2.92 0.37b',
     8 'Ce9S -2 2.62 0.37b', 'Ce9Se-2 2.74 0.37b', 'Ce9Te-2 2.92 0.37b',
     9 'Ce9N -3 2.34 0.37b', 'Ce9P -3 2.70 0.37b', 'Ce9As-3 2.78 0.37b',
     * 'Ce9H -1 2.04 0.37b', 'Cf3O -2 2.07 0.37b', 'Cf3F -1 1.95 0.37b',
     1 'Cf3F -1 1.94 0.40p', 'Cf3Cl-1 2.45 0.37b', 'Cf3Cl-1 2.41 0.40p',
     2 'Cf3Br-1 2.55 0.40p', 'Cf4O -2 2.06 0.35p', 'Cf4F -1 1.92 0.40p',
     3 'Cl3O -2 1.71 0.37e', 'Cl3F -1 1.69 0.37e', 'Cl5O -2 1.67 0.37e',
     4 'Cl7O -2 1.6320.37a', 'Cl7F -1 1.55 0.37b', 'Cl7Cl-1 2.00 0.37b',
     5 'Cf3Cl-1 2.45 0.37b', 'Cm3O -2 2.23 0.37b', 'Cm3O -2 2.12 0.35p',
     6 'Cm3F -1 2.12 0.37b', 'Cm3F -1 1.96 0.40p', 'Cm3Cl-1 2.62 0.37b',
     7 'Cm3Cl-1 2.44 0.40p', 'Cm4O -2 2.08 0.35p', 'Cm4F -1 1.94 0.40p',
     8 'Co1H -1 1.0000.35e', 'Co2O -2 1.6920.37a', 'Co2O -2 1.6850.37i',
     9 'Co2S -2 1.94 0.37e', 'Co2F -1 1.64 0.37b', 'Co2Cl-1 2.0330.37a',
     * 'Co2Cl-1 2.01 0.37b', 'Co2N -3 1.72 0.37e', 'Co3O -2 1.6370.37i',
     1 'Co3O -2 1.70 0.37b', 'Co3S -2 2.02 0.37e', 'Co3F -1 1.62 0.37b',
     2 'Co3Cl-1 2.05 0.37b', 'Co3N -3 1.75 0.37e', 'Co3C  2 1.6340.37b',
     3 'Co4O -2 1.72 0.37e', 'Co4F -1 1.55 0.37e', 'Co9O -2 1.6550.42o',
     4 'Co9Br-1 2.18 0.37b', 'Co9I -1 2.37 0.35b', 'Co9S -2 2.06 0.37b',
     5 'Co9Se-2 2.24 0.37b', 'Co9Te-2 2.46 0.37b', 'Co9N -3 1.84 0.37b',
     6 'Co9P -3 2.21 0.37b', 'Co9As-3 2.28 0.37b', 'Co9H -1 1.44 0.37b',
     7 'Cr2O -2 1.73 0.37b', 'Cr2F -1 1.67 0.37b', 'Cr2F -1 1.74 0.37e',
     8 'Cr2Cl-1 2.09 0.37b', 'Cr2Br-1 2.26 0.37e', 'Cr2I -1 2.48 0.37e',
     9 'Cr2N -3 1.83 0.35e', 'Cr3O -2 1.7240.37a', 'Cr3O -2 1.7080.37w',
     * 'Cr3S -2 2.1620.37e', 'Cr3F -1 1.6570.37a', 'Cr3F -1 1.64 0.37b',
     1 'Cr3Cl-1 2.08 0.37b', 'Cr3Br-1 2.28 0.37e', 'Cr3N -3 1.81 0.37e',
     2 'Cr4O -2 1.81 0.37e', 'Cr4F -1 1.56 0.37e', 'Cr5O -2 1.76 0.37w',
     3 'Cr5O -2 1.78 0.37e', 'Cr6O -2 1.7940.37a', 'Cr6F -1 1.74 0.37b',
     4 'Cr6Cl-1 2.12 0.37b', 'Cr9O -2 1.79 0.34o', 'Cr9O -2 1.7240.37w'/
     5 )
      VALENCE(313:417) = (/
     5 'Cr9Br-1 2.26 0.37b', 'Cr9I -1 2.45 0.37b', 'Cr9S -2 2.18 0.37b',
     6 'Cr9Se-2 2.29 0.37b', 'Cr9Te-2 2.52 0.37b', 'Cr9N -3 1.85 0.37b',
     7 'Cr9P -3 2.27 0.37b', 'Cr9As-3 2.34 0.37b', 'Cr9H -1 1.52 0.37b',
     8 'Cs1O -2 2.4170.37a', 'Cs1O -2 2.2860.40c', 'Cs1S -2 2.89 0.37b',
     9 'Cs1S -2 2.5250.51c', 'Cs1S -2 2.93 0.37e', 'Cs1Se-2 2.98 0.37b',
     * 'Cs1Se-2 2.6420.55c', 'Cs1Te-2 3.16 0.37b', 'Cs1Te-2 2.7640.60c',
     1 'Cs1F -1 2.33 0.37b', 'Cs1F -1 2.1980.41c', 'Cs1F -1 2.38 0.37e',
     2 'Cs1Cl-1 2.7910.37a', 'Cs1Cl-1 2.4710.49c', 'Cs1Br-1 2.95 0.37b',
     3 'Cs1Br-1 2.5030.54c', 'Cs1I -1 3.18 0.37b', 'Cs1I -1 2.6920.60c',
     4 'Cs1I -1 3.29 0.37e', 'Cs1N -3 2.83 0.37e', 'Cs1N -3 2.53 0.37b',
     5 'Cs1P -3 2.93 0.37b', 'Cs1As-3 3.04 0.37b', 'Cs1H -1 2.44 0.37b',
     6 'Cu1O -2 1.6100.37e', 'Cu1O -2 1.5040.37l', 'Cu1S -2 1.8980.37a',
     7 'Cu1S -2 1.8110.37l', 'Cu1Se-2 1.9000.37l', 'Cu1F -1 1.6  0.37b',
     8 'Cu1Cl-1 1.8580.37l', 'Cu1Cl-1 1.89 0.37e', 'Cu1Br-1 2.03 0.37e',
     9 'Cu1I -1 2.1080.37a', 'Cu1I -1 2.1550.37l', 'Cu1N -3 1.5200.37l',
     * 'Cu1N -3 1.4800.37l', 'Cu1N -3 1.6300.37l', 'Cu1P -3 1.7740.37l',
     1 'Cu1As-3 1.8560.37l', 'Cu1C -4 1.4460.37l', 'Cu2O -2 1.6790.37a',
     2 'Cu2O -2 1.6490.37j', 'Cu2O -2 1.6550.37l', 'Cu2S -2 2.0540.37a',
     3 'Cu2S -2 2.0600.37j', 'Cu2S -2 2.0240.37l', 'Cu2S -2 1.86 0.37b',
     4 'Cu2Se-2 2.02 0.37b', 'Cu2Se-2 2.1240.37l', 'Cu2Te-2 2.27 0.37b',
     5 'Cu2F -1 1.5940.37a', 'Cu2Cl-1 2.00 0.37b', 'Cu2Br-1 1.99 0.37b',
     6 'Cu2Br-1 2.1340.37l', 'Cu2I -1 2.16 0.37b', 'Cu2I -1 2.36 0.37l',
     7 'Cu2N -3 1.7510.37j', 'Cu2N -3 1.7130.37l', 'Cu2N -3 1.61 0.37b',
     8 'Cu2N -3 1.7090.37l', 'Cu2N -3 1.7040.37l', 'Cu2N -3 1.7630.37l',
     9 'Cu2P -3 1.97 0.37b', 'Cu2P -3 2.05 0.37l', 'Cu2As-3 2.08 0.37b',
     * 'Cu2C -4 1.72 0.37l', 'Cu2H -1 1.21 0.37b', 'Cu3O -2 1.7350.37t',
     1 'Cu3O -2 1.7390.37e', 'Cu3F -1 1.58 0.37e', 'Cu3Cl-1 2.0780.37l',
     2 'Cu3N -3 1.7680.37l', 'Cu3N -3 1.7530.37t', 'Cu3C -4 1.84 0.37l',
     3 'Dy2O -2 1.90 0.37e', 'Dy3O -2 2.0010.37a', 'Dy3O -2 2.0050.37a',
     4 'Dy3F -1 1.9220.37b', 'Dy3F -1 1.89 0.40p', 'Dy3Cl-1 2.41 0.37b',
     5 'Dy3Cl-1 2.38 0.40p', 'Dy3Br-1 2.53 0.40p', 'Dy3I -1 2.76 0.40p',
     6 'Dy9Br-1 2.56 0.37b', 'Dy9I -1 2.77 0.37b', 'Dy9S -2 2.47 0.37b',
     7 'Dy9Se-2 2.61 0.37b', 'Dy9Te-2 2.80 0.37b', 'Dy9N -3 2.18 0.37b',
     8 'Dy9P -3 2.57 0.37b', 'Dy9As-3 2.64 0.37b', 'Dy9H -1 1.89 0.37b',
     9 'Er2O -2 1.88 0.37e', 'Er2S -2 2.52 0.37e', 'Er3O -2 1.9880.37a'/
     * )
      VALENCE(418:520) = (/
     * 'Er3O -2 2.0100.37b', 'Er3O -2 1.9790.37a', 'Er3S -2 2.52 0.37e',
     1 'Er3Se-2 2.58 0.37e', 'Er3F -1 1.9040.37a', 'Er3F -1 1.87 0.40p',
     2 'Er3Cl-1 2.39 0.37b', 'Er3Cl-1 2.36 0.40p', 'Er3Br-1 2.51 0.40p',
     3 'Er3I -1 2.75 0.40p', 'Er9Br-1 2.54 0.37b', 'Er9I -1 2.75 0.37b',
     4 'Er9S -2 2.46 0.37b', 'Er9Se-2 2.59 0.37b', 'Er9Te-2 2.78 0.37b',
     5 'Er9N -3 2.16 0.37b', 'Er9P -3 2.55 0.37b', 'Er9As-3 2.63 0.37b',
     6 'Er9H -1 1.86 0.37b', 'Es3O -2 2.08 0.35p', 'Eu2O -2 2.13 0.37e',
     7 'Eu2S -2 2.5840.37a', 'Eu2F -1 2.04 0.37b', 'Eu2Cl-1 2.53 0.37b',
     8 'Eu2Br-1 2.67 0.37e', 'Eu2I -1 2.90 0.37e', 'Eu2N -3 2.34 0.37e',
     9 'Eu3O -2 2.0740.37a', 'Eu3O -2 2.0380.37a', 'Eu3S -2 2.58 0.35e',
     * 'Eu3F -1 1.9610.37b', 'Eu3F -1 1.93 0.40p', 'Eu3Cl-1 2.48 0.37e',
     1 'Eu3Cl-1 2.42 0.40p', 'Eu3Br-1 2.57 0.40p', 'Eu3I -1 2.79 0.40p',
     2 'Eu9Br-1 2.61 0.37b', 'Eu9I -1 2.83 0.37b', 'Eu9S -2 2.53 0.37b',
     3 'Eu9Se-2 2.66 0.37b', 'Eu9Te-2 2.85 0.37b', 'Eu9N -3 2.24 0.37b',
     4 'Eu9P -3 2.62 0.37b', 'Eu9As-3 2.70 0.37b', 'Eu9H -1 1.95 0.37b',
     5 'Fe2C -4 1.47 0.37*',
     5 'Fe2O -2 1.7340.37a', 'Fe2O -2 1.7130.37h', 'Fe2O -2 1.7000.37j',
     6 'Fe2S -2 2.12 0.37e', 'Fe2S -2 2.1250.37j', 'Fe2F -1 1.65 0.37b',
     7 'Fe2Cl-1 2.06 0.37b', 'Fe2Cl-1 2.15 0.37e', 'Fe2Br-1 2.21 0.35e',
     8 'Fe2I -1 2.47 0.35e', 'Fe2N -3 1.7690.37j', 'Fe3O -2 1.7590.37a',
     9 'Fe3O -2 1.7510.37h', 'Fe3O -2 1.7650.37j', 'Fe3S -2 2.1490.37a',
     * 'Fe3S -2 2.1340.37j', 'Fe3F -1 1.6790.37a', 'Fe3Cl-1 2.09 0.37b',
     1 'Fe3Cl-1 2.15 0.37e', 'Fe3N -3 1.8150.37j', 'Fe3C  2 1.6890.37a',
     2 'Fe4S -2 2.23 0.35e', 'Fe6O -2 1.76 0.35e', 'Fe9O -2 1.74 0.38o',
     3 'Fe9Br-1 2.26 0.37b', 'Fe9I -1 2.47 0.37b', 'Fe9S -2 2.16 0.37b',
     4 'Fe9Se-2 2.28 0.37b', 'Fe9Te-2 2.53 0.37b', 'Fe9N -3 1.86 0.37b',
     5 'Fe9P -3 2.27 0.37b', 'Fe9As-3 2.35 0.37b', 'Fe9H -1 1.53 0.37b',
     6 'Ga1Se-1 2.55 0.37e', 'Ga3O -2 1.7300.37a', 'Ga3S -2 2.1630.37a',
     7 'Ga3F -1 1.62 0.37b', 'Ga3F -1 1.69 0.37e', 'Ga3Cl-1 2.07 0.37b',
     8 'Ga3Br-1 2.20 0.35e', 'Ga3I -1 2.46 0.37e', 'Ga9Br-1 2.24 0.37b',
     9 'Ga9I -1 2.45 0.37b', 'Ga9S -2 2.17 0.37b', 'Ga9Se-2 2.30 0.37b',
     * 'Ga9Te-2 2.54 0.37b', 'Ga9N -3 1.84 0.37b', 'Ga9P -3 2.26 0.37b',
     1 'Ga9As-3 2.34 0.37b', 'Ga9H -1 1.51 0.37b', 'Gd2O -2 2.01 0.37e',
     2 'Gd2F -1 2.40 0.37e', 'Gd3O -2 2.0650.37b', 'Gd3O -2 2.0310.37a',
     3 'Gd3S -2 2.53 0.37e', 'Gd3F -1 1.95 0.37b', 'Gd3F -1 1.92 0.40p'/
     4 )
      VALENCE(521:625) = (/
     4 'Gd3Cl-1 2.4450.37b', 'Gd3Cl-1 2.41 0.40p', 'Gd3Cl-1 2.47 0.37e',
     5 'Gd3Br-1 2.56 0.40p', 'Gd3I -1 2.78 0.40p', 'Gd9Br-1 2.60 0.37b',
     6 'Gd9I -1 2.82 0.37b', 'Gd9S -2 2.53 0.37b', 'Gd9Se-2 2.65 0.37b',
     7 'Gd9Te-2 2.84 0.37b', 'Gd9N -3 2.22 0.37b', 'Gd9N -3 2.10 0.37e',
     8 'Gd9P -3 2.61 0.37b', 'Gd9As-3 2.68 0.37b', 'Gd9H -1 1.93 0.37b',
     9 'Ge4O -2 1.7480.37a', 'Ge4S -2 2.2170.37a', 'Ge4Se-2 2.35 0.37e',
     * 'Ge4F -1 1.66 0.37b', 'Ge4Cl-1 2.14 0.37b', 'Ge9Br-1 2.30 0.37b',
     1 'Ge9I -1 2.50 0.37b', 'Ge9S -2 2.23 0.37b', 'Ge9Se-2 2.35 0.37b',
     2 'Ge9Te-2 2.56 0.37b', 'Ge9N -3 1.88 0.37b', 'Ge9P -3 2.32 0.37b',
     3 'Ge9As-3 2.43 0.37b', 'Ge9H -1 1.55 0.37b', 'H 1O -2 0.5690.94e',
     4 'H 1O -2 0.9070.28e', 'H 1O -2 0.9900.59e', 'Hf3F -1 2.62 0.37e',
     5 'Hf4O -2 1.9230.37b', 'Hf4F -1 1.85 0.37b', 'Hf4F -1 1.82 0.40p',
     6 'Hf4Cl-1 2.24 0.37e', 'Hf4Cl-1 2.30 0.37b', 'Hf9Br-1 2.47 0.37b',
     7 'Hf9S -2 2.39 0.37b', 'Hf9Se-2 2.52 0.37b', 'Hf9Te-2 2.72 0.37b',
     8 'Hf9I -1 2.68 0.37b', 'Hf9N -3 2.09 0.37b', 'Hf9P -3 2.48 0.37b',
     9 'Hf9As-3 2.56 0.37b', 'Hf9H -1 1.78 0.37b', 'Hg1O -2 1.90 0.37b',
     * 'Hg1F -1 1.81 0.37b', 'Hg1Cl-1 2.28 0.37b', 'Hg2O -2 1.9720.37a',
     1 'Hg2O -2 1.93 0.37b', 'Hg2S -2 2.3080.37a', 'Hg2F -1 2.17 0.37e',
     2 'Hg2F -1 1.90 0.37b', 'Hg2Cl-1 2.28 0.37e', 'Hg2Cl-1 2.25 0.37b',
     3 'Hg2Br-1 2.38 0.37e', 'Hg2I -1 2.62 0.37e', 'Hg9Br-1 2.40 0.37b',
     4 'Hg9I -1 2.59 0.37b', 'Hg9S -2 2.32 0.37b', 'Hg9Se-2 2.47 0.37b',
     5 'Hg9Te-2 2.61 0.37b', 'Hg9N -3 2.02 0.37b', 'Hg9P -3 2.42 0.37b',
     6 'Hg9As-3 2.50 0.37b', 'Hg9H -1 1.71 0.37b', 'Hg2Hg 2 2.51 0.35f',
     7 'Ho3O -2 2.0250.37a', 'Ho3O -2 1.9920.37a', 'Ho3S -2 2.49 0.37e',
     8 'Ho3F -1 1.9080.37b', 'Ho3F -1 1.88 0.40p', 'Ho3Cl-1 2.4010.37b',
     9 'Ho3Cl-1 2.37 0.40p', 'Ho3Br-1 2.52 0.40p', 'Ho3I -1 2.76 0.40p',
     * 'Ho9Br-1 2.55 0.37b', 'Ho9I -1 2.77 0.37b', 'Ho9S -2 2.48 0.37b',
     1 'Ho9Se-2 2.61 0.37b', 'Ho9Te-2 2.80 0.37b', 'Ho9N -3 2.18 0.37b',
     2 'Ho9P -3 2.56 0.37b', 'Ho9As-3 2.64 0.37b', 'Ho9H -1 1.88 0.37b',
     3 'I 0I  0 2.1950.35e', 'I 1F -1 2.32 0.37e', 'I 1Cl-1 2.47 0.37e',
     4 'I 3O -2 2.02 0.37e', 'I 3F -1 1.90 0.37b', 'I 3Cl-1 2.39 0.37e',
     5 'I 5O -2 2.0030.37a', 'I 5F -1 1.84 0.37e', 'I 5F -1 1.90 0.37b',
     6 'I 5Cl-1 2.38 0.37b', 'I 7O -2 1.93 0.37b', 'I 7F -1 1.83 0.37b',
     7 'I 7Cl-1 2.31 0.37b', 'In1Cl-1 2.56 0.37e', 'In3O -2 1.9020.37a',
     8 'In3S -2 2.3700.37a', 'In3F -1 1.7920.37a', 'In3Cl-1 2.28 0.37b'/
     9 )
      VALENCE(626:730) = (/
     9 'In3Br-1 2.51 0.35e', 'In3I -1 2.63 0.37e', 'In3Co-1 2.5930.35e',
     * 'In3Mn-2 2.6040.35e', 'In9Br-1 2.41 0.37b', 'In9I -1 2.63 0.37b',
     1 'In9S -2 2.36 0.37b', 'In9Se-2 2.47 0.37b', 'In9Te-2 2.69 0.37b',
     2 'In9N -3 2.03 0.37b', 'In9P -3 2.43 0.37b', 'In9As-3 2.51 0.37b',
     3 'In9H -1 1.72 0.37b', 'Ir4O -2 1.87 0.37e', 'Ir4F -1 1.80 0.37e',
     4 'Ir5O -2 1.9160.37b', 'Ir5O -2 2.01 0.37e', 'Ir5F -1 1.82 0.37b',
     5 'Ir5Cl-1 2.30 0.37b', 'Ir9S -2 2.38 0.37b', 'Ir9Se-2 2.51 0.37b',
     6 'Ir9Te-2 2.71 0.37b', 'Ir9Br-1 2.45 0.37b', 'Ir9I -1 2.66 0.37b',
     7 'Ir9N -3 2.06 0.37b', 'Ir9P -3 2.46 0.37b', 'Ir9As-3 2.54 0.37b',
     8 'Ir9H -1 1.76 0.37b', 'K 1O -2 2.1320.37a', 'K 1O -2 2.1130.37u',
     9 'K 1O -2 1.9540.43c', 'K 1O -2 1.84 0.48o', 'K 1S -2 2.59 0.37b',
     * 'K 1S -2 2.1510.58c', 'K 1S -2 2.63 0.37e', 'K 1Se-2 2.72 0.37b',
     1 'K 1Se-2 2.2810.61c', 'K 1Te-2 2.93 0.37b', 'K 1Te-2 2.4100.65c',
     2 'K 1F -1 1.9920.37a', 'K 1F -1 1.8300.42c', 'K 1Cl-1 2.5190.37a',
     3 'K 1Cl-1 2.0700.55c', 'K 1Br-1 2.66 0.37b', 'K 1Br-1 2.1520.60c',
     4 'K 1I -1 2.88 0.37b', 'K 1I -1 2.2820.65c', 'K 1I -1 2.92 0.37e',
     5 'K 1N -3 2.26 0.37b', 'K 1N -3 2.30 0.37e', 'K 1P -3 2.64 0.37b',
     6 'K 1As-3 2.83 0.37b', 'K 1H -1 2.10 0.37b', 'Kr2F -1 1.89 0.37e',
     7 'La3O -2 2.1720.37a', 'La3O -2 2.1720.33a', 'La3O -2 2.1480.37a',
     8 'La3S -2 2.6430.37a', 'La3Se-2 2.74 0.37b', 'La3Te-2 2.94 0.37b',
     9 'La3F -1 2.02 0.40p', 'La3F -1 2.08 0.37e', 'La3Cl-1 2.5450.37b',
     * 'La3Cl-1 2.57 0.37e', 'La3Cl-1 2.58 0.40p', 'La3Br-1 2.72 0.37b',
     1 'La3Br-1 2.66 0.40p', 'La3I -1 2.93 0.37b', 'La3I -1 2.88 0.40p',
     2 'La3N -3 2.34 0.37b', 'La3P -3 2.73 0.37b', 'La3As-3 2.80 0.37b',
     3 'La3H -1 2.06 0.37b', 'Li1O -2 1.4660.37a', 'Li1O -2 1.1740.51c',
     4 'Li1O -2 1.29 0.48o', 'Li1S -2 1.94 0.37b', 'Li1S -2 1.4600.65c',
     5 'Li1Se-2 2.09 0.37b', 'Li1Se-2 1.6270.68c', 'Li1Te-2 2.30 0.37b',
     6 'Li1Te-2 1.7340.71c', 'Li1F -1 1.3600.37a', 'Li1F -1 1.0960.50c',
     7 'Li1Cl-1 1.91 0.37b', 'Li1Cl-1 1.3870.64c', 'Li1Cl-1 1.94 0.37e',
     8 'Li1Br-1 2.02 0.37b', 'Li1Br-1 1.5150.67c', 'Li1I -1 2.22 0.37b',
     9 'Li1I -1 1.6750.72c', 'Li1N -3 1.61 0.37b', 'Lu3O -2 1.9710.37b',
     * 'Lu3O -2 1.9470.37a', 'Lu3S -2 2.43 0.37b', 'Lu3Se-2 2.56 0.37b',
     1 'Lu3Te-2 2.75 0.37b', 'Lu3F -1 1.8760.37b', 'Lu3F -1 1.84 0.40p',
     2 'Lu3Cl-1 2.3610.37b', 'Lu3Cl-1 2.33 0.40p', 'Lu3Br-1 2.50 0.37b',
     3 'Lu3Br-1 2.48 0.40p', 'Lu3I -1 2.73 0.37b', 'Lu3I -1 2.73 0.40p'/
     4 )
      VALENCE(731:836) = (/
     4 'Lu3N -3 2.11 0.37b', 'Lu3P -3 2.51 0.37b', 'Lu3As-3 2.59 0.37b',
     5 'Lu3H -1 1.82 0.37b', 'Mg2O -2 1.6930.37a', 'Mg2O -2 1.6360.42o',
     6 'Mg2S -2 2.18 0.37b', 'Mg2Se-2 2.32 0.37b', 'Mg2Te-2 2.53 0.37b',
     7 'Mg2F -1 1.5780.37a', 'Mg2Cl-1 2.08 0.37b', 'Mg2Br-1 2.28 0.37b',
     8 'Mg2I -1 2.46 0.37b', 'Mg2N -3 1.85 0.37b', 'Mg2P -3 2.29 0.37b',
     9 'Mg2As-3 2.38 0.37b', 'Mg2H -1 1.53 0.37b', 'Mn1C -4 1.2370.37*',
     * 'Mn1P -3 1.6230.37*', 'Mn1N -3 1.2750.37*', 'Mn1O -2 1.3000.37*',
     * 'Mn2O -2 1.7900.37a', 'Mn2S -2 2.22 0.37e', 'Mn2F -1 1.6980.37a',
     1 'Mn2Cl-1 2.1330.37a', 'Mn2Br-1 2.34 0.37e', 'Mn2I -2 2.52 0.37e',
     2 'Mn2N -3 1.8490.37j', 'Mn2N -3 1.65 0.35e', 'Mn3O -2 1.7600.37a',
     3 'Mn3O -2 1.7320.37j', 'Mn3F -1 1.66 0.37b', 'Mn3Cl-1 2.14 0.37b',
     4 'Mn3N -3 1.8370.37j', 'Mn4O -2 1.7530.37a', 'Mn4O -2 1.7500.37j',
     5 'Mn4F -1 1.71 0.37b', 'Mn4F -1 1.63 0.37e', 'Mn4Cl-1 2.13 0.37b',
     6 'Mn4N -3 1.8220.37j', 'Mn6O -2 1.79 0.37e', 'Mn7O -2 1.8270.37e',
     7 'Mn7O -2 1.79 0.37b', 'Mn7F -1 1.72 0.37b', 'Mn7Cl-1 2.17 0.37b',
     8 'Mn9O -2 1.7540.37g', 'Mn9Br-1 2.26 0.37b', 'Mn9I -1 2.49 0.37b',
     9 'Mn9S -2 2.20 0.37b', 'Mn9Se-1 2.32 0.37b', 'Mn9Te-2 2.55 0.37b',
     * 'Mn9N -3 1.87 0.37b', 'Mn9P -3 2.24 0.37b', 'Mn9As-3 2.36 0.37b',
     1 'Mn9H -1 1.55 0.37b', 'Mo3O -2 1.8340.37m', 'Mo3F -1 1.76 0.35e',
     2 'Mo3Cl-1 2.22 0.37e', 'Mo3Br-1 2.34 0.37e', 'Mo3N -3 1.96 0.37e',
     3 'Mo4O -2 1.8860.37j', 'Mo4O -2 1,8560.37m', 'Mo4S -2 2.2350.37j',
     4 'Mo4F -1 1.80 0.37e', 'Mo4Cl-1 2.17 0.37e', 'Mo4N -3 2.0430.37j',
     5 'Mo5O -2 1.9070.37j', 'Mo5O -2 1.8780.37m', 'Mo5S -2 2.2880.37j',
     6 'Mo5F -1 1.77 0.37*',
     6 'Mo5Cl-1 2.26 0.37e', 'Mo5N -3 2.0090.37j', 'Mo6O -2 1.9070.37a',
     7 'Mo6O -2 1.9150.41x', 'Mo6O -2 1.87 0.26n', 'Mo6O -2 1.9000.37m',
     8 'Mo6S -2 2.3310.37j', 'Mo6F -1 1.81 0.37b', 'Mo6Cl-1 2.28 0.37b',
     9 'Mo6N -3 2.0090.37j', 'Mo9O -2 1.8790.30z', 'Mo9Br-1 2.43 0.37b',
     * 'Mo9I -1 2.64 0.37b', 'Mo9S -2 2.35 0.37b', 'Mo9Se-2 2.49 0.37b',
     1 'Mo9Te-2 2.69 0.37b', 'Mo9N -3 2.04 0.37b', 'Mo9P -3 2.44 0.37b',
     2 'Mo9As-3 2.52 0.37b', 'Mo9H -1 1.73 0.37b', 'N 3O -2 1.3610.37a',
     3 'N 3S -2 1.73 0.37e', 'N 3F -1 1.37 0.37b', 'N 3Cl-1 1.75 0.37b',
     4 'N 3N -3 1.44 0.35e', 'N 5O -2 1.4320.37a', 'N 5O -2 1.41 0.43o',
     5 'N 5F -1 1.36 0.37b', 'N 5Cl-1 1.80 0.37b', 'Na1O -2 1.8030.37a',
     6 'Na1O -2 1.7560.37v', 'Na1O -2 1.5760.47c', 'Na1O -2 1.6610.44o',
     7 'Na1S -2 2.3000.37a', 'Na1S -2 2.28 0.37b', 'Na1S -2 1.8210.62c'/
     8 )
      VALENCE(837:941) = (/
     8 'Na1Se-2 2.41 0.37b', 'Na1Se-2 1.8900.65c', 'Na1Te-2 2.64 0.37b',
     9 'Na1Te-2 2.0400.69c', 'Na1F -1 1.6770.37a', 'Na1F -1 1.4480.46c',
     * 'Na1Cl-1 2.15 0.37b', 'Na1Cl-1 1.6830.60c', 'Na1Cl-1 2.22 0.37e',
     1 'Na1Br-1 2.33 0.37b', 'Na1Br-1 1.7710.64c', 'Na1I -1 2.56 0.37b',
     2 'Na1I -1 1.9550.69c', 'Na1N -3 1.93 0.37b', 'Na1N -3 2.01 0.37e',
     3 'Na1P -3 2.36 0.37b', 'Na1As-3 2.53 0.37b', 'Na1H -1 1.68 0.37b',
     4 'Nb3O -2 1.91 0.35e', 'Nb3F -1 1.71 0.37e', 'Nb3Cl-1 2.20 0.37e',
     5 'Nb3Br-1 2.35 0.37e', 'Nb4O -2 1.88 0.37e', 'Nb4F -1 1.90 0.37e',
     6 'Nb4Cl-1 2.26 0.35e', 'Nb4Br-1 2.62 0.37e', 'Nb5O -2 1.9110.37a',
     7 'Nb5O -2 1.9160.37x', 'Nb5F -1 1.87 0.37b', 'Nb5Cl-1 2.27 0.37b',
     8 'Nb5I -1 2.77 0.37e', 'Nb5N -3 2.01 0.35e', 'Nb9Br-1 2.45 0.37b',
     9 'Nb9I -1 2.68 0.37b', 'Nb9S -2 2.37 0.37b', 'Nb9Se-2 2.51 0.37b',
     * 'Nb9Te-2 2.70 0.37b', 'Nb9N -3 2.06 0.37b', 'Nb9P -3 2.46 0.37b',
     1 'Nb9As-3 2.54 0.37b', 'Nb9H -1 1.75 0.37b', 'Nd2O -2 1.95 0.37e',
     2 'Nd2S -2 2.60 0.35e', 'Nd3O -2 2.1050.37a', 'Nd3O -2 2.1170.37b',
     3 'Nd3O -2 2.0860.37a', 'Nd3S -2 2.59 0.37b', 'Nd3Se-2 2.71 0.37b',
     4 'Nd3Te-2 2.89 0.37b', 'Nd3F -1 2.0080.37b', 'Nd3F -1 1.98 0.40p',
     5 'Nd3Cl-1 2.4920.37b', 'Nd3Cl-1 2.46 0.40p', 'Nd3Br-1 2.66 0.37b',
     6 'Nd3Br-1 2.61 0.40p', 'Nd3I -1 2.87 0.37b', 'Nd3I -1 2.84 0.40p',
     7 'Nd3N -3 2.30 0.37b', 'NH1O -2 2.2260.37s', 'NH1F -1 2.1290.37s',
     8 'NH1Cl-1 2.6190.37s', 'Ni2O -2 1.6540.37a', 'Ni2O -2 1.6700.37j',
     9 'Ni2S -2 1.98 0.37e', 'Ni2S -2 1.9370.37j', 'Ni2F -1 1.5960.37a',
     * 'Ni2Cl-1 2.02 0.37b', 'Ni2Br-1 2.20 0.37e', 'Ni2I -1 2.40 0.37e',
     1 'Ni2N -3 1.70 0.37e', 'Ni2N -3 1.6470.37j', 'Ni3O -2 1.75 0.37e',
     2 'Ni3S -2 2.0400.37j', 'Ni3F -1 1.58 0.37e', 'Ni3N -3 1.7310.37j',
     3 'Ni4O -2 1.78 0.35e', 'Ni4F -1 1.61 0.37e', 'Ni9Br-1 2.16 0.37b',
     4 'Ni9I -1 2.34 0.37b', 'Ni9S -2 2.04 0.37b', 'Ni9Se-2 2.14 0.37b',
     5 'Ni9Te-2 2.43 0.37b', 'Ni9N -3 1.75 0.37b', 'Ni9P -3 2.17 0.37b',
     6 'Ni9As-3 2.24 0.37b', 'Ni9H -1 1.40 0.37b', 'Np3F -1 2.00 0.40p',
     7 'Np3Cl-1 2.48 0.40p', 'Np3Br-1 2.62 0.40p', 'Np3I -1 2.85 0.40p',
     8 'Np4O -2 2.18 0.37e', 'Np4O -2 2.11 0.35p', 'Np4F -1 2.02 0.37e',
     9 'Np4F -1 1.98 0.40p', 'Np4Cl-1 2.46 0.40p', 'Np5O -2 2.09 0.35p',
     * 'Np5F -1 1.97 0.40p', 'Np5Cl-1 2.42 0.40p', 'Np6O -2 2.07 0.35p',
     1 'Np6F -1 1.97 0.40p', 'Np7O -2 2.06 0.35p', 'O 2O -2 1.5000.35e',
     2 'Os4O -2 1.8110.37b', 'Os4S -2 2.21 0.37e', 'Os4F -1 1.72 0.37b'/
     3 )
      VALENCE(942:1046) = (/
     3 'Os4Cl-1 2.19 0.37b', 'Os4Br-1 2.37 0.37e', 'Os5F -1 1.81 0.37e',
     4 'Os6O -2 2.03 0.37a', 'Os6F -1 1.80 0.35e', 'Os8O -2 1.92 0.37e',
     5 'P 3O -2 1.63 0.37e', 'P 3S -2 2.12 0.37e', 'P 3Se-2 2.24 0.37e',
     6 'P 3F -1 1.53 0.35e', 'P 4O -2 1.64 0.37e', 'P 4S -2 2.13 0.35e',
     7 'P 4F -1 1.66 0.37e', 'P 5O -2 1.6170.37a', 'P 5O -2 1.6040.37b',
     8 'P 5S -2 2.1450.37a', 'P 5F -1 1.54 0.37e', 'P 5Cl-1 2.02 0.37e',
     9 'P 5Br-1 2.17 0.40e', 'P 5N -3 1.7040.37a', 'P 9Br-1 2.15 0.37b',
     * 'P 9I -1 2.40 0.37b', 'P 9S -2 2.11 0.37b', 'P 9Se-2 2.26 0.37b',
     1 'P 9Te-2 2.44 0.37b', 'P 9N -3 1.73 0.37b', 'P 9P -3 2.19 0.37b',
     2 'P 9As-3 2.25 0.37b', 'P 9H -1 1.41 0.37b', 'P 5P  5 2.22 0.35e',
     3 'Pa4O -2 2.15 0.35p', 'Pa4F -1 2.02 0.40p', 'Pa4Cl-1 2.49 0.40p',
     4 'Pa4Br-1 2.66 0.40p', 'Pa5O -2 2.09 0.35e', 'Pa5O -2 2.11 0.35p',
     5 'Pa5F -1 2.04 0.37e', 'Pa5F -1 2.01 0.40p', 'Pa5Cl-1 2.45 0.40p',
     6 'Pa5Br-1 2.58 0.40p', 'Pb2O -2 1.9630.49q', 'Pb2O -2 2.1120.37a',
     7 'Pb2S -2 2.5410.37a', 'Pb2Se-2 2.69 0.37e', 'Pb2F -1 2.03 0.37b',
     8 'Pb2Cl-1 2.53 0.37b', 'Pb2Br-1 2.68 0.37e', 'Pb2I -1 2.83 0.37e',
     9 'Pb2N -3 2.18 0.40e', 'Pb4O -2 2.0420.37a', 'Pb4F -1 1.94 0.37b',
     * 'Pb4Cl-1 2.43 0.37b', 'Pb4Cl-1 2.36 0.37e', 'Pb4Br-1 3.04 0.35e',
     1 'Pb9Br-1 2.64 0.37b', 'Pb9I -1 2.78 0.37b', 'Pb9S -2 2.55 0.37b',
     2 'Pb9Se-2 2.67 0.37b', 'Pb9Te-2 2.84 0.37b', 'Pb9N -3 2.22 0.37b',
     3 'Pb9P -3 2.64 0.37b', 'Pb9As-3 2.72 0.37b', 'Pb9H -1 1.97 0.37b',
     4 'Pd2O -2 1.7920.37b', 'Pd2S -2 2.09 0.37e', 'Pd2F -1 1.74 0.37b',
     5 'Pd2Cl-1 2.05 0.37b', 'Pd2Br-1 2.20 0.37e', 'Pd2I -1 2.36 0.37e',
     6 'Pd2N -3 1.82 0.35e', 'Pd2C -4 1.73 0.37e', 'Pd4S -2 2.30 0.37e',
     7 'Pd4F -1 1.66 0.37e', 'Pd9Br-1 2.19 0.37b', 'Pd9I -1 2.38 0.37b',
     8 'Pd9S -2 2.10 0.37b', 'Pd9Se-2 2.22 0.37b', 'Pd9Te-2 2.48 0.37b',
     9 'Pd9N -3 1.81 0.37b', 'Pd9P -3 2.22 0.37b', 'Pd9As-3 2.30 0.37b',
     * 'Pd9H -1 1.47 0.37b', 'Pm3F -1 1.96 0.40p', 'Pm3Cl-1 2.45 0.40p',
     1 'Pm3Br-1 2.59 0.40p', 'Pm3Cl-1 2.82 0.40p', 'Po4O -2 2.19 0.37e',
     2 'Po4F -1 2.38 0.37e', 'Pr3O -2 2.1380.37a', 'Pr3O -2 2.0980.37a',
     3 'Pr3S -2 2.60 0.37b', 'Pr3Se-1 2.72 0.37b', 'Pr3Te-2 2.90 0.37b',
     4 'Pr3F -1 2.0220.37b', 'Pr3F -1 1.99 0.40p', 'Pr3Cl-1 2.50 0.37b',
     5 'Pr3Cl-1 2.47 0.40p', 'Pr3Br-1 2.67 0.37b', 'Pr3Br-1 2.63 0.40p',
     6 'Pr3I -1 2.89 0.37b', 'Pr3I -1 2.85 0.40p', 'Pr3N -3 2.30 0.37b',
     7 'Pr3P -3 2.68 0.37b', 'Pr3As-3 2.75 0.37b', 'Pr3H -1 2.02 0.37b'/
     8 )
      VALENCE(1047:1151) = (/
     8 'Pt2O -2 1.7680.37b', 'Pt2O -2 1.80 0.37e', 'Pt2S -2 2.16 0.37e',
     9 'Pt2F -1 1.68 0.37b', 'Pt2Cl-1 2.05 0.37b', 'Pt2Br-1 2.20 0.37e',
     * 'Pt2C  2 1.7600.37a', 'Pt2N -3 1.81 0.37e', 'Pt3O -2 1.87 0.37e',
     1 'Pt3Cl-1 2.30 0.37e', 'Pt3Br-1 2.47 0.35e', 'Pt4O -2 1.8790.37a',
     2 'Pt4F -1 1.7590.37b', 'Pt4F -1 2.19 0.37e', 'Pt4Cl-1 2.17 0.37b',
     3 'Pt4Cl-1 2.32 0.37e', 'Pt4Br-1 2.6  0.35e', 'Pt9Br-1 2.18 0.37b',
     4 'Pt9I -1 2.37 0.37b', 'Pt9S -2 2.08 0.37b', 'Pt9Se-2 2.19 0.37b',
     5 'Pt9Te-2 2.45 0.37b', 'Pt9N -3 1.77 0.37b', 'Pt9P -3 2.19 0.37b',
     6 'Pt9As-3 2.26 0.37b', 'Pt9H -1 1.40 0.37b', 'Pu3O -2 2.11 0.37b',
     7 'Pu3O -2 2.14 0.35p', 'Pu3F -1 2.00 0.37b', 'Pu3F -1 1.99 0.40p',
     8 'Pu3Cl-1 2.48 0.37b', 'Pu3Cl-1 2.46 0.40p', 'Pu3Br-1 2.60 0.40p',
     9 'Pu3I -1 2.84 0.40p', 'Pu4O -2 2.09 0.35p', 'Pu4F -1 1.97 0.40p',
     * 'Pu4Cl-1 2.44 0.40p', 'Pu5O -2 2.11 0.37e', 'Pu5O -2 2.08 0.35p',
     1 'Pu5F -1 1.96 0.40p', 'Pu6O -2 2.06 0.35p', 'Pu6F -1 1.96 0.40p',
     2 'Pu7O -2 2.05 0.35p', 'Rb1O -2 2.2630.37a', 'Rb1O -2 2.0810.41c',
     3 'Rb1S -2 2.70 0.37b', 'Rb1S -2 2.2990.55c', 'Rb1S -2 2.80 0.37e',
     4 'Rb1Se-2 2.81 0.37b', 'Rb1Se-2 2.3880.58c', 'Rb1Te-2 3.00 0.37b',
     5 'Rb1Te-2 2.4170.63c', 'Rb1F -1 2.16 0.37b', 'Rb1F -1 1.9710.41c',
     6 'Rb1F -1 2.20 0.37e', 'Rb1Cl-1 2.6520.37a', 'Rb1Cl-1 2.2650.53c',
     7 'Rb1Br-1 2.78 0.37b', 'Rb1Br-1 2.3290.57c', 'Rb1Br-1 2.86 0.37e',
     8 'Rb1I -1 3.01 0.37b', 'Rb1I -1 2.4500.63c', 'Rb1I -1 3.12 0.37e',
     9 'Rb1N -3 2.62 0.37e', 'Rb1N -3 2.37 0.37b', 'Rb1P -3 2.76 0.37b',
     * 'Rb1As-3 2.87 0.37b', 'Rb1H -1 2.26 0.37b', 'Re1Cl-1 2.62 0.35e',
     1 'Re3O -2 1.9  0.35e', 'Re3Cl-1 2.23 0.37e', 'Re4F -1 1.81 0.37e',
     2 'Re4Cl-1 2.23 0.37e', 'Re4Br-1 2.35 0.37e', 'Re5O -2 1.86 0.37e',
     3 'Re5Cl-1 2.24 0.37e', 'Re6F -1 1.79 0.37e', 'Re7O -2 1.97 0.37e',
     4 'Re7F -1 1.86 0.37b', 'Re7Cl-1 2.23 0.37b', 'Re9Br-1 2.45 0.37b',
     5 'Re9I -1 2.61 0.37b', 'Re9S -2 2.37 0.37b', 'Re9Se-2 2.50 0.37b',
     6 'Re9Te-2 2.70 0.37b', 'Re9N -3 2.06 0.37b', 'Re9P -3 2.46 0.37b',
     7 'Re9As-3 2.54 0.37b', 'Re9H -1 1.75 0.37b', 'Rh3O -2 1.7930.37b',
     8 'Rh3F -1 1.71 0.37b', 'Rh3Cl-1 2.08 0.37e', 'Rh3Cl-1 2.17 0.37b',
     9 'Rh3Br-1 2.27 0.35e', 'Rh3N -3 1.82 0.35e', 'Rh4F -1 1.59 0.37e',
     * 'Rh5F -1 1.80 0.37e', 'Rh9Br-1 2.25 0.37b', 'Rh9I -1 2.48 0.37b',
     1 'Rh9S -2 2.15 0.37b', 'Rh9Se-1 2.33 0.37b', 'Rh9Te-2 2.55 0.37b',
     2 'Rh9N -3 1.88 0.37b', 'Rh9P -3 2.29 0.37b', 'Rh9As-3 2.37 0.37b'/
     3 )
      VALENCE(1152:1256) = (/
     3 'Rh9H -1 1.55 0.37b', 'Ru2Se-2 2.11 0.35e', 'Ru2F -1 1.84 0.35e',
     4 'Ru3O -2 1.77 0.37o', 'Ru3S -2 2.20 0.35e', 'Ru3F -1 2.12 0.37e',
     5 'Ru3Cl-1 2.25 0.37e', 'Ru3N -3 1.82 0.35e', 'Ru4O -2 1.8340.37b',
     6 'Ru4S -2 2.21 0.37e', 'Ru4F -1 1.74 0.37b', 'Ru4Cl-1 2.21 0.37b',
     7 'Ru5O -2 1.90 0.37o', 'Ru5F -1 1.82 0.37e', 'Ru5Cl-1 2.23 0.35e',
     8 'Ru6O -2 1.87 0.35e', 'Ru7O -2 1.99 0.37e', 'Ru9Br-1 2.26 0.37b',
     9 'Ru9I -1 2.48 0.37b', 'Ru9S -2 2.16 0.37b', 'Ru9Se-2 2.33 0.37b',
     * 'Ru9Te-2 2.54 0.37b', 'Ru9N -3 1.88 0.37b', 'Ru9P -3 2.29 0.37b',
     1 'Ru9As-3 2.36 0.37b', 'Ru9H -1 1.61 0.37b', 'S 2O -2 1.74 0.37e',
     2 'S 2S -2 2.03 0.37e', 'S 2N -2 1.5970.37a', 'S 2N -3 1.6820.37a',
     3 'S 2S  2 2.10 0.35e', 'S 4O -2 1.6440.37a', 'S 4F -1 1.60 0.37b',
     4 'S 4Cl-1 2.02 0.37b', 'S 4N -3 1.7620.37a', 'S 6O -2 1.6240.37a',
     5 'S 6F -1 1.56 0.37b', 'S 6Cl-1 2.03 0.37b', 'S 6N -3 1.72 0.37e',
     6 'S 9Br-1 2.17 0.37b', 'S 9I -1 2.36 0.37b', 'S 9S -2 2.07 0.37b',
     7 'S 9Se-2 2.21 0.37b', 'S 9Te-2 2.45 0.37b', 'S 9N -3 1.74 0.37b',
     8 'S 9P -3 2.15 0.37b', 'S 9As-3 2.25 0.37b', 'S 9H -1 1.38 0.37b',
     9 'Sb3O -2 1.9730.37a', 'Sb3S -2 2.4740.37a', 'Sb3Se-2 2.60 0.37e',
     * 'Sb3F -1 1.8830.37a', 'Sb3F -1 1.90 0.37b', 'Sb3Cl-1 2.35 0.37b',
     1 'Sb3Br-1 2.51 0.37e', 'Sb3I -1 2.76 0.37e', 'Sb3N -3 2.1080.37d',
     2 'Sb5O -2 1.9420.37a', 'Sb5F -1 1.7970.37a', 'Sb5Cl-1 2.30 0.37b',
     3 'Sb5Br-1 2.48 0.37e', 'Sb5N -3 1.99 0.35e', 'Sb9S -2 2.45 0.37b',
     4 'Sb9Se-2 2.57 0.37b', 'Sb9Te-2 2.78 0.37b', 'Sb9Br-1 2.50 0.37b',
     5 'Sb9I -1 2.72 0.37b', 'Sb9N -3 2.12 0.37b', 'Sb9P -3 2.52 0.37b',
     6 'Sb9As-3 2.60 0.37b', 'Sb9H -1 2.77 0.37b', 'Sc3O -2 1.8490.37a',
     7 'Sc3O -2 1.8770.35o', 'Sc3S -2 2.3210.37a', 'Sc3Se-2 2.44 0.37b',
     8 'Sc3Te-2 2.64 0.37b', 'Sc3F -1 1.76 0.37b', 'Sc3Cl-1 2.36 0.37e',
     9 'Sc3Cl-1 2.23 0.37b', 'Sc3Br-1 2.38 0.37b', 'Sc3I -1 2.59 0.37b',
     * 'Sc3N -3 1.98 0.37b', 'Sc3P -3 2.40 0.37b', 'Sc3As-3 2.48 0.37b',
     1 'Sc3H -1 1.68 0.37b', 'Se2S -2 2.21 0.37e', 'Se2Se-2 2.33 0.37e',
     2 'Se4O -2 1.8110.37a', 'Se4F -1 1.73 0.37b', 'Se4Cl-1 2.22 0.37b',
     3 'Se4Br-1 2.43 0.37e', 'Se6O -2 1.7880.37a', 'Se6F -1 1.69 0.37b',
     4 'Se6Cl-1 2.16 0.37b', 'Se6N -3 1.90 0.35e', 'Se9Br-1 2.33 0.37b',
     5 'Se9I -1 2.54 0.37b', 'Se9S -2 2.25 0.37b', 'Se9Se-2 2.36 0.37b',
     6 'Se9Te-2 2.55 0.37b', 'Se9P -3 2.34 0.37b', 'Se9As-3 2.42 0.37b',
     7 'Se9H -1 1.54 0.37b', 'Si4O -2 1.6240.37b', 'Si4O -2 1.6400.37a'/
     8 )
      VALENCE(1257:1361) = (/
     8 'Si4S -2 2.1260.37a', 'Si4Se-2 2.26 0.37b', 'Si4Te-2 2.49 0.37b',
     9 'Si4F -1 1.58 0.37b', 'Si4Cl-1 2.03 0.37b', 'Si4Br-1 2.20 0.37b',
     * 'Si4I -1 2.41 0.37b', 'Si4C -4 1.8830.37a', 'Si4N -3 1.7240.37a',
     1 'Si4N -3 1.77 0.37b', 'Si4P -3 2.23 0.37b', 'Si4As-3 2.31 0.37b',
     2 'Si4H -1 1.47 0.37b', 'Sm3O -2 2.0880.37b', 'Sm3O -2 2.0630.37a',
     3 'Sm3S -2 2.55 0.37b', 'Sm3Se-2 2.67 0.37b', 'Sm3Te-2 2.86 0.37b',
     4 'Sm3F -1 1.94 0.40p', 'Sm3F -1 2.00 0.37e', 'Sm3Cl-1 1.9770.37b',
     5 'Sm3Cl-1 2.43 0.40p', 'Sm3Br-1 2.66 0.37b', 'Sm3Br-1 2.58 0.40p',
     6 'Sm3I -1 2.84 0.37b', 'Sm3I -1 2.80 0.40p', 'Sm3N -3 2.24 0.37b',
     7 'Sm3P -3 2.63 0.37b', 'Sm3As-3 2.70 0.37b', 'Sm3H -1 1.96 0.37b',
     8 'Sn2O -2 1.94 0.37b', 'Sn2S -2 2.44 0.37e', 'Sn2F -1 1.9250.37a',
     9 'Sn2Cl-1 2.41 0.37e', 'Sn3Cl-1 2.36 0.37b', 'Sn2Br-1 2.53 0.35d',
     * 'Sn2I -1 2.81 0.37e', 'Sn2N -3 2.03 0.35e', 'Sn4O -2 1.9050.37a',
     1 'Sn4S -2 2.3990.37a', 'Sn4Se-2 2.51 0.37e', 'Sn4F -1 1.8430.37a',
     2 'Sn4Cl-1 2.2760.37a', 'Sn4Br-1 2.40 0.37e', 'Sn4N -3 2.03 0.35e',
     3 'Sn9Br-1 2.55 0.37b', 'Sn9I -1 2.76 0.37b', 'Sn9S -2 2.39 0.37a',
     4 'Sn9S -2 2.45 0.37b', 'Sn9Se-2 2.59 0.37b', 'Sn9Te-2 2.76 0.37b',
     5 'Sn9N -3 2.06 0.37a', 'Sn9N -3 2.14 0.37b', 'Sn9P -3 2.45 0.37b',
     6 'Sn9As-3 2.62 0.37b', 'Sn9H -1 1.85 0.37b', 'Sr2O -2 2.1180.37a',
     7 'Sr2S -2 2.59 0.37b', 'Sr2S -2 2.65 0.37e', 'Sr2Se-2 2.72 0.37b',
     8 'Sr2Te-2 2.87 0.37b', 'Sr2Te-2 2.06 0.37e', 'Sr2F -1 2.0190.37b',
     9 'Sr2Cl-1 2.51 0.37b', 'Sr2Br-1 2.68 0.37b', 'Sr2I -1 2.88 0.37b',
     * 'Sr2N -3 2.23 0.37b', 'Sr2P -3 2.67 0.37b', 'Sr2As-3 2.76 0.37b',
     1 'Sr2H -1 2.01 0.37b', 'Ta4O -2 2.29 0.37e', 'Ta5O -2 1.9200.37a',
     2 'Ta5S -2 2.47 0.37e', 'Ta5F -1 1.88 0.37b', 'Ta5Cl-1 2.30 0.37b',
     3 'Ta9Br-1 2.45 0.37b', 'Ta9I -1 2.66 0.37b', 'Ta9S -2 2.39 0.37b',
     4 'Ta9Se-2 2.51 0.37b', 'Ta9Te-2 2.70 0.37b', 'Ta9N -3 2.01 0.37b',
     5 'Ta9P -3 2.47 0.37b', 'Ta9As-3 2.55 0.37b', 'Ta9H -1 1.76 0.37b',
     6 'Tb3O -2 2.0320.37a', 'Tb3O -2 2.0490.37b', 'Tb3O -2 2.0130.37a',
     7 'Tb3S -2 2.51 0.37b', 'Tb3Se-2 2.63 0.37b', 'Tb3Te-2 2.82 0.37b',
     8 'Tb3F -1 1.9360.37b', 'Tb3F -1 1.90 0.40p', 'Tb3Cl-1 2.4270.37b',
     9 'Tb3Cl-1 2.39 0.40p', 'Tb3Br-1 2.58 0.37b', 'Tb3Br-1 2.54 0.40p',
     * 'Tb3I -1 2.80 0.37b', 'Tb3I -1 2.77 0.40p', 'Tb3N -3 2.20 0.37b',
     1 'Tb3P -3 2.59 0.37b', 'Tb3As-3 2.66 0.37b', 'Tb3H -1 1.91 0.37b',
     2 'Tc4F -1 1.88 0.40p', 'Tc4Cl-1 2.21 0.37e', 'Tc7O -2 1.90 0.37e'/
     3 )
      VALENCE(1362:NP53) = (/
     3 'Te4O -2 1.9770.37a', 'Te4S -2 2.44 0.37e', 'Te4F -1 1.87 0.37b',
     4 'Te4Cl-1 2.37 0.37b', 'Te4Br-1 2.55 0.37e', 'Te4I -1 2.7870.37e',
     5 'Te6O -2 1.9170.37a', 'Te6F -1 1.82 0.37b', 'Te6Cl-1 2.30 0.37b',
     6 'Te9Br-1 2.53 0.37b', 'Te9I -1 2.76 0.37b', 'Te9S -2 2.45 0.37b',
     7 'Te9Se-2 2.53 0.37b', 'Te9Te-2 2.76 0.37b', 'Te9N -3 2.12 0.37b',
     8 'Te9P -3 2.52 0.37b', 'Te9As-3 2.60 0.37b', 'Te9H -1 1.83 0.37b',
     9 'Th4O -2 2.1670.37b', 'Th4O -2 2.18 0.35p', 'Th4S -2 2.64 0.37b',
     * 'Th4Se-2 2.76 0.37b', 'Th4Te-2 2.94 0.37b', 'Th4F -1 2.0680.37a',
     1 'Th4F -1 2.05 0.40p', 'Th4Cl-1 2.55 0.37b', 'Th4Cl-1 2.52 0.40p',
     2 'Th4Br-1 2.71 0.37b', 'Th4Br-1 2.68 0.40p', 'Th4I -1 2.93 0.37b',
     3 'Th4I -1 2.92 0.40p', 'Th4I -1 2.96 0.37e', 'Th4N -3 2.34 0.37b',
     4 'Th4P -3 2.73 0.37b', 'Th4As-3 2.80 0.37b', 'Th4H -1 2.07 0.37b',
     5 'Ti2F -1 2.15 0.37e', 'Ti2Cl-1 2.31 0.37e', 'Ti2Br-1 2.49 0.37e',
     6 'Ti3O -2 1.7910.37b', 'Ti3S -2 2.11 0.37e', 'Ti3F -1 1.7230.37b',
     7 'Ti3Cl-1 2.22 0.37e', 'Ti3Cl-1 2.17 0.37b', 'Ti3I -1 2.52 0.37e',
     8 'Ti4O -2 1.8150.37a', 'Ti4O -2 1.78 0.43o', 'Ti4S -2 2.29 0.37e',
     9 'Ti4F -1 1.76 0.37b', 'Ti4Cl-1 2.19 0.37b', 'Ti4Br-1 2.36 0.37e',
     * 'Ti9O -2 1.7900.37k', 'Ti9Cl-1 2.1840.37k', 'Ti9Br-1 2.32 0.37b',
     1 'Ti9I -1 2.54 0.37b', 'Ti9S -2 2.24 0.37b', 'Ti9Se-2 2.38 0.37b',
     2 'Ti9Te-2 2.60 0.37b', 'Ti9N -3 1.93 0.37b', 'Ti9N -3 1.9060.37k',
     3 'Ti9P -3 2.36 0.37b', 'Ti9As-3 2.42 0.37b', 'Ti9H -1 1.61 0.37b',
     4 'Tl1O -2 2.1240.37a', 'Tl1O -2 2.1720.37b', 'Tl1O -2 1.9270.50a',
     5 'Tl1S -2 2.5450.37a', 'Tl1F -1 2.15 0.37b', 'Tl1Cl-1 2.56 0.37b',
     6 'Tl1Cl-1 2.61 0.37e', 'Tl1Br-1 2.69 0.37e', 'Tl1I -1 2.8220.37a',
     7 'Tl3O -2 2.0030.37b', 'Tl3F -1 1.88 0.37b', 'Tl3Cl-1 2.32 0.37b',
     8 'Tl3Br-1 2.65 0.35e', 'Tl9Br-1 2.70 0.37b', 'Tl9I -1 2.91 0.37b',
     9 'Tl9S -2 2.63 0.37b', 'Tl9Se-2 2.70 0.37b', 'Tl9Te-2 2.93 0.37b',
     * 'Tl9N -3 2.29 0.37b', 'Tl9P -3 2.71 0.37b', 'Tl9As-3 2.79 0.37b',
     1 'Tl9H -1 2.05 0.37b', 'Tm3O -2 2.0000.37b', 'Tm3O -2 1.9680.37a',
     2 'Tm3O -2 1.93 0.37e', 'Tm3S -2 2.45 0.37b', 'Tm3Se-2 2.58 0.37b',
     3 'Tm3Te-2 2.77 0.37b', 'Tm3F -1 1.8420.37b', 'Tm3F -1 1.86 0.40p',
     4 'Tm3F -1 1.91 0.37e', 'Tm3Cl-1 2.38 0.37b', 'Tm3Cl-1 2.35 0.40p',
     5 'Tm3Br-1 2.53 0.37b', 'Tm3Br-1 2.50 0.40p', 'Tm3I -1 2.74 0.37b',
     6 'Tm3I -1 2.74 0.40p', 'Tm3N -3 2.14 0.37b', 'Tm3P -3 2.53 0.37b',
     7 'Tm3As-3 2.62 0.37b', 'Tm3H -1 1.85 0.37b', 'U 2O -1 2.08 0.37e',
     8 'U 3S -2 2.54 0.37e', 'U 3F -1 2.02 0.40p', 'U 3F -1 2.09 0.37e',
     9 'U 3Cl-1 2.49 0.40p', 'U 3Br-1 2.64 0.40p', 'U 3I -1 2.87 0.40p',
     * 'U 4O -2 2.1120.37b', 'U 4O -2 2.13 0.35p', 'U 4S -2 2.55 0.37e',
     1 'U 4F -1 2.0380.37a', 'U 4F -1 2.0340.37b', 'U 4F -1 2.00 0.40p',
     2 'U 4Cl-1 2.47 0.40p', 'U 4Br-1 2.60 0.40p', 'U 4Br-1 2.61 0.37e',
     3 'U 4I -1 2.88 0.37e', 'U 4N -3 2.18 0.37e', 'U 5O -2 2.0750.37b',
     4 'U 5O -2 2.10 0.35p', 'U 5F -1 1.9660.37b', 'U 5F -1 1.99 0.40p',
     5 'U 5Cl-1 2.46 0.37b', 'U 5Cl-1 2.43 0.40p', 'U 5Br-1 2.7  0.35e',
     6 'U 6O -2 2.0510.51r', 'U 6O -2 2.0750.37a', 'U 6O -2 2.08 0.35p',
     7 'U 6F -1 1.98 0.40p', 'U 6Cl-1 2.42 0.40p', 'U 6N -3 1.93 0.35e',
     8 'U 9Br-1 2.63 0.37b', 'U 9I -1 2.84 0.37b', 'U 9S -2 2.56 0.37b',
     9 'U 9Se-2 2.70 0.37b', 'U 9Te-2 2.86 0.37b', 'U 9N -3 2.24 0.37b',
     * 'U 9P -3 2.64 0.37b', 'U 9As-3 2.72 0.37b', 'U 9H -1 1.97 0.37b',
     1 'V 1O -2 1.88 0.37e', 'V 1Cl-1 2.00 0.35e', 'V 2O -2 1.70 0.37e',
     2 'V 2S -2 2.11 0.37e', 'V 2F -1 2.16 0.37e', 'V 2Cl-1 2.44 0.37e',
     3 'V 3O -2 1.7430.37a', 'V 3O -2 1.7490.37j', 'V 3S -2 2.17 0.37e',
     4 'V 3S -2 2.1850.37j', 'V 3F -1 1.7020.37b', 'V 3Cl-1 2.19 0.37b',
     5 'V 3Br-1 2.33 0.35e', 'V 3N -3 1.8130.37j', 'V 3N -3 1.84 0.35e',
     6 'V 4O -2 1.7840.37a', 'V 4O -2 1.7800.37j', 'V 4O -2 1.7350.37j',
     7 'V 4S -2 2.2260.37j', 'V 4S -2 2.1810.37j', 'V 4S -2 2.24 0.37e',
     8 'V 4F -1 1.70 0.37b', 'V 4Cl-1 2.16 0.37b', 'V 4N -3 1.8750.37j',
     9 'V 5O -2 1.8030.37a', 'V 5O -2 1.7990.37x', 'V 5N -3 1.9400.37*',
     * 'V 5S -2 2.25 0.37e', 'V 5F -1 1.70 0.37e', 'V 5Cl-1 2.16 0.37b',
     1 'V 9O -2 1.81 0.34o', 'V 9Br-1 2.30 0.37b', 'V 9I -1 2.51 0.37b',
     2 'V 9S -2 2.23 0.37b', 'V 9Se-2 2.33 0.37b', 'V 9Te-2 2.57 0.37b',
     3 'V 9N -3 1.86 0.37b', 'V 9P -3 2.31 0.37b', 'V 9As-3 2.39 0.37b',
     4 'V 9H -1 1.58 0.37b', 'W 5O -2 1.89 0.37e', 'W 6O -2 1.9170.37a',
     5 'W 6O -2 1.9160.41x', 'W 6O -2 1.9210.37b', 'W 6F -1 1.83 0.37b',
     6 'W 6Cl-1 2.27 0.37b', 'W 9Br-1 2.45 0.37b', 'W 9I -1 2.66 0.37b',
     7 'W 9S -2 2.39 0.37b', 'W 9Se-2 2.51 0.37b', 'W 9Te-2 2.71 0.37b',
     8 'W 9N -3 2.06 0.37b', 'W 9P -3 2.46 0.37b', 'W 9As-3 2.54 0.37b',
     9 'W 9H -1 1.76 0.37b', 'Xe2O -2 2.05 0.35e', 'Xe2F -1 2.02 0.37e',
     * 'Xe4F -1 1.93 0.37e', 'Xe6O -2 2.00 0.37e', 'Xe6F -1 1.89 0.37e',
     1 'Xe8O -2 1.94 0.37e', 'Y 3O -2 2.0190.37a', 'Y 3O -2 2.0140.37b',
     2 'Y 3S -2 2.48 0.37b',
     2 'Y 3Se-2 2.61 0.37b', 'Y 3Te-2 2.80 0.37b', 'Y 3F -1 1.9040.37b',
     3 'Y 3F -1 1.87 0.37e', 'Y 3Cl-1 2.40 0.37b', 'Y 3Br-1 2.55 0.37b',
     4 'Y 3I -1 2.77 0.37b', 'Y 3N -3 2.17 0.37b', 'Y 3P -3 2.57 0.37b',
     5 'Y 3As-3 2.64 0.37b', 'Y 3H -1 1.86 0.37b', 'Yb3O -2 1.9650.37a',
     6 'Yb3O -2 1.9850.37b', 'Yb3O -2 1.9540.37a', 'Yb3S -2 2.43 0.37b',
     7 'Yb3Se-2 2.56 0.37b', 'Yb3Te-2 2.76 0.37b', 'Yb3F -1 1.8750.37b',
     8 'Yb3F -1 1.85 0.40p', 'Yb3F -1 1.90 0.37e', 'Yb3Cl-1 2.3710.37b',
     9 'Yb3Cl-1 2.34 0.40p', 'Yb3Br-1 2.4510.37b', 'Yb3Br-1 2.49 0.40p',
     * 'Yb3I -1 2.72 0.37b', 'Yb3I -1 2.74 0.40p', 'Yb3N -3 2.12 0.37b',
     1 'Yb3P -3 2.53 0.37b', 'Yb3As-3 2.59 0.37b', 'Yb3H -1 1.82 0.37b',
     2 'Zn2O -2 1.7040.37a', 'Zn2O -2 1.6750.39o', 'Zn2S -2 2.09 0.37b',
     3 'Zn2Se-2 2.22 0.37b', 'Zn2Te-2 2.45 0.37b', 'Zn2F -1 1.62 0.37b',
     4 'Zn2F -1 1.67 0.37e', 'Zn2Cl-1 2.01 0.37b', 'Zn2Br-1 2.15 0.37b',
     5 'Zn2I -1 2.36 0.37b', 'Zn2N -3 1.72 0.37e', 'Zn2P -3 2.15 0.37b',
     6 'Zn2As-3 2.24 0.37b', 'Zn2H -1 1.42 0.37b', 'Zr2O -2 2.34 0.37e',
     7 'Zr2F -1 2.24 0.37e', 'Zr2Cl-1 2.58 0.37e', 'Zr4C -4 2.03 0.37*',
     8 'Zr4O -2 1.9280.37a',
     8 'Zr4O -2 1.9370.37b', 'Zr4S -2 2.41 0.37b', 'Zr4Se-2 2.53 0.37b',
     9 'Zr4Te-2 2.67 0.37b', 'Zr4F -1 1.8460.37a', 'Zr4F -1 1.8540.37b',
     * 'Zr4Cl-1 2.33 0.37b', 'Zr4Br-1 2.48 0.37b', 'Zr4I -1 2.69 0.37b',
     1 'Zr4N -3 2.11 0.37b', 'Zr4N -3 2.15 0.37e', 'Zr4P -3 2.52 0.37b',
     2 'Zr4As-3 2.57 0.37b', 'Zr4H -1 1.79 0.37b'/)
      RETURN
      END SUBROUTINE PLA445
 
      SUBROUTINE PLA446
C * LOAD RECOGNIZED CIF DATANAMES
      USE cif
      CIFDIR(1:100) = (/
C * 1-10
     1 '_atom_site_aniso_label                             ',
     2 '_atom_site_aniso_type_symbol                       ',
     3 '_atom_site_aniso_U_11                              ',
     4 '_atom_site_aniso_U_12                              ',
     5 '_atom_site_aniso_U_13                              ',
     6 '_atom_site_aniso_U_22                              ',
     7 '_atom_site_aniso_U_23                              ',
     8 '_atom_site_aniso_U_33                              ',
     9 '_atom_site_attached_hydrogens                      ',
     * '_atom_site_calc_attached_atom                      ',
C * 11-20
     1 '_atom_site_calc_flag                               ',
     2 '_atom_site_Cartn_x                                 ',
     3 '_atom_site_Cartn_y                                 ',
     4 '_atom_site_Cartn_z                                 ',
     5 '_atom_site_chemical_conn_number                    ',
     6 '_atom_site_constraints                             ',
     7 '_atom_site_description                             ',
     8 '_atom_site_disorder_group                          ',
     9 '_atom_site_fract_x                                 ',
     * '_atom_site_fract_y                                 ',
C * 21-30
     1 '_atom_site_fract_z                                 ',
     2 '_atom_site_label                                   ',
     3 '_atom_site_label_component_0                       ',
     4 '_atom_site_label_component_1                       ',
     5 '_atom_site_label_component_2                       ',
     6 '_atom_site_label_component_3                       ',
     7 '_atom_site_label_component_4                       ',
     8 '_atom_site_label_component_5                       ',
     9 '_atom_site_label_component_6                       ',
     * '_atom_site_occupancy                               ',
C * 31-40
     1 '_atom_site_refinement_flags                        ',
     2 '_atom_site_restraints                              ',
     3 '_atom_site_symmetry_multiplicity                   ',
     4 '_atom_site_thermal_displace_type                   ',
     5 '_atom_site_type_symbol                             ',
     6 '_atom_site_U_iso_or_equiv                          ',
     7 '_atom_site_Wyckoff_symbol                          ',
     8 '_atom_sites_Cartn_tran_matrix_11                   ',
     9 '_atom_sites_Cartn_tran_matrix_12                   ',
     * '_atom_sites_Cartn_tran_matrix_13                   ',
C * 41-50
     1 '_atom_sites_Cartn_tran_matrix_21                   ',
     2 '_atom_sites_Cartn_tran_matrix_22                   ',
     3 '_atom_sites_Cartn_tran_matrix_23                   ',
     4 '_atom_sites_Cartn_tran_matrix_31                   ',
     5 '_atom_sites_Cartn_tran_matrix_32                   ',
     6 '_atom_sites_Cartn_tran_matrix_33                   ',
     7 '_atom_sites_Cartn_transform_axes                   ',
     8 '_atom_sites_solution_primary                       ',
     9 '_atom_sites_solution_secondary                     ',
     * '_atom_sites_solution_hydrogens                     ',
C * 51-60
     1 '_atom_type_analytical_mass_%                       ',
     2 '_atom_type_description                             ',
     3 '_atom_type_number_in_cell                          ',
     4 '_atom_type_oxidation_number                        ',
     5 '_atom_type_radius_bond                             ',
     6 '_atom_type_radius_contact                          ',
     7 '_atom_type_scat_Cromer_Mann_a1                     ',
     8 '_atom_type_scat_Cromer_Mann_a2                     ',
     9 '_atom_type_scat_Cromer_Mann_a3                     ',
     * '_atom_type_scat_Cromer_Mann_a4                     ',
C * 61-70
     1 '_atom_type_scat_Cromer_Mann_b1                     ',
     2 '_atom_type_scat_Cromer_Mann_b2                     ',
     3 '_atom_type_scat_Cromer_Mann_b3                     ',
     4 '_atom_type_scat_Cromer_Mann_b4                     ',
     5 '_atom_type_scat_Cromer_Mann_c                      ',
     6 '_atom_type_scat_dispersion_imag                    ',
     7 '_atom_type_scat_dispersion_real                    ',
     8 '_atom_type_scat_source                             ',
     9 '_atom_type_scat_versus_stol_list                   ',
     * '_atom_type_symbol                                  ',
C * 71-80
     1 '_audit_creation_date                               ',
     2 '_audit_creation_method                             ',
     3 '_audit_update_record                               ',
     4 '_cell_angle_alpha                                  ',
     5 '_cell_angle_beta                                   ',
     6 '_cell_angle_gamma                                  ',
     7 '_cell_formula_units_Z                              ',
     8 '_cell_length_a                                     ',
     9 '_cell_length_b                                     ',
     * '_cell_length_c                                     ',
C * 81-90
     1 '_cell_measurement_pressure                         ',
     2 '_cell_measurement_radiation                        ',
     3 '_cell_measurement_refln_index_h                    ',
     4 '_cell_measurement_refln_index_k                    ',
     5 '_cell_measurement_refln_index_l                    ',
     6 '_cell_measurement_refln_theta                      ',
     7 '_cell_measurement_reflns_used                      ',
     8 '_cell_measurement_temperature                      ',
     9 '_cell_measurement_theta_max                        ',
     * '_cell_measurement_theta_min                        ',
C * 91-100
     1 '_cell_measurement_wavelength                       ',
     2 '_cell_special_details                              ',
     3 '_cell_volume                                       ',
     4 '_chemical_compound_source                          ',
     5 '_chemical_conn_atom_charge                         ',
     6 '_chemical_conn_atom_display_x                      ',
     7 '_chemical_conn_atom_display_y                      ',
     8 '_chemical_conn_atom_NCA                            ',
     9 '_chemical_conn_atom_NH                             ',
     * '_chem_conn_atom_number                             '/)
      CIFDIR(101:200) = (/
C * 101-110
     1 '_chemical_conn_atom_type_symbol                    ',
     2 '_chemical_conn_bond_atom_1                         ',
     3 '_chemical_conn_bond_atom_2                         ',
     4 '_chemical_conn_bond_type                           ',
     5 '_chemical_formula_appendix                         ',
     6 '_chemical_formula_analytical                       ',
     7 '_chemical_formula_moiety                           ',
     8 '_chemical_formula_structural                       ',
     9 '_chemical_formula_sum                              ',
     * '_chemical_formula_weight                           ',
C * 111-120
     1 '_chemical_formula_weight_meas                      ',
     2 '_chemical_melting_point                            ',
     3 '_chemical_name_common                              ',
     4 '_chemical_name_mineral                             ',
     5 '_chemical_name_structure_type                      ',
     6 '_chemical_name_systematic                          ',
     7 '_computing_cell_refinement                         ',
     8 '_computing_data_collection                         ',
     9 '_computing_data_reduction                          ',
     * '_computing_molecular_graphics                      ',
C * 121-130
     1 '_computing_publication_material                    ',
     2 '_computing_structure_refinement                    ',
     3 '_computing_structure_solution                      ',
     4 '_database_code_CAS                                 ',
     5 '_database_code_CSD                                 ',
     6 '_database_code_ICSD                                ',
     7 '_database_code_MDF                                 ',
     8 '_database_code_NBS                                 ',
     9 '_database_code_PDF                                 ',
     * '_database_journal_ASTM                             ',
C * 131-140
     1 '_database_journal_CSD                              ',
     2 '_diffrn_ambient_pressure                           ',
     3 '_diffrn_ambient_temperature                        ',
     4 '_diffrn_attenuator_code                            ',
     5 '_diffrn_attenuator_scale                           ',
     6 '_diffrn_measurement_device                         ',
     7 '_diffrn_measurement_method                         ',
     8 '_diffrn_orient_matrix_type                         ',
     9 '_diffrn_orient_matrix_UB_11                        ',
     * '_diffrn_orient_matrix_UB_12                        ',
C * 141-150
     1 '_diffrn_orient_matrix_UB_13                        ',
     2 '_diffrn_orient_matrix_UB_21                        ',
     3 '_diffrn_orient_matrix_UB_22                        ',
     4 '_diffrn_orient_matrix_UB_23                        ',
     5 '_diffrn_orient_matrix_UB_31                        ',
     6 '_diffrn_orient_matrix_UB_32                        ',
     7 '_diffrn_orient_matrix_UB_33                        ',
     8 '_diffrn_orient_refln_angle_chi                     ',
     9 '_diffrn_orient_refln_angle_kappa                   ',
     * '_diffrn_orient_refln_angle_phi                     ',
C * 151-160
     1 '_diffrn_orient_refln_angle_psi                     ',
     2 '_diffrn_orient_refln_index_h                       ',
     3 '_diffrn_orient_refln_index_k                       ',
     4 '_diffrn_orient_refln_index_l                       ',
     5 '_diffrn_radiation_detector                         ',
     6 '_diffrn_radiation_detector_dtime                   ',
     7 '_diffrn_radiation_filter_edge                      ',
     8 '_diffrn_radiation_inhomogeneity                    ',
     9 '_diffrn_radiation_monochromator                    ',
     * '_diffrn_radiation_polarisn_norm                    ',
C * 161-170
     1 '_diffrn_radiation_polarisn_ratio                   ',
     2 '_diffrn_radiation_source                           ',
     3 '_diffrn_radiation_type                             ',
     4 '_diffrn_radiation_wavelength                       ',
     5 '_diffrn_radiation_wavelength_id                    ',
     6 '_diffrn_radiation_wavelength_wt                    ',
     7 '_diffrn_refln_angle_chi                            ',
     8 '_diffrn_refln_angle_kappa                          ',
     9 '_diffrn_refln_angle_omega                          ',
     * '_diffrn_refln_angle_phi                            ',
C * 171-180
     1 '_diffrn_refln_angle_psi                            ',
     2 '_diffrn_refln_angle_theta                          ',
     3 '_diffrn_refln_attenuator_code                      ',
     4 '_diffrn_refln_counts_bg_1                          ',
     5 '_diffrn_refln_counts_bg_2                          ',
     6 '_diffrn_refln_counts_net                           ',
     7 '_diffrn_refln_counts_peak                          ',
     8 '_diffrn_refln_counts_total                         ',
     9 '_diffrn_refln_crystal_id                           ',
     * '_diffrn_refln_detect_slit_horiz                    ',
C * 181-190
     1 '_diffrn_refln_detect_slit_vert                     ',
     2 '_diffrn_refln_elapsed_time                         ',
     3 '_diffrn_refln_index_h                              ',
     4 '_diffrn_refln_index_k                              ',
     5 '_diffrn_refln_index_l                              ',
     6 '_diffrn_refln_intensity_net                        ',
     7 '_diffrn_refln_intensity_sigma                      ',
     8 '_diffrn_refln_scale_group_code                     ',
     9 '_diffrn_refln_scan_mode                            ',
     * '_diffrn_refln_scan_mode_backgd                     ',
C * 191-200
     1 '_diffrn_refln_scan_width                           ',
     2 '_diffrn_refln_sinth/lambda                         ',
     3 '_diffrn_refln_standard_code                        ',
     4 '_diffrn_refln_wavelength                           ',
     5 '_diffrn_refln_wavelength_id                        ',
     6 '_diffrn_reflns_av_R_equivalents                    ',
     7 '_diffrn_reflns_av_sigmaI/netI                      ',
     8 '_diffrn_reflns_limit_h_max                         ',
     9 '_diffrn_reflns_limit_h_min                         ',
     * '_diffrn_reflns_limit_k_max                         '/)
      CIFDIR(201:300) = (/
C * 201-210
     1 '_diffrn_reflns_limit_k_min                         ',
     2 '_diffrn_reflns_limit_l_max                         ',
     3 '_diffrn_reflns_limit_l_min                         ',
     4 '_diffrn_reflns_number                              ',
     5 '_diffrn_reflns_reduction_process                   ',
     6 '_diffrn_reflns_theta_max                           ',
     7 '_diffrn_reflns_theta_min                           ',
     8 '_diffrn_reflns_trans_matrix_11                     ',
     9 '_diffrn_reflns_trans_matrix_12                     ',
     * '_diffrn_reflns_trans_matrix_13                     ',
C * 211-220
     1 '_diffrn_reflns_trans_matrix_21                     ',
     2 '_diffrn_reflns_trans_matrix_22                     ',
     3 '_diffrn_reflns_trans_matrix_23                     ',
     4 '_diffrn_reflns_trans_matrix_31                     ',
     5 '_diffrn_reflns_trans_matrix_32                     ',
     6 '_diffrn_reflns_trans_matrix_33                     ',
     7 '_diffrn_scale_group_code                           ',
     8 '_diffrn_scale_group_net                            ',
     9 '_diffrn_special_details                            ',
     * '_diffrn_standard_refln_code                        ',
C * 221-230
     1 '_diffrn_standard_refln_index_h                     ',
     2 '_diffrn_standard_refln_index_k                     ',
     3 '_diffrn_standard_refln_index_l                     ',
     4 '_diffrn_standards_decay_%                          ',
     5 '_diffrn_standards_interval_count                   ',
     6 '_diffrn_standards_interval_time                    ',
     7 '_diffrn_standards_number                           ',
     8 '_diffrn_standards_scale_sigma                      ',
     9 '_exptl_absorpt_coefficient_mu                      ',
     * '_exptl_absorpt_correction_T_max                    ',
C * 231-240
     1 '_exptl_absorpt_correction_T_min                    ',
     2 '_exptl_absorpt_correction_type                     ',
     3 '_exptl_absorpt_process_details                     ',
     4 '_exptl_crystal_colour                              ',
     5 '_exptl_crystal_density_diffrn                      ',
     6 '_exptl_crystal_density_meas                        ',
     7 '_exptl_crystal_density_meas_temp                   ',
     8 '_exptl_crystal_density_method                      ',
     9 '_exptl_crystal_description                         ',
     * '_exptl_crystal_F_000                               ',
C * 241-250
     1 '_exptl_crystal_face_diffr_chi                      ',
     2 '_exptl_crystal_face_diffr_kappa                    ',
     3 '_exptl_crystal_face_diffr_phi                      ',
     4 '_exptl_crystal_face_diffr_psi                      ',
     5 '_exptl_crystal_face_index_h                        ',
     6 '_exptl_crystal_face_index_k                        ',
     7 '_exptl_crystal_face_index_l                        ',
     8 '_exptl_crystal_face_perp_dist                      ',
     9 '_exptl_crystal_id                                  ',
     * '_exptl_crystal_preparation                         ',
C * 251-260
     1 '_exptl_crystal_size_max                            ',
     2 '_exptl_crystal_size_mid                            ',
     3 '_exptl_crystal_size_min                            ',
     4 '_exptl_crystal_size_rad                            ',
     5 '_exptl_crystals_number                             ',
     6 '_exptl_special_details                             ',
     7 '_geom_angle                                        ',
     8 '_geom_angle_atom_site_label_1                      ',
     9 '_geom_angle_atom_site_label_2                      ',
     * '_geom_angle_atom_site_label_3                      ',
C * 261-270
     1 '_geom_angle_publ_flag                              ',
     2 '_geom_angle_site_symmetry_1                        ',
     3 '_geom_angle_site_symmetry_2                        ',
     4 '_geom_angle_site_symmetry_3                        ',
     5 '_geom_bond_atom_site_label_1                       ',
     6 '_geom_bond_atom_site_label_2                       ',
     7 '_geom_bond_distance                                ',
     8 '_geom_bond_publ_flag                               ',
     9 '_geom_bond_site_symmetry_1                         ',
     * '_geom_bond_site_symmetry_2                         ',
C * 271-280
     1 '_geom_contact_atom_site_label_1                    ',
     2 '_geom_contact_atom_site_label_2                    ',
     3 '_geom_contact_distance                             ',
     4 '_geom_contact_publ_flag                            ',
     5 '_geom_contact_site_symmetry_1                      ',
     6 '_geom_contact_site_symmetry_2                      ',
     7 '_geom_special_details                              ',
     8 '_geom_torsion                                      ',
     9 '_geom_torsion_atom_site_label_1                    ',
     * '_geom_torsion_atom_site_label_2                    ',
C * 281-290
     1 '_geom_torsion_atom_site_label_3                    ',
     2 '_geom_torsion_atom_site_label_4                    ',
     3 '_geom_torsion_publ_flag                            ',
     4 '_geom_torsion_site_symmetry_1                      ',
     5 '_geom_torsion_site_symmetry_2                      ',
     6 '_geom_torsion_site_symmetry_3                      ',
     7 '_geom_torsion_site_symmetry_4                      ',
     8 '_journal_coden_ASTM                                ',
     9 '_journal_coden_Cambridge                           ',
     * '_journal_coeditor_address                          ',
C * 291-300
     1 '_journal_coeditor_code                             ',
     2 '_journal_coeditor_email                            ',
     3 '_journal_coeditor_fax                              ',
     4 '_journal_coeditor_name                             ',
     5 '_journal_coeditor_notes                            ',
     6 '_journal_coeditor_phone                            ',
     7 '_journal_date_accepted                             ',
     8 '_journal_date_from_coeditor                        ',
     9 '_journal_date_to_coeditor                          ',
     * '_journal_date_printers_final                       '/)
      CIFDIR(301:400) = (/
C * 301-310
     1 '_journal_date_printers_first                       ',
     2 '_journal_date_proofs_in                            ',
     3 '_journal_date_proofs_out                           ',
     4 '_journal_date_recd_copyright                       ',
     5 '_journal_date_recd_electronic                      ',
     6 '_journal_date_recd_hard_copy                       ',
     7 '_journal_issue                                     ',
     8 '_journal_name_full                                 ',
     9 '_journal_page_first                                ',
     * '_journal_page_last                                 ',
C * 311-320
     1 '_journal_suppl_publ_number                         ',
     2 '_journal_suppl_publ_pages                          ',
     3 '_journal_techeditor_address                        ',
     4 '_journal_techeditor_code                           ',
     5 '_journal_techeditor_email                          ',
     6 '_journal_techeditor_fax                            ',
     7 '_journal_techeditor_name                           ',
     8 '_journal_techeditor_notes                          ',
     9 '_journal_techeditor_phone                          ',
     * '_journal_volume                                    ',
C * 321-330
     1 '_journal_year                                      ',
     2 '_publ_author_address                               ',
     3 '_publ_author_name                                  ',
     4 '_publ_contact_author                               ',
     5 '_publ_contact_author_email                         ',
     6 '_publ_contact_author_fax                           ',
     7 '_publ_contact_author_phone                         ',
     8 '_publ_contact_letter                               ',
     9 '_publ_manuscript_creation                          ',
     * '_publ_manuscript_incl_extra_item                   ',
C * 331-340
     1 '_publ_manuscript_incl_extra_info                   ',
     2 '_publ_manuscript_incl_extra_defn                   ',
     3 '_publ_manuscript_processed                         ',
     4 '_publ_manuscript_text                              ',
     5 '_publ_requested_coeditor_name                      ',
     6 '_publ_requested_journal                            ',
     7 '_publ_section_title                                ',
     8 '_publ_section_abstract                             ',
     9 '_publ_section_comment                              ',
     * '_publ_section_introduction                         ',
C * 341-350
     1 '_publ_section_experimental                         ',
     2 '_publ_section_discussion                           ',
     3 '_publ_section_acknowledgements                     ',
     4 '_publ_section_references                           ',
     5 '_publ_section_figure_captions                      ',
     6 '_publ_section_table_legends                        ',
     7 '_refine_diff_density_max                           ',
     8 '_refine_diff_density_min                           ',
     9 '_refine_ls_abs_structure_details                   ',
     * '_refine_ls_abs_structure_Flack                     ',
C * 351-360
     1 '_refine_ls_abs_structure_Rogers                    ',
     2 '_refine_ls_extinction_coef                         ',
     3 '_refine_ls_extinction_expression                   ',
     4 '_refine_ls_extinction_method                       ',
     5 '_refine_ls_goodness_of_fit_all                     ',
     6 '_refine_ls_goodness_of_fit_obs                     ',
     7 '_refine_ls_hydrogen_treatment                      ',
     8 '_refine_ls_matrix_type                             ',
     9 '_refine_ls_number_constraints                      ',
     * '_refine_ls_number_parameters                       ',
C * 361-370
     1 '_refine_ls_number_reflns                           ',
     2 '_refine_ls_number_restraints                       ',
     3 '_refine_ls_R_factor_all                            ',
     4 '_refine_ls_R_factor_obs                            ',
     5 '_refine_ls_restrained_S_all                        ',
     6 '_refine_ls_restrained_S_obs                        ',
     7 '_refine_ls_shift/esd_max                           ',
     8 '_refine_ls_shift/esd_mean                          ',
     9 '_refine_ls_structure_factor_coef                   ',
     * '_refine_ls_weighting_scheme                        ',
C * 371-380
     1 '_refine_ls_wR_factor_all                           ',
     2 '_refine_ls_wR_factor_obs                           ',
     3 '_refine_special_details                            ',
     4 '_refln_A_calc                                      ',
     5 '_refln_A_meas                                      ',
     6 '_refln_B_calc                                      ',
     7 '_refln_B_meas                                      ',
     8 '_refln_crystal_id                                  ',
     9 '_refln_F_calc                                      ',
     * '_refln_F_meas                                      ',
C * 381-390
     1 '_refln_F_sigma                                     ',
     2 '_refln_F_squared_calc                              ',
     3 '_refln_F_squared_meas                              ',
     4 '_refln_F_squared_sigma                             ',
     5 '_refln_index_h                                     ',
     6 '_refln_index_k                                     ',
     7 '_refln_index_l                                     ',
     8 '_refln_intensity_calc                              ',
     9 '_refln_intensity_meas                              ',
     * '_refln_intensity_sigma                             ',
C * 391-400
     1 '_refln_mean_path_length_tbar                       ',
     2 '_refln_observed_status                             ',
     3 '_refln_phase_calc                                  ',
     4 '_refln_phase_meas                                  ',
     5 '_refln_refinement_status                           ',
     6 '_refln_scale_group_code                            ',
     7 '_refln_sint/lambda                                 ',
     8 '_refln_symmetry_epsilon                            ',
     9 '_refln_symmetry_multiplicity                       ',
     * '_refln_wavelength                                  '/)
      CIFDIR(401:500) = (/
C * 401-410
     1 '_refln_wavelength_id                               ',
     2 '_reflns_d_resolution_high                          ',
     3 '_reflns_d_resolution_low                           ',
     4 '_reflns_limit_h_max                                ',
     5 '_reflns_limit_h_min                                ',
     6 '_reflns_limit_k_max                                ',
     7 '_reflns_limit_k_min                                ',
     8 '_reflns_limit_l_max                                ',
     9 '_reflns_limit_l_min                                ',
     * '_reflns_number_total                               ',
C * 411-420
     1 '_reflns_number_observed                            ',
     2 '_reflns_observed_criterion                         ',
     3 '_reflns_scale_group_code                           ',
     4 '_reflns_scale_meas_F                               ',
     5 '_reflns_scale_meas_F_squared                       ',
     6 '_reflns_scale_meas_intensity                       ',
     7 '_reflns_special_details                            ',
     8 '_symmetry_cell_setting                             ',
     9 '_symmetry_equiv_pos_as_xyz                         ',
     * '_symmetry_Int_Tables_number                        ',
C * 421-430
     1 '_symmetry_space_group_name_Hall                    ',
     2 '_symmetry_space_group_name_H-M                     ',
     3 '_atom_site_B_iso_or_equiv                          ',
     4 '_publ_section_exptl_prep                           ',
     5 '_publ_section_exptl_refinement                     ',
     6 '_geom_hbond_atom_site_label_D                      ',
     7 '_geom_hbond_atom_site_label_H                      ',
     8 '_geom_hbond_atom_site_label_A                      ',
     9 '_geom_hbond_distance_DH                            ',
     * '_geom_hbond_distance_HA                            ',
C * 431-440
     1 '_geom_hbond_distance_DA                            ',
     2 '_geom_hbond_angle_DHA                              ',
     3 '_geom_hbond_site_symmetry_A                        ',
     4 '_geom_hbond_publ_flag                              ',
     5 '_journal_coden_Cambridge                           ',
     6 '_publ_requested_category                           ',
     7 '_publ_contact_author_name                          ',
     8 '_publ_contact_author_address                       ',
     9 '_publ_section_title_footnote                       ',
     * '_publ_section_synopsis                             ',
C * 441-450
     1 '_diffrn_measurement_device_type                    ',
     2 '_reflns_number_gt                                  ',
     3 '_reflns_threshold_expression                       ',
     4 '_diffrn_reflns_theta_full                          ',
     5 '_refine_ls_R_factor_gt                             ',
     6 '_refine_ls_wR_factor_ref                           ',
     7 '_refine_ls_goodness_of_fit_ref                     ',
     8 '_refine_ls_shift/su_max                            ',
     9 '_atom_site_adp_type                                ',
     * '_atom_site_disorder_assembly                       ',
C * 451-460
     1 '_refine_ls_weighting_details                       ',
     2 '_atom_site_aniso_B_11                              ',
     3 '_atom_site_aniso_B_12                              ',
     4 '_atom_site_aniso_B_13                              ',
     5 '_atom_site_aniso_B_22                              ',
     6 '_atom_site_aniso_B_23                              ',
     7 '_atom_site_aniso_B_33                              ',
     8 '_diffrn_measured_fraction_theta_max                ',
     9 '_diffrn_measured_fraction_theta_full               ',
     * '_refine_ls_wR_factor_gt                            ',
C * 461-470
     1 '_refine_ls_shift/su_mean                           ',
     2 '_refine_diff_density_rms                           ',
     3 '_diffrn_detector_area_resol_mean                   ',
     4 '_database_code_CSD                                 ',
     5 '_iucr_compatibility_tag                            ',
     6 '_geom_hbond_site_symmetry_D                        ',
     7 '_geom_hbond_site_symmetry_H                        ',
     8 '_journal_paper_category                            ',
     9 '_publ_author_footnote                              ',
     * '_geom_extra_table_head_A                           ',
C * 471-480
     1 '_geom_extra_tableA_col_1                           ',
     2 '_geom_extra_tableA_col_2                           ',
     3 '_geom_extra_tableA_col_3                           ',
     4 '_geom_extra_tableA_col_4                           ',
     5 '_geom_extra_tableA_col_5                           ',
     6 '_geom_extra_tableA_col_6                           ',
     7 '_geom_extra_tableA_col_7                           ',
     8 '_geom_extra_tableA_col_8                           ',
     9 '_refln_nonius_diffracted_cos_cstar                 ',
     * '_symmetry_equiv_pos_site_id                        ',
C * 481-490
     1 '_diffrn_radiation_probe                            ',
     2 '_chemical_formula_iupac                            ',
     3 '_space_group_crystal_system                        ',
     4 '_space_group_id                                    ',
     5 '_space_group_IT_number                             ',
     6 '_space_group_name_Hall                             ',
     7 '_space_group_name_H-M                              ',
     8 '_space_group_name_H-M_alt                          ',
     9 '_space_group_symop_id                              ',
     * '_space_group_symop_operation_xyz                   ',
C * 491-500
     1 '_space_group_symop_sg_id                           ',
     2 '_diffrn_source                                     ',
     3 '_diffrn_detector                                   ',
     4 '_diffrn_detector_dtime                             ',
     5 '_diffrn_standards_decay_corr_max                   ',
     6 '_diffrn_standards_decay_corr_min                   ',
     7 '_diffrn_reflns_av_unetI/netI                       ',
     8 '_exptl_absorpt_factor_mur                          ',
     9 '_exptl_absorpt_correction_t_ave                    ',
     * '_audit_conform_dict_name                           '/)
      CIFDIR(501:600) = (/
C * 501-510
     1 '_audit_conform_dict_version                        ',
     2 '_audit_conform_dict_location                       ',
     3 '_platon_squeeze_void_nr                            ',
     4 '_platon_squeeze_void_average_x                     ',
     5 '_platon_squeeze_void_average_y                     ',
     6 '_platon_squeeze_void_average_z                     ',
     7 '_platon_squeeze_void_volume                        ',
     8 '_platon_squeeze_void_count_electrons               ',
     9 '_platon_squeeze_void_content                       ',
     * '_platon_squeeze_details                            ',
C * 511-520
     1 '_refine_ls_shift/su_max_lt                         ',
     2 '_refine_ls_abs_structure_Hooft                     ',
     3 '_iucr_refine_instructions_details                  ',
     4 '_refine_ls_goodness_of_fit_gt                      ',
     5 '_refine_ls_restrained_s_gt                         ',
     6 '_publ_section_related_literature                   ',
     7 '_publ_section_exptl_solution                       ',
     8 '_iucr_refine_instruction_details                   ',
     9 '_iucr_refine_instructions_details_restraints       ',
     * '_iucr_refine_instructions_details_constraints      ',
C * 521-530
     1 '_chemical_melting_point_gt                         ',
     2 '_chemical_melting_point_lt                         ',
     3 '_diffrn_source_type                                ',
     4 '_diffrn_source_power                               ',
     5 '_diffrn_source_voltage                             ',
     6 '_diffrn_source_current                             ',
     7 '_diffrn_radiation_collimation                      ',
     8 '_diffrn_measurement_details                        ',
     9 '_journal_data_validation_number                    ',
     * '_database_code_depnum_ccdc_archive                 ',
C * 531-540
     1 '_iucr_geom_hbonds_special_details                  ',
     2 '_publ_author_email                                 ',
     3 '_publ_contact_author_id_iucr                       ',
     4 '_chemical_optical_rotation                         ',
     5 '_chemical_properties_physical                      ',
     6 '_chemical_properties_biological                    ',
     7 '_geom_table_footnote_A                             ',
     8 '_geom_table_footnote_B                             ',
     9 '_iucr_compatibility_tag                            ',
     * '_diffrn_detector_type                              ',
C * 541-550
     1 '_geom_table_headnote_A                             ',
     2 '_geom_table_headnote_B                             ',
     3 '_exptl_crystal_recrystallization_method            ',
     4 '_pd_meas_2theta_range_min                          ',
     5 '_pd_meas_2theta_range_max                          ',
     6 '_twin_lattice_merohedry                            ',
     7 '_twin_lattice_reticular_merohedry                  ',
     8 '_twin_lattice_hybrid                               ',
     9 '_twin_lattice_special_details                      ',
     * '_twin_individual_number                            ',
C * 551-560
     1 '_twin_law_matrix_11                                ',
     2 '_twin_law_matrix_12                                ',
     3 '_twin_law_matrix_13                                ',
     4 '_twin_law_matrix_21                                ',
     5 '_twin_law_matrix_22                                ',
     6 '_twin_law_matrix_23                                ',
     7 '_twin_law_matrix_31                                ',
     8 '_twin_law_matrix_32                                ',
     9 '_twin_law_matrix_33                                ',
     * '_twin_matrix_11_UB                                 ',
C * 561-570
     1 '_twin_matrix_12_UB                                 ',
     2 '_twin_matrix_13_UB                                 ',
     3 '_twin_matrix_21_UB                                 ',
     4 '_twin_matrix_22_UB                                 ',
     5 '_twin_matrix_23_UB                                 ',
     6 '_twin_matrix_31_UB                                 ',
     7 '_twin_matrix_32_UB                                 ',
     8 '_twin_matrix_33_UB                                 ',
     9 '_iucr_refine_reflections_details                   ',
     * '_atom_site_site_symmetry_order                     ',
C * 571-580
     1 '_atom_site_site_symmetry_multiplicity              ',
     2 '_reflns_Friedel_fraction_max                       ',
     3 '_reflns_Friedel_fraction_full                      ',
     4 '_shelx_space_group_comment                         ',
     5 '_shelx_estimated_absorpt_T_min                     ',
     6 '_shelx_estimated_absorpt_T_max                     ',
     7 '_shelxl_version_number                             ',
     8 '_shelx_res_file                                    ',
     9 '_shelx_res_checksum                                ',
     * '_shelx_hkl_file                                    ',
C * 581-590
     1 '_shelx_hkl_checksum                                ',
     2 '_exptl_transmission_factor_max                     ',
     3 '_exptl_transmission_factor_min                     ',
     4 '_diffrn_reflns_sigmaI/netI                         ',
     5 '_diffrn_reflns_Laue_measured_fraction_max          ',
     6 '_diffrn_reflns_Laue_measured_fraction_full         ',
     7 '_diffrn_reflns_point_group_measured_fraction_max   ',
     8 '_diffrn_reflns_point_group_measured_fraction_full  ',
     9 '_reflns_Friedel_coverage                           ',
     * '_geom_extra_table_head_B                           ',
C * 591-600
     1 '_geom_extra_tableB_col_1                           ',
     2 '_geom_extra_tableB_col_2                           ',
     3 '_geom_extra_tableB_col_3                           ',
     4 '_geom_extra_tableB_col_4                           ',
     5 '_geom_extra_tableB_col_5                           ',
     6 '_geom_extra_tableB_col_6                           ',
     7 '_diffrn_source_monochromator                       ',
     8 '_atom_site_refinement_flags_posn                   ',
     9 '_atom_site_refinement_flags_adp                    ',
     * '_atom_site_refinement_flags_occupancy              '/)
      CIFDIR(601:700) = (/
C * 601-610
     1 '_shelx_fab_file                                    ',
     2 '_shelx_fab_checksum                                ',
     3 '_diffrn_reflns_transf_matrix_11                    ',
     4 '_diffrn_reflns_transf_matrix_12                    ',
     5 '_diffrn_reflns_transf_matrix_13                    ',
     6 '_diffrn_reflns_transf_matrix_21                    ',
     7 '_diffrn_reflns_transf_matrix_22                    ',
     8 '_diffrn_reflns_transf_matrix_23                    ',
     9 '_diffrn_reflns_transf_matrix_31                    ',
     * '_diffrn_reflns_transf_matrix_32                    ',
C * 611-620
     1 '_diffrn_reflns_transf_matrix_33                    ',
     2 '_diffrn_measurement_specimen_support               ',
     3 '_smtbx_masks_special_details                       ',
     4 '_smtbx_masks_void_nr                               ',
     5 '_smtbx_masks_void_average_x                        ',
     6 '_smtbx_masks_void_average_y                        ',
     7 '_smtbx_masks_void_average_z                        ',
     8 '_smtbx_masks_void_volume                           ',
     9 '_smtbx_masks_void_count_electrons                  ',
     * '_smtbx_masks_void_content                          ',
C * 621-630
     1 '_ccdc_compound_id                                  ',
     2 '_space_group_ssg_name                              ',
     3 '_publcif_datablock.id                              ',
     4 '_publcif_info_exptl_table_max_cols                 ',
     5 '_publcif_info_exptl_table_use_headnotes            ',
     6 '_publcif_info_tables.block_id                      ',
     7 '_publcif_info_tables.reference_item                ',
     8 '_publcif_info_datablock.id                         ',
     9 '_publcif_info_datablock.publ_exptl                 ',
     * '_publcif_info_datablock.publ_geom                  ',
C * 631- 640
     1 '_publcif_info_datablock.structure                  ',
     2 '_publcif_info_exptl_table_extra_item               ',
     3 '_publcif_info_exptl_table_header_item              ',
     4 '_publ_section_keywords                             ',
     5 '_publ_body_element                                 ',
     6 '_publ_body_title                                   ',
     7 '_publ_body_contents                                ',
     8 '_oxford_refine_reflns_threshold_expression_ref     ',
     9 '_platon_squeeze_void_probe_radius                  ',
     * '_exptl_absorpt_special_details                     ',
C * 641-650
     1 '_shelx_SHELXL_version_number                       ',
     2 '_platon_missing_refln_index_h                      ',
     3 '_platon_missing_refln_index_k                      ',
     4 '_platon_missing_refln_index_l                      ',
     5 '_platon_missing_refln_theta                        ',
     6 '_citation_database_id_csd                          ',
     7 '_citation_special_details                          ',
     8 '_twin_individual_id                                ',
     9 '_twin_individual_mass_fraction_refined             ',
     * '_twin_individual_twin_matrix_11                    ',
C * 651-660
     1 '_twin_individual_twin_matrix_12                    ',
     2 '_twin_individual_twin_matrix_13                    ',
     3 '_twin_individual_twin_matrix_21                    ',
     4 '_twin_individual_twin_matrix_22                    ',
     5 '_twin_individual_twin_matrix_23                    ',
     6 '_twin_individual_twin_matrix_31                    ',
     7 '_twin_individual_twin_matrix_32                    ',
     8 '_twin_individual_twin_matrix_33                    ',
     9 '_restr_distance_atom_site_label_1                  ',
     * '_restr_distance_site_symmetry_1                    ',
C * 661-670
     1 '_restr_distance_atom_site_label_2                  ',
     2 '_restr_distance_site_symmetry_2                    ',
     3 '_restr_distance_target                             ',
     4 '_restr_distance_target_weight_param                ',
     5 '_restr_angle_atom_site_label_1                     ',
     6 '_restr_angle_site_symmetry_1                       ',
     7 '_restr_angle_atom_site_label_2                     ',
     8 '_restr_angle_site_symmetry_2                       ',
     9 '_restr_angle_atom_site_label_3                     ',
     * '_restr_angle_site_symmetry_3                       ',
C * 671-680
     1 '_restr_angle_target                                ',
     2 '_restr_angle_target_weight_param                   ',
     3 '_restr_torsion_atom_site_label_1                   ',
     4 '_restr_torsion_site_symmetry_1                     ',
     5 '_restr_torsion_atom_site_label_2                   ',
     6 '_restr_torsion_site_symmetry_2                     ',
     7 '_restr_torsion_atom_site_label_3                   ',
     8 '_restr_torsion_site_symmetry_3                     ',
     9 '_restr_torsion_atom_site_label_4                   ',
     * '_restr_torsion_site_symmetry_4                     ',
C * 681-690
     1 '_restr_torsion_angle_target                        ',
     2 '_restr_torsion_weight_param                        ',
     3 '_restr_equal_distance_atom_site_label_1            ',
     4 '_restr_equal_distance_site_symmetry_1              ',
     5 '_restr_equal_distance_atom_site_label_2            ',
     6 '_restr_equal_distance_site_symmetry_2              ',
     7 '_restr_equal_distance_class_class_id               ',
     8 '_restr_equal_distance_class_target_weight_param    ',
     9 '_restr_equal_angle_atom_site_label_1               ',
     * '_restr_equal_angle_site_symmetry_1                 ',
C * 691-700
     1 '_restr_equal_angle_atom_site_label_2               ',
     2 '_restr_equal_angle_site_symmetry_2                 ',
     3 '_restr_equal_angle_atom_site_label_3               ',
     4 '_restr_equal_angle_site_symmetry_3                 ',
     5 '_restr_equal_angle_class_class_id                  ',
     6 '_restr_equal_angle_class_target_weight_param       ',
     7 '_restr_equal_torsion_atom_site_label_1             ',
     8 '_restr_equal_torsion_site_symmetry_1               ',
     9 '_restr_equal_torsion_atom_site_label_2             ',
     * '_restr_equal_torsion_site_symmetry_2               '/)
      CIFDIR(701:800) = (/
C * 701-710
     1 '_restr_equal_torsion_atom_site_label_3             ',
     2 '_restr_equal_torsion_site_symmetry_3               ',
     3 '_restr_equal_torsion_atom_site_label_4             ',
     4 '_restr_equal_torsion_site_symmetry_4               ',
     5 '_restr_equal_torsion_class_class_id                ',
     6 '_restr_equal_torsion_class_target_weight_param     ',
     7 '_journal_paper_doi                                 ',
     8 '_olex2_refinement_description                      ',
     9 '_platon_Bijvoet-pair_Hooft_y                       ',
     * '_platon_Bijvoet-pair_Hooft_P2-true                 ',
C * 711-720
     1 '_platon_Bijvoet-pair_Hooft_P2-false                ',
     2 '_platon_Bijvoet-pair_Hooft_P3-true                 ',
     3 '_platon_Bijvoet-pair_Hooft_P3-rac-twin             ',
     4 '_platon_Bijvoet-pair_Hooft_P3-false                ',
     5 '_platon_Bijvoet-pair_Parsons_z                     ',
     6 '_audit_block_doi                                   ',
     7 '_citation_id                                       ',
     8 '_citation_doi                                      ',
     9 '_citation_year                                     ',
     * '_chemical_oxdiff_formula                           ',
C * 721-730
     1 '_chemical_oxdiff_usercomment                       ',
     2 '_exptl_crystal_colour_primary                      ',
     3 '_diffrn_ambient_environment                        ',
     4 '_reflns_odcompleteness_completeness                ',
     5 '_reflns_odcompleteness_iscentric                   ',
     6 '_reflns_odcompleteness_theta                       ',
     7 '_exptl_oxdiff_crystal_face_indexfrac_h             ',
     8 '_exptl_oxdiff_crystal_face_indexfrac_k             ',
     9 '_exptl_oxdiff_crystal_face_indexfrac_l             ',
     * '_exptl_oxdiff_crystal_face_x                       ',
C * 731-740
     1 '_exptl_oxdiff_crystal_face_y                       ',
     2 '_exptl_oxdiff_crystal_face_z                       ',
     3 '_olex2_submission_special_instructions             ',
     4 '_oxford_refln_omitted_index_h                      ',
     5 '_oxford_refln_omitted_index_k                      ',
     6 '_oxford_refln_omitted_index_l                      ',
     7 '_oxford_refln_omitted_flag                         ',
     8 '_oxford_refln_omitted_details                      ',
     9 '_journal_language                                  ',
     * '_twin_refln_datum_id                               ',
C * 741-750
     1 '_twin_refln_individual_id                          ',
     2 '_twin_refln_index_h                                ',
     3 '_twin_refln_index_k                                ',
     4 '_twin_refln_index_l                                ',
     5 '_twin_refln_F_squared_calc                         ',
     6 '_twin_refln_F_squared_meas                         ',
     7 '_twin_refln_F_squared_sigma                        ',
     8 '_twin_refln_include_status                         ',
     9 '_oxford_structure_analysis_title                   ',
     * '_oxford_diffrn_wilson_b_factor                     ',
C * 751-760
     1 '_oxford_diffrn_wilson_scale                        ',
     2 '_oxford_reflns_threshold_expression_ref            ',
     3 '_oxford_refine_ls_r_factor_ref                     ',
     4 '_oxford_reflns_number_all                          ',
     5 '_oxford_atom_site_special_shape                    ',
     6 '_oxford_refine_ls_scale                            ',
     7 '_vrn_publ_code                                     ',
     8 '_chemical_absolute_configuration                   ',
     9 '_geom_extra_tableB_col_7                           ',
     * '_geom_extra_tableB_col_8                           ',
C * 761-770
     1 '_iucr_refine_fcf_details                           ',
     2 '_iucr_refine_fcf_checksum                          ',
     3 '_refln_include_status                              ',
     4 '_geom_extra_table_head_C                           ',
     5 '_geom_extra_tableC_col_1                           ',
     6 '_geom_extra_tableC_col_2                           ',
     7 '_geom_extra_tableC_col_3                           ',
     8 '_geom_extra_tableC_col_4                           ',
     9 '_geom_extra_tableC_col_5                           ',
     * '_geom_extra_tableC_col_6                           ',
C * 771-780
     1 '_geom_extra_tableC_col_7                           ',
     2 '_geom_extra_tableC_col_8                           ',
     3 '_geom_table_headnote_C                             ',
     4 '_geom_table_footnote_C                             ',
     5 '_geom_extra_table_head_D                           ',
     6 '_geom_extra_tableD_col_1                           ',
     7 '_geom_extra_tableD_col_2                           ',
     8 '_geom_extra_tableD_col_3                           ',
     9 '_geom_extra_tableD_col_4                           ',
     * '_geom_extra_tableD_col_5                           ',
C * 781-790
     1 '_geom_extra_tableD_col_6                           ',
     2 '_geom_extra_tableD_col_7                           ',
     3 '_geom_extra_tableD_col_8                           ',
     4 '_geom_table_headnote_D                             ',
     5 '_geom_table_footnote_D                             ',
     6 '_twin_dimensionality                               ',
     7 '_twin_formation_mechanism                          ',
     8 '_twin_morphology                                   ',
     9 '_twin_special_details                              ',
     * '_twin_individual_twin_lattice_type                 ',
C * 790-800
     1 '_twin_refln_F_squared_calc_individual              ',
     2 '_oxdiff_exptl_absorpt_empirical_full_min           ',
     3 '_oxdiff_exptl_absorpt_emeitical_full_max           ',
     4 '_oxdiff_exptl_absorpt_empirical_details            ',
     5 '_publcif_info_cif.paper_type                       ',
     6 '_publ_contact_author_id_orcid                      ',
     7 '_exptl_crystal_colour_lustre                       ',
     8 '_exptl_crystal_colour_modifier                     ',
     9 '_exptl_crystal_colour_primary                      ',
     * '_refine_ls_r_fsqd_factor                           '/)
      CIFDIR(801:900) = (/
C * 801-810
     1 '_atom_rho_multipole_atom_label                     ',
     2 '_atom_rho_multipole_coeff_pv                       ',
     3 '_atom_rho_multipole_coeff_p00                      ',
     4 '_atom_rho_multipole_coeff_p11                      ',
     5 '_atom_rho_multipole_coeff_p1-1                     ',
     6 '_atom_rho_multipole_coeff_p10                      ',
     7 '_atom_rho_multipole_coeff_p20                      ',
     8 '_atom_rho_multipole_coeff_p21                      ',
     9 '_atom_rho_multipole_coeff_p2-1                     ',
     * '_atom_rho_multipole_coeff_p22                      ',
C * 811-820
     1 '_atom_rho_multipole_coeff_p2-2                     ',
     2 '_atom_rho_multipole_coeff_p30                      ',
     3 '_atom_rho_multipole_coeff_p31                      ',
     4 '_atom_rho_multipole_coeff_p3-1                     ',
     5 '_atom_rho_multipole_coeff_p32                      ',
     6 '_atom_rho_multipole_coeff_p3-2                     ',
     7 '_atom_rho_multipole_coeff_p33                      ',
     8 '_atom_rho_multipole_coeff_p3-3                     ',
     9 '_atom_rho_multipole_coeff_p40                      ',
     * '_atom_rho_multipole_coeff_p41                      ',
C * 821-830
     1 '_atom_rho_multipole_coeff_p4-1                     ',
     2 '_atom_rho_multipole_coeff_p42                      ',
     3 '_atom_rho_multipole_coeff_p4-2                     ',
     4 '_atom_rho_multipole_coeff_p43                      ',
     5 '_atom_rho_multipole_coeff_p4-3                     ',
     6 '_atom_rho_multipole_coeff_p44                      ',
     7 '_atom_rho_multipole_coeff_p4-4                     ',
     8 '_atom_rho_multipole_kappa                          ',
     9 '_atom_rho_multipole_kappa_prime0                   ',
     * '_atom_rho_multipole_kappa_prime1                   ',
C * 831-840
     1 '_atom_rho_multipole_kappa_prime2                   ',
     2 '_atom_rho_multipole_kappa_prime3                   ',
     3 '_atom_rho_multipole_kappa_prime4                   ',
     4 '_atom_local_axes_atom_label                        ',
     5 '_atom_local_axes_atom0                             ',
     6 '_atom_local_axes_ax1                               ',
     7 '_atom_local_axes_atom1                             ',
     8 '_atom_local_axes_atom2                             ',
     9 '_atom_local_axes_ax2                               ',
     * '_oxdiff_exptl_absorpt_empirical_full_max           ',
C * 841-850
     1 '_oxdiff_twin_integration_method                    ',
     2 '_oxdiff_twin_items                                 ',
     3 '_oxdiff_twin_reflns_isolated                       ',
     4 '_oxdiff_twin_reflns_overlapped                     ',
     5 '_olex2_date_sample_date_collection                 ',
     6 '_audit_author_name                                 ',
     7 '_diffrn_source_target                              ',
     8 '_geom_extra_table_head_F                           ',
     9 '_geom_extra_tableF_col_1                           ',
     * '_geom_extra_tableF_col_2                           ',
C * 851-860
     1 '_geom_extra_tableF_col_3                           ',
     2 '_geom_extra_tableF_col_4                           ',
     3 '_geom_extra_tableF_col_5                           ',
     4 '_geom_extra_tableF_col_6                           ',
     5 '_geom_extra_tableF_col_7                           ',
     6 '_geom_extra_tableF_col_8                           ',
     7 '_geom_table_headnote_F                             ',
     8 '_geom_table_footnote_F                             ',
     9 '_geom_extra_table_head_G                           ',
     * '_geom_extra_tableG_col_1                           ',
C * 861-870
     1 '_geom_extra_tableG_col_2                           ',
     2 '_geom_extra_tableG_col_3                           ',
     3 '_geom_extra_tableG_col_4                           ',
     4 '_geom_extra_tableG_col_5                           ',
     5 '_geom_extra_tableG_col_6                           ',
     6 '_geom_extra_tableG_col_7                           ',
     7 '_geom_extra_tableG_col_8                           ',
     8 '_geom_table_headnote_G                             ',
     9 '_geom_table_footnote_G                             ',
     * '_shelx_title                                       ',
C * 871-880
     1 '_shelx_refln_list_code                             ',
     2 '_shelx_F_calc_maximum                              ',
     3 '_audit_contact_author_address                      ',
     4 '_audit_contact_author_email                        ',
     5 '_audit_contact_author_name                         ',
     6 '_audit_contact_author_phone                        ',
     7 '_ccdc_journal_manuscript_code                      ',
     8 '_gsas_exptl_extinct_corr_t_min                     ',
     9 '_gsas_exptl_extinct_corr_t_max                     ',
     * '_gsas_i100_meas                                    ',
C * 881-890
     1 '_refln_d_spacing                                   ',
     2 '_iucr_refine_fab_details                           ',
     3 '_olex2_date_sample_data_collection                 ',
     4 '_olex2_date_sample_submission                      ',
     5 '_olex2_submission_original_sample_id               ',
     6 '_publcif_funding_html                              ',
     7 '_atom_type_scat_dispersion_source                  ',
     8 '_refine_ls_d_res_high                              ',
     9 '_refine_ls_d_res_low                               ',
     * '_atom_type_scat_length_neutron                     ',
C * 891-900
     1 '_shelx_include_file_name                           ',
     2 '_shelx_include_file                                ',
     3 '_shelx_include_file_checksum                       ',
     4 '_audit_author_email                                ',
     5 '_audit_author_address                              ',
     6 '_diffrn_radiation_xray_symbol                      ',
     7 '_diffrn_refln_intensity_u                          ',
     8 '_restr_rigu_atom_site_label_1                      ',
     9 '_restr_rigu_atom_site_label_2                      ',
     * '_restr_rigu_u13_diff                               '/)
      CIFDIR(901:NP34) = (/
C * 901-910
     1 '_restr_rigu_u23_diff                               ',
     2 '_restr_rigu_u33_diff                               ',
     3 '_restr_rigu_target_weight_param                    ',
     4 '_olex2_diffrn_ambient_temperature_device           ',
     5 '_shelx_fcf_file                                    ',
     6 '_reflns_number_all                                 ',
     7 '_restr_rigid_body_class.class_id                   ',
     8 '_restr_rigid_body_class.details                    ',
     9 '_restr_rigid_body.id                               ',
     * '_restr_rigid_body.atom_site_label                  ',
C * 911-920
     1 '_restr_rigid_body.site_symmetry                    ',
     2 '_restr_rigid_body.class_id                         ',
     3 '_restr_rigid_body.details                          ',
     4 '_refine_ls_r_factor                                ',
     5 '_gsas_proc_ls_prof_r_b_factor                      ',
     6 '_gsas_proc_ls_prof_wr_b_factor                     ',
     7 '_symmetry_space_group_name_H-M_alt                 ',
     8 '_smtbx_masks_void_probe_radius                     ',
     9 '_smtbx_masks_void_truncation_radius                ',
     * '_olex2_exptl_crystal_mounting_method               ',
C * 921-330
     1 '_diffrn_measurement_device_details                 ',
     2 '_diffrn_measurement_ambient_temperature_device_make',
     3 '_space_group_name_H-M_full                         ',
     4 '_oxford_refine_reflns_threshold_expression         ',
     5 '_refine_ls_r_factor_ref                            ',
     6 '_audit_xyz                                         ',
     7 '_publcif_datablock_id                              ',
     8 '_publcif_info_datablock_id                         ',
     9 '_publcif_info_datablock_publ_exptl                 ',
     * '_publcif_info_datablock_publ_geom                  ',
C * 931-940
     1 '_publcif_info_datablock_structure                  ',
     2 '_publcif_info_tables_block_id                      ',
     3 '_publcif_info_tables_reference_item                ',
     4 '_publcif_info_cif_paper_type                       ',
     5 '_oxford_refine_ls_r_factor_all                     ',
     6 '_oxford_refine_ls_wr_factor_all                    ',
     7 '_pd_block_id                                       ',
     8 '_diffrn_oxdiff_scatteringfactors_ed                ',
     9 '_diffrn_frame_id                                   ',
     * '_diffrn_frame_h                                    ',
C * 941-950
     1 '_diffrn_frame_k                                    ',
     2 '_diffrn_frame_l                                    ',
     3 '_diffrn_frame_start_angle                          ',
     4 '_diffrn_frame_end_angle                            ',
     5 '_diffrn_frame_scale                                ',
     6 '_diffrn_oxdiff_digest_creation                     ',
     7 '_diffrn_oxdiff_digest_hkl                          ',
     8 '_diffrn_oxdiff_digest_hkl_ed                       ',
     9 '_diffrn_oxdiff_digest_od_ed                        ',
     * '_olex2_refine_details                              ',
C * 951-960
     1 '_refln_frame_id                                    ',
     2 '_refln_diffraction_start_angle                     ',
     3 '_refln_diffraction_end_angle                       ',
     4 '_refln_intensity_scale_factor                      ',
     5 '_oxdiff_exptl_crystal_thickness                    ',
     6 '_restr_chirality_atom_site_label_1                 ',
     7 '_restr_chirality_atom_site_label_2                 ',
     8 '_restr_chirality_atom_site_label_3                 ',
     9 '_restr_chirality_atom_site_label_4                 ',
     * '_restr_chirality_site_symmetry_1                   ',
C * 961-970
     1 '_restr_chirality_site_symmetry_2                   ',
     2 '_restr_chirality_site_symmetry_3                   ',
     3 '_restr_chirality_site_symmetry_4                   ',
     4 '_restr_chirality_volume_target                     ',
     5 '_restr_chirality_weight_param                      ',
     6 '_restr_chirality_diff                              ',
     7 '_restr_distance_diff                               ',
     8 '_restr_equal_distance_class_id                     ',
     9 '_restr_equal_distance_class_average                ',
     * '_restr_equal_distance_class_esd                    ',
C * 971-NP34
     1 '_restr_equal_distance_class_diff_max               ',
     2 '_restr_u_iso_atom_site_label                       ',
     3 '_restr_u_iso_weight_param                          ',
     4 '_restr_u_similar_atom_site_label_1                 ',
     5 '_restr_u_similar_atom_site_label_2                 ',
     6 '_restr_u_similar_weight_param                      '/)
      RETURN
      END SUBROUTINE PLA446
 
      SUBROUTINE DATE_TIME (DATIJD)
C * RETURN IN DATIJD A 20 CHARACTER LONG STRING EQUIVALENT TO THE
C * CHARACTERS 5-24 IN THE STRING RETURNED BY THE OLD FDATE ROUTINE
 
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: K
      INTEGER                         :: N
      CHARACTER(len=2)                :: T2
      CHARACTER(len=2)                :: T3
      CHARACTER(len=8)                :: DATE
      CHARACTER(len=10)               :: TIME
      CHARACTER(len=20)               :: DATIJD
      CHARACTER(len=3), DIMENSION(12) :: MONTHS = (/
     1  'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep',
     2  'Oct', 'Nov', 'Dec'/)
      CALL DATE_AND_TIME(DATE, TIME)
      READ (DATE, '(I4, 2I2)') K, N, I
      READ (TIME, '(I2, 2A)') J, T2, T3
      WRITE (DATIJD, 99999) MONTHS(N), I, J, T2, T3, K
      RETURN
99999 FORMAT (A, 2I3, ':', A, ':', A, I5)
      END SUBROUTINE DATE_TIME
 
      SUBROUTINE SPAWN (COMMAND, LU, WACHT, IER)
C * CALL SYSTEM HANDLER ROUTINE
      USE files
      IMPLICIT NONE
      CHARACTER(len = *), INTENT(IN)  :: COMMAND
      INTEGER,            INTENT(OUT) :: IER
      INTEGER                         :: LU
      LOGICAL,            INTENT(IN)  :: WACHT
C STRIP_END
      RETURN
      END SUBROUTINE SPAWN
 
      SUBROUTINE PRINTX (LU, STR, N1, N2)
      USE files
      IMPLICIT NONE
      INTEGER           :: LU
      INTEGER           :: N1
      INTEGER           :: N2
      CHARACTER(len=*)  :: STR
      CHARACTER(len=80) :: STR1
      CHARACTER(len=80) :: STR2
      STR1 = ' '
      STR2 = ' '
      IF (N1 == 2) WRITE (STR1, 99998)
      IF (N2 == 2) WRITE (STR2, 99998)
 
      IF (LU /= 0) THEN
        IF (LU == LU6) THEN
          IF (N1 > 0) CALL TRAILER(STR1)
          CALL TRAILER (STR)
          IF (N2 > 0) CALL TRAILER(STR2)
        ELSE
          IF (N1 > 0) WRITE (LU, 99999) STR1
          WRITE (LU, 99999) STR
          IF (N2 > 0) WRITE (Lu, 99999) STR2
        END IF
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT (6('** S-Abort **'))
      END SUBROUTINE PRINTX
 
      SUBROUTINE TRAILER(STR)
C * TRAILER LISTING ON UNIT 6
      USE files
      IMPLICIT NONE
      CHARACTER(len=*) :: STR
      IF (DOS) THEN
        WRITE (6, 99999) STR
      ELSE
        WRITE (LU6, 99999) STR
      END IF
      RETURN
99999 FORMAT (A)
      END SUBROUTINE TRAILER
 
      INTEGER FUNCTION FINDEXE (EXE, PADX, PROGRAMX)
C * GET PATH STRING TO EXECUTABLE INTO PADX
      USE files
      IMPLICIT NONE
      INTEGER             :: L
      INTEGER             :: LE
      INTEGER             :: LP
      INTEGER             :: LX
      INTEGER             :: I1
      INTEGER             :: I2
      INTEGER             :: LC
      INTEGER             :: LH
      INTEGER             :: IS
      INTEGER             :: NB
      CHARACTER(len=1024) :: P
      CHARACTER(len=*)    :: EXE
      CHARACTER(len=*)    :: PADX
      CHARACTER(len=256)  :: FILEX
      CHARACTER(len=1)    :: DELIM1
      CHARACTER(len=1)    :: DELIM2
      CHARACTER(len=4)    :: SUFFIX
      CHARACTER(len=*)    :: PROGRAMX
      CHARACTER(len=256)  :: COMPONENT
C * PROGRAMX = NAME OF PROGRAM EXECUTABLE SEARCHED FOR (e.g. shelxl)
C * EXE      = ENVIRONMENT VARIABLE WITH PATH TO EXECUTABLE (WHEN PRESENT)
C * PADX     = PATH TO EXECUTABLE (OUTPUT) (e.g. /usr/local/bin/shelxl)
      IF (DOS) THEN
        DELIM1 = CHAR (92)
        DELIM2 = CHAR (59)
        SUFFIX = '.exe'
      ELSE
        DELIM1 = CHAR (47)
        DELIM2 = CHAR (58)
        SUFFIX = ' '
      END IF
C * FIND OUT WHETHER 'PROGRAM' IS AVAILABLE
      L  = LEN (PROGRAMX)
      LE = LEN (EXE)
      LP = LEN (PADX)
      IS = 0
      NB = 1
      CALL GET_ENVIRONMENT_VARIABLE (EXE, VALUE = PADX)
      IF (PADX(1:1) /= ' ') THEN
        CALL GEN039 (1, PADX, 1, LP, NB, IS)
        INQUIRE (FILE = PADX(1:IS), EXIST = EXST)
        IF (.NOT. EXST) THEN
          WRITE (6, 99999) PADX(1:IS)
          STOP
        END IF
      ELSE
C * Get the executable search path from the environment
        CALL GET_ENVIRONMENT_VARIABLE ('PATH', VALUE = P)
        LX = LEN (P)
        NB = 0
        LH = LX
        CALL GEN039 (1, P, 1, LX, NB, LH)
        IF (LH > 0) THEN
          I2 = 0
          DO
            I2 = I2 + 1
            I1 = I2
            IF (I2 > LH) EXIT
C * Look for separating ":" .OR. ";" character
            DO
              IF (ICHAR (P(I2:I2)) == ICHAR (DELIM2) .OR. I2 > LH)
     1          EXIT
              I2 = I2 + 1
            END DO
            IF (I2 == I1) THEN
C * Empty path component is equal to current directory.
              COMPONENT = '.'
              LC = 1
            ELSE
C * Found path component
              COMPONENT = P(I1:I2-1)
              LC = I2 - I1
            END IF
C * CHECK FOR TERMINATING SEPARATOR DELIM1
            IF (COMPONENT(LC:LC) == DELIM1) LC = LC - 1
C * Build file name, and see if it exists
            FILEX = COMPONENT(1:LC)//DELIM1//PROGRAMX(1:L)//SUFFIX
            INQUIRE (FILE = FILEX, EXIST = EXST)
            IF (EXST) THEN
              PADX = FILEX(1:LP)
              CALL GEN039 (1, PADX, 1, LP, NB, IS)
              EXIT
            END IF
C * Next path component, if any
          END DO
        END IF
      END IF
      FINDEXE = IS
99999 FORMAT (/, 'Executable ', A, ' not found! ***', /)
      END FUNCTION FINDEXE
 
      BLOCK DATA ATOM_DATA
      INTEGER,          DIMENSION(92, 24)     :: IFUNTYP
      INTEGER,          DIMENSION(92, 24)     :: NPARMS
      INTEGER,          DIMENSION(92)         :: NORB
      DOUBLE PRECISION, DIMENSION(92, 24, 11) :: XSC
      DOUBLE PRECISION, DIMENSION(6,  24, 92) :: XNRG
      DOUBLE PRECISION, DIMENSION(92)         :: RELCOR
      DOUBLE PRECISION, DIMENSION(92)         :: XKPCOR
      DOUBLE PRECISION, DIMENSION(92, 24)     :: BINDNRG
      DOUBLE PRECISION, DIMENSION(92, 4)      :: DRAY
      DOUBLE PRECISION, DIMENSION(92, 4)      :: DCMP
      COMMON /ANOMD/ XSC, XNRG, RELCOR, XKPCOR, IFUNTYP, NPARMS, DRAY,
     1 DCMP, NORB, BINDNRG
C * DUMMY USE OF NOT USED H-ATOM ENTRY
      DATA (XNRG(I, 1, 1), I = 1, 5)/
     1 80.0002518D0,   26.7000599D0,   8.89995575D0,   3.00003362D0,
     2 1.00000000D0/
C * DATA FOR LI ELEMENT # 3
      DATA ((XNRG(I, J, 3), I = 1, 5), J = 1, 2)/
     1 24.8800831D0,   1.02811790D0,   0.218999997D0,  9.252656251D-02,
     2 6.027210504D-02,2.42666030D0,   0.100276709D0,  2.136000060D-02,
     3 9.024509229D-03,5.878594704D-03/
C * DATA FOR BE ELEMENT # 4
      DATA ((XNRG(I, J, 4), I = 1, 5), J = 1, 2)/
     1 50.4418144D0,   2.08440351D0,   0.444000006D0,  0.187588111D0,
     2 0.122195505D0,  3.82630682D0,   0.158114210D0,  3.367999941D-02,
     3 1.422965620D-02,9.269244038D-03/
C * DATA FOR B  ELEMENT # 5
      DATA ((XNRG(I, J, 5), I = 1, 5), J = 1, 3)/
     1 85.4329758D0,   3.53034091D0,   0.751999974D0,  0.317716777D0,
     2 0.206961751D0,  6.12118196D0,   0.252945185D0,  5.387999862D-02,
     3 2.276406996D-02,1.482858974D-02,2.13582444D0,   8.825852722D-02,
     4 1.879999973D-02,7.942919619D-03,5.174043588D-03/
C * DATA FOR C  ELEMENT # 6
      DATA ((XNRG(I, J, 6), I = 1, 5), J = 1, 3)/
     1 128.967453D0,   5.32931280D0,   1.13520002D0,   0.479617149D0,
     2 0.312424183D0,  8.86594391D0,   0.366366804D0,  7.804000378D-02,
     3 3.297156841D-02,2.147778682D-02,2.90835667D0,   0.120181821D0,
     4 2.559999935D-02,1.081589051D-02,7.045506500D-03/
C * DATA FOR N  ELEMENT # 7
      DATA ((XNRG(I, J, 7), I = 1, 5), J = 1, 4)/
     1 182.499390D0,   7.54140949D0,   1.60640001D0,   0.678697169D0,
     2 0.442105532D0,  11.9560728D0,   0.494059980D0,  0.105240002D0,
     3 4.446345195D-02,2.896363661D-02,4.18076277D0,   0.172761381D0,
     4 3.680000082D-02,1.554784272D-02,1.012791600D-02,4.18076277D0,
     5 0.172761381D0,  3.680000082D-02,1.554784272D-02,1.012791600D-02/
C * DATA FOR O  ELEMENT # 8
      DATA ((XNRG(I, J, 8), I = 1, 5), J = 1, 4)/
     1 241.757156D0,   9.99011421D0,   2.12800002D0,   0.899070919D0,
     2 0.585657716D0,  10.7700090D0,   0.445048332D0,  9.480000287D-02,
     3 4.005259648D-02,2.609039098D-02,3.22645831D0,   0.133326709D0,
     4 2.840000018D-02,1.199887879D-02,7.816108875D-03,3.22645831D0,
     5 0.133326709D0,  2.840000018D-02,1.199887879D-02,7.816108875D-03/
C * DATA FOR F  ELEMENT # 9
      DATA ((XNRG(I, J, 9), I = 1, 5), J = 1, 4)/
     1 311.466827D0,   12.8707218D0,   2.74160004D0,   1.15831435D0,
     2 0.754529715D0,  14.0873537D0,   0.582130730D0,  0.124000005D0,
     3 5.238947272D-02,3.412667289D-02,3.90810442D0,   0.161494330D0,
     4 3.440000117D-02,1.453385316D-02,9.467399679D-03,3.90810442D0,
     5 0.161494330D0,  3.440000117D-02,1.453385316D-02,9.467399679D-03/
C * DATA FOR NE ELEMENT #10
      DATA ((XNRG(I, J, 10), I = 1, 5), J = 1, 4)/
     1 393.946014D0,   16.2790031D0,   3.46759987D0,   1.46504617D0,
     2 0.954335868D0,  20.4493828D0,   0.845028460D0,  0.180000007D0,
     3 7.604923099D-02,4.953871667D-02,8.31608295D0,   0.343644917D0,
     4 7.320000231D-02,3.092668764D-02,2.014574595D-02,8.31608295D0,
     5 0.343644917D0,  7.320000231D-02,3.092668764D-02,2.014574595D-02/
C * DATA FOR NA ELEMENT #11
      DATA ((XNRG(I, J, 11), I = 1, 6), J = 1, 4)/
     1 22.8543644D0,   4.64584494D0,   2.14420009D0,   1.39372301D0,
     2 1.12486768D0,   1.07317209D0,   28.7654667D0,   1.18867338D0,
     3 0.253199995D0,  0.106975920D0,  6.968446076D-02,0.0D0,
     4 14.1327963D0,   0.584008574D0,  0.124399997D0,  5.255847052D-02,
     5 3.423675895D-02,0.0D0,          14.1327963D0,   0.584008574D0,
     6 0.124399997D0,  5.255847052D-02,3.423675895D-02,0.0D0/
C * DATA FOR MG ELEMENT #12
      DATA ((XNRG(I, J, 12), I = 1, 6), J = 1, 4)/
     1 27.8191833D0,   5.65509510D0,   2.60999990D0,   1.69649148D0,
     2 1.36923075D0,   1.30630505D0,   40.6261101D0,   1.67878985D0,
     3 0.357600003D0,  0.151084468D0,  9.841691703D-02,0.0D0,
     4 23.3577404D0,   0.965210319D0,  0.205600008D0,  8.686511964D-02,
     5 5.658422410D-02,0.0D0,          23.3577404D0,   0.965210319D0,
     6 0.205600008D0,  8.686511964D-02,5.658422410D-02,0.0D0/
C * DATA FOR AL ELEMENT #13
      DATA ((XNRG(I, J, 13), I = 1, 6), J = 1, 5)/
     1 33.2465858D0,   6.75838041D0,   3.11919999D0,   2.02746964D0,
     2 1.63636184D0,   1.56115961D0,   53.4864998D0,   2.21021891D0,
     3 0.47080001D0,   0.198910996D0,  0.129571274D0,  0.0D0,
     4 33.2188873D0,   1.37270176D0,   0.292400002D0,  0.123537749D0,
     5 8.047289401D-02,0.0D0,          33.2188873D0,   1.37270176D0,
     6 0.292400002D0,  0.123537749D0,  8.047289401D-02,0.0D0,
     7 3.80615973D0,   0.157281682D0,  3.350266069D-02,1.415473130D-02,
     8 9.220438078D-03,0.0D0/
C * DATA FOR SI ELEMENT #14
      DATA ((XNRG(I, J, 14), I = 1, 6), J = 1, 6)/
     1 39.2005310D0,   7.96870089D0,   3.67779994D0,   2.39055800D0,
     2 1.92940867D0,   1.84073889D0,   67.5738525D0,   2.79234958D0,
     3 0.594799995D0,  0.251300454D0,  0.163697943D0,  0.0D0,
     4 45.0795288D0,   1.86281824D0,   0.396800011D0,  0.167646304D0,
     5 0.109205350D0,  0.0D0,          45.0795288D0,   1.86281824D0,
     6 0.396800011D0,  0.167646304D0,  0.109205350D0,  0.0D0,
     7 5.16104650D0,   0.213269562D0,  4.542867094D-02,1.919342019D-02,
     8 1.250265632D-02,0.0D0,          2.30989599D0,   9.545166790D-02,
     9 2.033221535D-02,8.590274490D-03,5.595732480D-03,0.0D0/
C * DATA FOR P  ELEMENT #15
      DATA ((XNRG(I, J, 15), I = 1, 6), J = 1, 7)/
     1 45.7364426D0,   9.29732323D0,   4.29099989D0,   2.78913593D0,
     2 2.25109935D0,   2.14764547D0,   86.0237350D0,   3.55475307D0,
     3 0.757200003D0,  0.319913775D0,  0.208392873D0,  0.0D0,
     4 60.0757446D0,   2.48250580D0,   0.528800011D0,  0.223415747D0,
     5 0.145533741D0,  0.0D0,          60.0757446D0,   2.48250580D0,
     6 0.528800011D0,  0.223415747D0,  0.145533741D0,  0.0D0,
     7 6.57174635D0,   0.271563828D0,  5.784596503D-02,2.443967387D-02,
     8 1.592008211D-02,0.0D0,          2.90150857D0,   0.119898833D0,
     9 2.553972043D-02,1.079042256D-02,7.028916851D-03,0.0D0,
     * 2.87958717D0,   0.118992977D0,  2.534676343D-02,1.070889924D-02,
     1 6.975811906D-03,0.0D0/
C * DATA FOR S  ELEMENT #16
      DATA ((XNRG(I, J, 16), I = 1, 6), J = 1, 7)/
     1 52.6965675D0,   10.7121801D0,   4.94400024D0,   3.21358371D0,
     2 2.59366918D0,   2.47447205D0,   104.155533D0,   4.30401182D0,
     3 0.916800022D0,  0.387344092D0,  0.252317220D0,  0.0D0,
     4 74.8901901D0,   3.09468198D0,   0.659200013D0,  0.278509200D0,
     5 0.181421801D0,  0.0D0,          74.8901901D0,   3.09468198D0,
     6 0.659200013D0,  0.278509200D0,  0.181421801D0,  0.0D0,
     7 8.03807640D0,   0.332156867D0,  7.075292617D-02,2.989280969D-02,
     8 1.947227307D-02,0.0D0,          3.55075431D0,   0.146727577D0,
     9 3.125452623D-02,1.320490334D-02,8.601716720D-03,0.0D0,
     * 3.51496625D0,   0.145248711D0,  3.093951195D-02,1.307181176D-02,
     1 8.515020832D-03,0.0D0/
C * DATA FOR CL ELEMENT #17
      DATA ((XNRG(I, J, 17), I = 1, 6), J = 1, 7)/
     1 60.1661758D0,   12.2306061D0,   5.64479971D0,   3.66910148D0,
     2 2.96131539D0,   2.82522225D0,   122.787186D0,   5.07392645D0,
     3 1.08080006D0,   0.456633389D0,  0.297452480D0,  0.0D0,
     4 91.6132355D0,   3.78572750D0,   0.806400001D0,  0.340700567D0,
     5 0.221933454D0,  0.0D0,          90.8861542D0,   3.75568223D0,
     6 0.800000012D0,  0.337996602D0,  0.220172077D0,  0.0D0,
     7 7.95253801D0,   0.328622192D0,  7.000000030D-02,2.957470156D-02,
     8 1.926505752D-02,0.0D0,          3.09012914D0,   0.127693191D0,
     9 2.720000036D-02,1.149188355D-02,7.485850714D-03,0.0D0,
     * 3.09012914D0,   0.127693191D0,  2.720000036D-02,1.149188355D-02,
     1 7.485850714D-03,0.0D0/
C * DATA FOR AR ELEMENT #18
      DATA ((XNRG(I, J, 18), I = 1, 6), J = 1, 7)/
     1 68.2774429D0,   13.8794670D0,   6.40580034D0,   4.16374922D0,
     2 3.36054349D0,   3.20610285D0,   145.417831D0,   6.00909138D0,
     3 1.27999997D0,   0.540794551D0,  0.352275312D0,  0.0D0,
     4 112.380722D0,   4.64390087D0,   0.989199996D0,  0.417932779D0,
     5 0.272242785D0,  0.0D0,          111.426414D0,   4.60446596D0,
     6 0.980799973D0,  0.414383799D0,  0.269930959D0,  0.0D0,
     7 11.4970980D0,   0.475093782D0,  0.101199999D0,  4.275656864D-02,
     8 2.785176784D-02,0.0D0,          5.63494110D0,   0.232852280D0,
     9 4.960000142D-02,2.095578797D-02,1.365066878D-02,0.0D0,
     * 5.63494110D0,   0.232852280D0,  4.960000142D-02,2.095578797D-02,
     1 1.365066878D-02,0.0D0/
C * DATA FOR K  ELEMENT #19
      DATA ((XNRG(I, J, 19), I = 1, 6), J = 1, 7)/
     1 76.9003220D0,   15.6323299D0,   7.21479988D0,   4.68959618D0,
     2 3.78495240D0,   3.61100745D0,   171.365829D0,   7.08133841D0,
     3 1.50839996D0,   0.637292564D0,  0.415134460D0,  0.0D0,
     4 134.647827D0,   5.56404305D0,   1.18519998D0,   0.500741959D0,
     5 0.326184928D0,  0.0D0,          133.420868D0,   5.51334143D0,
     6 1.17439997D0,   0.496178985D0,  0.323212624D0,  0.0D0,
     7 15.4052029D0,   0.636588097D0,  0.135600001D0,  5.729041994D-02,
     8 3.731916845D-02,0.0D0,          8.08886719D0,   0.334255695D0,
     9 7.119999826D-02,3.008169681D-02,1.959531568D-02,0.0D0,
     * 8.08886719D0,   0.334255695D0,  7.119999826D-02,3.008169681D-02,
     1 1.959531568D-02,0.0D0/
C * DATA FOR CA ELEMENT #20
      DATA ((XNRG(I, J, 20), I = 1, 6), J = 1, 7)/
     1 86.0817184D0,   17.4987278D0,   8.07619953D0,   5.24950361D0,
     2 4.23685122D0,   4.04213810D0,   198.949783D0,   8.22118759D0,
     3 1.75119996D0,   0.739874542D0,  0.481956691D0,  0.0D0,
     4 159.050766D0,   6.57244349D0,   1.39999998D0,   0.591494024D0,
     5 0.385301143D0,  0.0D0,          157.414810D0,   6.50484133D0,
     6 1.38559997D0,   0.585410118D0,  0.381338030D0,  0.0D0,
     7 19.8586235D0,   0.820616543D0,  0.174799994D0,  7.385225594D-02,
     8 4.810759798D-02,0.0D0,          11.5425415D0,   0.476971626D0,
     9 0.101599999D0,  4.292556643D-02,2.796185389D-02,0.0D0,
     * 11.5425415D0,   0.476971626D0,  0.101599999D0,  4.292556643D-02,
     1 2.796185389D-02,0.0D0/
C * DATA FOR SC ELEMENT #21
      DATA ((XNRG(I, J, 21), I = 1, 6), J = 1, 7)/
     1 95.7747269D0,   19.4691277D0,   8.98559952D0,   5.84061050D0,
     2 4.71393061D0,   4.49729300D0,   227.397141D0,   9.39671612D0,
     3 2.00160003D0,   0.845667481D0,  0.550870538D0,  0.0D0,
     4 184.816986D0,   7.63717937D0,   1.62679994D0,   0.687316060D0,
     5 0.447719902D0,  0.0D0,          182.772049D0,   7.55267668D0,
     6 1.60880005D0,   0.679711163D0,  0.442766041D0,  0.0D0,
     7 24.4483738D0,   1.01027846D0,   0.215200007D0,  9.092108160D-02,
     8 5.922628939D-02,0.0D0,          14.6781130D0,   0.606542647D0,
     9 0.129199997D0,  5.458644778D-02,3.555779159D-02,0.0D0,
     * 14.6781130D0,   0.606542647D0,  0.129199997D0,  5.458644778D-02,
     1 3.555779159D-02,0.0D0/
C * DATA FOR TI ELEMENT #22
      DATA ((XNRG(I, J, 22), I = 1, 6), J = 1, 7)/
     1 105.870644D0,   21.5214291D0,   9.93280029D0,   6.45628738D0,
     2 5.21084070D0,   4.97136641D0,   256.162628D0,   10.5853901D0,
     3 2.25480008D0,   0.952643394D0,  0.620554984D0,  0.0D0,
     4 209.719788D0,   8.66623592D0,   1.84599996D0,   0.779927135D0,
     5 0.508047044D0,  0.0D0,          206.993210D0,   8.55356598D0,
     6 1.82200003D0,   0.769787252D0,  0.501441896D0,  0.0D0,
     7 27.4021740D0,   1.13233817D0,   0.241200000D0,  0.101905972D0,
     8 6.638187915D-02,0.0D0,          15.7233038D0,   0.649733007D0,
     9 0.138400003D0,  5.847340822D-02,3.808977082D-02,0.0D0,
     * 15.7233038D0,   0.649733007D0,  0.138400003D0,  5.847340822D-02,
     1 3.808977082D-02,0.0D0/
C * DATA FOR V  ELEMENT #23
      DATA ((XNRG(I, J, 23), I = 1, 6), J = 1, 8)/
     1 116.501617D0,   23.6824989D0,   10.9301996D0,   7.10459423D0,
     2 5.73408651D0,   5.47056532D0,   285.473389D0,   11.7965975D0,
     3 2.51279998D0,   1.06164730D0,   0.691560507D0,  0.0D0,
     4 236.531204D0,   9.77416229D0,   2.08200002D0,   0.879636109D0,
     5 0.572997808D0,  0.0D0,          233.077530D0,   9.63144684D0,
     6 2.05159998D0,   0.866792262D0,  0.564631283D0,  0.0D0,
     7 30.2196445D0,   1.24876428D0,   0.266000003D0,  0.112383865D0,
     8 7.320721447D-02,0.0D0,          17.1774826D0,   0.709823906D0,
     9 0.151199996D0,  6.388135254D-02,4.161252454D-02,0.0D0,
     * 17.1774826D0,   0.709823906D0,  0.151199996D0,  6.388135254D-02,
     1 4.161252454D-02,0.0D0,          0.999747634D0,  4.131250456D-02,
     2 8.799999952D-03,3.717962420D-03,2.421892947D-03,0.0D0/
C * DATA FOR CR ELEMENT #24
      DATA ((XNRG(I, J, 24), I = 1, 6), J = 1, 9)/
     1 127.674065D0,   25.9536381D0,   11.9784002D0,   7.78592062D0,
     2 6.28398228D0,   5.99518919D0,   315.647583D0,   13.0434837D0,
     3 2.77839994D0,   1.17386210D0,   0.764657617D0,  0.0D0,
     4 265.251221D0,   10.9609585D0,   2.33480000D0,   0.986443043D0,
     5 0.642572224D0,  0.0D0,          261.070465D0,   10.7881966D0,
     6 2.29800010D0,   0.970895171D0,  0.632444322D0,  0.0D0,
     7 33.6733170D0,   1.39148021D0,   0.296400011D0,  0.125227734D0,
     8 8.157375455D-02,0.0D0,          19.3133068D0,   0.798082411D0,
     9 0.170000002D0,  7.182427496D-02,4.678656533D-02,0.0D0,
     * 19.3133068D0,   0.798082411D0,  0.170000002D0,  7.182427496D-02,
     1 4.678656533D-02,0.0D0,          1.04519069D0,   4.319034144D-02,
     2 9.200000204D-03,3.886960680D-03,2.531978767D-03,0.0D0,
     3 1.04519069D0,   4.319034144D-02,9.200000204D-03,3.886960680D-03,
     4 2.531978767D-03,0.0D0/
C * DATA FOR MN ELEMENT #25
      DATA ((XNRG(I, J, 25), I = 1, 6), J = 1, 9)/
     1 139.394363D0,   28.3361435D0,   13.0780001D0,   8.50065708D0,
     2 6.86084270D0,   6.54553890D0,   349.457245D0,   14.4405975D0,
     3 3.07599998D0,   1.29959691D0,   0.846561670D0,  0.0D0,
     4 296.016174D0,   12.2322559D0,   2.60559988D0,   1.10085487D0,
     5 0.717100441D0,  0.0D0,          290.972015D0,   12.0238161D0,
     6 2.56119990D0,   1.08209610D0,   0.704880893D0,  0.0D0,
     7 38.1267395D0,   1.57550859D0,   0.335599989D0,  0.141789570D0,
     8 9.236218780D-02,0.0D0,          22.0853348D0,   0.912630737D0,
     9 0.194399998D0,  8.213317394D-02,5.350181460D-02,0.0D0,
     * 22.0853348D0,   0.912630737D0,  0.194399998D0,  8.213317394D-02,
     1 5.350181460D-02,0.0D0,          3.29989052D0,   0.136361137D0,
     2 2.904636599D-02,1.227196585D-02,7.993998006D-03,0.0D0,
     3 3.24635458D0,   0.134148881D0,  2.857512981D-02,1.207287051D-02,
     4 7.864307612D-03,0.0D0/
C * DATA FOR FE ELEMENT #26
      DATA ((XNRG(I, J, 26), I = 1, 6), J = 1, 9)/
     1 151.609222D0,   30.8191853D0,   14.2240000D0,   9.24555302D0,
     2 7.46204519D0,   7.11911201D0,   384.493866D0,   15.8884125D0,
     3 3.38439989D0,   1.42989457D0,   0.931437969D0,  0.0D0,
     4 327.690002D0,   13.5411119D0,   2.88440013D0,   1.21864665D0,
     5 0.793830454D0,  0.0D0,          321.782410D0,   13.2969923D0,
     6 2.83240008D0,   1.19667697D0,   0.779519260D0,  0.0D0,
     7 42.2166176D0,   1.74451435D0,   0.371600002D0,  0.156999409D0,
     8 0.102269933D0,  0.0D0,          24.5392609D0,   1.01403415D0,
     9 0.216000006D0,  9.125907719D-02,5.944646150D-02,0.0D0,
     * 24.5392609D0,   1.01403415D0,   0.216000006D0,  9.125907719D-02,
     1 5.944646150D-02,0.0D0,          1.63595068D0,   6.760227680D-02,
     2 1.439999975D-02,6.083938293D-03,3.963097464D-03,0.0D0,
     3 1.63595068D0,   6.760227680D-02,1.439999975D-02,6.083938293D-03,
     4 3.963097464D-03,0.0D0/
C * DATA FOR CO ELEMENT #27
      DATA ((XNRG(I, J, 27), I = 1, 6), J = 1, 9)/
     1 164.333557D0,   33.4057961D0,   15.4177999D0,   10.0215197D0,
     2 8.08832359D0,   7.71660900D0,   420.621094D0,   17.3812962D0,
     3 3.70239997D0,   1.56424820D0,   1.01895642D0,   0.0D0,
     4 360.636230D0,   14.9025459D0,   3.17440009D0,   1.34117043D0,
     5 0.873642802D0,  0.0D0,          353.819794D0,   14.6208706D0,
     6 3.11439991D0,   1.31582069D0,   0.857129872D0,  0.0D0,
     7 45.7611771D0,   1.89098597D0,   0.402799994D0,  0.170181274D0,
     8 0.110856637D0,  0.0D0,          27.0386295D0,   1.11731541D0,
     9 0.238000005D0,  0.100553982D0,  6.550119072D-02,0.0D0,
     * 27.0386295D0,   1.11731541D0,   0.238000005D0,  0.100553982D0,
     1 6.550119072D-02,0.0D0,          1.31784916D0,   5.445738882D-02,
     2 1.159999985D-02,4.900950473D-03,3.192495089D-03,0.0D0,
     3 1.31784916D0,   5.445738882D-02,1.159999985D-02,4.900950473D-03,
     4 3.192495089D-03,0.0D0/
C * DATA FOR NI ELEMENT #28
      DATA ((XNRG(I, J, 28), I = 1, 6), J = 1, 9)/
     1 177.633469D0,   36.1094093D0,   16.6655998D0,   10.8325853D0,
     2 8.74293137D0,   8.34113312D0,   21.4900513D0,   4.36850691D0,
     3 2.01620007D0,   1.31052339D0,   1.05771756D0,   1.00910807D0,
     4 396.218170D0,   16.3728962D0,   3.48760009D0,   1.47349608D0,
     5 0.959840178D0,  0.0D0,          388.401947D0,   16.0499077D0,
     6 3.41880012D0,   1.44442844D0,   0.940905392D0,  0.0D0,
     7 50.8053589D0,   2.09942627D0,   0.447200000D0,  0.188940093D0,
     8 0.123076193D0,  0.0D0,          30.9467335D0,   1.27880979D0,
     9 0.272399992D0,  0.115087837D0,  7.496859133D-02,0.0D0,
     * 30.9467335D0,   1.27880979D0,   0.272399992D0,  0.115087837D0,
     1 7.496859133D-02,0.0D0,          1.63595068D0,   6.760227680D-02,
     2 1.439999975D-02,6.083938293D-03,3.963097464D-03,0.0D0,
     3 1.63595068D0,   6.760227680D-02,1.439999975D-02,6.083938293D-03,
     4 3.963097464D-03,0.0D0/
C * DATA FOR CU ELEMENT #29
      DATA ((XNRG(I, J, 29), I = 1, 6), J = 1, 9)/
     1 191.406631D0,   38.9092216D0,   17.9577999D0,   11.6725111D0,
     2 9.42083168D0,   8.98787880D0,   23.3659821D0,   4.74984646D0,
     3 2.19219995D0,   1.42492282D0,   1.15004885D0,   1.09719610D0,
     4 432.163635D0,   17.8582687D0,   3.80399990D0,   1.60717380D0,
     5 1.04691827D0,   0.0D0,          423.120483D0,   17.4845772D0,
     6 3.72440004D0,   1.57354307D0,   1.02501106D0,   0.0D0,
     7 54.4408035D0,   2.24965358D0,   0.479200006D0,  0.202459961D0,
     8 0.131883070D0,  0.0D0,          33.4461021D0,   1.38209105D0,
     9 0.294400007D0,  0.124382742D0,  8.102332801D-02,0.0D0,
     * 33.4461021D0,   1.38209105D0,   0.294400007D0,  0.124382742D0,
     1 8.102332801D-02,0.0D0,          0.727089226D0,  3.004545718D-02,
     2 6.400000304D-03,2.703972859D-03,1.761376741D-03,0.0D0,
     3 0.727089226D0,  3.004545718D-02,6.400000304D-03,2.703972859D-03,
     4 1.761376741D-03,0.0D0/
C * DATA FOR ZN ELEMENT #30
      DATA ((XNRG(I, J, 30), I = 1, 6), J = 1, 9)/
     1 205.896057D0,   41.8546371D0,   19.3171997D0,   12.5561171D0,
     2 10.1339865D0,   9.66825867D0,   25.4444256D0,   5.17235374D0,
     3 2.38720012D0,   1.55167222D0,   1.25234771D0,   1.19479358D0,
     4 22.2297649D0,   4.51887608D0,   2.08559990D0,   1.35563314D0,
     5 1.09412551D0,   1.04384279D0,   21.7373333D0,   4.41877460D0,
     6 2.03940010D0,   1.32560337D0,   1.06988859D0,   1.02071965D0,
     7 61.7571373D0,   2.55198598D0,   0.543600023D0,  0.229668677D0,
     8 0.149606928D0,  0.0D0,          39.3537025D0,   1.62621033D0,
     9 0.346399993D0,  0.146352515D0,  9.533450752D-02,0.0D0,
     * 39.3537025D0,   1.62621033D0,   0.346399993D0,  0.146352515D0,
     1 9.533450752D-02,0.0D0,          3.68088913D0,   0.152105123D0,
     2 3.240000084D-02,1.368886139D-02,8.916969411D-03,0.0D0,
     3 3.68088913D0,   0.152105123D0,  3.240000084D-02,1.368886139D-02,
     4 8.916969411D-03,0.0D0/
C * DATA FOR GA ELEMENT #31
      DATA ((XNRG(I, J, 31), I = 1, 6), J = 1, 9)/
     1 220.999420D0,   44.9248581D0,   20.7341995D0,   13.4771624D0,
     2 10.8773575D0,   10.3774672D0,   27.6635666D0,   5.62346125D0,
     3 2.59540009D0,   1.68700147D0,   1.36157143D0,   1.29899764D0,
     4 24.3508453D0,   4.95004988D0,   2.28460002D0,   1.48498249D0,
     5 1.19852281D0,   1.14344227D0,   23.7774067D0,   4.83348131D0,
     6 2.23079991D0,   1.45001268D0,   1.17029881D0,   1.11651540D0,
     7 71.8455048D0,   2.96886683D0,   0.632400036D0,  0.267186314D0,
     8 0.174046025D0,  0.0D0,          48.5332031D0,   2.00553417D0,
     9 0.427199990D0,  0.180490181D0,  0.117571890D0,  0.0D0,
     * 46.7609253D0,   1.93229842D0,   0.411599994D0,  0.173899248D0,
     1 0.113278531D0,  0.0D0,          7.90709448D0,   0.326744318D0,
     2 6.960000098D-02,2.940570191D-02,1.915496960D-02,0.0D0,
     3 7.90709448D0,   0.326744318D0,  6.960000098D-02,2.940570191D-02,
     4 1.915496960D-02,0.0D0/
C * DATA FOR GE ELEMENT #32
      DATA ((XNRG(I, J, 32), I = 1, 6), J = 1, 9)/
     1 236.689011D0,   48.1142426D0,   22.2061996D0,   14.4339571D0,
     2 11.6495829D0,   11.1142035D0,   30.1491718D0,   6.12873650D0,
     3 2.82859993D0,   1.83858073D0,   1.48391032D0,   1.41571426D0,
     4 26.5998287D0,   5.40722418D0,   2.49559999D0,   1.62213182D0,
     5 1.30921543D0,   1.24904776D0,   25.9368572D0,   5.27245522D0,
     6 2.43339992D0,   1.58170199D0,   1.27658463D0,   1.21791673D0,
     7 81.7975388D0,   3.38011384D0,   0.720000029D0,  0.304196924D0,
     8 0.198154882D0,  0.0D0,          58.1216927D0,   2.40175867D0,
     9 0.511600018D0,  0.216148809D0,  0.140800044D0,  0.0D0,
     * 54.8952332D0,   2.26843190D0,   0.483200014D0,  0.204149932D0,
     1 0.132983938D0,  0.0D0,          13.0421619D0,   0.538940370D0,
     2 0.114799999D0,  4.850250855D-02,3.159469366D-02,0.0D0,
     3 13.0421619D0,   0.538940370D0,  0.114799999D0,  4.850250855D-02,
     4 3.159469366D-02,0.0D0/
C * DATA FOR AS ELEMENT #33
      DATA ((XNRG(I, J, 33), I = 1, 6), J = 1, 9)/
     1 252.966965D0,   51.4232330D0,   23.7334003D0,   15.4266319D0,
     2 12.4507666D0,   11.8785667D0,   32.5409851D0,   6.61494493D0,
     3 3.05300021D0,   1.98444009D0,   1.60163271D0,   1.52802658D0,
     4 28.9617939D0,   5.88736582D0,   2.71720004D0,   1.76617110D0,
     5 1.42546880D0,   1.35995865D0,   28.2050266D0,   5.73353004D0,
     6 2.64619994D0,   1.72002137D0,   1.38822162D0,   1.32442307D0,
     7 92.4766541D0,   3.82140660D0,   0.814000010D0,  0.343911529D0,
     8 0.224025086D0,  0.0D0,          66.5286636D0,   2.74915934D0,
     9 0.585600019D0,  0.247413501D0,  0.161165968D0,  0.0D0,
     * 63.8475227D0,   2.63836670D0,   0.562000036D0,  0.237442613D0,
     1 0.154670894D0,  0.0D0,          18.7225475D0,   0.773670495D0,
     2 0.164800003D0,  6.962729990D-02,4.535545036D-02,0.0D0,
     3 18.7225475D0,   0.773670495D0,  0.164800003D0,  6.962729990D-02,
     4 4.535545036D-02,0.0D0/
C * DATA FOR SE ELEMENT #34
      DATA ((XNRG(I, J, 34), I = 1, 6), J = 1, 9)/
     1 269.831146D0,   54.8513908D0,   25.3155994D0,   16.4550571D0,
     2 13.2808037D0,   12.6704578D0,   35.2568169D0,   7.16702080D0,
     3 3.30780005D0,   2.15005922D0,   1.73530328D0,   1.65555394D0,
     4 31.4687195D0,   6.39697456D0,   2.95239997D0,   1.91905034D0,
     5 1.54885697D0,   1.47767615D0,   30.6074982D0,   6.22190523D0,
     6 2.87160015D0,   1.86653066D0,   1.50646865D0,   1.43723583D0,
     7 105.200722D0,   4.34720182D0,   0.925999999D0,  0.391231060D0,
     8 0.254849195D0,  0.0D0,          76.4352493D0,   3.15852857D0,
     9 0.672800004D0,  0.284255117D0,  0.185164720D0,  0.0D0,
     * 73.5723343D0,   3.04022455D0,   0.647599995D0,  0.273608238D0,
     1 0.178229287D0,  0.0D0,          25.7662239D0,   1.06473589D0,
     2 0.226799995D0,  9.582202882D-02,6.241878495D-02,0.0D0,
     3 25.7662239D0,   1.06473589D0,   0.226799995D0,  9.582202882D-02,
     4 6.241878495D-02,0.0D0/
C * DATA FOR BR ELEMENT #35
      DATA ((XNRG(I, J, 35), I = 1, 6), J =  1, 9)/
     1 287.223999D0,   58.3870163D0,   26.9473991D0,   17.5157223D0,
     2 14.1368608D0,   13.4871740D0,   37.9875755D0,   7.72213030D0,
     3 3.56400013D0,   2.31658840D0,   1.86970818D0,   1.78378201D0,
     4 34.0225410D0,   6.91611624D0,   3.19199991D0,   2.07478952D0,
     5 1.67455339D0,   1.59759593D0,   33.0398102D0,   6.71634674D0,
     6 3.09980011D0,   2.01485991D0,   1.62618446D0,   1.55144989D0,
     7 116.561485D0,   4.81666231D0,   1.02600002D0,   0.433480620D0,
     8 0.282370687D0,  0.0D0,          86.0237350D0,   3.55475307D0,
     9 0.757200003D0,  0.319913775D0,  0.208392873D0,  0.0D0,
     * 82.4791794D0,   3.40828133D0,   0.726000011D0,  0.306731910D0,
     1 0.199806154D0,  0.0D0,          31.8555946D0,   1.31636655D0,
     2 0.280400008D0,  0.118467800D0,  7.717031240D-02,0.0D0,
     3 31.3557224D0,   1.29571033D0,   0.275999993D0,  0.116608821D0,
     4 7.595936954D-02,0.0D0/
C * DATA FOR KR ELEMENT #36
      DATA ((XNRG(I, J, 36), I = 1, 6), J = 1, 9)/
     1 305.384277D0,   62.0786438D0,   28.6511993D0,   18.6231861D0,
     2 15.0306911D0,   14.3399258D0,   40.9506912D0,   8.32447338D0,
     3 3.84200001D0,   2.49728751D0,   2.01554966D0,   1.92292106D0,
     4 36.8193817D0,   7.48465967D0,   3.45440006D0,   2.24534869D0,
     5 1.81221104D0,   1.72892725D0,   35.7044830D0,   7.25802231D0,
     6 3.34979987D0,   2.17735887D0,   1.75733674D0,   1.67657483D0,
     7 131.026016D0,   5.41437912D0,   1.15331995D0,   0.487272769D0,
     8 0.317411065D0,  0.0D0,          101.201729D0,   4.18195200D0,
     9 0.890799999D0,  0.376359195D0,  0.245161608D0,  0.0D0,
     * 97.1572952D0,   4.01482391D0,   0.855199993D0,  0.361318350D0,
     1 0.235363945D0,  0.0D0,          40.3988914D0,   1.66940069D0,
     2 0.355599999D0,  0.150239483D0,  9.786649048D-02,0.0D0,
     3 40.3988914D0,   1.66940069D0,   0.355599999D0,  0.150239483D0,
     4 9.786649048D-02,0.0D0/
C * DATA FOR RB ELEMENT #37
      DATA ((XNRG(I, J, 37), I = 1, 6), J = 1, 9)/
     1 324.017792D0,   65.8664780D0,   30.3993988D0,   19.7595100D0,
     2 15.9478130D0,   15.2148991D0,   44.0225258D0,   8.94891739D0,
     3 4.13019991D0,   2.68461657D0,   2.16674209D0,   2.06716514D0,
     4 39.7334671D0,   8.07703590D0,   3.72779989D0,   2.42305779D0,
     5 1.95563912D0,   1.86576390D0,   38.4650841D0,   7.81919861D0,
     6 3.60879993D0,   2.34570813D0,   1.89321065D0,   1.80620444D0,
     7 146.372147D0,   6.04852581D0,   1.28840005D0,   0.544343531D0,
     8 0.354587138D0,  0.0D0,          112.426170D0,   4.64577866D0,
     9 0.989600003D0,  0.418101788D0,  0.272352874D0,  0.0D0,
     * 108.381729D0,   4.47865057D0,   0.953999996D0,  0.403060913D0,
     1 0.262555212D0,  0.0D0,          50.8053589D0,   2.09942627D0,
     2 0.447200000D0,  0.188940093D0,  0.123076193D0,  0.0D0,
     3 50.1237106D0,   2.07125854D0,   0.441199988D0,  0.186405122D0,
     4 0.121424899D0,  0.0D0/
C * DATA FOR SR ELEMENT #38
      DATA ((XNRG(I, J, 38), I = 1, 6), J = 1, 12)/
     1 343.307892D0,   69.7877731D0,   32.2092018D0,   20.9358749D0,
     2 16.8972511D0,   16.1207047D0,   47.2457123D0,   9.60412788D0,
     3 4.43260002D0,   2.88117552D0,   2.32538390D0,   2.21851635D0,
     4 42.7797203D0,   8.69628048D0,   4.01360035D0,   2.60882688D0,
     5 2.10557270D0,   2.00880694D0,   41.3471947D0,   8.40507507D0,
     6 3.87920022D0,   2.52146745D0,   2.03506517D0,   1.94153965D0,
     7 162.458984D0,   6.71328163D0,   1.42999995D0,   0.604168892D0,
     8 0.393557578D0,  0.0D0,          127.149719D0,   5.25419903D0,
     9 1.11919999D0,   0.472857207D0,  0.308020741D0,  0.0D0,
     * 122.287315D0,   5.05327034D0,   1.07640004D0,   0.454774410D0,
     1 0.296241522D0,  0.0D0,          61.3481522D0,   2.53508544D0,
     2 0.540000021D0,  0.228147700D0,  0.148616150D0,  0.0D0,
     3 60.4847336D0,   2.49940634D0,   0.532400012D0,  0.224936724D0,
     4 0.146524519D0,  0.0D0,          17.1320381D0,   0.707946062D0,
     5 0.150800005D0,  6.371235847D-02,4.150243476D-02,0.0D0,
     6 9.04317188D0,   0.373690367D0,  7.959999889D-02,3.363065794D-02,
     7 2.190712094D-02,0.0D0,          9.04317188D0,   0.373690367D0,
     8 7.959999889D-02,3.363065794D-02,2.190712094D-02,0.0D0/
C * DATA FOR Y  ELEMENT #39
      DATA ((XNRG(I, J, 39), I = 1, 6), J = 1, 12)/
     1 363.214050D0,   73.8343048D0,   34.0767975D0,   22.1498070D0,
     2 17.8770123D0,   17.0554371D0,   50.5754852D0,   10.2810059D0,
     3 4.74499989D0,   3.08423448D0,   2.48927188D0,   2.37487245D0,
     4 45.9496155D0,   9.34065723D0,   4.31099987D0,   2.80213594D0,
     5 2.26159143D0,   2.15765548D0,   44.3401527D0,   9.01348495D0,
     6 4.15999985D0,   2.70398617D0,   2.18237543D0,   2.08207989D0,
     7 178.863937D0,   7.39118242D0,   1.57440007D0,   0.665177286D0,
     8 0.433298647D0,  0.0D0,          141.964172D0,   5.86637545D0,
     9 1.24960005D0,   0.527950704D0,  0.343908787D0,  0.0D0,
     * 136.465546D0,   5.63915634D0,   1.20120001D0,   0.507501841D0,
     1 0.330588371D0,  0.0D0,          72.5271454D0,   2.99703431D0,
     2 0.638400018D0,  0.269721270D0,  0.175697312D0,  0.0D0,
     3 71.5273972D0,   2.95572186D0,   0.629599988D0,  0.266003311D0,
     4 0.173275426D0,  0.0D0,          20.6311550D0,   0.852539837D0,
     5 0.181600004D0,  7.672522217D-02,4.997906089D-02,0.0D0,
     6 11.6334267D0,   0.480727285D0,  0.102399997D0,  4.326356202D-02,
     7 2.818202600D-02,0.0D0,          11.6334267D0,   0.480727285D0,
     8 0.102399997D0,  4.326356202D-02,2.818202600D-02,0.0D0/
C * DATA FOR ZR ELEMENT #40
      DATA ((XNRG(I, J, 40), I = 1, 6), J = 1, 13)/
     1 383.661713D0,   77.9909134D0,   35.9952011D0,   23.3967628D0,
     2 18.8834229D0,   18.0155983D0,   53.9670830D0,   10.9704514D0,
     3 5.06320000D0,   3.29106331D0,   2.65620255D0,   2.53413153D0,
     4 49.1728020D0,   9.99586868D0,   4.61339998D0,   2.99869490D0,
     5 2.42023325D0,   2.30900669D0,   47.3736153D0,   9.63012886D0,
     6 4.44460011D0,   2.88897538D0,   2.33167934D0,   2.22452235D0,
     7 195.541550D0,   8.08034992D0,   1.72119999D0,   0.727199614D0,
     8 0.473700225D0,  0.0D0,          156.415070D0,   6.46352863D0,
     9 1.37679994D0,   0.581692100D0,  0.378916144D0,  0.0D0,
     * 150.189362D0,   6.20626450D0,   1.32200003D0,   0.558539391D0,
     1 0.363834351D0,  0.0D0,          82.8881683D0,   3.42518210D0,
     2 0.729600012D0,  0.308252901D0,  0.200796947D0,  0.0D0,
     3 81.7975388D0,   3.38011384D0,   0.720000029D0,  0.304196924D0,
     4 0.198154882D0,  0.0D0,          23.3122978D0,   0.963332415D0,
     5 0.205200002D0,  8.669612557D-02,5.647413805D-02,0.0D0,
     6 13.0421619D0,   0.538940370D0,  0.114799999D0,  4.850250855D-02,
     7 3.159469366D-02,0.0D0,          13.0421619D0,   0.538940370D0,
     8 0.114799999D0,  4.850250855D-02,3.159469366D-02,0.0D0,
     9 1.82837915D0,   7.555398345D-02,1.609379798D-02,6.799560972D-03,
     * 4.429256078D-03,0.0D0/
C * DATA FOR NB ELEMENT #41
      DATA ((XNRG(I, J, 41), I = 1, 6), J = 1, 13)/
     1 404.723267D0,   82.2723160D0,   37.9711990D0,   24.6811543D0,
     2 19.9200497D0,   19.0045853D0,   57.5079002D0,   11.6902304D0,
     3 5.39540005D0,   3.50699234D0,   2.83047795D0,   2.70039773D0,
     4 52.5409508D0,   10.6805468D0,   4.92939997D0,   3.20409369D0,
     5 2.58600998D0,   2.46716475D0,   50.5328522D0,   10.2723398D0,
     6 4.74100018D0,   3.08163452D0,   2.48717356D0,   2.37287045D0,
     7 212.855362D0,   8.79580784D0,   1.87360001D0,   0.791588008D0,
     8 0.515643001D0,  0.0D0,          171.956589D0,   7.10575056D0,
     9 1.51359999D0,   0.639489532D0,  0.416565567D0,  0.0D0,
     * 164.958359D0,   6.81656265D0,   1.45200002D0,   0.613463819D0,
     1 0.399612308D0,  0.0D0,          94.2489319D0,   3.89464211D0,
     2 0.829599977D0,  0.350502461D0,  0.228318438D0,  0.0D0,
     3 92.9765320D0,   3.84206271D0,   0.818399966D0,  0.345770508D0,
     4 0.225236028D0,  0.0D0,          26.4024258D0,   1.09102559D0,
     5 0.232400000D0,  9.818800539D-02,6.395998597D-02,0.0D0,
     6 15.4052029D0,   0.636588097D0,  0.135600001D0,  5.729041994D-02,
     7 3.731916845D-02,0.0D0,          15.4052029D0,   0.636588097D0,
     8 0.135600001D0,  5.729041994D-02,3.731916845D-02,0.0D0,
     9 1.45417833D0,   6.009091064D-02,1.279999968D-02,5.407945253D-03,
     * 3.522753250D-03,0.0D0/
C * DATA FOR MO ELEMENT #42
      DATA ((XNRG(I, J, 42), I = 1, 6), J = 1, 14)/
     1 426.336975D0,   86.6659546D0,   39.9990005D0,   25.9992180D0,
     2 20.9838543D0,   20.0194988D0,   61.0849571D0,   12.4173756D0,
     3 5.73099995D0,   3.72513127D0,   3.00653696D0,   2.86836553D0,
     4 55.9602585D0,   11.3756247D0,   5.25020027D0,   3.41261292D0,
     5 2.75430465D0,   2.62772512D0,   53.7240639D0,   10.9210510D0,
     6 5.04040003D0,   3.27624345D0,   2.64424157D0,   2.52272010D0,
     7 229.305756D0,   9.47558594D0,   2.01839995D0,   0.852765381D0,
     8 0.555494130D0,  0.0D0,          186.180283D0,   7.69351435D0,
     9 1.63880002D0,   0.692385972D0,  0.451022506D0,  0.0D0,
     * 178.273178D0,   7.36677027D0,   1.56920004D0,   0.662980318D0,
     1 0.431867540D0,  0.0D0,          104.655403D0,   4.32466793D0,
     2 0.921200037D0,  0.389203072D0,  0.253528148D0,  0.0D0,
     3 103.155777D0,   4.26269913D0,   0.907999992D0,  0.383626133D0,
     4 0.249895304D0,  0.0D0,          28.0838203D0,   1.16050577D0,
     5 0.247199997D0,  0.104440942D0,  6.803317368D-02,0.0D0,
     6 15.8141899D0,   0.653488696D0,  0.139200002D0,  5.881140754D-02,
     7 3.830994293D-02,0.0D0,          15.8141899D0,   0.653488696D0,
     8 0.139200002D0,  5.881140754D-02,3.830994293D-02,0.0D0,
     9 0.817975342D0,  3.380113840D-02,7.200000342D-03,3.041969379D-03,
     * 1.981548732D-03,0.0D0,          0.817975342D0,  3.380113840D-02,
     1 7.200000342D-03,3.041969379D-03,1.981548732D-03,0.0D0/
C * DATA FOR TC ELEMENT #43
      DATA ((XNRG(I, J, 43), I = 1, 6), J = 1, 14)/
     1 448.602966D0,   91.1921997D0,   42.0879974D0,   27.3570614D0,
     2 22.0797634D0,   21.0650425D0,   64.8581314D0,   13.1843891D0,
     3 6.08500004D0,   3.95523000D0,   3.19224858D0,   3.04554248D0,
     4 59.5437088D0,   12.1040707D0,   5.58640003D0,   3.63114166D0,
     5 2.93067837D0,   2.79599309D0,   57.0644989D0,   11.6000948D0,
     6 5.35379982D0,   3.47995234D0,   2.80865407D0,   2.67957687D0,
     7 248.846268D0,   10.2830572D0,   2.19039989D0,   0.925434649D0,
     8 0.602831125D0,  0.0D0,          202.176239D0,   8.35451412D0,
     9 1.77960002D0,   0.751873374D0,  0.489772767D0,  0.0D0,
     * 193.133072D0,   7.98082447D0,   1.70000005D0,   0.718242764D0,
     1 0.467865676D0,  0.0D0,          116.516045D0,   4.81478453D0,
     2 1.02559996D0,   0.433311641D0,  0.282260597D0,  0.0D0,
     3 114.925537D0,   4.74906015D0,   1.01160002D0,   0.427396685D0,
     4 0.278407604D0,  0.0D0,          31.0830631D0,   1.28444326D0,
     5 0.273600012D0,  0.115594834D0,  7.529885322D-02,0.0D0,
     6 17.6773567D0,   0.730480134D0,  0.155599996D0,  6.574033201D-02,
     7 4.282346740D-02,0.0D0,          17.6773567D0,   0.730480134D0,
     8 0.155599996D0,  6.574033201D-02,4.282346740D-02,0.0D0,
     9 3.18627834D0,   0.131666362D0,  2.804632671D-02,1.184945367D-02,
     * 7.718772627D-03,0.0D0,          3.05805564D0,   0.126367822D0,
     1 2.691768296D-02,1.137260627D-02,7.408152800D-03,0.0D0/
C * DATA FOR RU ELEMENT #44
      DATA ((XNRG(I, J, 44), I = 1, 6), J = 1, 14)/
     1 471.480804D0,   95.8428116D0,   44.2344017D0,   28.7522144D0,
     2 23.2057858D0,   22.1393166D0,   68.7272339D0,   13.9709015D0,
     3 6.44799995D0,   4.19117880D0,   3.38268185D0,   3.22722387D0,
     4 63.2465363D0,   12.8567829D0,   5.93379974D0,   3.85695052D0,
     5 3.11292768D0,   2.96986675D0,   60.4965973D0,   12.2977743D0,
     6 5.67580032D0,   3.68925142D0,   2.97757840D0,   2.84073806D0,
     7 265.841980D0,   10.9853697D0,   2.33999991D0,   0.988640010D0,
     8 0.644003332D0,  0.0D0,          219.399170D0,   9.06621647D0,
     9 1.93120003D0,   0.815923750D0,  0.531495392D0,  0.0D0,
     * 209.310806D0,   8.64933586D0,   1.84240007D0,   0.778406143D0,
     1 0.507056296D0,  0.0D0,          128.876556D0,   5.32555723D0,
     2 1.13440001D0,   0.479279160D0,  0.312204003D0,  0.0D0,
     3 126.967949D0,   5.24668789D0,   1.11759996D0,   0.472181231D0,
     4 0.307580382D0,  0.0D0,          34.0368614D0,   1.40650296D0,
     5 0.299600005D0,  0.126579717D0,  8.245444298D-02,0.0D0,
     6 19.5859642D0,   0.809349477D0,  0.172399998D0,  7.283826172D-02,
     7 4.744708166D-02,0.0D0,          19.5859642D0,   0.809349477D0,
     8 0.172399998D0,  7.283826172D-02,4.744708166D-02,0.0D0,
     9 0.908861518D0,  3.755681962D-02,8.000000380D-03,3.379965900D-03,
     * 2.201720839D-03,0.0D0,          0.908861518D0,  3.755681962D-02,
     1 8.000000380D-03,3.379965900D-03,2.201720839D-03,0.0D0/
C * DATA FOR RH ELEMENT #45
      DATA ((XNRG(I, J, 45), I = 1, 6), J = 1, 14)/
     1 494.987457D0,   100.621262D0,   46.4398003D0,   30.1857166D0,
     2 24.3627586D0,   23.2431202D0,   72.7327728D0,   14.7851486D0,
     3 6.82380009D0,   4.43544769D0,   3.57983017D0,   3.41531181D0,
     4 67.0666122D0,   13.6333294D0,   6.29220009D0,   4.08990955D0,
     5 3.30094767D0,   3.14924622D0,   64.0331497D0,   13.0166855D0,
     6 6.00759983D0,   3.90492010D0,   3.15164375D0,   3.00680375D0,
     7 284.973511D0,   11.7759409D0,   2.50839996D0,   1.05978823D0,
     8 0.690349519D0,  0.0D0,          236.758423D0,   9.78355122D0,
     9 2.08400011D0,   0.880481124D0,  0.573548257D0,  0.0D0,
     * 225.488541D0,   9.31784725D0,   1.98479998D0,   0.838569522D0,
     1 0.546246946D0,  0.0D0,          141.646072D0,   5.85323048D0,
     2 1.24680007D0,   0.526767671D0,  0.343138188D0,  0.0D0,
     3 139.510239D0,   5.76497173D0,   1.22799993D0,   0.518824756D0,
     4 0.337964118D0,  0.0D0,          36.8088913D0,   1.52105117D0,
     5 0.324000001D0,  0.136888623D0,  8.916968852D-02,0.0D0,
     6 21.7672329D0,   0.899485826D0,  0.191599995D0,  8.095017821D-02,
     7 5.273121223D-02,0.0D0,          21.7672329D0,   0.899485826D0,
     8 0.191599995D0,  8.095017821D-02,5.273121223D-02,0.0D0,
     9 1.13607681D0,   4.694602638D-02,9.999999776D-03,4.224957433D-03,
     * 2.752150875D-03,0.0D0,          1.13607681D0,   4.694602638D-02,
     1 9.999999776D-03,4.224957433D-03,2.752150875D-03,0.0D0/
C * DATA FOR PD ELEMENT #46
      DATA ((XNRG(I, J, 46), I = 1, 6), J = 1, 14)/
     1 519.084656D0,   105.519745D0,   48.7005997D0,   31.6552315D0,
     2 25.5487976D0,   24.3746510D0,   76.8342361D0,   15.6188955D0,
     3 7.20860004D0,   4.68556643D0,   3.78169966D0,   3.60790420D0,
     4 70.9932785D0,   14.4315434D0,   6.66060019D0,   4.32936811D0,
     5 3.49421382D0,   3.33363032D0,   67.6464462D0,   13.7511978D0,
     6 6.34660006D0,   4.12526894D0,   3.32948637D0,   3.17647314D0,
     7 304.423157D0,   12.5796566D0,   2.67960000D0,   1.13211954D0,
     8 0.737466395D0,  0.0D0,          254.072235D0,   10.4990091D0,
     9 2.23639989D0,   0.944869459D0,  0.615491033D0,  0.0D0,
     * 241.529938D0,   9.98072529D0,   2.12599993D0,   0.898225904D0,
     1 0.585107327D0,  0.0D0,          154.506454D0,   6.38465929D0,
     2 1.36000001D0,   0.574594200D0,  0.374292523D0,  0.0D0,
     3 152.097977D0,   6.28513384D0,   1.33879995D0,   0.565637290D0,
     4 0.368457973D0,  0.0D0,          39.2628174D0,   1.62245464D0,
     5 0.345600009D0,  0.146014526D0,  9.511433542D-02,0.0D0,
     6 23.2214108D0,   0.959576786D0,  0.204400003D0,  8.635812998D-02,
     7 5.625396594D-02,0.0D0,          23.2214108D0,   0.959576786D0,
     8 0.204400003D0,  8.635812998D-02,5.625396594D-02,0.0D0,
     9 2.47511697D0,   0.102279089D0,  2.178652771D-02,9.204714559D-03,
     * 5.995981395D-03,0.0D0,          2.28052115D0,   9.423781186D-02,
     1 2.007365227D-02,8.481032215D-03,5.524571985D-03,0.0D0/
C * DATA FOR AG ELEMENT #47
      DATA ((XNRG(I, J, 47), I = 1, 6), J = 1, 14)/
     1 543.891663D0,   110.562531D0,   51.0279999D0,   33.1680336D0,
     2 26.7697716D0,   25.5395145D0,   81.1296921D0,   16.4920769D0,
     3 7.61159992D0,   4.94751501D0,   3.99311733D0,   3.80960584D0,
     4 75.1160583D0,   15.2696238D0,   7.04740000D0,   4.58078671D0,
     5 3.69713283D0,   3.52722383D0,   71.4366760D0,   14.5216780D0,
     6 6.70219994D0,   4.35640812D0,   3.51603746D0,   3.35445118D0,
     7 326.054047D0,   13.4735088D0,   2.86999989D0,   1.21256280D0,
     8 0.789867342D0,  0.0D0,          273.749084D0,   11.3121147D0,
     9 2.40960002D0,   1.01804566D0,   0.663158298D0,  0.0D0,
     * 259.661743D0,   10.7299833D0,   2.28559995D0,   0.965656221D0,
     1 0.629031599D0,  0.0D0,          169.411789D0,   7.00059128D0,
     2 1.49119997D0,   0.630025625D0,  0.410400748D0,  0.0D0,
     3 166.639755D0,   6.88604307D0,   1.46679997D0,   0.619716763D0,
     4 0.403685510D0,  0.0D0,          43.2618065D0,   1.78770459D0,
     5 0.380800009D0,  0.160886377D0,  0.104801908D0,  0.0D0,
     6 28.4473648D0,   1.17552853D0,   0.250400007D0,  0.105792932D0,
     7 6.891386211D-02,0.0D0,          25.4026775D0,   1.04971313D0,
     8 0.223600000D0,  9.447004646D-02,6.153809652D-02,0.0D0,
     9 1.49962151D0,   6.196875498D-02,1.319999993D-02,5.576943979D-03,
     * 3.632839303D-03,0.0D0,          1.49962151D0,   6.196875498D-02,
     1 1.319999993D-02,5.576943979D-03,3.632839303D-03,0.0D0/
C * DATA FOR CD ELEMENT #48
      DATA ((XNRG(I, J, 48), I = 1, 6), J = 1, 14)/
     1 569.412842D0,   115.750481D0,   53.4224014D0,   34.7243843D0,
     2 28.0258961D0,   26.7379112D0,   85.6532364D0,   17.4116268D0,
     3 8.03600025D0,   5.22337341D0,   4.21576166D0,   4.02201796D0,
     4 79.4498825D0,   16.1506042D0,   7.45400000D0,   4.84507561D0,
     5 3.91043901D0,   3.73072696D0,   75.4102325D0,   15.3294249D0,
     6 7.07499981D0,   4.59872675D0,   3.71161199D0,   3.54103732D0,
     7 350.002563D0,   14.4631319D0,   3.08080006D0,   1.30162489D0,
     8 0.847882688D0,  0.0D0,          295.698090D0,   12.2191114D0,
     9 2.60279989D0,   1.09967184D0,   0.716329873D0,  0.0D0,
     * 280.156555D0,   11.5768900D0,   2.46600008D0,   1.04187453D0,
     1 0.678680420D0,  0.0D0,          186.543823D0,   7.70853758D0,
     2 1.64199996D0,   0.693737984D0,  0.451903194D0,  0.0D0,
     3 183.453690D0,   7.58084393D0,   1.61479998D0,   0.682246089D0,
     4 0.444417328D0,  0.0D0,          48.8967476D0,   2.02055693D0,
     5 0.430399984D0,  0.181842163D0,  0.118452579D0,  0.0D0,
     6 30.4014168D0,   1.25627565D0,   0.267600000D0,  0.113059856D0,
     7 7.364755869D-02,0.0D0,          30.4014168D0,   1.25627565D0,
     8 0.267600000D0,  0.113059856D0,  7.364755869D-02,0.0D0,
     9 4.22620583D0,   0.174639210D0,  3.720000014D-02,1.571684144D-02,
     * 1.023800205D-02,0.0D0,          4.22620583D0,   0.174639210D0,
     1 3.720000014D-02,1.571684144D-02,1.023800205D-02,0.0D0/
C * DATA FOR IN ELEMENT #49
      DATA ((XNRG(I, J, 49), I = 1, 6), J = 1, 14)/
     1 595.605469D0,   121.074936D0,   55.8797989D0,   36.3216858D0,
     2 29.3150711D0,   27.9678402D0,   90.3324051D0,   18.3628082D0,
     3 8.47500038D0,   5.50872231D0,   4.44606543D0,   4.24173737D0,
     4 83.9478455D0,   17.0649548D0,   7.87599993D0,   5.11937428D0,
     5 4.13182449D0,   3.94193816D0,   79.5159683D0,   16.1640396D0,
     6 7.46019983D0,   4.84910536D0,   3.91369152D0,   3.73383021D0,
     7 375.178009D0,   15.5034552D0,   3.30239987D0,   1.39524984D0,
     8 0.908870339D0,  0.0D0,          319.101257D0,   13.1862001D0,
     9 2.80879998D0,   1.18670607D0,   0.773024142D0,  0.0D0,
     * 301.878357D0,   12.4744978D0,   2.65720010D0,   1.12265563D0,
     1 0.731301546D0,  0.0D0,          204.857376D0,   8.46530724D0,
     2 1.80320001D0,   0.761844337D0,  0.496267855D0,  0.0D0,
     3 201.358261D0,   8.32071304D0,   1.77240002D0,   0.748831451D0,
     4 0.487791240D0,  0.0D0,          55.3951073D0,   2.28908825D0,
     5 0.487599999D0,  0.206008926D0,  0.134194881D0,  0.0D0,
     6 35.1729393D0,   1.45344889D0,   0.309599996D0,  0.130804673D0,
     7 8.520659059D-02,0.0D0,          35.1729393D0,   1.45344889D0,
     8 0.309599996D0,  0.130804673D0,  8.520659059D-02,0.0D0,
     9 7.36177778D0,   0.304210246D0,  6.480000168D-02,2.737772278D-02,
     * 1.783393882D-02,0.0D0,          7.36177778D0,   0.304210246D0,
     1 6.480000168D-02,2.737772278D-02,1.783393882D-02,0.0D0/
C * DATA FOR SN ELEMENT #50
      DATA ((XNRG(I, J, 50), I = 1, 6), J = 1, 14)/
     1 622.469666D0,   126.535896D0,   58.4001999D0,   37.9599380D0,
     2 30.6372986D0,   29.2293015D0,   95.1757126D0,   19.3473587D0,
     3 8.92940044D0,   5.80408049D0,   4.68444777D0,   4.46916485D0,
     4 88.5971680D0,   18.0100708D0,   8.31220055D0,   5.40290260D0,
     5 4.36065912D0,   4.16025639D0,   83.7517242D0,   17.0250874D0,
     6 7.85760021D0,   5.10741425D0,   4.12217140D0,   3.93272877D0,
     7 401.625885D0,   16.5963593D0,   3.53520012D0,   1.49360693D0,
     8 0.972940385D0,  0.0D0,          343.731415D0,   14.2039890D0,
     9 3.02559996D0,   1.27830303D0,   0.832690775D0,  0.0D0,
     * 324.645325D0,   13.4152966D0,   2.85759997D0,   1.20732379D0,
     1 0.786454678D0,  0.0D0,          224.170685D0,   9.26338959D0,
     2 1.97319996D0,   0.833668590D0,  0.543054461D0,  0.0D0,
     3 220.308029D0,   9.10377312D0,   1.93920004D0,   0.819303751D0,
     4 0.533697128D0,  0.0D0,          62.0297966D0,   2.56325293D0,
     5 0.546000004D0,  0.230682671D0,  0.150267437D0,  0.0D0,
     6 40.2625656D0,   1.66376710D0,   0.354400009D0,  0.149732485D0,
     7 9.753622860D-02,0.0D0,          40.2625656D0,   1.66376710D0,
     8 0.354400009D0,  0.149732485D0,  9.753622860D-02,0.0D0,
     9 10.8608942D0,   0.448803991D0,  9.559999406D-02,4.039059207D-02,
     * 2.631056309D-02,0.0D0,          10.8608942D0,   0.448803991D0,
     1 9.559999406D-02,4.039059207D-02,2.631056309D-02,0.0D0/
C * DATA FOR SB ELEMENT #51
      DATA ((XNRG(I, J, 51), I = 1, 6), J = 1, 14)/
     1 649.992554D0,   132.130753D0,   60.9823990D0,   39.6383591D0,
     2 31.9919453D0,   30.5216904D0,   100.155449D0,   20.3596420D0,
     3 9.39659977D0,   6.10775900D0,   4.92954540D0,   4.70299816D0,
     4 93.3786545D0,   18.9820538D0,   8.76080036D0,   5.69449139D0,
     5 4.59599876D0,   4.38478041D0,   88.0876846D0,   17.9065018D0,
     6 8.26440048D0,   5.37183285D0,   4.33558273D0,   4.13633204D0,
     7 428.846283D0,   17.7211857D0,   3.77480006D0,   1.59483683D0,
     8 1.03888190D0,   0.0D0,          368.952332D0,   15.2461910D0,
     9 3.24760008D0,   1.37209713D0,   0.893788576D0,  0.0D0,
     * 347.912170D0,   14.3767509D0,   3.06239986D0,   1.29385090D0,
     1 0.842818737D0,  0.0D0,          243.983871D0,   10.0821285D0,
     2 2.14759994D0,   0.907351851D0,  0.591051936D0,  0.0D0,
     3 239.712219D0,   9.90561104D0,   2.10999990D0,   0.891465962D0,
     4 0.580703855D0,  0.0D0,          69.0734787D0,   2.85431838D0,
     5 0.608000040D0,  0.256877422D0,  0.167330787D0,  0.0D0,
     6 44.7159843D0,   1.84779561D0,   0.393600017D0,  0.166294321D0,
     7 0.108324662D0,  0.0D0,          44.7159843D0,   1.84779561D0,
     8 0.393600017D0,  0.166294321D0,  0.108324662D0,  0.0D0,
     9 14.2691259D0,   0.589642107D0,  0.125599995D0,  5.306546390D-02,
     * 3.456701711D-02,0.0D0,          14.2691259D0,   0.589642107D0,
     1 0.125599995D0,  5.306546390D-02,3.456701711D-02,0.0D0/
C * DATA FOR TE ELEMENT #52
      DATA ((XNRG(I, J, 52), I = 1, 6), J = 1, 14)/
     1 678.186890D0,   137.862122D0,   63.6275978D0,   41.3577309D0,
     2 33.3796425D0,   31.8456135D0,   105.290810D0,   21.4035606D0,
     3 9.87839985D0,   6.42092752D0,   5.18230247D0,   4.94413948D0,
     4 98.3157654D0,   19.9856701D0,   9.22399998D0,   5.99556971D0,
     5 4.83899784D0,   4.61661196D0,   92.5472794D0,   18.8130493D0,
     6 8.68280029D0,   5.64379168D0,   4.55507898D0,   4.34574127D0,
     7 21.4452858D0,   4.35940695D0,   2.01200008D0,   1.30779338D0,
     8 1.05551422D0,   1.00700605D0,   395.218414D0,   16.3315830D0,
     9 3.47880006D0,   1.46977818D0,   0.957418263D0,  0.0D0,
     * 372.042450D0,   15.3738842D0,   3.27480006D0,   1.38358903D0,
     1 0.901274383D0,  0.0D0,          264.705902D0,   10.9384241D0,
     2 2.32999992D0,   0.984415054D0,  0.641251206D0,  0.0D0,
     3 259.979828D0,   10.7431288D0,   2.28839993D0,   0.966839254D0,
     4 0.629802227D0,  0.0D0,          76.4806976D0,   3.16040635D0,
     5 0.673200011D0,  0.284424126D0,  0.185274810D0,  0.0D0,
     6 50.0782700D0,   2.06938076D0,   0.440800011D0,  0.186236113D0,
     7 0.121314816D0,  0.0D0,          50.0782700D0,   2.06938076D0,
     8 0.440800011D0,  0.186236113D0,  0.121314816D0,  0.0D0,
     9 18.0863438D0,   0.747380733D0,  0.159199998D0,  6.726132333D-02,
     * 4.381424561D-02,0.0D0,          18.0863438D0,   0.747380733D0,
     1 0.159199998D0,  6.726132333D-02,4.381424561D-02,0.0D0/
C * DATA FOR I  ELEMENT #53
      DATA ((XNRG(I, J, 53), I = 1, 6), J = 1, 14)/
     1 707.084778D0,   143.736481D0,   66.3387985D0,   43.1200027D0,
     2 34.8019638D0,   33.2025681D0,   110.596710D0,   22.4821453D0,
     3 10.3761997D0,   6.74449587D0,   5.44345284D0,   5.19328833D0,
     4 103.434067D0,   21.0261211D0,   9.70419979D0,   6.30769825D0,
     5 5.09091520D0,   4.85695219D0,   97.1454391D0,   19.7477665D0,
     6 9.11419964D0,   5.92420006D0,   4.78139591D0,   4.56165695D0,
     7 22.8543644D0,   4.64584494D0,   2.14420009D0,   1.39372301D0,
     8 1.12486768D0,   1.07317209D0,   422.847809D0,   17.4733105D0,
     9 3.72200012D0,   1.57252908D0,   1.02435064D0,   0.0D0,
     * 397.445129D0,   16.4235973D0,   3.49839997D0,   1.47805905D0,
     1 0.962812483D0,  0.0D0,          286.882141D0,   11.8548098D0,
     2 2.52519989D0,   1.06688619D0,   0.694973171D0,  0.0D0,
     3 281.474396D0,   11.6313477D0,   2.47760010D0,   1.04677546D0,
     4 0.681872904D0,  0.0D0,          84.7058945D0,   3.50029564D0,
     5 0.745599985D0,  0.315012813D0,  0.205200374D0,  0.0D0,
     6 55.7586517D0,   2.30411100D0,   0.490799993D0,  0.207360908D0,
     7 0.135075569D0,  0.0D0,          55.7586517D0,   2.30411100D0,
     8 0.490799993D0,  0.207360908D0,  0.135075569D0,  0.0D0,
     9 22.5397644D0,   0.931409121D0,  0.198400006D0,  8.382315189D-02,
     * 5.460267514D-02,0.0D0,          22.5397644D0,   0.931409121D0,
     1 0.198400006D0,  8.382315189D-02,5.460267514D-02,0.0D0/
C * DATA FOR XE ELEMENT #54
      DATA ((XNRG(I, J, 54), I = 1, 6), J = 1, 14)/
     1 736.758545D0,   149.768585D0,   69.1228027D0,   44.9295921D0,
     2 36.2624741D0,   34.5959625D0,   116.239418D0,   23.6291981D0,
     3 10.9055996D0,   7.08860397D0,   5.72118092D0,   5.45825291D0,
     4 108.797523D0,   22.1164055D0,   10.2074003D0,   6.63477659D0,
     5 5.35489893D0,   5.10880375D0,   101.943985D0,   20.7232151D0,
     6 9.56439972D0,   6.21682882D0,   5.01757479D0,   4.78698206D0,
     7 24.3998737D0,   4.96001673D0,   2.28920007D0,   1.48797250D0,
     8 1.20093596D0,   1.14574456D0,   453.976318D0,   18.7596321D0,
     9 3.99600005D0,   1.68829298D0,   1.09975958D0,   0.0D0,
     * 425.801605D0,   17.5953712D0,   3.74799991D0,   1.58351398D0,
     1 1.03150618D0,   0.0D0,          311.466827D0,   12.8707218D0,
     2 2.74160004D0,   1.15831435D0,   0.754529715D0,  0.0D0,
     3 305.513794D0,   12.6247253D0,   2.68919992D0,   1.13617551D0,
     4 0.740108430D0,  0.0D0,          94.5670395D0,   3.90778708D0,
     5 0.832399964D0,  0.351685435D0,  0.229089037D0,  0.0D0,
     6 66.6649857D0,   2.75479269D0,   0.586799979D0,  0.247920483D0,
     7 0.161496207D0,  0.0D0,          66.6649857D0,   2.75479269D0,
     8 0.586799979D0,  0.247920483D0,  0.161496207D0,  0.0D0,
     9 29.0835686D0,   1.20181823D0,   0.256000012D0,  0.108158909D0,
     * 7.045506686D-02,0.0D0,          29.0835686D0,   1.20181823D0,
     1 0.256000012D0,  0.108158909D0,  7.045506686D-02,0.0D0/
C * DATA FOR CS ELEMENT #55
      DATA ((XNRG(I, J, 55), I = 1, 6), J = 1, 17)/
     1 767.097412D0,   155.935883D0,   71.9692001D0,   46.7797432D0,
     2 37.7557220D0,   36.0205841D0,   121.813911D0,   24.7623844D0,
     3 11.4286003D0,   7.42855263D0,   5.99555159D0,   5.72001410D0,
     4 114.248375D0,   23.2244568D0,   10.7187996D0,   6.96718454D0,
     5 5.62318373D0,   5.36475945D0,   106.840584D0,   21.7185993D0,
     6 10.0237999D0,   6.51543713D0,   5.25858068D0,   5.01691198D0,
     7 25.9453850D0,   5.27418900D0,   2.43420005D0,   1.58222198D0,
     8 1.27700436D0,   1.21831715D0,   22.7030106D0,   4.61507750D0,
     9 2.12999988D0,   1.38449299D0,   1.11741817D0,   1.06606495D0,
     * 453.340118D0,   18.7333412D0,   3.99040008D0,   1.68592691D0,
     1 1.09821832D0,   0.0D0,          336.051544D0,   13.8866339D0,
     2 2.95799994D0,   1.24974239D0,   0.814086258D0,  0.0D0,
     3 329.689514D0,   13.6237364D0,   2.90199995D0,   1.22608256D0,
     4 0.798674226D0,  0.0D0,          104.882614D0,   4.33405685D0,
     5 0.923200011D0,  0.390048057D0,  0.254078567D0,  0.0D0,
     6 78.2984161D0,   3.23551989D0,   0.689199984D0,  0.291184038D0,
     7 0.189678237D0,  0.0D0,          73.4360123D0,   3.03459120D0,
     8 0.646400034D0,  0.273101240D0,  0.177899033D0,  0.0D0,
     9 35.8091431D0,   1.47973871D0,   0.315200001D0,  0.133170649D0,
     * 8.674779534D-02,0.0D0,          34.7639503D0,   1.43654835D0,
     1 0.305999994D0,  0.129283696D0,  8.421581984D-02,0.0D0,
     2 10.3155775D0,   0.426269919D0,  9.080000222D-02,3.836261109D-02,
     3 2.498953044D-02,0.0D0,          5.95304298D0,   0.245997176D0,
     4 5.240000039D-02,2.213877626D-02,1.442127116D-02,0.0D0,
     5 5.18051052D0,   0.214073882D0,  4.560000077D-02,1.926580630D-02,
     6 1.254980825D-02,0.0D0/
C * DATA FOR BA ELEMENT #56
      DATA ((XNRG(I, J, 56), I = 1, 6), J = 1, 17)/
     1 798.135559D0,   162.245331D0,   74.8811951D0,   48.6725349D0,
     2 39.2833862D0,   37.4780388D0,   127.665535D0,   25.9519043D0,
     3 11.9776001D0,   7.78540087D0,   6.28356218D0,   5.99478865D0,
     4 119.880424D0,   24.3693428D0,   11.2472000D0,   7.31064320D0,
     5 5.90038776D0,   5.62922382D0,   111.852303D0,   22.7373829D0,
     6 10.4940004D0,   6.82106543D0,   5.50525188D0,   5.25224686D0,
     7 27.5591106D0,   5.60222769D0,   2.58559990D0,   1.68063152D0,
     8 1.35643029D0,   1.29409277D0,   24.2314682D0,   4.92578316D0,
     9 2.27340007D0,   1.47770250D0,   1.19264722D0,   1.13783669D0,
     * 22.6433220D0,   4.60294437D0,   2.12439990D0,   1.38085306D0,
     1 1.11448038D0,   1.06326222D0,   361.772308D0,   14.9494925D0,
     2 3.18440008D0,   1.34539545D0,   0.876394928D0,  0.0D0,
     3 354.774078D0,   14.6603050D0,   3.12279987D0,   1.31936967D0,
     4 0.859441698D0,  0.0D0,          114.970978D0,   4.75093746D0,
     5 1.01199996D0,   0.427565664D0,  0.278517663D0,  0.0D0,
     6 87.1598129D0,   3.60169911D0,   0.767199993D0,  0.324138731D0,
     7 0.211145014D0,  0.0D0,          81.6612015D0,   3.37448025D0,
     8 0.718800008D0,  0.303689927D0,  0.197824612D0,  0.0D0,
     9 42.0348434D0,   1.73700297D0,   0.370000005D0,  0.156323418D0,
     * 0.101829588D0,  0.0D0,          40.8533249D0,   1.68817914D0,
     1 0.359600008D0,  0.151929468D0,  9.896735102D-02,0.0D0,
     2 17.7682419D0,   0.734235823D0,  0.156399995D0,  6.607833505D-02,
     3 4.304363951D-02,0.0D0,          7.54355049D0,   0.311721623D0,
     4 6.639999896D-02,2.805371769D-02,1.827428304D-02,0.0D0,
     5 6.63468933D0,   0.274164796D0,  5.840000138D-02,2.467375249D-02,
     6 1.607256196D-02,0.0D0/
C * DATA FOR LA ELEMENT #57
      DATA ((XNRG(I, J, 57), I = 1, 6), J = 1, 17)/
     1 829.770569D0,   168.676102D0,   77.8491974D0,   50.6017227D0,
     2 40.8404274D0,   38.9635239D0,   133.581100D0,   27.1544247D0,
     3 12.5326004D0,   8.14614868D0,   6.57472086D0,   6.27256632D0,
     4 125.572166D0,   25.5263634D0,   11.7812004D0,   7.65774155D0,
     5 6.18052912D0,   5.89649057D0,   116.876808D0,   23.7587662D0,
     6 10.9653997D0,   7.12747383D0,   5.75255251D0,   5.48818254D0,
     7 29.0193520D0,   5.89906597D0,   2.72259998D0,   1.76968110D0,
     8 1.42830181D0,   1.36266136D0,   25.6746540D0,   5.21915436D0,
     9 2.40880013D0,   1.56571209D0,   1.26367927D0,   1.20560443D0,
     * 23.9479465D0,   4.86814880D0,   2.24679995D0,   1.46041262D0,
     1 1.17869258D0,   1.12452340D0,   385.584503D0,   15.9334812D0,
     2 3.39400005D0,   1.43395054D0,   0.934080064D0,  0.0D0,
     3 377.950043D0,   15.6180038D0,   3.32679987D0,   1.40555882D0,
     4 0.915585577D0,  0.0D0,          122.878075D0,   5.07768202D0,
     5 1.08159995D0,   0.456971377D0,  0.297672659D0,  0.0D0,
     6 93.5218506D0,   3.86459684D0,   0.823199987D0,  0.347798496D0,
     7 0.226557061D0,  0.0D0,          86.9780426D0,   3.59418774D0,
     8 0.765600026D0,  0.323462725D0,  0.210704684D0,  0.0D0,
     9 44.9431992D0,   1.85718477D0,   0.395599991D0,  0.167139307D0,
     * 0.108875088D0,  0.0D0,          44.9431992D0,   1.85718477D0,
     1 0.395599991D0,  0.167139307D0,  0.108875088D0,  0.0D0,
     2 14.6781130D0,   0.606542647D0,  0.129199997D0,  5.458644778D-02,
     3 3.555779159D-02,0.0D0,          6.54380274D0,   0.270409107D0,
     4 5.759999901D-02,2.433575504D-02,1.585238986D-02,0.0D0,
     5 6.54380274D0,   0.270409107D0,  5.759999901D-02,2.433575504D-02,
     6 1.585238986D-02,0.0D0/
C * DATA FOR CE ELEMENT #58
      DATA ((XNRG(I, J, 58), I = 1, 6), J = 1, 18)/
     1 862.138855D0,   175.255951D0,   80.8860016D0,   52.5756340D0,
     2 42.4335632D0,   40.4834442D0,   139.603271D0,   28.3786106D0,
     3 13.0976000D0,   8.51339722D0,   6.87112522D0,   6.55534887D0,
     4 131.404602D0,   26.7119827D0,   12.3283997D0,   8.01341915D0,
     5 6.46759558D0,   6.17036438D0,   122.007904D0,   24.8018188D0,
     6 11.4468002D0,   7.44038248D0,   6.00509977D0,   5.72912359D0,
     7 30.5819168D0,   6.21670485D0,   2.86919999D0,   1.86497056D0,
     8 1.50520957D0,   1.43603468D0,   27.1327629D0,   5.51555967D0,
     9 2.54559994D0,   1.65463161D0,   1.33544588D0,   1.27407277D0,
     * 25.2696247D0,   5.13681984D0,   2.37080002D0,   1.54101217D0,
     1 1.24374413D0,   1.18658543D0,   409.578430D0,   16.9249802D0,
     2 3.60520005D0,   1.52318156D0,   0.992205441D0,  0.0D0,
     3 401.398682D0,   16.5869694D0,   3.53320003D0,   1.49276197D0,
     4 0.972389996D0,  0.0D0,          131.603149D0,   5.43822765D0,
     5 1.15839994D0,   0.489419043D0,  0.318809152D0,  0.0D0,
     6 101.474380D0,   4.19321871D0,   0.893199980D0,  0.377373189D0,
     7 0.245822117D0,  0.0D0,          94.1580505D0,   3.89088655D0,
     8 0.828800023D0,  0.350164473D0,  0.228098273D0,  0.0D0,
     9 49.9873810D0,   2.06562519D0,   0.439999998D0,  0.185898125D0,
     * 0.121094644D0,  0.0D0,          49.9873810D0,   2.06562519D0,
     1 0.439999998D0,  0.185898125D0,  0.121094644D0,  0.0D0,
     2 39.0356026D0,   1.61306536D0,   0.343600005D0,  0.145169526D0,
     3 9.456390887D-02,0.0D0,          17.1774826D0,   0.709823906D0,
     4 0.151199996D0,  6.388135254D-02,4.161252454D-02,0.0D0,
     5 8.99772835D0,   0.371812522D0,  7.919999957D-02,3.346166015D-02,
     6 2.179703489D-02,0.0D0,          8.99772835D0,   0.371812522D0,
     7 7.919999957D-02,3.346166015D-02,2.179703489D-02,0.0D0/
C * DATA FOR PR ELEMENT #59
      DATA ((XNRG(I, J, 59), I = 1, 6), J = 1, 18)/
     1 895.129639D0,   181.962326D0,   83.9812012D0,   54.5875053D0,
     2 44.0573349D0,   42.0325928D0,   145.700043D0,   29.6179657D0,
     3 13.6696005D0,   8.88519478D0,   7.17120171D0,   6.84163475D0,
     4 137.292465D0,   27.9088688D0,   12.8808002D0,   8.37247753D0,
     5 6.75738955D0,   6.44684029D0,   127.143257D0,   25.8457355D0,
     6 11.9286003D0,   7.75355101D0,   6.25785637D0,   5.97026443D0,
     7 32.2105637D0,   6.54777670D0,   3.02199984D0,   1.96429002D0,
     8 1.58536983D0,   1.51251101D0,   28.5098667D0,   5.79549742D0,
     9 2.67479992D0,   1.73861122D0,   1.40322542D0,   1.33873737D0,
     * 26.4804516D0,   5.38295746D0,   2.48440003D0,   1.61485183D0,
     1 1.30333972D0,   1.24344218D0,   432.209076D0,   17.8601456D0,
     2 3.80439997D0,   1.60734272D0,   1.04702830D0,   0.0D0,
     3 423.075012D0,   17.4827003D0,   3.72399998D0,   1.57337415D0,
     4 1.02490103D0,   0.0D0,          138.374161D0,   5.71802616D0,
     5 1.21800005D0,   0.514599800D0,  0.335211992D0,  0.0D0,
     6 107.381989D0,   4.43733835D0,   0.945200026D0,  0.399342954D0,
     7 0.260133296D0,  0.0D0,          98.8841324D0,   4.08618212D0,
     8 0.870400012D0,  0.367740303D0,  0.239547223D0,  0.0D0,
     9 51.4415588D0,   2.12571597D0,   0.452800006D0,  0.191306069D0,
     * 0.124617398D0,  0.0D0,          51.4415588D0,   2.12571597D0,
     1 0.452800006D0,  0.191306069D0,  0.124617398D0,  0.0D0,
     2 1.59050763D0,   6.572443992D-02,1.400000043D-02,5.914940499D-03,
     3 3.853011411D-03,0.0D0,          16.9957104D0,   0.702312529D0,
     4 0.149599999D0,  6.320536137D-02,4.117217660D-02,0.0D0,
     5 10.1338062D0,   0.418758541D0,  8.919999748D-02,3.768661991D-02,
     6 2.454918623D-02,0.0D0,          10.1338062D0,   0.418758541D0,
     7 8.919999748D-02,3.768661991D-02,2.454918623D-02,0.0D0/
C * DATA FOR ND ELEMENT #60
      DATA ((XNRG(I, J, 60), I = 1, 6), J = 1, 18)/
     1 928.774841D0,   188.801743D0,   87.1378021D0,   56.6392822D0,
     2 45.7133141D0,   43.6124687D0,   151.907654D0,   30.8798542D0,
     3 14.2519999D0,   9.26375294D0,   7.47673416D0,   7.13312626D0,
     4 143.284775D0,   29.1269913D0,   13.4429998D0,   8.73790550D0,
     5 7.05232525D0,   6.72822142D0,   132.336166D0,   26.9013538D0,
     6 12.4158001D0,   8.07022953D0,   6.51344633D0,   6.21410799D0,
     7 33.5812721D0,   6.82641506D0,   3.15060019D0,   2.04787970D0,
     8 1.65283465D0,   1.57687533D0,   29.9040222D0,   6.07890224D0,
     9 2.80559993D0,   1.82363081D0,   1.47184432D0,   1.40420282D0,
     * 27.6571712D0,   5.62216139D0,   2.59480000D0,   1.68661153D0,
     1 1.36125672D0,   1.29869735D0,   454.203522D0,   18.7690201D0,
     2 3.99799991D0,   1.68913794D0,   1.10030997D0,   0.0D0,
     3 444.296936D0,   18.3596516D0,   3.91079998D0,   1.65229630D0,
     4 1.07631123D0,   0.0D0,          143.236572D0,   5.91895485D0,
     5 1.26080000D0,   0.532682598D0,  0.346991181D0,  0.0D0,
     6 110.562996D0,   4.56878710D0,   0.973199964D0,  0.411172837D0,
     7 0.267839313D0,  0.0D0,          102.065147D0,   4.21763086D0,
     8 0.898400009D0,  0.379570156D0,  0.247253239D0,  0.0D0,
     9 53.3956108D0,   2.20646310D0,   0.469999999D0,  0.198572993D0,
     * 0.129351094D0,  0.0D0,          53.3956108D0,   2.20646310D0,
     1 0.469999999D0,  0.198572993D0,  0.129351094D0,  0.0D0,
     2 1.36329222D0,   5.633522943D-02,1.200000010D-02,5.069948733D-03,
     3 3.302581143D-03,0.0D0,          17.0411530D0,   0.704190373D0,
     4 0.149999991D0,  6.337435544D-02,4.128226265D-02,0.0D0,
     5 9.58848858D0,   0.396224469D0,  8.440000564D-02,3.565864265D-02,
     6 2.322815545D-02,0.0D0,          9.58848858D0,   0.396224469D0,
     7 8.440000564D-02,3.565864265D-02,2.322815545D-02,0.0D0/
C * DATA FOR PM ELEMENT #61
      DATA ((XNRG(I, J, 61), I = 1, 6), J = 1, 18)/
     1 963.204529D0,   195.800629D0,   90.3680038D0,   58.7389030D0,
     2 47.4079094D0,   45.2291832D0,   158.343384D0,   32.1881104D0,
     3 14.8557997D0,   9.65622139D0,   7.79349327D0,   7.43532801D0,
     4 149.494537D0,   30.3893108D0,   14.0255995D0,   9.11659431D0,
     5 7.35796261D0,   7.01981258D0,   137.695358D0,   27.9907703D0,
     6 12.9186001D0,   8.39704800D0,   6.77721977D0,   6.46575928D0,
     7 35.0990677D0,   7.13495350D0,   3.29299998D0,   2.14043927D0,
     8 1.72753906D0,   1.64814651D0,   31.3663960D0,   6.37617397D0,
     9 2.94280005D0,   1.91281044D0,   1.54382074D0,   1.47287142D0,
     * 28.9255543D0,   5.87999916D0,   2.71379995D0,   1.76396108D0,
     1 1.42368519D0,   1.35825694D0,   22.4152260D0,   4.55657673D0,
     2 2.10299993D0,   1.36694312D0,   1.10325372D0,   1.05255151D0,
     3 21.8908195D0,   4.44997501D0,   2.05380011D0,   1.33496320D0,
     4 1.07744288D0,   1.02792692D0,   150.143921D0,   6.20438671D0,
     5 1.32159996D0,   0.558370352D0,  0.363724262D0,  0.0D0,
     6 115.607178D0,   4.77722740D0,   1.01760006D0,   0.429931641D0,
     7 0.280058891D0,  0.0D0,          107.245651D0,   4.43170452D0,
     8 0.944000006D0,  0.398835957D0,  0.259803057D0,  0.0D0,
     9 54.7134628D0,   2.26092052D0,   0.481599987D0,  0.203473940D0,
     * 0.132543594D0,  0.0D0,          54.7134628D0,   2.26092052D0,
     1 0.481599987D0,  0.203473940D0,  0.132543594D0,  0.0D0,
     2 1.81772292D0,   7.511363924D-02,1.599999890D-02,6.759931799D-03,
     3 4.403441679D-03,0.0D0,          17.0411530D0,   0.704190373D0,
     4 0.149999991D0,  6.337435544D-02,4.128226265D-02,0.0D0,
     5 9.58848858D0,   0.396224469D0,  8.440000564D-02,3.565864265D-02,
     6 2.322815545D-02,0.0D0,          9.58848858D0,   0.396224469D0,
     7 8.440000564D-02,3.565864265D-02,2.322815545D-02,0.0D0/
C * DATA FOR SM ELEMENT #62
      DATA ((XNRG(I, J, 62), I = 1, 6), J = 1, 18)/
     1 998.382507D0,   202.951614D0,   93.6684036D0,   60.8841515D0,
     2 49.1393318D0,   46.8810349D0,   164.928314D0,   33.5266991D0,
     3 15.4736004D0,   10.0577888D0,   8.11759758D0,   7.74453688D0,
     4 155.868423D0,   31.6849995D0,   14.6236000D0,   9.50529194D0,
     5 7.67167902D0,   7.31911182D0,   143.171799D0,   29.1040230D0,
     6 13.4323997D0,   8.73101616D0,   7.04676437D0,   6.72291613D0,
     7 36.7255821D0,   7.46559238D0,   3.44560003D0,   2.23962855D0,
     8 1.80759430D0,   1.72452271D0,   32.8436890D0,   6.67647886D0,
     9 3.08139992D0,   2.00289989D0,   1.61653161D0,   1.54224062D0,
     * 30.2664165D0,   6.15257025D0,   2.83959985D0,   1.84573066D0,
     1 1.48968101D0,   1.42121983D0,   23.5770245D0,   4.79274750D0,
     2 2.21199989D0,   1.43779278D0,   1.16043615D0,   1.10710597D0,
     3 23.0270348D0,   4.68094540D0,   2.16039991D0,   1.40425289D0,
     4 1.13336635D0,   1.08128023D0,   157.096710D0,   6.49169636D0,
     5 1.38279998D0,   0.584227085D0,  0.380567431D0,  0.0D0,
     6 120.696808D0,   4.98754597D0,   1.06239998D0,   0.448859483D0,
     7 0.292388529D0,  0.0D0,          112.426170D0,   4.64577866D0,
     8 0.989600003D0,  0.418101788D0,  0.272352874D0,  0.0D0,
     9 58.6215668D0,   2.42241502D0,   0.515999973D0,  0.218007803D0,
     * 0.142010987D0,  0.0D0,          58.6215668D0,   2.42241502D0,
     1 0.515999973D0,  0.218007803D0,  0.142010987D0,  0.0D0,
     2 2.49936914D0,   0.103281252D0,  2.199999988D-02,9.294905700D-03,
     3 6.054732017D-03,0.0D0,          16.9957104D0,   0.702312529D0,
     4 0.149599999D0,  6.320536137D-02,4.117217660D-02,0.0D0,
     5 9.67937469D0,   0.399980128D0,  8.519999683D-02,3.599663451D-02,
     6 2.344832569D-02,0.0D0,          9.67937469D0,   0.399980128D0,
     7 8.519999683D-02,3.599663451D-02,2.344832569D-02,0.0D0/
C * DATA FOR EU ELEMENT #63
      DATA ((XNRG(I, J, 63), I = 1, 6), J = 1, 18)/
     1 1034.29797D0,   210.252533D0,   97.0380020D0,   63.0743828D0,
     2 50.9070549D0,   48.5675201D0,   171.647552D0,   34.8925858D0,
     3 16.1040001D0,   10.4675474D0,   8.44831085D0,   8.06005192D0,
     4 162.376633D0,   33.0079880D0,   15.2342005D0,   9.90217972D0,
     5 7.99200583D0,   7.62471724D0,   148.729233D0,   30.2337418D0,
     6 13.9538002D0,   9.06992435D0,   7.32029581D0,   6.98387671D0,
     7 38.3712883D0,   7.80013180D0,   3.60000014D0,   2.33998823D0,
     8 1.88859415D0,   1.80180001D0,   34.4041214D0,   6.99368429D0,
     9 3.22779989D0,   2.09805942D0,   1.69333446D0,   1.61551392D0,
     * 31.5625134D0,   6.41604137D0,   2.96120000D0,   1.92477024D0,
     1 1.55347359D0,   1.48208058D0,   24.7409534D0,   5.02935123D0,
     2 2.32119989D0,   1.50877237D0,   1.21772349D0,   1.16176057D0,
     3 24.1078262D0,   4.90064907D0,   2.26180005D0,   1.47016263D0,
     4 1.18656170D0,   1.13203084D0,   163.685959D0,   6.76398325D0,
     5 1.44079995D0,   0.608731866D0,  0.396529913D0,  0.0D0,
     6 129.012894D0,   5.33119059D0,   1.13559997D0,   0.479786158D0,
     7 0.312534273D0,  0.0D0,          116.606926D0,   4.81854010D0,
     8 1.02639997D0,   0.433649600D0,  0.282480776D0,  0.0D0,
     9 60.5301743D0,   2.50128436D0,   0.532800019D0,  0.225105733D0,
     * 0.146634609D0,  0.0D0,          60.5301743D0,   2.50128436D0,
     1 0.532800019D0,  0.225105733D0,  0.146634609D0,  0.0D0,
     2 1.32307839D0,   5.467347428D-02,1.164602861D-02,4.920397419D-03,
     3 3.205162939D-03,0.0D0,          14.4508972D0,   0.597153425D0,
     4 0.127199993D0,  5.374145508D-02,3.500736132D-02,0.0D0,
     5 9.99747658D0,   0.413125038D0,  8.799999952D-02,3.717962652D-02,
     6 2.421892807D-02,0.0D0,          9.99747658D0,   0.413125038D0,
     7 8.799999952D-02,3.717962652D-02,2.421892807D-02,0.0D0/
C * DATA FOR GD ELEMENT #64
      DATA ((XNRG(I, J, 64), I = 1, 6), J = 1, 19)/
     1 1070.96606D0,   217.706436D0,   100.478195D0,   65.3105011D0,
     2 52.7118149D0,   50.2893372D0,   178.545853D0,   36.2948761D0,
     3 16.7511997D0,   10.8882246D0,   8.78783798D0,   8.38397598D0,
     4 169.053223D0,   34.3652115D0,   15.8606005D0,   10.3093376D0,
     5 8.32062054D0,   7.93823051D0,   154.397522D0,   31.3859959D0,
     6 14.4855995D0,   9.41559219D0,   7.59928274D0,   7.25004292D0,
     7 40.0937309D0,   8.15027046D0,   3.76160002D0,   2.44502759D0,
     8 1.97337091D0,   1.88268077D0,   35.9901352D0,   7.31609011D0,
     9 3.37660003D0,   2.19477892D0,   1.77139640D0,   1.68998826D0,
     * 32.9140358D0,   6.69077969D0,   3.08800006D0,   2.00718999D0,
     1 1.61999404D0,   1.54554403D0,   25.9475174D0,   5.27462196D0,
     2 2.43440008D0,   1.58235204D0,   1.27710927D0,   1.21841717D0,
     3 25.2653599D0,   5.13595295D0,   2.37039995D0,   1.54075217D0,
     4 1.24353433D0,   1.18638515D0,   170.775070D0,   7.05692673D0,
     5 1.50319993D0,   0.635095596D0,  0.413703322D0,  0.0D0,
     6 131.103271D0,   5.41757154D0,   1.15400004D0,   0.487560064D0,
     7 0.317598224D0,  0.0D0,          123.105293D0,   5.08707142D0,
     8 1.08360004D0,   0.457816362D0,  0.298223078D0,  0.0D0,
     9 63.8475227D0,   2.63836670D0,   0.562000036D0,  0.237442613D0,
     * 0.154670894D0,  0.0D0,          63.8475227D0,   2.63836670D0,
     1 0.562000036D0,  0.237442613D0,  0.154670894D0,  0.0D0,
     2 4.21684551D0,   0.174252421D0,  3.711760789D-02,1.568203233D-02,
     3 1.021532621D-02,0.0D0,          3.87365603D0,   0.160070822D0,
     4 3.409677744D-02,1.440574322D-02,9.383948520D-03,0.0D0,
     5 16.4049511D0,   0.677900612D0,  0.144400001D0,  6.100838631D-02,
     6 3.974106163D-02,0.0D0,          9.22494411D0,   0.381201744D0,
     7 8.120000362D-02,3.430665284D-02,2.234746702D-02,0.0D0,
     8 9.22494411D0,   0.381201744D0,  8.120000362D-02,3.430665284D-02,
     9 2.234746702D-02,0.0D0/
C * DATA FOR TB ELEMENT #65
      DATA ((XNRG(I, J, 65), I = 1, 6), J = 1, 19)/
     1 1108.41211D0,   225.318497D0,   103.991402D0,   67.5940704D0,
     2 54.5548744D0,   52.0476952D0,   185.631760D0,   37.7353020D0,
     3 17.4160004D0,   11.3203430D0,   9.13659859D0,   8.71670818D0,
     4 175.902496D0,   35.7575340D0,   16.5032005D0,   10.7270260D0,
     5 8.65773487D0,   8.25985146D0,   160.178802D0,   32.5612144D0,
     6 15.0279999D0,   9.76815033D0,   7.88383102D0,   7.52151394D0,
     7 41.9419479D0,   8.52597713D0,   3.93499994D0,   2.55773711D0,
     8 2.06433821D0,   1.96946752D0,   37.6827354D0,   7.66016245D0,
     9 3.53539991D0,   2.29799843D0,   1.85470438D0,   1.76946771D0,
     * 34.3486977D0,   6.98241758D0,   3.22259998D0,   2.09467959D0,
     1 1.69060647D0,   1.61291134D0,   27.1796608D0,   5.52509308D0,
     2 2.54999995D0,   1.65749156D0,   1.33775413D0,   1.27627504D0,
     3 26.4591331D0,   5.37862396D0,   2.48239994D0,   1.61355186D0,
     4 1.30229056D0,   1.24244118D0,   180.817993D0,   7.47192955D0,
     5 1.59160006D0,   0.672444224D0,  0.438032359D0,  0.0D0,
     6 140.964417D0,   5.82506275D0,   1.24080002D0,   0.524232686D0,
     7 0.341486901D0,  0.0D0,          129.512772D0,   5.35184717D0,
     8 1.13999999D0,   0.481645137D0,  0.313745201D0,  0.0D0,
     9 66.8013229D0,   2.76042628D0,   0.588000000D0,  0.248427495D0,
     * 0.161826476D0,  0.0D0,          66.8013229D0,   2.76042628D0,
     1 0.588000000D0,  0.248427495D0,  0.161826476D0,  0.0D0,
     2 4.27164888D0,   0.176517054D0,  3.759999946D-02,1.588583924D-02,
     3 1.034808718D-02,0.0D0,          3.90810442D0,   0.161494330D0,
     4 3.440000117D-02,1.453385316D-02,9.467399679D-03,0.0D0,
     5 17.7227993D0,   0.732357979D0,  0.156000003D0,  6.590933353D-02,
     6 4.293355718D-02,0.0D0,          11.5425415D0,   0.476971626D0,
     7 0.101599999D0,  4.292556643D-02,2.796185389D-02,0.0D0,
     8 11.5425415D0,   0.476971626D0,  0.101599999D0,  4.292556643D-02,
     9 2.796185389D-02,0.0D0/
C * DATA FOR DY ELEMENT #66
      DATA ((XNRG(I, J, 66), I = 1, 6), J = 1, 19)/
     1 1146.63000D0,   233.087433D0,   107.577003D0,   69.9246979D0,
     2 56.4359131D0,   53.8422890D0,   192.832764D0,   39.1991272D0,
     3 18.0916004D0,   11.7594805D0,   9.49102497D0,   9.05484581D0,
     4 182.915924D0,   37.1832275D0,   17.1611996D0,   11.1547232D0,
     5 9.00292778D0,   8.58918095D0,   166.064529D0,   33.7576675D0,
     6 15.5802002D0,   10.1270790D0,   8.17352009D0,   7.79789019D0,
     7 43.6324158D0,   8.86961651D0,   4.09359980D0,   2.66082668D0,
     8 2.14754128D0,   2.04884672D0,   39.2623520D0,   7.98126793D0,
     9 3.68360019D0,   2.39432788D0,   1.93245149D0,   1.84364188D0,
     * 35.7194023D0,   7.26105547D0,   3.35119987D0,   2.17826891D0,
     1 1.75807130D0,   1.67727554D0,   28.4054108D0,   5.77426386D0,
     2 2.66499996D0,   1.73224127D0,   1.39808428D0,   1.33383250D0,
     3 27.6038780D0,   5.61132765D0,   2.58980012D0,   1.68336153D0,
     4 1.35863364D0,   1.29619491D0,   189.179520D0,   7.81745195D0,
     5 1.66520000D0,   0.703539908D0,  0.458288163D0,  0.0D0,
     6 150.780121D0,   6.23067665D0,   1.32720006D0,   0.560736358D0,
     7 0.365265489D0,  0.0D0,          133.102768D0,   5.50019646D0,
     8 1.17159998D0,   0.494996011D0,  0.322442025D0,  0.0D0,
     9 70.0732193D0,   2.89563084D0,   0.616800010D0,  0.260595351D0,
     * 0.169752672D0,  0.0D0,          70.0732193D0,   2.89563084D0,
     1 0.616800010D0,  0.260595351D0,  0.169752672D0,  0.0D0,
     2 1.90860915D0,   7.886932045D-02,1.679999940D-02,7.097928319D-03,
     3 4.623613786D-03,0.0D0,          1.90860915D0,   7.886932045D-02,
     4 1.679999940D-02,7.097928319D-03,4.623613786D-03,0.0D0,
     5 28.5836945D0,   1.18116200D0,   0.251599997D0,  0.106299929D0,
     6 6.924411654D-02,0.0D0,          11.9515285D0,   0.493872195D0,
     7 0.105200000D0,  4.444655031D-02,2.895262837D-02,0.0D0,
     8 11.9515285D0,   0.493872195D0,  0.105200000D0,  4.444655031D-02,
     9 2.895262837D-02,0.0D0/
C * DATA FOR HO ELEMENT #67
      DATA ((XNRG(I, J, 67), I = 1, 6), J = 1, 19)/
     1 1185.62378D0,   241.014099D0,   111.235397D0,   72.3026428D0,
     2 58.3551445D0,   55.6733170D0,   200.259750D0,   40.7088852D0,
     3 18.7884007D0,   12.2123985D0,   9.85657215D0,   9.40359402D0,
     4 190.104141D0,   38.6444511D0,   17.8355999D0,   11.5930815D0,
     5 9.35672474D0,   8.92671776D0,   172.054718D0,   34.9753571D0,
     6 16.1422005D0,   10.4923773D0,   8.46835136D0,   8.07917118D0,
     7 45.3697853D0,   9.22278881D0,   4.25659990D0,   2.76677608D0,
     8 2.23305273D0,   2.13042831D0,   40.9890594D0,   8.33227348D0,
     9 3.84559989D0,   2.49962735D0,   2.01743817D0,   1.92472279D0,
     * 37.1178246D0,   7.54532671D0,   3.48239994D0,   2.26354861D0,
     1 1.82690001D0,   1.74294114D0,   29.6631374D0,   6.02993488D0,
     2 2.78299999D0,   1.80894089D0,   1.45998824D0,   1.39289153D0,
     3 28.8083096D0,   5.85616541D0,   2.70280004D0,   1.75681114D0,
     4 1.41791451D0,   1.35275137D0,   197.995483D0,   8.18175316D0,
     5 1.74280000D0,   0.736325562D0,  0.479644865D0,  0.0D0,
     6 156.096954D0,   6.45038366D0,   1.37399995D0,   0.580509126D0,
     7 0.378145546D0,  0.0D0,          139.328461D0,   5.75746059D0,
     8 1.22640002D0,   0.518148780D0,  0.337523788D0,  0.0D0,
     9 73.1633530D0,   3.02332401D0,   0.643999994D0,  0.272087246D0,
     * 0.177238524D0,  0.0D0,          73.1633530D0,   3.02332401D0,
     1 0.643999994D0,  0.272087246D0,  0.177238524D0,  0.0D0,
     2 1.68139374D0,   6.948012114D-02,1.480000000D-02,6.252937019D-03,
     3 4.073183518D-03,0.0D0,          1.68139374D0,   6.948012114D-02,
     4 1.480000000D-02,6.252937019D-03,4.073183518D-03,0.0D0,
     5 23.2668552D0,   0.961454630D0,  0.204799995D0,  8.652712405D-02,
     6 5.636405200D-02,0.0D0,          9.22494411D0,   0.381201744D0,
     7 8.120000362D-02,3.430665284D-02,2.234746702D-02,0.0D0,
     8 9.22494411D0,   0.381201744D0,  8.120000362D-02,3.430665284D-02,
     9 2.234746702D-02,0.0D0/
C * DATA FOR ER ELEMENT #68
      DATA ((XNRG(I, J, 68), I = 1, 6), J = 1, 19)/
     1 1225.44031D0,   249.108032D0,   114.971001D0,   74.7307739D0,
     2 60.3148766D0,   57.5429840D0,   207.872177D0,   42.2563438D0,
     3 19.5025997D0,   12.6766262D0,   10.2312489D0,   9.76105118D0,
     4 197.490616D0,   40.1459770D0,   18.5286007D0,   12.0435295D0,
     5 9.72027874D0,   9.27356434D0,   178.168549D0,   36.2181778D0,
     6 16.7157993D0,   10.8652153D0,   8.76926708D0,   8.36625767D0,
     7 47.0368042D0,   9.56166077D0,   4.41300011D0,   2.86843562D0,
     8 2.31510162D0,   2.20870662D0,   42.7584038D0,   8.69194698D0,
     9 4.01160002D0,   2.60752678D0,   2.10452342D0,   2.00780582D0,
     * 38.6228333D0,   7.85126591D0,   3.62360001D0,   2.35532808D0,
     1 1.90097499D0,   1.81361187D0,   30.9805508D0,   6.29773951D0,
     2 2.90660000D0,   1.88928056D0,   1.52482998D0,   1.45475340D0,
     3 30.0425854D0,   6.10706949D0,   2.81859994D0,   1.83208072D0,
     4 1.47866428D0,   1.41070926D0,   204.084839D0,   8.43338394D0,
     5 1.79639995D0,   0.758971334D0,  0.494396389D0,  0.0D0,
     6 166.412537D0,   6.87665367D0,   1.46480000D0,   0.618871748D0,
     7 0.403135061D0,  0.0D0,          145.417831D0,   6.00909138D0,
     8 1.27999997D0,   0.540794551D0,  0.352275312D0,  0.0D0,
     9 80.2979126D0,   3.31814504D0,   0.706799984D0,  0.298619986D0,
     * 0.194522023D0,  0.0D0,          76.1625900D0,   3.14726162D0,
     1 0.670400023D0,  0.283241153D0,  0.184504196D0,  0.0D0,
     2 1.95405221D0,   8.074716479D-02,1.720000058D-02,7.266926579D-03,
     3 4.733699840D-03,0.0D0,          1.95405221D0,   8.074716479D-02,
     4 1.720000058D-02,7.266926579D-03,4.733699840D-03,0.0D0,
     5 27.1749592D0,   1.12294888D0,   0.239199996D0,  0.101060979D0,
     6 6.583145261D-02,0.0D0,          13.3602638D0,   0.552085280D0,
     7 0.117600001D0,  4.968549684D-02,3.236529604D-02,0.0D0,
     8 13.3602638D0,   0.552085280D0,  0.117600001D0,  4.968549684D-02,
     9 3.236529604D-02,0.0D0/
C * DATA FOR TM ELEMENT #69
      DATA ((XNRG(I, J, 69), I = 1, 6), J = 1, 19)/
     1 1266.03076D0,   257.359253D0,   118.779198D0,   77.2060928D0,
     2 62.3126945D0,   59.4489899D0,   215.640228D0,   43.8354378D0,
     3 20.2313995D0,   13.1503439D0,   10.6135836D0,   10.1258154D0,
     4 205.007126D0,   41.6739349D0,   19.2337990D0,   12.5019064D0,
     5 10.0902338D0,   9.62651730D0,   184.352707D0,   37.4752960D0,
     6 17.2959995D0,   11.2423429D0,   9.07364559D0,   8.65664768D0,
     7 49.1749344D0,   9.99630165D0,   4.61359978D0,   2.99882483D0,
     8 2.42033815D0,   2.30910683D0,   44.5490646D0,   9.05595303D0,
     9 4.17960024D0,   2.71672630D0,   2.19265771D0,   2.09188986D0,
     * 40.1726074D0,   8.16630459D0,   3.76900005D0,   2.44983768D0,
     1 1.97725320D0,   1.88638449D0,   32.2873077D0,   6.56337738D0,
     2 3.02920008D0,   1.96897018D0,   1.58914709D0,   1.51611471D0,
     3 31.2875195D0,   6.36014032D0,   2.93540001D0,   1.90800035D0,
     4 1.53993857D0,   1.46916771D0,   214.354980D0,   8.85777569D0,
     5 1.88679993D0,   0.797164917D0,  0.519275844D0,  0.0D0,
     6 175.364822D0,   7.24658871D0,   1.54359996D0,   0.652164400D0,
     7 0.424822032D0,  0.0D0,          152.961395D0,   6.32081270D0,
     8 1.34640002D0,   0.568848252D0,  0.370549619D0,  0.0D0,
     9 81.6157608D0,   3.37260246D0,   0.718400002D0,  0.303520918D0,
     * 0.197714522D0,  0.0D0,          81.6157608D0,   3.37260246D0,
     1 0.718400002D0,  0.303520918D0,  0.197714522D0,  0.0D0,
     2 2.40848303D0,   9.952557087D-02,2.119999938D-02,8.956909180D-03,
     3 5.834559910D-03,0.0D0,          2.40848303D0,   9.952557087D-02,
     4 2.119999938D-02,8.956909180D-03,5.834559910D-03,0.0D0,
     5 24.1757164D0,   0.999011397D0,  0.212799996D0,  8.990709484D-02,
     6 5.856577307D-02,0.0D0,          14.6781130D0,   0.606542647D0,
     7 0.129199997D0,  5.458644778D-02,3.555779159D-02,0.0D0,
     8 14.6781130D0,   0.606542647D0,  0.129199997D0,  5.458644778D-02,
     9 3.555779159D-02,0.0D0/
C * DATA FOR YB ELEMENT #70
      DATA ((XNRG(I, J, 70), I = 1, 6), J = 1, 19)/
     1 1307.44409D0,   265.777771D0,   122.664604D0,   79.7315903D0,
     2 64.3510132D0,   61.3936348D0,   223.542587D0,   45.4418335D0,
     3 20.9727993D0,   13.6322508D0,   11.0025291D0,   10.4968863D0,
     4 212.709091D0,   43.2395935D0,   19.9563999D0,   12.9715948D0,
     5 10.4693165D0,   9.98817825D0,   190.654129D0,   38.7562523D0,
     6 17.8871994D0,   11.6266212D0,   9.38379478D0,   8.95254326D0,
     7 51.1212120D0,   10.3919420D0,   4.79619980D0,   3.11751413D0,
     8 2.51613188D0,   2.40049815D0,   46.3226700D0,   9.41649151D0,
     9 4.34599972D0,   2.82488561D0,   2.27995276D0,   2.17517304D0,
     * 41.5646286D0,   8.44927597D0,   3.89960003D0,   2.53472710D0,
     1 2.04576707D0,   1.95174980D0,   33.6025887D0,   6.83074808D0,
     2 3.15259981D0,   2.04917955D0,   1.65388381D0,   1.57787621D0,
     3 32.5686951D0,   6.62057781D0,   3.05559993D0,   1.98612988D0,
     4 1.60299659D0,   1.52932775D0,   221.398666D0,   9.14884186D0,
     5 1.94879997D0,   0.823359668D0,  0.536339164D0,  0.0D0,
     6 180.272675D0,   7.44939518D0,   1.58679998D0,   0.670416236D0,
     7 0.436711311D0,  0.0D0,          156.096954D0,   6.45038366D0,
     8 1.37399995D0,   0.580509126D0,  0.378145546D0,  0.0D0,
     9 90.0227356D0,   3.72000313D0,   0.792400002D0,  0.334785610D0,
     * 0.218080446D0,  0.0D0,          84.0242462D0,   3.47212815D0,
     1 0.739600003D0,  0.312477857D0,  0.203549087D0,  0.0D0,
     2 2.86291385D0,   0.118303984D0,  2.520000003D-02,1.064689271D-02,
     3 6.935420446D-03,0.0D0,          2.86291385D0,   0.118303984D0,
     4 2.520000003D-02,1.064689271D-02,6.935420446D-03,0.0D0,
     5 24.5847034D0,   1.01591194D0,   0.216399997D0,  9.142807871D-02,
     6 5.955654755D-02,0.0D0,          10.6336794D0,   0.439414799D0,
     7 9.360000491D-02,3.954559937D-02,2.576013282D-02,0.0D0,
     8 10.6336794D0,   0.439414799D0,  9.360000491D-02,3.954559937D-02,
     9 2.576013282D-02,0.0D0/
C * DATA FOR LU ELEMENT #71
      DATA ((XNRG(I, J, 71), I = 1, 6), J = 1, 19)/
     1 1349.68445D0,   274.364410D0,   126.627602D0,   82.3075256D0,
     2 66.4300385D0,   63.3771133D0,   231.728455D0,   47.1058617D0,
     3 21.7408009D0,   14.1314487D0,   11.4054298D0,   10.8812704D0,
     4 220.605057D0,   44.8446884D0,   20.6972008D0,   13.4531116D0,
     5 10.8579473D0,   10.3589487D0,   197.059998D0,   40.0584412D0,
     6 18.4881992D0,   12.0172691D0,   9.69908524D0,   9.25334454D0,
     7 53.1058617D0,   10.7953815D0,   4.98239994D0,   3.23854375D0,
     8 2.61381435D0,   2.49369121D0,   48.2518921D0,   9.80866528D0,
     9 4.52699995D0,   2.94253516D0,   2.37490702D0,   2.26576352D0,
     * 43.1378517D0,   8.76908112D0,   4.04720020D0,   2.63066673D0,
     1 2.12319946D0,   2.02562356D0,   34.9477158D0,   7.10418606D0,
     2 3.27880001D0,   2.13120914D0,   1.72008955D0,   1.64103937D0,
     3 33.8626595D0,   6.88361549D0,   3.17699981D0,   2.06503940D0,
     4 1.66668427D0,   1.59008849D0,   230.032837D0,   9.50563145D0,
     5 2.02480006D0,   0.855469346D0,  0.557255507D0,  0.0D0,
     6 186.362045D0,   7.70102596D0,   1.64040005D0,   0.693062007D0,
     7 0.451462835D0,  0.0D0,          163.276962D0,   6.74708271D0,
     8 1.43719995D0,   0.607210875D0,  0.395539135D0,  0.0D0,
     9 93.0674210D0,   3.84581852D0,   0.819200039D0,  0.346108496D0,
     * 0.225456208D0,  0.0D0,          88.6139984D0,   3.66178989D0,
     1 0.780000031D0,  0.329546660D0,  0.214667782D0,  0.0D0,
     2 3.13557220D0,   0.129571036D0,  2.759999968D-02,1.166088227D-02,
     3 7.595936768D-03,0.0D0,          3.13557220D0,   0.129571036D0,
     4 2.759999968D-02,1.166088227D-02,7.595936768D-03,0.0D0,
     5 25.8116665D0,   1.06661367D0,   0.227200001D0,  9.599103034D-02,
     6 6.252887100D-02,0.0D0,          12.7240610D0,   0.525795460D0,
     7 0.112000003D0,  4.731952026D-02,3.082409129D-02,0.0D0,
     8 12.7240610D0,   0.525795460D0,  0.112000003D0,  4.731952026D-02,
     9 3.082409129D-02,0.0D0/
C * DATA FOR HF ELEMENT #72
      DATA ((XNRG(I, J, 72), I = 1, 6), J = 1, 20)/
     1 1393.10791D0,   283.191559D0,   130.701599D0,   84.9556122D0,
     2 68.5672989D0,   65.4161530D0,   240.261810D0,   48.8405228D0,
     3 22.5414009D0,   14.6518364D0,   11.8254318D0,   11.2819710D0,
     4 228.935883D0,   46.5381851D0,   21.4787998D0,   13.9611429D0,
     5 11.2679815D0,   10.7501392D0,   203.809082D0,   41.4303970D0,
     6 19.1214008D0,   12.4288473D0,   10.0312672D0,   9.57026100D0,
     7 55.4443779D0,   11.2707567D0,   5.20179987D0,   3.38115287D0,
     8 2.72891355D0,   2.60350084D0,   50.4241333D0,   10.2502394D0,
     9 4.73079967D0,   3.07500434D0,   2.48182249D0,   2.36776543D0,
     * 44.9285126D0,   9.13308716D0,   4.21519995D0,   2.73986626D0,
     1 2.21133375D0,   2.10970759D0,   36.5891533D0,   7.43785858D0,
     2 3.43279982D0,   2.23130870D0,   1.80087936D0,   1.71811640D0,
     3 35.4230919D0,   7.20082092D0,   3.32339978D0,   2.16019893D0,
     4 1.74348700D0,   1.66336167D0,   244.529190D0,   10.1046629D0,
     5 2.15240002D0,   0.909379840D0,  0.592372954D0,  0.0D0,
     6 198.586227D0,   8.20616531D0,   1.74800003D0,   0.738522530D0,
     7 0.481075972D0,  0.0D0,          172.865463D0,   7.14330721D0,
     8 1.52160001D0,   0.642869532D0,  0.418767303D0,  0.0D0,
     9 101.701599D0,   4.20260811D0,   0.895199955D0,  0.378218174D0,
     * 0.246372551D0,  0.0D0,          97.1118469D0,   4.01294613D0,
     1 0.854799986D0,  0.361149341D0,  0.235253856D0,  0.0D0,
     2 7.77076530D0,   0.321110815D0,  6.839999557D-02,2.889870666D-02,
     3 1.882471144D-02,0.0D0,          7.77076530D0,   0.321110815D0,
     4 6.839999557D-02,2.889870666D-02,1.882471144D-02,0.0D0,
     5 29.4925556D0,   1.21871877D0,   0.259599984D0,  0.109679893D0,
     6 7.144583762D-02,0.0D0,          17.3138123D0,   0.715457439D0,
     7 0.152400002D0,  6.438834965D-02,4.194278270D-02,0.0D0,
     8 13.9055805D0,   0.574619353D0,  0.122400001D0,  5.171347782D-02,
     9 3.368632868D-02,0.0D0,          2.27215385D0,   9.389205277D-02,
     * 1.999999955D-02,8.449914865D-03,5.504302215D-03,0.0D0/
C * DATA FOR TA ELEMENT #73
      DATA ((XNRG(I, J, 73), I = 1, 6), J = 1, 20)/
     1 1437.14111D0,   292.142639D0,   134.832794D0,   87.6408768D0,
     2 70.7345657D0,   67.4838181D0,   249.018982D0,   50.6206856D0,
     3 23.3629990D0,   15.1858730D0,   12.2564507D0,   11.6931810D0,
     4 237.392487D0,   48.2572441D0,   22.2721996D0,   14.4768572D0,
     5 11.6842070D0,   11.1472359D0,   210.639175D0,   42.8188210D0,
     6 19.7621994D0,   12.8453655D0,   10.3674374D0,   9.89098072D0,
     7 57.7274666D0,   11.7348642D0,   5.41599989D0,   3.52038217D0,
     8 2.84128499D0,   2.71070790D0,   52.6262169D0,   10.6978798D0,
     9 4.93739986D0,   3.20929360D0,   2.59020662D0,   2.47116852D0,
     * 46.7703362D0,   9.50749397D0,   4.38800001D0,   2.85218573D0,
     1 2.30198646D0,   2.19619393D0,   38.2263298D0,   7.77066422D0,
     2 3.58640003D0,   2.33114839D0,   1.88145947D0,   1.79499328D0,
     3 36.9877892D0,   7.51889324D0,   3.47019982D0,   2.25561857D0,
     4 1.82049978D0,   1.73683500D0,   256.980591D0,   10.6191912D0,
     5 2.26200008D0,   0.955685377D0,  0.622536540D0,  0.0D0,
     6 211.219406D0,   8.72820473D0,   1.85920000D0,   0.785504103D0,
     7 0.511679888D0,  0.0D0,          183.817245D0,   7.59586716D0,
     8 1.61800003D0,   0.683598101D0,  0.445298016D0,  0.0D0,
     9 109.654144D0,   4.53123045D0,   0.965200007D0,  0.407792896D0,
     * 0.265637606D0,  0.0D0,          104.200966D0,   4.30588913D0,
     1 0.917199969D0,  0.387513071D0,  0.252427280D0,  0.0D0,
     2 11.3607683D0,   0.469460249D0,  0.100000001D0,  4.224957153D-02,
     3 2.752150968D-02,0.0D0,          11.3607683D0,   0.469460249D0,
     4 0.100000001D0,  4.224957153D-02,2.752150968D-02,0.0D0,
     5 32.3100243D0,   1.33514500D0,   0.284399986D0,  0.120157786D0,
     6 7.827117294D-02,0.0D0,          20.4039402D0,   0.843150616D0,
     7 0.179600000D0,  7.588023692D-02,4.942863062D-02,0.0D0,
     8 16.5412788D0,   0.683534145D0,  0.145600006D0,  6.151537970D-02,
     9 4.007131979D-02,0.0D0,          2.59025526D0,   0.107036933D0,
     * 2.280000038D-02,9.632902220D-03,6.274904124D-03,0.0D0/
C * DATA FOR W  ELEMENT #74
      DATA ((XNRG(I, J, 74), I = 1, 6), J = 1, 20)/
     1 1482.09094D0,   301.280060D0,   139.050003D0,   90.3820419D0,
     2 72.9469452D0,   69.5945282D0,   257.936066D0,   52.4333496D0,
     3 24.1996002D0,   15.7296610D0,   12.6953392D0,   12.1119003D0,
     4 246.087845D0,   50.0248413D0,   23.0879993D0,   15.0071239D0,
     5 12.1121836D0,   11.5555439D0,   217.582245D0,   44.2302132D0,
     6 20.4135990D0,   13.2687731D0,   10.7091675D0,   10.2170067D0,
     7 60.1064911D0,   12.2184725D0,   5.63920021D0,   3.66546154D0,
     8 2.95837784D0,   2.82241964D0,   54.8901253D0,   11.1580877D0,
     9 5.14979982D0,   3.34735298D0,   2.70163393D0,   2.57747483D0,
     * 48.6249466D0,   9.88449955D0,   4.56199980D0,   2.96528506D0,
     1 2.39326835D0,   2.28328085D0,   39.8976097D0,   8.11040306D0,
     2 3.74320006D0,   2.43306780D0,   1.96371818D0,   1.87347162D0,
     3 38.5674057D0,   7.83999872D0,   3.61840010D0,   2.35194802D0,
     4 1.89824688D0,   1.81100917D0,   270.386292D0,   11.1731539D0,
     5 2.37999988D0,   1.00553989D0,   0.655011952D0,  0.0D0,
     6 223.398148D0,   9.23146629D0,   1.96640003D0,   0.830795586D0,
     7 0.541182935D0,  0.0D0,          193.269394D0,   7.98645782D0,
     8 1.70120001D0,   0.718749762D0,  0.468195915D0,  0.0D0,
     9 117.606674D0,   4.85985279D0,   1.03520000D0,   0.437367588D0,
     * 0.284902662D0,  0.0D0,          111.517303D0,   4.60822201D0,
     1 0.981599987D0,  0.414721817D0,  0.270151138D0,  0.0D0,
     2 16.5867214D0,   0.685411990D0,  0.145999998D0,  6.168437749D-02,
     3 4.018140584D-02,0.0D0,          15.2688732D0,   0.630954564D0,
     4 0.134399995D0,  5.678342655D-02,3.698891029D-02,0.0D0,
     5 35.0366096D0,   1.44781542D0,   0.308400005D0,  0.130297676D0,
     6 8.487633616D-02,0.0D0,          21.2673588D0,   0.878829598D0,
     7 0.187199995D0,  7.909119874D-02,5.152026564D-02,0.0D0,
     8 16.1777344D0,   0.668511391D0,  0.142399997D0,  6.016339362D-02,
     9 3.919063136D-02,0.0D0,          2.77202749D0,   0.114548303D0,
     * 2.439999953D-02,1.030889619D-02,6.715248339D-03,0.0D0/
C * DATA FOR RE ELEMENT #75
      DATA ((XNRG(I, J, 75), I = 1, 6), J = 1, 21)/
     1 1527.95313D0,   310.602966D0,   143.352798D0,   93.1788483D0,
     2 75.2042389D0,   71.7480774D0,   267.036438D0,   54.2832794D0,
     3 25.0534000D0,   16.2846279D0,   13.1432505D0,   12.5392265D0,
     4 254.928162D0,   51.8219070D0,   23.9174004D0,   15.5462313D0,
     5 12.5472946D0,   11.9706583D0,   224.585007D0,   45.6537361D0,
     6 21.0706005D0,   13.6958208D0,   11.0538359D0,   10.5458355D0,
     7 62.4961662D0,   12.7042475D0,   5.86339998D0,   3.81119061D0,
     8 3.07599521D0,   2.93463159D0,   57.1646881D0,   11.6204624D0,
     9 5.36319971D0,   3.48606229D0,   2.81358552D0,   2.68428159D0,
     * 50.4646378D0,   10.2584724D0,   4.73460007D0,   3.07747436D0,
     1 2.48381591D0,   2.36966729D0,   41.5454445D0,   8.44537544D0,
     2 3.89779997D0,   2.53355718D0,   2.04482269D0,   1.95084894D0,
     3 40.1384964D0,   8.15937042D0,   3.76580000D0,   2.44775772D0,
     4 1.97557437D0,   1.88478291D0,   284.019226D0,   11.7365065D0,
     5 2.50000000D0,   1.05623937D0,   0.688037753D0,  0.0D0,
     6 235.349686D0,   9.72533894D0,   2.07159996D0,   0.875242174D0,
     7 0.570135593D0,  0.0D0,          201.949020D0,   8.34512520D0,
     8 1.77759993D0,   0.751028419D0,  0.489222348D0,  0.0D0,
     9 124.377693D0,   5.13965082D0,   1.09480000D0,   0.462548316D0,
     * 0.301305473D0,  0.0D0,          118.242882D0,   4.88614225D0,
     1 1.04079998D0,   0.439733565D0,  0.286443889D0,  0.0D0,
     2 18.4498882D0,   0.762403429D0,  0.162399992D0,  6.861330569D-02,
     3 4.469493032D-02,0.0D0,          18.4498882D0,   0.762403429D0,
     4 0.162399992D0,  6.861330569D-02,4.469493032D-02,0.0D0,
     5 37.6268654D0,   1.55485237D0,   0.331200004D0,  0.139930591D0,
     6 9.115123749D-02,0.0D0,          20.7220421D0,   0.856295526D0,
     7 0.182400003D0,  7.706321776D-02,5.019923300D-02,0.0D0,
     8 15.7233038D0,   0.649733007D0,  0.138400003D0,  5.847340822D-02,
     9 3.808977082D-02,0.0D0,          2.75506401D0,   0.113847315D0,
     * 2.425068244D-02,1.024581026D-02,6.674154196D-03,0.0D0,
     1 2.36718655D0,   9.781908989D-02,2.083650045D-02,8.803332224D-03,
     2 5.734519567D-03,0.0D0/
C * DATA FOR OS ELEMENT #76
      DATA ((XNRG(I, J, 76), I = 1, 6), J = 1, 21)/
     1 1574.73206D0,   320.112183D0,   147.741608D0,   96.0315552D0,
     2 77.5066452D0,   73.9446716D0,   276.443817D0,   56.1956139D0,
     3 25.9360008D0,   16.8583145D0,   13.6062717D0,   12.9809685D0,
     4 264.015778D0,   53.6692390D0,   24.7700005D0,   16.1004181D0,
     5 12.9945765D0,   12.3973846D0,   231.739120D0,   47.1080284D0,
     6 21.7418003D0,   14.1320982D0,   11.4059544D0,   10.8817711D0,
     7 64.9860382D0,   13.2103891D0,   6.09700012D0,   3.96302986D0,
     8 3.19854403D0,   3.05154848D0,   59.5223923D0,   12.0997372D0,
     9 5.58440018D0,   3.62984157D0,   2.92962909D0,   2.79499221D0,
     * 52.3810692D0,   10.6480455D0,   4.91440010D0,   3.19434381D0,
     1 2.57814074D0,   2.45965719D0,   43.2913399D0,   8.80028152D0,
     2 4.06160021D0,   2.64002681D0,   2.13075399D0,   2.03283095D0,
     3 41.7841988D0,   8.49390984D0,   3.92019987D0,   2.54811716D0,
     4 2.05657411D0,   1.96206009D0,   297.334045D0,   12.2867136D0,
     5 2.61720014D0,   1.10575581D0,   0.720292985D0,  0.0D0,
     6 248.346405D0,   10.2624006D0,   2.18600011D0,   0.923575640D0,
     7 0.601620197D0,  0.0D0,          212.764481D0,   8.79205132D0,
     8 1.87279999D0,   0.791249990D0,  0.515422821D0,  0.0D0,
     9 131.512253D0,   5.43447161D0,   1.15759993D0,   0.489081055D0,
     * 0.318589002D0,  0.0D0,          123.968712D0,   5.12275028D0,
     1 1.09119999D0,   0.461027354D0,  0.300314724D0,  0.0D0,
     2 21.0401440D0,   0.869440377D0,  0.185200006D0,  7.824621350D-02,
     3 5.096983537D-02,0.0D0,          21.0401440D0,   0.869440377D0,
     4 0.185200006D0,  7.824621350D-02,5.096983537D-02,0.0D0,
     5 38.0358543D0,   1.57175291D0,   0.334800005D0,  0.141451567D0,
     6 9.214201570D-02,0.0D0,          26.3569832D0,   1.08914781D0,
     7 0.231999993D0,  9.801901132D-02,6.384990364D-02,0.0D0,
     8 20.6311550D0,   0.852539837D0,  0.181600004D0,  7.672522217D-02,
     9 4.997906089D-02,0.0D0,          3.20493889D0,   0.132437468D0,
     * 2.821058221D-02,1.191885024D-02,7.763978094D-03,0.0D0,
     1 2.73928213D0,   0.113195166D0,  2.411176823D-02,1.018711925D-02,
     2 6.635922473D-03,0.0D0/
C * DATA FOR IR ELEMENT #77
      DATA ((XNRG(I, J, 77), I = 1, 6), J = 1, 21)/
     1 1622.48718D0,   329.819885D0,   152.222000D0,   98.9438019D0,
     2 79.8571014D0,   76.1871109D0,   286.047272D0,   58.1478119D0,
     3 26.8369999D0,   17.4439621D0,   14.0789442D0,   13.4319181D0,
     4 273.376221D0,   55.5720367D0,   25.6481991D0,   16.6712456D0,
     5 13.4552889D0,   12.8369246D0,   239.078690D0,   48.6000175D0,
     6 22.4304008D0,   14.5796862D0,   11.7672005D0,   11.2264156D0,
     7 67.6549683D0,   13.7529316D0,   6.34739971D0,   4.12578917D0,
     8 3.32990599D0,   3.17687368D0,   62.0058670D0,   12.6045790D0,
     9 5.81739998D0,   3.78129101D0,   3.05186319D0,   2.91160870D0,
     * 54.3742447D0,   11.0532198D0,   5.10139990D0,   3.31589317D0,
     1 2.67624283D0,   2.55325079D0,   45.1097107D0,   9.16992092D0,
     2 4.23220015D0,   2.75091624D0,   2.22025228D0,   2.11821628D0,
     3 43.4959831D0,   8.84188175D0,   4.08080006D0,   2.65250659D0,
     4 2.14082623D0,   2.04244041D0,   313.602661D0,   12.9589806D0,
     5 2.76040006D0,   1.16625726D0,   0.759703755D0,  0.0D0,
     6 262.251984D0,   10.8370209D0,   2.30839992D0,   0.975289166D0,
     7 0.635306537D0,  0.0D0,          224.625122D0,   9.28216839D0,
     8 1.97720003D0,   0.835358560D0,  0.544155300D0,  0.0D0,
     9 141.509735D0,   5.84759665D0,   1.24559999D0,   0.526260674D0,
     * 0.342807919D0,  0.0D0,          134.011627D0,   5.53775311D0,
     1 1.17960000D0,   0.498375952D0,  0.324643731D0,  0.0D0,
     2 28.8109093D0,   1.19055116D0,   0.253600001D0,  0.107144915D0,
     3 6.979455054D-02,0.0D0,          27.4930611D0,   1.13609385D0,
     4 0.241999999D0,  0.102243967D0,  6.660205126D-02,0.0D0,
     5 43.2618065D0,   1.78770459D0,   0.380800009D0,  0.160886377D0,
     6 0.104801908D0,  0.0D0,          28.6291370D0,   1.18303990D0,
     7 0.252000004D0,  0.106468923D0,  6.935420632D-02,0.0D0,
     8 22.9487514D0,   0.948309720D0,  0.201999992D0,  8.534413576D-02,
     9 5.559344962D-02,0.0D0,          3.66395903D0,   0.151405513D0,
     * 3.225097805D-02,1.362590026D-02,8.875955828D-03,0.0D0,
     1 3.11492109D0,   0.128717676D0,  2.741822600D-02,1.158408355D-02,
     2 7.545909379D-03,0.0D0/
C * DATA FOR PT ELEMENT #78
      DATA ((XNRG(I, J, 78), I = 1, 6), J = 1, 21)/
     1 1671.17188D0,   339.716522D0,   156.789597D0,   101.912727D0,
     2 82.2533112D0,   78.4731979D0,   295.883118D0,   60.1472473D0,
     3 27.7598000D0,   18.0437794D0,   14.5630541D0,   13.8937798D0,
     4 282.937073D0,   57.5155678D0,   26.5452003D0,   17.2542934D0,
     5 13.9258633D0,   13.2858725D0,   246.507797D0,   50.1102104D0,
     6 23.1273994D0,   15.0327339D0,   12.1328535D0,   11.5752640D0,
     7 70.2620850D0,   14.2829065D0,   6.59200001D0,   4.28477812D0,
     8 3.45822549D0,   3.29929590D0,   64.5170593D0,   13.1150541D0,
     9 6.05299997D0,   3.93443012D0,   3.17546129D0,   3.02952647D0,
     * 56.3929977D0,   11.4635925D0,   5.29080009D0,   3.43900251D0,
     1 2.77560377D0,   2.64804530D0,   46.9387398D0,   9.54172707D0,
     2 4.40380001D0,   2.86245537D0,   2.31027508D0,   2.20410180D0,
     3 45.2269554D0,   9.19375515D0,   4.24320030D0,   2.75806618D0,
     4 2.22602296D0,   2.12372160D0,   328.098999D0,   13.5580120D0,
     5 2.88800001D0,   1.22016764D0,   0.794821203D0,  0.0D0,
     6 276.839203D0,   11.4398079D0,   2.43680000D0,   1.02953756D0,
     7 0.670644164D0,  0.0D0,          235.849548D0,   9.74599457D0,
     8 2.07599998D0,   0.877101123D0,  0.571346521D0,  0.0D0,
     9 150.325684D0,   6.21189785D0,   1.32319999D0,   0.559046328D0,
     * 0.364164621D0,  0.0D0,          142.373154D0,   5.88327599D0,
     1 1.25320005D0,   0.529471636D0,  0.344899565D0,  0.0D0,
     2 33.7642059D0,   1.39523590D0,   0.297199994D0,  0.125565737D0,
     3 8.179392666D-02,0.0D0,          32.3100243D0,   1.33514500D0,
     4 0.284399986D0,  0.120157786D0,  7.827117294D-02,0.0D0,
     5 46.2156067D0,   1.90976429D0,   0.406800002D0,  0.171871260D0,
     6 0.111957498D0,  0.0D0,          29.6743279D0,   1.22623014D0,
     7 0.261200011D0,  0.110355884D0,  7.188618183D-02,0.0D0,
     8 23.4940701D0,   0.970843792D0,  0.206799999D0,  8.737211674D-02,
     9 5.691448227D-02,0.0D0,          3.38092208D0,   0.139709607D0,
     * 2.975962311D-02,1.257331390D-02,8.190297522D-03,0.0D0,
     1 2.78356099D0,   0.115024894D0,  2.450151928D-02,1.035178732D-02,
     2 6.743188016D-03,0.0D0/
C * DATA FOR AU ELEMENT #79
      DATA ((XNRG(I, J, 79), I = 1, 6), J = 1, 21)/
     1 372.712921D0,   168.043701D0,   114.162247D0,   92.0403137D0,
     2 82.6876373D0,   0.0D0,          305.964111D0,   62.1965141D0,
     3 28.7056007D0,   18.6585464D0,   15.0592299D0,   14.3671532D0,
     4 292.764404D0,   59.5132713D0,   27.4672012D0,   17.8535900D0,
     5 14.4095535D0,   13.7473335D0,   254.075470D0,   51.6485710D0,
     6 23.8374004D0,   15.4942312D0,   12.5053253D0,   11.9306183D0,
     7 73.0099030D0,   14.8414831D0,   6.84980011D0,   4.45234728D0,
     8 3.59346986D0,   3.42832494D0,   67.1028519D0,   13.6406965D0,
     9 6.29559994D0,   4.09211922D0,   3.30273151D0,   3.15094781D0,
     * 58.4735756D0,   11.8865337D0,   5.48600006D0,   3.56588197D0,
     1 2.87800741D0,   2.74574304D0,   48.8402519D0,   9.92826748D0,
     2 4.58220005D0,   2.97841501D0,   2.40386558D0,   2.29339123D0,
     3 47.0197487D0,   9.55819416D0,   4.41139984D0,   2.86739564D0,
     4 2.31426215D0,   2.20790577D0,   344.822052D0,   14.2490578D0,
     5 3.03519988D0,   1.28235900D0,   0.835332870D0,  0.0D0,
     6 292.517059D0,   12.0876627D0,   2.57480001D0,   1.08784199D0,
     7 0.708623827D0,  0.0D0,          247.846527D0,   10.2417450D0,
     8 2.18160009D0,   0.921716690D0,  0.600409269D0,  0.0D0,
     9 159.959625D0,   6.61000013D0,   1.40799999D0,   0.594873965D0,
     * 0.387502849D0,  0.0D0,          151.734421D0,   6.27011108D0,
     1 1.33560002D0,   0.564285278D0,  0.367577285D0,  0.0D0,
     2 39.2628174D0,   1.62245464D0,   0.345600009D0,  0.146014526D0,
     3 9.511433542D-02,0.0D0,          37.6268654D0,   1.55485237D0,
     4 0.331200004D0,  0.139930591D0,  9.115123749D-02,0.0D0,
     5 48.9876328D0,   2.02431273D0,   0.431199998D0,  0.182180166D0,
     6 0.118672751D0,  0.0D0,          32.5826836D0,   1.34641194D0,
     7 0.286799997D0,  0.121171772D0,  7.893168926D-02,0.0D0,
     8 24.4029312D0,   1.00840068D0,   0.214800000D0,  9.075208008D-02,
     9 5.911620334D-02,0.0D0,          3.77558589D0,   0.156018272D0,
     * 3.323354200D-02,1.404102985D-02,9.146372788D-03,0.0D0,
     1 3.08572841D0,   0.127511337D0,  2.716126479D-02,1.147551835D-02,
     2 7.475190330D-03,0.0D0/
C * DATA FOR HG ELEMENT #80
      DATA ((XNRG(I, J, 80), I = 1, 6), J = 1, 22)/
     1 383.689545D0,   172.992691D0,   117.524399D0,   94.7509613D0,
     2 85.1228409D0,   0.0D0,          316.335022D0,   64.3047180D0,
     3 29.6786003D0,   19.2909927D0,   15.5696745D0,   14.8541393D0,
     4 302.892303D0,   61.5720711D0,   28.4174004D0,   18.4712181D0,
     5 14.9080381D0,   14.2229090D0,   261.860565D0,   53.2311287D0,
     6 24.5678005D0,   15.9689894D0,   12.8885002D0,   12.2961836D0,
     7 75.9239883D0,   15.4338598D0,   7.12319994D0,   4.63005686D0,
     8 3.73689818D0,   3.56516171D0,   69.8890381D0,   14.2070723D0,
     9 6.55700016D0,   4.26202822D0,   3.43986440D0,   3.28177857D0,
     * 60.6927147D0,   12.3376408D0,   5.69420004D0,   3.70121121D0,
     1 2.98723125D0,   2.84994698D0,   50.8398209D0,   10.3347406D0,
     2 4.76979971D0,   3.10035419D0,   2.50228214D0,   2.38728476D0,
     3 48.9212570D0,   9.94473362D0,   4.58979988D0,   2.98335481D0,
     4 2.40785241D0,   2.29719496D0,   363.680939D0,   15.0283613D0,
     5 3.20120001D0,   1.35249329D0,   0.881018579D0,  0.0D0,
     6 307.604156D0,   12.7111053D0,   2.70759988D0,   1.14394939D0,
     7 0.745172381D0,  0.0D0,          259.479950D0,   10.7224722D0,
     8 2.28399992D0,   0.964980245D0,  0.628591299D0,  0.0D0,
     9 171.911148D0,   7.10387278D0,   1.51320004D0,   0.639320552D0,
     * 0.416455477D0,  0.0D0,          163.504181D0,   6.75647211D0,
     1 1.43920004D0,   0.608055890D0,  0.396089584D0,  0.0D0,
     2 46.4428215D0,   1.91915357D0,   0.408800006D0,  0.172716260D0,
     3 0.112507932D0,  0.0D0,          44.7614288D0,   1.84967339D0,
     4 0.393999994D0,  0.166463315D0,  0.108434752D0,  0.0D0,
     5 54.6680183D0,   2.25904274D0,   0.481200010D0,  0.203304946D0,
     6 0.132433504D0,  0.0D0,          36.5816765D0,   1.51166201D0,
     7 0.321999997D0,  0.136043623D0,  8.861926198D-02,0.0D0,
     8 26.1752110D0,   1.08163643D0,   0.230399996D0,  9.734302014D-02,
     9 6.340955943D-02,0.0D0,          2.90835667D0,   0.120181821D0,
     * 2.559999935D-02,1.081589051D-02,7.045506500D-03,0.0D0,
     1 2.90835667D0,   0.120181821D0,  2.559999935D-02,1.081589051D-02,
     2 7.045506500D-03,0.0D0,          3.50529981D0,   0.144849256D0,
     3 3.085442446D-02,1.303586271D-02,8.491603658D-03,0.0D0/
C * DATA FOR TL ELEMENT #81
      DATA ((XNRG(I, J, 81), I = 1, 6), J = 1, 22)/
     1 394.900269D0,   178.047226D0,   120.958252D0,   97.5194168D0,
     2 87.6099777D0,   0.0D0,          327.151459D0,   66.5034866D0,
     3 30.6934013D0,   19.9506092D0,   16.1020489D0,   15.3620472D0,
     4 313.320740D0,   63.6919708D0,   29.3957996D0,   19.1071720D0,
     5 15.4213142D0,   14.7125969D0,   269.824768D0,   54.8500900D0,
     6 25.3150005D0,   16.4546661D0,   13.2804890D0,   12.6701574D0,
     7 78.9617157D0,   16.0513706D0,   7.40819979D0,   4.81530571D0,
     8 3.88641191D0,   3.70780420D0,   72.8137817D0,   14.8016167D0,
     9 6.83139992D0,   4.44038773D0,   3.58381724D0,   3.41911578D0,
     * 63.0269699D0,   12.8121490D0,   5.91319990D0,   3.84356046D0,
     1 3.10212064D0,   2.95955658D0,   52.9758263D0,   10.7689486D0,
     2 4.97020006D0,   3.23061371D0,   2.60741401D0,   2.48758507D0,
     3 50.9336205D0,   10.3538074D0,   4.77860022D0,   3.10607433D0,
     4 2.50689888D0,   2.39168930D0,   384.221191D0,   15.8771458D0,
     5 3.38199997D0,   1.42888057D0,   0.930777490D0,  0.0D0,
     6 327.780884D0,   13.5448675D0,   2.88520002D0,   1.21898472D0,
     7 0.794050574D0,  0.0D0,          276.748322D0,   11.4360514D0,
     8 2.43600011D0,   1.02919960D0,   0.670423985D0,  0.0D0,
     9 184.771545D0,   7.63530159D0,   1.62639999D0,   0.687147021D0,
     * 0.447609842D0,  0.0D0,          175.501160D0,   7.25222206D0,
     1 1.54480004D0,   0.652671397D0,  0.425152272D0,  0.0D0,
     2 55.8040962D0,   2.30598879D0,   0.491200000D0,  0.207529902D0,
     3 0.135185659D0,  0.0D0,          53.8500443D0,   2.22524166D0,
     4 0.474000007D0,  0.200262979D0,  0.130451962D0,  0.0D0,
     5 61.9389153D0,   2.55949736D0,   0.545200050D0,  0.230344683D0,
     6 0.150047272D0,  0.0D0,          45.2613029D0,   1.87032962D0,
     7 0.398400009D0,  0.168322295D0,  0.109645694D0,  0.0D0,
     8 34.2640762D0,   1.41589212D0,   0.301600009D0,  0.127424717D0,
     9 8.300486952D-02,0.0D0,          6.95279026D0,   0.287309676D0,
     * 6.120000035D-02,2.585673891D-02,1.684316434D-02,0.0D0,
     1 5.95304298D0,   0.245997176D0,  5.240000039D-02,2.213877626D-02,
     2 1.442127116D-02,0.0D0,          4.39199686D0,   0.181490168D0,
     3 3.865932673D-02,1.633340120D-02,1.063963026D-02,0.0D0/
C * DATA FOR PB ELEMENT #82
      DATA ((XNRG(I, J, 82), I = 1, 6), J = 1, 23)/
     1 406.323364D0,   183.197510D0,   124.457153D0,   100.340317D0,
     2 90.1442337D0,   0.0D0,          338.110718D0,   68.7312927D0,
     3 31.7215996D0,   20.6189365D0,   16.6414528D0,   15.8766613D0,
     4 324.024200D0,   65.8677750D0,   30.4000015D0,   19.7599010D0,
     5 15.9481287D0,   15.2152004D0,   277.876343D0,   56.4868164D0,
     6 26.0704002D0,   16.9456749D0,   13.6767788D0,   13.0482349D0,
     7 82.0868378D0,   16.6866474D0,   7.70139980D0,   5.00588465D0,
     8 4.04022741D0,   3.85455060D0,   75.7662354D0,   15.4017925D0,
     9 7.10839987D0,   4.62043667D0,   3.72913408D0,   3.55775428D0,
     * 65.3676147D0,   13.2879572D0,   6.13280010D0,   3.98629975D0,
     1 3.21732497D0,   3.06946635D0,   55.1182213D0,   11.2044554D0,
     2 5.17119980D0,   3.36126304D0,   2.71286035D0,   2.58818555D0,
     3 52.9523735D0,   10.7641811D0,   4.96799994D0,   3.22918367D0,
     4 2.60625982D0,   2.48648405D0,   406.079315D0,   16.7803879D0,
     5 3.57439995D0,   1.51016879D0,   0.983728826D0,  0.0D0,
     6 347.139648D0,   14.3448277D0,   3.05559993D0,   1.29097795D0,
     7 0.840947270D0,  0.0D0,          292.880615D0,   12.1026850D0,
     8 2.57800007D0,   1.08919406D0,   0.709504545D0,  0.0D0,
     9 197.768265D0,   8.17236423D0,   1.74080002D0,   0.735480547D0,
     * 0.479094446D0,  0.0D0,          187.634460D0,   7.75360537D0,
     1 1.65160000D0,   0.697793961D0,  0.454545259D0,  0.0D0,
     2 64.9381561D0,   2.68343496D0,   0.571600020D0,  0.241498560D0,
     3 0.157312959D0,  0.0D0,          62.7568893D0,   2.59329844D0,
     4 0.552399993D0,  0.233386651D0,  0.152028829D0,  0.0D0,
     5 66.9376450D0,   2.76605964D0,   0.589199960D0,  0.248934478D0,
     6 0.162156731D0,  0.0D0,          47.6243439D0,   1.96797740D0,
     7 0.419200003D0,  0.177110210D0,  0.115370169D0,  0.0D0,
     8 39.0810432D0,   1.61494327D0,   0.344000012D0,  0.145338535D0,
     9 9.467399120D-02,0.0D0,          9.90659046D0,   0.409369349D0,
     * 8.720000088D-02,3.684162721D-02,2.399875596D-02,0.0D0,
     1 8.72507000D0,   0.360545486D0,  7.680000365D-02,3.244767338D-02,
     2 2.113652043D-02,0.0D0,          5.31246948D0,   0.219526812D0,
     3 4.676153511D-02,1.975654811D-02,1.286948007D-02,0.0D0,
     4 2.23201036D0,   9.223321080D-02,1.964665018D-02,8.300625719D-03,
     5 5.407054443D-03,0.0D0/
C * DATA FOR BI ELEMENT #83
      DATA ((XNRG(I, J, 83), I = 1, 6), J = 1, 23)/
     1 417.964874D0,   188.446274D0,   128.022949D0,   103.215149D0,
     2 92.7269363D0,   0.0D0,          349.338593D0,   71.0136948D0,
     3 32.7750015D0,   21.3036423D0,   17.1940765D0,   16.4038887D0,
     4 334.919525D0,   68.0825806D0,   31.4222012D0,   20.4243279D0,
     5 16.4843845D0,   15.7268114D0,   286.049408D0,   58.1482468D0,
     6 26.8372002D0,   17.4440918D0,   14.0790491D0,   13.4320183D0,
     7 85.2503357D0,   17.3297253D0,   7.99819994D0,   5.19880342D0,
     8 4.19593143D0,   4.00309896D0,   78.7954330D0,   16.0175686D0,
     9 7.39260006D0,   4.80516577D0,   3.87822795D0,   3.69999623D0,
     * 67.7231903D0,   13.7667990D0,   6.35379982D0,   4.12994909D0,
     1 3.33326364D0,   3.18007684D0,   57.2925911D0,   11.6464624D0,
     2 5.37519979D0,   3.49386215D0,   2.81988072D0,   2.69028759D0,
     3 54.9903145D0,   11.1784544D0,   5.15919971D0,   3.35346293D0,
     4 2.70656514D0,   2.58217955D0,   426.346924D0,   17.6179047D0,
     5 3.75279999D0,   1.58554196D0,   1.03282726D0,   0.0D0,
     6 365.953094D0,   15.1222534D0,   3.22119999D0,   1.36094320D0,
     7 0.886522889D0,  0.0D0,          308.513031D0,   12.7486629D0,
     8 2.71560001D0,   1.14732945D0,   0.747374117D0,  0.0D0,
     9 210.674103D0,   8.70567131D0,   1.85440004D0,   0.783476114D0,
     * 0.510358870D0,  0.0D0,          199.949524D0,   8.26250076D0,
     1 1.75999999D0,   0.743592501D0,  0.484378576D0,  0.0D0,
     2 73.5723343D0,   3.04022455D0,   0.647599995D0,  0.273608238D0,
     3 0.178229287D0,  0.0D0,          71.5273972D0,   2.95572186D0,
     4 0.629599988D0,  0.266003311D0,  0.173275426D0,  0.0D0,
     5 72.3908234D0,   2.99140072D0,   0.637199998D0,  0.269214272D0,
     6 0.175367057D0,  0.0D0,          53.0775108D0,   2.19331837D0,
     7 0.467200011D0,  0.197390005D0,  0.128580496D0,  0.0D0,
     8 42.1711731D0,   1.74263644D0,   0.371199995D0,  0.156830415D0,
     9 0.102159843D0,  0.0D0,          12.0424147D0,   0.497627884D0,
     * 0.105999999D0,  4.478454962D-02,2.917280048D-02,0.0D0,
     1 11.0881100D0,   0.458193213D0,  9.759999812D-02,4.123558104D-02,
     2 2.686099336D-02,0.0D0,          6.46809006D0,   0.267280430D0,
     3 5.693355948D-02,2.405418642D-02,1.566897519D-02,0.0D0,
     4 2.80379581D0,   0.115861058D0,  2.467963099D-02,1.042703912D-02,
     5 6.792207249D-03,0.0D0/
C * DATA FOR PO ELEMENT #84
      DATA ((XNRG(I, J, 84), I = 1, 6), J = 1, 24)/
     1 429.872772D0,   193.815140D0,   131.670349D0,   106.155762D0,
     2 95.3687439D0,   0.0D0,          361.101532D0,   73.4048691D0,
     3 33.8786011D0,   22.0209789D0,   17.7730350D0,   16.9562397D0,
     4 346.285950D0,   70.3931503D0,   32.4886017D0,   21.1174831D0,
     5 17.0438271D0,   16.2605438D0,   294.474060D0,   59.8608093D0,
     6 27.6276016D0,   17.9578495D0,   14.4937010D0,   13.8276148D0,
     7 88.4543457D0,   17.9810371D0,   8.29880047D0,   5.39419270D0,
     8 4.35362911D0,   4.15354967D0,   82.1593170D0,   16.7013817D0,
     9 7.70819998D0,   5.01030445D0,   4.04379463D0,   3.85795403D0,
     * 70.3878632D0,   14.3084745D0,   6.60379982D0,   4.29244804D0,
     1 3.46441603D0,   3.30520177D0,   59.6460304D0,   12.1248703D0,
     2 5.59599972D0,   3.63738155D0,   2.93571448D0,   2.80079794D0,
     3 57.1945343D0,   11.6265287D0,   5.36600018D0,   3.48788238D0,
     4 2.81505442D0,   2.68568301D0,   452.294922D0,   18.6901512D0,
     5 3.98119998D0,   1.68203998D0,   1.09568632D0,   0.0D0,
     6 386.720581D0,   15.9804268D0,   3.40400004D0,   1.43817544D0,
     7 0.936832190D0,  0.0D0,          320.373688D0,   13.2387791D0,
     8 2.81999993D0,   1.19143796D0,   0.776106596D0,  0.0D0,
     9 227.306259D0,   9.39296055D0,   2.00079989D0,   0.845329463D0,
     * 0.550650358D0,  0.0D0,          215.127518D0,   8.88969898D0,
     1 1.89359999D0,   0.800037920D0,  0.521147311D0,  0.0D0,
     2 79.6816254D0,   3.29267836D0,   0.701375306D0,  0.296328098D0,
     3 0.193029076D0,  0.0D0,          76.9632339D0,   3.18034625D0,
     4 0.677447379D0,  0.286218643D0,  0.186443746D0,  0.0D0,
     5 77.6650696D0,   3.20934820D0,   0.683625102D0,  0.288828701D0,
     6 0.188143954D0,  0.0D0,          57.1197777D0,   2.36035657D0,
     7 0.502780914D0,  0.212422788D0,  0.138372898D0,  0.0D0,
     8 44.6769676D0,   1.84618330D0,   0.393256575D0,  0.166149214D0,
     9 0.108230144D0,  0.0D0,          14.2691259D0,   0.589642107D0,
     * 0.125599995D0,  5.306546390D-02,3.456701711D-02,0.0D0,
     1 14.2691259D0,   0.589642107D0,  0.125599995D0,  5.306546390D-02,
     2 3.456701711D-02,0.0D0,          7.62429142D0,   0.315058053D0,
     3 6.711070240D-02,2.835398540D-02,1.846987754D-02,0.0D0,
     4 3.43538022D0,   0.141959980D0,  3.023897670D-02,1.277583838D-02,
     5 8.322223090D-03,0.0D0,          2.45154977D0,   0.101305217D0,
     6 2.157908306D-02,9.117070585D-03,5.938889459D-03,0.0D0/
C * DATA FOR AT ELEMENT #85
      DATA ((XNRG(I, J, 85), I = 1, 6), J = 1, 24)/
     1 441.992126D0,   199.279358D0,   135.382523D0,   109.148605D0,
     2 98.0574646D0,   0.0D0,          372.904938D0,   75.8042755D0,
     3 34.9860001D0,   22.7407856D0,   18.3539867D0,   17.5104923D0,
     4 357.805847D0,   72.7349243D0,   33.5694008D0,   21.8199997D0,
     5 17.6108246D0,   16.8014851D0,   302.994598D0,   61.5928688D0,
     6 28.4269981D0,   18.4774551D0,   14.9130726D0,   14.2277126D0,
     7 92.0271378D0,   18.7073154D0,   8.63399982D0,   5.61207151D0,
     8 4.52947807D0,   4.32131720D0,   85.4400635D0,   17.3682919D0,
     9 8.01599979D0,   5.21037388D0,   4.20526934D0,   4.01200819D0,
     * 73.0333481D0,   14.8462505D0,   6.85200024D0,   4.45377731D0,
     1 3.59462404D0,   3.42942595D0,   62.0058670D0,   12.6045790D0,
     2 5.81739998D0,   3.78129101D0,   3.05186319D0,   2.91160870D0,
     3 59.4051476D0,   12.0759029D0,   5.57340002D0,   3.62269163D0,
     4 2.92385840D0,   2.78948665D0,   22.2127113D0,   4.51540947D0,
     5 2.08400011D0,   1.35459316D0,   1.09328616D0,   1.04304194D0,
     6 402.625641D0,   16.6376705D0,   3.54399991D0,   1.49732482D0,
     7 0.975362301D0,  0.0D0,          336.278748D0,   13.8960238D0,
     8 2.96000004D0,   1.25058734D0,   0.814636707D0,  0.0D0,
     9 242.302475D0,   10.0126486D0,   2.13280010D0,   0.901098907D0,
     * 0.586978734D0,  0.0D0,          216.029388D0,   8.92696762D0,
     1 1.90153849D0,   0.803391874D0,  0.523332119D0,  0.0D0,
     2 89.5572205D0,   3.70076704D0,   0.788302481D0,  0.333054453D0,
     3 0.216952756D0,  0.0D0,          86.6041489D0,   3.57873726D0,
     4 0.762308896D0,  0.322072238D0,  0.209798917D0,  0.0D0,
     5 84.3500137D0,   3.48558974D0,   0.742467463D0,  0.313689321D0,
     6 0.204338253D0,  0.0D0,          62.9383812D0,   2.60079837D0,
     7 0.553997576D0,  0.234061599D0,  0.152468488D0,  0.0D0,
     8 49.2721024D0,   2.03606772D0,   0.433703929D0,  0.183238059D0,
     9 0.119361870D0,  0.0D0,          18.9016819D0,   0.781072855D0,
     * 0.166376784D0,  7.029347867D-02,4.578940198D-02,0.0D0,
     1 17.1146832D0,   0.707228839D0,  0.150647223D0,  6.364781410D-02,
     2 4.146039113D-02,0.0D0,          8.78822899D0,   0.363155365D0,
     3 7.735593617D-02,3.268255293D-02,2.128952183D-02,0.0D0,
     4 4.10398197D0,   0.169588551D0,  3.612415865D-02,1.526230201D-02,
     5 9.941913188D-03,0.0D0,          2.83769464D0,   0.117261857D0,
     6 2.497801557D-02,1.055310573D-02,6.874327082D-03,0.0D0/
C * DATA FOR RN ELEMENT #86
      DATA ((XNRG(I, J, 86), I = 1, 6), J = 1, 24)/
     1 454.338654D0,   204.845993D0,   139.164276D0,   112.197540D0,
     2 100.796585D0,   0.0D0,          384.757416D0,   78.2136536D0,
     3 36.0979996D0,   23.4635811D0,   18.9373531D0,   18.0670490D0,
     4 369.581573D0,   75.1287003D0,   34.6741982D0,   22.5381165D0,
     5 18.1904144D0,   17.3544369D0,   311.647308D0,   63.3517990D0,
     6 29.2388000D0,   19.0051231D0,   15.3389511D0,   14.6340189D0,
     7 95.5445023D0,   19.4223270D0,   8.96399975D0,   5.82657051D0,
     8 4.70259953D0,   4.48648214D0,   88.6589890D0,   18.0226364D0,
     9 8.31799984D0,   5.40667248D0,   4.36370134D0,   4.16315889D0,
     * 75.4208908D0,   15.3315916D0,   7.07599974D0,   4.59937668D0,
     1 3.71213651D0,   3.54153800D0,   64.4104691D0,   13.0933867D0,
     2 6.04299974D0,   3.92793012D0,   3.17021489D0,   3.02452135D0,
     3 61.6583939D0,   12.5339441D0,   5.78480005D0,   3.76010108D0,
     4 3.03476095D0,   2.89529252D0,   23.3851681D0,   4.75374651D0,
     5 2.19400001D0,   1.42609274D0,   1.15099323D0,   1.09809697D0,
     6 422.166168D0,   17.4451427D0,   3.71600008D0,   1.56999409D0,
     7 1.02269936D0,   0.0D0,          349.002808D0,   14.4218187D0,
     8 3.07200003D0,   1.29790688D0,   0.845460773D0,  0.0D0,
     9 257.480469D0,   10.6398468D0,   2.26640010D0,   0.957544327D0,
     * 0.623747468D0,  0.0D0,          244.029312D0,   10.0840063D0,
     1 2.14800000D0,   0.907520831D0,  0.591162026D0,  0.0D0,
     2 99.8069687D0,   4.12431622D0,   0.878523052D0,  0.371172220D0,
     3 0.241782799D0,  0.0D0,          96.6063461D0,   3.99205732D0,
     4 0.850350440D0,  0.359269410D0,  0.234029278D0,  0.0D0,
     5 91.2637482D0,   3.77128530D0,   0.803323686D0,  0.339400828D0,
     6 0.221086800D0,  0.0D0,          68.9694824D0,   2.85002112D0,
     7 0.607084632D0,  0.256490648D0,  0.167078853D0,  0.0D0,
     8 53.9939003D0,   2.23118615D0,   0.475266248D0,  0.200797960D0,
     9 0.130800441D0,  0.0D0,          22.1267567D0,   0.914342403D0,
     * 0.194764599D0,  8.228721470D-02,5.360215902D-02,0.0D0,
     1 20.1108532D0,   0.831039429D0,  0.177020177D0,  7.479026914D-02,
     2 4.871862754D-02,0.0D0,          9.97006226D0,   0.411992192D0,
     3 8.775869757D-02,3.707767278D-02,2.415251732D-02,0.0D0,
     4 4.80451918D0,   0.198536798D0,  4.229043797D-02,1.786752976D-02,
     5 1.163896732D-02,0.0D0,          3.23821735D0,   0.133812636D0,
     6 2.850350551D-02,1.204260904D-02,7.844595239D-03,0.0D0/
C * DATA FOR FR ELEMENT #87
      DATA ((XNRG(I, J, 87), I = 1, 6), J = 1, 24)/
     1 466.957123D0,   210.535233D0,   143.029312D0,   115.313629D0,
     2 103.596031D0,   0.0D0,          397.334656D0,   80.7703629D0,
     3 37.2779999D0,   24.2305775D0,   19.5563908D0,   18.6576385D0,
     4 381.719696D0,   77.5961456D0,   35.8129997D0,   23.2783337D0,
     5 18.7878399D0,   17.9244061D0,   320.425812D0,   65.1362915D0,
     6 30.0623989D0,   19.5404606D0,   15.7710190D0,   15.0462303D0,
     7 99.1684570D0,   20.1590061D0,   9.30399990D0,   6.04756927D0,
     8 4.88096666D0,   4.65665197D0,   92.2403107D0,   18.7506485D0,
     9 8.65400028D0,   5.62507153D0,   4.53997040D0,   4.33132696D0,
     * 78.0855713D0,   15.8732672D0,   7.32600021D0,   4.76187611D0,
     1 3.84328890D0,   3.66666293D0,   66.8555756D0,   13.5904293D0,
     2 6.27239990D0,   4.07703924D0,   3.29056048D0,   3.13933635D0,
     3 63.9457474D0,   12.9989185D0,   5.99940014D0,   3.89959025D0,
     4 3.14734197D0,   3.00269961D0,   24.5789413D0,   4.99641752D0,
     5 2.30599999D0,   1.49889243D0,   1.20974946D0,   1.15415299D0,
     6 445.342133D0,   18.4028416D0,   3.92000008D0,   1.65618324D0,
     7 1.07884324D0,   0.0D0,          368.088898D0,   15.2105122D0,
     8 3.24000001D0,   1.36888611D0,   0.891696930D0,  0.0D0,
     9 274.158081D0,   11.3290148D0,   2.41319990D0,   1.01956666D0,
     * 0.664149106D0,  0.0D0,          262.206543D0,   10.8351431D0,
     1 2.30800009D0,   0.975120127D0,  0.635196447D0,  0.0D0,
     2 112.011917D0,   4.62866068D0,   0.985953689D0,  0.416561216D0,
     3 0.271349341D0,  0.0D0,          108.546692D0,   4.48546743D0,
     4 0.955451965D0,  0.403674394D0,  0.262954801D0,  0.0D0,
     5 99.9908829D0,   4.13191652D0,   0.880141914D0,  0.371856183D0,
     6 0.242228344D0,  0.0D0,          76.8030090D0,   3.17372537D0,
     7 0.676037073D0,  0.285622776D0,  0.186055616D0,  0.0D0,
     8 60.4199524D0,   2.49672937D0,   0.531829774D0,  0.224695817D0,
     9 0.146367580D0,  0.0D0,          27.0558186D0,   1.11802578D0,
     * 0.238151312D0,  0.100617915D0,  6.554283947D-02,0.0D0,
     1 24.7905121D0,   1.02441657D0,   0.218211561D0,  9.219345450D-02,
     2 6.005511805D-02,0.0D0,          12.6640158D0,   0.523314238D0,
     3 0.111471474D0,  4.709622264D-02,3.067863174D-02,0.0D0,
     4 6.89143038D0,   0.284774095D0,  6.065989658D-02,2.562854625D-02,
     5 1.669451967D-02,0.0D0,          4.82253885D0,   0.199281439D0,
     6 4.244905338D-02,1.793454401D-02,1.168262027D-02,0.0D0/
C * DATA FOR RA ELEMENT #88
      DATA ((XNRG(I, J, 88), I = 1, 6), J = 1, 24)/
     1 479.815216D0,   216.332504D0,   146.967758D0,   118.488899D0,
     2 106.448647D0,   0.0D0,          410.076080D0,   83.3604355D0,
     3 38.4734001D0,   25.0075836D0,   20.1835098D0,   19.2559376D0,
     4 394.036865D0,   80.0999832D0,   36.9686012D0,   24.0294685D0,
     5 19.3940773D0,   18.5027847D0,   329.234161D0,   66.9268646D0,
     6 30.8888016D0,   20.0776196D0,   16.2045574D0,   15.4598446D0,
     7 102.792412D0,   20.8956852D0,   9.64400005D0,   6.26856852D0,
     8 5.05933380D0,   4.82682180D0,   95.7043839D0,   19.4548283D0,
     9 8.97900009D0,   5.83632040D0,   4.71046829D0,   4.49398947D0,
     * 80.8312454D0,   16.4314098D0,   7.58360004D0,   4.92931509D0,
     1 3.97842836D0,   3.79559183D0,   69.2473831D0,   14.0766373D0,
     2 6.49679995D0,   4.22289848D0,   3.40828276D0,   3.25164843D0,
     3 66.1883392D0,   13.4547930D0,   6.20980024D0,   4.03634977D0,
     4 3.25771999D0,   3.10800505D0,   25.7599239D0,   5.23648834D0,
     5 2.41680002D0,   1.57091200D0,   1.26787615D0,   1.20960844D0,
     6 22.5452633D0,   4.58301067D0,   2.11520004D0,   1.37487304D0,
     7 1.10965395D0,   1.05865765D0,   399.490082D0,   16.5081005D0,
     8 3.51640010D0,   1.48566401D0,   0.967766345D0,  0.0D0,
     9 288.972504D0,   11.9411907D0,   2.54360008D0,   1.07466018D0,
     * 0.700037122D0,  0.0D0,          273.885406D0,   11.3177481D0,
     1 2.41079998D0,   1.01855266D0,   0.663488567D0,  0.0D0,
     2 135.829346D0,   5.61286688D0,   1.19560003D0,   0.505135894D0,
     3 0.329047173D0,  0.0D0,          135.829346D0,   5.61286688D0,
     4 1.19560003D0,   0.505135894D0,  0.329047173D0,  0.0D0,
     5 115.607178D0,   4.77722740D0,   1.01760006D0,   0.429931641D0,
     6 0.280058891D0,  0.0D0,          91.0679245D0,   3.76319337D0,
     7 0.801599979D0,  0.338672578D0,  0.220612422D0,  0.0D0,
     8 69.4370193D0,   2.86934090D0,   0.611199975D0,  0.258229375D0,
     9 0.168211460D0,  0.0D0,          30.5377464D0,   1.26190913D0,
     * 0.268799990D0,  0.113566853D0,  7.397782058D-02,0.0D0,
     1 30.5377464D0,   1.26190913D0,   0.268799990D0,  0.113566853D0,
     2 7.397782058D-02,0.0D0,          19.7677383D0,   0.816860855D0,
     3 0.173999995D0,  7.351426035D-02,4.788742587D-02,0.0D0,
     4 8.54329777D0,   0.353034109D0,  7.519999892D-02,3.177167848D-02,
     5 2.069617435D-02,0.0D0,          8.54329777D0,   0.353034109D0,
     6 7.519999892D-02,3.177167848D-02,2.069617435D-02,0.0D0/
C * DATA FOR AC ELEMENT #89
      DATA ((XNRG(I, J, 89), I = 1, 6), J = 1, 24)/
     1 492.897217D0,   222.230743D0,   150.974792D0,   121.719460D0,
     2 109.350937D0,   0.0D0,          422.936829D0,   85.9747772D0,
     3 39.6800003D0,   25.7918701D0,   20.8165035D0,   19.8598404D0,
     4 406.803864D0,   82.6952591D0,   38.1664009D0,   24.8080349D0,
     5 20.0224552D0,   19.1022835D0,   338.328156D0,   68.7754898D0,
     6 31.7420006D0,   20.6321964D0,   16.6521549D0,   15.8868713D0,
     7 106.629539D0,   21.6756973D0,   10.0039997D0,   6.50256729D0,
     8 5.24819326D0,   5.00700188D0,   99.2537231D0,   20.1763401D0,
     9 9.31200027D0,   6.05276918D0,   4.88516331D0,   4.66065598D0,
     * 83.3296432D0,   16.9392853D0,   7.81799984D0,   5.08167410D0,
     1 4.10139704D0,   3.91290903D0,   71.8438416D0,   14.6044455D0,
     2 6.74039984D0,   4.38123798D0,   3.53607774D0,   3.37357020D0,
     3 68.6206512D0,   13.9492350D0,   6.43800020D0,   4.18467903D0,
     4 3.37743568D0,   3.22221899D0,   27.0517559D0,   5.49909258D0,
     5 2.53800011D0,   1.64969170D0,   1.33145881D0,   1.27026904D0,
     6 23.0227718D0,   4.68007898D0,   2.16000009D0,   1.40399289D0,
     7 1.13315642D0,   1.08107996D0,   404.443359D0,   16.7127857D0,
     8 3.55999994D0,   1.50408483D0,   0.979765713D0,  0.0D0,
     9 306.695313D0,   12.6735487D0,   2.69959998D0,   1.14056945D0,
     * 0.742970705D0,  0.0D0,          289.472382D0,   11.9618473D0,
     1 2.54800010D0,   1.07651913D0,   0.701248050D0,  0.0D0,
     2 138.121368D0,   5.70758009D0,   1.21577489D0,   0.513659716D0,
     3 0.334599614D0,  0.0D0,          134.087570D0,   5.54089117D0,
     4 1.18026841D0,   0.498658359D0,  0.324827671D0,  0.0D0,
     5 118.722435D0,   4.90595865D0,   1.04502118D0,   0.441516966D0,
     6 0.287605584D0,  0.0D0,          93.6906281D0,   3.87157130D0,
     7 0.824685633D0,  0.348426163D0,  0.226965934D0,  0.0D0,
     8 74.1787567D0,   3.06528354D0,   0.652937829D0,  0.275863439D0,
     9 0.179698348D0,  0.0D0,          37.7796021D0,   1.56116390D0,
     * 0.332544416D0,  0.140498593D0,  9.152124077D-02,0.0D0,
     1 34.9634132D0,   1.44479060D0,   0.307755679D0,  0.130025461D0,
     2 8.469901234D-02,0.0D0,          18.3879013D0,   0.759841919D0,
     3 0.161854371D0,  6.838277727D-02,4.454476759D-02,0.0D0,
     4 11.4448824D0,   0.472936064D0,  0.100740388D0,  4.256238416D-02,
     5 2.772527561D-02,0.0D0,          8.36247349D0,   0.345561922D0,
     6 7.360834628D-02,3.109921142D-02,2.025812678D-02,0.0D0/
C * DATA FOR TH ELEMENT #90
      DATA ((XNRG(I, J, 90), I = 1, 6), J = 1, 24)/
     1 506.266418D0,   228.258469D0,   155.069794D0,   125.020943D0,
     2 112.316940D0,   0.0D0,          436.411560D0,   88.7139282D0,
     3 40.9441986D0,   26.6135941D0,   21.4797153D0,   20.4925709D0,
     4 419.807465D0,   85.3386383D0,   39.3864021D0,   25.6010303D0,
     5 20.6624794D0,   19.7128944D0,   347.479706D0,   70.6358185D0,
     6 32.6006012D0,   21.1902828D0,   17.1025829D0,   16.3166008D0,
     7 110.473068D0,   22.4570122D0,   10.3646002D0,   6.73695612D0,
     8 5.43736744D0,   5.18748236D0,   102.971481D0,   20.9320869D0,
     9 9.66079998D0,   6.27948856D0,   5.06814718D0,   4.83523035D0,
     * 86.2522583D0,   17.5333958D0,   8.09220028D0,   5.25990343D0,
     1 4.24524498D0,   4.05014610D0,   74.4147110D0,   15.1270542D0,
     2 6.98159981D0,   4.53801727D0,   3.66261339D0,   3.49429083D0,
     3 71.0295105D0,   14.4389095D0,   6.66400003D0,   4.33157825D0,
     4 3.49599743D0,   3.33533192D0,   28.3414593D0,   5.76126385D0,
     5 2.65899992D0,   1.72834122D0,   1.39493656D0,   1.33082950D0,
     6 24.9029655D0,   5.06228542D0,   2.33640003D0,   1.51865232D0,
     7 1.22569752D0,   1.16936815D0,   439.570862D0,   18.1643562D0,
     8 3.86919999D0,   1.63472044D0,   1.06486225D0,   0.0D0,
     9 324.509003D0,   13.4096622D0,   2.85640001D0,   1.20681679D0,
     * 0.786124408D0,  0.0D0,          307.376953D0,   12.7017164D0,
     1 2.70560002D0,   1.14310443D0,   0.744621992D0,  0.0D0,
     2 156.505951D0,   6.46728468D0,   1.37759995D0,   0.582030118D0,
     3 0.379136324D0,  0.0D0,          152.325180D0,   6.29452324D0,
     4 1.34080005D0,   0.566482306D0,  0.369008392D0,  0.0D0,
     5 131.875809D0,   5.44949436D0,   1.16079998D0,   0.490433037D0,
     6 0.319469690D0,  0.0D0,          104.246414D0,   4.30776739D0,
     7 0.917599976D0,  0.387682080D0,  0.252537370D0,  0.0D0,
     8 82.6155090D0,   3.41391516D0,   0.727200031D0,  0.307238907D0,
     9 0.200136423D0,  0.0D0,          42.8528175D0,   1.77080405D0,
     * 0.377200007D0,  0.159365386D0,  0.103811137D0,  0.0D0,
     1 39.9444618D0,   1.65062225D0,   0.351599991D0,  0.148549497D0,
     2 9.676562995D-02,0.0D0,          27.0386295D0,   1.11731541D0,
     3 0.238000005D0,  0.100553982D0,  6.550119072D-02,0.0D0,
     4 22.2671070D0,   0.920142114D0,  0.195999995D0,  8.280916512D-02,
     5 5.394215882D-02,0.0D0,          19.5405216D0,   0.807471633D0,
     6 0.172000006D0,  7.266926765D-02,4.733699560D-02,0.0D0/
C * DATA FOR PA ELEMENT #91
      DATA ((XNRG(I, J, 91), I = 1, 6), J = 1, 24)/
     1 519.889099D0,   234.400482D0,   159.242432D0,   128.385025D0,
     2 115.339180D0,   0.0D0,          449.894806D0,   91.4548035D0,
     3 42.2091980D0,   27.4358406D0,   22.1433449D0,   21.1257038D0,
     4 433.034882D0,   88.0275192D0,   40.6273994D0,   26.4076767D0,
     5 21.3135185D0,   20.3340130D0,   356.705872D0,   72.5113220D0,
     6 33.4662018D0,   21.7529202D0,   17.5566864D0,   16.7498341D0,
     7 114.408257D0,   23.2569580D0,   10.7337999D0,   6.97693491D0,
     8 5.63105297D0,   5.37226677D0,   106.606094D0,   21.6709328D0,
     9 10.0018005D0,   6.50113726D0,   5.24703884D0,   5.00590086D0,
     * 88.9744873D0,   18.0867710D0,   8.34759998D0,   5.42591286D0,
     1 4.37923002D0,   4.17797375D0,   76.9813232D0,   15.6487970D0,
     2 7.22239971D0,   4.69453621D0,   3.78893948D0,   3.61481118D0,
     3 73.3701630D0,   14.9147177D0,   6.88359976D0,   4.47431755D0,
     4 3.61120176D0,   3.44524169D0,   29.5693417D0,   6.01086807D0,
     5 2.77420020D0,   1.80322099D0,   1.45537162D0,   1.38848710D0,
     6 26.0988693D0,   5.30538940D0,   2.44860005D0,   1.59158194D0,
     7 1.28455877D0,   1.22552431D0,   21.4602070D0,   4.36244011D0,
     8 2.01340008D0,   1.30870342D0,   1.05624866D0,   1.00770664D0,
     9 337.823822D0,   13.9598703D0,   2.97359991D0,   1.25633335D0,
     * 0.818379641D0,  0.0D0,          321.827850D0,   13.2988701D0,
     1 2.83279991D0,   1.19684589D0,   0.779629350D0,  0.0D0,
     2 168.684692D0,   6.97054577D0,   1.48479998D0,   0.627321661D0,
     3 0.408639371D0,  0.0D0,          163.367859D0,   6.75083828D0,
     4 1.43799996D0,   0.607548833D0,  0.395759314D0,  0.0D0,
     5 140.691757D0,   5.81379557D0,   1.23839998D0,   0.523218691D0,
     6 0.340826362D0,  0.0D0,          106.165833D0,   4.38708353D0,
     7 0.934495151D0,  0.394820213D0,  0.257187188D0,  0.0D0,
     8 83.1835709D0,   3.43738890D0,   0.732200205D0,  0.309351444D0,
     9 0.201512545D0,  0.0D0,          43.9338608D0,   1.81547582D0,
     * 0.386715561D0,  0.163385674D0,  0.106429957D0,  0.0D0,
     1 40.5537643D0,   1.67580032D0,   0.356963187D0,  0.150815427D0,
     2 9.824166447D-02,0.0D0,          20.6577549D0,   0.853638947D0,
     3 0.181834131D0,  7.682414353D-02,5.004349723D-02,0.0D0,
     4 12.9717808D0,   0.536032021D0,  0.114180483D0,  4.824076593D-02,
     5 3.142419457D-02,0.0D0,          9.23429012D0,   0.381587923D0,
     6 8.128226548D-02,3.434140980D-02,2.237010561D-02,0.0D0/
C * DATA FOR U  ELEMENT #92
      DATA ((XNRG(I, J, 92), I = 1, 6), J = 1, 24)/
     1 533.762024D0,   240.655319D0,   163.491714D0,   131.810898D0,
     2 118.416931D0,   0.0D0,          463.810791D0,   94.2836533D0,
     3 43.5148010D0,   28.2844772D0,   22.8282757D0,   21.7791576D0,
     4 446.547974D0,   90.7744598D0,   41.8951988D0,   27.2317429D0,
     5 21.9786186D0,   20.9685478D0,   365.940582D0,   74.3885498D0,
     6 34.3325996D0,   22.3160782D0,   18.0112076D0,   17.1834660D0,
     7 118.268829D0,   24.0417385D0,   11.0959997D0,   7.21236372D0,
     8 5.82106686D0,   5.55354786D0,   110.470932D0,   22.4565792D0,
     9 10.3643999D0,   6.73682594D0,   5.43726254D0,   5.18738222D0,
     * 91.7372208D0,   18.6483803D0,   8.60680008D0,   5.59439182D0,
     1 4.51520872D0,   4.30770350D0,   79.4626694D0,   16.1532059D0,
     2 7.45519972D0,   4.84585571D0,   3.91106844D0,   3.73132753D0,
     3 75.7129440D0,   15.3909588D0,   7.10339975D0,   4.61718655D0,
     4 3.72651100D0,   3.55525160D0,   30.7140846D0,   6.24357176D0,
     5 2.88160014D0,   1.87303054D0,   1.51171470D0,   1.44224083D0,
     6 27.1285000D0,   5.51469278D0,   2.54519987D0,   1.65437162D0,
     7 1.33523607D0,   1.27387261D0,   22.2745323D0,   4.52797604D0,
     8 2.08979988D0,   1.35836315D0,   1.09632885D0,   1.04594493D0,
     9 354.637756D0,   14.6546717D0,   3.12159991D0,   1.31886268D0,
     * 0.859111428D0,  0.0D0,          335.233551D0,   13.8528328D0,
     1 2.95079994D0,   1.24670041D0,   0.812104702D0,  0.0D0,
     2 177.818756D0,   7.34799194D0,   1.56519997D0,   0.661290348D0,
     3 0.430766672D0,  0.0D0,          173.092667D0,   7.15269661D0,
     4 1.52359998D0,   0.643714488D0,  0.419317722D0,  0.0D0,
     5 147.099228D0,   6.07857132D0,   1.29480004D0,   0.547047496D0,
     6 0.356348515D0,  0.0D0,          117.833893D0,   4.86924171D0,
     7 1.03719997D0,   0.438212574D0,  0.285453111D0,  0.0 D0,
     8 88.6594391D0,   3.66366792D0,   0.780400038D0,  0.329715669D0,
     9 0.214777872D0,  0.0D0,          47.7152290D0,   1.97173309D0,
     * 0.419999987D0,  0.177448213D0,  0.115590341D0,  0.0D0,
     1 43.7616806D0,   1.80836093D0,   0.385199994D0,  0.162745357D0,
     2 0.106012858D0,  0.0D0,          32.1282539D0,   1.32763362D0,
     3 0.282799989D0,  0.119481795D0,  7.783082873D-02,0.0D0,
     4 19.2224197D0,   0.794326723D0,  0.169200003D0,  7.148627937D-02,
     5 4.656639323D-02,0.0D0,          14.6781130D0,   0.606542647D0,
     6 0.129199997D0,  5.458644778D-02,3.555779159D-02,0.0D0/
C * DATA FOR LI ELEMENT # 3
      DATA ((XSC(3, I, J), J = 1, 10), I = 1, 2)/
     1 1.301553100D-03,5.167718977D-02,2.04572558D0,   73.6826706D0,
     2 2367.26001D0,   6.531799585D-02,2174.78979D0,   189729.859D0,
     3 1618910.88D0,   3022227.00D0,   2.456936636D-05,8.661831380D-04,
     4 3.219022229D-02,1.14365172D0,   35.4625931D0,   2.25543308D0,
     5 17745.8359D0,   440576.219D0,   1333729.63D0,   1448481.13D0/
C * DATA FOR BE ELEMENT # 4
      DATA ((XSC(4, I, J), J = 1, 10), I = 1, 2)/
     1 5.501731299D-03,0.216350690D0,  8.28356647D0,   277.734161D0,
     2 7976.12500D0,   2.560380660D-02,866.962646D0,   81105.0859D0,
     3 771925.063D0,   2051785.63D0,   2.081731509D-04,7.329026237D-03,
     4 0.263835013D0,  8.65200520D0,   237.105286D0,   4.02921534D0,
     5 31112.8418D0,   621490.375D0,   1648233.50D0,   1031229.06D0/
C * DATA FOR B  ELEMENT # 5
      DATA ((XSC(5, I, J), J = 1, 10), I = 1, 3)/
     1 1.651980355D-02,0.639404237D0,  23.6173916D0,   741.657715D0,
     2 19577.5059D0,   1.335961837D-02,447.895050D0,   43871.5781D0,
     3 435450.094D0,   1167093.38D0,   8.280635811D-04,2.931262553D-02,
     4 1.02559197D0,   31.2025394D0,   776.768555D0,   3.39596200D0,
     5 26979.2715D0,   581240.375D0,   1365937.50D0,   870618.875D0,
     6 1.498534630D-07,1.311181040D-05,1.204593806D-03,0.104659230D0,
     7 7.67965651D0,   0.400328189D0,  30321.8242D0,   1377606.13D0,
     8 6894477.00D0,   14448549.0D0/
C * DATA FOR C  ELEMENT # 6
      DATA ((XSC(6, I, J), J = 1, 10), I = 1, 3)/
     1 4.022771120D-02,1.52750432D0,   54.3804855D0,   1610.34399D0,
     2 39562.0547D0,   8.320189081D-03,275.130463D0,   27737.3262D0,
     3 281872.813D0,   765563.438D0,   2.234945307D-03,7.857172936D-02,
     4 2.65592504D0,   75.4173965D0,   1707.09705D0,   2.68837976D0,
     5 21804.5703D0,   492388.406D0,   1077516.38D0,   678007.188D0,
     6 1.561928684D-06,1.310063381D-04,1.182175893D-02,0.941143930D0,
     7 63.7416344D0,   1.06329751D0,   76115.4297D0,   3070108.00D0,
     8 11207961.0D0,   18938980.0D0/
C * DATA FOR N  ELEMENT # 7
      DATA ((XSC(7, I, J), J = 1, 10), I = 1, 4)/
     1 8.473966271D-02,3.15485168D0,   108.397171D0,   3054.15259D0,
     2 70342.9141D0,   5.561249331D-03,182.452774D0,   18816.3184D0,
     3 196109.391D0,   545683.125D0,   4.933742341D-03,0.170914933D0,
     4 5.56366348D0,   148.861649D0,   3093.78003D0,   2.19790149D0,
     5 17981.0859D0,   406345.625D0,   854337.875D0,   509074.750D0,
     6 5.528737347D-06,4.511051520D-04,3.958846256D-02,2.99486256D0,
     7 182.204178D0,   0.817081749D0,  60970.3750D0,   2508748.50D0,
     8 7526410.50D0,   10705870.0D0,   2.359686050D-06,2.124716120D-04,
     9 1.939095370D-02,1.48126984D0,   90.3186340D0,   0.402362198D0,
     * 30338.6758D0,   1251751.25D0,   3764252.50D0,   5362577.00D0/
C * DATA FOR O  ELEMENT # 8
      DATA ((XSC(8, I, J), J = 1, 10), I = 1, 4)/
     1 0.160504997D0,  5.85706615D0,   194.312134D0,   5221.68848D0,
     2 111657.734D0,   4.204052500D-03,135.399689D0,   14075.4473D0,
     3 147497.984D0,   417832.938D0,   9.546677582D-03,0.325384855D0,
     4 10.1911001D0,   256.266083D0,   4902.52197D0,   5.65027618D0,
     5 33413.8359D0,   514644.063D0,   839019.875D0,   466361.438D0,
     6 1.560978126D-05,1.245745225D-03,0.105102435D0,  7.58270359D0,
     7 419.397400D0,   5.73374319D0,   230141.391D0,   3959252.50D0,
     8 8621531.00D0,   10632627.0D0,   1.317946135D-05,1.174610457D-03,
     9 0.102651693D0,  7.48369217D0,   415.102356D0,   5.65493631D0,
     * 228981.328D0,   3953836.50D0,   8638009.00D0,   10673776.0D0/
C * DATA FOR F  ELEMENT # 9
      DATA ((XSC(9, I, J), J = 1, 10), I = 1, 4)/
     1 0.280725479D0,  10.0407209D0,   322.387848D0,   8296.84570D0,
     2 164967.891D0,   3.362095449D-03,102.271927D0,   10743.9775D0,
     3 113532.219D0,   328530.594D0,   1.684946194D-02,0.564888954D0,
     4 17.0781956D0,   405.708954D0,   7241.59912D0,   4.16125727D0,
     5 25509.5801D0,   409591.969D0,   663627.438D0,   342294.719D0,
     6 3.755814032D-05,2.953280695D-03,0.240616351D0,  16.3673668D0,
     7 847.311951D0,   6.02639341D0,   224444.438D0,   3326680.75D0,
     8 6272801.50D0,   6917325.50D0,   4.756415365D-05,4.174075089D-03,
     9 0.351481318D0,  24.1645908D0,   1255.78772D0,   8.86773872D0,
     * 334560.344D0,   4983429.00D0,   9439702.00D0,   10439668.0D0/
C * DATA FOR NE ELEMENT #10
      DATA ((XSC(10, I, J), J = 1, 10), I = 1, 4)/
     1 0.461048841D0,  16.1760311D0,   504.382843D0,   12496.9648D0,
     2 235837.344D0,   2.751233522D-03,77.5974884D0,   8264.11914D0,
     3 88570.9688D0,   262354.688D0,   2.783099376D-02,0.915888429D0,
     4 26.7597961D0,   604.638611D0,   10104.3848D0,   2.09819627D0,
     5 14937.3867D0,   281951.719D0,   503242.344D0,   240853.344D0,
     6 8.132271614D-05,6.272922270D-03,0.495196134D0,  31.8960037D0,
     7 1569.13635D0,   0.647712648D0,  45953.0586D0,   1562452.63D0,
     8 3068620.50D0,   2868416.00D0,   1.363403426D-04,1.177385636D-02,
     9 0.960985005D0,  62.6071243D0,   3095.17505D0,   1.25661778D0,
     * 91011.9609D0,   3113751.25D0,   6153211.00D0,   5780000.50D0/
C * DATA FOR NA ELEMENT #11
      DATA ((XSC(11, I, J), J = 1, 11), I = 1, 4)/
     1 0.719678938D0,  24.7575035D0,   749.831604D0,   17837.6504D0,
     2 0.0000D+00,     40.4996109D0,   5139.83252D0,   44760.4258D0,
     3 137345.703D0,   242031.281D0,   194894.047D0,   4.549028352D-02,
     4 1.47548819D0,   41.7576790D0,   896.968445D0,   13934.4736D0,
     5 1.17296302D0,   9320.54199D0,   201357.344D0,   518224.594D0,
     6 355563.563D0,   0.0D0,          1.788535155D-04,1.378671546D-02,
     7 1.06470704D0,   65.0138245D0,   2978.45313D0,   0.172413975D0,
     8 16576.0566D0,   938347.875D0,   2437551.50D0,   1397262.13D0,
     9 0.0D0,          3.001188161D-04,2.587055042D-02,2.06276727D0,
     * 127.485764D0,   5874.59863D0,   0.329745412D0,  32774.9375D0,
     1 1869307.13D0,   4888040.00D0,   2814550.00D0,   0.0D0/
C * DATA FOR MG ELEMENT #12
      DATA ((XSC(12, I, J), J = 1, 11), I = 1, 4)/
     1 1.07748890D0,   36.3590317D0,   1071.03394D0,   24479.2656D0,
     2 0.000000000D0,  31.9452724D0,   4077.84326D0,   35751.1758D0,
     3 110366.938D0,   192795.563D0,   195278.125D0,   7.123360038D-02,
     4 2.27467704D0,   62.3694611D0,   1277.60583D0,   18539.1563D0,
     5 0.615424693D0,  5559.92969D0,   139329.063D0,   436742.563D0,
     6 487870.688D0,   0.0D0,          3.576920135D-04,2.731011063D-02,
     7 2.05052972D0,   119.007393D0,   5120.11670D0,   4.636003450D-02,
     8 5738.63086D0,   450838.188D0,   2111516.75D0,   1120995.88D0,
     9 0.0D0,          5.990033969D-04,5.106269196D-02,3.96210837D0,
     * 232.971024D0,   10091.8086D0,   8.693627268D-02,11313.0215D0,
     1 896493.500D0,   4229249.00D0,   2257596.50D0,   0.0D0/
C * DATA FOR AL ELEMENT #13
      DATA ((XSC(13, I, J), J = 1, 11), I = 1, 5)/
     1 1.55751050D0,   51.5725327D0,   1478.33850D0,   32428.1270D0,
     2 0.000000000D0,  25.9100971D0,   3315.86548D0,   29194.6914D0,
     3 90483.5703D0,   157688.125D0,   167248.469D0,   0.107318684D0,
     4 3.36706495D0,   89.3895264D0,   1748.37085D0,   23709.1934D0,
     5 0.384381026D0,  3783.99194D0,   104031.250D0,   369606.750D0,
     6 494166.094D0,   0.0D0,          6.674015895D-04,5.023531988D-02,
     7 3.65229011D0,   201.835403D0,   8114.76563D0,   2.148255892D-02,
     8 2929.53931D0,   269588.344D0,   1592395.75D0,   1433475.88D0,
     9 0.0D0,          1.112943166D-03,9.348440170D-02,7.03663921D0,
     * 394.388367D0,   15981.2051D0,   3.948111460D-02,5758.07031D0,
     1 535215.063D0,   3186256.00D0,   2885157.25D0,   0.0D0,
     2 7.879838347D-03,0.224162638D0,  5.65236759D0,   109.529068D0,
     3 1489.20581D0,   58.8560448D0,   45791.7344D0,   266193.563D0,
     4 71344.7734D0,   347980.688D0,   0.0D0/
C * DATA FOR SI ELEMENT #14
      DATA ((XSC(14, I, J), J = 1, 11), I = 1, 6)/
     1 2.18636870D0,   71.0673218D0,   1984.17834D0,   41781.9570D0,
     2 0.000000000D0,  21.3957233D0,   2740.57544D0,   24228.9063D0,
     3 75374.5000D0,   131083.328D0,   142535.563D0,   0.156227812D0,
     4 4.81014633D0,   123.655083D0,   2312.42090D0,   29410.8008D0,
     5 0.263393164D0,  2770.06958D0,   81446.5391D0,   310726.656D0,
     6 444896.500D0,   0.0D0,          1.176461577D-03,8.714818954D-02,
     7 6.12822819D0,   323.639862D0,   12196.4600D0,   1.126069110D-02,
     8 1652.95496D0,   172008.016D0,   1209017.13D0,   1656120.25D0,
     9 0.0D0,          1.959844725D-03,0.161601678D0,  11.7720785D0,
     * 631.226135D0,   24000.7852D0,   2.011139318D-02,3237.92676D0,
     1 340892.344D0,   2417061.00D0,   3331674.75D0,   0.0D0,
     2 1.411816571D-02,0.401187301D0,  9.87669754D0,   183.102570D0,
     3 2358.03467D0,   44.4429398D0,   42208.6055D0,   313736.125D0,
     4 162653.281D0,   80005.2031D0,   0.0D0,          6.249973376D-05,
     5 3.996924497D-03,0.261709213D0,  13.4452877D0,   475.203278D0,
     6 32.8313789D0,   122243.977D0,   216556.953D0,   11214985.0D0,
     7 32290612.0D0,   0.0D0/
C * DATA FOR P  ELEMENT #15
      DATA ((XSC(15, I, J), J = 1, 11), I = 1, 7)/
     1 2.99109888D0,   95.5345459D0,   2601.35400D0,   52644.3086D0,
     2 0.000000000D0,  17.7680607D0,   2290.75854D0,   20345.6113D0,
     3 63556.0977D0,   110514.297D0,   121777.781D0,   0.220793724D0,
     4 6.66793537D0,   166.183395D0,   2980.13110D0,   35851.7344D0,
     5 0.176890522D0,  1945.68689D0,   61948.0781D0,   254934.203D0,
     6 385898.719D0,   0.0D0,          1.978232060D-03,0.144055828D0,
     7 9.80049324D0,   496.497589D0,   17670.9141D0,   6.065215450D-03,
     8 949.569885D0,   110775.891D0,   887976.250D0,   1629468.25D0,
     9 0.0D0,          3.278829157D-03,0.265864342D0,  18.7691917D0,
     * 966.596558D0,   34750.7227D0,   1.049841568D-02,1852.47876D0,
     1 219093.813D0,   1773571.75D0,   3276616.50D0,   0.0D0,
     2 2.243389189D-02,0.631072283D0,  15.1140366D0,   268.409637D0,
     3 3296.84058D0,   34.8709259D0,   38114.8672D0,   321233.156D0,
     4 227968.109D0,   4926.22803D0,   0.0D0,          1.338380243D-04,
     5 8.599226363D-03,0.548111379D0,  26.8109093D0,   882.155823D0,
     6 30.0270767D0,   129890.227D0,   204304.078D0,   12901790.0D0,
     7 30727232.0D0,   0.0D0,          5.532951764D-05,3.981444519D-03,
     8 0.261431783D0,  12.9882307D0,   431.338715D0,   14.9381475D0,
     9 65373.6758D0,   102237.445D0,   6433917.50D0,   15425960.0D0,
     * 0.0D0/
C * DATA FOR S  ELEMENT #16
      DATA ((XSC(16, I, J), J = 1, 11), I = 1, 7)/
     1 4.00297880D0,   125.645302D0,   3336.60425D0,   64908.2656D0,
     2 0.000000000D0,  15.0581884D0,   1949.67810D0,   17367.4648D0,
     3 54399.3633D0,   94464.5781D0,   105087.281D0,   0.303693503D0,
     4 8.99559212D0,   217.438217D0,   3737.79248D0,   42614.5664D0,
     5 0.130291492D0,  1515.55530D0,   50511.7813D0,   218041.891D0,
     6 344550.156D0,   0.0D0,          3.195327241D-03,0.228410363D0,
     7 15.0264416D0,   729.671326D0,   24527.0723D0,   4.100469407D-03,
     8 656.268738D0,   81419.5938D0,   699896.000D0,   1532038.00D0,
     9 0.0D0,          5.274787080D-03,0.419763833D0,  28.6901493D0,
     * 1417.97913D0,   48208.3945D0,   6.840255111D-03,1274.83459D0,
     1 160726.359D0,   1396900.50D0,   3080348.75D0,   0.0D0,
     2 3.336768597D-02,0.925767303D0,  21.5492477D0,   366.828888D0,
     3 4318.39111D0,   28.5174408D0,   34478.0508D0,   311271.250D0,
     4 263840.156D0,   5097.19873D0,   0.0D0,          2.531304199D-04,
     5 1.616474427D-02,0.997793913D0,  46.4188728D0,   1431.60376D0,
     6 26.2621441D0,   127479.820D0,   190660.828D0,   13336919.0D0,
     7 26273610.0D0,   0.0D0,          2.077342215D-04,1.485415734D-02,
     8 0.948392630D0,  44.8675652D0,   1397.84741D0,   26.2266979D0,
     9 128772.211D0,   192191.422D0,   13350413.0D0,   26480780.0D0,
     * 0.0D0/
C * DATA FOR CL ELEMENT #17
      DATA ((XSC(17, I, J), J = 1, 11), I = 1, 7)/
     1 5.25414228D0,   162.141266D0,   4201.44678D0,   78930.8828D0,
     2 0.000000000D0,  12.9650497D0,   1677.90186D0,   14986.1406D0,
     3 47054.5273D0,   81640.5781D0,   91375.2969D0,   0.408017427D0,
     4 11.8550882D0,   278.075928D0,   4582.91162D0,   49648.3242D0,
     5 0.106112912D0,  1241.04224D0,   42662.8477D0,   190254.953D0,
     6 310957.031D0,   0.0D0,          4.981699865D-03,0.349480033D0,
     7 22.2610455D0,   1037.18677D0,   33091.1836D0,   2.997984877D-03,
     8 469.981140D0,   61464.7539D0,   560663.125D0,   1384550.63D0,
     9 0.0D0,          8.185919374D-03,0.639391720D0,  42.3526001D0,
     * 2009.42236D0,   64820.0625D0,   4.982291255D-03,933.104126D0,
     1 123397.305D0,   1131530.13D0,   2813498.00D0,   0.0D0,
     2 4.733937234D-02,1.29461861D0,   29.2959709D0,   478.582855D0,
     3 5403.11523D0,   39.7703285D0,   42692.8984D0,   342222.719D0,
     4 275203.469D0,   19442.5215D0,   0.0D0,          4.393915879D-04,
     5 2.781425416D-02,1.66258872D0,   73.4911575D0,   2122.91431D0,
     6 66.6478119D0,   197430.234D0,   462803.625D0,   20593570.0D0,
     7 28671536.0D0,   0.0D0,          5.393139436D-04,3.811880946D-02,
     8 2.36163688D0,   106.294724D0,   3105.21143D0,   96.3641510D0,
     9 295091.563D0,   665788.375D0,   30513632.0D0,   43049564.0D0,
     * 0.0D0/
C * DATA FOR AR ELEMENT #18
      DATA ((XSC(18, I, J), J = 1, 11), I = 1, 7)/
     1 6.78045702D0,   205.872787D0,   5211.41455D0,   0.00000000D0,
     2 0.000000000D0,  11.2206945D0,   1451.25696D0,   13007.5967D0,
     3 40969.3633D0,   71071.4063D0,   79858.5313D0,   0.537745595D0,
     4 15.3215637D0,   349.145355D0,   5530.56934D0,   57249.9609D0,
     5 8.058060706D-02,990.483459D0,   35425.1172D0,   163749.750D0,
     6 276381.094D0,   0.0D0,          7.535587996D-03,0.518801868D0,
     7 32.0660934D0,   1437.97949D0,   43965.0234D0,   2.033560770D-03,
     8 325.793732D0,   45366.8281D0,   443202.438D0,   1192494.38D0,
     9 0.0D0,          1.232103910D-02,0.945011258D0,  60.8128281D0,
     * 2780.07568D0,   86040.3672D0,   3.250034759D-03,644.774658D0,
     1 91015.1250D0,   894592.375D0,   2427436.25D0,   0.0D0,
     2 6.486418098D-02,1.74860966D0,   38.5277634D0,   606.492554D0,
     3 6609.77051D0,   19.1251431D0,   27166.3066D0,   268914.438D0,
     4 284672.375D0,   42450.8164D0,   0.0D0,          7.182126865D-04,
     5 4.501340538D-02,2.61000037D0,   110.124474D0,   3000.17920D0,
     6 13.2102203D0,   91612.4297D0,   198423.344D0,   10275668.0D0,
     7 15258303.0D0,   0.0D0,          1.170826145D-03,8.175848424D-02,
     8 4.92371416D0,   211.844940D0,   5842.46826D0,   25.1585808D0,
     9 181295.203D0,   407273.000D0,   20135490.0D0,   30561258.0D0,
     * 0.0D0/
C * DATA FOR K  ELEMENT #19
      DATA ((XSC(19, I, J), J = 1, 11), I = 1, 7)/
     1 8.61559391D0,   257.381226D0,   6361.01416D0,   0.00000000D0,
     2 0.000000000D0,  9.75314999D0,   1266.26306D0,   11374.3389D0,
     3 35897.2773D0,   62242.4883D0,   70476.5469D0,   0.695426166D0,
     4 19.4439659D0,   430.745331D0,   6562.66797D0,   64891.7344D0,
     5 6.338828057D-02,788.968140D0,   29275.7754D0,   139685.906D0,
     6 254293.172D0,   0.0D0,          1.109857671D-02,0.749247313D0,
     7 44.9230194D0,   1933.97839D0,   56408.4883D0,   1.546652056D-03,
     8 238.654984D0,   34589.0430D0,   352950.938D0,   918931.813D0,
     9 0.0D0,          1.805134118D-02,1.35872793D0,   84.9236145D0,
     * 3731.17749D0,   110303.227D0,   2.377696102D-03,470.763550D0,
     1 69328.6250D0,   712621.875D0,   1866130.50D0,   0.0D0,
     2 8.954766393D-02,2.38756752D0,   51.3165588D0,   778.871826D0,
     3 8213.99219D0,   11.3997135D0,   19505.7285D0,   222586.125D0,
     4 398011.063D0,   198676.953D0,   0.0D0,          1.234294148D-03,
     5 7.772114873D-02,4.40419769D0,   177.011063D0,   4530.33447D0,
     6 6.19070959D0,   62596.0508D0,   371854.625D0,   2104738.75D0,
     7 26572800.0D0,   0.0D0,          2.018780215D-03,0.141051933D0,
     8 8.31027031D0,   341.028473D0,   8845.39355D0,   11.7073212D0,
     9 123850.641D0,   762296.438D0,   4081948.00D0,   52652676.0D0,
     * 0.0D0/
C * DATA FOR CA ELEMENT #20
      DATA ((XSC(20, I, J), J = 1, 11), I = 1, 7)/
     1 10.8012180D0,   317.499695D0,   7660.65479D0,   0.00000000D0,
     2 0.000000000D0,  8.58940220D0,   1112.51978D0,   10011.2959D0,
     3 31645.1211D0,   54821.7813D0,   62620.7578D0,   0.886400521D0,
     4 24.3066006D0,   523.445618D0,   7676.92627D0,   72531.1406D0,
     5 5.192638189D-02,645.348877D0,   24651.0664D0,   120790.688D0,
     6 221150.344D0,   0.0D0,          1.598180458D-02,1.05744219D0,
     7 61.5380554D0,   2544.06226D0,   70789.5391D0,   1.159604290D-03,
     8 180.250580D0,   26956.6484D0,   284359.000D0,   774663.750D0,
     9 0.0D0,          2.587469853D-02,1.90957880D0,   115.956467D0,
     * 4897.30762D0,   138282.609D0,   1.726604300D-03,354.880554D0,
     1 54049.7734D0,   574529.375D0,   1575394.13D0,   0.0D0,
     2 0.121023893D0,  3.18752408D0,   66.8213043D0,   979.660217D0,
     3 10024.3721D0,   7.39177656D0,   14683.5410D0,   186835.031D0,
     4 421672.531D0,   383247.125D0,   0.0D0,          1.983818365D-03,
     5 0.123837739D0,  6.82274866D0,   261.554993D0,   6312.27588D0,
     6 2.69190574D0,   38421.3984D0,   406731.313D0,   350113.156D0,
     7 4626078.50D0,   0.0D0,          3.220621264D-03,0.223583385D0,
     8 12.8490229D0,   503.650238D0,   12333.3105D0,   5.03576231D0,
     9 75807.5547D0,   827790.938D0,   700751.563D0,   9119556.00D0,
     * 0.0D0/
C * DATA FOR SC ELEMENT #21
      DATA ((XSC(21, I, J), J = 1, 11), I = 1, 7)/
     1 13.3754511D0,   387.105499D0,   9124.26074D0,   0.00000000D0,
     2 0.000000000D0,  7.63245869D0,   985.740845D0,   8887.63965D0,
     3 28145.1992D0,   48765.2773D0,   55765.8750D0,   1.11466527D0,
     4 29.9885063D0,   628.362183D0,   8892.73633D0,   80391.9453D0,
     5 4.445857555D-02,544.732727D0,   21299.0742D0,   106495.711D0,
     6 198788.484D0,   0.0D0,          2.259455808D-02,1.46455920D0,
     7 82.8303070D0,   3300.45557D0,   88189.5781D0,   9.547692607D-04,
     8 142.253525D0,   21883.9707D0,   237792.031D0,   660498.188D0,
     9 0.0D0,          3.633770719D-02,2.63203478D0,   155.574493D0,
     * 6340.27686D0,   172182.266D0,   1.371221151D-03,279.049683D0,
     1 43849.1992D0,   480606.969D0,   1344320.00D0,   0.0D0,
     2 0.157317132D0,  4.07192469D0,   83.1233444D0,   1180.57031D0,
     3 11781.1436D0,   5.22513533D0,   11549.5293D0,   158022.641D0,
     4 381183.219D0,   393901.906D0,   0.0D0,          2.940912731D-03,
     5 0.180802792D0,  9.67005634D0,   354.716370D0,   8119.83496D0,
     6 1.61626744D0,   27698.6602D0,   365879.313D0,   277917.594D0,
     7 1868140.75D0,   0.0D0,          4.759747069D-03,0.325096637D0,
     8 18.1512680D0,   681.726746D0,   15855.2959D0,   2.99188566D0,
     9 54482.2539D0,   742810.500D0,   575778.188D0,   3671602.75D0,
     * 0.0D0/
C * DATA FOR TI ELEMENT #22
      DATA ((XSC(22, I, J), J = 1, 11), I = 1, 7)/
     1 16.3783951D0,   466.729553D0,   10741.3164D0,   0.000000000D0,
     2 0.000000000D0,  6.81414413D0,   881.864502D0,   7959.78369D0,
     3 25236.7109D0,   43721.8906D0,   50025.1211D0,   1.38360548D0,
     4 36.5285339D0,   744.958191D0,   10184.4697D0,   88024.4688D0,
     5 3.695865348D-02,473.029541D0,   18804.6387D0,   95396.0859D0,
     6 180583.906D0,   0.0D0,          3.134495765D-02,1.98984599D0,
     7 109.354668D0,   4199.17480D0,   107379.313D0,   8.467737352D-04,
     8 120.095116D0,   18723.7754D0,   206431.688D0,   581895.938D0,
     9 0.0D0,          5.011180788D-02,3.55951881D0,   204.702057D0,
     * 8047.52686D0,   209401.109D0,   1.190659008D-03,235.652359D0,
     1 37602.7813D0,   418222.250D0,   1187201.38D0,   0.0D0,
     2 0.199400857D0,  5.07217216D0,   100.853806D0,   1388.92346D0,
     3 13522.3828D0,   4.71482325D0,   10629.2871D0,   147303.156D0,
     4 361211.375D0,   393500.281D0,   0.0D0,          4.219437949D-03,
     5 0.254280508D0,  13.1719360D0,   462.252045D0,   10030.2881D0,
     6 1.74592924D0,   28436.1680D0,   360342.531D0,   275575.281D0,
     7 1358419.00D0,   0.0D0,          6.784337573D-03,0.454848289D0,
     8 24.6371078D0,   886.506653D0,   19570.9004D0,   3.21035886D0,
     9 55870.5195D0,   732970.688D0,   575839.313D0,   2673432.25D0,
     * 0.0D0/
C * DATA FOR V  ELEMENT #23
      DATA ((XSC(23, I, J), J = 1, 11), I = 1, 8)/
     1 19.8593178D0,   557.293579D0,   12524.9434D0,   0.00000000D0,
     2 0.000000000D0,  6.15256977D0,   793.150940D0,   7166.36816D0,
     3 22744.7285D0,   39397.2227D0,   45205.3203D0,   1.69736111D0,
     4 43.9810371D0,   873.232361D0,   11541.8584D0,   95371.6563D0,
     5 3.313467652D-02,418.870239D0,   16851.0996D0,   86395.4922D0,
     6 165305.313D0,   0.0D0,          4.274908826D-02,2.65845490D0,
     7 142.064880D0,   5268.31689D0,   129182.891D0,   7.210918702D-04,
     8 102.273438D0,   16152.1201D0,   180568.219D0,   515993.250D0,
     9 0.0D0,          6.792763621D-02,4.73335934D0,   265.038300D0,
     * 10073.6582D0,   251756.672D0,   9.996999288D-04,200.471283D0,
     1 32481.7402D0,   366493.250D0,   1054867.88D0,   0.0D0,
     2 0.248241663D0,  6.20659971D0,   120.277809D0,   1608.43457D0,
     3 15290.3027D0,   4.38909674D0,   9963.03711D0,   138626.078D0,
     4 342480.813D0,   385242.594D0,   0.0D0,          5.895125680D-03,
     5 0.348192871D0,  17.4781113D0,   587.836182D0,   12128.6934D0,
     6 1.71744359D0,   27477.3926D0,   344220.781D0,   266125.000D0,
     7 1052709.13D0,   0.0D0,          9.413871914D-03,0.619588792D0,
     8 32.5734215D0,   1124.89624D0,   23648.6406D0,   3.13177872D0,
     9 53901.5117D0,   701182.125D0,   560652.000D0,   2076638.38D0,
     * 0.0D0,          7.826552064D-06,1.302643330D-03,0.193255246D0,
     1 20.0691166D0,   1380.06238D0,   1381.32471D0,   5239243.00D0,
     2 9182668.00D0,   10412750.0D0,   10710503.0D0,   0.0D0/
C * DATA FOR CR ELEMENT #24
      DATA ((XSC(24, I, J), J = 1, 11), I = 1, 9)/
     1 23.8584499D0,   659.701660D0,   14486.9111D0,   0.00000000D0,
     2 0.000000000D0,  5.58467245D0,   716.948975D0,   6486.02197D0,
     3 20613.4258D0,   35712.5781D0,   40916.9805D0,   2.06217980D0,
     4 52.4386368D0,   1014.19061D0,   12981.0391D0,   102526.242D0,
     5 3.025845997D-02,375.973938D0,   15277.1689D0,   79048.1406D0,
     6 151559.484D0,   0.0D0,          5.744704604D-02,3.50119233D0,
     7 182.161697D0,   6545.91699D0,   154516.766D0,   6.451446097D-04,
     8 87.9408264D0,   14092.8447D0,   160078.109D0,   468845.625D0,
     9 0.0D0,          9.077656269D-02,6.20592070D0,   338.715240D0,
     * 12490.7891D0,   301108.000D0,   8.811053121D-04,171.919571D0,
     1 28343.8750D0,   325225.781D0,   960945.375D0,   0.0D0,
     2 0.302706599D0,  7.43203974D0,   140.450073D0,   1828.28052D0,
     3 17014.6992D0,   3.90112567D0,   9012.97559D0,   126689.531D0,
     4 309776.031D0,   321821.813D0,   0.0D0,          7.973670959D-03,
     5 0.460968494D0,  22.4341736D0,   725.293579D0,   14298.7051D0,
     6 1.47912800D0,   24396.9609D0,   310075.875D0,   223923.734D0,
     7 1302581.75D0,   0.0D0,          1.263785642D-02,0.815583825D0,
     8 41.6369019D0,   1384.22351D0,   27850.6758D0,   2.66806769D0,
     9 47729.0195D0,   632149.500D0,   472555.719D0,   2572403.00D0,
     * 0.0D0,          1.598890958D-05,2.490416402D-03,0.352081299D0,
     1 35.3093948D0,   2332.49268D0,   1990.50281D0,   5731099.50D0,
     2 11103850.0D0,   15900373.0D0,   17578990.0D0,   0.0D0,
     3 2.306908527D-06,4.717691918D-04,7.798123360D-02,8.36031055D0,
     4 565.273315D0,   482.098938D0,   1422491.13D0,   2800122.25D0,
     5 4079126.25D0,   4554578.50D0,   0.0D0/
C * DATA FOR MN ELEMENT #25
      DATA ((XSC(25, I, J), J = 1, 11), I = 1, 9)/
     1 28.4208565D0,   774.182983D0,   16600.3594D0,   0.00000000D0,
     2 0.000000000D0,  5.09475040D0,   650.499634D0,   5888.91309D0,
     3 18730.2344D0,   32452.0781D0,   37298.2930D0,   2.47825813D0,
     4 61.8827705D0,   1166.31567D0,   14459.9814D0,   109372.039D0,
     5 2.737544663D-02,333.641083D0,   13715.8770D0,   71665.7734D0,
     6 139514.672D0,   0.0D0,          7.602304220D-02,4.54017782D0,
     7 229.838562D0,   7990.76465D0,   180338.203D0,   5.802452797D-04,
     8 75.9000168D0,   12276.8643D0,   140810.891D0,   412271.844D0,
     9 0.0D0,          0.119360931D0,  8.00909424D0,   425.921082D0,
     * 15215.7480D0,   351552.875D0,   7.861307240D-04,148.008759D0,
     1 24696.9512D0,   286419.781D0,   845586.250D0,   0.0D0,
     2 0.369769335D0,  8.92678928D0,   164.650696D0,   2087.09033D0,
     3 18974.6934D0,   3.25346279D0,   7935.61279D0,   114448.820D0,
     4 292233.063D0,   339664.719D0,   0.0D0,          1.085056923D-02,
     5 0.614776731D0,  29.0170918D0,   900.749329D0,   16910.4805D0,
     6 1.21343887D0,   20973.2129D0,   287629.000D0,   238536.297D0,
     7 650341.813D0,   0.0D0,          1.704382896D-02,1.08166397D0,
     8 53.6815720D0,   1716.14941D0,   32937.5547D0,   2.16276741D0,
     9 40929.7813D0,   586108.750D0,   510700.938D0,   1289947.25D0,
     * 0.0D0,          2.829528239D-05,4.537343513D-03,0.637378931D0,
     1 61.7960281D0,   3924.17334D0,   42.0984802D0,   1352013.25D0,
     2 6780917.00D0,   5107832.00D0,   3621647.25D0,   0.0D0,
     3 4.043392892D-06,8.592494996D-04,0.141584083D0,  14.6815014D0,
     4 954.535461D0,   10.6563883D0,   346167.406D0,   1705718.13D0,
     5 1301684.50D0,   926458.625D0,   0.0D0/
C * DATA FOR FE ELEMENT #26
      DATA ((XSC(26, I, J), J = 1, 11), I = 1, 9)/
     1 33.5967026D0,   901.826782D0,   18909.1035D0,   0.00000000D0,
     2 0.000000000D0,  4.64799356D0,   593.258423D0,   5374.18408D0,
     3 17106.8340D0,   29643.8125D0,   34122.8516D0,   2.95297790D0,
     4 72.4341125D0,   1331.50403D0,   16011.6406D0,   115667.063D0,
     5 2.514671162D-02,299.203613D0,   12430.0166D0,   65528.4492D0,
     6 128504.328D0,   0.0D0,          9.943902493D-02,5.81886387D0,
     7 286.807678D0,   9667.25781D0,   209151.594D0,   5.338012706D-04,
     8 66.8126221D0,   10892.3428D0,   126080.281D0,   372604.250D0,
     9 0.0D0,          0.155008718D0,  10.2135296D0,   529.719604D0,
     * 18373.6797D0,   407788.563D0,   7.196301012D-04,129.786392D0,
     1 21899.6582D0,   256620.547D0,   765136.438D0,   0.0D0,
     2 0.443230689D0,  10.5243616D0,   189.634857D0,   2344.99683D0,
     3 20846.9414D0,   2.90282345D0,   7199.48584D0,   105066.070D0,
     4 271252.344D0,   318037.219D0,   0.0D0,          1.434014179D-02,
     5 0.796495140D0,  36.4943275D0,   1089.90161D0,   19528.9355D0,
     6 1.07614696D0,   18903.8281D0,   265300.969D0,   225420.891D0,
     7 544294.313D0,   0.0D0,          2.241079509D-02,1.39496934D0,
     8 67.2663040D0,   2072.01074D0,   38024.9414D0,   1.89621890D0,
     9 36795.9922D0,   540918.875D0,   485733.313D0,   1083631.13D0,
     * 0.0D0,          4.385668217D-05,6.915745325D-03,0.943884850D0,
     1 88.1911469D0,   5344.88770D0,   904.588257D0,   4360846.00D0,
     2 6479449.50D0,   6033488.00D0,   5995079.50D0,   0.0D0,
     3 1.248026183D-05,2.616845304D-03,0.418635994D0,  41.8461266D0,
     4 2598.32959D0,   436.012756D0,   2171087.50D0,   3276084.50D0,
     5 3056089.75D0,   3007959.75D0,   0.0D0/
C * DATA FOR CO ELEMENT #27
      DATA ((XSC(27, I, J), J = 1, 11), I = 1, 9)/
     1 39.4313164D0,   1043.13147D0,   21369.3008D0,   0.00000000D0,
     2 0.000000000D0,  4.28146601D0,   543.329163D0,   4923.98242D0,
     3 15683.9902D0,   27184.9941D0,   31321.7324D0,   3.49209929D0,
     4 84.1281891D0,   1508.71106D0,   17605.7676D0,   121267.266D0,
     5 2.347338758D-02,270.816925D0,   11345.8652D0,   60245.4531D0,
     6 118855.930D0,   0.0D0,          0.128448009D0,  7.37002563D0,
     7 353.904449D0,   11571.7295D0,   239973.906D0,   4.955939366D-04,
     8 59.5110245D0,   9754.95801D0,   113755.008D0,   338721.719D0,
     9 0.0D0,          0.199023858D0,  12.8761759D0,   651.491699D0,
     * 21956.6172D0,   468721.469D0,   6.732242764D-04,115.055496D0,
     1 19594.3516D0,   231614.719D0,   696498.438D0,   0.0D0,
     2 0.527080059D0,  12.2973413D0,   216.458298D0,   2613.66479D0,
     3 22692.3418D0,   2.73499870D0,   6767.11426D0,   98785.1719D0,
     4 255470.359D0,   301436.031D0,   0.0D0,          1.868808270D-02,
     5 1.01760614D0,   45.2823868D0,   1302.37842D0,   22269.2207D0,
     6 0.973131120D0,  17233.8945D0,   245676.391D0,   212413.641D0,
     7 467092.094D0,   0.0D0,          2.898808010D-02,1.77265680D0,
     8 83.1538925D0,   2470.61206D0,   43352.5391D0,   1.69353569D0,
     9 33457.4688D0,   501269.844D0,   460572.344D0,   933397.188D0,
     * 0.0D0,          6.596191088D-05,1.024698000D-02,1.36048698D0,
     1 122.744514D0,   7140.04639D0,   2703.98633D0,   5272268.00D0,
     2 5839494.00D0,   6107424.50D0,   6859508.00D0,   0.0D0,
     3 2.791640509D-05,5.796468351D-03,0.903280079D0,  87.2194901D0,
     4 5200.96289D0,   1960.57092D0,   3948209.75D0,   4443491.50D0,
     5 4623939.50D0,   5131735.50D0,   0.0D0/
C * DATA FOR NI ELEMENT #28
      DATA ((XSC(28, I, J), J = 1, 11), I = 1, 9)/
     1 45.9692841D0,   1198.94641D0,   23975.1094D0,   0.00000000D0,
     2 0.000000000D0,  3.95673132D0,   499.031403D0,   4524.92383D0,
     3 14424.6455D0,   25003.7090D0,   28779.6367D0,   4.09878159D0,
     4 97.0018768D0,   1697.90784D0,   19234.1719D0,   0.00000000D0,
     5 175.452911D0,   8759.09961D0,   41247.1641D0,   85691.0078D0,
     6 115743.359D0,   125379.633D0,   0.164238393D0,  9.24035645D0,
     7 432.607697D0,   13745.6699D0,   277654.313D0,   4.599943059D-04,
     8 52.9345589D0,   8730.52051D0,   102716.945D0,   308360.781D0,
     9 0.0D0,          0.252628744D0,  16.0622597D0,   793.752747D0,
     * 26041.0527D0,   541307.000D0,   6.338458625D-04,101.764656D0,
     1 17515.0469D0,   209193.891D0,   634732.625D0,   0.0D0,
     2 0.620443940D0,  14.2436867D0,   245.278503D0,   2896.93066D0,
     3 24583.4199D0,   2.32250309D0,   6039.97852D0,   89677.1250D0,
     4 235188.766D0,   278220.125D0,   0.0D0,          2.409890480D-02,
     5 1.28517413D0,   55.5597305D0,   1541.96960D0,   25191.3965D0,
     6 0.763312697D0,  14306.6006D0,   218936.094D0,   199737.891D0,
     7 384962.188D0,   0.0D0,          3.709980473D-02,2.22665858D0,
     8 101.645332D0,   2918.94946D0,   49043.4727D0,   1.30890584D0,
     9 27669.1055D0,   446311.094D0,   435478.656D0,   771988.000D0,
     * 0.0D0,          9.720342496D-05,1.483889204D-02,1.91603458D0,
     1 167.094742D0,   9355.44727D0,   1645.66589D0,   4322541.00D0,
     2 4872569.00D0,   4804619.50D0,   5332216.00D0,   0.0D0,
     3 5.445885472D-05,1.115813758D-02,1.69257736D0,   158.038025D0,
     4 9076.38281D0,   1582.09875D0,   4310802.50D0,   4948048.50D0,
     5 4847296.50D0,   5294123.00D0,   0.0D0/
C * DATA FOR CU ELEMENT #29
      DATA ((XSC(29, I, J), J = 1, 11), I = 1, 9)/
     1 53.2751999D0,   1370.01917D0,   0.000000000D0,  0.00000000D0,
     2 0.000000000D0,  3.67557979D0,   460.387970D0,   4176.02441D0,
     3 13321.4180D0,   23094.5840D0,   26531.3652D0,   4.77699661D0,
     4 111.155106D0,   1901.57800D0,   20946.1465D0,   0.00000000D0,
     5 159.816452D0,   8044.51953D0,   38107.1836D0,   79578.3594D0,
     6 107951.578D0,   98264.7188D0,   0.207876742D0,  11.4773922D0,
     7 524.464844D0,   16219.5195D0,   335328.406D0,   4.353651893D-04,
     8 47.9885559D0,   7946.92432D0,   94237.9219D0,   285755.063D0,
     9 0.0D0,          0.317746878D0,  19.8555527D0,   959.083496D0,
     * 30679.8008D0,   642349.813D0,   6.144578801D-04,91.8376389D0,
     1 15937.9561D0,   192159.094D0,   590128.125D0,   0.0D0,
     2 0.722816169D0,  16.2981033D0,   274.493652D0,   3175.11328D0,
     3 26342.4785D0,   2.21426272D0,   5730.03467D0,   84846.7969D0,
     4 216483.391D0,   234566.063D0,   0.0D0,          3.050390072D-02,
     5 1.59164131D0,   66.8567581D0,   1792.96069D0,   27991.2402D0,
     6 0.722355902D0,  13405.5195D0,   202315.969D0,   164977.609D0,
     7 484288.344D0,   0.0D0,          4.648753628D-02,2.73926282D0,
     8 121.781357D0,   3385.16455D0,   54478.8164D0,   1.22389197D0,
     9 25846.0547D0,   413024.906D0,   362458.844D0,   968524.375D0,
     * 0.0D0,          1.341273601D-04,1.955577545D-02,2.42353272D0,
     1 204.523788D0,   11062.6572D0,   31380.8027D0,   4706225.00D0,
     2 6409198.00D0,   8098560.00D0,   9343090.00D0,   0.0D0,
     3 1.116064741D-04,2.188922837D-02,3.18954372D0,   288.272064D0,
     4 16006.7266D0,   45622.2109D0,   7098642.00D0,   9932945.00D0,
     5 12575751.0D0,   14364417.0D0,   0.0D0/
C * DATA FOR ZN ELEMENT #30
      DATA ((XSC(30, I, J), J = 1, 11), I = 1, 9)/
     1 61.3851280D0,   1556.50842D0,   0.000000000D0,  0.00000000D0,
     2 0.000000000D0,  3.41738033D0,   424.861633D0,   3855.01636D0,
     3 12305.6807D0,   21342.2305D0,   24597.9238D0,   5.53230429D0,
     4 126.530487D0,   2115.26636D0,   22648.3418D0,   0.00000000D0,
     5 144.203690D0,   7324.24951D0,   34937.3711D0,   73252.3047D0,
     6 99417.7656D0,   107036.820D0,   0.260641187D0,  14.1196003D0,
     7 629.830200D0,   18958.1777D0,   0.000000000D0,  27.0905952D0,
     8 5521.70898D0,   53473.4570D0,   167394.891D0,   300247.656D0,
     9 1333241.00D0,   0.395631582D0,  24.3039589D0,   1147.85352D0,
     * 35802.5313D0,   0.000000000D0,  51.2061539D0,   11047.5537D0,
     1 108699.633D0,   343778.188D0,   622572.875D0,   2775663.50D0,
     2 0.843118131D0,  18.7137108D0,   308.696930D0,   3499.22192D0,
     3 28351.6152D0,   1.81062496D0,   4876.25684D0,   74630.8828D0,
     4 200414.328D0,   237135.188D0,   0.0D0,          3.875831515D-02,
     5 1.98363042D0,   81.0585175D0,   2100.58325D0,   31268.1074D0,
     6 0.500795305D0,  10337.0840D0,   176975.906D0,   176503.344D0,
     7 277110.688D0,   0.0D0,          5.864527449D-02,3.39699197D0,
     8 147.175522D0,   3960.25513D0,   60918.1406D0,   0.831809580D0,
     9 19836.1797D0,   360242.563D0,   388554.844D0,   559752.813D0,
     * 0.0D0,          1.970313460D-04,2.921710163D-02,3.58537722D0,
     1 293.221649D0,   15270.9492D0,   132.655106D0,   1802453.38D0,
     2 3597675.00D0,   2548656.25D0,   2326434.25D0,   0.0D0,
     3 1.636254747D-04,3.274735808D-02,4.72995329D0,   414.446899D0,
     4 22173.4941D0,   185.929138D0,   2675326.50D0,   5466531.50D0,
     5 3880210.50D0,   3443699.50D0,   0.0D0/
C * DATA FOR GA ELEMENT #31
      DATA ((XSC(31, I, J), J = 1, 11), I = 1, 9)/
     1 70.3515015D0  , 1759.00732D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,3.18604612D0  , 392.892303D0  , 3565.45703D0  ,
     3 11387.8984D0  , 19762.4121D0  , 22863.1387D0  , 6.36879921D0  ,
     4 143.186615D0  , 2339.80249D0  , 24352.5195D0  , 0.00000000D+00,
     5 130.087662D0  , 6664.97998D0  , 32003.0059D0  , 67459.7031D0  ,
     6 93002.2422D0  , 97879.8594D0  , 0.323959708D0  ,17.2229671D0  ,
     7 750.230164D0  , 21983.3828D0  , 0.000000000D+00,23.8705845D0  ,
     8 4887.52295D0  , 47695.3945D0  , 150168.469D0  , 264292.719D0  ,
     9 1161609.88D0  , 0.488045543D0  ,29.4898682D0  , 1362.54773D0  ,
     * 41448.9023D0  , 0.000000000D+00,44.8492928D0  , 9771.77344D0  ,
     1 97009.0781D0  , 308733.250D0  , 547964.938D0  , 2423530.50D0  ,
     2 0.980047762D0  ,21.4168129D0  , 346.233002D0  , 3849.91260D0  ,
     3 30489.5234D0  , 1.32787907D0  , 3933.51074D0  , 63336.6367D0  ,
     4 180888.016D0  , 223851.828D0  , 0.0D0         , 4.889723286D-02,
     5 2.45786095D0  , 97.8323288D0  , 2453.60913D0  , 34869.2188D0  ,
     6 0.302032202D0  ,7056.10400D0  , 145255.656D0  , 194211.641D0  ,
     7 153909.406D0  , 0.0D0         , 7.358220965D-02,4.18986750D0  ,
     8 176.936600D0  , 4610.36816D0  , 67755.8047D0  , 0.556340277D0  ,
     9 14740.4688D0  , 307470.469D0  , 427068.250D0  , 334535.438D0  ,
     * 0.0D0         , 2.864034032D-04,4.266745225D-02,5.15593910D0  ,
     1 408.520752D0  , 20417.7539D0  , 8.49055195D0  , 496642.375D0  ,
     2 3697577.00D0  , 1791704.50D0  , 1466864.75D0  , 0.0D0         ,
     3 2.360964572D-04,4.774709046D-02,6.80612516D0  , 578.010925D0  ,
     4 29699.7559D0  , 11.3159914D0  , 733049.250D0  , 5574049.00D0  ,
     5 2732383.00D0  , 2190759.75D0  , 0.0D0         /
C * DATA FOR GE ELEMENT #32
      DATA ((XSC(32, I, J), J = 1, 11), I = 1, 9)/
     1 80.2246170D0  , 1978.03235D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.97958446D0  , 364.208313D0  , 3305.44434D0  ,
     3 10563.2871D0  , 18339.8008D0  , 21252.4922D0  , 7.28964853D0  ,
     4 161.231857D0  , 2578.17993D0  , 26116.5684D0  , 0.00000000D+00,
     5 116.147964D0  , 6021.05811D0  , 29166.0547D0  , 61864.8750D0  ,
     6 85900.4766D0  , 91946.7969D0  , 0.399251997D0  ,20.8421402D0  ,
     7 887.159058D0  , 25318.9590D0  , 0.000000000D+00,21.1208858D0  ,
     8 4340.14258D0  , 42661.2109D0  , 135139.531D0  , 236204.406D0  ,
     9 1025463.19D0  , 0.597486913D0  ,35.5078125D0  , 1605.66748D0  ,
     * 47667.3398D0  , 0.000000000D+00,39.4249001D0  , 8668.75293D0  ,
     1 86800.4922D0  , 278110.656D0  , 490046.188D0  , 2151649.50D0  ,
     2 1.13551497D0  , 24.4313889D0  , 387.218262D0  , 4224.90674D0  ,
     3 32690.6797D0  , 1.06691349D0  , 3305.13623D0  , 55324.1563D0  ,
     4 165297.047D0  , 210959.625D0  , 0.0D0         , 6.146106869D-02,
     5 3.03055429D0  , 117.449364D0  , 2851.64014D0  , 38660.9688D0  ,
     6 0.194859102D0  ,5125.17773D0  , 121457.352D0  , 203937.344D0  ,
     7 119521.008D0  , 0.0D0         , 9.169522673D-02,5.13813210D0  ,
     8 211.667389D0  , 5344.65771D0  , 75049.6797D0  , 0.374449104D0  ,
     9 11211.8652D0  , 263858.656D0  , 451811.719D0  , 274452.563D0  ,
     * 0.0D0         , 4.109158472D-04,6.092090160D-02,7.22076845D0  ,
     1 554.850220D0  , 26606.1992D0  , 1.40949738D0  , 170372.672D0  ,
     2 2955295.25D0  , 1788004.63D0  , 925162.063D0  , 0.0D0         ,
     3 3.384672746D-04,6.817138195D-02,9.52997208D0  , 785.181580D0  ,
     4 38735.9609D0  , 1.78750610D0  , 250344.313D0  , 4433116.00D0  ,
     5 2723435.00D0  , 1394704.25D0  , 0.0D0         /
C * DATA FOR AS ELEMENT #33
      DATA ((XSC(33, I, J), J = 1, 11), I = 1, 9)/
     1 91.0590286D0  , 2214.20728D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.77999401D0  , 338.074158D0  , 3071.30420D0  ,
     3 9819.92090D0  , 17059.8027D0  , 19765.7715D0  , 8.30234146D0  ,
     4 180.560242D0  , 2823.69092D0  , 27807.3613D0  , 0.00000000D+00,
     5 106.028755D0  , 5528.84961D0  , 26914.7109D0  , 57309.3477D0  ,
     6 79884.0313D0  , 86638.7656D0  , 0.488622487D0  ,25.0425739D0  ,
     7 1041.92041D0  , 28968.4316D0  , 0.000000000D+00,18.8089008D0  ,
     8 3873.24927D0  , 38317.7344D0  , 122051.578D0  , 212553.844D0  ,
     9 910310.875D0  , 0.725964069D0  ,42.4437675D0  , 1879.37708D0  ,
     * 54474.1758D0  , 0.000000000D+00,34.8414116D0  , 7723.30566D0  ,
     1 77956.7031D0  , 251346.531D0  , 441191.563D0  , 1911485.38D0  ,
     2 1.31026614D0  , 27.7612228D0  , 431.583313D0  , 4623.30566D0  ,
     3 34990.5742D0  , 0.875532150D0  ,2808.80566D0  , 48673.4727D0  ,
     4 152043.938D0  , 200912.766D0  , 0.0D0         , 7.672012597D-02,
     5 3.71009231D0  , 139.956955D0  , 3287.16162D0  , 42463.3164D0  ,
     6 0.146437481D0  ,4137.73193D0  , 106420.070D0  , 207359.031D0  ,
     7 121932.625D0  , 0.0D0         , 0.113692299D0  ,6.26289845D0  ,
     8 251.658844D0  , 6162.21240D0  , 82752.8125D0  , 0.268081605D0  ,
     9 8669.26953D0  , 226513.859D0  , 457978.469D0  , 282961.406D0  ,
     * 0.0D0         , 5.811402225D-04,8.526003361D-02,9.88842010D0  ,
     1 737.480530D0  , 33899.0352D0  , 0.408280015D0  ,74780.4766D0  ,
     2 2276189.50D0  , 1982255.38D0  , 636077.063D0  , 0.0D0         ,
     3 4.769114603D-04,9.527547657D-02,13.0436487D0  , 1043.49854D0  ,
     4 49382.5664D0  , 0.488065064D0  ,109408.219D0  , 3403490.75D0  ,
     5 3013125.75D0  , 961699.813D0  , 0.0D0         /
C * DATA FOR SE ELEMENT #34
      DATA ((XSC(34, I, J), J = 1, 11), I = 1, 9)/
     1 102.904449D0  , 2467.74854D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.61308599D0  , 314.814301D0  , 2859.95776D0  ,
     3 9148.33203D0  , 15902.4307D0  , 18405.3477D0  , 9.41354561D0  ,
     4 201.409302D0  , 3084.02319D0  , 29570.8711D0  , 0.00000000D+00,
     5 95.5265350D0  , 5028.90283D0  , 24670.2402D0  , 52813.6211D0  ,
     6 73890.2188D0  , 80790.6172D0  , 0.593881845D0  ,29.8914223D0  ,
     7 1216.38818D0  , 32970.6836D0  , 0.000000000D+00,16.7941189D0  ,
     8 3464.03857D0  , 34490.4727D0  , 110469.086D0  , 192158.172D0  ,
     9 806454.875D0  , 0.875946045D0  ,50.3962593D0  , 2186.65649D0  ,
     * 61936.3945D0  , 0.000000000D+00,30.8629723D0  , 6894.74365D0  ,
     1 70160.8828D0  , 227644.938D0  , 399123.906D0  , 1695917.13D0  ,
     2 1.50731444D0  , 31.4317169D0  , 479.496704D0  , 5048.24072D0  ,
     3 37444.2422D0  , 0.671760857D0  ,2349.33813D0  , 42372.9219D0  ,
     4 138259.844D0  , 189295.625D0  , 0.0D0         , 9.510219097D-02,
     5 4.51131201D0  , 165.746719D0  , 3769.60205D0  , 46480.4180D0  ,
     6 0.111424357D0  ,3291.01318D0  , 92255.5781D0  , 204266.703D0  ,
     7 134721.031D0  , 0.0D0         , 0.139976755D0  ,7.58119965D0  ,
     8 297.261536D0  , 7063.01318D0  , 90829.4453D0  , 0.190035895D0  ,
     9 6817.16602D0  , 195496.141D0  , 450909.063D0  , 315883.531D0  ,
     * 0.0D0         , 8.087955648D-04,0.117163680D0  ,13.2909241D0  ,
     1 963.809387D0  , 42543.8438D0  , 0.137163624D0  ,34927.3047D0  ,
     2 1639086.38D0  , 2139142.50D0  , 459565.406D0  , 0.0D0         ,
     3 6.616109749D-04,0.130725905D0  ,17.5188789D0  , 1363.39148D0  ,
     4 62003.9180D0  , 0.154018119D0  ,50843.1367D0  , 2443793.00D0  ,
     5 3244723.25D0  , 694652.125D0  , 0.0D0         /
C * DATA FOR BR ELEMENT #35
      DATA ((XSC(35, I, J), J = 1, 11), I = 1, 9)/
     1 115.801857D0  , 2738.54492D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.46435618D0  , 293.933472D0  , 2669.65356D0  ,
     3 8542.25879D0  , 14855.8311D0  , 17168.5137D0  , 10.6241693D0  ,
     4 223.629333D0  , 3352.69434D0  , 31288.7969D0  , 0.00000000D+00,
     5 87.0761642D0  , 4614.44434D0  , 22768.4023D0  , 48947.3555D0  ,
     6 68661.2578D0  , 75400.8125D0  , 0.717057228D0  ,35.4425697D0  ,
     7 1410.52295D0  , 37236.1719D0  , 0.000000000D+00,15.1906128D0  ,
     8 3129.47437D0  , 31291.8672D0  , 100618.641D0  , 174956.828D0  ,
     9 717155.438D0  , 1.04939413D0  , 59.4305878D0  , 2526.89600D0  ,
     * 69876.7578D0  , 0.000000000D+00,27.7121754D0  , 6221.36328D0  ,
     1 63677.0000D0  , 207570.500D0  , 364118.344D0  , 1505880.75D0  ,
     2 1.72405887D0  , 35.4125748D0  , 530.380676D0  , 5485.78857D0  ,
     3 39851.4297D0  , 0.576584041D0  ,2067.87671D0  , 38239.3828D0  ,
     4 128469.820D0  , 181360.719D0  , 0.0D0         , 0.117057204D0  ,
     5 5.44646025D0  , 194.888123D0  , 4290.66504D0  , 50516.0938D0  ,
     6 9.125851095D-02,2744.77466D0  , 81830.6953D0  , 199421.891D0  ,
     7 151311.875D0  , 0.0D0         , 0.171111077D0  ,9.11055565D0  ,
     8 348.548157D0  , 8031.59326D0  , 98924.9609D0  , 0.153152615D0  ,
     9 5720.55713D0  , 174393.688D0  , 441951.531D0  , 357866.969D0  ,
     * 0.0D0         , 1.109156408D-03,0.158323511D0  ,17.5431156D0  ,
     1 1235.59436D0  , 52167.1211D0  , 7.276616246D-02,21845.5039D0  ,
     2 1291753.50D0  , 2164522.00D0  , 369368.375D0  , 0.0D0         ,
     3 9.028668865D-04,0.176223963D0  ,23.0945625D0  , 1745.56506D0  ,
     4 75881.2969D0  , 8.406757563D-02,33285.5859D0  , 1971108.13D0  ,
     5 3277090.25D0  , 564616.125D0  , 0.0D0         /
C * DATA FOR KR ELEMENT #36
      DATA ((XSC(36, I, J), J = 1, 11), I = 1, 9)/
     1 129.995651D0  , 3029.05200D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.32620788D0  , 274.610352D0  , 2494.08398D0  ,
     3 7984.88086D0  , 13894.3145D0  , 16032.0732D0  , 11.9420261D0  ,
     4 247.392990D0  , 3634.12915D0  , 33032.5078D0  , 0.00000000D+00,
     5 78.6450119D0  , 4222.15674D0  , 20975.0977D0  , 45307.5313D0  ,
     6 63711.9375D0  , 70149.6953D0  , 0.860745907D0  ,41.8030548D0  ,
     7 1629.10864D0  , 41976.5313D0  , 0.000000000D+00,13.6485691D0  ,
     8 2812.35938D0  , 28296.9355D0  , 91485.9141D0  , 159344.422D0  ,
     9 637128.125D0  , 1.25032532D0  , 69.7208557D0  , 2908.56104D0  ,
     * 78711.8125D0  , 0.000000000D+00,24.6885414D0  , 5580.72559D0  ,
     1 57580.0781D0  , 188882.234D0  , 332067.063D0  , 1340001.13D0  ,
     2 1.96369970D0  , 39.7445793D0  , 584.965515D0  , 5951.28271D0  ,
     3 42458.3047D0  , 0.475202024D0  ,1761.07068D0  , 33711.1406D0  ,
     4 117089.836D0  , 170235.375D0  , 0.0D0         , 0.143166572D0  ,
     5 6.53821802D0  , 228.273178D0  , 4881.62988D0  , 55085.2852D0  ,
     6 6.140151992D-02,2028.23376D0  , 67512.3281D0  , 185534.875D0  ,
     7 159878.906D0  , 0.0D0         , 0.208088011D0  ,10.8912735D0  ,
     8 407.198456D0  , 9133.87207D0  , 108257.883D0  , 9.887553006D-02,
     9 4190.48828D0  , 143476.719D0  , 410401.406D0  , 378941.063D0  ,
     * 0.0D0         , 1.498913509D-03,0.210859850D0  ,22.8473740D0  ,
     1 1567.29126D0  , 63664.1602D0  , 3.360760957D-02,12333.9443D0  ,
     2 935434.938D0  , 2128649.75D0  , 295130.188D0  , 0.0D0         ,
     3 1.216916484D-03,0.234330356D0  ,30.0603981D0  , 2215.63501D0  ,
     4 92852.1797D0  , 3.355485573D-02,17778.7051D0  , 1389055.50D0  ,
     5 3219008.75D0  , 444752.625D0  , 0.0D0         /
C * DATA FOR RB ELEMENT #37
      DATA ((XSC(37, I, J), J = 1, 11), I = 1, 9)/
     1 145.150543D0  , 3335.24902D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.20369673D0  , 257.035278D0  , 2335.36548D0  ,
     3 7478.15186D0  , 13017.0439D0  , 15004.7373D0  , 13.3684654D0  ,
     4 272.545593D0  , 3922.27734D0  , 34714.9336D0  , 0.00000000D+00,
     5 71.6623535D0  , 3874.45020D0  , 19358.7090D0  , 41990.6445D0  ,
     6 59185.3477D0  , 64918.2656D0  , 1.02672589D0  , 49.0009155D0  ,
     7 1869.27454D0  , 46924.0781D0  , 0.000000000D+00,12.3343239D0  ,
     8 2535.96387D0  , 25624.2520D0  , 83175.4922D0  , 145147.594D0  ,
     9 169550.125D0  , 1.48078465D0  , 81.2901382D0  , 3325.66699D0  ,
     * 87919.4688D0  , 0.000000000D+00,22.1339550D0  , 5025.31738D0  ,
     1 52153.3359D0  , 171869.922D0  , 302482.156D0  , 355350.250D0  ,
     2 2.22920394D0  , 44.4258423D0  , 642.403442D0  , 6425.02148D0  ,
     3 45004.0195D0  , 0.379439354D0  ,1512.92029D0  , 29823.3379D0  ,
     4 106568.219D0  , 166562.719D0  , 0.0D0         , 0.173848987D0  ,
     5 7.78626299D0  , 264.755524D0  , 5475.88672D0  , 59050.4336D0  ,
     6 5.199510977D-02,1728.84705D0  , 60143.6719D0  , 179115.750D0  ,
     7 170479.313D0  , 0.0D0         , 0.250936806D0  ,12.9117928D0  ,
     8 471.177307D0  , 10247.3936D0  , 116533.945D0  , 8.001378179D-02,
     9 3515.19214D0  , 126855.000D0  , 395169.250D0  , 401144.719D0  ,
     * 0.0D0         , 1.996008214D-03,0.276897550D0  ,29.3404846D0  ,
     1 1958.40479D0  , 76366.8516D0  , 1.569856517D-02,6946.48096D0  ,
     2 651206.750D0  , 2144910.75D0  , 288034.063D0  , 0.0D0         ,
     3 1.618464827D-03,0.307255805D0  ,38.5445099D0  , 2763.93921D0  ,
     4 111082.711D0  , 1.564608514D-02,10406.0605D0  , 990321.813D0  ,
     5 3254537.25D0  , 431920.219D0  , 0.0D0         /
C * DATA FOR SR ELEMENT #38
      DATA ((XSC(38, I, J), J = 1, 11), I = 1, 12)/
     1 161.513519D0  , 3660.20239D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,2.09155250D0  , 241.108521D0  , 2189.63208D0  ,
     3 7012.84424D0  , 12210.6865D0  , 14059.6348D0  , 14.9101200D0  ,
     4 299.185394D0  , 4219.23926D0  , 36356.2305D0  , 0.00000000D+00,
     5 65.4292450D0  , 3560.53760D0  , 17888.4688D0  , 38957.1836D0  ,
     6 55047.1719D0  , 60405.5820D0  , 1.21865380D0  , 57.1402168D0  ,
     7 2133.73535D0  , 52165.9063D0  , 0.000000000D+00,11.1423483D0  ,
     8 2294.35181D0  , 23263.1074D0  , 75764.1719D0  , 132247.688D0  ,
     9 150195.922D0  , 1.74423289D0  , 94.2742844D0  , 3783.10938D0  ,
     * 97674.4453D0  , 0.000000000D+00,19.8181324D0  , 4538.41113D0  ,
     1 47343.8086D0  , 156657.875D0  , 275882.625D0  , 315142.156D0  ,
     2 2.51823068D0  , 49.4545937D0  , 703.053589D0  , 6912.58838D0  ,
     3 47542.7813D0  , 0.320201725D0  ,1313.70667D0  , 26578.0039D0  ,
     4 97467.1953D0  , 153493.984D0  , 0.0D0         , 0.209908247D0  ,
     5 9.22296047D0  , 305.693665D0  , 6123.24658D0  , 63259.9023D0  ,
     6 4.140869156D-02,1399.07043D0  , 51847.1016D0  , 167731.375D0  ,
     7 180220.813D0  , 0.0D0         , 0.300864190D0  ,15.2228489D0  ,
     8 542.591614D0  , 11452.9717D0  , 125273.719D0  , 6.202661991D-02,
     9 2845.76807D0  , 109597.852D0  , 370477.844D0  , 422457.781D0  ,
     * 0.0D0         , 2.632827265D-03,0.359631956D0  ,37.2268562D0  ,
     1 2414.14160D0  , 90173.9453D0  , 8.880086243D-03,4397.25391D0  ,
     2 476697.594D0  , 2032991.00D0  , 424226.844D0  , 0.0D0         ,
     3 2.128628781D-03,0.398270935D0  ,48.8483047D0  , 3404.98462D0  ,
     4 131123.516D0  , 8.409592323D-03,6564.34180D0  , 725246.188D0  ,
     5 3091865.00D0  , 635316.875D0  , 0.0D0         , 0.378550559D0  ,
     6 7.14977789D0  , 99.8566971D0  , 995.345764D0  , 7467.83545D0  ,
     7 21.4249725D0  , 13344.4141D0  , 124349.555D0  , 205973.406D0  ,
     8 104676.906D0  , 0.0D0         , 2.590393834D-02,1.07259893D0  ,
     9 34.1239853D0  , 668.743408D0  , 7179.04785D0  , 32.5392952D0  ,
     * 33407.7227D0  , 113940.352D0  , 2081546.50D0  , 15789259.0D0  ,
     1 0.0D0         , 3.694827110D-02,1.76024485D0  , 60.2213287D0  ,
     2 1243.12451D0  , 14006.2578D0  , 57.3781700D0  , 68820.7734D0  ,
     3 243546.422D0  , 3774906.50D0  , 30677134.0D0  , 0.0D0         /
C * DATA FOR Y  ELEMENT #39
      DATA ((XSC(39, I, J), J = 1, 11), I = 1, 12)/
     1 179.146790D0  , 4003.60840D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.98952651D0  , 226.568222D0  , 2056.57666D0  ,
     3 6588.13281D0  , 11473.4834D0  , 13194.2031D0  , 16.5722656D0  ,
     4 327.370148D0  , 4525.74902D0  , 38015.5039D0  , 0.00000000D+00,
     5 60.0163879D0  , 3284.59888D0  , 16586.6406D0  , 36256.3047D0  ,
     6 51340.8867D0  , 56210.4727D0  , 1.43939900D0  , 66.3263550D0  ,
     7 2426.01465D0  , 57802.6680D0  , 0.000000000D+00,10.1674337D0  ,
     8 2085.79395D0  , 21220.9609D0  , 69344.5781D0  , 121139.367D0  ,
     9 138701.953D0  , 2.04443002D0  , 108.828255D0  , 4286.77734D0  ,
     * 108218.703D0  , 0.000000000D+00,17.9094810D0  , 4117.66357D0  ,
     1 43179.9531D0  , 143478.172D0  , 252981.453D0  , 291438.125D0  ,
     2 2.83639383D0  , 54.8693581D0  , 767.066040D0  , 7417.85059D0  ,
     3 50142.5820D0  , 0.276592433D0  ,1157.77515D0  , 23958.1934D0  ,
     4 89794.2656D0  , 144308.313D0  , 0.0D0         , 0.251975983D0  ,
     5 10.8622761D0  , 351.090485D0  , 6813.45313D0  , 67504.2188D0  ,
     6 3.296152130D-02,1167.85828D0  , 45512.6055D0  , 156651.328D0  ,
     7 183206.031D0  , 0.0D0         , 0.358618289D0  ,17.8460426D0  ,
     8 621.632385D0  , 12742.8994D0  , 134270.031D0  , 5.000425503D-02,
     9 2364.53101D0  , 96150.6016D0  , 346162.188D0  , 429718.688D0  ,
     * 0.0D0         , 3.440195462D-03,0.462344706D0  ,46.7640839D0  ,
     1 2949.67236D0  , 105896.805D0  , 5.328153260D-03,2960.22778D0  ,
     2 360749.375D0  , 1858937.13D0  , 552808.563D0  , 0.0D0         ,
     3 2.773017157D-03,0.510965705D0  ,61.2910271D0  , 4158.10840D0  ,
     4 153977.609D0  , 4.748226609D-03,4387.53125D0  , 547963.625D0  ,
     5 2829978.50D0  , 828897.438D0  , 0.0D0         , 0.451179683D0  ,
     6 8.43212128D0  , 116.126633D0  , 1141.38098D0  , 8498.56152D0  ,
     7 15.9779139D0  , 11140.9570D0  , 112213.250D0  , 209913.750D0  ,
     8 150483.000D0  , 0.0D0         , 3.378038853D-02,1.38149095D0  ,
     9 42.9767265D0  , 816.078613D0  , 8485.08398D0  , 19.2197819D0  ,
     * 27772.6797D0  , 103374.656D0  , 1032195.00D0  , 6357127.50D0  ,
     1 0.0D0         , 4.790235683D-02,2.26003051D0  , 75.7655411D0  ,
     2 1518.69629D0  , 16618.9922D0  , 33.3941879D0  , 56679.7070D0  ,
     3 234334.891D0  , 1845420.75D0  , 12221569.0D0  , 0.0D0         /
C * DATA FOR ZR ELEMENT #40
      DATA ((XSC(40, I, J), J = 1, 11), I = 1, 13)/
     1 198.084564D0  , 4365.35010D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.89752984D0  , 213.369598D0  , 1935.44495D0  ,
     3 6200.74756D0  , 10803.4980D0  , 12404.0029D0  , 18.3579235D0  ,
     4 357.056580D0  , 4839.54834D0  , 39608.8945D0  , 0.00000000D+00,
     5 55.0786514D0  , 3045.32690D0  , 15444.5264D0  , 33866.7383D0  ,
     6 48042.4766D0  , 52498.1016D0  , 1.69195735D0  , 76.6252518D0  ,
     7 2745.34692D0  , 63772.3477D0  , 0.000000000D+00,9.37018871D0  ,
     8 1911.56104D0  , 19491.3379D0  , 63848.3672D0  , 111592.367D0  ,
     9 128467.000D0  , 2.38461804D0  , 125.030273D0  , 4834.98193D0  ,
     * 119323.406D0  , 0.000000000D+00,16.3419838D0  , 3766.07813D0  ,
     1 39653.8359D0  , 132203.844D0  , 233354.406D0  , 270296.406D0  ,
     2 3.17947149D0  , 60.6363792D0  , 834.236755D0  , 7938.17578D0  ,
     3 52774.6797D0  , 0.243396163D0  ,1033.27185D0  , 21803.2090D0  ,
     4 83217.4375D0  , 135922.281D0  , 0.0D0         , 0.301004767D0  ,
     5 12.7231665D0  , 400.982788D0  , 7538.53076D0  , 71666.0938D0  ,
     6 2.841274440D-02,1006.94525D0  , 40732.1367D0  , 147045.813D0  ,
     7 182756.844D0  , 0.0D0         , 0.425387323D0  ,20.8067722D0  ,
     8 708.235107D0  , 14099.4453D0  , 143236.375D0  , 4.015129432D-02,
     9 2032.82349D0  , 86105.8047D0  , 325500.844D0  , 429292.906D0  ,
     * 0.0D0         , 4.447322339D-03,0.588055849D0  ,58.1128082D0  ,
     1 3562.12866D0  , 122820.500D0  , 3.797446843D-03,2218.65479D0  ,
     2 291803.063D0  , 1696030.13D0  , 631846.563D0  , 0.0D0         ,
     3 3.569497028D-03,0.648275793D0  ,76.0760880D0  , 5019.27295D0  ,
     4 178619.703D0  , 3.210201627D-03,3261.68115D0  , 442121.875D0  ,
     5 2581909.75D0  , 947468.688D0  , 0.0D0         , 0.529819191D0  ,
     6 9.78068161D0  , 132.754120D0  , 1287.17285D0  , 9516.60938D0  ,
     7 13.6866503D0  , 10142.7656D0  , 105999.258D0  , 209340.328D0  ,
     8 171248.594D0  , 0.0D0         , 4.301036894D-02,1.72926521D0  ,
     9 52.4891701D0  , 965.794861D0  , 9737.61719D0  , 16.6749153D0  ,
     * 26720.4961D0  , 106705.492D0  , 768987.250D0  , 4248017.00D0  ,
     1 0.0D0         , 6.057272106D-02,2.81652451D0  , 92.3253784D0  ,
     2 1797.18713D0  , 19125.3691D0  , 28.6847382D0  , 54410.7930D0  ,
     3 245641.844D0  , 1375094.00D0  , 8130742.00D0  , 0.0D0         ,
     4 1.564582344D-04,1.751643978D-02,1.57011914D0  , 90.4214554D0  ,
     5 2764.07764D0  , 465.709259D0  , 26196.8945D0  , 11198567.0D0  ,
     6 13479409.0D0  , 12719175.0D0  , 0.0D0         /
C * DATA FOR NB ELEMENT #41
      DATA ((XSC(41, I, J), J = 1, 11), I = 1, 13)/
     1 218.421249D0  , 4747.14160D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.81405532D0  , 201.294617D0  , 1824.36816D0  ,
     3 5845.46338D0  , 10199.0410D0  , 11666.7500D0  , 20.2745953D0  ,
     4 388.375244D0  , 5163.62695D0  , 41282.5156D0  , 0.00000000D+00,
     5 50.8884010D0  , 2828.08960D0  , 14406.3662D0  , 31691.5313D0  ,
     6 45017.3555D0  , 49136.8516D0  , 1.98029768D0  , 88.1779251D0  ,
     7 3097.12842D0  , 70272.1328D0  , 0.000000000D+00,8.61602688D0  ,
     8 1756.81860D0  , 17960.6035D0  , 58998.5547D0  , 103244.578D0  ,
     9 118982.734D0  , 2.76925254D0  , 143.079041D0  , 5436.61084D0  ,
     * 131534.563D0  , 0.000000000D+00,14.9521971D0  , 3454.31055D0  ,
     1 36536.3594D0  , 122267.820D0  , 216200.359D0  , 250722.047D0  ,
     2 3.55402899D0  , 66.8008041D0  , 904.766113D0  , 8477.38574D0  ,
     3 55445.9492D0  , 0.217097908D0  ,928.643921D0  , 19960.2207D0  ,
     4 77480.8906D0  , 127574.836D0  , 0.0D0         , 0.357288361D0  ,
     5 14.8225965D0  , 455.976593D0  , 8313.54980D0  , 75939.4063D0  ,
     6 2.461441420D-02,870.914978D0  , 36546.6445D0  , 137495.297D0  ,
     7 179672.125D0  , 0.0D0         , 0.501355648D0  ,24.1268692D0  ,
     8 803.454651D0  , 15553.2676D0  , 152661.203D0  , 3.376957402D-02,
     9 1751.86255D0  , 77276.9609D0  , 305101.781D0  , 423001.219D0  ,
     * 0.0D0         , 5.694358610D-03,0.741096258D0  ,71.6300507D0  ,
     1 4274.30615D0  , 142226.250D0  , 2.645154018D-03,1681.38220D0  ,
     2 238178.453D0  , 1534821.38D0  , 582568.063D0  , 0.0D0         ,
     3 4.561474547D-03,0.815524220D0  ,93.6537781D0  , 6019.17334D0  ,
     4 206829.016D0  , 2.152563073D-03,2458.72705D0  , 360692.031D0  ,
     5 2338196.00D0  , 869593.438D0  , 0.0D0         , 0.612750053D0  ,
     6 11.1583605D0  , 149.253799D0  , 1429.06396D0  , 10510.4922D0  ,
     7 11.4717159D0  , 9049.18164D0  , 97834.2813D0  , 196611.281D0  ,
     8 157352.063D0  , 0.0D0         , 5.333347246D-02,2.10468006D0  ,
     9 62.3245010D0  , 1112.88916D0  , 10910.8672D0  , 11.9794130D0  ,
     * 23103.1055D0  , 102423.703D0  , 574271.688D0  , 3695229.25D0  ,
     1 0.0D0         , 7.447589189D-02,3.40727806D0  , 109.204124D0  ,
     2 2067.71436D0  , 21464.4473D0  , 20.2748394D0  , 46713.0156D0  ,
     3 237588.016D0  , 1027884.94D0  , 7088904.50D0  , 0.0D0         ,
     4 4.208431346D-04,4.603499547D-02,4.00764608D0  , 222.856277D0  ,
     5 6501.55127D0  , 2256.22852D0  , 360910.219D0  , 21367446.0D0  ,
     6 27653664.0D0  , 29049492.0D0  , 0.0D0         /
C * DATA FOR MO ELEMENT #42
      DATA ((XSC(42, I, J), J = 1, 11), I = 1, 14)/
     1 240.097275D0  , 5144.72656D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.73783219D0  , 190.097046D0  , 1722.38550D0  ,
     3 5518.71191D0  , 9627.55371D0  , 11005.0039D0  , 22.3213329D0  ,
     4 421.095978D0  , 5490.91113D0  , 42420.1602D0  , 0.00000000D+00,
     5 47.3239059D0  , 2639.03882D0  , 13488.4756D0  , 29747.5313D0  ,
     6 42303.9961D0  , 46096.3047D0  , 2.30739427D0  , 101.003838D0  ,
     7 3476.32935D0  , 77040.1797D0  , 0.000000000D+00,8.02373505D0  ,
     8 1624.74292D0  , 16628.1777D0  , 54710.8398D0  , 95766.4297D0  ,
     9 109727.063D0  , 3.20123339D0  , 162.969803D0  , 6082.30273D0  ,
     * 144061.484D0  , 0.000000000D+00,13.7183266D0  , 3188.79077D0  ,
     1 33827.0742D0  , 113491.219D0  , 200842.766D0  , 231035.063D0  ,
     2 3.95829892D0  , 73.3244247D0  , 977.726746D0  , 9017.90918D0  ,
     3 57976.3359D0  , 0.199403420D0  ,851.258484D0  , 18528.1855D0  ,
     4 72779.7734D0  , 121042.602D0  , 0.0D0         , 0.422186017D0  ,
     5 17.1760159D0  , 515.355103D0  , 9102.08594D0  , 79867.7734D0  ,
     6 2.242681757D-02,782.378540D0  , 33536.2383D0  , 130016.234D0  ,
     7 176863.469D0  , 0.0D0         , 0.588181078D0  ,27.8265152D0  ,
     8 905.909912D0  , 17032.8398D0  , 161457.938D0  , 3.009606339D-02,
     9 1572.45984D0  , 71061.6875D0  , 289479.813D0  , 417790.563D0  ,
     * 0.0D0         , 7.225201931D-03,0.925237000D0  ,87.4035797D0  ,
     1 5065.71143D0  , 162128.094D0  , 2.092840848D-03,1372.98071D0  ,
     2 203375.188D0  , 1406531.00D0  , 614487.563D0  , 0.0D0         ,
     3 5.769114941D-03,1.01592946D0  , 114.130440D0  , 7128.85303D0  ,
     4 235719.234D0  , 1.656617504D-03,2001.51587D0  , 308182.719D0  ,
     5 2145403.00D0  , 914660.375D0  , 0.0D0         , 0.703809321D0  ,
     6 12.6618958D0  , 167.027222D0  , 1578.99634D0  , 11535.5352D0  ,
     7 11.1804590D0  , 8929.43945D0  , 96923.2109D0  , 196239.875D0  ,
     8 165727.781D0  , 0.0D0         , 6.567740440D-02,2.54781103D0  ,
     9 73.6351395D0  , 1275.04834D0  , 12151.4619D0  , 13.2324371D0  ,
     * 24509.7188D0  , 107404.367D0  , 547929.938D0  , 3136452.50D0  ,
     1 0.0D0         , 9.101111442D-02,4.10334730D0  , 128.648575D0  ,
     2 2367.61401D0  , 23964.3633D0  , 22.2596340D0  , 49670.7539D0  ,
     3 251517.375D0  , 985744.375D0  , 6027433.50D0  , 0.0D0         ,
     4 6.148125976D-04,6.714596599D-02,5.73747110D0  , 308.015320D0  ,
     5 8571.79004D0  , 14348.6230D0  , 7814266.00D0  , 25720028.0D0  ,
     6 33348208.0D0  , 36858940.0D0  , 0.0D0         , 8.017745859D-05,
     7 1.205120422D-02,1.22094846D0  , 70.6675644D0  , 2032.77783D0  ,
     8 3417.11523D0  , 1867871.75D0  , 6514205.00D0  , 8738789.00D0  ,
     9 9799364.00D0  , 0.0D0         /
C * DATA FOR TC ELEMENT #43
      DATA ((XSC(43, I, J), J = 1, 11), I = 1, 14)/
     1 263.218353D0  , 5561.27295D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.66740632D0  , 179.844498D0  , 1627.83167D0  ,
     3 5215.59229D0  , 9100.87891D0  , 10391.3418D0  , 24.5051975D0  ,
     4 455.363861D0  , 5825.05176D0  , 0.000000000D+00,0.00000000D+00,
     5 43.9736137D0  , 2460.91431D0  , 12623.2471D0  , 27913.6055D0  ,
     6 39755.9648D0  , 43286.3984D0  , 2.67746568D0  , 115.233955D0  ,
     7 3886.97217D0  , 83721.3594D0  , 0.000000000D+00,7.47870445D0  ,
     8 1503.18005D0  , 15398.0850D0  , 50740.5664D0  , 88811.2891D0  ,
     9 101943.969D0  , 3.68525243D0  , 184.882828D0  , 6779.14258D0  ,
     * 157491.297D0  , 0.000000000D+00,12.6491575D0  , 2943.57031D0  ,
     1 31316.1777D0  , 105331.508D0  , 186493.297D0  , 215054.938D0  ,
     2 4.39064074D0  , 80.2249985D0  , 1054.03064D0  , 9577.97559D0  ,
     3 60510.0625D0  , 0.167934537D0  ,766.106262D0  , 16960.5234D0  ,
     4 67560.5156D0  , 114272.773D0  , 0.0D0         , 0.496396124D0  ,
     5 19.8073235D0  , 579.823730D0  , 9923.71777D0  , 83685.0391D0  ,
     6 2.020336129D-02,694.726440D0  , 30511.9727D0  , 122119.953D0  ,
     7 171240.531D0  , 0.0D0         , 0.686615527D0  ,31.9365902D0  ,
     8 1016.76294D0  , 18575.5742D0  , 170208.906D0  , 2.655065246D-02,
     9 1396.54407D0  , 64829.9766D0  , 272704.469D0  , 405984.375D0  ,
     * 0.0D0         , 9.092921391D-03,1.14576757D0  , 105.810783D0  ,
     1 5955.49951D0  , 183483.141D0  , 1.629359671D-03,1102.35706D0  ,
     2 171081.141D0  , 1266380.25D0  , 811327.688D0  , 0.0D0         ,
     3 7.236727048D-03,1.25537086D0  , 138.003021D0  , 8377.70313D0  ,
     4 266886.938D0  , 1.248953165D-03,1592.07019D0  , 258446.125D0  ,
     5 1929504.25D0  , 1213104.13D0  , 0.0D0         , 0.807469964D0  ,
     6 14.3330383D0  , 186.406754D0  , 1740.92493D0  , 12638.6240D0  ,
     7 9.87278652D0  , 8206.63672D0  , 91428.8672D0  , 195055.016D0  ,
     8 189214.219D0  , 0.0D0         , 8.067370206D-02,3.07626271D0  ,
     9 86.7981033D0  , 1458.61951D0  , 13531.8389D0  , 11.2235250D0  ,
     * 22794.4453D0  , 109566.453D0  , 395358.594D0  , 1882568.00D0  ,
     1 0.0D0         , 0.111048825D0  ,4.93399858D0  , 151.375626D0  ,
     2 2710.17578D0  , 26790.3730D0  , 18.6609764D0  , 46080.8359D0  ,
     3 257800.609D0  , 728719.875D0  , 3596759.75D0  , 0.0D0         ,
     4 9.261008236D-04,0.103053950D0  ,8.74145603D0  , 454.142639D0  ,
     5 12115.5635D0  , 370.902191D0  , 161808.516D0  , 18166836.0D0  ,
     6 12834695.0D0  , 8273540.00D0  , 0.0D0         , 1.214610529D-04,
     7 1.861779578D-02,1.87551463D0  , 105.118729D0  , 2899.72070D0  ,
     8 98.5036316D0  , 38843.8516D0  , 4626662.50D0  , 3323490.25D0  ,
     9 2198278.00D0  , 0.0D0         /
C * DATA FOR RU ELEMENT #44
      DATA ((XSC(44, I, J), J = 1, 11), I = 1, 14)/
     1 287.872009D0  , 6000.26904D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.59923828D0  , 170.411652D0  , 1540.85437D0  ,
     3 4937.02246D0  , 8611.95215D0  , 9830.63184D0  , 26.8350067D0  ,
     4 491.312775D0  , 6168.32861D0  , 0.000000000D+00,0.00000000D+00,
     5 41.0157661D0  , 2302.53369D0  , 11851.9229D0  , 26274.7012D0  ,
     6 37438.1367D0  , 40693.1719D0  , 3.09602880D0  , 131.068787D0  ,
     7 4337.21240D0  , 97572.5078D0  , 0.000000000D+00,6.99939537D0  ,
     8 1396.53210D0  , 14326.0068D0  , 47300.6523D0  , 82867.9531D0  ,
     9 93226.5938D0  , 4.22709703D0  , 209.091370D0  , 7540.30762D0  ,
     * 170757.391D0  , 0.000000000D+00,11.7136602D0  , 2729.48413D0  ,
     1 29138.4238D0  , 98301.0000D0  , 174310.500D0  , 196049.469D0  ,
     2 4.85759115D0  , 87.5167999D0  , 1132.91003D0  , 10143.5400D0  ,
     3 62980.7773D0  , 0.155831888D0  ,712.178772D0  , 15921.9951D0  ,
     4 64010.1133D0  , 108310.953D0  , 0.0D0         , 0.581026495D0  ,
     5 22.7495422D0  , 650.461365D0  , 10807.6689D0  , 87569.0625D0  ,
     6 1.823580079D-02,617.006958D0  , 27822.9355D0  , 114441.383D0  ,
     7 165762.281D0  , 0.0D0         , 0.797201991D0  ,36.4975395D0  ,
     8 1138.06311D0  , 20246.6113D0  , 179559.797D0  , 2.334276587D-02,
     9 1236.63257D0  , 59170.5859D0  , 256474.516D0  , 394525.250D0  ,
     * 0.0D0         , 1.136720739D-02,1.40930796D0  , 127.387573D0  ,
     1 6982.27832D0  , 208328.328D0  , 1.303084427D-03,903.103516D0  ,
     2 146945.813D0  , 1154545.50D0  , 683887.500D0  , 0.0D0         ,
     3 9.016356431D-03,1.54062247D0  , 165.916214D0  , 9814.36816D0  ,
     4 302962.688D0  , 9.781608824D-04,1300.55066D0  , 222252.859D0  ,
     5 1762292.63D0  , 1013434.63D0  , 0.0D0         , 0.910864234D0  ,
     6 15.9583178D0  , 204.765228D0  , 1891.68176D0  , 13675.8447D0  ,
     7 8.82271194D0  , 7577.24805D0  , 85910.4922D0  , 181337.719D0  ,
     8 162904.641D0  , 0.0D0         , 9.656544775D-02,3.61468291D0  ,
     9 99.5735474D0  , 1626.64807D0  , 14724.5879D0  , 9.53222752D0  ,
     * 20959.3516D0  , 105124.797D0  , 355984.500D0  , 1938333.38D0  ,
     1 0.0D0         , 0.131691754D0  ,5.75846052D0  , 172.905487D0  ,
     2 3016.97754D0  , 29205.1191D0  , 15.6216393D0  , 42190.2656D0  ,
     3 248403.688D0  , 657352.125D0  , 3728875.00D0  , 0.0D0         ,
     4 1.168414718D-03,0.126144901D0  ,10.3602219D0  , 519.234192D0  ,
     5 13235.6475D0  , 16849.2520D0  , 9683044.00D0  , 18919170.0D0  ,
     6 21132330.0D0  , 22473160.0D0  , 0.0D0         , 4.559287336D-04,
     7 6.772233546D-02,6.61125994D0  , 357.740875D0  , 9436.85938D0  ,
     8 12039.8447D0  , 6975326.00D0  , 14523259.0D0  , 16583439.0D0  ,
     9 17588262.0D0  , 0.0D0         /
C * DATA FOR RH ELEMENT #45
      DATA ((XSC(45, I, J), J = 1, 11), I = 1, 14)/
     1 314.038208D0  , 6447.44287D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.53989196D0  , 161.669327D0  , 1460.09253D0  ,
     3 4677.97705D0  , 8160.64990D0  , 9308.90527D0  , 29.3085480D0  ,
     4 528.739258D0  , 6515.34619D0  , 0.000000000D+00,0.00000000D+00,
     5 38.0843735D0  , 2156.85938D0  , 11137.7354D0  , 24749.6211D0  ,
     6 35295.7461D0  , 38326.3281D0  , 3.56632352D0  , 148.508102D0  ,
     7 4819.84473D0  , 0.000000000D+00,0.000000000D+00,6.57411432D0  ,
     8 1300.56580D0  , 13350.1484D0  , 44139.0898D0  , 77349.1563D0  ,
     9 85781.7344D0  , 4.82996225D0  , 235.562592D0  , 8353.98047D0  ,
     * 0.000000000D+00,0.000000000D+00,10.8769188D0  , 2535.83569D0  ,
     1 27146.8809D0  , 91811.0781D0  , 162951.688D0  , 181019.750D0  ,
     2 5.35817719D0  , 95.2024002D0  , 1214.72339D0  , 10722.4795D0  ,
     3 65303.3828D0  , 0.143014431D0  ,655.645508D0  , 14831.9404D0  ,
     4 60216.7891D0  , 102613.008D0  , 0.0D0         , 0.676429868D0  ,
     5 26.0001163D0  , 726.101990D0  , 11706.2002D0  , 91176.9219D0  ,
     6 1.582979597D-02,554.688538D0  , 25534.0957D0  , 107596.227D0  ,
     7 159663.047D0  , 0.0D0         , 0.922076643D0  ,41.5247650D0  ,
     8 1267.58264D0  , 21949.5234D0  , 188445.813D0  , 2.098630182D-02,
     9 1109.49890D0  , 54388.3359D0  , 241933.156D0  , 381712.625D0  ,
     * 0.0D0         , 1.410685759D-02,1.72059906D0  , 152.194992D0  ,
     1 8114.72852D0  , 234223.766D0  , 1.021503587D-03,751.620422D0  ,
     2 127058.289D0  , 1049446.50D0  , 715684.875D0  , 0.0D0         ,
     3 1.114092674D-02,1.87617385D0  , 197.972824D0  , 11399.3711D0  ,
     4 340686.688D0  , 7.530418225D-04,1075.53162D0  , 191977.859D0  ,
     5 1602119.00D0  , 1057860.88D0  , 0.0D0         , 1.02415228D0  ,
     6 17.7333393D0  , 224.654068D0  , 2052.98267D0  , 14765.3525D0  ,
     7 8.12298489D0  , 7134.23730D0  , 81918.4375D0  , 174728.828D0  ,
     8 160096.859D0  , 0.0D0         , 0.115625292D0  ,4.24856138D0  ,
     9 114.261101D0  , 1814.72986D0  , 16040.8086D0  , 8.03506279D0  ,
     * 19158.5625D0  , 102679.789D0  , 292163.031D0  , 1562784.25D0  ,
     1 0.0D0         , 0.156398177D0  ,6.73033333D0  , 197.786179D0  ,
     2 3364.05200D0  , 31917.4922D0  , 12.9800539D0  , 38416.9727D0  ,
     3 243174.047D0  , 550757.750D0  , 3011173.00D0  , 0.0D0         ,
     4 1.553658396D-03,0.166203409D0  ,13.3680382D0  , 647.823730D0  ,
     5 15844.0928D0  , 11416.7881D0  , 6163891.50D0  , 15592759.0D0  ,
     6 15830255.0D0  , 16222802.0D0  , 0.0D0         , 8.063389687D-04,
     7 0.118710421D0  ,11.3625679D0  , 594.924255D0  , 15067.2021D0  ,
     8 10823.0381D0  , 5871011.50D0  , 15941303.0D0  , 16474088.0D0  ,
     9 16681605.0D0  , 0.0D0         /
C * DATA FOR PD ELEMENT #46
      DATA ((XSC(46, I, J), J = 1, 11), I = 1, 14)/
     1 341.820618D0  , 6929.88525D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.48557293D0  , 153.623566D0  , 1385.51062D0  ,
     3 4438.48926D0  , 7752.14160D0  , 8818.31152D0  , 31.9330921D0  ,
     4 567.749390D0  , 6867.76660D0  , 0.000000000D+00,0.00000000D+00,
     5 35.6739388D0  , 2025.88623D0  , 10492.3643D0  , 23366.0879D0  ,
     6 33331.4141D0  , 36074.6445D0  , 4.09528351D0  , 167.752396D0  ,
     7 5341.66504D0  , 0.000000000D+00,0.000000000D+00,6.16704893D0  ,
     8 1215.63281D0  , 12484.5205D0  , 41325.7383D0  , 72403.0078D0  ,
     9 74949.1016D0  , 5.50118160D0  , 264.560547D0  , 9230.24219D0  ,
     * 0.000000000D+00,0.000000000D+00,10.1477365D0  , 2365.25098D0  ,
     1 25387.7773D0  , 86059.5313D0  , 152841.328D0  , 156774.797D0  ,
     2 5.89325142D0  , 103.292404D0  , 1299.56934D0  , 11316.4756D0  ,
     3 67682.6172D0  , 0.132441312D0  ,607.180298D0  , 13884.2705D0  ,
     4 56833.6680D0  , 97394.2891D0  , 0.0D0         , 0.784810185D0  ,
     5 29.6038456D0  , 807.572998D0  , 12640.6689D0  , 94440.4453D0  ,
     6 1.461805869D-02,505.420624D0  , 23651.6230D0  , 101696.453D0  ,
     7 154143.234D0  , 0.0D0         , 1.06200707D0  , 47.0543175D0  ,
     8 1406.76782D0  , 23728.8730D0  , 197113.906D0  , 1.815042086D-02,
     9 1009.27832D0  , 50481.5547D0  , 229668.359D0  , 370052.688D0  ,
     * 0.0D0         , 1.737349667D-02,2.08655882D0  , 180.792755D0  ,
     1 9387.08984D0  , 262496.344D0  , 8.519665571D-04,640.333557D0  ,
     2 111922.383D0  , 965541.938D0  , 597959.000D0  , 0.0D0         ,
     3 1.368676871D-02,2.27084923D0  , 234.873932D0  , 13178.5693D0  ,
     4 381904.469D0  , 6.217189366D-04,911.242188D0  , 169021.984D0  ,
     5 1475317.50D0  , 876121.938D0  , 0.0D0         , 1.14679289D0  ,
     6 19.5808277D0  , 244.713272D0  , 2213.70801D0  , 15841.3955D0  ,
     7 7.48869276D0  , 6840.04199D0  , 78827.8672D0  , 166242.125D0  ,
     8 137745.578D0  , 0.0D0         , 0.136756092D0  ,4.93306541D0  ,
     9 129.562637D0  , 2002.11621D0  , 17290.6992D0  , 7.61036730D0  ,
     * 18528.8125D0  , 100141.703D0  , 282794.250D0  , 1683916.13D0  ,
     1 0.0D0         , 0.183273137D0  ,7.76306963D0  , 223.361755D0  ,
     2 3706.39746D0  , 34494.4453D0  , 12.1436052D0  , 37082.0391D0  ,
     3 238696.328D0  , 533498.500D0  , 3273070.25D0  , 0.0D0         ,
     4 1.931572333D-03,0.200469404D0  ,15.6423988D0  , 734.317932D0  ,
     5 17329.5137D0  , 1353.56152D0  , 96767.9688D0  , 11283164.0D0  ,
     6 9874705.00D0  , 7802603.50D0  , 0.0D0         , 1.495557954D-03,
     7 0.212519825D0  ,19.7038517D0  , 999.829834D0  , 24445.3828D0  ,
     8 2400.72192D0  , 231654.063D0  , 17024572.0D0  , 16258404.0D0  ,
     9 13481004.0D0  , 0.0D0         /
C * DATA FOR AG ELEMENT #47
      DATA ((XSC(47, I, J), J = 1, 11), I = 1, 14)/
     1 371.173615D0  , 7404.35596D0  , 0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.43481195D0  , 146.067505D0  , 1315.53430D0  ,
     3 4213.75439D0  , 7359.54688D0  , 8367.52930D0  , 34.7085419D0  ,
     4 608.202698D0  , 7222.55518D0  , 0.000000000D+00,0.00000000D+00,
     5 33.4021225D0  , 1901.80884D0  , 9878.91504D0  , 22047.4551D0  ,
     6 31481.4609D0  , 34134.9883D0  , 4.68518305D0  , 188.830048D0  ,
     7 5899.13672D0  , 0.000000000D+00,0.000000000D+00,5.80971479D0  ,
     8 1135.11755D0  , 11660.7373D0  , 38641.9258D0  , 67712.7969D0  ,
     9 72616.8516D0  , 6.24195051D0  , 296.090698D0  , 10163.7803D0  ,
     * 0.000000000D+00,0.000000000D+00,9.39600563D0  , 2202.82422D0  ,
     1 23704.5723D0  , 80536.8672D0  , 143151.406D0  , 152821.203D0  ,
     2 6.46324205D0  , 111.762505D0  , 1386.70471D0  , 11912.9297D0  ,
     3 69822.0469D0  , 0.121659912D0  ,557.751953D0  , 12907.9512D0  ,
     4 53366.1133D0  , 92075.2422D0  , 0.0D0         , 0.906831205D0  ,
     5 33.5687065D0  , 894.524719D0  , 13595.2197D0  , 97441.9141D0  ,
     6 1.328355819D-02,453.930481D0  , 21669.6406D0  , 95233.3359D0  ,
     7 146965.922D0  , 0.0D0         , 1.21800828D0  , 53.0988960D0  ,
     8 1554.82153D0  , 25551.3164D0  , 205387.109D0  , 1.623871364D-02,
     9 905.297241D0  , 46351.3789D0  , 215771.313D0  , 354873.563D0  ,
     * 0.0D0         , 2.127772756D-02,2.51450348D0  , 213.351471D0  ,
     1 10782.4453D0  , 292004.375D0  , 6.910418742D-04,531.765259D0  ,
     2 96376.8438D0  , 867885.375D0  , 780110.813D0  , 0.0D0         ,
     3 1.668929122D-02,2.72970104D0  , 276.806854D0  , 15126.2559D0  ,
     4 424861.844D0  , 5.021790857D-04,752.546265D0  , 145539.859D0  ,
     5 1326624.63D0  , 1146642.13D0  , 0.0D0         , 1.27912045D0  ,
     6 21.5915146D0  , 266.562805D0  , 2387.33960D0  , 16980.1543D0  ,
     7 6.52393007D0  , 6185.69434D0  , 73095.4531D0  , 159421.859D0  ,
     8 149676.469D0  , 0.0D0         , 0.161787838D0  ,5.73900700D0  ,
     9 147.378464D0  , 2218.76978D0  , 18746.2285D0  , 4.71469355D0  ,
     * 14223.8457D0  , 92560.6094D0  , 182653.781D0  , 980771.875D0  ,
     1 0.0D0         , 0.215594113D0  ,8.98779106D0  , 253.145477D0  ,
     2 4098.16504D0  , 37397.2734D0  , 10.5392103D0  , 34347.0938D0  ,
     3 236129.094D0  , 444850.438D0  , 2185658.00D0  , 0.0D0         ,
     4 2.605415648D-03,0.273270607D0  ,21.0784111D0  , 955.892883D0  ,
     5 21619.0410D0  , 7536.34375D0  , 3400273.50D0  , 11635234.0D0  ,
     6 10617845.0D0  , 10882367.0D0  , 0.0D0         , 2.015347360D-03,
     7 0.291224808D0  ,26.7979927D0  , 1314.85693D0  , 30838.3770D0  ,
     8 10630.3838D0  , 4795128.50D0  , 17853854.0D0  , 16372035.0D0  ,
     9 16260426.0D0  , 0.0D0         /
C * DATA FOR CD ELEMENT #48
      DATA ((XSC(48, I, J), J = 1, 11), I = 1, 14)/
     1 402.193146D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.38744187D0  , 139.001984D0  , 1250.03833D0  ,
     3 4003.46631D0  , 6993.01221D0  , 7938.74268D0  , 37.6538239D0  ,
     4 650.309753D0  , 7583.02881D0  , 0.000000000D+00,0.00000000D+00,
     5 31.2527809D0  , 1783.91858D0  , 9296.45605D0  , 20793.3301D0  ,
     6 29788.5117D0  , 32232.9414D0  , 5.34350967D0  , 211.952164D0  ,
     7 6498.77979D0  , 0.000000000D+00,0.000000000D+00,5.47050619D0  ,
     8 1059.40247D0  , 10888.5313D0  , 36130.9141D0  , 63333.4414D0  ,
     9 70256.5078D0  , 7.06004715D0  , 330.427429D0  , 11165.3760D0  ,
     * 0.000000000D+00,0.000000000D+00,8.73649120D0  , 2050.06909D0  ,
     1 22124.5645D0  , 75358.7734D0  , 134077.578D0  , 148945.016D0  ,
     2 7.07008743D0  , 120.648285D0  , 1476.84485D0  , 12524.2734D0  ,
     3 71821.1172D0  , 0.111077316D0  ,508.901367D0  , 11937.0459D0  ,
     4 49828.3125D0  , 87278.6406D0  , 0.0D0         , 1.04392672D0  ,
     5 37.9316368D0  , 987.710999D0  , 14587.1270D0  , 100177.531D0  ,
     6 1.194320992D-02,403.858978D0  , 19719.7754D0  , 88850.4609D0  ,
     7 138626.625D0  , 0.0D0         , 1.39177334D0  , 59.7120972D0  ,
     8 1713.33618D0  , 27461.4473D0  , 213595.250D0  , 1.433763001D-02,
     9 801.577026D0  , 42172.6875D0  , 201692.719D0  , 335675.688D0  ,
     * 0.0D0         , 2.590886690D-02,3.01359344D0  , 250.567963D0  ,
     1 12343.2217D0  , 324396.969D0  , 5.484857247D-04,432.801788D0  ,
     2 81782.9531D0  , 773230.188D0  , 1046752.13D0  , 0.0D0         ,
     3 2.025088482D-02,3.26425838D0  , 324.690765D0  , 17305.2656D0  ,
     4 472220.563D0  , 3.991335398D-04,607.127319D0  , 123268.711D0  ,
     5 1181358.50D0  , 1555562.88D0  , 0.0D0         , 1.42603564D0  ,
     6 23.7744255D0  , 289.901031D0  , 2572.53320D0  , 18192.9414D0  ,
     7 5.35037184D0  , 5335.19873D0  , 65342.0234D0  , 151706.297D0  ,
     8 158377.469D0  , 0.0D0         , 0.190790504D0  ,6.65182829D0  ,
     9 166.873779D0  , 2444.54761D0  , 20169.2598D0  , 4.45543766D0  ,
     * 13676.0293D0  , 92448.1406D0  , 160554.719D0  , 692735.563D0  ,
     1 0.0D0         , 0.252439588D0  ,10.3763657D0  , 286.513611D0  ,
     2 4532.94678D0  , 40641.7773D0  , 6.85289192D0  , 27041.0039D0  ,
     3 218305.156D0  , 345191.938D0  , 1344777.13D0  , 0.0D0         ,
     4 3.445164068D-03,0.363392204D0  ,27.6695786D0  , 1215.86316D0  ,
     5 26505.5605D0  , 395.825348D0  , 203484.531D0  , 14914517.0D0  ,
     6 6239630.00D0  , 4870765.50D0  , 0.0D0         , 2.669762820D-03,
     7 0.388387829D0  ,35.3342743D0  , 1681.05505D0  , 38035.3438D0  ,
     8 537.642273D0  , 312976.813D0  , 22128590.0D0  , 9579849.00D0  ,
     9 7131414.00D0  , 0.0D0         /
C * DATA FOR IN ELEMENT #49
      DATA ((XSC(49, I, J), J = 1, 11), I = 1, 14)/
     1 434.917938D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.34354222D0  , 132.399948D0  , 1188.87671D0  ,
     3 3806.95923D0  , 6656.97412D0  , 7536.04053D0  , 40.7497978D0  ,
     4 693.810486D0  , 7944.25537D0  , 0.000000000D+00,0.00000000D+00,
     5 29.2774467D0  , 1675.00842D0  , 8755.65527D0  , 19626.1855D0  ,
     6 28158.8555D0  , 30508.5703D0  , 6.07568169D0  , 237.183563D0  ,
     7 7137.36230D0  , 0.000000000D+00,0.000000000D+00,5.16041517D0  ,
     8 989.900635D0  , 10175.6943D0  , 33801.3555D0  , 59266.4219D0  ,
     9 68483.8516D0  , 7.96010685D0  , 367.610535D0  , 12227.7061D0  ,
     * 0.000000000D+00,0.000000000D+00,8.13598537D0  , 1910.12476D0  ,
     1 20666.8047D0  , 70551.6797D0  , 125639.133D0  , 145913.063D0  ,
     2 7.71465921D0  , 129.926773D0  , 1569.21802D0  , 13137.7842D0  ,
     3 73556.2500D0  , 0.101870246D0  ,464.898895D0  , 11044.6797D0  ,
     4 46562.8008D0  , 82384.8047D0  , 0.0D0         , 1.19739389D0  ,
     5 42.7072029D0  , 1086.68335D0  , 15595.6992D0  , 102573.328D0  ,
     6 1.075263787D-02,359.387512D0  , 17930.0918D0  , 82653.3672D0  ,
     7 131364.328D0  , 0.0D0         , 1.58443534D0  , 66.9061966D0  ,
     8 1881.25659D0  , 29413.6855D0  , 221525.250D0  , 1.272562053D-02,
     9 710.295349D0  , 38356.5313D0  , 188043.344D0  , 317844.719D0  ,
     * 0.0D0         , 3.134656325D-02,3.59037566D0  , 292.593079D0  ,
     1 14046.4658D0  , 358032.625D0  , 4.392093979D-04,353.923401D0  ,
     2 69448.6328D0  , 684298.938D0  , 1362901.38D0  , 0.0D0         ,
     3 2.443429269D-02,3.88134480D0  , 378.674194D0  , 19679.1719D0  ,
     4 521345.250D0  , 3.238790378D-04,492.438324D0  , 104545.422D0  ,
     5 1045670.75D0  , 2049506.75D0  , 0.0D0         , 1.58318138D0  ,
     6 26.0998497D0  , 314.572235D0  , 2766.40479D0  , 19425.8887D0  ,
     7 4.18845844D0  , 4565.28613D0  , 58088.5039D0  , 144032.813D0  ,
     8 158709.734D0  , 0.0D0         , 0.224245504D0  ,7.68499517D0  ,
     9 188.437393D0  , 2689.43237D0  , 21684.5605D0  , 3.29573870D0  ,
     * 11402.6494D0  , 87467.1563D0  , 132859.359D0  , 445682.750D0  ,
     1 0.0D0         , 0.294052601D0  ,11.9301281D0  , 323.080231D0  ,
     2 4995.24609D0  , 43961.3984D0  , 4.95171165D0  , 22385.4727D0  ,
     3 204827.625D0  , 312471.688D0  , 859850.188D0  , 0.0D0         ,
     4 4.493633285D-03,0.474454135D0  ,35.5743599D0  , 1514.22400D0  ,
     5 31812.9629D0  , 71.5568008D0  , 237794.953D0  , 6435903.50D0  ,
     6 6812904.50D0  , 3388422.75D0  , 0.0D0         , 3.482840722D-03,
     7 0.507674456D0  ,45.5484734D0  , 2100.52588D0  , 45842.3477D0  ,
     8 93.4430008D0  , 355699.750D0  , 9263124.00D0  , 10435674.0D0  ,
     9 5075456.00D0  , 0.0D0         /
C * DATA FOR SN ELEMENT #50
      DATA ((XSC(50, I, J), J = 1, 11), I = 1, 14)/
     1 469.335571D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.30278218D0  , 126.259201D0  , 1131.63745D0  ,
     3 3622.84937D0  , 6329.84863D0  , 7176.64746D0  , 44.0108719D0  ,
     4 738.826843D0  , 8308.22559D0  , 0.000000000D+00,0.00000000D+00,
     5 27.4632511D0  , 1574.34033D0  , 8254.03809D0  , 18540.6504D0  ,
     6 26645.5977D0  , 28882.5742D0  , 6.88818979D0  , 264.686493D0  ,
     7 7817.49707D0  , 0.000000000D+00,0.000000000D+00,4.87964249D0  ,
     8 926.749756D0  , 9525.74512D0  , 31670.9961D0  , 55551.7070D0  ,
     9 64946.3008D0  , 8.94866943D0  , 407.852692D0  , 13358.3125D0  ,
     * 0.000000000D+00,0.000000000D+00,7.59024191D0  , 1782.53491D0  ,
     1 19333.6797D0  , 66145.1328D0  , 117902.984D0  , 138816.156D0  ,
     2 8.39794064D0  , 139.619003D0  , 1664.24524D0  , 13759.5059D0  ,
     3 75257.2188D0  , 9.384955466D-02,425.282135D0  , 10229.7158D0  ,
     4 43525.3945D0  , 77673.8906D0  , 0.0D0         , 1.36876702D0  ,
     5 47.9281425D0  , 1191.89270D0  , 16629.6406D0  , 104684.820D0  ,
     6 9.724338539D-03,320.816071D0  , 16334.0898D0  , 76944.7344D0  ,
     7 124711.328D0  , 0.0D0         , 1.79763031D0  , 74.7222824D0  ,
     8 2059.40894D0  , 31429.9531D0  , 228986.734D0  , 1.139104739D-02,
     9 631.474609D0  , 34957.1680D0  , 175520.609D0  , 302964.813D0  ,
     * 0.0D0         , 3.776062652D-02,4.25705576D0  , 340.030151D0  ,
     1 15916.9688D0  , 393437.000D0  , 3.568842076D-04,292.079224D0  ,
     2 59357.5664D0  , 608254.313D0  , 1563263.00D0  , 0.0D0         ,
     3 2.930581942D-02,4.59071922D0  , 439.543304D0  , 22287.4023D0  ,
     4 573262.688D0  , 2.687954111D-04,402.348206D0  , 89147.5625D0  ,
     5 928811.188D0  , 2384795.75D0  , 0.0D0         , 1.75388730D0  ,
     6 28.5942535D0  , 340.728271D0  , 2970.66602D0  , 20701.3730D0  ,
     7 3.48241735D0  , 3979.11450D0  , 52240.3828D0  , 135489.859D0  ,
     8 154490.063D0  , 0.0D0         , 0.262702942D0  ,8.84935951D0  ,
     9 212.117020D0  , 2951.28784D0  , 23259.3906D0  , 2.44925475D0  ,
     * 9630.53125D0  , 82213.8906D0  , 119546.063D0  , 314798.563D0  ,
     1 0.0D0         , 0.342183888D0  ,13.6839066D0  , 363.285828D0  ,
     2 5493.02246D0  , 47471.6484D0  , 3.59649491D0  , 18782.8730D0  ,
     3 191162.406D0  , 299461.094D0  , 616534.125D0  , 0.0D0         ,
     4 5.804231856D-03,0.608823895D0  ,44.7936058D0  , 1847.76965D0  ,
     5 37422.2109D0  , 21.2291412D0  , 173031.516D0  , 872345.125D0  ,
     6 11045122.0D0  , 2410028.00D0  , 0.0D0         , 4.492963664D-03,
     7 0.651289523D0  ,57.4127159D0  , 2567.69458D0  , 54067.1875D0  ,
     8 26.5790653D0  , 256064.547D0  , 1202452.63D0  , 16681656.0D0  ,
     9 3680548.50D0  , 0.0D0         /
C * DATA FOR SB ELEMENT #51
      DATA ((XSC(51, I, J), J = 1, 11), I = 1, 14)/
     1 505.496216D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.26502931D0  , 120.533768D0  , 1078.21399D0  ,
     3 3450.94507D0  , 6030.91211D0  , 6829.84473D0  , 47.4398270D0  ,
     4 785.260803D0  , 8672.91797D0  , 0.000000000D+00,0.00000000D+00,
     5 25.6544991D0  , 1482.06189D0  , 7791.75391D0  , 17536.1699D0  ,
     6 25232.7207D0  , 27353.8516D0  , 7.78759003D0  , 294.564087D0  ,
     7 8538.69238D0  , 0.000000000D+00,0.000000000D+00,4.62826967D0  ,
     8 869.748779D0  , 8935.69824D0  , 29728.7031D0  , 52155.4648D0  ,
     9 61254.6172D0  , 10.0333748D0  , 451.272095D0  , 14553.6240D0  ,
     * 0.000000000D+00,0.000000000D+00,7.10404396D0  , 1667.56592D0  ,
     1 18124.2422D0  , 62121.6719D0  , 110940.953D0  , 131077.984D0  ,
     2 9.12128925D0  , 149.717255D0  , 1761.59387D0  , 14384.0293D0  ,
     3 76311.1875D0  , 8.717016876D-02,390.636078D0  , 9503.69238D0  ,
     4 40772.2461D0  , 73333.0547D0  , 0.0D0         , 1.55957532D0  ,
     5 53.6119347D0  , 1303.03162D0  , 17677.0840D0  , 106432.773D0  ,
     6 8.890544064D-03,288.707092D0  , 14956.6553D0  , 71811.6797D0  ,
     7 118304.641D0  , 0.0D0         , 2.03267574D0  , 83.1816788D0  ,
     8 2247.32642D0  , 33490.4336D0  , 236239.328D0  , 1.033644192D-02,
     9 565.778931D0  , 32018.3027D0  , 164208.984D0  , 288257.781D0  ,
     * 0.0D0         , 4.525857046D-02,5.02239656D0  , 393.184570D0  ,
     1 17949.7637D0  , 429912.750D0  , 2.794173197D-04,244.952682D0  ,
     2 51304.2305D0  , 542743.000D0  , 1568719.38D0  , 0.0D0         ,
     3 3.499866277D-02,5.40406275D0  , 507.655334D0  , 25119.6133D0  ,
     4 626949.313D0  , 2.189208753D-04,334.194427D0  , 76887.9844D0  ,
     5 828476.313D0  , 2417228.50D0  , 0.0D0         , 1.94081104D0  ,
     6 31.2639618D0  , 368.240997D0  , 3183.97900D0  , 22000.8223D0  ,
     7 2.83087897D0  , 3493.35181D0  , 47218.6758D0  , 127794.977D0  ,
     8 150779.203D0  , 0.0D0         , 0.306472033D0  ,10.1463585D0  ,
     9 237.725143D0  , 3225.05713D0  , 24828.2930D0  , 2.04246855D0  ,
     * 8548.25391D0  , 78516.2891D0  , 115483.641D0  , 241015.188D0  ,
     1 0.0D0         , 0.397216707D0  ,15.6378651D0  , 406.766937D0  ,
     2 6016.44824D0  , 51029.2969D0  , 2.94445682D0  , 16596.7090D0  ,
     3 181993.641D0  , 300497.594D0  , 492359.344D0  , 0.0D0         ,
     4 7.412088104D-03,0.769712508D0  ,55.4780731D0  , 2218.22095D0  ,
     5 43305.5313D0  , 9.27482128D0  , 126239.773D0  , 148987.328D0  ,
     6 18163230.0D0  , 1913123.50D0  , 0.0D0         , 5.726999138D-03,
     7 0.822774887D0  ,71.1408691D0  , 3086.07959D0  , 62696.1250D0  ,
     8 11.1955481D0  , 185709.500D0  , 206236.031D0  , 26991814.0D0  ,
     9 2937263.50D0  , 0.0D0         /
C * DATA FOR TE ELEMENT #52
      DATA ((XSC(52, I, J), J = 1, 11), I = 1, 14)/
     1 543.457947D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.23006237D0  , 115.191147D0  , 1028.25171D0  ,
     3 3290.14868D0  , 5755.02539D0  , 6500.19238D0  , 51.0387535D0  ,
     4 833.152344D0  , 9037.26660D0  , 0.000000000D+00,0.00000000D+00,
     5 24.1354580D0  , 1396.82263D0  , 7363.05762D0  , 16601.8809D0  ,
     6 23920.1660D0  , 25938.9570D0  , 8.78302097D0  , 327.007843D0  ,
     7 9303.80078D0  , 0.000000000D+00,0.000000000D+00,4.37503052D0  ,
     8 817.693420D0  , 8395.02051D0  , 27941.9473D0  , 49081.9805D0  ,
     9 57618.5156D0  , 11.2163792D0  , 498.023865D0  , 15818.6797D0  ,
     * 0.000000000D+00,0.000000000D+00,6.65949011D0  , 1562.56665D0  ,
     1 17016.8184D0  , 58433.0078D0  , 104470.789D0  , 123283.906D0  ,
     2 9.88542557D0  , 160.228302D0  , 1861.38550D0  , 15013.1504D0  ,
     3 0.000000000D+00,268.347015D0  , 7620.71045D0  , 29398.8750D0  ,
     4 55816.5430D0  , 72969.3047D0  , 78514.3203D0  , 1.77139270D0  ,
     5 59.7895050D0  , 1420.43896D0  , 18742.4453D0  , 107931.641D0  ,
     6 8.181498386D-03,260.860443D0  , 13730.5879D0  , 67091.4219D0  ,
     7 112186.773D0  , 0.0D0         , 2.29133701D0  , 92.3204727D0  ,
     8 2445.53735D0  , 35605.1328D0  , 243246.750D0  , 9.464330040D-03,
     9 509.012604D0  , 29406.4902D0  , 153818.844D0  , 274294.938D0  ,
     * 0.0D0         , 5.395657942D-02,5.89682484D0  , 452.654053D0  ,
     1 20165.2617D0  , 467900.031D0  , 2.316953905D-04,207.141403D0  ,
     2 44610.1406D0  , 485886.938D0  , 1451067.88D0  , 0.0D0         ,
     3 4.160211980D-02,6.33225298D0  , 583.754639D0  , 28203.6348D0  ,
     4 682898.125D0  , 1.897431648D-04,279.897980D0  , 66722.4688D0  ,
     5 741277.250D0  , 2247015.25D0  , 0.0D0         , 2.13859034D0  ,
     6 34.0773811D0  , 397.046326D0  , 3406.03345D0  , 23322.0332D0  ,
     7 2.39971447D0  , 3090.32886D0  , 42859.1563D0  , 120638.492D0  ,
     8 147175.891D0  , 0.0D0         , 0.356053442D0  ,11.5856295D0  ,
     9 265.413971D0  , 3513.79102D0  , 26433.5625D0  , 1.61186409D0  ,
     * 7437.31689D0  , 73759.3594D0  , 112976.242D0  , 191477.125D0  ,
     1 0.0D0         , 0.458347231D0  ,17.7873383D0  , 453.762604D0  ,
     2 6571.93799D0  , 54741.0703D0  , 2.26832080D0  , 14359.0488D0  ,
     3 170265.156D0  , 300900.313D0  , 417148.813D0  , 0.0D0         ,
     4 9.369441308D-03,0.960885108D0  ,67.7794189D0  , 2628.51807D0  ,
     5 49492.0039D0  , 4.53558826D0  , 91436.6875D0  , 153573.922D0  ,
     6 16884066.0D0  , 1665414.50D0  , 0.0D0         , 7.222595625D-03,
     7 1.02602172D0  , 86.9253845D0  , 3659.91162D0  , 71778.8203D0  ,
     8 5.26037979D0  , 133817.531D0  , 240597.859D0  , 24838258.0D0  ,
     9 2550610.75D0  , 0.0D0         /
C * DATA FOR I  ELEMENT #53
      DATA ((XSC(53, I, J), J = 1, 11), I = 1, 14)/
     1 583.245239D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.19740903D0  , 110.184814D0  , 981.340576D0  ,
     3 3138.84619D0  , 5488.67529D0  , 6199.58057D0  , 54.8252258D0  ,
     4 882.531311D0  , 9402.86230D0  , 0.000000000D+00,0.00000000D+00,
     5 22.7374363D0  , 1317.67639D0  , 6963.47266D0  , 15728.3428D0  ,
     6 22737.3457D0  , 24558.4648D0  , 9.87876797D0  , 362.167480D0  ,
     7 10115.4580D0  , 0.000000000D+00,0.000000000D+00,4.16131210D0  ,
     8 769.584045D0  , 7895.64453D0  , 26293.9961D0  , 46208.0469D0  ,
     9 54148.6484D0  , 12.5069389D0  , 548.316711D0  , 17158.7988D0  ,
     * 0.000000000D+00,0.000000000D+00,6.21549034D0  , 1465.90515D0  ,
     1 15995.8418D0  , 55028.0117D0  , 98476.6797D0  , 116015.422D0  ,
     2 10.6919308D0  , 171.167542D0  , 1963.88062D0  , 15650.5244D0  ,
     3 0.000000000D+00,246.685699D0  , 7083.80664D0  , 27512.1523D0  ,
     4 52495.8242D0  , 68880.9609D0  , 74222.1406D0  , 2.00614882D0  ,
     5 66.4919968D0  , 1544.36499D0  , 19827.3535D0  , 108353.477D0  ,
     6 7.553438190D-03,236.124390D0  , 12618.8340D0  , 62695.4531D0  ,
     7 106305.945D0  , 0.0D0         , 2.57510161D0  , 102.176842D0  ,
     8 2654.61157D0  , 37784.0742D0  , 250097.375D0  , 8.723785169D-03,
     9 458.359650D0  , 27024.2891D0  , 144081.719D0  , 260777.641D0  ,
     * 0.0D0         , 6.408919394D-02,6.89599848D0  , 519.143921D0  ,
     1 22592.1602D0  , 509126.281D0  , 1.929337450D-04,175.291458D0  ,
     2 38821.3633D0  , 435245.531D0  , 1298463.13D0  , 0.0D0         ,
     3 4.922960699D-02,7.38825369D0  , 668.624268D0  , 31571.2012D0  ,
     4 743100.750D0  , 1.664647862D-04,235.063843D0  , 58034.3086D0  ,
     5 664276.000D0  , 2012410.00D0  , 0.0D0         , 2.35337949D0  ,
     6 37.0662956D0  , 427.166504D0  , 3637.14014D0  , 24670.3906D0  ,
     7 2.03494740D0  , 2725.11133D0  , 38797.4688D0  , 113233.711D0  ,
     8 142574.188D0  , 0.0D0         , 0.412523240D0  ,13.1800241D0  ,
     9 295.146637D0  , 3815.27075D0  , 28041.0430D0  , 1.32522774D0  ,
     * 6511.53564D0  , 69118.1094D0  , 111560.750D0  , 161005.781D0  ,
     1 0.0D0         , 0.526673079D0  ,20.1478863D0  , 504.201324D0  ,
     2 7155.66553D0  , 58536.1875D0  , 1.81927359D0  , 12502.0205D0  ,
     3 159002.281D0  , 301011.219D0  , 377583.531D0  , 0.0D0         ,
     4 1.171184145D-02,1.18566418D0  , 81.8601913D0  , 3081.73657D0  ,
     5 56009.5430D0  , 2.33227348D0  , 65372.1094D0  , 245734.016D0  ,
     6 7527104.50D0  , 1628419.25D0  , 0.0D0         , 9.003613144D-03,
     7 1.26440704D0  , 104.971863D0  , 4293.61768D0  , 81361.2031D0  ,
     8 2.58736515D0  , 95179.1016D0  , 385469.375D0  , 10990779.0D0  ,
     9 2475894.75D0  , 0.0D0         /
C * DATA FOR XE ELEMENT #54
      DATA ((XSC(54, I, J), J = 1, 11), I = 1, 14)/
     1 624.902771D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.16669405D0  , 105.467674D0  , 937.121216D0  ,
     3 2996.29761D0  , 5237.44922D0  , 5917.15186D0  , 58.7911682D0  ,
     4 933.676514D0  , 9777.10059D0  , 0.000000000D+00,0.00000000D+00,
     5 21.3622379D0  , 1240.57385D0  , 6577.08008D0  , 14887.8174D0  ,
     6 21553.1895D0  , 23289.6211D0  , 11.0863647D0  , 400.323730D0  ,
     7 10981.6182D0  , 0.000000000D+00,0.000000000D+00,3.95615411D0  ,
     8 724.057129D0  , 7425.85840D0  , 24750.0664D0  , 43523.0820D0  ,
     9 50915.9023D0  , 13.9128065D0  , 602.490906D0  , 18586.5664D0  ,
     * 0.000000000D+00,0.000000000D+00,5.82589436D0  , 1374.63269D0  ,
     1 15035.8057D0  , 51837.3047D0  , 92885.4141D0  , 109281.883D0  ,
     2 11.5422506D0  , 182.560226D0  , 2069.69287D0  , 16305.2402D0  ,
     3 0.000000000D+00,225.554062D0  , 6558.44336D0  , 25666.5449D0  ,
     4 49240.8281D0  , 64829.4492D0  , 69698.6953D0  , 2.26599121D0  ,
     5 73.7758789D0  , 1676.35754D0  , 20961.6934D0  , 125156.141D0  ,
     6 6.453159265D-03,211.357910D0  , 11509.1846D0  , 58277.1328D0  ,
     7 100207.680D0  , 0.0D0         , 2.88628817D0  , 112.821999D0  ,
     8 2876.83911D0  , 40080.6445D0  , 254936.969D0  , 8.000156842D-03,
     9 408.548584D0  , 24666.2402D0  , 134316.453D0  , 246848.984D0  ,
     * 0.0D0         , 7.581371069D-02,8.03451633D0  , 593.645935D0  ,
     1 25286.0742D0  , 554710.313D0  , 1.593173656D-04,146.911163D0  ,
     2 33567.6992D0  , 388215.625D0  , 1148923.00D0  , 0.0D0         ,
     3 5.801723897D-02,8.58840179D0  , 763.666443D0  , 35315.5352D0  ,
     4 810876.438D0  , 1.457292674D-04,194.779999D0  , 50045.7188D0  ,
     5 592061.188D0  , 1774536.25D0  , 0.0D0         , 2.58266187D0  ,
     6 40.2186584D0  , 458.666656D0  , 3879.22339D0  , 26078.4570D0  ,
     7 1.62305725D0  , 2361.20264D0  , 34653.8359D0  , 104898.953D0  ,
     8 136050.734D0  , 0.0D0         , 0.475486934D0  ,14.9392967D0  ,
     9 327.582428D0  , 4144.67236D0  , 29800.2109D0  , 0.845944464D0  ,
     * 4936.92480D0  , 59695.6836D0  , 104645.664D0  , 133242.016D0  ,
     1 0.0D0         , 0.603808820D0  ,22.7610054D0  , 559.287720D0  ,
     2 7799.18701D0  , 62819.4063D0  , 1.11512387D0  , 9363.07715D0  ,
     3 135641.188D0  , 282984.938D0  , 336481.969D0  , 0.0D0         ,
     4 1.452930365D-02,1.44994819D0  , 97.9827118D0  , 3587.86743D0  ,
     5 63078.9258D0  , 1.02980137D0  , 41673.0234D0  , 314019.625D0  ,
     6 2160809.75D0  , 2001500.50D0  , 0.0D0         , 1.111309417D-02,
     7 1.54286444D0  , 125.607826D0  , 5001.27832D0  , 91777.6953D0  ,
     8 1.07193601D0  , 60255.1250D0  , 485718.219D0  , 3088150.00D0  ,
     9 2997721.00D0  , 0.0D0         /
C * DATA FOR CS ELEMENT #55
      DATA ((XSC(55, I, J), J = 1, 11), I = 1, 17)/
     1 668.320923D0  , 0.000000000D+00,0.000000000D+00,0.00000000D+00,
     2 0.000000000D+00,1.13831234D0  , 101.049385D0  , 895.576660D0  ,
     3 2862.36206D0  , 5007.01465D0  , 5643.01758D0  , 62.9148407D0  ,
     4 985.461731D0  , 10133.5908D0  , 0.000000000D+00,0.00000000D+00,
     5 20.2039261D0  , 1173.67969D0  , 6234.69531D0  , 14131.9902D0  ,
     6 20480.4668D0  , 22111.2813D0  , 12.4088593D0  , 441.206024D0  ,
     7 11877.7227D0  , 0.000000000D+00,0.000000000D+00,3.77663493D0  ,
     8 683.332703D0  , 6998.48926D0  , 23326.7520D0  , 41032.0469D0  ,
     9 48133.7227D0  , 15.4399595D0  , 660.235291D0  , 20066.7324D0  ,
     * 0.000000000D+00,0.000000000D+00,5.47628450D0  , 1291.51416D0  ,
     1 14149.7021D0  , 48858.8516D0  , 87793.4297D0  , 103287.031D0  ,
     2 12.4345665D0  , 194.303421D0  , 2176.17163D0  , 16932.8340D0  ,
     3 0.000000000D+00,207.813293D0  , 6103.18750D0  , 24027.2090D0  ,
     4 46306.1641D0  , 61175.3398D0  , 66349.1484D0  , 2.55166268D0  ,
     5 81.5791855D0  , 1811.97534D0  , 22041.3555D0  , 0.00000000D+00,
     6 132.541412D0  , 8887.50684D0  , 41439.9219D0  , 78768.7188D0  ,
     7 99256.2813D0  , 116908.328D0  , 3.22512913D0  , 124.162460D0  ,
     8 3105.34570D0  , 42307.8672D0  , 286714.625D0  , 7.030848414D-03,
     9 369.943176D0  , 22729.1934D0  , 125855.672D0  , 234657.953D0  ,
     * 0.0D0         , 8.929523826D-02,9.31651497D0  , 674.936401D0  ,
     1 28080.4043D0  , 598648.063D0  , 1.352251275D-04,125.515762D0  ,
     2 29354.1777D0  , 347528.063D0  , 1013736.50D0  , 0.0D0         ,
     3 6.807342172D-02,9.93690300D0  , 867.317322D0  , 39209.3945D0  ,
     4 875926.188D0  , 1.313709508D-04,164.260330D0  , 43590.1602D0  ,
     5 529143.375D0  , 1566129.13D0  , 0.0D0         , 2.82313156D0  ,
     6 43.5039444D0  , 491.150970D0  , 4124.45654D0  , 27439.4531D0  ,
     7 1.35660052D0  , 2063.27148D0  , 31075.7227D0  , 96953.8828D0  ,
     8 136826.000D0  , 0.0D0         , 0.545892358D0  ,16.8631973D0  ,
     9 362.008423D0  , 4482.41504D0  , 31513.4902D0  , 0.584037483D0  ,
     * 3832.93018D0  , 51790.2969D0  , 99812.5313D0  , 119684.563D0  ,
     1 0.0D0         , 0.688148081D0  ,25.5704937D0  , 616.470398D0  ,
     2 8429.50781D0  , 66677.3281D0  , 0.917055428D0  ,8224.60254D0  ,
     3 126086.664D0  , 282213.500D0  , 341443.250D0  , 0.0D0         ,
     4 1.783043146D-02,1.75544798D0  , 116.101906D0  , 4130.71094D0  ,
     5 70102.7969D0  , 0.542041779D0  ,28382.6523D0  , 333746.094D0  ,
     6 509263.906D0  , 33172810.0D0  , 0.0D0         , 1.359604299D-02,
     7 1.86466908D0  , 148.681335D0  , 5751.55957D0  , 101874.367D0  ,
     8 0.606637239D0  ,43811.2578D0  , 516660.094D0  , 794425.000D0  ,
     9 40387076.0D0  , 0.0D0         , 0.472456068D0  ,6.95320225D0  ,
     * 76.9159241D0  , 654.311829D0  , 4590.27783D0  , 56.5033722D0  ,
     1 17553.1426D0  , 113058.570D0  , 88327.1797D0  , 39314.4805D0  ,
     2 0.0D0         , 7.315488160D-02,2.10896921D0  , 43.6368027D0  ,
     3 542.001160D0  , 4002.73047D0  , 117.951195D0  , 22826.1758D0  ,
     4 299502.938D0  , 6245063.50D0  , 34782560.0D0  , 0.0D0         ,
     5 8.944954723D-02,3.08562970D0  , 71.4837799D0  , 977.464233D0  ,
     6 8012.70508D0  , 281.478271D0  , 62977.6602D0  , 667453.938D0  ,
     7 14187204.0D0  , 75207264.0D0  , 0.0D0         /
C * DATA FOR BA ELEMENT #56
      DATA ((XSC(56, I, J), J = 1, 11), I = 1, 17)/
     1 713.582458D0  , 0.000000000D+00,0.000000000D+0, 0.00000000D+00,
     2 0.000000000D+00,1.11179888D0  , 96.9028397D0  , 856.469177D0  ,
     3 2735.89893D0  , 4783.97607D0  , 5391.82031D0  , 67.2285004D0  ,
     4 1038.76208D0  , 10493.1992D0  , 0.000000000D+0, 0.00000000D+00,
     5 19.0881329D0  , 1109.38501D0  , 5906.62012D0  , 13409.1484D0  ,
     6 19454.8555D0  , 20960.9531D0  , 13.8606262D0  , 485.220032D0  ,
     7 12817.0371D0  , 0.000000000D+00,0.000000000D+0, 3.61123204D0  ,
     8 645.642761D0  , 6601.72070D0  , 22001.8965D0  , 38780.4063D0  ,
     9 45369.6211D0  , 17.0906467D0  , 721.810120D0  , 21613.8535D0  ,
     * 0.000000000D+00,0.000000000D+00,5.15737438D0  , 1215.44312D0  ,
     1 13334.3994D0  , 46105.3984D0  , 82941.5078D0  , 97501.9453D0  ,
     2 13.3712473D0  , 206.457520D0  , 2284.67334D0  , 17555.6973D0  ,
     3 0.000000000D+00,191.704315D0  , 5684.00342D0  , 22503.7188D0  ,
     4 43555.9180D0  , 57755.9063D0  , 62266.0430D0  , 2.86609626D0  ,
     5 89.9967422D0  , 1954.58813D0  , 23138.7617D0  , 0.00000000D+00,
     6 120.214737D0  , 8159.10010D0  , 38513.3047D0  , 74012.3203D0  ,
     7 93928.9297D0  , 108998.781D0  , 3.59444380D0  , 136.313110D0  ,
     8 3344.86377D0  , 44585.9531D0  , 0.000000000D+0, 227.145859D0  ,
     9 17394.1035D0  , 87520.2578D0  , 177928.750D0  , 235298.797D0  ,
     * 271842.844D0  , 0.104761206D0  ,10.7616501D0  , 764.411133D0  ,
     1 31069.1133D0  , 644373.125D0  , 1.156260405D-04,107.815460D0  ,
     2 25759.6895D0  , 311501.281D0  , 900985.125D0  , 0.0D0         ,
     3 7.956307381D-02,11.4523907D0  , 981.137512D0  , 43359.9141D0  ,
     4 943255.750D0  , 1.209549810D-04,139.529465D0  , 38155.8359D0  ,
     5 473915.219D0  , 1389455.50D0  , 0.0D0         , 3.08263111D0  ,
     6 46.9716301D0  , 524.796814D0  , 4374.58398D0  , 28774.8438D0  ,
     7 1.17016554D0  , 1838.27747D0  , 28246.3711D0  , 90572.1094D0  ,
     8 129712.180D0  , 0.0D0         , 0.625213265D0 , 18.9666653D0  ,
     9 398.201202D0  , 4820.63867D0  , 33107.3359D0  , 0.478750050D0 ,
     * 3297.26660D0  , 47314.3828D0  , 97749.9844D0  , 109830.711D0  ,
     1 0.0D0         , 0.781740725D0  ,28.6364632D0  , 677.618713D0  ,
     2 9093.28320D0  , 70677.2500D0  , 0.729823232D0 , 7054.22217D0  ,
     3 115113.430D0  , 276223.219D0  , 328282.125D0  , 0.0D0         ,
     4 2.173442580D-02,2.10992384D0  , 136.500305D0  , 4715.90088D0  ,
     5 77176.7109D0  , 0.333374560D0  ,21233.9199D0  , 328205.063D0  ,
     6 191381.984D0  , 5116668.00D0  , 0.0D0         , 1.655145921D-02,
     7 2.23914099D0  , 174.731979D0  , 6567.91357D0  , 112285.172D0  ,
     8 0.355158508D0  ,32598.8613D0  , 509330.250D0  , 286083.969D0  ,
     9 8133637.00D0  , 0.0D0         , 0.551031470D0 , 8.08315945D0  ,
     * 88.9186935D0  , 753.340576D0  , 5275.69482D0  , 20.1813545D0  ,
     1 8736.69629D0  , 76697.9141D0  , 119734.805D0  , 46879.7344D0  ,
     2 0.0D0         , 9.369242191D-02,2.68614078D0  , 54.6888275D0  ,
     3 664.928711D0  , 4825.64844D0  , 82.7137222D0  , 21627.6367D0  ,
     4 176767.813D0  , 2802744.50D0  , 14046967.0D0  , 0.0D0         ,
     5 0.115231708D0  ,3.96815205D0  , 90.7736359D0  , 1219.17761D0  ,
     6 9861.18945D0  , 193.207626D0  , 59549.1172D0  , 412173.219D0  ,
     7 5905087.50D0  , 30859814.0D0  , 0.0D0         /
C * DATA FOR LA ELEMENT #57
      DATA ((XSC(57, I, J), J = 1, 11), I = 1, 17)/
     1 760.622742D0  , 0.000000000D+0, 0.000000000D+0, 0.000000000D+0,
     2 0.000000000D+0, 1.08746529D0  , 93.0395203D0  , 819.900757D0  ,
     3 2617.47217D0  , 4574.85010D0  , 5157.28516D0  , 71.7344208D0  ,
     4 1093.24158D0  , 10849.6484D0  , 0.000000000D+0, 0.000000000D+0,
     5 18.1027164D0  , 1051.47766D0  , 5608.29297D0  , 12748.2500D0  ,
     6 18545.5527D0  , 19904.3516D0  , 15.4446859D0  , 532.367676D0  ,
     7 13792.8945D0  , 0.000000000D+0, 0.000000000D+0, 3.46828914D0  ,
     8 612.457642D0  , 6248.75586D0  , 20814.9590D0  , 36688.3828D0  ,
     9 41857.4805D0  , 18.8738060D0  , 787.280396D0  , 23222.7852D0  ,
     * 0.000000000D+0, 0.000000000D+0, 4.88159323D0  , 1148.77698D0  ,
     1 12612.4453D0  , 43647.6953D0  , 78571.0156D0  , 89963.6719D0  ,
     2 14.3574810D0  , 218.963730D0  , 2393.10010D0  , 18141.1133D0  ,
     3 0.000000000D+0, 180.240738D0  , 5369.84570D0  , 21318.6699D0  ,
     4 41354.8047D0  , 55034.1289D0  , 58846.9102D0  , 3.21070743D0  ,
     5 99.0047684D0  , 2101.86963D0  , 24202.1484D0  , 0.000000000D+0,
     6 111.235100D0  , 7595.96582D0  , 36149.2617D0  , 70033.2422D0  ,
     7 89405.4063D0  , 104330.344D0  , 3.99530911D0  , 149.249466D0  ,
     8 3592.67651D0  , 46846.2500D0  , 0.000000000D+0, 208.944336D0  ,
     9 16194.5527D0  , 82332.9766D0  , 168956.438D0  , 224955.078D0  ,
     * 259557.609D0  , 0.122428671D0  ,12.3795862D0  , 861.627136D0  ,
     1 34171.8516D0  , 689897.938D0  , 1.033526787D-04,95.9333115D0  ,
     2 23207.3984D0  , 284373.250D0  , 819914.250D0  , 0.0D0         ,
     3 9.262146056D-02,13.1446447D0  , 1104.64941D0  , 47668.8398D0  ,
     4 1009631.00D0  , 1.158792584D-04,122.895706D0  , 34300.3750D0  ,
     5 432385.813D0  , 1263590.63D0  , 0.0D0         , 3.35369444D0  ,
     6 50.5715675D0  , 559.346008D0  , 4626.12598D0  , 30044.0469D0  ,
     7 1.07607150D0  , 1714.85522D0  , 26598.2578D0  , 86576.2031D0  ,
     8 125810.188D0  , 0.0D0         , 0.712526858D0  ,21.2413349D0  ,
     9 436.218292D0  , 5161.81543D0  , 34613.3047D0  , 0.422868967D0  ,
     * 3052.04541D0  , 45007.6914D0  , 97081.1250D0  , 109125.227D0  ,
     1 0.0D0         , 0.885864735D0  ,31.9587975D0  , 741.741638D0  ,
     2 9764.77148D0  , 74519.5469D0  , 0.670626879D0  ,6612.56006D0  ,
     3 110712.016D0  , 276993.594D0  , 337661.438D0  , 0.0D0         ,
     4 2.634496614D-02,2.51742959D0  , 159.058853D0  , 5327.98145D0  ,
     5 83920.8281D0  , 0.305604696D0  ,19869.7539D0  , 330691.094D0  ,
     6 173071.016D0  , 1769126.13D0  , 0.0D0         , 1.999914832D-02,
     7 2.66824508D0  , 203.687515D0  , 7435.59229D0  , 122600.813D0  ,
     8 0.280723274D0  ,28343.6602D0  , 502299.375D0  , 256709.563D0  ,
     9 2599748.00D0  , 0.0D0         , 0.634120166D0  ,9.22574329D0  ,
     * 100.573242D0  , 845.609009D0  , 5863.55518D0  , 34.9373627D0  ,
     1 13069.1367D0  , 102413.617D0  , 145775.375D0  , 82583.2813D0  ,
     2 0.0D0         , 0.115328141D0  ,3.26670742D0  , 65.2264099D0  ,
     3 776.051514D0  , 5532.49072D0  , 138.578018D0  , 28625.2891D0  ,
     4 268284.125D0  , 3371859.00D0  , 11701498.0D0  , 0.0D0         ,
     5 0.141208023D0  ,4.82152081D0  , 108.560730D0  , 1432.34155D0  ,
     6 11431.7119D0  , 237.852753D0  , 70301.5703D0  , 473999.531D0  ,
     7 5534420.00D0  , 21534214.0D0  , 0.0D0         /
C * DATA FOR CE ELEMENT #58
      DATA ((XSC(58, I, J), J = 1, 11), I = 1, 18)/
     1 809.808044D0  , 0.000000000D+0, 0.000000000D+0, 0.000000000D+0,
     2 0.000000000D+0, 1.06494546D0  , 89.4196777D0  , 785.679443D0  ,
     3 2507.05469D0  , 4384.17139D0  , 4934.34863D0  , 76.4517670D0  ,
     4 1149.86023D0  , 11217.5518D0  , 0.000000000D+0, 0.000000000D+0,
     5 17.2115879D0  , 999.253052D0  , 5340.44824D0  , 12156.1689D0  ,
     6 17694.2715D0  , 18956.2617D0  , 17.1871319D0  , 583.774780D0  ,
     7 14862.6494D0  , 0.000000000D+00,0.000000000D+00,3.34046555D0  ,
     8 582.965149D0  , 5939.49902D0  , 19788.4238D0  , 34880.5117D0  ,
     9 39648.7305D0  , 20.8196659D0  , 858.343506D0  , 24986.5137D0  ,
     * 0.000000000D+0, 0.000000000D+0, 4.63358974D0  , 1089.41125D0  ,
     1 11981.6689D0  , 41540.0820D0  , 74921.2031D0  , 87887.2813D0  ,
     2 15.3994770D0  , 232.209656D0  , 2510.77319D0  , 18812.0273D0  ,
     3 0.000000000D+0, 169.179718D0  , 5079.00439D0  , 20256.5059D0  ,
     4 39389.9805D0  , 52409.5625D0  , 56607.7656D0  , 3.59319282D0  ,
     5 108.887032D0  , 2263.31470D0  , 25395.0762D0  , 0.000000000D+0,
     6 103.819031D0  , 7137.40576D0  , 34230.3945D0  , 66648.0156D0  ,
     7 85321.3125D0  , 100858.266D0  , 4.43625975D0  , 163.381516D0  ,
     8 3865.47168D0  , 49440.1797D0  , 0.000000000D+0, 193.663513D0  ,
     9 15214.8311D0  , 78193.3125D0  , 161653.813D0  , 216238.609D0  ,
     * 250859.453D0  , 0.142987847D0 , 14.2490416D0  , 974.597046D0  ,
     1 37971.5156D0  , 766256.375D0  , 9.374778892D-05,86.6941147D0  ,
     2 21336.9805D0  , 266197.406D0  , 783598.063D0  , 0.0D0         ,
     3 0.107752517D0  ,15.0949926D0  , 1248.11316D0  , 52964.6797D0  ,
     4 1117025.88D0  , 1.129675657D-04,109.798767D0  , 31450.6113D0  ,
     5 404560.438D0  , 1208476.25D0  , 0.0D0         , 3.61078858D0  ,
     6 53.8377266D0  , 589.919250D0  , 4852.89404D0  , 31144.9297D0  ,
     7 0.976827741D0  ,1578.11487D0  , 24810.5371D0  , 80955.2500D0  ,
     8 117010.914D0  , 0.0D0         , 0.800607145D0 , 23.4364147D0  ,
     9 471.346466D0  , 5469.02637D0  , 35751.8672D0  , 0.367917597D0 ,
     * 2727.51880D0  , 41595.8828D0  , 90040.4922D0  , 99440.3594D0  ,
     1 0.0D0         , 0.984948337D0  ,35.0290184D0  , 799.215332D0  ,
     2 10361.3623D0  , 77732.5938D0  , 0.551236331D0  ,5903.72998D0  ,
     3 102664.188D0  , 259700.688D0  , 312581.281D0  , 0.0D0         ,
     4 3.089012951D-02,2.90309620D0  , 179.588837D0  , 5875.51270D0  ,
     5 89656.0000D0  , 0.224790260D0  ,16450.4414D0  , 302828.688D0  ,
     6 155294.266D0  , 2181362.25D0  , 0.0D0         , 2.329728007D-02,
     7 3.06572342D0  , 229.529587D0  , 8191.41748D0  , 131030.469D0  ,
     8 0.198385447D0  ,23346.7324D0  , 458748.375D0  , 230269.875D0  ,
     9 3252526.25D0  , 0.0D0         , 1.035557761D-05,3.610637737D-03,
     * 0.808584511D0  ,99.4774170D0  , 7211.28125D0  , 5.046080914D-04,
     1 1199.99670D0  , 226161.875D0  , 939981.813D0  , 176164.344D0  ,
     2 0.0D0         , 0.651443303D0  ,9.37103844D0  , 101.202232D0  ,
     3 846.455566D0  , 5818.99902D0  , 25.0341949D0  , 10096.7607D0  ,
     4 82769.1406D0  , 119174.609D0  , 54989.6055D0  , 0.0D0         ,
     5 0.121410131D0  ,3.36805582D0  , 65.7644196D0  , 767.275940D0  ,
     6 5356.12988D0  , 63.9939270D0  , 19259.2656D0  , 134978.344D0  ,
     7 2124584.25D0  , 10484848.0D0  , 0.0D0         , 0.146372274D0  ,
     8 4.90951490D0  , 108.452263D0  , 1408.65442D0  , 11072.5674D0  ,
     9 105.411148D0  , 45629.6680D0  , 262444.625D0  , 3349819.25D0  ,
     * 19155670.0D0  , 0.0D0         /
C * DATA FOR PR ELEMENT #59
      DATA ((XSC(59, I, J), J = 1, 11), I = 1, 18)/
     1 860.712097D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,1.04404485D0  , 86.0257263D0  , 753.414917D0  ,
     3 2402.43408D0  , 4199.05176D0  , 4728.57568D0  , 81.3395538D0  ,
     4 1207.10864D0  , 11565.8018D0  , 0.000000000D+00,0.000000000D+0,
     5 16.3109131D0  , 951.270203D0  , 5091.45117D0  , 11600.6182D0  ,
     6 16877.1348D0  , 18157.6543D0  , 19.0795765D0  , 638.302734D0  ,
     7 15951.4932D0  , 0.000000000D+00,0.000000000D+00,3.22954988D0  ,
     8 556.463745D0  , 5655.64258D0  , 18830.7266D0  , 33142.2188D0  ,
     9 37849.7344D0  , 22.9036770D0  , 933.039917D0  , 26775.6172D0  ,
     * 0.000000000D+00,0.000000000D+00,4.41599846D0  , 1036.26831D0  ,
     1 11404.3916D0  , 39572.0508D0  , 71370.6797D0  , 83811.2344D0  ,
     2 16.4826298D0  , 245.755096D0  , 2628.28271D0  , 19448.8730D0  ,
     3 0.000000000D+00,158.747223D0  , 4798.38330D0  , 19215.6523D0  ,
     4 37455.7188D0  , 49881.4883D0  , 54007.9102D0  , 4.00849056D0  ,
     5 119.319763D0  , 2425.90112D0  , 26482.9023D0  , 0.000000000D+0,
     6 98.3049698D0  , 6764.58691D0  , 32577.4707D0  , 63681.0547D0  ,
     7 81833.2656D0  , 95781.7969D0  , 4.91230440D0  , 178.217194D0  ,
     8 4139.19287D0  , 51840.7891D0  , 0.000000000D+00,182.810226D0  ,
     9 14453.4980D0  , 74755.5313D0  , 155398.234D0  , 208608.172D0  ,
     * 243150.438D0  , 0.166180491D0  ,16.3103027D0  , 1094.47742D0  ,
     1 41736.0703D0  , 853500.313D0  , 8.752152644D-05,79.9549789D0  ,
     2 19838.3828D0  , 249923.359D0  , 741483.375D0  , 0.0D0         ,
     3 0.124732487D0  ,17.2376976D0  , 1399.79138D0  , 58175.6797D0  ,
     4 1234410.50D0  , 1.128136355D-04,100.572495D0  , 29242.8535D0  ,
     5 380224.063D0  , 1145307.25D0  , 0.0D0         , 3.88804603D0  ,
     6 57.3575478D0  , 622.517395D0  , 5085.46436D0  , 32177.2168D0  ,
     7 0.930876434D0  ,1505.27185D0  , 23761.2402D0  , 77547.5938D0  ,
     8 112279.977D0  , 0.0D0         , 0.899813354D0  ,25.8756599D0  ,
     9 509.420319D0  , 5787.86377D0  , 36860.5078D0  , 0.347547859D0 ,
     * 2571.41772D0  , 39730.1016D0  , 86690.9844D0  , 95286.7266D0  ,
     1 0.0D0         , 1.09892488D0  , 38.4812775D0  , 862.006897D0  ,
     2 10987.7666D0  , 80905.5938D0  , 0.521490991D0  ,5636.45605D0  ,
     3 99302.6797D0  , 253925.141D0  , 306984.688D0  , 0.0D0         ,
     4 3.637861088D-02,3.36317515D0  , 203.367188D0  , 6471.13867D0  ,
     5 95183.6875D0  , 0.234063476D0  ,16634.0469D0  , 300942.000D0  ,
     6 155594.250D0  , 1859522.25D0  , 0.0D0         , 2.732011490D-02,
     7 3.54275942D0  , 259.574341D0  , 9017.19824D0  , 139186.813D0  ,
     8 0.203849971D0  ,23572.1543D0  , 456056.719D0  , 231231.016D0  ,
     9 2776127.50D0  , 0.0D0         , 2.183549441D-05,7.402888034D-03,
     * 1.58398998D0  , 180.476883D0  , 11228.9365D0  , 2134.21289D0  ,
     1 3177413.00D0  , 1800969.50D0  , 1281234.88D0  , 1149309.13D0  ,
     2 0.0D0         , 0.698364556D0  ,9.93235111D0  , 106.226723D0  ,
     3 882.846558D0  , 6008.07275D0  , 27.0433693D0  , 10559.6523D0  ,
     4 83490.3438D0  , 114421.273D0  , 52936.0195D0  , 0.0D0         ,
     5 0.134908944D0  ,3.68196821D0  , 70.4402924D0  , 805.636169D0  ,
     6 5511.17969D0  , 50.8948174D0  , 17093.0000D0  , 110354.102D0  ,
     7 1795618.25D0  , 9865037.00D0  , 0.0D0         , 0.160756379D0 ,
     8 5.32210493D0  , 115.589355D0  , 1477.56909D0  , 11442.8271D0  ,
     9 82.3358917D0  , 40193.3594D0  , 223769.688D0  , 2781508.00D0  ,
     * 17979608.0D0  , 0.0D0         /
C * DATA FOR ND ELEMENT #60
      DATA ((XSC(60, I, J), J = 1, 11), I = 1, 18)/
     1 913.447388D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,1.02490735D0  , 82.8395767D0  , 723.043884D0  ,
     3 2304.07080D0  , 4028.49536D0  , 4529.63818D0  , 86.4296341D0  ,
     4 1265.45947D0  , 11914.8076D0  , 0.000000000D+00,0.000000000D+0,
     5 15.5730972D0  , 906.954590D0  , 4859.86523D0  , 11082.6943D0  ,
     6 16151.4941D0  , 17348.4160D0  , 21.1415882D0  , 696.520569D0  ,
     7 17076.5527D0  , 0.000000000D+00,0.000000000D+00,3.13180876D0  ,
     8 532.388794D0  , 5395.26465D0  , 17946.8633D0  , 31614.7520D0  ,
     9 36935.4258D0  , 25.1437130D0  , 1012.18188D0  , 28640.3652D0  ,
     * 0.000000000D+00,0.000000000D+00,4.22006083D0  , 987.990540D0  ,
     1 10876.1992D0  , 37762.1992D0  , 68143.7031D0  , 79710.7188D0  ,
     2 17.6077061D0  , 259.519012D0  , 2743.41016D0  , 20013.6563D0  ,
     3 0.000000000D+00,152.314575D0  , 4609.48486D0  , 18466.1133D0  ,
     4 35998.0273D0  , 47935.9570D0  , 51975.0820D0  , 4.46138382D0  ,
     5 130.456482D0  , 2594.31519D0  , 27548.5840D0  , 0.000000000D+0,
     6 93.4612045D0  , 6428.92871D0  , 31062.5059D0  , 60916.6875D0  ,
     7 78521.5781D0  , 91443.4609D0  , 5.42337370D0  , 193.898621D0  ,
     8 4421.40381D0  , 54216.1445D0  , 0.000000000D+00,174.003799D0  ,
     9 13811.7891D0  , 71773.0547D0  , 149865.641D0  , 201881.109D0  ,
     * 238359.641D0  , 0.192459345D0  ,18.6036015D0  , 1224.46497D0  ,
     1 45675.3984D0  , 10258765.0D0  , 7.803834887D-05,74.7325974D0  ,
     2 18626.1699D0  , 236190.359D0  , 705053.500D0  , 0.0D0         ,
     3 0.143891469D0  ,19.6166897D0  , 1564.23059D0  , 63645.9609D0  ,
     4 1330188.38D0  , 1.077217312D-04,93.2128067D0  , 27422.7539D0  ,
     5 359431.469D0  , 1089675.88D0  , 0.0D0         , 4.17606592D0  ,
     6 60.9531631D0  , 655.201355D0  , 5311.15576D0  , 33073.5000D0  ,
     7 0.876959801D0  ,1476.41321D0  , 23229.2422D0  , 75376.2891D0  ,
     8 109102.828D0  , 0.0D0         , 1.00769746D0  , 28.4614315D0  ,
     9 548.302368D0  , 6095.67090D0  , 37794.9883D0  , 0.357061416D0 ,
     * 2562.55591D0  , 39166.2227D0  , 84976.8047D0  , 93437.0938D0  ,
     1 0.0D0         , 1.22021139D0  , 42.1038475D0  , 926.316162D0  ,
     2 11606.6885D0  , 83823.6797D0  , 0.521504462D0  ,5574.42334D0  ,
     3 98074.5938D0  , 251388.953D0  , 305621.188D0  , 0.0D0         ,
     4 4.261606559D-02,3.87616181D0  , 229.196854D0  , 7099.17236D0  ,
     5 100678.688D0  , 0.234244794D0  ,16402.4570D0  , 296047.875D0  ,
     6 154744.047D0  , 1601790.63D0  , 0.0D0         , 3.191594034D-02,
     7 4.07501125D0  , 292.152466D0  , 9887.37012D0  , 147312.656D0  ,
     8 0.200786948D0  ,23198.9570D0  , 448626.906D0  , 230925.766D0  ,
     9 2393268.75D0  , 0.0D0         , 3.790792107D-05,1.291131414D-02,
     * 2.73084378D0  , 303.519989D0  , 18331.5410D0  , 6201.41406D0  ,
     1 4246958.50D0  , 1898921.63D0  , 1260278.00D0  , 900741.375D0  ,
     2 0.0D0         , 0.744405925D0  ,10.4884844D0  , 111.216232D0  ,
     3 918.484375D0  , 6185.98535D0  , 28.2904549D0  , 10784.8213D0  ,
     4 82883.8125D0  , 109374.461D0  , 51805.9492D0  , 0.0D0         ,
     5 0.149897382D0  ,4.01506662D0  , 75.1642990D0  , 842.401367D0  ,
     6 5641.87305D0  , 62.5228653D0  , 18274.9824D0  , 129760.617D0  ,
     7 2142587.50D0  , 11493880.0D0  , 0.0D0         , 0.176585436D0 ,
     8 5.75601721D0  , 122.752457D0  , 1543.74365D0  , 11766.4434D0  ,
     9 101.254219D0  , 43792.4063D0  , 248609.359D0  , 3320073.25D0  ,
     * 21039738.0D0  , 0.0D0         /
C * DATA FOR PM ELEMENT #61
      DATA ((XSC(61, I, J), J = 1, 11), I = 1, 18)/
     1 968.105164D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,1.00672913D0  , 79.8226166D0  , 694.223694D0  ,
     3 2210.44873D0  , 3862.62012D0  , 4345.92725D0  , 91.7074280D0  ,
     4 1325.11218D0  , 12263.9980D0  , 0.000000000D+00,0.000000000D+0,
     5 14.8659601D0  , 864.576538D0  , 4639.04932D0  , 10588.7500D0  ,
     6 15432.6221D0  , 16601.2402D0  , 23.3821125D0  , 758.867065D0  ,
     7 18264.5020D0  , 0.000000000D+00,0.000000000D+00,3.01800466D0  ,
     8 509.440186D0  , 5148.70850D0  , 17113.2383D0  , 30120.5820D0  ,
     9 35252.3320D0  , 27.5586643D0  , 1096.41223D0  , 30605.2305D0  ,
     * 0.000000000D+00,0.000000000D+00,4.03355980D0  , 942.017212D0  ,
     1 10375.3223D0  , 36054.0430D0  , 65171.3828D0  , 76039.9375D0  ,
     2 18.7907276D0  , 273.776337D0  , 2861.63306D0  , 20585.3867D0  ,
     3 0.000000000D+00,145.209839D0  , 4405.80762D0  , 17676.3828D0  ,
     4 34478.1602D0  , 45973.0469D0  , 49837.1992D0  , 4.95716000D0  ,
     5 142.364609D0  , 2769.53345D0  , 28606.2969D0  , 0.000000000D+0,
     6 88.7883835D0  , 6105.67725D0  , 29603.0605D0  , 58231.0273D0  ,
     7 75172.6953D0  , 87920.0313D0  , 5.97502613D0  , 210.568954D0  ,
     8 4716.79346D0  , 56664.7109D0  , 0.000000000D+00,164.718735D0  ,
     9 13151.1162D0  , 68740.3672D0  , 144250.172D0  , 195117.422D0  ,
     * 227489.813D0  , 0.222328722D0  ,21.1643238D0  , 1367.03345D0  ,
     1 49949.4805D0  , 0.000000000D+00,42.2864380D0  , 13450.1514D0  ,
     2 140667.063D0  , 436547.063D0  , 768294.688D0  , 9587678.00D0  ,
     3 0.165465444D0  ,22.2592735D0  , 1743.82324D0  , 69536.2188D0  ,
     4 0.000000000D+00,51.1324348D0  , 19737.7246D0  , 213320.188D0  ,
     5 671213.563D0  , 1194337.88D0  , 14725362.0D0  , 4.48026371D0  ,
     6 64.6739578D0  , 688.634399D0  , 5541.96533D0  , 33967.9531D0  ,
     7 0.835677087D0  ,1411.66357D0  , 22271.9531D0  , 72218.1797D0  ,
     8 104547.602D0  , 0.0D0         , 1.12526691D0  , 31.2218380D0  ,
     9 588.890503D0  , 6411.08105D0  , 38681.0781D0  , 0.348930359D0 ,
     * 2468.01147D0  , 37817.0000D0  , 82121.3359D0  , 90096.3047D0  ,
     1 0.0D0         , 1.35085428D0  , 45.9449043D0  , 993.455322D0  ,
     2 12249.7432D0  , 86818.5234D0  , 0.489623427D0  ,5293.72363D0  ,
     3 94433.5938D0  , 244521.234D0  , 298490.156D0  , 0.0D0         ,
     4 4.967614636D-02,4.44507980D0  , 257.014374D0  , 7749.38623D0  ,
     5 105896.570D0  , 0.246039420D0  ,16661.4395D0  , 293728.563D0  ,
     6 154141.938D0  , 1425006.00D0  , 0.0D0         , 3.703936562D-02,
     7 4.66134930D0  , 327.162567D0  , 10787.4014D0  , 155038.797D0  ,
     8 0.208176479D0  ,23531.9668D0  , 445345.063D0  , 229929.859D0  ,
     9 2132981.75D0  , 0.0D0          ,6.042137829D-05,2.064520679D-02,
     * 4.31517363D0  , 468.574341D0  , 27527.2949D0  , 3282.38892D0  ,
     1 4659896.50D0  , 2167964.00D0  , 1106787.13D0  , 625464.750D0  ,
     2 0.0D0         , 0.793453932D0  ,11.0569677D0  , 116.161903D0  ,
     3 953.135803D0  , 6350.88232D0  , 29.7003460D0  , 11026.4053D0  ,
     4 82262.7031D0  , 104472.398D0  , 51364.2109D0  , 0.0D0         ,
     5 0.165404201D0  ,4.35852671D0  , 79.9592667D0  , 878.540588D0  ,
     6 5760.62988D0  , 66.6086273D0  , 18324.8105D0  , 136198.859D0  ,
     7 2281655.50D0  , 12365242.0D0  , 0.0D0         , 0.192575037D0 ,
     8 6.19663668D0  , 129.966965D0  , 1609.01404D0  , 12074.4307D0  ,
     9 107.336311D0  , 44408.6367D0  , 253856.297D0  , 3515567.00D0  ,
     * 22672972.0D0  , 0.0D0         /
C * DATA FOR SM ELEMENT #62
      DATA ((XSC(62, I, J), J = 1, 11), I = 1, 18)/
     1 1024.60889D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.989990175D0  ,76.9716949D0  , 666.947815D0  ,
     3 2122.06958D0  , 3709.04028D0  , 4167.85449D0  , 97.1800232D0  ,
     4 1385.82727D0  , 12577.5488D0  , 0.000000000D+00,0.000000000D+0,
     5 14.2096920D0  , 824.943970D0  , 4431.94629D0  , 10124.3301D0  ,
     6 14750.3789D0  , 15886.4209D0  , 25.8145218D0  , 825.375854D0  ,
     7 19507.0449D0  , 0.000000000D+00,0.000000000D+00,2.92831445D0  ,
     8 488.056732D0  , 4918.67969D0  , 16334.6289D0  , 28715.1699D0  ,
     9 33631.8125D0  , 30.1455135D0  , 1185.63635D0  , 32645.8516D0  ,
     * 0.000000000D+00,0.000000000D+00,3.85827994D0  , 899.062134D0  ,
     1 9907.23438D0  , 34452.4336D0  , 62228.0156D0  , 73187.8359D0  ,
     2 20.0156765D0  , 288.433502D0  , 2982.33032D0  , 21155.1348D0  ,
     3 0.000000000D+00,137.929657D0  , 4200.35010D0  , 16887.6016D0  ,
     4 32973.0820D0  , 43966.6367D0  , 47779.8008D0  , 5.49368525D0  ,
     5 155.004822D0  , 2950.27979D0  , 29631.3262D0  , 0.000000000D+0,
     6 84.6665878D0  , 5814.60059D0  , 28265.7559D0  , 55739.7070D0  ,
     7 72101.6797D0  , 84933.0078D0  , 6.56906414D0  , 228.257263D0  ,
     8 5024.90869D0  , 59169.4727D0  , 0.000000000D+00,155.505859D0  ,
     9 12499.7314D0  , 65756.5703D0  , 138696.875D0  , 188337.016D0  ,
     * 217892.078D0  , 0.255926639D0  ,24.0063839D0  , 1522.65051D0  ,
     1 54543.4414D0  , 0.000000000D+00,39.2380524D0  , 12562.8447D0  ,
     2 132371.422D0  , 413444.719D0  , 727641.688D0  , 8914730.00D0  ,
     3 0.189811066D0  ,25.1965961D0  , 1940.54822D0  , 75954.4844D0  ,
     4 0.000000000D+00,46.8156319D0  , 18364.1543D0  , 200432.625D0  ,
     5 635388.875D0  , 1130759.25D0  , 13595857.0D0  , 4.79181480D0  ,
     6 68.4667816D0  , 722.490662D0  , 5771.56299D0  , 34794.7070D0  ,
     7 0.798738182D0  ,1352.46814D0  , 21380.3438D0  , 69235.1953D0  ,
     8 100161.945D0  , 0.0D0         , 1.25433755D0  , 34.1671867D0  ,
     9 630.850708D0  , 6726.20850D0  , 39463.2578D0  , 0.342500240D0 ,
     * 2380.81567D0  , 36525.8398D0  , 79284.4063D0  , 86797.0078D0  ,
     1 0.0D0         , 1.49108446D0  , 49.9956284D0  , 1062.76575D0  ,
     2 12899.3506D0  , 89694.4844D0  , 0.462454557D0  ,5043.36279D0  ,
     3 91066.2344D0  , 237872.828D0  , 291451.938D0  , 0.0D0         ,
     4 5.766981095D-02,5.07888269D0  , 287.474701D0  , 8456.42090D0  ,
     5 111497.336D0  , 0.214876041D0  ,15080.7578D0  , 279950.500D0  ,
     6 151400.031D0  , 1231856.88D0  , 0.0D0         , 4.280338809D-02,
     7 5.31219530D0  , 365.430267D0  , 11766.2344D0  , 163378.766D0  ,
     8 0.176703438D0  ,21222.5664D0  , 423828.625D0  , 228382.328D0  ,
     9 1842798.25D0  , 0.0D0         , 9.115662397D-05,3.120273724D-02,
     * 6.44168377D0  , 684.032349D0  , 39105.0742D0  , 1407.56836D0  ,
     1 4632811.00D0  , 2616724.75D0  , 1052927.88D0  , 517781.719D0  ,
     2 0.0D0         , 0.841388226D0  ,11.6187687D0  , 121.064171D0  ,
     3 986.825439D0  , 6502.87549D0  , 31.2840271D0  , 11289.3701D0  ,
     4 81614.6094D0  , 99689.8125D0  , 51566.5273D0  , 0.0D0         ,
     5 0.182548285D0  ,4.72200823D0  , 84.8162308D0  , 913.745117D0  ,
     6 5864.52930D0  , 69.1399307D0  , 18138.4902D0  , 140176.719D0  ,
     7 2382270.25D0  , 13121841.0D0  , 0.0D0         , 0.210070804D0 ,
     8 6.65772390D0  , 137.215744D0  , 1672.80249D0  , 12359.4609D0  ,
     9 110.741966D0  , 44411.7617D0  , 255105.328D0  , 3646091.75D0  ,
     * 24088756.0D0  , 0.0D0         /
C * DATA FOR EU ELEMENT #63
      DATA ((XSC(63, I, J), J = 1, 11), I = 1, 18)/
     1 1082.95947D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.974171460D0  ,74.2786179D0  , 641.095825D0  ,
     3 2037.95776D0  , 3560.11499D0  , 4002.50830D0  , 102.862061D0  ,
     4 1447.51978D0  , 12906.5879D0  , 0.000000000D+00,0.000000000D+0,
     5 13.6051102D0  , 788.036255D0  , 4237.81445D0  , 9688.19727D0  ,
     6 14137.7637D0  , 15188.7998D0  , 28.4541492D0  , 896.136658D0  ,
     7 20760.3008D0  , 0.000000000D+00,0.000000000D+00,2.84694123D0  ,
     8 468.369171D0  , 4705.22266D0  , 15609.0039D0  , 27462.1641D0  ,
     9 32092.1113D0  , 32.9148712D0  , 1279.87524D0  , 34769.1055D0  ,
     * 0.000000000D+00,0.000000000D+00,3.67583942D0  , 859.464600D0  ,
     1 9473.74414D0  , 32965.2734D0  , 59528.4609D0  , 70212.0781D0  ,
     2 21.2896595D0  , 303.460571D0  , 3104.04297D0  , 21702.4473D0  ,
     3 0.000000000D+00,131.338531D0  , 4011.77026D0  , 16156.6387D0  ,
     4 31568.1660D0  , 42096.6328D0  , 45800.4844D0  , 6.07634449D0  ,
     5 168.462387D0  , 3137.86792D0  , 30639.4648D0  , 0.000000000D+0,
     6 80.5750580D0  , 5529.34521D0  , 26960.1426D0  , 53302.7578D0  ,
     7 69107.0547D0  , 80889.2344D0  , 7.20967674D0  , 246.910980D0  ,
     8 5340.70264D0  , 61623.8750D0  , 0.000000000D+00,148.134735D0  ,
     9 11953.7559D0  , 63179.2500D0  , 133790.188D0  , 182081.109D0  ,
     * 211428.422D0  , 0.293706030D0  ,27.1489658D0  , 1690.91504D0  ,
     1 59372.9727D0  , 0.000000000D+00,36.6632385D0  , 11795.0303D0  ,
     2 125044.891D0  , 392674.344D0  , 691058.563D0  , 8393959.00D0  ,
     3 0.216936782D0  ,28.4228420D0  , 2151.36255D0  , 82561.6563D0  ,
     4 0.000000000D+00,43.5729256D0  , 17289.3379D0  , 189921.781D0  ,
     5 605157.125D0  , 1076519.50D0  , 12751725.0D0  , 5.11582518D0  ,
     6 72.3587494D0  , 756.797119D0  , 5998.93994D0  , 35548.1523D0  ,
     7 0.771124959D0  ,1304.55896D0  , 20625.2500D0  , 66597.2422D0  ,
     8 96260.0313D0  , 0.0D0         , 1.39358258D0  , 37.3071594D0  ,
     9 675.029053D0  , 7056.30273D0  , 40208.6094D0  , 0.312348515D0 ,
     * 2182.68188D0  , 34230.7852D0  , 75077.6719D0  , 81696.9531D0  ,
     1 0.0D0         , 1.64342415D0  , 54.2822533D0  , 1134.02893D0  ,
     2 13547.2734D0  , 92375.8125D0  , 0.452580839D0  ,4910.60840D0  ,
     3 88969.8750D0  , 233275.406D0  , 287084.031D0  , 0.0D0         ,
     4 6.667943299D-02,5.77828264D0  , 319.998474D0  , 9173.61035D0  ,
     5 116564.227D0  , 0.217281744D0  ,14959.1025D0  , 275113.344D0  ,
     6 149905.344D0  , 1111816.63D0  , 0.0D0         , 4.926908761D-02,
     7 6.02834845D0  , 406.214783D0  , 12758.1240D0  , 170930.344D0  ,
     8 0.176095545D0  ,21010.7500D0  , 416563.594D0  , 226317.938D0  ,
     9 1665856.63D0  , 0.0D0         , 1.146181894D-04,3.901197389D-02,
     * 7.91907215D0  , 820.722168D0  , 45399.4453D0  , 17581.6465D0  ,
     1 5085654.50D0  , 1741765.38D0  , 1076830.88D0  , 847386.250D0  ,
     2 0.0D0         , 0.893049419D0  ,12.1990910D0  , 125.938431D0  ,
     3 1018.71301D0  , 6625.91211D0  , 46.2834549D0  , 14583.2295D0  ,
     4 92570.0938D0  , 99155.5078D0  , 59714.5078D0  , 0.0D0         ,
     5 0.200391889D0  ,5.09999228D0  , 89.8084869D0  , 948.916504D0  ,
     6 5960.54932D0  , 67.7624512D0  , 17511.6875D0  , 136995.969D0  ,
     7 2374781.50D0  , 13462045.0D0  , 0.0D0         , 0.228655919D0 ,
     8 7.13864422D0  , 144.625183D0  , 1736.83936D0  , 12636.8389D0  ,
     9 107.579514D0  , 43169.0313D0  , 246647.641D0  , 3599109.50D0  ,
     * 24708374.0D0  , 0.0D0         /
C * DATA FOR GD ELEMENT #64
      DATA ((XSC(64, I, J), J = 1, 11), I = 1, 19)/
     1 1143.10596D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.959365785D0  ,71.7253799D0  , 616.497253D0  ,
     3 1957.80847D0  , 3417.84131D0  , 3844.55103D0  , 108.705818D0  ,
     4 1509.59424D0  , 13262.7119D0  , 0.000000000D+00,0.000000000D+0,
     5 13.0326872D0  , 752.893372D0  , 4052.26807D0  , 9269.20313D0  ,
     6 13526.1328D0  , 14527.7451D0  , 31.2971840D0  , 970.748169D0  ,
     7 22036.9688D0  , 0.000000000D+00,0.000000000D+00,2.77000737D0  ,
     8 449.687836D0  , 4501.18213D0  , 14910.6494D0  , 26207.9980D0  ,
     9 29811.4863D0  , 35.8704872D0  , 1378.49341D0  , 36935.5586D0  ,
     * 0.000000000D+00,0.000000000D+00,3.52496028D0  , 821.969116D0  ,
     1 9058.11621D0  , 31526.7383D0  , 57033.2656D0  , 67089.6094D0  ,
     2 22.6053371D0  , 318.704803D0  , 3224.01489D0  , 22194.4258D0  ,
     3 0.000000000D+00,124.233932D0  , 3824.28784D0  , 15422.8926D0  ,
     4 30159.1445D0  , 40230.4570D0  , 43631.0859D0  , 6.70396900D0  ,
     5 182.570953D0  , 3325.80371D0  , 31544.6270D0  , 0.000000000D+0,
     6 76.8523788D0  , 5260.08838D0  , 25697.5762D0  , 50940.0703D0  ,
     7 66192.6016D0  , 77765.4844D0  , 7.88950205D0  , 266.344055D0  ,
     8 5659.05615D0  , 63945.3555D0  , 0.000000000D+00,140.800232D0  ,
     9 11401.4141D0  , 60519.6875D0  , 128700.688D0  , 175722.438D0  ,
     * 205292.328D0  , 0.335776091D0  ,30.5740318D0  , 1868.08398D0  ,
     1 64148.1680D0  , 0.000000000D+00,34.2140961D0  , 11034.2930D0  ,
     2 117430.922D0  , 370179.000D0  , 640741.938D0  , 7457943.00D0  ,
     3 0.247009426D0  ,31.9362679D0  , 2374.01660D0  , 89178.0625D0  ,
     4 0.000000000D+00,40.2313499D0  , 16143.1318D0  , 178306.984D0  ,
     5 570633.938D0  , 998727.500D0  , 11790371.0D0  , 5.46481276D0  ,
     6 76.5115356D0  , 792.899414D0  , 6229.29053D0  , 36272.9961D0  ,
     7 0.742980003D0  ,1255.48206D0  , 19839.9688D0  , 64191.5430D0  ,
     8 93504.5156D0  , 0.0D0         , 1.54827595D0  , 40.7001610D0  ,
     9 720.488281D0  , 7362.80664D0  , 40852.5234D0  , 0.332672507D0 ,
     * 2226.52393D0  , 34164.9609D0  , 74950.7344D0  , 83071.2188D0  ,
     1 0.0D0         , 1.81181812D0  , 58.9971085D0  , 1211.78772D0  ,
     2 14245.8799D0  , 95347.7031D0  , 0.417872757D0  ,4602.69824D0  ,
     3 84913.4297D0  , 227768.609D0  , 286891.344D0  , 0.0D0         ,
     4 7.735446095D-02,6.59424448D0  , 357.122192D0  , 9967.38086D0  ,
     5 122043.969D0  , 0.202335522D0  ,14063.8340D0  , 268268.563D0  ,
     6 165319.609D0  , 712462.688D0  , 0.0D0         , 5.692562088D-02,
     7 6.86587000D0  , 452.948425D0  , 13862.2871D0  , 179168.156D0  ,
     8 0.160692036D0  ,19700.2520D0  , 405765.781D0  , 255306.219D0  ,
     9 1038431.19D0  , 0.0D0         , 1.382994815D-04,5.050205067D-02,
     * 10.4638147D0  , 1061.43884D0  , 56876.5391D0  , 267.740540D0  ,
     1 3218998.75D0  , 2688464.25D0  , 642599.563D0  , 712302.250D0  ,
     2 0.0D0         , 2.152928209D-05,7.652925793D-03,1.61883366D0  ,
     3 167.511948D0  , 9102.13379D0  , 59.6805649D0  , 582469.250D0  ,
     4 432664.156D0  , 113483.703D0  , 131450.891D0  , 0.0D0         ,
     5 0.981478751D0  ,13.3112621D0  , 136.460098D0  , 1096.66003D0  ,
     6 7067.83691D0  , 38.4084663D0  , 12845.1797D0  , 87106.9688D0  ,
     7 106088.938D0  , 71148.1016D0  , 0.0D0         , 0.233047232D0 ,
     8 5.84594774D0  , 100.983673D0  , 1045.93884D0  , 6441.26855D0  ,
     9 92.7021561D0  , 20351.8477D0  , 175719.719D0  , 2570084.75D0  ,
     * 10158516.0D0  , 0.0D0         , 0.263996065D0  ,8.17296124D0  ,
     1 163.252853D0  , 1930.42529D0  , 13845.0762D0  , 149.189301D0  ,
     2 51857.5273D0  , 306965.938D0  , 3910144.00D0  , 18497008.0D0  ,
     3 0.0D0         /
C * DATA FOR TB ELEMENT #65
      DATA ((XSC(65, I, J), J = 1, 11), I = 1, 19)/
     1 1205.34631D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.945949912D0  ,69.3186493D0  , 593.315186D0  ,
     3 1882.57104D0  , 3287.10913D0  , 3693.98096D0  , 114.814537D0  ,
     4 1573.87476D0  , 13375.7695D0  , 0.000000000D+00,0.000000000D+0,
     5 12.5001888D0  , 720.184631D0  , 3880.36597D0  , 8883.49219D0  ,
     6 12978.4980D0  , 13936.3750D0  , 34.3973389D0  , 1051.35217D0  ,
     7 23490.6621D0  , 0.000000000D+00,0.000000000D+00,2.69980812D0  ,
     8 432.708130D0  , 4317.91797D0  , 14290.9492D0  , 25129.9688D0  ,
     9 29369.0313D0  , 39.0477180D0  , 1484.50305D0  , 39273.8164D0  ,
     * 0.000000000D+00,0.000000000D+00,3.38509846D0  , 787.803040D0  ,
     1 8687.35645D0  , 30263.5215D0  , 54709.1133D0  , 64491.0703D0  ,
     2 23.9997387D0  , 334.799286D0  , 3353.47583D0  , 22755.9551D0  ,
     3 0.000000000D+00,117.800514D0  , 3644.35376D0  , 14739.7920D0  ,
     4 28850.6484D0  , 38510.1875D0  , 41981.3789D0  , 7.39434862D0  ,
     5 197.906570D0  , 3531.16821D0  , 32558.9160D0  , 0.000000000D+0,
     6 73.1972122D0  , 5008.93066D0  , 24554.0254D0  , 48755.4336D0  ,
     7 63337.9180D0  , 75171.7266D0  , 8.62680721D0  , 287.360413D0  ,
     8 6009.16260D0  , 66647.3047D0  , 0.000000000D+00,133.595505D0  ,
     9 10891.2568D0  , 58180.1133D0  , 124256.758D0  , 170151.328D0  ,
     * 197383.625D0  , 0.383780777D0  ,34.4529114D0  , 2070.81250D0  ,
     1 69956.3516D0  , 0.000000000D+00,32.1261711D0  , 10430.3506D0  ,
     2 111923.531D0  , 355110.250D0  , 624042.125D0  , 7105357.00D0  ,
     3 0.281034321D0  ,35.9007416D0  , 2629.06689D0  , 97290.8906D0  ,
     4 0.000000000D+00,37.2868767D0  , 15211.0215D0  , 169810.875D0  ,
     5 547588.938D0  , 974825.438D0  , 10944593.0D0  , 5.80675125D0  ,
     6 80.4825516D0  , 827.448120D0  , 6460.78662D0  , 36959.6289D0  ,
     7 0.686059952D0  ,1169.97119D0  , 18663.2559D0  , 60345.0586D0  ,
     8 87095.1875D0  , 0.0D0         , 1.70720196D0  , 44.1261940D0  ,
     9 766.399048D0  , 7688.83008D0  , 41268.0859D0  , 0.283821434D0 ,
     * 2007.77905D0  , 31646.2520D0  , 69303.9453D0  , 75000.9297D0  ,
     1 0.0D0         , 1.97987509D0  , 63.5598145D0  , 1285.20654D0  ,
     2 14906.1006D0  , 97783.3438D0  , 0.387636513D0  ,4321.58154D0  ,
     3 81055.0938D0  , 217233.656D0  , 268992.719D0  , 0.0D0         ,
     4 8.829211444D-02,7.40487146D0  , 392.962372D0  , 10726.9199D0  ,
     5 126635.656D0  , 0.185695708D0  ,13399.7881D0  , 256613.031D0  ,
     6 146052.031D0  , 902967.500D0  , 0.0D0         , 6.464228779D-02,
     7 7.68600273D0  , 497.457062D0  , 14905.9932D0  , 186049.250D0  ,
     8 0.144532889D0  ,18709.5840D0  , 388000.563D0  , 222527.609D0  ,
     9 1354789.88D0  , 0.0D0         , 1.721229200D-04,6.180451438D-02,
     * 12.5331964D0  , 1244.15955D0  , 64718.2148D0  , 299.456726D0  ,
     1 3195598.25D0  , 2391837.75D0  , 624617.500D0  , 773388.250D0  ,
     2 0.0D0         , 5.317702744D-05,1.868223213D-02,3.86977792D0  ,
     3 392.014709D0  , 20689.9512D0  , 135.322144D0  , 1153528.25D0  ,
     4 769299.875D0  , 221514.781D0  , 285723.438D0  , 0.0D0         ,
     5 1.03394198D0  , 13.9011078D0  , 141.431335D0  , 1129.07935D0  ,
     6 7199.43555D0  , 33.8753967D0  , 11612.2939D0  , 80027.2891D0  ,
     7 98025.5156D0  , 66108.4219D0  , 0.0D0         , 0.254085600D0 ,
     8 6.27169275D0  , 106.286377D0  , 1080.55054D0  , 6513.52344D0  ,
     9 56.7002983D0  , 16049.0508D0  , 111103.094D0  , 1789577.25D0  ,
     * 8258508.00D0  , 0.0D0         , 0.285247445D0  ,8.70330620D0  ,
     1 171.062729D0  , 1995.06030D0  , 14106.6416D0  , 88.2457733D0  ,
     2 39786.7695D0  , 217099.766D0  , 2625967.25D0  , 14889155.0D0  ,
     3 0.0D0         /
C * DATA FOR DY ELEMENT #66
      DATA ((XSC(66, I, J), J = 1, 11), I = 1, 19)/
     1 1269.03821D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.933116853D0  ,67.0328217D0  , 571.199646D0  ,
     3 1810.45398D0  , 3159.20166D0  , 3552.20166D0  , 121.073395D0  ,
     4 1638.18860D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     5 12.0055704D0  , 689.449402D0  , 3717.61670D0  , 8515.11621D0  ,
     6 12436.9521D0  , 13368.8477D0  , 37.7270584D0  , 1136.07471D0  ,
     7 24637.5625D0  , 0.000000000D+00,0.000000000D+00,2.63352537D0  ,
     8 416.574951D0  , 4142.22021D0  , 13691.4355D0  , 24044.9551D0  ,
     9 28127.0898D0  , 42.4298096D0  , 1595.15820D0  , 41594.8398D0  ,
     * 0.000000000D+00,0.000000000D+00,3.25432801D0  , 755.406189D0  ,
     1 8330.66699D0  , 29036.6445D0  , 52571.1172D0  , 61865.2969D0  ,
     2 25.4214058D0  , 350.885254D0  , 3476.92969D0  , 23219.5254D0  ,
     3 0.000000000D+00,112.960999D0  , 3499.95288D0  , 14161.7920D0  ,
     4 27715.0840D0  , 36980.9453D0  , 40356.6797D0  , 8.13099670D0  ,
     5 213.814957D0  , 3732.61304D0  , 33409.2852D0  , 0.000000000D+0,
     6 70.5572205D0  , 4805.42578D0  , 23562.7539D0  , 46824.7617D0  ,
     7 60916.7031D0  , 71674.3516D0  , 9.41305542D0  , 309.148773D0  ,
     8 6356.02832D0  , 69104.2813D0  , 0.000000000D+00,127.893814D0  ,
     9 10452.6660D0  , 56052.5430D0  , 120100.625D0  , 164736.438D0  ,
     * 191838.219D0  , 0.436785549D0  ,38.6510544D0  , 2282.50684D0  ,
     1 75612.8828D0  , 0.000000000D+00,30.3219795D0  , 9870.32422D0  ,
     2 106393.242D0  , 338903.469D0  , 594702.563D0  , 6478023.00D0  ,
     3 0.318683326D0  ,40.1826210D0  , 2893.49243D0  , 105063.195D0  ,
     4 0.000000000D+00,34.9681435D0  , 14408.7461D0  , 161738.984D0  ,
     5 523696.688D0  , 931776.188D0  , 10292234.0D0  , 6.16890669D0  ,
     6 84.6834488D0  , 863.450195D0  , 6687.70117D0  , 37538.8594D0  ,
     7 0.654098988D0  ,1115.98035D0  , 17845.0586D0  , 57640.7539D0  ,
     8 83085.8359D0  , 0.0D0         , 1.88586521D0  , 47.8831367D0  ,
     9 815.259094D0  , 8020.14600D0  , 41676.5938D0  , 0.256207049D0 ,
     * 1830.93079D0  , 29529.2188D0  , 65308.7188D0  , 70211.6172D0  ,
     1 0.0D0         , 2.16415858D0  , 68.5139236D0  , 1362.90686D0  ,
     2 15563.0889D0  , 100088.992D0  , 0.388950288D0  ,4276.51904D0  ,
     3 79927.7734D0  , 214024.359D0  , 265998.406D0  , 0.0D0         ,
     4 0.101031192D0  ,8.34041023D0  , 433.510498D0  , 11552.5342D0  ,
     5 131406.703D0  , 0.174231455D0  ,12695.7656D0  , 247717.438D0  ,
     6 144066.406D0  , 825162.250D0  , 0.0D0         , 7.362566143D-02,
     7 8.63463211D0  , 548.028015D0  , 16047.1104D0  , 193261.594D0  ,
     8 0.132819816D0  ,17672.1348D0  , 374285.719D0  , 220294.266D0  ,
     9 1239739.75D0  , 0.0D0         , 2.185936755D-04,7.233473659D-02,
     * 13.9175034D0  , 1352.66003D0  , 68482.1563D0  , 7500.48291D0  ,
     1 4132833.50D0  , 1385385.25D0  , 828736.375D0  , 883879.313D0  ,
     2 0.0D0         , 1.387346565D-04,4.390750453D-02,8.51859379D0  ,
     3 845.185059D0  , 43485.8750D0  , 4717.44727D0  , 2783733.00D0  ,
     4 1026051.56D0  , 612730.688D0  , 501245.656D0  , 0.0D0         ,
     5 1.05230796D0  , 13.9913273D0  , 141.300461D0  , 1124.23755D0  ,
     6 7125.84473D0  , 12.0562201D0  , 5477.91113D0  , 47303.6328D0  ,
     7 71032.5000D0  , 36958.8359D0  , 0.0D0         , 0.263115197D0 ,
     8 6.35300446D0  , 105.325546D0  , 1050.53577D0  , 6179.10303D0  ,
     9 51.8145599D0  , 14367.9707D0  , 105505.625D0  , 1987611.88D0  ,
     * 12897179.0D0  , 0.0D0         , 0.289452046D0  ,8.66673756D0  ,
     1 167.291809D0  , 1923.84509D0  , 13376.9600D0  , 79.1424026D0  ,
     2 35618.4531D0  , 194356.781D0  , 2880928.50D0  , 23535914.0D0  ,
     3 0.0D0         /
C * DATA FOR HO ELEMENT #67
      DATA ((XSC(67, I, J), J = 1, 11), I = 1, 19)/
     1 1334.60571D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.921624780D0  ,64.8667908D0  , 550.195801D0  ,
     3 1742.11914D0  , 3040.18921D0  , 3414.98804D0  , 127.540550D0  ,
     4 1703.47290D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     5 11.5333118D0  , 660.078430D0  , 3562.11353D0  , 8163.54395D0  ,
     6 11921.4180D0  , 12838.9736D0  , 41.3182983D0  , 1225.84668D0  ,
     7 0.000000000D+00,0.000000000D+00,0.000000000D+00,2.57155919D0  ,
     8 401.451569D0  , 3977.12207D0  , 13127.6240D0  , 23027.7676D0  ,
     9 27011.9238D0  , 46.0263824D0  , 1711.56433D0  , 44107.8242D0  ,
     * 0.000000000D+00,0.000000000D+00,3.13175416D0  , 725.036011D0  ,
     1 7996.13916D0  , 27882.2988D0  , 50455.6523D0  , 59582.1641D0  ,
     2 26.8941078D0  , 367.326843D0  , 3601.06226D0  , 23651.1621D0  ,
     3 0.000000000D+00,108.356148D0  , 3362.00195D0  , 13608.3203D0  ,
     4 26627.5039D0  , 35508.2500D0  , 38797.9258D0  , 8.92685795D0  ,
     5 230.693222D0  , 3941.90771D0  , 34243.8906D0  , 0.000000000D+0,
     6 67.2341232D0  , 4589.64648D0  , 22539.3301D0  , 44850.4766D0  ,
     7 58392.7813D0  , 69366.3203D0  , 10.2482252D0  , 331.990784D0  ,
     8 6713.10693D0  , 71558.0859D0  , 0.000000000D+00,122.531265D0  ,
     9 10040.0723D0  , 54037.5586D0  , 116145.539D0  , 159645.594D0  ,
     * 188161.109D0  , 0.495855212D0  ,43.2557602D0  , 2510.42969D0  ,
     1 81572.2656D0  , 0.000000000D+00,28.6561489D0  , 9351.12891D0  ,
     2 101240.547D0  , 323746.344D0  , 568443.188D0  , 6167648.50D0  ,
     3 0.360295892D0  ,44.8689651D0  , 3179.04492D0  , 113355.961D0  ,
     4 0.000000000D+00,32.6780357D0  , 13619.6924D0  , 153859.719D0  ,
     5 500477.813D0  , 889989.313D0  , 9361720.00D0  , 6.54965067D0  ,
     6 89.0065689D0  , 899.932190D0  , 6912.58545D0  , 38045.2539D0  ,
     7 0.623715460D0  ,1062.71436D0  , 17037.9434D0  , 54990.2344D0  ,
     8 79177.1328D0  , 0.0D0         , 2.07605410D0  , 51.7956772D0  ,
     9 864.182861D0  , 8324.95703D0  , 41912.6055D0  , 0.255674392D0 ,
     * 1787.67529D0  , 28664.5137D0  , 63006.1758D0  , 67616.2500D0  ,
     1 0.0D0         , 2.36101580D0  , 73.7348785D0  , 1444.09924D0  ,
     2 16252.5742D0  , 102489.891D0  , 0.350760937D0  ,4059.06152D0  ,
     3 76798.9766D0  , 207234.531D0  , 258288.594D0  , 0.0D0         ,
     4 0.115379266D0  ,9.36775875D0  , 476.764099D0  , 12403.8252D0  ,
     5 135893.094D0  , 0.166401088D0  ,12151.7646D0  , 239899.516D0  ,
     6 141879.063D0  , 761918.750D0  , 0.0D0         , 8.369409293D-02,
     7 9.67334175D0  , 601.871643D0  , 17223.3164D0  , 200078.641D0  ,
     8 0.124392033D0  ,16865.3789D0  , 362281.500D0  , 217464.953D0  ,
     9 1146450.50D0  , 0.0D0         , 2.674403368D-04,8.751519024D-02,
     * 16.5284290D0  , 1573.17749D0  , 77197.3984D0  , 13586.1748D0  ,
     1 3802449.25D0  , 1208605.63D0  , 892395.938D0  , 1131814.25D0  ,
     2 0.0D0         , 2.103789157D-04,6.618701667D-02,12.6178923D0  ,
     3 1226.53137D0  , 61204.2852D0  , 10686.0869D0  , 3228999.00D0  ,
     4 1132930.50D0  , 786884.563D0  , 737857.188D0  , 0.0D0         ,
     5 1.10694396D0  , 14.5887871D0  , 146.121933D0  , 1151.68323D0  ,
     6 7187.39893D0  , 19.6703682D0  , 7636.67969D0  , 57470.4766D0  ,
     7 72151.2578D0  , 45606.9375D0  , 0.0D0         , 0.286340177D0 ,
     8 6.80150270D0  , 110.562202D0  , 1080.74817D0  , 6214.21094D0  ,
     9 101.692322D0  , 18338.1328D0  , 212050.547D0  , 3549127.75D0  ,
     * 20366612.0D0  , 0.0D0         , 0.311033279D0  ,9.19705486D0  ,
     1 174.798630D0  , 1979.67224D0  , 13542.6328D0  , 159.988159D0  ,
     2 48520.7188D0  , 316384.688D0  , 5354897.50D0  , 37786016.0D0  ,
     3 0.0D0         /
C * DATA FOR ER ELEMENT #68
      DATA ((XSC(68, I, J), J = 1, 11), I = 1, 19)/
     1 1402.23413D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     2 0.000000000D+00,0.910493791D0  ,62.8085632D0  , 530.175903D0  ,
     3 1676.71313D0  , 2924.07813D0  , 3286.56689D0  , 134.224869D0  ,
     4 1769.51392D0  , 0.000000000D+00,0.000000000D+00,0.000000000D+0,
     5 11.0918627D0  , 632.328796D0  , 3414.57690D0  , 7830.02783D0  ,
     6 11448.7598D0  , 12303.9238D0  , 45.1934395D0  , 1320.92285D0  ,
     7 0.000000000D+00,0.000000000D+00,0.000000000D+00,2.51335192D0  ,
     8 387.175659D0  , 3820.93506D0  , 12594.4482D0  , 22104.3848D0  ,
     9 25883.5938D0  , 49.8604622D0  , 1834.03943D0  , 46768.0977D0  ,
     * 0.000000000D+00,0.000000000D+00,3.01659632D0  , 696.403503D0  ,
     1 7680.22266D0  , 26794.0332D0  , 48556.0273D0  , 57260.2188D0  ,
     2 28.4245224D0  , 384.056274D0  , 3723.58569D0  , 24031.4414D0  ,
     3 0.000000000D+00,104.604179D0  , 3244.11865D0  , 13121.5859D0  ,
     4 25649.2266D0  , 34204.8359D0  , 37387.1719D0  , 9.78788471D0  ,
     5 248.512024D0  , 4155.96094D0  , 35022.5781D0  , 0.000000000D+0,
     6 64.4948883D0  , 4388.03076D0  , 21574.4277D0  , 42972.6523D0  ,
     7 55936.0938D0  , 66895.3828D0  , 11.1441288D0  , 356.091522D0  ,
     8 7084.56201D0  , 74073.6016D0  , 0.000000000D+00,116.850319D0  ,
     9 9610.54688D0  , 51969.5469D0  , 112100.977D0  , 154343.984D0  ,
     * 183117.734D0  , 0.561815262D0  ,48.3105659D0  , 2756.40894D0  ,
     1 87908.3125D0  , 0.000000000D+00,27.0312080D0  , 8847.34668D0  ,
     2 96264.0625D0  , 309125.344D0  , 542704.563D0  , 5805503.00D0  ,
     3 0.406345814D0  ,49.9846649D0  , 3485.59351D0  , 122086.500D0  ,
     4 0.000000000D+00,30.5725346D0  , 12886.4717D0  , 146502.688D0  ,
     5 478717.344D0  , 852600.375D0  , 8976748.00D0  , 6.93704367D0  ,
     6 93.3750305D0  , 936.191528D0  , 7123.01416D0  , 38406.8633D0  ,
     7 0.617027283D0  ,1041.06995D0  , 16609.8438D0  , 53253.5117D0  ,
     8 76497.2344D0  , 0.0D0         , 2.28188133D0  , 55.9661674D0  ,
     9 915.904053D0  , 8649.78418D0  , 42045.2266D0  , 0.232938945D0 ,
     * 1638.24182D0  , 26802.6348D0  , 59393.1172D0  , 63320.1914D0  ,
     1 0.0D0         , 2.57315612D0  , 79.2279968D0  , 1527.52917D0  ,
     2 16944.2441D0  , 104755.180D0  , 0.332286477D0  ,3873.14941D0  ,
     3 74026.1875D0  , 201022.984D0  , 251265.359D0  , 0.0D0         ,
     4 0.131258249D0  ,10.4975939D0  , 524.155212D0  , 13348.2412D0  ,
     5 140832.594D0  , 0.129286721D0  ,10204.1797D0  , 221111.578D0  ,
     6 141987.141D0  , 671699.750D0  , 0.0D0         , 9.472762048D-02,
     7 10.8004751D0  , 659.165894D0  , 18436.4121D0  , 206537.156D0  ,
     8 0.117730275D0  ,16194.6572D0  , 351368.469D0  , 214190.594D0  ,
     9 1068542.88D0  , 0.0D0         , 3.274603223D-04,0.105456732D0 ,
     * 19.5129871D0  , 1820.59167D0  , 86677.6875D0  , 9084.09766D0  ,
     1 3613573.25D0  , 1161608.38D0  , 818143.250D0  , 1083411.63D0  ,
     2 0.0D0         , 3.070689563D-04,9.543409199D-02,17.8338051D0  ,
     3 1700.11145D0  , 82362.3672D0  , 8540.36621D0  , 3669606.00D0  ,
     4 1304625.50D0  , 859613.500D0  , 804831.188D0  , 0.0D0         ,
     5 1.16627645D0  , 15.2216101D0  , 151.309143D0  , 1184.74243D0  ,
     6 7322.17041D0  , 14.6506004D0  , 6117.94434D0  , 48891.0039D0  ,
     7 66023.3203D0  , 41461.5586D0  , 0.0D0         , 0.312212288D0 ,
     8 7.28530025D0  , 116.161530D0  , 1114.94849D0  , 6270.96338D0  ,
     9 43.9072113D0  , 12625.0703D0  , 90044.5938D0  , 1784281.63D0  ,
     * 12572056.0D0  , 0.0D0         , 0.334918499D0  ,9.76585865D0  ,
     1 182.850647D0  , 2044.66467D0  , 13802.0625D0  , 65.2826080D0  ,
     2 31433.3828D0  , 168209.703D0  , 2505131.25D0  , 22829432.0D0  ,
     3 0.0D0         /
C * DATA FOR TM ELEMENT #69
      DATA ((XSC(69, I, J), J = 1, 11), I = 1, 19)/
     1 1471.39294D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.900793612D0,  60.8579330D0,   511.148865D0,
     3 1614.70337D0,   2815.89136D0,   3162.20386D0,   141.087921D0,
     4 1836.06555D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 10.6769648D0,   606.147705D0,   3275.28369D0,   7513.65723D0,
     6 10981.3125D0,   11814.0508D0,   49.3521461D0,   1421.06287D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.46011782D0,
     8 373.952698D0,   3675.54248D0,   12095.3730D0,   21194.6816D0,
     9 24834.6289D0,   53.9229431D0,   1962.25940D0,   48693.1875D0,
     * 0.000000000D0,  0.000000000D0,  2.91011405D0,   669.807983D0,
     1 7385.81055D0,   25773.7207D0,   46685.1289D0,   55121.9570D0,
     2 30.0097198D0,   401.448883D0,   3854.00562D0,   24460.3086D0,
     3 0.000000000D0,  98.9670410D0,   3083.91357D0,   12506.6670D0,
     4 24474.5977D0,   32640.4004D0,   35710.4648D0,   10.7098856D0,
     5 267.221588D0,   4373.77295D0,   35729.5391D0,   0.000000000D0,
     6 62.0311852D0,   4203.39844D0,   20678.1426D0,   41215.5820D0,
     7 53704.4063D0,   63454.3359D0,   12.0933790D0,   381.320831D0,
     8 7467.22461D0,   76588.0703D0,   0.000000000D0,  110.840065D0,
     9 9201.04980D0,   49991.0078D0,   108227.203D0,   149431.625D0,
     * 174449.719D0,   0.634685993D0,  53.8141022D0,   3018.67407D0,
     1 94442.3594D0,   0.000000000D0,  25.6605186D0,   8411.94238D0,
     2 91863.3594D0,   295954.406D0,   518979.188D0,   5293580.00D0,
     3 0.457368761D0,  55.5603256D0,   3813.18188D0,   131185.469D0,
     4 0.000000000D0,  28.7137737D0,   12225.6748D0,   139787.984D0,
     5 458623.906D0,   816952.000D0,   8491173.00D0,   7.33887577D0,
     6 97.8807297D0,   973.763184D0,   7345.04736D0,   38792.1875D0,
     7 0.582199454D0,  982.922791D0,   15753.3369D0,   50548.5898D0,
     8 72527.1875D0,   0.0D0,          2.50546837D0,   60.3660126D0,
     9 968.579041D0,   8961.88574D0,   42031.0703D0,   0.220133245D0,
     * 1537.44055D0,   25404.2891D0,   56425.6523D0,   59866.5938D0,
     1 0.0D0,          2.79648042D0,   84.9697342D0,   1614.07434D0,
     2 17656.3770D0,   106991.719D0,   0.306047380D0,  3628.43652D0,
     3 70536.3750D0,   193484.969D0,   242422.828D0,   0.0D0,
     4 0.148810402D0,  11.7134838D0,   572.790588D0,   14228.7041D0,
     5 144489.688D0,   0.137195289D0,  10440.6719D0,   219468.938D0,
     6 138375.516D0,   642768.188D0,   0.0D0,          0.106935367D0,
     7 12.0330038D0,   721.105347D0,   19745.8281D0,   213306.766D0,
     8 9.786464274D-02,14379.4043D0,   330647.188D0,   213969.000D0,
     9 969475.813D0,   0.0D0,          3.954572894D-04,0.125986248D0,
     * 22.9034939D0,   2096.21631D0,   96838.7969D0,   4822.57129D0,
     1 3442956.75D0,   1159065.38D0,   719061.125D0,   957708.813D0,
     2 0.0D0,          4.371200339D-04,0.133366182D0,  24.3661098D0,
     3 2279.20117D0,   107210.680D0,   5262.50977D0,   4053068.00D0,
     4 1512070.63D0,   890228.000D0,   796651.313D0,   0.0D0,
     5 1.22701144D0,   15.8550014D0,   156.277832D0,   1212.51257D0,
     6 7389.15381D0,   19.6424370D0,   7400.30957D0,   53884.4375D0,
     7 65175.7578D0,   49021.0898D0,   0.0D0,          0.338816017D0,
     8 7.78060484D0,   121.763123D0,   1146.57324D0,   6304.62207D0,
     9 36.6902924D0,   11354.2598D0,   76200.6406D0,   1554979.25D0,
     * 11641636.0D0,   0.0D0,          0.359959543D0,  10.3489361D0,
     1 190.831161D0,   2104.99976D0,   14006.3213D0,   53.4860840D0,
     2 28089.1348D0,   148433.328D0,   2130197.75D0,   21017072.0D0,
     3 0.0D0/
C * DATA FOR YB ELEMENT #70
      DATA ((XSC(70, I, J), J = 1, 11), I = 1, 19)/
     1 1541.71777D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.891275764D0,  59.0038948D0,   493.002045D0,
     3 1555.27869D0,   2710.34204D0,   3045.11670D0,   148.159210D0,
     4 1903.04565D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 10.2957468D0,   581.685791D0,   3144.11011D0,   7215.60938D0,
     6 10556.7441D0,   11334.2373D0,   53.8273430D0,   1526.73938D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.41081572D0,
     8 361.532532D0,   3538.25586D0,   11624.1348D0,   20375.9707D0,
     9 23828.7031D0,   58.2434082D0,   2096.82056D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.81023669D0,   644.727661D0,
     1 7107.52979D0,   24810.9688D0,   44999.6055D0,   53052.9805D0,
     2 31.6497993D0,   419.014099D0,   3980.23950D0,   24817.1445D0,
     3 0.000000000D0,  94.8272552D0,   2958.55615D0,   12004.4395D0,
     4 23485.4336D0,   31333.7148D0,   34275.3516D0,   11.6992607D0,
     5 286.825867D0,   4593.76123D0,   36350.0625D0,   0.000000000D0,
     6 59.9591522D0,   4040.46191D0,   19866.1914D0,   39596.6797D0,
     7 51595.8047D0,   61729.0781D0,   13.0980949D0,   407.446991D0,
     8 7849.08105D0,   78921.0469D0,   0.000000000D0,  107.206200D0,
     9 8900.72363D0,   48445.7031D0,   105081.813D0,   145282.313D0,
     * 172125.234D0,   0.715343714D0,  59.8061752D0,   3298.45850D0,
     1 101215.008D0,   0.000000000D0,  24.4502983D0,   8020.99121D0,
     2 87857.6094D0,   283850.594D0,   498111.625D0,   5105320.50D0,
     3 0.513391793D0,  61.6185150D0,   4163.95898D0,   140750.281D0,
     4 0.000000000D0,  26.9674721D0,   11601.7119D0,   133430.359D0,
     5 439541.156D0,   782701.625D0,   7711613.50D0,   7.75942469D0,
     6 102.477119D0,   1010.94470D0,   7549.69922D0,   39027.3984D0,
     7 0.573737562D0,  957.574097D0,   15289.0342D0,   48781.6914D0,
     8 69840.4219D0,   0.0D0,          2.74265718D0,   64.9363937D0,
     9 1021.21985D0,   9246.31445D0,   41915.9375D0,   0.224003002D0,
     * 1520.10571D0,   24818.6543D0,   54561.5313D0,   57819.7070D0,
     1 0.0D0,          3.03556943D0,   90.9325562D0,   1700.32141D0,
     2 18316.3105D0,   108793.031D0,   0.312239051D0,  3632.25000D0,
     3 70013.7891D0,   191272.922D0,   240422.688D0,   0.0D0,
     4 0.168596536D0,  13.0654650D0,   627.022766D0,   15258.4873D0,
     5 148995.359D0,   0.104630895D0,  8614.63477D0,   200358.922D0,
     6 139436.656D0,   566868.563D0,   0.0D0,          0.120508559D0,
     7 13.3664236D0,   785.539612D0,   21021.0391D0,   218893.000D0,
     8 9.704419225D-02,14176.2070D0,   323827.875D0,   209291.875D0,
     9 922033.500D0,   0.0D0,          4.783113254D-04,0.150039479D0,
     * 26.7413387D0,   2401.42017D0,   107613.094D0,   2872.09058D0,
     1 3231043.25D0,   1160468.25D0,   645744.625D0,   861925.125D0,
     2 0.0D0,          6.005421747D-04,0.180947632D0,  32.4296608D0,
     3 2977.81274D0,   135966.766D0,   3564.33423D0,   4325047.50D0,
     4 1725410.88D0,   922834.375D0,   786038.563D0,   0.0D0,
     5 1.28677082D0,   16.4926815D0,   161.412033D0,   1242.09070D0,
     6 7478.63379D0,   19.6980019D0,   7301.84863D0,   52230.3672D0,
     7 62098.7070D0,   51460.8164D0,   0.0D0,          0.368140638D0,
     8 8.30016899D0,   127.264908D0,   1173.84985D0,   6308.03711D0,
     9 84.3702698D0,   15436.2383D0,   179142.203D0,   3209781.50D0,
     * 20650992.0D0,   0.0D0,          0.384861618D0,  10.9296017D0,
     1 198.542496D0,   2156.73022D0,   14119.7676D0,   128.185013D0,
     2 41605.4023D0,   259133.484D0,   4670217.50D0,   38034944.0D0,
     3 0.0D0/
C * DATA FOR LU ELEMENT #71
      DATA ((XSC(71, I, J), J = 1, 11), I = 1, 19)/
     1 1613.48828D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.883233249D0,  57.2371292D0,   475.654175D0,
     3 1498.60583D0,   2611.30737D0,   2930.99756D0,   155.393066D0,
     4 1970.14307D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 9.92060280D0,   557.767273D0,   3016.21631D0,   6924.03613D0,
     6 10125.4639D0,   10887.1211D0,   58.6059151D0,   1637.07654D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.36310601D0,
     8 349.590149D0,   3405.74805D0,   11166.1563D0,   19539.6133D0,
     9 22904.3906D0,   62.7940331D0,   2236.17310D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.71535683D0,   620.746887D0,
     1 6838.91699D0,   23871.2461D0,   43283.5977D0,   51212.6484D0,
     2 33.3201714D0,   436.623932D0,   4102.14990D0,   25088.7871D0,
     3 0.000000000D0,  90.3469238D0,   2837.81519D0,   11514.1992D0,
     4 22520.4492D0,   30028.6621D0,   32739.8477D0,   12.7611723D0,
     5 307.310638D0,   4814.39746D0,   36885.3945D0,   0.000000000D0,
     6 57.6274033D0,   3863.48804D0,   19000.7676D0,   37902.2305D0,
     7 49390.6875D0,   59108.7813D0,   14.1667366D0,   434.669891D0,
     8 8237.31543D0,   81203.1641D0,   0.000000000D0,  102.608055D0,
     9 8537.13574D0,   46617.7578D0,   101414.391D0,   140450.109D0,
     * 166391.203D0,   0.804120004D0,  66.2429428D0,   3587.74219D0,
     1 107704.898D0,   0.000000000D0,  23.3029346D0,   7631.86670D0,
     2 83671.4688D0,   270691.625D0,   470973.875D0,   4747013.00D0,
     3 0.574538291D0,  68.0975571D0,   4525.43750D0,   149873.734D0,
     4 0.000000000D0,  25.3744278D0,   10999.2100D0,   126918.438D0,
     5 419047.344D0,   740054.438D0,   7348300.50D0,   8.19799042D0,
     6 107.265495D0,   1049.34241D0,   7751.48779D0,   39244.7852D0,
     7 0.527745187D0,  922.143555D0,   14694.8594D0,   46854.3125D0,
     8 67806.1094D0,   0.0D0,          3.00205064D0,   69.8310776D0,
     9 1076.05896D0,   9526.97656D0,   41866.3672D0,   0.224305376D0,
     * 1484.56787D0,   24069.7949D0,   53115.8008D0,   57030.2344D0,
     1 0.0D0,          3.29421878D0,   97.3660736D0,   1793.27148D0,
     2 19027.4980D0,   110932.484D0,   0.293062896D0,  3441.92285D0,
     3 67151.6953D0,   186272.109D0,   238990.172D0,   0.0D0,
     4 0.190909237D0,  14.5593395D0,   684.131104D0,   16224.4375D0,
     5 152658.563D0,   9.987676889D-02,8416.99707D0,   196324.063D0,
     6 150398.484D0,   419206.000D0,   0.0D0,          0.135900751D0,
     7 14.8690519D0,   857.071838D0,   22396.6934D0,   225081.625D0,
     8 8.654536307D-02,13099.7598D0,   310839.906D0,   230788.641D0,
     9 645989.625D0,   0.0D0,          5.493086064D-04,0.180792093D0,
     * 32.5430222D0,   2858.23975D0,   123095.383D0,   2413.55591D0,
     1 3257706.00D0,   1017187.19D0,   744482.438D0,   1443660.50D0,
     2 0.0D0,          6.554692518D-04,0.215257287D0,  39.6647453D0,
     3 3566.21997D0,   156586.266D0,   3008.99121D0,   4377753.00D0,
     4 1460495.00D0,   957145.563D0,   1859926.50D0,   0.0D0,
     5 1.39114165D0,   17.7119598D0,   172.230255D0,   1314.03467D0,
     6 7828.31934D0,   19.0485363D0,   7102.07129D0,   51647.7773D0,
     7 66721.8984D0,   55492.9336D0,   0.0D0,          0.419142008D0,
     8 9.31658077D0,   140.336517D0,   1269.64856D0,   6687.05322D0,
     9 60.9940910D0,   13675.2520D0,   119009.672D0,   2060831.88D0,
     * 9758692.00D0,   0.0D0,          0.437312812D0,  12.2985239D0,
     1 220.535339D0,   2363.42725D0,   15287.5957D0,   90.7493744D0,
     2 36299.0938D0,   200419.875D0,   2854342.50D0,   17617800.0D0,
     3 0.0D0/
C * DATA FOR HF ELEMENT #72
      DATA ((XSC(72, I, J), J = 1, 11), I = 1, 20)/
     1 1688.20093D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.874796391D0,  55.5281868D0,   458.902313D0,
     3 1443.75891D0,   2514.02637D0,   2823.03589D0,   162.862030D0,
     4 2038.14709D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 9.50245762D0,   534.485107D0,   2891.82593D0,   6642.30713D0,
     6 9725.18066D0,   10436.9785D0,   63.7537384D0,   1754.60303D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.31085491D0,
     8 337.440704D0,   3274.01147D0,   10717.6094D0,   18738.5156D0,
     9 21985.8203D0,   67.6438751D0,   2383.94409D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.61657453D0,   596.337463D0,
     1 6570.35596D0,   22947.1758D0,   41677.6367D0,   49231.2305D0,
     2 35.0507317D0,   454.802521D0,   4229.03564D0,   25362.2930D0,
     3 0.000000000D0,  85.5042877D0,   2697.13721D0,   10965.4121D0,
     4 21466.5176D0,   28631.2539D0,   31063.2051D0,   13.8976984D0,
     5 328.929138D0,   5043.80518D0,   37395.7422D0,   0.000000000D0,
     6 54.8440781D0,   3668.76709D0,   18083.6582D0,   36142.5859D0,
     7 47197.5508D0,   55615.4844D0,   15.2976475D0,   463.293823D0,
     8 8645.29688D0,   83623.2344D0,   0.000000000D0,  97.0691605D0,
     9 8123.25684D0,   44606.0742D0,   97459.6406D0,   135486.656D0,
     * 157065.313D0,   0.902078450D0,  73.3129120D0,   3907.98950D0,
     1 115234.406D0,   0.000000000D0,  21.6249485D0,   7123.05469D0,
     2 78621.7813D0,   255715.156D0,   441644.375D0,   4246291.50D0,
     3 0.642104566D0,  75.2015991D0,   4923.74219D0,   160371.875D0,
     4 0.000000000D0,  23.2587910D0,   10237.4199D0,   119206.297D0,
     5 395983.813D0,   693805.250D0,   6792580.00D0,   8.65830803D0,
     6 112.285439D0,   1090.12671D0,   7975.20752D0,   39552.8906D0,
     7 0.480294138D0,  849.728149D0,   13673.6367D0,   44007.0430D0,
     8 64164.0156D0,   0.0D0,          3.28429103D0,   75.0950470D0,
     9 1134.99402D0,   9836.72656D0,   41694.0547D0,   0.205113158D0,
     * 1359.13391D0,   22479.2051D0,   50541.5391D0,   54532.5078D0,
     1 0.0D0,          3.57295585D0,   104.230095D0,   1892.04309D0,
     2 19789.1621D0,   113293.516D0,   0.264104277D0,  3174.73242D0,
     3 63355.3164D0,   179580.281D0,   234113.688D0,   0.0D0,
     4 0.216101766D0,  16.2323036D0,   748.213989D0,   17346.4609D0,
     5 157133.984D0,   7.853221148D-02,7099.69336D0,   181097.531D0,
     6 164954.906D0,   298310.938D0,   0.0D0,          0.153188035D0,
     7 16.5431213D0,   936.576660D0,   23953.7383D0,   232304.688D0,
     8 6.261973083D-02,10912.7920D0,   285928.219D0,   257060.188D0,
     9 446283.844D0,   0.0D0,          6.675710320D-04,0.220822141D0,
     * 39.3831596D0,   3398.25854D0,   141960.484D0,   71.2154617D0,
     1 1770791.25D0,   1856734.88D0,   476388.219D0,   709763.125D0,
     2 0.0D0,          7.900626515D-04,0.262668312D0,  48.0901070D0,
     3 4250.57373D0,   181161.719D0,   87.1911545D0,   2318386.00D0,
     4 2598049.25D0,   641885.063D0,   975640.875D0,   0.0D0,
     5 1.51112092D0,   19.0874825D0,   184.359863D0,   1395.62964D0,
     6 8246.86230D0,   15.4164753D0,   6106.85547D0,   47049.9883D0,
     7 67087.8125D0,   55035.6289D0,   0.0D0,          0.477280259D0,
     8 10.4594488D0,   154.855560D0,   1375.17896D0,   7105.65918D0,
     9 31.8034935D0,   10495.0957D0,   64203.2539D0,   1095132.38D0,
     * 5265648.50D0,   0.0D0,          0.495673567D0,  13.8010616D0,
     1 244.304199D0,   2582.97314D0,   16523.7656D0,   80.3886871D0,
     2 35074.4531D0,   189362.813D0,   2306188.00D0,   12463341.0D0,
     3 0.0D0,          5.636430345D-03,0.354511261D0,  14.7646332D0,
     4 333.031616D0,   3140.31787D0,   648.280334D0,   102469.688D0,
     5 7361422.00D0,   11662020.0D0,   12384611.0D0,   0.0D0/
C * DATA FOR TA ELEMENT #73
      DATA ((XSC(73, I, J), J = 1, 11), I = 1, 20)/
     1 1764.08289D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.868327558D0,  53.9224358D0,   443.057892D0,
     3 1391.93054D0,   2423.33130D0,   2718.72656D0,   170.510300D0,
     4 2106.43604D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 9.15231609D0,   511.630402D0,   2773.23804D0,   6372.74121D0,
     6 9331.01563D0,   10000.7559D0,   69.2644882D0,   1877.56543D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.26493645D0,
     8 326.306915D0,   3151.53320D0,   10298.1045D0,   18016.4746D0,
     9 20370.0176D0,   72.7586212D0,   2537.89771D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.52462101D0,   573.537903D0,
     1 6318.83740D0,   22075.7539D0,   40093.8438D0,   47404.6367D0,
     2 36.8399849D0,   473.191589D0,   4352.81982D0,   25634.0977D0,
     3 0.000000000D0,  81.4038849D0,   2574.11890D0,   10475.6426D0,
     4 20512.1055D0,   27388.6699D0,   29541.9727D0,   15.1124964D0,
     5 351.513580D0,   5274.74268D0,   37790.0078D0,   0.000000000D0,
     6 52.0738792D0,   3491.09937D0,   17234.5039D0,   34495.3164D0,
     7 45095.1875D0,   53710.6758D0,   16.5006599D0,   493.182770D0,
     8 9062.79297D0,   86018.9922D0,   0.000000000D0,  91.9110031D0,
     9 7732.41016D0,   42691.3672D0,   93661.6953D0,   130546.828D0,
     * 151169.859D0,   1.00968874D0,   80.9500122D0,   4246.04883D0,
     1 122891.891D0,   0.000000000D0,  20.2029152D0,   6680.40820D0,
     2 74131.8359D0,   242187.578D0,   416389.344D0,   3998763.75D0,
     3 0.715727150D0,  82.8500214D0,   5344.44971D0,   171114.109D0,
     4 0.000000000D0,  21.4328136D0,   9566.49414D0,   112277.258D0,
     5 374941.938D0,   652197.063D0,   6060169.00D0,   9.13684845D0,
     6 117.435211D0,   1131.14722D0,   8187.01270D0,   39774.8008D0,
     7 0.450498790D0,  800.082458D0,   12929.4141D0,   41821.4141D0,
     8 61330.8359D0,   0.0D0,          3.59210086D0,   80.6877594D0,
     9 1195.90381D0,   10142.7871D0,   41449.8906D0,   0.189176232D0,
     * 1248.69189D0,   21034.2090D0,   48140.8828D0,   52246.6875D0,
     1 0.0D0,          3.87172508D0,   111.500801D0,   1995.66016D0,
     2 20583.1133D0,   115724.797D0,   0.234615475D0,  2898.20264D0,
     3 59392.9688D0,   172377.781D0,   228286.563D0,   0.0D0,
     4 0.244223863D0,  18.0670052D0,   816.785461D0,   18500.4902D0,
     5 161459.875D0,   6.520989537D-02,6196.16357D0,   169041.797D0,
     6 178054.969D0,   224480.016D0,   0.0D0,          0.172409460D0,
     7 18.3736744D0,   1021.24396D0,   25537.3867D0,   239193.469D0,
     8 5.150463432D-02,9607.10059D0,   268493.250D0,   279922.344D0,
     9 331131.531D0,   0.0D0,          8.157273987D-04,0.268452168D0,
     * 47.1837082D0,   3992.97632D0,   161293.719D0,   15.8366928D0,
     1 1023417.75D0,   2180539.50D0,   449506.844D0,   567391.875D0,
     2 0.0D0,          9.591804119D-04,0.318981498D0,  57.6663742D0,
     3 5002.06787D0,   206289.688D0,   19.2783432D0,   1330570.88D0,
     4 3008531.25D0,   611872.125D0,   797208.625D0,   0.0D0,
     5 1.64040196D0,   20.5572128D0,   197.213211D0,   1480.75830D0,
     6 8680.72852D0,   13.6645327D0,   5590.10547D0,   44457.9922D0,
     7 67152.5859D0,   56622.4805D0,   0.0D0,          0.541975379D0,
     8 11.7062254D0,   170.306900D0,   1483.91870D0,   7528.13330D0,
     9 23.3908730D0,   9218.46289D0,   50637.6055D0,   783713.750D0,
     * 3727575.25D0,   0.0D0,          0.561229527D0,  15.4432154D0,
     1 269.733032D0,   2815.31812D0,   17838.4727D0,   56.7247391D0,
     2 30256.5352D0,   162221.516D0,   1595024.88D0,   8489136.00D0,
     3 0.0D0,          1.150703989D-02,0.728107095D0,  30.0322151D0,
     4 661.442322D0,   6055.97852D0,   944.121033D0,   119037.039D0,
     5 11622477.0D0,   14882909.0D0,   12524732.0D0,   0.0D0/
C * DATA FOR W  ELEMENT #74
      DATA ((XSC(74, I, J), J = 1, 11), I = 1, 20)/
     1 1839.59070D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.861603260D0,  52.3897018D0,   427.891815D0,
     3 1342.07275D0,   2334.80713D0,   2620.14185D0,   178.335876D0,
     4 2174.81152D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 8.82645988D0,   490.719055D0,   2661.26294D0,   6117.26758D0,
     6 8952.00098D0,   9617.07813D0,   75.1551666D0,   2006.74841D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.20830035D0,
     8 315.302155D0,   3034.92700D0,   9898.46484D0,   17287.3848D0,
     9 19598.9844D0,   78.1690216D0,   2698.55029D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.43909431D0,   552.122559D0,
     1 6081.44873D0,   21254.2305D0,   38657.4180D0,   45660.5977D0,
     2 38.6690903D0,   491.844788D0,   4476.14502D0,   25778.6523D0,
     3 0.000000000D0,  77.4271851D0,   2455.24756D0,   10003.2510D0,
     4 19595.5137D0,   26147.5293D0,   28204.7148D0,   16.4158726D0,
     5 375.142456D0,   5507.75635D0,   38107.6367D0,   0.000000000D0,
     6 49.7714119D0,   3324.67725D0,   16432.8613D0,   32928.4063D0,
     7 43064.8789D0,   51348.9023D0,   17.7657871D0,   524.185852D0,
     8 9487.11426D0,   88367.6172D0,   0.000000000D0,  87.2588196D0,
     9 7375.69922D0,   40920.1836D0,   90119.0391D0,   125967.289D0,
     * 147796.500D0,   1.12825680D0,   89.2119217D0,   4604.43408D0,
     1 130792.680D0,   0.000000000D0,  18.8366451D0,   6276.40381D0,
     2 69987.8516D0,   229586.891D0,   393425.563D0,   3693187.00D0,
     3 0.796105862D0,  91.0866699D0,   5788.82764D0,   182139.047D0,
     4 0.000000000D0,  19.8286781D0,   8965.34570D0,   105974.055D0,
     5 355593.156D0,   616299.875D0,   5715916.50D0,   9.64179802D0,
     6 122.772850D0,   1173.07715D0,   8399.04297D0,   39935.5742D0,
     7 0.421601743D0,  751.282166D0,   12201.3760D0,   39692.8438D0,
     8 58542.0313D0,   0.0D0,          3.92075706D0,   86.5611801D0,
     9 1258.35046D0,   10439.9082D0,   41147.5898D0,   0.177314118D0,
     * 1160.63550D0,   19814.1895D0,   46024.0625D0,   50295.0273D0,
     1 0.0D0,          4.19067049D0,   119.129013D0,   2102.08813D0,
     2 21368.9277D0,   118118.719D0,   0.216527209D0,  2712.24292D0,
     3 56548.5117D0,   167150.609D0,   224852.141D0,   0.0D0,
     4 0.275548726D0,  20.0754814D0,   890.190186D0,   19696.5840D0,
     5 165691.563D0,   5.526931211D-02,5477.47314D0,   158389.719D0,
     6 189602.141D0,   177491.109D0,   0.0D0,          0.193728566D0,
     7 20.3751984D0,   1111.99805D0,   27188.4883D0,   246114.906D0,
     8 4.290794209D-02,8504.03711D0,   252341.953D0,   300490.063D0,
     9 259114.969D0,   0.0D0,          9.907740168D-04,0.324058443D0,
     * 56.1426735D0,   4666.74756D0,   182839.422D0,   3.27545214D0,
     1 496492.813D0,   2512080.00D0,   442645.656D0,   433333.844D0,
     2 0.0D0,          1.164219226D-03,0.385088027D0,  68.5707245D0,
     3 5836.61279D0,   232993.234D0,   5.84086895D0,   776562.438D0,
     4 3326166.50D0,   600367.000D0,   668055.625D0,   0.0D0,
     5 1.77789497D0,   22.1060219D0,   210.645462D0,   1568.55933D0,
     6 9127.75977D0,   12.3787432D0,   5189.83691D0,   42301.6406D0,
     7 66690.7344D0,   58239.9375D0,   0.0D0,          0.614715755D0,
     8 13.0612030D0,   186.514069D0,   1593.65063D0,   7943.89209D0,
     9 23.3992462D0,   9255.58008D0,   50394.6445D0,   732290.313D0,
     * 3191617.00D0,   0.0D0,          0.630771518D0,  17.1803799D0,
     1 296.236694D0,   3050.06738D0,   19139.8848D0,   66.5594025D0,
     2 33376.7227D0,   178937.891D0,   1679722.50D0,   7773797.00D0,
     3 0.0D0,          1.981321163D-02,1.25190413D0,   50.9601440D0,
     4 1095.75830D0,   9751.22949D0,   1327.13818D0,   150278.109D0,
     5 16371733.0D0,   17352948.0D0,   12707123.0D0,   0.0D0/
C * DATA FOR RE ELEMENT #75
      DATA ((XSC(75, I, J), J = 1, 11), I = 1, 21)/
     1 1915.94141D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.856772244D0,  50.9274673D0,   413.388062D0,
     3 1294.55408D0,   2251.55054D0,   2524.54565D0,   186.362640D0,
     4 2243.05322D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 8.52171612D0,   470.999451D0,   2555.01782D0,   5874.97314D0,
     6 8606.56836D0,   9233.93164D0,   81.4502411D0,   2141.64185D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.16742635D0,
     8 305.453949D0,   2925.90161D0,   9523.15723D0,   16638.9668D0,
     9 18821.6328D0,   83.8583908D0,   2865.32886D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.35974240D0,   532.163940D0,
     1 5859.44531D0,   20479.0078D0,   37230.5430D0,   42373.4063D0,
     2 40.5475540D0,   510.697052D0,   4597.07520D0,   25755.3281D0,
     3 0.000000000D0,  73.8408203D0,   2346.29224D0,   9565.46484D0,
     4 18739.3359D0,   25000.2461D0,   26851.5547D0,   17.7996998D0,
     5 399.693878D0,   5740.29785D0,   38368.5313D0,   0.000000000D0,
     6 47.7427826D0,   3174.26465D0,   15695.8252D0,   31477.2227D0,
     7 41229.4531D0,   48126.5547D0,   19.0995522D0,   556.300598D0,
     8 9915.43457D0,   90657.8906D0,   0.000000000D0,  83.2025681D0,
     9 7056.90430D0,   39308.3945D0,   86865.1719D0,   121818.766D0,
     * 139126.891D0,   1.25757134D0,   98.0825653D0,   4979.79834D0,
     1 138712.344D0,   0.000000000D0,  17.7671642D0,   5929.13525D0,
     2 66329.9375D0,   218231.391D0,   373204.563D0,   3301167.25D0,
     3 0.884033144D0,  99.9366913D0,   6255.14063D0,   193281.297D0,
     4 0.000000000D0,  18.3719311D0,   8438.23535D0,   100324.594D0,
     5 337942.750D0,   584597.063D0,   5269126.00D0,   10.1583014D0,
     6 128.224472D0,   1215.58923D0,   8605.82031D0,   40085.8594D0,
     7 0.396186143D0,  707.321289D0,   11537.1494D0,   37729.2148D0,
     8 55959.2500D0,   0.0D0,          4.27405453D0,   92.7415237D0,
     9 1322.24011D0,   10726.3467D0,   40762.2188D0,   0.159107268D0,
     * 1087.44250D0,   18750.2637D0,   44108.4883D0,   48576.1055D0,
     1 0.0D0,          4.53424215D0,   127.161201D0,   2211.54761D0,
     2 22153.6484D0,   120493.781D0,   0.204284385D0,  2572.76563D0,
     3 54298.7188D0,   162975.359D0,   222607.797D0,   0.0D0,
     4 0.310283005D0,  22.2605629D0,   967.831177D0,   20901.0840D0,
     5 169629.563D0,   4.961069301D-02,5023.96338D0,   150751.188D0,
     6 199682.219D0,   149001.297D0,   0.0D0,          0.217295468D0,
     7 22.5520267D0,   1208.34241D0,   28870.9023D0,   252725.297D0,
     8 3.730181977D-02,7712.63477D0,   239449.125D0,   318651.625D0,
     9 215458.031D0,   0.0D0,          1.201500068D-03,0.388672352D0,
     * 66.1321869D0,   5375.47461D0,   202675.484D0,   2.35555959D0,
     1 417513.969D0,   2530010.25D0,   432043.594D0,   420179.375D0,
     2 0.0D0,          1.404164592D-03,0.461420894D0,  80.8667755D0,
     3 6745.74121D0,   260033.359D0,   2.82714105D0,   538840.125D0,
     4 3440587.50D0,   593333.813D0,   597202.438D0,   0.0D0,
     5 1.92073214D0,   23.7256927D0,   224.696335D0,   1659.15942D0,
     6 9583.94531D0,   11.4298239D0,   4883.94971D0,   40571.7852D0,
     7 66197.8438D0,   60112.1328D0,   0.0D0,          0.693705618D0,
     8 14.5190458D0,   203.630386D0,   1705.74011D0,   8358.34766D0,
     9 27.6798763D0,   10018.3906D0,   56245.9688D0,   783515.875D0,
     * 2965132.75D0,   0.0D0,          0.708791614D0,  19.0751152D0,
     1 324.471436D0,   3295.98877D0,   20495.2559D0,   79.1133957D0,
     2 37051.2227D0,   198682.766D0,   1777104.75D0,   7157214.00D0,
     3 0.0D0,          2.498664521D-02,1.57436454D0,   63.2084389D0,
     4 1326.85498D0,   11485.3457D0,   1627.00220D0,   192282.688D0,
     5 17979350.0D0,   15546440.0D0,   10769062.0D0,   0.0D0,
     6 2.776123583D-03,0.249567151D0,  12.2760305D0,   284.824127D0,
     7 2630.48193D0,   502.536102D0,   73569.9609D0,   4687253.50D0,
     8 4525270.00D0,   3534136.00D0,   0.0D0/
C * DATA FOR OS ELEMENT #76
      DATA ((XSC(76, I, J), J = 1, 11), I = 1, 21)/
     1 1998.90881D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.851439536D0,  49.5324211D0,   399.505341D0,
     3 1248.81079D0,   2170.23877D0,   2434.48438D0,   194.573410D0,
     4 2311.51489D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 8.22620964D0,   451.903687D0,   2452.52637D0,   5641.01025D0,
     6 8263.15332D0,   8874.19434D0,   88.1680374D0,   2283.05469D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.12791586D0,
     8 296.024048D0,   2821.88159D0,   9165.03418D0,   15993.6143D0,
     9 18093.2109D0,   89.8695908D0,   3039.38940D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.28465271D0,   513.147217D0,
     1 5647.55273D0,   19742.5625D0,   35937.0938D0,   40865.7891D0,
     2 42.4907570D0,   529.875488D0,   4717.12939D0,   0.000000000D0,
     3 0.000000000D0,  70.3948135D0,   2240.75293D0,   9141.83301D0,
     4 17910.0566D0,   23923.6348D0,   25565.9590D0,   19.2818851D0,
     5 425.341064D0,   5974.59668D0,   38379.8125D0,   0.000000000D0,
     6 45.8187141D0,   3030.62378D0,   14990.4873D0,   30079.4863D0,
     7 39400.7031D0,   45775.0156D0,   20.5141945D0,   589.783813D0,
     8 10354.5322D0,   92906.1797D0,   0.000000000D0,  78.8293304D0,
     9 6746.38770D0,   37738.2813D0,   83675.9063D0,   117593.523D0,
     * 133297.078D0,   1.39927042D0,   107.673134D0,   5380.69873D0,
     1 147113.125D0,   0.000000000D0,  16.6950417D0,   5585.86182D0,
     2 62750.9883D0,   207209.391D0,   354913.469D0,   3120916.50D0,
     3 0.979503036D0,  109.458542D0,   6751.12744D0,   205034.984D0,
     4 0.000000000D0,  17.0489063D0,   7928.55518D0,   94875.0156D0,
     5 320961.156D0,   555184.313D0,   4692289.50D0,   10.6938610D0,
     6 133.808701D0,   1258.50085D0,   8806.44629D0,   40180.1016D0,
     7 0.375633150D0,  669.973206D0,   10958.3008D0,   35978.0820D0,
     8 53634.3945D0,   0.0D0,          4.65388107D0,   99.2522964D0,
     9 1388.01270D0,   11008.4053D0,   40285.1289D0,   0.149091095D0,
     * 1014.79846D0,   17698.9414D0,   42182.9766D0,   46797.1055D0,
     1 0.0D0,          4.89679003D0,   135.598221D0,   2326.23145D0,
     2 22975.7363D0,   122932.898D0,   0.187397838D0,  2393.85498D0,
     3 51509.3242D0,   157549.375D0,   218334.688D0,   0.0D0,
     4 0.348783582D0,  24.6409035D0,   1050.63794D0,   22148.4180D0,
     5 173515.281D0,   4.452895001D-02,4606.27441D0,   143338.641D0,
     6 208318.391D0,   130930.875D0,   0.0D0,          0.243262097D0,
     7 24.9115200D0,   1310.11157D0,   30572.0625D0,   259095.313D0,
     8 3.403215483D-02,7209.48877D0,   230274.516D0,   334488.406D0,
     9 191418.828D0,   0.0D0,          1.447967952D-03,0.463260889D0,
     * 77.4304123D0,   6157.79639D0,   223774.094D0,   1.48723567D0,
     1 326497.031D0,   2556644.50D0,   422422.719D0,   388640.281D0,
     2 0.0D0,          1.687170239D-03,0.549519956D0,  94.6720352D0,
     3 7731.37061D0,   287446.625D0,   1.77697241D0,   420702.313D0,
     4 3466842.00D0,   580206.188D0,   554103.000D0,   0.0D0,
     5 2.07420516D0,   25.4199944D0,   239.049011D0,   1749.07959D0,
     6 10019.4287D0,   11.9897060D0,   5035.51123D0,   41312.3555D0,
     7 67346.7422D0,   65126.1133D0,   0.0D0,          0.781921804D0,
     8 16.1034527D0,   221.873444D0,   1824.38684D0,   8787.28320D0,
     9 16.6444149D0,   7928.81055D0,   40503.4844D0,   488539.688D0,
     * 2061220.63D0,   0.0D0,          0.793199241D0,  21.1034431D0,
     1 354.554565D0,   3559.82104D0,   21988.5039D0,   42.5161095D0,
     2 27586.7891D0,   154677.563D0,   1046575.56D0,   4693892.50D0,
     3 0.0D0,          3.070637211D-02,1.92730153D0,   76.2970963D0,
     4 1563.94263D0,   13180.4521D0,   1332.16736D0,   118385.555D0,
     5 17022298.0D0,   13249806.0D0,   8565134.00D0,   0.0D0,
     6 6.823690142D-03,0.613249362D0,  29.7935276D0,   675.614624D0,
     7 6084.06689D0,   842.825684D0,   94287.0703D0,   9001080.00D0,
     8 7622129.50D0,   5465839.50D0,   0.0D0/
C * DATA FOR IR ELEMENT #77
      DATA ((XSC(77, I, J), J = 1, 11), I = 1, 21)/
     1 2084.31763D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.848372638D0,  48.1983681D0,   386.203674D0,
     3 1205.15100D0,   2093.68530D0,   2346.68823D0,   202.978378D0,
     4 2379.82813D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 7.94961882D0,   433.875183D0,   2355.21118D0,   5418.98389D0,
     6 7944.38232D0,   8525.54395D0,   95.3508377D0,   2431.26270D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.08959174D0,
     8 286.991730D0,   2722.27539D0,   8823.24609D0,   15401.6016D0,
     9 17388.1426D0,   96.2003555D0,   3221.25073D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.21084285D0,   494.703766D0,
     1 5443.54102D0,   19033.6289D0,   34653.4336D0,   39425.0234D0,
     2 44.4766579D0,   549.367920D0,   4837.60547D0,   0.000000000D0,
     3 0.000000000D0,  66.8703003D0,   2134.53540D0,   8720.20117D0,
     4 17093.2480D0,   22808.8457D0,   24449.2773D0,   20.8563576D0,
     5 452.088379D0,   6211.59619D0,   38778.5977D0,   0.000000000D0,
     6 43.8913994D0,   2889.76660D0,   14303.1133D0,   28721.6406D0,
     7 37636.5820D0,   44253.2461D0,   21.9989281D0,   624.555847D0,
     8 10804.3447D0,   95120.3594D0,   0.000000000D0,  74.9710388D0,
     9 6445.19922D0,   36214.6797D0,   80581.5391D0,   113507.164D0,
     * 130227.563D0,   1.55473530D0,   118.027016D0,   5806.80859D0,
     1 155937.141D0,   0.000000000D0,  15.6755810D0,   5258.79541D0,
     2 59341.3984D0,   196701.406D0,   337881.219D0,   2871178.25D0,
     3 1.08376312D0,   119.709694D0,   7277.57080D0,   217373.359D0,
     4 0.000000000D0,  15.8038664D0,   7443.31494D0,   89683.9844D0,
     5 304795.938D0,   528760.125D0,   4303920.00D0,   11.2494116D0,
     6 139.565872D0,   1302.66797D0,   9012.43750D0,   40174.4141D0,
     7 0.349638999D0,  625.133118D0,   10294.0283D0,   34029.5703D0,
     8 51012.5156D0,   0.0D0,          5.06145191D0,   106.100014D0,
     9 1455.52429D0,   11283.7832D0,   39719.5938D0,   0.139374569D0,
     * 945.073547D0,   16682.4863D0,   40277.2813D0,   44989.4844D0,
     1 0.0D0,          5.28274965D0,   144.459274D0,   2445.39209D0,
     2 23822.7559D0,   125401.656D0,   0.170843989D0,  2215.44385D0,
     3 48694.0586D0,   151871.141D0,   213374.094D0,   0.0D0,
     4 0.391450971D0,  27.2448635D0,   1140.29614D0,   23494.5469D0,
     5 177507.766D0,   3.553931415D-02,4019.15039D0,   132922.703D0,
     6 214696.141D0,   117752.625D0,   0.0D0,          0.271958530D0,
     7 27.4967785D0,   1421.43127D0,   32464.7871D0,   266095.906D0,
     8 2.719595842D-02,6175.17725D0,   212257.125D0,   346230.438D0,
     9 172286.266D0,   0.0D0,          1.736157807D-03,0.549801707D0,
     * 90.5000610D0,   7081.02197D0,   250507.734D0,   0.377159357D0,
     1 152774.266D0,   2498325.50D0,   461861.563D0,   300963.813D0,
     2 0.0D0,          2.016902668D-03,0.651284337D0,  110.502411D0,
     3 8871.02246D0,   320563.281D0,   0.563207269D0,  223356.625D0,
     4 3402945.75D0,   615073.625D0,   444890.000D0,   0.0D0,
     5 2.23526239D0,   27.1868801D0,   254.041412D0,   1844.41895D0,
     6 10506.6924D0,   9.46362782D0,   4318.91797D0,   37110.8359D0,
     7 63932.7344D0,   62294.8242D0,   0.0D0,          0.877922356D0,
     8 17.7858124D0,   240.620728D0,   1940.79102D0,   9193.33105D0,
     9 14.8904295D0,   7501.68311D0,   37936.2227D0,   423219.875D0,
     * 1749258.50D0,   0.0D0,          0.883787930D0,  23.2416325D0,
     1 385.564301D0,   3824.12793D0,   23457.9824D0,   35.0851936D0,
     2 25319.3652D0,   146989.172D0,   863663.250D0,   3837076.75D0,
     3 0.0D0,          3.728385270D-02,2.32002163D0,   90.3582153D0,
     4 1808.81775D0,   14857.0703D0,   1107.31140D0,   77534.5313D0,
     5 15999634.0D0,   11557034.0D0,   7199740.50D0,   0.0D0,
     6 1.240959018D-02,1.10907686D0,   53.0882607D0,   1176.70337D0,
     7 10343.2783D0,   1072.80054D0,   94213.7109D0,   12927625.0D0,
     8 9863556.00D0,   6704388.00D0,   0.0D0/
C * DATA FOR PT ELEMENT #78
      DATA ((XSC(78, I, J), J = 1, 11), I = 1, 21)/
     1 2152.86523D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  0.846432447D0,  46.9265976D0,   373.479858D0,
     3 1163.34302D0,   2020.09045D0,   2262.84082D0,   211.555557D0,
     4 2448.26978D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 7.68703556D0,   416.657501D0,   2262.49536D0,   5206.62012D0,
     6 7630.89746D0,   8209.95313D0,   103.003242D0,   2586.15039D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.05388427D0,
     8 278.498779D0,   2628.65894D0,   8500.87891D0,   14814.5088D0,
     9 16786.3652D0,   102.874779D0,   3410.68140D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.13092494D0,   476.970398D0,
     1 5252.69678D0,   18371.7715D0,   33486.5664D0,   38127.0547D0,
     2 46.5231895D0,   569.037903D0,   4954.47266D0,   0.000000000D0,
     3 0.000000000D0,  63.4835701D0,   2041.33167D0,   8343.52637D0,
     4 16352.0498D0,   21835.4512D0,   23311.2852D0,   22.5318508D0,
     5 479.917175D0,   6448.80908D0,   0.000000000D0,  0.000000000D0,
     6 42.1726990D0,   2761.56201D0,   13670.0547D0,   27461.3164D0,
     7 36029.4453D0,   40899.0625D0,   23.5708256D0,   660.746826D0,
     8 11264.8525D0,   97432.0156D0,   0.000000000D0,  71.4618454D0,
     9 6167.74268D0,   34803.2539D0,   77696.2500D0,   109723.523D0,
     * 123099.289D0,   1.72388852D0,   129.156601D0,   6258.42529D0,
     1 165190.234D0,   0.000000000D0,  14.7782784D0,   4969.39600D0,
     2 56307.0273D0,   187319.625D0,   322146.500D0,   2506648.50D0,
     3 1.19665027D0,   130.708649D0,   7836.30566D0,   230389.578D0,
     4 0.000000000D0,  14.6959858D0,   7008.56201D0,   85020.4922D0,
     5 290270.938D0,   504087.000D0,   4003906.75D0,   11.8233175D0,
     6 145.439590D0,   1346.93054D0,   9208.60059D0,   40177.9961D0,
     7 0.332287967D0,  592.279236D0,   9783.34766D0,   32463.5078D0,
     8 48631.1563D0,   0.0D0,          5.50269032D0,   113.329018D0,
     9 1525.03955D0,   11554.3320D0,   38976.4805D0,   0.130480543D0,
     * 880.564514D0,   15729.3545D0,   38386.2813D0,   43067.9727D0,
     1 0.0D0,          5.69251537D0,   153.742264D0,   2568.58374D0,
     2 24683.3379D0,   127952.664D0,   0.149947762D0,  2075.37939D0,
     3 46410.0625D0,   147089.547D0,   209243.250D0,   0.0D0,
     4 0.438516498D0,  30.0672398D0,   1235.32422D0,   24872.5625D0,
     5 181224.297D0,   3.104903921D-02,3631.53516D0,   125298.000D0,
     6 218161.641D0,   112476.070D0,   0.0D0,          0.303463370D0,
     7 30.2908669D0,   1539.00562D0,   34389.4453D0,   272764.500D0,
     8 2.241119184D-02,5549.03320D0,   200042.172D0,   352990.563D0,
     9 165764.000D0,   0.0D0,          2.073757816D-03,0.648876309D0,
     * 105.026894D0,   8065.94189D0,   276766.594D0,   0.201935664D0,
     1 105967.828D0,   2356522.00D0,   450271.250D0,   288861.844D0,
     2 0.0D0,          2.402246930D-03,0.767768264D0,  128.175995D0,
     3 10105.0068D0,   354410.719D0,   0.297191739D0,  154104.531D0,
     4 3225300.75D0,   597038.500D0,   432386.906D0,   0.0D0,
     5 2.39787269D0,   28.9441452D0,   268.689026D0,   1934.86853D0,
     6 10956.9707D0,   8.76206303D0,   4065.82104D0,   35385.5000D0,
     7 60787.6797D0,   60415.5820D0,   0.0D0,          0.977953315D0,
     8 19.4883652D0,   258.886353D0,   2048.14990D0,   9545.51953D0,
     9 14.9105349D0,   7464.91455D0,   37688.8164D0,   426000.906D0,
     * 1793904.38D0,   0.0D0,          0.973817170D0,  25.3129902D0,
     1 414.666168D0,   4062.57349D0,   24760.0371D0,   35.8129692D0,
     2 25837.0449D0,   149480.656D0,   885650.375D0,   4116500.50D0,
     3 0.0D0,          4.277142882D-02,2.60824323D0,   99.3904114D0,
     4 1943.15613D0,   15571.6396D0,   1458.41064D0,   130757.008D0,
     5 15573292.0D0,   10632751.0D0,   7138561.00D0,   0.0D0,
     6 2.346534841D-02,2.04996371D0,   95.8907242D0,   2077.51929D0,
     7 17845.7520D0,   2485.02710D0,   306832.750D0,   19785610.0D0,
     8 15738859.0D0,   11531171.0D0,   0.0D0/
C * DATA FOR AU ELEMENT #79
      DATA ((XSC(79, I, J), J = 1, 11), I = 1, 21)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  38.6293297D0,   324.666565D0,   902.221741D0,
     3 1572.68774D0,   2059.21899D0,   0.0D0,          220.632462D0,
     4 2516.19824D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 7.43844557D0,   400.267578D0,   2173.69653D0,   5003.65381D0,
     6 7338.01123D0,   7891.47705D0,   111.160133D0,   2747.67578D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  2.01955223D0,
     8 270.382141D0,   2538.76636D0,   8191.92285D0,   14277.0967D0,
     9 16157.1680D0,   109.872185D0,   3607.06885D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.06537437D0,   460.459686D0,
     1 5069.52979D0,   17732.0488D0,   32306.1172D0,   36908.1055D0,
     2 48.6085091D0,   588.897339D0,   5069.56836D0,   0.000000000D0,
     3 0.000000000D0,  60.4823265D0,   1949.15015D0,   7972.59766D0,
     4 15626.1211D0,   20858.4121D0,   22135.5469D0,   24.3186417D0,
     5 508.801605D0,   6683.98535D0,   0.000000000D0,  0.000000000D0,
     6 40.5689774D0,   2639.74976D0,   13064.5391D0,   26246.9785D0,
     7 34417.5859D0,   38574.1055D0,   25.2148151D0,   698.127991D0,
     8 11731.1084D0,   99664.2188D0,   0.000000000D0,  68.0884933D0,
     9 5900.46240D0,   33435.5117D0,   74900.0781D0,   106048.859D0,
     * 113809.922D0,   1.90877450D0,   141.108276D0,   6733.83203D0,
     1 174732.000D0,   0.000000000D0,  13.9222813D0,   4690.47510D0,
     2 53360.8867D0,   178147.047D0,   308140.906D0,   2278065.75D0,
     3 1.31898510D0,   142.470169D0,   8423.35449D0,   243802.313D0,
     4 0.000000000D0,  13.6534481D0,   6592.48730D0,   80502.7813D0,
     5 276057.313D0,   481926.281D0,   3517298.75D0,   12.4245834D0,
     6 151.485703D0,   1391.80408D0,   9401.99512D0,   40092.7461D0,
     7 0.312762827D0,  555.852295D0,   9229.88086D0,   30793.0605D0,
     8 46336.4688D0,   0.0D0,          5.97069407D0,   120.866180D0,
     9 1595.74219D0,   11811.1670D0,   38153.6992D0,   0.121744417D0,
     * 818.142944D0,   14798.9648D0,   36558.0859D0,   41252.3125D0,
     1 0.0D0,          6.13133955D0,   163.471375D0,   2695.16089D0,
     2 25549.3164D0,   130381.320D0,   0.137875795D0,  1938.36426D0,
     3 44127.1914D0,   142208.250D0,   204849.344D0,   0.0D0,
     4 0.490304232D0,  33.1184692D0,   1335.73010D0,   26275.9258D0,
     5 184691.813D0,   2.689767443D-02,3259.02222D0,   117527.594D0,
     6 221379.563D0,   109208.750D0,   0.0D0,          0.337982684D0,
     7 33.3066254D0,   1663.35889D0,   36360.0391D0,   279083.813D0,
     8 1.893635280D-02,4930.04053D0,   187187.797D0,   359200.031D0,
     9 162359.984D0,   0.0D0,          2.464715159D-03,0.761895299D0,
     * 121.243187D0,   9130.99805D0,   303588.688D0,   0.108959161D0,
     1 73797.3906D0,   2183817.25D0,   473625.219D0,   254614.594D0,
     2 0.0D0,          2.847113181D-03,0.900383472D0,  147.877197D0,
     3 11437.7539D0,   388956.375D0,   0.162117675D0,  107021.711D0,
     4 3008845.50D0,   623508.438D0,   379320.500D0,   0.0D0,
     5 2.57219863D0,   30.8129902D0,   284.109406D0,   2028.68372D0,
     6 11406.4199D0,   8.25963116D0,   3872.29126D0,   34036.7461D0,
     7 59422.1289D0,   61084.4102D0,   0.0D0,          1.09061289D0,
     8 21.3785706D0,   278.904144D0,   2164.76709D0,   9921.41602D0,
     9 12.9298220D0,   6920.77734D0,   34738.8086D0,   363105.688D0,
     * 1527340.13D0,   0.0D0,          1.07683420D0,   27.6668377D0,
     1 447.594238D0,   4332.26416D0,   26230.8809D0,   35.2958069D0,
     2 25916.6660D0,   151241.641D0,   843603.000D0,   3729802.50D0,
     3 0.0D0,          5.085494742D-02,3.07416463D0,   115.277191D0,
     4 2201.76416D0,   17229.4004D0,   1262.50232D0,   93408.2422D0,
     5 14953335.0D0,   9368696.00D0,   6231522.00D0,   0.0D0,
     6 3.338646144D-02,2.90079951D0,   133.737671D0,   2833.18213D0,
     7 23805.2930D0,   2647.12280D0,   271471.438D0,   22768304.0D0,
     8 16474063.0D0,   11680687.0D0,   0.0D0/
C * DATA FOR HG ELEMENT #80
      DATA ((XSC(80, I, J), J = 1, 11), I = 1, 22)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  37.6708527D0,   314.210602D0,   871.379089D0,
     3 1518.18823D0,   1988.59009D0,   0.0D0,          229.523453D0,
     4 2583.53491D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 7.19898653D0,   384.036194D0,   2088.10229D0,   4807.28418D0,
     6 7049.54932D0,   7582.37207D0,   119.987572D0,   2916.03564D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.98558009D0,
     8 262.480316D0,   2451.86548D0,   7892.88232D0,   13737.6699D0,
     9 15523.6602D0,   117.239082D0,   3811.51001D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  2.00101280D0,   444.345276D0,
     1 4891.01221D0,   17112.7383D0,   31212.5625D0,   35622.8555D0,
     2 50.7448845D0,   608.994934D0,   5182.54980D0,   0.000000000D0,
     3 0.000000000D0,  57.4882240D0,   1857.45996D0,   7605.57227D0,
     4 14912.4912D0,   19887.8281D0,   21237.7188D0,   26.2121353D0,
     5 538.837524D0,   6920.41309D0,   0.000000000D0,  0.000000000D0,
     6 38.6270218D0,   2514.95776D0,   12453.9170D0,   25036.1055D0,
     7 32819.9180D0,   37971.5625D0,   26.9522266D0,   736.975159D0,
     8 12208.2490D0,   101485.320D0,   0.000000000D0,  64.6448517D0,
     9 5628.21045D0,   32045.2227D0,   72048.1563D0,   102182.398D0,
     * 110843.000D0,   2.10924292D0,   153.905960D0,   7234.72949D0,
     1 184603.578D0,   0.000000000D0,  13.0759830D0,   4416.37061D0,
     2 50452.8555D0,   169043.188D0,   294712.563D0,   2243732.75D0,
     3 1.45195472D0,   155.072311D0,   9043.05273D0,   257820.844D0,
     4 0.000000000D0,  12.6301603D0,   6177.84326D0,   75985.2266D0,
     5 261800.734D0,   461422.781D0,   3343575.00D0,   13.0368004D0,
     6 157.633972D0,   1437.08508D0,   9591.41797D0,   39842.2656D0,
     7 0.291843653D0,  517.652100D0,   8656.07617D0,   29067.1582D0,
     8 44198.2227D0,   0.0D0,          6.46967506D0,   128.708359D0,
     9 1666.59021D0,   12044.7090D0,   37353.2266D0,   0.115271300D0,
     * 767.519165D0,   13999.4492D0,   34956.6250D0,   39751.6523D0,
     1 0.0D0,          6.59015846D0,   173.532974D0,   2823.66895D0,
     2 26396.5586D0,   132724.922D0,   0.128319412D0,  1824.18433D0,
     3 42133.4844D0,   137869.641D0,   200981.234D0,   0.0D0,
     4 0.547235131D0,  36.4216881D0,   1442.55212D0,   27736.9629D0,
     5 187947.438D0,   2.231793851D-02,2837.85498D0,   108309.156D0,
     6 223219.719D0,   109609.313D0,   0.0D0,          0.375783116D0,
     7 36.5666656D0,   1795.79980D0,   38421.8203D0,   285280.281D0,
     8 1.529175881D-02,4230.52148D0,   171749.438D0,   362657.750D0,
     9 165932.516D0,   0.0D0,          2.916152822D-03,0.890594184D0,
     * 139.378189D0,   10294.0381D0,   331971.719D0,   5.432848632D-02,
     1 47886.6445D0,   1922911.63D0,   565484.563D0,   208792.016D0,
     2 0.0D0,          3.359529423D-03,1.05118167D0,   169.904404D0,
     3 12895.7520D0,   425758.281D0,   7.615496218D-02,68313.9297D0,
     4 2655413.00D0,   744125.375D0,   302197.031D0,   0.0D0,
     5 2.75942302D0,   32.8090019D0,   300.530212D0,   2128.75781D0,
     6 11891.0273D0,   6.72155762D0,   3397.78882D0,   30975.9766D0,
     7 57560.1719D0,   60507.2617D0,   0.0D0,          1.21736455D0,
     8 23.4722557D0,   300.726715D0,   2289.89429D0,   10319.0693D0,
     9 10.6393175D0,   6229.20117D0,   31394.5254D0,   282175.094D0,
     * 1138393.13D0,   0.0D0,          1.19494247D0,   30.3488846D0,
     1 484.944244D0,   4637.80176D0,   27901.2949D0,   32.0235100D0,
     2 24897.1250D0,   149795.922D0,   723183.500D0,   2809717.75D0,
     3 0.0D0,          6.201901287D-02,3.75049901D0,   138.964645D0,
     4 2591.22046D0,   19821.1680D0,   2782.53613D0,   354706.813D0,
     5 17363448.0D0,   9453465.00D0,   8431507.00D0,   0.0D0,
     6 4.085951298D-02,3.58066297D0,   163.793716D0,   3392.00171D0,
     7 27899.5762D0,   3650.28955D0,   417583.906D0,   25729812.0D0,
     8 15345441.0D0,   12314197.0D0,   0.0D0,          0.243561655D0,
     9 2.62276173D0,   22.9374752D0,   163.816376D0,   958.838562D0,
     * 125.570839D0,   11494.9297D0,   45395.9727D0,   1154198.00D0,
     1 5944232.50D0,   0.0D0/
C * DATA FOR TL ELEMENT #81
      DATA ((XSC(81, I, J), J = 1, 11), I = 1, 22)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  36.7505112D0,   304.159332D0,   841.720154D0,
     3 1465.02539D0,   1917.29431D0,   0.0D0,          238.655640D0,
     4 2650.93481D0,   0.000000000D0,  0.000000000D0,  0.000000D0,
     5 6.96272993D0,   368.510254D0,   2004.36279D0,   4616.48633D0,
     6 6773.05127D0,   7278.79541D0,   129.225540D0,   3091.14038D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.95263731D0,
     8 254.904739D0,   2368.22070D0,   7605.98242D0,   13237.0400D0,
     9 14920.7422D0,   124.958359D0,   4023.65405D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.93868458D0,   428.747192D0,
     1 4718.60156D0,   16512.6172D0,   30123.8984D0,   34298.8086D0,
     2 52.9444160D0,   629.299194D0,   5292.59961D0,   0.000000000D0,
     3 0.000000000D0,  54.6170578D0,   1768.81311D0,   7250.07129D0,
     4 14218.6465D0,   19002.5254D0,   20241.8477D0,   28.2292805D0,
     5 570.029846D0,   7155.31543D0,   0.000000000D0,  0.000000000D0,
     6 36.9420433D0,   2393.39551D0,   11859.7744D0,   23856.9121D0,
     7 31273.2285D0,   36988.2617D0,   28.7684555D0,   777.151306D0,
     8 12694.6758D0,   107799.883D0,   0.000000000D0,  61.2213783D0,
     9 5359.04590D0,   30669.0098D0,   69222.7969D0,   98373.4688D0,
     * 113081.570D0,   2.32726169D0,   167.645569D0,   7766.12061D0,
     1 195036.063D0,   0.000000000D0,  12.1542692D0,   4141.63770D0,
     2 47547.7813D0,   159969.766D0,   281337.531D0,   2133384.75D0,
     3 1.59528470D0,   168.536713D0,   9697.68848D0,   272517.844D0,
     4 0.000000000D0,  11.6307917D0,   5770.26563D0,   71525.0859D0,
     5 247680.750D0,   440288.219D0,   3370416.00D0,   13.6683912D0,
     6 163.903152D0,   1482.60254D0,   9774.77051D0,   39569.7383D0,
     7 0.271508664D0,  480.142029D0,   8090.28613D0,   27381.3770D0,
     8 41939.8477D0,   0.0D0,          7.00394964D0,   136.961182D0,
     9 1740.10291D0,   12279.1162D0,   36269.2188D0,   0.104858741D0,
     * 698.989746D0,   12999.3340D0,   33023.7305D0,   37786.5898D0,
     1 0.0D0,          7.07736444D0,   184.146790D0,   2959.82471D0,
     2 27318.2383D0,   135199.766D0,   0.112245992D0,  1642.63049D0,
     3 39087.8398D0,   131048.930D0,   192620.031D0,   0.0D0,
     4 0.609680235D0,  39.9801559D0,   1555.03601D0,   29221.6465D0,
     5 190981.688D0,   1.847876050D-02,2464.54248D0,   99482.8906D0,
     6 224271.359D0,   117338.148D0,   0.0D0,          0.417017430D0,
     7 40.0667915D0,   1934.58154D0,   40495.5039D0,   291232.219D0,
     8 1.258266717D-02,3661.52075D0,   157913.375D0,   365015.281D0,
     9 181976.344D0,   0.0D0,          3.436008003D-03,1.03688824D0,
     * 159.680298D0,   11575.1328D0,   362794.156D0,   2.389349788D-02,
     1 28986.3750D0,   1593842.88D0,   749133.063D0,   184318.234D0,
     2 0.0D0,          3.947643563D-03,1.22219718D0,   194.503113D0,
     3 14495.2129D0,   465411.188D0,   3.316638619D-02,41200.2734D0,
     4 2209708.25D0,   983727.500D0,   257940.484D0,   0.0D0,
     5 2.95544767D0,   34.8801651D0,   317.410248D0,   2230.55225D0,
     6 12376.1113D0,   5.45351887D0,   2901.15405D0,   27592.9336D0,
     7 54876.1563D0,   56690.0430D0,   0.0D0,          1.35342801D0,
     8 25.7043285D0,   323.764130D0,   2419.94360D0,   10712.0381D0,
     9 6.59764719D0,   4895.47607D0,   25824.5352D0,   174385.094D0,
     * 777126.375D0,   0.0D0,          1.32109165D0,   33.2294579D0,
     1 525.348633D0,   4973.02100D0,   29784.1953D0,   16.8682785D0,
     2 17707.2637D0,   122690.359D0,   433154.469D0,   1640877.13D0,
     3 0.0D0,          7.489055395D-02,4.53407192D0,   166.225403D0,
     4 3031.78906D0,   22667.2891D0,   343.807739D0,   39589.9375D0,
     5 6899228.00D0,   9519483.00D0,   4303452.00D0,   0.0D0,
     6 4.969504476D-02,4.37703419D0,   198.447693D0,   4021.89771D0,
     7 32400.9922D0,   667.043518D0,   60946.2852D0,   13976118.0D0,
     8 14531094.0D0,   7702536.50D0,   0.0D0,          0.322027743D0,
     9 3.49257398D0,   30.5639877D0,   216.844971D0,   1261.86975D0,
     * 112.208260D0,   11709.5225D0,   38995.6016D0,   972106.063D0,
     1 5652065.00D0,   0.0D0/
C * DATA FOR PB ELEMENT #82
      DATA ((XSC(82, I, J), J = 1, 11), I = 1, 23)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  35.8716545D0,   294.524200D0,   813.227112D0,
     3 1414.63635D0,   1851.95520D0,   0.0D0,          247.877075D0,
     4 2717.17554D0,   0.000000000D0,  0.000000000D0,  0.000000D0,
     5 6.74366903D0,   353.930481D0,   1925.35803D0,   4434.95605D0,
     6 6505.57031D0,   6997.19141D0,   139.015854D0,   3272.97607D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.92084634D0,
     8 247.397278D0,   2288.31763D0,   7330.95020D0,   12735.9219D0,
     9 14381.0098D0,   133.052155D0,   4242.77148D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.88079166D0,   414.137512D0,
     1 4556.13574D0,   15947.2148D0,   29116.4727D0,   33094.9180D0,
     2 55.1786766D0,   649.716736D0,   5399.47363D0,   0.000000000D0,
     3 0.000000000D0,  51.9043045D0,   1684.87061D0,   6912.60889D0,
     4 13559.9385D0,   18136.0488D0,   19197.5273D0,   30.3572769D0,
     5 602.176270D0,   7385.01611D0,   0.000000000D0,  0.000000000D0,
     6 35.4397774D0,   2282.71826D0,   11311.4248D0,   22763.2051D0,
     7 29838.4570D0,   35104.1133D0,   30.6800423D0,   818.620605D0,
     8 13184.6084D0,   0.000000000D0,  0.000000000D0,  58.1819344D0,
     9 5114.12451D0,   29399.6211D0,   66591.6953D0,   94860.8672D0,
     * 109804.336D0,   2.56441355D0,   182.313431D0,   8320.59863D0,
     1 205728.031D0,   0.000000000D0,  11.4095411D0,   3897.81689D0,
     2 44929.0664D0,   151687.359D0,   268430.313D0,   2024232.25D0,
     3 1.75049591D0,   182.878403D0,   10380.8555D0,   287412.031D0,
     4 0.000000000D0,  10.7044430D0,   5407.70557D0,   67492.0313D0,
     5 234746.563D0,   419983.875D0,   3163863.50D0,   14.3185396D0,
     6 170.298172D0,   1528.43176D0,   9952.65332D0,   39227.0586D0,
     7 0.252745450D0,  444.717194D0,   7553.37305D0,   25753.1699D0,
     8 39676.5117D0,   0.0D0,          7.57276058D0,   145.542236D0,
     9 1813.84351D0,   12491.1357D0,   35186.3164D0,   9.720915556D-02,
     * 644.845276D0,   12162.3096D0,   31334.0801D0,   36176.0547D0,
     1 0.0D0,          7.59156179D0,   195.160721D0,   3098.26685D0,
     2 28227.4707D0,   137553.000D0,   0.100781851D0,  1504.72974D0,
     3 36656.7031D0,   125312.609D0,   186195.719D0,   0.0D0,
     4 0.678053319D0,  43.8103218D0,   1673.45789D0,   30730.8574D0,
     5 193726.781D0,   1.556147821D-02,2162.63745D0,   91739.6797D0,
     6 223297.859D0,   131120.797D0,   0.0D0,          0.461993575D0,
     7 43.8263206D0,   2080.62988D0,   42607.7734D0,   296820.406D0,
     8 1.058416534D-02,3199.59058D0,   145721.188D0,   364428.625D0,
     9 208738.016D0,   0.0D0,          4.032428842D-03,1.20229006D0,
     * 182.168381D0,   12949.8740D0,   394023.594D0,   1.262279321D-02,
     1 19181.6973D0,   1324029.13D0,   962867.563D0,   169274.266D0,
     2 0.0D0,          4.620685242D-03,1.41520584D0,   221.727631D0,
     3 16211.8027D0,   505706.313D0,   1.737721264D-02,27119.9004D0,
     4 1836849.50D0,   1265559.00D0,   233725.141D0,   0.0D0,
     5 3.16178107D0,   37.0364761D0,   334.694977D0,   2332.00024D0,
     6 12834.0713D0,   4.73887587D0,   2667.75488D0,   25855.5645D0,
     7 53445.3672D0,   55956.0820D0,   0.0D0,          1.50196934D0,
     8 28.0811501D0,   347.392487D0,   2546.10205D0,   11081.9209D0,
     9 6.37304354D0,   4764.15967D0,   25354.5469D0,   153902.828D0,
     * 663843.500D0,   0.0D0,          1.45888615D0,   36.3288460D0,
     1 567.993652D0,   5318.38916D0,   31683.5840D0,   12.5284662D0,
     2 15330.2109D0,   114308.805D0,   348896.344D0,   1225272.00D0,
     3 0.0D0,          8.954252303D-02,5.39927149D0,   195.322311D0,
     4 3483.39063D0,   25483.1211D0,   141.210983D0,   48489.7266D0,
     5 2526930.00D0,   13926979.0D0,   3251424.25D0,   0.0D0,
     6 5.954287946D-02,5.24107456D0,   234.869537D0,   4658.67432D0,
     7 36794.3047D0,   249.896179D0,   77629.7344D0,   4999401.00D0,
     8 19581046.0D0,   5958861.00D0,   0.0D0,          0.393189073D0,
     9 4.27342463D0,   37.3253899D0,   262.932922D0,   1523.90234D0,
     * 97.1954880D0,   11322.2471D0,   38387.7773D0,   706199.000D0,
     1 4520768.00D0,   0.0D0,          9.778127819D-02,1.60369289D0,
     2 18.6227684D0,   137.449020D0,   629.868591D0,   216.538300D0,
     3 37120.3281D0,   2332257.00D0,   14477358.0D0,   33478308.0D0,
     4 0.0D0/
C * DATA FOR BI ELEMENT #83
      DATA ((XSC(83, I, J), J = 1, 11), I = 1, 23)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  35.0313034D0,   285.287354D0,   785.885315D0,
     3 1365.58289D0,   1786.26929D0,   0.0D0,          257.295105D0,
     4 2782.74634D0,   0.000000000D0,  0.000000000D0,  0.000000D0,
     5 6.53682518D0,   340.036987D0,   1849.79492D0,   4261.91357D0,
     6 6253.20752D0,   6720.55078D0,   149.416214D0,   3460.82422D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.89219773D0,
     8 240.637894D0,   2213.10327D0,   7071.67627D0,   12280.5059D0,
     9 13831.9316D0,   141.511261D0,   4469.10352D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.82588029D0,   400.200531D0,
     1 4401.35645D0,   15404.8818D0,   28119.4688D0,   32014.1934D0,
     2 57.4725113D0,   670.225647D0,   5501.37598D0,   0.000000000D0,
     3 0.000000000D0,  49.4341507D0,   1606.95117D0,   6596.78760D0,
     4 12940.4873D0,   17344.4629D0,   18283.0898D0,   32.6096420D0,
     5 635.363953D0,   7610.20703D0,   0.000000000D0,  0.000000000D0,
     6 34.0434570D0,   2178.88477D0,   10792.9971D0,   21720.8320D0,
     7 28461.8203D0,   34004.9414D0,   32.6707001D0,   861.232056D0,
     8 13676.7070D0,   0.000000000D0,  0.000000000D0,  55.4122543D0,
     9 4888.97021D0,   28219.4629D0,   64132.8477D0,   91479.2813D0,
     * 105628.164D0,   2.82040119D0,   197.929398D0,   8899.62695D0,
     1 216495.000D0,   0.000000000D0,  10.7359819D0,   3675.45996D0,
     2 42511.4453D0,   143958.656D0,   255534.563D0,   1912356.63D0,
     3 1.91708291D0,   198.100357D0,   11092.5488D0,   302747.500D0,
     4 0.000000000D0,  9.93102837D0,   5079.45801D0,   63789.8672D0,
     5 222771.313D0,   401488.000D0,   2956409.00D0,   14.9950428D0,
     6 176.798233D0,   1573.41577D0,   10112.4609D0,   38650.5938D0,
     7 0.239857987D0,  417.083588D0,   7116.51025D0,   24382.7129D0,
     8 37838.4063D0,   0.0D0,          8.18303871D0,   154.478928D0,
     9 1887.62610D0,   12679.8613D0,   34116.4102D0,   9.152862430D-02,
     * 600.691833D0,   11441.7998D0,   29811.3867D0,   34709.4336D0,
     1 0.0D0,          8.13323975D0,   206.586700D0,   3239.14526D0,
     2 29127.9980D0,   139812.109D0,   9.195916355D-02,1392.10449D0,
     3 34588.3672D0,   120337.891D0,   181400.359D0,   0.0D0,
     4 0.752776563D0,  47.9184341D0,   1797.39246D0,   32245.8066D0,
     5 196220.234D0,   1.335039455D-02,1920.67053D0,   85025.8672D0,
     6 221361.969D0,   148493.578D0,   0.0D0,          0.510924935D0,
     7 47.8553734D0,   2233.79736D0,   44745.0469D0,   302076.063D0,
     8 9.048909880D-03,2817.76147D0,   134831.344D0,   361423.063D0,
     9 242470.063D0,   0.0D0,          4.714301322D-03,1.38842094D0,
     * 206.898804D0,   14403.4854D0,   424836.250D0,   7.369683590D-03,
     1 13740.0723D0,   1117142.50D0,   1183275.63D0,   157517.953D0,
     2 0.0D0,          5.388054997D-03,1.63211393D0,   251.696182D0,
     3 18037.5547D0,   546186.188D0,   9.792809375D-03,19018.0117D0,
     4 1538130.63D0,   1575194.88D0,   216121.422D0,   0.0D0,
     5 3.37275028D0,   39.2505760D0,   352.373291D0,   2434.26758D0,
     6 13285.7627D0,   4.22969723D0,   2445.92578D0,   24154.9160D0,
     7 52025.4648D0,   55566.9219D0,   0.0D0,          1.66625845D0,
     8 30.6352291D0,   372.132080D0,   2675.41235D0,   11441.5107D0,
     9 5.13349295D0,   4271.24170D0,   23504.8164D0,   121862.406D0,
     * 547337.938D0,   0.0D0,          1.60768282D0,   39.6253166D0,
     1 612.516968D0,   5670.96289D0,   33584.3477D0,   11.0835199D0,
     2 14409.6475D0,   111979.516D0,   313722.000D0,   1009973.50D0,
     3 0.0D0,          0.106654033D0,  6.36825800D0,   226.640030D0,
     4 3950.73438D0,   28295.7363D0,   89.7414627D0,   51561.1094D0,
     5 1270817.88D0,   20336782.0D0,   2788147.75D0,   0.0D0,
     6 7.075495273D-02,6.19856358D0,   273.989136D0,   5317.54688D0,
     7 41195.0039D0,   136.017487D0,   83653.1406D0,   2191223.75D0,
     8 29711264.0D0,   5008162.50D0,   0.0D0,          0.468857676D0,
     9 5.10219765D0,   44.4555626D0,   311.038757D0,   1796.65747D0,
     * 80.6937408D0,   10730.5605D0,   40150.2227D0,   452448.813D0,
     1 3054768.25D0,   0.0D0,          0.144043684D0,  2.36591268D0,
     2 27.2262955D0,   197.456253D0,   895.054871D0,   219.574280D0,
     3 28690.0664D0,   2224832.25D0,   15599741.0D0,   32534522.0D0,
     4 0.0D0/
C * DATA FOR PO ELEMENT #84
      DATA ((XSC(84, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  34.2208443D0,   276.376190D0,   759.477966D0,
     3 1318.86035D0,   1725.66687D0,   0.0D0,          266.872803D0,
     4 2848.68750D0,   0.000000000D0,  0.000000000D0,  0.000000D0,
     5 6.32812405D0,   326.251343D0,   1775.42444D0,   4091.75171D0,
     6 6004.19678D0,   6452.10645D0,   160.466888D0,   3657.99561D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.86150336D0,
     8 233.861206D0,   2139.08374D0,   6817.99902D0,   11823.7256D0,
     9 13289.1875D0,   150.405594D0,   4705.51270D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.77159297D0,   386.573853D0,
     1 4250.64844D0,   14882.2520D0,   27186.2402D0,   30899.5527D0,
     2 59.7953682D0,   690.732544D0,   5598.08887D0,   0.000000000D0,
     3 0.000000000D0,  47.1483383D0,   1534.45020D0,   6301.30176D0,
     4 12359.1094D0,   16543.8066D0,   17596.0977D0,   35.0146523D0,
     5 670.142517D0,   7840.27539D0,   0.000000000D0,  0.000000000D0,
     6 32.4779968D0,   2068.58521D0,   10257.8301D0,   20659.0410D0,
     7 27085.3965D0,   32381.3809D0,   34.7690544D0,   905.965210D0,
     8 14199.0693D0,   0.000000000D0,  0.000000000D0,  51.9325256D0,
     9 4640.19531D0,   26946.0840D0,   61510.2773D0,   87957.9922D0,
     * 102043.648D0,   3.09930158D0,   214.751480D0,   9521.85254D0,
     1 227992.469D0,   0.000000000D0,  10.0361357D0,   3448.90625D0,
     2 40089.4727D0,   136316.672D0,   242563.859D0,   1774240.50D0,
     3 2.09772229D0,   214.449371D0,   11856.1709D0,   319487.094D0,
     4 0.000000000D0,  9.14648628D0,   4746.33545D0,   60081.2852D0,
     5 210904.781D0,   381529.750D0,   2765607.75D0,   15.6847782D0,
     6 183.452728D0,   1620.00366D0,   10283.4570D0,   40372.1289D0,
     7 0.207703725D0,  383.014008D0,   6601.27393D0,   22815.6367D0,
     8 35706.0430D0,   0.0D0,          8.82795811D0,   163.769943D0,
     9 1962.60010D0,   12855.3604D0,   32902.6055D0,   8.550313860D-02,
     * 556.334351D0,   10723.8887D0,   28273.1523D0,   33159.0313D0,
     1 0.0D0,          8.70744705D0,   218.372986D0,   3379.19727D0,
     2 29969.9551D0,   142041.094D0,   8.800361305D-02,1331.04065D0,
     3 33340.2109D0,   117201.172D0,   178629.156D0,   0.0D0,
     4 0.834614336D0,  52.3687592D0,   1930.88782D0,   33889.8672D0,
     5 198118.484D0,   1.086249482D-02,1641.40857D0,   77060.2422D0,
     6 216239.391D0,   163054.609D0,   0.0D0,          0.564270496D0,
     7 52.2017975D0,   2397.88818D0,   47040.0234D0,   306972.500D0,
     8 7.494420279D-03,2406.56445D0,   122601.320D0,   353810.344D0,
     9 272668.813D0,   0.0D0,          5.490167998D-03,1.59623230D0,
     * 233.664749D0,   15881.7715D0,   452387.063D0,   5.607036874D-03,
     1 11417.5176D0,   1004739.50D0,   1346146.38D0,   148290.984D0,
     2 0.0D0,          6.257853005D-03,1.87339306D0,   283.922241D0,
     3 19864.8320D0,   580929.250D0,   7.690316066D-03,16142.7695D0,
     4 1399407.63D0,   1789339.88D0,   204764.938D0,   0.0D0,
     5 3.59758449D0,   41.5541191D0,   370.383270D0,   2536.76440D0,
     6 13722.8467D0,   3.84612560D0,   2268.73438D0,   22722.3086D0,
     7 50754.1758D0,   55935.4102D0,   0.0D0,          1.84124422D0,
     8 33.3191872D0,   397.508850D0,   2802.79980D0,   11776.8926D0,
     9 4.65631342D0,   4009.55371D0,   22531.4258D0,   105178.719D0,
     * 468122.031D0,   0.0D0,          1.77056026D0,   43.1420021D0,
     1 658.957031D0,   6033.04395D0,   35510.2031D0,   10.3189754D0,
     2 13909.4502D0,   111363.953D0,   296456.781D0,   870142.250D0,
     3 0.0D0,          0.125401482D0,  7.42411327D0,   260.130432D0,
     4 4433.51367D0,   31102.9941D0,   60.4447212D0,   51791.1797D0,
     5 671768.875D0,   21656248.0D0,   2575326.00D0,   0.0D0,
     6 8.318448067D-02,7.24629307D0,   315.867188D0,   6001.97363D0,
     7 45624.3789D0,   68.0741501D0,   80080.9219D0,   830642.250D0,
     8 31194066.0D0,   4331104.50D0,   0.0D0,          0.542585373D0,
     9 5.90712309D0,   51.3193245D0,   356.646271D0,   2053.41846D0,
     * 68.6135941D0,   10094.2344D0,   41401.5625D0,   322850.406D0,
     1 2148358.25D0,   0.0D0,          0.191404030D0,  3.12850118D0,
     2 35.5647087D0,   253.442856D0,   1136.24341D0,   204.103409D0,
     3 22289.6895D0,   1829071.25D0,   15444491.0D0,   30499764.0D0,
     4 0.0D0,          7.235468179D-02,1.55668128D0,   22.3732834D0,
     5 205.542908D0,   1246.63428D0,   294.814789D0,   26750.7090D0,
     6 1685096.00D0,   14813727.0D0,   35154412.0D0,   0.0D0/
C * DATA FOR AT ELEMENT #85
      DATA ((XSC(85, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  33.4477615D0,   267.846222D0,   734.165283D0,
     3 1273.40491D0,   1664.62390D0,   0.0D0,          276.584686D0,
     4 2912.15015D0,   0.000000000D0,  0.000000000D0,  0.000000D0,
     5 6.14143181D0,   313.561523D0,   1706.15686D0,   3932.88013D0,
     6 5771.06641D0,   6200.07471D0,   172.179092D0,   3860.64307D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.83471894D0,
     8 227.642502D0,   2070.02710D0,   6580.41406D0,   11404.3096D0,
     9 12789.5000D0,   159.925751D0,   4949.45166D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.72084296D0,   373.738007D0,
     1 4108.19775D0,   14386.8389D0,   26292.6484D0,   29845.1484D0,
     2 62.1954842D0,   711.726196D0,   5696.37939D0,   0.000000000D0,
     3 0.000000000D0,  44.6913452D0,   1457.77856D0,   5995.04395D0,
     4 11764.0693D0,   15779.8418D0,   16738.8672D0,   37.5388908D0,
     5 705.635925D0,   8058.35693D0,   0.000000000D0,  0.000000000D0,
     6 31.1980515D0,   1973.77893D0,   9784.15430D0,   19706.2461D0,
     7 25816.8613D0,   30766.2188D0,   36.9701653D0,   951.975098D0,
     8 14722.2813D0,   0.000000000D0,  0.000000000D0,  49.1683540D0,
     9 4418.11230D0,   25790.3516D0,   59101.8438D0,   84776.0000D0,
     * 97927.7500D0,   3.39954376D0,   232.614685D0,   10169.7500D0,
     1 245534.641D0,   0.000000000D0,  9.42238808D0,   3247.65674D0,
     2 37907.1563D0,   129371.938D0,   231361.875D0,   1661647.88D0,
     3 2.29122949D0,   231.771805D0,   12651.3115D0,   335991.906D0,
     4 0.000000000D0,  8.46072960D0,   4449.70996D0,   56726.8945D0,
     5 200025.984D0,   362108.594D0,   2547308.75D0,   16.3888626D0,
     6 190.113007D0,   1664.51538D0,   10423.3281D0,   0.000000000D0,
     7 278.480927D0,   5473.95068D0,   17455.6113D0,   29099.9414D0,
     8 35251.8594D0,   36664.1602D0,   9.50923252D0,   173.291367D0,
     9 2035.13770D0,   12990.9355D0,   31972.6758D0,   8.351007849D-02,
     * 532.281250D0,   10250.1025D0,   27125.6035D0,   32082.8555D0,
     1 0.0D0,          9.30827808D0,   230.684082D0,   3526.37354D0,
     2 30878.0488D0,   144276.859D0,   8.129967004D-02,1240.09729D0,
     3 31601.5723D0,   112773.047D0,   173837.141D0,   0.0D0,
     4 0.923649311D0,  57.1134109D0,   2069.04883D0,   35504.5117D0,
     5 199755.578D0,   8.756686933D-03,1450.80774D0,   71079.7188D0,
     6 211478.125D0,   175526.531D0,   0.0D0,          0.621270359D0,
     7 56.6601410D0,   2550.72974D0,   48721.6914D0,   312525.250D0,
     8 8.164047264D-03,2526.78271D0,   124631.594D0,   362389.063D0,
     9 312908.813D0,   0.0D0,          6.374954246D-03,1.83107507D0,
     * 263.773804D0,   17566.8594D0,   485916.688D0,   3.499210579D-03,
     1 8310.03711D0,   839269.250D0,   1534910.00D0,   132977.016D0,
     2 0.0D0,          7.247803267D-03,2.14576125D0,   320.237701D0,
     3 21964.8242D0,   624340.000D0,   4.749699496D-03,11686.6729D0,
     4 1168259.88D0,   2054845.50D0,   183562.797D0,   0.0D0,
     5 3.83146310D0,   43.9284134D0,   388.764069D0,   2640.73657D0,
     6 14159.3047D0,   3.40237308D0,   2059.03638D0,   21035.6172D0,
     7 48738.1797D0,   55508.8516D0,   0.0D0,          2.03308749D0,
     8 36.1748352D0,   423.725555D0,   2930.54126D0,   12088.4502D0,
     9 3.97840047D0,   3629.36279D0,   21085.6875D0,   88093.5234D0,
     * 389902.156D0,   0.0D0,          1.94541907D0,   46.8733482D0,
     1 707.780518D0,   6413.43506D0,   37545.8477D0,   8.31841469D0,
     2 12550.8926D0,   105896.617D0,   270469.938D0,   729713.875D0,
     3 0.0D0,          0.147015348D0,  8.59739876D0,   296.193359D0,
     4 4941.33105D0,   33947.9648D0,   27.7018490D0,   44771.9414D0,
     5 226886.781D0,   12036526.0D0,   2545714.25D0,   0.0D0,
     6 9.744767100D-02,8.40332127D0,   360.461853D0,   6706.18555D0,
     7 50046.8281D0,   41.8762245D0,   74827.9375D0,   402869.313D0,
     8 22061360.0D0,   4196645.50D0,   0.0D0,          0.619182169D0,
     9 6.72205544D0,   58.1308899D0,   401.326813D0,   2302.45313D0,
     * 59.5306664D0,   9449.20703D0,   41729.8555D0,   253140.563D0,
     1 1605019.50D0,   0.0D0,          0.239918485D0,  3.89793944D0,
     2 43.7474556D0,   306.356781D0,   1357.96216D0,   184.359955D0,
     3 18016.6719D0,   1456158.25D0,   14650160.0D0,   28570330.0D0,
     4 0.0D0,          0.139622480D0,  3.00979710D0,   43.0439720D0,
     5 391.753876D0,   2370.47290D0,   433.118469D0,   39754.7734D0,
     6 2284654.75D0,   23007766.0D0,   52331796.0D0,   0.0D0/
C * DATA FOR RN ELEMENT #86
      DATA ((XSC(86, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  32.7082405D0,   259.658112D0,   709.805664D0,
     3 1230.23901D0,   1608.56274D0,   0.0D0,          286.324463D0,
     4 2972.90430D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 5.97114515D0,   301.749786D0,   1641.25891D0,   3782.34375D0,
     6 5549.04736D0,   5963.90527D0,   184.543777D0,   4069.38232D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.80936372D0,
     8 221.735947D0,   2004.33875D0,   6352.86719D0,   10987.8975D0,
     9 12345.5225D0,   169.612091D0,   5201.73242D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.67247784D0,   361.447510D0,
     1 3972.32251D0,   13912.0547D0,   25430.2305D0,   28817.8984D0,
     2 64.6178741D0,   732.538330D0,   5786.84521D0,   0.000000000D0,
     3 0.000000000D0,  42.5356560D0,   1389.38672D0,   5717.67676D0,
     4 11219.5264D0,   15059.6963D0,   15867.3984D0,   40.2067871D0,
     5 741.913757D0,   8263.90039D0,   0.000000000D0,  0.000000000D0,
     6 30.1537457D0,   1891.12329D0,   9358.37988D0,   18830.8457D0,
     7 24668.4512D0,   29424.4844D0,   39.2416992D0,   998.335022D0,
     8 15222.5459D0,   0.000000000D0,  0.000000000D0,  47.1776733D0,
     9 4247.63916D0,   24860.7090D0,   57111.8984D0,   81949.1953D0,
     * 94896.7188D0,   3.72480917D0,   251.646774D0,   10847.8906D0,
     1 0.000000000D0,  0.000000000D0,  8.86661434D0,   3063.10254D0,
     2 35888.8672D0,   122888.352D0,   219814.375D0,   1555675.25D0,
     3 2.49988890D0,   250.186829D0,   13483.7422D0,   359265.281D0,
     4 0.000000000D0,  7.84287739D0,   4177.10596D0,   53618.7813D0,
     5 189895.703D0,   344056.375D0,   2367022.25D0,   17.1224976D0,
     6 196.950211D0,   1709.77856D0,   10565.5049D0,   0.000000000D0,
     7 259.228363D0,   5127.47314D0,   16426.4648D0,   27496.5684D0,
     8 33383.9609D0,   34959.8516D0,   10.2345371D0,   183.232803D0,
     9 2109.27319D0,   13117.0352D0,   30837.2793D0,   7.991340756D-02,
     * 501.215485D0,   9699.64551D0,   25842.3770D0,   30759.2852D0,
     1 0.0D0,          9.93726158D0,   243.324570D0,   3672.85864D0,
     2 31733.0859D0,   146491.719D0,   7.789496332D-02,1185.83594D0,
     3 30462.9922D0,   109736.867D0,   170845.469D0,   0.0D0,
     4 1.02049899D0,   62.1883850D0,   2213.63403D0,   37139.5391D0,
     5 201148.625D0,   7.511870470D-03,1292.48083D0,   65799.7656D0,
     6 206196.516D0,   184906.563D0,   0.0D0,          0.684727073D0,
     7 61.7869377D0,   2747.36743D0,   51662.1875D0,   315463.781D0,
     8 5.322730169D-03,1855.35278D0,   104139.547D0,   337458.000D0,
     9 316493.656D0,   0.0D0,          7.387246937D-03,2.09458923D0,
     * 296.885498D0,   19372.9922D0,   520578.719D0,   2.185826190D-03,
     1 6192.96729D0,   704435.938D0,   1681183.25D0,   119902.750D0,
     2 0.0D0,          8.376910351D-03,2.45077538D0,   360.115967D0,
     3 24213.7227D0,   669276.000D0,   2.965008840D-03,8667.49023D0,
     4 979375.500D0,   2265214.75D0,   165190.688D0,   0.0D0,
     5 4.07389593D0,   46.3649178D0,   407.378784D0,   2744.46777D0,
     6 14580.5107D0,   3.03716993D0,   1877.47229D0,   19520.6914D0,
     7 46664.3086D0,   54876.0547D0,   0.0D0,          2.23659277D0,
     8 39.1639290D0,   450.547058D0,   3056.46533D0,   12372.6953D0,
     9 3.31904221D0,   3301.19556D0,   19788.6934D0,   75461.7031D0,
     * 327917.344D0,   0.0D0,          2.12870932D0,   50.7740746D0,
     1 758.425842D0,   6803.62549D0,   39616.2148D0,   6.97234297D0,
     2 11397.9805D0,   100879.609D0,   252484.063D0,   626281.563D0,
     3 0.0D0,          0.170608014D0,  9.86708832D0,   334.363861D0,
     4 5458.49316D0,   36754.0469D0,   18.7006512D0,   40889.3008D0,
     5 129308.539D0,   7570712.00D0,   2955377.25D0,   0.0D0,
     6 0.112919755D0,  9.65379810D0,   407.838867D0,   7431.88428D0,
     7 54478.7461D0,   27.1053352D0,   68483.8750D0,   222144.750D0,
     8 13698569.0D0,   4497876.00D0,   0.0D0,          0.697724998D0,
     9 7.55132723D0,   64.9880676D0,   445.701447D0,   2547.71094D0,
     * 52.4515724D0,   8863.20605D0,   41573.1172D0,   212389.359D0,
     1 1263301.25D0,   0.0D0,          0.290859699D0,  4.69220400D0,
     2 51.9614487D0,   357.583649D0,   1567.24304D0,   165.204025D0,
     3 15162.6973D0,   1169024.63D0,   13539781.0D0,   26944454.0D0,
     4 0.0D0,          0.230380446D0,  4.94895029D0,   70.2489929D0,
     5 633.438477D0,   3824.13770D0,   551.077393D0,   52582.9805D0,
     6 2657891.25D0,   30586460.0D0,   67924296.0D0,   0.0D0/
C * DATA FOR FR ELEMENT #87
      DATA ((XSC(87, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  31.9943752D0,   251.755920D0,   686.283630D0,
     3 1188.50024D0,   1554.37158D0,   0.0D0,          296.320923D0,
     4 3034.51367D0,   0.000000000D0,  0.000000000D0,  0.0000000D0,
     5 5.79519224D0,   289.814911D0,   1576.21301D0,   3633.44873D0,
     6 5330.49902D0,   5726.51416D0,   197.661118D0,   4284.53076D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.78469050D0,
     8 216.020752D0,   1940.70569D0,   6133.70020D0,   10599.9395D0,
     9 11879.2715D0,   179.735413D0,   5460.53027D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.62679160D0,   349.418213D0,
     1 3842.15430D0,   13457.3525D0,   24601.6191D0,   27843.0977D0,
     2 67.0797348D0,   753.291138D0,   5871.17725D0,   0.000000000D0,
     3 0.000000000D0,  40.2350731D0,   1324.10559D0,   5452.16016D0,
     4 10698.1826D0,   14343.7090D0,   15202.3613D0,   43.0241318D0,
     5 779.583435D0,   8468.98926D0,   0.000000000D0,  0.000000000D0,
     6 28.9278431D0,   1801.74500D0,   8913.31836D0,   17933.7539D0,
     7 23499.6621D0,   24924.9941D0,   41.6333008D0,   1046.61279D0,
     8 15742.6631D0,   0.000000000D0,  0.000000000D0,  44.9014091D0,
     9 4058.74146D0,   23851.6895D0,   54968.7344D0,   79106.7031D0,
     * 91997.1406D0,   4.07376003D0,   271.746887D0,   11546.2959D0,
     1 0.000000000D0,  0.000000000D0,  8.35686111D0,   2892.12280D0,
     2 33985.2539D0,   116673.094D0,   208211.438D0,   1432288.88D0,
     3 2.72257781D0,   269.586182D0,   14340.2451D0,   0.000000000D0,
     4 0.000000000D0,  7.28321743D0,   3925.10522D0,   50692.0859D0,
     5 180248.219D0,   327725.219D0,   2252029.25D0,   17.8633900D0,
     6 203.805420D0,   1753.93909D0,   10689.7549D0,   0.000000000D0,
     7 241.903488D0,   4810.63721D0,   15469.8379D0,   25993.2148D0,
     8 31721.2422D0,   33730.0469D0,   11.0042925D0,   193.559799D0,
     9 2184.04248D0,   13225.3623D0,   29552.2559D0,   7.072333992D-02,
     * 465.379456D0,   9094.54102D0,   24473.4766D0,   29370.9590D0,
     1 0.0D0,          10.6014233D0,   256.580383D0,   3827.44263D0,
     2 32666.8652D0,   148676.000D0,   7.096084207D-02,1090.48291D0,
     3 28607.0156D0,   104814.398D0,   165223.531D0,   0.0D0,
     4 1.12570786D0,   67.6019821D0,   2364.32104D0,   38783.3672D0,
     5 202300.578D0,   6.375303492D-03,1142.47266D0,   60534.2539D0,
     6 200025.719D0,   191195.453D0,   0.0D0,          0.753192127D0,
     7 67.1091461D0,   2937.00317D0,   54118.6641D0,   319030.969D0,
     8 4.454412032D-03,1579.79993D0,   94146.6641D0,   324777.156D0,
     9 324697.000D0,   0.0D0,          8.524795994D-03,2.38788056D0,
     * 333.179413D0,   21303.7090D0,   556148.375D0,   1.353483414D-03,
     1 4465.52393D0,   575197.938D0,   1800094.88D0,   109305.172D0,
     2 0.0D0,          9.641480632D-03,2.78954172D0,   403.793365D0,
     3 26616.8008D0,   715483.375D0,   1.830850029D-03,6212.43799D0,
     4 797995.813D0,   2448281.25D0,   148537.156D0,   0.0D0,
     5 4.31972933D0,   48.8407059D0,   426.179840D0,   2847.59814D0,
     6 14988.2461D0,   2.51213217D0,   1672.80847D0,   17778.0117D0,
     7 43958.2109D0,   55705.2422D0,   0.0D0,          2.45826054D0,
     8 42.3176231D0,   477.886230D0,   3179.37451D0,   12626.5820D0,
     9 2.73784781D0,   2921.13599D0,   18260.4551D0,   62075.5117D0,
     * 251623.844D0,   0.0D0,          2.32740712D0,   54.9004822D0,
     1 810.926147D0,   7203.26953D0,   41725.6406D0,   5.50116587D0,
     2 9947.12988D0,   93407.3750D0,   232022.438D0,   531928.188D0,
     3 0.0D0,          0.197200686D0,  11.2590389D0,   374.991882D0,
     4 5991.90234D0,   39557.9727D0,   10.7602911D0,   34290.2656D0,
     5 76739.4609D0,   3658158.75D0,   16185262.0D0,   0.0D0,
     6 0.130038559D0,  11.0167799D0,   458.344269D0,   8182.57959D0,
     7 58945.6406D0,   14.4817677D0,   57082.9531D0,   127450.063D0,
     8 6339316.50D0,   18006056.0D0,   0.0D0,          0.786665022D0,
     9 8.52335644D0,   73.1453400D0,   498.471558D0,   2841.08960D0,
     * 37.4133263D0,   7173.56934D0,   38451.9102D0,   127378.500D0,
     1 560245.438D0,   0.0D0,          0.361461133D0,  5.83639669D0,
     2 64.0223694D0,   433.053284D0,   1879.62244D0,   105.092667D0,
     3 9165.91406D0,   527249.125D0,   7122332.50D0,   30174114.0D0,
     4 0.0D0,          0.309049726D0,  6.73805857D0,   95.7926941D0,
     5 856.510742D0,   5166.65625D0,   348.738373D0,   41605.0625D0,
     6 1091980.00D0,   18438080.0D0,   72377288.0D0,   0.0D0/
C * DATA FOR RA ELEMENT #88
      DATA ((XSC(88, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  31.3100777D0,   244.163834D0,   663.638000D0,
     3 1147.81702D0,   1499.77893D0,   0.0D0,          306.343689D0,
     4 3094.58105D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 5.63081169D0,   278.546875D0,   1514.61377D0,   3491.29004D0,
     6 5121.86621D0,   5501.38721D0,   211.452972D0,   4504.41064D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.76240766D0,
     8 210.690384D0,   1880.81946D0,   5925.33057D0,   10221.9863D0,
     9 11428.7754D0,   190.220993D0,   5724.52295D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.58466554D0,   338.502838D0,
     1 3719.79443D0,   13024.5957D0,   23807.6230D0,   26958.5313D0,
     2 69.5919037D0,   773.902649D0,   5947.17578D0,   0.000000000D0,
     3 0.000000000D0,  38.3973579D0,   1264.32166D0,   5205.85107D0,
     4 10210.7266D0,   13711.1406D0,   14467.4326D0,   45.9796181D0,
     5 817.757690D0,   8657.50586D0,   0.000000000D0,  0.000000000D0,
     6 27.9548969D0,   1725.49060D0,   8520.21973D0,   17128.5000D0,
     7 22414.0684D0,   23930.1797D0,   44.1171417D0,   1096.23083D0,
     8 16268.6279D0,   0.000000000D0,  0.000000000D0,  42.7194214D0,
     9 3877.75952D0,   22881.2480D0,   52901.7656D0,   76370.5938D0,
     * 82590.9453D0,   4.44829750D0,   292.898895D0,   12257.7246D0,
     1 0.000000000D0,  0.000000000D0,  7.88969946D0,   2745.00854D0,
     2 32304.4824D0,   111103.805D0,   198679.281D0,   177188.359D0,
     3 2.96144414D0,   289.992767D0,   15213.8330D0,   0.000000000D0,
     4 0.000000000D0,  6.81387997D0,   3706.67676D0,   48087.6328D0,
     5 171447.391D0,   311220.844D0,   214832.594D0,   18.6201916D0,
     6 210.705627D0,   1796.98657D0,   10796.8408D0,   0.000000000D0,
     7 226.921906D0,   4529.73535D0,   14609.6328D0,   24648.9258D0,
     8 30129.2930D0,   32176.0742D0,   11.8345547D0,   204.558075D0,
     9 2264.33569D0,   13339.8730D0,   0.000000000D0,  305.868378D0,
     * 7298.83887D0,   19680.2715D0,   26306.8438D0,   27586.1445D0,
     1 29280.1055D0,   11.3144207D0,   270.821228D0,   3999.07324D0,
     2 33804.1758D0,   150625.859D0,   5.938782915D-02,935.522278D0,
     3 25656.2949D0,   96879.2031D0,   155201.500D0,   0.0D0,
     4 1.24038506D0,   73.3497391D0,   2518.40259D0,   40360.0078D0,
     5 203748.609D0,   5.654674955D-03,1039.39172D0,   56579.8047D0,
     6 194990.953D0,   198087.109D0,   0.0D0,          0.826027393D0,
     7 72.6433868D0,   3123.74219D0,   56255.6680D0,   323509.313D0,
     8 4.171425942D-03,1465.78882D0,   89226.8438D0,   319066.719D0,
     9 341851.063D0,   0.0D0,          9.832645766D-03,2.72480321D0,
     * 376.080597D0,   23819.7715D0,   611912.938D0,   5.584582686D-04,
     1 2402.48877D0,   393222.969D0,   1755934.00D0,   120076.273D0,
     2 0.0D0,          1.109748799D-02,3.18180394D0,   456.724854D0,
     3 29953.3633D0,   797488.875D0,   6.517783040D-04,2963.92896D0,
     4 509079.594D0,   2362534.00D0,   161796.984D0,   0.0D0,
     5 4.58083582D0,   51.4267845D0,   445.765533D0,   2958.88501D0,
     6 15452.5674D0,   1.90909231D0,   1359.26526D0,   15092.7217D0,
     7 39369.9531D0,   50218.1484D0,   0.0D0,          2.69415879D0,
     8 45.6471405D0,   506.502319D0,   3306.69385D0,   12853.5693D0,
     9 1.91933167D0,   2339.09937D0,   15853.7207D0,   47174.8281D0,
     * 179422.031D0,   0.0D0,          2.53644729D0,   59.2411537D0,
     1 866.091980D0,   7624.38721D0,   43971.8086D0,   3.86100101D0,
     2 8254.29102D0,   83413.5703D0,   208301.781D0,   416361.406D0,
     3 0.0D0,          0.226390973D0,  12.7725086D0,   418.153687D0,
     4 6537.43896D0,   42370.2734D0,   8.06064320D0,   31118.6367D0,
     5 70931.5938D0,   2077290.13D0,   27086270.0D0,   0.0D0,
     6 0.149072587D0,  12.5121536D0,   512.665894D0,   8971.58398D0,
     7 63542.8398D0,   7.59291506D0,   45706.7578D0,   114507.891D0,
     8 2777723.00D0,   44059340.0D0,   0.0D0,          0.886055529D0,
     9 9.58439827D0,   81.9342346D0,   555.459351D0,   3162.22949D0,
     * 17.5091190D0,   4264.07861D0,   28889.3945D0,   65586.4219D0,
     1 260055.984D0,   0.0D0,          0.436373144D0,  7.01217413D0,
     2 75.9711151D0,   505.077942D0,   2168.33765D0,   82.3294144D0,
     3 7616.53564D0,   335531.406D0,   4094729.75D0,   19157046.0D0,
     4 0.0D0,          0.385011405D0,  8.42786121D0,   119.413391D0,
     5 1059.34106D0,   6383.57666D0,   130.730331D0,   25809.3125D0,
     6 308458.000D0,   4742936.50D0,   31345792.0D0,   0.0D0/
C * DATA FOR AC ELEMENT #89
      DATA ((XSC(89, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  30.6567307D0,   236.888184D0,   641.889221D0,
     3 1109.16467D0,   1449.53955D0,   0.0D0,          316.477295D0,
     4 3151.50293D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 5.48200941D0,   267.833832D0,   1456.66809D0,   3357.55054D0,
     6 4923.81934D0,   5289.55908D0,   226.114304D0,   4733.34521D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.74003148D0,
     8 205.477539D0,   1822.59863D0,   5724.74121D0,   9864.77539D0,
     9 11008.3662D0,   201.240692D0,   6000.46094D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.54255128D0,   327.727875D0,
     1 3600.14429D0,   12607.2275D0,   23046.5723D0,   26069.3262D0,
     2 72.1379547D0,   794.610840D0,   6019.70459D0,   0.000000000D0,
     3 0.000000000D0,  36.5615044D0,   1205.20618D0,   4964.37451D0,
     4 9734.85059D0,   13080.2842D0,   13720.7324D0,   49.1042252D0,
     5 856.942261D0,   8836.01172D0,   0.000000000D0,  0.000000000D0,
     6 26.8872776D0,   1653.85034D0,   8148.21484D0,   16358.6445D0,
     7 21413.0723D0,   22850.3496D0,   46.6983032D0,   1146.28943D0,
     8 16771.6113D0,   0.000000000D0,  0.000000000D0,  41.1373940D0,
     9 3736.69727D0,   22090.2813D0,   51169.0547D0,   74077.4141D0,
     * 79779.8984D0,   4.85433435D0,   315.624695D0,   13025.1230D0,
     1 0.000000000D0,  0.000000000D0,  7.43538141D0,   2592.81348D0,
     2 30611.1035D0,   105576.883D0,   188526.906D0,   195328.656D0,
     3 3.21741652D0,   311.810425D0,   16155.4209D0,   0.000000000D0,
     4 0.000000000D0,  6.32328796D0,   3482.07495D0,   45468.3867D0,
     5 162752.125D0,   295087.625D0,   338237.219D0,   19.3954716D0,
     6 217.705322D0,   1840.07129D0,   10899.5684D0,   0.000000000D0,
     7 211.895935D0,   4251.27832D0,   13759.5889D0,   23288.9883D0,
     8 28643.2637D0,   29793.3809D0,   12.6863012D0,   215.212051D0,
     9 2330.64307D0,   13359.8379D0,   0.000000000D0,  305.483002D0,
     * 7156.78564D0,   19147.0156D0,   25651.1367D0,   27066.9844D0,
     1 29640.3281D0,   12.0329638D0,   284.424713D0,   4142.14111D0,
     2 34493.0586D0,   152798.938D0,   6.149294972D-02,947.457397D0,
     3 25668.2832D0,   96631.8672D0,   155586.656D0,   0.0D0,
     4 1.36413980D0,   79.5076447D0,   2682.74268D0,   42052.0000D0,
     5 204243.516D0,   4.857109394D-03,925.638916D0,   52211.9570D0,
     6 188149.891D0,   202629.750D0,   0.0D0,          0.904943466D0,
     7 78.5924606D0,   3324.62476D0,   58619.4414D0,   326985.094D0,
     8 3.750892123D-03,1309.66064D0,   82803.7422D0,   309026.563D0,
     9 346923.031D0,   0.0D0,          1.126796473D-02,3.07849669D0,
     * 416.329987D0,   25565.6836D0,   630210.063D0,   5.881576217D-04,
     1 2465.20459D0,   390488.156D0,   1801447.88D0,   137987.719D0,
     2 0.0D0,          1.267871819D-02,3.58470702D0,   503.618317D0,
     3 31913.9668D0,   811952.313D0,   7.991899038D-04,3393.05811D0,
     4 539408.875D0,   2470865.00D0,   183959.109D0,   0.0D0,
     5 4.84823561D0,   54.0132103D0,   464.316376D0,   3051.76855D0,
     6 15752.6426D0,   1.90675843D0,   1345.01050D0,   14846.0020D0,
     7 39057.2734D0,   50900.0313D0,   0.0D0,          2.94850135D0,
     8 49.0861168D0,   534.170288D0,   3416.86621D0,   13048.9395D0,
     9 1.87780750D0,   2321.24805D0,   15658.3936D0,   45475.8203D0,
     * 160936.078D0,   0.0D0,          2.76166415D0,   63.7891426D0,
     1 922.139343D0,   8038.06787D0,   46089.5313D0,   3.45410872D0,
     2 7736.16016D0,   80580.0547D0,   203540.281D0,   375716.531D0,
     3 0.0D0,          0.259258419D0,  14.4386101D0,   464.838562D0,
     4 7122.88965D0,   45260.4453D0,   4.38500404D0,   24185.0078D0,
     5 72250.2734D0,   1012145.50D0,   6806866.00D0,   0.0D0,
     6 0.170383453D0,  14.1434507D0,   570.172852D0,   9780.20020D0,
     7 68143.4922D0,   5.16854811D0,   39766.3242D0,   124322.398D0,
     8 1605791.13D0,   11435348.0D0,   0.0D0,          0.987139583D0,
     9 10.6504345D0,   90.5672455D0,   609.544067D0,   3449.40454D0,
     * 22.4649811D0,   5156.58691D0,   33851.1367D0,   80294.3672D0,
     1 275116.500D0,   0.0D0,          0.515477836D0,  8.19324684D0,
     2 87.4149399D0,   571.221741D0,   2425.96313D0,   52.8046532D0,
     3 5783.98682D0,   182337.078D0,   2409595.00D0,   9638924.00D0,
     4 0.0D0,          0.456029475D0,  9.97208118D0,   140.421387D0,
     5 1234.91040D0,   7425.07813D0,   161.046219D0,   30990.6211D0,
     6 365109.531D0,   4785396.00D0,   23329580.0D0,   0.0D0/
C * DATA FOR TH ELEMENT #90
      DATA ((XSC(90, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D0,  0.000000000D0,  0.000000000D0,  0.000000000D0,
     2 0.000000000D0,  30.0256462D0,   229.867676D0,   620.880432D0,
     3 1071.32349D0,   1398.48145D0,   0.0D0,          326.748230D0,
     4 3206.74072D0,   0.000000000D0,  0.000000000D0,  0.000000000D0,
     5 5.32942200D0,   257.386353D0,   1399.47424D0,   3225.70532D0,
     6 4730.33398D0,   5081.20703D0,   241.548141D0,   4967.70508D0,
     7 0.000000000D0,  0.000000000D0,  0.000000000D0,  1.71924424D0,
     8 200.574661D0,   1767.55457D0,   5533.49854D0,   9516.22852D0,
     9 10637.3252D0,   212.661148D0,   6283.76123D0,   0.000000000D0,
     * 0.000000000D0,  0.000000000D0,  1.50324297D0,   317.605621D0,
     1 3487.47925D0,   12211.0791D0,   22325.4277D0,   25228.9023D0,
     2 74.7322159D0,   815.165771D0,   6084.66406D0,   0.000000000D0,
     3 0.000000000D0,  34.9095573D0,   1150.94543D0,   4740.57813D0,
     4 9292.06641D0,   12494.0732D0,   13091.6123D0,   52.3884277D0,
     5 897.195007D0,   9006.37988D0,   0.000000000D0,  0.000000000D0,
     6 25.9803047D0,   1583.89282D0,   7787.53174D0,   15613.9453D0,
     7 20437.0313D0,   21649.1680D0,   49.4018021D0,   1199.05383D0,
     8 17318.6953D0,   0.000000000D0,  0.000000000D0,  39.1069260D0,
     9 3568.88379D0,   21193.1660D0,   49261.0703D0,   71324.6953D0,
     * 77848.9531D0,   5.28865862D0,   339.583618D0,   13815.9453D0,
     1 0.000000000D0,  0.000000000D0,  7.04424381D0,   2459.69165D0,
     2 29104.2305D0,   100584.469D0,   179252.141D0,   217435.875D0,
     3 3.49079299D0,   334.796844D0,   17127.3691D0,   0.000000000D0,
     4 0.000000000D0,  5.86712837D0,   3284.89453D0,   43138.0977D0,
     5 154989.938D0,   281640.000D0,   284612.781D0,   20.1967239D0,
     6 224.785431D0,   1882.17468D0,   10988.6104D0,   0.000000000D0,
     7 198.749786D0,   4002.68408D0,   12988.8184D0,   22050.8066D0,
     8 27266.7383D0,   27966.6270D0,   13.6110401D0,   227.000778D0,
     9 2411.93018D0,   13423.7900D0,   0.000000000D0,  267.613220D0,
     * 6459.70215D0,   17602.8730D0,   23771.4902D0,   25100.8711D0,
     1 26530.9922D0,   12.8120422D0,   299.762665D0,   4325.41553D0,
     2 35709.0195D0,   154997.109D0,   5.151344091D-02,808.669556D0,
     3 22940.1172D0,   89038.2969D0,   145699.672D0,   0.0D0,
     4 1.49804378D0,   86.0589066D0,   2854.00293D0,   43763.1836D0,
     5 204403.484D0,   4.222495947D-03,831.180847D0,   48406.6719D0,
     6 181424.375D0,   203290.922D0,   0.0D0,          0.990160763D0,
     7 84.9544144D0,   3537.86011D0,   61136.7109D0,   329522.906D0,
     8 3.322858829D-03,1151.62366D0,   76118.0234D0,   296861.813D0,
     9 351032.781D0,   0.0D0,          1.291557774D-02,3.48761749D0,
     * 465.507446D0,   28162.8242D0,   678548.563D0,   3.316395741D-04,
     1 1685.94482D0,   305010.875D0,   1679498.13D0,   175044.375D0,
     2 0.0D0,          1.449720468D-02,4.05466318D0,   562.677917D0,
     3 35155.6523D0,   875816.438D0,   4.542820679D-04,2291.95605D0,
     4 418691.313D0,   2306520.25D0,   230358.953D0,   0.0D0,
     5 5.12543678D0,   56.6921768D0,   483.870819D0,   3157.56494D0,
     6 16144.9473D0,   1.59335065D0,   1164.63464D0,   13204.5693D0,
     7 35900.0742D0,   47829.9609D0,   0.0D0,          3.22147226D0,
     8 52.7174034D0,   563.078918D0,   3531.89648D0,   13205.3047D0,
     9 1.54382432D0,   2036.42456D0,   14326.3066D0,   39397.5703D0,
     * 133587.547D0,   0.0D0,          3.00122476D0,   68.5812454D0,
     1 981.033936D0,   8479.29980D0,   48400.3281D0,   2.72940397D0,
     2 6723.08105D0,   73879.2813D0,   190433.984D0,   334627.750D0,
     3 0.0D0,          0.295375645D0,  16.2332058D0,   513.687317D0,
     4 7711.88379D0,   48096.0586D0,   3.09335065D0,   21043.4316D0,
     5 77838.1016D0,   631898.438D0,   3774984.25D0,   0.0D0,
     6 0.193716198D0,  15.9032726D0,   630.955017D0,   10614.9180D0,
     7 72772.0156D0,   3.41730022D0,   34181.8906D0,   135000.875D0,
     8 965734.438D0,   5904875.00D0,   0.0D0,          1.09475064D0,
     9 11.7419624D0,   99.2631836D0,   664.996521D0,   3763.64331D0,
     * 11.4499903D0,   3186.35620D0,   24798.3672D0,   56315.5508D0,
     1 174274.469D0,   0.0D0,          0.599823773D0,  9.40906620D0,
     2 98.8109894D0,   635.234314D0,   2668.69360D0,   14.2233953D0,
     3 2937.01074D0,   40275.5586D0,   688249.250D0,   3604660.25D0,
     4 0.0D0,          0.530631721D0,  11.5330715D0,   161.249908D0,
     5 1410.66431D0,   8507.92773D0,   25.3249302D0,   11615.5664D0,
     6 91773.8047D0,   862096.063D0,   6226572.00D0,   0.0D0/
C * DATA FOR PA ELEMENT #91
      DATA ((XSC(91, I, J), J = 1, 11), I = 1, 24)/
     1 0.00000D+00,    0.00000D+00,    0.00000D+00,    0.00000D+00,
     2 0.00000D+00,    29.4217930D0,   223.136414D0,   600.697205D0,
     3 1035.42517D0,   1351.72815D0,   0.0D0,          337.117065D0,
     4 3259.90503D0,   0.00000D+00,    0.00000D+00,    0.00000D+00,
     5 5.19536877D0,   247.796692D0,   1346.48499D0,   3103.39087D0,
     6 4549.07129D0,   4889.17822D0,   257.905670D0,   5207.93652D0,
     7 0.00000D+00,    0.00000D+00,    0.00000D+00,    1.70157337D0,
     8 195.931076D0,   1716.45898D0,   5356.15381D0,   9198.30371D0,
     9 10276.5957D0,   224.646347D0,   6579.08398D0,   0.00000D+00,
     * 0.00000D+00,    0.00000D+00,    1.46701753D0,   308.214417D0,
     1 3383.15088D0,   11847.1455D0,   21659.8418D0,   24503.1035D0,
     2 77.3622284D0,   835.906982D0,   6148.06592D0,   0.00000D+00,
     3 0.00000D+00,    33.3525963D0,   1100.01904D0,   4531.10254D0,
     4 8875.43359D0,   11910.4385D0,   12559.3232D0,   55.8595657D0,
     5 938.530823D0,   9165.85547D0,   0.00000D+00,    0.00000D+00,
     6 25.2570820D0,   1523.98364D0,   7469.33203D0,   14942.1523D0,
     7 19542.1445D0,   20611.7461D0,   52.2285728D0,   1253.22778D0,
     8 17866.4277D0,   0.00000D+00,    0.00000D+00,    37.5625000D0,
     9 3435.58594D0,   20462.5117D0,   47677.2148D0,   69167.0703D0,
     * 75423.3516D0,   5.75961304D0,   365.341827D0,   14668.9941D0,
     1 0.00000D+00,    0.00000D+00,    6.70611525D0,   2344.94092D0,
     2 27821.2520D0,   96390.9688D0,   172092.281D0,   199769.953D0,
     3 3.78538799D0,   359.353912D0,   18164.5430D0,   0.00000D+00,
     4 0.00000D+00,    5.52108574D0,   3122.32910D0,   41225.8398D0,
     5 148619.266D0,   270616.875D0,   243039.594D0,   21.0021286D0,
     6 231.888794D0,   1923.84741D0,   11069.9834D0,   0.00000D+00,
     7 187.909515D0,   3793.61597D0,   12330.0967D0,   20968.8438D0,
     8 25971.4316D0,   26566.6719D0,   14.5760651D0,   238.804214D0,
     9 2485.84570D0,   13426.3496D0,   0.00000D+00,    251.954651D0,
     * 6102.91895D0,   16669.2676D0,   22509.7363D0,   23724.2344D0,
     1 26403.6543D0,   13.6208639D0,   315.044312D0,   4494.86768D0,
     2 36691.5938D0,   0.00000D+00,    555.756836D0,   18990.5801D0,
     3 68248.2109D0,   119065.188D0,   148118.625D0,   170989.891D0,
     4 1.64230478D0,   92.9962540D0,   3031.00464D0,   45459.7344D0,
     5 204356.516D0,   3.935094923D-03,784.074402D0,   46293.3555D0,
     6 177025.781D0,   205539.109D0,   0.0D0,          1.08176517D0,
     7 91.7048569D0,   3760.60034D0,   63706.4531D0,   331339.969D0,
     8 3.110173624D-03,1058.86145D0,   71959.8672D0,   288208.750D0,
     9 349291.844D0,   0.0D0,          1.475244574D-02,3.93603730D0,
     * 518.092651D0,   30809.9121D0,   723687.375D0,   2.541629074D-04,
     1 1390.44495D0,   268268.000D0,   1602622.00D0,   154225.938D0,
     2 0.0D0,          1.651385054D-02,4.56706667D0,   625.223999D0,
     3 38389.2852D0,   933006.688D0,   3.638048947D-04,1922.26392D0,
     4 372285.031D0,   2212278.25D0,   202474.141D0,   0.0D0,
     5 5.39867878D0,   59.2882462D0,   502.305939D0,   3254.17920D0,
     6 16468.6211D0,   1.38925898D0,   1076.47644D0,   12352.8877D0,
     7 33862.8359D0,   45490.0625D0,   0.0D0,          3.50052953D0,
     8 56.2884750D0,   589.689575D0,   3624.10645D0,   13284.4854D0,
     9 1.60460746D0,   2043.36145D0,   14154.6670D0,   39618.5391D0,
     * 134922.734D0,   0.0D0,          3.23309350D0,   73.0762100D0,
     1 1033.85815D0,   8852.53125D0,   50242.8086D0,   2.88203740D0,
     2 6937.99805D0,   75841.0234D0,   194803.375D0,   341959.656D0,
     3 0.0D0,          0.330870241D0,  17.9033680D0,   556.262878D0,
     4 8182.76172D0,   50086.0859D0,   3.14749432D0,   21223.2441D0,
     5 79335.6953D0,   639017.000D0,   3930551.75D0,   0.0D0,
     6 0.215997905D0,  17.4952431D0,   682.322693D0,   11258.5234D0,
     7 75960.1172D0,   3.56514740D0,   35011.4727D0,   137911.125D0,
     8 1001618.38D0,   6357603.00D0,   0.0D0,          1.13140631D0,
     9 12.0350523D0,   100.865013D0,   670.138062D0,   3754.40869D0,
     * 20.0664749D0,   4731.21875D0,   31794.8516D0,   81577.9766D0,
     1 277154.563D0,   0.0D0,          0.630836248D0,  9.71265221D0,
     2 99.9530487D0,   630.238342D0,   2609.59546D0,   47.1750145D0,
     3 5376.10059D0,   160318.656D0,   2133790.75D0,   8486705.00D0,
     4 0.0D0,          0.545299411D0,  11.6766758D0,   161.000015D0,
     5 1393.05579D0,   8330.90820D0,   148.432877D0,   30669.6621D0,
     6 333496.375D0,   4265278.50D0,   21050740.0D0,   0.0D0/
C * DATA FOR U  ELEMENT #92
      DATA ((XSC(92, I, J), J = 1, 11), I = 1, 24)/
     1 0.000000000D+00,0.000000000D+00,0.00000000D+00, 0.00000000D+00,
     2 0.000000000D+00,28.8420296D0,   216.662613D0,   581.247925D0,
     3 1000.75500D0,   1306.55957D0,   0.0D0,          347.511749D0,
     4 3312.69507D0,   0.000000000D+00,0.0000000D+00,  0.0000000D+00,
     5 5.04670286D0,   238.440948D0,   1294.83960D0,   2983.78101D0,
     6 4374.05371D0,   4702.30908D0,   275.066284D0,   5450.26367D0,
     7 0.0000000D+00,  0.000000D+00,   0.0000000D+00,  1.68461120D0,
     8 191.638474D0,   1667.37158D0,   5184.47363D0,   8887.00000D0,
     9 9914.98242D0,   237.038956D0,   6878.43262D0,   0.000000000D+00,
     * 0.000000000D+00,0.000000000D+00,1.43383610D0,   299.443634D0,
     1 3284.61499D0,   11500.2021D0,   21017.8418D0,   23796.3301D0,
     2 80.0252914D0,   856.124634D0,   6198.50488D0,   0.000000000D+00,
     3 0.000000000D+00,31.9933510D0,   1054.08093D0,   4338.32813D0,
     4 8489.07422D0,   11394.7461D0,   11993.1641D0,   59.4962463D0,
     5 980.760010D0,   9314.13086D0,   0.0000000D+00,  0.0000000D+00,
     6 24.4866905D0,   1463.05823D0,   7151.39600D0,   14279.6621D0,
     7 18608.2363D0,   19801.8965D0,   55.1471939D0,   1308.34705D0,
     8 18408.3984D0,   0.0000000D+00,  0.0000000D+00,  36.0961418D0,
     9 3308.43286D0,   19758.1250D0,   46138.4844D0,   67105.4063D0,
     * 72027.0781D0,   6.25987339D0,   392.130035D0,   15519.8467D0,
     1 0.0000000D+00,  0.0000000D+00,  6.42884302D0,   2246.63086D0,
     2 26677.9121D0,   92562.4453D0,   165677.625D0,   161128.875D0,
     3 4.09870529D0,   385.030487D0,   19217.2520D0,   0.0000000D+00,
     4 0.0000000D+00,  5.21098137D0,   2972.62866D0,   39420.1914D0,
     5 142481.063D0,   259586.344D0,   218465.656D0,   21.8197193D0,
     6 238.938248D0,   1962.87341D0,   11122.5977D0,   0.000000000D+00,
     7 179.128845D0,   3616.70117D0,   11754.8545D0,   20010.6035D0,
     8 24775.6016D0,   25608.8555D0,   15.5962124D0,   250.807953D0,
     9 2555.26270D0,   13389.1104D0,   0.000000000D+00,241.629105D0,
     * 5830.25635D0,   15898.3486D0,   21466.6270D0,   22644.9102D0,
     1 25456.2285D0,   14.4561348D0,   330.642548D0,   4663.99316D0,
     2 37632.7266D0,   0.000000000D+00,529.207092D0,   18250.4551D0,
     3 66057.5000D0,   115953.281D0,   145725.063D0,   141866.953D0,
     4 1.79938984D0,   100.411514D0,   3217.19214D0,   47229.0898D0,
     5 203494.406D0,   3.538780846D-03,720.358765D0,   43531.6289D0,
     6 171140.234D0,   204807.703D0,   0.0D0,          1.18061268D0,
     7 98.8114548D0,   3986.34106D0,   66153.5703D0,   333877.531D0,
     8 2.970987931D-03,987.693970D0,   68520.5469D0,   280925.094D0,
     9 351001.250D0,   0.0D0,          1.679878868D-02,4.42458105D0,
     * 573.094788D0,   33343.6875D0,   759708.875D0,   2.203819167D-04,
     1 1242.74731D0,   246723.141D0,   1552035.75D0,   155875.063D0,
     2 0.0D0,          1.875866763D-02,5.12651873D0,   691.397156D0,
     3 41594.4375D0,   982996.938D0,   3.104589123D-04,1681.13770D0,
     4 338206.375D0,   2135759.75D0,   203558.438D0,   0.0D0,
     5 5.68614292D0,   61.9411621D0,   520.420532D0,   3343.23804D0,
     6 16722.4473D0,   1.32321870D0,   1028.75464D0,   11836.4854D0,
     7 32616.0156D0,   44416.0352D0,   0.0D0,          3.80143571D0,
     8 60.0876083D0,   617.836304D0,   3722.43945D0,   13322.1113D0,
     9 1.32734489D0,   1789.09875D0,   12876.5469D0,   34906.4883D0,
     * 119073.344D0,   0.0D0,          3.48343849D0,   77.9058609D0,
     1 1090.78564D0,   9263.05469D0,   52299.1992D0,   2.57604432D0,
     2 6471.06104D0,   72662.7734D0,   188445.047D0,   325467.781D0,
     3 0.0D0,          0.370925695D0,  19.7877483D0,   604.217896D0,
     4 8715.60840D0,   52328.7227D0,   2.62085009D0,   19450.3066D0,
     5 81746.0547D0,   509536.844D0,   3205391.00D0,   0.00D0,
     6 0.241213620D0,  19.3023205D0,   740.695251D0,   11996.0439D0,
     7 79631.9766D0,   2.94554043D0,   32409.4219D0,   142580.594D0,
     8 805837.188D0,   5159188.50D0,   0.0D0,          1.19681120D0,
     9 12.6579933D0,   105.484665D0,   698.402161D0,   3911.92090D0,
     * 8.77220631D0,   2555.12280D0,   20492.0859D0,   50161.6914D0,
     1 174645.375D0,   0.0D0,          0.688192070D0,  10.4296017D0,
     2 105.452431D0,   653.458801D0,   2669.10205D0,   21.7011681D0,
     3 3465.78979D0,   66133.5859D0,   1070067.00D0,   5223840.00D0,
     4 0.0D0,          0.585494578D0,  12.4282341D0,   169.844070D0,
     5 1460.21033D0,   8725.37793D0,   54.2631149D0,   17623.1504D0,
     6 145704.859D0,   1739226.38D0,   11441855.0D0,   0.0D0/
C * DATA FOR ELEMENT H
      DATA DRAY( 1, 1)/-0.119080000D0  /,DCMP( 1, 1)/ -2.15770006D0  /
      DATA DRAY( 1, 2)/-0.937089980D0  /,DCMP( 1, 2)/  1.32690001D0  /
      DATA DRAY( 1, 3)/-0.200540006D0  /,DCMP( 1, 3)/-0.305620015D0  /
      DATA DRAY( 1, 4)/ 1.065899990D-02/,DCMP( 1, 4)/ 1.850200072D-02/
C * DATA FOR ELEMENT HE
      DATA DRAY( 2, 1)/  1.04770005D0  /,DCMP( 2, 1)/ -2.56360006D0  /
      DATA DRAY( 2, 2)/-8.517999947D-02/,DCMP( 2, 2)/  2.02539992D0  /
      DATA DRAY( 2, 3)/-0.403530002D0  /,DCMP( 2, 3)/-0.448709995D0  /
      DATA DRAY( 2, 4)/ 2.693999931D-02/,DCMP( 2, 4)/ 2.796900086D-02/
C * DATA FOR ELEMENT LI
      DATA DRAY( 3, 1)/  1.34370005D0  /,DCMP( 3, 1)/ -1.08739996D0  /
      DATA DRAY( 3, 2)/ 0.181559995D0  /,DCMP( 3, 2)/  1.03369999D0  /
      DATA DRAY( 3, 3)/-0.423979998D0  /,DCMP( 3, 3)/-0.190380007D0  /
      DATA DRAY( 3, 4)/ 2.661900036D-02/,DCMP( 3, 4)/ 7.799500134D-03/
C * DATA FOR ELEMENT BE
      DATA DRAY( 4, 1)/  2.00860000D0  /,DCMP( 4, 1)/-0.690079987D0  /
      DATA DRAY( 4, 2)/-4.619200155D-02/,DCMP( 4, 2)/ 0.946449995D0  /
      DATA DRAY( 4, 3)/-0.337020010D0  /,DCMP( 4, 3)/-0.171140000D0  /
      DATA DRAY( 4, 4)/ 1.869400032D-02/,DCMP( 4, 4)/ 6.514099892D-03/
C * DATA FOR ELEMENT B
      DATA DRAY( 5, 1)/  2.61859989D0  /,DCMP( 5, 1)/-0.791180015D0  /
      DATA DRAY( 5, 2)/-0.207920000D0  /,DCMP( 5, 2)/  1.21609998D0  /
      DATA DRAY( 5, 3)/-0.286280006D0  /,DCMP( 5, 3)/-0.239089996D0  /
      DATA DRAY( 5, 4)/ 1.449699979D-02/,DCMP( 5, 4)/ 1.176900044D-02/
C * DATA FOR ELEMENT C
      DATA DRAY( 6, 1)/  3.10859990D0  /,DCMP( 6, 1)/-0.982879996D0  /
      DATA DRAY( 6, 2)/-0.260580003D0  /,DCMP( 6, 2)/  1.46689999D0  /
      DATA DRAY( 6, 3)/-0.271970004D0  /,DCMP( 6, 3)/-0.293740004D0  /
      DATA DRAY( 6, 4)/ 1.351800002D-02/,DCMP( 6, 4)/ 1.559999958D-02/
C * DATA FOR ELEMENT N
      DATA DRAY( 7, 1)/  3.47760010D0  /,DCMP( 7, 1)/ -1.23689997D0  /
      DATA DRAY( 7, 2)/-0.215759993D0  /,DCMP( 7, 2)/  1.74510002D0  /
      DATA DRAY( 7, 3)/-0.288870007D0  /,DCMP( 7, 3)/-0.354660004D0  /
      DATA DRAY( 7, 4)/ 1.513100043D-02/,DCMP( 7, 4)/ 1.986999996D-02/
C * DATA FOR ELEMENT O
      DATA DRAY( 8, 1)/  3.77239990D0  /,DCMP( 8, 1)/ -1.73679996D0  /
      DATA DRAY( 8, 2)/-0.148540005D0  /,DCMP( 8, 2)/  2.17689991D0  /
      DATA DRAY( 8, 3)/-0.307119995D0  /,DCMP( 8, 3)/-0.449050009D0  /
      DATA DRAY( 8, 4)/ 1.672999933D-02/,DCMP( 8, 4)/ 2.647300065D-02/
C * DATA FOR ELEMENT F
      DATA DRAY( 9, 1)/  4.00719976D0  /,DCMP( 9, 1)/ -1.87570000D0  /
      DATA DRAY( 9, 2)/-5.609099939D-02/,DCMP( 9, 2)/  2.32019997D0  /
      DATA DRAY( 9, 3)/-0.332020015D0  /,DCMP( 9, 3)/-0.475410014D0  /
      DATA DRAY( 9, 4)/ 1.879299991D-02/,DCMP( 9, 4)/ 2.806800045D-02/
C * DATA FOR ELEMENT NE
      DATA DRAY(10, 1)/  4.20149994D0  /,DCMP(10, 1)/ -1.75510001D0  /
      DATA DRAY(10, 2)/ 4.162500054D-02/,DCMP(10, 2)/  2.24230003D0  /
      DATA DRAY(10, 3)/-0.356750011D0  /,DCMP(10, 3)/-0.447640002D0  /
      DATA DRAY(10, 4)/ 2.075899951D-02/,DCMP(10, 4)/ 2.558000013D-02/
C * DATA FOR ELEMENT NA
      DATA DRAY(11, 1)/  4.26370001D0  /,DCMP(11, 1)/-0.967719972D0  /
      DATA DRAY(11, 2)/ 0.134660006D0  /,DCMP(11, 2)/  1.61790001D0  /
      DATA DRAY(11, 3)/-0.370079994D0  /,DCMP(11, 3)/-0.287189990D0  /
      DATA DRAY(11, 4)/ 2.144699916D-02/,DCMP(11, 4)/ 1.315299980D-02/
C * DATA FOR ELEMENT MG
      DATA DRAY(12, 1)/  4.39400005D0  /,DCMP(12, 1)/-0.571609974D0  /
      DATA DRAY(12, 2)/ 0.137860000D0  /,DCMP(12, 2)/  1.35500002D0  /
      DATA DRAY(12, 3)/-0.359539986D0  /,DCMP(12, 3)/-0.224910006D0  /
      DATA DRAY(12, 4)/ 2.023800090D-02/,DCMP(12, 4)/ 8.301399648D-03/
C * DATA FOR ELEMENT AL
      DATA DRAY(13, 1)/  4.51989985D0  /,DCMP(13, 1)/-0.439319998D0  /
      DATA DRAY(13, 2)/ 0.140550002D0  /,DCMP(13, 2)/  1.30869997D0  /
      DATA DRAY(13, 3)/-0.352440000D0  /,DCMP(13, 3)/-0.211649999D0  /
      DATA DRAY(13, 4)/ 1.936900057D-02/,DCMP(13, 4)/ 7.542099804D-03/
C * DATA FOR ELEMENT SI
      DATA DRAY(14, 1)/  4.64680004D0  /,DCMP(14, 1)/-0.414970011D0  /
      DATA DRAY(14, 2)/ 0.162780002D0  /,DCMP(14, 2)/  1.34870005D0  /
      DATA DRAY(14, 3)/-0.358559996D0  /,DCMP(14, 3)/-0.222310007D0  /
      DATA DRAY(14, 4)/ 1.969300024D-02/,DCMP(14, 4)/ 8.419600315D-03/
C * DATA FOR ELEMENT P
      DATA DRAY(15, 1)/  4.78529978D0  /,DCMP(15, 1)/-0.476900011D0  /
      DATA DRAY(15, 2)/ 0.168709993D0  /,DCMP(15, 2)/  1.46029997D0  /
      DATA DRAY(15, 3)/-0.360379994D0  /,DCMP(15, 3)/-0.251329988D0  /
      DATA DRAY(15, 4)/ 1.971499994D-02/,DCMP(15, 4)/ 1.071999967D-02/
C * DATA FOR ELEMENT S
      DATA DRAY(16, 1)/  4.92710018D0  /,DCMP(16, 1)/-0.656419992D0  /
      DATA DRAY(16, 2)/ 0.165749997D0  /,DCMP(16, 2)/  1.65409994D0  /
      DATA DRAY(16, 3)/-0.359420002D0  /,DCMP(16, 3)/-0.298619986D0  /
      DATA DRAY(16, 4)/ 1.955099963D-02/,DCMP(16, 4)/ 1.429800037D-02/
C * DATA FOR ELEMENT CL
      DATA DRAY(17, 1)/  5.07219982D0  /,DCMP(17, 1)/-0.718630016D0  /
      DATA DRAY(17, 2)/ 0.149130002D0  /,DCMP(17, 2)/  1.74290001D0  /
      DATA DRAY(17, 3)/-0.352860004D0  /,DCMP(17, 3)/-0.319429994D0  /
      DATA DRAY(17, 4)/ 1.894400083D-02/,DCMP(17, 4)/ 1.584300026D-02/
C * DATA FOR ELEMENT AR
      DATA DRAY(18, 1)/  5.21080017D0  /,DCMP(18, 1)/-0.682110012D0  /
      DATA DRAY(18, 2)/ 0.135619998D0  /,DCMP(18, 2)/  1.74280000D0  /
      DATA DRAY(18, 3)/-0.347209990D0  /,DCMP(18, 3)/-0.317649990D0  /
      DATA DRAY(18, 4)/ 1.843300089D-02/,DCMP(18, 4)/ 1.564699970D-02/
C * DATA FOR ELEMENT K
      DATA DRAY(19, 1)/  5.25589991D0  /,DCMP(19, 1)/-0.344009995D0  /
      DATA DRAY(19, 2)/ 0.188040003D0  /,DCMP(19, 2)/  1.49240005D0  /
      DATA DRAY(19, 3)/-0.359620005D0  /,DCMP(19, 3)/-0.254139990D0  /
      DATA DRAY(19, 4)/ 1.930800080D-02/,DCMP(19, 4)/ 1.076800004D-02/
C * DATA FOR ELEMENT CA
      DATA DRAY(20, 1)/  5.32380009D0  /,DCMP(20, 1)/-9.824199975D-02/
      DATA DRAY(20, 2)/ 0.206689999D0  /,DCMP(20, 2)/  1.32830000D0  /
      DATA DRAY(20, 3)/-0.361660004D0  /,DCMP(20, 3)/-0.213750005D0  /
      DATA DRAY(20, 4)/ 1.933299936D-02/,DCMP(20, 4)/ 7.730599958D-03/
C * DATA FOR ELEMENT SC
      DATA DRAY(21, 1)/  5.43940020D0  /,DCMP(21, 1)/-0.159830004D0  /
      DATA DRAY(21, 2)/ 0.200169995D0  /,DCMP(21, 2)/  1.39059997D0  /
      DATA DRAY(21, 3)/-0.359059989D0  /,DCMP(21, 3)/-0.225850001D0  /
      DATA DRAY(21, 4)/ 1.910299994D-02/,DCMP(21, 4)/ 8.519499563D-03/
C * DATA FOR ELEMENT TI
      DATA DRAY(22, 1)/  5.55039978D0  /,DCMP(22, 1)/-0.230570003D0  /
      DATA DRAY(22, 2)/ 0.197699994D0  /,DCMP(22, 2)/  1.45850003D0  /
      DATA DRAY(22, 3)/-0.357690006D0  /,DCMP(22, 3)/-0.239160001D0  /
      DATA DRAY(22, 4)/ 1.898699999D-02/,DCMP(22, 4)/ 9.385299869D-03/
C * DATA FOR ELEMENT V
      DATA DRAY(23, 1)/  5.65509987D0  /,DCMP(23, 1)/-0.308099985D0  /
      DATA DRAY(23, 2)/ 0.199530005D0  /,DCMP(23, 2)/  1.52880001D0  /
      DATA DRAY(23, 3)/-0.357490003D0  /,DCMP(23, 3)/-0.252770007D0  /
      DATA DRAY(23, 4)/ 1.896899939D-02/,DCMP(23, 4)/ 1.025700010D-02/
C * DATA FOR ELEMENT CR
      DATA DRAY(24, 1)/  5.77400017D0  /,DCMP(24, 1)/-0.387639999D0  /
      DATA DRAY(24, 2)/ 0.203860000D0  /,DCMP(24, 2)/  1.59730005D0  /
      DATA DRAY(24, 3)/-0.359699994D0  /,DCMP(24, 3)/-0.266240001D0  /
      DATA DRAY(24, 4)/ 1.922200061D-02/,DCMP(24, 4)/ 1.115200017D-02/
C * DATA FOR ELEMENT MN
      DATA DRAY(25, 1)/  5.84600019D0  /,DCMP(25, 1)/-0.247060001D0  /
      DATA DRAY(25, 2)/ 0.213809997D0  /,DCMP(25, 2)/  1.49720001D0  /
      DATA DRAY(25, 3)/-0.359719992D0  /,DCMP(25, 3)/-0.238780007D0  /
      DATA DRAY(25, 4)/ 1.914599910D-02/,DCMP(25, 4)/ 8.932099678D-03/
C * DATA FOR ELEMENT FE
      DATA DRAY(26, 1)/  5.93289995D0  /,DCMP(26, 1)/-0.342379987D0  /
      DATA DRAY(26, 2)/ 0.225040004D0  /,DCMP(26, 2)/  1.57249999D0  /
      DATA DRAY(26, 3)/-0.361750007D0  /,DCMP(26, 3)/-0.253199995D0  /
      DATA DRAY(26, 4)/ 1.930199936D-02/,DCMP(26, 4)/ 9.858200327D-03/
C * DATA FOR ELEMENT CO
      DATA DRAY(27, 1)/  6.01480007D0  /,DCMP(27, 1)/-0.428799987D0  /
      DATA DRAY(27, 2)/ 0.237959996D0  /,DCMP(27, 2)/  1.64129996D0  /
      DATA DRAY(27, 3)/-0.364060014D0  /,DCMP(27, 3)/-0.266009986D0  /
      DATA DRAY(27, 4)/ 1.947499998D-02/,DCMP(27, 4)/ 1.065099984D-02/
C * DATA FOR ELEMENT NI
      DATA DRAY(28, 1)/  6.09200001D0  /,DCMP(28, 1)/-0.504360020D0  /
      DATA DRAY(28, 2)/ 0.252279997D0  /,DCMP(28, 2)/  1.70039999D0  /
      DATA DRAY(28, 3)/-0.366569996D0  /,DCMP(28, 3)/-0.276439995D0  /
      DATA DRAY(28, 4)/ 1.965899952D-02/,DCMP(28, 4)/ 1.126299985D-02/
C * DATA FOR ELEMENT CU
      DATA DRAY(29, 1)/  6.17740011D0  /,DCMP(29, 1)/-0.570209980D0  /
      DATA DRAY(29, 2)/ 0.273119986D0  /,DCMP(29, 2)/  1.75039995D0  /
      DATA DRAY(29, 3)/-0.372359991D0  /,DCMP(29, 3)/-0.284550011D0  /
      DATA DRAY(29, 4)/ 2.016399987D-02/,DCMP(29, 4)/ 1.169299986D-02/
C * DATA FOR ELEMENT ZN
      DATA DRAY(30, 1)/  6.23400021D0  /,DCMP(30, 1)/-0.420529991D0  /
      DATA DRAY(30, 2)/ 0.284310013D0  /,DCMP(30, 2)/  1.63399994D0  /
      DATA DRAY(30, 3)/-0.372139990D0  /,DCMP(30, 3)/-0.253650010D0  /
      DATA DRAY(30, 4)/ 2.005299926D-02/,DCMP(30, 4)/ 9.272299707D-03/
C * DATA FOR ELEMENT GA
      DATA DRAY(31, 1)/  6.28299999D0  /,DCMP(31, 1)/-0.358220011D0  /
      DATA DRAY(31, 2)/ 0.291330010D0  /,DCMP(31, 2)/  1.60049999D0  /
      DATA DRAY(31, 3)/-0.369390011D0  /,DCMP(31, 3)/-0.244910002D0  /
      DATA DRAY(31, 4)/ 1.970300078D-02/,DCMP(31, 4)/ 8.619000204D-03/
C * DATA FOR ELEMENT GE
      DATA DRAY(32, 1)/  6.33900023D0  /,DCMP(32, 1)/-0.334380001D0  /
      DATA DRAY(32, 2)/ 0.291509986D0  /,DCMP(32, 2)/  1.60239995D0  /
      DATA DRAY(32, 3)/-0.365640014D0  /,DCMP(32, 3)/-0.245550007D0  /
      DATA DRAY(32, 4)/ 1.929000020D-02/,DCMP(32, 4)/ 8.712399751D-03/
C * DATA FOR ELEMENT AS
      DATA DRAY(33, 1)/  6.39750004D0  /,DCMP(33, 1)/-0.339190006D0  /
      DATA DRAY(33, 2)/ 0.288870007D0  /,DCMP(33, 2)/  1.62530005D0  /
      DATA DRAY(33, 3)/-0.361750007D0  /,DCMP(33, 3)/-0.250779986D0  /
      DATA DRAY(33, 4)/ 1.887900010D-02/,DCMP(33, 4)/ 9.091000073D-03/
C * DATA FOR ELEMENT SE
      DATA DRAY(34, 1)/  6.45639992D0  /,DCMP(34, 1)/-0.432929993D0  /
      DATA DRAY(34, 2)/ 0.286740005D0  /,DCMP(34, 2)/  1.72829998D0  /
      DATA DRAY(34, 3)/-0.358790010D0  /,DCMP(34, 3)/-0.277139992D0  /
      DATA DRAY(34, 4)/ 1.856200024D-02/,DCMP(34, 4)/ 1.117299963D-02/
C * DATA FOR ELEMENT BR
      DATA DRAY(35, 1)/  6.51440001D0  /,DCMP(35, 1)/-0.448000014D0  /
      DATA DRAY(35, 2)/ 0.286320001D0  /,DCMP(35, 2)/  1.76080000D0  /
      DATA DRAY(35, 3)/-0.357030004D0  /,DCMP(35, 3)/-0.285100013D0  /
      DATA DRAY(35, 4)/ 1.835599914D-02/,DCMP(35, 4)/ 1.178599987D-02/
C * DATA FOR ELEMENT KR
      DATA DRAY(36, 1)/  6.57130003D0  /,DCMP(36, 1)/-0.391810000D0  /
      DATA DRAY(36, 2)/ 0.287710011D0  /,DCMP(36, 2)/  1.73010004D0  /
      DATA DRAY(36, 3)/-0.356310010D0  /,DCMP(36, 3)/-0.276820004D0  /
      DATA DRAY(36, 4)/ 1.824700087D-02/,DCMP(36, 4)/ 1.128000021D-02/
C * DATA FOR ELEMENT RB
      DATA DRAY(37, 1)/  6.59749985D0  /,DCMP(37, 1)/-0.128040001D0  /
      DATA DRAY(37, 2)/ 0.302390009D0  /,DCMP(37, 2)/  1.53040004D0  /
      DATA DRAY(37, 3)/-0.356750011D0  /,DCMP(37, 3)/-0.227400005D0  /
      DATA DRAY(37, 4)/ 1.817099936D-02/,DCMP(37, 4)/ 7.390299812D-03/
C * DATA FOR ELEMENT SR
      DATA DRAY(38, 1)/  6.62200022D0  /,DCMP(38, 1)/ 7.991600037D-02/
      DATA DRAY(38, 2)/ 0.324559987D0  /,DCMP(38, 2)/  1.38399994D0  /
      DATA DRAY(38, 3)/-0.361649990D0  /,DCMP(38, 3)/-0.192220002D0  /
      DATA DRAY(38, 4)/ 1.847999915D-02/,DCMP(38, 4)/ 4.786099773D-03/
C * DATA FOR ELEMENT Y
      DATA DRAY(39, 1)/  6.67100000D0  /,DCMP(39, 1)/ 6.290599704D-02/
      DATA DRAY(39, 2)/ 0.325080007D0  /,DCMP(39, 2)/  1.41579998D0  /
      DATA DRAY(39, 3)/-0.360610008D0  /,DCMP(39, 3)/-0.199709997D0  /
      DATA DRAY(39, 4)/ 1.833299920D-02/,DCMP(39, 4)/ 5.333099980D-03/
C * DATA FOR ELEMENT ZR
      DATA DRAY(40, 1)/  6.72279978D0  /,DCMP(40, 1)/ 3.666999936D-02/
      DATA DRAY(40, 2)/ 0.323960006D0  /,DCMP(40, 2)/  1.45210004D0  /
      DATA DRAY(40, 3)/-0.359459996D0  /,DCMP(40, 3)/-0.208120003D0  /
      DATA DRAY(40, 4)/ 1.818899997D-02/,DCMP(40, 4)/ 5.951399915D-03/
C * DATA FOR ELEMENT NB
      DATA DRAY(41, 1)/  6.79010010D0  /,DCMP(41, 1)/ 2.022900007D-04/
      DATA DRAY(41, 2)/ 0.311280012D0  /,DCMP(41, 2)/  1.49349999D0  /
      DATA DRAY(41, 3)/-0.355230004D0  /,DCMP(41, 3)/-0.217419997D0  /
      DATA DRAY(41, 4)/ 1.782299951D-02/,DCMP(41, 4)/ 6.622400135D-03/
C * DATA FOR ELEMENT MO
      DATA DRAY(42, 1)/  6.84600019D0  /,DCMP(42, 1)/-5.628599972D-02/
      DATA DRAY(42, 2)/ 0.302800000D0  /,DCMP(42, 2)/  1.55780005D0  /
      DATA DRAY(42, 3)/-0.351130009D0  /,DCMP(42, 3)/-0.233339995D0  /
      DATA DRAY(42, 4)/ 1.744000055D-02/,DCMP(42, 4)/ 7.855099626D-03/
C * DATA FOR ELEMENT TC
      DATA DRAY(43, 1)/  6.87599993D0  /,DCMP(43, 1)/ 7.576200366D-02/
      DATA DRAY(43, 2)/ 0.326160014D0  /,DCMP(43, 2)/  1.44949996D0  /
      DATA DRAY(43, 3)/-0.358969986D0  /,DCMP(43, 3)/-0.204889998D0  /
      DATA DRAY(43, 4)/ 1.804799959D-02/,DCMP(43, 4)/ 5.647500046D-03/
C * DATA FOR ELEMENT RU
      DATA DRAY(44, 1)/  6.93139982D0  /,DCMP(44, 1)/-4.249799997D-02/
      DATA DRAY(44, 2)/ 0.334789991D0  /,DCMP(44, 2)/  1.54639995D0  /
      DATA DRAY(44, 3)/-0.363499999D0  /,DCMP(44, 3)/-0.226469994D0  /
      DATA DRAY(44, 4)/ 1.844299957D-02/,DCMP(44, 4)/ 7.183799986D-03/
C * DATA FOR ELEMENT RH
      DATA DRAY(45, 1)/  6.97550011D0  /,DCMP(45, 1)/-0.160400003D0  /
      DATA DRAY(45, 2)/ 0.346390009D0  /,DCMP(45, 2)/  1.64859998D0  /
      DATA DRAY(45, 3)/-0.367790014D0  /,DCMP(45, 3)/-0.250239998D0  /
      DATA DRAY(45, 4)/ 1.878800057D-02/,DCMP(45, 4)/ 8.938199840D-03/
C * DATA FOR ELEMENT PD
      DATA DRAY(46, 1)/  7.03219986D0  /,DCMP(46, 1)/-0.267560005D0  /
      DATA DRAY(46, 2)/ 0.349839985D0  /,DCMP(46, 2)/  1.73740005D0  /
      DATA DRAY(46, 3)/-0.370099992D0  /,DCMP(46, 3)/-0.269879997D0  /
      DATA DRAY(46, 4)/ 1.899800077D-02/,DCMP(46, 4)/ 1.032499969D-02/
C * DATA FOR ELEMENT AG
      DATA DRAY(47, 1)/  7.06449986D0  /,DCMP(47, 1)/-0.166470006D0  /
      DATA DRAY(47, 2)/ 0.363460004D0  /,DCMP(47, 2)/  1.65789998D0  /
      DATA DRAY(47, 3)/-0.373600006D0  /,DCMP(47, 3)/-0.248740003D0  /
      DATA DRAY(47, 4)/ 1.924799941D-02/,DCMP(47, 4)/ 8.662199602D-03/
C * DATA FOR ELEMENT CD
      DATA DRAY(48, 1)/  7.09859991D0  /,DCMP(48, 1)/-5.166999996D-02/
      DATA DRAY(48, 2)/ 0.372200012D0  /,DCMP(48, 2)/  1.57430005D0  /
      DATA DRAY(48, 3)/-0.375340015D0  /,DCMP(48, 3)/-0.227650002D0  /
      DATA DRAY(48, 4)/ 1.934799924D-02/,DCMP(48, 4)/ 7.056499831D-03/
C * DATA FOR ELEMENT IN
      DATA DRAY(49, 1)/  7.12709999D0  /,DCMP(49, 1)/-8.172799833D-03/
      DATA DRAY(49, 2)/ 0.382079989D0  /,DCMP(49, 2)/  1.55869997D0  /
      DATA DRAY(49, 3)/-0.376850009D0  /,DCMP(49, 3)/-0.224490002D0  /
      DATA DRAY(49, 4)/ 1.941500045D-02/,DCMP(49, 4)/ 6.857799832D-03/
C * DATA FOR ELEMENT SN
      DATA DRAY(50, 1)/  7.16090012D0  /,DCMP(50, 1)/ 1.421499997D-02/
      DATA DRAY(50, 2)/ 0.385509998D0  /,DCMP(50, 2)/  1.55750000D0  /
      DATA DRAY(50, 3)/-0.376480013D0  /,DCMP(50, 3)/-0.224739999D0  /
      DATA DRAY(50, 4)/ 1.933000050D-02/,DCMP(50, 4)/ 6.914000027D-03/
C * DATA FOR ELEMENT SB
      DATA DRAY(51, 1)/  7.19670010D0  /,DCMP(51, 1)/ 1.563600078D-02/
      DATA DRAY(51, 2)/ 0.385540009D0  /,DCMP(51, 2)/  1.57179999D0  /
      DATA DRAY(51, 3)/-0.375050008D0  /,DCMP(51, 3)/-0.228750005D0  /
      DATA DRAY(51, 4)/ 1.916100085D-02/,DCMP(51, 4)/ 7.263899781D-03/
C * DATA FOR ELEMENT TE
      DATA DRAY(52, 1)/  7.23460007D0  /,DCMP(52, 1)/-4.075799882D-02/
      DATA DRAY(52, 2)/ 0.382490009D0  /,DCMP(52, 2)/  1.64269996D0  /
      DATA DRAY(52, 3)/-0.372709990D0  /,DCMP(52, 3)/-0.247899994D0  /
      DATA DRAY(52, 4)/ 1.891900040D-02/,DCMP(52, 4)/ 8.805699646D-03/
C * DATA FOR ELEMENT I
      DATA DRAY(53, 1)/  7.27409983D0  /,DCMP(53, 1)/-4.044200107D-02/
      DATA DRAY(53, 2)/ 0.377220005D0  /,DCMP(53, 2)/  1.65600002D0  /
      DATA DRAY(53, 3)/-0.369729996D0  /,DCMP(53, 3)/-0.251069993D0  /
      DATA DRAY(53, 4)/ 1.862799935D-02/,DCMP(53, 4)/ 9.048700333D-03/
C * DATA FOR ELEMENT XE
      DATA DRAY(54, 1)/  7.31470013D0  /,DCMP(54, 1)/-2.824099967D-03/
      DATA DRAY(54, 2)/ 0.370310009D0  /,DCMP(54, 2)/  1.64040005D0  /
      DATA DRAY(54, 3)/-0.366279989D0  /,DCMP(54, 3)/-0.247639999D0  /
      DATA DRAY(54, 4)/ 1.830299944D-02/,DCMP(54, 4)/ 8.821399882D-03/
C * DATA FOR ELEMENT CS
      DATA DRAY(55, 1)/  7.33489990D0  /,DCMP(55, 1)/ 0.184860006D0  /
      DATA DRAY(55, 2)/ 0.376830012D0  /,DCMP(55, 2)/  1.50030005D0  /
      DATA DRAY(55, 3)/-0.365709990D0  /,DCMP(55, 3)/-0.213330001D0  /
      DATA DRAY(55, 4)/ 1.818400063D-02/,DCMP(55, 4)/ 6.242599804D-03/
C * DATA FOR ELEMENT BA
      DATA DRAY(56, 1)/  7.35809994D0  /,DCMP(56, 1)/ 0.344379991D0  /
      DATA DRAY(56, 2)/ 0.379359990D0  /,DCMP(56, 2)/  1.38740003D0  /
      DATA DRAY(56, 3)/-0.364100009D0  /,DCMP(56, 3)/-0.186360002D0  /
      DATA DRAY(56, 4)/ 1.798200049D-02/,DCMP(56, 4)/ 4.249200225D-03/
C * DATA FOR ELEMENT LA
      DATA DRAY(57, 1)/  7.39529991D0  /,DCMP(57, 1)/ 0.409099996D0  /
      DATA DRAY(57, 2)/ 0.369899988D0  /,DCMP(57, 2)/  1.33070004D0  /
      DATA DRAY(57, 3)/-0.359380007D0  /,DCMP(57, 3)/-0.170880005D0  /
      DATA DRAY(57, 4)/ 1.754100062D-02/,DCMP(57, 4)/ 3.041099990D-03/
C * DATA FOR ELEMENT CE
      DATA DRAY(58, 1)/  7.44259977D0  /,DCMP(58, 1)/ 0.439880013D0  /
      DATA DRAY(58, 2)/ 0.371329993D0  /,DCMP(58, 2)/  1.30920005D0  /
      DATA DRAY(58, 3)/-0.359640002D0  /,DCMP(58, 3)/-0.164550006D0  /
      DATA DRAY(58, 4)/ 1.758500002D-02/,DCMP(58, 4)/ 2.526399912D-03/
C * DATA FOR ELEMENT PR
      DATA DRAY(59, 1)/  7.48350000D0  /,DCMP(59, 1)/ 0.449119985D0  /
      DATA DRAY(59, 2)/ 0.368429989D0  /,DCMP(59, 2)/  1.30350006D0  /
      DATA DRAY(59, 3)/-0.357690006D0  /,DCMP(59, 3)/-0.161840007D0  /
      DATA DRAY(59, 4)/ 1.741000079D-02/,DCMP(59, 4)/ 2.273899969D-03/
C * DATA FOR ELEMENT ND
      DATA DRAY(60, 1)/  7.52330017D0  /,DCMP(60, 1)/ 0.437279999D0  /
      DATA DRAY(60, 2)/ 0.366459996D0  /,DCMP(60, 2)/  1.31369996D0  /
      DATA DRAY(60, 3)/-0.356050014D0  /,DCMP(60, 3)/-0.162870005D0  /
      DATA DRAY(60, 4)/ 1.726200059D-02/,DCMP(60, 4)/ 2.293800004D-03/
C * DATA FOR ELEMENT PM
      DATA DRAY(61, 1)/  7.56220007D0  /,DCMP(61, 1)/ 0.405820012D0  /
      DATA DRAY(61, 2)/ 0.365049988D0  /,DCMP(61, 2)/  1.33840001D0  /
      DATA DRAY(61, 3)/-0.354510009D0  /,DCMP(61, 3)/-0.167229995D0  /
      DATA DRAY(61, 4)/ 1.712100022D-02/,DCMP(61, 4)/ 2.555700019D-03/
C * DATA FOR ELEMENT SM
      DATA DRAY(62, 1)/  7.60020018D0  /,DCMP(62, 1)/ 0.355379999D0  /
      DATA DRAY(62, 2)/ 0.364129990D0  /,DCMP(62, 2)/  1.37730002D0  /
      DATA DRAY(62, 3)/-0.353089988D0  /,DCMP(62, 3)/-0.174940005D0  /
      DATA DRAY(62, 4)/ 1.698900014D-02/,DCMP(62, 4)/ 3.062099917D-03/
C * DATA FOR ELEMENT EU
      DATA DRAY(63, 1)/  7.63710022D0  /,DCMP(63, 1)/ 0.280319989D0  /
      DATA DRAY(63, 2)/ 0.363959998D0  /,DCMP(63, 2)/  1.44019997D0  /
      DATA DRAY(63, 3)/-0.351920009D0  /,DCMP(63, 3)/-0.188639998D0  /
      DATA DRAY(63, 4)/ 1.687799953D-02/,DCMP(63, 4)/ 4.012300167D-03/
C * DATA FOR ELEMENT GD
      DATA DRAY(64, 1)/  7.66940022D0  /,DCMP(64, 1)/ 0.273130000D0  /
      DATA DRAY(64, 2)/ 0.359750003D0  /,DCMP(64, 2)/  1.43840003D0  /
      DATA DRAY(64, 3)/-0.348899990D0  /,DCMP(64, 3)/-0.186140001D0  /
      DATA DRAY(64, 4)/ 1.658900082D-02/,DCMP(64, 4)/ 3.752399934D-03/
C * DATA FOR ELEMENT TB
      DATA DRAY(65, 1)/  7.70800018D0  /,DCMP(65, 1)/ 0.257539988D0  /
      DATA DRAY(65, 2)/ 0.365350008D0  /,DCMP(65, 2)/  1.45060003D0  /
      DATA DRAY(65, 3)/-0.350030005D0  /,DCMP(65, 3)/-0.187590003D0  /
      DATA DRAY(65, 4)/ 1.669299975D-02/,DCMP(65, 4)/ 3.799299942D-03/
C * DATA FOR ELEMENT DY
      DATA DRAY(66, 1)/  7.74189997D0  /,DCMP(66, 1)/ 0.242689997D0  /
      DATA DRAY(66, 2)/ 0.367110014D0  /,DCMP(66, 2)/  1.46270001D0  /
      DATA DRAY(66, 3)/-0.349429995D0  /,DCMP(66, 3)/-0.189099997D0  /
      DATA DRAY(66, 4)/ 1.662700064D-02/,DCMP(66, 4)/ 3.856299911D-03/
C * DATA FOR ELEMENT HO
      DATA DRAY(67, 1)/  7.77470016D0  /,DCMP(67, 1)/ 0.228489995D0  /
      DATA DRAY(67, 2)/ 0.369720012D0  /,DCMP(67, 2)/  1.47440004D0  /
      DATA DRAY(67, 3)/-0.349130005D0  /,DCMP(67, 3)/-0.190559998D0  /
      DATA DRAY(67, 4)/ 1.658600010D-02/,DCMP(67, 4)/ 3.909000196D-03/
C * DATA FOR ELEMENT ER
      DATA DRAY(68, 1)/  7.80639982D0  /,DCMP(68, 1)/ 0.215230003D0  /
      DATA DRAY(68, 2)/ 0.373230010D0  /,DCMP(68, 2)/  1.48549998D0  /
      DATA DRAY(68, 3)/-0.349150002D0  /,DCMP(68, 3)/-0.191909999D0  /
      DATA DRAY(68, 4)/ 1.657100022D-02/,DCMP(68, 4)/ 3.956499975D-03/
C * DATA FOR ELEMENT TM
      DATA DRAY(69, 1)/  7.83710003D0  /,DCMP(69, 1)/ 0.202659994D0  /
      DATA DRAY(69, 2)/ 0.377550006D0  /,DCMP(69, 2)/  1.49629998D0  /
      DATA DRAY(69, 3)/-0.349440008D0  /,DCMP(69, 3)/-0.193230003D0  /
      DATA DRAY(69, 4)/ 1.657800004D-02/,DCMP(69, 4)/ 4.002300091D-03/
C * DATA FOR ELEMENT YB
      DATA DRAY(70, 1)/  7.86660004D0  /,DCMP(70, 1)/ 0.202250004D0  /
      DATA DRAY(70, 2)/ 0.382930011D0  /,DCMP(70, 2)/  1.48800004D0  /
      DATA DRAY(70, 3)/-0.350129992D0  /,DCMP(70, 3)/-0.189140007D0  /
      DATA DRAY(70, 4)/ 1.661700010D-02/,DCMP(70, 4)/ 3.622600110D-03/
C * DATA FOR ELEMENT LU
      DATA DRAY(71, 1)/  7.89139986D0  /,DCMP(71, 1)/ 0.197180003D0  /
      DATA DRAY(71, 2)/ 0.386029989D0  /,DCMP(71, 2)/  1.50259995D0  /
      DATA DRAY(71, 3)/-0.349759996D0  /,DCMP(71, 3)/-0.192469999D0  /
      DATA DRAY(71, 4)/ 1.654800028D-02/,DCMP(71, 4)/ 3.857499920D-03/
C * DATA FOR ELEMENT HF
      DATA DRAY(72, 1)/  7.91800022D0  /,DCMP(72, 1)/ 0.199469998D0  /
      DATA DRAY(72, 2)/ 0.387019992D0  /,DCMP(72, 2)/  1.50230002D0  /
      DATA DRAY(72, 3)/-0.348879993D0  /,DCMP(72, 3)/-0.191389993D0  /
      DATA DRAY(72, 4)/ 1.644100063D-02/,DCMP(72, 4)/ 3.740099957D-03/
C * DATA FOR ELEMENT TA
      DATA DRAY(73, 1)/  7.94530010D0  /,DCMP(73, 1)/ 0.196869999D0  /
      DATA DRAY(73, 2)/ 0.387300014D0  /,DCMP(73, 2)/  1.50619996D0  /
      DATA DRAY(73, 3)/-0.347930014D0  /,DCMP(73, 3)/-0.191400006D0  /
      DATA DRAY(73, 4)/ 1.633000001D-02/,DCMP(73, 4)/ 3.708899952D-03/
C * DATA FOR ELEMENT W
      DATA DRAY(74, 1)/  7.97270012D0  /,DCMP(74, 1)/ 0.191019997D0  /
      DATA DRAY(74, 2)/ 0.387699991D0  /,DCMP(74, 2)/  1.51240003D0  /
      DATA DRAY(74, 3)/-0.347160012D0  /,DCMP(74, 3)/-0.191919997D0  /
      DATA DRAY(74, 4)/ 1.623700000D-02/,DCMP(74, 4)/ 3.714499995D-03/
C * DATA FOR ELEMENT RE
      DATA DRAY(75, 1)/  7.99940014D0  /,DCMP(75, 1)/ 0.189640000D0  /
      DATA DRAY(75, 2)/ 0.388740003D0  /,DCMP(75, 2)/  1.50870001D0  /
      DATA DRAY(75, 3)/-0.346729994D0  /,DCMP(75, 3)/-0.189569995D0  /
      DATA DRAY(75, 4)/ 1.617500000D-02/,DCMP(75, 4)/ 3.495800076D-03/
C * DATA FOR ELEMENT OS
      DATA DRAY(76, 1)/  8.02569962D0  /,DCMP(76, 1)/ 0.116449997D0  /
      DATA DRAY(76, 2)/ 0.390460014D0  /,DCMP(76, 2)/  1.57609999D0  /
      DATA DRAY(76, 3)/-0.346659988D0  /,DCMP(76, 3)/-0.205530003D0  /
      DATA DRAY(76, 4)/ 1.614500023D-02/,DCMP(76, 4)/ 4.667299800D-03/
C * DATA FOR ELEMENT IR
      DATA DRAY(77, 1)/  8.05150032D0  /,DCMP(77, 1)/ 7.199099660D-02/
      DATA DRAY(77, 2)/ 0.393139988D0  /,DCMP(77, 2)/  1.61199999D0  /
      DATA DRAY(77, 3)/-0.347050011D0  /,DCMP(77, 3)/-0.213190004D0  /
      DATA DRAY(77, 4)/ 1.615699939D-02/,DCMP(77, 4)/ 5.204999819D-03/
C * DATA FOR ELEMENT PT
      DATA DRAY(78, 1)/  8.08080006D0  /,DCMP(78, 1)/ 4.201899841D-02/
      DATA DRAY(78, 2)/ 0.395790011D0  /,DCMP(78, 2)/  1.63610005D0  /
      DATA DRAY(78, 3)/-0.348030001D0  /,DCMP(78, 3)/-0.217960000D0  /
      DATA DRAY(78, 4)/ 1.623499952D-02/,DCMP(78, 4)/ 5.526700057D-03/
C * DATA FOR ELEMENT AU
      DATA DRAY(79, 1)/  8.10519981D0  /,DCMP(79, 1)/ 1.569199935D-02/
      DATA DRAY(79, 2)/ 0.400579989D0  /,DCMP(79, 2)/  1.65409994D0  /
      DATA DRAY(79, 3)/-0.349339992D0  /,DCMP(79, 3)/-0.220980003D0  /
      DATA DRAY(79, 4)/ 1.632600091D-02/,DCMP(79, 4)/ 5.707500037D-03/
C * DATA FOR ELEMENT HG
      DATA DRAY(80, 1)/  8.12539959D0  /,DCMP(80, 1)/ 0.114589997D0  /
      DATA DRAY(80, 2)/ 0.405860007D0  /,DCMP(80, 2)/  1.58080006D0  /
      DATA DRAY(80, 3)/-0.350329995D0  /,DCMP(80, 3)/-0.202969998D0  /
      DATA DRAY(80, 4)/ 1.637700014D-02/,DCMP(80, 4)/ 4.356900230D-03/
C * DATA FOR ELEMENT TL
      DATA DRAY(81, 1)/  8.14400005D0  /,DCMP(81, 1)/ 0.147049993D0  /
      DATA DRAY(81, 2)/ 0.408690006D0  /,DCMP(81, 2)/  1.56690001D0  /
      DATA DRAY(81, 3)/-0.349799991D0  /,DCMP(81, 3)/-0.200350001D0  /
      DATA DRAY(81, 4)/ 1.628899947D-02/,DCMP(81, 4)/ 4.209000152D-03/
C * DATA FOR ELEMENT PB
      DATA DRAY(82, 1)/  8.15999985D0  /,DCMP(82, 1)/ 0.182170004D0  /
      DATA DRAY(82, 2)/ 0.418029994D0  /,DCMP(82, 2)/  1.54659998D0  /
      DATA DRAY(82, 3)/-0.352329999D0  /,DCMP(82, 3)/-0.195789993D0  /
      DATA DRAY(82, 4)/ 1.646599919D-02/,DCMP(82, 4)/ 3.907700069D-03/
C * DATA FOR ELEMENT BI
      DATA DRAY(83, 1)/  8.17490005D0  /,DCMP(83, 1)/ 0.189860001D0  /
      DATA DRAY(83, 2)/ 0.427920014D0  /,DCMP(83, 2)/  1.56120002D0  /
      DATA DRAY(83, 3)/-0.355069995D0  /,DCMP(83, 3)/-0.200929999D0  /
      DATA DRAY(83, 4)/ 1.665999927D-02/,DCMP(83, 4)/ 4.367699847D-03/
C * DATA FOR ELEMENT PO
      DATA DRAY(84, 1)/  8.19359970D0  /,DCMP(84, 1)/ 0.194100007D0  /
      DATA DRAY(84, 2)/ 0.434500009D0  /,DCMP(84, 2)/  1.57790005D0  /
      DATA DRAY(84, 3)/-0.357190013D0  /,DCMP(84, 3)/-0.205149993D0  /
      DATA DRAY(84, 4)/ 1.683500037D-02/,DCMP(84, 4)/ 4.707800224D-03/
C * DATA FOR ELEMENT AT
      DATA DRAY(85, 1)/  8.20750046D0  /,DCMP(85, 1)/ 0.195850000D0  /
      DATA DRAY(85, 2)/ 0.443300009D0  /,DCMP(85, 2)/  1.59249997D0  /
      DATA DRAY(85, 3)/-0.359880000D0  /,DCMP(85, 3)/-0.209830001D0  /
      DATA DRAY(85, 4)/ 1.698499918D-02/,DCMP(85, 4)/ 5.121100228D-03/
C * DATA FOR ELEMENT RN
      DATA DRAY(86, 1)/  8.22550011D0  /,DCMP(86, 1)/ 0.196620002D0  /
      DATA DRAY(86, 2)/ 0.451480001D0  /,DCMP(86, 2)/  1.60080004D0  /
      DATA DRAY(86, 3)/-0.362060010D0  /,DCMP(86, 3)/-0.213799998D0  /
      DATA DRAY(86, 4)/ 1.715599932D-02/,DCMP(86, 4)/ 5.517200101D-03/
C * DATA FOR ELEMENT FR
      DATA DRAY(87, 1)/  8.23349953D0  /,DCMP(87, 1)/ 0.193220004D0  /
      DATA DRAY(87, 2)/ 0.460599989D0  /,DCMP(87, 2)/  1.61670005D0  /
      DATA DRAY(87, 3)/-0.364410013D0  /,DCMP(87, 3)/-0.217370003D0  /
      DATA DRAY(87, 4)/ 1.727100089D-02/,DCMP(87, 4)/ 5.795000121D-03/
C * DATA FOR ELEMENT RA
      DATA DRAY(88, 1)/  8.24709988D0  /,DCMP(88, 1)/ 0.189150006D0  /
      DATA DRAY(88, 2)/ 0.468199998D0  /,DCMP(88, 2)/  1.62730002D0  /
      DATA DRAY(88, 3)/-0.365990013D0  /,DCMP(88, 3)/-0.220500007D0  /
      DATA DRAY(88, 4)/ 1.738899946D-02/,DCMP(88, 4)/ 6.078000180D-03/
C * DATA FOR ELEMENT AC
      DATA DRAY(89, 1)/  8.26220036D0  /,DCMP(89, 1)/ 0.181580007D0  /
      DATA DRAY(89, 2)/ 0.474400014D0  /,DCMP(89, 2)/  1.64059997D0  /
      DATA DRAY(89, 3)/-0.367009997D0  /,DCMP(89, 3)/-0.224219993D0  /
      DATA DRAY(89, 4)/ 1.747700013D-02/,DCMP(89, 4)/ 6.406699773D-03/
C * DATA FOR ELEMENT TH
      DATA DRAY(90, 1)/  8.27840042D0  /,DCMP(90, 1)/ 0.170890003D0  /
      DATA DRAY(90, 2)/ 0.479059994D0  /,DCMP(90, 2)/  1.65559995D0  /
      DATA DRAY(90, 3)/-0.367659986D0  /,DCMP(90, 3)/-0.229699999D0  /
      DATA DRAY(90, 4)/ 1.746200025D-02/,DCMP(90, 4)/ 6.925200112D-03/
C * DATA FOR ELEMENT PA
      DATA DRAY(91, 1)/  8.30169964D0  /,DCMP(91, 1)/ 0.144180000D0  /
      DATA DRAY(91, 2)/ 0.480199993D0  /,DCMP(91, 2)/  1.69449997D0  /
      DATA DRAY(91, 3)/-0.367549986D0  /,DCMP(91, 3)/-0.239150003D0  /
      DATA DRAY(91, 4)/ 1.751700044D-02/,DCMP(91, 4)/ 7.667399943D-03/
C * DATA FOR ELEMENT U
      DATA DRAY(92, 1)/  8.33010006D0  /,DCMP(92, 1)/ 0.108280003D0  /
      DATA DRAY(92, 2)/ 0.478309989D0  /,DCMP(92, 2)/  1.74160004D0  /
      DATA DRAY(92, 3)/-0.367249995D0  /,DCMP(92, 3)/-0.254099995D0  /
      DATA DRAY(92, 4)/ 1.741299964D-02/,DCMP(92, 4)/ 8.950600401D-03/
C * DATA FOR LI ELEMENT # 3
      DATA XKPCOR( 3)/ 1.000000000D-03/
      DATA RELCOR( 3)/ 1.000000047D-03/
      DATA (IFUNTYP(3, I), I = 1, 2)/2, 2/
      DATA (NPARMS( 3, I), I = 1, 2)/10, 10/
C * DATA FOR BE ELEMENT # 4
      DATA XKPCOR( 4)/ 0.000000000D-03/
      DATA RELCOR( 4)/ 1.000000047D-03/
      DATA (IFUNTYP(4, I), I = 1, 2)/2, 2/
      DATA (NPARMS( 4, I), I = 1, 2)/10, 10/
C * DATA FOR B  ELEMENT # 5
      DATA XKPCOR( 5)/ 1.000000000D-03/
      DATA RELCOR( 5)/ 2.000000095D-03/
      DATA (IFUNTYP(5, I), I = 1, 3)/2, 2, 2/
      DATA (NPARMS( 5, I), I = 1, 3)/10, 10, 10/
C * DATA FOR C  ELEMENT # 6
      DATA XKPCOR( 6)/ 1.000000000D-03/
      DATA RELCOR( 6)/ 3.000000026D-03/
      DATA (IFUNTYP(6, I), I = 1, 3)/2, 2, 2/
      DATA (NPARMS( 6, I), I = 1, 3)/10, 10, 10/
C * DATA FOR N  ELEMENT # 7
      DATA XKPCOR( 7)/ 2.000000000D-03/
      DATA RELCOR( 7)/ 4.999999888D-03/
      DATA (IFUNTYP(7, I), I = 1, 4)/2, 2, 2, 2/
      DATA (NPARMS( 7, I), I = 1, 4)/10, 10, 10, 10/
C * DATA FOR O  ELEMENT # 8
      DATA XKPCOR( 8)/ 3.000000000D-03/
      DATA RELCOR( 8)/ 7.000000216D-03/
      DATA (IFUNTYP(8, I), I = 1, 4)/2, 2, 2, 2/
      DATA (NPARMS( 8, I), I = 1, 4)/10, 10, 10, 10/
C * DATA FOR F  ELEMENT # 9
      DATA XKPCOR( 9)/ 4.000000000D-03/
      DATA RELCOR( 9)/ 8.999999613D-03/
      DATA (IFUNTYP(9, I), I = 1, 4)/2, 2, 2, 2/
      DATA (NPARMS( 9, I), I = 1, 4)/10, 10, 10, 10/
C * DATA FOR NE ELEMENT #10
      DATA XKPCOR(10)/ 4.000000000D-03/
      DATA RELCOR(10)/ 1.099999994D-02/
      DATA (IFUNTYP(10, I), I = 1, 4)/2, 2, 2, 2/
      DATA (NPARMS( 10, I), I = 1, 4)/10, 10, 10, 10/
C * DATA FOR NA ELEMENT #11
      DATA XKPCOR(11)/ 6.000000000D-03/
      DATA RELCOR(11)/ 1.400000043D-02/
      DATA (IFUNTYP(11, I), I = 1, 4)/0, 2, 2, 2/
      DATA (NPARMS( 11, I), I = 1, 4)/11, 10, 10, 10/
C * DATA FOR MG ELEMENT #12
      DATA XKPCOR(12)/ 8.000000000D-03/
      DATA RELCOR(12)/ 1.799999923D-02/
      DATA (IFUNTYP(12, I), I = 1, 4)/0, 2, 2, 2/
      DATA (NPARMS( 12, I), I = 1, 4)/11, 10, 10, 10/
C * DATA FOR AL ELEMENT #13
      DATA XKPCOR(13)/ 8.000000000D-03/
      DATA RELCOR(13)/ 2.099999972D-02/
      DATA (IFUNTYP(13, I), I = 1, 5)/0, 2, 2, 2, 2/
      DATA (NPARMS( 13, I), I = 1, 5)/11, 10, 10, 10, 10/
C * DATA FOR SI ELEMENT #14
      DATA XKPCOR(14)/ 1.100000000D-02/
      DATA RELCOR(14)/ 2.600000054D-02/
      DATA (IFUNTYP(14, I), I = 1, 6)/0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 14, I), I = 1, 6)/11, 10, 10, 10, 10, 10/
C * DATA FOR P  ELEMENT #15
      DATA XKPCOR(15)/ 1.200000000D-02/
      DATA RELCOR(15)/ 2.999999933D-02/
      DATA (IFUNTYP(15, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 15, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR S  ELEMENT #16
      DATA XKPCOR(16)/ 1.400000000D-02/
      DATA RELCOR(16)/ 3.500000015D-02/
      DATA (IFUNTYP(16, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 16, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR CL ELEMENT #17
      DATA XKPCOR(17)/ 1.700000000D-02/
      DATA RELCOR(17)/ 4.100000113D-02/
      DATA (IFUNTYP(17, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 17, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR AR ELEMENT #18
      DATA XKPCOR(18)/ 2.000000000D-02/
      DATA RELCOR(18)/ 4.699999839D-02/
      DATA (IFUNTYP(18, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 18, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR K  ELEMENT #19
      DATA XKPCOR(19)/ 2.200000000D-02/
      DATA RELCOR(19)/ 5.299999937D-02/
      DATA (IFUNTYP(19, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 19, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR CA ELEMENT #20
      DATA XKPCOR(20)/ 2.500000000D-02/
      DATA RELCOR(20)/ 5.999999866D-02/
      DATA (IFUNTYP(20, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 20, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR SC ELEMENT #21
      DATA XKPCOR(21)/ 2.800000000D-02/
      DATA RELCOR(21)/ 6.800000370D-02/
      DATA (IFUNTYP(21, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 21, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR TI ELEMENT #22
      DATA XKPCOR(22)/ 3.100000000D-02/
      DATA RELCOR(22)/ 7.500000298D-02/
      DATA (IFUNTYP(22, I), I = 1, 7)/0, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 22, I), I = 1, 7)/11, 10, 10, 10, 10, 10, 10/
C * DATA FOR V  ELEMENT #23
      DATA XKPCOR(23)/ 3.500000000D-02/
      DATA RELCOR(23)/ 8.399999887D-02/
      DATA (IFUNTYP(23, I), I = 1, 8)/0, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 23, I), I = 1, 8)/11, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR CR ELEMENT #24
      DATA XKPCOR(24)/ 3.900000000D-02/
      DATA RELCOR(24)/ 9.300000221D-02/
      DATA (IFUNTYP(24, I), I = 1, 9)/0, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 24, I), I = 1, 9)/11, 10, 10, 10, 10, 10, 10, 10,
     1 10/
C * DATA FOR MN ELEMENT #25
      DATA XKPCOR(25)/ 4.200000000D-02/
      DATA RELCOR(25)/ 0.101999998D0  /
      DATA (IFUNTYP(25, I), I = 1, 9)/0, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 25, I), I = 1, 9)/11, 10, 10, 10, 10, 10, 10, 10,
     1 10/
C * DATA FOR FE ELEMENT #26
      DATA XKPCOR(26)/ 4.800000000D-02/
      DATA RELCOR(26)/ 0.112999998D0  /
      DATA (IFUNTYP(26, I), I = 1, 9)/0, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 26, I), I = 1, 9)/11, 10, 10, 10, 10, 10, 10, 10,
     1 10/
C * DATA FOR CO ELEMENT #27
      DATA XKPCOR(27)/ 5.200000000D-02/
      DATA RELCOR(27)/ 0.123000003D0  /
      DATA (IFUNTYP(27, I), I = 1, 9)/0, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 27, I), I = 1, 9)/11, 10, 10, 10, 10, 10, 10, 10,
     1 10/
C * DATA FOR NI ELEMENT #28
      DATA XKPCOR(28)/ 5.700000000D-02/
      DATA RELCOR(28)/ 0.135000005D0  /
      DATA (IFUNTYP(28, I), I = 1, 9)/0, 0, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 28, I), I = 1, 9)/11, 11, 10, 10, 10, 10, 10, 10,
     1 10/
C * DATA FOR CU ELEMENT #29
      DATA XKPCOR(29)/ 6.100000000D-02/
      DATA RELCOR(29)/ 0.145999998D0  /
      DATA (IFUNTYP(29, I), I = 1, 9)/0, 0, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 29, I), I = 1, 9)/11, 11, 10, 10, 10, 10, 10, 10,
     1 10/
C * DATA FOR ZN ELEMENT #30
      DATA XKPCOR(30)/ 6.700000000D-02/
      DATA RELCOR(30)/ 0.158999994D0  /
      DATA (IFUNTYP(30, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 30, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR GA ELEMENT #31
      DATA XKPCOR(31)/ 7.300000000D-02/
      DATA RELCOR(31)/ 0.172000006D0  /
      DATA (IFUNTYP(31, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 31, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR GE ELEMENT #32
      DATA XKPCOR(32)/ 7.900000000D-02/
      DATA RELCOR(32)/ 0.186000004D0  /
      DATA (IFUNTYP(32, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 32, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR AS ELEMENT #33
      DATA XKPCOR(33)/ 8.500000000D-02/
      DATA RELCOR(33)/ 0.200000003D0  /
      DATA (IFUNTYP(33, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 33, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR SE ELEMENT #34
      DATA XKPCOR(34)/ 9.200000000D-02/
      DATA RELCOR(34)/ 0.215000004D0  /
      DATA (IFUNTYP(34, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 34, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR BR ELEMENT #35
      DATA XKPCOR(35)/ 9.900000000D-02/
      DATA RELCOR(35)/ 0.231000006D0  /
      DATA (IFUNTYP(35, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 35, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR KR ELEMENT #36
      DATA XKPCOR(36)/ 1.060000000D-01/
      DATA RELCOR(36)/ 0.246999994D0  /
      DATA (IFUNTYP(36, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 36, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR RB ELEMENT #37
      DATA XKPCOR(37)/ 1.140000000D-01/
      DATA RELCOR(37)/ 0.263999999D0  /
      DATA (IFUNTYP(37, I), I = 1, 9)/0, 0, 0, 0, 2, 2, 2, 2, 2/
      DATA (NPARMS( 37, I), I = 1, 9)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10/
C * DATA FOR SR ELEMENT #38
      DATA XKPCOR(38)/ 1.220000000D-01/
      DATA RELCOR(38)/ 0.282000005D0  /
      DATA (IFUNTYP(38, I), I = 1, 12)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2/
      DATA (NPARMS( 38, I), I = 1, 12)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10/
C * DATA FOR Y  ELEMENT #39
      DATA XKPCOR(39)/ 1.300000000D-01/
      DATA RELCOR(39)/ 0.300000012D0  /
      DATA (IFUNTYP(39, I), I = 1, 12)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2/
      DATA (NPARMS( 39, I), I = 1, 12)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10/
C * DATA FOR ZR ELEMENT #40
      DATA XKPCOR(40)/ 1.380000000D-01/
      DATA RELCOR(40)/ 0.319000006D0  /
      DATA (IFUNTYP(40, I), I = 1, 13)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2/
      DATA (NPARMS( 40, I), I = 1, 13)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10/
C * DATA FOR NB ELEMENT #41
      DATA XKPCOR(41)/ 1.470000000D-01/
      DATA RELCOR(41)/ 0.338000000D0  /
      DATA (IFUNTYP(41, I), I = 1, 13)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2/
      DATA (NPARMS( 41, I), I = 1, 13)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10/
C * DATA FOR MO ELEMENT #42
      DATA XKPCOR(42)/1.560000000D-01/
      DATA RELCOR(42)/ 0.358999997D0  /
      DATA (IFUNTYP(42, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 42, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR TC ELEMENT #43
      DATA XKPCOR(43)/1.660000000D-01/
      DATA RELCOR(43)/ 0.379999995D0  /
      DATA (IFUNTYP(43, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 43, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR RU ELEMENT #44
      DATA XKPCOR(44)/1.750000000D-01/
      DATA RELCOR(44)/ 0.400999993D0  /
      DATA (IFUNTYP(44, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 44, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR RH ELEMENT #45
      DATA XKPCOR(45)/1.860000000D-01/
      DATA RELCOR(45)/ 0.423999995D0  /
      DATA (IFUNTYP(45, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 45, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR PD ELEMENT #46
      DATA XKPCOR(46)/1.960000000D-01/
      DATA RELCOR(46)/ 0.446999997D0  /
      DATA (IFUNTYP(46, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 46, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR AG ELEMENT #47
      DATA XKPCOR(47)/2.070000000D-01/
      DATA RELCOR(47)/ 0.470999986D0  /
      DATA (IFUNTYP(47, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 47, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR CD ELEMENT #48
      DATA XKPCOR(48)/2.190000000D-01/
      DATA RELCOR(48)/ 0.495999992D0  /
      DATA (IFUNTYP(48, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 48, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR IN ELEMENT #49
      DATA XKPCOR(49)/2.30000000D-01/
      DATA RELCOR(49)/ 0.521000028D0  /
      DATA (IFUNTYP(49, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 49, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR SN ELEMENT #50
      DATA XKPCOR(50)/2.42000000D-01/
      DATA RELCOR(50)/ 0.546999991D0  /
      DATA (IFUNTYP(50, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 50, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR SB ELEMENT #51
      DATA XKPCOR(51)/2.55000000D-01/
      DATA RELCOR(51)/ 0.574999988D0  /
      DATA (IFUNTYP(51, I), I = 1, 14)/0, 0, 0, 0, 2, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 51, I), I = 1, 14)/11, 11, 11, 11, 10, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR TE ELEMENT #52
      DATA XKPCOR(52)/2.67000000D-01/
      DATA RELCOR(52)/ 0.601999998D0  /
      DATA (IFUNTYP(52, I), I = 1, 14)/0, 0, 0, 0, 0, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 52, I), I = 1, 14)/11, 11, 11, 11, 11, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR I  ELEMENT #53
      DATA XKPCOR(53)/2.81000000D-01/
      DATA RELCOR(53)/ 0.630999982D0  /
      DATA (IFUNTYP(53, I), I = 1, 14)/0, 0, 0, 0, 0, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 53, I), I = 1, 14)/11, 11, 11, 11, 11, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR XE ELEMENT #54
      DATA XKPCOR(54)/2.94000000D-01/
      DATA RELCOR(54)/ 0.660000026D0  /
      DATA (IFUNTYP(54, I), I = 1, 14)/0, 0, 0, 0, 0, 2, 2, 2, 2, 2,
     1 2, 2, 2, 2/
      DATA (NPARMS( 54, I), I = 1, 14)/11, 11, 11, 11, 11, 10, 10, 10,
     1 10, 10, 10, 10, 10, 10/
C * DATA FOR CS ELEMENT #55
      DATA XKPCOR(55)/3.08000000D-01/
      DATA RELCOR(55)/ 0.689999998D0  /
      DATA (IFUNTYP(55, I), I = 1, 17)/0, 0, 0, 0, 0, 0, 2, 2, 2, 2,
     1 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 55, I), I = 1, 17)/11, 11, 11, 11, 11, 11, 10, 10,
     1 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR BA ELEMENT #56
      DATA XKPCOR(56)/3.23000000D-01/
      DATA RELCOR(56)/ 0.721000016D0  /
      DATA (IFUNTYP(56, I), I = 1, 17)/0, 0, 0, 0, 0, 0, 0, 2, 2, 2,
     1 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 56, I), I = 1, 17)/11, 11, 11, 11, 11, 11, 11, 10,
     1 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR LA ELEMENT #57
      DATA XKPCOR(57)/3.38000000D-01/
      DATA RELCOR(57)/ 0.753000021D0  /
      DATA (IFUNTYP(57, I), I = 1, 17)/0, 0, 0, 0, 0, 0, 0, 2, 2, 2,
     1 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 57, I), I = 1, 17)/11, 11, 11, 11, 11, 11, 11, 10,
     1 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR CE ELEMENT #58
      DATA XKPCOR(58)/3.54000000D-01/
      DATA RELCOR(58)/ 0.786000013D0  /
      DATA (IFUNTYP(58, I), I = 1, 18)/0, 0, 0, 0, 0, 0, 0, 2, 2, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 58, I), I = 1, 18)/11, 11, 11, 11, 11, 11, 11, 10,
     1 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR PR ELEMENT #59
      DATA XKPCOR(59)/3.69000000D-01/
      DATA RELCOR(59)/ 0.819000006D0  /
      DATA (IFUNTYP(59, I), I = 1, 18)/0, 0, 0, 0, 0, 0, 0, 2, 2, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 59, I), I = 1, 18)/11, 11, 11, 11, 11, 11, 11, 10,
     1 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR ND ELEMENT #60
      DATA XKPCOR(60)/3.86000000D-01/
      DATA RELCOR(60)/ 0.853999972D0  /
      DATA (IFUNTYP(60, I), I = 1, 18)/0, 0, 0, 0, 0, 0, 0, 2, 2, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 60, I), I = 1, 18)/11, 11, 11, 11, 11, 11, 11, 10,
     1 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR PM ELEMENT #61
      DATA XKPCOR(61)/4.02000000D-01/
      DATA RELCOR(61)/ 0.888999999D0  /
      DATA (IFUNTYP(61, I), I = 1, 18)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 61, I), I = 1, 18)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR SM ELEMENT #62
      DATA XKPCOR(62)/4.19000000D-01/
      DATA RELCOR(62)/ 0.925000012D0  /
      DATA (IFUNTYP(62, I), I = 1, 18)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 62, I), I = 1, 18)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR EU ELEMENT #63
      DATA XKPCOR(63)/4.37000000D-01/
      DATA RELCOR(63)/ 0.962000012D0  /
      DATA (IFUNTYP(63, I), I = 1, 18)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 63, I), I = 1, 18)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR GD ELEMENT #64
      DATA XKPCOR(64)/4.55000000D-01/
      DATA RELCOR(64)/  1.00000000D0  /
      DATA (IFUNTYP(64, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 64, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR TB ELEMENT #65
      DATA XKPCOR(65)/4.74000000D-01/
      DATA RELCOR(65)/  1.03900003D0  /
      DATA (IFUNTYP(65, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 65, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR DY ELEMENT #66
      DATA XKPCOR(66)/4.93000000D-01/
      DATA RELCOR(66)/  1.07900000D0  /
      DATA (IFUNTYP(66, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 66, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR HO ELEMENT #67
      DATA XKPCOR(67)/5.12000000D-01/
      DATA RELCOR(67)/  1.11899996D0  /
      DATA (IFUNTYP(67, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 67, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR ER ELEMENT #68
      DATA XKPCOR(68)/5.32000000D-01/
      DATA RELCOR(68)/  1.16100001D0  /
      DATA (IFUNTYP(68, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 68, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR TM ELEMENT #69
      DATA XKPCOR(69)/5.53000000D-01/
      DATA RELCOR(69)/  1.20400000D0  /
      DATA (IFUNTYP(69, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 69, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR YB ELEMENT #70
      DATA XKPCOR(70)/5.74000000D-01/
      DATA RELCOR(70)/  1.24800003D0  /
      DATA (IFUNTYP(70, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 70, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR LU ELEMENT #71
      DATA XKPCOR(71)/5.96000000D-01/
      DATA RELCOR(71)/  1.29299998D0  /
      DATA (IFUNTYP(71, I), I = 1, 19)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 71, I), I = 1, 19)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR HF ELEMENT #72
      DATA XKPCOR(72)/6.17000000D-01/
      DATA RELCOR(72)/  1.33800006D0  /
      DATA (IFUNTYP(72, I), I = 1, 20)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 72, I), I = 1, 20)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR TA ELEMENT #73
      DATA XKPCOR(73)/6.40000000D-01/
      DATA RELCOR(73)/  1.38499999D0  /
      DATA (IFUNTYP(73, I), I = 1, 20)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 73, I), I = 1, 20)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR W  ELEMENT #74
      DATA XKPCOR(74)/6.63000000D-01/
      DATA RELCOR(74)/  1.43299997D0  /
      DATA (IFUNTYP(74, I), I = 1, 20)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 74, I), I = 1, 20)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR RE ELEMENT #75
      DATA XKPCOR(75)/6.87000000D-01/
      DATA RELCOR(75)/  1.48199999D0  /
      DATA (IFUNTYP(75, I), I = 1, 21)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 75, I), I = 1, 21)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR OS ELEMENT #76
      DATA XKPCOR(76)/7.11000000D-01/
      DATA RELCOR(76)/  1.53199995D0  /
      DATA (IFUNTYP(76, I), I = 1, 21)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 76, I), I = 1, 21)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR IR ELEMENT #77
      DATA XKPCOR(77)/7.36000000D-01/
      DATA RELCOR(77)/  1.58299994D0  /
      DATA (IFUNTYP(77, I), I = 1, 21)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 77, I), I = 1, 21)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR PT ELEMENT #78
      DATA XKPCOR(78)/7.62000000D-01/
      DATA RELCOR(78)/  1.63600004D0  /
      DATA (IFUNTYP(78, I), I = 1, 21)/0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 78, I), I = 1, 21)/11, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR AU ELEMENT #79
      DATA XKPCOR(79)/7.88000000D-01/
      DATA RELCOR(79)/  1.68900001D0  /
      DATA (IFUNTYP(79, I), I = 1, 21)/1, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 79, I), I = 1, 21)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR HG ELEMENT #80
      DATA XKPCOR(80)/8.14000000D-01/
      DATA RELCOR(80)/  1.74300003D0  /
      DATA (IFUNTYP(80, I), I = 1, 22)/1, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 80, I), I = 1, 22)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR TL ELEMENT #81
      DATA XKPCOR(81)/8.42000000D-01/
      DATA RELCOR(81)/  1.79900002D0  /
      DATA (IFUNTYP(81, I), I = 1, 22)/1, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 81, I), I = 1, 22)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR PB ELEMENT #82
      DATA XKPCOR(82)/8.70000000D-01/
      DATA RELCOR(82)/  1.85599995D0  /
      DATA (IFUNTYP(82, I), I = 1, 23)/1, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 82, I), I = 1, 23)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR BI ELEMENT #83
      DATA XKPCOR(83)/8.99000000D-01/
      DATA RELCOR(83)/  1.91400003D0  /
      DATA (IFUNTYP(83, I), I = 1, 23)/1, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 83, I), I = 1, 23)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR PO ELEMENT #84
      DATA XKPCOR(84)/9.28000000D-01/
      DATA RELCOR(84)/  1.97300005D0  /
      DATA (IFUNTYP(84, I), I = 1, 24)/1, 0, 0, 0, 0, 0, 0, 0, 0, 2,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 84, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR AT ELEMENT #85
      DATA XKPCOR(85)/9.57000000D-01/
      DATA RELCOR(85)/  2.03299999D0  /
      DATA (IFUNTYP(85, I), I = 1, 24)/1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 85, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR RN ELEMENT #86
      DATA XKPCOR(86)/9.88000000D-01/
      DATA RELCOR(86)/  2.09500003D0  /
      DATA (IFUNTYP(86, I), I = 1, 24)/1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 86, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR FR ELEMENT #87
      DATA XKPCOR(87)/1.01800000D-00/
      DATA RELCOR(87)/  2.15700006D0  /
      DATA (IFUNTYP(87, I), I = 1, 24)/1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 87, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR RA ELEMENT #88
      DATA XKPCOR(88)/1.05000000D-00/
      DATA RELCOR(88)/  2.22099996D0  /
      DATA (IFUNTYP(88, I), I = 1, 24)/1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 88, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR AC ELEMENT #89
      DATA XKPCOR(89)/1.08300000D-00/
      DATA RELCOR(89)/  2.28699994D0  /
      DATA (IFUNTYP(89, I), I = 1, 24)/1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS( 89, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR TH ELEMENT #90
      DATA XKPCOR(90)/1.11500000D-00/
      DATA RELCOR(90)/  2.35299993D0  /
      DATA (IFUNTYP(90, I), I = 1, 24)/ 1,  0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS(90, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR PA ELEMENT #91
      DATA XKPCOR(91)/1.14900000D-00/
      DATA RELCOR(91)/  2.42100000D0  /
      DATA (IFUNTYP(91, I), I = 1, 24)/ 1,  0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 0, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS(91, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR U  ELEMENT #92
      DATA XKPCOR(92)/1.18400000D-00/
      DATA RELCOR(92)/  2.49000001D0  /
      DATA (IFUNTYP(92, I), I = 1, 24)/ 1,  0, 0, 0, 0, 0, 0, 0, 0, 0,
     1 0, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
      DATA (NPARMS(92, I), I = 1, 24)/10, 11, 11, 11, 11, 11, 11, 11,
     1 11, 11, 11, 11, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10/
C * DATA FOR H  ELEMENT # 1
      DATA NORB( 1)/ 1/
      DATA BINDNRG( 1, 1)/ 14.D-3/
C * DATA FOR HE ELEMENT # 2
      DATA NORB( 2)/ 1/
      DATA BINDNRG( 2, 1)/ 25.D-3/
C * DATA FOR LI ELEMENT # 3
      DATA NORB( 3)/ 2/
      DATA (BINDNRG( 3, II), II = 1, 2)/
     1 5.474999920D-02, 5.34000014D-03/
C * DATA FOR BE ELEMENT # 4
      DATA NORB( 4)/ 2/
      DATA (BINDNRG( 4, II), II = 1, 2)/
     1 0.111000001D0, 8.419999853D-03/
C * DATA FOR B  ELEMENT # 5
      DATA NORB( 5)/ 3/
      DATA (BINDNRG( 5, II), II = 1, 3)/
     1 0.187999994D0, 1.346999966D-02, 4.699999932D-03/
C * DATA FOR C  ELEMENT # 6
      DATA NORB( 6)/ 3/
      DATA (BINDNRG( 6, II), II = 1, 3)/
     1 0.283800006D0, 1.951000094D-02, 6.399999838D-03/
C * DATA FOR N  ELEMENT # 7
      DATA NORB( 7)/ 4/
      DATA (BINDNRG( 7, II), II = 1, 4)/
     1 0.401600003D0, 2.631000057D-02, 9.200000204D-03, 9.200000204D-03/
C * DATA FOR O  ELEMENT # 8
      DATA NORB( 8)/ 4/
      DATA (BINDNRG( 8, II), II = 1, 4)/
     1 0.532000005D0, 2.370000072D-02, 7.100000046D-03, 7.100000046D-03/
C * DATA FOR F  ELEMENT # 9
      DATA NORB( 9)/ 4/
      DATA (BINDNRG( 9, II), II = 1, 4)/
     1 0.685400009D0, 3.100000136D-02, 8.600000292D-03, 8.600000292D-03/
C * DATA FOR NE ELEMENT #10
      DATA NORB(10)/ 4/
      DATA (BINDNRG(10, II), II = 1, 4)/
     1 0.866899967D0, 4.500000179D-02, 1.830000058D-02, 1.830000058D-02/
C * DATA FOR NA ELEMENT #11
      DATA NORB(11)/ 4/
      DATA (BINDNRG(11, II), II = 1, 4)/
     1 1.07210004D0, 6.329999864D-02, 3.109999932D-02, 3.109999932D-02/
C * DATA FOR MG ELEMENT #12
      DATA NORB(12)/ 4/
      DATA (BINDNRG(12, II), II = 1, 4)/
     1 1.30499995D0, 8.940000087D-02, 5.140000209D-02, 5.140000209D-02/
C * DATA FOR AL ELEMENT #13
      DATA NORB(13)/ 5/
      DATA (BINDNRG(13, II), II = 1, 5)/
     1 1.55960000D0, 0.117700003D0, 7.310000062D-02, 7.310000062D-02,
     2 8.375665173D-03/
C * DATA FOR SI ELEMENT #14
      DATA NORB(14)/ 6/
      DATA (BINDNRG(14, II), II = 1, 6)/
     1 1.83889997D0, 0.148699999D0, 9.920000285D-02, 9.920000285D-02,
     2 1.135716774D-02, 5.083053838D-03/
C * DATA FOR P  ELEMENT #15
      DATA NORB(15)/ 7/
      DATA (BINDNRG(15, II), II = 1, 7)/
     1 2.14549994D0, 0.189300001D0, 0.132200003D0, 0.132200003D0,
     2 1.446149126D-02, 6.384930108D-03, 6.336690858D-03/
C * DATA FOR S  ELEMENT #16
      DATA NORB(16)/ 7/
      DATA (BINDNRG(16, II), II = 1, 7)/
     1 2.47200012D0, 0.229200006D0, 0.164800003D0, 0.164800003D0,
     2 1.768823154D-02, 7.813631557D-03, 7.734877989D-03/
C * DATA FOR CL ELEMENT #17
      DATA NORB(17)/ 7/
      DATA (BINDNRG(17, II), II = 1, 7)/
     1 2.82239985D0, 0.270199984D0, 0.201600000D0, 0.200000003D0,
     2 1.750000007D-02, 6.800000090D-03, 6.800000090D-03/
C * DATA FOR AR ELEMENT #18
      DATA NORB(18)/ 7/
      DATA (BINDNRG(18, I), I = 1, 7)/
     1 3.20290017D0, 0.319999993D0, 0.247299999D0, 0.245199993D0,
     2 2.529999986D-02, 1.240000036D-02, 1.240000036D-02/
C * DATA FOR K  ELEMENT #19
      DATA NORB(19)/ 7/
      DATA (BINDNRG(19, I), I = 1, 7)/
     1 3.60739994D0, 0.377099991D0, 0.296299994D0, 0.293599993D0,
     2 3.390000015D-02, 1.779999956D-02, 1.779999956D-02/
C * DATA FOR CA ELEMENT #20
      DATA NORB(20)/ 7/
      DATA (BINDNRG(20, I), I = 1, 7)/
     1 4.03809977D0, 0.437799990D0, 0.349999994D0, 0.346399993D0,
     2 4.369999841D-02, 2.539999969D-02, 2.539999969D-02/
C * DATA FOR SC ELEMENT #21
      DATA NORB(21)/ 7/
      DATA (BINDNRG(21, I), I = 1, 7)/
     1 4.49279976D0, 0.500400007D0, 0.406699985D0, 0.402200013D0,
     2 5.380000174D-02, 3.229999915D-02, 3.229999915D-02/
C * DATA FOR TI ELEMENT #22
      DATA NORB(22)/ 7/
      DATA (BINDNRG(22, I), I = 1, 7)/
     1 4.96640015D0, 0.563700020D0, 0.461499989D0, 0.455500007D0,
     2 6.030000001D-02, 3.460000083D-02, 3.460000083D-02/
C * DATA FOR V  ELEMENT #23
      DATA NORB(23)/ 8/
      DATA (BINDNRG(23, I), I = 1, 8)/
     1 5.46509981D0, 0.628199995D0, 0.520500004D0, 0.512899995D0,
     2 6.650000066D-02, 3.779999912D-02,3.779999912D-02,2.199999988D-03/
C * DATA FOR CR ELEMENT #24
      DATA NORB(24)/ 9/
      DATA (BINDNRG(24, I), I = 1, 9)/
     1 5.98920012D0, 0.694599986D0, 0.583700001D0, 0.574500024D0,
     2 7.410000265D-02, 4.250000045D-02,4.250000045D-02,2.300000051D-03,
     3 2.300000051D-03/
C * DATA FOR MN ELEMENT #25
      DATA NORB(25)/ 9/
      DATA (BINDNRG(25, I), I = 1, 9)/
     1 6.53900003D0, 0.768999994D0, 0.651399970D0, 0.640299976D0,
     2 8.389999717D-02, 4.859999940D-02, 4.859999940D-02,
     3 7.261591498D-03, 7.143782452D-03/
C * DATA FOR FE ELEMENT #26
      DATA NORB(26)/ 9/
      DATA (BINDNRG(26, I), I = 1, 9)/
     1 7.11199999D0, 0.846100032D0, 0.721100032D0, 0.708100021D0,
     2 9.290000051D-02, 5.400000140D-02, 5.400000140D-02,
     3 3.599999938D-03, 3.599999938D-03/
C * DATA FOR CO ELEMENT #27
      DATA NORB(27)/ 9/
      DATA (BINDNRG(27, I), I = 1, 9)/
     1 7.70889997D0, 0.925599992D0, 0.793600023D0, 0.778599977D0,
     2 0.100699998D0, 5.950000137D-02, 5.950000137D-02, 2.899999963D-03,
     3 2.899999963D-03/
C * DATA FOR NI ELEMENT #28
      DATA NORB(28)/ 9/
      DATA (BINDNRG(28, I), I = 1, 9)/
     1 8.33279991D0, 1.00810003D0, 0.871900022D0, 0.854700029D0,
     2 0.111800000D0, 6.809999794D-02, 6.809999794D-02, 3.599999938D-03,
     3 3.599999938D-03/
C * DATA FOR CU ELEMENT #29
      DATA NORB(29)/ 9/
      DATA (BINDNRG(29, I), I = 1, 9)/
     1 8.97889996D0, 1.09609997D0, 0.950999975D0, 0.931100011D0,
     2 0.119800001D0, 7.360000163D-02, 7.360000163D-02, 1.600000076D-03,
     3 1.600000076D-03/
C * DATA FOR ZN ELEMENT #30
      DATA NORB(30)/ 9/
      DATA (BINDNRG(30, I), I = 1, 9)/
     1 9.65859985D0, 1.19360006D0, 1.04279995D0, 1.01970005D0,
     2 0.135900006D0, 8.659999818D-02, 8.659999818D-02, 8.100000210D-03,
     3 8.100000210D-03/
C * DATA FOR GA ELEMENT #31
      DATA NORB(31)/ 9/
      DATA (BINDNRG(31, I), I = 1, 9)/
     1 10.3670998D0, 1.29770005D0, 1.14230001D0, 1.11539996D0,
     2 0.158100009D0, 0.10679999D0, 0.102899998D0, 1.740000024D-02,
     3 1.740000024D-02/
C * DATA FOR GE ELEMENT #32
      DATA NORB(32)/ 9/
      DATA (BINDNRG(32, I), I = 1, 9)/
     1 11.1030998D0, 1.41429996D0, 1.24779999D0, 1.21669996D0,
     2 0.180000007D0, 0.127900004D0, 0.120800003D0, 2.869999968D-02,
     3 2.869999968D-02/
C * DATA FOR AS ELEMENT #33
      DATA NORB(33)/ 9/
      DATA (BINDNRG(33, I), I = 1, 9)/
     1 11.8667002D0, 1.52650011D0, 1.35860002D0, 1.32309997D0,
     2 0.203500003D0, 0.146400005D0, 0.140500009D0, 4.120000079D-02,
     3 4.120000079D-02/
C * DATA FOR SE ELEMENT #34
      DATA NORB(34)/ 9/
      DATA (BINDNRG(34, I), I = 1, 9)/
     1 12.6577997D0, 1.65390003D0, 1.47619998D0, 1.43580008D0,
     2 0.231500000D0, 0.168200001D0, 0.161899999D0, 5.669999868D-02,
     3 5.669999868D-02/
C * DATA FOR BR ELEMENT #35
      DATA NORB(35)/ 9/
      DATA (BINDNRG(35, I), I = 1, 9)/
     1 13.4736996D0, 1.78200006D0, 1.59599996D0, 1.54990005D0,
     2 0.256500006D0, 0.189300001D0, 0.181500003D0, 7.010000199D-02,
     3 6.899999827D-02/
C * DATA FOR KR ELEMENT #36
      DATA NORB(36)/ 9/
      DATA (BINDNRG(36, I), I = 1, 9)/
     1 14.3255997D0, 1.92100000D0, 1.72720003D0, 1.67489994D0,
     2 0.288329989D0, 0.222700000D0, 0.213799998D0, 8.889999986D-02,
     3 8.889999986D-02/
C * DATA FOR RB ELEMENT #37
      DATA NORB(37)/ 9/
      DATA (BINDNRG(37, I), I = 1, 9)/
     1 15.1996994D0, 2.06509995D0, 1.86389995D0, 1.80439997D0,
     2 0.322100013D0, 0.247400001D0, 0.238499999D0, 0.111800000D0,
     3 0.110299997D0/
C * DATA FOR SR ELEMENT #38
      DATA NORB(38)/12/
      DATA (BINDNRG(38, I), I = 1, 12)/
     1 16.1046009D0, 2.21630001D0, 2.00680017D0, 1.93959999D0,
     2 0.357499987D0, 0.279799998D0, 0.269100010D0, 0.135000005D0,
     3 0.133100003D0, 3.770000115D-02, 1.989999972D-02, 1.989999972D-02/
C * DATA FOR Y  ELEMENT #39
      DATA NORB(39)/12/
      DATA (BINDNRG(39, I), I = 1, 12)/
     1 17.0383987D0, 2.37249994D0, 2.15549994D0, 2.07999992D0,
     2 0.393600017D0, 0.312400013D0, 0.300300002D0, 0.159599990D0,
     3 0.157399997D0, 4.540000111D-02, 2.559999935D-02, 2.559999935D-02/
C * DATA FOR ZR ELEMENT #40
      DATA NORB(40)/13/
      DATA (BINDNRG(40, I), I = 1, 13)/
     1 17.9976006D0, 2.53160000D0, 2.30669999D0, 2.22230005D0,
     2 0.430299997D0, 0.344199985D0, 0.330500007D0, 0.182400003D0,
     3 0.180000007D0, 5.130000040D-02, 2.869999968D-02,2.869999968D-02,
     4 4.023449495D-03/
C * DATA FOR NB ELEMENT #41
      DATA NORB(41)/13/
      DATA (BINDNRG(41, I), I = 1, 13)/
     1 18.9855995D0, 2.69770002D0, 2.46469998D0, 2.37050009D0,
     2 0.468400002D0, 0.378399998D0, 0.363000005D0, 0.207399994D0,
     3 0.204600006D0, 5.810000002D-02, 3.390000015D-02, 3.390000015D-02,
     4 3.199999919D-03/
C * DATA FOR MO ELEMENT #42
      DATA NORB(42)/14/
      DATA (BINDNRG(42, I), I = 1, 14)/
     1 19.9995003D0, 2.86549997D0, 2.62510014D0, 2.52020001D0,
     2 0.504599988D0, 0.409700006D0, 0.392300010D0, 0.230300009D0,
     3 0.226999998D0, 6.179999933D-02, 3.480000049D-02, 3.480000049D-02,
     4 1.800000085D-03,1.800000085D-03/
C * DATA FOR TC ELEMENT #43
      DATA NORB(43)/14/
      DATA (BINDNRG(43, I), I = 1, 14)/
     1 21.0439987D0, 3.04250002D0, 2.79320002D0, 2.67689991D0,
     2 0.547599971D0, 0.444900006D0, 0.425000012D0, 0.256399989D0,
     3 0.252900004D0, 6.840000302D-02, 3.889999911D-02, 3.889999911D-02,
     4 7.011581678D-03, 6.729420740D-03/
C * DATA FOR RU ELEMENT #44
      DATA NORB(44)/14/
      DATA (BINDNRG(44, I), I = 1, 14)/
     1 22.1172009D0, 3.22399998D0, 2.96689987D0, 2.83789992D0,
     2 0.584999979D0, 0.482800007D0, 0.460600019D0, 0.283600003D0,
     3 0.279399991D0, 7.490000129D-02, 4.309999943D-02, 4.309999943D-02,
     4 2.000000095D-03,2.000000095D-03/
C * DATA FOR RH ELEMENT #45
      DATA NORB(45)/14/
      DATA (BINDNRG(45, I), I = 1, 14)/
     1 23.2199001D0, 3.41190004D0, 3.14610004D0, 3.00379992D0,
     2 0.627099991D0, 0.521000028D0, 0.496199995D0, 0.311700016D0,
     3 0.306999981D0, 8.100000024D-02, 4.789999872D-02,4.789999872D-02,
     4 2.499999944D-03, 2.499999944D-03/
C * DATA FOR PD ELEMENT #46
      DATA NORB(46)/14/
      DATA (BINDNRG(46, I), I = 1, 14)/
     1 24.3502998D0, 3.60430002D0, 3.33030009D0, 3.17330003D0,
     2 0.669900000D0, 0.559099972D0, 0.531499982D0, 0.340000004D0,
     3 0.334699988D0, 8.640000224D-02, 5.110000074D-02, 5.110000074D-02,
     4 5.446631927D-03, 5.018413067D-03/
C * DATA FOR AG ELEMENT #47
      DATA NORB(47)/14/
      DATA (BINDNRG(47, I), I = 1, 14)/
     1 25.5139999D0, 3.8057999D0, 3.52370000D0, 3.35109997D0,
     2 0.717499971D0, 0.602400005D0, 0.571399987D0, 0.372799993D0,
     3 0.366699994D0, 9.520000219D-02, 6.260000169D-02, 5.590000004D-02,
     4 3.299999982D-03, 3.299999982D-03/
C * DATA FOR CD ELEMENT #48
      DATA NORB(48)/14/
      DATA (BINDNRG(48,I), I = 1, 14)/
     1 26.7112007D0, 4.01800013D0, 3.72700000D0, 3.53749990D0,
     2 0.770200014D0, 0.650699973D0, 0.616500020D0, 0.410499990D0,
     3 0.403699994D0, 0.107600003D0, 6.689999998D-02, 6.689999998D-02,
     4 9.300000034D-03, 9.300000034D-03/
C * DATA FOR IN ELEMENT #49
      DATA NORB(49)/14/
      DATA (BINDNRG(49, I), I = 1, 14)/
     1 27.9398994D0, 4.23750019D0, 3.93799996D0, 3.73009992D0,
     2 0.825599968D0, 0.702199996D0, 0.664300025D0, 0.450800002D0,
     3 0.443100005D0, 0.121900000D0, 7.739999890D-02, 7.739999890D-02,
     41.620000042D-02, 1.620000042D-02/
C * DATA FOR SN ELEMENT #50
      DATA NORB(50)/14/
      DATA (BINDNRG(50, I), I = 1, 14)/
     1 29.2000999D0, 4.46470022D0, 4.15610027D0, 3.92880011D0,
     2 0.883800030D0, 0.756399989D0, 0.714399993D0, 0.493299991D0,
     3 0.484800011D0, 0.136500001D0, 8.860000223D-02, 8.860000223D-02,
     4 2.389999852D-02, 2.389999852D-02/
C * DATA FOR SB ELEMENT #51
      DATA NORB(51)/14/
      DATA( BINDNRG(51, I), I = 1, 14)/
     1 30.4911995D0, 4.69829988D0, 4.38040018D0, 4.13220024D0,
     2 0.943700016D0, 0.811900020D0, 0.765600026D0, 0.536899984D0,
     3 0.527499974D0, 0.152000010D0, 9.840000421D-02, 9.840000421D-02,
     4 3.139999881D-02, 3.139999881D-02/
C * DATA FOR TE ELEMENT #52
      DATA NORB(52)/14/
      DATA (BINDNRG(52, I), I = 1, 14)/
     1 31.8137989D0, 4.93919992D0, 4.61199999D0, 4.34140015D0,
     2 1.00600004D0, 0.869700015D0, 0.818700016D0, 0.582499981D0,
     3 0.572099984D0, 0.168300003D0, 0.110200003D0, 0.110200003D0,
     4 3.979999945D-02, 3.979999945D-02/
C * DATA FOR I  ELEMENT #53
      DATA NORB(53)/14/
      DATA (BINDNRG(53, I), I = 1, 14)/
     1 33.1693993D0, 5.18809986D0, 4.85209990D0, 4.55710030D0,
     2 1.07210004D0, 0.930500031D0, 0.874599993D0, 0.631299973D0,
     3 0.619400024D0, 0.186399996D0, 0.122699998D0, 0.122699998D0,
     4 4.960000142D-02, 4.960000142D-02/
C * DATA FOR XE ELEMENT #54
      DATA NORB(54)/14/
      DATA (BINDNRG(54, I), I = 1, 14)/
     1 34.5614014D0, 5.45279980D0, 5.10370016D0, 4.78219986D0,
     2 1.14460003D0, 0.999000013D0, 0.936999977D0, 0.685400009D0,
     3 0.672299981D0, 0.208099991D0, 0.146699995D0, 0.146699995D0,
     4 6.400000304D-02, 6.400000304D-02/
C * DATA FOR CS ELEMENT #55
      DATA NORB(55)/17/
      DATA (BINDNRG(55, I), I = 1, 17)/
     1 35.9846001D0, 5.71430016D0, 5.35939980D0, 5.01189995D0,
     2 1.21710002D0, 1.06500006D0, 0.997600019D0, 0.739499986D0,
     3 0.725499988D0, 0.230800003D0, 0.172299996D0, 0.161599994D0,
     4 7.880000025D-02, 7.649999857D-02, 2.270000055D-02,
     5 1.310000010D-02, 1.140000019D-02/
C * DATA FOR BA ELEMENT #56
      DATA NORB(56)/17/
      DATA (BINDNRG(56, II), II = 1, 17)/
     1 37.4405975D0, 5.98880005D0, 5.62360001D0, 5.24700022D0,
     2 1.29279995D0, 1.13670003D0, 1.06219995D0, 0.796100020D0,
     3 0.780699968D0, 0.252999991D0, 0.191799998D0, 0.179700002D0,
     4 9.250000119D-02, 8.990000188D-02, 3.909999877D-02,
     5 1.659999974D-02, 1.460000034D-02/
C * DATA FOR LA ELEMENT #57
      DATA NORB(57)/17/
      DATA (BINDNRG(57, II), II = 1, 17)/
     1 38.9245987D0, 6.26630020D0, 5.89060020D0, 5.48269987D0,
     2 1.36129999D0, 1.20439994D0, 1.12339997D0, 0.848500013D0,
     3 0.831699967D0, 0.270400017D0, 0.205799997D0, 0.191400006D0,
     4 9.889999777D-02, 9.889999777D-02, 3.229999915D-02,
     5 1.439999975D-02, 1.439999975D-02/
C * DATA FOR CE ELEMENT #58
      DATA NORB(58)/18/
      DATA (BINDNRG(58, II), II = 1, 18)/
     1 40.4430008D0, 6.54879999D0, 6.16419983D0, 5.72340012D0,
     2 1.43460000D0, 1.27279997D0, 1.18540001D0, 0.901300013D0,
     3 0.883300006D0, 0.289599985D0, 0.223299995D0, 0.207200006D0,
     4 0.109999999D0, 0.109999999D0, 8.590000123D-02,
     5 3.779999912D-02, 1.979999989D-02, 1.979999989D-02/
C * DATA FOR PR ELEMENT #59
      DATA NORB(59)/18/
      DATA (BINDNRG(59, II), II = 1, 18)/
     1 41.9906006D0, 6.83480024D0, 6.44040012D0, 5.96430016D0,
     2 1.51099992D0, 1.33739996D0, 1.24220002D0, 0.951099992D0,
     3 0.930999994D0, 0.304500014D0, 0.236300007D0, 0.217600003D0,
     4 0.113200001D0, 0.113200001D0, 3.500000108D-03,
     4 3.739999980D-02, 2.229999937D-02, 2.229999937D-02/
C * DATA FOR ND ELEMENT #60
      DATA NORB(60)/18/
      DATA (BINDNRG(60, II), II = 1, 18)/
     1 43.5689011D0, 7.12599993D0, 6.72149992D0, 6.20790005D0,
     2 1.57530010D0, 1.40279996D0, 1.29740000D0, 0.999499977D0,
     3 0.977699995D0, 0.315200001D0, 0.243299991D0, 0.224600002D0,
     4 0.117500000D0, 0.117500000D0, 3.000000026D-03,
     5 3.749999776D-02, 2.110000141D-02, 2.110000141D-02/
C * DATA FOR PM ELEMENT #61
      DATA NORB(61)/18/
      DATA (BINDNRG(61, II), II = 1, 18)/
     1 45.1840019D0, 7.42789984D0, 7.01279974D0, 6.45930004D0,
     2 1.64649999D0, 1.47140002D0, 1.35689998D0, 1.05149996D0,
     3 1.02690005D0, 0.330399990D0, 0.254399985D0, 0.236000001D0,
     4 0.120399997D0, 0.120399997D0, 4.000000190D-03,
     5 3.749999776D-02, 2.110000141D-02, 2.110000141D-02/
C * DATA FOR SM ELEMENT #62
      DATA NORB(62)/18/
      DATA (BINDNRG(62, II), II = 1, 18)/
     1 46.8342018D0, 7.73680019D0, 7.31180000D0, 6.71619987D0,
     2 1.72280002D0, 1.54069996D0, 1.41979992D0, 1.10599995D0,
     3 1.08019996D0, 0.345699996D0, 0.265599996D0, 0.247400001D0,
     4 0.128999993D0, 0.128999993D0, 5.499999970D-03,
     4 3.739999980D-02, 2.129999921D-02, 2.129999921D-02/
C * DATA FOR EU ELEMENT #63
      DATA NORB(63)/18/
      DATA (BINDNRG(63, II), II = 1, 18)/
     1 48.5190010D0, 8.05200005D0, 7.61710024D0, 6.97690010D0,
     2 1.80000007D0, 1.61389995D0, 1.48060000D0, 1.16059995D0,
     3 1.13090003D0, 0.360199988D0, 0.283899993D0, 0.256599993D0,
     4 0.133200005D0, 0.133200005D0, 2.911507152D-03,
     4 3.179999813D-02, 2.199999988D-02, 2.199999988D-02/
C * DATA FOR GD ELEMENT #64
      DATA NORB(64)/19/
      DATA (BINDNRG(64, II), II = 1, 19)/
     1 50.2391014D0, 8.37559986D0, 7.93029976D0, 7.24279976D0,
     2 1.88080001D0, 1.68830001D0, 1.54400003D0, 1.21720004D0,
     3 1.18519998D0, 0.375799984D0, 0.288500011D0, 0.270900011D0,
     4 0.140500009D0, 0.140500009D0, 9.279401973D-03, 8.524194360D-03,
     5 3.610000014D-02, 2.030000091D-02, 2.030000091D-02/
C * DATA FOR TB ELEMENT #65
      DATA NORB(65)/19/
      DATA (BINDNRG(65, II), II = 1, 19)/
     1 51.9957008D0, 8.70800018D0, 8.25160027D0, 7.51399994D0,
     2 1.96749997D0, 1.76769996D0, 1.61129999D0, 1.27499998D0,
     3 1.24119997D0, 0.397900015D0, 0.310200006D0, 0.284999996D0,
     4 0.147000000D0, 0.147000000D0, 9.399999864D-03, 8.600000292D-03,
     5 3.900000080D-02, 2.539999969D-02, 2.539999969D-02/
C * DATA FOR DY ELEMENT #66
      DATA NORB(66)/19/
      DATA (BINDNRG(66, II), II = 1, 19)/
     1 53.7885017D0, 9.04580021D0, 8.58059978D0, 7.79010010D0,
     2 2.04679990D0, 1.84180009D0, 1.67559993D0, 1.33249998D0,
     3 1.29489994D0, 0.416299999D0, 0.331800014D0, 0.292899996D0,
     4 0.154200003D0 ,0.154200003D0, 4.199999850D-03, 4.199999850D-03,
     5 6.289999932D-02, 2.630000003D-02, 2.630000003D-02/
C * DATA FOR HO ELEMENT #67
      DATA NORB(67)/19/
      DATA (BINDNRG(67, II), II = 1, 19)/
     1 55.6176987D0, 9.39420033D0, 8.91779995D0, 8.07110023D0,
     2 2.12829995D0, 1.92279994D0, 1.74119997D0, 1.39150000D0,
     3 1.35140002D0, 0.435699999D0, 0.343499988D0, 0.306600004D0,
     4 0.160999998D0, 0.160999998D0, 3.700000001D-03, 3.700000001D-03,
     5 5.119999871D-02, 2.030000091D-02, 2.030000091D-02/
C * DATA FOR ER ELEMENT #68
      DATA NORB(68)/19/
      DATA (BINDNRG(68, II), II = 1, 19)/
     1 57.4855003D0, 9.75129986D0, 9.26430035D0, 8.35789967D0,
     2 2.20650005D0, 2.00580001D0, 1.81180000D0, 1.45330000D0,
     3 1.40929997D0, 0.449099988D0, 0.366200000D0, 0.319999993D0,
     4 0.17669999D0, 0.167600006D0, 4.300000146D-03, 4.300000146D-03,
     5 5.979999900D-02, 2.940000035D-02, 2.940000035D-02/
C * DATA FOR TM ELEMENT #69
      DATA NORB(69)/19/
      DATA (BINDNRG(69, II), II = 1, 19)/
     1 59.3895988D0, 10.1156998D0, 9.61689949D0, 8.64799976D0,
     2 2.30679989D0, 2.08980012D0, 1.88450003D0, 1.51460004D0,
     3 1.46770000D0, 0.471699983D0, 0.385900021D0, 0.336600006D0,
     4 0.179600000D0, 0.179600000D0, 5.299999844D-03, 5.299999844D-03,
     5 5.319999903D-02, 3.229999915D-02, 3.229999915D-02/
C * DATA FOR YB ELEMENT #70
      DATA NORB(70)/19/
      DATA (BINDNRG(70, II), II = 1, 19)/
     1 61.3323021D0, 10.4863997D0, 9.97819996D0, 8.94359970D0,
     2 2.39809990D0, 2.17300010D0, 1.94980001D0, 1.57629991D0,
     3 1.52779996D0, 0.487199992D0, 0.396699995D0, 0.343499988D0,
     4 0.198100001D0, 0.184900001D0, 6.300000008D-03, 6.300000008D-03,
     5 5.409999937D-02, 2.340000123D-02, 2.340000123D-02/
C * DATA FOR LU ELEMENT #71
      DATA NORB(71)/19/
      DATA (BINDNRG(71, II), II = 1, 19)/
     1 63.3138008D0, 10.8704004D0, 10.3486004D0, 9.24409962D0,
     2 2.49119997D0, 2.26349998D0, 2.02360010D0, 1.63940001D0,
     3 1.58849990D0, 0.506200016D0, 0.410100013D0, 0.359299988D0,
     4 0.204800010D0, 0.195000008D0, 6.899999920D-03, 6.899999920D-03,
     5 5.680000037D-02, 2.800000086D-02, 2.800000086D-02/
C * DATA FOR HF ELEMENT #72
      DATA NORB(72)/20/
      DATA (BINDNRG(72,II), II = 1, 20)/
     1 65.3507996D0, 11.2707005D0, 10.7393999D0, 9.56070042D0,
     2 2.60089993D0, 2.36539984D0, 2.10759997D0, 1.71639991D0,
     3 1.66169989D0, 0.538100004D0, 0.437000006D0, 0.380400002D0,
     4 0.223799989D0, 0.213699996D0, 1.709999889D-02, 1.709999889D-02,
     5 6.489999592D-02,3.810000047D-02, 3.060000017D-02,
     6 4.999999888D-03/
C * DATA FOR TA ELEMENT #73
      DATA NORB(73)/20/
      DATA (BINDNRG(73, II), II = 1, 20)/
     1 67.4163971D0, 11.6814995D0, 11.1360998D0, 9.88109970D0,
     2 2.70799994D0, 2.46869993D0, 2.19400001D0, 1.79320002D0,
     3 1.73509991D0, 0.565500021D0, 0.464800000D0, 0.404500008D0,
     4 0.241300002D0, 0.229299992D0, 2.500000037D-02, 2.500000037D-02,
     5 7.109999657D-02, 4.490000010D-02, 3.640000150D-02,
     6 5.700000096D-03/
C * DATA FOR W  ELEMENT #74
      DATA NORB(74)/20/
      DATA (BINDNRG(74, II), II = 1, 20)/
     1 69.5250015D0, 12.0998001D0, 11.5439997D0, 10.2068005D0,
     2 2.81960011D0, 2.57489991D0, 2.28099990D0, 1.87160003D0,
     3 1.80920005D0, 0.594999969D0, 0.491600007D0, 0.425300002D0,
     4 0.258800000D0, 0.245399997D0, 3.649999946D-02, 3.359999880D-02,
     5 7.710000128D-02, 4.679999873D-02, 3.559999913D-02,
     6 6.099999882D-03/
C * DATA FOR RE ELEMENT #75
      DATA NORB(75)/21/
      DATA (BINDNRG(75, II), II = 1, 21)/
     1 71.6763992D0, 12.5267000D0, 11.9587002D0, 10.5353003D0,
     2 2.93169999D0, 2.68159986D0, 2.36730003D0, 1.94889998D0,
     3 1.88290000D0, 0.625000000D0, 0.517899990D0, 0.444399983D0,
     4 0.273699999D0, 0.260199994D0, 4.059999809D-02, 4.059999809D-02,
     5 8.280000091D-02, 4.560000077D-02, 3.460000083D-02,
     6 6.062670611D-03, 5.209125113D-03/
C * DATA FOR OS ELEMENT #76
      DATA NORB(76)/21/
      DATA (BINDNRG(76, II), II = 1, 21)/
     1 73.8708038D0, 12.9680004D0, 12.3850002D0, 10.8709002D0,
     2 3.04850006D0, 2.79220009D0, 2.45720005D0, 2.03080010D0,
     3 1.96009994D0, 0.654300034D0, 0.546500027D0, 0.468199998D0,
     4 0.289399981D0, 0.272799999D0, 4.630000144D-02, 4.630000144D-02,
     5 8.370000124D-02, 5.799999833D-02, 4.540000111D-02,
     6 7.052645553D-03, 6.027942058D-03/
C * DATA FOR IR ELEMENT #77
      DATA NORB(77)/21/
      DATA (BINDNRG(77, II), II = 1, 21)/
     1 76.1110001D0, 13.4184999D0, 12.8240995D0, 11.2152004D0,
     2 3.17369986D0, 2.90869999D0, 2.55069995D0, 2.11610007D0,
     3 2.04040003D0, 0.690100014D0, 0.577099979D0, 0.494300008D0,
     4 0.311399996D0, 0.294900000D0, 6.340000033D-02, 6.049999967D-02,
     5 9.520000219D-02, 6.300000101D-02, 5.049999803D-02,
     6 8.062744513D-03, 6.854556501D-03/
C * DATA FOR PT ELEMENT #78
      DATA NORB(78)/21/
      DATA (BINDNRG(78, II), II = 1, 21)/
     1 78.3947983D0, 13.8799000D0, 13.2726002D0, 11.5636997D0,
     2 3.29600000D0, 3.02649999D0, 2.64540005D0, 2.20190001D0,
     3 2.12160015D0, 0.722000003D0, 0.609200001D0, 0.518999994D0,
     4 0.330799997D0, 0.313300014D0, 7.429999858D-02, 7.109999657D-02,
     5 0.101700000D0, 6.530000269D-02, 5.169999972D-02, 7.439905778D-03,
     6 6.125379819D-03/
C * DATA FOR AU ELEMENT #79
      DATA NORB(79)/21/
      DATA (BINDNRG(79, II), II = 1, 21)/
     1 80.7248993D0, 14.3528004D0, 13.7336006D0, 11.9187002D0,
     2 3.42490005D0, 3.14779997D0, 2.74300003D0, 2.29110003D0,
     3 2.20569992D0, 0.758799970D0, 0.643700004D0, 0.545400023D0,
     4 0.351999998D0, 0.333900005D0, 8.640000224D-02, 8.280000091D-02,
     5 0.107799999D0, 7.169999927D-02, 5.370000005D-02, 8.308385499D-03,
     6 6.790316198D-03/
C * DATA FOR HG ELEMENT #80
      DATA NORB(80)/22/
      DATA (BINDNRG(80, II), II = 1, 22)/
     1 83.1023026D0, 14.8393002D0, 14.2087002D0, 12.2839003D0,
     2 3.56159997D0, 3.27850008D0, 2.84710002D0, 2.38489985D0,
     3 2.29489994D0, 0.800300002D0, 0.676899970D0, 0.570999980D0,
     4 0.378300011D0, 0.359800011D0, 0.102200001D0, 9.849999845D-02,
     5 0.120300002D0, 8.049999923D-02, 5.759999901D-02,
     6 6.399999838D-03, 6.399999838D-03, 7.713606115D-03/
C * DATA FOR TL ELEMENT #81
      DATA NORB(81)/22/
      DATA (BINDNRG(81, II), II = 1, 22)/
     1 85.5304031D0, 15.3467007D0, 14.6978998D0, 12.6575003D0,
     2 3.70409989D0, 3.41569996D0, 2.95659995D0, 2.48510003D0,
     3 2.38930011D0, 0.845499992D0, 0.721300006D0, 0.609000027D0,
     4 0.406599998D0, 0.386200011D0, 0.122800000D0, 0.118500002D0,
     5 0.136300012D0, 9.960000217D-02, 7.540000230D-02,
     6 1.530000009D-02, 1.310000010D-02, 9.664831683D-03/
C * DATA FOR PB ELEMENT #82
      DATA NORB(82)/23/
      DATA (BINDNRG(82, II), II = 1, 23)/
     1 88.0045013D0, 15.8607998D0, 15.2000008D0, 13.0352001D0,
     2 3.85069990D0, 3.55419993D0, 3.06640005D0, 2.58559990D0,
     3 2.48399997D0, 0.893599987D0, 0.763899982D0, 0.644500017D0,
     4 0.435200006D0, 0.412900001D0, 0.142900005D0, 0.138100013D0,
     5 0.147299990D0, 0.104800001D0, 8.600000292D-02, 2.180000022D-02,
     6 1.920000091D-02, 1.169038378D-02, 4.911662545D-03/
C * DATA FOR BI ELEMENT #83
      DATA NORB(83)/23/
      DATA (BINDNRG(83, II), II = 1, 23)/
     1 90.5259018D0, 16.3875008D0, 15.7111006D0, 13.4186001D0,
     2 3.99909997D0, 3.69630003D0, 3.17689991D0, 2.68759990D0,
     3 2.57959986D0, 0.938199997D0, 0.805299997D0, 0.678900003D0,
     4 0.463600010D0, 0.439999998D0, 0.161899999D0, 0.157399997D0,
     5 0.159299999D0, 0.116800003D0, 9.279999882D-02, 2.649999969D-02,
     6 2.439999953D-02, 1.423338987D-02, 6.169907749D-03/
C * DATA FOR PO ELEMENT #84
      DATA NORB(84)/24/
      DATA (BINDNRG(84, II), II = 1, 24)/
     1 93.1050034D0, 16.9393005D0, 16.2443008D0, 13.8138008D0,
     2 4.14940023D0, 3.85409999D0, 3.30189991D0, 2.79799986D0,
     3 2.68300009D0,0.995299995D0, 0.851000011D0, 0.704999983D0,
     4 0.500199974D0, 0.473399997D0, 0.175343826D0, 0.169361845D0,
     5 0.170906276D0, 0.125695229D0, 9.831414372D-02, 3.139999881D-02,
     6 3.139999881D-02, 1.677767560D-02, 7.559744176D-03,
     7 5.394770764D-03/
C * DATA FOR AT ELEMENT #85
      DATA NORB(85)/24/
      DATA (BINDNRG(85, II), II = 1, 24)/
     1 95.7298965D0, 17.4930000D0, 16.7847004D0, 14.2134991D0,
     2 4.31699991D0, 4.00799990D0, 3.42600012D0, 2.90869999D0,
     3 2.78670001D0, 1.04200006D0, 0.885999978D0, 0.740000010D0,
     4 0.533200026D0, 0.475384623D0, 0.197075620D0, 0.190577224D0,
     5 0.185616866D0, 0.138499394D0, 0.108425982D0, 4.159419611D-02,
     6 3.766180575D-02, 1.933898404D-02, 9.031039663D-03,
     7 6.244503893D-03/
C * DATA FOR RN ELEMENT #86
      DATA NORB(86)/24/
      DATA (BINDNRG(86, II), II = 1, 24)/
     1 98.4039993D0, 18.0489998D0, 17.3370991D0, 14.6194000D0,
     2 4.48199987D0, 4.15899992D0, 3.53799987D0, 3.02149987D0,
     3 2.89240003D0, 1.09700000D0, 0.929000020D0, 0.768000007D0,
     4 0.566600025D0, 0.537000000D0, 0.219630763D0, 0.212587610D0,
     5 0.200830922D0, 0.151771158D0, 0.118816562D0, 4.869114980D-02,
     6 4.425504431D-02, 2.193967439D-02, 1.057260949D-02,
     7 7.125876378D-03/
C * DATA FOR FR ELEMENT #87
      DATA NORB(87)/24/
      DATA (BINDNRG(87, II), II = 1, 24)/
     1 101.137001D0, 18.6389999D0, 17.9064999D0, 15.0311995D0,
     2 4.65199995D0, 4.32700014D0, 3.66300011D0, 3.13619995D0,
     3 2.99970007D0, 1.15300000D0, 0.980000019D0, 0.810000002D0,
     4 0.603300035D0, 0.577000022D0, 0.246488422D0, 0.238862991D0,
     5 0.220035478D0, 0.169009268D0, 0.132957444D0, 5.953782797D-02,
     6 5.455289036D-02, 2.786786854D-02, 1.516497415D-02,
     7 1.061226334D-02/
C * DATA FOR RA ELEMENT #88
      DATA NORB(88)/24/
      DATA (BINDNRG(88, II), II = 1, 24)/
     1 103.921898D0, 19.2367001D0, 18.4843006D0, 15.4444008D0,
     2 4.82200003D0, 4.48950005D0, 3.79180002D0, 3.24839997D0,
     3 3.10490012D0, 1.20840001D0, 1.05760002D0, 0.879100025D0,
     4 0.635900021D0, 0.602699995D0, 0.298900008D0, 0.298900008D0,
     5 0.254399985D0, 0.200399995D0, 0.152799994D0, 6.719999760D-02,
     6 6.719999760D-02, 4.349999875D-02, 1.879999973D-02,
     7 1.879999973D-02/
C * DATA FOR AC ELEMENT #89
      DATA NORB(89)/24/
      DATA (BINDNRG(89, II), II = 1, 24)/
     1 106.755302D0, 19.8400002D0, 19.0832005D0, 15.8710003D0,
     2 5.00199986D0, 4.65600014D0, 3.90899992D0, 3.37019992D0,
     3 3.21900010D0, 1.26900005D0, 1.08000004D0, 0.889999986D0,
     4 0.674899995D0, 0.637000024D0, 0.303943723D0, 0.295067102D0,
     5 0.261255294D0, 0.206171408D0, 0.163234457D0, 8.313610405D-02,
     6 7.693891972D-02, 4.046359286D-02, 2.518509701D-02,
     7 1.840208657D-02/
C * DATA FOR TH ELEMENT #90
      DATA NORB(90)/24/
      DATA (BINDNRG(90, II), II = 1, 24)/
     1    109.650902D0,    20.4720993D0,   19.6932011D0,   16.3003006D0,
     2    5.18230009D0,    4.83039999D0,   4.04610014D0,   3.49079990D0,
     3    3.33200002D0,    1.32949996D0,   1.16820002D0,  0.967299998D0,
     4   0.714100003D0,   0.676400006D0,  0.344399989D0,  0.335200012D0,
     5   0.290199995D0,   0.229399994D0,  0.181800008D0,9.430000186d-02,
     6 8.789999783D-02, 5.950000137D-02,4.899999872D-02,4.300000146D-02/
C * DATA FOR PA ELEMENT #91
      DATA NORB(91)/24/
      DATA (BINDNRG(91, II), II = 1, 24)/
     1    112.601402D0,    21.1045990D0,   20.3136997D0,   16.7331009D0,
     2    5.36689997D0,    5.00090027D0,   4.17379999D0,   3.61119986D0,
     3    3.44179988D0,    1.38710010D0,   1.22430003D0,   1.00670004D0,
     4   0.743399978D0,   0.708199978D0,  0.371199995D0,  0.359499991D0,
     5   0.309599996D0,   0.233623788D0,  0.183050051D0,9.667889029D-02,
     6 8.924079686D-02, 4.545853287D-02,2.854512073D-02,2.032056637D-02/
C * DATA FOR U  ELEMENT #92
      DATA NORB(92)/24/
      DATA (BINDNRG(92, II), II = 1, 24)/
     1    115.606102D0,   21.7574005D0,   20.9475994D0,   17.1662998D0,
     2    5.54799986D0,   5.18219995D0,   4.30340004D0,   3.72760010D0,
     3    3.55169988D0,   1.44080007D0,   1.27259994D0,   1.04489994D0,
     4   0.780399978D0,  0.737699986D0,  0.391299993D0,  0.380899996D0,
     5   0.323700011D0,  0.259299994D0,  0.195100009D0,  0.104999997D0,
     6 9.629999846D-02,7.069999725D-02,4.230000079D-02,3.229999915D-02/
      END BLOCK DATA ATOM_DATA
 
      MODULE pluto
      SAVE
      INTEGER, PARAMETER              :: NP0  = 6
      INTEGER, PARAMETER              :: MP7  = 256
      INTEGER, PARAMETER              :: NP14 = 64
      INTEGER, PARAMETER              :: NP32 = 63
      INTEGER, PARAMETER              :: NP33 = 15
      INTEGER, PARAMETER              :: NP43 = 12
      INTEGER, PARAMETER              :: NP48 = 2000
      INTEGER, PARAMETER              :: NP49 = 5000000
      INTEGER                         :: NSF
      INTEGER                         :: NFHAT
      INTEGER, DIMENSION(2, NP48)     :: MOL
      INTEGER, DIMENSION(32)          :: IBT
      INTEGER, DIMENSION(NP32)        :: KRS
      INTEGER, DIMENSION(9)           :: NCRS
      INTEGER, DIMENSION(17)          :: NPRS
      INTEGER, DIMENSION(MP7, 3)      :: IPPR
      INTEGER, DIMENSION(16)          :: NUNIT
      REAL,    DIMENSION(3, 3)        :: A
      REAL,    DIMENSION(3, 3)        :: R
      REAL,    DIMENSION(3)           :: T
      REAL,    DIMENSION(NP49)        :: RA
      REAL,    DIMENSION(3, 3)        :: OM
      REAL,    DIMENSION(NP14)        :: RP
      REAL,    DIMENSION(15)          :: ZU
      REAL,    DIMENSION(3)           :: TRL
      REAL,    DIMENSION(3, 3)        :: ROM
      REAL,    DIMENSION(3, 3)        :: TMX
      REAL,    DIMENSION(3, 3)        :: TMY
      REAL,    DIMENSION(4, NP32)     :: RCG
      REAL,    DIMENSION(3)           :: XJS
      REAL,    DIMENSION(3)           :: SEP
      REAL,    DIMENSION(192, 3)      :: XTT
      REAL,    DIMENSION(3)           :: DLIM
      REAL,    DIMENSION(3)           :: SHFT
      REAL,    DIMENSION(8)           :: XYZK
      REAL,    DIMENSION(3)           :: XYZR
      REAL,    DIMENSION(3)           :: XYZJS
      REAL,    DIMENSION(3)           :: XYZOR
      REAL,    DIMENSION(6)           :: XYZPL
      REAL,    DIMENSION(3)           :: RASGX
      CHARACTER(len=20)               :: TEXT = ' '
      CHARACTER(len=2), DIMENSION(16) :: SFC
      END MODULE pluto
 
C *====================================================================
      SUBROUTINE PLUTON (MPLUT)
C *====================================================================C
C *                                                                    C
C *                          P L U T O N                               C
C *                       =================                            C
C *                                                                    C
C *         PROGRAM FOR THE AUTOMATED DISPLAY AND ANALYSIS OF          C
C *                                                                    C
C *                  CRYSTAL AND MOLECULAR STRUCTURES                  C
C *                           =========                                C
C *                                                                    C
C * (C) 1979-2018  A.L. SPEK, UTRECHT UNIVERSITY, THE NETHERLANDS.     C
C *                                                                    C
C *                         PROGRAM HISTORY                            C
C *                         ===============                            C
C * CDC NOS/BE        IMPLEMENTATION (PLUTO78/Clegg) & EXTENSION  1979 C
C * MICROVAX-II/VMS   IMPLEMENTATION & EXTENSION ................ 1986 C
C * IBM-PC/AT         IMPLEMENTATION ............................ 1986 C
C * CDC-CYBER -NOS/VE IMPLEMENTATION ............................ 1986 C
C * CONVEX-UNIX       IMPLEMENTATION ............................ 1989 C
C * SILICON-GRAPHICS  IMPLEMENTATION ............................ 1990 C
C * DECstation5000    IMPLEMENTATION & EXTENSION ................ 1990 C
C * IBM-RS/6000       IMPLEMENTATION ............................ 1992 C
C * 80386/Linux       IMPLEMENTATION ............................ 1992 C
C * SG-Challenge      IMPLEMENTATION ............................ 1993 C
C * AXP/OSF           IMPLEMENTATION ............................ 1993 C
C * DEC-Alpha         INTEGRATION within PLATON ................. 1997 C
C * MAC OSX (Intel)   ........................................... 2009 C
C * MAC OS  (M1)      ........................................... 2020 C
C *                                                                    C
C * THIS VERSION INCLUDES  FEATURES FOR INTERACTIVE USE OF THE PROGRAM C
C * WITH                                             X-Window/UNIX     C
C *                HPGL,POSTSCRIPT                 - META FILE         C
C *                                                                    C
C *====================================================================C
C *                                                                    C
C * Acknowledgement: PLUTON has evolved by an evolutionary proces from C
C *                  the source code of PLUTO-78 (Motherwell & Clegg)  C
C *                  The current version probably doesn't contain any  C
C *                  original code and is several times larger than    C
C *                  the original version.                             C
C *********************************************************************C
C *********************************************************************C
C *====================================================================C
C *                      -------------                                 C
C *                      F  I  L  E  S                                 C
C *                      -------------                                 C
C *  UNIT 1  -  STANDARD PARAMETER INPUTFILE (SPF)                     C
C *  UNIT 2  -  DEFAULT INSTRUCTION FILE                               C
C *  UNIT 3  -  SAVE FILE FOR INSTRUCTIONS                             C
C *  UNIT 5  -  INTERACTIVE INPUT FROM CONSOLE                         C
C *  UNIT 6  -  INTERACTIVE OUTPUT TO  CONSOLE                         C
C *  UNIT 9  -  JOURNAL FILE OF INSTRUCTIONS                           C
C *                                                                    C
C *====================================================================C
C * PLUTON            - INPUT read/interpretation                      C
C * PLUT01            - INITIALISATION full/partial                    C
C * PLUT02            - PLOTTING (ATOMS, BONDS, LABELS)                C
C * PLUT03            - ATOM CARD HANDLING                             C
C * PLUT04            - LABEL Setting and plotting                     C
C * PLUT05            - SET UP OF BOND arrays                          C
C * PLUT06            - VIEW option management                         C
C * PLUT07            - BOND DISTANCE scanning                         C
C * PLUT08            - GENERATE MINIMUM OVERLAP ROTATION MATRIX       C
C * PLUT09            - IN/EX-CLUDE MANAGEMENT OF ATOMS                C
C * PLUT10            - BOND DRAWING                                   C
C * PLUT11            - ATOM CIRCLE DRAWING                            C
C * PLUT12            - MANAGEMENT OF MOST PRINTING                    C
C * PLUT13            - ATOM NAME PROCESSING                           C
C * PLUT14            - PLOT ATOM ITEM STORAGE/RETRIEVAL MANAGEMENT    C
C * PLUT15            - ATOM FLAG STORAGE/RETRIEVAL                    C
C * PLUT16            - BOND STORAGE AND RETRIEVAL                     C
C * PLUT17            - MANAGEMENT OF ARU (=MOLES) ARRAY               C
C * PLUT18            - GENERATE OBSCURATION LIST                      C
C * PLUT19            - OBSCURATION MANAGEMENT                         C
C * PLUT20            - INTERSECTION TEST                              C
C * PLUT21            - MANAGEMENT OF THE VARIOUS RADIUS OPTIONS       C
C * PLUT22            - CALCULATE DISTANCE                             C
C * PLUT23            - ORTHOGONALISATION MANAGEMENT                   C
C * PLUT24            - AD_HOC GEOMETRY CALCULATION                    C
C * PLUT25            - UNPACK LABEL INFORMATION                       C
C * PLUT26            - GENERATION OF LABEL POSITIONS                  C
C * PLUT27            - GET RBO & NLI                                  C
C * PLUT28            - HANDLE SPECIAL JOIN/LABEL/VIEW/DIST ARU        C
C * PLUT29            - RENAME/DELETE ETC RES-FILE                     C
C * PLUT30            - ACTUAL CIRCLE PLOTTING                         C
C * PLUT31            - PUT DIAMOND                                    C
C * PLUT32            - RENAME                                         C
C * PLUT33            - LOAD UNITCELL PLOT DATA                        C
C * PLUT35            - EXPAND ARU/MOLECULE                            C
C * PLUT36            - SHADE MODE                                     C
C * PLUT37            - ANGLE, TORSION CALCULATION                     C
C * PLUT38            - ERROR HANDLING                                 C
C * PLUT39            - PACK RANGE/PLAN                                C
C * PLUT40            - TEST FOR D-H                                   C
C * PLUT41            - SUPPORT RENAME                                 C
C * PLUT42            - SUPPORT HFIX                                   C
C * PLUT43            - FIND NEAREST ITEM                              C
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE pluto
      USE chdat
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: M
      INTEGER           :: N
      INTEGER           :: N1
      INTEGER           :: N2
      INTEGER           :: NA
      INTEGER           :: KN
      INTEGER           :: KL
      INTEGER           :: IP
      INTEGER           :: IS
      INTEGER           :: NB
      INTEGER           :: NE
      INTEGER           :: NN
      INTEGER           :: NS
      INTEGER           :: NSS
      INTEGER           :: NED
      INTEGER           :: NEI
      INTEGER           :: KN7
      INTEGER           :: KL0
      INTEGER           :: KLI
      INTEGER           :: KLM
      INTEGER           :: IMD
      INTEGER           :: IAT
      INTEGER           :: JAT
      INTEGER           :: IER
      INTEGER           :: ISW
      INTEGER           :: NAX
      INTEGER           :: NQX
      INTEGER           :: NATL
      INTEGER           :: NATX
      INTEGER           :: IVAL
      INTEGER           :: ITRS
      INTEGER           :: ICOL
      INTEGER           :: IDUM
      INTEGER           :: IEND
      INTEGER           :: IBWC
      INTEGER           :: IBEG
      INTEGER           :: IAT1
      INTEGER           :: IATK
      INTEGER           :: IASU
      INTEGER           :: IHAT
      INTEGER           :: IPDC
      INTEGER           :: JUNK
      INTEGER           :: KADD
      INTEGER           :: MNFX
      INTEGER           :: MODE
      INTEGER           :: NIEN
      INTEGER           :: NQSM
      INTEGER           :: NPROP
      INTEGER           :: KSTEP
      INTEGER           :: IXPK1
      INTEGER           :: IXPK2
      INTEGER           :: INQNR
      INTEGER           :: JNQNR
      INTEGER           :: MPLUT
      INTEGER           :: IGBL8
      INTEGER           :: MADDR
      INTEGER           :: MNFIX
      INTEGER           :: NHAUTO
      INTEGER           :: MSUBST
      INTEGER           :: IGBL30
      REAL              :: XL
      REAL              :: YL
      REAL              :: ZL
      REAL              :: RL
      REAL              :: P15
      REAL              :: DET
      REAL              :: FNK
      REAL              :: XDUM
      REAL              :: PAR40
      CHARACTER(len=2)  :: JK12
      CHARACTER(len=3)  :: JK13
      CHARACTER(len=3)  :: N12
      CHARACTER(len=5)  :: J215
      CHARACTER(len=7)  :: CLR
      CHARACTER(len=10) :: BCKG
      CHARACTER(len=10) :: BCOL
      CHARACTER(len=10) :: IFLNQ
      CHARACTER(len=20) :: HCOL
C * MPLUT = -1 - NATIVE, RENAME, HFIX, ANIS FLAGS
C * MPLUT =  0 - S-MODE
C * MPLUT =  1 - FROM PLATON
C * MPLUT =  2 - FROM ADDSYM
      IGBL30   = 0
      IGBL8    = 0
      PAR40    = 0.0
      IGBL(63) = 0
C * MAIN PLUTON ROUTINE
      IF (MPLUT /= 0) THEN
C * TEST FOR 'FROM PLATON' OR 'ADDSYM'
        CLOSE (UNIT = LU1)
C * FROM PLATON OR ADDSYM
        IF (MPLUT > 0) THEN
C * TEST FOR OUTPUT TYPE ON LU2
          IF (IGBL(31) /= 0) THEN
            CLOSE (UNIT = LU2, IOSTAT = IOST)
            IGBL(31) = 0
            IGBL(2)  = 0
          END IF
          IGBL(23) = 0
        END IF
C * TEST FOR CIF
        IF (IABS(IGBL(8)) == 3) THEN
          FN(1) = IGBL(54)
C * SET 'CALC ADDSYM' to DEFAULT ZERO
          IPR(205) = 0
          IPR(220) = 1
          IPR(221) = 1
C * HANDLE MULTIPLE ENTRY INPUT FILE
          CALL PLA007
        END IF
        IGBL30 = IGBL(30)
        IGBL8  = IGBL(8)
        IF (IPR(504) == 1) IGBL(30) = 0
C * MPLUT = 0 CASE
      ELSE
        INQUIRE (UNIT = LU23, OPENED = OPEND)
        IF (OPEND) CLOSE (UNIT = LU23)
      END IF
C * INIT
      CALL PLUT01 (-1)
C * LOOP: READ AND INTERPRET UNTIL FIRST PLOT INSTRUCTION
C * MOUSE LOOP - CHECK # PLOT (= IGBL(2))
   10 IF (IGBL(2) > 0) THEN
C * TEST FOR 'AUTO-S'-MODE
        IF (IGBL(50) == 0) THEN
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          IF (IGGT(1:3) == 'END') IGBL(2) = -1
        ELSE
C * HFIX
          IF (IGBL(3) == 13) THEN
            CALL PLA280 ('HFIX')
C * ANIS
          ELSE IF (IGBL(3) == 26) THEN
            CALL PLA280 ('ANIS')
          END IF
        END IF
      END IF
      IGBL(2)  = IGBL(2) + 1
      IF (IGBL(2) == 0) GO TO 300
C * INITIALISE
      ISW = 0
   20 CALL PLUT01 (0)
C * UNITCELL ON FOR ADDSYM/PLUTON
C * CHECK for AUTO-PLOT
      IF (IGBL(35) == 1) GO TO 50
      IGBL(24) = 1
      IF (IGBL(5) == LU23) IGBL(5) = LU5
C * ALL DATA CARDS READ HERE (UNIT IGBL(5) = LU1, LU23, LU3 OR LU5)
C * LU1  = CRYSTALLOGRAPHIC PARAMETER DATA
C * LU23 = DEFAULT INSTRUCTIONS
C * LU3  = SAVE FILE INSTRUCTIONS
C * LU5  = INTERACTIVE INPUT INSTRUCTIONS
   30 CALL GEN038 (IGGT, 1, 80)
      IF (IGBL(5) * IGBL(24) * IGBL(25) == LU5) THEN
        IF (IGBL(50) == 0) THEN
C * WHAT NEXT ?
          CALL PLA012 (0, 1)
          IF (IGGT(1:1) == ' ') GO TO 30
        ELSE
          GO TO 290
        END IF
      END IF
      GO TO 50
C * AUTO-PLOT
   40 IF (IGBL(5) * IGBL(24) * IGBL(25) == LU5) THEN
        IF (IGBL(35) /= 1) GO TO 30
        CALL PLA280 ('PLOT')
      END IF
C * FREE FORMAT READ LOOP
C * THE INPUT FILE CAN BE SPF, RES, CIF OR PDB STYLE
   50 CALL PLA006 (1, ISW)
      IF (IGBL(8) == 0) THEN
        IF (ICL(1:1) == '#') GO TO 50
      END IF
C * INIT 'RESET'
      IPR(170) = 0
      IF (ISW > 1) THEN
C * CHECK ISAVE (IGBL(45))
        IF (IGBL(5) == LU5 .AND. IGBL(45) > 0) THEN
          WRITE (LU3, 99987, IOSTAT = IOST) ICL(1:80)
          WRITE (LU6, 99978, IOSTAT = IOST) ICL(1:70)
C * ISW = 14 = END
          IF (ISW /= 14) THEN
C * COUNT # SAVE RECORDS
            IGBL(45) = IGBL(45) + 1
          ELSE
            IGBL(45) = -1
          END IF
        END IF
      ELSE IF (ISW < 1) THEN
        GO TO 250
      END IF
      KL = IPR(220)
      KN = IPR(221)
      IF (KL == 0 .AND. KN == 0) GO TO 50
C * ISW = 1: ATOM ? DATA
      IF (ISW == 1) THEN
        GO TO 120
C * ISW = 2: TITL - TITLE FOR PLOT
      ELSE IF (ISW == 2) THEN
        JID(1:74) = ICL(5:78)
        GO TO 220
C * ISW = 3: MESS - MESSAGE DISPLAY
      ELSE IF (ISW == 3) THEN
        WRITE (LU6, 99976, IOSTAT = IOST) ICL(5:80)
        GO TO 220
C * ISW = 4: REMARK
      ELSE IF (ISW == 4) THEN
        GO TO 220
C * ISW = 5: CELL CONSTANTS
      ELSE IF (ISW == 5) THEN
        IF (KN == 1) THEN
          FN(2)    = FN(1)
          FN(3)    = FN(1)
          IPR(221) = 3
          KN       = IPR(221)
        END IF
        IF (KN == 3) THEN
          FN(4)    = 90.0
          FN(5)    = 90.0
          FN(6)    = 90.0
          IPR(221) = 6
          KN       = IPR(221)
        END IF
        IF (KN == 6) THEN
          KN7 = 0
        ELSE IF (KN == 7) THEN
          KN7 = 1
        ELSE
          IPR(72) = 1
          GO TO 220
        END IF
        DO I = 1, 6
          PAR(100 + I) = FN(I + KN7)
        END DO
C * SET FOR FRACTIONAL COORDINATE DATA EXPECTED
        IPR(50) = 0
        GO TO 220
C * ISW = 6: SPGR
      ELSE IF (ISW == 6) THEN
        GO TO 110
C * ISW = 7: LATT
      ELSE IF (ISW == 7) THEN
        GO TO 110
C * ISW = 8: LIST
      ELSE IF (ISW == 8) THEN
        GO TO 240
C * ISW = 9: SYMM
      ELSE IF (ISW == 9) THEN
        GO TO 110
C * ISW = 10: ANGSTROM
      ELSE IF (ISW == 10) THEN
        IF (KL == 1) THEN
          IF (IPR(50) == 0 .AND. PAR(101) > 0.0) THEN
            IPR(156) = 1
          ELSE
            IPR(50) = - 1
            IF (KN >= 1) PAR(11) = FN(1)
          END IF
        END IF
        GO TO 220
C * ISW = 11: ROD MODE
      ELSE IF (ISW == 11) THEN
        IF (IPR(4) /= 2 .OR. KL == 1) THEN
          IPR(4) = 2
          CALL PLUT21 (-1)
        END IF
        GO TO 170
C * ISW = 12: ATOM RECORD
      ELSE IF (ISW == 12) THEN
        GO TO 120
C * ISW = 13: JOIN (CALC)
      ELSE IF (ISW == 13) THEN
        GO TO 140
C * ISW = 14: END
      ELSE IF (ISW == 14) THEN
        IF (IGBL(5) == LU1 .AND. IGBL(8) == 2 .AND.
     1      IGBL(95) /= 0) THEN
          GO TO 30
        ELSE
         GO TO 260
        END IF
C * ISW = 17: U
      ELSE IF (ISW == 17) THEN
        GO TO 130
C * ISW = 18/161: VIE(W)
      ELSE IF (ISW == 18 .OR. ISW == 161) THEN
        CALL PLUT06
        GO TO 220
C * ISW = 19/162: SOL(ID) MODE
      ELSE IF (ISW == 19 .OR. ISW == 162) THEN
        IF (IPR(4) /= 1 .OR. KL == 1) THEN
          IPR(4) = 1
          CALL PLUT21 (-1)
        END IF
      GO TO 170
C * ISW = 20/163: STI(CK) MODE
      ELSE IF (ISW == 20 .OR. ISW == 163) THEN
        IPR(4) = 0
        CALL PLUT21 (-1)
        GO TO 170
C * ISW = 21/158: LAB(EL) - INSTRUCTION
      ELSE IF (ISW == 21 .OR. ISW == 158) THEN
        CALL PLUT04 (2, 0)
        GO TO 220
C * ISW = 22/164: UNL(ABEL) - INSTRUCTION
      ELSE IF (ISW == 22 .OR. ISW == 164) THEN
        CALL PLUT04 (3, 0)
        GO TO 220
C * ISW = 23: PUT INSTRUCTION
      ELSE IF (ISW == 23) THEN
        CALL PLUT04 (4, 0)
        GO TO 220
C * ISW = 24: RADII - INSTRUCTION
      ELSE IF (ISW == 24) THEN
        CALL PLUT21 (0)
        GO TO 220
C * ISW = 25/168: PAC(KING) DIAGRAM CONTROL
      ELSE IF (ISW == 25 .OR. ISW == 168) THEN
        IF (IPR(37) == IPR(69)) THEN
          WRITE (LU6, 99993, IOSTAT = IOST)
          IPR(72) = 8
        ELSE
          IF (IPR(17) == 0) THEN
            CALL PLUT05
C * CALL EXIT/STOP
            IF (IPR(72) /= 0) CALL GEN127 ('304')
          END IF
          CALL PLUT39
          IPR(46) = 1
        END IF
        GO TO 220
C * ISW = 26: MOLES/ARU
      ELSE IF (ISW == 26) THEN
        GO TO 180
C * ISW = 27/165: INC(LUDE)
      ELSE IF (ISW == 27 .OR. ISW == 165) THEN
        N = 1
        GO TO 210
C * ISW = 28/166: EXC(LUDE)
      ELSE IF (ISW == 28 .OR. ISW == 166) THEN
        N = 0
        GO TO 210
C * ISW = 29/167: UNITCELL TO BE PLOTTED(OR UNIT CARD)
      ELSE IF (ISW == 29 .OR. ISW == 167) THEN
        IF (IPR(37) > IPR(69)) THEN
          IF (IPR(50) == 0) THEN
            IF (KL > 1 .AND. IFL(2)(2:2) == 'F') THEN
              IPR(46) = 0
            ELSE
              IPR(46) = 1
            END IF
C * SET INCLUDE BIT
            DO I = 1, 8
              CALL PLUT15 (1, I, 27, IPR(46))
            END DO
            IF (KN == 2) THEN
              PAR(75)  = FN(1)
              IPR(107) = NINT (FN(2))
            END IF
C * SET REBUILD
            IPR(130) = 0
          ELSE
            GO TO 30
          END IF
        ELSE IF (IABS (IGBL(8)) == 2) THEN
          DO I = 1, KN
            NUNIT(I) = NINT (FN(I))
          END DO
          GO TO 220
        END IF
        GO TO 220
C * ISW = 30: RETRACE INSTRUCTION
      ELSE IF (ISW == 30) THEN
        IF (KN > 0) THEN
          IF (KL > 1) THEN
            IF (IFL(2)(1:1) /= 'L') THEN
              IF (IFL(2)(1:1) == 'A') THEN
C * RETRACE ATOMS
                IPR(5) = NINT (FN(1))
                IF (KN == 2) PAR(3) = FN(2)
              ELSE
                IPR(72) = 5
              END IF
            ELSE
C * RETRACE LABELS
              IPR(7) = NINT (FN(1))
              IF (KN >= 2) PAR(4) = FN(2)
            END IF
          ELSE
            IPR(72) = 6
          END IF
        ELSE
          IPR(72) = 7
        END IF
        GO TO 220
C * ISW = 31: STEREO/MONO INSTRUCTION
      ELSE IF (ISW == 31) THEN
        PAR(25)  = 1.0
C * SET REBUILD
        IPR(130) = 0
        IPR(143) = IPR(19)
        IPR(144) = IPR(19)
C * STEREO - MODE
        IF (ICL(1:1) == 'S') THEN
          IPR(116) = -1
          PAR(48)  = PAR(12)
          IPR(6)   = 1
          IF (PAR(18) < 0) PAR(18) = - PAR(50) / 2.0
C * MONO - MODE
        ELSE IF (ICL(1:1) == 'M') THEN
          IPR(346) = IABS (IPR(346))
          IPR(116) = 0
          PAR(48)  = 0.0
          IPR(6)   = 0
          IF (PAR(18) < 0) PAR(18) = - PAR(50)
        END IF
        IF (KL > 1) THEN
          DO I = 2, KL
C * STEREO RedGreen, GreenRed, RedBlue OR BlueRed PAIR
            IF (IFL(I)(1:1) == 'R' .OR. IFL(I)(1:1) == 'G') THEN
              IPR(6)   = 0
              IPR(477) = 0
              IF (IFL(I)(1:1) == 'R') THEN
                IPR(346)   = - IABS (IPR(346))
                IPR(143)   = 2
                IF (IFL(I)(2:2) == 'B') THEN
                  IPR(144) = 4
                ELSE
                  IPR(144) = 3
                END IF
              ELSE
                IPR(346)   = - IABS (IPR(346))
                IPR(144)   = 2
                IF (IFL(I)(1:1) == 'B') THEN
                  IPR(143) = 4
                ELSE
                  IPR(143) = 3
                END IF
              END IF
              IF (PAR(18) < 0) PAR(18) = - PAR(50)
C * CROSSED - SUBKEYWORD
            ELSE IF (IFL(I)(1:1) == 'C') THEN
              IPR(6)  = -1
C * SMALL - SUBKEYWORD
            ELSE IF (IFL(I)(1:1) == 'S') THEN
              PAR(25) = 0.5
C * PERSPECTIVE - SUBKEYWORD
            ELSE IF (IFL(I)(1:1) == 'P') THEN
              PAR(48) = PAR(12)
C * RESET PERSPECTIVE - DEFAULT
              IF (KN > 0) THEN
                IF (FN(1) > 0.1) THEN
                  PAR(48) = FN(1)
                  IF (PAR(48) >= 10000.0) PAR(48) = 0.0
                END IF
              END IF
            END IF
          END DO
        END IF
        GO TO 220
C * ISW = 33: SIZE CONTROL: SIZE OF DRAWING, SCALE, LABELS,TITLE
      ELSE IF (ISW == 33) THEN
        IF (IGBL(8) /= 2) THEN
          IF (KN == KL) THEN
C * SET REBUILD
            IPR(130) = 0
            DO K = 1, KL
              JK13 = IFL(K)(1:3)
C * SIZE
              IF (JK13 == 'SIZ') THEN
C * DUMMY FOR NOW
                PAR(15) = FN(K)
C * RATIO
              ELSE IF (JK13 == 'RAT') THEN
                PAR(18) = FN(K)
C * SCALE
              ELSE IF (JK13 == 'SCA') THEN
                PAR(16) = FN(K)
C * TITLE (SIZE)
              ELSE IF (JK13 == 'TIT') THEN
                PAR(14) = FN(K)
C * CHARARACTER (SIZE)
              ELSE IF (JK13 == 'CHA') THEN
                PAR(349) = FN(K)
              END IF
            END DO
          END IF
          P15 = - PAR(15)
          WRITE (LU6, 99994, IOSTAT = IOST)
     1      PAR(18), PAR(14), P15, PAR(16), VERT, PAR(349)
          GO TO 220
        END IF
C * ISW = 34: PLOT INSTRUCTION
      ELSE IF (ISW == 34) THEN
        IPR(151) = 0
        IF (IPR(157) > 0) THEN
          IPR(130) = 0
          IPR(157) = 0
        END IF
        GO TO 280
C * ISW = 35: RESET - SET DEFAULTS AND CLEAR FLAGS
      ELSE IF (ISW == 35) THEN
        CALL PLUT01 (1)
        GO TO 220
C * ISW = 36: SEGMENT = PLOTSTEP SIZE (CM)
      ELSE IF (ISW == 36) THEN
        IF (KN > 0) THEN
          PAR(5) = FN(1)
          IF (KN > 1) IPR(111) = NINT (FN(2))
        END IF
        WRITE (LU6, 99999, IOSTAT = IOST) PAR(5), IPR(111)
        GO TO 220
C * ISW = 38: HP MANAGEMENT
      ELSE IF (ISW == 38) THEN
        IPDC = -2
        IF (KL > 1) THEN
          IF (IFL(1)(3:3) == 'P') IPDC = -4
          IF (IFL(2)(2:2) == 'N') IPDC = IABS (IPDC)
          CALL GGIP (-999.0, 0.0, 0.0, IPDC)
        END IF
        GO TO 220
C * ISW = 39: CAL MANAGEMENT
      ELSE IF (ISW == 39) THEN
        IPDC = -3
        IF (KL > 1) THEN
          IF (IFL(1)(3:3) == 'P') IPDC = -4
          IF (IFL(2)(2:2) == 'N') IPDC = IABS (IPDC)
          CALL GGIP (-999.0, 0.0, 0.0, IPDC)
        END IF
        GO TO 220
C * ISW = 40: COLOR/BWC MANAGEMENT
      ELSE IF (ISW == 40) THEN
        IF (IFL(1)(1:3) == 'BWC') THEN
          IBWC = 1
        ELSE
          IBWC = 0
        END IF
        IF (KL > 1) THEN
          JK13  = IFL(2)(1:3)
          KSTEP = IBWC + 1
C * COLOR TYPE
          IF (JK13 == 'TYP') THEN
            IF (KL >= 3 .AND. MOD (KL, KSTEP) == 0) THEN
              DO K = 3, KL, KSTEP
                CALL PLUT13 (0, -K, N1, XDUM)
                IF (N1 < 0) THEN
                  N1 = - N1
                  IF (IBWC == 1) THEN
                    DO J = 1, NP10 + 1
                      IF (IFL(K + 1)(1:3) == BWCT(J)(1:3)) GO TO 60
                    END DO
                    J        = 17
   60               IBCL(N1) = J
                  ELSE
                    IF (KN >= K - 2) IACL(N1) = NINT (FN(K - 2))
                    DO J = 1, NP10 + 1
                      IF (IFL(K + 1)(1:3) == COLR(J)(1:3)) GO TO 70
                    END DO
                    J        = 17
   70               IACL(N1) = J
                  END IF
                ELSE
                  WRITE (LU6, 99981, IOSTAT = IOST) IFL(K)
                END IF
              END DO
              IPR(90) = 256
            END IF
C * BWC/COLOR RESD
          ELSE IF (JK13 == 'RES') THEN
            IF (IFL(3)(1:3) == 'OFF') THEN
              IPR(346 - IBWC) = 0
              IPR(477 + IBWC) = 0
            ELSE
              IPR(346 - IBWC) = 1
              IPR(477 + IBWC) = -1
            END IF
C * BWC/COLOR ARU
          ELSE IF (JK13 == 'ARU') THEN
            IF (IFL(3)(1:3) == 'OFF') THEN
              IPR(346 - IBWC) = 0
              IPR(477 + IBWC) = 0
            ELSE
              IPR(346 - IBWC) = 1
              IPR(477 + IBWC) = 1
            END IF
          ELSE IF (JK13 == 'ON ') THEN
            IPR(346 - IBWC) = 1
          ELSE IF (JK13 == 'OFF') THEN
            IPR(346 - IBWC) = 0
          ELSE
            IPR(19) = 1
            IF (JK13 == 'RED') IPR(19) = 2
            IF (JK13 == 'GRE') IPR(19) = 3
            IF (JK13 == 'BLU') IPR(19) = 4
            IF (JK13 == 'YEL') IPR(19) = 5
            IF (JK13 == 'ORA') IPR(19) = 6
            IF (JK13 == 'VIO') IPR(19) = 7
            IF (JK13 == 'BRO') IPR(19) = 8
          END IF
        ELSE
          IF (IBWC == 1) THEN
            IPR(345) = 1
          ELSE
            IPR(346) = 1
          END IF
        END IF
        GO TO 220
C * ISW = 41: SET, PARAMETER MANIPULATION
      ELSE IF (ISW == 41) THEN
        IF (KL > 1) THEN
          JK12 = IFL(2)(1:2)
C * IPR/PAR/IGBL/RGBL - PARAMETER ARRAY
          IF (IFL(2)(1:3) == 'IPR' .OR.
     1        IFL(2)(1:3) == 'PAR' .OR.
     2        IFL(2)(1:3) == 'IGB' .OR.
     3        IFL(2)(1:3) == 'RGB') THEN
            CALL PLA206 (1, IFL(2)(1:3))
            GO TO 30
C * SET DISPLAY TYPE
          ELSE IF (JK12 == 'DI') THEN
            MEDIUM = 1
C * SET META-FILE TYPE
          ELSE IF (JK12 == 'ME') THEN
            MEDIUM = 2
C * SET WINDOW/DISPLAY FRACTION
          ELSE IF (JK12 == 'WI') THEN
            CALL GGIP (-999.0, 0.0, FN(1) * 1000.0, 9)
C * SET REVERSE
          ELSE IF (JK12 == 'RE') THEN
            IGBL(68) = MOD (IGBL(68) + 1, 2)
            CALL GGIP (-999.0, FLOAT (IGBL(68)), IGBL(62) * 0.25, 9)
          ELSE
            IPR(72) = 23
          END IF
          IF (IPR(72) == 0) THEN
            IF (KL > 2) THEN
              CALL GGIP (-999.0, 0.0, 0.0, 6)
            END IF
          END IF
        END IF
        GO TO 220
C * ISW = 42: OMIT
      ELSE IF (ISW == 42) THEN
        N = 0
        GO TO 210
C * ISW = 43/49/150: QUIT/STOP/EXIT
      ELSE IF (ISW == 43 .OR. ISW == 49 .OR. ISW == 150) THEN
        GO TO 290
C * ISW = 44: RESI
      ELSE IF (ISW == 44) THEN
        IPR(538) = NINT (FN(1))
        GO TO 220
C * ISW = 45: ANGLE CALCULATION
      ELSE IF (ISW == 45) THEN
        IF (KL == 4) THEN
          CALL PLUT24 (3, 0, IDUM)
          GO TO 30
        ELSE
          GO TO 220
        END IF
C * ISW = 46: DETACH
      ELSE IF (ISW == 46) THEN
        GO TO 150
C * ISW = 47: SAVE COMMAND
      ELSE IF (ISW == 47) THEN
        IGBL(45) = 1
        CALL GEN108 (LU3, 0)
        GO TO 220
C * ISW = 48: OVERLAP OPTION OFF = 0, BA = 1, BB = 2, ON = 3
      ELSE IF (ISW == 48) THEN
        IF (KL > 1) THEN
          N = 0
          DO K = 2, KL
            JK12 = IFL(K)(1:2)
C * OVERLAP SHADOW
            IF (JK12 == 'SH') THEN
              N = N + 1
              PAR(58) = FN(N)
C * OVERLAP MARGIN
            ELSE IF (JK12 == 'MA') THEN
              N = N + 1
              PAR(36) = FN(N)
C * ON AA, AB, BA, BB
            ELSE IF (JK12 == 'ON') THEN
              IPR(77) = 3
C * AB ATOM OVER BOND
            ELSE IF (JK12 == 'AB') THEN
              IPR(77) = 2
C * BA BOND OVER ATOM
            ELSE IF (JK12 == 'BA') THEN
              IPR(77) = 1
C * OFF
            ELSE IF (JK12 == 'OF') THEN
              IPR(77) = 0
            END IF
          END DO
        END IF
        WRITE (LU6, 99984, IOSTAT = IOST) IPR(77), PAR(36), PAR(58)
        GO TO 220
C * ISW = 51: BOX - INSTRUCTION
      ELSE IF (ISW == 51) THEN
        IF (KL > 1) THEN
C * SET REBUILD
          IPR(130) = 0
          N = 0
          DO K = 2, KL
            JK12 = IFL(K)(1:2)
C * BOX OFF
            IF (JK12 == 'OF') THEN
              IGBL(103) = 0
C * BOX ON
            ELSE IF (JK12 == 'ON') THEN
              IGBL(103) = 1
C * BOX SHRINK
            ELSE IF (JK12 == 'SH') THEN
              N = N + 1
              IF (N > KN) THEN
                IPR(72) = 12
                GO TO 220
              ELSE
                IF (FN(N) <= 1.0 .AND. FN(N) > 0.01) THEN
                  PAR(13) = FN(N)
                ELSE
                  CALL PLUT38 (6, 0, LU6)
                END IF
              END IF
C * BOX RATIO
            ELSE IF (JK12 == 'RA') THEN
              N = N + 1
              IF (N > KN) THEN
                IPR(72) = 13
                GO TO 220
              ELSE
                PAR(18) = FN(N)
              END IF
            END IF
          END DO
        END IF
        IF (IGBL(103) == 1) THEN
          N12 = 'ON '
        ELSE
          N12 = 'OFF'
        END IF
        WRITE (LU6, 99985, IOSTAT = IOST) N12, PAR(13), ABS(PAR(18))
        GO TO 220
C * ISW = 52: FVAR - SHELX76 STYLE
      ELSE IF (ISW == 52) THEN
        IGBL(8) = 2
        IPR(81) = 1
        IF (IPR(13) + KN > NP14) CALL PLUT38 (7, 1, LU6)
        DO I = 1, KN
          RP(IPR(13) + I) = MOD (FN(I) + 5.0, 10.0) - 5.0
        END DO
        IPR(13) = IPR(13) + KN
        GO TO 220
C * ISW = 53: HELP OPTION
      ELSE IF (ISW == 53) THEN
        IWIN  = IGBL(25) * IGBL(32)
        CALL PLA299 (2)
        GO TO 220
C * ISW = 55: B-ISO
      ELSE IF (ISW == 55) THEN
        GO TO 130
C * ISW = 58: CPK STYLE
      ELSE IF (ISW == 58) THEN
        IF (IABS (IPR(4)) /= 3 .OR. KL == 1) CALL PLUT21 (1)
        GO TO 170
C * ISW = 59: SFAC - SHELX STYLE
      ELSE IF (ISW == 59) THEN
        IF (IABS (IGBL(8)) /= 2) THEN
          IGBL(8) = 2
          NSF     = 0
          NFHAT   = 0
        END IF
        DO I = 2, KL
          NSF = NSF + 1
          SFC(NSF) = IFL(I)(1:2)
          IF (SFC(NSF) == 'H ') NFHAT = 1
        END DO
        GO TO 220
C * ISW = 62: DISTANCE CALCULATION
      ELSE IF (ISW == 62) THEN
        CALL PLUT24 (2, 0, IDUM)
        GO TO 30
C * ISW = 63: TORSION CALCULATION
      ELSE IF (ISW == 63) THEN
        CALL PLUT24 (4, 0, IDUM)
        GO TO 30
C * ISW = 65: TRNS/TRMX INSTRUCTION
      ELSE IF (ISW == 65) THEN
        IF (KN /= 1) THEN
          IF (IPR(37) <= IPR(69)) THEN
            CALL GEN074 (SGX, 1, 13, 0.0)
            SGX(1) = 1.0
            SGX(5) = 1.0
            SGX(9) = 1.0
C * TRANSFORMATION MATRIX
            IF (KN == 9 .OR. KN == 12) THEN
C * REGISTER TRMX
              IPR(127) = 1
              K        = 0
              DO I = 1, 3
                DO J = 1, 3
                  K = K + 1
                  TMX(I, J) = FN(K)
                  SGX(K)    = FN(K)
                END DO
              END DO
C * GET TRANSPOSED INVERTED MATRIX -TMY- FROM -TMX-
              CALL GEN003 (TMX, A, DET, 0)
              WRITE (LU6, 99973, IOSTAT = IOST) DET
              CALL GEN005 (A, TMY)
            END IF
C * STORE ORIGIN SHIFT
            IF (KN == 3 .OR. KN == 12) THEN
              IPR(128) = 1
              DO I = 1, 3
                SHFT(I) = - FN(KN - 3 + I)
                SGX(I + 9) = - SHFT(I)
              END DO
            END IF
          ELSE
            WRITE (LU6, 99972, IOSTAT = IOST)
          END IF
C * SPECIAL FIX OPTION (KN = 1)
        ELSE
C * TEST FOR FIT IN SYMMETRY RANGE
          N = INT(ABS(FN(1)))
          IF (N > IPR(48)) THEN
            WRITE (LU6, 99986, IOSTAT = IOST) N, FN(1), IPR(48)
          ELSE
            IF (FN(1) < 0) THEN
C * FIX FOR FIRST ATOM IN NEW RESIDUE
              PAR(140) = FN(1)
            ELSE
C * FIX FOR NEXT ATOM
              PAR(141) = FN(1)
            END IF
          END IF
        END IF
        GO TO 220
C * ISW = 67: INORG - INSTRUCTION
      ELSE IF (ISW == 67) THEN
        IGBL(97) = 0
        GO TO 220
C * ISW = 68: ORGA - INSTRUCTION
      ELSE IF (ISW == 68) THEN
        IGBL(97) = 1
        GO TO 220
C * ISW = 69: STRAW STYLE
      ELSE IF (ISW == 69) THEN
        IF (IPR(4) /= 4 .OR. KL == 1) THEN
          IPR(4) = 4
          CALL PLUT21 (-1)
        END IF
        GO TO 170
C * ISW = 70: INFO
      ELSE IF (ISW == 70) THEN
        GO TO 240
C * ISW = 72: CROT(X/Y/Z)(M) (STEPS, (NR-STEPS)) (COLOR) INSTRUCTION
      ELSE IF (ISW == 72) THEN
        IF (KN > 0) PAR(145) = FN(1)
        IF (KN > 1) IPR(152) = NINT (FN(2))
        IPR(346) = - IABS (IPR(346))
        IF (IABS(IPR(4)) == 3) IPR(4) = -3
C * CHECK AUTOPLOT
        IGBL(35) = 1
C * TEST FOR X, Y OR Z CROT
        IF (IFL(1)(5:5) == 'X') THEN
          IPR(155) = 1
        ELSE IF (IFL(1)(5:5) == 'Z') THEN
          IPR(155) = 3
        ELSE
          IPR(155) = 2
        END IF
        IF (IFL(1)(6:6) == 'M') THEN
          IPR(164) = -1
        ELSE
          IPR(164) = 1
        END IF
        IPR(336) = 0
        IF (KL > 1 .AND. IFL(2)(1:1) == 'C') IPR(336) = 1
        IPR(151) = IPR(152)
        IPR(130) = 0
C * SET META OFF
        CALL GGIP (-999.0, 0.0, 0.0, -3)
C * PLOT
        IPR(221) = 0
        KN       = IPR(221)
        IPR(220) = 1
        KL       = IPR(220)
        GO TO 280
C * ISW = 73: VIEW DEFINITION  XROT
      ELSE IF (ISW == 73) THEN
        CALL PLUT06
        GO TO 220
C * ISW = 74: VIEW DEFINITION YROT
      ELSE IF (ISW == 74) THEN
        CALL PLUT06
        GO TO 220
C * ISW = 75: VIEW DEFINITION ZROT
      ELSE IF (ISW == 75) THEN
        CALL PLUT06
        GO TO 220
C * ISW = 76: DEFINE INSTRUCTION (CREATE CENTROID PSEUDO-ATOM)
      ELSE IF (ISW == 76) THEN
        IF (IPR(17) == 0) THEN
          CALL PLUT05
C * CALL EXIT/STOP
          IF (IPR(72) /= 0) CALL GEN127 ('305')
        END IF
        IPR(130) = 0
        NATX     = IPR(38)  + 1
        K        = NATX * NP43
        DO I = 1, 3
          RA(K + I) = 0.0
        END DO
C * GENERATE AND SAVE NEW CG# - LABEL
        NQ1 = 'CG'//CHAR (IPR(160) + ICHAR ('1'))//'    '
        CALL PLA046 (9, NQ1, NED, NQX, NSS, NQSM, INQNR, JNQNR, NIEN)
        IF (NIEN < 0) IPR(72) = - NIEN
        M = 0
        IF (KL < 5) THEN
          IPR(72) = 9
          GO TO 220
        END IF
C * TEST FOR -TO- SUB-KEYWORD
        DO I = 2, KL
          IF (IFL(I)(1:2) == 'TO') THEN
            IF (I == 2) THEN
              IPR(161) = -1
            ELSE IF (I == 3) THEN
              IPR(161) = 1
            ELSE
              IPR(72) = 10
              GO TO 220
            END IF
C * TEST FOR CENTRE OF GRAVITY
          ELSE IF (IFL(I)(1:2) == 'CG') THEN
            IF (I == 2) THEN
              IPR(161) = -2
            ELSE
              IPR(72) = 10
              GO TO 220
            END IF
          ELSE
            N = I
            CALL PLUT13 (0, N, IAT, XDUM)
            IF (IAT == 0) THEN
              IPR(72) = 11
              GO TO 220
            END IF
            IF (IPR(161) /= 0) THEN
              M = M + 1
              DO J = 1, 3
                RA(K + J) = RA(K + J) + RA(IAT * NP43 + J)
              END DO
              IF (M == 1) JAT = IAT
            END IF
          END IF
        END DO
        IF (M == 0) THEN
          IPR(71) = 0
          GO TO 220
        END IF
        DO I = 1, 3
          RA(K + I) = RA(K + I) / M
        END DO
        IPR(38)  = NATX
        IPR(37)  = NATX
        IPR(160) = IPR(160) + 1
        CALL PLUT23 (NATX)
        RA(K + 7)  = INQNR
        RA(K + 8)  = RA(JAT * NP43 + 8)
        RA(K + 9)  = RA(JAT * NP43 + 9)
        RA(K + 10) = RA(JAT * NP43 + 10)
        RA(K + 11) = -1.0
        RA(K + 12) = RA(JAT * NP43 + 12)
        CALL PLUT25 (1, NATX, JUNK)
        IFL(KL + 1) = NQ1
        CALL PLUT25 (0, NATX, N1)
        IF (IPR(161) == -2) THEN
          IPR(161) = 0
          IF (IPR(4) /= 0 .AND. RADR(N1, 1) == 0.0)
     1      CALL PLUT21 (-1)
          GO TO 220
        ELSE
C * SET EXCLUDE CG#
        IVAL = 0
        CALL PLUT15 (1, NATX, 27, IVAL)
C * DO DETACH Me# TO ATOM1 ATOM2 ...
          GO TO 150
        END IF
C * ISW = 78/157: REN(AME) ATOM LABELS
      ELSE IF (ISW == 78 .OR. ISW == 157) THEN
        IF (MOD (KL, 2) == 1 .OR. KL == 2) THEN
C * RENAME
          CALL PLUT32
        ELSE
          IPR(72) = 25
        END IF
        GO TO 220
C * ISW = 79: GEOM CALCULATION AROUND ATOM
      ELSE IF (ISW == 79) THEN
        IPR(163) = 0
        CALL PLUT24 (1, IPR(38), IDUM)
        GO TO 30
C * ISW = 80: MENU (ON/OFF)
      ELSE IF (ISW == 80) THEN
        IF (KL == 2 .AND. IFL(2)(1:3) == 'OFF') THEN
          IGBL(25) = 0
        ELSE
          IGBL(25) = 1
        END IF
      GO TO 220
C * ISW = 84: PART - SHELXL STYLE
      ELSE IF (ISW == 84) THEN
        IPR(612) = NINT(FN(1))
        IGBL(30) = 1
        GO TO 220
C * ISW = 87: COORDN AROUND ATOM
      ELSE IF (ISW == 87) THEN
        IPR(163) = 1
        IF (IPR(44) - IPR(43) == 0) THEN
C * TEMPORARILY SAVE ITEM 2
          IFL(4) = IFL(2)
C * SET RADII
          IFL(2)(1:5) = 'RADII'
C * SET INTER
          IFL(3)(1:5) = 'INTER'
          IPR(220) = 3
          KL       = IPR(220)
          CALL PLUT05
C * CALL EXIT/STOP
          IF (IPR(72) /= 0) CALL GEN127 ('306')
C * RESTORE ITEM 2
          IFL(2) = IFL(4)
          IPR(220) = 2
          KL       = IPR(220)
        END IF
        CALL PLUT24 (1, IPR(37), IDUM)
        GO TO 220
C * ISW = 89/159: DEL(ETE)
      ELSE IF (ISW == 89 .OR. ISW == 159) THEN
        N = 0
        GO TO 210
C * ISW = 90: ENTRY - READ UNTIL SPECIFIED DATA-ENTRY FOR KN /= 0
      ELSE IF (ISW == 90) THEN
        CALL PLA007
        IF (ICL(1:4) == 'END ') THEN
          GO TO 260
        ELSE
          GO TO 220
        END IF
C * ISW = 91: DIR
      ELSE IF (ISW == 91) THEN
        CALL PLA007
        IF (ICL(1:4) == 'END ') THEN
          GO TO 260
        ELSE
          GO TO 220
        END IF
C * ISW = 92: HFIX (SHELXL ONLY)
      ELSE IF (ISW == 92) THEN
        IF (KN > 0) GO TO 220
        IF (IGBL(50) > 0) THEN
          IGBL(8) = - IABS (IGBL(8))
        END IF
C * CHECK FOR .RES FILE
        IF (IGBL(8) == -2) THEN
          IF (KL == 1) THEN
            KL0 = 1
          ELSE
            KL0 = 2
          END IF
C * PICKUP AUTO-MODE FROM S
          NHAUTO = IGBL(50)
          DO KLI = KL0, KL
C * ENUMERATED
            IBEG = IPR(69) + 1
            IEND = IPR(39)
            IAT1 = 0
            IF (NHAUTO == 0) THEN
C * NAMED ATOM(TYPE)
              IF (KLI > 1) THEN
                CALL PLUT13 (0, KLI, IAT1, XDUM)
                IF (IAT1 > 0) THEN
                  IF (KN > 0) THEN
                    MNFIX = NINT (FN(1))
                    CALL PLUT29 (3, IFL(KLI), NQ2, MNFIX, 0)
                    CYCLE
                  END IF
                  IBEG = IAT1
                  IEND = IAT1
                ELSE IF (IAT1 == 0) THEN
                  CYCLE
                END IF
              END IF
            END IF
            DO I = IBEG, IEND
   80         IAT = I
C * TEST FOR RESIDUE
              IF (IPR(140) /= 0) THEN
                CALL PLUT15 (-6, IAT, 5, IVAL)
                IF (IVAL /= IPR(140)) CYCLE
              END IF
C * SKIP H-ATOMS
              CALL PLUT15 (-1, IAT, 44, IHAT)
              IF (IHAT == 0) THEN
                CALL PLUT25 (1, IAT, IATK)
                IFL(2) = NQ1
                IF (IAT1 < 0 .AND. -IAT1 /= IATK) CYCLE
                CALL PLA046 (8, NQ1, NEI, NA, NAX, NS, IXPK1, IXPK2,
     1                       NIEN)
                NB = 1
                NE = 7
                CALL GEN039 (1, IFL(2), 1, 7, NB, NE)
                IPR(220) = 2
C * DO GEOM LISTING FOR THIS ATOM
                CALL PLUT24 (-1, IPR(38), MNFX)
                IF (MNFX >= 0) THEN
                  CALL GEN040 (MNFX, NQ2, IP)
                  IF (NHAUTO == 0) THEN
   90               IF (IGBL(25) * IGBL(32) == 1) THEN
                      PAR40 = NE * PAR(349) * PAR(19) / 2.0
                      NATL  = IPR(62) + I
                      IASU  = 0
                      CALL PLUT14 (-1, NATL, IASU, NPROP, XL, YL, ZL,
     1                             RL)
                      IFLNQ = IFL(2)(1:NE)//'['//NQ2(1:IP)//']'
                      CALL PLA439 (0.0, IFLNQ, NE + IP + 2, PAR(349),
     1                  2, 2, XL - PAR40, YL - PAR(28))
                      SBCD      = 'HFIX '//IFL(2)//' mn['
                      SBCD(17:) =
     1                NQ2(1:IP)//'] or -1, AUTO, QUIT or END :'//CHAR(0)
C * WHAT NEXT ?
                      CALL PLA012 (0, 1)
                      ICL = IGGT
                    ELSE
                      WRITE (LU6, 99975, ADVANCE = 'NO', IOSTAT = IOST)
     1                  IFL(2), MNFX
                      READ  (LU5, 99987) ICL(1:80)
                    END IF
                    CALL GEN020 (1, ICL, 1, 4)
                    IF (ICL(1:4) == 'QUIT' .OR.
     1                  ICL(1:3) == 'END') THEN
                      GO TO 100
                    ELSE IF (ICL(1:4) == 'AUTO') THEN
                      NHAUTO = 1
                      MNFIX = MNFX
                    ELSE IF (ICL(1:4) == 'PLOT') THEN
                      CALL PLUT02
                      GO TO 80
                    ELSE IF (ICL(1:4) == 'VIEW') THEN
                      CALL PLA006 (1, IS)
                      CALL PLUT06
                      CALL PLUT02
                      GO TO 80
                    ELSE IF (ICL(1:1) == '!') THEN
                      IF (LRET == 2) THEN
                        CALL PLUT02
                        GO TO 80
                      ELSE
                        MNFIX = MNFX
                      END IF
                    ELSE
                      IF (ICL(1:4) == 'HFIX') THEN
                        MNFIX = 0
                      ELSE
                        READ (ICL, 99997, IOSTAT = IOST) MNFIX
                        IF (IOST > 0) GO TO 90
                      END IF
                      IF (MNFIX == 0) MNFIX = MNFX
                    END IF
                  ELSE
                    MNFIX = MNFX
                  END IF
                  IF (MNFIX > 0) WRITE (LU22, 99998, IOSTAT = IOST
     1            ) MNFIX, IFL(2)
                  CALL GEN038 (NQ2, 1, 7)
                  CALL PLUT29 (3, IFL(2), NQ2, MNFIX, 0)
                  CALL PLA439 (0.0, IFLNQ, NE + IP + 2, PAR(349), 0, 2,
     1                XL - PAR40, YL - PAR(28))
                  CALL PLA439 (0.0, IFL(2), NE, PAR(349), 1, 2,
     1                XL - PAR40, YL - PAR(28))
                END IF
              END IF
            END DO
          END DO
        END IF
  100   IF (IGBL(50) == 0) THEN
          CALL PLA280 ('PLOT')
C * HFIX
          IF (IGBL(3) == 13) THEN
            IPR(332) = 1
            CALL PLA015 (332, 1)
C * ANIS
          ELSE IF (IGBL(3) == 26) THEN
            IPR(352) = 1
            CALL PLA015 (352, 1)
          END IF
          IF (IPR(308) /= 0) IGBL(3) = 8
          GO TO 220
        ELSE
          IGBL(2) = 0
          CALL GEN038 (IGGT, 1, 80)
          GO TO 300
        END IF
C * ISW = 135: ANIS
      ELSE IF (ISW == 135) THEN
        WRITE (LU22, 99987, IOSTAT = IOST) ICL(1:80)
        IF (IGBL(8) == -2) THEN
          IF (KL == 1) THEN
            KL0 = 1
          ELSE
            KL0 = 2
          END IF
C * HANDLE ALIASES
          MSUBST = 0
          CALL PLA281 (1, IFL(KL0), MSUBST)
          DO KLI = KL0, KL
            IAT1 = 0
C * NAMED ATOM(TYPE)
            IF (KLI > 1) THEN
              CALL PLUT13 (0, KLI, IAT1, XDUM)
              IF (IAT1 > 0) THEN
                CALL PLUT29 (5, IFL(KLI), NQ2, 0, 0)
              END IF
            END IF
          END DO
        END IF
C * ANIS
        IF (IGBL(3) == 26) THEN
          IPR(352) = 1
          CALL PLA015 (352, 1)
        END IF
        GO TO 220
C * ISW = 140: ENDS
      ELSE IF (ISW == 140) THEN
        GO TO 260
C * ISW = 143: NOMOVE
      ELSE IF (ISW == 143) THEN
        IF (IPR(17) == 0 .AND. IPR(127) == 0) THEN
          IF (KL > 1 .AND. IFL(2)(1:3) == 'OFF') THEN
            IGBL(30) = 0
          ELSE
            IGBL(30) = 1
          END IF
        END IF
        GO TO 220
C * ISW = 144: RESD
      ELSE IF (ISW == 144) THEN
        IF (IPR(50) == 1) THEN
          IPR(135) = NINT (FN(1))
        ELSE
          IF (IPR(136) /= 0) THEN
            IPR(136) = NINT (FN(1))
          ELSE IF (IPR(37) == IPR(69)) THEN
            IPR(136) = NINT (FN(1))
          END IF
        END IF
        GO TO 220
C * ISW = 145: NOSORT OPTION
      ELSE IF (ISW == 145) THEN
        IGBL(33) = 0
        GO TO 220
C * 147: HALL
      ELSE IF (ISW == 147) THEN
        GO TO 110
C * ISW = 152: PORTRAIT
      ELSE IF (ISW == 152) THEN
        IGBL(46) = MOD (IGBL(46) + 1, 2)
        PAR(50)  = (4.0 - IGBL(46)) / 3.0
        PAR(18)  = - PAR(50)
        NN       = 4 - IGBL(46) * 8
        CALL GGIP (-999.0, 0.0, 0.0, NN)
        GO TO  220
C * ISW = 170: FIT => END
      ELSE IF (ISW == 170) THEN
        GO TO 290
C * ISW = 185: TEXT
      ELSE IF (ISW == 185) THEN
        TEXT = ICL(6:25)
      END IF
      GO TO 50
C * SPGR/LATT/SYMM/HALL - CARD
  110 IF ((ISW == 6 .OR. ISW == 9) .AND.
     1 (IGBL(8) <= 2) .AND.
     1     KL == 1 .AND. KN == 0) THEN
        WRITE (LU6, 99979, IOSTAT = IOST) ICL(1:4)
        GO TO 220
      ELSE IF (KL == 1 .AND. (KN == 9 .OR. KN == 12)) THEN
C * SYMM MATRIX INPUT: R11,R12,..,R33,(T1,T2,T3)
        ITRS = 15
        CALL SGSM (ITRS, ICL, FN, 0, LU6, IERR)
      ELSE
        IF (IPR(127) == 1 .OR. IPR(128) == 1) THEN
          ITRS = 16
        ELSE
          ITRS = 0
        END IF
        CALL SGSM (ITRS, ICL, SGX, 0, LU6, IERR)
      END IF
      CALL SGSM (18, ICL, SGY, 0, 0, IERR)
      SPGRNM(1) = ICL(1:26)
      IPR(48) = NINT(SGY(9))
C * SET TO SKIP FOR UNKNOWN SYMMETRY
      IF (IPR(48) == 0) THEN
        IPR(11) = 1
        WRITE (LU6, 99974, IOSTAT = IOST)
      END IF
      IF (IPR(48) > 48) THEN
        IF (IPR(134) /= 9) WRITE (LU6, 99982, IOSTAT = IOST)
        IPR(134) = 9
        PAR(42)  = 10.0
      END IF
C * SPECIAL DEFAULT SETTING
      IF (ICL(12:12) == 'h') THEN
        PAR(148) = 120.0
      ELSE
        PAR(148) = 90.0
      END IF
      GO TO 220
C * REAL OR POTENTIAL ATOM CARD
  120 IF (IPR(220) == 0 .AND. IPR(221) == 0) GO TO 50
      IF (IFL(1)(1:7) == 'CREATED') GO TO 50
C * CHECK FOR RES FILE
      IF (IGBL(8) == 2) THEN
      END IF
C * ATOM RECORD HANDLING
      CALL PLUT03 (IER)
      IF (IER /= 0) IPR(72) = 2
      GO TO 220
C * U/B
  130 IF (KL == 1) THEN
        GO TO 120
      ELSE
        GO TO 220
      END IF
C * JOIN CARD - SETS UP CONNECTIONS
C * CHECK FOR NUMBER OF LOADED ATOMS
  140 IF (IPR(37) > IPR(69)) THEN
        IMD      = 1
        IPR(110) = 0
C * TEST FOR JOIN INSTRUCTION
C * (TO BE INTERPRETED AS: JOIN RADII UNIQUE EXPAND)
        IF (KL == 1) THEN
C * DO JOIN RADII UNIQUE
          IF (IPR(17) == 0) THEN
            IMD = 0
          ELSE
            WRITE (LU6, 99971, IOSTAT = IOST)
            GO TO 220
          END IF
        ELSE IF (KL == 2) THEN
          J215 = IFL(2)(1:5)
C * JOIN INTRA
          IF (J215 == 'INTRA') THEN
            IF (IPR(17) == 0) IMD = 0
C * JOIN UNIQUE
          ELSE IF (J215 == 'UNIQU') THEN
            IF (IPR(17) == 0) IMD = 0
C * JOIN NONE
          ELSE IF (J215 == 'NONE ') THEN
            IPR(52) = IPR(68)
            IPR(53) = IPR(68)
            IPR(17) = 1
            IF (IPR(75) == 0) THEN
              CALL PLUT33
              IPR(75) = 1
              CALL PLUT17 (1555.0 + 1.0 / PAR(42), 0, MADDR, LU6)
              DO I = 1, 3
                RCG(1, I) = RA(NP43 + I)
              END DO
              RCG(1, 4) = IPR(37) - IPR(69)
            END IF
            GO TO 220
C * JOIN HBONDS (EXPAND TO: JOIN RADII INTER HBONDS EXPAND)
          ELSE IF (J215 == 'HBOND' .OR. J215 == 'XBOND') THEN
C * SET RADII
            IFL(2)(1:5) = 'RADII'
C * SET INTER
            IFL(3)(1:5) = 'INTER'
C * SET HBONDS
            IF (J215 == 'HBOND') THEN
              IFL(4)(1:6) = 'HBONDS'
            ELSE
              IFL(4)(1:6) = 'XBONDS'
            END IF
C * SET EXPAND
            IFL(5)(1:6) = 'EXPAND'
            IPR(220) = 5
            KL       = IPR(220)
            GO TO 140
          END IF
        ELSE IF (KL >= 3) THEN
C * EXECUTE A JOIN RADII UNIQUE FIRST WHEN NOT DONE PREVIOUSLY
          IF (IPR(17) == 0) THEN
C * JOIN RADII INTER
            IF (IFL(3)(1:5) == 'INTER') THEN
              CALL PLUT05
C * CALL EXIT/STOP
              IF (IPR(72) /= 0) CALL GEN127 ('301')
            END IF
          END IF
        END IF
        GO TO 160
      ELSE
        WRITE (LU6, 99993, IOSTAT = IOST)
        IPR(72) = 3
        GO TO 220
      END IF
C * DETACH CARD
  150 IMD = -1
C * DETACH ALL
      IF (KL == 1) THEN
        IPR(52) = IPR(68)
        IPR(53) = IPR(68)
        IPR(17) = -1
        GO TO 220
      END IF
      IF (IPR(37) <= IPR(69)) THEN
        WRITE (LU6, 99993, IOSTAT = IOST)
        IPR(72) = 4
        GO TO 220
      END IF
      IF (IPR(52) == 0) THEN
        CALL PLUT05
        IF (IPR(72) /= 0) THEN
          IPR(72) = 0
          GO TO 50
        END IF
      END IF
  160 IPR(17) = IMD
      CALL PLUT05
C * HANDLE ERROR
      IF (IPR(72) /= 0) THEN
        IPR(72) = 0
        GO TO 50
      END IF
C * CHECK FOR DEFINE
      IF (IABS(IPR(161)) == 1) THEN
C * DO JOIN Me# - CG#
        IMD      = 1
        IF (IPR(161) == -1) THEN
          IFL(2)   = IFL(KL + 1)
        ELSE
          IFL(3)   = IFL(KL + 1)
          IPR(220) = 3
          KL       = IPR(220)
        END IF
        IPR(161) = 0
        IF (IPR(4) /= 0 .AND. RADR(N1, 1) == 0.0) CALL PLUT21 (-1)
        GO TO 160
      END IF
      GO TO 220
C * SET REBUILD
  170 IPR(130) = 0
      IF (IPR(100) == 0) CALL PLUT33
C * # CONTOUR
      IPR(8)   = IPR(74)
C * RESET NONUCL
      IPR(18)  = 0
C * RESET SPOT
      IPR(96)  = 0
C * RESET BWC
      IPR(345) = 0
C * RESET COLOR
      IPR(346) = 0
C * RESET GLOBAL B&W  MODE
      IPR(139) = 0
      PAR(130) = 0.0
      PAR(131) = 0.0
C * RESET SEGMENT STEP
      PAR(125) = 5.25
C * LOOP OVER SUB-KEYWORD OPTIONS
      IF (KL > 1) THEN
        DO K = 2, KL
          JK13 = IFL(K)(1:3)
          IF (JK13 == 'SPO') THEN
C * SET SPOT ON
            IPR(96) = 1
C * CPK/ROD/SOLID/STRAW GLOBE MODE
          ELSE IF (JK13 == 'GLO') THEN
            IPR(139) = 8
          ELSE IF (JK13 == 'CON') THEN
C * CPK/ROD/SOLID/STRAW CONTOUR MODE
            IPR(139) = 1
            IF (KN == 1) IPR(8) = NINT (FN(1))
          ELSE IF (JK13 == 'BLA') THEN
C * CPK/ROD/SOLID/STRAW BLACK MODE
            IPR(139) = 6
          ELSE IF (JK13 == 'SEG') THEN
C * CPK/ROD/SOLID/STRAW SEGMENT MODE
            IPR(139) = 4
C * CPK/ROD/SOLID/STRAW CROSS MODE
          ELSE IF (JK13 == 'CRO') THEN
            IPR(139) = 7
C * CPK/ROD/SOLID/STRAW PARALLEL MODE
          ELSE IF (JK13 == 'PAR') THEN
            IPR(139) = 9
C * CPK/ROD/SOLID/STRAW MERIDIAN MODE
          ELSE IF (JK13 == 'MER') THEN
            IPR(139) = 10
C * CPK/ROD/SOLID/STRAW DOTS
          ELSE IF (JK13 == 'DOT') THEN
            IPR(139) = 5
C * COLOR DOTS MODE
          ELSE IF (JK13 == 'NUC') THEN
C * CPK/ROD/SOLID NUCL MODE
            IPR(18) = 1
          ELSE IF (JK13 == 'SHA') THEN
C * CPK/ROD/SOLID SHADE MODE
            IPR(139) = 3
            IF (KN >= 2) THEN
              PAR(135) = FN(1)
              PAR(136) = FN(2)
              IF (KN > 2)  PAR(134) = FN(3)
            END IF
          ELSE IF (JK13 == 'STI') THEN
C * CPK STICK MODE
            IF (IABS(IPR(4)) == 3) THEN
              IPR(4)      = -3
            END IF
          ELSE IF (JK13 == 'COL') THEN
C * CPK/ROD/SOLID COLOR (SHADE) MODE
            IPR(346) = 1
            IF (K == 2 .AND. K == KL) THEN
            END IF
          ELSE IF (JK13 == 'NET') THEN
C * CPK/ROD/SOLID NET MODE
            IPR(139) = 2
            IF (KN == 2) THEN
              IPR(85) = NINT (FN(1))
              IPR(86) = NINT (FN(2))
            END IF
          ELSE IF (JK13 == 'BWC') THEN
C * CPK/ROD/SOLID BWCOL MODE
            IPR(345) = 1
          END IF
        END DO
      END IF
      GO TO 220
C * ARU/MOLES (TO BE PLOTTED) - INSTRUCTION (SKIP MOLE IN SHELXS.RES)
  180 IF (IGBL(8) /= 2) THEN
        IF (KN == 0 .AND. KL == 1) THEN
          KL = 2
          IFL(1) = 'LIST'
          IFL(2) = 'ARU'
          GO TO 240
        ELSE
          CALL PLUT17 (0.0, 1001, MADDR, LU6)
          MODE = 0
          IF (KL > 1) THEN
C * ARU BOND ...
            IF (IFL(2)(1:4) == 'BOND') THEN
              KLM  = 3
              KADD = 64
C * ARU BWC ...
            ELSE IF (IFL(2)(1:3) == 'BWC') THEN
              KLM  = 3
              KL   = 3
              KADD = 0
              GO TO 190
C * ARU ...
            ELSE
              KLM  = 2
              KL   = 2
              KADD = 0
            END IF
C * FIND OUT ABOUT ARU COLOR
            DO K = 1, 9
              IF (IFL(KLM)(1:3) == COLR(K)(1:3)) THEN
                MODE = K + KADD
                KL   = 1
                GO TO 200
              END IF
            END DO
C * FIND OUT ABOUT ARU BWC
  190       DO K = 1, 17
              IF (IFL(KLM)(1:7) == BWCT(K)(1:7)) THEN
                MODE = K + 32 + KADD
                KL   = 1
                GO TO 200
              END IF
            END DO
          END IF
  200     IF (KN > 0 .OR. KL > 1) THEN
            IF (KN > 0) THEN
              DO K = 1, KN
                FNK = FN(K)
                CALL PLUT17 (FNK, MODE, MADDR, LU6)
                IF (IPR(43) > 1) CALL PLUT35 (FNK, 0)
              END DO
            END IF
            IF (KL > 1) THEN
              DO K = 2, KL
                IF (IFL(K)(2:2) == ' ') THEN
                  CALL GEN105 (1, IFL(K)(1:1), N)
                  IF (N > 0) THEN
                    N = IPR(75) + N - ICHAR ('A')
                    IF (N < IPR(42)) THEN
                      XDUM = ABS (MOL(1, N + 1) / PAR(42))
                      CALL PLUT17 (XDUM, MODE, MADDR, LU6)
                    END IF
                  END IF
                END IF
              END DO
            END IF
          END IF
        END IF
      END IF
      GO TO 220
C * INCLUDE / EXCLUDE / OMIT / DELETE - INSTRUCTION
C * TAKE CARE OF SPECIAL MEANING OF OMIT AS SHELX-INSTRUCTION
  210 IF (IGBL(8) /= 2) THEN
        IF (KL > 1) THEN
          CALL PLUT09 (N, ISW)
        ELSE IF (KL == 1 .AND. KN > 0) THEN
C * OMIT, INCLUDE, EXCLUDE ARU'S
          DO I = 1, KN
            FN(I) = ((N * 2) - 1) * FN(I)
          END DO
          GO TO 180
        END IF
      END IF
C * GENERAL ERROR MESSAGE
  220 IF (IPR(72) > 0) THEN
        IF (IGBL(5) == LU5)
     1    WRITE (LU6, 99983, IOSTAT = IOST) IPR(72), CHAR (7)
        IF (IPR(72) == 24) THEN
          ISW = 140
          GO TO 260
        END IF
        IPR(72) = 0
        GO TO 220
      ELSE
        IF (IGBL(5) == LU5) THEN
C * SAVE INTERACTIVE INSTRUCTION ON FILE -.PJN
          IF (IFL(1)(1:3) /= 'REN') THEN
            WRITE (LU22, 99987, IOSTAT = IOST) ICL(1:80)
          END IF
C * AUTOMATIC PLOT INSTRUCTION
          IF (IFL(1)(2:4) == 'ROT' .OR. IFL(1)(1:4) == 'VIEW') THEN
C * AUTO-PLOT
            IF (IGBL(35) == 1) THEN
              IPR(221) = 0
              KN       = IPR(221)
              IPR(220) = 1
              KL       = IPR(220)
              GO TO 280
            ELSE
              GO TO 30
            END IF
          END IF
        END IF
C * DO MODE=2 RESET WHEN ATOMS HAVE BEEN DELETED OR RENAMED TO NEW ATOM TYPE
        IF (IPR(170) == 2) THEN
          IF (IPR(140) > 0) THEN
            DO I = 1, IPR(39)
C * CHECK RESIDUE
              CALL PLUT15 (-6, I,  5, IVAL)
              IF (IVAL == IPR(140)) THEN
C * CHECK FOR 'INCLUDED'
                CALL PLUT15 (-1, I,  27, IVAL)
                IF (IVAL == 1) THEN
                  IPR(140) = -I
                  GO TO 230
                END IF
              END IF
            END DO
            IPR(140) = 0
          END IF
  230     WRITE (LU6, 99995, IOSTAT = IOST)
          CALL PLUT01 (2)
          CALL PLUT21 (-1)
          IPR(75) = 0
          IPR(17) = 0
          IGBL(5) = LU23
          CALL GEN108 (LU23, 0)
        END IF
      END IF
      GO TO 40
C * LIST/INFO ON DISPLAY OR TRAILER LISTING OF
C * SYMM/ATOM(S)/BOND(S)/ARU/MOLES/LINES LISTS ETC.
  240 IF (KL > 1 .AND.
     1   (IFL(2)(1:3) == 'PAR' .OR. IFL(2)(1:3) == 'IPR') .OR.
     2    IPR(37) > IPR(69)) THEN
        IPR(90)  = 510
        IPR(147) = 0
        IF (KL >= 2) THEN
          IPR(90)  = 0
C * SET LIST INTER FLAG OFF
          IGBL(31) = 0
          DO I = 2, KL
            JK13 = IFL(I)(1:3)
C * LIST CELL
            IF (JK13 == 'CEL') THEN
              WRITE (BCD, 99980, IOSTAT = IOST)
     1          (PAR(100 + J), J = 1, 3),
     2          (ACOS (PAR(103 + J)) * RGBL(6), J = 1, 3), PAR(126),
     3          CHAR (0)
              IF (IGBL(25) * IGBL(32) == 1) THEN
                IGBL(6) = - IABS (IGBL(6))
                CALL GGIP (-999.0, 5.0 + FLOAT (IGBL(68)), 78.0, 111)
              ELSE
                WRITE (LU6, 99977, IOSTAT = IOST) BCD
              END IF
              GO TO 30
C * SET INTER BIT FOR LIST (ATOM(S)/BOND(S)) INTER
            ELSE IF (JK13 == 'INT') THEN
              IGBL(31) = 1
C * SELECT RESIDUE NUMBER FOR PRINTING
            ELSE IF (JK13 == 'RES') THEN
              IF (KN == 1) IPR(147) = NINT (FN(1))
C * LIST IPR/PAR/IGBL/RGBL
            ELSE IF (JK13 == 'IPR' .OR.
     1               JK13 == 'PAR' .OR.
     2               JK13 == 'IGB' .OR.
     3               JK13 == 'RGB') THEN
              CALL PLA206 (-1, JK13)
              CALL GGIP (0.0,0.0,0.0,6)
              GO TO 30
C * LIST SYMM
            ELSE IF (JK13 == 'SYM') THEN
              IPR(90) = IPR(90) + 2
C * LIST ATOM(S)
            ELSE IF (JK13 == 'ATO') THEN
              IPR(90) = IPR(90) + 4
C * LIST BOND(S)
            ELSE IF (JK13 == 'BON') THEN
              IPR(90) = IPR(90) + 8
C * LIST LINES
            ELSE IF (JK13 == 'LIN') THEN
              IPR(90) = IPR(90) + 16
C * LIST ARU
            ELSE IF (JK13 == 'ARU') THEN
              IPR(90) = IPR(90) + 32
C * LIST MOLES
            ELSE IF (JK13 == 'MOL') THEN
              IPR(90) = IPR(90) + 32
C * LIST MATRIX
            ELSE IF (JK13 == 'MAT') THEN
              IPR(90) = IPR(90) + 64
C * LIST STATUS
            ELSE IF (JK13 == 'STA')  THEN
              IPR(90) = IPR(90) + 128
C * LIST TYP
            ELSE IF (JK13 == 'TYP') THEN
              IPR(90) = IPR(90) + 256
C * LIST ATOM-FLAGS
            ELSE IF (JK13 == 'FLA') THEN
              IPR(90) = IPR(90) + 512
C * ATOM/ ATOM TYPE
            ELSE
              CALL PLUT13 (0, -I , IAT, XDUM)
              IF (IAT == 0) THEN
                IPR(72) = 21
                GO TO 220
              END IF
            END IF
         END DO
        END IF
        CALL PLUT12
      ELSE
        IPR(72) = 22
      END IF
      GO TO 220
C * UNCHECKED EOF OR CTRL_D - HANDLING
  250 IF (IGBL(5) == LU1) THEN
C * FRACTIONAL AND NO COORDINATES EXIT
        IF (IPR(39) == 0 .AND. IPR(50) == 1) GO TO 290
C * COUNT NUMBER OF EOF ON UNIT LU1
        IPR(47)  = IPR(47) + 1
        IF (IPR(47) > 1) GO TO 290
      ELSE IF (IGBL(5) == LU23) THEN
        CALL GEN108 (LU23, 0)
        IGBL(5) = LU3
        GO TO 50
      ELSE IF (IGBL(5) == LU3) THEN
        CALL GEN108 (LU3, 0)
        IGBL(5)  = LU5
        IGBL(24) = IABS (IGBL(24))
        IF (IGBL(50) == 0) THEN
          IF (IGBL(24) * IGBL(25) /= 0) CALL PLA280 ('PLOT')
        END IF
        IPR(72) = 0
        GO TO 50
      ELSE IF (IGBL(5) == LU5) THEN
        GO TO 290
      END IF
C * END / ENDS / EOF - HANDLING
  260 IF (ISW == 140) THEN
        IF (IGBL(5) == LU1)
     1    WRITE (LU6, 99989, IOSTAT = IOST) JID(1:19)
        IF (IGBL(5) == LU5) THEN
          ICL(1:4) = '    '
          GO TO 270
        END IF
      ELSE
        IF (IGBL(5) == LU5) THEN
          IF (IGBL(8) /= 0) THEN
            IGBL(8) = IABS (IGBL(8))
            IF (IGBL(8) /= 2) THEN
              IGBL(5) = LU1
              GO TO 270
            END IF
          END IF
          GO TO 290
        END IF
      END IF
C * HANDLE SHELX(L).XXX
      IF (IABS(IGBL(8)) == 2) THEN
        IPR(47)  = IPR(47) + 1
        IGBL(8)  = 2
      END IF
      IGBL(8) = - IABS (IGBL(8))
      CALL GEN108 (LU3, 0)
C * SWITCH TO DEFAULT INSTRUCTION FILE
      IF (IGBL(5) == LU1) THEN
        IGBL(5) = LU23
        CALL GEN108 (LU23, 0)
        GO TO 50
      END IF
C * HANDLE END & EOF
      IF (ICL(1:4) /= 'ENDS') THEN
        IF (IGBL(5) == LU3 .AND. IPR(47) == 0) GO TO 270
        IF (IPR(47) > 0) GO TO 290
      END IF
      IF (IGBL(5) == LU23) THEN
        IGBL(5) = LU3
        GO TO 50
      END IF
      IF (IGBL(5) == LU3) THEN
        IGBL(5)  = LU5
        IGBL(24) = IABS (IGBL(24))
        GO TO 50
      END IF
  270 IPR(61) = - 1
      GO TO 20
C * ENTRY FROM CROT, XROT, YROT, ZROT
  280 IPR(82)  = 0
      IPR(145) = 0
      IF (KL > 1) THEN
        DO K = 2, KL
          JK13 = IFL(K)(1:3)
C * TRAILER LIST OPTION
          IF (JK13 == 'LIS') THEN
            IPR(145) = 1
C * POVRAY/RASMOL OPTION
          ELSE IF (JK13 == 'POV' .OR. JK13 == 'PDB') THEN
            IPR(130) = 0
            IGBL(67) = 1
            IPR(82)  = 1
            IF (JK13 == 'PDB') THEN
              OPEN (UNIT = LU60,  FILE = NAMEFIL(1:KNMFIL)//'.ras',
     1                                          STATUS = 'UNKNOWN')
              IPR(10)  = 2
              IGBL(11) = 1
              CALL GEN108 (LU60, 0)
              WRITE (LU60, '(''HEADER'', 3X, A)', IOSTAT = IOST)
     1          JID(1:70)
              IPR(340) = 1
            ELSE
              OPEN (UNIT = LU61,  FILE = NAMEFIL(1:KNMFIL)//'.pov',
     1                                          STATUS = 'UNKNOWN')
              CALL GEN108 (LU61, 0)
              IPR(10)  = 1
              IGBL(98) = 1
              IF (IGBL(101) == 0) THEN
                BCKG = 'White '
                BCOL = 'Bronze'
                HCOL = 'rgb <0.6,0.6,0.6>'
              ELSE IF (IGBL(101) == 1) THEN
                BCKG = 'SummerSky '
                BCOL = 'LightGray'
                HCOL = 'White'
              ELSE IF (IGBL(101) == 2) THEN
                BCKG = 'Black '
                BCOL = 'LightGray'
                HCOL = 'White'
              ELSE IF (IGBL(101) == 3) THEN
                BCKG = 'Scarlet '
                BCOL = 'LightGray'
                HCOL = 'White'
              ELSE IF (IGBL(101) == 4) THEN
                BCKG = 'Silver'
                BCOL = 'Bronze'
                HCOL = 'rgb <0.6,0.6,0.6>'
              END IF
              WRITE (LU61, 99992, IOSTAT = IOST)
     1          ABS (PAR(18)), BCOL, HCOL
              WRITE (LU61, 99991, IOSTAT = IOST) BCKG
              DO I = 3, IAN
                ICOL = IACL(I)
                IF (ICOL > 1 .AND. ICOL < 9) THEN
                  CLR = COLR(ICOL)(1:7)
                  CALL GEN020 (0, CLR, 2, 7)
                ELSE
                  CLR = 'Coral  '
                END IF
                N2 = IEL(IEN(I))
                N1 = N2 / 100 + ICHAR ('A') - 1
                N2 = MOD (N2, 100)
                IF (N2 == 0) THEN
                  N2 = ICHAR (' ')
                ELSE
                  N2 = N2 + ICHAR ('a') - 1
                END IF
                WRITE (LU61, 99990, IOSTAT = IOST)
     1            CHAR (N1), CHAR (N2), CLR
              END DO
              WRITE (LU61, 99988, IOSTAT = IOST)
            END IF
          ELSE
C * FIRST DECIDE WHETHER THE META OR DISPLAY SHOULD BE ON
            IPDC = -3
            IF (IFL(K)(1:1) == 'M' .OR. IFL(K)(1:1) == 'C')
     1        IPDC = -2
            CALL GGIP (-999.0, 0.0, 0.0, IPDC)
            IF (IFL(K)(1:1) == 'D') THEN
C * DECIDE WHETHER DISPLAY SHOULD BE ON
              IPDC = 2
              CALL GGIP (-999.0, 0.0, 0.0, IPDC)
            END IF
          END IF
        END DO
      END IF
      IF (IPR(37) > IPR(69)) THEN
C * SET-UP BOND ARRAY
        IF (IPR(17) == 0) THEN
          CALL PLUT05
          IF (IPR(72) /= 0) GO TO 220
        END IF
C * DO AN AUTOMATIC VIEW MIN WHEN NOT SET
        IF (IGBL(67) == 0) THEN
          WRITE (LU6, 99996, IOSTAT = IOST)
          IPR(220)    = 2
          KL          = IPR(220)
          IPR(221)    = 0
          KN          = IPR(221)
          IFL(2)(1:2) = 'MI'
          WRITE (LU6, 99996, IOSTAT = IOST)
          CALL PLUT06
        END IF
      ELSE
        WRITE (LU6, 99993, IOSTAT = IOST)
        IPR(72) = 24
      END IF
C * TEST FOR ERROR
      IF (IPR(72) /= 0) GO TO 220
      GO TO 300
C * END OF JOB (STOP/EXIT)
  290 IGBL(2) = -1
C * EXECUTE THIS PLOT INSTRUCTION / ALL PLOTTING IS DONE IN PLUT02
C * END OF LOOP: TEST (IGBL(2) = 0)
  300 IF (IGBL(2) > 0) THEN
        CALL PLUT02
        GO TO 10
      ELSE
C * SHIFT ORIGIN BACK FROM  PAR(64), PAR(65)
        CALL GGIP (-PAR(64), -PAR(65), 0.0, -3)
        CALL GGIP (-XSH0,       -YSH0, 0.0, -3)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        IPR(308) = 0
        CALL PLA015 (335, 0)
        CALL PLA015 (351, 0)
        CALL PLA015 (349, 0)
        CALL PLA015 (332, 0)
        CALL PLA015 (352, 0)
C * RESTORE IGBL(8)
        IF (IGBL8 /= 0) THEN
          IGBL(30) = IGBL30
          IGBL(8)  = IGBL8
        END IF
      END IF
      RETURN
99999 FORMAT (':: PlotStep =', F4.2, ' cm., Number SubSteps =', I3)
99998 FORMAT ('HFIX', I3, 1X, A)
99997 FORMAT (I3)
99996 FORMAT (':: AEX:VIEW MIN')
99995 FORMAT (':: RESET executed in view of deleted atom(s)',
     1        ' or change of Element type')
99994 FORMAT (
     1 45X, ' RATIO', F6.3, ' TITL', F7.2, ' SIZE', F6.2, /,
     2 45X, ' SCALE', F6.2, ' YLIM', F7.2, ' CHAR', F6.2)
99993 FORMAT (':: NO Coordinates given')
99992 FORMAT ('#include "shapes.inc"', /,
     1        '#include "metals.inc"', /,
     2        '#include "colors.inc"', /,
     3        'global_settings {assumed_gamma 2.0}', /,
     4        'camera { location < 0, 0, +15> up < 0, 1, 0>',
     5        ' right <', F8.4, ', 0, 0> look_at < 0, -0.25, 0>',
     6        ' angle 15 }', /,
     7        'light_source  { < -1, 2, +2 > color White }', /,
     8        'light_source  { < 0, 1, +8 > color White }', /,
     9        '#declare color_bond = ', A, ' ;', /,
     *        '#declare finish_all = finish { phong 0.8 }', /,
     1        '#declare color_H = ', A, ' ;', /,
     2        '#declare color_C = rgb < 0.3, 0.3, 0.3 > ;')
99991 FORMAT ('background { color ', A, ' }')
99990 FORMAT ('#declare color_', 2A, ' = ', A, ' ;')
99989 FORMAT ( ':: Data Set : ', A, ' loaded')
99988 FORMAT ('union {' )
99987 FORMAT (A)
99986 FORMAT (/, ':: Symmetry # :', I4, ' in TRNS (', F8.3,
     1         ') OUT OF RANGE (', I3, '(Ignored)')
99985 FORMAT (':: BOX ',A, ' SHRINKAGE FACTOR:', F6.2,
     1 ' AND WINDOW RATIO:', F7.3)
99984 FORMAT (':: Overlap (OFF=0,BA=1,BB=2,ON=3)=', I2, ', Margin=',
     1        F5.2, ', Shadow = ', F5.2)
99983 FORMAT (':: Instruction Error(', I4,
     1        ') - Ignored , (see HELP ALL)', A)
99982 FORMAT (':: Note: Max. Number of Residues in limited to 9',/)
99981 FORMAT (':: ', A, 'is NOT an Atom-type (Ignored)')
99980 FORMAT ('CELL ', 3F10.4, 3F10.2, F12.2, A)
99979 FORMAT (/, ':: ', A, ' instruction ignored', /)
99978 FORMAT (':: Saved: ', A)
99977 FORMAT (/, A, /)
99976 FORMAT ('** ', A)
99975 FORMAT (/, 'HFIX ', A, ' mn[',I3,'] or Q[uit] :')
99974 FORMAT (/, ':: DATA will be SKIPPED until END-OF-SECTION')
99973 FORMAT (':: Transformation on Input Data: Det =', F6.3)
99972 FORMAT (':: TRNS Instruction NOT ALLOWED here and IGNORED')
99971 FORMAT (':: JOIN Instruction Ignored')
      END SUBROUTINE PLUTON
 
      SUBROUTINE PLUT01 (IMODE)
C * INITIALISATION full/partial
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE menus
      USE pluto
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: NM0
      INTEGER :: NMK
      INTEGER :: IVAL
      INTEGER :: IVERM
      INTEGER :: IMODE
C * IMODE = -1
C * IMODE =  0
C * IMODE =  1
C * IMODE =  2
      IF (IMODE == -1) THEN
        CALL GEN038 (IGGT, 1, 80)
        IGBL(100) = 0
        IGBL(2)   = 0
        IGBL(5)   = 0
        IGBL(6)   = 2
        IGBL(24)  = - IABS (IGBL(24))
        IGBL(27)  = 1
        IGBL(32)  = - IABS (IGBL(32))
        IPR(61)   = -1
        SBCD      = CHAR (0)
C * OPEN APPROPRIATE PARAMETER FILE
C * IGBL(3) =  0 - PLATON/_P.SPF-PATH
C *         =  8 - Native PLUTON mode
C *         = 12 - RENAME mode
C *         = 13 - HFIX mode
C *         = 26 - ANIS mode
        IF (IGBL(3) == 8 .OR. IGBL(3) == 12 .OR. IGBL(3) == 13
     1                     .OR. IGBL(3) == 26) THEN
          IGBL(8)  = IABS (IGBL(8))
C * RESET ALIASES FOR CI
          IF (IGBL(8) == 3 .OR. IGBL(8) == 2) IPR(759) = 0
C * SET LABEL ON
          IF (IGBL(3) == 26) IGBL(75) = 1
C * TEST FOR RUN-FROM-S
          IF (IGBL(92) == 1) THEN
            NAMEFIL  = 'satom'
            KNMFIL   = 5
            EXTENS   = 'spf'
            KXT      = 3
            IGBL(26) = 0
            INQUIRE (UNIT = LU98, OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU98, STATUS = 'SCRATCH',
     1          FORM = 'FORMATTED')
            ELSE
              REWIND (UNIT = LU98, IOSTAT = IOST)
            END IF
C * CHANNEL FOR SAVED INSTRUCTIONS
            INQUIRE (UNIT = LU3, OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU3, STATUS = 'SCRATCH',
     1          FORM = 'FORMATTED')
            ELSE
              REWIND (UNIT = LU3, IOSTAT = IOST)
            END IF
            INQUIRE (UNIT = LU23, OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU23, FILE = NAMEFIL(1:KNMFIL)//'.def',
     1                                          STATUS = 'UNKNOWN')
            ELSE
              REWIND (UNIT = LU23, IOSTAT = IOST)
            END IF
            INQUIRE (UNIT = LU21, OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU21,  FILE = NAMEFIL(1:KNMFIL)//'.new',
     1                                           STATUS = 'UNKNOWN')
            ELSE
              REWIND (UNIT = LU21, IOSTAT = IOST)
            END IF
            INQUIRE (UNIT = LU22, OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU22,  FILE = NAMEFIL(1:KNMFIL)//'.pjn',
     1                                           STATUS = 'UNKNOWN')
            ELSE
              REWIND (UNIT = LU22, IOSTAT = IOST)
            END IF
          END IF
C * DATA INPUT FILE
          FNLU1 = NAMEFIL(1:KNMFIL)//'.'//EXTENS
          KNMXT = KNMFIL + KXT + 1
C * RENAME, ANIS AND HFIX FUNCTION
          IF (IGBL(3) == 12 .OR. IGBL(3) == 13 .OR.
     1        IGBL(3) == 26) THEN
            IGBL(48) = 1
            IGBL(6)  = 3
          END IF
        ELSE
          IGBL(8) = 1
          FNLU1   = NAMEFIL(1:KNMFIL)//'_pl.spf'
          KNMXT   = KNMFIL + 7
        END IF
C * CHECK FOR DEFAULT PRESENT
        IF (IGBL(23) == 0 .AND. IGBL(3) /= 8) THEN
          CALL GEN108 (LU23, 0)
C * STRAW COLOR
          WRITE (LU23, 99995, IOSTAT = IOST)
C * LABEL
          IF (IGBL(75) == 1) WRITE (LU23, 99997, IOSTAT = IOST)
          IF (IGBL(87) * IGBL(67) /= 0) THEN
C * VIEW UNIT XROT YROT ZROT
            WRITE (LU23, 99994, IOSTAT = IOST)
     1        RGBL(28), RGBL(29), RGBL(30)
C * VIEW INVERT
            IF (IGBL(87) < 0) WRITE (LU23, 99993, IOSTAT = IOST)
          END IF
C * PLOT (CAL/DISPLAY)
          IF (IGBL(3) == 13 .AND. IGBL(50) > 0) THEN
            WRITE (LU23, 99996, IOSTAT = IOST)
          ELSE
            WRITE (LU23, 99992, IOSTAT = IOST)
          END IF
          CALL GEN108 (LU23, 0)
        END IF
        INQUIRE (FILE = FNLU1, OPENED = OPEND)
        IF (OPEND) WRITE (6,'(''LU1 OPEN ALREADY'')', IOSTAT = IOST)
        OPEN (UNIT = LU1, FILE = FNLU1, STATUS = 'OLD', IOSTAT = IOST)
        IF (IOST > 0) GO TO 10
        GO TO 20
C * OPEN ERROR, SWITCH TO INTERACTIVE DATA INPUT
   10   WRITE (LU6, 99990, IOSTAT = IOST) FNLU1(1:KNMXT)
        LU1 = LU5
        GO TO 20
C * FULL OR PARTIAL INITIALISATION ROUTINE FOR (RE)SETTING OF DEFAULTS.
C * TEST FOR FULL/PARTIAL INITIALISATION (IMODE 0, 1, 2)
      ELSE IF (IMODE == 0) THEN
C * IPR(61) SET IN PLUT00 TO -1
        IF (IPR(61) == 0) GO TO 20
        CALL GEN074 (PAR, 1, NP13, 0.0)
C * INIT BIT
        CALL GEN048 (0, I, 0, I)
        IGBL(5) = LU1
C * GET AND PRINT VERSION DATE
        WRITE (LU6, 99999, IOSTAT = IOST) IGBL(4)
        WRITE (LU6, 99991, IOSTAT = IOST) FNLU1(1:KNMXT)
        IGBL(8) = IABS (IGBL(8))
        IAN     = 4
        DO I = 1, NP10
          IACL(I) = JACL(I)
          IF (I > IAN) THEN
            IEN(I) = 0
          ELSE
C * PRELOAD H C O N
            IEN(I) = I
            RADR(I, 3) = REL(IEN(I))
            RADR(I, 4) = ABS (VDWR(IEN(I)))
          END IF
          IENLB(I)   = 0
          RADR(I, 2) = 0.0
          RADR(I, 1) = 0.0
        END DO
        CALL GEN097 (MNH, 1, NP35, 0)
        MNH(6) = 2
        MNH(7) = 2
        DO I = 1, 31
          IBT(I) = 2**(I - 1)
        END DO
        CALL GEN097 (IPPR, 1, MP7 * 3, 0)
C * DEFAULT RESIDUE COLORS
        DO I = 1, 9
          NCRS(I) = I
        END DO
C * DEFAULT RESIDUE PATTERNS
        DO I = 1, 17
          NPRS(I) = I
        END DO
        DO I = 1, 2
          DO J = 1, NP48
            MOL(I, J) = 0
          END DO
        END DO
C * SET DEFAULT ARU PATTERNS
        DO I = 1, 17
          CALL GEN048 (5, MOL(2, I), 1, I)
        END DO
C * SET DEFAULT ARU (ATOM/BOND) COLORS
        DO I = 1, 17
          CALL GEN048 (5, MOL(2, I), 6, I)
          CALL GEN048 (5, MOL(2, I), 11, I)
        END DO
        IPPR(1, 1) = 10000
        IPPR(1, 2) = 0
        IPPR(1, 3) = 1
        PAR(24)    = 0
        IF (IGBL(47) > 0) THEN
          IPR(590) = 1
        ELSE
          IPR(590) = 0
        END IF
C * SET SPECIAL POSITION PARAMETERS ( ANGSTROM AND CM RESP)
        PAR(22) = 0.3
        PAR(45) = 0.1
C * PACKING CONSTANT IN ARU
        PAR(42) = 100.0
C * SET IPR TO ZERO AND ID TO BLANK
        CALL GEN097 (IPR, 1, NP12, 0)
        CALL GEN038 (JID, 1, 80)
        IPR(460) = 3
        IPR(551) = 3
        IPR(9)  = 1
C * FRAC/ANGSTROM
        IPR(50) = 1
        IPR(69) = 8
        IPR(37) = IPR(69)
        CALL SGSM (1, ICL, SGX, 0, LU6, IERR)
        IPR(48) = 1
C * SAVE NRESMAX
        IPR(134) = NP32
C * MAX NR OF BONDS IN IC
        IPR(36) = 0
C * START OF LINE TYPE STACK (PLACES RESERVED FOR CIF & RES /INPUT)
        IPR(80) = NP49 - 1000000
C * MAX NUMBER OF BOND-TYPES
        IPR(76) = 100
C * TO H-X COVALENT BOND RADIUS PARAMETER (SOLID)
        IPR(103) = 4035
C * TO H-X COVALENT BOND RADIUS PARAMETER (ROD)
        IPR(104) = 3060
C * TO H-X COVALENT BOND RADIUS PARAMETER (STRAW)
        IPR(106) = 2120
C * SKIP Q-ATOMS FROM 'new'-SHELX file
        IPR(176) = 1
C * INIT RENAME
        CALL GEN038 (ICL, 1, 80)
        CALL PLUT29 (0, ICL, NQ1, 0, 0)
C * SET CELL CORNER COORDINATES AND FLAGS
        DO I = 1, 8
          IVAL = 0
          CALL PLUT15 (6, I, 18, IVAL)
          IVAL = 1
          CALL PLUT15 (1, I, 27, IVAL)
          NM0   = I - 1
          IVERM = 8
          DO J = 1, 3
            IVERM            = IVERM / 2
            NMK              = NM0 / IVERM
            NM0              = NM0 - NMK * IVERM
            RA(I * NP43 + J) = FLOAT (NMK)
          END DO
          RA(I * NP43 + 7) = ICHAR (' ')
        END DO
C * ORIGIN LABEL O
        RA(NP43 + 7)     = ICHAR ('O')
C * ORIGIN LABEL c
        RA(2 * NP43 + 7) = ICHAR ('c')
C * ORIGIN LABEL b
        RA(3 * NP43 + 7) = ICHAR ('b')
C * ORIGIN LABEL a
        RA(5 * NP43 + 7) = ICHAR ('a')
      ELSE
C * MODE 1 & 2 INIT
        IF (IMODE == 1) THEN
          WRITE (LU6, 99998, IOSTAT = IOST)
          DO I = IPR(69) + 1, IPR(37)
C * RESET LABEL POSITION AND PUT INSTRUCTION
            IVAL = 0
            CALL PLUT15 (1, I, 42, IVAL)
            IVAL = 0
            CALL PLUT15 (4, I, 37, IVAL)
C * RESET INCLUDE ATOM BIT
            IVAL = 1
            CALL PLUT15 (1, I, 27, IVAL)
          END DO
        ELSE IF (IMODE == 2) THEN
          IPR(37) = IPR(39)
          IPR(38) = IPR(39)
          DO I = IPR(69) + 1, IPR(37)
            IVAL = 0
            CALL PLUT15 (16, I, 1, IVAL)
C * SET DEFAULT RESIDUE
            IF (IPR(136) == IPR(69)) THEN
              IVAL = 1
            END IF
            CALL PLUT15 (6,  I, 5, IVAL)
            IVAL = 0
C * RESET NUMBER OF CONNECTIONS TO OXYGEN ATOMS
            CALL PLUT15 (3,  I, 24, IVAL)
            IVAL = 0
C * RESET NR OF BONDS
            CALL PLUT15 (4,  I, 33, IVAL)
          END DO
        END IF
      END IF
      CALL GEN038 (IGGT, 1, 80)
C * (GENERAL) INITIALISATION
C * RESET NUMBER OF ARU'S
      IPR(142) = 0
C * RESET NUMBER OF ARU'S (TOTAL, UNIQUE, INTER)
      IPR(42)  = 0
      IPR(43)  = 0
      IPR(44)  = 0
C * SET BONDS
      IPR(52)  = IPR(68)
      IPR(53)  = IPR(68)
C * NON- RESET MODE 2 DEFAULTS
      IF (IMODE /= 2) THEN
C * DEFAULT UNIT VIEW MATRIX
        CALL GEN021 (R, 1.0)
C * BOX ON
      ELSE IF (IMODE == 2) THEN
        GO TO 20
      END IF
C * TOL
      PAR(2) = 0.4
C * PLDEF - PLOTTER RESOLUTION TO BE USED (CM)
      PAR(5)  = 0.09
C * TRDEF - RADIAL DECREMENT (MM) FOR RETRACING ATOMS
      PAR(3)  = 0.1
C * TLDEF - STEP FOR RETRACING LABELS
      PAR(4)  = 0.01
C * ANGSCF- DEFAULT ANGSTROM SCALING FACTOR
      PAR(11) = 1.0
C * RADEF - DEFAULT ATOM RADII
      PAR(21) = 0.5
C * CHDEF - DEFAULT CHARACTER SIZE (CM)
      PAR(349) = 0.25
C * DPDEF - DEFAULT FOR VIEW DISTANCE (CM)
      PAR(12) = 60.0
C * SHRNK - SHRINK RATIO
      PAR(13) = 0.9
C * TDEF  - TEXT DEFAULT SIZE (CM)
      PAR(14) = 0.4
      PAR(15) = 0.0
      PAR(16) = 0.0
C * EYE SEPARATION (CM)
      PAR(17) = 3.0
C * SET DEFAULT RATIO
      PAR(50) = (4.0 - IGBL(46)) / 3.0
      PAR(18) = - PAR(50)
C * RATIO - WIDTH OF CHARACTERS DEVIDED BY HEIGHT
      PAR(19) = 6.0 / 7.0
C * FRACTIONAL SCALING FACTOR
      PAR(25) = 1.0
C * BLACK/COLOR SHADE LINE DISTANCE STEP (TO FILL IN SPHERE)
      PAR(23) = 0.0195
C * SET TOLE - (EARTH) ALKALI - O,N, ... ADDITIONAL TOLERANCE
      PAR(26) = 0.7
C * OVERLAP MARGIN
      PAR(36) = 0.1
C * RBDEF
      PAR(38) = 0.0
C * LABEL SHIFT (CM)
      PAR(39) = 0.2
C * TAPER - DEFAULT FOR TAPERING OF BONDS
      PAR(44) = 0.25
C * SET DEF MONO PERSPECTIVE
      PAR(48) = 0.0
C * ANG1 BRIGHT SPOT
      PAR(51) = 25.0
C * ANG2 BRIGHT SPOT
      PAR(52) = 15.0
C * SPOT SIZE PARAMETER
      PAR(53) = 1.90
C * BOX TEXT OFFSET
      PAR(54) = 0.15
C * SET SHADOW MARGIN( ATOM-INCOMING BOND
      PAR(58) = 0.10
C * LABEL Z OFFSET (CM)
      PAR(60) = -100.0
C * RADII ALL PAR
      PAR(70) = 0.2
C * RADIUS ORIGIN/UNITCELL BONDS
      PAR(75) = 0.01
C * SET MIN D-H...A ANGLE
      PAR(97) = 100.0
C * CIRCLE SEGMENT PARAMETER
      PAR(125) = 5.25
      PAR(127) = - PAR(2)
C * SHADE DIST
      PAR(134) = 0.15
C * BWC-SHADE ANG1
      PAR(135) = 120.0
C * BWC-SHADE ANG2
      PAR(136) = -45
C * DEFAULT TRNS
      PAR(140) = 0
C * DEFAULT CROT ROTATION ANGLE
      PAR(145) = 1.0
C * CLOSENESS DIST CRITERIUM PLUT18
      PAR(149) = 0.05
C * ATOM IDENTITY DISTANCE CRITERIUM
      PAR(150) = 0.001
C * INTERACTIVE TEXT-SIZE
      PAR(350) = 0.50
C * TYPE 1 RADIUS FRACTION
      PAR(351) = 0.5
C * TYPE 2 RADIUS FRACTION
      PAR(352) = 0.5
C * TYPE 4 RADIUS FRACTION
      PAR(354) = 0.3
C * DEFAULT MAX ME-H
      PAR(461) = 2.1
C * ZN-O,N
      PAR(541) = 0.20
C * CU-O,N
      PAR(542) = 0.35
C * MN-O,N
      PAR(543) = 0.40
C * AG-O,N
      PAR(544) = 0.20
C * CR-O,N
      PAR(545) = 0.20
C * TL-O,N
      PAR(546) = 0.3
C * UNITCELL OFF
      IPR(46)   = 0
C * MONO
      IPR(116) = 0
C * STICK MODE O
      IPR(4)   = 0
C * NR OF CONTOURS
      IPR(74)  = 8
C * IENC = 0
      IPR(15)  = 0
C * IJN = 0
      IPR(17)  = 0
C * ILBC = 0
      IPR(18)  = 0
C * SET NUMBER OF MESH LINES
      IPR(54)  = 7
C * SET NON-INVERT
      IPR(65)  = 1
C * NO PARENTHESES
      IPR(71)  = 0
C * NPRH (NET)
      IPR(85)  = 24
C * NPRV (NET)
      IPR(86)  = 24
C * UNITCELL LINE NR
      IPR(107) = 2
C * HBONDS OFF
      IPR(109) = 0
C * EXPAND OFF
      IPR(110) = 0
C * (DE/IN)CREMENT NINC
      IPR(111) = 4
C * NR OF PARALLELS
      IPR(112) = 13
C * NO PUT
      IPR(117) = 0
C * NR OF DOTS ON STANDARD SPHERE
      IPR(124) = 5000
C * REBUILD
      IPR(130) = 0
C * LABEL SHIFT TRIALS
      IPR(131) = 4
C * NUMBER OF MERIDIANS
      IPR(132) = 24
C * SET ICROT-MAX
      IPR(152) = 100000
C * SET DELETE COLOR (CROT)
      IPR(153) = 0
C * SET WRITE COLOR (CROT)
      IPR(154) = 1
C * SET NRINCL
      IPR(165) = 2
C * SET INTER INCLUDE
      IPR(166) = 1
C * POVRAY-SIZE
      IPR(171) = 1024
      IPR(172) = 768
C * INCLUDE H-ATOMS (PLOT)
      IPR(212) = 1
C * DOAC-ATOM TYPES
      IPR(480) = 11
      IPR(19)  = 1
      IPR(5)   = 1
      IPR(6)   = 0
      IPR(7)   = 1
C * SET <CR> --> END for S
      IF (IGBL(50) == 0) THEN
        IF (IGBL(92) /= 0) IPR(308) = 1
      END IF
   20 RETURN
99999 FORMAT (/, ':: Full Init - PLATON/PLUTON (', I6, ') - ',
     1 'type  HELP for information', /, 42X,
     2 ' or   PLOT for default plot', //, 6X,
     3 '********************************************************', /,6X,
     4 '>> PLEASE type ''MENU OFF'' when you dont want the      <<', /,
     5 6X,'>>              MENU feature (X-window only!)         <<', /,
     6 6X,'********************************************************', /)
99998 FORMAT (':: Partial Init')
99997 FORMAT ('LABEL')
99996 FORMAT ('PLOT CAL')
99995 FORMAT ('CREATED BY PLATON ', /,
     1        'STRAW COLOR')
99994 FORMAT ('VIEW UNIT XROT', F7.0, ' YROT', F7.0, ' ZROT', F7.0)
99993 FORMAT ('VIEW INVERT')
99992 FORMAT ('PLOT DISPLAY')
99991 FORMAT (':: Data from: ', A)
99990 FORMAT (':: File ', A, ' NOT Available,',
     1        ' Interactive INPUT Assumed', /)
      END SUBROUTINE PLUT01
 
      SUBROUTINE PLUT02
C * SUBROUTINE CONTROLS ALL PLOTTING OF ATOMS , BONDS AND LABELS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE pluto
      USE chdat
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: I1
      INTEGER            :: N1
      INTEGER            :: N2
      INTEGER            :: II
      INTEGER            :: JJ
      INTEGER            :: IO
      INTEGER            :: JO
      INTEGER            :: N0
      INTEGER            :: IP
      INTEGER            :: NE
      INTEGER            :: NR
      INTEGER            :: NAB
      INTEGER            :: NAP
      INTEGER            :: NAT
      INTEGER            :: IP1
      INTEGER            :: IP2
      INTEGER            :: IPM
      INTEGER            :: IRU
      INTEGER            :: ITX
      INTEGER            :: ITY
      INTEGER            :: ITZ
      INTEGER            :: IVL
      INTEGER            :: JAT
      INTEGER            :: MPM
      INTEGER            :: MR2
      INTEGER            :: MS2
      INTEGER            :: NMZ
      INTEGER            :: NRS
      INTEGER            :: NMLX
      INTEGER            :: NTP1
      INTEGER            :: NTP2
      INTEGER            :: NTYP
      INTEGER            :: NSPC
      INTEGER            :: NRES
      INTEGER            :: NORG
      INTEGER            :: NMOL
      INTEGER            :: NINC
      INTEGER            :: NATL
      INTEGER            :: NATO
      INTEGER            :: LTYP
      INTEGER            :: JJJJ
      INTEGER            :: IRES
      INTEGER            :: ILAB
      INTEGER            :: ILPB
      INTEGER            :: IASU
      INTEGER            :: IATK
      INTEGER            :: ICMD
      INTEGER            :: IDET
      INTEGER            :: IDIS
      INTEGER            :: NPROP
      INTEGER            :: NINCL
      INTEGER            :: JOMIT
      INTEGER            :: IROTX
      INTEGER            :: IROTY
      INTEGER            :: IROTZ
      INTEGER            :: IDUM1
      INTEGER            :: IDUM2
      INTEGER            :: IDUM3
      INTEGER            :: IDUM5
      INTEGER            :: MADDR
      INTEGER            :: IDPLT
      INTEGER            :: ICOL0
      INTEGER            :: INCLUDEX
      REAL               :: Q
      REAL               :: RI
      REAL               :: XI
      REAL               :: YI
      REAL               :: ZI
      REAl               :: YK
      REAL               :: XII
      REAL               :: YII
      REAL               :: ZII
      REAL               :: PHI
      REAL               :: P14
      REAL               :: CLR
      REAL               :: DIS
      REAL               :: RAX
      REAL               :: XNM
      REAL               :: YNM
      REAL               :: ZNM
      REAL               :: XLAB
      REAL               :: RA11
      REAL               :: DUM4
      REAL               :: DISK
      REAL               :: DEYE
      REAL               :: DIFF
      REAL               :: XLNG
      INTEGER            :: FINDEXE
      CHARACTER(len=40)  :: TXT3
      CHARACTER(len=255) :: PLPATH
      CHARACTER(len=6)   :: TXT2
      CHARACTER(len=10)  :: KLEUR
C * CHECK FOR 'CURRENT-RESIDUE-NUMBER'
      IF (IPR(140) < 0) THEN
        IVL = - IPR(140)
        CALL PLUT15 (-6, IVL, 5, IPR(140))
        DO I = 1, IPR(42)
          XNM = ABS (MOL(1, I) / PAR(42))
          IRES = IABS (MOL(1, I)) - INT (XNM) * NINT (PAR(42))
          IF (IRES /= IPR(140)) THEN
            MOL(1, I) = - NINT (XNM * PAR(42))
          ELSE
            MOL(1, I) =   NINT (XNM * PAR(42))
          END IF
        END DO
      END IF
      IPR(45) = 0
      IF (IGBL(2) > 0) THEN
C * TEST FOR REBUILD
        IF (IPR(130) == 0) THEN
C * SET NUMBER OF MOLECULES TO BE PLOTTED TO AT LEAST ONE (=INP. MOL)
          CALL PLUT17 (0.0, 0, MADDR, LU6)
C * FIRST COUNT THE ACTIVE NUMBER OF MOLECULES
C * SET POINTER FOR ACTIVE ASU LIST
          CALL PLUT17 (0.0, 1002, MADDR, LU6)
C * CALCULATE TOTAL NUMBER OF ACTIVE/PASSIVE PLOT ITEMS = ATOMS/LABELS
C * IN ARRAY RA BEFORE ACTUAL FILLING AND TEST WHETHER THERE IS ENOUGH
C * SPACE AVAILABLE FOR THIS PLOT REQUEST
C * FIRST NUMBER OF ATOM - ITEMS IN IPR(62)
          IPR(62) = IPR(142) * (IPR(37) - IPR(69)) + IPR(69)
C * SAVE NUMBER OF ATOM + ATOMLABEL ITEMS IN IPR(59)
          IPR(59) = IPR(62) + IPR(37) * IPR(452)
C * SAVE TOTAL NUMBER OF ITEMS IN IPR(40)
          IF (IPR(63) == 0) THEN
            IPR(40) = IPR(59)
          ELSE
            IPR(40) = IPR(59) + IPR(42)
          END IF
          IPR(125) = (IPR(37) + 1) * NP43
C * SET BOTTOM POINTER OF XP, YP, ZP, RP INFORMATION IN RA-ARRAY
          IPR(158) = IPR(125) + IPR(62) * IPR(82) * 4
C * RESERVE CROT SPACE
          NSPC     = NP0
          IPR(157) = IPR(158)
          IPR(167) = IPR(158)  + IPR(62) * NP0
          IPR(168) = IPR(158)  + IPR(62) * NP0
          IF (IPR(151) > 0) THEN
            IPR(158) = IPR(158) + IPR(62) * NP0
            NSPC     = 2 * NP0
            IF (IPR(116) /= 0) THEN
              IPR(167) = IPR(158) + IPR(62) * NP0
              IPR(168) = IPR(167) + IPR(62) * NP0
              NSPC     = 4 * NP0
            END IF
          END IF
C * CHECK FOR SUFFICIENT STORAGE
          IF (IPR(157) + NSPC * IPR(40) >= IPR(64) - IPR(52) * 2)
     1      THEN
            CALL PLUT38 (5, 0, LU6)
            GO TO 90
          END IF
        END IF
C * SET COUNTERS FOR PLOT ATOM, ATOM LABELS , MOL LABELS
        NAP  = 0
        NAT  = IPR(37)
        NATO = IPR(39)
        NMOL = IPR(42)
        NATL = IPR(62)
        NRES = IPR(75)
        ILPB = IPR(69) + 1
        NAB  = NAT - ILPB + 1
        DISK = PAR(35)**2
C * BUILD UP ARRAY OF PLOT COORDINATES (IPR(130) = 0)
   10   IF (IPR(130) == 0) THEN
          IF (IPR(116) <= 0) THEN
C * INITIALISATION FOR THIS PLOT
            CALL GEN074 (PAR, 61, 63,  1E10)
            CALL GEN074 (PAR, 64, 66, -1E10)
            IF (IPR(49) /= 0) WRITE (IPR(49), 99998, IOSTAT = IOST)
C * SORT ACTIVE ASU LIST
            CALL GEN034 (RA, IPR(159) + 1 - IPR(142), IPR(159) - 1)
C * BEGIN LOOP ON ASU-LIST
            NMLX = IPR(142)
            DO M = 1, NMLX
              IF (M == 1) THEN
                I1 = 1
              ELSE
                I1 = ILPB
              END IF
              XNM = NINT (RA(IPR(159) + 1 - M))
              MPM = NINT (XNM * PAR(42))
              CALL GEN098 (MPM, PAR(42), N, ITX, ITY, ITZ, NR)
              TRL(1) = ITX
              TRL(2) = ITY
              TRL(3) = ITZ
C * DETERMINE ACTIVE RESIDUES (i.e. KRS(J) >= 0) FOR THIS ASU
              DO J = 1, NRES
                KRS(J) = -1
              END DO
C * LOOP OVER ARU'S
              DO J = 1, NMOL
                YNM = MOL(1, J) / PAR(42)
                ZNM = INT (YNM)
                IF (XNM == ZNM)
     1              KRS (NINT ((YNM - XNM) * PAR(42))) = MOL(2, J)
              END DO
C * BEGIN LOOP ON ATOMS IN ASU
              DO I = I1, NAT
C * INCLUDEX = -1 EXCLUDE from PLOTTING
C * INCLUDEX =  1 INCLUDE in   PLOT
                INCLUDEX = - 1
C * FIRST GENERATE FRACTIONAL COORDINATES
                DO J = 1, 3
                  SGX(J)     = RA(I * NP43 + J)
                  SGX(J + 3) = TRL(J)
                  SGX(J + 6) = SGX(J)
                END DO
                IF (I >= ILPB) THEN
                  CALL SGSM (3, ICL, SGX, N, LU6, IERR)
C * TEST FOR ATOM OUTSIDE BOX ENCLOSURE FOR PLOT
                  IF (IPR(15) > 0) THEN
                    DO J = 1, 6
                      L    = (J + 1) / 2
                      JJJJ = L * 2 - J
                      DIFF = SGX(L + 6) - PAR(J + 28)
                      IF (DIFF < 0.0) THEN
                        IF (JJJJ /= 0) GO TO 30
                      ELSE IF (DIFF > 0.0) THEN
                        IF (JJJJ == 0) GO TO 30
                      END IF
                    END DO
                  ELSE IF (IPR(15) < 0) THEN
                    GO TO 20
                  END IF
                END IF
                IDIS = 10000
C * CHECK FOR 'MAJOR/MINOR DISORDER FORM ONLY'
                IF (IGBL(59) /= 0 .AND. I >= ILPB) THEN
                  CALL PLUT15 (-4, I, 28, IDIS)
                  IDIS   = IPPR(IDIS + 1, 1)
                END IF
                IF (IDIS < 10000) THEN
                  IF (IGBL(88) == 0) THEN
                    IF (IDIS >= 5000) INCLUDEX = 1
                  ELSE
                    IF (IDIS <= 5000) INCLUDEX = 1
                  END IF
                ELSE
                  INCLUDEX = 1
                END IF
C * MAKE ORTHONORMAL
   20           DO II = 1, 3
                  RA(II) = SGX(II + 6)
                END DO
                CALL PLUT23 (0)
C * TEST FOR ATOM OUTSIDE ENCLOSURE SPHERE FOR PLOT
                IF (IPR(15) < 0) THEN
                  IF (I >= ILPB) THEN
                    DIS = 0
                    DO II = 4, 6
                      DIS = DIS +
     1                   (RA( - IPR(15) * NP43 + II) - RA(II))**2
                    END DO
                    IF (DIS > DISK)  GO TO 30
                    INCLUDEX = 1
                  END IF
                END IF
C * ROTATE THE ORTHONORMAL COORDINATES
                CALL GEN002 (1, R, RA(4), XYZR, XLNG)
C * GET INCLUDE STATUS OF (PARENT) ATOM
                IF (I <= NATO) THEN
                  J = I
                ELSE
                  XLAB = RA(I * NP43 + 7)
                  DO J = ILPB, NATO
                    IF (RA(J * NP43 + 7) == XLAB) GO TO 30
                  END DO
                  GO TO 40
                END IF
   30           CALL PLUT15 (-1, J, 27, NINCL)
                IF (NINCL == 0) INCLUDEX = - 1
C * CHECK FOR 'HANGING' BOND
   40           IF (IPR(166) == 0) THEN
                  IF (I > NATO) THEN
                    CALL PLUT15 (-6, I, 11, IRU)
                    MPM = IABS (MOL(1, IRU + 1))
                    CALL GEN098 (MPM, PAR(42), MS2, ITX, ITY, ITZ, MR2)
                    SGX(6) = ITX
                    SGX(7) = ITY
                    SGX(8) = ITZ
                    SGX(1) = N
                    SGX(2) = TRL(1)
                    SGX(3) = TRL(2)
                    SGX(4) = TRL(3)
                    SGX(5) = MS2
                    CALL SGSM (8, ICL, SGX, 0, LU6, IERR)
                    NMZ = NINT (SGX(9)) * 1000 + NINT (SGX(10)) * 100
     1                  + NINT (SGX(11)) * 10  + NINT (SGX(12)) + 555
                    NMZ = NINT (NMZ * PAR(42)) + MR2
                    DO J = 1, NMOL
                      IF (NMZ == MOL(1, J)) GO TO 50
                    END DO
                    INCLUDEX = -1
                  END IF
                END IF
   50           JOMIT = 0
C * LOOK FOR SPACIAL IDENTITY WITH PREVIOUSLY LOADED ATOM
                IF (IPR(4) /= 0 .AND. M > 1 .AND.
     1            INCLUDEX == 1) THEN
                  JO = ILPB - 1
                  II = IPR(158) + JO * NP0
                  DO N0 = ILPB, NAP
                    II = II + NP0
                    JO = JO + 1
                    IF (RA(II) > 0.0) THEN
                      IF (ABS (RA(II - 3) - XYZR(1)) < PAR(150))
     1                  THEN
                        IF (ABS (RA(II - 2) - XYZR(2)) < PAR(150))
     1                    THEN
                          IF (ABS (RA(II - 1) - XYZR(3)) < PAR(150))
     1                      THEN
                            IO = MOD (JO - ILPB, NAB) + ILPB
                            IF (IO <= IPR(39)) THEN
                              CALL PLUT15 (-1, IO, 27, NINC)
                              IF (NINC == 1) THEN
                                JOMIT = 1000
                                GO TO 60
                              END IF
                            END IF
                          END IF
                        END IF
                      END IF
                    END IF
                  END DO
                END IF
   60           NAP = NAP + 1
C * LOAD ATOM POSITIONS FOR CURRENT ARU
                IF (I >= ILPB) THEN
                  CALL PLUT15 (-6, I, 5, NRS)
                  IF (INCLUDEX == 1 .AND. NRS > 0) THEN
C * OMIT NON-ESSENTIAL DUMMY ATOMS
                    IF (I > IPR(38)) THEN
                      CALL PLUT15 (-4, I, 37, ILAB)
                      IF (ILAB == 0 .OR. M > 1) THEN
                        N2 = IPR(64) - IPR(53) * 2 - 1
                        N1 = IPR(64) - IPR(52) * 2 + 1
                        DO N0 = N1, N2, 2
                          ICMD = NINT (RA(N0))
                          IF (ICMD < 0) THEN
                            CYCLE
                          ELSE
                            JAT = NINT (RA(N0 + 1))
                            IF (I == JAT) GO TO 70
                          END IF
                        END DO
                        INCLUDEX = - 1
                        GO TO 80
                      END IF
                    END IF
   70               IF (KRS(NRS) < 0) INCLUDEX = - 1
                  END IF
C * GET ATOM TYPE
 
   80             RA11 = RA(I * NP43 + 11)
                  IF (RA11 < 0.0) THEN
                    IF (IPR(231) == 0) THEN
                      IATK = INT (RA(I * NP43 + 7) / 64000)
                      RAX  = RADR(IATK + 1, 1)
                    ELSE
                      RAX = ABS (RA11) * 0.35
                    END IF
                  ELSE
                    RAX  = RA11
                  END IF
                  IF (NRS /= 0) THEN
                    NPROP = KRS(NRS)
                  ELSE
                    NPROP = 0
                  END IF
                ELSE
C * CELL CORNER
                  IF (IPR(46) == 0) INCLUDEX = - 1
                  RAX   = PAR(75)
                  NPROP = 0
                END IF
C * TEST ASYM RESIDUE ONLY
                IF (IGBL(128) == 1) THEN
                  IF (M /= 1) INCLUDEX = -1
                END IF
                IF (INCLUDEX == 1) THEN
C * KEEP TRACK OF PLOT MAXIMA IN ANGSTROM UNITS
                  DO JJ = 1, 3
                    PAR(63 + JJ) = MAX (XYZR(JJ) + RAX, PAR(63 + JJ))
                    PAR(60 + JJ) = MIN (XYZR(JJ) - RAX, PAR(60 + JJ))
                  END DO
                ELSE
                  JOMIT = - 1000
                  IF (RAX > 0.0) THEN
                    RAX = - RAX
                  ELSE
                    RAX = - 1.0
                  END IF
                END IF
                RAX = RAX + JOMIT
                IASU = I * 1000 + M
                CALL PLUT14 (1, NAP, IASU, NPROP, XYZR(1), XYZR(2),
     1                       XYZR(3), RAX)
              END DO
C * END OF LOOP ON ATOMS
            END DO
C * END OF LOOP ON MOLECULES
C * GET ALL COORDS REFERRED TO CENTRE OF THE PLOT (Or Zoom-Centre) AS ORIGIN
            IF (IPR(342) /= 0) THEN
              CALL PLUT14 (-1, IPR(342), IASU, NPROP, PAR(67), PAR(68),
     1                         PAR(69), YK)
            END IF
            DO I = 1, 3
              IF (IPR(342) == 0)
     1        PAR(66 + I) = (PAR(60 + I) + PAR(63 + I)) / 2.0
              IF (I < 3 .OR. IPR(151) > 0) THEN
                PAR(60 + I) = (PAR(60 + I) - PAR(66 + I))
                PAR(63 + I) = (PAR(63 + I) - PAR(66 + I))
              END IF
            END DO
C * GET MAX AND MIN FOR PLOT BOUNDARIES ALLOWING A SAFETY MARGIN.
C * AND CALCULATE SCALE FACTOR TO FIT DRAWING IN BOX OF
C * VERTICAL   DIMENSION VERT
C * HORIZONTAL DIMENSION PAR(15) = PAR(18) * VERT
            PAR(15) = VERT * ABS (PAR(18))
            IF (PAR(64) + PAR(65) < 0.0001) THEN
              PAR(64) = 5
              PAR(65) = 5
            END IF
C * GET CENTIMETER/ANGSTROM SCALE  (AUTO OR USER SUPPLIED)
            IF (PAR(16) == 0.0 .AND. PAR(65) /= 0.0) THEN
              IF (PAR(64) / PAR(65) > ABS (PAR(18))) THEN
                PAR(24) = PAR(15) * PAR(13) / (2.0 * PAR(64))
              ELSE
                PAR(24) = VERT * PAR(13) / (2.0 * PAR(65))
              END IF
            ELSE
              PAR(24) = PAR(16)
            END IF
            PAR(61) = - PAR(15) / 2
            PAR(62) = - VERT  / 2
            PAR(64) = - PAR(61)
            PAR(65) = - PAR(62)
C * LOAD ACTIVE BONDS FROM IPR(79)
            IPR(79) = IPR(64) - IPR(52) * 2 - IPR(142)
            CALL PLUT16 (-6, IDUM1, IDUM2, IDUM3, DUM4, IDUM5)
C * SET SCRATCH POINTER OF TOP DOWN  OBSCURATION SCRATCH : IPR(66)
            IPR(66) = IPR(79) - IPR(97) * 4
          END IF
C * IF STEREO OR PERSPECTIVE REQUIRED ADJUST CO-ORDINATES.
          NORG = (1 - IPR(46)) * IPR(69)
          II   = IPR(158)
          K    = 0
          IF (IPR(116) > 0) THEN
            IF (IGBL(75) > 0) THEN
              NATL = IPR(40)
            END IF
          END IF
          DO I = 1, NATL
            II = II + NP0
            NPROP = NINT (RA(II - 4))
            XI = RA(II - 3)
            YI = RA(II - 2)
            ZI = RA(II - 1)
            RI = RA(II)
            IF (RI >= 0) THEN
              INCLUDEX =  1
            ELSE
              RI       =  ABS (RI)
              INCLUDEX = -1
            END IF
            IF (RI > 999.9) THEN
              JOMIT = 1000
              RI = RI - JOMIT
            ELSE
              JOMIT = 0
            END IF
            IF (IPR(116) <= 0) THEN
C * MONO AND LEFT STEREO
              XII = XI
              YII = YI
              ZII = ZI
              XI  = (XI - PAR(67)) * PAR(24)
              YI  = (YI - PAR(68)) * PAR(24)
              IF (IPR(151) == 0) THEN
                ZI = (ZI - PAR(66)) * PAR(24)
              ELSE
                ZI = (ZI - PAR(69)) * PAR(24)
              END IF
              RI = PAR(24) * RI
C * APPLY PERSPECTIVE REDUCTION ON RADIUS
              IF (PAR(48) > 0.0)
     1          RI = RI * PAR(48) / (PAR(48) - ZI)
              IF (IPR(82) /= 0 .AND. I <= IPR(62)
     1          .AND. I > NORG) THEN
                CALL PLUT25 (-1, I, IATK)
                IF (INCLUDEX == 1) THEN
C * OUTPUT ANGSTROM DATA TO MOGLI-FILE
                  IF (I <= IPR(69)) THEN
                    NQ1(3:4) = '  '
                    LTYP = NINT (RA(I * NP43 + 7))
                    IF (LTYP /= ICHAR (' ')) THEN
                      NQ1(1:2) = 'AR'
                    ELSE
                      NQ1(1:2) = 'NE'
                    END IF
                  END IF
                  K                              = K + 1
                  RA(IPR(125) + (I - 1) * 4 + 1) = K
                  RA(IPR(125) + (I - 1) * 4 + 2) = XII
                  RA(IPR(125) + (I - 1) * 4 + 3) = YII
                  RA(IPR(125) + (I - 1) * 4 + 4) = ZII
C * FOR POVRAY
                  IF (IPR(10) == 1) THEN
                    IF (IPR(4) /= 0) THEN
                      IO = MOD (I - ILPB, NAB) + ILPB
                      CALL PLUT15 (-1, IO, 27, NINCL)
                      IF (NINCL > 0) THEN
                        IF (IABS (IPR(477)) /= 0) THEN
                          IF (IPR(477) > 0) THEN
                            CALL GEN048 (-5, NPROP, 1, ICOL0)
                          ELSE IF (IPR(477) < 0) THEN
                            CALL PLUT15 (-6, IO, 5, NRS)
                            IF (NRS > 0 .AND. NRS <= 8) THEN
                              ICOL0 = NRS
                            ELSE
                              ICOL0 = 0
                            END IF
                          END IF
                          IF (ICOL0 > 0 .AND. ICOL0 <= 16) THEN
                            KLEUR = COLR(ICOL0)
                            CALL GEN020 (-1, KLEUR, 2, 10)
                            IF (ICOL0 == 16)
     1                        CALL GEN020 (1, KLEUR, 6, 6)
                          ELSE
                            KLEUR = '  color_C '
                          END IF
                        ELSE
                          NTYP = IEL(IEN(IATK))
                          NTP1 = NTYP / 100
                          NTP2 = NTYP - NTP1 * 100 + ICHAR ('a') - 1
                          NTP1 = NTP1 + ICHAR ('A') - 1
                          IF (NTP2 == ICHAR ('a') - 1)
     1                      NTP2 = ICHAR (' ')
                          KLEUR = '  color_'//CHAR (NTP1)//CHAR (NTP2)
                        END IF
                        WRITE (LU61, 99999, IOSTAT = IOST)
     1                    NQ1, XII - PAR(67), YII - PAR(68),
     2                    - ZII + PAR(69), RI / PAR(24), KLEUR
                      END IF
                    END IF
C * PDB (RASMOL)
                  ELSE IF (IPR(10) == 2) THEN
                    IO = MOD (I - ILPB, NAB) + ILPB
                    CALL PLUT15 (-1, IO, 27, NINCL)
                    IF (NINCL > 0) THEN
                      WRITE (LU60, 99997, IOSTAT = IOST)
     1                  I, NQ1(1:5), 0, XII - PAR(67), - YII + PAR(68),
     2                  - ZII + PAR(69),  1.0, 0.0
                    END IF
                  END IF
                END IF
              END IF
            END IF
            IF (IPR(151) == 0) THEN
              Q = 1.0
              IF (PAR(48) > 0.0) Q = PAR(48) / (PAR(48) - ZI)
              IF (IPR(116) == 0) THEN
C * PERSPECTIVE ONLY
                XI = XI * Q
                YI = YI * Q
              ELSE
C * STEREO AND PERSPECTIVE
                IF (IPR(6) < 0) THEN
                  DEYE = - PAR(17)
                ELSE
                  DEYE =   PAR(17)
                END IF
                IF (IPR(116) < 0) THEN
C * STEREO COORDS FOR LEFT EYE VIEW
                  XI = (XI + DEYE) * Q - DEYE
                  YI = YI * Q
                ELSE
C * STEREO COORDS FOR RIGHT EYE VIEW
                  XI = XI + 2.0 * DEYE * (1.0 - Q)
                END IF
              END IF
            END IF
            RA(II - 3) = XI
            RA(II - 2) = YI
            RA(II - 1) = ZI
            RA(II)     = (RI + JOMIT) * INCLUDEX
          END DO
        END IF
        IF (IPR(116) <= 0) THEN
          IGBL(32) = IABS (IGBL(32))
          IWIN     = IGBL(25) * IGBL(32)
 
C * PLOT INITIALISATION
          BCD = 'P.L.U.T.O.N'//CHAR (0)
          IF (IGBL(50) == 0) THEN
            CALL GGIP ((1 + IABS (IPR(6))) * PAR(15), VERT, PAR(25), 1)
          ELSE
            CALL GGIP (XSH0, YSH0, 0.0, -3)
          END IF
C * SHIFT ORIGIN TO PAR(64),PAR(65)
          CALL GGIP (PAR(64), PAR(65), 0.0, -3)
        END IF
        IF (IPR(82) /= 0) THEN
        END IF
C * DEFAULT PEN
        CALL GGIP (0.0, FLOAT (IPR(19)), 0.0, 0)
C * RED/GREEN OR GREEN/RED STEREO
        IF (IPR(6) == 0) THEN
          IF (IPR(116) == -1) THEN
C * LEFT STEREO
            CALL GGIP (0.0, FLOAT (IPR(143)), 0.0, 0)
          ELSE IF (IPR(116) == 1) THEN
C * RIGHT STEREO
            CALL GGIP (0.0, FLOAT (IPR(144)), 0.0, 0)
          END IF
        END IF
C * PLOT SPECIAL TEXT
        LMOD = 0
        CALL PLA109 (2, 1, 0.0, 0.0)
C * PLOT SEQUENCE: ATOMS/LABELS/BONDS
        IF (IPR(151) <= 0) THEN
          IF (IGBL(25) * IGBL(32) == 1) THEN
            IF (IGBL(50) == 0) THEN
              BCD = 'Click HERE to INTERRUPT PLOTTING'//CHAR (0)
              CALL GGIP (-999.0, 2.0, 33.0, 111)
            END IF
            IF (IPR(116) == 0) THEN
C * DEFAULT PEN
              CLR = IPR(19)
            ELSE IF (IPR(116) > 0) THEN
              CLR = IPR(144)
            ELSE
              CLR = IPR(143)
            END IF
              CALL GGIP (0.0, CLR, 0.0, 0)
          END IF
C * PLOT ATOMS
          IF (IPR(10) <= 0) THEN
            CALL PLUT11
C * POSITION AND PLOT LABELS (UNLESS INTERRUPTED I.E. IPR(45) = 0)
            IF (IPR(45) == 0) CALL PLUT04 (1, 0)
          END IF
        ELSE
          IF (IGBL(25) * IGBL(32) == 1) THEN
            BCD = 'Click on Window to STOP Rotation'//CHAR (0)
          ELSE
            TXT3 = 'Freeze CROTX Rotation by pressing CTRL-C'
            TXT3(12:12) = CHAR (ICHAR ('W') + IPR(155))
          END IF
          IF (IPR(169) == 0) THEN
            IF (IGBL(25) * IGBL(32) == 1) THEN
              CALL GGIP (-999.0, 2.0, 33.0, 111)
            ELSE
              CALL PLA439 (0.0, TXT3, 40, PAR(14) * 1.4, 2, 2, PAR(61),
     1          PAR(62) + PAR(14) * 0.7)
            END IF
          END IF
        END IF
C * PLOT BONDS
        IF (IPR(45) == 0) CALL PLUT10
C * PLOT TITLE/BOX WITH DEFAULT PEN SELECTED
        IF (IPR(45) == 0 .AND. IGBL(103) == 1) THEN
          P14  = PAR(14)
          IPM = MIN (NINT ((PAR(64) - PAR(61)) / P14) - 14, 74)
          CALL PLA439 (0.0, JID, IPM, P14, IPR(19), 1,
     1        PAR(61) + 7 * P14, PAR(62) + PAR(54))
          CALL GEN040 (IGBL(4), NQ2, IP)
          CALL PLA439 (90.0, PROGNM//' - ('//NQ2(1:IP)//')',
     1         IP + 33, P14, IPR(19), 1, PAR(61) + P14 + PAR(54),
     2         PAR(62) + 3 * P14)
C * DRAW BOX DEFINING THE LIMIT OF PLOTTING COORDS
          CALL GGIP (PAR(61), PAR(62), 0.0, 3)
          CALL GGIP (PAR(61), PAR(65), 0.0, 2)
          CALL GGIP (PAR(64), PAR(65), 0.0, 2)
          CALL GGIP (PAR(64), PAR(62), 0.0, 2)
          CALL GGIP (PAR(61), PAR(62), 0.0, 2)
C * REPORT ON '.def'
          IF (IGBL(23) == 1) THEN
            CALL PLA439 (0.0, 'DEF-FILE ACTIVE', 15, P14,
     1        5 + IGBL(68), 1, PAR(64) - 55 * P14,
     2        PAR(65) - PAR(54) - P14)
          END IF
C * REPORT ON (NO)MOVE
          IF (IGBL(60) > 0) THEN
            CALL PLA439 (0.0, 'INPUT ATOMS MOVED', 17,
     1        P14, 2, 1, PAR(64) - 41 * P14, PAR(65) - PAR(54) - P14)
          ELSE
            IF (IGBL(30) == 1) THEN
              CALL PLA439 (0.0, 'NOMOVE FORCED', 13, P14,
     1          3, 1, PAR(64) - 37 * P14, PAR(65) - PAR(54) - P14)
            END IF
          END IF
C * PLOT TEXT
          CALL PLA439 (0.0, TEXT, 20, P14, 1, 1, -30 * P14 , PAR(65)
     1      - PAR(54) - P14)
C * PLOT XROT,YROT,ZROT AND VIEW DISTANCE IN BOX CORNERS
          IDPLT = INT(PAR(48))
          IF (IDPLT > 998) IDPLT = 0
          CALL GEN096 (R, IROTX, IROTY, IROTZ, IDET, XYZOR, PHI, ROM)
          IPR(65) = IDET
          IF (IDET == -1) CALL PLA439 (0.0, 'INVERT', 6, P14,
     1        3, 2, PAR(64) - 13 * P14, PAR(65) - PAR(54) - P14)
          CALL GEN040 (IPR(140), NQ1, IP)
          TXT2 = 'RES='//NQ1(1:2)
          CALL PLA439 (0.0, TXT2, 6, P14, 1, 1, PAR(64)
     1              - 21 * P14, PAR(65) - PAR(54) - P14)
          CALL GEN040 (IROTX, NQ1, IP)
          NQ1(IP + 1:IP + 2) = ' X'
          IP                 = IP + 2
          CALL PLA439 (0.0, NQ1, IP, P14, 1, 1, PAR(64) - IP * P14,
     1         PAR(62) + PAR(54))
          CALL GEN040 (IROTY, NQ1, IP)
          NQ1(IP + 1:IP + 2) = ' Y'
          IP                 = IP + 2
          CALL PLA439 (90.0, NQ1, IP, P14, 1, 1,
     1         P14 + PAR(54) + PAR(61), PAR(65) - IP * P14)
          CALL PLA439 (0.0, 'Z', 1, P14, -1, 1, PAR(61) + PAR(54),
     1         PAR(62) + PAR(54))
          CALL GEN040 (IROTZ, NQ1, IP)
          CALL PLA439 (0.0, NQ1, IP, P14, 1, 1,
     1           PAR(61) + PAR(54) + 2 * P14, PAR(62) + PAR(54))
          CALL GEN040 (IDPLT, NQ1, IP)
          CALL PLA439 (0.0, NQ1, IP, P14, 1, 1, PAR(64) - IP * P14,
     1         PAR(65) - PAR(54) - P14)
        END IF
C * TEST IF STEREO PAIR IS TO BE DRAWN
        IF (IPR(116) < 0) THEN
          IPR(116) = 1
C * NO SHIFT OF  PLOTTER ORIGIN FOR IPR(6) = 0
          IF (IABS(IPR(6)) > 0)
     1        CALL GGIP (ABS(PAR(15)), 0.0, 0.0, -3)
          GO TO 10
        ELSE
          IPR(116) = - IPR(116)
C * LIST ATOMS, BONDS, ARU'S, LINES
          IF (IPR(130) == 0 .AND. IPR(145) == 1) THEN
            IPR(90) = 254
          END IF
C * SET REBUILD
          IPR(130) = 1 + IPR(116)
C * POVRAY
          IF (IPR(340) /= 0) THEN
            IF (IGBL(98) == 1) THEN
              CLOSE (UNIT = LU61)
              XGGIP = -999.0
              YGGIP = 0.0
              ZGGIP = 0.0
              IF (IGBL(123) == 0) THEN
              CALL GGIP (XGGIP, YGGIP, ZGGIP, -8)
              IPR(172) = MIN (IPR(172), NINT (YGGIP))
              IPR(171) = NINT (IPR(172) * ABS (PAR(18)))
              ELSE
                IPR(172) = 768 * IGBL(123)
                IPR(171) = NINT (IPR(172) * ABS (PAR(18)))
              END IF
              CALL GEN040 (IPR(171), NQ1, IP1)
              CALL GEN040 (IPR(172), NQ2, IP2)
              CALL GEN038 (PLPATH, 1, 255)
C * FIND povray
              NE = FINDEXE ('POVEXE', PLPATH, 'povray')
              IF (NE > 0) THEN
                PLPATH(NE +1:) =
     1 ' +P +D +A0.3 +W'//NQ1//'+H'//NQ2//'+I'//NAMEFIL(1:KNMFIL)//' &'
                KERR = 0
                CALL SPAWN (PLPATH, LU6, .true., KERR)
                IPR(340) = 0
              ELSE
                CALL PLA015 (0, 9)
              END IF
              IGBL(98) = -1
            ELSE IF (IGBL(11) == 1) THEN
              CLOSE (UNIT = LU60)
              CALL GEN038 (PLPATH, 1, 255)
C * FIND rasmol
              NE = FINDEXE ('RASEXE', PLPATH, 'rasmol')
              IF (NE > 0) THEN
                PLPATH(NE + 1:) = ' '//NAMEFIL(1:KNMFIL)//'.ras &'
                KERR = 0
                CALL SPAWN (PLPATH, LU6, .true., KERR)
                IPR(340) = 0
              ELSE
                CALL PLA015 (0, 9)
              END IF
              IGBL(11) = -1
            END IF
          END IF
        END IF
      END IF
   90 RETURN
99999 FORMAT ('// ', A, /, 7X, 'sphere {', /,
     1        15X, '< ', F9.4, ',', F9.4, ',', F9.4, ' >,', F5.2, /,
     3        15X, 'texture { pigment { color ',A, '}', /,
     4        15X, 'finish { finish_all } } }')
99998 FORMAT (//, ' NR  NMOL ATNR LABEL     XMOL', 9X, 'X', 9X, 'Y',
     1       9X, 'Z', 9X, 'RAX'/)
99997 FORMAT ('ATOM', 2X, I5, 1X, A, 4X, I5, 4X, 3F8.3, 2F6.2)
      END SUBROUTINE PLUT02
 
      SUBROUTINE PLUT03 (IER)
C * ATOM CARD HANDLING
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      USE sgxyz
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: N
      INTEGER            :: N1
      INTEGER            :: N2
      INTEGER            :: I1
      INTEGER            :: I2
      INTEGER            :: I4
      INTEGER            :: II
      INTEGER            :: KL
      INTEGER            :: KN
      INTEGER            :: LOP
      INTEGER            :: IWD
      INTEGER            :: NED
      INTEGER            :: NQX
      INTEGER            :: NSS
      INTEGER            :: NSYM
      INTEGER            :: NQSM
      INTEGER            :: NPOP
      INTEGER            :: NIEN
      INTEGER            :: NATX
      INTEGER            :: MODE
      INTEGER            :: MULT
      INTEGER            :: IDUM
      INTEGER            :: IVAL
      INTEGER            :: IYUNK
      INTEGER            :: INQNR
      INTEGER            :: JNQNR
      INTEGER            :: IANIS
      INTEGER            :: IANP1
      INTEGER            :: INTPOP
      INTEGER            :: ICLOSE
      INTEGER            :: IER
      REAL               :: SJ
      REAL               :: YY
      REAL               :: VRS
      REAL               :: XLNG
      REAL               :: TRNS
      REAL               :: UISO
      REAL               :: VERS
      REAL               :: PAR22
      REAL               :: DCLOSE
      REAL, DIMENSION(3) :: DUMA
      I4   = 0
      KL   = IPR(220)
      KN   = IPR(221)
      NSYM = IPR(48)
      MULT = NSYM
C * HANDLE X (= DISORDER) CHARACTER
      IF (KL == 3 .AND. IFL(3)(1:1) == 'X') THEN
        IPR(220) = 2
        KL       = IPR(220)
      END IF
C * CHECK FOR ADEQUATE NUMBER OF DATA ON CARD
      IF (KL > 3 .OR. KL == 0) THEN
        WRITE (LU6, 99997, IOSTAT = IOST) ICL(1:80)
        IER = 1
        RETURN
      END IF
      IF (KN > 0 .AND. KN < 3) THEN
        IF (INDEX (ICL, '.RES') == 0)
     1    WRITE (LU6, 99998, IOSTAT = IOST) ICL(1:70)
        IER = 1
        RETURN
      END IF
C * DEFAULT S>O>F. TO 1.0
      IF (KN == 3) FN(4) = 1.0
C * CIF STYLE ATOM LABEL
      IF (IGBL(8) == 3) THEN
        NQ1 = IFL(2)
C * RES STYLE ATOM LABEL
      ELSE IF (IGBL(8) == 2) THEN
        NQ1 = IFL(1)
        IF (IPR(538) /= 0) THEN
          N = INDEX (NQ1, ' ')
          IF (N /= 0) THEN
            IF (IPR(538) < 10) THEN
              WRITE (NQ1(N:N + 1), 99994, IOSTAT = IOST)
     1          IPR(538)
            ELSE
              WRITE (NQ1(N:N + 2), 99993, IOSTAT = IOST)
     1          IPR(538)
            END IF
          END IF
          IFL(KL) = NQ1
        END IF
C * SPF STYLE ATOM LABEL
      ELSE IF (IGBL(8) == 1) THEN
C * ADD RESIDUE NUMBER TO LABEL (SHELXL STYLE)
        IF (IFL(1)(1:4) == 'ATOM' .OR. IFL(1)(1:2) == 'U ' .OR.
     1    IFL(1)(2:3) == 'IJ' .OR. IFL(1)(3:4) == 'IJ') THEN
          NQ1 = IFL(2)
          NQ2 = IFL(3)
          CALL GEN020 (-1, IFL(3), 2, 2)
C * ADD ELEMENT TYPES FOR NON C, H, N, O TYPES
          DO I = 1, 105
C * GET ELEMENT 'NUMBER' AND CODING NUMBER
            IF (IFL(3)(1:2) == ELB(I)) THEN
C * SKIP FOR C, H, N, O
              IF (I > 4) THEN
                IANP1      = IAN + 1
                IEN(IANP1) = I
 
                DO J = 5, IANP1
                  IF (IEL(I) == IEL(IEN(J))) THEN
                    IF (J == IANP1) IAN = IANP1
                    EXIT
                  END IF
                END DO
              END IF
              EXIT
            END IF
          END DO
        ELSE
          NQ1 = IFL(1)
        END IF
C * PDB STYLE ATOM LABEL
      ELSE IF (IGBL(8) == 4) THEN
        NQ1 = IFL(1)
      ELSE
        NQ1 = IFL(1)
      END IF
C * PACK LABEL INFORMATION
      MODE = 9
      LOP  = 0
C * SAVE INPUT LABEL
      NQ4  = NQ1
      CALL GEN020 ( 1, NQ4, 1, NP64)
      CALL GEN020 (-1, NQ4, 2, 2)
      NQ1 = NQ4
      DO
        CALL PLA046 (MODE, NQ1, NED, NQX, NSS, NQSM, INQNR, JNQNR, NIEN)
C * CALL EXIT/STOP
        IF (NIEN == -2)
     1    CALL GEN127 ('Stop:: More that 16 atom types !!')
        LOP = LOP + 1
C * CHECK FOR ERROR RETURN
        IF (NIEN < 0) THEN
          IF (IABS (IGBL(8)) >= 1 .OR. IABS (IGBL(8)) <= 3) THEN
            IF (IABS(IGBL(8)) == 1 .AND. KL == 3)
     1        NQ1 = IFL(3)
            CALL GEN020 (1,NQ1, 1, 2)
            IF (IABS(IGBL(8)) == 3 .OR. IABS (IGBL(8)) == 1) THEN
              IF (ICHAR (NQ1(2:2)) >= 48 .AND.
     1            ICHAR (NQ1(2:2)) <= 48) THEN
                NQ1(2:) = ' '
              ELSE
                NQ1(3:) = ' '
              END IF
            ELSE
              NQ1 = SFC(NINT (FN(1)))
            END IF
C * CREATE ACCEPTABLE LABEL
            IF (NQ1(1:1) == ' ') THEN
              NQ1(1:) = NQ1(2:2)
              NQ1(2:4) = '999'
            ELSE IF (NQ1(2:2) == ' ') THEN
              NQ1(2:) = '999'
            ELSE
              NQ1(3:) = '99'
            END IF
            MODE = 10
            IF (LOP == 1) CYCLE
          END IF
        END IF
        IF (LOP >= 1) EXIT
      END DO
      IF (NIEN < 0 .OR. NQSM > 0) THEN
        IF (NIEN < 0 .OR. IPR(50) == 0) THEN
          WRITE (LU6, 99996, IOSTAT = IOST) NQ1
          IER = 1
          RETURN
        END IF
      END IF
C * TEST FOR PREVIOUS CELL CARD HANDLING; IF NOT, DO SO
      IF (IPR(51) == 0) CALL PLUT23 (-1)
      ICLOSE = 0
      IANIS  = 0
      UISO   = -1.0
C * SKIP FOR ANGSTROM (IPR(50) /= 0) COORDINATE INPUT
      IF (IPR(50) == 0) THEN
C * HANDLE CASE OF SHELX INPUT (AS PRODUCED BY SHELX)
        IF (IABS(IGBL(8)) == 2) THEN
          IF (KN == 11) IANIS = 1
          RP(1) = 1
C * IGNORE DIFFERENCE MAP DENSITY WHEN PRESENT
          IF (KN == 7) THEN
            IPR(221) = 6
            KN       = IPR(221)
          END IF
          DO I = 2, KN
            YY = FN(I)
            IF (ABS (YY) > 5.0) THEN
              J  = NINT (ABS (YY) * 0.1)
              SJ = SIGN (0.5, YY)
              IF (J /= 1 .AND. J > IPR(13)) CALL PLUT38 (4, 1, LU6)
              YY = (YY - J * SJ * 20.0) * (RP(J) + SJ - 0.5)
            END IF
            FN(I - 1) = YY
          END DO
          IF (KN == 6 .AND. FN(6) > 0.0) UISO = - FN(6) / 0.04
          FN(KN)   = 0.0
          IPR(221) = IPR(221) -1
          KN       = IPR(221)
        END IF
C * SKIP ATOMS WITH POPULATION ZERO
        IF (IABS (IGBL(8)) /= 2 .AND. KN == 8 .OR.
     1      IABS (IGBL(8)) == 2 .AND. KN > 3) THEN
          IF (FN(4) < 0.0001) THEN
            WRITE (LU6, 99995, IOSTAT = IOST) NQ1
            IER = 1
            RETURN
          END IF
        END IF
C * APPLY CELL TRANSFORMATION OR DE-ORTHOGONALIZATION
        IF (IPR(127) > 0 .OR. IPR(156) > 0) THEN
          IF (IPR(156) == 1) THEN
            CALL GEN002 (1, ROM, FN, SGX, XLNG)
            DO J = 1, 3
              FN(J) = SGX(J)
            END DO
          ELSE
            CALL GEN002 (1, TMY, FN, SGX, XLNG)
            IGBL(30) = 0
            DO J = 1, 3
              FN(J) = MOD (SGX(J), 1.0)
            END DO
          END IF
        END IF
C * CHECK WHETHER THIS ATOM IS NOT ALREADY PRESENT IN THE ATOM LIST
C * IF SO THEN SKIP IT
        I2 = (IPR(37) + 1) * NP43
        I4 = I2 + NP43
        DO J = 1, 3
          SGX(J + 3) = 0.0
C * ADD SHIFT VECTOR
          IF (IPR(128) > 0) FN(J) = FN(J) + SHFT(J)
          SGX(J)     = FN(J)
          RA(I2 + J) = FN(J)
          RA(I4 + J) = 0.0
        END DO
        SGX(10) = 0.0
        CALL SGSM (19, ICL, SGX, 0, LU6, IERR)
C * SPECIAL MULTIPLICITY HANDLING FOR CIF (IGBL(8) = 3)
        IF (IGBL(8) == 3) FN(4) = FN(4) * SGX(10)
        IF (ABS (1.0 - FN(4) / SGX(10)) < 0.001) THEN
          PAR22 = PAR(22)
        ELSE
          PAR22 = 0.1
        END IF
        MULT   = 0
        ICLOSE = 0
        DCLOSE = 999.0
        DO J = 1, NSYM
          CALL SGSM (3, ICL, SGX, J, LU6, IERR)
C * START BEYOND (0 or 8) UNITCELL VERTICE COORDINATES
          I1   = (IPR(69) + 1) * NP43
          II   = IPR(69)
          DO I = I1, I2, NP43
            II   = II + 1
            VERS = 0.0
            DO K = 1, 3
              VRS = RA(I + K) - SGX(K + 6)
              DO
                IF (VRS <= 0.5) EXIT
                SGX(K + 6) = SGX(K + 6) + 1.0
                VRS        = VRS - 1.0
              END DO
              DO
                IF (VRS > - 0.5) EXIT
                SGX(K + 6) = SGX(K + 6) - 1.0
                VRS        = VRS + 1.0
              END DO
              DUMA(K) = VRS
            END DO
            VERS = SQRT ((PAR(101) * DUMA(1)) **2
     1        + (PAR(102) * DUMA(2)) **2
     2        + (PAR(103) * DUMA(3)) **2
     3        + 2.0 * PAR(101) * PAR(102) * PAR(106) * DUMA(1) * DUMA(2)
     4        + 2.0 * PAR(101) * PAR(103) * PAR(105) * DUMA(1) * DUMA(3)
     5        + 2.0 * PAR(102) * PAR(103) * PAR(104) * DUMA(2) * DUMA(3)
     6        )
            IF (VERS < PAR22) THEN
              IF (I == I2) THEN
                MULT = MULT + 1
                DO K = 1, 3
                  RA(I4 + K) = RA(I4 + K) + SGX(K + 6)
                END DO
              ELSE
                CALL PLUT25 (2, II, IDUM)
                ICLOSE = 1
                DCLOSE = VERS
              END IF
            END IF
          END DO
        END DO
      END IF
      IF (IPR(37) == IPR(69)) THEN
        IPPR(1, 3) = NSYM
      END IF
      NATX = IPR(37) + 1
C * STORE BOTTOM UP
      I          = NATX * NP43
      RA(I + 6)  = JNQNR
      RA(I + 7)  = INQNR
      RA(I + 8)  = 0.0
      RA(I + 9)  = 0.0
      RA(I + 10) = 0.0
      IF (PAR(141) > 0.0) THEN
        TRNS     = PAR(141)
        PAR(141) = 0.0
      ELSE
        TRNS     = PAR(140)
      END IF
      RA(I + 11) = UISO
      RA(I + 12) = TRNS
      DO II = 1, 3
        IF (IPR(50) == 1) THEN
          RA(I + II) = FN(II) * PAR(11)
        ELSE
          IF (MULT == 0) MULT = 1
          RA(I + II) = RA(I4 + II) / MULT
        END IF
      END DO
C * HANDLE POPULATION PARAMETER
      NPOP = IPR(9)
        FN(4) = MIN (1.0, FN(4) * MULT)
      IF (NQ1(1:1) == 'Q' .OR. FN(4) < 0.001) FN(4) = 1.0
      INTPOP = NINT (FN(4) * 10000.0)
      IF (MULT == 48 .AND. INTPOP > 9997) INTPOP = 10000
C * SKIP NON-DISORDER CLOSE ATOMS (DUPLICATE ?)
      IF (PAR(22) >= 0.0) THEN
        IF (INTPOP == 10000 .AND. ICLOSE == 1 .AND.
     1    (NQ1(1:1) /= 'Q' .OR.
     2    (NQ1(1:1) == 'Q' .AND. NQ2(1:1) == 'Q'))) THEN
          WRITE (LU6, 99999, IOSTAT = IOST) NQ1, DCLOSE, NQ2
          IER = 1
          RETURN
        END IF
      END IF
      IF (KN > 3) THEN
        IF (INTPOP == 5000 .AND. MULT == 1) THEN
          IF (FN(4) > 0.5) INTPOP = 5001
          IF (FN(4) < 0.5) INTPOP = 4999
        END IF
      END IF
      IPPR(NPOP + 1, 1) = INTPOP
      IPPR(NPOP + 1, 3) = NSYM / MULT
      IPR(37) = NATX
      IPR(38) = NATX
      IPR(39) = NATX
      IF (IABS (IGBL(8)) >= 1 .AND. IABS (IGBL(8)) <= 3) THEN
        CALL PLUT25 (2, NATX, IDUM)
        IF (NQ1 /= NQ4) THEN
          CALL PLA282 (1, NQ4, NQ2, LU6)
        END IF
      END IF
      II = NPOP
      DO N = 1, NPOP
        IF (IPPR(N, 1) == IPPR(NPOP + 1, 1)) THEN
          II = N - 1
          EXIT
        END IF
      END DO
      IF (II == NPOP) THEN
        IF (NPOP < MP7) IPR(9) = NPOP + 1
      END IF
      CALL PLUT15 (4, NATX, 28, II)
C * SET MULTIPLICITY AND INCLUDE TO 1
      CALL PLUT15 (6, NATX, 18, MULT)
      IVAL = 1
      CALL PLUT15 (1, NATX, 27, IVAL)
      IVAL = 0
      CALL PLUT15 (4, NATX, 37, IVAL)
C * SET SHELXL PART #
      IYUNK = IPR(612) + 16
      CALL PLUT15 (5, NATX, 48, IYUNK)
C * SET ISO/ANISO
      CALL PLUT15 (1, NATX, 41, IANIS)
C * GET A CHARACTERISTIC NUMBER TO IDENTIFY ATOM TYPE LATER ON.
      CALL PLUT25 (0, NATX, N1)
      N2 = IEN(N1)
C * TEST FOR INORG/ORGA
      IF (N2 == 2) IGBL(97) = 1
      IF (N1 > 4) THEN
        RADR(N1, 3) = REL(N2)
        RADR(N1, 4) = VDWR(N2)
      END IF
C * SET DO/AC BIT
      DO II = 1, IPR(480)
        IF (N2 == IDOAC(II)) THEN
          IVAL = 1
          CALL PLUT15 (1, NATX, 46, IVAL)
          EXIT
        END IF
      END DO
C * SET METAL BIT
      IF (IATPR(N2) > 0) THEN
        IWD = 1
      ELSE
        IWD = 0
      END IF
      CALL PLUT15 (1, NATX, 17, IWD)
C * H-ATOM BIT (H & D)
      IF (N2 == 1 .OR. N2 == 33) THEN
        IWD = 1
      ELSE
        IWD = 0
      END IF
      CALL PLUT15 (1, NATX, 44, IWD)
C * SET DEFAULT RESIDUE
      IF (IPR(136) == 0) THEN
        IVAL = 0
      ELSE
        IVAL = IPR(136)
      END IF
      CALL PLUT15 (6, NATX, 5, IVAL)
      IER = 0
      IF (IPR(50) * IPR(135) > 0) THEN
        RA(NATX * NP43 + 3) = RA(NATX * NP43 + 3) + IPR(135) * 100.0
      END IF
      RETURN
99999 FORMAT (':: ATOM ', A, ' eliminated. (within', F5.2,' Ang.',
     1 ' from ', A, ')')
99998 FORMAT (':: Less than 3 numbers on ATOM record',
     1        ' (or unrecognized instruction)', /, ':: =>> ', A, /)
99997 FORMAT (':: Inadequate number of text items on ATOM record', /, A)
99996 FORMAT (':: ATOM label ', A, ' not acceptable')
99995 FORMAT (':: (Dummy) Atom ', A, ' with zero population skipped')
99994 FORMAT ('_', I1)
99993 FORMAT ('_', I2)
      END SUBROUTINE PLUT03
 
      SUBROUTINE PLUT04 (MODE, NATR)
C * THIS ROUTINE ATTEMPTS TO FIND MINIMUM OVERLAP POSITIONS FOR LABELS
      USE parameters
      USE atomdata
      USE cchar
      USE cggt
      USE pluto
      USE chdat
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: K
      INTEGER             :: L
      INTEGER             :: M
      INTEGER             :: M0
      INTEGER             :: MM
      INTEGER             :: JB
      INTEGER             :: JE
      INTEGER             :: II
      INTEGER             :: LL
      INTEGER             :: KL
      INTEGER             :: KN
      INTEGER             :: IP
      INTEGER             :: NB
      INTEGER             :: NM
      INTEGER             :: NR
      INTEGER             :: NT
      INTEGER             :: NTM
      INTEGER             :: NT0
      INTEGER             :: NRS
      INTEGER             :: NMLX
      INTEGER             :: KLB
      INTEGER             :: IP0
      INTEGER             :: ILB
      INTEGER             :: IAI
      INTEGER             :: IAJ
      INTEGER             :: IAT
      INTEGER             :: IHA
      INTEGER             :: INM
      INTEGER             :: IVL
      INTEGER             :: NAB
      INTEGER             :: NAT
      INTEGER             :: NATL
      INTEGER             :: NATO
      INTEGER             :: NATX
      INTEGER             :: NATY
      INTEGER             :: MMIN
      INTEGER             :: LABL
      INTEGER             :: ISET
      INTEGER             :: IREN
      INTEGER             :: ILBO
      INTEGER             :: ILPB
      INTEGER             :: IBEG
      INTEGER             :: ICOL
      INTEGER             :: IEND
      INTEGER             :: IATK
      INTEGER             :: IASU
      INTEGER             :: IVAL
      INTEGER             :: LFIX
      INTEGER             :: LMAX
      INTEGER             :: MODE
      INTEGER             :: NATR
      INTEGER             :: NPROP
      INTEGER             :: MSTEP
      INTEGER             :: LMODE
      INTEGER             :: LABL0
      INTEGER             :: IUNIT
      INTEGER             :: IANIS
      REAL                :: RI
      REAL                :: XI
      REAL                :: YI
      REAL                :: ZI
      REAL                :: XL
      REAL                :: YL
      REAL                :: ZL
      REAL                :: RL
      REAL                :: XNM
      REAL                :: XSH
      REAL                :: XSH0
      REAL                :: XMOL
      REAL                :: XDUM
      CHARACTER(len=3)    :: NL123
      CHARACTER(len=2)    :: LBPOS
C * MODE = 1 - CALC    MODE
C * MODE = 2 - LABEL   MODE
C * MODE = 3 - UNLABEL MODE
C * MODE = 4 - PUT     MODE
      KL      = IPR(220)
      KN      = IPR(221)
      ILPB    = IPR(69) + 1
      NAT     = IPR(37)
      NATO    = IPR(39)
      NAB     = NAT - IPR(69)
C * SET NO-ERROR STATUS
      IPR(72) = 0
      XSH     = PAR(39)
      IASU    = 0
C * CALC POSITION MODE
      IF (MODE == 1) THEN
C * CHECK FOR 'LOAD LABELS' FLAG
        IF (IGBL(75) == 0) THEN
          IF (IPR(339) == 1) THEN
            NATY = IPR(69)
          ELSE
            NATY = 0
          END IF
        ELSE
          NATY = NAT
        END IF
C * CHECK FOR 'LOAD ARU-LABEL' FLAG
        IF (IPR(63) == 0) THEN
          NATX = NATY
        ELSE
          NATX = NATY + IPR(42)
        END IF
C * TEST FOR LABELS LOADED FOR PLOTTING
        IF (NATX > 0) THEN
          PAR(28) = 0.5 * PAR(349)
C * ENSURE THE USE OF THE SAME LABEL POS. FOR LEFT AND RIGHT STEREO PAIR
          IF (IPR(116) == 1 .OR. IPR(130) == 1) THEN
            NTM = 1
            NT0 = 1
          ELSE
            NTM = 2
C * TEST FOR ANY PUT INSTRUCTIONS ACTIVE
            IF (IPR(117) == 0) THEN
              NT0 = 2
            ELSE
              NT0 = 1
            END IF
          END IF
C * LOOP FIRST OVER PUT INSTRUCTIONS AND THEN OVER AUTO LAB. INSTR.
          DO NT = NT0, NTM
C * LABEL POSITIONS FOLLOW ATOMS ON THE STACK
            NATL = IPR(62)
C * LOOP OVER ALL ATOMS/MOLECULES FOR LABELLING
            IF (NATR /= 0) THEN
              IBEG = NATR
              IEND = NATR
              NATL = IPR(62) + NATR - 1
            ELSE
              IBEG = 1
              IEND = NATX
            END IF
            DO 60 I = IBEG, IEND
              NATL = NATL + 1
              IF (I <= NATY) THEN
C * NO LABELLING OF OVERLAPPED ATOMS
                IF (IPR(4) > 0) THEN
                  CALL PLUT15 (-1, I, 45, IVAL)
                  IF (IVAL == 0 .AND. I >= ILPB) GO TO 60
                END IF
C * TEST FOR LABELLING TYPE ( 0 = NOLABELLING OF THIS ATOM)
                CALL PLUT15 (-4, I, 37, M)
                IF (M == 0)  GO TO 60
C * GET COORDINATES OF PARENT ATOM
                CALL PLUT14 (-1, I, IASU, NPROP, XI, YI, ZI, RI)
                IF (RI < 0.0)  GO TO 60
                IF (IPR(4) <= 0 .AND. RI > 0.0) RI = 0.0
                IF (I < ILPB) THEN
C * LABELLING UNIT CELL CORNERS (TEST)
                  IF (IPR(46) == 0) THEN
                    GO TO 60
                  ELSE
                    NQ0(1:1) = CHAR (INT (RA(I * NP43 + 7)))
                    KLB      = 1
                    GO TO 10
                  END IF
                END IF
C * GET ATOM LABEL IN NQ2
                IAT = I
                IF (I >= ILPB .AND. IPR(14) == 1) IAT = - I
                CALL PLUT25 (2, IAT, IATK)
C * COPY LABEL IN NQ0
                NQ0 = NQ2
                CALL GEN020 (-1, NQ0, 2, 2)
C * ARU LABEL CASE
              ELSE
                M = IABS (IPR(63))
C * GET MOL LABEL
                XNM = MOL(1, I - NATY) / PAR(42)
C * SKIP LABELS FOR EXCLUDED MOLECULES
                IF (XNM < 0)  GO TO 60
                NM  = NINT (XNM)
C * GET RESIDUE NUMBER
                NR  = NINT ((XNM - NM) * PAR(42))
                CALL GEN040 (NM, NQ0, IP0)
                IP0 = IP0 + 1
                NQ0(IP0:IP0) = '.'
                IF (NR < 10 .AND. IPR(134) > 9) THEN
                  IP0          = IP0 + 1
                  NQ0(IP0:IP0) = '0'
                END IF
                CALL GEN040 (NR, NQ0(IP0 + 1:IP0 + 1), IP)
                IP  = IP0 + IP
C * GET POSITION OF FIRST ATOM IN MOL
                NMLX = IPR(142)
                DO J = 1, NMLX
                  INM = NINT (RA(IPR(159) + 1 - J))
                  IF (NM == INM) EXIT
                END DO
                DO K = ILPB, NATO
                  CALL PLUT15 (-6, K, 5, IVAL)
                  IF (IVAL == NR) THEN
                    CALL PLUT15 (-1, K, 27, IVAL)
                    IF (IVAL == 1) EXIT
                  END IF
                END DO
                K = (J - 1) * NAB + K
                CALL PLUT14 (-1, K, IASU, NPROP, XI, YI, ZI, RI)
              END IF
              NB  = 0
              KLB = 0
              CALL GEN039 (1, NQ0, 1, NP64, NB, KLB)
C * PAR(40) IS THE HALF WIDTH OF THE LABEL IN CM.
   10         PAR(40) = KLB * PAR(349) * PAR(19) / 2.0
              IF (IPR(116) <= 0 .AND. IPR(130) == 0 .AND.
     1            M /= 15) THEN
C * NT = 1 : EXECUTE PUT INSTRUCTIONS
C * NT = 2 : AUTOPOSITIONING CYCLE
                IF (I <= NATY) THEN
                  CALL PLUT15 (-1, I, 42, ILB)
                ELSE
                  IF (IPR(63) < -1) THEN
                    ILB = 1
                  ELSE
                    ILB = 0
                  END IF
                END IF
C * GET DEFAULT LABEL SHIFT
                XSH = PAR(39)
                IF (NT == 1) THEN
C * IS THIS A SPECIFIED LABEL POSITION
                  IF (ILB == 0)  GO TO 60
                  IF (M == 1)  GO TO 60
                  MM = 0
                ELSE
C * AUTO LABELLING
                  IF (ILB == 1)  GO TO 60
                  MMIN = 999
                  M0   = 10
                  XSH0 = 0.0
C * LABEL SHIFT LOOP
                  XSH = 0.0
   20             XSH = XSH + PAR(39)
                  IF (IPR(116) /= 0 .AND. XSH > PAR(39)) GO TO 40
                  IF (XSH > IPR(131) * PAR(39)) GO TO 40
C * EXAMINE LABEL POSITIONS 2 TO 9(10)
                  M = 10 + IPR(18)
C * CHECK WHETHER LABEL WOULD FIT IN ATOM BOUNDERY OUTLINE
                  IF (PAR(40) > RI * 0.9) M = 10
                  IF (I >= ILPB) THEN
                    MSTEP = 1
                  ELSE
                    MSTEP = 2
                    M     = 11
                  END IF
   30             M = M - MSTEP
                  IF (M < 2) GO TO 20
                  CALL PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL,
     1                         RL, XSH)
C * TEST FOR LABEL POSITION OUTSIDE PERMITTED PLOT RANGE
                  IF (XL - PAR(40) < PAR(61) .OR.
     1                XL + PAR(40) > PAR(64) .OR.
     2                YL - PAR(28) < PAR(62) .OR.
     3                YL + PAR(28) > PAR(65)) THEN
C * REJECT OUT-OF-BOUNDS LABEL POSITION
                    MM = 999
                    IF (NT == 2)  GO TO 30
                    IVAL = 1
                    CALL PLUT15 (4, I, 37, IVAL)
                    GO TO 60
                  END IF
                  IPR(67) = 2
                  CALL PLUT18 (NATL, 0)
                  MM = IPR(78)
                  IF (MM == 0) THEN
                    GO TO 50
                  ELSE IF (MM > 0) THEN
                    IF (MM < MMIN) THEN
                      M0   = M
                      XSH0 = XSH
                      MMIN = MM
                    END IF
                  END IF
                  GO TO 30
   40             M = M0
                  IF (IPR(4) > 0 .AND. MMIN > 0
     1              .AND. I <= NATY .AND. I >= ILPB) THEN
                    IVAL = 0
                    CALL PLUT15 (1, I, 45, IVAL)
                    IF (IGBL(105) == 0) GO TO 60
                  END IF
                  XSH = XSH0
                END IF
C * ADD THE COORDINATES FOR THIS LABEL TO THE ATOM LIST
                CALL PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL,
     1                       RL, XSH)
   50           IF (I <= NATY) THEN
                  CALL PLUT15 (4, I, 37, M)
                ELSE
                  IF (ILB == 1) THEN
                    IPR(63) = - M
                  ELSE
                    IPR(63) = 1
                  END IF
                END IF
              ELSE
                IF (I <= NATY) THEN
                  CALL PLUT15 (-4, I, 37, M)
                ELSE
                  M = MAX (-IPR(63), 2)
                END IF
                IF (IPR(116) /= 0) THEN
                  XSH =  PAR(39)
                  CALL PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL,
     1                         RL, XSH)
                ELSE
                  CALL PLUT14 (-1, NATL, IASU, NPROP, XL, YL, ZL, RL)
                END IF
              END IF
              IF (CC) GO TO 100
C * LABEL PLOT AND RETRACE LOOP
              IF (IPR(477) < 0) THEN
                CALL PLUT15 (-6, I, 5, NRS)
                IF (NRS > 0 .AND. NRS <= 8) THEN
                  ICOL = NCRS(NRS)
                ELSE
                  ICOL = 0
                END IF
                LMAX = 2
              ELSE
                LMAX = IPR(7)
                IF (I > NATY) THEN
                  ICOL = 6
                ELSE
                  ICOL = -1
                  IF (IPR(116) == 0) THEN
C * PLUTON/ANIS
                    IF (IGBL(3) == 26 .OR. IPR(352) == 1) THEN
                      CALL PLUT15 (-1, I, 41, IANIS)
                      IF (IANIS == 1) ICOL = 2
                    END IF
C * PLUTON/RENAME
                    IF (IGBL(3) == 12) THEN
                      CALL PLUT15 (-1, I, 47, IREN)
                      IF (IREN == 1) ICOL = 3
                    END IF
                  END IF
                END IF
              END IF
              DO LL = 1, LMAX
                CALL PLA439 (0.0, NQ0, KLB, PAR(349), ICOL, 1,
     1            XL - PAR(40), YL - PAR(28))
                XL = XL + PAR(4)
              END DO
   60       CONTINUE
          END DO
        END IF
      ELSE
        IF (IPR(17) == 0) THEN
          CALL PLUT05
C * CALL EXIT/STOP
          IF (IPR(72) /= 0) CALL GEN127 ('308')
        END IF
        IF (MODE == 2 .OR. MODE == 3) THEN
C * SET REBUILD
          IPR(130) = 0
C * LABEL SETTING MODE (2)  - SET LABELLING BIT UP
C * LABEL SETTING MODE (3)  - SET LABELLING BIT DOWN
          LABL = 3 - MODE
          IF (KL == 1) THEN
            KL = 2
            IFL(2)(1:3) = 'ON '
          END IF
          ISET  = 0
          IUNIT = 0
          DO K = 2, KL
            SELECT CASE (IFL(K)(1:3))
C * HANDLE (UN)LABEL ON
              CASE ('ON ')
                IGBL(75) = LABL
                IPR(452) = IGBL(75)
                IPR(63)  = 0
                ISET     = 1
                IUNIT    = 1
C * HANDLE (UN)LABEL OFF
              CASE ('OFF')
                IGBL(75) = 1 - LABL
                IPR(452) = IGBL(75)
                IPR(63)  = 0
                ISET     = 1
                IUNIT    = 1
                LABL     = MOD (LABL + 1, 2)
C * HANDLE (UN)LABEL NONE
              CASE ('NON')
                IPR(63)  = 0
                ISET     = 1
                IUNIT    = 1
                LABL     = MOD (LABL + 1, 2)
C * (UN)LABEL UNITCELL
              CASE ('UNI')
                IUNIT    = 1
C * (UN)LABEL ARU'S
              CASE ('ARU')
                IPR(63) = LABL
C * (UN)LABEL MOLES
              CASE ('MOL')
                IPR(63) = LABL
C * (UN)LABEL ATOMS
              CASE ('ATO')
                IPR(452) = LABL
                IF (LABL == 1) IGBL(75) = LABL
                ISET     = 1
C * (UN)LABEL ALL
              CASE ('ALL')
                IPR(63)  = LABL
                IGBL(75) = LABL
                ISET     = 1
                IUNIT    = 1
C * LABELS WITH PARENTHESES
              CASE ('PAR')
                IPR(71) = 1
C * LABELS WITHOUT PARENTHESES
              CASE ('NOP')
                IPR(71) = 0
C * FULL LABEL
              CASE ('FUL')
                IPR(14) = 0
C * NUMERICAL LABEL PART ONLY FOR H & C
              CASE ('NUM')
                IPR(14) = 1
                IPR(71) = 0
C * HANDLING OF ATOM-TYPES OR ATOM-LABELS (POSSIBLY WITH SYMMETRY CODES)
              CASE DEFAULT
C * GET ATOM-TYPE OR ATOM-NAME (IN THAT ORDER) OF ENTRY-NR K INTO IAT
                CALL PLUT13 (-1, -K, IAT, XMOL)
                IGBL(75) = 1
C * ATOM-TYPE CASE
                IF (IAT < 0) THEN
                  DO I = ILPB, NAT
                    II = I
                    CALL PLUT25 (0, II, IAI)
                    IF (IAI + IAT == 0) THEN
                      IF (KN == 1) CALL PLUT28 (0, II, FN(1))
                      CALL PLUT15 (4, II, 37, LABL)
                    END IF
                  END DO
C * ATOM-NAME CASE
                ELSE IF (IAT > 0) THEN
                  IF (KN == 1) XMOL = FN(1)
                  CALL PLUT28 (0, IAT, XMOL)
                  CALL PLUT15 (4, IAT, 37, LABL)
                END IF
            END SELECT
          END DO
C * EXECUTE GLOBAL (UN)LABEL ATOMS AND UNITCELL CORNERS
          IF (ISET == 1) THEN
            DO I = ILPB, NAT
              IF (LABL == 1) THEN
C * YES/NO INCLUDE H-LABELS
                IF (IPR(232) == 1) THEN
                  LABL0 = 1
                ELSE
                  CALL PLUT15 (-1, I, 44, IHA)
                  LABL0 = 1 - IHA
                END IF
              ELSE
                LABL0 = 0
              END IF
              CALL PLUT15 (4, I, 37, LABL0)
              IF (LABL == 0) THEN
                IVL = 0
                CALL PLUT15 (1, I, 42, IVL)
              END IF
            END DO
          END IF
          IF (IPR(50) == 0 .AND. IUNIT == 1) THEN
            IPR(339) = LABL
            DO I = 1, 8
              IF (I < 4 .OR. I == 5) THEN
                ILB = LABL
              ELSE
                ILB = 0
              END IF
              CALL PLUT15 (4, I, 37, ILB)
            END DO
          END IF
        ELSE IF (MODE == 4) THEN
C * PUT LABELS WHERE REQUESTED
C * SET REBUILD
          IPR(130) = 0
          L = 2
   70     IF (L > KL)  GO TO 110
          NL123 = IFL(L)(1:3)
C * PUT ARU LABELS
          IF (NL123 == 'ARU') THEN
            LMODE = -1
C * PUT MOLES LABELS
          ELSE IF (NL123 == 'MOL') THEN
            LMODE = -1
C * PUT ATOMS LABELS
          ELSE IF (NL123 == 'ATO') THEN
            IAT   = 0
            LMODE = 1
          ELSE
            CALL PLUT13 (0, -L, IAT, XDUM)
            IF (IAT == 0) THEN
              L = L + 1
              GO TO 90
            END IF
            LMODE = 1
          END IF
          L = L + 1
          IF (L > KL)  GO TO 90
          LBPOS = IFL(L)(1:2)
          DO I = 1, 10
            IF (LABP(I + 1) == LBPOS)  GO TO 80
          END DO
          GO TO 90
   80     IF (LMODE == -1) THEN
            IPR(63) = - MIN (IABS (IPR(63)), 1) * I
          ELSE
            IF (IAT <= 0) THEN
              JB = ILPB
              JE = NAT
            ELSE
              JB = IAT
              JE = IAT
            END IF
            DO J = JB, JE
              CALL PLUT25 (0, J, IAJ)
              IAJ = - IAJ
              CALL PLUT15 (-4, J, 37, ILB)
              ILB = MIN (ILB, 1) * I
              IF (IAT >= 0 .OR. IAT == IAJ) THEN
                CALL PLUT15 (4, J, 37, ILB)
                IF (ILB > 1) THEN
                  LFIX = 1
                ELSE
                  LFIX = 0
                END IF
                CALL PLUT15 (1, J, 42, LFIX)
              END IF
            END DO
          END IF
          L = L + 1
          IPR(117) = 1
          GO TO 70
   90     IPR(72) = 26
        END IF
      END IF
  100 IF (MODE > 1) THEN
        IF (IPR(63) /= 0) THEN
          ILBO = 1
        ELSE
          ILBO = 0
        END IF
        DO I = 1, NAT
          CALL PLUT15 (-4, I, 37, IVAL)
          IF (IVAL > 0) ILBO = 1
          IF (ILBO /= 0) GO TO 110
        END DO
      END IF
  110 IF (MODE == 2 .OR. MODE == 3) THEN
        IF (IPR(63) + IPR(339) + IGBL(75) == 0) THEN
          IGBL(75) = 0
        ELSE
          IGBL(75) = 1
        END IF
      END IF
      RETURN
      END SUBROUTINE PLUT04
 
      SUBROUTINE PLUT05
C * THIS ROUTINE HANDLES ALL JOIN/DETACH INSTRUCTIONS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: KB
      INTEGER          :: KL
      INTEGER          :: KN
      INTEGER          :: I1
      INTEGER          :: I2
      INTEGER          :: J1
      INTEGER          :: J2
      INTEGER          :: M13
      INTEGER          :: KL0
      INTEGER          :: IAT
      INTEGER          :: JAT
      INTEGER          :: IVL
      INTEGER          :: IAIO
      INTEGER          :: JAIO
      INTEGER          :: IVAL
      INTEGER          :: IDASH
      INTEGER          :: IDUM0
      INTEGER          :: IDUM2
      INTEGER          :: MADDR
      REAL             :: XMOL
      REAL             :: XDUM
      REAL             :: DUM1
      CHARACTER(len=5) :: J15
C * IPR(17) = 0 : AUTOMATIC JOIN RADII (UNIQUE) INSTRUCTION
C * IPR(17) = 1 : NORMAL    JOIN                INSTRUCTION
C * IPR(17) =-1 : DETACH                        INSTRUCTION
C * SET REBUILD
      IDASH    = 0
      IPR(130) = 0
      KL       = IPR(220)
      KN       = IPR(221)
      PAR(1)   = PAR(2) / 2
C * SET POINTERS AND LOAD UNITCELL BONDS
      IF (IPR(100) == 0) CALL PLUT33
      IPR(72) = 0
C * TEST FOR AUTOMATIC JOIN RADII UNIQUE
      IF (IPR(17) == 0) THEN
        IDASH    = 0
C * DEFAULT INTRA RADII SETTING
        IPR(35)  = 1 - IPR(50)
C * SET AUTO RADII BIT
        IPR(60)  = 1
C * SET EXPAND BIT
        IPR(110) = (1 - IPR(50)) * IGBL(97)
C * SET NOMOVE BIT FOR DISORDERED STRUCTURES
        IF (IPR(9) > 1 .AND. IPR(127) == 0) THEN
          IGBL(30) = 1
          WRITE (LU6, 99999, IOSTAT = IOST)
        END IF
      ELSE
        IF (KL <= 1) GO TO 30
C * JOIN RADII (..)
        IF (IFL(2)(1:5) == 'RADII') THEN
C * RADII GIVEN FOR DISTANCE SCAN
          IPR(35) = 0
          IPR(60) = 1
          N       = 0
          DO I = 1, NP10
             RADR(I, 2) = -1
          END DO
          IF (KL > 2) THEN
C * SET NOMOVE DEFAULT TO (FRACTIONAL = 0/ANGSTROM = 1)
            IGBL(30) = IPR(50)
            DO K = 3, KL
               J15 = IFL(K)(1:5)
C * NOMOVE OPTION
               IF (J15 == 'NOMOV') THEN
                  IGBL(30) = 1
C * JOIN RADII UNIQUE
               ELSE IF (J15 == 'UNIQU') THEN
C * SET UNIQUE-FLAG UP
                  IPR(35)  = 1 - IPR(50)
                  IPR(110) = 0
C * JOIN RADII INTER
               ELSE IF (J15 == 'INTER') THEN
C * SET INTER-FLAG UP
                 IPR(35) = - 1
C * TOL & TOLE
               ELSE IF (J15(1:3) == 'TOL') THEN
C * CHANGE AUTOMATIC RADII TOLERANCE SETTING
                 N = N + 1
                 IF (N <= KN) THEN
                   IF (J15(4:4) == 'E') THEN
                     PAR(26) = FN(N)
                   ELSE
                     PAR(1) = FN(N)
                   END IF
                   WRITE (LU6, 99998, IOSTAT = IOST)
     1               PAR(1), IGBL(97) * PAR(26)
                 END IF
C * JOIN RADII (UNIQUE/INTER HBONDS) EXPAND
               ELSE IF (J15 == 'EXPAN') THEN
                 IPR(110) = 1
C * JOIN RADII INTER HBONDS
               ELSE IF (J15 == 'HBOND') THEN
                IPR(109) = 1
C * JOIN RADII INTER XBONDS
               ELSE IF (J15 == 'XBOND') THEN
                IPR(109) = 2
               ELSE
C * TEST FOR ATOM TYPE
                 CALL PLUT13 (0, -K, IAT, XDUM)
                 IF (IAT >= 0) GO TO 30
C * TYPE OF ATOM LIST.  THIS IS USED TO SET ATOM RADII FOR SCAN
                 M          = - IAT
                 N          = N + 1
                 RADR(M, 2) = FN(N)
C * DISABLE AUTOMATIC RADII SETTING
                 IPR(60)    = 0
               END IF
            END DO
            IPR(221) = 0
            KN       = IPR(221)
          END IF
C * JOIN INTRA
        ELSE IF (IFL(2)(1:5) == 'INTRA') THEN
          IPR(37) = IPR(38)
          IPR(52) = IPR(53)
          GO TO 40
        ELSE
C * JOIN/DETACH
          IDASH = 0
          IF (IFL(2)(1:4) == 'DASH' .AND. KL == 4) THEN
            IDASH    = 1
            IFL(2)   = IFL(3)
            IFL(3)   = IFL(4)
            KL       = 3
            IPR(220) = KL
          END IF
          IF (KL < 3) GO TO 30
          IF (IPR(52) == (1 - IPR(50)) * 12) THEN
            IPR(75) = 1
            CALL PLUT17 (1555.0 + 1 / PAR(42), 0, MADDR, LU6)
            WRITE (LU6, 99997, IOSTAT = IOST)
C * DO CARTESIAN COORDINATE CALCULATION
            DO I = 1, IPR(37)
              CALL PLUT23 (I)
            END DO
          END IF
C * CHECK FOR DEFINE
          IF (IPR(161) < 0) THEN
            KB = 3
          ELSE
            KB = 2
          END IF
C * SPECIFIC ATOM CONNECTIONS/ OR SEQUENCES
   10     CALL PLUT13 (0, - KB, IAT, XDUM)
C * 'TO' KEYWORD
          IF (IPR(161) == 1) THEN
            KL0 = 4
          ELSE
            KL0 = KB + 1
          END IF
          IF (IAT == 0 .OR. KL < KL0) GO TO 30
          DO K = KL0, KL
            IF (IAT > 0) THEN
              I1 = IAT
              I2 = IAT
            ELSE
              I1 = IPR(69) + 1
              I2 = IPR(37)
            END IF
            IF (KN == 1) THEN
              M13 = -1
            ELSE
              M13 = 0
            END IF
            CALL PLUT13 (M13, -K, JAT, XMOL)
            IF (JAT == 0) THEN
              GO TO 30
            ELSE IF (JAT > 0) THEN
              IF (IAT > 0 .AND. KL == 3) THEN
                IF (KN == 1) XMOL = FN(1)
                CALL PLUT28 (IAT, JAT, XMOL)
                IFL(K) = NQ1
              END IF
              J1 = JAT
              J2 = JAT
            ELSE
              J1 = IPR(69) + 1
              J2 = IPR(37)
            END IF
            DO I = I1, I2
              IAIO =  - INT (RA(I * NP43 + 7) / 64000) - 1
              IF (IAT >= 0 .OR. IAT == IAIO) THEN
                DO J = J1, J2
                  JAIO = - INT (RA(J * NP43 + 7) / 64000) - 1
                  IF (JAT >= 0 .OR. JAT == JAIO) THEN
                    CALL PLUT16 (IPR(17) - 2, IDUM0, I, J, DUM1, IDUM2)
                    IF (IPR(17) == 1) THEN
                      CALL PLUT15 (-4, I, 33, IVAL)
                      IF (IVAL < NP33) THEN
                        IVL = IVAL + 1
                        CALL PLUT15 (4, I, 33, IVL)
                      END IF
                      CALL PLUT15 (-4, J, 33, IVAL)
                      IF (IVAL < NP33) THEN
                        IVL = IVAL + 1
                        CALL PLUT15 (4, J, 33, IVL)
                      END IF
                    END IF
                  END IF
                END DO
              END IF
            END DO
          END DO
C * CHECK FOR DEFINE
          IF (IPR(161) < 0) THEN
            KB = KB + 1
            IF (KB < KL) GO TO 10
          END IF
          GO TO 40
        END IF
      END IF
C * LOAD INTRA/INTER RADII FROM STANDARD TABLE
      IF (IPR(60) /= 0) THEN
        DO I = 1, IAN
          RADR(I, 2) = RADR(I, 3) + PAR(1)
          IF (IPR(35) < 0) THEN
            RADR(I, 2) = RADR(I, 4)
C * HBONDS/XBONDS
            IF (IPR(109) > 0) THEN
              DO N = 1, IPR(480)
                IF (IEN(I) == IDOAC(N)) THEN
                  RADR(I, 2) = RADR(I, 4)
                  GO TO 20
                END IF
              END DO
C * TEST FOR H AND D ATOMS
              IF (MOD (IEN(I), 32) == 1) THEN
                RADR(1, 2) = VDWR(1)
              ELSE
                RADR(I, 2) = 0.0
              END IF
   20         CONTINUE
            END IF
          END IF
        END DO
      END IF
C * EXECUTE JOIN INSTRUCTION
      CALL PLUT07
      GO TO 40
   30 IPR(72) = 27
      WRITE (LU6, 99996, IOSTAT = IOST)
      CALL PLA015 (0, 48)
   40 IF ((IDASH == 1 .OR. IPR(221) > 0) .AND. IPR(4) /= 0) THEN
        IF (IDASH == 1) THEN
          IFL(5)   = IFL(3)
          IFL(4)   = IFL(2)
          IFL(3)   = 'DASH '
          IPR(220) = 5
          IF (IPR(221) < 2) THEN
            FN(1) = 0.02
            FN(2) = 5
            IPR(221) = 2
          END IF
        ELSE
          IFL(4)  = IFL(3)
          IFL(3)  = IFL(2)
          IPR(220) = 4
        END IF
        IFL(2) = 'BONDS'
        CALL PLUT21 (0)
        IPR(220) = 5
        IDASH    = 0
      END IF
      IPR(17) = 1
      RETURN
99999 FORMAT (':: Automatic NOMOVE set because of (partial) disorder')
99998 FORMAT (':: Current JOIN RADII INTRA   TOL /ATOM=', F5.2,' Ang.',/
     1       ,'    +(EARTH)ALKALI-NON-METAL) TOLE/BOND=', F5.2,' Ang.')
99997 FORMAT (':: User-Supplied Bonds only mode')
99996 FORMAT (':: Problem/Error in JOIN - routine')
      END SUBROUTINE PLUT05
 
      SUBROUTINE PLUT06
C * THIS ROUTINE HANDLES THE VARIOUS VIEWPOINT INSTRUCTIONS
      USE files
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: J1
      INTEGER               :: J2
      INTEGER               :: J3
      INTEGER               :: KL
      INTEGER               :: KN
      INTEGER               :: IAT
      INTEGER               :: JAT
      INTEGER               :: KLS
      INTEGER               :: KNS
      INTEGER               :: IDET
      INTEGER               :: ILINE
      INTEGER               :: IROTX
      INTEGER               :: IROTY
      INTEGER               :: IROTZ
      REAL                  :: CA
      REAL                  :: CB
      REAL                  :: SA
      REAL                  :: PHI
      REAL                  :: ANG
      REAL                  :: XDUM
      REAL                  :: XLNG
      REAL                  :: TEMP
      REAL                  :: GEN017
      REAL, DIMENSION(3, 3) :: RSAVE
      REAL, DIMENSION(3, 3) :: YUNK
      CHARACTER(len=6)      :: INVERT
      CHARACTER(len=2)      :: N12
      CHARACTER(len=1)      :: N1
C * SET REBUILD
      IPR(130) = 0
      IPR(150) = 0
      KL       = IPR(220)
      KN       = IPR(221)
C * TEST FOR PREVIOUS JOIN INSTRUCTION EXECUTED, OTHERWISE DO SO
      IF (IPR(17) == 0) THEN
        KNS      = KN
        KLS      = KL
        IPR(221) = 0
        IPR(220) = 1
        CALL PLUT05
C * CALL EXIT/STOP
        IF (IPR(72) /= 0) CALL GEN127 ('309')
        IPR(221) = KNS
        KN       = IPR(221)
        IPR(220) = KLS
        KL       = IPR(220)
      END IF
C * SAVE R IN RSAVE AND RESTORES R IN CASE OF ERROR
      CALL GEN052 (R, RSAVE)
      IF (IPR(51) == 0 .OR. IPR(37) == 0) THEN
        WRITE (LU6, 99994, IOSTAT = IOST)
        GO TO 70
      END IF
      IPR(72)  = 0
      N        = 0
      L        = 2
      IGBL(67) = 1
      IF (KL == 1) THEN
        IPR(220) = 2
        KL       = IPR(220)
        IF (IFL(1)(1:1) == 'V') THEN
C * SET VIEW UNIT
          IFL(2)(1:4) = 'UNIT'
        ELSE
C * XROT, YROT OR ZROT
          IFL(2) = IFL(1)
        END IF
      END IF
      N12 = IFL(L)(1:2)
C * VIEW XR xr YR yr ZR zr INTERPRETED AS VIEW CUR XR xr YR yr ZR zr
C * VIEW INVERT interpreted as VIEW CUR INVERT
      IF (N12 == 'IN' .OR. N12 == 'XR' .OR. N12 == 'YR' .OR.
     1    N12 == 'ZR') THEN
         L = 1
         GO TO 40
      END IF
C * VIEW ALIGN
      IF (N12 == 'AL') THEN
        IF (KL /= 6)  GO TO 70
C * WITH
        IF (IFL(5)(1:1) /= 'W')  GO TO 70
C * XP
        IF (IFL(6)(1:1) == 'X') THEN
          ANG = 0.0
C * YP
        ELSE IF (IFL(6)(1:1) == 'Y') THEN
          ANG = -90.0
        ELSE
          GO TO 70
        END IF
C * GET ATOM NAME NUMBER
        CALL PLUT13 (0, 3, IAT, XDUM)
        CALL PLUT13 (0, 4, JAT, XDUM)
C * TEST FOR NON-VALID ATOM LABELS
        IF (IAT <= 0 .OR. JAT <= 0)  GO TO 70
        IF (KN == 1 .AND. KL == 6) CALL PLUT28 (IAT, JAT, FN(1))
        DO I = 1, 2
          ZU(I + 9)  = 0.0
          ZU(I + 12) = 0.0
          DO J = 4, 6
            ZU(I + 9)  = R(I, J - 3) * RA(IAT * NP43 + J) + ZU(I + 9)
            ZU(I + 12) = R(I, J - 3) * RA(JAT * NP43 + J) + ZU(I + 12)
          END DO
          ZU(I) = ZU(I + 12) - ZU(I + 9)
        END DO
        IF (ABS (ZU(1)) + ABS (ZU(2)) <= 1.0) THEN
          WRITE (LU6, 99998, IOSTAT = IOST)
          RETURN
        END IF
        ANG         = ATAN2(ZU(2), ZU(1)) * RGBL(6) + ANG
        N           = 0
        L           = 0
        IPR(220)    = 1
        KL          = IPR(220)
        IPR(221)    = 1
        KN          = IPR(221)
C * GENERATE A VIEW ZROT INSTRUCTION
        FN(1)       = ANG
        IFL(1)(1:1) = 'Z'
        IGBL(67)    = 1
C * VIEW MATRIX CARD
      ELSE IF (N12 == 'MA') THEN
        IF (KN < 9) THEN
          WRITE (LU6, 99991, IOSTAT = IOST)
          GO TO 70
        END IF
        K = 0
        DO I = 1, 3
          DO J = 1, 3
            K = K + 1
            R(I, J) = FN(K)
          END DO
        END DO
        N = 9
C * VIEW MIN - FIND MINIMUM OVERLAP MATRIX
      ELSE IF (N12 == 'MI') THEN
        CALL PLUT08
        L        = 2
        IPR(150) = 2
C * VIEW XO
      ELSE IF (N12 == 'XO') THEN
        CALL GEN021 (R, 0.0)
        R(1, 2) = 1.0
        R(2, 3) = 1.0
        R(3, 1) = 1.0
        IPR(150) = 3
C * VIEW YO
      ELSE IF (N12 == 'YO') THEN
        CALL GEN021 (R, 0.0)
        R(1, 3) = 1.0
        R(2, 1) = 1.0
        R(3, 2) = 1.0
        IPR(150) = 4
C * VIEW ZO OR UNIT
      ELSE IF (N12 == 'ZO' .OR. N12 == 'UN') THEN
        CALL GEN021 (R, 1.0)
        IF (N12 == 'ZO') THEN
          IPR(150) = 5
        ELSE
          IPR(150) = 1
        END IF
C * VIEW CURRENT
      ELSE IF (N12 == 'CU') THEN
        GO TO 40
      ELSE
C * SUB-KEYWORDS DEFINING A ROTATION MATRIX TO BE CALCULATED
C * AFACE, BFACE, CFACE, DIRECTION, LINE, PERP, BISECT
        CALL GEN021 (R, 0.0)
        CALL GEN074 (RA, 1, 3, 0.5)
C * XFACE CARD
        IF (N12(2:2) == 'F') THEN
          IF (N12(1:1) == 'B') THEN
            J = 2
          ELSE IF (N12(1:1) == 'C') THEN
            J = 3
          ELSE
            J = 1
          END IF
          IPR(150) = 5 + J
          ILINE = 1
          RA(J) = 1.0
          GO TO 10
        END IF
C * VIEW DIRECTION
        IF (N12 == 'DI') THEN
          IF (KN < 3) THEN
            WRITE (LU6, 99987, IOSTAT = IOST)
            GO TO 70
          END IF
          DO K = 1, 3
            RA(K) = FN(K)
          END DO
          ILINE = 1
          L     = 2
          N     = 3
          GO TO 10
        END IF
C * VIEW LINE
        IF (N12 == 'LI') THEN
          ILINE = 1
          IF (KL < 4) THEN
            WRITE (LU6, 99992, IOSTAT = IOST)
            GO TO 70
          END IF
          CALL PLUT13 (0, 3, IAT, XDUM)
          CALL PLUT13 (0, 4, JAT, XDUM)
          IF (IAT <= 0 .OR. JAT <= 0) THEN
            WRITE (LU6, 99993, IOSTAT = IOST)
            GO TO 70
          END IF
          IF (KN == 1 .AND. KL == 4) CALL PLUT28 (IAT, JAT, FN(1))
          DO K = 1, 3
            RA(K) = RA(IAT * NP43 + K) - RA(JAT * NP43 + K)
          END DO
          L = L + 2
          GO TO 10
        END IF
C * VIEW PERP
        IF (N12 == 'PE') THEN
          ILINE = 2
          GO TO 20
        END IF
C * VIEW BISECT
        IF (N12 == 'BI') THEN
          ILINE = 3
          GO TO 20
        END IF
        WRITE (LU6, 99986, IOSTAT = IOST)
         GO TO 70
   10   CALL PLUT23 (0)
C * CALC R MATRIX FOR LINE VIEW
        XDUM = GEN017 (RA(4))
        DO K = 7, 9
C * NEW Z PARALLEL TO VIEW DIRECTION (ZU 7,8,9)
          ZU(K)     = RA(K - 3)
          ZU(K + 6) = 0.0
        END DO
        IF (ABS(ZU(8)) > 0.9999) THEN
          ZU(13) = 1.0
        ELSE
          ZU(14) = 1.0
        END IF
C * DEFINE NEW X (ZU 1,2,3) AND Y (ZU 4,5,6) AXES
        CALL GEN008 (ZU(13), ZU(7), ZU(1), 1)
        CALL GEN008 (ZU(7), ZU(1), ZU(4), 1)
        GO TO 30
C * VIEW BISECT/PERP
   20   IF (KL < 5) THEN
          WRITE (LU6, 99989, IOSTAT = IOST)
          GO TO 70
        END IF
        CALL PLUT13 (0, 3, J1, XDUM)
        CALL PLUT13 (0, 4, J2, XDUM)
        CALL PLUT13 (0, 5, J3, XDUM)
        IF (J1 <= 0 .OR. J2 <= 0 .OR. J3 <= 0) THEN
          WRITE (LU6, 99988, IOSTAT = IOST)
          GO TO 70
        END IF
        L = L + 3
C * CALC R MATRIX FOR PERP AND BISECT VIEWS
        DO K = 1, 3
          M = K + 3
          ZU(K + 6)  = 0.5 * (RA(J1 * NP43 + M)
     1               + RA(J3 * NP43 + M)) - RA(J2 * NP43 + M)
          ZU(K + 9)  = RA(J1 * NP43 + M)  - RA(J2 * NP43 + M)
          ZU(K + 12) = RA(J3 * NP43 + M)  - RA(J2 * NP43 + M)
        END DO
        XDUM = GEN017 (ZU(7))
        XDUM = GEN017 (ZU(10))
        XDUM = GEN017 (ZU(13))
C * NOW GET V2 = V3 X R2  AND THEN V1 = V2 X V3
        CALL GEN008 (ZU(7), ZU(13), ZU(4), 1)
        CALL GEN008 (ZU(4), ZU(7), ZU(1), 1)
        IF (ILINE /= 3) THEN
C * FOR PERP  JUST SWAP AXES
          DO K = 1, 3
            TEMP      = ZU(K + 6)
            ZU(K + 6) = ZU(K + 3)
            ZU(K + 3) = ZU(K)
            ZU(K)     = TEMP
          END DO
        END IF
C * SET R MATRIX
   30   DO I = 1, 9
          J = (I - 1) / 3
          K = I - J * 3
          R(J + 1, K) = ZU(I)
        END DO
      END IF
C * KEYWORDS GIVING ROTATIONS TO BE APPLIED TO THE CURRENT R MATRIX
   40 L = L + 1
      IF (L > KL)  GO TO 60
      N1 = IFL(L)(1:1)
C * VIEW INVERT - INVERT IMAGE
      IF (N1 == 'I') THEN
        CALL GEN010 (R, -1, -1)
        GO TO 40
      END IF
      N = N + 1
      IF (N > KN) THEN
        WRITE (LU6, 99985, IOSTAT = IOST)
        GO TO 70
      END IF
      CALL GEN021 (A, 1.0)
      ANG = FN(N) / RGBL(6)
      CA  = COS (ANG)
      SA  = SIN (ANG)
      IF (N1 == 'B') THEN
C * BOND ROTN
        IF ((L + 2) > KL) THEN
          WRITE (LU6, 99985, IOSTAT = IOST)
          GO TO 70
        END IF
        L = L + 1
        CALL PLUT13 (0, L, I, XDUM)
        L = L + 1
        CALL PLUT13 (0, L, J, XDUM)
        IF (I <= 0 .OR. J <= 0) THEN
          WRITE (LU6, 99988, IOSTAT = IOST)
          GO TO 70
        END IF
        DO K = 1, 3
          RA(K) = RA(I * NP43 + K) - RA(J * NP43 + K)
        END DO
        CALL PLUT23 (0)
        XDUM = GEN017 (RA(4))
        CALL GEN002 (1, R, RA(4), RA(1), XLNG)
        GO TO 50
      ELSE IF (N1 == 'L') THEN
C * LINE ROTN
        IF ((N + 3) > KN)  GO TO 70
        DO I = 1, 3
          N = N + 1
          RA(I) = FN(N)
        END DO
        CALL PLUT23 (0)
        XDUM = GEN017 (RA(4))
        CALL GEN002 (1, R, RA(4), RA(1), XLNG)
        GO TO 50
      ELSE IF (N1 == 'O') THEN
C * ORTHOLINE ROTN
        IF ((N + 3) > KN)  GO TO 70
        DO I = 1, 3
          N = N + 1
          ZU(I + 6) = FN(N)
        END DO
        XDUM = GEN017 (RA(4))
        CALL GEN002 (1, R, RA(4), RA(1), XLNG)
        GO TO 50
      ELSE IF (N1 == 'P') THEN
C * PROT
        IF ((N + 3) > KN)  GO TO 70
        DO I = 1, 3
          N = N + 1
          ZU(I + 3) = FN(N)
        END DO
        XDUM = GEN017 (ZU(4))
         GO TO 50
      ELSE IF (N1 == 'X') THEN
C * X ROTN
        CALL GEN043 (1, A, ANG)
        CALL GEN004 (A, R, YUNK)
        CALL GEN052 (YUNK, R)
        GO TO 40
      ELSE IF (N1 == 'Y') THEN
C * Y ROTN
        CALL GEN043 (2, A, ANG)
        CALL GEN004 (A, R, YUNK)
        CALL GEN052 (YUNK, R)
        GO TO 40
      ELSE IF (N1 == 'Z') THEN
C * Z ROTN
        CALL GEN043 (3, A, ANG)
        CALL GEN004 (A, R, YUNK)
        CALL GEN052 (YUNK, R)
        GO TO 40
      END IF
      GO TO 70
   50 CB = 1.0 - CA
      DO I = 1, 3
        DO J = 1, 3
          A(I, J) = CB * RA(I) * RA(J)
        END DO
      END DO
      A(1, 1) = A(1, 1) + CA
      A(1, 2) = A(1, 2) + RA(3) * SA
      A(1, 3) = A(1, 3) - RA(2) * SA
      A(2, 1) = A(2, 1) - RA(3) * SA
      A(2, 2) = A(2, 2) + CA
      A(2, 3) = A(2, 3) + RA(1) * SA
      A(3, 1) = A(3, 1) + RA(2) * SA
      A(3, 2) = A(3, 2) - RA(1) * SA
      A(3, 3) = A(3, 3) + CA
      CALL GEN004 (A, R, YUNK)
      CALL GEN052 (YUNK, R)
      GO TO 40
   60 CALL GEN096 (R, IROTX, IROTY, IROTZ, IDET, XYZOR, PHI, ROM)
      RGBL(28) = IROTX
      RGBL(29) = IROTY
      RGBL(30) = IROTZ
      IGBL(87) = IDET
      INVERT   = ' '
C * TEST DETERMINANT = +/-1.0000
      IF (IDET == 0) THEN
        WRITE (LU6, 99997, IOSTAT = IOST)
     1    ((R(I, J), J = 1, 3), I = 1, 3)
        GO TO 70
      ELSE IF (IDET < 0) THEN
        WRITE (LU6, 99999, IOSTAT = IOST)
        INVERT = 'INVERT'
      END IF
      IPR(330) = (1 - IDET) / 2
      WRITE (LU6, 99996, IOSTAT = IOST) IROTX, IROTY, IROTZ, INVERT
      WRITE (LU6, 99995, IOSTAT = IOST) (XYZOR(I), I = 1, 3), PHI,
     1  INVERT
      RETURN
C * ERROR HANDLING
   70 IPR(72) = 28
      WRITE (LU6, 99984, IOSTAT = IOST)
C * COPY MATRIX
      CALL GEN052 (RSAVE, R)
      WRITE (LU6, 99990, IOSTAT = IOST)
      RETURN
99999 FORMAT (':: Absolute Configuration changed !!')
99998 FORMAT (':: ATOMS superimposed in this VIEW: VIEW MATRIX ',
     1        'NOT changed')
99997 FORMAT (/, ':: Abs(Determinant) /= 1.00', //, 10X, 'Matrix', /,
     1               3(3F10.5,/))
99996 FORMAT (/, ':: ORIENTATION     : VIEW UNIT XROT', I5,
     1                            ' YROT', I5, ' ZROT', I5, 2X, A)
99995 FORMAT (':: Equivalent with : VIEW DIR', 3F9.4, ' ZROT',
     1         F7.1, 2X, A)
99994 FORMAT (':: VIEW instruction NOT ALLOWED before',
     1        ' ATOM, CELL or ANGSTROM card')
99993 FORMAT (':: One or both ATOMS unacceptable')
99992 FORMAT (':: Less than 2 ATOMS specified')
99991 FORMAT (':: Less than 9 numbers on MATRIX card')
99990 FORMAT (':: Old VIEW Matrix retained')
99989 FORMAT (':: Less than 3 ATOMS specified')
99988 FORMAT (':: One or more ATOM LABELS unacceptable')
99987 FORMAT (':: Too few direction vector components')
99986 FORMAT (':: VIEW instruction not recognized')
99985 FORMAT (':: Inadequate rotation data')
99984 FORMAT (':: Error in VIEW routine')
      END SUBROUTINE PLUT06
 
      SUBROUTINE PLUT07
C * AUTOMATIC SEARCH FOR CONNECTIONS
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: M3
      INTEGER :: M4
      INTEGER :: L1
      INTEGER :: II
      INTEGER :: JJ
      INTEGER :: IL
      INTEGER :: I0
      INTEGER :: IT
      INTEGER :: MI
      INTEGER :: MJ
      INTEGER :: MK
      INTEGER :: NT
      INTEGER :: IL0
      INTEGER :: IL1
      INTEGER :: IL2
      INTEGER :: ICG
      INTEGER :: ID0
      INTEGER :: ID1
      INTEGER :: ISW
      INTEGER :: ITX
      INTEGER :: ITY
      INTEGER :: ITZ
      INTEGER :: IVL
      INTEGER :: KAT
      INTEGER :: MR1
      INTEGER :: MR2
      INTEGER :: MR4
      INTEGER :: MS1
      INTEGER :: MS2
      INTEGER :: MS3
      INTEGER :: MS4
      INTEGER :: MT4
      INTEGER :: MPM
      INTEGER :: NEW
      INTEGER :: NRI
      INTEGER :: NRJ
      INTEGER :: NSYM
      INTEGER :: MT11
      INTEGER :: MT13
      INTEGER :: MT14
      INTEGER :: MT21
      INTEGER :: MT23
      INTEGER :: MT24
      INTEGER :: MT31
      INTEGER :: MT33
      INTEGER :: MT34
      INTEGER :: NEXT
      INTEGER :: NATC
      INTEGER :: NMOL
      INTEGER :: NML0
      INTEGER :: NATO
      INTEGER :: NELI
      INTEGER :: NELJ
      INTEGER :: MOLY
      INTEGER :: MOLZ
      INTEGER :: JDIS
      INTEGER :: IVAL
      INTEGER :: ITST
      INTEGER :: IDIS
      INTEGER :: IDUM
      INTEGER :: IHAT
      INTEGER :: ILPB
      INTEGER :: INXT
      INTEGER :: JDUM
      INTEGER :: JHAT
      INTEGER :: JUNK
      INTEGER :: NRBO
      INTEGER :: NBOND
      INTEGER :: NRESM
      INTEGER :: NRESI
      INTEGER :: NRESJ
      INTEGER :: NMULT
      INTEGER :: MTYPE
      INTEGER :: NTRNS
      INTEGER :: MADDR
      INTEGER :: KSHFT
      INTEGER :: JJRES
      INTEGER :: JDOAC
      INTEGER :: IVAL1
      INTEGER :: IVAL2
      INTEGER :: IPART
      INTEGER :: IDUM0
      INTEGER :: IDUM2
      INTEGER :: I0RES
      INTEGER :: INFIN
      INTEGER :: JPART
      INTEGER :: IATPRI
      INTEGER :: IATPRJ
      INTEGER :: IATPRX
      INTEGER :: ILSTRT
      REAL    :: XM1
      REAL    :: XM2
      REAL    :: XM3
      REAL    :: XM4
      REAL    :: YM1
      REAL    :: YM2
      REAL    :: YM3
      REAL    :: DIJ
      REAL    :: YUNK
      REAL    :: YRES
      REAL    :: YMM1
      REAL    :: XMOL
      REAL    :: DUM1
      REAL    :: DUM4
      REAL    :: DUM5
      REAL    :: DMAX
      REAL    :: XTRNS
      REAL    :: DIJSQ
      REAL    :: DMAXSQ
      REAL    :: GEN009
      REAL    :: PLA395
      ILSTRT = 0
      IT     = 0
C * JOIN RADII UNIQUE  IPR(35) =  1
C * JOIN RADII         IPR(35) =  0
C * JOIN RADII INTER   IPR(35) = -1
      IDUM0 = 0
      IDUM2 = 0
      DUM1  = 0.0
      DO I = 1, 192
        DO J = 1, 3
          XTT(I, J) = 0.0
        END DO
      END DO
      NATO  = IPR(39)
      NSYM  = IPR(48)
      ILPB  = IPR(69) + 1
      NRESM = IPR(134)
      KSHFT = 0
      IF (IPR(35) >= 0) THEN
C * JOIN RADII UNIQUE
        IF (IPR(35) == 1) THEN
          KSHFT = 1
          IF (IPR(110) == 1) THEN
            WRITE (LU6, 99998, IOSTAT = IOST)
          ELSE
            WRITE (LU6, 99993, IOSTAT = IOST)
          END IF
          WRITE (LU22, 99991, IOSTAT = IOST)
C * JOIN RADII
        ELSE
          WRITE (LU6, 99996, IOSTAT = IOST)
C * FULL RESET NUMBER OF BONDS
          IPR(52) = IPR(68)
          IPR(53) = IPR(68)
        END IF
        CALL GEN074 (RCG, 1, NP32 * 4, 0.0)
        IPR(38) = NATO
        IPR(42) = 0
        IPR(43) = 0
        IPR(44) = 0
        IPR(70) = 0
C * SET CONNECTIVITY SEARCH DEFAULTS (NO)-MOVE
C * CONTENTS OF FLAG ARRAY, IDONE = BIT 1, INEXT = BIT 2
        IVAL = MAX (0, IGBL(30) * 4)
        DO I = ILPB, NATO
          IF (IVAL > 0) RA(I * NP43 + 12) = 1.555
          CALL PLUT15 (4, I, 1, IVAL)
C * ORTHOGONALIZE FOR ANGSTROM COORDINATES INPUT
          IF (IPR(50) == 1) CALL PLUT23 (I)
        END DO
        ILSTRT = ILPB
      ELSE
C * JOIN RADII INTER MODE, RESET NUMBER OF BONDS TO UNIQUE
        IPR(52) = IPR(53)
        KSHFT   = 1 - IPR(50)
        I       = ILPB - 1
      END IF
      IPR(37) = IPR(38)
C * SET TO NO-ERROR
      IPR(72)  = 0
C * SET REBUILD
      IPR(130) = 0
      IPR(55)  = 0
      GO TO 160
C * HEADER OF LOOP ON ATOM I:
C * SEQUENTIAL FOR INTER, PROBLEM DEPENDENT SEQUENCE FOR INTRA(UNIQUE)
   10 DO L = 1, 3
        XYZOR(IPR(120 + L)) = RA(I * NP43 + L)
      END DO
C * GET DISORDER PARAMETER ATOM I
      CALL PLUT15 (-4, I, 28, IDIS)
      IDIS   = IPPR(IDIS + 1, 1)
      CALL PLUT15 (-5, I, 48, IPART)
      IPART  = IPART - 16
C * GET ELEMENT RELATED DATA FOR ATOM I
      NRI    = INT (RA(I * NP43 + 7) / 64000) + 1
      NELI   = IEN(NRI)
      IATPRX = IATPR(NELI)
C * TEST FOR ALKALI OR ALKALI-EARTH
      IF (IATPRX == 5 .OR. IATPRX == 6) THEN
        IATPRI = 1
C * TEST FOR NON-METAL
      ELSE IF (IATPRX < 0) THEN
        IATPRI = -1
      ELSE
        IATPRI = 0
      END IF
C * TEST FOR INTRA-CONNECT ORDER
      NEXT = 0
      CALL PLUT15 (-6, I, 5, NRESI)
C * GET H-ATOM IDENTIFICATION
      CALL PLUT15 (-1, I, 44, IHAT)
      IF (IPR(35) < 0) THEN
        IF (IPR(109) > 0) THEN
C * NO P-ACCEPTOR
          IF (NELI == 8) GO TO 160
C * NO CU-ACCEPTOR
          IF (NELI == 10) GO TO 160
C * AVOID O-COORDINATE N=4,S=6 AS DO/AC
          IF (NELI == 4 .OR. NELI == 6) THEN
            CALL PLUT15 (-1, I, 46, IVAL)
            IF (IVAL == 0) GO TO 160
          END IF
        END IF
      ELSE
C * AVOID LOOP ON H-ATOM
        IF (IPR(50) == 0) THEN
          IF (IHAT == 1) THEN
            J    = NATO
            NEXT = 0
            GO TO 150
          END IF
        END IF
      END IF
C * HEADER OF LOOP ON ATOMS J
      J = ILPB
      IF (IPR(50) == 1 .AND. IPR(35) >= 0) J = ILSTRT
C * SHORTCUT FOR INTER/ANGSTROM CASE
   20 IF (IPR(35) >= 0 .AND. IPR(50) == 1 .AND. J < I) THEN
        CALL PLUT15 (-2, J, 1, IVAL)
        IF (IVAL == 1) GO TO 150
      END IF
C * DISORDER INFO ATOM J
      CALL PLUT15 (-4, J, 28, JDIS)
      JDIS = IPPR(JDIS + 1, 1)
      CALL PLUT15 (-5, J, 48, JPART)
      JPART  = JPART - 16
C * GET ELEMENT RELATED DATA FOR ATOM J
      NRJ    = INT (RA(J * NP43 + 7) / 64000) + 1
      NELJ   = IEN(NRJ)
      IATPRX = IATPR(NELJ)
C * TEST FOR ALKALI OR ALKALI-EARTH
      IF (IATPRX == 5 .OR. IATPRX == 6) THEN
        IATPRJ = 1
C * TEST FOR NON-METAL
      ELSE IF (IATPRX < 0) THEN
        IATPRJ = -1
      ELSE
        IATPRJ = 0
      END IF
C * GET H-ATOM IDENTIFICATION
      CALL PLUT15 (-1, J, 44, JHAT)
C * HANDLE H-BONDS/XBONDS
      IF (IPR(35) < 0) THEN
        IF (IPR(109) > 0) THEN
C * NO -P-ACCEPTOR
          IF (NELJ == 8) GO TO 150
C * TEST FOR MIXED H (OR D) AND NON-H (OR D)
          IF (IHAT == JHAT) GO TO 150
C * AVOID O-COORDINATED N,S AS DO/AC
          IF (NELJ == 4 .OR. NELJ == 6) THEN
            CALL PLUT15 (-1, J, 46, IVAL)
            IF (IVAL == 0) GO TO 150
          END IF
        END IF
      END IF
C * GET MULTIPLICITY FOR J
      CALL PLUT15 (-6, J, 18, NMULT)
C * GET RESIDUE NUMBER FOR ATOM J
      CALL PLUT15 (-6, J, 5, NRESJ)
      DMAX = RADR(NRI, 2) + RADR(NRJ, 2)
C * INCLUDE INTERMEDIATE CONTACTS FOR CU,CO ETC
      IF (IPR(35) >= 0) THEN
        IF (IPR(60) == 1) THEN
          ITST = NELI * NELJ
C * ZN..O,N
          IF (ITST == 309 .OR. ITST == 412) THEN
            DMAX = DMAX + PAR(541)
C * CU..O,N
          ELSE IF (ITST == 30 .OR. ITST == 40 .OR.
     1      ITST == 50 .OR. ITST == 120 .OR. ITST == 180) THEN
            DMAX = DMAX + PAR(542)
C * MN..O,N
          ELSE IF (ITST == 177 .OR. ITST == 236) THEN
            DMAX = DMAX + PAR(543)
C * AG..O,N
          ELSE IF (ITST == 39 .OR. ITST == 52) THEN
            DMAX = DMAX + PAR(544)
C * CR..O,N
          ELSE IF (ITST == 93 .OR. ITST == 124) THEN
            DMAX = DMAX + PAR(545)
C * TL..O,N
          ELSE IF (ITST == 285 .OR. ITST == 380) THEN
            DMAX = DMAX + PAR(546)
          ELSE
            IF (IATPRI * IATPRJ < 0) THEN
              DMAX = DMAX + IGBL(97) * PAR(26)
            END IF
C * AVOID CU-CU, NI-NI,MN-MN,TI-TI,ZN-ZN,CU-NI ETC.
              YUNK = PLA395 (NELI, NELJ)
              IF (YUNK < -9.0) THEN
                DMAX = 2.0
              ELSE
                DMAX = DMAX + YUNK
              END IF
          END IF
C * AVOID LONG I ... I- BONDS
          IF (NELI == 9 .AND. NELJ == 9) DMAX = 3.0
          IF (NELI == 1 .OR. NELJ == 1) DMAX = MIN (DMAX, PAR(461))
        END IF
      ELSE
        IF (IPR(109) > 0) THEN
          DMAX = DMAX - 0.12
        END IF
      END IF
      DMAXSQ = DMAX**2
C * SET UP THE D LIMITS FOR EACH AXIS, START LOOP ON SYMMETRY OPERATORS
      NT = 0
      DO L = 1, 3
        DLIM(IPR(120 + L)) = DMAX / PAR(112 + L)
        RASGX(L)           = RA(J * NP43 + L)
      END DO
      MOLY = 1555
      DO 140 N = 1, NSYM
        IF (JPART < 0 .AND. N > 1) GO TO 140
        DO L = 1, 3
          T(L)       = 0.0
          SGX(L + 3) = 0.0
          SGX(L)     = RASGX(L)
        END DO
        CALL SGSM (3, ICL, SGX, N, LU6, IERR)
C * TAKE CARE OF ATOMS ON SPECIAL POSITIONS
        IF (NMULT > 1) THEN
          IF (N > 1) THEN
            DO K = 1, NT
              DO L = 1, 3
                IF (0.5 - ABS (MOD (10.0 + ABS (SGX(L + 6)
     1            - XTT(K, L)), 1.0)
     2            - 0.5) > 0.005) CYCLE
              END DO
            END DO
          END IF
          NT = NT + 1
          DO L = 1, 3
            XTT(NT, L) = SGX(L + 6)
          END DO
        END IF
        DO M = 1, 3
          XJS(IPR(120 + M)) = SGX(M + 6)
        END DO
C * BEGIN TRANSLATIONAL SEARCH ROUTINE
C * SPECIAL 'NOSHIFT' SHORTCUT
        IF (KSHFT == 0) THEN
C * NO CALCULATION OF INTERMOLECULAR DISTANCES
          IF (I == J)  GO TO 140
          DO K = 1, 3
            SEP(K) = XYZOR(K) - XJS(K)
            IF (ABS (SEP(K)) > DLIM(K))  GO TO 140
          END DO
          GO TO 60
        END IF
        K = 1
C * TRANSLATE XJS ON AXIS K TO A POINT BELOW LOWER LIMIT
   30   IF (XYZOR(K) - XJS(K) > DLIM(K))  GO TO 50
        XJS(K) = XJS(K) - 1.0
        T(K)   = T(K)   - 1.0
        GO TO 30
   40   K = K - 1
        IF (KSHFT == 0) GO TO 140
C * ADVANCE +1.0 ON AXIS K
   50   XJS(K) = XJS(K) + 1.0
        T(K)   = T(K)   + 1.0
        SEP(K) = XJS(K) - XYZOR(K)
        IF (SEP(K) < - DLIM(K))  GO TO 50
C * TEST IF XJS - XI LESS THAN OR EQUAL TO DLIM(K)
        IF (SEP(K) > DLIM(K)) THEN
C * TEST GIVES ATOM OUT OF RANGE. REDUCE AXIS K BY 1
          K = K - 1
          IF (K > 0) THEN
            GO TO 50
          ELSE
            GO TO 140
          END IF
C * K = 0 SIGNALS THE END OF THE SEARCH
        END IF
C * IF XJS WAS WITHIN RANGE ON AXIS K THEN WE ADVANCE K BY 1
        K = K + 1
        IF (K < 4)  GO TO 30
C * ATOM IN RANGE FOR ALL 3 AXES
        IT = INT (ABS (T(1)) + ABS (T(2)) + ABS (T(3)))
C * ELIMINATE DISTANCE OF ATOM FROM ITSELF
        IF (N == 1 .AND. IT == 0 .AND. I == J) GO TO 40
C * NOW CALCULATE EXACT DISTANCE
   60   DO M = 1, 3
          RA(M) = SEP(IPR(120 + M))
        END DO
C * ORTHOGONALIZE
        CALL PLUT23 (0)
        DIJSQ = GEN009(RA(4), RA(4))
        IF (DIJSQ < DMAXSQ) THEN
C * ELIMINATE INTRAMOLECULAR DISTANCES IF INTERMOLECULAR SEARCH ONLY
          IF (IPR(35) < 0) THEN
            IF (N == 1) THEN
              IF (NRESI == NRESJ) THEN
C * TEST FOR H-BOND OPTION
                IF (IPR(109) == 0) THEN
                  IF (IT == 0) GO TO 40
                ELSE
C * AVOID DOUBLE STORAGE OF THE SAME INTRA H-BOND
                  IF (IHAT == 1) THEN
                    IF (IT == 0) GO TO 40
                  END IF
C * AVOID C-H..A CONTACTS
                  CALL PLUT40 (I, J, N, ISW)
                  IF (ISW < 0) GO TO 40
                END IF
              ELSE
                IF (IPR(109) > 0) THEN
C * AVOID C-H..A CONTACTS
                  CALL PLUT40 (I, J, N, ISW)
                  IF (ISW < 0) GO TO 40
                END IF
              END IF
            ELSE
C * CHECK INTER CONTACTS (N > 1)
              IF (IPR(109) > 0) THEN
C * AVOID C-H..A CONTACTS
                CALL PLUT40 (I, J, N, ISW)
                IF (ISW < 0) GO TO 40
              END IF
            END IF
          END IF
        ELSE
          GO TO 40
        END IF
C * WE HAVE A DISTANCE LESS THAN OR EQUAL TO DMAX. STORE CONNECTION
        DIJ = SQRT(DIJSQ)
C * AVOID SI-ND
        IF (DIJ > 3.1) THEN
          IF ((NELI == 63 .AND. NELJ == 85) .OR.
     1        (NELJ == 85 .AND. NELI == 63)) GO TO 40
        END IF
        IF (IPR(109) > 0 .AND. DIJ < 1.25) GO TO 40
C * GET TRANSFORMATION
        MOLZ = NINT(N * 1000 + T(IPR(121)) * 100 + T(IPR(122)) * 10
     1       + T(IPR(123)) + 555)
C * TEST FOR ELEMENT TYPE Q
        IF (NELJ == 111) THEN
          IF (DIJ < RGBL(25) .AND. I /= J) THEN
C * GET ATOM LABEL J
            CALL PLUT25 (1, J, JDUM)
C * GET ATOM LABEL I
            CALL PLUT25 (2, I, IDUM)
            WRITE (LU6, 99992, IOSTAT = IOST) NQ1, NQ2, DIJ
C * EXCLUDE THIS ATOM AND MARK AS SETTLED
            IVAL = 0
            CALL PLUT15 (6, J, 18, IVAL)
            IVAL = 0
            CALL PLUT15 (1, J, 27, IVAL)
            IVAL = 1
            CALL PLUT15 (2, J,  1, IVAL)
            GO TO 150
          END IF
        END IF
        DO M = 1, 3
          XYZJS(M) = XJS(IPR(120 + M))
        END DO
        IF (DIJ < 0.05 .AND. I == J) THEN
          IF (J > IPR(37)) GO TO 40
          CALL PLUT15 (-2, J, 3, IVL)
          IVL = MAX (IVL, 1)
          CALL PLUT15 ( 2, J, 3, IVL)
          IVL = 1
          CALL PLUT15 ( 1, J, 1, IVL)
          IF (I == J) GO TO 40
C * DELETE SYMMETRY-EQUIVALENT ATOM
          IVL = 0
          CALL PLUT15 (1, J, 2, IVL)
          L = IPR(68) + 1
   70     CALL PLUT16 (0, L, IL1, IL2, DUM1, IDUM2)
C * AVOID ELIMINATION OF UNIQUE BONDS
          IF (IL1 > IPR(38) .OR. IL2 > IPR(38)) THEN
            IF (IL1 == J) THEN
              GO TO 80
            ELSE IF (IL1 > J) THEN
              GO TO 100
            END IF
            IF (IL2 /= J)  GO TO 90
   80       CALL PLUT16 (-3, IDUM0, IL1, IL2, DUM1, IDUM2)
          END IF
   90     L = L + 1
          IF (L <= IPR(52))  GO TO 70
  100     IVL = 3
          CALL PLUT15 (2, J, 3, IVL)
          GO TO 140
        END IF
C * DECIDE WHAT TO DO WITH THIS CONNECTION
        KAT = J
        NEW = 1
C * JOIN RADII INTER CASE
        IF (IPR(35) < 0) THEN
C * HANDLE CASE OF MORE THAN ONE RESIDUES IN ASYMMETRIC UNIT
          IF (N == 1 .AND. IT == 0 .AND. NRESI /= NRESJ) THEN
            GO TO 130
          ELSE
            GO TO 110
          END IF
        ELSE
C * JOIN RADII (UNIQUE) MODE
          IF (JHAT == 1) THEN
            CALL PLUT15 (-1, I, 46, JDOAC)
            CALL PLUT15 ( 1, J, 32, JDOAC)
          END IF
          CALL PLUT15 (-1, J, 1, IVAL)
          IF (IVAL == 0) THEN
C * SET 'INEXT' FLAG
            IVL = 1
            CALL PLUT15 (1, J, 2, IVL)
            IF (IPR(50) == 0) THEN
              IF (IATPRI >= 0 .AND. IATPRJ < 0) NEXT = 1
            END IF
          END IF
          CALL PLUT15 (-2, J, 3, IVL)
          IF (N == 1 .AND. IT == 0) THEN
            ITX = 1
            IF (IVL > 0) GO TO 130
          ELSE
            ITX = 0
          END IF
          IF (IVL == 0) THEN
            IF (ITX == 0) THEN
C * MOVE ATOM J
              DO II = 1, 3
                RA(J * NP43 + II) = XYZJS(II)
              END DO
              CALL PLUT23 (J)
              IVL = 2
            ELSE
              IVL = 1
            END IF
            CALL PLUT15 (2, J, 3, IVL)
            GO TO 130
          END IF
          IF (IPR(50) == 0) THEN
            DO II = 1, 3
              IF (ABS (RA(J * NP43 + II) - XYZJS(II)) * PAR(100 + II)
     1           > PAR(22)) GO TO  110
            END DO
            GO TO 130
          END IF
        END IF
C * ADD ATOM TO LIST. THE EXTRA ATOMS ARE USED FOR DRAWING BONDS BETWEEN
C * MOLECULES. THE CIRCLES ARE IN GENERAL NOT TO BE DRAWN HOWEVER.
C * TEST FOR DUPLICATION OF ATOM COORDINATES IN LIST
  110   IF (NEW > 0) THEN
          NATC = IPR(38) + IPR(55)
          DO 120 KAT = ILPB, NATC
            DO II = 1, 3
              IF (ABS (RA(KAT * NP43 + II) - XYZJS(II))
     1            * PAR(100 + II) >= PAR(22)) GO TO 120
            END DO
            GO TO 130
  120     CONTINUE
          IPR(55) = IPR(55) + 1
          KAT     = IPR(38) + IPR(55)
C * STACK OVERFLOW TEST
          IF ((KAT + 1) * NP43 > IPR(64) - IPR(52) * 2) THEN
C * SEARCH INTERRUPTED
            IPR(42) = IPR(43)
            IPR(52) = IPR(53)
            IPR(37) = IPR(38)
            IPR(72) = 29
            GO TO 230
          END IF
          DO II = 1, 3
            RA(KAT * NP43 + II) = XYZJS(II)
          END DO
          CALL PLUT23 (KAT)
C * SET AND COPY FLAGS FOR ATOM KAT
C * COPY LABEL POSITION, ATOM TYPE (ELEMENT INDEX), DOAC-BIT
C * COPY IDH-BIT, METAL/HATOM BITS, MULTIPLICITY
          RA(KAT * NP43 + 8)  = RA(J * NP43 + 8)
          RA(KAT * NP43 + 9)  = RA(J * NP43 + 9)
          RA(KAT * NP43 + 10) = RA(J * NP43 + 10)
          RA(KAT * NP43 + 11) = RA(J * NP43 + 11)
          XM1                 = RA(J * NP43 + 12) * 1000.0
          XM2 = MOLZ
          CALL PLA270 (XM1, XM2, XM3)
          RA(KAT * NP43 + 12) = XM3 / 1000.0
          IVL = 0
          CALL PLUT15 (2, KAT, 3, IVL)
          IVL = 0
          CALL PLUT15 (2, I,   1, IVL)
C * SPECIAL INTRA RESIDUE COPY
            CALL PLUT15 (-6, I,   5, IVAL)
            CALL PLUT15 ( 6, KAT, 5, IVAL)
C * SET INCLUDE BIT TO 0
          IVL = 0
          CALL PLUT15 ( 1, KAT, 27, IVL)
        END IF
C * SET RESIDUE NUMBER
        IF (IPR(35) >= 0) THEN
          CALL PLUT15 (6, KAT,  5, IPR(70))
          IVL = IPR(70) - 1
          CALL PLUT15 (6, KAT, 11, IVL)
        END IF
C * ADD THIS ARU TO ARU-LIST
        IF (IPR(35) >= 0) THEN
          CALL PLUT15 (-6, KAT, 5, NRESJ)
        ELSE
          CALL PLUT15 (-6, J, 5, NRESJ)
        END IF
        XM1  = MOLZ
        XM2  = MOLY
        CALL PLA270 (XM1, XM2, XM3)
        XMOL = INT (XM3) + NRESJ / PAR(42)
        IF (IPR(35) < 0) THEN
          MTYPE = -1
        ELSE
          MTYPE =  0
        END IF
C * ADD MOLECULE
        CALL PLUT17 (XMOL, MTYPE, MADDR, LU6)
C * EXPAND TO MOLECULE
        IF (IPR(35) < 0) CALL PLUT35 (XMOL, -1)
        IF (NEW > 0) THEN
C * COPY LABEL
          RA(KAT * NP43 + 7) = RA(J * NP43 + 7)
          CALL PLUT15 (6, KAT, 11, MADDR)
        END IF
C * REGISTER TRANSFORMATION ON INPUT COORDINATES
  130   IF (RA(KAT * NP43 + 12) <= 0.0) THEN
          RA(KAT * NP43 + 12) = MOLZ / 1000.0
          IF (KAT <= NATO) THEN
            XM1 = MOLZ
            XM2 = 0.0
            CALL PLA270 (XM1, XM2, XM3)
            IF (IPR(2) /= 0) THEN
              IPR(72) = 100 + IPR(2)
              GO TO 230
            END IF
            MOLY = INT (XM3)
          END IF
        END IF
 
C * ADD CONNECTION TO LIST
        IF (.TRUE.) THEN
C * AVOID DISORDER BONDS
          JUNK = 0
          IF (IPART /= JPART) THEN
            IF (IPART == 0 .OR. JPART == 0) JUNK = 1
          ELSE IF (IPART == JPART) THEN
            JUNK = 1
          END IF
          IF (JUNK == 1) THEN
            IF (IDIS < 10000 .AND. JDIS < 10000) THEN
              IF (IDIS == 5000 .AND. JDIS == 5000) THEN
                IF (IABS (IPART) > 0 .AND.
     1              IABS (JPART) > 0) THEN
                  IF (IPART /= JPART) GO TO 40
                END IF
              END IF
              IF (ABS (IDIS -JDIS) > 1) THEN
                IF (IABS (2 * IDIS - JDIS) > 1 .AND.
     1              IABS (2 * JDIS - IDIS) > 1) THEN
                  IF (IPART /= JPART .OR.
     1               (IPART == 0 .AND. JPART == 0)) GO TO 40
                END IF
              END IF
            END IF
            IF (NEW > 0) THEN
              CALL PLUT16 (-1, IDUM0, I, KAT, DUM1, IDUM2)
C * REGISTER NUMBER OF BONDS PER ATOM AND NR OF BONDS TO OXYGEN
              IF (IPR(35) >= 0) THEN
                CALL PLUT15 (-3, I, 24, IVAL1)
                IF (NELJ == 3 .AND. IVAL1 < 7) THEN
                  IVL = IVAL1 + 1
                  CALL PLUT15 (3, I, 24, IVL)
                END IF
                CALL PLUT15 (-3, KAT, 24, IVAL2)
                IF (NELI == 3 .AND. IVAL2 < 7) THEN
                  IVL = IVAL2 + 1
                  CALL PLUT15 (3, KAT, 24, IVL)
                END IF
              END IF
            END IF
          END IF
        END IF
        GO TO 40
C * END LOOP ON SYMMETRY OPERATORS ON ATOM J
  140 CONTINUE
C * BREAK SEQUENCE FOR METAL-NEWFIX
  150 IF (NEXT == 0) THEN
        J = J + 1
        IF (J <= NATO)  GO TO 20
C * NOW DECIDE WHAT TO DO ABOUT THE NEXT ATOM I
        IF (IPR(35) >= 0) THEN
C * MARK THIS ATOM AS SETTLED
          IVL = 1
          CALL PLUT15 (2, I, 1, IVL)
C * COLLECT DATA FOR C.G. OF RESIDUE (ASYMMETRIC UNIT)
          DO JJ = 1, 3
            RCG(JJ, NRESI) = RCG(JJ, NRESI) + RA(I * NP43 + JJ)
          END DO
          RCG(4, NRESI) = RCG(4, NRESI) + 1
        END IF
      END IF
C * DETERMINE THE NEXT I-ATOM
  160 IF (IPR(35) >= 0) THEN
        IATPRI = 0
        INXT   = 0
        I      = 0
        IL0    = ILSTRT
C * LOOK FOR THE  NEXT UNSETTLED ATOM
        DO IL = IL0, NATO
C * GET INEXT / IDONE STATUS
          CALL PLUT15 (-2, IL, 1, IVAL)
C * TEST FOR NOT-DONE STATUS
          IF (IVAL /= 1) THEN
C * GET ELEMENT TYPE INDEX IN NON-ANGSTROM CASE
            IF (IPR(50) == 0)
     1      IATPRI = IATPR(IEN(INT(RA(IL * NP43 + 7) / 64000) + 1))
            IF (IVAL == 2) THEN
C * METAL/NON-METAL TEST
              IF (IATPRI < 0) THEN
                I = IL
                GO TO 170
              ELSE
                IF (I == 0) I = - IL
              END IF
            END IF
C * REGISTER POTENTIAL STARTING ATOM TO START NEW RESIDUE (PREF. NON-METAL)
            IF (INXT <= 0) THEN
              IF (IVAL == 0) THEN
                IF (IATPRI < 0) THEN
                  INXT =   IL
                ELSE
                  INXT = - IL
                END IF
              END IF
            END IF
          ELSE
C * RAISE BOTTOM OF SEARCH LOOP
            IF (IL == ILSTRT) ILSTRT = ILSTRT + 1
          END IF
        END DO
C * FINALLY LOOP ON A 'NOT-YET-DONE' METAL ATOM
        IF (I < 0) THEN
          I = IABS (I)
          GO TO 170
        END IF
C * CALCULATE RESIDUE C.G.
        JJ = IPR(70)
        IF (JJ > 0) THEN
          ICG = IPR(38) + IPR(55) + 1
          ID0 = ICG + 1
          ID1 = ID0 + 1
          DO L = 1, 3
            RCG(L, JJ)         = RCG(L, JJ) / RCG(4, JJ)
            RA(ICG * NP43 + L) = RCG(L, JJ)
            RA(ID0 * NP43 + L) = PAR(141 + L)
          END DO
          RA(ICG * NP43 + 12) = 1.555
          CALL PLUT15 (6, ICG, 5, JJ)
C * BRING X,Y,Z OF CENTRE OF GRAVITY IN RANGE 0 TO 1
C * (CLOSEST TO PAR(142), PAR(143), PAR(144))
          IF (IGBL(30) <= 0) THEN
            CALL PLUT23 (ICG)
            CALL PLUT23 (ID0)
            DUM5 = 99999.0
            IF (PAR(140) >= 0.0) THEN
              DO K = 1, NSYM
                DO L = 1, 3
                  SGX(L)     = RA(ICG * NP43 + L)
                  SGX(L + 3) = 0.0
                END DO
                CALL SGSM (3, ICL, SGX, K, LU6, IERR)
                DO L = 1, 3
                  DUM1 = AMOD (SGX(L + 6), 1.0)
                  IF (DUM1 < 0.0) DUM1 = DUM1 + 1.0
                  RA(ID1 * NP43 + L) = DUM1
                  TRL(L)            = DUM1 - SGX(L + 6)
                END DO
                CALL PLUT23 (ID1)
                CALL PLUT22 (ID0, ID1, DUM4)
                IF (DUM4 < DUM5) THEN
                  DUM5 = DUM4
                  N = K
                  DO L = 1, 3
                    T(L) = TRL(L)
                  END DO
                END IF
              END DO
            ELSE
              YM1  = ABS (PAR(140) * 1000.0)
              N    = INT (YM1 / 1000.0)
              YM1  = YM1 - N * 1000.0
              T(1) = INT (YM1 / 100.0)
              YM1  = YM1 - T(1) * 100.0
              T(1) = T(1) - 5
              T(2) = INT (YM1 / 10.0)
              T(3) = INT (YM1 - T(2) * 10.0)
              T(2) = T(2) - 5
              T(3) = T(3) - 5
            END IF
            YM1 = N * 1000.0 + T(1) * 100.0 + T(2) * 10.0 + T(3)
     1          + 555.0
C * CG_TRANSFORMATION AND INVERSE
            CALL PLA270 (YM1, 0.0, YMM1)
C * CALL EXIT/STOP
            IF (IPR(2) /= 0) CALL GEN127 ('105')
C * APPLY TRANSFORMATION TO ALL ATOMS (INCL CG_RESD) IN THIS RESIDUE
            DO I0 = ILPB, ICG
C * GET RESIDUE NUMBER FOR THIS ATOM
              CALL PLUT15 (-6, I0, 5, I0RES)
              IF (I0RES == JJ) THEN
                DO L = 1, 3
                  SGX(L)     = RA(I0 * NP43 + L)
                  SGX(L + 3) = T(L)
                END DO
                CALL SGSM (3, ICL, SGX, N, LU6, IERR)
                DO L = 1, 3
                  RA(I0 * NP43 + L) = SGX(L + 6)
                END DO
                CALL PLUT23 (I0)
                YM2 = RA(I0 * NP43 + 12) * 1000.0
                CALL PLA270 (YM1, YM2, YM3)
                IF (IPR(2) == 0)
     1          RA(I0 * NP43 + 12) = YM3 / 1000.0
              END IF
            END DO
C * RETURN TRANSFORMED CENTRE_OF_GRAVITY
            DO L = 1, 3
              RCG(L, JJ) = RA(ICG * NP43 + L)
            END DO
C * MODIFY ARU [ T R T-1 ]
            L1 = IPR(42)
            IF (L1 > 0) THEN
              DO L = 1, L1
                YRES = MOD (MOL(1, L) / PAR(42), 1.0)
                JJRES = NINT (YRES * PAR(42))
                IF (JJ == JJRES) THEN
                  YM3 = INT (MOL(1, L) / PAR(42))
                  CALL PLA270 (YM1, YM3, YM2)
C * CALL EXIT/STOP
                  IF (IPR(2) /= 0) CALL GEN127 ('103')
                  CALL PLA270 (YM2, YMM1, YM3)
C * CALL EXIT/STOP
                  IF (IPR(2) /= 0) CALL GEN127 ('102')
                  MOL(1, L) = NINT ((YM3 + YRES) * PAR(42))
                END IF
              END DO
            END IF
          END IF
        END IF
C * NO CONNECTED ATOM IS LEFT TO GOTO, THEREFORE WE BEGIN A NEW
C * RESIDUE, UNLESS ALL ATOMS HAVE BEEN DONE
        IF (INXT == 0) GO TO 180
        I = IABS (INXT)
        IF (IGBL(30) == 0) THEN
          NTRNS = IABS (NINT (RA(I * NP43 + 12) * 1000))
          IF (NTRNS > 0) THEN
            IGBL(30) = - 1
            N     = NTRNS / 1000
            NTRNS = NTRNS - N * 1000
            K     = NTRNS / 100
            T(1)  = K - 5
            NTRNS = NTRNS - K * 100
            K     = NTRNS / 10
            T(2)  = K - 5
            NTRNS = NTRNS - K * 10
            T(3)  = NTRNS - 5
            DO L = 1, 3
              SGX(L)     = RA(I * NP43 + L)
              SGX(L + 3) = T(L)
            END DO
            CALL SGSM (3, ICL, SGX, N, LU6, IERR)
            DO L = 1, 3
              RA(I * NP43 + L) = SGX(L + 6)
            END DO
            NTRNS = N * 1000 + NINT (T(1) * 100.0 + T(2) * 10.0 + T(3))
     1            + 555
C * SET MOVE BIT
            IF (NTRNS /= 1555) THEN
              IVL = 1
              CALL PLUT15 (1, I, 43, IVL)
            END IF
            XTRNS = NTRNS / 1000.0
          ELSE
            XTRNS = 1.555
          END IF
        ELSE
          XTRNS = 1.555
        END IF
        RA(I * NP43 + 12) = XTRNS
        IVL = 1
        CALL PLUT15 (2, I, 3, IVL)
C * SET THE NEXT ATOM I FOR CALCULATION
        IF (IPR(70) < NRESM) THEN
          IF (IPR(136) == 0) THEN
            IPR(70) = IPR(70) + 1
          ELSE
            CALL PLUT15 (-6, I, 5, IPR(70))
          END IF
          IPR(75) = MAX (IPR(75), IPR(70))
          IF (IPR(70) == NRESM)
     1      WRITE (LU6, 99999, IOSTAT = IOST) NRESM
        END IF
        XMOL = 1555.0 + IPR(70) / PAR(42)
        CALL PLUT17 (XMOL, 0, MADDR, LU6)
C * SET RESIDUE AND ARU NUMBERS AND ORTHONORMALISE IN INTRA MODE
  170   CALL PLUT23 (I)
        CALL PLUT15 (6, I,  5, IPR(70))
        IVL = IPR(75) - 1
        CALL PLUT15 (6, I, 11, IVL)
      ELSE
C * ADVANCE I TO I + 1 IF NOT UNIQUE MODE
        I = I + 1
        IF (I > NATO)  GO TO 180
      END IF
      GO TO 10
C * END OF LOOP ON I
  180 IPR(37) = IPR(38) + IPR(55)
      IF (IPR(35) >= 0) THEN
        IPR(38) = IPR(37)
        IPR(53) = IPR(52)
        IPR(20) = 1
C * PRINT OUT WHAT HAS BEEN FOUND
        WRITE (LU6, 99997, IOSTAT = IOST) IPR(75)
        DO I = ILPB, NATO
          CALL PLUT15 (-2, I, 3, IVAL)
          IF (IVAL == 2) THEN
            IVL = 1
            CALL PLUT15 (1, I, 43, IVL)
          END IF
        END DO
      END IF
      IF (IPR(35) < 0) THEN
        MTYPE = -1
      ELSE
        MTYPE   = 0
        IPR(43) = IPR(42)
        IPR(44) = IPR(42)
      END IF
        DO I = ILPB, IPR(39)
          IF (RA(I * NP43 + 12) /= 1.555) IGBL(60) = IGBL(60) + 1
        END DO
C * COMPLETE MOLECULES SITTING ON A SYMMETRY ELEMENT
      IF (IPR(110) == 1) THEN
        INFIN = 0
C * GENERATE ADDITIONAL ARU'S FOR N-ORDER SYMMETRY ELEMENTS
        IF (IPR(42) > 1) THEN
          NML0 = 0
  190     NMOL = IPR(42)
          MI   = 0
C * GET AND UNPACK NEXT ARU MI
  200     DO
            MI = MI + 1
            IF (MI > NMOL) GO TO 220
            MPM = MOL(1, MI)
            IF (MPM >= 0) EXIT
          END DO
          CALL GEN098 (MPM, PAR(42), MS1, MT11, MT21, MT31, MR1)
          IF (MI > NML0) THEN
            MJ = 0
          ELSE
            MJ = NML0
          END IF
C * GET AND UNPACK NEXT ARU MJ
  210     DO
            MJ = MJ + 1
            IF (MJ > NMOL) GO TO 200
            MPM = MOL(1, MJ)
            IF (MPM < 0) CYCLE
            CALL GEN098 (MPM, PAR(42), MS2, ITX, ITY, ITZ, MR2)
            IF (MR2 == MR1) EXIT
          END DO
          SGX(1) = MS1
          SGX(2) = MT11
          SGX(3) = MT21
          SGX(4) = MT31
          SGX(5) = MS2
          SGX(6) = ITX
          SGX(7) = ITY
          SGX(8) = ITZ
          CALL SGSM (8, ICL, SGX, 0, LU6, IERR)
          MS3  = NINT (SGX(9))
          MT13 = NINT (SGX(10))
          MT23 = NINT (SGX(11))
          MT33 = NINT (SGX(12))
          M3   = (MS3 * 1000 + MT13 * 100 + MT23 * 10 + MT33 + 555)
          M3   = NINT(M3 * PAR(42)) + MR1
          XM3  = M3 / PAR(42)
          MK   = 0
          DO
            MK   = MK + 1
            IF (MK > NMOL) THEN
C * ADD THIS ARU/ASU TO THE LIST
              CALL PLUT17 (XM3, MTYPE, MADDR, LU6)
              IF (IPR(35) < 0) CALL PLUT35 (XM3, -1)
              GO TO 210
            END IF
            XM4 = MOL(1, MK) / PAR(42)
            IF (XM4 < 0.0) GO TO 210
            IF (XM3 == XM4) GO TO 210
            M4  = INT (XM4)
            MR4 = NINT ((XM4 - M4) * PAR(42))
            IF (MR4 == MR1) THEN
              MS4 = M4 / 1000
              MT4 = M4 - MS4 * 1000
C * AVOID INFINITE NET
              IF (MS3 == MS4) THEN
                MT14 = MT4 / 100
                IF (IABS (MT13 - MT14 + 5) > 0) THEN
                  INFIN = 1
                  GO TO 210
                ELSE
                  MT4 = MT4 - MT14 * 100
                  MT24 = MT4 / 10
                  IF (IABS (MT23 - MT24 + 5) > 0) THEN
                    INFIN = 1
                    GO TO 210
                  ELSE
                    MT34 = MT4 - MT24 * 10
                    IF (IABS (MT33 - MT34 + 5) > 0) THEN
                      INFIN = 1
                      GO TO 210
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END DO
C * RECYCLE WHEN NEW ARU('S) HAS/HAVE BEEN ADDED
  220     IF (IPR(42) > NMOL) THEN
            NML0 = NMOL
            GO TO 190
          END IF
        END IF
        IF (IPR(35) >= 0) THEN
          IPR(43) = IPR(42)
          IPR(44) = IPR(42)
C * AVOID H-BONDS TO CENTRAL ATOMS IN Phen-NO, NO3, SO4 etc
          DO I = 1, IPR(37)
C * GET ELEMENT RELATED DATA FOR ATOM I
            NRI  = INT (RA(I * NP43 + 7) / 64000) + 1
            NELI = IEN(NRI)
C * N (= 4)
            IF (NELI == 4) THEN
C * GET NUMBER OF BONDS
              CALL PLUT15 (-4, I, 33, NBOND)
              IF (NBOND == 2) THEN
                NRBO = 99
              ELSE IF (NBOND == 3) THEN
                NRBO = 2
              ELSE
                NRBO = 1
              END IF
C * S (= 6)
            ELSE IF (NELI == 6) THEN
              NRBO = 2
C * P (= 8)
            ELSE IF (NELI == 8) THEN
              NRBO = 4
            ELSE
              NRBO = 99
            END IF
C * GET NUMBER OF CONNECTIONS TO O
            CALL PLUT15 (-3, I, 24, IVAL)
            IF (IVAL >= NRBO) THEN
              IVL = 0
              CALL PLUT15 (1, I, 46, IVL)
C * ELIMINATE METAL - N(O3) ETC. BONDS
              DO J = 1, IPR(37)
                NRJ = INT (RA(J * NP43 + 7) / 64000) + 1
                IATPRJ = IATPR(IEN(NRJ))
C * CHECK FOR METAL
                IF (IATPRJ > 0) THEN
                  IF (NELI /= 4 .OR. NBOND /= 3) THEN
C * DELETE THIS BOND
                    CALL PLUT16 (-3, IDUM0, I, J, DUM1, IDUM2)
                  END IF
                END IF
              END DO
            END IF
          END DO
          WRITE (LU6, 99995, IOSTAT = IOST) IPR(43)
          IF (INFIN > 0) THEN
            IGBL(127) = 1
            WRITE (LU6, 99994, IOSTAT = IOST)
          END IF
        END IF
      END IF
C * END MOL EXPAND
  230 IF (IPR(50) * IPR(135) > 0) THEN
        DO I = 1, IPR(37)
          YUNK = MOD (RA(I * NP43 + 3), 100.0)
          IF (YUNK > 50.0) YUNK = YUNK - 100.0
          RA(I * NP43 + 3) = YUNK
          RA(I * NP43 + 6) = YUNK
        END DO
      END IF
      RETURN
99999 FORMAT ( ':: Maximum Residue Number(=', I2, ') reached.',
     1         ' (non-fatal)')
99998 FORMAT ( ':: AEX:JOIN RADII UNIQUE EXPAND')
99997 FORMAT ( ':: Structure contains', I3, ' isolated residue(s)')
99996 FORMAT ( ':: AEX:JOIN RADII')
99995 FORMAT (/':: Number of Unique Asymmetric Residue Units:', I5)
99994 FORMAT (/':: Infinite Structure')
99993 FORMAT ( ':: AEX:JOIN RADII UNIQUE')
99992 FORMAT ( ':: ', A, ' Excluded, DIST TO ', A, ' =', F7.2, ' Ang')
99991 FORMAT ('VIEW MIN')
      END SUBROUTINE PLUT07
 
      SUBROUTINE PLUT08
      USE files
      USE parameters
      USE pluto
      USE sgxyz
      IMPLICIT NONE
      INTEGER              :: I
      INTEGER              :: J
      INTEGER              :: K
      INTEGER              :: M
      INTEGER              :: N
      INTEGER              :: KM
      INTEGER              :: NM
      INTEGER              :: NR
      INTEGER              :: NS
      INTEGER              :: ITX
      INTEGER              :: ITY
      INTEGER              :: ITZ
      INTEGER              :: NAT
      INTEGER              :: MPM
      INTEGER              :: NMOL
      INTEGER              :: JINC
      INTEGER              :: IRES
      INTEGER              :: ILPB
      INTEGER              :: IDET
      INTEGER              :: NINCL
      INTEGER              :: MADDR
      REAL                 :: XX
      REAL                 :: YY
      REAL                 :: ZZ
      REAL                 :: XNM
      REAL                 :: XSQ
      REAL                 :: YSQ
      REAL                 :: ZSQ
      REAL                 :: TEMP
      REAL, DIMENSION(3,3) :: V
      REAL, DIMENSION(6)   :: XDA
C * COMPUTE MATRIX FOR L.S. PLANE WITH NORMAL ALONG Z-AXIS
C * THE METHOD USED IS TO FIND THE PRINCIPAL AXES OF INERTIA. THE Z-AXIS
C * WILL GIVE THE MAXIMUM MOMENT OF INERTIA, AND THE X-AXIS THE MINIMUM.
C * MAKE SHURE THAT THERE IS AT LEAST ONE ARU
      CALL PLUT17 (0.0, 0, MADDR, LU6)
      NAT  = IPR(37)
      NMOL = IPR(42)
      ILPB = IPR(69) + 1
C * GET THE MASS CENTRE
      CALL GEN074 (PAR, 67, 69, 0.0)
      N  = 0
C * GET STACK PARAMETERS
      K  = (NAT + 1) * NP43
      KM = IPR(64) - IPR(52) * 2 - 3
C * LOOP OVER ATOMS
      DO I = ILPB, NAT
        CALL PLUT15 (-1, I, 27, NINCL)
        IF (NINCL > 0) THEN
C * GET RESIDUE NUMBER
          CALL PLUT15 (-6, I, 5, IRES)
          CALL PLUT15 (-6, I, 18, JINC)
          IF (JINC == 1) THEN
            NM = NMOL
          ELSE
            NM = 1
          END IF
C * LOOP OVER ARU LIST
          DO M = 1, NM
            XNM = MOL(1, M) / PAR(42)
            IF (XNM > 0.0) THEN
              MPM = NINT (XNM * PAR(42))
              CALL GEN098 (MPM, PAR(42), NS, ITX, ITY, ITZ, NR)
              TRL(1) = ITX
              TRL(2) = ITY
              TRL(3) = ITZ
C * RESIDUE TEST
              IF (NR == 0 .OR. IRES == NR) THEN
C * GENERATE FRACTIONAL COORDINATES
                DO J = 1,3
                  SGX(J)     = RA(I * NP43 + J)
                  SGX(J + 3) = TRL(J)
                END DO
                CALL SGSM (3, ICL, SGX, NS, LU6, IERR)
C * ORTHOGONALIZE
                DO J = 1, 3
                  RA(J) = SGX(J + 6)
                END DO
                CALL PLUT23 (0)
                IF (K < KM) THEN
                  DO J = 1, 3
                    RA(K + J)   = RA(J + 3)
                    PAR(66 + J) = PAR(66 + J) + RA(J + 3)
                  END DO
                  K = K + 3
                  N = N + 1
                ELSE
                  IPR(101) = IPR(101) + 1
                END IF
              END IF
            END IF
          END DO
        END IF
      END DO
      IF (N > 0) THEN
        IF (N > 1) THEN
          IF (N == 2) THEN
            DO J = 1, 3
              PAR(66 + J) = PAR(66 + J) + 0.01
            END DO
          END IF
          CALL GEN074 (XDA, 1, 6, 0.0)
          DO J = 1, 3
            PAR(66 + J) = PAR(66 + J) / N
          END DO
          K = (NAT + 1) * NP43
          DO I = 1, N
            XX = RA(K + 1) - PAR(67)
            YY = RA(K + 2) - PAR(68)
            ZZ = RA(K + 3) - PAR(69)
            K   = K + 3
            XSQ = XX * XX
            YSQ = YY * YY
            ZSQ = ZZ * ZZ
C * STORE MATRIX Q IN COMPACT MODE FOR GEN023
            XDA(1) = XDA(1) + (YSQ + ZSQ)
            XDA(2) = XDA(2) - XX * YY
            XDA(4) = XDA(4) - XX * ZZ
            XDA(3) = XDA(3) + (ZSQ + XSQ)
            XDA(5) = XDA(5) - YY * ZZ
            XDA(6) = XDA(6) + (XSQ + YSQ)
          END DO
C * CALCULATE EIGENVECTORS AND EIGENVALUES
          CALL GEN023 (XDA, V, 3)
C * THE LATENT ROOTS ARE NOW THE DIAGONAL  ELEMENTS OF A
C * THE ROTATION MATRIX R IS THE TRANSPOSE OF V
          CALL GEN005 (V, R)
C * ROTATE 90 DEG. ABOUT Y SO THAT THE Z AXIS IS PERP TO LS PLANE
          DO K = 1, 3
            TEMP = R(1, K)
            R(1, K) = -R(3, K)
            R(3, K) = TEMP
          END DO
          CALL GEN010 (R, IDET, 1)
        ELSE
          CALL GEN021 (R, 1.0)
        END IF
      ELSE
        IPR(72) = 30
      END IF
      RETURN
      END SUBROUTINE PLUT08
 
      SUBROUTINE PLUT09 (NINCL, ISW)
C * HANDLE INCLUDE/EXCLUDE/OMIT/DELETE
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: IS
      INTEGER          :: KL
      INTEGER          :: KN
      INTEGER          :: NAT
      INTEGER          :: IAI
      INTEGER          :: ISW
      INTEGER          :: IBEG
      INTEGER          :: IEND
      INTEGER          :: ILPB
      INTEGER          :: NINC
      INTEGER          :: IVAL
      INTEGER          :: NATO
      INTEGER          :: NATOS
      INTEGER          :: IMULT
      INTEGER          :: IDUM2
      INTEGER          :: NINCL
      REAL             :: XDUM
      CHARACTER(len=3) :: NTXT
      IS = ISW
      IF (IABS(IGBL(8)) /= 2) THEN
C * CHANGE DEL(ETE) INTO EXCLUDE (DELETE = 89)
        IF (IS == 89 .OR. IS == 159) THEN
          IS    = 28
          NINCL = 0
        END IF
      END IF
C * SET REBUILD
      IPR(130) = 0
      NAT      = IPR(37)
      NATOS    = IPR(38)
      NATO     = IPR(39)
      ILPB     = IPR(69) + 1
      KL       = IPR(220)
      KN       = IPR(221)
      IPR(72)  = 0
      IF (KL > 1) THEN
        NTXT = IFL(2)(1:3)
      ELSE
        NTXT = 'ALL'
      END IF
      NINC = NINCL
C * (IN/EX)CLUDE NONE - CHANGE INTO ALL
      IF (NTXT == 'NON') THEN
        NINC = MOD (NINCL + 1, 2)
        NTXT = 'ALL'
      END IF
C * (IN/EX)CLUDE ALL
      IF (NTXT == 'ALL') THEN
        DO I = ILPB, NAT
          CALL PLUT15 (1, I, 27, NINC)
        END DO
C * (IN/EX)CLUDE C-H ATOMS
      ELSE IF (NTXT == 'CH') THEN
        DO I = ILPB, NATO
          CALL PLUT15 (-1, I, 44, IVAL)
          IF (IVAL == 1) THEN
            CALL PLUT15 (-1, I, 32, IVAL)
            IF (IVAL == 0) THEN
              CALL PLUT15 (1, I, 27, NINCL)
            END IF
          END IF
        END DO
C * (IN/EX)CLUDE D-H ATOMS
      ELSE IF (NTXT == 'DH') THEN
        DO I = ILPB, NATO
          CALL PLUT15 (-1, I, 32, IVAL)
          IF (IVAL == 1) THEN
            CALL PLUT15 (1, I, 27, NINCL)
          END IF
        END DO
C * (IN/EX)CLUDE ZOMBIES
      ELSE IF (NTXT == 'ZOM') THEN
        IPR(166) = NINC
        IPR(130) = 0
C * OMIT OUTSIDE
      ELSE IF (NTXT == 'OUT') THEN
C * SET DEFAULT ENCLOSURE VALUES
        DO I = 1, 3
          PAR(I * 2 + 28) =  1.01
          PAR(I * 2 + 27) = -0.01
        END DO
        PAR(35) = 4.5
C * SET ENCLOSURE BIT ON (I.E. ONLY ATOMS WITHIN ENCLOSURE TO BE PLOTTED)
        IF (KL == 3) THEN
          CALL PLUT13 (0, KL, M, XDUM)
        ELSE
          M = 0
        END IF
        IF (KN == 0 .AND. M <= 0) THEN
          IPR(15) = 1
        ELSE IF (KN == 1) THEN
          PAR(35) = FN(1)
          IF (PAR(35) > 0.0) THEN
            IPR(15) = - M
          ELSE
C * SET ENCLOSURE BIT OFF
            IPR(15) = 0
          END IF
        ELSE IF (KN == 6) THEN
          DO I = 1, KN
            PAR(I + 28) = FN(I)
          END DO
          IF (M > 0) THEN
            DO I = 1, 3
              DO J = 27, 28
                PAR(I * 2 + J) = PAR(I * 2 + J) + RA(M * NP43 + I)
              END DO
            END DO
          END IF
          IPR(15) = 1
        ELSE
          IPR(72) = 31
        END IF
      ELSE
        DO K = 2, KL
C * (IN/EX)CLUDE UNIQUE
           IF (IFL(K)(1:3) == 'UNI') THEN
             M = NATO + 1
             IF (M <= NATOS) THEN
               DO I = M, NATOS
                  CALL PLUT15 (1, I, 27, NINCL)
               END DO
             END IF
C * (IN/EX)CLUDE INTER
           ELSE IF (IFL(K)(1:3) == 'INT') THEN
             M = NATOS + 1
             IF (M <= NAT) THEN
               DO I = M, NAT
                 CALL PLUT15 (1, I, 27, NINCL)
               END DO
             END IF
C * (IN/EX)CLUDE ORIG
           ELSE IF (IFL(K)(1:3) == 'ORI') THEN
             DO I = ILPB, NATO
               CALL PLUT15 (1, I, 27, NINCL)
             END DO
C * (IN/EX)CLUDE ATOM-TYPE/ATOM-NAME
           ELSE
             IF (IS == 89 .OR. IS == 159) THEN
               CALL PLUT13 (0, K, M, XDUM)
             ELSE
               CALL PLUT13 (0, -K, M, XDUM)
             END IF
C * EXCLUDE ON ELEMENT TYPE
             IF (M < 0) THEN
               IBEG = ILPB
               IF (NINC == 0) THEN
                 IEND = NAT
               ELSE
                 IEND = NATO
               END IF
C * EXCLUDE ON ATOM NAME
             ELSE
               CALL PLUT25 (0, M, IAI)
               IBEG = M
               IEND = M
               M    = - IAI
             END IF
             DO I = IBEG, IEND
               CALL PLUT25 (0, I, IAI)
               IF (IAI == - M) THEN
                 IF (IS == 89 .OR. IS == 159) THEN
                   IVAL = 0
                   CALL PLUT15 (6, I, 18, IVAL)
                   CALL PLUT25 (1, I, IDUM2)
                   CALL PLUT29 (4, NQ1, NQ2, 0, 0)
                 ELSE
                   CALL PLUT15 (1, I, 27, NINCL)
                 END IF
               END IF
             END DO
           END IF
        END DO
      END IF
C * ELIMINATE DELETED ATOMS AND DO RESET MODE 2 FOR DELETE ATOMS CASE
      IF (IS == 89 .OR. IS == 159) THEN
        L = IPR(69)
        DO I = ILPB, NATO
          CALL PLUT15 (-6, I, 18, IMULT)
          IF (IMULT > 0) THEN
            L = L + 1
            DO K = 1, 12
              RA(L * NP43 + K) = RA(I * NP43 + K)
            END DO
          END IF
        END DO
        IPR(37)  = L
        IPR(38)  = L
        IPR(39)  = L
        IPR(170) = 2
      END IF
      RETURN
      END SUBROUTINE PLUT09
 
      SUBROUTINE PLUT10
C * BOND DRAWING
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      USE cggt
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: IO
      INTEGER               :: L0
      INTEGER               :: L4
      INTEGER               :: I1
      INTEGER               :: IG
      INTEGER               :: NN
      INTEGER               :: NAB
      INTEGER               :: III
      INTEGER               :: IIN
      INTEGER               :: IDF
      INTEGER               :: IDL
      INTEGER               :: IDR
      INTEGER               :: NDL
      INTEGER               :: NDR
      INTEGER               :: NLIN
      INTEGER               :: NDL1
      INTEGER               :: NDR1
      INTEGER               :: ILPB
      INTEGER               :: IDL1
      INTEGER               :: IDR1
      INTEGER               :: IADR
      INTEGER               :: ICOL
      INTEGER               :: ISTK
      INTEGER               :: JADR
      INTEGER               :: KADR
      INTEGER               :: JCOL
      INTEGER               :: INDX1
      INTEGER               :: INDX2
      INTEGER               :: INDX3
      INTEGER               :: NPROP
      INTEGER               :: NINCL
      INTEGER               :: NBOND
      INTEGER               :: NBLNE
      INTEGER               :: NATOT
      INTEGER               :: KADR1
      INTEGER               :: JRADR
      INTEGER               :: JADR1
      INTEGER               :: IUASU
      INTEGER               :: IYANK
      INTEGER               :: ISTK1
      INTEGER               :: ISTK2
      INTEGER               :: IRADR
      INTEGER               :: ICOL1
      INTEGER               :: IDASH
      INTEGER               :: IDELD
      INTEGER               :: IPR120
      INTEGER               :: IPR151
      INTEGER               :: IPR152
      REAL                  :: CT
      REAL                  :: ST
      REAL                  :: XG
      REAL                  :: YG
      REAL                  :: ZG
      REAL                  :: CPH
      REAL                  :: CSS
      REAL                  :: RBO
      REAL                  :: SNS
      REAL                  :: SPH
      REAL                  :: RAK2
      REAL                  :: RAK3
      REAL                  :: DELT
      REAL                  :: DIST
      REAL                  :: THETA
      REAL                  :: RAXAV
      REAL                  :: RAXPL
      REAL                  :: RAYAV
      REAL                  :: RAYPL
      REAL                  :: RAXPL1
      REAL                  :: RAYPL1
      REAL                  :: DELCOL
      REAL                  :: PAR145
      REAL                  :: WRICOL
      REAL, DIMENSION(3, 3) :: YUNK
C * BOND MODE:
      PAR145  = 0.0
      CPH     = 0.0
      SPH     = 0.0
      IDF     = 0
      IRADR   = 0
      JRADR   = 0
      INDX1   = 0
      INDX2   = 0
      INDX3   = 0
      IDL1    = 0
      NDL1    = 0
      IDR1    = 0
      NDR1    = 0
      ICOL    = 0
      JCOL    = 0
      ISTK2   = 0
      ISTK    = IPR(158) + IPR(40) * NP0
      N       = 0
      NAB     = IPR(37) - IPR(69)
C * GET NR OF ATOM ITEMS
      NATOT   = IPR(62)
      ILPB    = IPR(69) + 1
C * SET DEFAULT BOND PARAMETERS
      PAR(37) = 0
C * GET CROT PARAMETERS
      IPR151 = IPR(151)
      IPR152 = IPR(152)
      IF (IPR151 > 0) THEN
        IF (IPR(116) /= 0) IPR(336) = 0
        PAR145   = PAR(145)   * IPR(164)
        CPH      = COS (PAR145 / RGBL(6))
        SPH      = SIN (PAR145 / RGBL(6))
        IDF      = NATOT * NP0
        DELCOL   = IPR(153)
        WRICOL   = IPR(154)
        PAR(146) = 0.0
        IRADR    = IPR(157)
        JRADR    = IPR(167)
C * ESTABLISH ROTATION AXIS
        INDX1    = IPR(155)
        INDX2    = 2
        INDX3    = 3
        IF (INDX1 == 2) THEN
          INDX2  = 1
          INDX3  = 3
          SPH    = - SPH
        ELSE IF (INDX1 == 3) THEN
          INDX2  = 1
          INDX3  = 2
        END IF
      END IF
C * PURE STICK MODE DRAW BOXES FOR ISOLATED ATOMS
      IF (IPR(4) == 0 .OR. IPR(151) > 0) THEN
        CSS = COS (6.0 / RGBL(6))
        SNS = SIN (6.0 / RGBL(6))
        DO K = 1, NATOT
          IF (IPR(116) /= 0) THEN
            I = IPR(158) + K * NP0
            J = IPR(168) + K * NP0
            RA(J - 3) =  CSS * RA(I - 3) + SNS * RA(I - 1)
            RA(J - 2) =  RA(I - 2)
            RA(J - 1) = -SNS * RA(I - 3) + CSS * RA(I - 1)
            RA(J)     =  RA(I)
          END IF
C * CHECK FOR INCLUDED
          IO = MOD (K - ILPB, NAB) + ILPB
          CALL PLUT15 (-1, IO, 27, NINCL)
          IF (NINCL /= 0) THEN
            CALL PLUT14 (-1, K, NPROP, IUASU, XYZK(1), XYZK(2),
     1                   XYZK(3), XYZK(4))
            IF (XYZK(4) < 0.0 .OR. XYZK(4) > 999.9) CYCLE
C * CHECK FOR ISOLATED ATOM STATUS
            IF (IO >= ILPB) THEN
              CALL PLUT15 (-4, IO, 33, NBOND)
            ELSE
              NBOND = 3
            END IF
C * GENERATE DIAMOND TO REPRESENT ISOLATED ATOM
            IF (NBOND == 0) THEN
              I = K * NP0 + IPR(158)
              CALL PLUT31 (I - NP0, -1.0)
              IF (IPR(151) > 0) RA(I) = 100000.0
            END IF
          END IF
        END DO
      END IF
C * LOOP OVER (ACTIVE) BONDS
C * INTERRUPT INTERCEPT
   10 IF (IPR(151) /= 0 .AND. IGBL(25) == 1) THEN
        XG = 0.0
        YG = 0.0
        ZG = 0.0
        IG = 9
        CALL GGIP (XG, YG, ZG, IG)
        IF (IG > 0) CC = .TRUE.
      END IF
      IF (CC) THEN
        IF (IPR(116) == 0) THEN
          IPR(346) =   IABS (IPR(346))
        ELSE
          IPR(346) = - IABS (IPR(346))
        END IF
        IPR(4) = IABS (IPR(4))
        GO TO 50
      END IF
      IPR(56) = 0
      IADR    = IPR(79)
C * LOOP OVER BONDS
   20 IPR(56) = IPR(56) + 1
      IF (IPR(151) <= 0) THEN
C * INTERRUPT INTERCEPT
        IF (CC) THEN
          IPR(346) = IABS (IPR(346))
          GO TO 50
        END IF
      END IF
      IF (IPR(56) > IPR(97)) THEN
        IPR151 = IPR151 - 1
        IF (IPR151 <= 0) THEN
          GO TO 40
        ELSE
          IF (CC) THEN
            IPR(346) = IABS (IPR(346))
            GO TO 50
          END IF
          PAR(146) = PAR(146) + PAR145
          JADR     = IRADR
          KADR     = JADR  + IDF
          JADR1    = JRADR
          KADR1    = JADR1 + IDF
          DO I = 1, NATOT
            RA(JADR + NP0)  = RA(KADR + NP0)
            RA(JADR + INDX1 + NP0 - 4) = RA(KADR + INDX1 + NP0 - 4)
            RAK2                       = RA(KADR + INDX2 + NP0 - 4)
            RAK3                       = RA(KADR + INDX3 + NP0 - 4)
            RA(JADR + INDX2 + NP0 - 4) =   CPH * RAK2 + SPH * RAK3
            RA(JADR + INDX3 + NP0 - 4) = - SPH * RAK2 + CPH * RAK3
            IF (IPR(116) /= 0) THEN
              RA(JADR1 + INDX1 + NP0 - 4) = RA(KADR1 + INDX1 + NP0 - 4)
              RA(JADR1 + NP0)  = RA(KADR1 + NP0)
              RAK2             = RA(KADR1 + INDX2 + NP0 - 4)
              RAK3             = RA(KADR1 + INDX3 + NP0 - 4)
              RA(JADR1 + INDX2 + NP0 - 4) =   CPH * RAK2 + SPH * RAK3
              RA(JADR1 + INDX3 + NP0 - 4) = - SPH * RAK2 + CPH * RAK3
            END IF
 
C * ROTATE DIAMONDS
            IF (RA(KADR + NP0) > 9999.0) THEN
              CALL PLUT31 (KADR, DELCOL)
              IF (IPR(116) /= 0) WRICOL = IPR(144)
              CALL PLUT31 (JADR, WRICOL)
              IF (IPR(116) /= 0) THEN
                CALL PLUT31 (KADR1, DELCOL)
                CALL PLUT31 (JADR1, FLOAT (IPR(143)))
              END IF
            END IF
            JADR    = JADR + NP0
            KADR    = KADR + NP0
            IF (IPR(116) /= 0) THEN
              JADR1 = JADR1 + NP0
              KADR1 = KADR1 + NP0
            END IF
          END DO
          IRADR = IRADR + IDF
          JRADR = JRADR + IDF
          IDF   = - IDF
          GO TO 10
        END IF
      END IF
C * CROT DELETE
      IF (IPR151 > 0) THEN
        IADR = IADR - 4
        IDL  = IRADR + NINT (RA(IADR + 1) * NP0)
        NDL  = IRADR + NINT (RA(IADR + 2) * NP0)
        IDR  = IDL   + IDF
        NDR  = NDL   + IDF
        IF (IPR(116) /= 0) THEN
          IDL1 = JRADR + NINT (RA(IADR + 1) * NP0)
          NDL1 = JRADR + NINT (RA(IADR + 2) * NP0)
          IDR1 = IDL1 + IDF
          NDR1 = NDL1 + IDF
        END IF
        IF (IPR151 < IPR152) THEN
          CALL GGIP (0.0, DELCOL, 0.0, 0)
          CALL GGIP (RA(IDL - 3), RA(IDL - 2), 0.0, 3)
          RAXPL = RA(NDL - 3)
          RAYPL = RA(NDL - 2)
          IF (IPR(336) == 1) THEN
            RAXAV = RA(IDL - 3) + (RAXPL - RA(IDL - 3)) / 2
            RAYAV = RA(IDL - 2) + (RAYPL - RA(IDL - 2)) / 2
            CALL GGIP (RAXAV, RAYAV, 0.0, 2)
          END IF
          CALL GGIP (RAXPL, RAYPL, 0.0, 2)
          IF (IPR(116) /= 0) THEN
            CALL GGIP (RA(IDL1 - 3), RA(IDL1 - 2), 0.0, 3)
            RAXPL1 = RA(NDL1 - 3)
            RAYPL1 = RA(NDL1 - 2)
            CALL GGIP (RAXPL1, RAYPL1, 0.0, 2)
          END IF
        END IF
C * CROT DRAW
        CALL GGIP (RA(IDR - 3), RA(IDR - 2), 0.0, 3)
        RAXPL = RA(NDR - 3)
        RAYPL = RA(NDR - 2)
        IF (IPR(336) == 0) THEN
          CALL GGIP (0.0, WRICOL, 0.0, 0)
        ELSE
          ICOL = MOD (IABS (INT (RA(IADR + 4))), 1024)
          JCOL = MOD(ICOL, 32)
          IF (JCOL > 0)  JCOL = IACL(JCOL)
          IF (JCOL == 0 .OR. JCOL == 17) JCOL = IPR(19)
          ICOL = ICOL / 32
          ICOL = IPR(19)
          IF (ICOL > 0)  ICOL = IACL(ICOL)
          IF (ICOL == 0 .OR. ICOL == 17) ICOL = IPR(19)
          CALL GGIP (0.0, FLOAT (ICOL), 0.0, 0)
          RAXAV = RA(IDR - 3) + (RAXPL - RA(IDR - 3)) / 2
          RAYAV = RA(IDR - 2) + (RAYPL - RA(IDR - 2)) / 2
          CALL GGIP (RAXAV, RAYAV, 0.0, 2)
          CALL GGIP (0.0, FLOAT (JCOL), 0.0, 0)
        END IF
        IF (IPR(116) /= 0) CALL GGIP (0.0, FLOAT (IPR(144)), 0.0, 0)
        CALL GGIP (RAXPL, RAYPL, 0.0, 2)
        IF (IPR(116) /= 0) THEN
          CALL GGIP (RA(IDR1 - 3), RA(IDR1 - 2), 0.0, 3)
          RAXPL1 = RA(NDR1 - 3)
          RAYPL1 = RA(NDR1 - 2)
          CALL GGIP (0.0, FLOAT (IPR(143)), 0.0, 0)
          CALL GGIP (RAXPL1, RAYPL1, 0.0, 2)
        END IF
        GO TO 20
      END IF
C * GET BOND CHARACTERISTICS
      IPR(67) = 0
      CALL PLUT16 (IPR(56), I1, I, N, RBO, NBLNE)
      IF (IPR(56) > IPR(68)) THEN
        IPR120 = IPR(120)
      ELSE
        IPR120 = 1
      END IF
C * CALL EXIT/STOP
      IF (I == 0) CALL GEN127 (' KAN NIET GOTO 20')
      IF (NBLNE < 0) THEN
        NBLNE = IABS (NBLNE)
        IDASH = 1
      ELSE
        IDASH = 0
      END IF
      PAR(37) = RBO * PAR(24)
      NN      = I
      IPR(67) = 5
C * OUTPUT BONDS TO POVRAY FILE
      IF (IPR(82) /= 0 .AND. IPR(116) <= 0) THEN
        III = IPR(125) + I * 4
        IIN = IPR(125) + N * 4
        IF (IPR(4) == 0) THEN
          IF (I <= IPR(69)) THEN
            CALL GEN040 (I, NQ1, IYANK)
          ELSE
            CALL PLUT25 (1, I, IYANK)
          END IF
          IF (N <= IPR(69)) THEN
            CALL GEN040 (N, NQ2, IYANK)
          ELSE
            CALL PLUT25 (2, N, IYANK)
          END IF
          IF (IPR(10) == 1) THEN
            WRITE (LU61, 99999, IOSTAT = IOST)
     1        NQ1, NQ2, RA(III - 2) - PAR(67),
     2        RA(III - 1) - PAR(68), -RA(III) + PAR(69),
     3        RA(IIN - 2) - PAR(67),  RA(IIN - 1) - PAR(68),
     4        -RA(IIN) + PAR(69), MAX (RBO, 0.05)
          END IF
        END IF
      END IF
      IF (IPR(4) > 0) THEN
C * CHECK FOR INTERRUPT
        IF (IGBL(25) * IGBL(32) == 1) THEN
          XG = 0.0
          YG = 0.0
          ZG = 0.0
          IG = 9
          CALL GGIP (XG, YG, ZG, IG)
          IF (IG == 3) THEN
            IPR(45) = 1
            GO TO 50
          END IF
        END IF
C * FIND OBSCURATIONS FOR THIS BOND (WITH PSEUDO ATOMS AS END-POINTS)
        CALL PLUT18 (IPR(40) + 1, IPR(40) + 2)
C * NOW WE CAN DRAW THE BOND I TO N, UNLESS FOUND TO BE FULLY OBSCURED
        IF (IPR(78) < 0)  GO TO 20
      ELSE
        IPR(78) = 0
      END IF
C * BOND MODE
      IF (NBLNE > 1) THEN
        DELT = RGBL(5) / (2 * FLOAT (NBLNE - 1))
      ELSE
        DELT = 0.0
      END IF
C * STICK MODE
      IF (IPR(4) == 0) THEN
C * CHECK FOR COLOR ON
        IF (IPR(346) == 1) THEN
          NBLNE = 2
          IF (IPR(477) == 0 .AND. IPR(120) /= 0) THEN
            ICOL = IACL(IPR(120) / 32)
            IF (ICOL == 17) ICOL = IPR(19)
            JCOL = IACL(MOD (IPR(120), 32))
            IF (JCOL == 17) JCOL = IPR(19)
          ELSE
            ICOL = IPR(120)
            JCOL = IPR(120)
          END IF
        END IF
      END IF
      ZU(4) = 0.0
      ZU(5) = 0.0
      ZU(6) = 1.0
C * SET UP COORD SYSTEM FOR THE SEMI-CIRCLE CROSS SECTION OF BOND
      CALL GEN008 (ZU(4), ZU(7), ZU(1), 1)
      CALL GEN008 (ZU(7), ZU(1), ZU(4), 1)
      DIST  = 0
      L0    = - 2
      IDELD = 2
      ISTK1 = ISTK
      IF (IDASH == 1) THEN
        ISTK1 = ISTK + 2 * NP0
        ISTK2 = ISTK + 4 * NP0
        DO L = 1, 3
          L4 = NP0 + L - 4
          DIST = DIST + (RA(ISTK + NP0 + L4)
     1         - RA(ISTK + L4)) ** 2
        END DO
        IDELD = NINT (3.0 * SQRT (DIST) / PAR(24)) * 2 + 1
        DO L = 1, 3
          L4 = NP0 + L - 4
          RA(ISTK2 + L4) = (RA(ISTK + NP0 + L4)
     1                   - RA(ISTK + L4)) / IDELD
        END DO
        RA(ISTK2 + NP0) = (RA(ISTK + 2 * NP0)
     1                  - RA(ISTK + NP0)) / IDELD
      END IF
   30 L0 = L0 + 2
      IF (L0 >= IDELD) GO TO 20
      IF (IDASH == 1) THEN
        DO L = 1, 4
          L4 = NP0 + L - 4
          RA(ISTK1 + L4)       = RA(ISTK  + L4)
     1                         + RA(ISTK2 + L4) *  L0
          RA(ISTK1 + NP0 + L4) = RA(ISTK  + L4)
     1                         + RA(ISTK2 + L4) * (L0 + 1)
        END DO
      END IF
      IF (IPR(10) == 1 .AND. IPR(4) /= 0) THEN
        IF (I <= IPR(69)) THEN
          CALL GEN040 (I, NQ1, IYANK)
        ELSE
          CALL PLUT25 (1, I, IYANK)
        END IF
        IF (N <= IPR(69)) THEN
          CALL GEN040 (N, NQ2, IYANK)
        ELSE
          CALL PLUT25 (2, N, IYANK)
        END IF
        WRITE (LU61, 99999, IOSTAT = IOST)  NQ1, NQ2,
     1    RA(ISTK1 + NP0 - 3) / PAR(24),
     2    RA(ISTK1 + NP0 - 2) / PAR(24),
     3   -RA(ISTK1 + NP0 - 1) / PAR(24) - PAR(66) + PAR(69),
     4    RA(ISTK1 + 2 * NP0 - 3) / PAR(24),
     5    RA(ISTK1 + 2 * NP0 - 2) / PAR(24),
     6   -RA(ISTK1 + 2 * NP0 - 1) / PAR(24) - PAR(66) + PAR(69),
     7    MAX (RBO, 0.05)
      END IF
      NN    = I
      THETA = 0.0
      NLIN  = 0
C * SET UP POINTS ON SEMICIRCLE AT CENTRES OF ATOMS
      DO
        CT = COS (THETA)
        ST = SIN (THETA)
        DO L = 1, 3
          L4 = NP0 + L - 4
          XYZPL(L)     = (ZU(L) * CT + ZU(3 + L) * ST)
     1                 * RA(ISTK1 + NP0) + RA(ISTK1 + L4)
          XYZPL(L + 3) = (ZU(L) * CT + ZU(3 + L) * ST)
     1                 * RA(ISTK1 + 2 * NP0) + RA(ISTK1 + NP0 + L4)
        END DO
C * START PLOTTING THE LINE XSTART-XEND
        NLIN = NLIN + 1
C * DRAW THIS LINE, TEST FOR OBSCURATION OF THIS BOND BY ATOMS/BONDS
        IF (IPR(4) == 0) THEN
          IF (IPR(346) == 1) THEN
            IF (NN > 0) THEN
              ICOL1 = ICOL
            ELSE
              ICOL1 = JCOL
            END IF
            IF (ICOL1 == 0 .OR. ICOL1 > 15) ICOL1 = IPR(19)
            CALL GGIP (0.0, FLOAT (ICOL1), 0.0, 0)
          END IF
        ELSE
          IF (IPR(477) /= 0) THEN
            ICOL1 = IPR120
            IF (ICOL1 <= 0 .OR. ICOL1 > 15) ICOL1 = IPR(19)
            CALL GGIP (0.0, FLOAT (ICOL1), 0.0, 0)
          END IF
        END IF
        IF (IPR(10) <= 0) CALL PLUT19 (0, NN)
        IF (NLIN >= NBLNE)  GO TO 30
C * DRAW NEXT LINE IN REVERSE DIRECTION
        NN    = - NN
        THETA = THETA + DELT
      END DO
   40 IF (IPR(82) /= 0 .AND. IPR(116) <= 0) THEN
        IF (IPR(10) == 1) THEN
          WRITE (LU61, 99998, IOSTAT = IOST) PAR(24) * 0.16
          IPR(10) = 0
        ELSE IF (IPR(10) == 2) THEN
          IPR(10) = 0
        END IF
      END IF
C * APPLY CROT TO MATRIX
   50 IF (PAR(146) /= 0) THEN
        CALL GEN043 (IPR(155), A, PAR(146) / RGBL(6))
        CALL GEN004 (A, R, YUNK)
        CALL GEN052 (YUNK, R)
        PAR(146) = 0
        IPR(151) = -1
      END IF
      RETURN
99999 FORMAT ('// bond ', A, 1X, A, ' 1', /,
     1        10X, 'cylinder { ', /, 15X, '<', F9.4, ',', F9.4, ',',
     2        F9.4, ' > , < ', F9.4, ',', F9.4, ',', F9.4, ' >,', /,
     3        F7.3, /,
     4        15X, 'texture { pigment { color color_bond }', /,
     5        15X, 'finish { finish_all } } }')
99998 FORMAT ('scale', F7.3, /, 'rotate y*180', /, 'translate y*-0.25',
     1 /, '}', /, '// End-of-Plot')
      END SUBROUTINE PLUT10
 
      SUBROUTINE PLUT11
C * SUBROUTINE DRAWS THE VARIOUS PROJECTION SPHERE OUTLINES,
C * ATOM-ATOM AND ATOM-BOND INTERSECTIONS.
      USE parameters
      USE atomdata
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: M
      INTEGER :: MP
      INTEGER :: IG
      INTEGER :: IO
      INTEGER :: NJ
      INTEGER :: NL
      INTEGER :: NN
      INTEGER :: NRS
      INTEGER :: IVL
      INTEGER :: NAB
      INTEGER :: NEL
      INTEGER :: NPNT
      INTEGER :: NPRC
      INTEGER :: NPRH
      INTEGER :: MODE
      INTEGER :: IVAL
      INTEGER :: IPOP
      INTEGER :: ILPB
      INTEGER :: IDUM
      INTEGER :: IASU
      INTEGER :: NPRV
      INTEGER :: NTRCE
      INTEGER :: NPRVM
      INTEGER :: NPROP
      INTEGER :: NPRHM
      INTEGER :: NINCL
      INTEGER :: ICOL0
      INTEGER :: ISEGM
      INTEGER :: NATOT
      INTEGER :: NDOTS
      INTEGER :: ISHADE
      REAL    :: PI
      REAL    :: XG
      REAL    :: YG
      REAL    :: ZG
      REAL    :: RJB
      REAL    :: RJK
      REAL    :: RKK
      REAL    :: RIN
      REAL    :: PHI
      REAL    :: ANG
      REAL    :: DKJ
      REAL    :: CHI
      REAL    :: DIN
      REAL    :: DMG
      REAL    :: DSQ
      REAL    :: SCHI
      REAL    :: CDTH
      REAL    :: XLNG
      REAL    :: XPL1
      REAL    :: XPL2
      REAL    :: XPL3
      REAL    :: DMARG
      REAL    :: PDTHH
      REAL    :: PDTHV
      REAL    :: GEN013
      NAB   = IPR(37) - IPR(69)
      NATOT = IPR(62)
      ILPB  = IPR(69) + 1
C * NO SPHERE PLOTTING IN STICK-MODE
C * NEGATIVE IPR(4) : CPK + STICK
      IF (IPR(4) /= 0) THEN
C * LOOP OVER ALL ATOMS K IN PLOT ARRAY
        DO 30 K = ILPB, NATOT
          IO = MOD(K - ILPB, NAB) + ILPB
          CALL PLUT15 (-1, IO, 27, NINCL)
          IF (NINCL /= 0) THEN
C * CHECK FOR INTERRUPT
            IF (IGBL(25) * IGBL(32) == 1) THEN
              XG = 0.0
              YG = 0.0
              ZG = 0.0
              IG = 9
              CALL GGIP (XG, YG, ZG, IG)
              IF (IG == 3) THEN
                IPR(45) = 1
                GO TO 40
              END IF
            END IF
            IF (K <= IPR(37)) THEN
              IF (IPR(130) == 0) THEN
                IVAL = 1
                CALL PLUT15 (1, K, 45, IVAL)
              END IF
            END IF
C * RESET PSEUDO ATOM STACK
            IPR(67) = 0
C * DRAW THE CIRCLE REPRESENTING THE SPHERE PROJECTED ON THE XY-PLANE.
C * GET X, Y, Z AND R DATA FOR ATOM K AND STORE IN XYZK(1:4).
            CALL PLUT14 (-1, K, IASU, NPROP, XYZK(1), XYZK(2), XYZK(3),
     1                                 XYZK(4))
C * EXCLUDE ATOMS WITH NEGATIVE RADIUS OR DUPLICATE ATOMS
            IF (XYZK(4) < 0 .OR. XYZK(4) > 999.9)  GO TO 30
C * GET LIST OF ATOMS AND BONDS WHICH OBSCURE ATOM K
            CALL PLUT18 (K, 0)
C * DO NOT DRAW TOTALLY OBSCURED ATOMS
            IF (IPR(78) < 0) THEN
C * REGISTER FULLY OVERLAPPED ATOMS FOR NOT LABELLING
              IF (K <= IPR(37)) THEN
                IVAL = 0
                CALL PLUT15 (1, K, 45, IVAL)
              END IF
            ELSE
C * GET SERIAL NUMBER OF ELEMENT TYPE IN ARRAY IEN FOR THIS ATOM
              NEL    = INT(RA(IO * NP43 + 7) / 64000) + 1
              ISHADE = 0
              NPRC   = 1
              NPRH   = 0
              NPRV   = 0
              NPRHM  = 0
              NPRVM  = 0
              NDOTS  = 0
              ISEGM  = 0
              PAR(7) = 0.0
              PAR(8) = 0.0
C * DETERMINE COLOR SETTINGS
              IF (IPR(346) == 1) THEN
                ISHADE = 1
                PAR(6) = PAR(23)
                IF (IPR(477) == 0) THEN
                  ICOL0 = IACL(NEL)
                  IF (ICOL0 > 8) ICOL0 = 0
                ELSE IF (IPR(477) < 0) THEN
                  CALL PLUT15 (-6, IO, 5, NRS)
                  IF (NRS > 0 .AND. NRS <= 8) THEN
                    ICOL0 = NCRS(NRS)
                  ELSE
                    ICOL0 = 0
                  END IF
                ELSE
C * ARU-SPECIFIED COLOR
                  CALL GEN048 (-5, NPROP, 1, ICOL0)
                END IF
                IF (ICOL0 == 0 .OR. ICOL0 > 16) THEN
                  IF (IABS (IPR(477)) == 1) THEN
                    ICOL0 = IPR(19)
                  ELSE
                    ISHADE = 0
                  END IF
                END IF
                IPR(88) = ICOL0
              END IF
              PAR(130) = 0.0
              PAR(131) = 0.0
C * DETERMINE PARAMETERS FOR B&W COLOR
              IF (IPR(345) == 1) THEN
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                IF (IPR(478) == 0) THEN
                  IF (IPR(461) == 0) THEN
                    IPR(162) = IBCL(NEL)
                  ELSE
                    IPR(162) = IPR(139)
                  END IF
                ELSE IF (IPR(478) < 0) THEN
                  CALL PLUT15 (-6, IO, 5, NRS)
                  IF (NRS > 0 .AND. NRS <= 16) THEN
                    IPR(162) = NPRS(NRS)
                  ELSE
                    IPR(162) = 0
                  END IF
                ELSE
C * ARU SPECIFIC
                  CALL GEN048 (-5, NPROP, 6, IPR(162))
                END IF
              ELSE
                IPR(162) = IPR(139)
              END IF
C * CONTOUR
              IF (IPR(162) == 1) THEN
                NPRC   = NINT (IPR(8) * PAR(24) / 4) + 1
                ISHADE = 0
              END IF
C * NET
              IF (IPR(162) == 2) THEN
                IF (IPR(4) == 3) THEN
                  NPRH = IPR(85) + 10
                  NPRV = IPR(86) + 10
                ELSE
                  NPRH = IPR(85)
                  NPRV = IPR(86)
                END IF
                NPRH = NINT (NPRH * PAR(24) / 4)
                NPRV = NINT (NPRV * PAR(24) / 4)
                ISHADE = 0
C * CROSS
              ELSE IF (IPR(162) == 7) THEN
                NPRH   = 3
                NPRV   = 3
                NPRHM  = 2
                NPRVM  = 2
                ISHADE = 0
C * GLOBE
              ELSE IF (IPR(162) == 8) THEN
                IF (IPR(4) == 3) THEN
                  NPRC = IPR(112) * 2
                  NPRV = IPR(132) * 2
                ELSE
                  NPRC = IPR(112)
                  NPRV = IPR(132)
                END IF
                NPRC     = NINT (NPRC * PAR(24) / 4)
                NPRV     = NINT (NPRV * PAR(24) / 4)
                PAR(130) = -45.0
                PAR(131) = -35.0
                ISHADE   = 0
C * SET SPECIAL SHADE IN SPOT/GLOBE MODE
                IF (IPR(96) == 1) THEN
                  ISHADE = 1
                  PAR(6) = 0.075
                  PAR(7) = 145.0
                  PAR(8) = -55.0
                END IF
C * PARAL
              ELSE IF (IPR(162) == 9) THEN
                NPRC     = NINT (IPR(112) * PAR(24) / 4)
                NPRV     = 0
                ISHADE   = 0
                PAR(130) = -45.0
                PAR(131) = -35.0
C * MERID
              ELSE IF (IPR(162) == 10) THEN
                NPRC     = 0
                NPRV     = NINT (IPR(132) * PAR(24) / 4)
                ISHADE   = 0
                PAR(130) = -45.0
                PAR(131) = -35.0
              END IF
C * SHADE
              IF (IPR(162) == 3) THEN
                ISHADE = 1
                PAR(6) = PAR(134)
                PAR(7) = PAR(135)
                PAR(8) = PAR(136)
C * HORIZONTAL
              ELSE IF (IPR(162) == 11) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 0.0
C * VERTICAL
              ELSE IF (IPR(162) == 12) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 90.0
C * MESH
              ELSE IF (IPR(162) == 13) THEN
                ISHADE = 2
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 0.0
C * DIAGONAL
              ELSE IF (IPR(162) == 14) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = -45.0
C * SLANT
              ELSE IF (IPR(162) == 15) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 45.0
C * TEXTILE
              ELSE IF (IPR(162) == 16) THEN
                ISHADE = 2
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = -45.0
C * BLACK
              ELSE IF (IPR(162) == 6 .AND. NEL /= 1) THEN
                ISHADE = 1
                PAR(6) = PAR(23)
              END IF
C * SEGMENT
              IF (IPR(162) == 4) THEN
                ISEGM  = 1
                NPRC   = 3
                ISHADE = 0
              END IF
C * DOTS
              IF (IPR(162) == 5) THEN
                NDOTS  = 1
                ISHADE = 0
              END IF
C * DETERMINE NET PARAMETERS FOR THIS ATOM
C * BUT NO NET FOR H-ATOMS
              IF (NEL == 1) THEN
                IF (IPR(162) == 0) THEN
                  NPRH  = 0
                  NPRV  = 0
                  NPRC  = 0
                  ISEGM = 0
                  NDOTS = 0
                END IF
              END IF
              IF (NPRH > 0) THEN
                PDTHH = 180.0 / (NPRH * RGBL(6))
              ELSE
                PDTHH = 0.0
              END IF
              IF (NPRV > 0) THEN
                PDTHV = 180.0 / (NPRV * RGBL(6))
              ELSE
                PDTHV = 0.0
              END IF
C * DETERMINE CONTOUR PARAMETERS
              IF (NPRC > 0) THEN
                CDTH = 90.0 / (NPRC * RGBL(6))
              ELSE
                CDTH =  0.0
              END IF
C * HANDLE SHADE/COLOR OPTION FIRST (IN VIEW OF WET INKING PROBLEMS)
              IF (IPR(346) > 0 .OR. NEL /= 1 .OR.
     1           IABS (IPR(4)) >= 3) THEN
                IF (ISHADE > 0 .AND. IPR(78) >= 0) THEN
                  CALL PLUT36 (K, ISHADE)
                END IF
              END IF
C * DOTS
              IF (NDOTS > 0) THEN
                NPNT = NINT (IPR(124) * RADR(NEL, 1)**2)
C * SELECT COLOR
                IF (IPR(346) == 1 .AND. IPR(139) == 5) THEN
                  CALL GGIP (0.0, FLOAT (ICOL0), 0.0, 0)
                END IF
                PI    = RGBL(5) / 2.0
                IDUM  = -1
                DO J = 1, NPNT
                  PHI  = GEN013 (IDUM) * 2 * PI
                  CHI  = SQRT (GEN013 (IDUM) * GEN013 (IDUM)) *
     1                   (1.0 + 0.99 * COS ((PHI - PI) / 2)) / 2
                  CHI  = ATAN (SQRT (1 - (CHI**2)) / CHI)
                  SCHI = SIN(CHI) * XYZK(4)
                  XPL1 = SCHI * COS (PHI)
                  XPL2 = SCHI * SIN (PHI)
                  XPL3 = SQRT (ABS (XYZK(4)**2 - XPL1**2 - XPL2**2))
                  XYZPL(1) = XYZK(1) + XPL1
                  XYZPL(2) = XYZK(2) + XPL2
                  XYZPL(3) = XYZK(3) + XPL3
                  XYZPL(4) = XYZPL(1)
                  XYZPL(5) = XYZPL(2)
                  XYZPL(6) = XYZPL(3)
C * SELECT COLOR
                  IF (IPR(346) == 1 .AND. IPR(139) == 0) THEN
                    CALL GGIP (0.0, FLOAT (ICOL0), 0.0, 0)
                  END IF
C * TEST FOR OBSCURATION OF THIS POINT
                  NN = 1
                  CALL PLUT19 (K, NN)
                END DO
              END IF
              DO I = 1, 4
                PAR(70 + I) = XYZK(I)
              END DO
C * DETERMINE NUMBER OF SEGMENTS PER 180 DEGREES
              MP = MAX (NINT (PAR(125) * SQRT (PAR(74) * 10.0)), 5)
              IF (IPR(78) == 0) THEN
                IPR(91) = MP
              ELSE
                IPR(91) = MAX (NINT (RGBL(5) * PAR(74) * IPR(111) /
     1                    (4 * PAR(5)) + 1), 5)
              END IF
              PAR(55) = RGBL(5) / FLOAT (IPR(91) * 2)
              PAR(56) = RGBL(5) / FLOAT (MP * 2)
C * TEST THE CIRCLE AS THE SEQUENCE OF NPP LINES
              IF (ABS(PAR(130)) + ABS(PAR(131)) < 0.001) THEN
                NTRCE = 0
              ELSE
                NTRCE = - NPRC
              END IF
              IPR(87) = 2
              PAR(57) = 0.0
              CALL GEN074 (ZU, 2, 15, 0.0)
C * HANDLE SEGMENT PLOT (EXCLUDING H-ATOMS)
              IF (ISEGM == 1 .AND. NEL > 1) THEN
                PAR(57) = 180.0 / RGBL(6)
                IPR(114) = INT (RGBL(5) / (3.0 * PAR(55)))
              END IF
C * CONTOUR LOOP
              DO WHILE (NTRCE < NPRC)
                NTRCE = NTRCE + 1
                IF (IPR(346) == 1)
     1            CALL GGIP (0.0, FLOAT (ICOL0), 0.0, 0)
                PAR(74) = XYZK(4) * COS (NTRCE * CDTH)
                ZU(10)  = 1.0
                ZU(11)  = 0.0
                ZU(12)  = 0.0
                ZU(13)  = 0.0
                ZU(14)  = 1.0
                ZU(15)  = 0.0
                ANG     = PAR(130)
C * GLOBE/PARALLEL OPTION
                IF (IPR(162) == 8 .OR. IPR(162) == 9) THEN
                  ANG = ANG + 90.0
                END IF
                CALL GEN043 (1, A, ANG / RGBL(6))
                CALL GEN002 (1, A, ZU(10), ZU(4), XLNG)
                CALL GEN002 (1, A, ZU(13), ZU(7), XLNG)
C * ROTATE CONTOUR-LEVEL VECTOR
                ZU(13) = 0.0
                ZU(14) = 0.0
                ZU(15) = XYZK(4) * SIN (NTRCE * CDTH)
                CALL GEN002 (1, A, ZU(13), ZU(10), XLNG)
                CALL GEN043 (2, A, PAR(131) / RGBL(6))
                CALL GEN002 (1, A, ZU(4), ZU(1), XLNG)
                CALL GEN002 (1, A, ZU(7), ZU(4), XLNG)
                CALL GEN002 (1, A, ZU(10), ZU(7), XLNG)
                DO I = 1, 3
                  PAR(70 + I) = XYZK(I) + ZU(6 + I)
                END DO
                CALL PLUT19 (0, 0)
              END DO
C * DRAW NET ON ATOM SURFACE
              IPR(114) = 0
              DO I = 1, 4
                PAR(70 + I)  = XYZK(I)
              END DO
              IPR(87) = 1
              DO WHILE (NPRV > NPRVM)
                NPRV = NPRV - 1
C * AVOID DOUBLE CIRCLE PLOT
                IF (NPRV == 0) THEN
                  IF (ABS (PAR(130)) + ABS (PAR(131)) < 0.001) EXIT
                END IF
                IF (IPR(346) == 1) THEN
                  CALL GGIP (0.0, FLOAT (ICOL0), 0.0, 0)
                END IF
                ANG    = NPRV * PDTHV - PAR(131) / RGBL(6)
                ZU(10) = COS (ANG)
                ZU(11) = 0.0
                ZU(12) = SIN (ANG)
                ZU(13) = 0.0
                ZU(14) = 1.0
                ZU(15) = 0.0
                CALL GEN043 (1, A, PAR(130) / RGBL(6))
                CALL GEN002 (1, A, ZU(10), ZU(4), XLNG)
                CALL GEN002 (1, A, ZU(13), ZU(7), XLNG)
                CALL GEN043 (2, A, PAR(131) / RGBL(6))
                CALL GEN002 (1, A, ZU(4), ZU(1), XLNG)
                CALL GEN002 (1, A, ZU(7), ZU(4), XLNG)
C * CALCULATE ANGLE VALUE FOR INTERSECTION WITH XY-PLANE
                CALL GEN008 (ZU(1), ZU(4), ZU(7), 1)
                ZU(10) = 0.0
                ZU(11) = 0.0
                ZU(12) = 1.0
                CALL GEN008 (ZU(7), ZU(10), ZU(13), 1)
                PAR(57) = ACOS (ZU(1) * ZU(13) + ZU(2) * ZU(14)
     1                  + ZU(3) * ZU(15)) - RGBL(5) / 2.0
                CALL PLUT19 (0, 0)
              END DO
              IPR(87) = 1
              DO WHILE (NPRH > NPRHM)
                NPRH = NPRH - 1
                IF (NPRH == 0) THEN
                  IF (ABS (PAR(130)) + ABS (PAR(131)) < 0.001) EXIT
                END IF
                IF (IPR(346) == 1) THEN
                  CALL GGIP (0.0, FLOAT (ICOL0), 0.0, 0)
                END IF
                ANG = NPRH * PDTHH + PAR(130) / RGBL(6)
                ZU(10) = 1.0
                ZU(11) = 0.0
                ZU(12) = 0.0
                ZU(13) = 0.0
                ZU(14) = COS (ANG)
                ZU(15) = SIN (ANG)
                CALL GEN043 (1, A, PAR(130) / RGBL(6))
                CALL GEN002 (1, A, ZU(10), ZU(4), XLNG)
                CALL GEN002 (1, A, ZU(13), ZU(7), XLNG)
                CALL GEN043 (2, A, PAR(131) / RGBL(6))
                CALL GEN002 (1, A, ZU(4), ZU(1), XLNG)
                CALL GEN002 (1, A, ZU(7), ZU(4), XLNG)
C * CALCULATE ANGLE VALUE FOR INTERSECTION WITH XY-PLANE
                CALL GEN008 (ZU(1), ZU(4), ZU(7), 1)
                ZU(10) = 0.0
                ZU(11) = 0.0
                ZU(12) = 1.0
                CALL GEN008 (ZU(7), ZU(10), ZU(13), 1)
                PAR(57) = ACOS (ZU(1) * ZU(13) + ZU(2) * ZU(14)
     1                  + ZU(3) * ZU(15)) - RGBL(5) / 2.0
                CALL PLUT19 (0, 0)
              END DO
C * SELECT DEFAULT PEN
              IF (IPR(346) > 0) THEN
                IF (IPR(139) == 1 .AND. ICOL0 /= 0) THEN
                  CALL GGIP (0.0, FLOAT (ICOL0), 0.0, 0)
                ELSE
                  CALL GGIP (0.0, FLOAT (IPR(19)), 0.0, 0)
                END IF
              END IF
C * NOW WE CAN DRAW THE EQUATORIAL CIRCLE FOR ATOM K
              DO I = 1, 4
                PAR(70 + I) = XYZK(I)
              END DO
              IPR(87) = 2
              PAR(57) = 0.0
              CALL GEN074 (ZU, 1, 15, 0.0)
              ZU(1) = 1.0
              ZU(5) = 1.0
C * CIRCLE LOOP WITH OBSCURATION TEST
              IPR(129) = 0
              CALL PLUT19 (0, 0)
              IF (IPR(129) == 0) THEN
C * REGISTER FULLY OVERLAPPED ATOMS FOR NOT LABELLING
                IF (K <= IPR(37)) THEN
                  IVL = 0
                  CALL PLUT15 (1, K, 45, IVL)
                END IF
              END IF
C * DRAW CIRCLES SHOWING THE SECTION OF OVERLAP OF SPHERES.
              MODE = 0
   10         MODE = MODE - 1
              IF (MODE + IPR(78) < 0) GO TO 30
              IPOP = IPR(66) + MODE * 13
C * GET BONDS OUT OF ATOM K WITH PSEUDO ATOM ENDS NJ AND NL
              NJ = NINT (RA(IPOP + 1))
              IF (NJ > 0) GO TO 10
              NL = NINT (RA(IPOP + 2))
              DO I = 5, 8
                XYZK(I) = RA(IPOP + I - 2)
              END DO
              DMARG  = RA(IPOP + 13)
              DMG    = 0.0
   20         RJB    = XYZK(8) + DMG
              ZU(10) = 0.0
              ZU(11) = 0.0
              ZU(12) = 1.0
C * TESTS TO AVOID DRAWING EACH INTERSECTION MORE THAN ONCE
              DSQ    = 0
              DO M = 1, 3
                ZU(6 + M) = XYZK(M + 4) - XYZK(M)
                DSQ       = DSQ + ZU(6 + M)**2
              END DO
              IF (NL == 0) THEN
                IF (ZU(9) > 0.0)  GO TO 10
              END IF
C * GET THE DISTANCE ALONG LINE KJ OF THE PLANE OF THE INTERSECTION.
C * THIS IS CALCULATED BY SIMPLE COSINE FORMULA.
C * SEE SMITH & GUND, J. CHEM. INF. COMPUT. SCI., 18, 207, 1978.
              DKJ = SQRT(DSQ)
C * THIS IS A TEMP FIX
              IF (DKJ < 0.0001) GO TO 10
              RKK = XYZK(4)**2
              RJK = RJB**2
              DIN = (RKK + DSQ - RJK) / (2.0 * DKJ)
              RIN = RKK - DIN**2
C * THIS IS A TEMP. FIX
              IF (RIN < 0.0) GO TO 10
              PAR(74) = SQRT (RIN)
C * DIRECTION COSINES OF VECTOR
              DO I = 7, 9
                ZU(I)       = ZU(I) / DKJ
                PAR(64 + I) = XYZK(I - 6) + ZU(I) * DIN
              END DO
C * THE INTERSECTION CIRCLE HAS CENTRE AT (XB,YB,ZB) AND RADIUS RIN.
C * SET UP AXIAL SYSTEM WITH U3 ALONG DIRECTION KJ. THE CIRCLE IS
C * GENERATED AS COORDINATES  (XX,YY,0)
              IF (ZU(9) < 0.9999) THEN
                CALL GEN008 (ZU(10), ZU(7), ZU(1), 1)
              ELSE
                ZU(1) = 1.0
                ZU(2) = 0.0
                ZU(3) = 0.0
              END IF
              CALL GEN008 (ZU(7), ZU(1), ZU(4), 1)
              CALL PLUT19 (IABS (NJ), 0)
              IF (IPR(346) > 0 .AND. NL /= 0) THEN
                IF (DMARG > 0.0 .AND. IPR(88) > 0) THEN
                  DMG   = DMARG
                  DMARG = 0.0
                  GO TO 20
                END IF
              END IF
              GO TO 10
            END IF
          END IF
   30   CONTINUE
      END IF
   40 IF (IPR(346) > 0 .OR. IPR(477) < 0)
     1  CALL GGIP (0.0, FLOAT (IPR(19)), 0.0, 0)
      RETURN
      END SUBROUTINE PLUT11
 
      SUBROUTINE PLUT12
C * MANAGEMENT OF MOST PRINTING
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE pluto
      USE chdat
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: NC
      INTEGER           :: KL
      INTEGER           :: JF
      INTEGER           :: J0
      INTEGER           :: J1
      INTEGER           :: J2
      INTEGER           :: J4
      INTEGER           :: I0
      INTEGER           :: I1
      INTEGER           :: I2
      INTEGER           :: I4
      INTEGER           :: N1
      INTEGER           :: N2
      INTEGER           :: N3
      INTEGER           :: N4
      INTEGER           :: N5
      INTEGER           :: N6
      INTEGER           :: N7
      INTEGER           :: N8
      INTEGER           :: N9
      INTEGER           :: N10
      INTEGER           :: N11
      INTEGER           :: N12
      INTEGER           :: N13
      INTEGER           :: N14
      INTEGER           :: N15
      INTEGER           :: N16
      INTEGER           :: ILB
      INTEGER           :: IDH
      INTEGER           :: IMV
      INTEGER           :: NEL
      INTEGER           :: NLI
      INTEGER           :: NRF
      INTEGER           :: NRI
      INTEGER           :: NS2
      INTEGER           :: NRES
      INTEGER           :: NRBO
      INTEGER           :: JINC
      INTEGER           :: IDUM
      INTEGER           :: IAIO
      INTEGER           :: IATK
      INTEGER           :: IDET
      INTEGER           :: IPV1
      INTEGER           :: IPV2
      INTEGER           :: MULT
      INTEGER           :: NSYM
      INTEGER           :: NSPEC
      INTEGER           :: MADDR
      INTEGER           :: JDOAC
      INTEGER           :: IYUNK
      INTEGER           :: IROTX
      INTEGER           :: IROTY
      INTEGER           :: IROTZ
      INTEGER           :: IDUM2
      INTEGER           :: IDASH
      INTEGER           :: IPR90
      REAL              :: D
      REAL              :: RB
      REAL              :: RBO
      REAL              :: PHI
      REAL              :: ARU
      REAL              :: DUM1
      REAL              :: XDUM
      REAL              :: XTRF
      CHARACTER(len=1)  :: J3
      CHARACTER(len=1)  :: J5
      CHARACTER(len=1)  :: J6
      CHARACTER(len=1)  :: J7
      CHARACTER(len=1)  :: ICH
      CHARACTER(len=1)  :: JIN
      CHARACTER(len=1)  :: LFIX
      CHARACTER(len=11) :: ATPR1
      CHARACTER(len=5)  :: ATPR2
      CHARACTER(len=6)  :: PARAM
 
C * LIST INTERNAL TABLES ETC. ROUTINE
      IPR(21) = IPR(90)
      NSPEC   = IPR(41)
      NC      = IPR(52)
      NSYM    = IPR(48)
      KL      = IPR(220)
C * GET LIST OPTIONS FOR ARU'S, LINES, BONDS, ATOMS, SYMM AND PART
      DO I = 1, 9
        K           = 2**(10 - I)
        IPR(31 - I) = IPR(21) / K
        IPR(21)     = IPR(21) - IPR(31 - I) * K
      END DO
C * LIST SYMMETRY TABLE
      IF (IPR(22) == 1 .AND. IPR(50) == 0) CALL PLA274
C * TEST FOR INDIVIDUAL ATOM(S)/BOND(S) LIST REQUEST
      IPV1  = 0
      IPV2  = 0
      IPR90 = IPR(90)
C * SPECIFIED ATOM/BOND
C * TEST FOR LIST INTER
      IF (IGBL(31) == 1) KL = 2
      IF (IPR(147) > 0)  KL = 2
      IF (IABS (IPR90 - 6) == 2 .AND. KL > 2) THEN
        CALL PLUT13 (0, -3, IPV1, XDUM)
C * SPECIFIED BOND
        IF (IPR90 == 8 .AND. KL > 3) THEN
          CALL PLUT13 (0, -4, IPV2, XDUM)
        END IF
      END IF
C * LIST ATOMS
      IF (IPR(23) /= 0) THEN
        WRITE (LINE, 99991, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 0.4
          CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.4
        ELSE
          WRITE (LU6, 99970, IOSTAT = IOST) LINE
        END IF
        IF (IPV1 > 0) THEN
          I1 = IPV1
          I2 = IPV1
        ELSE
C * TEST FOR LIST INTER
          IF (IGBL(31) == 0) THEN
            IF (IPR(46) == 0) THEN
              I1 = IPR(69) + 1
            ELSE
              I1 = 1
            END IF
          ELSE
            I1 = IPR(38) + 1
          END IF
          I2 = IPR(37)
        END IF
        DO I = I1, I2
          CALL PLUT15 (-5, I, 48, IYUNK)
          CALL PLUT15 (-6, I, 5, NRES)
          IF (IPR(147) > 0) THEN
            IF (IPR(147) /= NRES) CYCLE
          END IF
          CALL PLUT25 (1, I, J4)
          IAIO = - J4
          IF (IPV1 >= 0 .OR. IAIO == IPV1) THEN
C * GET HBOND CHARACTERISTICS
            CALL PLUT15 (-1, I, 46, JDOAC)
            CALL PLUT15 (-1, I, 32, IDH)
            IF (JDOAC == 0 .AND. IDH == 0) THEN
              J6 = ' '
              J7 = ' '
            ELSE
              J6 = 'D'
              IF (IDH == 1) THEN
                J7 = 'H'
              ELSE
                J7 = 'A'
              END IF
            END IF
            NEL = INT (RA(I * NP43 + 7) / 64000) + 1
            CALL PLUT15 (-6, I, 18, JINC)
            CALL PLUT15 (-1, I, 27, J1)
            IF (J1 > 0) THEN
              JIN = '*'
            ELSE
              JIN  = ' '
            END IF
            IF (JINC >=  2) THEN
              J3 = 'S'
            ELSE
              J3 = ' '
            END IF
            CALL PLUT15 (-4, I, 37, ILB)
            J2   = ILB + 1
            CALL PLUT15 (-1, I, 42, JF)
            IF (JF == 1) THEN
              LFIX = '*'
            ELSE
              LFIX = '-'
            END IF
C * GET TRANSFORMATION ON INPUT
            CALL PLUT15 (-1, I, 43, IMV)
            IF (IMV > 0) THEN
              J5 = 'M'
            ELSE
              J5 = ' '
            END IF
            XTRF = RA(I * NP43 + 12)
C * HANDLE SPECIAL CASE OF UNITCELL
            IF (I <= IPR(69)) THEN
              NQ1(1:1) = 'O'
              IF (I == 1) THEN
                NQ1(2:2) = 'R'
              ELSE IF (I == 2) THEN
                NQ1(2:2) = 'C'
              ELSE IF (I == 3) THEN
                NQ1(2:2) = 'B'
              ELSE IF (I == 5) THEN
                NQ1(2:2) = 'A'
              ELSE
                NQ1(1:2) = '  '
              END IF
              WRITE (LINE, 99981, IOSTAT = IOST) NQ1(1:2),
     1        (RA(I * NP43 + K), K = 1, 3), JIN, LABP(J2), LFIX
            ELSE
              IF (JINC /= 0) THEN
                MULT = NSYM / JINC
              ELSE
                MULT = NSYM
              END IF
              WRITE (LINE, 99990, IOSTAT = IOST)
     1          NQ1(1:7), (RA(I * NP43 + K), K = 1, 3),
     2          (RADR(J4, 5 - K), K = 1, 4), MULT, J3, JIN, XTRF,
     3          J5, LABP(J2), LFIX, NRES, NEL, J6, J7
            END IF
            IF (IGBL(25) * IGBL(32) == 1) THEN
              IF (VRT - 0.4 < 0) THEN
C * WHAT NEXT ?
                CALL PLA012 (1, 1)
                ICH = IGGT(1:1)
                CALL GGIP (HORS, VERT, 0.0, 1)
                IF (ICH /= 'Y' .AND. ICH /= '!') GO TO 10
                  VRT = VERT
              END IF
              VRT = VRT - 0.4
              CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993, IOSTAT = IOST) LINE
            END IF
          END IF
        END DO
        GO TO 10
      END IF
C * LIST BONDS
      IF (IPR(24) /= 0) THEN
C * SKIP FOR NIL-BOND CASE
        IF (NC > IPR(68)) THEN
C * PRINT LIST HEADER
          WRITE (LINE, 99989, IOSTAT = IOST)
          IF (IGBL(25) * IGBL(32) == 1) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT - 0.4
            CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2,
     1                   1.0, VRT)
            VRT = VRT - 0.4
          ELSE
            WRITE (LU6, 99970, IOSTAT = IOST) LINE
          END IF
          NRBO = 0
C * SET SEARCH RANGE FOR BOND ATOM I
          IF (IPV1 > 0) THEN
            I1 = IPV1
            I2 = IPV1
          ELSE
            IF (IPR(46) == 0) THEN
              I1 = IPR(69) + 1
            ELSE
              I1 = 1
            END IF
            I2 = IPR(39)
          END IF
          DO I0 = I1, I2
C * TEST ON ELEMENT TYPE
            IF (IPV1 < 0) THEN
              I4 = INT (RA(I0 * NP43 + 7) / 64000)
              IF (IPV1 + I4 + 1 /= 0)  CYCLE
            END IF
C * TEST ON RESIDUE NUMBER
            IF (IPR(147) > 0) THEN
              CALL PLUT15 (-6, I0, 5, NRES)
              IF (IPR(147) /= NRES) CYCLE
            END IF
C * SET SEARCH RANGE FOR ATOM J
            IF (IPV2 > 0) THEN
              J1 = IPV2
              J2 = IPV2
            ELSE
C * TEST FOR LIST INTER
              IF (IGBL(31) == 0) THEN
                IF (IPV2 == 0) THEN
                  J1 = I0 + 1
                ELSE
                  J1 = 1
                END IF
              ELSE
                J1 = IPR(38) + 1
              END IF
              J2 = IPR(37)
            END IF
            DO J0 = J1, J2
C * TEST ON ELEMENT TYPE
              IF (IPV2 < 0) THEN
                J4 = INT (RA(J0 * NP43 + 7) / 64000)
                IF (IPV2 + J4 + 1 /= 0)  CYCLE
              END IF
C * GET LIST NR -K- FOR THIS BOND I0 - J0
              CALL PLUT16 (-4, K, I0, J0, DUM1, IDUM2)
              IF (K > IPR(68)) THEN
C * GET BOND DATA: I, J, RBO, NLI, IDASH
                CALL PLUT16 (0, K, I, J, RBO, NLI)
                IF (NLI < 0) THEN
                  NLI   = IABS (NLI)
                  IDASH = 1
                ELSE
                  IDASH = 0
                END IF
                IF (I /= 0) THEN
C * GET LABELS INTO NQ1 & NQ2
                  CALL PLUT25 (1, I, IDUM)
                  CALL PLUT25 (2, J, IDUM)
C * GET RESIDUE-NUMBER FOR ATOMS I
                  CALL PLUT15 (-6, I, 5, NRI)
C * GET THE ARU-CODE FOR THE SECOND ATOM
                  CALL PLUT15 (-6, J, 11, NS2)
                  ARU = MOL(1, NS2 + 1) / PAR(42)
C * GET DISTANCE
                  CALL PLUT22 (I, J, D)
                  NRBO = NRBO + 1
                  WRITE (LINE, 99988, IOSTAT = IOST) NRBO, NRI,
     1              NQ1(1:7), NQ2(1:7), ARU, D, RBO, NLI, IDASH
                  IF (IGBL(25) * IGBL(32) == 1) THEN
                    IF (VRT - 0.4 < 0) THEN
C * WHAT NEXT ?
                      CALL PLA012 (1, 1)
                      ICH = IGGT(1:1)
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      IF (ICH /= 'Y' .AND. ICH /= '!') GO TO 10
                      VRT = VERT
                    END IF
                    VRT = VRT - 0.4
                    CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
                  ELSE
                    WRITE (LU6, 99993, IOSTAT = IOST) LINE
                  END IF
                END IF
              END IF
            END DO
          END DO
        END IF
        GO TO 10
      END IF
C * LIST BOND-TYPES
      IF (IPR(25) /= 0) THEN
        IF (IPR(12) < 0) THEN
          IDASH = 1
        ELSE
          IDASH = 0
        END IF
        WRITE (LINE, 99987, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 1.5
          CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.8
        ELSE
          WRITE (LU6, 99992, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99986, IOSTAT = IOST)
     1    PAR(38), IABS (IPR(12)), IDASH
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.6
          CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99993, IOSTAT = IOST) LINE
        END IF
        DO K = 1, NSPEC
          NRF = IPR(80) - (K - 1) * 3
          L   = NINT (RA(NRF - 2))
          I   = IABS (L) / 1000
          RB  = 0.001 * FLOAT (MOD (IABS (L), 1000))
          N1  = NINT (RA(NRF))
          N2  = NINT (RA(NRF - 1))
          IF (L < 0) THEN
            IDASH = 1
          ELSE
            IDASH = 0
          END IF
          IF (N1 < 0) THEN
            WRITE (LINE, 99985, IOSTAT = IOST) RB, I, IDASH
            IF (IGBL(25) * IGBL(32) == 1) THEN
              VRT = VRT - 0.6
              CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993, IOSTAT = IOST) LINE
            END IF
          ELSE IF (N1 == 0) THEN
            N2 = NINT (RA(NRF - 1))
            IF (N2 <= 0) THEN
              N2 = IEL(IEN( - N2))
              N1 = N2 / 100 + ICHAR ('A') - 1
              N2 = MOD(N2, 100)
              IF (N2 == 0) THEN
                N2 = ICHAR (' ')
              ELSE
                N2 = N2 + ICHAR ('a') - 1
              END IF
              NQ1 = CHAR(N1)//CHAR (N2)//'     '
            ELSE
              CALL PLUT25 (1, N2, IATK)
            END IF
            WRITE (LINE, 99983, IOSTAT = IOST) NQ1, RB, I, IDASH
            IF (IGBL(25) * IGBL(32) == 1) THEN
              VRT = VRT - 0.6
              CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993, IOSTAT = IOST) LINE
            END IF
          ELSE
            CALL PLUT25 (1, N1, IATK)
            CALL PLUT25 (2, N2, IATK)
            WRITE (LINE, 99982, IOSTAT = IOST) NQ1, NQ2, RB, I, IDASH
            IF (IGBL(25) * IGBL(32) == 1) THEN
              VRT = VRT - 0.6
              CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993, IOSTAT = IOST) LINE
            END IF
          END IF
        END DO
        WRITE (LINE, 99980, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 1.0
          CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99969, IOSTAT = IOST) LINE
        END IF
        GO TO 10
      END IF
C * LIST ARU'S
      IF (IPR(26) /= 0) THEN
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VERT - 0.2
          CALL GGIP (HORS, VERT, 0.0, 1)
          OPEN (LU61, FILE = 'srcsrc', STATUS = 'UNKNOWN')
          CALL PLUT17 (0.0, 1004, MADDR, LU61)
          CALL GEN108 (LU61, 0)
          DO
            READ (LU61, 99993, IOSTAT = IOST) LINE
            IF (IOST /= 0) EXIT
            VRT = VRT - 0.5
            CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          END DO
          CLOSE (UNIT = LU61, STATUS = 'DELETE')
          GO TO 10
        ELSE
          CALL PLUT17 (0.0, 1004, MADDR, LU6)
        END IF
      END IF
C * LIST ORIENTATION MATRIX PARAMETERS
      IF (IPR(27) /= 0) THEN
        CALL GEN096 (R, IROTX, IROTY, IROTZ, IDET, XYZOR, PHI, ROM)
        WRITE (LU6, 99997, IOSTAT = IOST) IROTX, IROTY, IROTZ, IDET,
     1    ((R(I, J), J = 1, 3), I = 1, 3)
      END IF
      IF (IPR(28) /= 0) THEN
        WRITE (LU6, 99996, IOSTAT = IOST)
     1    IPR(39), IPR(38), IPR(37), IPR(53), IPR(52), IPR(75),
     2    IPR(42), IPR(43)
        WRITE (LU6, 99995, IOSTAT = IOST)
     1    IPR(46), IPR(116), NINT (PAR(48)), IPR(4), IPR(9), IGBL(67),
     2    IGBL(75), IPR(77), IPR(346), IPR(19), IPR(63)
        WRITE (LU6, 99994, IOSTAT = IOST)
     1    PAR(24), PAR(15), VERT, PAR(48), PAR(13), PAR(36), PAR(39),
     2    PAR(5), PAR(3), PAR(44)
      END IF
C * LIST ATOM TYPE PARAMETERS
      IF (IPR(29) /= 0) THEN
        WRITE (LINE, 99999, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          CALL GGIP (HORS, VERT, 1.0, 1)
          VRT = VERT - 0.8
          CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.3
        ELSE
          WRITE (LU6, 99992, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99977, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.4
          CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99993, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99976, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.8
          CALL PLA439 (0.0, LINE, 80, 0.35, 6, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99969, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99975, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.8
          CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99969, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99974, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.8
          CALL PLA439 (0.0, LINE, 80, 0.35, 6, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99969, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99973, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.8
          CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99992, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99972, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 0.6
          CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99993, IOSTAT = IOST) LINE
        END IF
        WRITE (LINE, 99971, IOSTAT = IOST) PAR(1)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          VRT = VRT - 1.0
          CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.2
        ELSE
          WRITE (LU6, 99992, IOSTAT = IOST) LINE
        END IF
        DO I = 1, IAN
          N2 = IEL(IEN(I))
          N1 = N2 / 100 + ICHAR ('A') - 1
          N2 = MOD (N2, 100)
          IF (N2 == 0) THEN
            N2 = ICHAR (' ')
          ELSE
            N2 = N2 + ICHAR ('a') - 1
          END IF
          N3 = IATPR(IEN(I))
          ATPR1 = '           '
          IF (N3 <= 0) THEN
            N3 = - N3
            ATPR2 = '     '
          ELSE
            ATPR2 = 'Metal'
          END IF
          IF (N3 == 2) THEN
            ATPR1 = 'Lanthanide '
          ELSE IF (N3 == 3) THEN
            ATPR1 = 'Actinide   '
          ELSE IF (N3 == 4) THEN
            ATPR1 = 'Transition '
          ELSE IF (N3 == 5) THEN
            ATPR1 = 'Alkali     '
          ELSE IF (N3 == 6) THEN
            ATPR1 = 'AlkaliEarth'
          ELSE IF (N3 == 7) THEN
            ATPR1 = 'Halogen    '
          END IF
          PARAM = '      '
          IF (BWCT(IBCL(I))(1:3)  == 'NET') THEN
            WRITE (PARAM, 99984, IOSTAT = IOST) IPR(85), IPR(86)
          ELSE IF (BWCT(IBCL(I))(1:3) == 'GLO') THEN
            WRITE (PARAM, 99984, IOSTAT = IOST) IPR(112), IPR(132)
          END IF
          WRITE (LINE, 99998, IOSTAT = IOST)
     1      CHAR (N1), CHAR (N2), COLR(IACL(I)), BWCT(IBCL(I)), PARAM,
     2      (RADR(I, 5 - J), J = 1, 4), ATPR1, ATPR2
          IF (IGBL(25) * IGBL(32) == 1) THEN
            VRT = VRT - 0.6
            CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          ELSE
            WRITE (LU6, 99993, IOSTAT = IOST) LINE
          END IF
        END DO
        GO TO 10
      END IF
C * LIST ATOM-FLAGS
      IF (IPR(30) == 1) THEN
        WRITE (LINE, 99978, IOSTAT = IOST)
        IF (IGBL(25) * IGBL(32) == 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 0.8
          CALL PLA439 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.3
        ELSE
          WRITE (LU6, 99992, IOSTAT = IOST) LINE
        END IF
        DO I = IPR(69) + 1, IPR(37)
          CALL PLUT25 (1, I, IDUM)
          CALL PLUT15 (-4, I,  1, N1)
          CALL PLUT15 (-6, I,  5, N2)
          CALL PLUT15 (-6, I, 11, N3)
          CALL PLUT15 (-1, I, 17, N6)
          CALL PLUT15 (-6, I, 18, N10)
          CALL PLUT15 (-3, I, 24, N16)
          CALL PLUT15 (-1, I, 27, N11)
          CALL PLUT15 (-4, I, 28, N12)
          CALL PLUT15 (-1, I, 32, N13)
          CALL PLUT15 (-4, I, 33, N14)
          CALL PLUT15 (-4, I, 37, N15)
          CALL PLUT15 (-1, I, 42, N5)
          CALL PLUT15 (-1, I, 43, N4)
          CALL PLUT15 (-1, I, 44, N7)
          CALL PLUT15 (-1, I, 45, N8)
          CALL PLUT15 (-1, I, 46, N9)
          WRITE (LINE, 99979, IOSTAT = IOST)
     1      NQ1, N1, N2, N3, N6, N16, N10, N11, N12, N13, N14, N15, N5,
     2      N4, N7, N8, N9
          IF (IGBL(25) * IGBL(32) == 1) THEN
            IF (VRT - 0.4 < 0) THEN
C * WHAT NEXT ?
              CALL PLA012 (1, 1)
              ICH = IGGT(1:1)
              CALL GGIP (HORS, VERT, 0.0, 1)
              IF (ICH /= 'Y' .AND. ICH /= '!') GO TO 10
              VRT = VERT
            END IF
            VRT = VRT - 0.4
            CALL PLA439 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          ELSE
            WRITE (LU6, 99993, IOSTAT = IOST) LINE
          END IF
        END DO
        GO TO 10
      END IF
      RETURN
   10 IF (IGBL(25) * IGBL(32) == 1) CALL PLA297 (1)
      RETURN
99999 FORMAT (20X, ' ATOM TYPES AND PARAMETERS')
99998 FORMAT (2X, 2A, 1X, A, 1X, A, A, F5.2, 3F7.2, 2X, A, 1X, A)
99997 FORMAT (//, 'VIEW ROTATION MATRIX  XROT=', I5, 2X, 'YROT=', I5,
     1 2X, 'ZROT=', I5, 2X, 'IDET=', I5, /, 3(/, 9X, 3F10.5, /), /)
99996 FORMAT (/, 'STATUS REPORT - CONTENTS', // 'ATOMS-A :', I4,
     1 ' ATOMS-B:', I4, ' ATOMS-C  :', I4, /, 13X, ' BONDS-B:', I4,
     2 ' BONDS-C  :', I4, /, 'NR. RES.:', I4, ' MOL-A  :', I4,
     3 ' MOL-B    :', I4, /)
99995 FORMAT (/, 'STATUS REPORT - STYLE', //, 'UNITCELL:', I4,
     1 ' STEREO :', I4, ' PERSPECT :', I4, ' SOLID    :', I4, /,
     2 'SHADE   :', I4, ' V.D.W.R:', I4, ' LABELS   :', I4,
     3 ' OVERL.OP.:', I4, /, 'AT.COLOR:', I4, ' DEF.COL:', I4,
     4 ' MOL LAB  :', I4, /)
99994 FORMAT (/, 'STATUS REPORT - PLOT', //
     1 'SCALE CM/A ', F8.3/'SIZE-X/CM  ', F8.2,
     2 ' SIZE-Y/CM  ', F8.2, ' PERS.D. CM ', F8.1/'SHRINK PERC', F8.2,
     3 ' OVL. MARGIN', F8.2, ' LAB. SHIFT ', F8.2/'PLOT STEP  ', F8.2,
     4 ' TRACE DEF  ', F8.2, ' TAPER', 6X, F8.2,/)
99993 FORMAT (A)
99992 FORMAT (/, A, /)
99991 FORMAT ('Atom', 7X, 'X', 7X, 'Y', 7X, 'Z  VDW',
     1 '  Cov Join Plot', 1X, 'Mul Incl   Move  Lab Res Nel HB')
99990 FORMAT (A, 3F7.3, 4F5.2, I4, A1, 2X, A, F8.3, A, 1X,
     1 A, A1, I4, I4, 1X, 2A)
99989 FORMAT (3X, 'Nr NRES(I)',1X, 'Bonds(I-J)', 7X, '[  ARU(J) ]',
     1          4X, 'Dist (A) Radius  Lines Dash')
99988 FORMAT (2I5, 4X, A, '--', A, ' [',F9.2,'] ', 2F9.3, I7, I5)
99987 FORMAT ('Bond(s)', 12X, 'Radius(Ang) Lines Dash')
99986 FORMAT ('Normal', 17X, F6.3, I7, I5)
99985 FORMAT ('Intermolecular', 6X, F9.3, I7, I5)
99984 FORMAT (2I3)
99983 FORMAT ('To ',  A, 10X, F9.3, I7, I5)
99982 FORMAT (A, '-- ', A, 3X, F9.3, I7, I5)
99981 FORMAT (A, 5X, 3F7.3, 27X, A, 10X, 2A)
99980 FORMAT ('Note: Radii may be changed with RADII BONDS',
     1            ' instruction(s)')
99979 FORMAT (A, I3, 2I3, I2, 2I3, I2, I3, I2, I3, I3, 5I2)
99978 FORMAT ('Atom', 9X, 'MD  R  A M  O  M I  D D  B  P P M H N D')
99977 FORMAT ('( May be Changed with COLOR TYPE, BWC TYPE or ',
     1           'RADII ATOMS instructions)')
99976 FORMAT ('===== COLOR TYPE atom-type col (atom-type col ...)')
99975 FORMAT ('col = BLACK(WHITE), RED, GREEN, BLUE, YELLOW',
     1 ' ORANGE, VIOLET, BROWN, NONE')
99974 FORMAT ('===== BWC TYPE atom-type bwc (atom-type bwc ...)')
99973 FORMAT ('bwc = CONTOUR, NET, SHADE, SEGMENT, DOTS, BLACK,',
     1 ' CROSS, PARALLEL, GLOBE,')
99972 FORMAT ('      MERIDIAN, HORIZONTAL, VERTICAL, MESH, DIAGONAL,',
     1        ' SLANT, TEXTILE, VOID')
99971 FORMAT ('Type Color      BWC', 8X, 'Param  vdW-   COV-  ',
     1 'JOIN- PLOT-RAD (TOL =', F4.1, ' A/at)')
99970 FORMAT (//, A, /)
99969 FORMAT (/, A)
      END SUBROUTINE PLUT12
 
      SUBROUTINE PLUT13 (MODE, KK, IAT, XMOL)
C * SUBROUTINE RETURNS IN IAT : ATOM SERIAL NUMBER (POSITIVE) FOR IFL(KK)
C *           OR              : ELEMENT TYPE NUMB. (IEN ENT)( IAT < 0)
C *           OR              : 0, FOR UNRECOGNISED ATOM NAME OR TYPE
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: N
      INTEGER          :: KK
      INTEGER          :: NA1
      INTEGER          :: NA2
      INTEGER          :: NE1
      INTEGER          :: NE2
      INTEGER          :: NS1
      INTEGER          :: NS2
      INTEGER          :: IAT
      INTEGER          :: NIEN
      INTEGER          :: NAX1
      INTEGER          :: NAX2
      INTEGER          :: IATK
      INTEGER          :: MODE
      INTEGER          :: IXPK1
      INTEGER          :: IXPK2
      INTEGER          :: MSUBST
      REAL             :: XMOL
      CHARACTER(len=1) :: ICH
C * MODE
C * KK > 0 : TEST ON ATOM-NAME, THEN ON ATOM-TYPE
C * KK < 0 : TEST ON ATOM-TYPE, THEN ON ATOM-NAME
C * HANDLE ALIASES
 
      NQ1    = IFL(IABS(KK))
      MSUBST = 0
      CALL PLA281 (1, NQ1, MSUBST)
C * SPLIT ATOM LABEL (NQ1) INTO ELEMENT TYPE (NE1),
C *                           NUMERICAL TYPE (NA1),
C *                      SEMI-NUMERICAL TYPE (NAX1),
C *                        AND SYMMETRY PART (NS1).
      XMOL = 0.0
C * IGNORE 'RENAME'
      IF (NQ1(1:3) == 'REN') THEN
        IAT  = 0
        WRITE (LU6, 99999, IOSTAT = IOST) NQ1
        RETURN
      END IF
      N = INDEX (NQ1, '_')
      IF (N /= 0) THEN
        ICH = NQ1(N+1:N+1)
        DO I = 1, 10
          IF (ICH == CHAR (ICHAR ('0') + I - 1)) THEN
            N = 0
            GO TO 10
          END IF
        END DO
      END IF
   10 CALL PLA046 (8, NQ1, NE1, NA1, NAX1, NS1, IXPK1, IXPK2, NIEN)
C * TEST FOR NUMBER OF ELEMENT IN ARRAY IEN
      IF (NE1 == 0) THEN
        IAT = 0
      ELSE IF (NE1 < NP9 - 3) THEN
        IF (KK < 0) THEN
C * REGISTER ATOM-TYPE
          IF (NA1 < 0) THEN
            IAT = - NE1
            GO TO 20
          END IF
        END IF
C * TEST FOR ATOM NAME
        DO IAT = IPR(69) + 1, IPR(37)
           CALL PLUT25 (2, IAT, IATK)
           CALL PLA046 (8, NQ2, NE2, NA2, NAX2, NS2, IXPK1, IXPK2,
     1       NIEN)
           IF (NE1 == NE2) THEN
             IF (NA1 == NA2 .OR. (NA1 == 0 .AND. NA2 == -1)) THEN
               IF (NAX1 == NAX2) THEN
                 IF (MODE < 0) THEN
                   IF (NS1 > 0) XMOL =
     1               MOL(1, NS1 + IPR(75)) / PAR(42)
                   GO TO 20
                 ELSE
                   IF (NS1 == NS2) GO TO 20
                 END IF
               END IF
             END IF
           END IF
        END DO
        IF (NA1 > 0) THEN
          IAT = 0
          GO TO 20
        END IF
C * TEST FOR ELEMENT NAME
        IAT = - NE1
      ELSE IF (NE1 == NP9 - 3) THEN
        IAT = 1
      ELSE IF (NE1 == NP9 - 2) THEN
        IAT = 5
      ELSE IF (NE1 == NP9 - 1) THEN
        IAT = 3
      ELSE IF (NE1 == NP9) THEN
        IAT = 2
      ELSE
        IAT = 0
      END IF
   20 IF (MODE <= 0 .AND. IAT == 0 .AND. KK > 0) THEN
        WRITE (LU6, 99999, IOSTAT = IOST) NQ1
      END IF
      RETURN
99999 FORMAT (':: ATOM Name/Type ERROR for: ', A)
      END SUBROUTINE PLUT13
 
      SUBROUTINE PLUT14 (MODE, J, IASU, NPROP, X, Y, Z, S)
C * THIS SUBROUTINE HANDLES THE STORAGE AND RETRIEVAL OF ATOM ITEMS
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: IASU
      INTEGER :: MODE
      INTEGER :: NPROP
      REAL    :: X
      REAL    :: Y
      REAL    :: Z
      REAL    :: S
C * MODE =  1 - PUT FUNCTION
C * MODE =  0 - STACK FUNCTION
C * MODE = -1 - GET FUNCTION
      I = J * NP0 + IPR(158)
      IF (MODE < 0) THEN
C * RETRIEVE MODE
        IASU  = NINT (RA(I - 5))
        NPROP = NINT (RA(I - 4))
        X     = RA(I - 3)
        Y     = RA(I - 2)
        Z     = RA(I - 1)
        S     = RA(I)
      ELSE
C * MODE >= 0
        IF (MODE == 0) THEN
          IPR(67) = IPR(67) + 1
          J       = IPR(40) + IPR(67)
          I       = J * NP0 + IPR(158)
          IF (I >= IPR(66) - IPR(78) * 13) THEN
            IPR(101) = IPR(101) + 1
            J        = 0
            IPR(67)  = IPR(67) - 1
            RETURN
          END IF
        END IF
C * STORE MODE
        RA(I - 5) = IASU
        RA(I - 4) = NPROP
        RA(I - 3) = X
        RA(I - 2) = Y
        RA(I - 1) = Z
        RA(I)     = S
      END IF
      RETURN
      END SUBROUTINE PLUT14
 
      SUBROUTINE PLUT15 (IKEY, IAT, IBITN, IVL)
      USE pluto
      IMPLICIT NONE
      INTEGER :: IX
      INTEGER :: IAT
      INTEGER :: IVL
      INTEGER :: INH
      INTEGER :: IKEY
      INTEGER :: IBTN
      INTEGER :: IFLI
      INTEGER :: IBIT
      INTEGER :: IBITN
C * BITS  1 TO 23 ARE STORED IN RA(I + 8) AND
C * BITS 24 TO 46 ARE STORED IN RA(I + 9)
C * BITS 47 TO 69 ARE STORED IN RA(I + 10)
      IBTN = IBITN
      IX   = IAT * NP43 + 8 + (IBTN - 1) / 23
      IBTN = 1 + MOD (IBTN - 1, 23)
      IFLI = NINT (RA(IX))
      IBIT = IBT(IBTN)
      INH  = MOD (IFLI / IBIT, IBT(IABS (IKEY) + 1))
      IF (IKEY < 0) THEN
        IVL = INH
      ELSE
        RA(IX) = IFLI + (IVL - INH) * IBIT
      END IF
      RETURN
      END SUBROUTINE PLUT15
 
      SUBROUTINE PLUT16 (MODE, IAJAT, IAT, JAT, RBO, NLI)
C * BOND STORAGE AND RETRIEVAL
      USE files
      USE parameters
      USE atomdata
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: KK
      INTEGER :: MD
      INTEGER :: ML
      INTEGER :: NC
      INTEGER :: NC0
      INTEGER :: NCU
      INTEGER :: MDD
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: NLI
      INTEGER :: ICI
      INTEGER :: IBN
      INTEGER :: IM2
      INTEGER :: JCI
      INTEGER :: NAB
      INTEGER :: NLN
      INTEGER :: NRS
      INTEGER :: NSK
      INTEGER :: MNML
      INTEGER :: JAT0
      INTEGER :: JARU
      INTEGER :: IBNB
      INTEGER :: IADR
      INTEGER :: IARU
      INTEGER :: IAT0
      INTEGER :: MODE
      INTEGER :: ICMD
      INTEGER :: IJAT
      INTEGER :: ILPB
      INTEGER :: ISTK
      INTEGER :: IVAL
      INTEGER :: NRJT
      INTEGER :: NMLX
      INTEGER :: NPROP
      INTEGER :: NINCL
      INTEGER :: ITYPE
      INTEGER :: JTYPE
      INTEGER :: IAJAT
      INTEGER :: NRINCL
      INTEGER :: IENITP
      INTEGER :: IENJTP
      INTEGER :: IPR158
      REAL    :: AL
      REAL    :: BE
      REAL    :: DK
      REAL    :: DX
      REAL    :: DY
      REAL    :: DZ
      REAL    :: RB
      REAL    :: RI
      REAL    :: RJ
      REAL    :: RJK
      REAL    :: RAI
      REAL    :: RAJ
      REAL    :: RIK
      REAL    :: RBO
      REAL    :: RA4
      REAL    :: RA8
      REAL    :: RB9
      REAL    :: RA12
      REAL    :: DXYZ
      REAL    :: QMPK
      REAL    :: RPKPK
      REAL    :: RQKQK
      REAL    :: DKQMPK
C * MODE = -1: ADD THIS BOND TO BOND LIST
C * MODE = -2: LOAD UNIT-CELL OUTLINE
C * MODE = -3: DELETE THIS BOND FROM BOND LIST ( = MAKE ENTRY NEGATIVE)
C * MODE = -4: GET LIST NUMBER OF SPECIFIED BOND
C * MODE = -5: CHECK WHETHER IAT AND JAT ARE BONDED ATOMS
C * MODE = -6: LOAD ACTIVE BONDS
C * MODE =  0: UNPACK MODE INTO IAT AND JAT + RBO + NLI FROM BONDLIST
C * MODE = >0: UNPACK MODE INTO IAT AND JAT + RBO + NLI FROM ACTIVE LIST
      RA12   = 0.0
      MD     = MODE
      ILPB   = IPR(69) + 1
      NAB    = IPR(37) - IPR(69)
      IPR158 = IPR(158)
      NSK    = 0
      IF (MD > 0) THEN
C * UNPACK BOND FROM ACTIVE BOND LIST AND GENERATE PSEUDO ATOM ENDPOINTS
C * ON OUTPUT: PSEUDO ATOM ENDPOINT PARAMETERS ON STACK
C *            UNIT VECTOR ALONG BOND IN ZU(7:9)
C *            BOND RADIUS IN RBO
C *            NR OF LINES IN NLI
        IADR     = IPR(79) - MD * 4
        IAT      = NINT (RA(IADR + 1))
        JAT      = NINT (RA(IADR + 2))
        RBO      = RA(IADR + 3)
        NLN      = NINT (RA(IADR + 4))
        IPR(120) = MOD (IABS (NLN), 1024)
        NLI      = IABS (NLN) / 1024
        I        = IAT * NP0 + IPR158
        J        = JAT * NP0 + IPR158
        IF (IPR(477) > 0) THEN
          NPROP  = MAX (NINT (RA(I - 4)), NINT (RA(J - 4)))
          CALL GEN048 (-5, NPROP, 1, IPR(120))
        ELSE IF (IPR(477) < 0) THEN
          IAT0 = MOD (IAT - ILPB, NAB) + ILPB
          CALL PLUT15 (-6, IAT0, 5, NRS)
          IF (NRS > 0 .AND. NRS <= 16) IPR(120) = NRS
        END IF
        ISTK     = IPR158 + (IPR(40) + IPR(67)) * NP0
        IPR(67)  = IPR(67) + 2
        IF (NLN < 0) NLI = - NLI
        IF (RBO < 0.0) RBO = ABS (RBO)
        IF (ISTK + 2 * NP0 >= IPR(66) - IPR(78) * 13)
     1    CALL PLUT38 (3, 1, LU6)
        DK = 0
        DO K = 1, 3
          ZU(K + 6) = RA(J + K - 4) - RA(I + K - 4)
          DK        = DK + ZU(K + 6)**2
        END DO
        IF (DK /= 0.0) THEN
          DXYZ = SQRT (DK)
        ELSE
          DXYZ = 1.0
        END IF
        RI   = AMOD (ABS (RA(I)), 1000.0)
        RJ   = AMOD (ABS (RA(J)), 1000.0)
C * GET BOND RADIUS AT ATOMS IAT AND JAT
        RB   = RBO * PAR(24)
        RA4  = RB
        RA8  = RB
        IF (PAR(48) == 0.0) THEN
          IF (PAR(44) /= 0.0 .AND. IPR(4) /= 4) THEN
C * APPLY TAPER (NO PERSPECTIVE OR STRAW CASE)
            RB9 = RB * ABS (PAR(44) * ZU(9) / DXYZ)
            RA4 = RB + RB9
            RA8 = RB - RB9
          END IF
        ELSE
C * APPLY PERSPECTIVE
          RA4 = RB * PAR(48) / (PAR(48) - RA(I - 1))
          RA8 = RB * PAR(48) / (PAR(48) - RA(J - 1))
        END IF
        RA4 = MAX (MIN (RA4, RI - 0.001), 0.0)
        RA8 = MAX (MIN (RA8, RJ - 0.001), 0.0)
        IF (IPR(4) > 0) THEN
          RA12   = RA8 - RA4
          QMPK   = RA12**2
          RIK    = RI**2
          RJK    = RJ**2
          RPKPK  = DK * (RIK - RA4**2) + RIK * QMPK
          RQKQK  = DK * (RJK - RA8**2) + RJK * QMPK
          DKQMPK = DK + QMPK
          AL     = (SQRT (RPKPK) - RA4 * RA12) / DKQMPK
          BE     = (SQRT (RQKQK) + RA8 * RA12) / DKQMPK
        ELSE
          AL     = 0.0
          BE     = 0.0
        END IF
C * STORE BOND ENDPOINTS AS PSEUDO ATOMS
        DO K = 1, 3
          RA(ISTK + K +     NP0 - 4) = RA(I + K - 4) + AL * ZU(K + 6)
          RA(ISTK + K + 2 * NP0 - 4) = RA(J + K - 4) - BE * ZU(K + 6)
        END DO
        RA(ISTK + NP0)     = RA4 + AL * RA12
        RA(ISTK + 2 * NP0) = RA8 - BE * RA12
        DO K = 7, 9
          ZU(K) = ZU(K) / DXYZ
        END DO
      ELSE IF (MD < 0) THEN
C * HANDLING OF MODE = - 6 - LOAD ACTIVE BONDS
        IF (MD == -6) THEN
C * ACTIVE BOND COUNTER
          IADR    = IPR(79)
          IPR(97) = 0
C * NUMBER OF ASU'S = ASYMMETRIC STRUCTURE UNITS
          NMLX    = IPR(142)
C * NUMBER OF BONDS
          NC      = IPR(52)
C * NUMBER OF UNIQUE BONDS
          NCU     = IPR(53)
C * TEST FOR UNITCELL OFF/ON
          IF (IPR(46) > 0) THEN
            IBNB = 1
          ELSE
            IBNB = IPR(68) + 1
          END IF
C * LOOP THROUGH THE LIST OF CONNECTIONS STORED IN ARRAY RA
          IF (NC >= IBNB) THEN
            DO IBN = IBNB, NC
              ICMD = NINT (RA(IPR(64) + 1 - IBN * 2))
C * SKIP EXCLUDED BOND
              IF (ICMD > 0) THEN
                IAT    = ICMD
                JAT    = NINT (RA(IPR(64) + 2 - IBN * 2))
                NRINCL = 2
C * SKIP BONDS INVOLVING EXCLUDED ATOMS
                IF (IAT >= ILPB) THEN
C * GET ELEMENT TYPE (SPECIAL Cg TREATMENT
                  ITYPE = INT (RA(IAT * NP43 + 7) / 64000) + 1
                  IF (IAT <= IPR(39)) THEN
                    CALL PLUT15 (-1, IAT, 27, NINCL)
                    NRINCL = NRINCL - 1 + NINCL
                  END IF
                  IENITP = IEN(ITYPE)
                ELSE
                  ITYPE  = 0
                  IENITP = 0
                END IF
                IF (JAT >= ILPB) THEN
C * GET ELEMENT TYPE
                  JTYPE = INT (RA(JAT * NP43 + 7) / 64000) + 1
                  IF (JAT <= IPR(39)) THEN
                    CALL PLUT15 (-1, JAT, 27, NINCL)
                    NRINCL = NRINCL - 1 + NINCL
                  END IF
                  IENJTP = IEN(JTYPE)
                ELSE
                  JTYPE  = 0
                  IENJTP = 0
                END IF
                IF (NRINCL >= IPR(165)) THEN
C * GET ARU-NUMBERS
                  CALL PLUT15 (-6, IAT, 11, IARU)
                  CALL PLUT15 (-6, JAT, 11, JARU)
                  CALL PLUT27 (IBN, IAT, JAT, RBO, NLI)
                  IF (IBN > IPR(68)) THEN
                    MNML = NMLX
                  ELSE
                    MNML = 1
                  END IF
                  IAT0 = IAT - NAB
                  JAT0 = JAT - NAB
C * LOOP OVER ASU LIST
                  DO ML = 1, MNML
                    IAT0 = IAT0 + NAB
                    JAT0 = JAT0 + NAB
                    IF (IBN > NCU) THEN
                      NRJT = 2
                    ELSE
                      NRJT = 3 - IPR(165)
                    END IF
                    I   = IAT0 * NP0 + IPR(158)
                    J   = JAT0 * NP0 + IPR(158)
                    NSK = 2
C * ELIMINATE REDUNDANT BONDS
                    RAI = ABS (RA(I))
                    IF (RAI > 999.9) THEN
                      NSK = NSK - 1
                      RAI = RAI - 1000.0
                    END IF
                    RAJ = ABS (RA(J))
                    IF (RAJ > 999.9) THEN
                      NSK = NSK - 1
                      RAJ = RAJ - 1000.0
                    END IF
                    IF (NSK < 2) THEN
C * TEST FOR 'OMIT OUTSIDE ATOM'
                      IF (IPR(15) < 0) THEN
                        NSK = 0
                      ELSE
                        NSK = 2
                      END IF
                    END IF
                    IF (NSK > 0) THEN
C * OMIT INTER-MOLECULAR BONDS WHEN BOTH ATOMS ARE OMITTED
                      IF (ITYPE /= 0 .AND. JTYPE /= 0) THEN
C * TEST FOR CG (106)
                        IF (IENITP /= 106 .AND.
     1                      IENJTP /= 106) THEN
                          IF (IARU /= JARU) NRJT = 1
                        ELSE
                          NRJT = 2
                        END IF
                      END IF
C * OMIT INTRA-MOLECULAR BONDS WHEN EITHER ATOM IS OMITTED
                      IF (ITYPE /= 0 .AND. JTYPE /= 0)THEN
                        IF (RA(I) < 0.0) NRJT = NRJT - 1
                        IF (RA(J) < 0.0) NRJT = NRJT - 1
                      END IF
                      IF (NRJT > 0) THEN
                        IF (NLI /= 0) THEN
                          DX = RA(I - 3) - RA(J - 3)
                          DY = RA(I - 2) - RA(J - 2)
                          DZ = RA(I - 1) - RA(J - 1)
                          DK = DX**2 + DY**2 + DZ**2
C * MAKE SHURE THAT ATOM IAT HAS HIGHEST Z-VALUE
                          IF (DZ < 0.0) THEN
                            CALL GEN014 (IAT0, JAT0)
C * EXCHANGE TYPES AS WELL
                            CALL GEN014 (ITYPE, JTYPE)
                          END IF
                          IF (IPR(4) > 0) DK = DK - RAI**2 - RAJ**2
                          IF (DK > 0.0) THEN
                            RA(IADR - 3) = IAT0
                            RA(IADR - 2) = JAT0
                            RA(IADR - 1) = RBO
                            RA(IADR    ) = ISIGN (IABS (NLI) * 1024
     1                                   + ITYPE * 32 + JTYPE, NLI)
                            IPR(97)      = IPR(97) + 1
                            IADR         = IADR - 4
                          END IF
                        END IF
                      END IF
                    END IF
                  END DO
                END IF
              END IF
            END DO
          END IF
C * HANDLING OF MODE = -2 CASE (UNIT CELL OUTLINE)
        ELSE IF (MD == -2) THEN
          DO K = 1, 4
            KK = 2 * ((K - 1) / 2) + K
            RA(IPR(64) - (K - 1) * 2 - 1) = 2 * K - 1
            RA(IPR(64) - (K - 1) * 2)     = 2 * K
            RA(IPR(64) - (K + 3) * 2 - 1) = K
            RA(IPR(64) - (K + 3) * 2)     = K + 4
            RA(IPR(64) - (K + 7) * 2 - 1) = KK
            RA(IPR(64) - (K + 7) * 2)     = KK + 2
          END DO
          IPR(68) = 12
          IPR(52) = IPR(68)
          IPR(53) = IPR(68)
        ELSE
C * HANDLING OF MODE= -1, -3, -4, -5 CASES
          IAT0 = IAT
          JAT0 = JAT
C * HANDLING OF MODE = -5 CASE: REDUCE ATOM NUMBERS TO PRIMARIES
          IF (MD == -5) THEN
            JAT0 = MOD (JAT - ILPB, NAB) + ILPB
            IAT0 = MOD (IAT - ILPB, NAB) + ILPB
          END IF
          IF (JAT0 /= IAT0) THEN
            IF (JAT0 < IAT0) CALL GEN014 (IAT0, JAT0)
            IF (MD == -3) THEN
              MDD = -1
            ELSE
              MDD = 1
            END IF
            IJAT = IAT0 * MDD
            NC   = IPR(52)
            NC0  = IPR(68) + 1
            IF (NC >= NC0) THEN
              DO I = NC0, NC
                ICI = NINT (ABS (RA(IPR(64) + 1 - I * 2)))
                JCI = NINT (RA(IPR(64) + 2 - I * 2))
                IF (ICI == IABS (IJAT) .AND. JCI == JAT0) GO TO 10
              END DO
            END IF
            I = -1
            IF (MD == -1) THEN
              IPR(52) = IPR(52) + 1
C * CHECK FOR STACK OVERFLOW
              IF (((IPR(37) + 1) * NP43) > (IPR(64) - IPR(52) * 2))
     1          CALL PLUT38 (3, 1, LU6)
              I   = IPR(52)
              IM2 = I * 2
              IF (IPR(35) >= 0) THEN
                IF (JAT0 <= IPR(38)) THEN
C * SWAP/SHIFT
                  IPR(53)               = IPR(53) + 1
                  RA(IPR(64) + 1 - IM2) = RA(IPR(64) + 1 - IPR(53) * 2)
                  RA(IPR(64) + 2 - IM2) = RA(IPR(64) + 2 - IPR(53) * 2)
                  I                     = IPR(53)
                END IF
                CALL PLUT15 (-4, IAT, 33, IVAL)
                IF (IVAL < NP33) THEN
                  IVAL = IVAL + 1
                  CALL PLUT15 (4, IAT, 33, IVAL)
                END IF
                CALL PLUT15 (-4, JAT, 33, IVAL)
                IF (IVAL < NP33) THEN
                  IVAL = IVAL + 1
                  CALL PLUT15 (4, JAT, 33, IVAL)
                END IF
              END IF
            ELSE
              GO TO 20
            END IF
   10       IF (IABS (MD + 2) == 1) THEN
              RA(IPR(64) + 1 - I * 2) = IAT0 * MDD
              RA(IPR(64) + 2 - I * 2) = JAT0
            END IF
   20       IAJAT = I
          ELSE
            IAJAT = -1
          END IF
        END IF
      ELSE IF (MD == 0) THEN
C * UNPACK BOND FROM PRIMARY BOND LIST
        ICMD = NINT (RA(IPR(64) + 1 - IAJAT * 2))
        IF (ICMD < 0) THEN
          IAT = 0
          JAT = 0
        ELSE
          IAT = ICMD
          JAT = NINT (RA(IPR(64) + 2 - IAJAT * 2))
          CALL PLUT27 (IAJAT, IAT, JAT, RBO, NLI)
          IF (NLI == 0) THEN
            IAT = 0
            JAT = 0
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE PLUT16
 
      SUBROUTINE PLUT17 (XMOLE, MODE, MADDR, LUNIT)
C * SUBROUTINE MANAGES ARU'S
      USE files
      USE parameters
      USE atomdata
      USE pluto
      USE chdat
      USE sgxyz
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: M
      INTEGER           :: KL
      INTEGER           :: NR
      INTEGER           :: IM1
      INTEGER           :: IM2
      INTEGER           :: ITX
      INTEGER           :: ITY
      INTEGER           :: ITZ
      INTEGER           :: MPM
      INTEGER           :: MXL
      INTEGER           :: NMA
      INTEGER           :: NMB
      INTEGER           :: NR1
      INTEGER           :: NR2
      INTEGER           :: NMLX
      INTEGER           :: NRES
      INTEGER           :: NMOL
      INTEGER           :: LDIF
      INTEGER           :: LRES
      INTEGER           :: IVAL
      INTEGER           :: MODE
      INTEGER           :: NSL2
      INTEGER           :: NSLM
      INTEGER           :: NSYM
      INTEGER           :: NRESA
      INTEGER           :: NRESB
      INTEGER           :: ILAST
      INTEGER           :: MADDR
      INTEGER           :: LUNIT
      INTEGER           :: NARU1
      INTEGER           :: NARU2
      INTEGER           :: NARU3
      INTEGER           :: NARU4
      REAL              :: XML
      REAL              :: XNM
      REAL              :: OXML
      REAL              :: DPLN
      REAL              :: XMOLL
      REAL              :: XMOLE
      CHARACTER(len=3)  :: N1
      CHARACTER(len=10) :: ARU1
      CHARACTER(len=10) :: ARU2
      CHARACTER(len=10) :: ARU3
C * SPF or RES INSTRUCTIONS
C * 1 - XMOLE        : sttt.rr ARU-CODE
C * 2 - MODE  = +/-  : ADD/DELETE ARU'S (NEG. =  INTER ARU ADD) (LE 1000)
C *           = 1001 : LIST INSTRUCTIONS
C *           = 1002 : COUNT ACTIVE NUMBER OF ASU'S
C *           = 1003 : UNIQUE AND HBOND ARU'S INACTIVE
C *           = 1004 : LIST ARU'S AND ASU'S
C *           = 1005 : DELETE ARU ON SERIAL #
C * 3 - MADDR        : SERIAL NUMBER OF ARU 'XMOLE' IN ARU-LIST
C * 4 - LUNIT        : OUTPUT UNIT
      KL    = IPR(220)
      NSYM  = IPR(48)
      NRES  = IPR(75)
      NMOL  = IPR(42)
      MADDR = 0
C * ADD/DELETE MODE
      IF (IABS (MODE) <= 1000) THEN
        IPR(130) = 0
        IF (MODE > 0) THEN
          NMA = MODE / 32
          NMA = NMA * 5 + 1
          NMB = MOD (MODE, 32)
        END IF
        XML = XMOLE
C * MAKE SHURE THAT THERE IS AT LEAST ONE ARU TO BE PLOTTED
        IF (XML == 0.0) THEN
          IF (NMOL > 0) THEN
            DO I = 1, NMOL
              IF (MOL(1, I) > 0.0) THEN
                RETURN
              END IF
            END DO
          END IF
          XML = 1555.00
        END IF
        MXL = INT(ABS(XML))
C * IN/EX-CLUDE RESIDUE (EG ARU 2)
        IF (MXL <= NRES) THEN
          IF (NMOL > 0) THEN
            DO L = 1, NMOL
              XMOLL = ABS (MOL(1, L) / PAR(42))
              MPM = NINT (XMOLL * PAR(42))
              CALL GEN098 (MPM, PAR(42), NSL2, ITX, ITY, ITZ, NR2)
              IF (MXL == NR2) THEN
                MOL(1, L) = NINT (SIGN (XMOLL, XML) * PAR(42))
              END IF
            END DO
          END IF
C * COLOR/RESD & PATTERN/RESD
          IF (MODE > 0) THEN
            IF (NMA == 1) THEN
              NCRS(NINT (XML)) = NMB
            ELSE
              NPRS(NINT (XML)) = NMB
            END IF
          END IF
          RETURN
        ELSE IF (MXL < 100) THEN
          WRITE (LUNIT, 99992, IOSTAT = IOST)
          RETURN
        END IF
C * UNPACK ARU
        MPM = NINT (XML * PAR(42))
        CALL GEN098 (MPM, PAR(42), NSLM, ITX, ITY, ITZ, NR)
C * CHECK VALIDITY OF THIS ARU
        IF (NSLM > NSYM .OR. NSLM == 0) THEN
          WRITE (LUNIT, 99999, IOSTAT = IOST) XML, NSLM
          RETURN
        END IF
C * SAVE FOR CALCULATION  C.G. OF NEW ARU
        SGY(4) = ITX
        SGY(5) = ITY
        SGY(6) = ITZ
        IF (NR > 0) THEN
C * CHECK VALIDITY OF RESIDUE NUMBER
          IF (NR > NRES) THEN
            WRITE (LUNIT, 99998, IOSTAT = IOST) XML, NR
            RETURN
          END IF
          NR1 = NR
          NR2 = NR
        ELSE
          NR1 = 1
          NR2 = NRES
        END IF
        DO NR = NR1, NR2
          IF (XML > 0) THEN
            XML =   MXL + NR / PAR(42)
          ELSE
            XML = - MXL - NR / PAR(42)
          END IF
          IF (IPR(20) > 0) THEN
            DO I = 1, 3
              SGY(I) = RCG(I, NR)
            END DO
            CALL SGSM (3, ICL, SGY, NSLM, LU6, IERR)
C * PACK PLANE TEST
            IF (IPR(36) /= 0) THEN
              DPLN = - RA(IPR(80) + 4)
              DO I = 1, 3
                DPLN = DPLN + SGY(I + 6) * RA(IPR(80) + I)
              END DO
              IF (DPLN > RA(IPR(80) + 6)) RETURN
              IF (DPLN < RA(IPR(80) + 5)) RETURN
            END IF
          END IF
C * CHECK FOR OCCURRENCE OF ARU XML IN THE ARU LIST
          NMOL = IPR(42)
          IF (NMOL > 0) THEN
            DO 10 L = 1, NMOL
              XMOLL = ABS (MOL(1, L) / PAR(42))
              IF (ABS (ABS (XML) - XMOLL) < 0.005) GO TO 20
              IF (IPR(20) > 0) THEN
                MPM = NINT (XMOLL * PAR(42))
                CALL GEN098 (MPM, PAR(42), NSL2, ITX, ITY, ITZ, NR2)
                SGZ(4) = ITX
                SGZ(5) = ITY
                SGZ(6) = ITZ
                DO I = 1, 3
                  SGZ(I) = RCG(I, NR2)
                END DO
                CALL SGSM (3, ICL, SGZ, NSL2, LU6, IERR)
                DO I = 7, 9
                  IF (ABS (SGY(I) - SGZ(I)) > 0.001) GO TO 10
                END DO
                GO TO 20
              END IF
   10       CONTINUE
          END IF
          L       = IPR(42)
          IPR(42) = IPR(42) + 1
C * HANDLE INTER CASE
          IF (MODE < 0) THEN
            MOL(1, L + 1) = MOL(1, IPR(44) + 1)
            L             = IPR(44)
            IPR(44)       = IPR(44) + 1
C * HANDLE INTRA CASE
          ELSE
C * SHIFT ARU'S (WHEN NEEDED) TO INSERT RESIDUE
            LDIF = IPR(42) - IPR(75)
            IF (LDIF > 0) THEN
              IF (NINT ((XML - 1555.0) * PAR(42)) == IPR(75)) THEN
                DO M = 1, LDIF
                  MOL(1, L + 1) = MOL(1, L)
                  L = L - 1
                END DO
                DO M = IPR(39) + 1, IPR(37) + IPR(55)
                  CALL PLUT15 (-6, M, 11, LRES)
                  IF (LRES > IPR(75) - 2) THEN
                    IVAL = LRES + 1
                    CALL PLUT15 (6, M, 11, IVAL)
                  END IF
                END DO
              END IF
            END IF
          END IF
          IF (L < NP48) THEN
            MOL(1, L + 1) = NINT(XML * PAR(42))
          ELSE
            WRITE (LU6, 99990)
            STOP
          END IF
          IF (MODE > 0) THEN
            CALL GEN048 (5, MOL(2, L + 1), NMA, MAX (0, NMB))
          END IF
          GO TO 30
C * ARU PRESENT (SET ARU ON/OFF)
   20     L    = L - 1
          OXML = MOL(1, L + 1) / PAR(42)
          IF (MODE < 0 .AND. L >= IPR(44)) THEN
            MOL(1, L + 1) = MOL(1, IPR(44) + 1)
            L             = IPR(44)
            IPR(44)       = IPR(44) + 1
          END IF
          IF (XML < 0) THEN
            MOL(1, L + 1) = - NINT (ABS (OXML) * PAR(42))
          ELSE
            MOL(1, L + 1) =   NINT (ABS (OXML) * PAR(42))
            IF (MODE > 0)
     1         CALL GEN048 (5, MOL(2, L + 1), NMA, NMB)
          END IF
   30     MADDR = L
        END DO
C * MODE == 1001 - NONE/UNIQUE/INTER/RESTORE LIST INSTRUCTIONS
      ELSE IF (MODE == 1001) THEN
C * SET REBUILD
          IPR(130) = 0
          IF (IPR(17) == 0) THEN
            CALL PLUT05
          END IF
          IF (KL > 1) THEN
            N1 = IFL(2)(1:3)
C * ARU NONE CASE
            IF (N1 == 'NON') THEN
              ILAST = 0
C * ARU UNIQUE
            ELSE IF (N1 == 'UNI') THEN
              ILAST = IPR(43)
C * ARU INTER
            ELSE IF (N1 == 'INT') THEN
              ILAST = IPR(44)
C * ARU RESTORE
            ELSE IF (N1 == 'RES') THEN
              ILAST =  NMOL
            ELSE
              RETURN
            END IF
            DO I = 1, NMOL
              XNM = ABS (MOL(1, I) / PAR(42))
              IF (I > ILAST) THEN
                MOL(1, I) = - NINT (XNM * PAR(42))
              ELSE
                MOL(1, I) =   NINT (XNM * PAR(42))
              END IF
            END DO
        END IF
C * COUNT THE ACTIVE NUMBER OF ASU'S
      ELSE IF (MODE == 1002) THEN
        IPR(159) = IPR(64) - IPR(52) * 2
        NMLX     = 0
        DO 40 I = 1, NMOL
          XNM = INT (MOL(1, I) / PAR(42))
          IF (XNM > 0) THEN
            RA(IPR(159) - NMLX) = XNM
            IF (NMLX > 0) THEN
              DO J = 1, NMLX
                IF (RA(IPR(159) + 1 - J) == XNM) GO TO 40
              END DO
            END IF
            NMLX = NMLX + 1
          END IF
   40   CONTINUE
        IPR(142) = NMLX
C * UNIQUE AND HBOND ARU'S INACTIVE
      ELSE IF (MODE == 1003) THEN
        IPR(42) = IPR(44)
        NMOL    = IPR(42)
        DO K = 1, NMOL
          MOL(1, K) = - IABS (MOL(1, K))
        END DO
C * LIST ARU'S AND ASU'S
      ELSE IF (MODE == 1004) THEN
        WRITE (LUNIT, 99997, IOSTAT = IOST)
     1    IPR(43), IPR(44) - IPR(43), NMOL, NRES
        IF (NMOL /= 0) THEN
          DO I = 1, NMOL
            CALL GEN098 (MOL(1, I), PAR(42), NSL2, ITX, ITY, ITZ, NR)
            ARU1 = '-         '
            ARU2 = ARU1
            ARU3 = ARU1
            CALL GEN048 (-5, MOL(2, I),  1, NARU1)
            IF (NARU1 > 0) ARU1 = COLR(NARU1)
            CALL GEN048 (-5, MOL(2, I),  6, NARU2)
            IF (NARU2 > 0) ARU2 = BWCT(NARU2)
            CALL GEN048 (-5, MOL(2, I), 11, NARU3)
            IF (NARU3 > 0) ARU3 = COLR(NARU3)
            CALL GEN048 (-5, MOL(2, I), 15, NARU4)
            IF (I == 1) WRITE (LUNIT, 99991, IOSTAT = IOST)
            NRESA = 9
            NRESB = 17
            IF (NR < 9)  NRESA = NCRS(NR)
            IF (NR < 17) NRESB = NPRS(NR)
            IF (IPR(134) > 9) THEN
              WRITE (LUNIT, 99996, IOSTAT = IOST)
     1          I, MOL(1, I) / PAR(42), ARU1, ARU2,
     2          ARU3, NARU4, COLR(NRESA), BWCT(NRESB)
            ELSE
              WRITE (LUNIT, 99995, IOSTAT = IOST)
     1          I, MOL(1, I) / PAR(42), ARU1, ARU2,
     2          ARU3, NARU4, COLR(NRESA), BWCT(NRESB)
            END IF
          END DO
          IF (IPR(130) == 1) THEN
            WRITE (LUNIT, 99993, IOSTAT = IOST) IPR(142)
            IM2 = IPR(159)
            IM1 = IM2 + 1 - IPR(142)
            WRITE (LUNIT, 99994, IOSTAT = IOST)
     1        (RA(IM2 + IM1 - I), I = IM1, IM2)
          END IF
        END IF
C * SPECIAL ARU EXCLUDE ON SERIAL #
      ELSE IF (MODE == 1005) THEN
        L = NINT (XMOLE)
        IF (L > 0) THEN
          MOL(1, L) = - IABS (MOL(1, L))
        ELSE
          WRITE (LU6, '(''Cannot exclude #'', I3)', IOSTAT = IOST) L
        END IF
      END IF
      RETURN
99999 FORMAT (':: ARU', F10.2, ' NOT Accepted (Check SYMM.Nr=', I3,')')
99998 FORMAT (':: ARU', F10.2, ' NOT Accepted (Check RESD.Nr=', I3,')')
99997 FORMAT (//, 'Asymmetric Residue Units :: UNIQUE =', I5,
     1          ', INTER =', I5, ', TOTAL =', I5, //,
     2          'The first', I3, ' refer(s) to 1555.nn ARU''s, the',
     3          ' next ones to _a, _b etc', /)
99996 FORMAT (I3, F12.2, 3(2X, A), I5, 2X, 2(2X, A))
99995 FORMAT (I3, F12.1, 3(2X, A), I5, 2X, 2(2X, A))
99994 FORMAT (8F9.0)
99993 FORMAT (/, '(Partially) ACTIVE Asymmetric Structure Units =',
     1        I5, /)
99992 FORMAT (':: Residue number out of range')
99991 FORMAT ('  #', 7X, 'ARU', 4X, 'ARUColor', 4X, 'ARUPattern ',
     1        'BondColor', 2X, '#Lines', 3X, 'ResColor',
     2        4X, 'ResPattrn')
99990 FORMAT (/, '> MOL ARRAY OVERFLOW IN PLUT17 <', /)
      END SUBROUTINE PLUT17
 
      SUBROUTINE PLUT18 (IAT, JAT)
C * GENERATE OBSCURATION LIST
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: M
      INTEGER :: N
      INTEGER :: MA
      INTEGER :: NJ
      INTEGER :: NL
      INTEGER :: NP
      INTEGER :: JO
      INTEGER :: II
      INTEGER :: IT
      INTEGER :: NPA
      INTEGER :: NLI
      INTEGER :: NAB
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: NDUM
      INTEGER :: MODE
      INTEGER :: MNRB
      INTEGER :: LABI
      INTEGER :: LRET
      INTEGER :: JEQM
      INTEGER :: JEQN
      INTEGER :: JLAB
      INTEGER :: JMAX
      INTEGER :: IVAL
      INTEGER :: IPOP
      INTEGER :: IPHI
      INTEGER :: ILPB
      INTEGER :: IASU
      INTEGER :: NRBD
      INTEGER :: NPROP
      INTEGER :: NOBSC
      INTEGER :: NINCL
      INTEGER :: INOBS
      INTEGER :: IABSNJ
      REAL    :: X1
      REAL    :: Y1
      REAL    :: Z1
      REAL    :: X2
      REAL    :: Y2
      REAL    :: Z2
      REAL    :: RI
      REAL    :: RJ
      REAL    :: RM
      REAL    :: RN
      REAL    :: XN
      REAL    :: YN
      REAL    :: XJ
      REAL    :: YJ
      REAL    :: ZJ
      REAL    :: XM
      REAL    :: YM
      REAL    :: ZM
      REAL    :: BX
      REAL    :: BY
      REAL    :: BZ
      REAL    :: CA
      REAL    :: CX
      REAL    :: CY
      REAL    :: CZ
      REAL    :: SA
      REAL    :: ZN
      REAL    :: XS
      REAL    :: XT
      REAL    :: YT
      REAL    :: ZT
      REAL    :: ZD
      REAL    :: XTA
      REAL    :: YTA
      REAL    :: XMN
      REAL    :: YMN
      REAL    :: ZMN
      REAL    :: RMJ
      REAL    :: DL1
      REAL    :: DL2
      REAL    :: RBO
      REAL    :: ZU7
      REAL    :: ZU8
      REAL    :: ZU9
      REAL    :: ALF
      REAL    :: ASQ
      REAL    :: BET
      REAL    :: YP12
      REAL    :: YT12
      REAL    :: YQ12
      REAL    :: XP12
      REAL    :: XQ12
      REAL    :: XT12
      REAL    :: ZP12
      REAL    :: ZQ12
      REAL    :: RSV1
      REAL    :: RSV2
      REAL    :: DL21
      REAL    :: DL2C
      REAL    :: ZMIN
      REAL    :: ZMAX
      REAL    :: ZT12
      REAL    :: ZSMN
      REAL    :: ZSJI
      REAL    :: ZRMN
      REAL    :: ZRIJ
      REAL    :: CPHI
      REAL    :: SPHI
      REAL    :: ANG1
      REAL    :: ANG2
      REAL    :: ALFA
      REAL    :: BSQ2
      REAL    :: BSQ3
      REAL    :: CSQ3
      REAL    :: PHIQ
      REAL    :: PHIP
      REAL    :: RMNS
      REAL    :: RTST
      REAL    :: TANP
      REAL    :: SNPHP
      REAL    :: SNPHQ
      REAL    :: RTEST
      REAL    :: RMJSQ
      REAL    :: PHIPX
      REAL    :: PHIQX
      REAL    :: CRADP
      REAL    :: CRADQ
      REAL    :: CSPHP
      REAL    :: CSPHQ
      REAL    :: ZTEST
      REAL    :: ZMNJI
      REAL    :: XMARG
      REAL    :: RATIO
      REAL    :: DMARG
      REAL    :: ZIJMIN
C * SUBROUTINE CALLS - PLUT14, PLUT16
C * SUBROUTINE GENERATES A LIST OF OVERLAP SITUATIONS FOR
C *                        ATOMS, BONDS AND LABELS (ATOM & ARU'S)
C * MODE = 1 : ATOM - OVER - ATOM/LABEL  (JAT == 0)
C * MODE = 2 : ATOM - OVER - BOND
C * MODE = 3 : BOND - OVER - ATOM/LABEL  (JAT == 0)
C * MODE = 4 : BOND - OVER - BOND
C * ON LEAVING PLUT18, IPR(78) CONTAINS THE NUMBER OF OBSCURATIONS
C * IPR(78) = -1 - SKIP THIS PLOT ITEM
C * IPR(78) >  0 - NUMBER OF OBSCURATIONS
      J       = 0
      II      = 0
      NDUM    = 0
      MNRB    = 0
      NRBD    = 0
      IASU    = 0
      XP12    = 0.0
      YP12    = 0.0
      ZP12    = 0.0
      ZMN     = 0.0
      RMNS    = 0.0
      CPHI    = 0.0
      SPHI    = 0.0
      XN      = 0.0
      YN      = 0.0
      ZN      = 0.0
      ZMIN    = 0.0
      DMARG   = 0.0
      ZU7     = 0.0
      ZU8     = 0.0
      ZU9     = 0.0
      ZRIJ    = 0.0
      ZRMN    = 0.0
      CSPHP   = 0.0
      CSPHQ   = 0.0
      SNPHP   = 0.0
      SNPHQ   = 0.0
      PHIP    = 0.0
      RI      = 0.0
      RJ      = 0.0
      DL1     = 0.0
      PHIQ    = 0.0
      XQ12    = 0.0
      YQ12    = 0.0
      ZIJMIN  = 0.0
      ZJ      = 0.0
      ZQ12    = 0.0
      XMARG   = PAR(36)
C * INITIALISE OBSCURATION STACK
      IPR(78) = 0
      ILPB    = IPR(69) + 1
      NAB     = IPR(37) - IPR(69)
C * GET NR OF ATOM TYPE PLOT-ITEMS = NPA IN PLOT-ARRAY
      NPA     = IPR(62)
      JMAX    = NPA
C * GET TOTAL NUMBER OF PLOT ITEMS = NP ( = ATOMS + LABELS)
      NP      = IPR(40)
      M       = IAT
      MA      = M
      N       = JAT
      IF (N > 0) THEN
C * BOND OVERLAP TEST
        MODE = 2
      ELSE
C * ATOM OR LABEL OVERLAP TEST
        MODE = 1
      END IF
      RTEST = PAR(149) * PAR(24)
      LRET  = 1
      CALL PLUT14 (-1, M, IASU, NPROP, XM, YM, ZM, RM)
      LABI = 0
C * ATOMS AND LABEL PLOT-ITEMS ONLY
      IF (M <= NP) THEN
C * TEST FOR LABEL ITEM
        IF (M > NPA) THEN
C * HANDLE LABEL CASE
           LABI  = M - NPA
C * SIMULATE LABEL WITH A BOND BETWEEN TWO PSEUDO ATOMS M AND N
           XP12  = XM
           YP12  = YM
           ZP12  = ZM
           ZMN   = 0.0
           RMNS  = 2 * RM
           DL2   = RM
           PHIP  = 0.0
           CPHI  = 1.0
           SPHI  = 0.0
           XN    = XM + RM
           XM    = XM - RM
           RM    = PAR(28)
           RN    = RM
           YN    = YM
           ZN    = ZM
           M     = NP + 1
           N     = NP + 2
           MODE  = 2
           JMAX  = NP
           RSV1  = RM
           RSV2  = RN
           ZMIN  = ZM - RM
           XMARG = 0
           GO TO 20
        END IF
      END IF
C * TEST FOR ATOM OR BOND OVERLAP LIST CASE
   10 IF (MODE > 1) THEN
        I    = N * NP0 + IPR(158)
        ZN   = RA(I - 1)
        RN   = RA(I)
        IF (MODE == 4) THEN
C * TEST WHETHER BOND M TO N IS ENTIRELY BELOW BOND J TO I
C * M & J ARE RESPECTIVE HIGHEST BOND END-POINTS
          ZMAX = MAX (ZM + RM, ZN + RN)
          IF (ZMAX < ZIJMIN) GO TO 90
        END IF
        XN   = RA(I - 3)
        YN   = RA(I - 2)
        ZMIN = MIN (ZM - RM, ZN - RN)
        RSV1 = RM
        RSV2 = RN
        XMN  = XM - XN
        YMN  = YM - YN
        ZMN  = ZM - ZN
        ASQ  = XMN**2 + YMN**2
        RMNS = ASQ + ZMN**2
        DL21 = SQRT (ASQ)
        DL2  = DL21 / 2.0
C * CALCULATE MIDPOINT BOND M-N
        XP12 = (XM + XN) / 2
        YP12 = (YM + YN) / 2
        ZP12 = (ZM + ZN) / 2
        IF (DL21 /= 0.0) THEN
          ZRMN = ZMN * RN / DL21
          PHIP = ATAN2 (YMN, XMN)
          CPHI = -XMN / DL21
          SPHI = -YMN / DL21
        ELSE
C * ? DL21 CASE RN
          ZRMN = RN
          PHIP = 0.0
          CPHI = 1.0
          SPHI = 0.0
        END IF
        CSPHP = COS (PHIP)
        SNPHP = SIN (PHIP)
        IF (MODE == 4) THEN
C * TEST FOR BOND/BOND - OVERLAP CASE
          PHIQX =   PHIQ - PHIP
          PHIPX = - PHIQX
C * ROTATE BONDS OVER PHIQ AND TRANSLATE ORIGIN TO BOND I-J CENTER
          XT12  =   XP12 - XQ12
          YT12  =   YP12 - YQ12
C * XT, YT, ZT ARE COORDINATES CENTRE BOND M-N IN NEW (ROTATED) SYSTEM
          XT    =   XT12 * CSPHQ + YT12 * SNPHQ
          YT    = - XT12 * SNPHQ + YT12 * CSPHQ
          ZT    =   ZP12 - ZQ12
C * TEST FOR BOND/BOND INTERSECTION
          CALL PLUT20 (DL1 + ZRIJ , RJ, RI, DL2 + ZRMN, RM, RN,
     1      PHIPX, XT, YT, IT, XMARG)
C * GOTO NEXT BOND WHEN NO INTERSECTION FOUND FOR THIS BOND
          IF (IT == 0) THEN
            GO TO 90
          ELSE
C * REVERSE TEST ORDER
C * ROTATE OVER PHIP AND TRANSLATE ORIGIN TO BOND M-N CENTER
            XTA = - XT12 * CSPHP - YT12 * SNPHP
            YTA =   XT12 * SNPHP - YT12 * CSPHP
C * TEST FOR BOND/BOND INTERSECTION
            CALL PLUT20 (DL2 + ZRMN, RM, RN, DL1 + ZRIJ, RJ, RI,
     1        PHIQX, XTA, YTA, IT, XMARG)
            IF (IT == 0) GO TO 90
          END IF
C * FIND OUT WHERE THE BONDS INTERSECT IN Z
C * CALCULATION IS NOT EXACT FOR NON-PARALLEL PERSPECTIVE
          IPHI = MOD (NINT (ABS (PHIQX * RGBL(6) * 10.0)), 1800)
          ALF  = 0.0
          BET  = 0.0
C * TEST FOR PARALLEL BONDS (KIND = 2)
          IF (IPHI == 0) THEN
C * SPECIAL PARALLEL BOND CASE HANDLING
            IF (ABS (ZT) > 0.001)  THEN
              IF (ZT < 0.0) THEN
                GO TO 90
              ELSE
                GO TO 50
              END IF
            END IF
            IF (IPR(56) >= NRBD)    GO TO 90
            IF (IPR(56) <= IPR(68)) GO TO 90
C * SKIP THIS BOND BECAUSE OF REDUNDANCY
            GO TO 100
C * TEST FOR PERPENDICULAR BONDS (KIND = 1)
          ELSE IF (IPHI == 900) THEN
C * SPECIAL PERP BOND CASE HANDLING
            IF (DL2 > 0.0) ALF = -YT / DL2
            IF (DL1 > 0.0) BET =  XT / DL1
          ELSE
            TANP = TAN (PHIPX)
            XS   = (XT * TANP - YT) / TANP
            DL2C = DL2 * COS (PHIPX)
            IF (DL2C > 0.0) ALF = (XS - XT) / DL2C
            IF (DL1  > 0.0) BET =  XS / DL1
          END IF
C * GET Z-VALUES AT 'INTERSECTION' AND DIFFERENCE
          ZSJI  = (ZJ - ZQ12) * BET
          ZSMN  = (ZM - ZP12) * ALF + ZT
          ZMNJI = ZSMN - ZSJI
C * GET SHORT BOND-BOND CONTACT DISTANCE (APPROXIMATE)
          CRADP = (RM + RN) / 2.0
          CRADQ = (RJ + RI) / 2.0
          IF (ABS (ZMNJI) > 0.01) THEN
            IF (ABS (ALF) < 1.0 .AND. ABS (BET) < 1.0) THEN
C * TEST WHETHER BOND M-N PASSES BEHIND BOND J-I
C *             IF (ZMNJI < - (CRADP + CRADQ)) GO TO 90
C * CHANGED TO HANDLE DISORDER
              IF (ZMNJI < + (CRADP + CRADQ)) GO TO 90
            ELSE
              IF (ZT < (CRADP + CRADQ)) GO TO 90
            END IF
          ELSE
C * BONDS JOIN ( ABS(ALF) & ABS(BET) > 0)
            IF (ZT < 0.0) GO TO 90
          END IF
          GO TO 50
        ELSE IF (MODE == 3) THEN
          GO TO 40
        END IF
      END IF
C * GET LIST OF ATOMS WHICH OBSCURE ATOM M (OR BOND (M-N))
C * THIS ALLOWS FOR INTERSECTION OF SPHERES IN V.D. WAALS MODELS
   20 NL = 0
      J  = IPR(69)
      IF (LABI > 0) THEN
C * STICK & CPK-STICK CASE
        IF (IPR(4) <= 0) THEN
          J = NPA
        END IF
      END IF
C * GENERATE BRIGHT SPOT
      IF (MODE == 1) THEN
        IF (IPR(96) == 1) THEN
          ANG1 = PAR(51) / RGBL(6)
          ANG2 = PAR(52) / RGBL(6)
          CA   = COS (ANG1)
          SA   = SIN (ANG1)
          YJ   = YM + RM * SA / 2
          ZJ   = RM * CA / 2
          RJ   = RM / PAR(53)
          CA   = COS (ANG2)
          SA   = SIN (ANG2)
          ZD   = ZJ
          XJ   = XM + ZD * SA
          ZJ   = ZM + ZD * CA
          NJ   = 0
          CALL PLUT14 (0, NJ, IASU, NPROP, XJ, YJ, ZJ, RJ)
          NJ   = - NJ
          GO TO 50
        END IF
      END IF
   30 J = J + 1
      IF (J > JMAX)  GO TO 70
      IF (MODE < 3) THEN
C * SKIP IN CASE OF AUTO OVERLAP (ATOM-ATOM OR LABEL-ATOM)
        IF (J == MA)  GO TO 30
C * SKIP LABEL TO PARENT ATOM OVERLAP
        IF (LABI > 0) THEN
          IF (IGBL(75) == 1) THEN
             IF (LABI <= IPR(37)) THEN
               IF (LABI == J) GO TO 30
             ELSE
               IF ((LABI - NAB) == J) GO TO 30
             END IF
          ELSE
             IF (LABI == (J - IPR(69))) GO TO 30
          END IF
        END IF
      END IF
      JLAB = J - NPA
      IF (JLAB <= 0) THEN
        JO = MOD (J - ILPB, NAB) + ILPB
        CALL PLUT15 (-1, JO, 27, NINCL)
        IF (NINCL == 0) GO TO 30
      END IF
      I   = J * NP0 + IPR(158)
      XJ  = RA(I - 3)
      YJ  = RA(I - 2)
      ZJ  = RA(I - 1)
      RJ  = RA(I    )
C * SKIP VIRTUAL OR EXCLUDED ATOMS
      IF (JLAB > 0) THEN
C * HANDLE LABEL-LABEL OVERLAP
        IF (JLAB <= (IPR(37) * IGBL(75))) THEN
          IF (IPR(46) == 0 .AND. JLAB <= IPR(69)) GO TO 30
C * DO NOT CONSIDER UNSETTLED OR NOT INCLUDED LABELS
          CALL PLUT15 (-4, JLAB, 37, IVAL)
          IF (IVAL <= 1) GO TO 30
        ELSE
C * DO NOT CONSIDER UNSETTLED MOL LABELS
          IF (J > MA) GO TO 30
        END IF
        BX = ABS (XP12 - XJ)
        BY = ABS (YP12 - YJ)
        IF ((BY < 2.0 * PAR(28)) .AND. (BX < DL2 + RJ)) GO TO 100
      END IF
C * CHANGED FROM 499.9 TO 499.99 (16/11/02)
      IF (ABS (RJ - 500.0) > 499.99)  GO TO 30
      RSV1 = RJ
   40 BX   = XJ - XM
      BY   = YJ - YM
      BZ   = ZJ - ZM
C * J AND M ARE CONSIDERED EQUIVALENT WHEN THE DISTANCE BETWEEN THEIR
C * CENTRES IS LESS THAN RJ
      JEQM = 0
      BSQ2 = BX**2 + BY**2
      BSQ3 = BSQ2  + BZ**2
      IF (BSQ3 < RTEST) JEQM = 1
      IF (MODE == 1) THEN
C * SKIP THIS OVERLAP FOR J EQUIV M
        IF (JEQM /= 0) THEN
          IF (M <= J)  GO TO 30
C * SKIP THIS PLOT ITEM
          GO TO 100
        END IF
C * TEST WHETHER SPHERE J IS BELOW SPHERE M
        IF (BZ < - RJ)  GO TO 30
C * INTERSECTING SPHERES ARE MARKED WITH NEGATIVE J
        RMJ   = RM + RJ
C * COMPLETELY OVERLAPPED ATOM
        IF (BSQ2 < PAR(24) * 0.01) THEN
        END IF
C * TEST FOR INTERSECTING CIRCLES M AND J
        RMJSQ = RMJ**2
        IF (BSQ2 > RMJSQ)  GO TO 30
C * ENVELOPE CIRCL INTERS. IN PROJ. DOWN ZP - TEST FOR SPHERE INTERS.
        IF (BSQ3 < RMJSQ) THEN
          NJ = - J
        ELSE
          NJ = J
        END IF
      ELSE
C * BOND OVERLAP CASE
        CX = XJ - XN
        CY = YJ - YN
        CZ = ZJ - ZN
C * TEST FOR CASE J.EQ.N
        JEQN = 0
        CSQ3 = CX**2 + CY**2 + CZ**2
        IF (CSQ3 < RTEST) JEQN = 1
        IF (MODE == 3) THEN
C * SKIP THIS BOND WHEN ZJ ABOVE ZN AND ZM
          IF (BZ > RJ)  GO TO 90
          RSV1 = RN
          IF (JEQN /= 0 .OR. JEQM /= 0) THEN
C * BOND M-N EMERGES FROM ATOM J, GENERATE AUXILLARY PSEUDO ATOM AT
C *      THE POINT WHERE THE BOND INTERSECTS THE SPHERE
            IF (JEQN /= 1) THEN
              NJ = - N + 1
              NL = N
              IF (ZMN >= 0.0001 .AND. RM > 0.001) THEN
                RATIO = RN * SQRT (RMNS) / (RM * ZMN)
                IF (RATIO <= 1)  GO TO 90
              END IF
            ELSE
              NL   = N - 1
              NJ   = - N
              CPHI = - CPHI
              SPHI = - SPHI
            END IF
            GO TO 50
          END IF
C * TEST FOR BOND-CIRCLE INTERSECTION
        ELSE IF (LABI <= 0) THEN
          IF (JEQN == 1)  GO TO 30
          IF (CZ < 0)  GO TO 30
        END IF
C * TEST FOR ATOM/BOND INTERSECTION
        CALL PLUT20 (-1.0, RJ, 0.0, DL2, RM, RN, PHIP, XP12 - XJ,
     1   YP12 - YJ, IT, XMARG)
        IF (IT == 0)  THEN
          IF (LRET == 1) THEN
            GO TO 30
          ELSE IF (LRET == 2) THEN
            GO TO 90
          END IF
        END IF
C * THIS ATOM J / BOND (N-M) INTERSECTS IN PROJECTION (MODE 2 & 3)
C * SHIFT BOND M-N AND ATOM J TO ORIGIN AT BOND CENTRE
        XT12  = XJ - XP12
        YT12  = YJ - YP12
        ZT12  = ZJ - ZP12
C * ROTATE OVER PHIP
        XT    = XT12 * CSPHP + YT12 * SNPHP
        ZTEST = ZT12
        IF (DL2 > 0.0) ZTEST = ZTEST + (ZP12 - ZM) * XT / DL2
C * FIRST APPROXIMATION !
        RTST = (RM + RN) / 2.0 + RJ
C * ATOM OVER BOND CASE
        IF (MODE == 2) THEN
          NJ = J
          IF (BSQ3 < RJ**2) THEN
            NJ = - IABS (J)
          ELSE
            IF (JEQN == 0) THEN
              IF (ZTEST < RTST) GO TO 30
            END IF
          END IF
C * BOND OVER ATOM CASE (MODE = 3)
        ELSE
          IF (JEQN + JEQM == 0) THEN
C * CHANGED TO HANDLE DISORDER
            IF (ZTEST + RTST >= 0.0) GO TO 90
          END IF
        END IF
      END IF
C * ENTER THIS ATOM OR BOND TO THE OBSCURING LIST
   50 IABSNJ = IABS (NJ)
      CALL PLUT14 (-1, IABSNJ, IASU, NPROP, X1, Y1, Z1, RSV1)
C * BUT AVOID MULTIPLE ENTRY DUE TO SYMMETRY
      NOBSC = IPR(78)
      IPOP  = IPR(66)
      IF (NOBSC > 0) THEN
        DO INOBS = 1, NOBSC
          IPOP = IPOP - 13
          IF (ABS (RA(IPOP + 3) - X1) + ABS (RA(IPOP + 4) - Y1) +
     1          ABS (RA(IPOP + 5) - Z1) < 0.01) GO TO 60
        END DO
      END IF
C * STORE THIS OBSCURATION (WITH OVERLAP TYPE VIA +/- INDICATION)
C * NORMAL BOND OVERLAP        :     +NJ    +NL
C * INCOMING BOND IN SPHERE    :     -NJ    +NL
C * NORMAL OVERLAPPING SPHERE  :     +NJ     0
C * INTERPENETRATING SPHERE    :     -NJ     0
      IPR(78) = IPR(78) + 1
      IPOP    = IPR(66) - IPR(78) * 13
      IF (IPOP >= IPR(158) + (IPR(40) + IPR(67) + 1) * NP0) THEN
        RA(IPOP + 1) = NJ
        RA(IPOP + 2) = NL
        RA(IPOP + 3) = X1
        RA(IPOP + 4) = Y1
        RA(IPOP + 5) = Z1
        RA(IPOP + 6) = RSV1
        IF (NL /= 0) THEN
          CALL PLUT14 (-1, NL, IASU, NPROP, X2, Y2, Z2, RSV2)
          RA(IPOP + 7)  = RSV2
          RA(IPOP + 8)  = DL2
          RA(IPOP + 9)  = CPHI
          RA(IPOP + 10) = SPHI
          RA(IPOP + 11) = XP12
          RA(IPOP + 12) = YP12
        END IF
C * SAVE APPROPRIATE MARGIN
        IF (MODE < 4) THEN
          IF (NJ > 0) THEN
            DMARG = XMARG
          ELSE
            IF (MODE == 2) THEN
              DMARG = 0.0
            ELSE IF (MODE == 3) THEN
              IF (Z2 > Z1) THEN
C * SET SHADOW MARGIN
                IF (DL2 > 0.0) THEN
                  ALFA  = ATAN ((Z2 - Z1) / (DL2 * 2.0))
                ELSE
                  ALFA  = 90.0 / RGBL(6)
                END IF
                DMARG = PAR(58) * SIN (ALFA)
              ELSE
                DMARG = 0.0
              END IF
            ELSE
              DMARG = XMARG
            END IF
          END IF
        ELSE IF (MODE == 4) THEN
          DMARG = XMARG
        END IF
C * HANDLE PERSPECTIVE
        IF (PAR(48) > 0.0) DMARG = DMARG * PAR(48) / (PAR(48) - Z1)
        RA(IPOP + 13) = DMARG
      ELSE
        IPR(78) = IPR(78) - 1
      END IF
      NDUM = 0
   60 IF (LABI /= 0) THEN
C * QUIT OVERLAP SEARCH WHEN MORE THAN 2 ITEMS OVERLAPPING LABEL FOUND
        IF (IPR(78) >= 2) RETURN
      END IF
      IF (LRET == 1) THEN
        GO TO 30
      ELSE IF (LRET == 2) THEN
        GO TO 90
      END IF
C * NOW CONSIDER BOND/ATOM AND BOND/BOND OVERLAP
   70 IF (LABI <= 0) THEN
C * SKIP IF NO BOND-OVERLAP TEST REQUESTED
        IF (IPR(77) == 0) RETURN
        IF (MODE == 2 .AND. IABS (IPR(77)) > 1)  GO TO 80
        IF (IABS (IABS (IPR(77)) - 2) /= MODE) RETURN
      END IF
C * START FOR LOOP OVER BONDS
   80 MODE = MODE + 2
      XJ   = XM
      YJ   = YM
      ZJ   = ZM
      RJ   = RM
      LRET = 2
C * TEST FOR BOND OVER ATOM OVERLAP AND COPY DATA
      IF (MODE == 3) THEN
        J      = M
        RTEST  = RJ**2
C * TEST FOR BOND OVER BOND OVERLAP AND COPY DATA
      ELSE IF (MODE == 4) THEN
        RI     = RN
        PHIQ   = PHIP
        CSPHQ  = CSPHP
        SNPHQ  = SNPHP
        DL1    = DL2
        XQ12   = XP12
        YQ12   = YP12
        ZQ12   = ZP12
        ZIJMIN = ZMIN
        ZRIJ   = ZRMN
C * SAVE ZU7-ZU9
        ZU7    = ZU(7)
        ZU8    = ZU(8)
        ZU9    = ZU(9)
      END IF
C * LOOP OVER RELEVANT AND ACTIVE BONDS
      NRBD = 0
      NDUM = 0
      IF (IPR(4) > 0) THEN
        MNRB = IPR(97)
      ELSE
        MNRB = 0
      END IF
   90 NRBD = NRBD + 1
      IF (NRBD > MNRB) THEN
        IF (MODE == 4) THEN
C * RESTORE BOND INFORMATION FOR BOND ENDPOINTS IAT AND JAT
          ZU(7) = ZU7
          ZU(8) = ZU8
          ZU(9) = ZU9
        END IF
        RETURN
      END IF
      IPR(67) = IPR(67) - NDUM
      CALL PLUT16 (NRBD, II, M, N, RBO, NLI)
      IF (NLI < 0) NLI = IABS (NLI)
      NDUM = 2
C * SKIP SELF-OVERLAP OF BOND
      IF (MODE == 4) THEN
        IF (IPR(56) == NRBD) GO TO 90
      END IF
      IF (M == 0) GO TO 90
C * SCALE AND ADD OVERLAP MARGIN (TO) BOND RADIUS
      N   = IPR(67) + NP
      M   = N - 1
      NJ  = M
      NL  = N
      I   = M * NP0 + IPR(158)
      XM  = RA(I - 3)
      YM  = RA(I - 2)
      ZM  = RA(I - 1)
      RM  = RA(I    )
      GO TO 10
  100 IPR(78) = -1
      RETURN
      END SUBROUTINE PLUT18
 
      SUBROUTINE PLUT19 (M, MODE)
C * DRAW OBJECT, TAKING OBSCURATION LIST INTO ACCOUNT
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: M
      INTEGER :: NL
      INTEGER :: IP1
      INTEGER :: IP2
      INTEGER :: IPP
      INTEGER :: ITF
      INTEGER :: ITS
      INTEGER :: IUP
      INTEGER :: JNL
      INTEGER :: NPP
      INTEGER :: NRF
      INTEGER :: NRF1
      INTEGER :: IPOP
      INTEGER :: MODE
      INTEGER :: NINC
      INTEGER :: NOBSC
      INTEGER :: IDOWN
      INTEGER :: IDRAW
      INTEGER :: ISLOW
      INTEGER :: ISTEP
      INTEGER :: JMODE
      INTEGER :: LDRAW
      REAL    :: X
      REAL    :: Y
      REAL    :: Z
      REAL    :: X0
      REAL    :: Y0
      REAL    :: XA
      REAL    :: YA
      REAL    :: ZA
      REAL    :: DL
      REAL    :: CX
      REAL    :: CY
      REAL    :: SX
      REAL    :: SY
      REAL    :: RK
      REAL    :: RM
      REAL    :: XK
      REAL    :: YK
      REAL    :: ZK
      REAL    :: XM
      REAL    :: YM
      REAL    :: ZM
      REAL    :: XX
      REAL    :: YY
      REAL    :: XA0
      REAL    :: YA0
      REAL    :: RMS
      REAL    :: RNL
      REAL    :: RKB
      REAL    :: RKS
      REAL    :: DL2
      REAL    :: DSQ
      REAL    :: DUM
      REAL    :: DXK
      REAL    :: DYK
      REAL    :: DZK
      REAL    :: DZS
      REAL    :: DXM
      REAL    :: DYM
      REAL    :: XP12
      REAL    :: YP12
      REAL    :: SPHI
      REAL    :: DELX
      REAL    :: DELY
      REAL    :: DELZ
      REAL    :: D3SQ
      REAL    :: CPHI
      REAL    :: RBND
      REAL    :: DELXN
      REAL    :: DELYN
      REAL    :: DELZN
      REAL    :: DMARG
      REAL    :: RADIUS
C * MODE = 0    - DRAW CIRCLE MODE (CIRCLE PLOT TEST)
C *             - M == 0 FOR NORMAL CIRCLE PLOT
C *             - M > 0 FOR REAL OR DUMMY ATOM SPHERE INTERSECTION PLOT
C * MODE = +/-  - DRAW LINE MODE (LINE PLOT TEST)
C *             - M == 0 FOR BOND PLOT
C *             - M /= 0 FOR SHADE OR DOT PLOT OF ATOM M
      IUP     = 0
      IPP     = 0
      NINC    = 0
      ISLOW   = 0
      NOBSC   = IPR(78)
      IPR(98) = 0
      IDOWN   = 3
      LDRAW   = 0
      IDRAW   = 3
      ISTEP   = 1
      DELX    = 0.0
      DELY    = 0.0
      DELZ    = 0.0
      DL      = 0.0
      DZS     = 0.0
      RADIUS  = 0.0
      CX      = 0.0
      SX      = 0.0
      CY      = 0.0
      SY      = 0.0
      RNL     = 0.0
      DL2     = 0.0
      CPHI    = 0.0
      SPHI    = 0.0
      XP12    = 0.0
      YP12    = 0.0
      DYM     = 0.0
      DXM     = 0.0
      RMS     = 0.0
      ZM      = 0.0
C * TEST FOR LINE OR DOT MODE
      IF (MODE /= 0) THEN
        IF (MODE < 0) THEN
          NRF  = 3
          NRF1 = 0
        ELSE
          NRF  = 0
          NRF1 = 3
        END IF
        X    = XYZPL(NRF  + 1)
        Y    = XYZPL(NRF  + 2)
        Z    = XYZPL(NRF  + 3)
        DELX = XYZPL(NRF1 + 1) - X
        DELY = XYZPL(NRF1 + 2) - Y
        DELZ = XYZPL(NRF1 + 3) - Z
C * HANDLE STICK COLOR MODE
        IF (IPR(4) == 0) THEN
          IF (IPR(346) == 1) THEN
            DELX = DELX / 2.0
            DELY = DELY / 2.0
            DELZ = DELZ / 2.0
          END IF
        END IF
        DL = SQRT (DELX ** 2 + DELY ** 2)
        IF (NOBSC > 0) THEN
          NINC = (INT (DL / PAR(5)) + 1) * IPR(111)
          DELX = DELX / NINC
          DELY = DELY / NINC
          DELZ = DELZ / NINC
        ELSE
          NINC  = 1
        END IF
        IF (NOBSC > 0) THEN
          IF (M /= 0) THEN
C * GET COORDINATES AND RADIUS OF ATOM TO SHADE
            XM  = XYZK(1)
            YM  = XYZK(2)
            ZM  = XYZK(3)
            RM  = XYZK(4)
            RMS = RM ** 2
            DXM = X - XM
            DYM = Y - YM
            DZS = (Z - ZM) ** 2
          END IF
        END IF
        GO TO 50
C * MODE = 0 : CIRCLE PLOT TEST SECTION
      ELSE
C * GET NUMBER OF POINTS = SEGMENTS
        NPP = IPR(91) * IPR(87)
C * SKIP OBSCURATION LOOP WHEN NO OBSCURATIONS AND NON-GLOBE MODE
        IF (NOBSC == 0 .AND. IPR(139) == 0 .AND.
     1      IPR(162) /= 8 .AND. IPR(162) /= 9) THEN
           CALL PLUT30 (0, NPP)
           RETURN
        ELSE
          RADIUS = PAR(74)
C * DEFINE ANGLE INCREMENT
          CX     = COS (PAR(55))
          SX     = SIN (PAR(55))
C * DEFINE STARTING POINT
          CY     = COS (PAR(57))
          SY     = SIN (PAR(57))
          IUP    = 1
          ITS    = 0
          ITF    = 0
          IPP    = -1
          GO TO 40
        END IF
      END IF
C * AN OBSCURING ATOM HAS BEEN FOUND IN CIRCLE MODE, LIFT THE PEN.
   10 IF (IUP == 0) ITF = IPP - 1
      IUP = 1
      GO TO 30
C * NO OBSCURING IN CIRCLE MODE SO GO AHEAD WITH PLOTTING OF THIS STEP.
   20 IF (IUP == 1) THEN
        CALL PLUT30 (ITS, ITF)
        ITS = IPP
      END IF
      ITF = IPP
      IUP = 0
C * NEXT POINT OF CIRCLE
   30 DUM = CY * CX - SY * SX
      SY  = SY * CX + CY * SX
      CY  = DUM
   40 IPP = IPP + 1
      IF (IPP > NPP) THEN
C * OUTPUT (FINAL) RESULT AND RETURN
        CALL PLUT30 (ITS, ITF)
        RETURN
      END IF
      XX = CY * RADIUS
      YY = SY * RADIUS
      Z  = ZU(3) * XX + ZU(6) * YY + PAR(73)
C * NOW PLOT THIS POINT, TEST FOR OBSCURATION
      IF (XYZK(3) > Z) GO TO 10
      X = ZU(1) * XX + ZU(4) * YY + PAR(71)
      Y = ZU(2) * XX + ZU(5) * YY + PAR(72)
C * START LOOP OVER OBSCURATIONS
C * NORMAL BOND OVERLAP        :     +J    +NL  : JNL = 3
C * INCOMING BOND IN SPHERE    :     -J    +NL  :     = 2
C * NORMAL OVERLAPPING SPHERE  :     +J     0   :     = 1
C * INTERPENETRATING SPHERE    :     -J     0   :     = 0
   50 JMODE = - 1
      IPOP  = IPR(66)
   60 IF (JMODE + NOBSC >= 0) THEN
        IPOP  = IPOP  - 13
        JMODE = JMODE - 1
        J     = NINT (RA(IPOP + 1))
        IF (J > 0) THEN
          K   = J
          JNL = 1
        ELSE
          K   = - J
          JNL = 0
        END IF
        NL  = NINT(RA(IPOP + 2))
        XK  = RA(IPOP + 3)
        YK  = RA(IPOP + 4)
        ZK  = RA(IPOP + 5)
        RK  = RA(IPOP + 6)
        RKB = RK
        IF (NL > 0) THEN
          JNL  = JNL + 2
          RNL  = RA(IPOP + 7)
          DL2  = RA(IPOP + 8)
          CPHI = RA(IPOP + 9)
          SPHI = RA(IPOP + 10)
          XP12 = RA(IPOP + 11)
          YP12 = RA(IPOP + 12)
        END IF
        DMARG = RA(IPOP + 13)
C * TEST FOR OVERLAP BY ATOM OR INCOMING BOND CASE
        IF (JNL < 3) THEN
C * TEST WHETHER POINT X,Y,Z IS OUTSIDE SPHERE OF RADIUS RK
          DXK = X - XK
          DYK = Y - YK
          DZK = Z - ZK
          DSQ = DXK**2 + DYK**2
          IF (MODE == 0) THEN
C * OVERLAP BY NON-INTERSECTING ATOM
            IF (JNL == 1 .AND. M == 0) THEN
              RK = RK + DMARG
            ELSE IF (JNL > 0) THEN
              IF (M /= 0) THEN
                RK = RK + DMARG
              ELSE
                DMARG = 0.0
              END IF
            END IF
          ELSE
C * MODE /= 0 (DMARG = 0 FOR MODE 3, J < 0)
            RK = RK + DMARG
          END IF
          RKS = RK**2
C * POINT XK, YK IS OBSCURED WHEN WITHIN ENVELOPE CIRCLE K AND ZK > Z
          IF (DSQ < RKS) THEN
C * BOND - ENDPOINT OVERLAP CASE TEST (LINE)
            IF (MODE /= 0 .AND. J < 0) THEN
              IF (DZK < 0.0) GO TO 70
            ELSE IF (J > 0 .OR. MODE == 0) THEN
              IF (DZK <= 0.0)  GO TO 70
            ELSE
C * POINT WITHIN SPHERE TEST
              D3SQ = DSQ + DZK**2
              IF (D3SQ < RKS)  GO TO 70
            END IF
          END IF
          IF (MODE /= 0) THEN
C * LINE  MODE /= 0
            IF (M /= 0) THEN
              IF (RKS >= DSQ) THEN
C * TEST WHETHER X, Y, Z IN SPHERE K
                IF (DZS < 0)  GO TO 70
                DZK = SQRT (DZS) + ZM - ZK
                DSQ = DSQ + DZK**2
                IF (DSQ < RKS)  GO TO 70
              END IF
            END IF
          ELSE
C * CIRCLE MODE = 0 CASE
            IF (J < 0) THEN
C * POINT IS OBSCURED IF WITHIN SPHERE J
              IF (K /= M) THEN
                DZK = Z - ZK
                DSQ = DSQ + DZK**2
                IF (DSQ < RKS)  GO TO 70
              END IF
            END IF
          END IF
          IF (NL == 0)  GO TO 60
        END IF
        IF (M > 0 .OR. J < 0) THEN
          IF (XYZK(3) >= ZK)  GO TO 60
        END IF
C * SET BOND RADIUS EQUAL TO PSEUDO ATOM RADII
C * TEST WHETHER X,Y IS WITHIN BOND
C * ROTATE AXIS SYSTEM (X,Y) SUCH THAT BONDS ARE ALONG X-NEW
        X0  = X - XP12
        Y0  = Y - YP12
        XA0 = CPHI * X0 + SPHI * Y0
        IF (ABS (XA0) > DL2)  GO TO 60
        YA0 = -SPHI * X0 + CPHI * Y0
C * CALCULATE THICKNESS OF BOND AT XA0 (WITH MARGIN)
        IF (DL2 /= 0) THEN
          RBND = ((RKB + RNL) + (RNL - RKB) * XA0 / DL2) / 2.0 + DMARG
        ELSE
          RBND = DMARG
        END IF
        IF (ABS(YA0) > RBND)  GO TO 60
C * OBSCURED POINT FOUND, MAKE THIS OBSCURATION AS THE FIRST ONE IN THE
C * LIST (EXCHANGE) EXCEPT FOR SPHERE INTERSECTION CASE
   70   IF (JMODE < -2) THEN
          IF (M <= 0) THEN
            IP1 = IPR(66) - 13
            IP2 = IPR(66) + (JMODE + 1) * 13
            DO I = 1, 13
              DUM         = RA(IP1 + I)
              RA(IP1 + I) = RA(IP2 + I)
              RA(IP2 + I) = DUM
            END DO
          END IF
        END IF
        IF (MODE == 0) GO TO 10
        IDRAW = 3
      ELSE
C * END OF OBSCURATION LOOP - NO OBSCURATION FOUND FOR THIS POINT
        IF (MODE == 0) GO TO 20
        IDRAW = 2
      END IF
C * IDRAW SIGNALS WHETHER TO DRAW THE LINE AT THE CURRENT POINT
C * (IDRAW = 3/2 FOR NO/YES)
C * IDOWN RECORDS THE APPARENT STATUS OF THE PEN = 3/2 FOR UP/DOWN
      IF (LDRAW /= IDRAW) THEN
C * LDRAW /= 0
        IF (LDRAW /= 0) THEN
          IF (ISTEP > 1) THEN
C * RETEST WITH SMALL STEP
            ISTEP = 1 - ISTEP
            ISLOW = - ISTEP
            NINC  = NINC - ISTEP
            DELXN = DELX * ISTEP
            DELYN = DELY * ISTEP
            DELZN = DELZ * ISTEP
            GO TO 80
          ELSE
            ISTEP = 1
            IF (ISLOW > 0) ISLOW = ISLOW - 1
          END IF
        ELSE
C * LDRAW == 0
          LDRAW = IDRAW
          IF (DL < PAR(5)) THEN
C * EXIT DL == 0.0
            IF (IDRAW == 3 .AND. ABS (DL) < 0.0001) THEN
              RETURN
            ELSE
              ISLOW = IPR(111) - 1
              ISTEP = 1
            END IF
          ELSE
            ISLOW = 0
            ISTEP = IPR(111)
          END IF
          IF (ISTEP > NINC) ISTEP = NINC
        END IF
      ELSE
C * LDRAW = IDRAW
        IF (ISLOW > 0) THEN
          ISTEP = 1
          ISLOW = ISLOW -1
        ELSE
          ISTEP = IPR(111)
          IF (ISTEP > NINC) ISTEP = NINC
        END IF
      END IF
      IF (NINC == 0) IDRAW = 3
      LDRAW = IDRAW
      IF (IDRAW == 2) THEN
        IF (IDOWN == 3) THEN
C * NOTE THE STARTING POINT OF A LINE SEGMENT AT THIS POINT (XA,YA,ZA).
          XA = X
          YA = Y
          IF (MODE == 0 .OR. M == 0) THEN
            ZA = Z
          ELSE
            ZA = ZM
          END IF
          IDOWN = 2
        END IF
      ELSE
C * OBSCURING OCCURS AT THIS POINT. DRAW LINE SEGMENT (XA,YA) TO (X,Y)
C * THEN LIFT THE PEN
        IF (IDOWN == 2) THEN
          CALL GGIP (XA, YA, ZA, 3)
          CALL GGIP (X,  Y,  Z,  2)
          IDOWN = 3
        END IF
        IF (NINC <= 0) RETURN
      END IF
      IF (NINC == 1) THEN
        NINC  = 0
        DELXN = DELX
        DELYN = DELY
        DELZN = DELZ
      ELSE
        NINC  = NINC - ISTEP
        DELXN = DELX * ISTEP
        DELYN = DELY * ISTEP
        DELZN = DELZ * ISTEP
      END IF
   80 X = X + DELXN
      Y = Y + DELYN
      IF (M /= 0) THEN
C * CALCULATE NEW Z COORDINATE ON THE SPHERE SURFACE
        DXM = DXM + DELXN
        DYM = DYM + DELYN
        DZS = RMS - DXM**2 - DYM**2
        Z   = ZM  + SQRT (ABS (DZS))
      ELSE
        Z = Z + DELZN
      END IF
      GO TO 50
      END SUBROUTINE PLUT19
 
      SUBROUTINE PLUT20 (XDL1, XRJ, XRI, XDL2, XRM, XRN, XPHI, XXT,
     1                   XYT, IT, XOVRL)
C * SUBROUTINE TESTS FOR TWO DIMENSIONAL INTERSECTION OF BOND/BOND AND
C * BOND/ATOM OVERLAP SITUATIONS.
      IMPLICIT NONE
      INTEGER :: K
      INTEGER :: L
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IT
      INTEGER :: IBX
      INTEGER :: IBY
      REAL    :: X
      REAL    :: Y
      REAL    :: BX
      REAL    :: BY
      REAL    :: XRJ
      REAL    :: XRI
      REAL    :: XRM
      REAL    :: XRN
      REAL    :: XXT
      REAL    :: XYT
      REAL    :: CSPH
      REAL    :: SNPH
      REAL    :: XDL1
      REAL    :: XDL2
      REAL    :: XPHI
      REAL    :: XOVRL
      REAL    :: X0CSPH
      REAL    :: X0SNPH
      REAL    :: Y0CSPH
      REAL    :: Y0SNPH
C *---------------------------------------------------------------------C
C *                                                                     C
C *          -1,+1     I           0,+1          I     +1,+1           C
C *                    I                         I                     C
C *        ------------I-------------------------I------------         C
C *                    I                         I                     C
C *          -1, 0     I           0, 0          I     +1, 0           C
C *                    I                         I                     C
C *        ------------I-------------------------I------------         C
C *                    I                         I                     C
C *          -1,-1     I           0,-1          I     +1,-1           C
C *                                                                    C
C *--------------------------------------------------------------------C
C * IT = 0 : NO OVERLAP
C * IT = 1 : OVERLAP
      X0CSPH = 0.0
      X0SNPH = 0.0
      IX     = 0
      IY     = 0
      IT     = 1
      IBX    = 0
      IBY    = 0
      IF (ABS (XPHI) < 0.0001) THEN
        CSPH = 1.0
        SNPH = 0.0
      ELSE
        CSPH = COS (XPHI)
        SNPH = SIN (XPHI)
      END IF
      DO 10 L = 1, 3, 2
        IF (L == 1) THEN
          X0CSPH = -XDL2 * CSPH
          X0SNPH = -XDL2 * SNPH
          Y0CSPH = -XRN  * CSPH
          Y0SNPH = -XRN  * SNPH
        ELSE
          X0CSPH = -X0CSPH
          X0SNPH = -X0SNPH
          Y0CSPH = -XRM * CSPH
          Y0SNPH = -XRM * SNPH
        END IF
        DO K = 1, 3, 2
          IF (K == 1) THEN
            X = X0CSPH - Y0SNPH + XXT
            Y = X0SNPH + Y0CSPH + XYT
          ELSE
            X = X0CSPH + Y0SNPH + XXT
            Y = X0SNPH - Y0CSPH + XYT
          END IF
          IF (XDL1 < 0.0) THEN
C * ATOM/BOND CASE
            BX = XRJ
            BY = XRJ
C * HANDLE INSIDE SPHERE ENCLOSURE/OUTSIDE SPHERE CASE
            IF (ABS (X) < XRJ .AND. ABS (Y) < XRJ) THEN
              IF (X**2 + Y**2 > XRJ**2) THEN
                IF (X > 0) THEN
                  IBX = 2
                ELSE
                  IBX = -2
                END IF
                IF (Y > 0) THEN
                  IBY = 2
                ELSE
                  IBY = -2
                END IF
              ELSE
                IBX = 0
                IBY = 0
                GO TO 10
              END IF
            END IF
          ELSE
C * BOND/BOND CASE
            BX = XDL1
            BY = ((XRJ + XRI) + (XRJ - XRI) * X / XDL1) / 2.0 + XOVRL
            IF (BY < 0.0) BY = 0.0
          END IF
          IF (X > BX) THEN
            IX = IX + 1
          ELSE IF (X + BX < 0.0) THEN
            IX = IX - 1
          END IF
          IF (Y > BY) THEN
            IY = IY + 1
          ELSE IF (Y + BY < 0.0) THEN
            IY = IY - 1
          END IF
        END DO
   10 CONTINUE
      IF (IBX == 0) THEN
        IF (IABS (IX) == 4 .OR. IABS (IY) == 4) IT = 0
      ELSE
        IF (IX == IBX .AND. IY == IBY) IT = 0
      END IF
      RETURN
      END SUBROUTINE PLUT20
 
      SUBROUTINE PLUT21 (MODE)
      USE files
      USE parameters
      USE atomdata
      USE pluto
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: N1
      INTEGER          :: N2
      INTEGER          :: N3
      INTEGER          :: KL
      INTEGER          :: KN
      INTEGER          :: N10
      INTEGER          :: N20
      INTEGER          :: JP1
      INTEGER          :: JPL
      INTEGER          :: IAT
      INTEGER          :: JAT
      INTEGER          :: IRB
      INTEGER          :: ITO
      INTEGER          :: KNB
      INTEGER          :: NRF
      INTEGEr          :: ITOH
      INTEGER          :: MODR
      INTEGER          :: MODE
      INTEGER          :: IDASH
      INTEGER          :: ITOCG
      INTEGER          :: NSPEC
      INTEGER          :: ITOMET
      REAL             :: RB
      REAL             :: RMIN
      REAL             :: XDUM
      CHARACTER(len=2) :: J212
      CHARACTER(len=3) :: JJ13
      CHARACTER(len=3) :: J313
C * RADII CARD. THIS SETS RADII FOR ATOMS AND BONDS. THERE ARE SEVERAL
C * OPTIONS FOR BOND SPECIFICATION, ATOM TYPE, INTERMOLECULAR, TO
C * LIST, SPECIFIC ATOM PAIR.  WE ALSO ENTER NUMBER OF LINES FOR BOND.
C * TAPERING OF BONDS MAY BE CONTROLLED ALSO.
C * MODE = -1 : AUTOMATIC (SOLID/STRAW/ROD) RADII ASSIGNMENT
C * MODE =  0 : HANDLE RADII INSTRUCTION
C * MODE =  1 : AUTOMATIC CPK RADII ASSIGNMENT
      N1     = 0
      N2     = 0
      ITOH   = 0
      ITOMET = 0
      ITOCG  = 0
      KL = IPR(220)
      KN = IPR(221)
      IPR(72) = 0
      MODR    = MODE
      IF (MODR == 0) THEN
        IPR(130) = 0
        IF (KL < 3) THEN
          IPR(72) = 32
          RETURN
        END IF
        N = 0
        J212 = IFL(2)(1:2)
C * TEST SUB-KEYWORD BONDS
        IF (J212 == 'BO') THEN
          IDASH = 1
          DO 10 J = 3, KL
            JJ13 = IFL(J)(1:3)
C * TEST FOR SUB-KEYWORD DASH
            IF (JJ13 == 'DAS') THEN
              IDASH = -1
              GO TO 10
            END IF
C * TEST SUB-KEYWORD TAPERING
            IF (JJ13 == 'TAP') THEN
              IF (KN == 0) THEN
                IPR(72) = 33
              ELSE
                PAR(44) = FN(1)
              END IF
               RETURN
            END IF
C * TEST SUB-KEYWORD ALL
            IF (JJ13 == 'ALL') THEN
C * CHANGE DEFAULT SETTINGS FOR RADIUS AND LINES OF ALL BONDS
              IF (KN == 0) THEN
                IPR(72) = 34
              ELSE
                IPR(41) = 0
                PAR(38) = FN(1)
                IF (KN >= 2) IPR(12) = NINT (ABS (FN(2)) * IDASH)
              END IF
              RETURN
            END IF
C * SUB-KEYWORD NORMAL
            IF (JJ13 == 'NOR') THEN
C * CHANGE DEFAULT SETTINGS FOR RADIUS AND LINES OF NORMAL BONDS
              IF (KN == 0) THEN
                IPR(72) = 35
              ELSE
                PAR(38) = FN(1)
                IF (KN >= 2) IPR(12) = NINT (ABS (FN(2)) * IDASH)
              END IF
              RETURN
            END IF
            IF (JJ13 == 'TO') THEN
C * KEYWORD  -TO-  FOLLOWED BY ATOM NAME OR ATOM TYPE
              JPL = - J - 1
              CALL PLUT13 (0, JPL, M, XDUM)
              IF (M == 0) THEN
                IPR(72) = 36
              ELSE
                N1 = 0
                N2 = M
              END IF
              GO TO 20
C * INTER
            ELSE IF (JJ13 == 'INT') THEN
C * KEYWORD INTER FOR ALL INTERMOLECULAR BONDS
              N1 = -1
              N2 = 0
              GO TO 20
            ELSE
              JP1 = J + 1
              CALL PLUT13 (0, J,   IAT, XDUM)
              CALL PLUT13 (0, JP1, JAT, XDUM)
              IF (IAT > 0 .AND. JAT > 0) THEN
C * SPECIFIC BOND NAMED HERE
                N1 = MIN (IAT, JAT)
                N2 = MAX (IAT, JAT)
                GO TO 20
              ELSE
                IPR(72) = 37
              END IF
            END IF
   10     CONTINUE
   20     IF (IPR(72) == 0) THEN
C * TEST FOR ARU
            IF (KN > 0) THEN
              KNB = 0
              IF (FN(1) > 1.0) THEN
                KNB = 1
                IF (KN == 1) THEN
                  KN    = 3
                  FN(2) = 0.02
                  FN(3) = 5.0
                END IF
              END IF
C * STORE BOND RADIUS AND NUMBER OF LINES (IF NO-PREVIOUS ERROR DETECTED)
 
              IF (KN > KNB) THEN
                RB = FN(KNB + 1)
              ELSE
                RB = PAR(38)
              END IF
              IF (KN > KNB + 1) THEN
                L = NINT (FN(KNB + 2))
              ELSE
                L = IPR(12)
              END IF
            END IF
            L = IABS (L) * IDASH
            IF (L == 1) THEN
              IRB = 1
            ELSE
              IRB = NINT (RB * 1000.0)
            END IF
            N3    = ISIGN (1000 * IABS(L) + IRB, L)
            NSPEC = IPR(41)
            NRF   = IPR(80)
            DO I = 1, NSPEC
              N10 = NINT (RA(NRF))
              N20 = NINT (RA(NRF - 1))
              IF (N1 == N10 .AND. N2 == N20)  GO TO 30
              NRF = NRF - 3
            END DO
            IF (IPR(41) >= IPR(76)) THEN
              WRITE (LU6, 99999, IOSTAT = IOST)
              RETURN
            END IF
            IPR(41)     = IPR(41) + 1
            RA(NRF)     = N1
            RA(NRF - 1) = N2
   30       RA(NRF - 2) = N3
C * STORE NEW -TO H- VALUES FOR FUTURE USE
            IF (NRF == IPR(80)) THEN
              IF (IPR(4) == 1) THEN
                IPR(103) = N3
              ELSE IF (IPR(4) == 2) THEN
                IPR(104) = N3
              ELSE IF (IPR(4) == 4) THEN
                IPR(106) = N3
              END IF
            END IF
          END IF
C * TEST KEYWORD ATOMS
        ELSE IF (J212 == 'AT') THEN
          J313  = IFL(3)(1:3)
C * ATOM RADIUS SPECIFICATION HERE
          IF (KL < 3) THEN
            GO TO 50
          ELSE IF (KL > 3) THEN
            GO TO 40
          END IF
          IF (J313 == 'ALL') THEN
C * RADII ATOMS ALL
            IF (KN == 0) THEN
              IPR(72) = 38
            ELSE
              DO I = 1, IAN
                 IF (KN >= 1) THEN
                   RADR(I, 1) = FN(1)
                 ELSE
                   RADR(I, 1) = PAR(70)
                 END IF
              END DO
              IPR(99) = 1
            END IF
            RETURN
          END IF
          IPR(99) = 2
C * RADII ATOMS AUTO
          IF (J313 == 'AUT') THEN
            IF (IABS (IPR(4)) == 3) THEN
              MODR   = 1
            ELSE
              MODR   = -1
              IPR(4) = 1
            END IF
             GO TO 50
C * RADII ATOMS COVALENT
          ELSE IF (J313 == 'COV') THEN
            MODR   = -1
            IPR(4) = 1
            GO TO 50
C * RADII ATOMS CPK
          ELSE IF (J313 == 'CPK')  THEN
            MODR   = 1
            GO TO 50
          END IF
   40     DO K = 3, KL
            CALL PLUT13 (0, -K, IAT, XDUM)
C * RADII FOR ATOM TYPES
            IF (IAT < 0) THEN
              M = - IAT
              N = N + 1
              IF (N > KN) THEN
                IPR(72) = 39
                RETURN
              ELSE
                RADR(M, 1) = FN(N)
              END IF
C * RADII FOR INDIVIDUAL ATOMS
            ELSE
              N = N + 1
              IF (N > KN) THEN
                IPR(72) = 39
                RETURN
              END IF
              RA(IAT * NP43 + 11) = FN(N)
            END IF
          END DO
          IPR(99) = 2
        ELSE
          IPR(72) = 41
        END IF
      END IF
   50 IF (MODR < 0) THEN
C * SET UP DEFAULT SPECIAL BOND LIST : RA() = (NL + RB) * 1000
C * NEGATIVE ENTRY = DASHED BOND
C * SET :  RADII INTER 0.020 5 (DASHED)
        RA(IPR(80)    ) = -1
        RA(IPR(80) - 1) = 0
        RA(IPR(80) - 2) = -5020
        IPR(41)         = 1
C * AUTOMATIC ASSIGNMENT OF NORMAL BOND RADII
        IF (IPR(4) == 0) THEN
          CALL GEN074 (RADR, 1, IAN, 0.0)
        ELSE
          IF (IPR(4) == 1) THEN
C * SOLID RADII RESET
            PAR(38)     = 0.05
            IPR(12)     = 30
            PAR(21)     = PAR(351)
            ITOH        = IPR(103)
            ITOMET      = 2040
            ITOCG       = -6040
          ELSE IF (IPR(4) == 2) THEN
C * ROD MODE RADII RESET
            PAR(38)     = 0.2
            IPR(12)     = 8
            PAR(21)     = PAR(352)
            ITOH        = IPR(104)
            ITOMET      = 2040
            ITOCG       = -6040
          ELSE IF (IPR(4) == 4) THEN
C * STRAW MODE RADII RESET
            PAR(38)     = 0.12
            IPR(12)     = 2
            PAR(21)     = PAR(354)
            ITOH        = IPR(106)
            ITOMET      = -6040
            ITOCG       = -6040
          END IF
          RMIN            = MOD(ITOH, 1000) / 1000.0
C * SET :  RADII BONDS TO METAL 0.04 2 (0.12 20 for STRAW)
C * SET :  RADII BONDS TO CG    0.06 6 DASH
          DO I = 1, IAN
C * TO CG-'ATOM'
            IF (IEN(I) == 106) THEN
              ITO = ITOCG
C * TO Q-ATOM
            ELSE IF (IEN(I) == 111) THEN
              ITO = 1010
C * TO METAL
            ELSE IF (IATPR(IEN(I)) >= 0) THEN
              ITO = ITOMET
            ELSE
              ITO = 0
            END IF
            IF (ITO /= 0) THEN
              RA(IPR(80) - IPR(41) * 3)     = 0
              RA(IPR(80) - IPR(41) * 3 - 1) = -I
              RA(IPR(80) - IPR(41) * 3 - 2) = ITO
              IPR(41)                       = IPR(41) + 1
            END IF
C * AUTOMATIC ASSIGNMENT OF SOLID/ROD/STRAW RADII BASED ON COVALENT RADII
            RADR(I, 1) = MAX (PAR(21) * RADR(I, 3), RMIN)
          END DO
C * (RE)SET: RADII BONDS TO H (SOLID: 0.035 4, ROD: 0.07 3, STRAW: 0.10 2)
          RA(IPR(80) - IPR(41) * 3)     = 0
          RA(IPR(80) - IPR(41) * 3 - 1) = -1
          RA(IPR(80) - IPR(41) * 3 - 2) = ITOH
          IPR(41)                       = IPR(41) + 1
          IPR(94)                       = IPR(41)
          IPR(77)                       = 3
          WRITE (LU6, 99998, IOSTAT = IOST) PAR(21)
        END IF
      ELSE IF (MODR > 0) THEN
        DO I = 1, IAN
          RADR(I, 1) = ABS (VDWR(IEN(I)))
        END DO
        WRITE (LU6, 99997, IOSTAT = IOST)
        PAR(38) = 0.0
        IPR(12) = 0
        IPR(4)  = 3
        IPR(77) = 3
        IPR(41) = 0
      END IF
      RETURN
99999 FORMAT (':: Not enough storage, Request IGNORED',/)
99998 FORMAT (':: Atom Radii (RE)SET to ', F5.2, ' x Covalent Radii')
99997 FORMAT (':: Atom Radii (RE)SET to van der Waals Radii')
      END SUBROUTINE PLUT21
 
      SUBROUTINE PLUT22 (I, J, D)
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: L
      REAL    :: D
      D = 0
      DO L = 4, 6
        D = D + (RA(I * NP43 + L) - RA(J * NP43 + L))**2
      END DO
      D = SQRT (ABS (D))
      RETURN
      END SUBROUTINE PLUT22
 
      SUBROUTINE PLUT23 (MODE)
C * ORTHOGONALIZATION
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: MODE
      REAL    :: ARG
      REAL    :: DET
      REAL    :: AXHI
      REAL    :: AXLO
C * MODE <   0 : IPR(51) = 1 + ORTHOGON. MATRIX
C * MODE =>  0 : ORTHOGONALIZE X, Y, Z ATOM MODE
C * PAR(101) = A
C * PAR(102) = B
C * PAR(103) = C
C * PAR(104) = COS(ALPHA)
C * PAR(105) = COS(BETA)
C * PAR(106) = COS(GAMMA)
C * PAR(107) = SIN(ALPHA)
C * PAR(108) = SIN(BETA)
C * PAR(109) = SIN(GAMMA)
C * PAR(110) = COS(ALPHA*)
C * PAR(111) = COS(BETA*)
C * PAR(112) = COS(GAMMA*)
C * PAR(113) = 1/A*
C * PAR(114) = 1/B*
C * PAR(115) = 1/C*
C * PAR(116) =
C * PAR(117) =
C * PAR(118) =
C * PAR(119) = ALPHA
C * PAR(120) = BETA
C * PAR(121) = GAMMA
C * PAR(126) = VOLUME
      IF (MODE >= 0) THEN
C * CALCULATE ORTHOGONAL COORDINATES FOR ATOM 'MODE'
        I = MODE * NP43
        DO J = 1, 3
          RA(I + J + 3) = 0.0
          DO K = J, 3
             RA(I + J + 3) = RA(I + J + 3) + OM(J, K) * RA(I + K)
          END DO
        END DO
C * ORTHOGONALISE
      ELSE
C * CHECK FOR ANGSTROM DATA CASE
        IF (IABS (IPR(50)) == 1) THEN
C * TEST FOR NO EXPLICIT ANGSTROM CASE
          IF (IPR(50) == 1) THEN
            WRITE (LU6, 99999, IOSTAT = IOST)
          ELSE
C * RESET TO POSITIVE
            IPR(50) = 1
          END IF
          IPR(37)  = 0
C * SET CELL FLAG (1, 1, 1, 90, 90, 90)
          IPR(52)  = 0
          IPR(53)  = 0
          IPR(68)  = 0
          IPR(69)  = 0
          IGBL(30) = 1
          IGBL(33) = 0
          CALL GEN074 (PAR, 101, 103, 1.0)
          PAR(148) = 90.0
        END IF
        IPR(51) = 1
        IF (PAR(104) == 0.0) PAR(104) = 90.0
        IF (PAR(105) == 0.0) PAR(105) = 90.0
        IF (PAR(106) == 0.0) PAR(106) = PAR(148)
C * CALCULATE METRIC (TEMP STORE IN OM)
        CALL GEN026 (1, OM, PAR(101))
C * APPLY AXES TRANSFORMATION
        IF (IPR(127) > 0) THEN
          CALL GEN001 (1, TMX, OM, ROM)
          CALL GEN026 (-1, ROM, PAR(101))
          WRITE (LU6, 99998, IOSTAT = IOST) (PAR(J), J = 101, 106)
        END IF
C * APPLY SYMMETRY CONSTRAINTS ON CELL DIMENSIONS
        CALL GEN066 (0, PAR(101), PAR(107), SPGRNM(1)(12:12), IPR(783))
C * DUNITZ TYPE ORTHOGONALISATION
        CALL GEN044 (PAR(101), OM, 1)
C * GET INVERSE MATRIX FOR ORTHOG. TO FRACT. TRANSFORMATION
        CALL GEN003 (OM, ROM, DET, 0)
        ARG = 1.0
        DO J = 4, 6
          PAR(115 + J) = PAR(100 + J)
          PAR(103 + J) = SIN (PAR(100 + J) / RGBL(6))
          PAR(100 + J) = COS (PAR(100 + J) / RGBL(6))
          ARG          = ARG - PAR(100 + J)**2
        END DO
        PAR(126) = PAR(101) * PAR(102) * PAR(103) *
     1  SQRT (ARG + 2.0 * PAR(104) * PAR(105) * PAR(106))
        PAR(110) = (PAR(105) * PAR(106) - PAR(104)) /
     1             (PAR(108) * PAR(109))
        PAR(111) = (PAR(104) * PAR(106) - PAR(105)) /
     1             (PAR(107) * PAR(109))
        PAR(112) = (PAR(104) * PAR(105) - PAR(106)) /
     1             (PAR(107) * PAR(108))
C * SET UP LIMITS FOR TESTING IF ATOM IN RANGE FOR DISTANCE CALCULATION
        PAR(113) = PAR(126) / (PAR(102) * PAR(103) * PAR(107))
        PAR(114) = PAR(126) / (PAR(101) * PAR(103) * PAR(108))
        PAR(115) = PAR(126) / (PAR(101) * PAR(102) * PAR(109))
        PAR(116) = 2.0 * PAR(110) / (PAR(114) * PAR(115))
        PAR(117) = 2.0 * PAR(111) / (PAR(113) * PAR(115))
        PAR(118) = 2.0 * PAR(112) / (PAR(113) * PAR(114))
        DO I = 7, 9
          PAR(100 + I) = 1.0 / PAR(106 + I)**2
        END DO
C * DECIDE ORDER OF AXES IN DESCENDING AXIAL LENGTH.
        DO I = 1, 3
          PAR(97 + I) = PAR(100 + I)
        END DO
        IF (PAR(101) == PAR(102) .OR. PAR(101) == PAR(103))
     1    PAR(98) = PAR(101) + 0.0002
        IF (PAR(102) == PAR(103)) PAR(99) = PAR(102) + 0.0001
        AXHI = MAX (PAR(98), PAR(99), PAR(100))
        AXLO = MIN (PAR(98), PAR(99), PAR(100))
        DO K = 1, 3
          IF (PAR(97 + K) == AXHI) THEN
            IPR(120 + K) = 1
          ELSE IF (PAR(97 + K) == AXLO) THEN
            IPR(120 + K) = 3
          ELSE
            IPR(120 + K) = 2
          END IF
        END DO
      END IF
      RETURN
99999 FORMAT (':: No CELL card given, Angstrom data assumed')
99998 FORMAT (':: New Cell', 3F8.4, 3F7.2)
      END SUBROUTINE PLUT23
 
      SUBROUTINE PLUT24 (MODE, JATM, MNCODE)
C * AD_HOC GEOMETRY CALCULATION
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      USE cggt
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: M
      INTEGER :: NA
      INTEGER :: NB
      INTEGER :: NG
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: LAT
      INTEGER :: MET
      INTEGER :: NMET
      INTEGER :: IATK
      INTEGER :: JATK
      INTEGER :: JNCL
      INTEGER :: KNCL
      INTEGER :: IDUM
      INTEGER :: MJAT
      INTEGER :: MODE
      INTEGER :: JATM
      INTEGER :: IDUM1
      INTEGER :: MADDR
      INTEGER :: MNCODE
      REAL    :: D
      REAL    :: D1
      REAL    :: D2
      REAL    :: ANG
      REAL    :: XNM
      REAL    :: SANG
      REAL    :: XDUM
      REAL    :: XMOL
      REAL    :: ANGM
      REAL    :: ANGLE
      REAL    :: DUMMY
      REAL    :: OMEGA
      CHARACTER(len=80), SAVE, DIMENSION(10) :: GEOM
C * MODE = -3 - NEGATIVE WRITE/DELETE
C * MODE = -2 - CLEAR GEOM
C * MODE = -1 - HFIX
C * MODE =  1 - GEOM/COORDN
C * MODE =  2 - BOND DISTANCE
C * MODE =  3 - BOND ANGLE
C * MODE =  4 - TORSION ANGLE
C * CLEAR GEOM-LISTING
      IF (MODE == -3) THEN
        DO I = 1, 10
          CALL PLA439 (0.0, GEOM(I), 80, 0.3, 0, 2, -PAR(64) + 1.0,
     1             PAR(65) - 1.0 - I * 0.5)
        END DO
C * CLEAR GEOM
      ELSE IF (MODE == -2) THEN
        DO I = 2, 10
          CALL GEN038 (GEOM(I), 1, 80)
        END DO
      ELSE
C * TEST FOR PREVIOUS JOIN INSTRUCTION EXECUTED, OTHERWISE DO SO
        IF (IPR(17) == 0) THEN
          CALL PLUT05
C * CALL EXIT/STOP
          IF (IPR(72) /= 0) CALL GEN127 ('311')
        END IF
        IF (ABS (MODE) == IPR(220) - 1) THEN
C * GET SERIAL NUMBER FOR THIS ATOM
          CALL PLUT13 (0, 2, IAT, XDUM)
C * GET LABEL
          CALL PLUT25 (1, IAT, IATK)
          IF (IAT > 0) THEN
C * GEOM/COORDN CASE
            IF (ABS (MODE) == 1) THEN
              NB   = 0
              SANG = 0.0
              ANGM = 0.0
              NMET = 0
C * CREATE GEOM HEADER
              WRITE (GEOM(1), 99999, IOSTAT = IOST)
C * CLEAR GEOM DISPLAY LIST
              DO I = 2, 10
                CALL PLA439 (0.0, GEOM(I), 80, 0.3, 0, 2, -PAR(64)
     1               + 1.0, PAR(65) - 1.0 - I * 0.5)
                CALL GEN038 (GEOM(I), 1, 80)
              END DO
              NG = 1
              DO JAT = IPR(69) + 1, JATM
                CALL PLUT15 (-1, JAT, 27, JNCL)
                IF (JNCL == 1 .OR. IPR(163) == 1
     1               .OR. JAT > IPR(39)) THEN
C * TEST WHETHER THIS IS A BOND
                  CALL PLUT16 (-5, IDUM, IAT, JAT, DUMMY, IDUM1)
                  IF (IDUM > 0) THEN
                    NB = NB + 1
C * GET DISTANCE
                    CALL PLUT22 (IAT, JAT, D)
                    IF (NB == 1) D1 = D
                    IF (NB == 2) THEN
                      D2 = D
                      IF (D2 < D1) CALL GEN018 (D1, D2)
                    END IF
C * GET LABEL
                    CALL PLUT25 (2, JAT, JATK)
C * METAL ?
                    CALL PLUT15 (-1, JAT, 17, MET)
                    NMET = NMET + MET
C * GET SYMMETRY OPERATION
                    CALL PLUT15 (-6, JAT, 11, MADDR)
                    XMOL = MOL(1, MADDR + 1) / PAR(42)
                    NA   = 0
                    IF (NB > 1) THEN
                      MJAT = MIN (JAT - 1, IPR(38))
                      DO KAT = IPR(69) + 1, MJAT
C * TEST WHETHER THIS ATOM IS INCLUDED
                        CALL PLUT15 (-1, KAT, 27, KNCL)
                        IF (KNCL == 1 .OR. IPR(163) == 1
     1                      .OR. KAT > IPR(39)) THEN
C * TEST WHETHER THIS IS A BOND
                          CALL PLUT16 (-5, IDUM, IAT, KAT, DUMMY, IDUM1)
                          IF (IDUM > 0) THEN
                            CALL PLUT37 (KAT, IAT, JAT, 0, ANG)
                            ANGM = MAX (ANGM, ANG)
                            IF (NA < 12) THEN
                              NA      = NA + 1
                              SGY(NA) = ANG
                              SANG    = SANG + ANG
                            END IF
                          END IF
                        END IF
                      END DO
                    END IF
                    IF (NG < 10) THEN
                      NG = NG + 1
                      CALL GEN020 (-1, NQ1, 2, 2)
                      CALL GEN020 (-1, NQ2, 2, 2)
                      WRITE (GEOM(NG), 99998, IOSTAT = IOST)
     1                  NQ1, NQ2, XMOL, D, (SGY(I), I = 1, NA)
                    END IF
                  END IF
                END IF
              END DO
C * DISPLAY GEOM LIST
              DO I = 1, NG
                CALL PLA439 (0.0, GEOM(I), 80, 0.3, 5 + IGBL(68), 2,
     1               - PAR(64) + 1.0, PAR(65) - 1.0 - I * 0.5)
              END DO
C * HFIX (MODE = -1)
              IF (MODE == -1) THEN
                CALL PLUT42 (NB, IATK, JATK, SANG, ANGM, NMET, D, D1,
     1            D2, MNCODE)
              END IF
            ELSE
C * GET SEQUENCE NUMBER 'JAT' FOR SECOND ATOM
              CALL PLUT13 (0, 3, JAT, XDUM)
              IF (JAT > 0) THEN
C * (BOND) DISTANCE CASE
                IF (MODE == 2) THEN
                  IF (IPR(221) == 1) THEN
                    XNM = FN(1)
                    IF (XNM < 0.0) THEN
                      M = - NINT (XNM)
                      XNM = NINT (RA(IPR(159) + 1  - M))
                    END IF
                    CALL PLUT28 (IAT, JAT, XNM)
                    CALL PLUT15 (4, JAT, 37, 1)
                  END IF
                  CALL PLUT22 (IAT, JAT, D)
                  WRITE (SBCD, 99997, IOSTAT = IOST)
     1              (IFL(I), I = 1, 3), D, CHAR (0)
                  IF (IGBL(32) == 0)
     1              WRITE (LU6, 99994, IOSTAT = IOST) SBCD
                ELSE
                  CALL PLUT13 (0, 4, KAT, XDUM)
                  IF (KAT > 0) THEN
C * (BOND) ANGLE CASE
                    IF (MODE == 3) THEN
                      CALL PLUT37 (IAT, JAT, KAT, 0, ANGLE)
                      WRITE (SBCD, 99996, IOSTAT = IOST)
     1                  (IFL(I), I = 1, 4), ANGLE, CHAR (0)
                      IF (IGBL(32) == 0)
     1                  WRITE (LU6, 99994, IOSTAT = IOST) SBCD
                    ELSE
                      CALL PLUT13 (0, 5, LAT, XDUM)
                      IF (LAT > 0) THEN
C * TORSION ANGLE CASE
                        IF (MODE == 4) THEN
                          CALL PLUT37 (IAT, JAT, KAT, LAT, OMEGA)
                          WRITE (SBCD, 99995, IOSTAT = IOST)
     1                      (IFL(I), I = 1, 5), OMEGA * IPR(65),
     2                      CHAR (0)
                          IF (IGBL(32) == 0)
     1                      WRITE (LU6, 99994, IOSTAT = IOST) SBCD
                        END IF
                      ELSE
                        IPR(72) = 42
                      END IF
                    END IF
                  ELSE
                    IPR(72) = 43
                  END IF
                END IF
              ELSE
                IPR(72) = 44
              END IF
            END IF
          ELSE
            IPR(72) = 45
          END IF
        ELSE
          IPR(72) = 46
        END IF
        IPR(163) = 0
      END IF
      RETURN
99999 FORMAT ('Geom/Coord', 8X, '[   ARU   ]    Dist Angle(s)')
99998 FORMAT (A, ' - ', A, ' [', F9.2, '] =', F6.3, 8F5.0)
99997 FORMAT (3(A, 1X), ' =', F8.3, A)
99996 FORMAT (4(A, 1X), ' =', F8.2, A)
99995 FORMAT (5(A, 1X), ' =', F8.2, A)
99994 FORMAT (A)
      END SUBROUTINE PLUT24
 
      SUBROUTINE PLUT25 (MD, IAT, IATK)
C * RECOVER ATOMLABEL : INQNR + SYMM_FLAG----> NQ  INCLUDING PARENTHESES
      USE parameters
      USE atomdata
      USE cchar
      USE pluto
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: J1
      INTEGER               :: J2
      INTEGER               :: J3
      INTEGER               :: MD
      INTEGER               :: NAT
      INTEGER               :: JX0
      INTEGER               :: JX1
      INTEGER               :: JX2
      INTEGER               :: JX3
      INTEGER               :: IAT
      INTEGER               :: NSS
      INTEGER               :: NPAR
      INTEGER               :: IATK
      INTEGER               :: MODE
      INTEGER               :: INQNR
      INTEGER               :: MSUBST
      INTEGER, DIMENSION(4) :: NUM
      CHARACTER(len=NP64)   :: NQ
C * ABS(MD) = 0    - GET ATOM TYPE
C * ABS(MD) = 1, 2 - OUTPUT IN NQ1 OR NQ2 RESPECTIVELY
      IF (MD >= 0) THEN
        MODE = MD
        NPAR = IPR(71)
      ELSE
        MODE = - MD
        NPAR = 0
      END IF
      NAT = IABS (IAT)
      IF (NAT > IPR(37)) THEN
        N = MOD (NAT - IPR(69) - 1, IPR(37) - IPR(69)) + IPR(69) + 1
      ELSE
        N = NAT
      END IF
      INQNR = NINT (RA(N * NP43 + 7))
C * GET SYMMETRY (STARTING FROM IPR(75))
      CALL PLUT15 (-6, N, 11, JX3)
      IF (IPR(75) > 0) THEN
        JX3 = JX3 - IPR(75) + 1
      ELSE
        JX3 = 0
      END IF
      IF (MODE /= 0) THEN
        I = 1
        IF (INQNR >= 0.0) THEN
          JX1 = INQNR / 64000
          JX2 = INQNR - JX1 * 64000
          NSS = MOD (JX2, 32)
          JX2 = JX2 / 32
          JX0 = JX1 + 1
          JX1 = IEL(IEN(JX0))
          J1  = JX1 / 100
          J2  = JX1 - J1 * 100
          IF (IAT > 0 .OR. JX0 > 2) THEN
            NQ(I:I) = CHAR (ICHAR ('A') - 1 + J1)
            I = I + 1
            IF (J2 /= 0) THEN
              NQ(I:I) = CHAR (ICHAR ('a') - 1 + J2)
              I = I + 1
            END IF
          END IF
          IF (JX2 == 0) NPAR = 0
          IF (NPAR /= 0) THEN
            NQ(I : I) = '('
            I = I + 1
          END IF
          J2 = JX2 / 10
          NUM(4) = MOD (JX2, 10)
          J3     = J2 / 10
          NUM(3) = MOD (J2, 10)
          NUM(1) = J3 / 10
          NUM(2) = MOD (J3, 10)
          J2     = 0
          DO J = 1, 4
            IF (NUM(J) > 0 .OR. J2 > 0) THEN
              NQ(I : I) = CHAR (ICHAR ('0') + NUM(J))
              I = I + 1
              J2 = J2 + 1
            END IF
          END DO
          IF (NSS /= 0) THEN
            IF (NSS == 1) THEN
              NQ(I : I) = ''''
            ELSE IF (NSS == 2) THEN
              NQ(I : I) = '"'
            ELSE IF (NSS == 3) THEN
              NQ(I : I) = '#'
            ELSE IF (NSS > 3) THEN
              NQ(I : I) = CHAR (ICHAR ('A') + NSS - 4)
            END IF
            I = I + 1
          END IF
          IF (NPAR /= 0) THEN
            NQ(I : I) = ')'
            I = I + 1
          END IF
          IF (JX3 > 0) THEN
            IF (NPAR == 0) THEN
              NQ(I : I) = '_'
              I = I + 1
            END IF
            IF (JX3 < 27) THEN
              NQ(I : I) = CHAR (ICHAR ('a') - 1 + JX3)
            ELSE IF (JX3 == 27 .OR. JX3 > 53) THEN
              NQ(I : I) = '*'
            ELSE
              NQ(I : I) = CHAR (ICHAR ('a') + JX3 - 28)
            END IF
            I = I + 1
          END IF
        END IF
        IF (I <= NP64) THEN
          CALL GEN038 (NQ, I, NP64)
        END IF
C * HANDLE ALIASES
        MSUBST = 0
        IF (IGBL(55) == 0) THEN
          MSUBST = 0
          CALL PLA281 (-1, NQ, MSUBST)
        END IF
        IF (MODE /= 2) THEN
          NQ1 = NQ
        ELSE
          NQ2 = NQ
        END IF
      END IF
      IATK = INQNR / 64000 + 1
      RETURN
      END SUBROUTINE PLUT25
 
      SUBROUTINE PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL, RL, XSH)
C * SUBROUTINE GENERATES LABEL POSITIONS WITH REFERENCE TO ATOM POSITIONS
      USE parameters
      IMPLICIT NONE
      INTEGER :: M
      INTEGER :: IASU
      INTEGER :: NATL
      INTEGER :: NPROP
      REAL    :: CA
      REAL    :: SA
      REAL    :: XI
      REAL    :: YI
      REAL    :: ZI
      REAL    :: RI
      REAL    :: XL
      REAL    :: YL
      REAL    :: ZL
      REAL    :: RL
      REAL    :: RIX
      REAL    :: ANG
      REAL    :: XSH
C *-------------------------------------------------------------------C
C *                                                                   C
C *                          4                                        C
C *                  5       I       3                                C
C *                    \     I     /                LABEL             C
C *                      \   I   /                  POSITION          C
C *                        \ I /                    NUMBERS           C
C *               6 ------- 10 ------- 2            M                 C
C *                        / I \                                      C
C *                      /   I   \                                    C
C *                    /     I     \                                  C
C *                  7       I       9                                C
C *                          8                                        C
C *                                                                   C
C *-------------------------------------------------------------------C
      XL = XI
      YL = YI
      IF (IPR(116) /= 0) THEN
        ZL = ZI
      ELSE
        IF (PAR(48) /= 0.0) THEN
          ZL = ZI
        ELSE
          ZL = ZI + PAR(60)
        END IF
      END IF
      RL = MAX (PAR(28), PAR(40))
      IF (M < 10) THEN
        ANG = RGBL(5) * (M - 2) / 8
        CA  = COS (ANG)
        SA  = SIN (ANG)
        RIX = RI + XSH
        XL  = XL + RIX * CA
        YL  = YL + RIX * SA
        IF (ABS (CA) > 0.1) XL = XL + PAR(40) * CA / ABS (CA)
        IF (ABS (SA) > 0.1) YL = YL + PAR(28) * SA / ABS (SA)
      END IF
      NPROP = 0
      IASU  = 0
      CALL PLUT14 (1, NATL, IASU, NPROP, XL, YL, ZL, RL)
      RETURN
      END SUBROUTINE PLUT26
 
      SUBROUTINE PLUT27 (IAJAT, IAT, JAT, RBO, NLI)
C * ROUTINE ALLOCATES BOND RADIUS AND NUMBER OF LINES FOR BOND IAT-JAT
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N1
      INTEGER :: N2
      INTEGER :: N3
      INTEGER :: NRF
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: NLI
      INTEGER :: IHAT
      INTEGER :: JHAT
      INTEGER :: IAIO
      INTEGER :: IAJO
      INTEGER :: IDIS
      INTEGER :: JDIS
      INTEGER :: NSPEC
      INTEGER :: IAJAT
      INTEGER :: NRESI
      INTEGER :: NRESJ
      INTEGER :: ITYPE
      INTEGER :: JTYPE
      REAL    :: RBO
C * TEST FOR STICK/NON-STICK MODE
      IF (IPR(4) > 0) THEN
C * NON-STICK MODE
        IF (IAT > IPR(69)) THEN
C * GET RESIDUE AND ATOM PROPERTIES FOR IAT & JAT
          CALL PLUT15 (-6, IAT, 5,  NRESI)
          CALL PLUT15 (-6, JAT, 5,  NRESJ)
          ITYPE = INT (RA(IAT * NP43 + 7) / 64000)
          JTYPE = INT (RA(JAT * NP43 + 7) / 64000)
          CALL PLUT15 (-1, IAT, 44, IHAT)
          CALL PLUT15 (-1, JAT, 44, JHAT)
C * HANDLE D-ATOMS AS H-ATOMS
          IF (IHAT == 1) ITYPE = 0
          IF (JHAT == 1) JTYPE = 0
          L     = -1
          NSPEC = IPR(41)
          NRF   = IPR(80) + 1
C * LOOP OVER SPECIAL BOND TYPES
          DO K = 1, NSPEC
            NRF = NRF - 3
            N1  = NINT (RA(NRF + 2))
            N2  = NINT (RA(NRF + 1))
            N3  = NINT (RA(NRF    ))
            IF (N1 < 0) THEN
C * INTERMOLECULAR BOND SPECIFICATION
              IF (IAJAT > IPR(53)) L = N3
              IF (NRESI /= NRESJ)  L = N3
            ELSE IF (N1 == 0) THEN
C * TO - BOND SPECIFICATION
              IF (N2 < 0) THEN
C * TO ATOM-TYPE
                IAIO = - ITYPE - 1
                IAJO = - JTYPE - 1
              ELSE
C * TO ATOM-NAME
                IAIO = IAT
                IAJO = JAT
              END IF
              IF (IAIO == N2 .OR. IAJO == N2) THEN
C * ONLY THE FIRST NON-DEFAULT SETTING WILL BE EFFECTIVE
                IF (L == -1) THEN
                  L = N3
                END IF
              END IF
            ELSE
C * SPECIFIC BOND
              IF (N1 == IAT .AND. N2 == JAT) THEN
                L = N3
              ELSE IF (N1 == JAT .AND. N2 == IAT) THEN
                L = N3
              END IF
            END IF
          END DO
          IF (L /= -1) THEN
C * NON-DEFAULT BOND RADII SETTINGS
            RBO = 0.001 * FLOAT (MOD (IABS (L), 1000))
            NLI = ISIGN (IABS (L) / 1000, L)
          ELSE
C * DEFAULT BOND RADII SETTINGS
            RBO = PAR(38)
            NLI = IPR(12)
          END IF
C * HANDLE MAJOR/MINOR DISORDER
          CALL PLUT15 (-4, IAT, 28, IDIS)
          CALL PLUT15 (-4, JAT, 28, JDIS)
          IDIS = IPPR(IDIS + 1, 1)
          JDIS = IPPR(JDIS + 1, 1)
          IF (IDIS < 5000 .OR. JDIS < 5000) NLI = - IABS (NLI)
        ELSE
C * UNITCELL
          RBO = PAR(75)
          NLI = IPR(107)
        END IF
      ELSE
C * STICK - MODE
        NLI = 1
        RBO = 0.0
      END IF
      RETURN
      END SUBROUTINE PLUT27
 
      SUBROUTINE PLUT28 (IAT, JAT, XML)
C * HANDLE SPECIAL JOIN/LABEL/VIEW/DIST ARU
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE cchar
      USE pluto
      USE sgxyz
      IMPLICIT NONE
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: NR
      INTEGER  :: NS
      INTEGER  :: IAT
      INTEGER  :: JAT
      INTEGER  :: KAT
      INTEGER  :: ITX
      INTEGER  :: ITY
      INTEGER  :: ITZ
      INTEGER  :: MPM
      INTEGER  :: IVAL
      INTEGER  :: JDUM
      INTEGER  :: MADDR
      REAL     :: XM2
      REAL     :: XM3
      REAL     :: XML
      IF (NINT (XML) /= 0) THEN
C * STORE THIS ARU IN ARU-LIST
        CALL PLUT17 (XML, -1, MADDR, LU6)
C * UNPACK ARU
        MPM = NINT (XML * PAR(42))
        CALL GEN098 (MPM, PAR(42), NS, ITX, ITY, ITZ, NR)
        SGX(4) = ITX
        SGX(5) = ITY
        SGX(6) = ITZ
        DO I = 1, 3
          SGX(I) = RA(JAT * NP43 + I)
        END DO
        CALL SGSM (3, ICL, SGX, NS, LU6, IERR)
C * TEST FOR DUPLICATION OF ATOM IN COORDINATE LIST
        DO 10 KAT = IPR(69) + 1, IPR(37)
          DO J = 1, 3
            IF (ABS (RA(KAT * NP43 + J) - SGX(6 + J)) *
     1          PAR(100 + J) >= PAR(22)) GO TO 10
          END DO
          JAT = KAT
          RETURN
   10   CONTINUE
        IPR(37) = IPR(37) + 1
        IPR(38) = IPR(38) + 1
        KAT     = JAT
        JAT     = IPR(37)
        DO I = 1, 3
          RA(JAT * NP43 + I) = SGX(6 + I)
        END DO
C * ORTHOGONALIZE
        CALL PLUT23 (JAT)
C * SET FLAGS
        DO I = 8, 10
          RA(JAT * NP43 + I)  = RA(KAT * NP43 + I)
        END DO
        IF (IAT > 0) THEN
          CALL PLUT15 (-6, IAT,  5, IVAL)
          CALL PLUT15 ( 6, JAT,  5, IVAL)
        END IF
        IVAL = 0
        CALL PLUT15 ( 1, JAT, 27, IVAL)
C * COPY LABEL
        RA(JAT * NP43 + 7) = RA(KAT * NP43 + 7)
        CALL PLUT15 (6, JAT, 11, MADDR)
        CALL PLUT25 (1, JAT, JDUM)
        WRITE (LU6, 99999, IOSTAT = IOST) NQ1
C * SET TRNS
        XM2 = RA(KAT * NP43 + 12) * 1000.0
        CALL PLA270 (XML, XM2, XM3)
C * CALL EXIT/STOP
        IF (IPR(2) /= 0) CALL GEN127 ('101')
        RA(JAT * NP43 + 12) = XM3 / 1000.0
        RA(JAT * NP43 + 11) = RA(IAT * NP43 + 11)
      END IF
      RETURN
99999 FORMAT (':: ', A, ' added to coordinate list.')
      END SUBROUTINE PLUT28
 
      SUBROUTINE PLUT29 (MODE, LINE, NQ, NRFIX, LU)
C * RENAME/DELETE ETC RES-FILE
      USE files
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: L
      INTEGER           :: N
      INTEGER           :: LU
      INTEGER           :: IS
      INTEGER           :: NR
      INTEGER           :: NR0
      INTEGER           :: NRES
      INTEGER           :: NBLK
      INTEGER           :: LENM
      INTEGER           :: LRES
      INTEGER           :: MODE
      INTEGER           :: ISF1
      INTEGER           :: ISF2
      INTEGER           :: IDEL
      INTEGER           :: NRFIX
      CHARACTER(len=*)  :: LINE
      CHARACTER(len=80) :: LIN
      CHARACTER(len=*)  :: NQ
      CHARACTER(len=2)  :: LTYPE
      CHARACTER(len=2)  :: SLT
      CHARACTER(len=4)  :: CRDT
      CHARACTER(len=4)  :: KEY
      CHARACTER(len=4)  :: RESD
      CHARACTER(len=4)  :: LYN
C * RES-ONLY
      IF (IABS(IGBL(8)) == 3 .AND. IGBL(3) == 8) RETURN
      LENM = MIN (80, LEN(LINE))
C * IPR(200) - START OF .RES STORAGE
C * IPR(201) - END   OF .RES STORAGE
C * MODE =  0 - INIT
C *      =  1 - ADD LINE
C *      =  2 - RENAME
C *      =  3 - HFIX
C *      =  4 - DELETE
C *      =  5 - ANIS
C *      = -1 - OUTPUT (MODIFIED) .RES (=NEW)
C * ADD LINE
      IF (MODE == 1) THEN
        IF (IPR(201) > IPR(80) + 80) THEN
          LIN = LINE(1:LENM)
          CALL GEN020 (1, LIN, 1, 4)
          NBLK = -1
          DO I = 1, 80
            IPR(201)     = IPR(201) - 1
            RA(IPR(201)) = ICHAR (LIN(I:I))
            IF (LIN(I:I) /= ' ') NBLK = 0
          END DO
          IPR(201)     = IPR(201) - 1
          RA(IPR(201)) = 0
          IPR(201)     = IPR(201) - 1
          RA(IPR(201)) = NBLK
          IPR(201)     = IPR(201) - 1
          RA(IPR(201)) = 0
C * DO/DONOT (IPR(176) SKIP Q-PEAKS)
          IF (LIN(1:1) == 'Q') IGBL(26) = IGBL(26) + IPR(176)
        ELSE
          WRITE (LU6, 99992) MODE
          STOP
        END IF
C * RENAME - MODE
      ELSE IF (MODE == 2) THEN
C * OVERRULE POSSIBLE Q-PEAK NON-DELETE
C * UPPER-CASE CHAR # 2
        CALL GEN020 (1, LINE, 2, 2)
        CALL GEN020 (1, NQ, 1, 4)
        I = IPR(200)
   10   IF (I - 83 >= IPR(201)) THEN
          WRITE (KEY, 99994, IOSTAT = IOST)
     1      (CHAR (NINT (RA(I - J))), J = 1, 4)
          IF (KEY == 'SADI') THEN
            DO K = 1, 4
              RA(I - K) = 32.0
            END DO
          END IF
          IF (KEY /= LINE(1:4)) THEN
            I = I - 83
            GO TO 10
          END IF
          IGBL(26) = IGBL(26) + 1
          DO J = 1, 4
            RA(I - J) = ICHAR (NQ(J:J))
          END DO
          RA(I - 82) = 0
          CALL GEN020 (1, NQ, 1, 2)
          LTYPE = NQ(1:1)//' '
          DO J =  ICHAR ('A'), ICHAR ('Z')
            IF (NQ(2:2) == CHAR (J)) THEN
              LTYPE = NQ(1:2)
              EXIT
            END IF
          END DO
          DO K = 1, NSF
            SLT = SFC(K)
            CALL GEN020 (1, SLT, 1, 2)
            IF (LTYPE == SLT) GO TO 20
          END DO
          NSF      = NSF + 1
          K        = NSF
          SFC(K)   = LTYPE
          NUNIT(K) = 1
C * REPLACE SCATTERING TYPE
   20     ISF1 = K / 10
          ISF2 = MOD (K, 10)
          DO J = 6, 20
            L = J
            IF (RA(I - J) /= ICHAR (' ')) THEN
              IF (RA(I - J - 1) /= ICHAR (' ')) THEN
                RA(I - J) = ICHAR (' ')
                L = L + 1
              END IF
              RA(I - L) = ICHAR ('0') + ISF2
              IF (ISF1 /= 0) RA(I - L + 1) = ICHAR ('1')
              GO TO 30
            END IF
          END DO
          GO TO 30
        END IF
C * HFIX MODE
      ELSE IF (MODE == 3) THEN
        NRES = 0
        I    = IPR(200)
        DO WHILE (I - 83 >= IPR(201))
          I = I - 83
          WRITE (KEY, 99994, IOSTAT = IOST)
     1      (CHAR (NINT (RA(I + 83 - J))), J = 1, 4)
          IF (KEY == 'RESI') THEN
            WRITE (RESD, 99994, IOSTAT = IOST)
     1        (CHAR (NINT (RA(I + 83 - J))), J = 5, 8)
            READ (RESD, *) NRES
            CYCLE
          END IF
          IF (NRES /= 0) THEN
            N = INDEX (LINE, '_')
            IF (N > 0) THEN
              READ (LINE(N +1:), *) LRES
              IF (LRES /= NRES) CYCLE
              LINE(N:) = ' '
            END IF
          END IF
          IF (KEY == LINE(1:4)) THEN
            IGBL(26)     = IGBL(26) + 1
            RA(I + 2)   = NRFIX
            IF (NFHAT == 0) THEN
              NSF        = NSF + 1
              SFC(NSF)   = 'H '
              NUNIT(NSF) = 1
              NFHAT      = 1
            END IF
          END IF
        END DO
C * DELETE ATOMS
      ELSE IF (MODE == 4) THEN
        CALL GEN020 (1, LINE, 1, 7)
        I = IPR(200)
        DO WHILE (I - 83 >= IPR(201))
          I = I - 83
          WRITE (KEY, 99994, IOSTAT = IOST)
     1      (CHAR (NINT (RA(I + 83 - J))), J = 1, 4)
          IF (KEY == LINE(1:4)) THEN
            IGBL(26)  = IGBL(26) + 1
            RA(I + 1) = -1
C * HANDLE EXTENSIONS (INDICATED BY '=')
            DO J = 1, 80
              IF (RA(I + 83 - J) == ICHAR ('=')) THEN
                I         = I - 83
                RA(I + 1) = -1
                EXIT
              END IF
            END DO
          END IF
        END DO
C * ANIS - MODE
      ELSE IF (MODE == 5) THEN
        I = IPR(200)
        DO WHILE (I - 83 >= IPR(201))
          I = I - 83
          WRITE (KEY, 99994, IOSTAT = IOST)
     1      (CHAR (NINT (RA(I + 83 - J))), J = 1, 4)
          IF (KEY == LINE(1:4)) THEN
            IGBL(26) = IGBL(26) + 1
            RA(I)    = 1
          END IF
        END DO
 
C * OUTPUT UPDATED RES-FILE
      ELSE IF (MODE == -1) THEN
        IDEL = 0
        NR0  = -1
        I    = IPR(200)
        DO WHILE (I - 83 >= IPR(201))
          I = I - 83
          DO J = 1, 80
            LIN(J:J) = CHAR (NINT (RA(I + 83 - J)))
          END DO
          CRDT = LIN(1:4)
          IF (CRDT == 'SFAC') THEN
            IF (IDEL == 0)
     1        WRITE (LU, 99999, IOSTAT = IOST) (SFC(K), K = 1, NSF)
            IDEL = 1
          ELSE IF (CRDT == 'UNIT') THEN
            WRITE (LU, 99998, IOSTAT = IOST) (NUNIT(K), K = 1, NSF)
            IDEL = 0
          ELSE IF (CRDT == 'AFIX') THEN
            READ (LIN(5:80), *) NR0
          ELSE IF (CRDT == 'FVAR') THEN
C * HFIX LOOP
            K = I
            DO WHILE (K - 83 >= IPR(201))
              K = K - 83
              DO J = 1, 4
                LYN(J:J) = CHAR (NINT (RA(K + 83 -J)))
              END DO
              NR = NINT (RA(K + 2))
              IF (NR /= 0)
     1          WRITE (LU, 99997, IOSTAT = IOST) NR, LYN(1:4)
            END DO
            WRITE (LU, 99993, IOSTAT = IOST) LIN
          ELSE IF (CRDT == 'HKLF') THEN
            NR0 = 0
            WRITE (LU, 99996, IOSTAT = IOST) NR0
            WRITE (LU, 99993, IOSTAT = IOST) LIN
            NR0 = -1
          ELSE
            IF (NINT (RA(I + 1)) /= 0) CYCLE
            IF (IPR(176) == 1 .AND. LIN(1:1) == 'Q') CYCLE
            IF (IDEL == 0) THEN
              NR = NINT (RA(I))
              IF (NR /= 0) THEN
                CALL PLA280 (LIN)
                CALL PLA006 (1, IS)
                WRITE (LIN (6:), 99995, IOSTAT = IOST) NINT (FN(1)),
     1            (FN(K), K = 2, 6), FN(6), FN(6), 0.0, 0.0, 0.0
              END IF
C * AVOID OUTPUT OF REDUNDANT AFIX LINES
              IF (NR0 >= 0) THEN
                WRITE (LU, 99996, IOSTAT = IOST) NR0
                NR0 = -1
              END IF
              WRITE (LU, 99993, IOSTAT = IOST) LIN
            ELSE IF (IDEL < 0) THEN
              IDEL = 0
            END IF
          END IF
        END DO
      ELSE IF (MODE == 0 .AND. LINE(1:3) /= 'END') THEN
        IPR(200) = NP49 - 6
        IPR(201) = IPR(200)
        IGBL(26) = 0
        NSF      = 0
      END IF
   30 IF (IABS (IGBL(8)) == 2 .AND. IPR(80) > IPR(201)) THEN
C * CALL EXIT/STOP
        CALL GEN127 ('PLUT29')
      END IF
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT ('SFAC', 16(2X, A))
99998 FORMAT ('UNIT', 2I5, 14I4)
99997 FORMAT ('HFIX', I5, 2X, A)
99996 FORMAT ('AFIX', I5)
99995 FORMAT (I3, 7F8.4, 3F4.1)
99994 FORMAT (4A)
99993 FORMAT (A)
99992 FORMAT (/, ':: Storage Overflow in PLUT29 (MODE =', I3, ')', /)
      END SUBROUTINE PLUT29
 
      SUBROUTINE PLUT30 (ITS, ITF)
C * ACTUAL CIRCLE PLOTTING
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: N
      INTEGER :: ITS
      INTEGER :: ITF
      INTEGER :: IUP
      INTEGER :: ITFF
      REAL    :: XO
      REAL    :: YO
      REAL    :: ZO
      REAL    :: XP
      REAL    :: YP
      REAL    :: ZP
      REAL    :: RO
      REAL    :: ROC
      REAL    :: ROS
      REAL    :: DTH1
      REAL    :: DTH2
      REAL    :: DTHS
      IF (IPR(114) > 0) THEN
        ITFF = MIN (ITF, IPR(114))
      ELSE
        ITFF = ITF
      END IF
      IF (ITS < ITFF) THEN
C * GET BEGIN AND END THETA VALUES
        DTH1     = PAR(57) + ITS  * PAR(55)
        DTH2     = PAR(57) + ITFF * PAR(55)
C * GET STEP SIZE
        N        = MAX (1, NINT((DTH2 - DTH1) / PAR(56)))
        DTHS     = (DTH2 - DTH1) / N
        IPR(129) = IPR(129) + N
C * GET CENTRE AND RADIUS OF CIRCLE
        XO       = PAR(71)
        YO       = PAR(72)
        ZO       = PAR(73)
        RO       = PAR(74)
        IUP      = 1
        DO I = 0, N
          ROC = RO * COS (DTH1)
          ROS = RO * SIN (DTH1)
          XP  = XO + ROC * ZU(1) + ROS * ZU(4)
          YP  = YO + ROC * ZU(2) + ROS * ZU(5)
          ZP  = ZO + ROC * ZU(3) + ROS * ZU(6)
          CALL GGIP (XP, YP, ZP, 2 + IUP)
          IUP      = 0
C * NEXT POINT OF CIRCL
          DTH1     = DTH1 + DTHS
        END DO
      END IF
      RETURN
      END SUBROUTINE PLUT30
 
      SUBROUTINE PLUT31 (K, COLR)
C * PUT DIAMOND
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: K
      REAL    :: X
      REAL    :: Y
      REAL    :: COL
      REAL    :: DSH
      REAL    :: COLR
      DSH = 0.15
      I   = K + NP0
      X   = RA(I - 3)
      Y   = RA(I - 2)
      COL = COLR
      IF (COL >= 0.0) CALL GGIP (0.0, COL, 0.0, 0)
C * PLOT MARKER
      CALL PLA411 (X, Y, DSH, -1.0)
      RETURN
      END SUBROUTINE PLUT31
 
      SUBROUTINE PLUT32
C * EXPLICIT RELABELLING
      USE files
      USE parameters
      USE atomdata
      USE cchar
      USE xwdw
      USE cggt
      USE pluto
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: M
      INTEGER             :: N
      INTEGER             :: KL
      INTEGER             :: IS
      INTEGER             :: NS
      INTEGER             :: NA
      INTEGER             :: NB
      INTEGER             :: NE
      INTEGER             :: NEE
      INTEGER             :: NEI
      INTEGER             :: IER
      INTEGER             :: IAT
      INTEGER             :: JAT
      INTEGER             :: NAX
      INTEGER             :: NQX
      INTEGER             :: NSS
      INTEGER             :: IVAL
      INTEGER             :: IAT1
      INTEGER             :: IATK
      INTEGER             :: NATL
      INTEGER             :: IBEG
      INTEGER             :: ICOL
      INTEGER             :: IDUM
      INTEGER             :: IEND
      INTEGER             :: IASU
      INTEGER             :: IREN
      INTEGER             :: NIEN
      INTEGER             :: NQSM
      INTEGER             :: IXPK1
      INTEGER             :: IXPK2
      INTEGER             :: NPROP
      INTEGER             :: INQNR
      INTEGER             :: JNQNR
      INTEGER             :: MSUBST
      REAL                :: XL
      REAL                :: YL
      REAL                :: ZL
      REAL                :: RL
      REAL                :: XDUM
      REAL                :: YUNK
      REAL                :: PAR40
      CHARACTER(len=NP64) :: RIFL2
      CHARACTER(len=NP64) :: RIFL3
      KL        = IPR(220)
      IGBL(105) = 1
C * HANDLE ALIASES
      IF (KL > 1) THEN
        MSUBST = 0
        CALL PLA281 (1, IFL(2), MSUBST)
      END IF
      IF (KL > 2) THEN
        DO I = 3, KL, 2
          CALL PLUT13 (0, I - 1, IAT, XDUM)
          IF (IAT > 0) THEN
            CALL PLA046 (8, IFL(I - 1), NEI, NA, NAX, NS,
     1                   IXPK1, IXPK2, NIEN)
C * CHECK FOR UNIQUENESS OF NEW NAME
   10       CALL PLUT13 (1, I, JAT, XDUM)
            CALL PLA046 (9, IFL(I), NEE, NQX, NSS, NQSM,
     1                       INQNR, JNQNR, NIEN)
            IF (JAT <= 0) THEN
              IF (IFL(I)(1:3) == 'REN') THEN
                WRITE (LU6, 99997, IOSTAT = IOST) IFL(I)
                RETURN
              ELSE
                IF (NEE /= NEI) IPR(170) = 2
                YUNK = RA (IAT * NP43 + 7)
                DO J = 1, IPR(37)
                  IF (RA(J * NP43 + 7) == YUNK)
     1                RA(J * NP43 + 7) = INQNR
                END DO
                IF (RADR(NEE, 3) < 0.001) RADR(NEE, 3) =
     1              REL(IEN(NEE))
C * WRITE RENAME INSTRUCTION TO .pjn
                WRITE (LU22, 99996, IOSTAT = IOST) IFL(I - 1), IFL(I)
                IF (IABS (IGBL(8)) == 2)
     1            CALL PLUT29 (2, IFL(I - 1), IFL(I), 0, 0)
                CALL PLUT15 (1, IAT, 47, 1)
              END IF
            ELSE
C * SUBSTITUTE GENERATED LABEL
              IER = 0
              CALL PLUT41 (JAT, NEE, IER)
              IF (IER == 0) GO TO 10
              RETURN
            END IF
          ELSE
            WRITE (LU6, 99998, IOSTAT = IOST) IFL(I)
            RETURN
          END IF
        END DO
C * ENUMERATED RELABELING
      ELSE IF (KL <= 2) THEN
C * CLEAR GEOMETRY
        CALL PLUT24 (-2, IPR(38), IDUM)
        NCNT = 0
        IAT1 = 0
        IF (KL == 2) CALL PLUT13 (0, 2, IAT1, XDUM)
        IF (IAT1 > 0) THEN
          IBEG = IAT1
          IEND = IAT1
        ELSE
          IBEG = IPR(69) + 1
          IEND = IPR(39)
        END IF
        DO 50 I = IBEG, IEND
C * TEST FOR LABELLING TYPE ( 0 = NOLABELLING OF THIS ATOM)
          CALL PLUT15 (-4, I, 37, M)
          IF (M > 1) THEN
C * TEST FOR RESIDUE
            IF (IPR(140) /= 0) THEN
              CALL PLUT15 (-6, I, 5, IVAL)
              IF (IVAL /= IPR(140)) GO TO 50
            END IF
            IAT = I
            CALL PLUT25 (1, IAT, IATK)
            IF (IAT1 >= 0 .OR. -IAT1 == IATK) THEN
              IFL(2)   = NQ1
              IFL(3)   = NQ1
              CALL PLA046 (8, NQ1, NEI, NA, NAX, NS,
     1                     IXPK1, IXPK2, NIEN)
              NB       = 1
              NE       = 7
              CALL GEN039 (1, IFL(2), 1, 7, NB, NE)
              IPR(220) = 2
              KL       = IPR(220)
              CALL PLUT24 (1, IPR(38), IDUM)
              IFL(3)   = NQ1
              RIFL2    = IFL(2)
              RIFL3    = IFL(3)
   20         IF (IGBL(25) * IGBL(32) == 1) THEN
C * PAR40 IS THE HALF WIDTH OF THE LABEL IN CM.
                PAR40 = NE * PAR(349) * PAR(19) / 2.0
                NATL  = IPR(62) + I
                CALL PLUT14 (-1, NATL, IASU, NPROP, XL, YL, ZL, RL)
                CALL PLA439 (0.0, RIFL2, NE, PAR(349), 2, 2,
     1            XL - PAR40, YL - PAR(28))
                SBCD = 'Rename '//RIFL2(1:NE)//' (NewName/Quit['
                SBCD(23 + NE:) = RIFL3(1:NE)//'])'//CHAR (0)
C * MOUSE/KEYBOARD LOOP
C * WHAT NEXT ?
   30           CALL PLA012 (0, 1)
                SELECT CASE (IGGT(1:4))
C * RENAME
                  CASE ('REN ', 'RENA')
                    IF (IGGT(8:8) /= ' ') GO TO 30
                    IGGT(1:5)   = '     '
                    IFL(3)(1:1) = IFL(2)(1:1)
C * !
                  CASE ('!   ')
                    IF (LRET == 2) THEN
                      CALL PLUT02
                      GO TO 20
                    END IF
C * VIEW
                  CASE ('VIEW')
                    CALL PLA006 (1, IS)
                    CALL PLUT06
                    CALL PLUT02
                    GO TO 20
C * PLOT
                  CASE ('PLOT')
                    CALL PLUT02
                    GO TO 20
                  CASE ('LAB ', 'LABL')
                    GO TO 20
                  CASE ('ARU ')
                    GO TO 20
                  CASE ('OMI ', 'OMIT')
                    GO TO 20
                  CASE ('HFI ', 'HFIX')
                    GO TO 20
C * END
                  CASE ('END ')
                    IFL(3)(1:4) = 'QUIT'
C * EXIT
                  CASE ('EXIT')
                    IFL(3)(1:4) = 'QUIT'
                  CASE DEFAULT
C * SEARCH FOR NUMERAL IN POSITION #1
                    CALL GEN105 (3, IGGT(1:1), N)
                    IF (N < 0) THEN
                      IFL(3) = IGGT(1:7)
                    ELSE
C * SEARCH FOR NUMERAL IN POSITION #2
                      CALL GEN105 (3, IFL(2)(2:2), N)
                      IF (IFL(2)(2:2) == ' ' .OR. N >= 0) THEN
                        IFL(3) = IFL(2)(1:1)//IGGT(1:6)
                      ELSE
                        IFL(3) = IFL(2)(1:2)//IGGT(1:5)
                      END IF
                    END IF
                    CALL GEN038 (IGGT, 1, 80)
                END SELECT
              ELSE
                WRITE (LU6, 99999, ADVANCE = 'NO', IOSTAT = IOST)
     1            IFL(2), IFL(2)
                READ  (LU5, 99995) IFL(3)
              END IF
C * UPPER CASE
              CALL GEN020 (1, IFL(3), 1, 7)
              IF (IFL(3)(1:4) == 'QUIT' .OR. IFL(3)(1:3) == 'END')
     1          THEN
                CALL PLA280 ('PLOT')
                IPR(335) = 1
                CALL PLA015 (335, 1)
                RETURN
              END IF
C * LOWER CASE SECOND CHARACTER
              CALL GEN020 (-1, IFL(3), 2, 2)
              NEE = NEI
              IF (IFL(3) /= IFL(2) .AND. IFL(3)(1:1) /= ' ') THEN
   40           CALL PLUT13 (1, 3, JAT, XDUM)
                CALL PLA046 (9, IFL(3), NEE, NQX, NSS, NQSM,
     1                       INQNR, JNQNR, NIEN)
                IF (JAT <= 0) THEN
                  IF (NIEN >= 0) THEN
                    IF (NEE /= NEI) IPR(170) = 2
                    YUNK = RA (IAT * NP43 + 7)
                    DO J = 1, IPR(37)
                      IF (RA(J * NP43 + 7) == YUNK)
     1                    RA(J * NP43 + 7) = INQNR
                    END DO
                    IF (RADR(NEE, 3) < 0.001)
     1                  RADR(NEE, 3) = REL(IEN(NEE))
C * WRITE RENAME INSTRUCTION TO .pjn
                    WRITE (LU22, 99996, IOSTAT = IOST) IFL(2), IFL(3)
                    IF (IABS(IGBL(8)) == 2)
     1                CALL PLUT29 (2, IFL(2), IFL(3), 0, 0)
                    CALL PLA439 (0.0, IFL(2), NE, PAR(349), 0, 2,
     1                XL - PAR40, YL - PAR(28))
                    CALL PLUT15 (1, IAT, 47, 1)
                    CALL GEN039 (1, IFL(3), 1, 7, NB, NE)
                    PAR40 = NE * PAR(349) * PAR(19) / 2.0
                  ELSE
C * NO SUBSTITUTION (CONFLICT/ERROR)
                    CALL PLA015 (0, 28)
                    GO TO 20
                  END IF
                ELSE
C * SUBSTITUTE GENERATED LABEL
                  IER = 0
                  CALL PLUT41 (JAT, NEE, IER)
                  IF (IER /= 0) GO TO 20
                  GO TO 40
                END IF
              END IF
              IF (NEE /= NEI) THEN
                CALL PLUT02
              ELSE
C * LOWER CASE SECOND CHARACTER
                CALL GEN020 (-1, IFL(3), 2, 2)
                CALL PLUT15 (-1, IAT, 47, IREN)
                ICOL = 1
                IF (IREN == 1) ICOL = 3
                CALL PLA439 (0.0, IFL(3), NE, PAR(349), ICOL, 2,
     1                       XL - PAR40, YL - PAR(28))
              END IF
            END IF
          END IF
   50   CONTINUE
        IF (IEND > IBEG) THEN
          IPR(332)  = 1
          CALL PLA015 (335, 1)
C * RESET TO 'NO-RENAME'
          IF (IPR(308) /= 0) IGBL(3) = 8
        END IF
C * TERMINATE RENAME AT END OF LOOP
      END IF
      RETURN
99999 FORMAT (/, 'Rename ', A, ' (NewName/Quit[', A, '])')
99998 FORMAT (':: No Substitution: Unsuitable Old Label: ', A)
99997 FORMAT (':: No Substitution: Unsuitable New Label: ', A)
99996 FORMAT ('RENAME', 2(1X, A))
99995 FORMAT (A)
      END SUBROUTINE PLUT32
 
      SUBROUTINE PLUT33
C * LOAD UNITCELL PLOT DATA
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: N
      INTEGER               :: N0
      INTEGER               :: ND
      INTEGER               :: NN
      INTEGER               :: NEL
      INTEGER               :: ID1
      INTEGER               :: ID2
      INTEGER               :: IDUM0
      INTEGER               :: IDUM2
      REAL                  :: DUM1
      REAL, DIMENSION(NP43) :: YANK
      IPR(64)  = IPR(80) - IPR(76) * 3
      IPR(100) = 1
C * SET UP CELL CONNECTIVITY HERE
      ID1      = 0
      ID2      = 0
      IF (IPR(50) == 0)
     1  CALL PLUT16 (-2, IDUM0, ID1, ID2, DUM1, IDUM2)
      IF (IGBL(33) == 1) THEN
C * SORT ATOM ARRAY
        N0      = IPR(69) + 1
        N       = IPR(37)
C * SORT FROM N0 TO N (SMALL TO LARGE)
        NEL     = N - N0 + 1
        IF (NEL <= 1) RETURN
        NN      = INT (ALOG (FLOAT (NEL)) / ALOG (2.0))
        ND      = 2**NN - 1
   10   IF (ND <= 0) RETURN
        I       = N0
   20   J       = I
        DO K = 1, NP43
          YANK(K) = RA((I + ND) * NP43 + K)
        END DO
   30   IF (YANK(6) >= RA(J * NP43 + 6)) GO TO 40
        DO K = 1, NP43
          RA((J + ND) * NP43 + K) = RA(J * NP43 + K)
        END DO
        J = J - ND
        IF (J >= N0) GO TO 30
   40   DO K = 1, NP43
          RA((J + ND) * NP43 + K) = YANK(K)
        END DO
        I = I + 1
        IF (I + ND <= N) GO TO 20
        ND = (ND - 1) / 2
        GO TO 10
      END IF
      RETURN
      END SUBROUTINE PLUT33
 
      SUBROUTINE PLUT35 (XMOL, MODE)
C * EXPAND ARU/MOLECULE
      USE files
      USE parameters
      USE pluto
      USE sgxyz
      IMPLICIT  NONE
      INTEGER             :: I
      INTEGER             :: M3
      INTEGER             :: NB
      INTEGER             :: NE
      INTEGER             :: ITX
      INTEGER             :: ITY
      INTEGER             :: ITZ
      INTEGER             :: MPM
      INTEGER             :: MR2
      INTEGER             :: MS2
      INTEGER             :: MS3
      INTEGER             :: MS1
      INTEGER             :: MT1
      INTEGER             :: MT2
      INTEGER             :: MT3
      INTEGER             :: MR1
      INTEGER             :: NMOL
      INTEGER             :: MT13
      INTEGER             :: MT23
      INTEGER             :: MT33
      INTEGER             :: MSGN
      INTEGER             :: MODE
      INTEGER             :: MADDR
      REAL                :: XM3
      REAL                :: XMOL
      CHARACTER(len=NP45) :: ICLL
C * DO-NOT FOR INFINITE STRUCTURES AND GLOBAL ARU INSTRUCTION
      IF (ABS(XMOL) <= IPR(75) .OR. IGBL(127) /= 0) THEN
        CALL PLUT17 (XMOL, MODE, MADDR, LU6)
        RETURN
      END IF
      IF (XMOL > 0) THEN
        MSGN = 1
      ELSE
        MSGN = -1
      END IF
C * COPY RELATED ARU'S
      NMOL = NINT (ABS(XMOL) * PAR(42))
      CALL GEN098 (NMOL, PAR(42), MS1, MT1, MT2, MT3, MR1)
      IF (MR1 /= 0) THEN
        NB = MR1
        NE = MR1
      ELSE
        NB = 1
        NE = IPR(75)
      END IF
      DO MR1 = NB, NE
        DO I = 1, IPR(43)
          MPM = MOL(1, I)
          CALL GEN098 (MPM, PAR(42), MS2, ITX, ITY, ITZ, MR2)
          SGZ(6) = ITX
          SGZ(7) = ITY
          SGZ(8) = ITZ
          IF (MR2 == MR1) THEN
            SGZ(1) = MS1
            SGZ(2) = MT1
            SGZ(3) = MT2
            SGZ(4) = MT3
            SGZ(5) = MS2
            CALL SGSM (8, ICLL, SGZ, 0, LU6, IERR)
            IF (IERR /= 0) THEN
              WRITE (LU6, 99999, IOSTAT = IOST) XMOL
              RETURN
            END IF
            MS3  = NINT (SGZ(9))
            MT13 = NINT (SGZ(10))
            MT23 = NINT (SGZ(11))
            MT33 = NINT (SGZ(12))
            M3   = (MS3 * 1000 + MT13 * 100 + MT23 * 10 + MT33 + 555)
            M3   = NINT (M3 * PAR(42)) + MR1
            XM3  = (M3 / PAR(42)) * MSGN
            CALL PLUT17 (XM3, MODE, MADDR, LU6)
          END IF
        END DO
      END DO
      RETURN
99999 FORMAT ('Multiply Problem with ARU = ', F10.2)
      END SUBROUTINE PLUT35
 
      SUBROUTINE PLUT36 (MODE, ISHADE)
C * SHADE MODE
      USE parameters
      USE pluto
      IMPLICIT NONE
      INTEGER :: NN
      INTEGER :: ISH
      INTEGER :: MODE
      INTEGER :: IHOR
      INTEGER :: IANG2
      INTEGER :: ICOL2
      INTEGER :: ISHADE
      REAL    :: YS
      REAL    :: R0
      REAL    :: R1
      REAL    :: CA
      REAL    :: CB
      REAL    :: SB
      REAL    :: R0K
      REAL    :: RSQ
      REAL    :: XPL1
      REAL    :: XPL2
      REAL    :: XPL4
      REAL    :: XPL5
      REAL    :: ANG3
      REAL    :: DISP
C * SHADE MODE OF ATOM MODE
      DO ISH = 1, ISHADE
C * DRAW SHADE LINES ON SURFACE OF SPHERE.
C * LIGHT SOURCE AT YROT, ZROT GIVEN BY (ANG1, ANG2)
        ICOL2 = MOD (IPR(88), 100)
        IF (ICOL2 > 8) ICOL2 = 0
        IANG2 = IPR(88) / 100
        ANG3  = PAR(8) + MOD (IANG2, 100)
        IANG2 = IANG2 / 100
        IHOR  = 1
        IF (ANG3 /= 0.0) THEN
          ANG3 = ANG3 / RGBL(6)
          CB   = COS (ANG3)
          SB   = SIN (ANG3)
          IHOR = 0
        ELSE
          CB   = 1.0
          SB   = 0.0
        END IF
        IF (PAR(7) /= 0.0) THEN
          CA   = COS (PAR(7) / RGBL(6))
          IHOR = 0
        ELSE
          CA = 1.0
        END IF
        NN   = 1
        DISP = PAR(6)
C * HANDLE DISP PERSPECTIVE
        IF (PAR(48) > 0.0)
     1    DISP = DISP * PAR(48) / (PAR(48) - XYZK(3))
        DISP = MAX (DISP, PAR(23))
        IF (IPR(346) > 0) THEN
          CALL GGIP (0.0, FLOAT (ICOL2), 0.0, 0)
        END IF
        R0  = XYZK(4)
        R0K = R0**2
        YS  = - R0
C * ONCE THROUGH THIS LOOP FOR EACH SHADING LINE TO BE DRAWN
   10   RSQ = R0K - YS**2
        IF (RSQ > 0.0001) THEN
          R1 = SQRT (RSQ)
C * SET UP END-POINTS OF LINE
          IF (IHOR == 1) THEN
            XPL1 =  R1
            XPL2 =  YS
            XPL4 = -R1
            XPL5 =  YS
          ELSE
            XPL1 =   CB * CA * R1 + SB * YS
            XPL2 = - SB * CA * R1 + CB * YS
            XPL4 = - CB * R1 + SB * YS
            XPL5 =   SB * R1 + CB * YS
          END IF
          XYZPL(1) = XPL1 + XYZK(1)
          XYZPL(2) = XPL2 + XYZK(2)
          XYZPL(3) = SQRT (ABS (R0K - XPL1**2 - XPL2**2))
     1             +   XYZK(3)
          XYZPL(4) = XPL4 + XYZK(1)
          XYZPL(5) = XPL5 + XYZK(2)
          XYZPL(6) = XYZK(3)
C * PLOT THIS LINE AND TEST FOR OBSCURATIONS BY ATOMS/BONDS
          CALL PLUT19 (MODE, NN)
C * DRAW NEXT LINE IN REVERSE DIRECTION
          NN = - NN
        END IF
C * END OF LOOP FOR SHADING
        YS = YS + DISP
        IF (YS < R0)  GO TO 10
        IF (IPR(346) > 0) CALL GGIP (0.0, FLOAT (IPR(19)), 0.0, 0)
        PAR(8) = PAR(8) + 90.0
      END DO
      RETURN
      END SUBROUTINE PLUT36
 
      SUBROUTINE PLUT37 (IAT, JAT, KAT, LAT, OMEGA)
      USE parameters
      USE pluto
C * BOND ANGLE
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IAT
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: LAT
      REAL    :: VA
      REAL    :: VB
      REAL    :: DAB
      REAL    :: DAK
      REAL    :: DBK
      REAL    :: COSW
      REAL    :: OMEGA
      REAL    :: GEN009
      IF (LAT == 0) THEN
        DAK = 0
        DBK = 0
        DAB = 0
        DO I = 4, 6
          VA  = RA(IAT * NP43 + I) - RA(JAT * NP43 + I)
          VB  = RA(KAT * NP43 + I) - RA(JAT * NP43 + I)
          DAK = DAK + VA**2
          DBK = DBK + VB**2
          DAB = DAB + VA*VB
        END DO
        IF (DAK <= 0.0 .OR. DBK <= 0.0) THEN
          OMEGA = 0.0
        ELSE
          DAB   = MAX (-1.0, MIN (1.0, DAB / SQRT (DAK * DBK)))
          OMEGA = ACOS (DAB) * RGBL(6)
        END IF
      ELSE
C * TORSION ANGLE
        DO I = 1, 3
          ZU(I)     = RA(JAT * NP43 + I + 3) - RA(IAT * NP43 + I + 3)
          ZU(I + 3) = RA(KAT * NP43 + I + 3) - RA(JAT * NP43 + I + 3)
          ZU(I + 6) = RA(LAT * NP43 + I + 3) - RA(KAT * NP43 + I + 3)
        END DO
        CALL GEN008 (ZU(1),  ZU(4),  ZU(10), 1)
        CALL GEN008 (ZU(4),  ZU(7),  ZU(13), 1)
        CALL GEN008 (ZU(10), ZU(13), ZU(1),  1)
        COSW  = MAX (-1.0, MIN (1.0, GEN009 (ZU(10), ZU(13))))
        OMEGA = ACOS (COSW) * RGBL(6)
        IF (GEN009 (ZU(1), ZU(4)) < 0.0) OMEGA = - OMEGA
      END IF
      RETURN
      END SUBROUTINE PLUT37
 
      SUBROUTINE PLUT38 (NER, NERR, LU)
C * ERROR HANDLING
      IMPLICIT NONE
      INTEGER :: LU
      INTEGER :: NER
      INTEGER :: NERR
      INTEGER :: IOST
      SELECT CASE (NER)
        CASE (1)
          WRITE (LU, 99999, IOSTAT = IOST)
        CASE (2)
        CASE (3)
          WRITE (LU, 99997, IOSTAT = IOST)
        CASE (4)
          WRITE (LU, 99996, IOSTAT = IOST)
          WRITE (LU, 99995, IOSTAT = IOST)
        CASE (5)
          WRITE (LU, 99994, IOSTAT = IOST)
        CASE (6)
          WRITE (LU, 99993, IOSTAT = IOST) CHAR (7)
        CASE (7)
          WRITE (LU, 99998, IOSTAT = IOST)
        CASE (8)
        CASE (9)
        CASE (10)
      END SELECT
C * CALL EXIT/STOP
      IF (NERR == 1) CALL GEN127 (' FATAL PROBLEM')
      IF (IOST /= 0) RETURN
      RETURN
99999 FORMAT (/'>>> PROBLEM TOO LARGE; INCREASE ARRAY SIZE (NP49) <<<')
99998 FORMAT (/':: Too Many FVAR - Parameters')
99997 FORMAT (/'>>> STACK1 OVERFLOW;  INCREASE ARRAY SIZE (NP49) <<<')
99996 FORMAT (/'>>> PROBLEM WITH SHELX-STYLE INPUT <<<')
99995 FORMAT (/'    CHECK FVAR-FREE VARIABLES CONSISTENCY !')
99994 FORMAT (/':: Problem Too Large to fit in scratch array (Ignored)'
     1        )
99993 FORMAT (/':: Parameter outside acceptable range (ignored)', A)
      END SUBROUTINE PLUT38
 
      SUBROUTINE PLUT39
C * PACK RANGE/PLAN INSTRUCTIONS
      USE files
      USE parameters
      USE pluto
      USE sgxyz
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: N
      INTEGER          :: KL
      INTEGER          :: KN
      INTEGER          :: MML
      INTEGER          :: NRS
      INTEGER          :: NSYM
      INTEGER          :: MODE
      INTEGER          :: NRES
      INTEGER          :: ITKK
      INTEGER          :: MADDR
      REAL             :: XML
      REAL             :: CMAX
      REAL             :: CMIN
      REAL             :: CMIA
      REAL             :: DHKL
      REAL             :: XDUM
      CHARACTER(len=1) :: N1
C * MODE =      0 : PACK RANGE CALCULATION WITH C.G.
C * MODE = > 1 :  ,,    ,,     ,,        ,,  ATOM
      MODE     = 0
C * SET REBUILD
      IPR(130) = 0
      NSYM     = IPR(48)
      NRES     = IPR(75)
      KL       = IPR(220)
      KN       = IPR(221)
C * TEST FOR PACK RANGE MODE (=0)
C * SET DEFAULT PACK RANGE
      CALL GEN074 (PAR, 119, 121, -0.01)
      CALL GEN074 (PAR, 122, 124,  0.01)
C * SET DEFAULT MAXIMUM TO PLANE DISTANCES
      RA(IPR(80) + 5) = -1.5
      RA(IPR(80) + 6) =  1.5
C * GET PACK RANGE PARAMETERS
      I = 0
      IF (KL > 1) THEN
        DO L = 2, KL
          N1 = IFL(L)(1:1)
C * PACK RANGE PARAMETERS
          IF (N1 == 'R') THEN
            DO J = 1, 3
              IF (I + 2 <= KN) THEN
                PAR(118 + J) = FN(I + 1)
                PAR(121 + J) = FN(I + 2)
              END IF
              I = I + 2
            END DO
            IPR(126) = 1
C * PACK PLAN H K L PARAMETERS
          ELSE IF (N1 == 'P') THEN
            IPR(36) = 1
            IF ((KN - 3) < I) CYCLE
            DO K = 1, 3
              I = I + 1
              IPR(31 + K) = NINT (FN(I))
            END DO
            IF ((KN - 2) < I) CYCLE
C * MAXIMUM TO PLANE DISTANCES
            RA(IPR(80) + 5) = FN(I + 1)
            RA(IPR(80) + 6) = FN(I + 2)
            I = I + 2
          ELSE IF (N1 == 'C') THEN
            IPR(31) = 1
            CALL PLUT13 (0, KL, MODE, XDUM)
            IPR(220) = IPR(220) - 1
            KL       = IPR(220)
            IF (MODE <= 0) GO TO 50
          END IF
        END DO
      END IF
C * FIND MOLECULES HAVING THEIR CENTRE WITHIN THE RANGE GIVEN
      IF (IPR(126) == 0) THEN
C * TEST FOR PLANE MODE
        IF (IPR(36) > 0) THEN
          CMIA = 0
        ELSE
          CMIA = 2
        END IF
        CMIN = -2
        CMAX =  3
        DO K = 1, 3
          PAR(118 + K) = CMIN + CMIA
          PAR(121 + K) = CMAX - CMIA
        END DO
      END IF
C * UNIQUE AND HBOND ARU INACTIVE
      CALL PLUT17 (0.0, 3, MADDR, LU6)
      DO NRS = 1, NRES
        DO K = 1, 3
          SGX(K + 3) = 0.0
          IF (MODE == 0) THEN
            SGX(K) = RCG(K, NRS)
          ELSE
            SGX(K) = RA(MODE * NP43 + K)
          END IF
          SGY(K) = SGX(K)
        END DO
        IF (IPR(36) > 0) THEN
          DHKL = IPR(32) * IPR(32) * PAR(107)
     1         + IPR(33) * IPR(33) * PAR(108)
     2         + IPR(34) * IPR(34) * PAR(109)
     3         + IPR(32) * IPR(33) * PAR(118)
     4         + IPR(32) * IPR(34) * PAR(117)
     5         + IPR(33) * IPR(34) * PAR(116)
          DHKL = SQRT (DHKL)
          RA(IPR(80) + 4) = 0.0
          DO K = 1, 3
            RA(IPR(80) + K) = FLOAT (IPR(K + 31)) / DHKL
            RA(IPR(80) + 4) = RA(IPR(80) + 4) +
     1                        RA(IPR(80) + K) * SGY(K)
          END DO
        END IF
C * GENERATE AND TEST ARU'S FOR BEING WITHIN PACK RANGE
        DO N = 1, NSYM
          CALL SGSM (3, ICL, SGX, N, LU6, IERR)
          DO K = 1, 3
            T(K)     = 0.0
            XYZOR(K) = SGX(K + 6)
          END DO
          K = 1
   10     IF (XYZOR(K) < PAR(K + 118))  GO TO 20
          XYZOR(K) = XYZOR(K) - 1.0
          T(K) = T(K) - 1.0
          GO TO 10
   20     XYZOR(K) = XYZOR(K) + 1.0
          T(K)     = T(K) + 1.0
          IF (XYZOR(K) > PAR(K + 121))  GO TO 40
          K = K + 1
          IF (K <= 3)  GO TO 10
          DO J = 1, 3
            ITKK = NINT (T(J))
C * T(KK) TO BE WITHIN THE RANGE -5:4
            IF (ITKK > 4 .OR. ITKK < -5) GO TO 30
          END DO
          MML = N * 1000 + NINT (T(1)) * 100 + NINT (T(2)) * 10
     1        + NINT(T(3)) + 555
          XML = MML + NRS / PAR(42)
C * COPY ALL TRANSFORMED ARU'S FOR NRS
          CALL PLUT35 (XML, 0)
   30     K = K - 1
          GO TO 20
   40     K = K - 1
          IF (K > 0)  GO TO 20
        END DO
      END DO
   50 IPR(36) = 0
      RETURN
      END SUBROUTINE PLUT39
 
      SUBROUTINE PLUT40 (I, J, N, ISW)
C * TEST FOR D-H
      USE files
      USE parameters
      USE pluto
      USE sgxyz
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: M
      INTEGER :: N
      INTEGER :: I0
      INTEGER :: J0
      INTEGER :: IDH
      INTEGER :: JDH
      INTEGER :: ISW
      INTEGER :: IHAT
      INTEGER :: NATO
      REAL    :: D
      REAL    :: ANG
      NATO = IPR(39)
      ISW  = -1
C * TEST FOR H-ATOM
      CALL PLUT15 (-1, I, 44, IHAT)
      IF (IHAT == 1) THEN
C * TEST FOR D-H ATOM
        IF (IPR(109) == 1) THEN
          CALL PLUT15 (-1, I, 32, IDH)
        ELSE
          IDH = 1
        END IF
        IF (IDH > 0) THEN
C * PUT TRANSFORMED COORDINATES FOR J IN 0
          DO K = 1, 3
            SGX(K)     = RA(J * NP43 + K)
            SGX(K + 3) = T(IPR(120 + K))
          END DO
          CALL SGSM (3, ICL, SGX, N, LU6, IERR)
          DO K = 1, 3
            RA(K) = SGX(K + 6)
          END DO
          CALL PLUT23 (0)
C * FIND DONOR ATOM BONDED TO I
          DO I0 = IPR(69) + 1, NATO
            CALL PLUT22 (I0, I, D)
            IF (D < 1.25) THEN
              CALL PLUT37 (I0, I, 0, 0, ANG)
              IF (ANG >= PAR(97)) ISW = 1
              RETURN
            END IF
          END DO
        END IF
      ELSE
C * TEST FOR D-H ATOM
        CALL PLUT15 (-1, J, 32, JDH)
        IF (JDH > 0) THEN
C * GET INVERSE OPERATION TO APPLY ON ATOM I
          SGX(1) = N
          DO K = 1, 3
            SGX(K + 1) = T(IPR(120 + K))
          END DO
          CALL SGSM (9, ICL, SGX, 0, LU6, IERR)
          DO K = 1, 3
            SGX(K)     = RA(I * NP43 + K)
            SGX(K + 3) = SGX(9 + K)
          END DO
          M = NINT (SGX(9))
          CALL SGSM (3, ICL, SGX, M, LU6, IERR)
          DO K = 1, 3
            RA(K) = SGX(6 + K)
          END DO
          CALL PLUT23 (0)
          DO J0 = IPR(69) + 1, NATO
            CALL PLUT22 (J0, J, D)
            IF (D < 1.25) THEN
              CALL PLUT37 (J0, J, 0, 0, ANG)
              IF (ANG >= PAR(97)) ISW = 1
              RETURN
            END IF
          END DO
        END IF
      END IF
      RETURN
      END SUBROUTINE PLUT40
 
      SUBROUTINE PLUT41 (JAT, NEE, IER)
C * SUPPORT RENAME
      USE files
      USE parameters
      USE atomdata
      USE pluto
      IMPLICIT NONE
      INTEGER :: J
      INTEGER :: K
      INTEGER :: J1
      INTEGER :: J2
      INTEGER :: NB
      INTEGER :: NE
      INTEGER :: JM
      INTEGER :: JAT
      INTEGER :: KAT
      INTEGER :: NEE
      INTEGER :: NQX
      INTEGER :: IER
      INTEGER :: NE4
      INTEGER :: NSS
      INTEGER :: IASU
      INTEGER :: NATZ
      INTEGER :: NQSM
      INTEGER :: NIEN
      INTEGER :: NPROP
      INTEGER :: INQNR
      INTEGER :: JNQNR
      REAL    :: ZL
      REAL    :: RL
      REAL    :: XLZ
      REAL    :: YLZ
      REAL    :: XDUM
      REAL    :: YUNK
      REAL    :: PAR40
C * SUBSTITUTE TEMPORARY NEW LABEL
      NB = 1
      NE = 7
      J1 = IEL(IEN(NEE)) / 100
      J2 = MOD (IEL(IEN(NEE)), 100)
      IF (J2 == 0) THEN
        JM = 900
      ELSE
        JM = 90
      END IF
      DO J = 1, JM
        IF (J2 == 0) THEN
          WRITE (IFL(4), 99999, IOSTAT = IOST)
     1      CHAR (ICHAR ('A') + J1 - 1), 1000 - J
        ELSE
          WRITE (IFL(4), 99998, IOSTAT = IOST)
     1      CHAR (ICHAR ('A') + J1 - 1), CHAR (ICHAR ('a') + J2 - 1),
     2      100 - J
        END IF
        CALL PLUT13 (1, 4, KAT, XDUM)
        IF (KAT <= 0) THEN
          CALL PLA046 (9, IFL(4), NE4, NQX, NSS, NQSM,
     1                 INQNR, JNQNR, NIEN)
        YUNK = RA (JAT * NP43 + 7)
        DO K = 1, IPR(37)
          IF (RA(K * NP43 + 7) == YUNK)
     1    RA(K * NP43 + 7) = INQNR
        END DO
C * WRITE RENAME INSTRUCTION TO .pjn
        WRITE (LU22, 99997, IOSTAT = IOST) IFL(3), IFL(4)
        IF (IABS (IGBL(8)) == 2) CALL PLUT29 (2, IFL(3), IFL(4), 0, 0)
          CALL PLA015 (0, 53)
          CALL GEN039 (1, IFL(3), 1, 7, NB, NE)
          PAR40 = NE * PAR(349) * PAR(19) / 2.0
          NATZ  = IPR(62) + JAT
          CALL PLUT14 (-1, NATZ, IASU, NPROP, XLZ, YLZ, ZL, RL)
          CALL PLA439 (0.0, IFL(3), NE, PAR(349), 0, 2,
     1                 XLZ - PAR40, YLZ - PAR(28))
          CALL GEN039 (1, IFL(4), 1, 7, NB, NE)
          PAR40 = NE * PAR(349) * PAR(19) / 2.0
          CALL PLA439 (0.0, IFL(4), NE, PAR(349), 1, 2,
     1                 XLZ - PAR40, YLZ - PAR(28))
          RETURN
        END IF
      END DO
C * NO SUBSTITUTION (CONFLICT)
      CALL PLA015 (0, 8)
      WRITE (LU6, 99996, IOSTAT = IOST) IFL(3), IFL(2), CHAR(7)
      IER = 1
      RETURN
99999 FORMAT (A, I3)
99998 FORMAT (2A, I2)
99997 FORMAT ('RENAME', 2(1X, A))
99996 FORMAT (':: No Substitution: New Label: ', A, 'for: ', A,
     1        'conflicts with label in list', A)
      END SUBROUTINE PLUT41
 
      SUBROUTINE PLUT42 (NB, IATK, JATK, SANG, ANGM, NMET, D, D1, D2,
     1  MNCODE)
C * SUPPORT HFIX
      USE atomdata
      IMPLICIT NONE
      INTEGER :: NB
      INTEGER :: IATK
      INTEGER :: IATL
      INTEGER :: JATK
      INTEGER :: JATL
      INTEGER :: NMET
      INTEGER :: MNCODE
      REAL    :: SANG
      REAL    :: ANGM
      REAL    :: D
      REAL    :: D1
      REAL    :: D2
      IF (NB == 0) THEN
        MNCODE = -1
      ELSE
        IATL   = IATNR(IEN(IATK))
        JATL   = IATNR(IEN(JATK))
        MNCODE = 0
C * HOST = Boron
        IF (IATL == 5) THEN
          IF (NB == 4) THEN
            IF (ANGM < 130) THEN
              MNCODE = -1
            ELSE
              MNCODE = 153
            END IF
          ELSE IF (NB == 5) THEN
            MNCODE = 153
          END IF
C * HOST = Carbon
        ELSE IF (IATL == 6) THEN
C * FOUR BONDS - NO ATTACHED H-ATOMS
          IF (NB == 4) THEN
            MNCODE = -1
          ELSE IF (NB == 3) THEN
            IF (SANG < 340.0) THEN
              IF (NMET == 1) THEN
                MNCODE = 43
              ELSE
                MNCODE = 13
              END IF
            ELSE IF (SANG > 350) THEN
              MNCODE = -1
            END IF
          ELSE IF (NB == 2) THEN
            IF (SANG < 115) THEN
              IF (D1 > 1.45) THEN
                MNCODE = 23
              ELSE
                MNCODE = 43
              END IF
            ELSE IF (SANG > 150.0) THEN
              MNCODE = -1
            ELSE
              IF (D1 > 1.45 .AND. D2 > 2.0) THEN
                MNCODE = 23
              ELSE
                MNCODE = 43
              END IF
            END IF
C * TERMINAL CH3 - FREE ROTATOR
          ELSE IF (NB == 1) THEN
            IF (D > 1.4) THEN
              MNCODE = 137
            ELSE IF (D > 1.25) THEN
              MNCODE = 93
            ELSE
              MNCODE = 163
            END IF
          END IF
C * HOST = Nitrogen
        ELSE IF (IATL == 7) THEN
          IF (NB == 1) THEN
            IF (D > 1.35) MNCODE = 93
          END IF
C * HOST = Oxygen
        ELSE IF (IATL == 8) THEN
          IF (NB == 1) THEN
C * TEST FOR BONDED TO P OR S
            IF (JATL == 15 .OR. JATL == 16) THEN
              IF (D > 1.5)  MNCODE = 83
            ELSE
              IF (D > 1.27) MNCODE = 83
            END IF
          ELSE
            MNCODE = -1
          END IF
        ELSE
          MNCODE = -1
        END IF
      END IF
      RETURN
      END SUBROUTINE PLUT42
 
      SUBROUTINE PLUT43 (IB, IBEG, IEND, X, Y, DELMIN, IASU, IMIN)
C * FIND NEAREST ITEM
      USE pluto
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IB
      INTEGER :: IBEG
      INTEGER :: IEND
      INTEGER :: IASU
      INTEGER :: IMIN
      REAL    :: X
      REAL    :: Y
      REAL    :: DEL
      REAL    :: DELMIN
      DO I = IBEG, IEND
        IB = IB + NP0
        DEL = (RA(IB - 3) - X)**2
     1      + (RA(IB - 2) - Y)**2
        IF (DEL < DELMIN - 0.001) THEN
          IASU   = NINT (RA(IB - 5))
          IMIN   = I
          DELMIN = DEL
        END IF
      END DO
      RETURN
      END SUBROUTINE PLUT43
 
      SUBROUTINE CHECK (MODE, IVERS)
C * EMBEDDED ENCODED check.def FILE
      IMPLICIT NONE
      INTEGER                            :: MODE
      INTEGER                            :: IVERS
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ICK
      ALLOCATE (ICK( 60630))
      ICK(     1:   300) = (/
     *   -250202, 589325160,1701014318,1684366880,1668247156,1634299507,
     * 544499813, 544499059,1953704992,1701999215,1914729576,1919251304,
     *1869374579, 740324200,1869771808,2002874990,1768843040,1835365235,
     *1634166131,        -3, 589307936, 538976288,1634624544,1952807028,
     * 544171622,1701996910,1730179951,1835343973,2020633697,1851880553,
     *1869488225,1852055649,1685481827,1696622963,1937073508, 543324448,
     *        -3, 589307936, 538976288, 538976288,1952998688,1886547815,
     *1918987552,1347174740,1330520183,1751477792,1920298528,1768824948,
     *1751457831,1447119945,1145132105,1330521888,1836016741,        -3,
     * 589307936,        -3, 589307936, 538976288, 542402665,1931503209,
     *1818566761,1931506277,1633951863,1751477792,1347174740,1330520169,
     *1931502433,1819043172, 544696692,1746957416,1696605997,1965498479,
     *1914709805,1428627571,2003399779,1746935840, 589307936, 538976288,
     * 538976288, 538976288, 538976288, 539518254,1731076135,1886151028,
     *1869488173,1965060971, 825569328, 778266982, 657006624,        -3,
     * 589307936,        -3, 589316462, 543518307,1868850532, 543385701,
     *1667968612,1701191798,1701999465,1869488233,1931502957,1650812004,
     *1701060713,1847620712,1696616524,1096044366, 544436085,1919116576,
     *1668244581, 773870696,1635000352,        -3, 589325167,1684349033,
     *1931507059,1701060725,1852597619,1931497548,1096044366, 543582574,
     *1685266529, 543385701,1667968612,1701191782,1768711456,2003399784,
     * 543236205,1869767968,1919247205,1853104228,1635018030,        -3,
     * 589316384,1919246692,1633840229, 543387504,2032168806, 544499813,
     * 543518050,1701078117,1679844200,1701014318,1684366880,1986359923,
     *1768910368,1667329568,1650794607,1651794281,1852138528,2003399784,
     * 544499813,        -3, 589329509,1919773038,1634476139,1702453871,
     *1634886688,1668246893,1634624570, 544238689,1953459744, 762982944,
     *        -3, 589307936,        -3, 589311264,1449225321,1684108393,
     *1869488239,1970565237,1948284777,1819025506,1696622958, 544499813,
     * 544174692,1701978209,1931502693,1718185573,1679845741,1886153059,
     *1769237625, 543319404,1870081056,        -3, 589307936,1937072746,
     *1701016608,1953439842,1701408359, 544436332,1769221493,1881172334,
     * 541150277,1381244993, 740311596, 541270054, 541532275,1701016681,
     *1869488160,        -3, 589307936,        -3, 589311264,1415934836,
     *1931501938,1696622948,1701737577,1718183268, 544696692,1746957416,
     *1919247661,1684629353,1948282485,1835165042,1931485216,        -3,
     * 589307936,1597012088, 539828327,1701733746,1634476064,        -3,
     * 589307936,1597077624, 539828323,1701604399,1937337709,1702130297,
     *        -3, 589307936,1597143160, 539828321,1685073266,1701601652,
     *1701060640,        -3, 589307936,1597208696, 539828329,1853125217,
     * 543647087,1835365490,2032148512,        -3, 589307936,1597274232,
     * 539828329,1853121906, 543647087,1835365490,2032148512,        -3,
     * 589307936,1597339768, 539828323,1869574756,1768841588,1768910368,
     *1734700909,1702130297,        -3, 589307936,1597405304, 539828342,
     *1869177888,1952805748,1931486752,1986097769,1629495328,        -3,
     * 589307936,1597470840, 539828342,1634888033,        -3, 589307936,
     *1597536376, 539828264,1180791905,1814634579,1868985463,1634886944,
     *1165128303,1920151376,1919902316,1701671712,        -3, 589307936,
     *1597601912, 539828306,1701211237,1668573551,1847616609,1952522345,
     *1936946533,1931485216,        -3, 589307936,        -3, 589311264/
     * )
      ICK(   301:   600) = (/
     *1097624608,1952805748,1931501938,1696621669,1718185573,1679843699,
     * 544503663, 543975790,1696625524,1634630241,1931485216,        -3,
     * 589307936,1416127776,1718186611,1948281961,1852121191,1769366899,
     * 544499813, 544499059,1949134453,1835165042, 543256164, 544499826,
     *1702062191,1818522400, 675361836, 540229941, 689971232,        -3,
     * 589307936, 538976325, 778513952,1600875629, 543388265,1952395552,
     *1668442484,1597120611,1919513695, 857743392,        -3, 589307936,
     *1416127776,1936024431,1852055660,1768842528,1684366953,1852142368,
     *1952998688,1835365235,1634166048, 675362101, 690888736,        -3,
     * 589307936, 538976325, 778513952, 659780722,1969452149,1919230051,
     *1869509729,1768846112,1936682102,1701737504,1633903461,1936943458,
     *1818566742,1869177971, 544171552, 608575553,1852254762, 858202144,
     *        -3, 589307936,        -3, 589307936, 608772196,1701210478,
     *1702043767,1751478885, 539520880,1953066862,1634495609, 689987950,
     * 539453806,1952802661,1915166836,1752327539,1752132708, 796287340,
     *1969561719,1768713248,1650794608,1818321765,1679826976, 589307936,
     * 608575588,1701210478,1702043767,1751478885, 539520880,1953066862,
     *1634495609, 689987872, 661808481,1814503540,1752327539,1752132708,
     * 796287340,1969561719,1768713248,1650794608,1818321765,1679826976,
     *        -3, 589307936, 608247908,1701210478,1702043767,1751478885,
     * 543256096,1635020653, 543973730,1701585001,1931503982,1936028276,
     *1701060648,1718186611,1948852256,        -3, 589307936, 608313444,
     *1701210478,1702043767,1751478885, 543256096,1635020653, 543973730,
     *1701585001,1931503982,1936028276,1701060648,1936024431,1852057888,
     *        -3, 589307936, 609755236,1701210478,1702043767,1751478885,
     * 543321966,1680630126,1735157036,1953460851,1768910368, 677601644,
     *1668639841,1952801833, 543781664,1768846181,1920230756,        -3,
     * 589307936, 609820772,1701210478,1702043767,1751478885, 543321966,
     *1680630126,1735157036,1953460851,1768910368, 678585712,1869771877,
     *1680416800, 543781664,1768846181,1920230756,        -3, 589307936,
     *        -3, 589321317,1937011488, 678846828,1969561662, 543388265,
     *1948852321,1919230052,1869505824,1718775661, 544368999,1752440948,
     *1864395877,1718886440,1768235107,1919513695, 857760626,1769234226,
     * 543388265,1952395561,        -3, 589307936,        -3, 589316428,
     *1163023455,1281717861,1818181920,1025524591,1970037792,1231971433,
     *1667331173, 543236179,1701996911,1970479184,1919902316,1701650477,
     * 541290350,1936286821,1914717025,1919247989,1819048238,        -3,
     * 589316428,1163023455,1281717861,1818182176,1025527145,1734898720,
     *1231971433,1667331173, 543236176,1869899118,1953063276,1819877459,
     *1701996911,1970479184,1919902316,1701654048,        -3, 589316428,
     *1163023455,1281717861,1818182432,1025524584,1701014304,1953439813,
     *1853060466,1696622964, 543781664,1330323553,1852055662,1869881410,
     *1701011829,1936007279,1713398126, 542078565,1920166247,1752444448,
     *        -3, 589316428,1163023455,1281717861,1818183456,1025525605,
     *1852142177,1814055278,1718562336,1130915171,1797289064,1635000425,
     *1948281203, 544108404, 542338925,1702127721,1852252245,1852143728,
     *1701016677,1680744480,        -3, 589307936,        -3, 589316428,
     *1163023455,1417244773,1597055008,1025524553,1176519535,1853060210,
     *1969452137,1869492051,2037281889,2015380850,1919906348, 541683299,
     *1869509481,1937007982,1948282738, 541944179,1936289383, 541352308/
     * )
      ICK(   601:   900) = (/
     *1630412832, 589316428,1163023455,1417244773,1597120544,1025526126,
     *1684628321,1953460768,1952997748, 544499813, 542340210,1969452149,
     *1919230029,1868850540, 544039289, 543319328,1467117422,1730178930,
     * 541353318,1768122725,1853107744, 589316428,1163023455,1417244773,
     *1597186080,1025526126,1684628321,1953460768,1952997748, 544499813,
     * 542340210,1969452149,1919230033,1969319017,1954095213,1635328098,
     *1696615535,1999511584,        -3, 589316428,1163023455,1417244773,
     *1597251616,1025524591,1936549236,1768104041,1836085871,1986358629,
     *1853107232,1298494568,1868853100,1869052204, 542209381,1920540783,
     *1914721141,1734829427,1953066862, 773857312,        -3, 589316428,
     *1163023455,1417244773,1597317152,1025526126,1718579821,1635019126,
     *1696615781,1936941415,1697390659,1751475051, 773857312,        -3,
     * 589307936,        -3, 589319759,1413829434, 539828310,1634494820,
     *1635019119,1847620213,1853038697,1853255531,1701060727,1769236512,
     *1952998688, 657290535, 544174196,1768910368,2003397740, 544240239,
     *1986618469, 544499064,1953849708,        -3, 589307936, 538976288,
     * 538976361,1852206962,1835103337,1869488225,1852055624,1162629152,
     *1869488244,1751457906,1701867378,1952801824,1095517522,1414733864,
     *1634624544, 760553591,1769236591,1970546976,        -3, 589307936,
     * 538976288, 539828291,1868851566,1730178926, 543388265,1952805481,
     *1629514857,1852127776,1092631840,1097624620, 541663293, 541676867,
     *1914728302,1819880480,1327512864,1331852143,1818588261,        -3,
     * 589307936, 538976288, 539828294,1869967904,1853189474,1701999392,
     * 674242671,1914712361, 543780452,1768120692,1696606305,1852055669,
     *1936024608,1718579744,1668248942,1953066599, 689992293,1936745827,
     *1953068645,1819877408, 589307936, 538976288, 538976301, 541944179,
     *1936289383, 541423728,1701996909,1701737569,1814055278,1718558793,
     *1936946533,1931485216,        -3, 589307936, 538976288, 538976301,
     * 541423728,1701996909,1701737569,1814053985,1952522322,1701601652,
     *1701060681,1936946533,1931485216,        -3, 589307936, 538976288,
     * 538976301, 542340210,1969452149,1918987296,1299145829,1814057573,
     *1818326117,1679837555,1937073523,        -3, 589307936, 538976288,
     * 538976301, 542469746,1702063980,1986356256,1869750388,1864393317,
     * 541288549,1667982692, 541684595,1969582880,        -3, 589307936,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1701667429,1684301156, 539451251,1751477368,1601332595,1600547180,
     *1697063026,1701210478,1701668206,1948281198,1937011317,1668573551,
     *1847617129,1818566696, 779249011, 689971232,1596993585, 538976288,
     * 807411744, 540155936, 538981152, 824197408, 538980640, 807415840,
     * 807411744,        -3,1315905631,1936221548,2019521125,1935631977,
     *1818566724,1635017038,1634559264,1181709678,1679845742, 542328901,
     *1280855072,1128875552, 538976288, 542141541,1634952480,1148133409,
     *        -3,        -2, 542328901,1280855090, 808532000,1634624544,
     *1818326117,1914730345,1819025505,1970564973,1635019107,1634495609,
     * 543780451,1819632741, 544499813, 543582574,1634476071, 779249011,
     * 656434793,1818566761,1847620712,1696604192, 541280582, 543257376,
     *1634607205,1835165028,1684366368,1668246893,1701737504,1886545251,
     *1701078372, 543324448,1952998688,1684108385,1851878757, 539451251,
     *1751477368,1601332595,1600547180,1697066528,        -3, 542402657,
     *1948279905,1952542305,1835343987,1752135020,1679847023,1948279397/
     * )
      ICK(   901:  1200) = (/
     * 544367982,1634559332, 543780468,1864378207,1769300850,1601332582,
     *1768842591,1768846196,1920295796,1768910451,1600415092,1634298995,
     * 657334304, 542402665,1931502957,1650812004,1701060710,1768711456,
     *1668247156,1634299507, 544499813, 543387501,1886152052,1696621669,
     *1952541036,1931505510, 544499813, 544367974,1768842605,1701737504,
     *1836016741,1814044704,        -3, 544568165,1679843694,1679844193,
     *1847615852,1869506336,2003399784, 544499813, 543518050,1701078117,
     *1679843187,1751477368,1600678764,1600547180,1696621157, 543520884,
     *1918985076,1701060724,1864397413,1885692276,        -3, 544499813,
     * 543582574,1634476146,1701210478,1701668206,1948281198, 544174692,
     *1701978228,1864397413,1668441441,1952784500,1751457894,1768841580,
     * 539438694,1667639072,1718185061, 544501536,1650794613,1936024608,
     *        -3, 543584114, 544499813, 544629100,1768186228,1768910368,
     *1868963956,1751457906,1701210478,1701668206,1949179936,        -3,
     *        -1, 589315646,1042305637,1886351988, 544499813, 544109933,
     *1650815520,1868963937,1953459488,1936290917,1931507561,1952981092,
     *1769174113,1852007727,1634625388,1696625253,1937011297,1768846451,
     *        -3,1596993586, 538976288, 807411744, 540024864, 538980384,
     * 840974624, 538980384, 807416096, 807411744,        -3,1316318562,
     *1701978223,1713390697,1937006958,1667571823,1914716526,1735157024,
     *1382380404,1918986606,1953701999,1847607668,1399420005, 539248928,
     *1315927141,        -3,        -2, 542402665,1931493708,1163023392,
     *1919250543,1920234272,1952998688,1853189474,1701978223,1713398132,
     *1869441379, 544434548,1702043764,1751217184,1634886944,1718378855,
     *1734698016,1768824948,1751457859,1229332577,1931485216, 543451507,
     *1952542307,1696624498, 543256167,1818566770,1702065266,1634299493,
     *1679829060, 759589985,1730752032,1416127776,1634956143,1667850612,
     *1701060708,1701996918,1701060711,1701801317,1953659168,1885434465,
     *1835365477, 544629100,1969582880,1835104544,1650794612,1751478885,
     *1718579744,1818588019, 543780454,1869770081,1953068645, 773857312,
     *        -3,        -1, 589315646,1042305637,1886351988, 544499813,
     * 544109933,1650815520,1868963950,1869491528, 543257711,1836261495,
     *1769236512,1432974191, 544174624,1428711724,1781080178,1702065266,
     *1634299508,1931485216,        -3,1596993587, 538976288, 807411744,
     * 540024864, 538980384, 840974624, 538980384, 807416096, 807411744,
     *        -3,1316318562,1701978223,1713395049,1936662639,1914721576,
     *1764518441, 538989157,1937011297,1768842596, 544108398, 759704897,
     *1953459571, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402665,1931493708,1163023392,1919250543,1920234272,1952998688,
     *1853189474,1701978223,1713401455,1848461344,1635020653,1931506792,
     *1635000417,1919230054,1818322791,1701060705,1931503713,1852075109,
     *1679826976,        -3, 544696692,1746949481,1936662639,1914721576,
     *1764518441, 544367987,1953653097,1853125408, 676670790,1818322729,
     * 773870696,1701409312,1970495847,1696623969,2032167017,1684349045,
     *1852990835,1869379173,1679826976,        -3, 543451507,1869767781,
     *1914726771,1937073523, 773857312,        -3,        -1, 589315646,
     *1042305637,1886351988, 544499813, 543451501,1701737321,1869504876,
     *1769240864,1868963937, 544239468,2037212530,1768104051,1953658211,
     *1953854053,        -3,1596993588, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 807411744,        -3/
     * )
      ICK(  1201:  1500) = (/
     *1349479545,1835364969,1663062900,1920295796,1970431264,1181709678,
     *1679849321,1952981069,1635281261,1970085956,1768777070,1936289646,
     * 539248928,1231971951,        -3,        -2, 542402665,1931493708,
     *1163023392,1919250543,1920234272,1869488240,1869379949,1701996899,
     * 544105844,2003792491,1931501934,1679848552,1701409312,1684630885,
     *1853057391,1851878505,1954095201,1931503215,1970168864,1768824864,
     * 544499813, 543388281,1937006956, 544437362,1969452149,1919233568,
     *        -3, 542011252,1698308176,1869379949,1701996899, 544437362,
     *1969452149,1919251232,1667329568,1650794604,1701276020,1768776052,
     *1696624498, 543454565, 544501536,1634607205,1920102254,1701803379,
     * 544437362,1969452149,1919229984, 543256161,1819898729,1932402720,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1634629920,1701667429,1684301156, 544367974,1768842605,1701737504,
     *1768846196,1920295796,1768910368,1718185061, 544240229,1936027252,
     * 543780384,1952998688,1128875552,        -3,1596993589, 538976288,
     * 807411744, 540024864, 538980640, 891306272, 538980640, 807415840,
     * 807411744,        -3,1315905605,1835165028,1684366368,1382377065,
     *1852140901,1853104196,1702125929,1819484230,1869966948, 538995054,
     * 544499813, 541280582, 538976288, 542141541,1634952480,1148133409,
     *        -3,        -2, 542011168,1701667429,1684301156, 539456101,
     *1718185573,1835363956, 543450484,1634298995, 656437861,1668248164,
     *1931507557,1919230054,1869966948, 543780384,1952998688,1128875566,
     * 541156212,1629504370,2037609518,        -3, 544367985,1969844837,
     *1931506792,1696622958,1668052339,1768910368,1868963956,1751457900,
     *1634956320, 657355365,1931944038,1768711456, 677998112,1667330917,
     * 544171552,1629508424,1162631244, 740317260, 544174624,        -3,
     * 542067781,1479680114,1701210478,1701668206,1948282738, 544434541,
     *1768710514, 543584114, 544108398, 760432709,1280855072,1919247977,
     *1852140901,1853104240,1919903602,1634562857, 543780384,1952998688,
     *1128875564,        -3, 543518050,1701078117,1679843941,1953981797,
     *1847620197,1668248164,1931507561,1952981107,1701669219,1869377390,
     *1931503982, 544239475,1769236847,1847603500, 544240229,1667589221,
     *1679843961, 543236128,        -3, 543126376,1701607519,1919251295,
     *1718185061, 544174624, 660564341,1668439922,1701210478,1700751726,
     *1937011317,1668573551,1853054820,1702125929,1819485984,1919247215,
     *1919168032,        -3, 542011252,1698308179,1212501080,1278357624,
     *2032170857,1819025505,1970564973,1635019107,1634495609, 543780451,
     *1819632741, 544499813, 543582574,1634476071, 779249011, 656434793,
     *1818566753,1931501934,        -3, 543518050,1701078117,1679827043,
     *1869442405,1853104247,1769236512,1952998688,1684108385,1851878757,
     * 539451251,1751477368,1601332595,1600547180,1697066528,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1702392937,
     *1852011625,1869488240,1634885997,1702126962, 544367974,1768842605,
     *1701737504,        -3,1596993590, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 807411744,        -3,
     *1315927141, 975193464,1953066595,1953066862, 542138738,1634559348,
     *1701978194,1701210478,1701060640,1025516609, 538976288, 538976288,
     * 538976289, 541683302,1864376352,        -3,        -2, 542402665,
     *1931493708,1163023392,1919250543,1920234272,1952998688,1919247977,
     *1852140901,1853104239,1713398126, 543520884,1768842100,1768910368/
     * )
      ICK(  1501:  1800) = (/
     *1885434465,1835365477,1915625504,        -3, 542328901,1280855072,
     *1668248178,1701016691, 541486946,1931507297,1819633011, 543780384,
     *1952998688,1178813984,1718579744,1165522025,1852011625,1869491744,
     *1245793857, 544108404, 773857312,        -3, 542011252,1698308172,
     *1634887525, 544629100,1969582880,1868963956,1751741216,1885434465,
     *1835365477,1914727777,2032165477, 543383925,1936024608,1652105327,
     *1952998770, 543580515,1953460851, 544499809,1847599136,        -3,
     * 543520884,1768842100,1768910368, 677719655, 773878903,1768844905,
     *1852255264,1937339252,1701667188,1768120684,1819877493,1852073330,
     * 544174624,1870030194, 761623412,1768776052,1701060640,        -3,
     * 543780468,1701737321,1953064307, 543256164, 544175208,1701978227,
     *2037609573,1835103337,1663067506,1919906419, 690888736,        -3,
     *        -1, 589315646,1042305637,1886351988, 544173600,1970172517,
     *1718185573,1679836271,1852797485,1210933620,1869443872,        -3,
     *1596993591, 538976288, 807411744, 540024864, 538980384, 891306272,
     * 538980384, 807416096, 807411744,        -3,1316318562,1701978223,
     *1713395054,1919247977,1852138528,1148153455,1915570208,1098149741,
     *1931488814, 774778414, 774778414, 774778414, 539248928,1382379631,
     *1920213024,        -3,        -2, 541684768,1769152627,1952542308,
     *1634886688,1886544227,1953063781, 544501536,1919247977,1852121160,
     * 761361519,1836261487,1847617637,1952805487, 543257711,1836261491,
     *1969448992,1634934863, 539369550, 543257376,        -3, 544240239,
     *1868963951,1713402984,1701409312,1668248178,1701016608,1634956137,
     *1735290213,1853107744,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1701667429,1684301156, 544367974,1768842605,
     *1701737504,1919247980,1701016681,1869509408,1684370529,1768715040,
     *1718185061, 539504232,1802250528,        -3,1596993592, 538976288,
     * 807411744, 540024864, 538980896, 891306272, 538980640, 807415840,
     * 807411744,        -3,1315905631,1769300850,1601332582,1768842591,
     *1919247980,1701016681,1869509471,1684370529,1768715040, 538995054,
     * 544499813, 541280582, 538976288, 542141541,1634952480,1148133409,
     *        -3,        -2, 542011168,1919247980,1701016681,1869488242,
     *1701015410,1685266551,1701995808,1718580590,1679845742, 544499813,
     * 539438691,1768302368,1718185061, 773865827,1952522307,1920562036,
     * 773874030,1679828806,1095324199,        -3, 544367985,1969844837,
     * 544499813, 543780451,1819636585,1869488239,1713402984,1696626030,
     *1835364967,1701060722,1701211237,1668573551,1847617129,1818566773,
     *1936024608,1768824948,1751457894,1768841580,        -3, 544367974,
     *1768842605,1701737504, 673656424,1802250016,1768824931,1634952480,
     *1868963937, 542328901,1280855072,1869750360,1277194853,1718185573,
     *1835363956, 689989998, 544499813, 541280582, 740320621,1650812004,
     *1701060640, 543319412,2003133806, 544367971,1869767795, 544696692,
     *1746957157,1835623279,1819242099, 543780384,1886352233,1953066862,
     * 540090465,1852055664,1919247205,1684366368,1652105313,1847599136,
     *        -3, 539451241,1969451615,1919247977,1852137321,1853060210,
     *1969452137,1869509471,1684370529,1768715047, 544367971,1869767726,
     *        -3, 542011252,1698308179,1212501080,1278357624,2032170857,
     *1819025505,1970564973,1635019107,1634495609, 543780451,1819632741,
     * 544499813, 539438696,1802250016,1718185061, 543257376,1634607205,
     *1835165028,1684366368,        -3, 543387501,1835363956, 544696692/
     * )
      ICK(  1801:  2100) = (/
     *1746957416,1696621665,1952542305,1835343911,1601398885,1819828072,
     *1802264422,1768711463, 773857312,        -3,        -1, 589315646,
     *1042301800,1701014304,1718579744,1886352485,1853122913,1814065761,
     *1684627828,1768910368,1954115685, 543256164, 544437345,1852072306,
     *1679849313,1986358373,1852273768, 543387502,1718380899,1948262432,
     *        -3,1596993593, 538976288, 807411744, 540155936, 538980896,
     * 824197408, 538980384, 807415840, 824188960,        -3,1382379631,
     *1920230756, 542269796,1767994473,1869488244,2037409056,1634624544,
     *1466005093,1818586727,1952981059,1869506156,1768125503, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542402661, 544367984,1869771877,1679849057,1819633011, 543584114,
     * 539451236,1768318578,1851748961,1684627828,1768910431,1954115685,
     * 656437106, 539451236,1768318578,1851748961,1684627828,1768910431,
     *1886547810,1697062944, 543256164, 539451236,1768318578,1851748961,
     *1684627828,1768910431,2002876005,1818586727,1952982816,1936224117,
     *1818501218,1696621423,1853057395,1952804468, 773870696,1769152577,
     *1279611476, 544434287,1970037792,        -3, 543383924,1667768432,
     *1869837161,1651270944,1667330917,1931506549,1667768417,1931507560,
     *1701995808,1629516665,1852008562,1869902447,1847616097,1936024608,
     *1684108385,1936028704,1769152613,1920102254,1701803379,1819877408,
     * 544367974,1768842596, 544696692,1746956142,1696624486, 544499813,
     * 544437345,1852072306,1679849313,1986358373,1852273768,1931506549,
     *1667768417,1931496815,1264656445, 540028471, 825243443, 541159015,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750388,1751457889,1986095468,1633839468,1769240864,1868963954,
     *1701211237,1668573551,1847616609,1952522342,1869750390,1634494820,
     *1635019119,1847615854,1679843698,1667787126,1634476064,1596993840,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980640,
     * 807415840, 807411744,        -3,1315905619,1969845345,1651270944,
     * 539510125,1650812004,1701062944,1382377068,1701016681,1869488196,
     *1635016992,1400205424,1818846564, 538976288, 542141541,1634952480,
     *1148133409,        -3,        -2, 541291129,1937006956, 544437362,
     *1969452149,1919230070,1634494820,1635019119,1847617907, 544108404,
     * 543387501,1886152052,1696626537,1953001333,1948284008,1696620918,
     *1634298977,1651076201,1954095215,1713402984,1696604192, 543257459,
     *1868786017,1952801824,1684629094,1918985076,1768910368,1684108385,
     * 773866597,1886352233,1952801824,1919247980,1701016681,1869488228,
     *1635016992,1634886944,1886545254,1701994850,1819877474,1869899808,
     *        -3, 544499813, 544433524, 544171552,1919247980,1701016681,
     *1869509408,1952997748, 544695666,1696626035,1701060713,1847620712,
     *1696622185,1851878432,1919247977,1852140901,1853104225,1852055668,
     *1752134501,        -3, 543518050,1701078117,1679845742, 544499813,
     * 539438691,1768302368,1718185061, 543319412,2003133806, 544367971,
     *1869767795, 544696692,1746957157,1835623279,1819242099, 543780384,
     *1886352233,1953066862, 540090465,1852055584, 544240229,1667589221,
     *1679843961, 543236135,1601398885,1819828072,1802264422,1768711463,
     * 544174624, 660564341,1668439922,1701210478,1700754021,1718379875,
     *1953066862,1935631461,1952541036,1931944050,1701015410,1680744480,
     * 542328901,1280855090, 813201696,1650553701,1679848037,1718185573,
     *1835363956, 544696684,1814062191, 544499809,1948279157,1953459553/
     * )
      ICK(  2101:  2400) = (/
     *1953063777,1819048238, 541158516,1701998177,1953068645,1819880480,
     *1634607136,        -3, 543520884,1701998177,1814062697,1818566775,
     *1769236512,1718185569,1814064994,1936028278,1701063712,1667329123,
     *1970037108,1701060705,1852055667,1768385889, 544367974,1818583924,
     *1768910368,1684108385, 544696684,1814044704, 543319328,1952998688,
     *1835626089,1836412192,1718579744,1986096233,1684108393,1869488225,
     *1852055649,1919117417,1986096174,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750369,1853431873,1414483232,1919247215,
     *1919185696,1718580590,1679845742, 544499813, 541280582,        -3,
     *1596993841, 538976288, 807411744, 540024864, 538980384, 824197408,
     * 538980384, 807415840, 807411744,        -3,1315905601,1953459571,
     * 541486965,1852055657,1847620712,1696617333,1886415977,1701060675,
     *1229332526, 774778414, 774778414, 774778414, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 542011168,
     *1635020653, 543387503,1919183214,1635018099, 544695666,1696621669,
     *1952801652,1701060713,1847620712,1696613193,1176531058,1768911392,
     *1953439860,1751457877, 677981290, 689990767,1869622816,1416127776,
     *        -3, 543257711,1830841441,1650814067, 543780384,1651471464,
     * 543977327,1886593139,1752135020,1679843941, 543777893,1853122915,
     *1634476137,1847619442,1684369952,1953439842,1696620915,1936679785,
     *1635018084, 544696692,1746935840, 543514979,1746956148,1751478830,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1952998688,1886545267,1701733221, 544171552,1629517409,1818846240,
     *1601398885,1819828082,1702059875,1751475051,1937075488,1919247215,
     *1919164521,1847620712,1696613193,1176510496,1596993842, 538976288,
     * 807411744, 540024864, 825110560, 824197408, 538980640, 807415840,
     * 807411744,        -3, 608264051,1751477368,1601332595,1600350309,
     *1667986293,1830831727,1970168864,1768824899,1229332526, 774778414,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542402661, 544437616,1886153061,1679835977,1176527727,
     *1853120873,1853038689, 539451251,1751477368,1601332595,1600547180,
     *1697063026,1701015410,1679843957,1948282479,1948279072,1986096233,
     *1679826976,        -3, 543257459,1868786017,1952801824, 660566888,
     *1701607519,1919251295,1667786083,1802728813, 656437861,1668248164,
     * 773865760,1986096233,1679847521,1769087087,1713399149,1650812004,
     *1701060647, 779249011, 656433518,1679826976, 539438696,1802250016,
     *1718185061,1931501932,1819244403, 544499813, 543257972,1869439348,
     *1768104035,1919246708,1768910368,1868963937, 539438694,1667639072,
     *1718185061, 544696692,1746948936,1162631244, 842037369,        -3,
     * 544501536,1650794613,1936024608,1718579744,1629512805,1952541036,
     *1701060705,1851878521,1936290592,1868963956,1751457906,1701210478,
     *1701668206,1948283493,1937075316, 773865760,1718185061, 543781664,
     *1986096233,1679826976, 544696421,1847620712,1696621409,1818457452,
     *1635018084, 543256164, 544367984,1869771877,1679844200,1701014387,
     *1970107168,1634886944,1768187246,1953063777,1814962255,1852602656,
     *1667785074,1633907813,1920147488,        -3, 544696692,1746952558,
     * 541152067,1229529206,1634497893, 543713639,1751478816,1952997742,
     * 540226080,1668247156,1919509109,1952784500,1864397928,1696621416,
     *1701014387,1970089504,1097736293,1835165028,1684366368,        -3,
     * 539438706,1702045472,1718185061, 544041319,1752440930,1696621170/
     * )
      ICK(  2401:  2700) = (/
     *1869309294, 740320617,1952998770, 543454565, 544501536,1684108385,
     * 544502369,1853056613,1914725746,1919906419, 544174624,1953439776,
     *        -3, 543450476,1768056178,1635018016,1869750369,1667459428,
     *1701737569,1814065263,1936993650,1701210478,1701668206,1948280164,
     *1769236846,1730178918, 543782003, 543387502,1952804468, 773869676,
     *1700885349,        -3, 544367917,1919247977,1852121185,1718904178,
     * 543780208,1818586469,1853122926,1730175342,2032165736,1634625381,
     *1931506799, 544499813, 539438706,1702045472,1718185061, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1952998688,1886545267,1701733221, 544171552,1629517409,1818846240,
     *1601398885,1819828072,1802264419,1751475051,1937075488,1919247215,
     *1919164521,1847620712,1696613193,1176510496,1596993843, 538976288,
     * 807411744, 540024864, 825110560, 824197408, 538980640, 807415840,
     * 807411744,        -3, 608264051,1751477368,1600678764,1600350309,
     *1667986293,1830831727,1970168864,1768824899,1229332526, 774778414,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542402661, 544437616,1886153061,1679835977,1176527727,
     *1853120873,1853038689, 539451251,1751477368,1600678764,1600547180,
     *1697063026,1701015410,1679843957,1948282479,1948279072,1986096233,
     *1679826976,        -3, 543257459,1868786017,1952801824, 660566888,
     *1701607519,1751870559,1667786083,1802728813, 656437861,1668248164,
     * 773865760,1986096233,1679847521,1769087087,1713399149,1650812004,
     *1701060647, 779249011, 656433518,1679826976, 539438696,1802250016,
     *1718185061,1931501932,1819244403, 544499813, 543257972,1869439348,
     *1768104035,1919246708,1768910368,1868963937, 539438694,1667639072,
     *1718185061, 544696692,1746948936,1162631244, 842037369,        -3,
     * 544501536,1650794613,1936024608,1718579744,1629512805,1952541036,
     *1701060705,1851878521,1936290592,1868963956,1751457906,1701210478,
     *1701668206,1948283493,1937075316, 773865760,1718185061, 543781664,
     *1986096233,1679826976, 544696421,1847620712,1696621409,1818457452,
     *1635018084, 543256164, 544367984,1869771877,1679844200,1701014387,
     *1970107168,1634886944,1768187246,1953063777,1814962255,1852602656,
     *1667785074,1633907813,1920147488,        -3, 544696692,1746952558,
     * 541152067,1229529206,1634497893, 543713639,1751478816,1952997742,
     * 540226080,1668247156,1919509109,1952784500,1864397928,1696621416,
     *1701014387,1970089504,        -3, 541158944,1701667429,1684301156,
     * 539438706,1702045472,1718185061, 544041319,1752440930,1696621170,
     *1869309294, 740320617,1952998770, 543454565, 544501536,1953653102,
     *1936090482, 543519346,1869771552,1869750388,1864376352, 543450476,
     *1768056178,1635018016,1869750369,1667459428,1701737569,1814065263,
     *1936993650,1701210478,1701668206,1948280164,1769236846,1730178918,
     * 543782003, 543387502,1952804468, 773857312,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1952998688,1886545267,
     *1701733221, 544171552,1629517409,1818846240,1601398885,1819828070,
     *1633836899,1751475051,1937075488,1919247215,1919164521,1847620712,
     *1696613193,1176510496,1596993844, 538976288, 807411744, 540024864,
     * 825110560, 824197408, 538980640, 807415840, 807411744,        -3,
     * 608264051,1751477368,1600545122,1600350309,1667986293,1830831727,
     *1970168864,1768824899,1229332526, 774778414, 773857312, 538988652,
     *1700885349, 541288549,1667964960,        -3,        -2, 542402661/
     * )
      ICK(  2701:  3000) = (/
     * 544437616,1886153061,1679835977,1176527727,1853120873,1853038689,
     * 539451251,1751477368,1600545122,1600547180,1697063026,1701015410,
     *1679843957,1948282479,1948279072,1986096233,1679826976,        -3,
     * 543257459,1868786017,1952801824, 660566888,1701607519,1717658207,
     *1667786083,1802728813, 656437861,1668248164, 773865760,1986096233,
     *1679847521,1769087087,1713399149,1650812004,1701060647, 779249011,
     * 656433518,1679826976, 539438696,1802250016,1718185061,1931501932,
     *1819244403, 544499813, 543257972,1869439348,1768104035,1919246708,
     *1768910368,1868963937, 539438694,1667639072,1718185061, 544696692,
     *1746948936,1162631244, 842037369,        -3, 544501536,1650794613,
     *1936024608,1718579744,1629512805,1952541036,1701060705,1851878521,
     *1936290592,1868963956,1751457906,1701210478,1701668206,1948283493,
     *1937075316, 773865760,1718185061, 543781664,1986096233,1679826976,
     * 544696421,1847620712,1696621409,1818457452,1635018084, 543256164,
     * 544367984,1869771877,1679844200,1701014387,1970107168,1634886944,
     *1768187246,1953063777,1814962255,1852602656,1667785074,1633907813,
     *1920147488,        -3, 544696692,1746952558, 541152067,1229529206,
     *1634497893, 543713639,1751478816,1952997742, 540226080,1668247156,
     *1919509109,1952784500,1864397928,1696621416,1701014387,1970089504,
     *1097736293,1835165028,1684366368,        -3, 539438706,1702045472,
     *1718185061, 544041319,1752440930,1696621170,1869309294, 740320617,
     *1952998770, 543454565, 544501536,1953653102,1936090482, 543519346,
     *1869771552,1869750388,1864393829,1818845797,1918989413,        -3,
     * 544174624,1633903465,1684369012,1634476144,1869837357,1919247977,
     *1852140901,1853104229,1684632681,1852252271,1713400180,1931502447,
     *1853121902,1949179936,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1919247977,1852140901,1853104242,1701211237,
     *1668573551,1853038692,1702125929,1819484200,1397245260,1481388592,
     *2021206304,        -3,1596993845, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980640, 807415840, 807411744,        -3,
     *1315905631,1936221548,2019518571,1818191465,1818566738,1701015410,
     *1679845742, 542328901,1280855090, 813201696,1128875552, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542011168,1701667429,1684301156, 544367974,1818583924,1768910368,
     *1919247215,1919164535,1634934886,1869966948, 543780384,1952998688,
     *1128875552,1718185061, 544499809,1948284769,1931502450,1700885605,
     *1679849321,1952981024, 542328901,1280855090, 813201696, 678392352,
     *1481386286, 542328901,1280855090, 813201696,1635087471,1835103337,
     *1667329132,2032167278,1668052324,1702043764,1751457831, 778595180,
     * 656434793,1818566772,1751217184,        -3, 544694643, 544568165,
     *1679845742, 544499813, 544367974,1768842605,1701737504, 677473391,
     *1852252279,1769236512,1952998688,1718185569,1814046510,1919251239,
     * 543582572,1697194081,1931501934, 543518050,1701078117,1679826976,
     * 543387501,1835363956, 544696692,1746957416,1696621665,1952542305,
     *1835343911,1601398885,1819828072,1802264422,1768711463, 773866607,
     * 544108404, 543385697,1852269856,1952999795, 543449460,1634623853,
     *1696604192,        -3, 543780384, 660564341,1668439922,1701210478,
     *1700754021,1718379875,1953066862,1935631461,1952541036,1931947552,
     *1400202088, 543236210,1701015410,1679845747, 544568165,1718971424,
     *1718579744,1634886504,1769365868,        -3, 543256164, 543584108/
     * )
      ICK(  3001:  3300) = (/
     *1819244333,1970282595,1634493301,1818326121,1869509422,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1919247977,
     *1852140901,1853104198,1094852710,1768711456, 676546629,1280855090,
     * 813201705,        -3,1596993846, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980640, 807415840, 807411744,        -3,
     *1315905631,1936221548,2019518049,1650419305,1818566738,1701015410,
     *1679845742, 542328901,1280855090, 813201696,1128875552, 774778414,
     * 538976288, 542141541,1634952480,1400205424,1819877408,        -3,
     *        -2, 542011168,1701667429,1684301156, 539451251,1751477368,
     *1600545122,1600547180,1697063026,1701015410,1679849313,1931503215,
     *1970168864,1768824948,1751457831, 778266982, 656434793,1818566772,
     *1751217184,2002875168,        -3, 543388261,1635018084, 544696692,
     *1746948936,1162631244, 842037369, 539520882, 542657577, 773870408,
     *1162631244, 842037369, 543257972,1869439348,1768120684,1819877481,
     *1852009589,1684370208,1952998688, 657352289,1646731296, 543582572,
     *1696625768,1635000439,1634934901,1936024608,1768824948,1751457894,
     *1768841580, 544367974,1768842605,1701737504, 677473391,1852252279,
     *1769236512,1952998688,1718185569,1814046510,1919251239, 539369504,
     *        -3, 539438696,1802250016,1718185061,1932075105,1931501934,
     * 543518050,1701078117,1679844207,1835885934,1948284777,1952981108,
     *1751457892,1635017070,1634559264, 660566888,1701607519,1717658207,
     *1718185061, 657334304,        -3, 541355808,1852797984,1667785070,
     *1734680692,1751741216,1684108385,1851878757, 773870453,1667768417,
     * 544367971,1869767712,1769152629,1936025205,1814062703,1914724722,
     *1667787126,1634476129,1852055584,        -3, 543584108,1819244333,
     *1970282595,1634493301,1818326121,1869509422,        -3,        -1,
     * 589315646,1042301800,1701014304,1952998688,1668247155,1769174117,
     *1852012832,1868963955,1667331188,1701996910,1730172025,1885675552,
     *        -3,1596993847, 540028464, 807415854, 808460337, 774909984,
     * 824197408, 538980384, 807415840, 824188960,        -3,1130915171,
     *1797280611,1635021925,1919512167, 542407024,1696613231,1853057395,
     *1952804451,2032168806, 539246945,1931485220,1109411186,1919906367,
     *        -3,        -2, 541288549,1667965030,1869750388,1751457891,
     *1869771365,1668554867,1667331188,1701996910,1730180217,1885675617,
     *1936943463,1852663150,1948284015, 544499817,1931501940,1869426208,
     *1416127776,1937076336,1818846564,        -3, 539451233,1953459551,
     *1936290917,1601468784,1700754297,1835167596, 656438881,1819632928,
     * 677864814,1701994860,1819877487,1852121199,1914729591,1864393576,
     *1634885987,1952805491, 689990003, 543584117,1852055668,1864376352,
     * 543319328,1768842095,1853057395,1952804468, 544696692,1746957416,
     *1696622185,1920168992,1869505824,1869750388,2003771491,1751216737,
     *1668572530,1931503982, 539451233,1953459551,1936290917,1600938338,
     *1701586734,        -3,        -1, 589315646,1042301800,1701014304,
     *1600416102,1718775391,1835360627,1970431332,1600549473,1668573551,
     *1851749480,1702125919,1835104288,1634624544, 710895221,1819025509,
     *1903518060,1769240864,        -3,1596993848, 540028464, 807416110,
     * 808460338, 774909984, 824197408, 538980384, 807415840, 807411744,
     *        -3,1600416102,1718775391,1835360627,1970431332,1600549473,
     *1668573551,1851749480,1702125919,1835104288, 776881454, 539647846,
     *1970039840, 538976288, 538976288, 538976544,1130915171,1797267488/
     * )
      ICK(  3301:  3600) = (/
     *        -3,        -2, 542402661, 544629100,1969582880,1868963879,
     *1600416102,1718775391,1919247980,1853054836,1751479393,1601003896,
     * 656433518,1679828831,1684629094,1919836018,1701211246,1935635560,
     *1702125919,1718971500, 656416800,        -3, 543257189, 538997349,
     *1886351988,1701060705,1931502961,1969318958, 541618039,1702258034,
     * 740324456,1696620915,1936679785,1635018084, 544367984,1869771877,
     *1679849057,1819633011, 544171552,        -3, 539451236,1768318578,
     *1851747685,1634956658,1701076838,1918985076,1768910431,1952998772,
     *1633643873,2015830048,1634624544,        -3, 539451236,1768318578,
     *1851747685,1634956658,1701076838,1918985076,1768910431,1952998772,
     *1633642101,1819027232,1634886944,1852797984,1701934433,1814962260,
     *1751741216,1769152617,1852010350,1936290676,1701737518,        -3,
     *        -2, 541280582, 541352308,1634623853,1696613477,1718185577,
     *1953066862,1933189152,        -3, 543122537,1717989998,1601004897,
     *1937076837,1683973746,1633907817,1869504372,1751479393,1601003896,
     * 975183904,        -3, 538976288,1181901155,1953066862, 544171552,
     *1970170225,1969561640,1937337709,1702130297, 761884260,1701864814,
     *1684369012, 689992293,1718379875,1953066862,1931504997,1634956658,
     *1701060719,1970544756,1864376352,        -3, 538976288, 660563049,
     *1717989998,1601332582,1819177823,1952998772,1633643873,2015833632,
     *        -3, 543122537,1717989998,1601004897,1937076837,1683973746,
     *1633907817,1869504372,1751479393,1600550252,1815748640,        -3,
     * 538976288,1181901155,1953066862, 544171552,1970170225,1969561640,
     *1937337709,1702130297, 761884260,1701864814,1684369012, 689992293,
     *1718379875,1953066862,1931504997,1634956658,1701060719,1970544756,
     *1864376352,        -3, 538976288, 660563049,1717989998,1601332582,
     *1819177823,1952998772,1633642101,1819027246,        -3, 543122537,
     *1717989998,1601332582,1819177823,1952998772,1633643873,2017075232,
     *        -3, 538976333,1635281261,1970086004,1751479393, 543256167,
     *1818566761,1847616613,1735550309,1931503215,1914729576,1696623973,
     *1634956658,1701060713,1853121902,1936290921,1702047264,1416127776,
     *1718772067,1953066862,        -3, 538976367,1713403246,1769043301,
     * 544367974,1818583924,1768910451, 544040289,1937076837,1679847285,
     *1948284015, 544499817,1931501934,1735157024,1769152615,1769366894,
     * 543324448,        -3, 538976295,1600416102,1718775391,1835360627,
     *1970431332,1600549473,1668573551,1851749480,1702125919,1835104295,
     * 773857312,        -3, 543122537,1717989998,1601332582,1819177823,
     *1952998772,1633642101,1819032096,        -3, 538976288,1416127776,
     *1952998772,1629512046,1735157024, 677998112,1684367218,1701147433,
     * 543257632,2003331427,1746957416,1696623973,1634956658,1701060722,
     *1701211237,1668573551,1847616367,1970172960,1769152544,        -3,
     * 538976288,1668050803,1696625775, 543387501,1886152052,1697521748,
     *1751457894,1918985076,1768910368,1868963957,1852404085,1696625253,
     *1718379875,1953066862,1931504997,1634956658,1701060719,1970544756,
     *1864376352,        -3, 538976288,1952999795, 543256167,1818566761,
     *1931503465,1986358816,1652105255,1600416102,1718775391,1835360627,
     *1970431332,1600549473,1668573551,1851749480,1702125919,1718971500,
     * 657334304,        -3,        -1, 589315646,1042301800,1701014304,
     *1600416102,1718775391,1835360627,1970431332,1600549473,1668573551,
     *1851749480,1702125919,1835104303, 710895221,1819025507,1869509481/
     * )
      ICK(  3601:  3900) = (/
     *1937007982,1668882464,        -3,1596993849, 540028464, 807415854,
     * 808591409, 774909984, 824197408, 538980384, 824193056, 807411744,
     *        -3,1600416102,1718775391,1835360627,1970431332,1600549473,
     *1668573551,1851749480,1702125919,1718971500, 791306093,1635262524,
     * 540094000, 539248160,1382379631,1920213024,        -3,        -2,
     * 542402661, 544367984,1869771877,1679849057,1819632928,1868963879,
     *1600416102,1718775391,1835360627,1970431332,1600549473,1668573551,
     *1851749480,1702125919,1718971500, 656435571, 543974771,1931506792,
     *1634607136,        -3, 544499813, 544367984,1869771877,1679849057,
     *1819632928,1868963879,1600416102,1718775391,1835360627,1970431332,
     *1600549473,1668573551,1851749480,1702125919,1835104295, 773870696,
     *1701409312,1918989417,1864395123,        -3, 544367984,1869771877,
     *1679849320,1701716076,1702064928,1952997742, 540094000, 773871464,
     *1701716084,1751479393,1600550252,1814063475, 543974771,1931506792,
     *1634607220,1751479393,1601003896, 544437603,1746935840,        -3,
     * 543236214,1634497893, 543780452,1768120692,1702043764,1751217184,
     *1952998770,1696620914,1696625253,1818326121,1986358393, 544042866,
     *1696625253,1718379875,1953066862,1931505001,1936943470,1730175348,
     *        -3, 543977335,1701978226,1702063980,1970563439,1848516640,
     *        -3, 542402661, 544040289,1937076837,1679844978,1633907817,
     *1869488168,1668246896,1818588261,1852142451, 689990003, 543520880,
     *1701016677,1679848559, 543319328,1751738216,1701978209,1948279072,
     *1819244389,1914708000,        -3, 544499813,1952538470,1970039840,
     *1986096245,1697521696,        -3, 542471029,1634495609, 740319520,
     *1952998772,1633642101,1819025526,1634497893, 543387506,1919251312,
     *1869505641,1852252276,1864397673,1848145000,1702125865, 795631981,
     *1650745632,1025519662, 908083566,1730816557, 824188960, 544434287,
     *1970037792,1734964837, 543236211,1635019123,1717658484,1869773088,
     *1684108385, 543387501,1886152052,1701733747,1931507297,1819632942,
     *        -3,        -2, 541280582, 541352308,1634623853,1696613477,
     *1718185577,1953066862,1933189152,        -3, 543122537,1717989998,
     *1601004897,1937076837,1683973746,1633907817,1869504372,1751479393,
     *1601003896, 975183904,        -3, 538976288,1181901155,1953066862,
     * 544171552,1970170225,1969561640,1937337709,1702130297, 761884260,
     *1701864814,1684369012, 689992293,1718379875,1953066862,1931504997,
     *1634956658,1701060719,1970544756,1864376352,        -3, 538976288,
     * 660563049,1717989998,1601332582,1819177823,1952998772,1633643873,
     *2015833632,        -3, 543122537,1717989998,1601004897,1937076837,
     *1683973746,1633907817,1869504372,1751479393,1600550252,1815748640,
     *        -3, 538976288,1181901155,1953066862, 544171552,1970170225,
     *1969561640,1937337709,1702130297, 761884260,1701864814,1684369012,
     * 689992293,1718379875,1953066862,1931504997,1634956658,1701060719,
     *1970544756,1864376352,        -3, 538976288, 660563049,1717989998,
     *1601332582,1819177823,1952998772,1633642101,1819027246,        -3,
     * 543122537,1717989998,1601332582,1819177823,1952998772,1633643873,
     *2017075232,        -3, 538976333,1635281261,1970086004,1751479393,
     * 543256167,1818566761,1847616613,1735550309,1931503215,1914729576,
     *1696623973,1634956658,1701060713,1853121902,1936290921,1702047264,
     *1416127776,1718772067,1953066862,        -3, 538976367,1713403246,
     *1769043301, 544367974,1818583924,1768910451, 544040289,1937076837/
     * )
      ICK(  3901:  4200) = (/
     *1679847285,1948284015, 544499817,1931501934,1735157024,1769152615,
     *1769366894, 543324448,        -3, 538976295,1600416102,1718775391,
     *1835360627,1970431332,1600549473,1668573551,1851749480,1702125919,
     *1835104295, 773857312,        -3, 543122537,1717989998,1601332582,
     *1819177823,1952998772,1633642101,1819032096,        -3, 538976288,
     *1416127776,1952998772,1629512046,1735157024, 677998112,1684367218,
     *1701147433, 543257632,2003331427,1746957416,1696623973,1634956658,
     *1701060722,1701211237,1668573551,1847616367,1970172960,1769152544,
     *        -3, 538976288,1668050803,1696625775, 543387501,1886152052,
     *1697521748,1751457894,1918985076,1768910368,1868963957,1852404085,
     *1696625253,1718379875,1953066862,1931504997,1634956658,1701060719,
     *1970544756,1864376352,        -3, 538976288,1952999795, 543256167,
     *1818566761,1931503465,1986358816,1652105255,1600416102,1718775391,
     *1835360627,1970431332,1600549473,1668573551,1851749480,1702125919,
     *1718971500, 657334304,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1970173299,1969319020,2032167017,1734877266,
     *1768846368,1986096245,1696604192,        -3,1596994096, 540028465,
     * 840970286, 825761840, 775042336, 857751840, 538980384, 824193056,
     * 807411744,        -3,1416127776,1449225333,1696624486, 542271854,
     *1948281203, 541553253,1635018098, 542402657,1847603246, 825368622,
     * 774778414, 774778414, 539248160,1382379631,1920213024,        -3,
     *        -2, 542402661, 544629100,1969561711,1713394281,1853104168,
     *1764648238, 539451236,1768318578,1851748965,1718382195,1600222815,
     *1381983601,1969845857,1818586740,1931946272,1936224117,1818501230,
     *1869770081,1819048224,1650794528, 543387502,1936286821,1918984812,
     *2032168037,1936924788,1751215648, 808333618, 543256164, 543780384,
     *1952998688,1869767781,1914728294, 544039271,1852404853,1684349039,
     *1713402984,1696625253,1886351988,1701060640,        -3, 542256502,
     *1634497893,1932402770,1768846368,1835104544,1650794610,1701601652,
     *1769366892,2032168293,1634625902,1735157107,1931507560,1701716066,
     *1634952548, 544173600,1629517413,1920540780,1768778100,1701060640,
     *        -3, 544109933,1650815520,1868963937,1986359905,1734698016,
     *1684108385, 773867625,1734894962, 544629100,1969582880,1936224117,
     *1818501218,1696620899,1668246896,1634625893,1679843961, 543236211,
     *1969845345,1651270944,        -3, 543520880,1818324577,1953066862,
     * 543780384,1952998688, 660566133,1651269491,1701016681,1869504357,
     *2020635756,1601332582,1768842605,1701737511, 544433507,1953066862,
     * 773867631,2003138149,1915494432,        -3, 543257972,1752134259,
     * 544434287,1970037792,1718186611,1948280174,1937076837, 544499809,
     *1948284008,1701995808,1634886944,1852797984,1870030194,1819242347,
     *1701060720,1919902316,1701671712,        -3, 543257459,1868786017,
     *1952801824,2003399784, 544499813, 543449460,1629515634, 544499813,
     * 544436321,1667575143,1919907184, 773866860,1702257012,1701060726,
     *1634497893,1931503215,1914708000,        -3, 539451236,1768318578,
     *1851748965,1718382195,1600222815,1381983601,1969845857,1818586740,
     *1931944045,1635328098,1696622958,1684628321,1953068645, 544171552,
     *1629515365,1701060724,1864397413,1668246636,1701016608,        -3,
     * 544499813, 543449460,1629513330,1869422689, 543388281,1937006956,
     * 544171552,1751738216,1701978225,1969319017,1954095215,1914729576,
     *1635000436,1751478885, 543781664,1629515890,1868721253,1830844265/
     * )
      ICK(  4201:  4500) = (/
     *1952981024,        -3, 544499813, 543449460,1629516914,1700885613,
     *1701737518, 541290350,1936286821,1914729576,1696622191,1819045751,
     *1768843040,        -3, 539517225, 542402661, 543253107,1869770868,
     *1768910368,1668248178,1701016681,1869509408,1634886944,1768841572,
     *1701934433,1952784495,1914726766,1634758770,1869640297,1635018030,
     *        -3, 539517481, 542402661, 544175717,1918987372, 544306529,
     *1818850425, 544171552,1952998688,1684108385, 544039289, 543319328,
     *1886351218, 543454565, 544501536,1952998688,1668446579,1952541728,
     *1903518060,1769240878,        -3, 539517737, 542402661, 543388281,
     *1937006956, 543781664,1986359929, 544695649,1802271008,1684629094,
     *1918985076,1768843052, 544436000,1952997748, 543236204,1634887525,
     * 544240239,1886351988,1768910368,1868963872,        -3, 538976288,
     * 543519603,1701737577,1634495609, 539129198,1868723045,1920361828,
     * 572551781,1718379875,1953066862,1931501938,1696621157,1768843040,
     *1970496868, 543780384,1952998688,1919247977,1852140901,1853107744,
     *        -3, 538976288, 542732149, 544434287,1970037792,1668247155,
     *1768187250, 544568169,1852252257, 543319412,1952805408,1668446579,
     *1952541728,1869750369, 543449460,1629512559,1819043171,1953066862,
     * 543257632,        -3, 538976288, 543977335, 544499053,1885696609,
     *1953854053, 543256164, 795832876, 543778336,1952998688,1668246896,
     *1869966948, 543781664,1869768545,1852400428, 544568169,1852252227,
     *1965060705,1684627828,1768910382,        -3, 539517993, 542732149,
     * 543257189, 544698226,1802071655, 543780384,1952998688,2003988334,
     *1730175858,2037609569,1814066041,1937007981, 544174624,1281455461,
     * 543650415,1970286112,        -3, 539518249, 542732149, 543711606,
     *1696624494,1819877473, 544630130,2032169837,1634495520,1853189474,
     *1701978223,1713399153,1969845857,1818586740, 544367974,1818583924,
     *1768910451, 740325224,1768122400,        -3, 538976288, 544039289,
     * 543974753,1679848559, 543257204,1768319331,1767992428,2032167017,
     *1734877302,1634497893,1931505510, 539451236,1768318578,1851748965,
     *1718382195,1600222815,1381983601,1969845857,1818586740,1931943968,
     *        -2, 542011252,1696625768,1635000425,1713383263,1684629094,
     *1919836018,1701211246,1935630710,1601399143,1835092271,1852142665,
     * 656435571, 543255667,1864395873,1919378732, 544499813, 544306529,
     *1818850425,        -3, 544171552,1952998688,1684108385, 544434287,
     *1970037792,1650794595,1869509481,1684370021,1679848559, 543319328,
     *1937077104,1701016622,        -3,        -1, 589315646,1042301800,
     *1701014304,1702391909,1668572516, 544109933,1650815520,1868963954,
     *1701211237,1668573551,1853038632,1298233376,1025519904,1130720884,
     *1919888416, 840969504,1852796461,1667591796,1919887648,        -3,
     *1596994097, 540028464, 824193070, 808788017, 808463904, 874529056,
     * 538980384, 824193056, 807411744,        -3,1382118505,1864389998,
     *1769043301, 539959365,2020631907,1952801824,1382377068,1701016681,
     *1869509408,1953460000,1214867304, 539897390, 539248160,        -3,
     *        -2, 542402661, 544109933,1650815520,1868963957,1852404085,
     *1696625253,1818583924,1768910451, 543781664,1952998688,1986096245,
     *1696625253,1886351988,1701060713,1847620712,1696613193,1176532841,
     *1952981108,1751457824,        -3, 543449460,1634623853,1696606047,
     *1919247980,1853054830,1970102885,1918858351,1952541735, 773870696,
     *1696621944,1885692788,1701060718,1970102885,1914728294, 544367974/
     * )
      ICK(  4501:  4800) = (/
     *1818583924,1768910451,        -3, 543387506,1919251312,1869505651,
     * 544501536,1952997748, 543780384,1952998688,1634957677,1835365490,
     *1768104053,1852404768,1868963956,1751457868,1635083552,1735552885,
     *1882071109,2020631907,1952801824,1918989417,1866080288, 543974771,
     *1932357490, 761622901,1634476081, 543584114, 543384942,1953656608,
     *1937337709,1702130281,1663071092,1920295796,1970431347, 543256164,
     * 543974771,1931506792,1634607154, 543584114,        -3, 544108398,
     * 761488750,1953656691,2037214565,1953655139, 544437362,1969452149,
     *1919251246,        -3, 542270817,1936682611, 544501536,1702388581,
     *1701060724,1752134501, 544109933,1650815603, 543383918, 543319354,
     *        -3, 538980640, 757093241,1937007981,1635019107, 543253107,
     *1701733225,1702043758,1869881455,1835627636,1701060710,1919905056,
     *1952998688,1868723045,1920361828, 543449460,1629512559,1970172974,
     *        -3, 538980896, 757092965,1718185573,1835363956, 544696692,
     *1746956901,1685417572,1634628640, 677981797, 773877359,1948282213,
     *1919378788, 796225129,1903519017, 543449460,1629516645,1949179936,
     *        -3, 538981152, 757093192,1162631244, 541608780,1176515872,
     *1382377065,1852140901,1853104160,        -3,        -1, 589315646,
     *1042301800,1701014304,1702391909,1668572516, 544109933,1650815520,
     *1868963954,1701211237,1668573551,1853038632,1668246896,1818588261,
     *1852142451, 689971232,        -3,1596994098, 540028464, 891301934,
     * 825237552, 774976800, 857751840, 538980384, 824193056, 807411744,
     *        -3,1382118505,1864389998,1769043301, 539959365,2020631907,
     *1952801824,1382377068,1701016681,1869509408, 678719343, 689982575,
     *1998597678, 539248160,        -3,        -2, 542401907,1948280431,
     *1914725473,1952522339,1869443180,1702126958,1702064942, 542402661,
     * 544366964,1768890479,1713402984,1696625253,1886351988,1701060718,
     *1970102885,1914728294, 544566889,1903519008,        -3, 544367974,
     *1818583924,1768910451, 543256164, 543520880,1701016677,1679847029,
     *1835165042, 544171552,1919247980,1701016681,1869509408,1718579744,
     *1952998688,1919251311,1819636841,1869488231,1769366894, 543781664,
     *        -3, 544367984,1869771877,1680744532,1751457906,1635019119,
     * 543383918, 543319328,1819244320,1685415200,1953439841, 544041331,
     *1936289383, 543389043,1881173862, 543449460,1629517672,1701716067,
     *1869376613,1668572516,        -3, 544696692,1746952480, 843328868,
     *1702126947,1953460782, 541158516,1701998177,1953068645,1819880480,
     *1952998688,2003988334,1730175347,2037214565,1953655139, 544235890,
     *1948282726, 544367971,1768977007,1667329056,        -3, 544436321,
     *1667571831,1634934883,1869376613,1668572516, 544173600,1629516645,
     *1919508844, 543450484,1701016687,1914729337,1937007981, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1416127860,
     *1630358881,2015371296,        -3,1596994099, 539897905, 807415344,
     * 842342448, 774911264, 857751840, 538980384, 824193056, 807411744,
     *        -3,1382380399,1819636841,1869488168,1953460009, 541880183,
     * 542864233,1848145000,1702125865, 793534829,1650745632,1008742446,
     * 912076334, 539248160,1097754413, 824188960,        -3,        -2,
     * 541288549,1667965042,1702063980,1970563439,1847619430, 544499813,
     * 543449460,1629516645,1949179988,1751741216,1634493810,1948281203,
     * 543781747,1969579040,2003330414, 544434542, 678717541,1952524591,
     *1818324322,1684086816, 540811312, 775299112,1764648238, 544499813/
     * )
      ICK(  4801:  5100) = (/
     *1952522300, 540161326, 842276964,1701278309,1696622191,1914719599,
     *1264656495,1914713655, 775364708,1701278309,1696622191,1914717045,
     *1264656498,1633970529,1953066862, 690888736, 541683232,1886546286,
     *1667854444,1697390689,1819025519,1651729778,1986356256,1684108385,
     * 544434287,1970037792,1650794601,1852009589,1684366368,1768824948,
     *1751457906,1701210478,1701668206,1949179936,        -3, 541158516,
     *1701998177,1953068645,1819880480,1629516649,1848145000,1702125865,
     * 793534829,1650745632,1668641903,1717969014,1634497893, 543383918,
     * 543319328,1970496868, 543257632,1629517409,1819632928,2003330418,
     *1696604192, 543258213,1918986085, 675884883,1768385889, 675883305,
     * 540811314, 543780384,1869767781,1914728047,1948284015, 544367974,
     *1768842528,1869488238,1869181797, 773857312,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1215129966, 774786157,
     *1635262496,        -3,1596994101, 539897904, 807415344, 808460338,
     * 774909984, 824197408, 538980640, 807415840, 807411744,        -3,
     *1215129966, 774786157,1635262532,1635016992,1231971183,1836084325,
     *1952784495,1914719593,1936943470,1730162222, 774778414, 774778414,
     * 538976288, 542141541,1634952480,1130915171,1797267488,        -3,
     *        -2, 541288549,1667965042,1701867378,1952801824,1747741484,
     *1814048032,1918987879,1696626537,1952981091,1634493301,1818326117,
     *1679848033,1852269856,1650553701,1679847278, 544367984,1869771877,
     *1679826976,        -3, 544499813,1952525677,1635266080,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1629517669,
     *1634410596,1635016992,1936028704,        -3,1596994102, 538976309,
     * 807411744, 909123616, 540487712, 857751840, 538980384, 824193056,
     * 807411744,        -3,1382118505,1864388450,1936028278,1701060655,
     * 542469737,1903519008,1382377068,1701016681,1869509408, 678719343,
     * 689982575,1998597678, 608773408,1130915171,1797267488,        -3,
     *        -2, 541288549,1667965047,1751479400,1701978209, 544437606,
     *1718182761,1701737504, 627470945,1668573551,1847619430, 544499813,
     * 544438637,1835365490,2032165238,1701994855,1701060725,1852404085,
     *1696604192,        -3, 544367974,1818583924,1768910368,1936028704,
     * 675094567,1601332582,1819177823,1853189474,1701994356,1869898092,
     * 657006697,1931503982,1684366692, 543253103,1986338932,1751457902,
     *1869181797, 543974774,1701584928,        -3, 539508000, 660566629,
     *1718382195,1601464434,1702062191,1818517349,2020635237,1936943471,
     *1848060192,1634934893,1700885365,1919247392,1652105332,1751457906,
     *1635019119, 975183904,        -3, 538976288, 538976305, 808460330,
     * 539502431,1919247980,1853054830,1970102885,1918857058,1936028278,
     *1701062432,1869750311,1601332582,1819177823,1853189474,1701994343,
     *1948723488,        -3, 538976288, 538976301, 757935405, 757935405,
     * 757935405, 757935405, 757935405, 757935405, 757935405, 757935405,
     * 757935405, 757935405, 757935405, 757935405, 757935405, 757935392,
     *        -3, 538976288, 538976288, 538976288, 538976288, 538978343,
     *1601332582,1819177823,1853189474,1701994356,1869898092, 657006624,
     *        -3,        -2, 541288549,1667965047,1751479400,1701978228,
     *1751741216,1819244320, 628253044,1768890473,1931502433,1970496868,
     * 543324448,2003132779, 543449460,1629512293,2037345892, 544499813,
     * 544367971,1869442405,1852073316,        -3, 544041326,1768781165,
     * 544434542, 678717541,1952524591,1818324322,1684086845, 540028469/
     * )
      ICK(  5101:  5400) = (/
     * 541159015, 707407153, 544367987,1869378932,1768910382, 541290350,
     *1936286821,1914729061,1836021345,1814063209,1734894962,        -3,
     * 544367987,1869378932,1768910368,1936221548,1819484258,1702457198,
     *1679831086, 891306350,1730816557, 824206962,1869422708,1751457906,
     *1701210478,1701668206,1948284776,1701716067,1818583410,1819877486,
     *1869181797, 773857312, 541139058,1635019119, 543319404,1870078000,
     * 775233641,1847615852,1814065765,1936682101,1953066862, 544434277,
     *1819046688, 677998112,1885434484,1768125804,1634869364,1751457900,
     *1870095731,1948262432,        -3, 544367987,1869378932,1768910368,
     *1936221548,1819486496,1835104544,1634497391, 544239465,1853104244,
     *1864396137,1936942436, 544502369,1853058145,1953066862, 544438637,
     *1835365490,2032169845,1667768417,1931485216,        -3, 544566889,
     *1948279653,1819025512,1634498153,1852255776,1399418217,1818325612,
     *2032934952,1835627379,1701062944,1953982830,1852403303, 544041319,
     *1752440946,1702065516,1948281198, 543236204,1870077989, 773870437,
     *1696604192, 544499813, 544367987,1869378932,1768910368,1936221548,
     *1814066036,1635019123,1953063795, 543780384,1399153524,1768910368,
     * 908095334, 544499813, 544629100,1768186228,1768910368, 657351531,
     *1713840230,1768711470,        -3,        -1, 589315646,1042301800,
     *1701014304,1600416102,1718775391,1919247980,1853054836,1751479393,
     *1600550252,1814044704,        -3,1596994103, 538979888, 908075054,
     * 808919072, 774912032, 857751840, 538980384, 824193056, 807411744,
     *        -3,1600416102,1718775391,1919247980,1853054836,1751479393,
     *1600550252,1814066785,1819632928, 678719343, 689982575,1998597678,
     * 774778414, 539248160,1147496306,1701126176,        -3,        -2,
     * 541680741,1634495609, 539517294,1679843616,1919250805,1769104749,
     *1701737504,1718579744,1886741100,1768120692,1768910368,1768824897,
     *1668571424,1131575667,1952541804,1869050465,1885890915,1630088224,
     *        -3, 544499813, 543449460,1634952564, 544434287,1970037792,
     *1650794597,1936942446,1953063276,1819877475,1869443180,1702126892,
     * 543257376,1684366953,1852138528,1652105248,        -3, 539451236,
     *1768318578,1851747685,1634956658,1701076838,1918985076,1768910431,
     *1952998772,1633642101,1819027232, 677604463,1936007284,1864380718,
     * 808004640,1970282612,1864376352,        -3, 544434542, 678717541,
     *1952524591,1818324322,1684086845, 540028470, 539519278,1697521714,
     * 892219956, 543450471,1919247731, 541945675,1630088736,        -3,
     * 542402661, 544499826,1701126253,1634365298, 543383925,1936028448,
     *1868963945,1852010349,1886152052,1696621665,1952522355,1702130464,
     *1634886970,        -3, 540090413, 541139053,1769173865,1852252259,
     *1970499616,1868963940,1635016992,1685415200,1953439844,1635016992,
     *1668246636,1701016681,1869488226,2032169583,1952543849,1869488225,
     *1919907182,1679826976,        -3, 538976288, 544499813, 544436329,
     *1852075109, 543258729,1931505518,1819877416,1937006958,1684107876,
     * 544173600,1936682341, 543780193,1734684016,1818326117, 544438643,
     *1952804211, 690888736,        -3, 538976288, 541291890,1698308195,
     *1869376613,1668554849,1847615844,1684632681,1869504876, 543449460,
     *1629516645,1948279142,1952805408,1919249775,1970173033,1852252276,
     *1751457891,1920562036,1634479648,        -3, 540155949, 542402661,
     * 541345102,1515135081,1835100005, 544240239,1667593075,1768843040,
     *1885430635,1634166048,1751216928,1886547810,1818586483, 544696692/
     * )
      ICK(  5401:  5700) = (/
     *1746953061,1920229737,1847620468,1919905383,        -3, 538976288,
     * 544367974,1818583924,1768910451, 773870696,1702436961,1919230063,
     *1718904174, 543520867,1819632741,1679844978,1869422708,1751457892,
     *1635016992,1936028718,        -3, 538976288, 541291890,1698308161,
     *1684283489,1847615844,1684632681,1869504876, 544432993,1847615860,
     * 543977335,1701978224,1870095730, 544433524,1953066599, 543780384,
     *1869767781,1914729583, 543780451,1819632741,        -3, 538976288,
     * 544437362,1869506336,1819244320,1869767781,1914729061,1718379875,
     *1953066862,1932402720,        -3, 540221485, 541683299,1869443180,
     *1702126880,1935892846,1932402720,        -3,        -1, 589315646,
     *1042301800,1701014304,1952998688,1919250543,1920230756, 543122537,
     *1717989998,1601004897,1937076837,1683973746,1633907817,1869504372,
     *1751479393,1601003896,        -3,1596994104, 539897909, 807415345,
     * 808460336, 774976800, 857751840, 538980384, 824193056, 807411744,
     *        -3,1600416102,1718775391,1835360627,1970431332,1600549473,
     *1668573551,1851749480,1702125919,1835104288,1449225333,1696615535,
     *1998597678, 539248160,1466464575,        -3,        -2, 541680741,
     *1634495609, 740324456,1696625253,1886351988,1701060647,1600416102,
     *1718775391,1835360627,1970431332,1600549473,1668573551,1851749480,
     *1702125919,1835104295, 544629100,1969564704,        -3, 543387506,
     *1919251312,1869505641,1852252276,1864397928,1702125869,1835104300,
     * 544434287,1970037792,1650794595,1819243365, 544501536, 825110574,
     *        -3,        -1, 589315646,1042301800,1701014304,1952998688,
     *1919250543,1920230756, 543122537,1717989998,1601004897,1937076837,
     *1683973746,1633907817,1869504372,1751479393,1600550252,1814044704,
     *        -3,1596994105, 539897906, 807415344, 875569198, 808857632,
     * 857751840, 538980384, 824193056, 807411744,        -3,1600416102,
     *1718775391,1835360627,1970431332,1600549473,1668573551,1851749480,
     *1702125919,1718971500, 544629100,1969561676,1870077998, 539248160,
     *1466464575,        -3,        -2, 541680741,1634495609, 539517294,
     *1679843616,1919250805,1769104749,1701737504,1718579744,1886741100,
     *1768120692,1768910368,1768824897,1668571424,1131575667,1952541804,
     *1869050465,1885890915,1630088224,        -3, 544499817,1931503218,
     *1633907817,1869488243,1752135020,1679843941, 543386735,1936007284,
     *1864380718, 807429743,1914729576,1702125869,1718971500, 543650405,
     *1635018098, 544174624,1701934433,1814044704,        -3, 544501536,
     *1936289320,1952998772,1630497889,1835164769, 689978656, 808334880,
     * 677981797, 773861941, 775042080,1684367218,1701147424,1718579744,
     *1299139425, 543256164, 540423982, 924869733,1735550309,1931485216,
     *        -3, 543584114, 541291851,1629495410,1633970529,1953066862,
     * 690888736,        -3, 542402661, 544499826,1701126253,1634365298,
     * 543383925,1936028448,1868963945,1852010349,1886152052,1696621665,
     *1952522355,1702130464,1634886970,        -3, 540090413, 541139053,
     *1769173865,1852252259,1970499616,1868963940,1635016992,1685415200,
     *1953439844,1635016992,1668246636,1701016681,1869488226,2032169583,
     *1952543849,1869488225,1919907182,1679826976,        -3, 538976288,
     * 544499813, 544436329,1852075109, 543258729,1931505518,1819877416,
     *1937006958,1684107876, 544173600,1936682341, 543780193,1734684016,
     *1818326117, 544438643,1952804211, 690888736,        -3, 538976288,
     * 541291890,1698308195,1869376613,1668554849,1847615844,1684632681/
     * )
      ICK(  5701:  6000) = (/
     *1869504876, 543449460,1629516645,1948279142,1952805408,1919249775,
     *1970173033,1852252276,1751457891,1920562036,1634479648,        -3,
     * 540155949, 542402661, 541345102,1515135081,1835100005, 544240239,
     *1667593075,1768843040,1885430635,1634166048,1751216928,1886547810,
     *1818586483, 544696692,1746953061,1920229737,1847620468,1919905383,
     *        -3, 538976288, 544367974,1818583924,1768910451, 773870696,
     *1702436961,1919230063,1718904174, 543520867,1819632741,1679844978,
     *1869422708,1751457892,1635016992,1936028718,        -3, 538976288,
     * 541291890,1698308161,1684283489,1847615844,1684632681,1869504876,
     * 544432993,1847615860, 543977335,1701978224,1870095730, 544433524,
     *1953066599, 543780384,1869767781,1914729583,        -3, 538976288,
     * 543780451,1819632741, 544437362,1869506336,1819244320,1869767781,
     *1914729061,1718379875,1953066862,1932402720,        -3, 540221485,
     * 541683299,1869443180,1702126880,1935892846,1932271728,1869837161,
     *1651276064,1650553701,1679847278, 543519346,1869505903,1970498681,
     * 543257459,1970103652, 543713639,1751478816,1952997742,        -3,
     * 538976288, 543253364,1969318944,1937337709,1702130297, 773857312,
     *        -3,        -2, 542011252,1698308180,1751457892,1701208437,
     *1819549814,1634497893, 544171552, 660563049,1717989998,1601004897,
     *1937076837,1683973746,1633907817,1869504372,1751479393,1600550252,
     *1814503540,1751217184,        -3, 543781664,1635087471,1835103337,
     *1667329132,2032165729,1818457452,1635018084, 543256164, 543780467,
     *1701999717,1679845742, 544499813, 541280582, 543324448,1397245260,
     *1481387321, 924872041,1734898720,        -3, 543647086,1701994868,
     *1696612653,1818588773,1814053196,1163023443, 544696421,1847620457,
     *1735289190,1768120686,1948282485,1835165042,1931505510, 544367974,
     *1818583924,1768910451, 543257189,        -3, 544041331,1936289383,
     * 543257632,1751738216,1701978228,1751479393, 544629100,1969582894,
     * 541683232,1869767781,1914729583, 543258223,1768169587,1969448992,
     *1634607169,1279611476, 740302880,        -3, 544437602,1937009012,
     *1970562336,1952998688,1986096245,1702043747,1634493301,1818326117,
     *1679849321,1952981108,1751457875,1212501080,1277192558,1937011317,
     *1668573551,1847600961,1129595168, 892348192,        -3, 543584114,
     * 539451236,1768318578,1851748965,1718382195,1601464421,1952538470,
     *1970039847, 543256164, 539451236,1768318578,1851747685,1634956658,
     *1701076838,1918985076,1768910431,1952998772,1633642101,1819027232,
     *        -3, 544367987,1885692788,1769366892,2033066054,1869750349,
     *1865249377,1684627828,1768910380, 543387506,1919251312,1869505641,
     *1852252278,1634497893,1931505510, 540161312,1684367205,1702043688,
     *1869750304,        -3, 543713639,1751478825, 543256164, 540028473,
     * 958408815,1914726505,1734894962, 689987954,1696621944,1885692788,
     *1701064224, 676554085, 542328901,1280855072,1835101813,1634478382,
     *        -3, 542133313,1414483488,1835104544,1650794613,1936024608,
     *1953439841,1851878521,1936007284,1751457891,1634952480,1635000424,
     *1634624544, 677542176,1768846959,1802071655, 543517044,1751478816,
     *1952998688,        -3, 539444803,1177376321,1279870017,1414090574,
     * 656436591,1684349039,1914729576,1696606017,1398361389,1447642455,
     * 656436591,1684351278,        -3,        -1, 589315646,1042301800,
     *1701014304,1600416102,1718775391,1919247980,1853054830,1970102885,
     *1914715709, 543126117,1718382195,1601074541,1650815583,1953461345/
     * )
      ICK(  6001:  6300) = (/
     *1814044704,        -3,1596994352, 538976288, 807411744, 540155936,
     * 538980896, 824197408, 538980384, 807415840, 807411744,        -3,
     *1600416102,1718775391,1919247980,1853054830,1970102885,1914708000,
     *1008738336,1601332582,1819177823,1853189474,1701994356,1869898092,
     * 538976288, 542141541,1634952480,1130915171,1797267488,        -3,
     *        -2, 542402661, 544109933,1650815520,1868963949,1700885365,
     *1919247392,1919247980,1701016681,1869509408,1936224117,1818501218,
     *1696621937,1969318944,1869750375,1919246708,1701978228,1751215648,
     *1952998688,        -3, 544109933,1650815520,1868963957,1852404085,
     *1696625253,1718379875,1953066862,1932402720,        -3,        -1,
     * 589315646,1042301800,1701014304,1852138852, 543584114, 543520884,
     *1768842100,1768910368,1668248178,1701016681,1869488240,1634885997,
     *1702126962,        -3,1596994353, 538980398, 857743408, 775168032,
     * 825110560, 874529056, 538980384, 824193056, 807411744,        -3,
     *1382377065,1852138528,1165522025,1852011625,1869488208,1634885997,
     *1702126962, 542599540,1751739936,1382116967,1696624486, 539897390,
     * 539248160,1399416685,1629495328,        -3,        -2, 542402665,
     *1931506789,1936990307,1751475051,1931507560,1702127717,1914724640,
     *1919247977,1852138528,1702392937,1852011625,1869488240,1634885997,
     *1702126962, 543781664,1835360622,1768843110,1970020384,        -3,
     * 543764069, 773879656,1702127717,1914726772,1931507297,1819632928,
     *1769152627,1768386153,1718182753,1853123705, 543973746,1734701600,
     *1952997742, 543782003, 543387506,1919251312,1869505641,1852252275,
     * 779431456,        -3, 541681184,1852797996, 544499817,1931505761,
     *1918987621,1952805408,1936224117,1818501218,1696625253,1836021349,
     *1679844978,1869422708,1751457901,1868850540, 543256164, 544499813,
     * 544437362,1969452149,1919229984,        -3, 544367974,1768842596,
     * 544696692,1752135028, 544499817,1931504997,1634625902,1735157107,
     *1931501924,1684632681,1869504876, 544235890,1634559348,1701981728,
     *        -3, 542402661, 543389042,1919250036, 543450470,1635085428,
     * 543648118,1702043745, 544694642,1852403303, 544696421,1847617908,
     *1931507297,1819632928,1769152631,1769236585,1847604014, 858988659,
     * 779431456,        -3, 542328901,1280855097, 925708832,2003397740,
     * 544108404, 543255660,1870078062,1701273972,1769366816,1986096245,
     *1702043756,1700881513,1852252276,1864395116,1814913903,1853252978,
     *1734700643,1696620910,1679826976,        -3, 544108398, 762996082,
     *1864396129,2020175221,1830843240,1768322095,1701999215,1914730081,
     *1819633011, 975204965,1836021349, 544499813, 543520884,1768842100,
     *1768910368,1885434465,1835365477,1914726002,1869422708,1751457824,
     * 544367974,1768842605,1701737518,        -3,        -1, 589315646,
     *1042301800,1701014304,1932424494, 541486177,1667965040,1634885997,
     *1702126962,        -3,1596994354, 538980398, 840970544, 774905905,
     * 808333344, 874529056, 538980384, 807415840, 807411744,        -3,
     *1400136750, 542469731,1701999713,1768846457, 544173600,1181507939,
     *1797279841,1918987621,1952805408,1449225333,1696614505,1734877230,
     * 539248160,1382379631,1920213024,        -3,        -2, 541288549,
     *1667965044,1751457910,1634494820,1769240864,1868963956,1751457889,
     *1651732332,1970562336,1937011317,1668576626,1696621669,1952805485,
     *1768841588,1768910382,        -3, 541139048,1768384544,1932424494,
     * 543780452,1768120692,1702043764,1751217184,1952998688,1702391909/
     * )
      ICK(  6301:  6600) = (/
     *1919511909,1853120876, 543449460,1629512815, 544108404, 544437616,
     *1886351988, 544499813,        -3, 543450484,1701997929,1851880553,
     *1869488239,1713402984,1696620898,1936682101,1952784499,1953658211,
     *1953854053, 773870696,1769152631,1768713248,1734700645,1918987372,
     *2032165477, 544499813, 543383923,1696604192,        -3, 544696692,
     *1746955369,1734898720,1635020653, 541945675,1629512801,1952522359,
     *1751478885, 543564320,1769152622,1700885100,2032171621,1919888928,
     *        -3, 542011252,1698308181,1936007284,1751457876,1464421920,
     * 639648321,1397104688, 774905961,1853060210,1969452137,1869509408,
     *1768824915,1212501080,1278818094, 542402661, 543450470,1635085428,
     *        -3, 541477953,1128996976,1634885997,1702126962, 543781664,
     *1852797984,1634498401,2037588082,1701603681,1651270956, 543780384,
     *1885434484,1768125804,1634869367,1751477792,1937011311,1852271737,
     *        -3, 543387506,1919249505,1952801824,2003399784, 544499813,
     * 544239475,1769236847,1847619430, 544499813, 544174697,1734962720,
     * 677719655, 773874028,1869506336,2032167278, 544436321,1667575143,
     *1919907184, 542126641, 690888736, 542141541,1634952480,1919247973,
     *1914729583, 541486177,1667968072, 776220192, 639648357,1919836530,
     *1684631141,1819044140, 541535776, 674314553, 958996545,1668571424,
     *1131575667,1949179969, 892677152,        -3, 540618808, 758722869,
     * 543256164, 539505200, 808462624,1244536897,1886415918, 541291129,
     *1936993836, 540226348, 540094772, 858599729, 876097056,        -3,
     *        -1, 589315646,1042301800,1701014304,1181507939,1797288033,
     *1918987621,1952805408,1986096245,1696604192,        -3,1596994355,
     * 538980398, 857747760, 774905905, 808333344, 874529056, 538980384,
     * 807415840, 807411744,        -3,1181507939,1797290016,1449225333,
     *1696613477,1986617716,1702043710, 540225072, 539631699,1768385889,
     * 543584879,1830836837,1919885358, 539248160,1315927141,        -3,
     *        -2, 541288549,1667965044,1751457906,1701602678,1634624357,
     * 796287340,1768188276,2032168806, 544499813, 543253107,1869378932,
     *1696625524,1920295796,1970431264,1684370533,1919773038,1635019119,
     *1848516688,1818583411,1696604192, 544367974,1701978228,1864386156,
     *1633905452,1210991662, 539369538,1701998177,1919183214,1701604457,
     * 740312878, 539504953, 960047392,1097036897, 541291129,1936993824,
     *1094006060, 540618808, 758722869, 543256164,        -3, 539505200,
     * 808462624,1244536897,1886415918, 541291129,1936993836, 540226348,
     * 540094772, 858599729, 876097056,1092646497,1819632928,1868963956,
     *1751457862,1818321771, 544235890,1634559348,1701978228,1751217184,
     *        -3, 543450486,1767994469,1931506537,1735289190,1768120686,
     *1953265952,1718775661, 544892274,1864376360,1952541545,1852252265,
     *1853124384,1633903471,1970172960,1952998688,1634956143,1667850612,
     *1701060723, 779431465,        -3, 544041319,1752440937,1852074339,
     *1635018016,1952997748, 544499813, 543253107,1869378932,1696625524,
     *1920295796,1970431264,1936224117,1818501218,1696622958,1986359924,
     *1701060713,1847616353,1936007279,1713398048,        -3, 544629100,
     *1969561699,1819243365,1914729583, 540094000, 544499809,1847620719,
     * 544892274,1865293889, 544629100,1969561699,1819243365, 544501536,
     * 808334624,1835104544,1650794601,1852074339,1635019126,1696624486,
     *        -3, 543256096,1768846949,1920166255,1847620727,1768824943,
     *1914724640,1835627379,1701060707,1701737586,1696624486, 543780470/
     * )
      ICK(  6601:  6900) = (/
     *1701999465,1869491744,1181708832,1986096233,1679843682,1936682101,
     *1952784416,        -3, 544437362,1969452149,1919230049,1936943463,
     *1852663150,1953704992,1633841960,2015961203,1752135020,1679843941,
     * 543974771,1931506792,1634607154, 539631731, 779431468, 544696692,
     *1746957102,1965957180, 540028464, 875438112, 541486962, 543518305,
     *1853122927,1886745189, 543387501,1886352750,1685269536,1932424494,
     * 544434287,1970037792,1650794604,1702064928,1952997742, 540028465,
     * 773857312,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1181507939,1797288033,1918987621,1952805408,1986096245,
     *1696625520,1701013862,1768252448,1514034025, 740322927,1848468325,
     *1853125231,        -3,1596994356, 538976288, 807411744, 540155936,
     * 538980896, 824197408, 538980384, 807415840, 807411744,        -3,
     *1315905606,1818321771, 542138738,1634559348,1701978183,1769366894,
     * 773872160,1042305897, 740314735,1849910638,1953656608, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542011168,1181507939,1797288033,1918987621,1952805408,1986096245,
     *1696622441,1986358816,1718579744,1852796461,1667591796,1919906681,
     *1835885940,1919509280,1937011317,1668576626,1696626537,1952981024,
     *        -3, 543712609,1986618739,1948279156,1869422682, 540942419,
     *1764630612,1751741216,1835624296,1948279397, 543780468,1701737577,
     *1869504876, 773857312,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1600350309,1835623265,1818190178,1936682101,
     *1952800611,1869506153,1735750241,1953066862,        -3,1596994357,
     * 538976288, 807411744, 540024864, 538980896, 824197408, 538980640,
     * 807415840, 807411744,        -3,1600350309,1835623265,1818190178,
     *1936682101,1952800611,1869506153,1735750241,1953066862, 541683302,
     *1864376398,1869881415,1769366894, 538976288, 542141541,1634952480,
     *1148133409,        -3,        -2, 542077044,1768910451, 543257189,
     * 539456109, 657203239,1633953580, 539456109,1633953580, 539456377,
     *1848060960, 662007403, 656437106, 539438631,        -3,        -2,
     * 544369952, 538982944,1633842031,1819636837, 543387502,1718183797,
     *1918989417,1869488229,1937006946,1818850152,1701060706,2032170088,
     *1696625524,1920295796,1970431264,1684370533,1919773038,1635019119,
     *1847599136,        -3, 538976288, 538976288,1868963937, 543387501,
     *1886352750,1679844207,1853120873,1852403303, 543236195,1751741025,
     *1814065765,1717924453,1852007712,1836018789,1668639845, 544171552,
     *1802399607,1847599136,        -3, 538976288, 538976288,1633842031,
     *1819636837, 543387502,1718183797,1918989417,1869491744,        -3,
     * 543253536, 538982944,1633842031,1819636837, 543387502,1718183797,
     *1918989417,1869488229,1937006946,1818850152,1701060706,2032165230,
     *1869439340,1869968160,1684632432,1701999465,1869488229,1717986659,
     *1953701920,        -3, 538976288, 538976288,1768824932,1768318578,
     *1633907817,1869488237,1700885365,1919249765,1853125408,1869488244,
     *1751457891,1920562036,1634479648,        -3, 544370017,1679833632,
     *1633842031,1819636837, 543387502,1718183797,1918989417,1869488229,
     *1937006946,1818850152,1701060706,2032170088,1696625524,1920295796,
     *1970431264,1684370533,1919773038,1635019119,1847599136,        -3,
     * 538976288, 538976288,1868963937, 543387501,1886352750,1679844207,
     *1853120873,1852403303, 543236195,1751741025,1814065765,1717924453,
     *1852007712,1836018789,1668639845, 544171552,1802399607,1847599136/
     * )
      ICK(  6901:  7200) = (/
     *        -3, 538976288, 538976288,1633842031,1819636837, 543387502,
     *1718183797,1918989417,1869488225,1852055651,1869506153,1919772004,
     * 543324448,1634627437,1634496373,1931502697,1936745842,1936289646,
     *        -3, 538976288, 538976288,1701209701,1668576032,1768824932,
     *1768318578,1633907817,1869488237,1700885365,1919249765,1853125408,
     *1869488244,1751457891,1920562036,1634479648,        -3, 544438638,
     * 538982944,1633842031,1819636837, 543387502,1718183797,1918989417,
     *1869488232,1634934894,1869881442,1701146144,1702065249,1651272051,
     *1751475232,1652105313,1852796257,1819243891,        -3, 538976288,
     * 538976288,1684632432,1701999465,1869488229,1717986659,1953701993,
     *1847616617,1717989985,1668573551,1847618917,1634956658,1701668206,
     *1953701999,1847620712,1696621426,2037609569,1814962208,        -3,
     * 538976288, 538976288,1416127776,1701732718,1953066861,1701978216,
     *1634934882,1701146144,1634956137,1735288164, 543324448,1919247973,
     *1919250019,1696625775, 543256096,1970168680,1634625385,1852252192,
     *        -3, 538976288, 538976288,1667787122,1634476131,1701737586,
     *1696622958, 544499813, 544438638,1952998772,1768104048,1919902565,
     *1685418597, 773857312,        -3, 544566891, 538982944,1633842031,
     *1819636837, 543387502,1718183797,1918989417,1869488233,1931507054,
     *1802399607,1848385652,1751478885, 543319401,1852252270,1864394345,
     *1919754339,1751477609,1667329056,        -3, 538976288, 538976288,
     *1702259044,1701733221, 543584114, 543782003, 543257459,1768386157,
     *1701737504,1953439848,1634624544,1634624544,1769218152,1635150190,
     *1730178671,1948279397,1701716000,        -3, 538976288, 538976288,
     *1702065249,1651272051,1751475232,1652105313,1852796257,1819243891,
     * 543451507,1885696627,1768910368,1701209701,1668576032,1768824932,
     *1768318578,1633907817,1869488160,        -3, 538976288, 538976288,
     *1835360627,1970431341,1701737587, 544173600,1952998688,1668446579,
     *1952541742, 541158944,1634886249,1953653106,2032165736,1869177701,
     * 544171552,1701732718,1953066861,1701978144,        -3, 538976288,
     * 538976288,1751216928,1650812270, 544039268,1697521696,        -3,
     * 539893792, 538982944,1768841584,1886153059,1633840229, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1835627379,1768843040,1181507939,1797288033,1918987621,1952805408,
     *1932424494,        -3,1596994358, 538980398, 891297842, 774905888,
     * 841887776, 824197408, 538980640, 807415840, 807411744,        -3,
     *1315905651, 779431456,1198093925,1847617135,1914717804,1633905440,
     *1348563553,1835365477,1914711598, 774778414, 774778414, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542011168,1937006958,1684107876, 544566883,1701999713,1768846457,
     * 543584117,1852055654,1869750388,1751457862,1818321771, 544235890,
     *1634559348,1701981728,1466459502, 544499813, 544437362,1969452149,
     *1919229984,        -3, 544367974,1768842605,1701737504,2002875168,
     *1685024357, 544696692,1746948936,1162631244, 959917362, 740324456,
     *1696623721,1801809017, 544367969,1936682528,1718579744,1952999795,
     * 543781664,1629515113,1936943470,1730158624, 541213011,1176529262,
     *1937011317,1668573551,1848516692,1751741216,1634758764,1768256288,
     *1768824944,1634890857,1668639841,1914730344,1701716084,1751457889,
     *1936944995,1767994469,1679836780,1633905440,        -3, 544235890,
     *1634559348,1701978216,1634934900,1751457910,1634497893, 540028464/
     * )
      ICK(  7201:  7500) = (/
     * 808463904,1315905654,1634494820, 543387502,1668052339,1768910451,
     * 544173600,1952998688,1633842031,1819636837, 544437362,1969452149,
     *1919229984, 543383918, 543319328,1685217655,1847617902, 544499809,
     *1948279649,1936010784,        -3,        -1, 589315646,1042301800,
     *1701014304,1600416102,1718775391,1919247980,1853054836,1751479393,
     *1600550252,1814044704,        -3,1596994359, 538976288, 807411744,
     * 540024864, 538980384, 824199456, 538980640, 807415840, 807411744,
     *        -3,1600416102,1718775391,1919247980,1853054836,1751479393,
     *1600550252,1814048302, 774778414, 774778414, 774774862,1869881415,
     *1769366894, 538976288, 542141541,1634952480,1148133409,        -3,
     *        -2, 542011168,1768842863,1919770996,1768910368,1769152615,
     *1769366894, 543253103,1970544756,1751457908,1751479393, 544629100,
     *1969561702,1869750391,1751737192, 544499813, 543449460,1634952564,
     * 543781664,        -3, 543387501,1886152052,1697390707,1969384037,
     *1668554868,1864397928,1696624741,1919116654,1952540517, 543648118,
     *1701716087,1769236512,1952998688,1684108385,1851878757,        -3,
     * 539451236,1768318578,1851747685,1634956658,1701076838,1918985076,
     *1768910431,1952998772,1633642101,1819027246,        -3,        -1,
     * 589315646,1042301800,1701014304,1600416102,1718775391,1835360627,
     *1970431332,1600549473,1668573551,1851749480,1702125919,1835104288,
     *        -3,1596994360, 538976288, 807411744, 540024864, 538980384,
     * 824199456, 538980640, 807415840, 807411744,        -3,1600416102,
     *1718775391,1835360627,1970431332,1600549473,1668573551,1851749480,
     *1702125919,1835104288, 542011252, 541550966,1701716014, 538976288,
     * 542141541,1634952480,1148133409,        -3,        -2, 542402665,
     *1931503218,1633907817,1869488243,1752135020,1679843941, 544436325,
     *1667851881,1701060713,1847616367,1835166062,1635019119,1847621481,
     *1952981108,1751457908,1751479393, 544629100,1969561703,1769366894,
     *        -3, 544696692,1746957416,1696621665,1952542305,1835343911,
     *1600416102,1718775391,1919247980,1853054836,1751479393,1600550252,
     *1814507040,        -3,        -1, 589315646,1042301800,1701014304,
     *1600416102,1718775391,1835360627,1970431332,1600549473,1668573551,
     *1851749480,1702125919,1718971500,        -3,1596994361, 538976288,
     * 807411744, 540024864, 538980384, 824199456, 538980640, 807415840,
     * 807411744,        -3,1600416102,1718775391,1835360627,1970431332,
     *1600549473,1668573551,1851749480,1702125919,1718971500, 542011252,
     * 541550966,1701716014, 538976288, 542141541,1634952480,1148133409,
     *        -3,        -2, 542402665,1931503218,1633907817,1869488243,
     *1752135020,1679843941, 544436325,1667851881,1701060713,1847616367,
     *1835166062,1635019119,1847621481,1952981108,1751457910,1634497893,
     * 543584114,        -3, 539451236,1768318578,1851748965,1718382195,
     *1601464421,1952538477,1635264302,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750344, 761361519,1836261467, 808202589,
     *        -3,1596994608, 538980398, 807418169, 774905913, 959328288,
     * 824197408, 538980384, 807416096, 807411744,        -3,1315905608,
     * 761361519,1836261481,1847620712,1769152579,1634886255,1847608175,
     *1853120873,1852403303, 541290349,1886352750,1679830574, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 541158501,1920213094,1869750311,1852776520, 761361519,1836263200,
     *1768824899,1229336096,1416128883, 543781664,1970173299,1969318944/
     * )
      ICK(  7501:  7800) = (/
     *1718579744,1667330658,1869488227,1869509729,1768843630,1730158624,
     *        -3, 543387501,1886352750,1685269536,1651864608,1835104544,
     *1650794595,1869771365,1668558368,        -3,        -1, 589315646,
     *1042306149,1936990323,1970085990,1869770101,1818304544,        -3,
     *1596994609, 538980398, 807418169, 774905913, 959328288, 824197408,
     * 538980384, 807415840, 824188960,        -3,1130458211, 773874030,
     *1679839845,1886351988,1701060691,1970095727,1919776108,1629495328,
     * 542340210,1768843123, 538985577,1717986674, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 541683232,
     *1952998688,1768187233,1814061921,1936010272,1651471464, 542340461,
     *1181708909,1970037024,1937011305,1852273440, 678585712,1869771877,
     *1679843694,1679844193,1818457452,1635018084, 689992552,1869966436,
     *        -3, 543319328,1768187246,1953063777,1814962249,1713401455,
     *1949048948,1751457906,1700885359,1847617135,1914729576,1696621673,
     *1717986674,1701733221, 544434287,1970037792,1650794595,1818583410,
     * 773866872,1634562156,1702043680, 543257189, 543383923,1702043767,
     *1751478885, 544239472,1970037108,1768910451, 543452960,1852797984,
     *1633969184,1970282612,1864395118,1952802661,1914728053,1835165042,
     *1932271727,1914730344,1701716083,1869379173,1853104160, 544042860,
     *1701016940,1702043752,1635149088,1650812270, 542331221,1162172997,
     *1143873568,        -3, 542011252,1698308179,1212501080,1278818080,
     *1919250543,1920234272,1886351477,1818326121,1869488240,1634885997,
     *1702126962,1931503982, 544499813, 541280582, 544696692,1746957431,
     *1864393829,1667853665,1819484192,        -3, 544173676,2033066068,
     *1751741216,1835104544,1818583396, 544501536,1852796461,1768846437,
     *1734701600,1635020653, 543387509,1853125408,1768824931,1634952563,
     * 544171552,1684632431,1919182194,        -3, 543454565, 544501536,
     *1919907182,1684631143, 773857312,        -3, 542011252,1698308161,
     *1818587764,1931501360, 875637792,1596994610, 539369567, 808727840,
     *1667329568,1886547810,1633840249, 543319328,1768386159,1919247392,
     *2003330414, 544499813, 544367980,1702257006,1948262432,        -3,
     * 544629100,1969582880,1684629094,1701978210,2032170088,1696625505,
     *1835343974,1633907823,1915625504,        -3,        -1, 589315646,
     *1042306149,1936990317,1869178228,2032166511,1919776108,1629495328,
     *        -3,1596994610, 538980398, 807418169, 774905913, 959328288,
     * 824199456, 538980384, 807415840, 824188960,        -3,1130458211,
     * 773874030,1679839845,1886351988,1701060685,1869178228,2034659186,
     *1836412001, 542340210,1768843123, 538985577,1717986674, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 541683232,1952998688,1768187233,1814061921,1936010272,1952998688,
     *1299147109,1954104943,1919776108,1629516660,1919512167, 543257376,
     *1919250543,1920230756, 544434287,1970037792,1650794601,1684369012,
     *1768120684,        -3, 544501536,1952998688,1299147109,1954104943,
     *1919776108,1629516660,1919512167, 543383916,1668639841,1952801824,
     *1718775661, 544499813, 543449460,1629514094, 544499813, 541280582,
     * 773867878, 544108404, 740324456,1696604192, 544367969,1936682528,
     *1936224117,1818501218,1696621420,1700885038, 541423713,1836084325,
     *1931501938,1696621409,1936028448,2003330418,1696625768,1701995808,
     *1769152622,1864397669,1885434465,1953066599, 544436321,1667571744,
     * 543319412,2003133806, 544503663, 543517797,1835363956, 544104813/
     * )
      ICK(  7801:  8100) = (/
     *1702043759,1914725217,1936028448,2003330418,1696624751,1886743649,
     *1953066862,1931502703, 544108404, 543253604, 544567328,1953439776,
     *        -3, 543780468,1701274994, 544109933,1650815603, 544174624,
     *2003330414, 544042857,1702127973,1931501938,1696625509,1885434465,
     *1952801824,1652105255, 774316137,1853060197,1633951855,1713383212,
     * 657334304,        -3,        -2, 541423713,1836084325, 975195727,
     * 857764712,1869966436, 543319328,1734964837,1847615859, 541990991,
     * 857743392,        -3,        -2, 542011252,1698308161,1818587764,
     *1931501360, 875637792,1596994610, 539369567, 808727840,1667329568,
     *1886547810,1633840249, 543319328,1768386159,1919247392,2003330414,
     * 544499813, 544367980,1702257006,1948262432,        -3, 544629100,
     *1969582880,1684629094,1701978210,2032170088,1696625505,1835343974,
     *1633907823,1915625504,        -3,        -1, 590429758,1042306149,
     *1936990310,1869750381,1869374819,1970037106, 544695657,1734898720,
     *        -3,1596994611, 538980398, 824188977, 774905905, 808333344,
     * 824197408, 538980384, 807415840, 824188960,        -3,1130458211,
     *1970037108,1701060705,1852055634,1701867378,1952801824,1299147822,
     * 542598505,1734898720,1147758182,1701978210,2032152110, 539248160,
     *1130915171,1797267488,        -3,        -2, 542011252,1698308193,
     *1953459561,1663072101,1768384628,1931507059,1701060713,1847620712,
     *1696621409,1818457452,1635019119,1847619430, 544499813, 544042860,
     *1701016940,1634869367,1701406568,1948279154,1696604192,        -3,
     * 544498027,1701716070,1919905056,1231974258,1731076163,1751739694,
     * 541156212,1629499953, 924854321, 960050217, 540160311, 758264120,
     * 544696425,1667768420,1702259041,1952784489,1847615776,1717925664,
     *1667330917,1931485216, 544435305,1734898796,2032166514,1869422708,
     *1751457903,1818518898, 544629100,1969582880,1970496868, 543780384,
     *1397245260,1481390391, 758263328,        -3, 542011252,1698308180,
     *1751457908,1633842540,1635018084, 543257711,1835623200,2003134823,
     *1752462112,1952997748, 543257189, 544568165,1679846753,2032165989,
     *1986617716,1696622194,1869422708,1751457889,1668576609,1814044704,
     * 544629100,1969561705,1847616353,1936007279,1713402736,1701013857,
     *1814063475,1869901680,1702043759,1713399086,1731076181,1918987881,
     *1970085999,1914720364,1970564974,1769303342,        -3,        -1,
     * 590429758,1042301800,1701014304,1919250543,1920230756, 543254369,
     *1768846196, 543383916,1668639841,1952801824,1684369011,1769240864,
     *        -3,1596994612, 538980654, 807411765, 774905905, 808333344,
     * 824197408, 538980384, 807415840, 824188960,        -3,1130458211,
     *1970037108,1701060705,1852055634,1701867378,1952801824,1147498099,
     *1769240864,1148723232,1147758182,1701978210,2032152110, 539248160,
     *1130915171,1797267488,        -3,        -2, 541683232,1952998688,
     *1768187233,1814061921,1936010272,1651471464, 543449460,1629514100,
     *1701671712,1936224117,1818501218,1696625768,1696625505,1835343991,
     *1769236585,1847615776,1936548204,1814044704,        -3, 544501612,
     *1701994862,1667575328,1231429742,1869884448,1952998688,1919246707,
     *1869488243,1752135020,1679843941, 543386725,1634872864,1130915171,
     *1797284204,1936662647,1751479400,1701978228,1751457824,        -3,
     * 543450478,1936290937, 544629100,1969561705,1931506277,1886351988,
     *1701060713,1847620712,1696613193,1177428000,        -3,        -1,
     * 590429758,1042301800,1701014304,1919250543,1920230756, 543256164/
     * )
      ICK(  8101:  8400) = (/
     * 543383916,1668639841,1952801824,1512054816,        -3,1596994613,
     * 538980398, 807411760, 774905888, 808333344, 824197408, 538980384,
     * 807415840, 824188960,        -3,1130458211,1970037108,1701060705,
     *1852055634,1701867378,1952801824,1512064105,1717986674, 543324448,
     *1629505121,1668575090, 539897390, 538977345, 541288549,1667964960,
     *        -3,        -2, 541683232,1952998688,1768187233,1814061921,
     *1936010272,1952998688,1986096245,1702043759,1713398383,1952981092,
     *1635016992,1769235821,1931487322, 677601644,1663639590, 542779506,
     *1701867378,1952801833, 689987954,1696604192, 543520880,1701016677,
     *1679848559, 543319328,1952998688,1935764837, 773867878, 544108404,
     * 740324456,1696625253,1634955118, 543584114, 544499809,1948279913,
     *1717986674,1701733221, 544434287,1970037792,1650794528,        -3,
     * 543386725,1634872864,1097736293,2019650928,1818566761,1931506792,
     *1696625513,1953849716,1768910368,2003330418,1696616524,1096044366,
     * 543648118,1702043738, 540876849, 544696421,1847620712,1696624754,
     *1869050465,1830821920, 543383918,1852797984,2003792491, 544175476,
     * 543236208,1919905893,1914722862,        -3, 542011252,1698308161,
     *1818587764,1931501360, 875637792,1596994610, 539369567, 808727840,
     *1667329568,1886547810,1633840249, 543319328,1768386159,1919247392,
     *2003330414, 544499813, 544367980,1702257006,1948262432,        -3,
     * 544629100,1969582880,1684629094,1701978210,2032170088,1696625505,
     *1835343974,1633907823,1915625504,        -3,        -1, 590429758,
     *1042301800,1701014304,1919250543,1920230756, 543450478,1936290937,
     * 544696692,1746953057,1818457452,1635018084, 543450478,1936290937,
     * 543584879,1830836768, 706760023,        -3,1596994614, 538980654,
     * 807411765, 774905905, 808333344, 824197408, 538980384, 807415840,
     * 824188960,        -3,1382379631,1920230756, 542780448,1297555553,
     *1852055620, 677601644,1663639649,1919230025,1852010350,1936290676,
     *1701737504, 774778414, 539248160,1130915171,1797267488,        -3,
     *        -2, 541337699,1634493225, 543257376,1667329123,1970037108,
     *1701060710,1919905056,1952998688,1919250543,1920230756, 542777441,
     *1852055629,1461741939, 543387501,1885434469,1679844975,1914725231,
     *1853057395,1952804451,2032148512, 544696692,1746957416,1696625253,
     *1886351988,1701060708, 677601644,1663643168,        -3,        -1,
     * 590429758,1042306149,1936990323,1970085990,1869770101,1818304615,
     *1769366894,        -3,1596994615, 538980398, 807411760, 774905888,
     * 808333344, 824197408, 538980640, 807415840, 807411744,        -3,
     *1400204614,1869770101,1818304590,1869881415,1769366894, 539897390,
     * 774778414, 774778414, 774778414, 774778414, 774778414, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542402661, 542340461,1718579821,1970037036, 543387506,1919251312,
     *1869505641,1852252279,1769236512,1952998688,1299147109,1954113135,
     *1919776108,1630281843,1752135020,1679843941, 543648118,1701719584,
     *        -3,        -1, 590429758,1042306149,1936990317,1869178228,
     *2032166511,1919776108,1629513577,1986358816,        -3,1596994616,
     * 538980398, 807418169, 774905913, 959328288, 824199456, 538980640,
     * 807415840, 807411744,        -3,1299147109,1954104943,1919776108,
     *1629507183,1948272489,1986358816, 678392352,1231971183,1836084325,
     *1952786720, 774778414, 774778414, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542402661, 541945705/
     * )
      ICK(  8401:  8700) = (/
     *1702132000,1718579821,1970037024, 677981797, 773878888,1696625520,
     *1701013862,1768120692,1768910368,1868963956,1751457910,1634888047,
     *1970479219,1885692777,1702043753,1847620712,1696604192,        -3,
     * 544437362,1969452149,1919232288,1936224117,1818501218,1696622441,
     *1986358816,1768824948,1751457859,1229336096,        -3,        -2,
     * 541423713,1836084325, 975185704,1130635314, 724120364, 539509558,
     * 541996611,1914712877, 691153952, 841500722, 542058791,        -3,
     *        -1, 589315646,1042301800,1701014304,1667329123,1970037108,
     *1701060708,1701737321,1954095166, 540094000,        -3,1596994617,
     * 538980398, 807411760, 774905888, 825110560, 824197408, 538980384,
     * 807415840, 824188960,        -3,1130458211,1970037108,1701060676,
     *1701737321,1954095180,1702064928,1416126830, 540094000, 543646573,
     * 758325294, 774778414, 774778414, 539248160,1130915171,1797267488,
     *        -3,        -2, 542402661, 543383916,1668639841,1952801824,
     *1684369011,1769240864,2003397740, 544696692,1746952480,1717925664,
     *1702388581,1886677359,1853038690,1696623713,1919378802, 544499809,
     *1847603502, 808329248,        -3, 541139059,1835101292,1701978230,
     *1634497893, 544039289, 543780452,1768120692,1696621929,1952998770,
     * 543256096,1768842095,1836084325,1952784493,1868850540, 544174624,
     *1768842095,1920099683,1948262432,        -3, 544438637,1835365490,
     *2033066024,1697539886, 543236205,1769173865,1852252199,1650553383,
     * 543780384,1345138976,1702126382, 689971232,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750381,1965057897,1986358816,
     *1529883697,1562386464,        -3,1596994864, 538980398, 807411760,
     * 774905888, 808333344, 824197408, 538980640, 807415840, 807411744,
     *        -3,1096971119,1919972457,1869488195,1868916326,1768122725,
     *1853104237,1965051503,1948272489,1986358816, 774778414, 774778414,
     * 774778414, 538976288, 542141541,1634952480,1148133409,        -3,
     *        -2, 542402661, 543975790,1700885024,1633842031,1919972457,
     *1869488227,1868916326,1768122725,1853104227,1869771365,1936748398,
     *1684631143, 544501536,1952998688,1400204646,1869770101,1818304627,
     *1752135020,1679843941,        -3, 543648118,1701719584,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750372,1768318565,
     *1919250019,1696623989, 677603686, 689993577,1952981101,1965581153,
     *1818437920,1529175328,        -3,1596994865, 538976288, 824188960,
     * 540352544, 540094496, 824197408, 538980384, 807415840, 824188960,
     *        -3,1299523683,1634493225, 543256164, 541947176,1667851817,
     * 542269812,1768890436,1768318565,1920147558,1919905056, 825110560,
     *1652105262, 539248160, 622862368,        -3,        -2, 541683232,
     *1952998688,1768187233,1814061921,1936010272,1651471464, 541947176,
     *1667329123, 689987950,1679838581, 677603686, 689993313,1819633011,
     * 544434287,1970037792,1650794612,1751457907,1634559264,2003399784,
     *1768824864, 543236211,1835101292, 544501612,1701994862,1667575328,
     *1231429742,1869884448,1952998688,1919246707,1869488230,1869750388,
     *1751457892,1768318565,1919250019,1696625512,1869966436, 543319328,
     *1668048225,1915625504,        -3, 542133313,1414483503,1667786083,
     *1799571782, 543383916,1668639841,1952805664,1299523683,1634493225,
     * 543318387,1701060719,1847618933, 793929839, 544629100,1969582880,
     *1952539253,1818326117,1679845742, 544499813,        -3, 541683316,
     * 773870689,1651271027, 543584114, 544694646,1701602670,1735682163/
     * )
      ICK(  8701:  9000) = (/
     * 541291816,1264658732, 541945640,1264658720,1634624544,1097279563,
     *1630088736,1181708832,1869899877,1914730337,1986358373,1852273768,
     *1932271648, 544437603,1746952563, 544499823,1936007270,1869750355,
     *2037277544,1919906930,1869491232,1197549643,1630085217,1852055625,
     *1848134497, 689992559,1970430821,1932271732,1752134501, 544629100,
     *1969582880,1634886944,        -3, 543383916,1668639841,1952801824,
     *1718578284,1870096750,1730171694, 541225573,1852727662, 539369552,
     * 776744480,1131378529,1847601201, 960049705, 773870181,1982734419,
     *1667837472,1231975284,1915628576, 909323296,        -3, 540554544,
     * 758658355, 773870696,1869833504,1986096245,1702043757,1635328100,
     *1768318565,1914729324,1768384628,1819877478,1919905056,1986096245,
     *1702043747,1634493301,1818326117,1679849321,1952981024,        -3,
     * 543255668,1701998177,1953068645, 543520884,1701998177,1814066287,
     *1869378348, 543780384,1885434484,1768125804,1634869350,1869750391,
     *1635149164,1701734260,1752375406,1700885024,1633842031,1919972457,
     *1869488160,        -3, 543515751,1702047264,1416127776,1836396370,
     *1752113270,1634497893,1931507059,1701060706,2032160844,1096044366,
     * 795043941,1667973961,1176528495,1914728308,1751478816,2002876005,
     *1818586727,1953002272,1667329568,1650794528, 543975795,1952801824,
     *2003399784, 544499813, 542133313,1414483488,1768846196,1920295796,
     *1768910368, 658591311,1293973345,1986358373,1852273768, 657334304,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1885692777,1718182753,1953066862, 543253107,1869770868,1768910368,
     *1668248178,1701016681,1869488237,1702127727,1679842096, 741432608,
     *        -3,1596994866, 538980398, 807418169, 774905913, 959328288,
     * 824197408, 538980640, 807415840, 807411744,        -3,1231971951,
     * 544173600,1096971119,1919972457,1869488195,1869771365,1668573551,
     *1847610725,1953001316, 538976334,1869881415,1769366894, 538976288,
     * 542141541,1634952480,1148133409,        -3,        -2, 542402661,
     * 544502373,1635020133,1853108077,1702127727,1679847270, 543253107,
     *1869770868,1768910376,1668248178,1701016681,1869490464,1936224117,
     *1818501218,1696622441,1986358816,1702391916,1768122740,1819880992,
     *        -3, 542336372, 539451237,2020635756,1600217715,1869770868,
     *1600352114,1919247220,1768910431,1954115685, 656438383, 539455087,
     *1852122912,2003330414, 544108320,1668248178,1701016681,1869488233,
     *1931502703,1852124704,        -3, 542078056,1701978226,1701015399,
     *1852406373,1679849057,1819633011, 543257189, 539455603,1764586339,
     *1634608940, 539452781,1885958761,1667329063, 740304749,1970041961,
     * 762536801,1848060960,        -3, 539456101,1717855596,1713843232,
     * 660696673,1819898985,1667329063, 740304750,1970103666,1768120684,
     * 657203239,1734440307,1936286062, 657334304,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750387,1885692777,1718182753,
     *1953066862, 544765025,1818190953,1835363955,1768910431,1835626016,
     *1529883697,1562386464,        -3,1596994867, 538980398, 807411762,
     * 774905888, 841887776, 824199456, 538980640, 807415840, 807411744,
     *        -3,1298755177,1836412192,1131575667,1952541728,1147759973,
     *1853057391,1847610729,1936943470,1730160751,1914717554,1919906345,
     * 539897390, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542402661, 544435553,1819043187,1948279666,
     *2037609569,1814062185,1835363955,1768910368,1936224117,1818501218/
     * )
      ICK(  9001:  9300) = (/
     *1696625525,1886415977,1701060713,1847620712,1696613193,1177428000,
     *        -3, 542402661, 543520880,1701016677,1679849057,1819632928,
     *1936224117,1818501218,1696620832,1919246700, 544109933,1650815520,
     * 677981797, 773877359,1948266542, 859139437, 689971232,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1885692777,
     *1718182753,1953066862, 544765025,1818190953,1835363955,1768910431,
     *1835623456,1529883697,1562386464,        -3,1596994868, 538980398,
     * 807411762, 774905888, 841887776, 824199456, 538980640, 807415840,
     * 807411744,        -3,1298490473,1970085920,1131575667,1952541728,
     *1147759973,1853057391,1847610729,1936943470,1730160751,1914717554,
     *1919906345, 539897390, 538976288, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 542402661, 544040292,1769303328,
     *1668446579,1952541728,1684630885,1853057391,1847620456,1869966436,
     * 543319328,1937076336,1818846564, 543780384,1952998688,1128875566,
     *        -3, 542402661, 543520880,1701016677,1679849057,1819632928,
     *1936224117,1818501218,1696620832,1919246700, 544109933,1650815520,
     * 677981797, 773877359,1948266542, 859139437, 689971232,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1885692777,
     *1718182753,1953066862, 544765025,1818190953,1835363955,1768910431,
     *1835104288,1529883697,1562386464,        -3,1596994869, 538980398,
     * 807411762, 774905888, 841887776, 824199456, 538980640, 807415840,
     * 807411744,        -3,1298233449,1836412192,1131575667,1952541728,
     *1147759973,1853057391,1847610729,1936943470,1730160751,1914717554,
     *1919906345, 539897390, 538976288, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 542402661, 543973746,1734701940,
     * 543388281,1937006956, 543451501,1701737321,1869488243,1752135020,
     *1679843941, 544437616,1886153061,1679845742, 544499813, 541280582,
     * 773857312,        -3, 542402661, 543520880,1701016677,1679849057,
     *1819632928,1936224117,1818501218,1696620832,1919246700, 544109933,
     *1650815520, 677981797, 773877359,1948266542, 859139437, 689971232,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1885692777,1718182753,1953066862, 544765025,1818194529,1684632947,
     * 542847020, 828186656,        -3,1596994870, 538980398, 807411760,
     * 774905888, 808333344, 824199456, 538980640, 807415840, 807411744,
     *        -3,1131575667,1952541728,1382114409,1970479181,1769173865,
     *1852252262,1869750355,1885889906,1768120684, 541290354,1919247220,
     *1768910368, 538976288, 542141541,1634952480,1148133409,        -3,
     *        -2, 542339176,1701996899,1634476131,1869771365,1668573551,
     *1847617135,1914724706,1936683632,1953066862, 543781664,1919250543,
     *1920230756, 773870696,1696625249,1684632947, 544568165,1679845747,
     * 544108404,        -3, 544437616,1886153061,1680744480,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750371,1869771365,
     *1668573551,1847617135,1914724706,1936683632,1953066862, 544105829,
     *1684366368,        -3,1596994871, 538980654, 824188977, 775036960,
     * 825111328, 857751840, 538980384, 824193056, 807411744,        -3,
     *1131377266,1701016681,1869488230,1869750337,1651732338,1886677359,
     *1847612005,1903520114,1701060640, 542266408,1702391849, 539897390,
     * 539248160,1148133409,        -3,        -2, 542732149, 543711606,
     *1696622958,1684628321,1952801824,1952997748, 543256096,1633842031,
     *1919972457,1869488227,1869771365,1668573551,1847617633,1931505263/
     * )
      ICK(  9301:  9600) = (/
     *1948279397,1701716065,1886415977,1701064224,        -3, 539502431,
     *1702391924,1818190178,1936683632,1952408431,1920099683,1953066862,
     *1601468784,1697062951,1852796517, 657010208,1215264613,1986359852,
     * 544499813, 544240229,1684628340,1701060726,1634497893,1931505510,
     *        -3, 542403945,1847600672,1416454520, 740319841,1936024608,
     *1869488244,1751457891,1920562036,1634476132,1768777070,1936289646,
     *1931503465,1986358816,1768824948,1751457831, 778266982, 656434793,
     *1818569760,1634886944,        -3, 544437606,1718182761,1701737580,
     *2032170350,1701934433,1814066280,1635000417,1651732338,1886677359,
     *1847616870,1717920628,1931501936,1885692274, 544501536,1650794611,
     *1768386153,1718182753,1853107744,        -3, 542402661,1919247983,
     *1919233056,1952998688,1634758764,1768120692,1768910368,1868963937,
     * 544437609,1952539244,1696620898,1936683632,1953066862, 543387506,
     *1919247220,1768910368,2003793260,1679826976,        -3, 543256688,
     *1700885024,1953439842,1696625253,1903520114,1701064224,1097626479,
     * 543385701,1667965044,1751217184,1952998688,1668446579,1952541728,
     *1684630885,1853057391,1853038695,1769366894, 543780384,1952998688,
     *        -3, 541280582, 543452960,1919250546,1702061422,1948284008,
     *1696620899,1953849708, 543388281,1937006956, 543451501,1701737321,
     *1869509408,1634934883,1819243365,1819877473,1931505775,1936943458,
     *1818570272,        -3, 541683297,1667462514,1633904997,1931503717,
     *1919230051,1634607212,1700881440,1953439841, 544239471,1914728562,
     *1701079395,1953066862, 544171552,1416456558, 539369556,1835104288,
     *1634624544,1734964837,        -3, 544369011,1696625775, 544499813,
     *1936007265,1818587764,1932402761,1948283752,1869966436, 544108402,
     *1835101292,2032165477, 544239475,1936286316,1696625775, 543519604,
     *1768776052,1696625768,1696604192,        -3, 543388281,1937006956,
     * 543451501,1701737321,1869509408,1953439794, 543450467,1768776044,
     * 544238689,1667593006, 542273397,1734877285,1937009005,1635018099,
     * 544501536,1869507705, 540090468,1701013869,1634476064,        -3,
     * 544238689,1667571821,1635328098,1696625775,1864395118,1633903477,
     *1918989413, 544501536,1886547830,1768187168,1919249513,1633840229,
     * 543519604,1768776052,1702043759,1713394797,1768824870, 542403937,
     *2016288800,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1885692777,1718182753,1953066862, 542403937,2015386416,
     * 741432608,        -3,1596994872, 538980398, 891297840, 775233568,
     * 808334624, 824197408, 538980640, 807415840, 807411744,        -3,
     *1298233449,1836412192,1416782190,1936550259,1936289646, 541483363,
     *1953460768,1298756467,1768843040, 774778414, 774778414, 774778414,
     * 538976288, 538976288, 538984224,        -3,        -2, 542402661,
     * 541942136,1768781165, 544502369,1853058409,1936943471,1847617121,
     *1668575090, 544434287,1970037792,1650794611,1885692777,1718183268,
     * 543780384,1952998688,1667330917, 543236195,1869771365,1668573551,
     *1847599136, 543584114, 543253107,1869770868,1768910368,2002875168,
     *1685024357, 773870696,1769152617,1931497039,1411413096,1696626273,
     *1819632928,1952997748, 543781664,1667329123,1970037108,1701060640,
     *        -3, 543257972,1869439348,1768120684,1819877495,1769236512,
     *1397245260,1481384055,1751477792,1629508425,1514479721,1853060210,
     *1969452137,1869488233,1931503465,1986358816,1768824948,1751457875,
     *1212501080,1277173792,        -3, 543780467,1953658211,1953066862/
     * )
      ICK(  9601:  9900) = (/
     * 543582572,1697521748,1751457910,1634497893,1931506277,1886351988,
     *1701060706,2032161608,1162631244, 544367984,1919251301,1853104244,
     *1751457861,1481655619,1413825568,        -3, 543387506,1919247220,
     *1768910368,1918987879,1697521747,1869440288,1668248178,1701016681,
     *1869488240,1633905505,1734701856, 677719655, 773870401,1145127507,
     * 689993577,1819025520,1919907433,1684348960,        -3, 544173676,
     *2032168814,1696606066,1701601652,1769366829,1668248178,1701016681,
     *1869491558,1633907823,1915170336,1231954035,1969448992,1667330917,
     *1932271700,1835104288,1936224117,1818501218,1696604192,        -3,
     * 543648118,1701716065,1931498605,1635265893,2020631907,1952801824,
     *1634624544,1416456558, 540876914,1701601652,1769366829,1668248178,
     *1701016681,1869491558,1633907823,1914710560,1416454520, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1885692777,1718182753,1953066862, 542403945,1847614256, 741432608,
     *        -3,1596994873, 538980398, 891297840, 775233568, 808334624,
     * 824197408, 538980640, 807415840, 807411744,        -3,1298755177,
     *1836412192,1416782190,1936550259,1936289646, 541483363,1953460768,
     *1298756467,1768843040, 774778414, 774778414, 774778414, 538976288,
     * 538976288, 538984224,        -3,        -2, 542402661, 541944174,
     *1768781165, 544502369,1853058409,1936943471,1847617121,1668575090,
     * 544434287,1970037792,1650794611,1885692777,1718183268, 543780384,
     *1667330917, 543236195,1869771365,1668573551,1847599136,        -3,
     * 543584114, 543253107,1869770868,1768910368,2002875168,1685024357,
     * 773870696,1769152617,1931497039,1411413096,1696626273,1819632928,
     *1952997748, 543781664,1667329123,1970037108,1701060640,        -3,
     * 543257972,1869439348,1768120684,1819877495,1769236512,1397245260,
     *1481384055,1751477792,1629508425,1514479721,1853060210,1969452137,
     *1869488233,1931503465,1986358816,1768824948,1751457875,1212501080,
     *1277173792,        -3, 543780467,1953658211,1953066862, 543582572,
     *1697521748,1751457910,1634497893,1931506277,1886351988,1701060706,
     *2032161608,1162631244, 544367984,1919251301,1853104244,1751457861,
     *1481655619,1413825568,        -3, 543387506,1919247220,1768910368,
     *1918987879,1697521747,1869440288,1668248178,1701016681,1869488240,
     *1633905505,1734701856, 677719655, 773870401,1145127507, 689993577,
     *1819025520,1919907433,1684348960,        -3, 544173676,2032168814,
     *1696606066,1701601652,1769366829,1668248178,1701016681,1869491558,
     *1633907823,1915170336,1231954035,1969448992,1667330917,1932271700,
     *1835104288,1936224117,1818501218,1696604192,        -3, 543648118,
     *1701716065,1931498605,1635265893,2020631907,1952801824,1634624544,
     *1416456558, 540876914,1701601652,1769366829,1668248178,1701016681,
     *1869491558,1633907823,1914710560,1416454520, 773857312,        -3,
     *        -1, 589315646,1042305618, 544499059,1948262432,        -3,
     *1596995120, 540094001, 807416110, 892346418, 774909984, 874531104,
     *1327509536, 807415840, 807411744,        -3,1382118505,1864389741,
     *1635266388,1835626016, 675641456, 762605357,1382379561, 539522159,
     *1864966220,1634887525, 539897390, 774778414, 539248160,        -3,
     *        -2, 544433509, 541676867,1377851205,1110265953,1734701856,
     *        -3,        -1, 589315646,1042305618, 656438373,1936990240,
     *        -3,1596995121, 540028465, 807415854, 842342448, 775237664,
     * 874531104,1327509536, 807415840, 807411744,        -3,1416454520/
     * )
      ICK(  9901: 10200) = (/
     * 794062185,1847612001,1852269856,1415934836, 542265895, 544501615,
     * 541876594,1734680622, 774778414, 774778414, 774778414, 539248160,
     *        -3,        -2, 544433509, 541676867,1377851205,1110265953,
     *1734701856,        -3,        -1, 589315646,1042305637,1935892844,
     *1696617581,1768824870, 542403937,2015371296,        -3,1596995122,
     * 538976288, 807411744, 540155936, 538980896, 874531104,1327509536,
     * 807415840, 807411744,        -3,1382380387,1634493728,1411935593,
     *1848188966, 542386285,1635264800,1652105262, 774778414, 774778414,
     * 774778414, 774778414, 774778414, 539248160,        -3,        -2,
     * 542338925,1696606309,1836083570,1768120684, 689988463,1920099683,
     *1953066862, 544235875,1801545573,1931487333, 778513952,1396786241,
     *1112746272,2003397740, 544240239,1986618469, 544173676,2032168814,
     *1696604192,        -3, 539456101,1818326121,1986342243,1869771365,
     *1668573551,1848469089,1668575090, 657334345,1847620469,1667768419,
     *1634952563, 740316269,1635262579,1752135020,1679843941, 543648118,
     *1701716065,1931485216,        -3, 542403937,2016241016,1885692788,
     *1701060648,1634934883,1634493301,1818326117,1679844978,1869422708,
     *1751457891,1920562036,1634476132,1768777070,1936289646,1932075105,
     *1852055584,        -3, 542403945,1847606560,1919249505,1953068645,
     * 761491314,1919247220,1768910381,1717658484,1869750314, 542403937,
     *2016288800,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750371,1920562036,1634476147,1769628960,        -3,1596995123,
     * 538980398, 908075056, 775299104, 892219424, 874531104, 538980384,
     * 807415840, 824188960,        -3,1131575667,1952541728,1399421541,
     * 542142323,1936286316,2032170095,1864387681,1919378720,1718579744,
     *1113940333, 542337402,1696607790, 539248160,1835868192,        -3,
     *        -2, 541158501,1920213094,1869750371,1920562036,1634497312,
     *2003399784, 543257632,1818583411,1948282734,1696621673,1835363955,
     *1768910368,1886547810,1633840249, 544501615, 543973746,1734680678,
     *1869750388,1751457824,        -3, 543715181,1869047150,1701803379,
     * 544235890,1948282726, 544499813, 542649714,1635328098,1700883744,
     *2003330414, 544568165,1679844975,1914725473,1952539503,1819043171,
     *1953066862, 544568169,1852252192,        -3, 543388281,1937006956,
     * 544042862,1868785778,1869439348,1701060722,1633970529,1953066862,
     * 773865838, 543520867,1701868649,1869488247,1768713248,1650794596,
     *1635017059,1869376613,1668573551,1847620979,1768843040,        -3,
     * 543236194,1702125869,1718185076,1701978209,1852055649, 544437606,
     *1718182761,1701737580,2032168033,1919378720,1668246636,1768776052,
     *1869753888,        -3,        -2, 542336357, 543255667,1866080323,
     * 776482375,1869767273,1954160680, 825833785, 690757697,1668571424,
     *1131575667,1949179970, 892677152, 825243952, 758198329, 942546976,
     *        -3,        -1, 589315646,1042306149,1936990322,1701867378,
     *1952801824,1953653102,1936550259,1936289646,1931503215,1914721320,
     *1835104297, 540949792,1411935593,1848188960,        -3,1596995124,
     * 538980398, 807411760, 774905888, 808333344, 824197408, 538980384,
     * 807415840, 807411744,        -3,1382379631,1920230756, 542386285,
     *1768827168,1769152583,1919246708,1701978228,1751215648,1382379631,
     *1920230756, 542386285,1635264800, 773857312, 538976288, 538976544,
     *        -3,        -2, 541288549,1667965044,1751217184,1952998688,
     *1986096245,1702043749,1853121906,1701060725,1852073330, 539451237/
     * )
      ICK( 10201: 10500) = (/
     *2020635756,1600217715,1869770868,1600352114,1919247220,1768910431,
     *1415540073,1848057953,1852055584,        -3, 539451237,2020635756,
     *1600217715,1869770868,1600352114,1919247220,1768910431,1415540065,
     *2015830120,1635149088,1852797984,1650812270, 544367990,1701999461,
     *1679847282, 543778336,1952998770,1696622963, 543236128,        -3,
     * 544504176,1869050465,1885890915,1634476133,1920102258, 543584114,
     * 544173669, 544171552,1952998771,1696625783,1864395124,1701671726,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750369,
     *1886415977,1667326569,1818850425, 544171552, 678651245,1764567397,
     *1836083570,1768120684, 543253107,1869770868,1768910368,1668248178,
     *1701016681,1869488219, 808202589,        -3,1596995125, 538981166,
     * 807411763, 774905888, 858664992, 857751840,1327509536, 807415840,
     * 807411744,        -3,1316318565,1919509345,1814053743,1920099683,
     *1953066862, 541944167,1752440930,1696612965,1852139113,1667850604,
     * 975203701, 711813476, 539248160,1315927141,        -3,        -2,
     * 541486962, 543713639,1746955637, 539631725,1768169590,1634497893,
     *1932271726,1970103666,1768120684, 543253107,1869770868,1768910368,
     *1668248178,1701016681,1869488240,1919902565,1685418597,1931501938,
     *1696604192,        -3, 544367971,1869442405,1852073316, 539518313,
     *1952998770, 543318387,1701060719,1847609185,1970500457,1634607209,
     *1853121895,1918989417,1869488239,1914724718,1634498932,1768120684,
     * 689989998, 543383923,1696624486,        -3, 543715181,1869047150,
     *1701803379, 543319393,1830842482,1868982636,1702043745,1852055651,
     *1920562036,1634497312,1936548204,1814062446,1869965160, 544501536,
     *1718187040,2003399784,1768824948,1751457824,        -3, 543715181,
     *1869047150,1701803379, 544235890,1948282726, 544499813, 542649714,
     *1635328098,1700883758,        -3, 541683232,1667330917, 544171552,
     *1768828264,1869442919,1701733743,1970479202,1700883827, 740319520,
     *1668246882,1768841588,1768910368,1868963950,1970103666,1768120684,
     * 543388281,1937006956, 543580515,1696604192,        -3, 543318387,
     *1701060707,1869771365,1668573551,1847615854,1679846773,1819568429,
     *1935892846, 543387506,1919247220,1768910368,1769152626,1701015405,
     *1835363940,1701064224,        -3,        -1, 589315646,1042306149,
     *1936990327,1751479400,1701978224,1919247465,1668572516, 543256164,
     * 544367984,1869771877,1679848562,1634628461,1769173865,1869488242,
     *1634625381,1931501938,1696622948,1701737577,1667329056,        -3,
     *1596995126, 538980398, 807411762, 774905888, 841887776, 824199456,
     * 538980384, 807415840, 807411744,        -3,1349674340,1768125541,
     *1679843694,1679839845,1886351988,1701060692,1835626022,1416454520,
     * 542269806,1734680649,1684369012,1768120684, 538976288, 538976288,
     * 538984224,1130915171,1797267488,        -3,        -2, 542402661,
     * 544240229,1684628340,1701060705,1852055666,1701867378,1952801824,
     *1953653102,1936550259,1936289646, 544366958,1734701856,1634886944,
     *1718580590,1679848559, 543319328,1768187246,1953063777,1814044704,
     *        -3, 544696425,1667768425,1931505263,1948284015, 543319328,
     *1702391909,1668572516, 773866313,1176990496,1734700645,1918989413,
     *1679849321,1952981075,1212501080,1278818080,1919250543,1920213024,
     *        -3, 544502369,1853058409,1936943471,1847620193,1852269939,
     * 543318387,1701060719,1847620712,1696621426,2037609569,1814062185,
     *1835363955,1768910451, 544437616,1886153061,1679847278, 544499813/
     * )
      ICK( 10501: 10800) = (/
     *        -3, 542329178,1159750497,1919168032,1416130419,1696626273,
     *1819633011, 543711606,1696624239,1952999790,1730180207, 543452960,
     *2003399784, 544499813, 543253364,1969318944,1668248178,1701016681,
     *1869509408,        -3, 543584114, 543253107,1869770868,1768910368,
     *1634934881,1886415977,1701060724,1864397928,1696621665,1952528928,
     *1952998777, 543847795,1948283493,1886351988, 544499813, 541415504,
     *1162040389,1142977121,1852269870,        -3, 542338925,1696621423,
     *1920099683,1953066862, 544235875,1801545573,1931487333, 778513952,
     *1396786241,1112746272,2003397740, 544240239,1986618469, 544173676,
     *2032168814,1696604192,        -3, 539456101,1818326121,1986342243,
     *1869771365,1668573551,1848469089,1668575090, 657334345,1847620469,
     *1667768419,1634952563, 740316269,1635262579,1752135020,1679843941,
     * 543648118,1701716065,1931485216,        -3, 542403937,2016241016,
     *1885692788,1701060705,1852055636,1835626016,1025536613,1818326121,
     *1986342243,1869771365,1668573551,1848469089,1668575090, 539631700,
     *1835104302,        -3,        -1, 589315646,1042302318,1937076837,
     * 544499809,1948282217,1852403061,1830839401,1835363955,1768910368,
     *1008758113,2020175221,1830839401,1835363955,1768910368,        -3,
     *1596995127, 538980398, 807411760, 774905888, 808333344, 824199456,
     * 538980384, 807415840, 824188960,        -3,1298233449,1836412192,
     *1147759973,1853057391,1847610469,1936924749,1768828448,1484022124,
     * 541354349,1701737321,1869488174, 774778414, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 541944174,
     *1768781165, 543256164, 541942136,1768781165, 543451501,1701737321,
     *1869509408,1634886944,1818848101,1819877477,2019780705,1852269924,
     * 543780384,1952998688,1128875566,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750369,1847608880, 808476515,1634493231,
     *1177563184,1601332592,1869771877,1679849057,1819632928,1684629094,
     *1701995886,1667571744,        -3,1596995128, 540028464, 824193328,
     * 774905905, 808333344, 824199456, 538980384, 807415840, 824188960,
     *        -3,1382379631,1920230756, 541470768, 807421033,1717986674,
     *1931503218,1869422659,1634493284, 539520882, 541944179,1936289383,
     * 690892334, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541683232,1952998688,1768187233,1814061921,
     *1936010272,1651471464, 543449460,1629514100,1701671712,1936224117,
     *1818501224,1635149088,1952998688,1935764837, 544629100,1969565216,
     *1231429742,1869884448,        -3, 544499813, 544367969,1936682528,
     *1936224117,1818501218,1696621420,1700885038, 541139058,1700885359,
     *1847618921,1734898720,1650794612,1751217184,1886351477,1818326121,
     *1869488240,1634885997,1702126962, 544629100,1969582880, 543257189,
     * 543257187,1751742053,1679843961, 542328901,1280855072,2003399784,
     * 544173676,2032170103,1864393829,1667853665,1819484265,1847620712,
     *1696613193,1177428000,        -3, 542011252,1698308179,1212501080,
     *1277191023,1970173043, 544499813, 544109933,1650815520,1868963941,
     *1818583924,1919905395, 543780384,1952998688,1970170228, 543384940,
     *1814962260,1751457906,1702065516,1948262432,        -3, 544696684,
     *1814063470, 543647086,1701994860, 543319328,1634607209,1853121895,
     *1701981728,1416128883, 543781664,1634497391, 544499813, 544109933,
     *1650815520,1667786083,1801806880,1718579744,1751478885, 773857312,
     *        -3, 542402661, 544171622,1768122721,1814062181,1718185577/
     * )
      ICK( 10801: 11100) = (/
     *1953066862, 543383916,1819484262,1869750311,1416127776,1701209701,
     *1668573558,1696624245,1835165042, 544171552,1701602659,1953656686,
     *1931503982, 544499813,        -3, 543388281,1937006956, 544566889,
     *1948279653,1819025507,1869509746,1768060276,1768843040,1953439814,
     * 674246704, 690433568,1232347245,1635328099,1869509729,1768824932,
     *1769173093,1920166255,1847599136,        -3, 543387502,1953655138,
     *1970563439,1853038689,1852055657,1931502433,1818457452,1635018084,
     * 543257402,        -3,        -2, 541468720, 808462624,1025530656,
     * 678655341, 543587954,2116640306,1579166496, 678655341, 543587945,
     *2116640306,1579179358, 825176670,        -3,        -2, 543587954,
     *2116042016,1919246700, 544235890,1948282726, 544499813, 544432993,
     *1953785202,1768843040,1717658484,1869771552,1635000436,1751479393,
     * 540876848,        -3, 543587945,2116042016,1768776039,1768841586,
     *2032169057,1920213103,1713402984,1696625507,1635021925,1919512167,
     * 543580515,1953460851, 543257632,1952998772,1629502752, 807411744,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750380,
     *1633838444, 544696692,1752135028, 544109933,1701996899,1634476144,
     *1634890784,        -3,1596995129, 538980398, 807411762, 774905888,
     * 841887776, 824199456, 538980384, 807415840, 824188960,        -3,
     *1098149741, 541876578,1701584983,1769236591,1970544718,1970103666,
     *1768120684, 542138738,1948266030, 774778414, 774778414, 774778414,
     * 538977345, 541355808, 555753504,        -3,        -2, 541156212,
     *1629504370,2037609518, 542011252,1702043750,1869750337,1970563183,
     *1920147570,1701934441,1919251232,1635020653, 543973730,1701606176,
     *1953439843,1869509729,1768824929, 544109933,1701996899,1634476064,
     *        -3, 544235890,1949179973, 778513952,1092643937,1650813984,
     *1868963956,1751457908,2037409056, 659498784,1936224117,1818501218,
     *1696622441,1986358816,1634934823,1328621358,        -3, 542402665,
     *1931503987, 544108404, 544105827,1702064993,1919511673, 543236210,
     *1701934441,1919249765,1853104230,1869750383,1952998770, 543846261,
     *1919836524,1932402720,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750372,1970302057,1667331173, 543973730,1701606176,
     *        -3,1596995376, 538980398, 807411760, 774905888, 808333344,
     * 824197408, 538980384, 807415840, 824188960,        -3,1148547180,
     *1768120692,1696612724,1869441379, 541876578,1701585007,1847609678,
     *1347769376, 774778414, 774778414, 774778414, 774778414, 538977345,
     * 542011252,1696604192,        -3,        -2, 542402661, 541280582,
     * 543387502,1952541038,1931502709,1886153059,1635018016,1818321509,
     *1819484272,1869834606,1730177390,1952805488,1919251553,1953066862,
     * 544240239,1651271021,1931503215,1914708000,        -3, 542133313,
     *1414483503,1128809795,1261314116,1701996918,1701060711,1701801317,
     *1953659168,1095517522,1414733933,1635328104,1635149088,1952998761,
     *1914728306,1768384878, 543780384,1952999795, 544240239,1651271021,
     * 773857312,        -1, 589315646,1042306149,1936990310,1869750389,
     *1852403316,1701998706,1702125922,1818566764,1633838444,1931485216,
     *        -3,1596995377, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980384, 807415840, 824188960,        -3,1433299310,
     *1952805488,1919251553,1651270944,1098149741, 541876578,1701585007,
     *1847609710,1886745632, 774778414, 774778414, 774778414, 538977345,
     * 542011252,1696604192,        -3,        -2, 542402661, 541280582/
     * )
      ICK( 11101: 11400) = (/
     * 543387502,1952541038,1931504737,1650814067, 544239475,1768843040,
     *1886547810,1818586483, 543584114, 542133313,1414483503,1128809795,
     *1261314080,        -3, 541423713,1836084325, 975203425,1650813984,
     *1213083936,2003399784, 544108320,1935892852,1952805481,1852252276,
     *2037409056,1768842863,1919770996,1768910368,1937076336,1818846564,
     * 773857312,        -3, 542531948,1768186228,1768910368,1769152609,
     *1651470964,1701064224,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750373,2020897381,1835343974,1769108340, 544695657,
     *1734898793,1852252272,1634885997,1702126962, 544629100,1969561640,
     *1397245260,1481386272,        -3,1596995378, 538980398, 824188976,
     * 775036960, 808334112, 840974624, 538980384, 807415840, 824188960,
     *        -3,1397245260,1481384006,1769108340, 538988641,1918987621,
     *1952805408,1768824919,1195922464, 542469749,1937072492,1819877452,
     *1634887525, 539248160,1382379631,1920213024,        -3,        -2,
     * 542402661, 543582578,1936990320,1634885997,1702126962, 544173600,
     *1952998688,1397245260,1481384055,1701406568,1953066599, 543975790,
     *1696620910,1679848819,1701060713,1847620712,1696625253,1718185573,
     *1835363956,        -3, 543711603, 543256096,1702388581,1886677359,
     *1851878508,2032168033,1919378720,1986096245,1697521747,1212501080,
     *1277196137,1819025522,1701015405,1835363940, 539449159,1213472816,
     * 775036976, 774907680,1953439776,        -3, 543319328,1970496868,
     * 543780384,1952998688,1852143732, 544367974,1768842605,1701737504,
     *2003330414, 543781920,1786078311,1702043764,1751217184,1952998688,
     *1919247977,1852138528,2003134823,1752440864,        -3, 544235890,
     *1634559348,1701999392,1986096245,1702043764,1864393317, 543520867,
     *1702065001,1986342432,1416128883, 544239465,1853125408,1953439841,
     * 543975787,1700881004,1696624754,1868721253,1830844265,1952981108,
     *1751457824, 544367974,1818583924,1768910368,1684108385, 543256164,
     * 795832864,1952998688,1919247977,1852140901,1853104237,1868850540,
     * 544437603,1746952563, 543780208,1919905893,1914729061,1718379875,
     *1953066862,        -3, 544419445, 774337312,1869750369,1847620974,
     *1919251311,1819698532, 544240239,1651271021, 544437603,1746952563,
     * 544041331,1936024608,1953982830,1852403303, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750377,1852010350,
     *1936290676,1701733241, 539452271,1853060210, 656438885,1920169331,
     * 539445293,1635020653,1931506277,1718185573,1680285728,        -3,
     *1596995379, 538976288, 807411744, 540024864, 538980384, 824199456,
     * 538980384, 807415840, 824188960,        -3,1210933620,1869443872,
     *1919247918, 740319861,1948280953,1685221223,1701716084,1919246708,
     *1835363956, 542270832,1869771877,1679843699, 538977345, 541288549,
     *1667964960,        -3,        -2, 542402661, 544437362,1969452149,
     *1919230051,1869509729,1768846112,1919247977,1852138528,1752786034,
     *1869047150, 543257711,1836264992,1215264613,1986359840,1952998688,
     *1684108385, 543781989,1830821920,        -3, 539451250,1701210478,
     *1700752499,1600682340,1919903589,1851749490,1700885613,1701737511,
     * 543711603, 544499813, 544629100,1969561639,1668247155,1953638190,
     * 542402661, 544629100,1969561639,1835628645,1680285801,1931485216,
     * 544042866,1696620912,1886547824,1919508852,1697521696,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750383,1667462512,
     *1634624377, 540876848, 774905896,1685417325,2032165236,1869443881/
     * )
      ICK( 11401: 11700) = (/
     *        -3,1596995380, 538980398, 807411760, 774905888, 808333344,
     * 824197408, 538980384, 807415840, 824188960,        -3,1331913589,
     *1885433443,2032160865,1918987621,1952805408,1025519662, 807429743,
     *1914711598, 774778414, 774778414, 774778414, 774778414, 538977345,
     * 541288549,1667964960,        -3,        -2, 542402661, 541280582,
     * 543387502,1952541038,1931501934, 543257711,1830844265,1952981103,
     *1667462512,1634624377, 543974771,1931506792,1634607152, 774910000,
     * 824188960,        -3, 542141541,1634952480,1667786083,1797289832,
     *1702127717,1914729576,1696627301,1919885423,1667462512,1634624377,
     * 544436325,1667851881,1667331177,1869488233,1931503982,1952804452,
     *1701064224,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750383,1667462512,1634624377, 540942385, 774905888,        -3,
     *1596995381, 538980398, 807411760, 774905888, 808333344, 824197408,
     * 538980384, 807415840, 824188960,        -3,1331913589,1885433443,
     *2032149574, 541553253,1635018098, 542402657,1847603502, 807429743,
     *1914711598, 774778414, 538976288, 608247840,        -3,        -2,
     * 542402661, 541280582, 543387502,1952541038,1931501934, 543257711,
     *1830844265,1952981071,1667462512,1634624377, 543650405,1635018098,
     * 544499809,1847603502, 808329248,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750383,1667462512,1634624377, 540811313,
     * 774905958,1869750369,1953459488,1869488243,1885692777,1634476144,
     *1869834612,1768910368,        -3,1596995382, 538980398, 807411761,
     * 774905888, 825110560, 824197408, 538980384, 807415840, 824188960,
     *        -3,1331913589,1885433443,2032149574, 541877619,1931498600,
     *1634607153, 774905958,1869750355,1882091631,1931485230, 538976288,
     * 608247840,        -3,        -2, 542402661, 541280582, 543387502,
     *1952541038,1931501934, 543257711,1830843241,1953786222,1730178926,
     * 543236211,1885692777,1634476144,1869834612,1768910368,2003399784,
     * 544170851,1970299246,1668882464,        -3, 544436325,1667851881,
     *1701060705,1931504741,1936924788,1751215648, 825110574, 542402665,
     *1931503987, 544171636,1701716065,1847616882,1919906336,1634624544,
     *1952998688,1919251317,1819549807,1713402984,1696604192,        -3,
     * 543387502,1718973289,1869488239,1713402984,1696624239,1953066862,
     *1931487087,1667462512,1634624377, 656433518,1679828848,1869641068,
     *1635019119,1847619681,1918987621,1952805415, 773870696,1696622185,
     *1920168992,        -3, 544434287,1970037792,1650794545, 774905958,
     *1869750369, 543585644,1819877487,1667462512,1768252448,1936290917,
     * 773870696,1696623713,1953785202, 544044396,1953067116,1768256288,
     *1952998688,        -3, 544434548,1697477497,1835885940,1920540791,
     *1769236512,1952998688,1868784501,1885433443,2033066068,1752527660,
     * 543584114, 543236198,1970039929, 544170851,1970301285,1679848297,
     *1952784495,1847615776,        -3, 544041330,1919906336,1886151022,
     *1696625768,1696625513,1952787827,2037214565,1953659168,2003397740,
     * 543319328, 808334624, 706752814, 807419168, 808334638,        -3,
     * 542011252,1698308193, 544698991,1852252271,1667462512,1634624377,
     * 544109933,1650815520,2003397740, 543974753,1679848559, 543256096,
     *1768842095,1920099683,1948280184,1885692788,1701060707,1751477609,
     *1667329056,        -3, 543584114,1836412001, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750382,1869491561,
     *1853121895,1918987296, 589328230, 543257711,1836261481,1847620974/
     * )
      ICK( 11701: 12000) = (/
     *1769218147,1701604384,        -3,1596995383, 538980398, 807411761,
     * 774905888, 825110560, 874529056, 538980384, 807415840, 824188960,
     *        -3,1433299316, 541287788,1814053743,1853120873,1853038670,
     *1869491561,1853121895,1701978190,1970102885,1914728294, 541160559,
     *1836261422, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542402661, 544566889,1948279653,1819025507,
     *1869509729,1768846112,1629515375,1848469870,1952802661,1914728053,
     *1835165042, 544171552,1635020653,1931505510, 543236199,1769366894,
     * 543257711,1830843513,1885679136,        -3, 542531948,1768169586,
     *1700885359,1853038697,1852009589,1684349040,1634890857,1634495609,
     * 544170851,1970301285,1679829107,1869379173,1853106464,1936290917,
     *1931501934,1679848309,1651733609,1953854569,1869504876,        -3,
     * 543451507,1869767781,1915625504,        -3,        -1, 589315646,
     *1042306149,1936990307,1869509481,1937007982,1668882471,1734700909,
     * 658255166, 661548832,1210933620,1869443879, 539516769,1953459551,
     *1936290917,1935635311,1819636841,1869504360,2036626031,1734700659,
     * 689971232,1596995384, 538976288, 807411744, 540024864, 538980384,
     * 824199456, 538980384, 807415840, 824188960,        -3,1315905608,
     * 661859360,1651864608,1600222319,1834972009,1952805727,1936682101,
     *1953066862,1600682340,1919903589,1853038674,1701868644, 538977345,
     * 541288549,1667964960,        -3,        -2, 542402661, 544437362,
     *1969452149,1919230051,1869509729,1768846112,1852776552,2036626031,
     *1734700576,1635020653,1932402760,1870095734,1701978228,1751457892,
     *1635016992,1769235821,        -3, 543121780,1869438835,1769235827,
     *1601400684,1970563439,1851746425,1685221223,1701737248,1751213088,
     *1952998688,1986096245,1696606055,1701801255, 773870696,1769152630,
     *1634497893, 543781664,1818848101,1819877492,1751457824, 542328901,
     *1280855072,1684366945,1970041888,1634624544,1936224117,1818501218,
     *1696625253,1886151011,1701060706,2032150318, 657334304,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750377,1852010350,
     *1936290676,1701733241, 539454825,2019910695, 544630130,1937077024,
     * 661548832,1210933620,1869443879,        -3,1596995385, 538976288,
     * 807411744, 540024864, 538980384, 824199456, 538980384, 807415840,
     * 824188960,        -3,1315905608, 761361519,1836264480,1651864608,
     *1600682340,1919903589,1851749490,1700885613,1701737504,1382379631,
     *1920230756, 543257376, 538977345, 541288549,1667964960,        -3,
     *        -2, 542402661, 544437362,1969452149,1919230051,1869509729,
     *1768846112,1852776552,2036626031,1734700576,1635020653,1932402760,
     *1870095734,1701978228,1751457892,1635016992,1769235821,        -3,
     * 539451250,1701210478,1700752499,1600682340,1919903589,1851749490,
     *1700885613,1701737511, 543711603, 544499813, 544629100,1969561639,
     *1835628645,1680289312,1416128883, 544629100,1969561705,1931504745,
     *1801809017,        -3, 544499813, 542328901,1280855072,1684366945,
     *1970041888,1634624544,1936224117,1818501218,1696625253,1886151011,
     *1701060706,2032150318, 657334304,        -3,        -1, 589315646,
     *1042306149,1936990317,1635281261,1970086003,1751737972, 795177586,
     *1869750390,1634497893,        -3,1596995632, 540028464, 891301934,
     * 825237552, 775041056, 840974624, 538980384, 807416096, 807411744,
     *        -3,1298233449,1836412192,1399351654,1949255026,1919906336,
     * 774778414, 774778414, 774778414, 774778414, 774778414, 774778414/
     * )
      ICK( 12001: 12300) = (/
     * 774778414, 539248160,1466464544,1059069984,        -3,        -2,
     * 541290350,1986359911,1701733221, 544171552,1952998688,1919247977,
     *1852140901,1853104233,1931505778,1870030180, 544696692,1746952480,
     *1668050803,1696625775, 544892274,1864397672,1768322095,1701999215,
     *1914708000,        -3, 544629100,1969561702,1869750369,1819025522,
     *1701210478,1701060720,1634885997,1702126962,1932402771,1969448992,
     *1629512559,1853252978,1734700643,1696622963, 543514995,1768716576,
     *1633904745,1702258020,        -3, 544696692,1746952480,1717925664,
     *1633969257,1953066862,1634476146,1701210478,1701668206,1948279673,
     *1668048243, 543257632,1818850420,1818566755,1869837358,        -3,
     * 542011252,1698308179,1869440288,1397245260,1481387321, 924874341,
     *1920166255,1853038692,1864396399,1948279148,1819244320,1718579744,
     *1852139361,1953068645, 541486177,1667965040,1634885997,1702126962,
     *        -3, 544629100,1969582894, 541290350,1986359911,1701733221,
     * 543780384,1937073000, 543236195,1634952480,1835104544,1650794606,
     *1702258034, 544367969,1667786084, 543319395,1635087205, 544499813,
     * 541486177,1667964960,        -3, 544235890,1634559348,1701978230,
     *1634497893, 543781664,1919251301,1948284015, 544892274,1865293856,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750304,
     *1835104361,1836412192,1936222566,1949263218,1919906336,1734964837,
     *1847599136,        -3,1596995633, 540028464, 807415854, 808460336,
     * 774909984, 824197408, 538980384, 807415840, 824188960,        -3,
     *1315905613,1635281261,1970085971,1751737972, 793080434,1869750343,
     *1769366894, 539897390, 774778414, 774778414, 774778414, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 541139053,1635281261,1970086003,1751737972, 795177586,1869750387,
     *1752135020,1679843941, 544436325,1667851881,1701060713,1847619442,
     *1684369952,1953439850,1969514341, 543387502,1986359911,1701733221,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1700885359,1851875948,1696617009, 544629100,1969561632,
     *        -3,1596995634, 540028465, 807415854, 825565232, 775041056,
     * 840974624, 538980384, 807416096, 807411744,        -3,1214867304,
     * 542257440,1449225333,1696607790, 774778414, 774778414, 774778414,
     * 774778414, 774778414, 774778414, 774778414, 774778414, 539248160,
     *1382379631,1920213024,        -3,        -2, 541139048,1768384613,
     *1914729576,1634607221,1937072492, 542257440,1768842345,1667331173,
     *1931502953,1952998770, 543256096,1768846197,1717987683,1768255092,
     * 544042852,1701585007,1914728559,1869750304,        -3, 544306529,
     *1818850425, 543449460,1630412832,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750373,2020897381,1835343987,1701015406,
     *1679849317,1768384628,1768843040,1885434465,1835365477,1914730081,
     *1819632928, 676546629,1280855081,        -3,1596995635, 538981678,
     * 807416373, 774905909, 808333344, 840974624, 538980384, 807415840,
     * 824188960,        -3,1397245260,1481384019,1701015406,1679839329,
     *1918987621,1952805408,1768824919,1195922464, 542469749,1937072492,
     *1819877452,1634887525, 539248160,1466464544,1059069984,        -3,
     *        -2, 542402661, 544433507,1869505568,1885434465,1835365477,
     *1914728302, 544499813, 542328901,1280855072,2003134823,1752459630,
     *1730178153,1852121192,1634934881,1847616888,1667592308,1768910433,
     *1819048224,1818325607,1696604192, 544629100,1969565216,1416128883/
     * )
      ICK( 12301: 12600) = (/
     * 544039289, 543780452,1768120692,1696621929,1952998770, 543780208,
     *1919905893,1914729061,1718379875,1953066862, 544419445, 779296879,
     *1914724718, 544566898,1702063980,1986356256,        -3, 544240239,
     *1651271021, 544437603,1746952563, 544041331,1936024608,1953982830,
     *1852403303, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750386,1700885359,1851875948,1696626514, 840988257,
     *1819632928,        -3,1596995636, 540028466, 891301934, 859119664,
     * 775173408, 857751840, 538980384, 807416096, 807411744,        -3,
     *1214867304, 544690738, 542531948,1969561640,1764648238, 540942384,
     * 775042345, 539897390, 774778414, 774778414, 774778414, 774778414,
     * 539248160,1382379631,1920213024,        -3,        -2, 544690738,
     * 544696684,1814063470, 543647086,1701994860, 543711606,1696620832,
     *1986096245,1696625783,1768121632,1868963956,1751217184,1868963922,
     * 824211305,1952981106,1701210478,1701668206,1948282734, 541469226,
     * 841883680, 542337383,1852401257,1667329652,1819877484,1634887525,
     *1914730081,1819633011, 544568181,1634495609, 543780452,1768120692,
     *1696620832,1886351218, 544367974,1768842605,1701737504,1836016741,
     *1814962241,1819504416,        -3, 543385701,1667965030,1869750389,
     *1851876195,1869966964,1701060710,1869750388,2003398254,1768843054,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750372,
     *1701208437,1819549779,1212501080,1277196133,1768384628,1768843040,
     *1935894629,1835343904,        -3,1596995637, 538976288, 807411744,
     * 825237536, 540094496, 840974624, 538980384, 807415840, 824188960,
     *        -3,1397245260,1481384004,1701208437,1819549783,1701406568,
     *1953066599, 542335848,1701668128,1769152622,1869881423,1886677357,
     *1769629028, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542402661, 544695657,1734898793,1852252275,
     *1667786093,1696622963, 543584117,1852055668,1864393317, 543974758,
     *1948279156, 544499813, 542328901,1280855072,1684366945,1970041902,
     * 542402665,1931485216,        -3, 543450470,1635085428, 544629100,
     *1969561705,1931506277,1668246893,1701733477,1679844975,1914729576,
     *1696624754,1701603693,1768841586,2032169844,1920295796,1970431264,
     *1919247977,1852140901,1853107744,1232347241,1931485216, 544566883,
     *1869442415,1847620712,1635000436,1751741216,1970171760,1953066345,
     *2053465120,2003134823,1752440935,1769366899, 544499813, 543319411,
     *1948280425,1851878432,1919247977,1852140901,1853104242,1702065516,
     *1949179936,        -1, 589315646,1042306149,1936990310,1869750386,
     *1700885359,1851875948,1696617248,1986096245,1696606324,1869553740,
     *1870080288,        -3,1596995638, 538980398, 874520624, 775299104,
     * 808335392, 840974624, 538980384, 807415840, 824188960,        -3,
     *1433301857,1953067878,1633907823,1920540755, 542531948,1969561640,
     *1416589088,1282373408,1869750350,1869881415,1769366894, 689974830,
     * 539248160,1130915171,1797267488,        -3,        -2, 542402661,
     * 541552495,1684956531,1932357478, 759589236, 544629100,1969561683,
     * 544434287,1970037792,1768824935,1701733746,1634476130,1696621420,
     *1869833504,1953439793, 543257632,1952998688,1701733408,1868963937,
     *        -3, 544367974,1768842605,1701737504,2003399784, 543236208,
     *1919905893,1914730341,1768384628,1768843040,1935894629,1835347488,
     *1231429742,1869884448,1952998770,1696623977,1734898720,1650794611,
     *1768386153,1718182753,1853104160, 544566898,1702063980,1986356256/
     * )
      ICK( 12601: 12900) = (/
     *1886547810,1818586483, 544696692,1746957416,1696625253,1718185573,
     *1835363956, 544042852,1701585007,1914729061,1718379875,1953066862,
     * 543449460,1630412832,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750386,1700885359,1851875948,1696617248,1986096245,
     *1696606324,1869553736,1768384553,        -3,1596995639, 538980910,
     * 807411764, 774905888, 908996640, 840974624, 538980384, 807415840,
     * 824188960,        -3,1433301857,1953067878,1633907823,1920540755,
     * 544629100,1969561640,1416589088,1214867304, 689974830, 774778414,
     * 774778414, 774778414, 539248160,1130915171,1797267488,        -3,
     *        -2, 542402661, 541552495,1684956531,1932357478, 759589236,
     * 544629100,1969561683, 544434287,1970037792,1768824935,1701733746,
     *1634476130,1696621420,1869833504,1953439793, 543257632,1952998688,
     *1701733408,1868963937,        -3, 544367974,1768842605,1701737504,
     *2003399784, 543236208,1919905893,1914730341,1768384628,1768843040,
     *1935894629,1835347488,1231429742,1869884448,1952998770,1696623977,
     *1734898720,1650794611,1768386153,1718182753,1853104160, 544566898,
     *1702063980,1986356256,1886547810,1818586483, 544696692,1746957416,
     *1696625253,1718185573,1835363956, 544042852,1701585007,1914729061,
     *1718379875,1953066862, 543449460,1630412832,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750386,1700885359,1851875948,
     *1696621665,1952522287, 544235890,1634559348,1701978226,1635019119,
     * 538978403,1701737586,1869838701,1835365490,1768104035,1634952489,
     *        -3,1596995640, 540094510, 807416114, 775233585, 908998432,
     * 857751840, 538980384, 807416096, 807411744,        -3,1349480306,
     * 541352308,1629499168,1348563553,1835365477,1914720865,1953066784,
     * 774778414, 774778414, 774778414, 774778414, 774778414, 539248160,
     *1315927141,        -3,        -2, 542402661, 543449460,1630498913,
     *1918987621,1952805408,1918989417,1864397672,1869966436, 543780384,
     *1734700645,1918987296,1650794600,1768384613,1914729576,1634607153,
     * 807429743,1914724640,1903518060,1769240864,        -3, 544437362,
     *1969452149,1919230052,1702126962,1835626081,1953066862, 773870696,
     *1769152626,1635019119, 543383918, 543319328,1768779890,1870030180,
     * 543324448,1852797984,1919247977,1852403303,        -3, 541273416,
     * 544235890,1634559348,1701999392,1869899877,1914729576,1634607218,
     *1768188270,1730178926, 544499813,1769087075,1634890345,1701978209,
     *1953459502,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1700885359,1851875948,1696621665,1952522287, 544235890,
     *1634559348,1701978226,1635019119, 539520623,1848468325,1853125231,
     * 689973338,1835104288,1008742712, 689971232,        -3,1596995641,
     * 540095278, 891302200, 774905906, 892219424, 857751840, 538980384,
     * 807416096, 807411744,        -3,1349480306, 541352308,1629499168,
     *1348563553,1835365477,1914720865,1953066784, 677014881,2015378464,
     * 825764128, 774778414, 774778414, 539248160,1315927141,        -3,
     *        -2, 542402661, 543449460,1630498913,1918987621,1952805408,
     *1918989417,1864397672,1869966436, 543780384,1734700645,1918987296,
     *1650794600,1768384613,1914729576,1634607159, 543584114, 543236209,
     *1969319017,1954095136,        -3, 543450484,1701997929,1851880553,
     *1869488239,1713398048,1937011317,1668576626,1696621423,1853120873,
     *1852403303, 543257711,1836261495,1769236512,1512074341,1936924788,
     *1751215648, 825765408,1416128883,        -3, 544366964,1768890467/
     * )
      ICK( 12901: 13200) = (/
     *1634607202,1696622957,1886547830,1701060706,2032168559,1948283493,
     *1718185577,1852252227, 759701616,1634885997,1702126962,1931505524,
     *1751478816,1952997742, 544368996,1768843040,1869488160,        -3,
     * 544499813,1769087075,1634890345,1701978209,1953459502,        -3,
     * 542011252,1698308180,1751457902,1970102885,1914728294, 544367974,
     *1818583924,1768910451, 544568165,1679845742, 544499817,1931506273,
     *1953066784,1769152628,1751457902,1970102885,1914728290,1952541038,
     *1701060640,        -3, 543324448,1281455461, 543650415,1970282593,
     *1986359905,1734962791, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750386,1700885359,1851875948,1696621665,
     *1952522287, 544235890,1634559348,1701978226,1635019119, 539520623,
     *1848468325,1853125231, 689973338,1296128032,1042297144, 689971232,
     *        -3,1596995888, 540095022, 891302198, 775233586, 892219424,
     * 857751840, 538980384, 807416096, 807411744,        -3,1349480306,
     * 541352308,1629499168,1348563553,1835365477,1914720865,1953066784,
     * 677014881,2015378976, 825764128, 774778414, 774778414, 539248160,
     *1315927141,        -3,        -2, 542402661, 543449460,1630498913,
     *1918987621,1952805408,1918989417,1864397672,1869966436, 543780384,
     *1734700645,1918987296,1650794600,1768384613,1914729576,1634607160,
     * 543584114, 543236209,1969319017,1954095136,        -3, 543450484,
     *1701997929,1851880553,1869488230,1869750369, 544437362,1969452149,
     *1919230051,1869509729,1768843630,1730177125,1635154208,1635020653,
     *1931507561,1952981082,1296128032,1735550305,1952805408,        -3,
     * 544499809,1847603512, 773870696,1769152626,1635019119, 543383918,
     * 543319328,1768779890,1870030180, 543324448,1919247977,1852403303,
     * 541273416, 541620580,1919903589,1847615860,1869422704,1634885997,
     *1702126962,1931485216, 544368996,1768843040,1869488244,1751476594,
     * 543383922,1919509874, 543257711,1831739424,        -3, 542402661,
     * 544109933,1650815520,1868963954,1701211237,1668573551,1853038709,
     *1936024608,1768824948,1751457891,1634493301,1818326121,1869488239,
     *1713402984,1769152626,1635019119, 543781664,1952998688,1281455461,
     *        -3, 543258213,1918986085,1679847029,1835165042, 544171552,
     *1919247980,1701016681,1869509422, 542402661, 544629100,1768186228,
     *1768910368,1668442484,1701996897, 544568165,1679843698,1696621944,
     *1885692788,1701060724,1864376352, 543319328,1835365408,2003399784,
     * 543236196,1635017075,1702109283,1869443180,1702126880,2003399784,
     * 543236210,1702063980,1970563439,1847620457,1848145000,1702125865,
     * 795631981,1650745632,1044193328, 775299104,        -3, 541159015,
     * 758197792,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750311,1315908983,1635149164,1701734260,1746954089,1986358823,
     *        -3,1596995889, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980640, 807415840, 807411744,        -3,1315905623,
     *1635149164,1701734260,1746945647,1970168864,1768824899,1229332525,
     * 540028471, 825243443, 541159015, 541160307,1970103652, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542011168,1466005093,1818586727,1952981107,1885692777,1718182753,
     *1953066862, 543584117,1852055657,1847620712,1696613193,1177428000,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750391,
     *1635149164,1701734260,1746957433,1885675611,1131752480,1197550624,
     *1299131424,1097280544,1231953995,1633493024,        -3,1596995890/
     * )
      ICK( 13201: 13500) = (/
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1130915171,1798971479,1635149164,
     *1701734260,1746945897,1986358816,1769152622,1869881411,1965836129,
     * 743272236,1097280585,1847610209, 539248160,1097754414,        -3,
     *        -2, 542402661, 544694646,1701602670,1735682092, 544436325,
     *1667851881,1701060713,1847620712,1696613193,1177297001,1931505263,
     *1948271477,1264656445, 540094005, 875640897, 740312929,1264656445,
     * 540094003, 875639873, 740302880, 541945675,1629502752, 808335153,
     * 808923969, 740311399,1264656445, 540028469, 909129782,1092644722,
     * 541683275,1629502752, 808334641, 859126081, 544366948,1767994473,
     *1869488247,1769236585,1847615776,        -3, 544501612,1701994862,
     *1667571823,1713385518, 808464437,1093541920,1449225321,1679844728,
     *1667592308,1768910451, 543257189, 541811244, 542008693,1953656686,
     * 543256164, 542341486,1667789423,1953656686, 543449460,1630412832,
     *        -1, 589315646,1042306149,1936990310,1869750377,1852010350,
     *1936290676,1701733241, 539454825,2019910695, 544630130,1937077024,
     * 661548832,1919247977,1852138528,1210085487,1936290921,1869509415,
     *        -3,1596995891, 538976288, 807411744, 540024864, 538980384,
     * 824199456, 538980384, 807415840, 824188960,        -3,1315905651,
     * 779431463,1931505518, 541601136,1869834612,1768910451, 740315749,
     *1718185573,1835363956, 542270832,1869771877,1679843699, 538977345,
     * 541288549,1667964960,        -3,        -2, 542402661, 539454825,
     *2019910695, 544504176,1696614521,1685221223,1701716065,1953459488,
     *1919247977,1852140901,1853104233,1931506277,1886351988,1701060648,
     *1397245260,1481387321, 924869733,1717663084,1948855840,        -3,
     * 541618039,1702258034, 740322927, 541620580,1919903589,1847615860,
     *1869443872,2003399784, 543584869,1701607712,1919247977,1852138528,
     *1886352233,1953066862,1931501938,1696622191,1970168864,1768824948,
     *1751457824,        -3, 541280582, 773868649,1801809017, 740324456,
     *1696626273,1819632928, 660828014,1937011239, 544174624, 661808486,
     *1428627558,1869750304,        -3, 539451250,1701210478,1700752499,
     *1600682340,1919903589,1851749490,1700885613,1701737511, 544696684,
     *1814061669, 544042866,1696620912,1886547824,1919508852,1696606309,
     * 778513952,2003330414, 543255660,        -3, 541620580,1919903589,
     *1847615860,1869443872,1751217765, 543319397,1847620197,1718185573,
     *1679845742, 544499813, 544368996,1768843040,1836016741, 544173600,
     *1952998761,1914725217,1920100709,1914724724,1869424942,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750381,1635281261,
     *1970089837,1768843629,1970086002,1702062436,1969318944,1684369011,
     *1769240864,1918989417,1864376352,        -3,1596995892, 538980910,
     * 807411764, 774905888, 942551072, 840974624, 538980384, 807416096,
     * 807411744,        -3,1382118505,1864396646, 541942136,1768781165,
     * 539959373,1768843629,1970085970,1702062436,1969318944,1147498099,
     *1769240864, 774778414, 539248160,1382379631,1920213024,        -3,
     *        -2, 542402661, 544366964,1768890479,1713402984,1696623969,
     *2020175221,1830838638,1679846761,1852403061,1830842981,1936286837,
     *1634476132,1701737321,1954095205,2019784050,1936289646,1931503987,
     *        -3, 544566901,1937072492, 773870696,1769152621,1768384628,
     * 543780452,1768120692,1696626030,1633903471,1970173029,1679844975,
     *1914729591,1768844905,1852252271,1914727785,1936943470,1730175348/
     * )
      ICK( 13501: 13800) = (/
     *1869443872,        -3, 539518254,1731076193,1936944995,1767994469,
     *1679849321,1952981092,1769172850,1684370021,1679848303,1819698542,
     *1948855840,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1702062436,1969318944,1684369011,1769240864,1835104361,
     *1836412192,1734964837,1847614256, 741432608,        -3,1596995893,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980640,
     * 807415840, 807411744,        -3,1315905618,1702062436,1969318944,
     *1147498099,1769240864,1298233449,1836412192,1198093925,1847602734,
     * 774778414, 774778414, 774778414, 538976288, 542141541,1634952480,
     *1148133409,        -3,        -2, 542011168,1919251305,1685414252,
     * 543517797,1668575855,1847616613,1853057396,2032168289,2020175221,
     *1830840169,1986358816,1768824899,1229336096,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750386,1702062436,1969318944,
     *1684369011,1769240864,1835626089,1836412192,1734964837,1847614256,
     * 741432608,        -3,1596995894, 538976288, 807411744, 540024864,
     * 538980384, 824197408, 538980640, 807415840, 807411744,        -3,
     *1315905618,1702062436,1969318944,1147498099,1769240864,1298755177,
     *1836412192,1198093925,1847602734, 774778414, 774778414, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542011168,1919251305,1685414252, 543517797,1668575855,1847616613,
     *1853057396,2032168297,1852403061,1830840169,1986358816,1768824899,
     *1229336096,        -3,        -1, 589315646,1042306149,1936990317,
     *1635281261,1970086002,1702062436,1969318944,1684369011,1769240864,
     * 678585712,1869771877,1680416800,        -3,1596995895, 540028471,
     * 891297841, 774905888, 841887776, 840974624, 538980384, 807416096,
     * 807411744,        -3,1281454695,1696617061,1886351988,1701060685,
     *1635266080, 539512943,1936290921,1986341152,1382380393,1685414252,
     * 541353326,1936290937, 539248160,1698770227,        -3,        -2,
     * 541139058,1702062436,1969318944,1684369011,1769240864,1835104361,
     *1836412192,1818325607,1701978228,1751215648,1702391909,1668572516,
     * 543781664,1919250543,1920230756, 773870696,1769152621,1768384628,
     * 543319328,        -3, 543383925,1936024608,1652105330,1702062436,
     *1969318944,1633842031,1919972457,1869488225,1920230758,1633907827,
     * 740324718,1633903471,1970173029,1679844975,1914729591,1768844905,
     *1852255264,1684632431,1919182194, 740302880, 544698991,1852271737,
     * 543257459,1768386149,1679843700,1869422708,2037409139, 740322665,
     *1936943470,1730177145,1685221223,1701716065,1953459571, 543256164,
     * 544175208,1701978221,1868850540, 543519346,1869771566,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750381,1768843629,
     *1970086002,1702062436,1969318944,1684369011,1769240864, 678585712,
     *1869771877,1680416800,        -3,1596995896, 540028471, 891297841,
     * 774905888, 841887776, 840974624, 538980384, 807416096, 807411744,
     *        -3,1281454695,1696617061,1886351988,1701060685,1768828448,
     * 539512421,1734440041,1986341152,1382380393,1685414252, 541353326,
     *1936290937, 539248160,1698770227,        -3,        -2, 541139058,
     *1702062436,1969318944,1684369011,1769240864,1835626089,1836412192,
     *1818325607,1701978228,1751215648,1702391909,1668572516, 543781664,
     *1919250543,1920230756, 773870696,1769152621,1768384628, 543319328,
     *        -3, 543383925,1936024608,1652105330,1702062436,1969318944,
     *1633842031,1919972457,1869488225,1920230758,1633907827, 740320361/
     * )
      ICK( 13801: 14100) = (/
     *1936683620,1701981216,2003988334,1735162144,1634956137,1735288164,
     * 543257711,1830821920,        -3, 544504176,1702043745,1852055663,
     *1952998770, 544042852,1701584997,1920102258,1932402720,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750381,1768843629,
     *1970086002,1702062436,1969318944,1684369011,1769240864,1735550305,
     *1952805408,2053468783, 542847020, 540106016,        -3,1596995897,
     * 538980398, 807411760, 774905888, 808333344, 824197408, 538980384,
     * 807415840, 824188960,        -3,1298755177,1836412192, 676226407,
     *1635019126,1697194066,1702062436,1969318944,1147498099,1769240864,
     * 776422702, 540024865, 556674606, 539248160,1698770227,        -3,
     *        -2, 541878635,1701607712,1768846437,1919117409,1852269924,
     * 544039288,1768781165, 543256164, 544041326,1768781165, 544629100,
     *1969582894, 541158516,1701998177,1953068645,1819880480,1952998688,
     *1835626089,1836412192,        -3, 544367987,1768191329,1814062181,
     *1853057396,2032167009,1931506792,1696606325,1852598635,1701607721,
     * 544629100,1969561722,1701998382,        -3,        -1, 589315646,
     *1042305637,1886351988, 544108398, 761884276,1701274994, 544367984,
     *1869771877,1679841837,1986096245,1696622958, 541280582,        -3,
     *1597059120, 538976288, 807411744, 540024864, 538980384, 891306272,
     * 538980384, 807415840, 824188960,        -3,1092636271,1848461678,
     *1952802661,1914722848,1986096245,1696617061,1886351988,1701060713,
     *1847620712,1696613193,1176514094, 774778414, 539248160,1130915171,
     *1797267488,        -3,        -2, 542402661, 544108402,1830840691,
     * 543780468,1701274994, 773870696,1696613193,1177379941,1718185577,
     *1953066862, 543584114, 539451235,1701604447,1718579821,1970037087,
     *1970170228,1935628839,        -3, 544436325,1667851881,1702043738,
     * 544629100,1969582880,1634934833, 539835936,1768842857,1852404857,
     * 773870408,1162631244, 544039289, 544367984,1869771808,1768824931,
     *1701999713,1768824931,1634952563, 543236128,        -3, 544367969,
     *1814064757,1835165042, 539510062,1731076186, 540876848, 775305001,
     * 773867886, 544437603,1746952480,1667330917, 740320104,1701014304,
     *2003330420,1751478816,1919246700,1819877485,1869767968,        -3,
     * 543450467,1768776044,1931501938,1696622958,1952804452,1701060705,
     *1852055653,1684632608,1633903471,1919183214,1735162156, 543764069,
     * 773861422, 909582397,1042296878, 909522486, 925769760,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750377,1853060454,
     *1718182761,1701737504,1684629353,1953701990,1869750387,1885692777,
     *1634476144,1869834612,1768910368, 540094259, 539369522, 791879785,
     *1847621677,1668247410,1680744480,1597059121, 538976288, 807411744,
     * 540024864, 540094496, 840974624, 538980640, 807415840, 807411744,
     *        -3,1281977705,1952801824,1349674339,1769171311,1847621677,
     *1131376498,1684631137,1952784420,1092634223,1914711598, 773857316,
     *1109410664,1701014304,        -3,        -2, 541487713,1668573551,
     *1853038703,1713402984,1696625785,1885675560, 724512041, 825176864,
     *1634624544, 673918765, 691154739, 543584114, 544499813, 544239475,
     *1769236847,1851878432,1885434465,1835365477,1920147567,1713381408,
     * 543257711,1836261481,1847620464,1701013857,1814065263,1936290921,
     *1869509408,1936224117,1818501218,1696624754,1870031204,1701060727,
     *1769236512,1937073766,1768122725,1853104228,1768384884,1932402720,
     *        -3, 539519278,1697521712, 775304758, 909582433,1852055600/
     * )
      ICK( 14101: 14400) = (/
     * 775107379, 858990894, 541288549,1667965047,1751479400,1701978213,
     *2019648372, 540094259, 543519843, 773876083, 543780468,1701733477,
     *1680744480,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750377,1853060454,1718182761,1701737504,1684629353,1953701990,
     *1869750387,1885692777,1634476144,1869834612,1768910368, 825176864,
     * 639644207, 857762158, 544812387,1869574756, 773857312,1597059122,
     * 538976288, 807411744, 540024864, 540094496, 840974624, 538980640,
     * 807415840, 807411744,        -3,1281977705,1952801824,1349674339,
     *1769171311,1847621933,1131376498,1684631137,1952784420,1092634223,
     *1914711598, 773857316,1109410664,1701014304,        -3,        -2,
     * 541487713,1668573551,1853038703,1713402984,1696625785,1885675560,
     * 724512041, 825176864,1634624544, 673918765, 691154739, 543584114,
     * 544499813, 544239475,1769236847,1851878432,1885434465,1835365477,
     *1920147567,1713381408, 543257711,1836261481,1847620464,1701013857,
     *1814065263,1936290921,1869509408,1936224117,1818501218,1696624754,
     *1870031204,1701060727,1769236512,1937073766,1768122725,1853104228,
     *1768384884,1932402720,        -3, 539519278,1697521712, 775304758,
     * 909582433,1852055600, 775107379, 858990894, 541288549,1667965047,
     *1751479400,1701978213,2019648372, 540094259, 543519843, 773876083,
     * 543780468,1701733477,1680744480,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750377,1853060454,1718182761,1701737504,
     *1684629353,1953701990,1869750387,1885692777,1634476144,1869834612,
     *1768910368, 825176864, 639644207, 857762158, 544877923,1869574756,
     * 773857312,1597059123, 538976288, 807411744, 540024864, 540094496,
     * 840974624, 538980640, 807415840, 807411744,        -3,1281977705,
     *1952801824,1349674339,1769171311,1847622189,1131376498,1684631137,
     *1952784420,1092634223,1914711598, 773857316,1109410664,1701014304,
     *        -3,        -2, 541487713,1668573551,1853038703,1713402984,
     *1696625785,1885675560, 724512041, 825176864,1634624544,1764240175,
     * 757674543, 857761391,1914729576,1696624751,1936290921,1869504876,
     * 544235890,1634559348,1701999392,1868963872, 543257711,1836261481,
     *1847620464,1701013857,1814065263,1936290921,1869509408,1936224117,
     *1818501218,1696624754,1870031204,1701060727,1769236512,1937073766,
     *1768122725,1853104228,1768384884,1932402720,        -3, 539519278,
     *1697521712, 775304758, 909582433,1852055600, 775107379, 858990894,
     * 541288549,1667965047,1751479400,1701978213,2019648372, 540094259,
     * 543519843, 773876083, 543780468,1701733477,1680744480,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750369,1684302196,
     *1768910433,1814066290,1634628460,1635019119,1851878432,1937337709,
     *1702130297, 542847020, 540106016,        -3,1597059124, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 807415840,
     * 824188960,        -3,1416127776,1382379631,1920230756, 541291129,
     *1937006956, 542341491,1952804128,1769152585,1852010350,1936290676,
     *1701737504,2003399784, 538977345, 541288549,1667964960,        -3,
     *        -2, 541288549,1667965044,1751457906,1701867378,1952801824,
     *1668446579,1952541728,1937339252,1701650529,1734437230,1936990324,
     *1751457906,1701867378,1952801824,1936744803,1696622450,1869967406,
     *        -3, 541158516,1701998177,1953068645,1819880480,1852776547,
     *1920562036,1634476147,2037609573,1830844257,1931506277,1886351988,
     *1701064224,        -3,        -1, 589315646,1042306149,1936990310/
     * )
      ICK( 14401: 14700) = (/
     *1869750377,1852010350,1936290676,1701737504,1919250543,1920230756,
     * 544694646,1701602670,1735682163, 543780384,1128875552,1634624544,
     * 779249011, 543582572,1696604192,        -3,1597059125, 538976288,
     * 807411744, 540024864, 538980896, 824197408, 538980384, 807415840,
     * 824188960,        -3,1128875552,1634624544,1380274976,1382379631,
     *1920230756, 542597494,1701602670,1735682163, 541683299,1869509481,
     *1937007982,1948266030, 538976288, 538976288, 538984224,1130915171,
     *1797267488,        -3,        -2, 542402661, 544694646,1701602670,
     *1735682163, 544367984,1869771877,1679845742, 541280582, 543582572,
     *1696620910,1679845742, 544499813, 541279564,1277194853,1668248164,
     * 544171552,1952998688,1701667429,1684301156,        -3, 542262611,
     * 543582572,1696625512,1869966436, 543319328,1768187246,1953063777,
     *1814962245, 778513952,1299139425, 540876848, 775369008, 926097513,
     *1847620712,1696613193,1176527214,1679836021,1264656445,        -3,
     * 540094005, 875640864,1097754414, 543780384,1952998688,1701667429,
     *1684301156, 539438706,1702045472,1718185061,        -3,        -1,
     * 589315646,1042306149,1936990326,1634494820,1769240864,1868963945,
     *1853252978,1936289646, 544503657,1852729710,1730178928,1701994868,
     *1768910368,        -3,1597059127, 538976288, 807411744, 540024864,
     * 540621088, 840974624, 538980384, 824193056, 807411744,        -3,
     *1417111918,1852403303, 541942132,1919514656,1231976033,1818846240,
     *1768824899,1701737586,1869838701,1835365490,1768104019,1346851360,
     * 538976288, 538976288, 538984224,1130915171,1797267488,        -3,
     *        -2, 541683318,1701999465,1869488244,2003398254,1768843040,
     *1769152621,1700884073,1852271717,1936924777,1847616357,1853125231,
     *1937337709,1702130281,1663071088,1633903975,1919907184, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990326,1634494820,
     *1769240864,1868963956,1751457908,2003398254,1768843040,1869636978,
     *1635019119,1847599136,        -3,1597059128, 538976288, 824188960,
     * 540090400, 538980640, 840974624, 538980384, 824193056, 807411744,
     *        -3,1417111918,1852403303, 541942132,1919514656,1769152617,
     *1853252978,1952801824,1281455461, 543650415,1970282607,1885696609,
     *1953066862, 538976288, 538976288, 538984224,1130915171,1797267488,
     *        -3,        -2, 542402661, 542328901,1280855072,1415006542,
     * 543780467,1953658211,1953066862, 544039284,1919514656,1668248178,
     *1702064239,1852076832,1953439841, 544438637,1835365490,2032168816,
     *1701994868,1768910368,1868963956,1751457824, 544108398, 761488750,
     *1953656691,2037214565,1953655139, 541876597,1696622450,1869967392,
     *1868963956,1751457891,1920562036,1634476147,1953658211,1953854053,
     * 773870696,1769152617,1931505263,1948279072,1986096233,1679826976,
     * 544503657,1847619440,1701994868,1768910382,        -3,        -1,
     * 589315646,1042306149,1936990324,1751457908,2003398254,1768843040,
     *1869636978,1635019119,1847615859, 543255668,1701998177,1952784489,
     *1853252978,1936289646, 544503657,1852729710,1730158624,        -3,
     *1597059129, 538976288, 824188960, 540090400, 538980640, 840974624,
     * 538980384, 824193056, 807411744,        -3,1417111918,1852403303,
     * 541942132,1919514656,1025524076,1952805486,1635018016,1231976037,
     *1920166255,1847612535,1768844905,1852252206, 538976288, 538976288,
     * 538984224,1130915171,1797267488,        -3,        -2, 542402661,
     * 542328901,1280855072,1415006542, 543780467,1953658211,1953066862/
     * )
      ICK( 14701: 15000) = (/
     * 544039284,1919514656,1668248178,1702064239,1852076832,1953439841,
     *1847617902,1986359924,1701060640,        -3, 544108398, 761488750,
     *1953656691,2037214565,1953655139, 544239465,1853122418,1869967392,
     *1869636978,1635019119,1847616101,1819242087,1768843040,1953439860,
     *1751457891,1869771365,1936748398,1684631143,        -3, 543384942,
     *1953656691,2037214565,1953655139, 541876597,1696622450,1869967406,
     * 542402661, 544367984,1869771877,1679848567,1768844905,1852252262,
     *1633907823,1914726771, 543253364,1969319020,2032170088,1696604192,
     *        -3, 541486177,1667965048, 544629100,1969565216,1416127776,
     *1668050803,1696625775, 544892274,1864385353,1176531557,1886351988,
     *1701060678,1818321771, 544235890,1634559348,1701978230,1634497893,
     * 543781664,        -3, 544040289,1852403303,1818588019, 773857360,
     *1818583411,1696625253, 762471782,1768842528,2003399784, 544499813,
     * 542398281,1310746990,1937011317,1668573551,1847620197,1886151011,
     *1701060706,2032150356,1464421927,        -3, 539519278,1697521783,
     *1769236591,1970544750,1970103666,1768120684, 543449460,1630088736,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750369,
     *1684302196,1768910433,1814066290,1634628460,1635019119,1851878432,
     *1937337709,1702130297, 542847020, 540106016, 675365956,1398361385,
     *        -3,1597059376, 538980398, 891297840, 775233568, 960051488,
     * 840974624, 538980384, 807415840, 824188960,        -3,1094992979,
     *1498226756,1702126947,1953701968,1869899118,1953063276, 541876596,
     *1953063781, 542405217,1853058145,1953066862, 539897390, 538976288,
     * 538976288, 538984224,1130915171,1797267488,        -3,        -2,
     * 542401907,1953701990,1869750381,1769173861,1679848313,1835885940,
     *1920540769,1919230052,1869505824,2003399784, 541148228,1398361388,
     * 543256096,1702392933,1852073316, 541935955,1398361376, 675490080,
     *        -3, 543386735,1852124704,1416127859,1696625765,1937011488,
     *2002874990, 543584114, 544041331,1936024608,1869750384,1869837161,
     *1651270944,1751738216,1701978152,1886610805,1685006624,1937337709,
     *1702130297, 543780384,        -3, 544499813, 544437362,1969452149,
     *1918987296,1836016741,1814046825, 778382880,1650553701,1679847278,
     * 544499813, 543387503,1919183214,1635018016,1684108385, 690888736,
     *        -3, 541289583,1936007269,2019650921,1851880553,1869488239,
     *1713402984,1696625513,1953849716,1768910368,1635000424,1634624544,
     *1769152617,1852074339,1635018084, 543780384,1869767781,1914729583,
     *        -3, 544240239,1986342756,1769173106,1870030112,1952998688,
     *1769173877,1696606325,1937072492,1819877481,1847616367,1835166062,
     *1635019119,1847621481,1952981108,1751457906,1701211237,1668573551,
     *1847616609,1952524590,        -3, 542270832,1869771808,1869488240,
     *1869899118,1953063276, 539521139,1702192239, 796026209,1814634604,
     *1635021929,1667571811,1701737573,1919512167, 544174624,1667591276,
     * 543711596,1986621031, 773857312,        -3, 542011252,1698308168,
     * 761361519,1836261473,1852055652,1769172850,1684370021,1679843700,
     *1869443872,1634886944,1852797984,1952541541,1847617902,1953439841,
     *1667460981,1853104233,1847620712,1696625765,1937011502,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750369,1684302196,
     *1768910433,1814061925,1853125221, 544171552,1937337709,1702130297,
     * 542847020, 540094512,1562388545,1145328473,1294540832,        -3,
     *1597059377, 538976313, 807411744, 959782944, 825241632, 840974624/
     * )
      ICK( 15001: 15300) = (/
     * 538980384, 807415840, 824188960,        -3,1094992979,1498226756,
     *1702126947,1953701966,1702305832,1349739893,1685006624,1130720884,
     *1919230063,1713394553,1835885940,1920540718, 539248928, 625371508,
     *        -3,        -2, 542401907,1953701990,1869750381,1769173861,
     *1679848313,1835885940,1920540769,1919230052,1869505824,2003399784,
     * 541148228,1398361388, 543256096,1702392933,1852073316, 541935955,
     *1398361376, 675490080,        -3, 543386735,1852124704,1416127859,
     *1696625765,1937011488,2002874990, 543584114, 544041331,1936024608,
     *1869750384,1869837161,1651270944,1751738216,1701978152,1886610805,
     *1685006624,1937337709,1702130297, 543780384,        -3, 544499813,
     * 544437362,1969452149,1918987296,1836016741,1814046825, 778382880,
     *1650553701,1679847278, 544499813, 543387503,1919183214,1635018016,
     *1684108385, 690888771,1819243365, 543520865,1835626081,1953066862,
     *        -3, 544171552,1952998688,1936290933,1635019119,1847615860,
     * 543711598,1679849321,1952981072,1279349839,1311719748,1146313037,
     * 543781664,1768842345,1667331173,1679845742, 544174692,1701978228,
     *1864396914,1870030127,        -3, 543451507,1886547830,1696625768,
     *1696622963,1937073440, 678785909,1634495609, 543780384,1668246882,
     *1768841588,1768910368,2003399784, 544499813, 544367974,1818583924,
     *1768910368,1684108385, 690888736,        -3, 542402665,1931493708,
     *1163023392,1919250543,1920234272,1869488225, 544239476,1701737577,
     *1634476129,1684302196,1768910433,1814046832,1936029028,1865380453,
     *1634478368,1768846949,1920166255,1847616357,1853125221, 773857312,
     * 541139056,1936029028,1865245541,1853125221, 544039289, 543319328,
     *1768842095,1836081524,1768057957, 544696692,1746953592,1769174121,
     *1852252275,2037214565,1953659168,1701602669,1701737587, 773857312,
     *        -3, 541288553,1918987296,1836018789,1668639845,1931501938,
     *1696622958,1668246896,1635019106,1818566775,1769236512,1634607209,
     *1853252978,1936289646, 543384942,1953654062,        -3, 542011252,
     *1698308168, 761361519,1836261473,1852055652,1769172850,1684370021,
     *1679843700,1869443872,1634886944,1852797984,1952541541,1847617902,
     *1953439841,1667460981,1853104233,1847620712,1696625765,1936993824,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750369,
     *1684302196,1768910433,1814066041,1835885940,1920540763, 808198193,
     *1562388545,1145328473,1294540832,        -3,1597059378, 538976309,
     * 807411744, 959782944, 825241632, 840974624, 538980384, 807415840,
     * 824188960,        -3,1094992979,1498226756,1702126947,1953701966,
     *1702305832,1349739893,1685006624,1400466797, 773866860,1701650468,
     *1092625481, 539313769,1948262432,        -3,        -2, 542401907,
     *1953701990,1869750381,1769173861,1679848313,1835885940,1920540769,
     *1919230052,1869505824,2003399784, 541148228,1398361388, 543256096,
     *1702392933,1852073316, 541935955,1398361376, 675490080,        -3,
     * 543386735,1852124704,1416127859,1696625765,1937011488,2002874990,
     * 543584114, 544041331,1936024608,1869750384,1869837161,1651270944,
     *1751738216,1701978152,1886610805,1685006624,1937337709,1702130297,
     * 543780384,        -3, 544499813, 544437362,1969452149,1918987296,
     *1836016741,1814046825, 778382880,1650553701,1679847278, 544499813,
     * 543387503,1919183214,1635018016,1684108385, 690888771,1819243365,
     * 543520865,1835626081,1953066862,        -3, 544171552,1952998688,
     *1936290933,1635019119,1847615860, 543711598,1679845747, 543780452/
     * )
      ICK( 15301: 15600) = (/
     *1768120692,1701060713,1847619442,1684369952,1953439856,1919907429,
     * 795109747,1886547830,1696625768,1696622963,1937073440,        -3,
     * 539522419,1969319020,2032167278, 543387501,1651076705,1953066862,
     * 544696692,1746957416,1696625253,1718379875,1953066862, 543449460,
     *1630088736,1416128883, 541150277,1381245042,1701867378,1953701999,
     *1847599136,        -3, 544239476,1701737577,1634476129,1684302196,
     *1768910433,1814046832,1936029028,1865380453,1634478368,1919906913,
     *1953066862, 543258725,1931501934,1679846761,1920102258,1932402720,
     *        -3, 541683232,1633969257,1953066862, 740305008,1936029028,
     *1865380453,1634478368,1818326132,1768121632,1667591796,1701996910,
     *1731163250,1634628460,1635019119,1853038689,1919230066,1701867378,
     *1952801824,1634934816,        -3, 541142048,1110188099, 740313388,
     * 542649376,1496064090, 740315950, 539510885,1919230035, 544437345,
     *1852076832,1718579744,1936745827,1767992352,1634624544,1852797984,
     *1668249189,1919247392,1652105332,1751457824,        -3, 544240229,
     *1667589225,1852252276,2037409139, 690888774,1970039840,1684370529,
     *1768715040,1869488244,1751457907,1769239905,1953066862, 543257632,
     *1751215716, 544434287,1970037792,1650794599,1818583406,1701060640,
     *        -3, 543584879,1830838638, 543253364,1969318944,1347174740,
     *1330523969,1145328473,1293972085,1848516640,        -3, 542011252,
     *1698308161,1953459488,1954115685,1931501938,1696625778,1700885605,
     *1679845742, 544499817,1931506789,1936990305,1931494737,1430342688,
     *1718579744,1937011317,1668576626,1702043767,1769236512,1818588019,
     *        -3, 544499809,1847603765, 807428468,1869443872,1768824948,
     *1751457889,1937337709,1702130281,1663071598,1769218153,1847619442,
     *1684369952,1953439844,1702126947,1948279649,1936028448,1868963949,
     *1769169267,1936287598,1701060640, 543257711,1830843513,1885696814,
     *        -3, 541288553,1918987296,1836018789,1668639845,1931501938,
     *1696622958,1668246896,1635019106,1818566775,1769236512,1634607209,
     *1853252978,1936289646, 543384942,1953654048,1869750312,1735158116,
     *1697214572,1634624883, 773857312, 542011252,1698308168, 761361519,
     *1836261473,1852055652,1769172850,1684370021,1679843700,1869443872,
     *1634886944,1852797984,1952541541,1847617902,1953439841,1667460981,
     *1853104233,1847620712,1696625765,1937011502,        -3,        -1,
     * 589315646,1042305637,1886351988, 542008695, 544436321,1667575143,
     *1919907184, 544437607,1734701940,1701060706,2032156996,1146313037,
     *        -3,1597059379, 538976313, 807411744, 959782944, 825241632,
     * 840974624, 538980384, 807415840, 824188960,        -3,1094992979,
     *1498226771,1969710949,1937011488,1349481331,1768057957, 542143333,
     *1969516335,1315272480, 542339169,1667571783,1919907184, 538977345,
     * 541288549,1667964960,        -3,        -2, 542401907,1953701990,
     *1869750381,1769173861,1679848313,1835885940,1920540769,1919230052,
     *1869505824,2003399784, 541148228,1398361388, 543256096,1702392933,
     *1852073316, 541935955,1398361376, 675490080,        -3, 543386735,
     *1852124704,1416127859,1696625765,1937011488,2002874990, 543584114,
     * 544041331,1936024608,1869750384,1869837161,1651270944,1751738216,
     *1701978152,1886610805,1685006624,1937337709,1702130297, 543780384,
     *        -3, 544499813, 544437362,1969452149,1918987296,1836016741,
     *1814046825, 778382880,1650553701,1679847278, 544499813, 543387503,
     *1919183214,1635018016,1684108385, 690888771,1819243365, 543520865/
     * )
      ICK( 15601: 15900) = (/
     *1835626081,1953066862,        -3, 544171552,1952998688,1936290933,
     *1635019119,1847615860, 543711598,1679845747, 543780452,1768120692,
     *1701060713,1847619442,1684369952,1953439856,1919907429, 795109747,
     *1886547830,1696625768,1696622963,1937073440,        -3, 539522419,
     *1969319020,2032167278, 543387501,1651076705,1953066862, 544696692,
     *1746957416,1696625253,1718379875,1953066862, 543449460,1630088736,
     *        -3, 541288553,1918987296,1836018789,1668639845,1931501938,
     *1696622958,1668246896,1635019106,1818566775,1769236512,1634607209,
     *1853252978,1936289646, 543384942,1953654048,1869750312,1735158116,
     *1697214572,1634624883, 773857312, 541486962, 543256096,1702388077,
     *1886151968,1868963954,1701867378,1952801824,1886610805,1685007731,
     *2037214565,1953659168,1936024864,1227768110,1198881381,1763730804,
     * 543255596, 539505200, 808593710,        -3, 541156212,1629504370,
     *2037609518, 541275448, 740322609, 875638125, 825504558,        -3,
     * 542011252,1698308168, 761361519,1836261473,1852055652,1769172850,
     *1684370021,1679843700,1869443872, 677981797, 773874036,1869443872,
     *2003399784, 544239472,1970037108,1768910368,1818588019,        -3,
     * 544499809,1847603502, 808001633,1919230062,1869881460,1634428270,
     * 543780468,1864393059,1668248942,1948281198, 544499813, 544499059,
     *1953705504,1416128883, 544039289, 543257204,1768319331,1767992428,
     *2032148512,        -3, 543974753,1679848559, 543236211,2037214565,
     *1953659168,1751738216,1701978228,1751215648,1952998688,1633907829,
     *1634476143,1852124704,        -3, 542011252,1698308161,1953459571,
     * 543257189, 544502373,1635018084, 543257376,1751217769,1852252276,
     *1751457907,1634559264,1635020653, 544504176,1696622958, 544174692,
     *1701978228,1864393569,1952671776,        -3, 543384946,1952541038,
     * 544504176,1702043759,1713398889,1936683620,1701978223,1914726766,
     *1668248178,1701016608,1635020653, 544504176,1696620915,1936287598,
     *1835363956, 773857312,        -3,        -1, 589315646,1042305637,
     *1886351988, 544173600,1094992979,1498226800,1919902316,1701650464,
     *        -3,1597059380, 538976288, 807411744, 540155936, 538980896,
     * 840974624, 538980384, 807415840, 824188960,        -3,1094992979,
     *1498226755,1869966436, 544108404, 539513445, 692285294,1937011317,
     *1668554832,1919905893,1914721136,1633903975,1919907184, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 541148228,1398361376,1751216928,1886547810,1818586483, 544501536,
     *1919247215,1853060210,1969452064,1629516656,1633903904,1735552885,
     *1881171570,1869422708,1751457907,2037214565,1953659168,1869636978,
     *1635019119,1847599136, 543584117,1852055657,1847620712,1696625529,
     *1835885940,1920540773,2020630894,1684366368,1668247410,1684631137,
     *1952784499,1702112800,1416127776,1919246707,1869488226,1701408359,
     * 543517044,1751478816,        -3, 543780468,1919509345,1952784481,
     *1684302196,1768910433,1819048224,1684370533,1668572516, 544240485,
     *1969516333,1937337709,1702130297, 544174624,1936028265,1869968160,
     *1701999215,1920147561,1847620712,1696621665,1952522272, 544433524,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750382,1869491555,1920562036,1634495599,1735549296,1751737120,
     *1667591796,1919230063,1713402745,1835885940,1920540763, 808198193,
     * 808475936,        -3,1597059381, 538976309, 807411761, 808460320,
     * 825241632, 891306272, 538980384, 807415840, 824188960,        -3/
     * )
      ICK( 15901: 16200) = (/
     *1094992979,1498226756,1702126947,1953701966,1869505394,2037609569,
     *1819045735,1918988392,1768104009,1853252978,1936289646, 539897390,
     * 608773408,1130915171,1797267488,        -3,        -2, 542401907,
     *1953701990,1869750381,1769173861,1679848313,1835885940,1920540769,
     *1919230052,1869505824,2003399784, 541148228,1398361388, 543256096,
     *1702391905,1852073316, 541935955,1398361376, 675490080,        -3,
     * 543386735,1852124704,1416128883, 541150277,1381245042,1701867378,
     *1953701999,1847618671,1667329056,1768846949,1920166255,1847620473,
     *1835885940,1920543776,1852797984,1668246896,1635019106,1818566688,
     *        -3, 544696692,1746957416,1696625253,1886351988,1701060723,
     *1885430629, 761754223,1970282611,2037214565,1953659182,        -3,
     * 542011252,1698308168, 761361519,1836261473,1852055652,1769172850,
     *1684370021,1679843700,1869443872,1634886944,1852797984,1952541541,
     *1847617902,1953439841,1667460981,1853104233,1847620712,1696625765,
     *1936993824,        -3,        -1, 589315646,1042305637,1886351988,
     * 543780208,1818586469,1853121892, 539521139,1702192239, 689990753,
     *1953786211,1696625778,1634628460,1635019119,1847599136,        -3,
     *1597059382, 538976288, 807411744, 540090400, 538980896, 840974624,
     * 538980384, 807415840, 824188960,        -3,1094992979,1498226761,
     *1852009589,1684366368, 676361061,1969516329, 541876596,1953063781,
     * 542405217,1853058145,1953066862, 539897390, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 541138984,
     *1349739893,1685006624,1281455220,1768121632,1953653102,1936482676,
     *1768910368,2002875168,1684370533,1668572516, 543256164, 543780208,
     *1818586469,1853121892, 543319398,1869767968,1952998688,        -3,
     * 543389042,1919250036, 541148228,1398361376,1634623852,2037606771,
     * 773857312,        -3,        -1, 589315646,1042305637,1886351988,
     * 544240239,1651271021, 544696692,1746957177,1835885940,1920540783,
     *1885696609,1953066862, 544438638,1952544800,        -3,1597059385,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980384,
     * 807415840, 824188960,        -3,1349676898,1818586400,2003399784,
     * 544499813, 542341486,1952544800,1868963937, 542341485,1835365490,
     *2032160624,1701994868,1768910382, 538977345, 541288549,1667964960,
     *        -3,        -2, 541139059,2037214565,1953659168,1869636978,
     *1635019119,1847620456,1869966436, 543319328,1936745827,1768319333,
     *1679845742, 544499813, 541280582, 543517044,1751478816,2003399784,
     *1869968416,        -3, 544436321,1667592992,1869750370,1702131557,
     *1701716081,1970238565,1932402720,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1948278643,
     *2037214565,1953659231,1936744803,1700751218,1869967455,1851878757,
     *1598565709, 543256164, 542341485,1830834032,1881153568,        -3,
     *1597059632, 538976288, 807411744, 825237536, 540094496, 824197408,
     * 538980384, 807415840, 824188960,        -3,1382379631,1920230756,
     * 539246880,1231971183,1853057395,1952804468, 544696692,1746945400,
     *1886153059,1769218080, 538976292,1109410664,1701014304,        -3,
     *        -2, 542339169,1667571815,1919907184, 544438637,1835365490,
     *2032169832,1869966436, 543319328,1886547830,1768187236, 543780384,
     *1952998688,1128875552,1651471464, 543520880,1818846057,1953265952,
     *2003399784, 543236128,        -3, 539451251,2037214565,1953659231,
     *1701934441,1985966191,1935630707,1601730938, 656436335,1869619297/
     * )
      ICK( 16201: 16500) = (/
     *1852055657,1836084329,1667855468,2032170857,1952981024,        -3,
     * 539451251,2037214565,1953659231,1936744803,1700751218,1869967455,
     *1851878757,1598565709, 657334304,        -3,        -2, 541158944,
     *1970173299,1969318944, 678326126, 762541153,1852072306,1680416867,
     *1752131939,1696624486, 544174697,1734962720,1835104544,1634497391,
     * 544366953,1936007284,1751741216,1095517522,1412309024,        -3,
     * 542141541,1634952480,1667786083,1797284206,1679836536,1886151017,
     *1848516640,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750390,1634494820, 543126393,1835885940,1920556915,1885430629,
     *1600615023,1970298734,1634559327,1210928416, 673914977,1818845555,
     *1702045984,        -3,1597059633, 538976288, 807411744, 825237536,
     * 540094496, 824197408, 538980640, 807415840, 807411744,        -3,
     *1231976033,1818846240,1601403245,1835365490,2036298608,1633903967,
     *1735552885,1885302369,1835360072, 760029230, 774778414, 774778414,
     * 538977345, 541288549,1667964960,        -3,        -2, 542341485,
     *1835365490,2032167278, 544499813, 541280582, 544434287,1970037792,
     *1650794608,1919907433,1684366368,1651471464, 543520880,1818846057,
     *1953265952,2003399784, 543236128,        -3, 539451251,2037214565,
     *1953659231,1701934441,1985966191,1935630707,1601730938, 656436335,
     *1869619297,1852055657,1836084329,1667855468,2032170857,1952981024,
     *        -3, 539451251,2037214565,1953659231,1936744803,1700751218,
     *1869967455,1851878757,1598565709, 657334304,        -3, 542401907,
     *1948280431,1914730081,1818846240, 660566905,1835885940,1920556915,
     *1885430629,1600615023,1970298734,1634559327,1210928423, 544438637,
     *1651469358,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750335, 543126393,1835885940,1920556915,1885430629,1600615023,
     *1970298734,1634559327,1210928416,        -3,1597059634, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980640, 807415840,
     * 807411744,        -3,1315905631,1937337709,1702130297,1601400929,
     *1667587943,1919907184,1601069421,1700743213,1293961065,1986358816,
     * 774778414, 774778414, 538976288, 542141541,1634952480,1148133409,
     *        -3,        -2, 542341485,1835365490,2032167278, 544499813,
     * 541280582, 544434287,1970037792,1650794608,1919907433,1684366368,
     *1651471464, 543520880,1818846057,1953265952,2003399784, 543236128,
     *        -3, 543126393,1835885940,1920556901,1903520118,1601204083,
     *1600222047,2021227040,1819242352, 543256164, 543780208,1818846057,
     *1953265952,2003399784,        -3, 543126393,1835885940,1920556915,
     *1885430629,1600615023,1970298734,1634559327,1210928430,        -3,
     * 542401907,1948280431,1914727785,1936943470,1730160745, 778382880,
     *1059659815,1601403245,1835365490,2036298608,1633903967,1735552885,
     *1885302369,1835360072, 760031008,1937337698,1869360672,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750377,1853121906,
     *1886545268,1633840229, 544436321,1667575143,1919907184, 544438637,
     *1835365490,2032148512,        -3,1597059635, 538976288, 807411744,
     * 540024864, 538980384, 824197408, 538980640, 807415840, 807411744,
     *        -3,1433299310,1952805488,1919251553,1651270944,1869750345,
     *1852010350,1936290676,1701737504,1399873891,1697466226,1869967392,
     *1231971951, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542341485,1835365490,2032167278, 544499813,
     * 541280582, 544434287,1970037792,1650794608,1919907433,1684366368/
     * )
      ICK( 16501: 16800) = (/
     *1768824948,1751457859,1229332578,1869899808,1702391916,1768122740,
     *1819877495,1769236512,1629495328,        -3, 539451251,2037214565,
     *1953659231,1701934441,1985966191,1935630707,1601730938, 656436335,
     *1869619297,1852055657,1836084329,1667855468,2032170857,1952981024,
     *        -3, 539451251,2037214565,1953659231,1936744803,1700751218,
     *1869967455,1851878757,1598565709, 656437106, 539451251,1885430629,
     *1600615023,1970298734,1634559327,1210928479,1634497575, 773857312,
     *        -3, 542401907,1948280431,1914729838,1768846437,1919971941,
     *1952539244,1696624498, 543780451,1869509481,1937007982,1948283760,
     *1633903904,1735552885,1881172334,1718579821,1635019119,1848516640,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750367,
     *1937337709,1702130297,1600483701,1769365360,1869832033,1935636601,
     *2048946290,1702061422,1948262432,        -3,1597059636, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980640, 807415840,
     * 807411744,        -3,1433299310,1952805488,1919251553,1651270944,
     *1869750350,1864392563,2037214565,1953659231,1701934441,1985966191,
     *1935630707,1601730938, 538976288, 538976288, 538984224,1130915171,
     *1797267488,        -3,        -2, 542341485,1835365490,2032167278,
     * 544499813, 541280582, 544434287,1970037792,1650794608,1919907433,
     *1684366368,1768824948,1751457859,1229332578,1869899808,1702391916,
     *1768122740,1819877495,1769236512,1629495328,        -3, 539451251,
     *2037214565,1953659231,1701934441,1985966191,1935630707,1601730938,
     * 656436335,1869619297,1852055657,1836084329,1667855468,2032170857,
     *1952981024,        -3, 539451251,2037214565,1953659231,1936744803,
     *1700751218,1869967455,1851878757,1598565709, 657334304,        -3,
     * 542401907,1948280431,1914729838,1768846437,1919971941,1952539244,
     *1696624498, 543253107,1701737504,1702391916,1768122740, 544438637,
     *1835365490,2032169573,1668248164,1932402720,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750335, 543126393,1835885940,
     *1920556915,1885430629,1600615023,1970298734,1634559327,1214344300,
     *        -3,1597059637, 538976288, 807411744, 825237536, 540094496,
     * 874531104, 538980640, 807415840, 807411744,        -3,1315905575,
     *1601403245,1835365490,2036298608,1633903967,1735552885,1885302369,
     *1835360072,1634495527, 541550966,1701716014, 774778414, 538976288,
     * 542141541,1634952480,1148133409,        -3,        -2, 542077044,
     *1768910433,1819048224,1936745827,1768323360,1952998688,1214344300,
     * 544438637,1651469358, 542402661, 541614444,1814066041,1835167596,
     * 544240239,1986618469,1931501934,        -3, 544566881,1835166055,
     *1970238835, 543450470,1768843636,1768910368,1868963956,1751457907,
     *1885430629, 761754223,1970282611,2037214565,1953659168,2003330418,
     *1696625768,1696614501,1919770990,1848451104,        -3, 541942133,
     *1735747950, 544438637,1651469344,1818583414,1702043762,1869573408,
     *1718579744,1634497637,1919836532,1769366816,1667788649,1667592992,
     *1868963956,1751457903,1919510377,1848516640,        -3, 541404775,
     * 773875311,1914729328,1633903917,1735552885,1881165874, 824975476,
     *1751457907,1668441463, 543258729,1931503987, 543780384,1734700645,
     *1918987296,1952541541,1847620719, 543387497,1852008804,1696604192,
     *        -3, 544696692,1746957416,1696621101,1635281267, 773867631,
     *2003138149,1915494515,1869440372,1768777075, 543781920,1769152611,
     *1752134501,1847620719, 543319328,1936222566,1952801824,1652105265/
     * )
      ICK( 16801: 17100) = (/
     * 791945248,        -3, 543780384,1952998688,1663918456,1769152612,
     *1769104739,1953066862, 544501536,1651665262,1730178933,1948284008,
     *1696625253,1818326121,1869488247,1769236512,1345466671,1663967316,
     *1751457864,1634495520,        -3, 544438637,1651469427, 544696684,
     *1814061669, 539447328, 846815783, 543256164, 539447328, 846815843,
     * 656437861,1936745827,1953068645,1819880992,        -3,        -2,
     * 542270822,1701978228,1866080339, 777137736,1634495532, 542339169,
     *1667571783,1919907184, 542011252,1635019119,1847621481,1952981089,
     *1847608696,1886153059,1769218127,1919510377,1849368608,        -3,
     * 538976288, 538976288, 538976321,1668571424,1131575667,1949179944,
     * 825833521, 690757697, 859253792, 892417837, 892482862,        -3,
     *        -2, 538976288, 538976367,1916412008,1953787962, 791639927,
     *1999530866,1769174113,1819029093,1953004078,1667772236,1179332467,
     *1868985463,1634886959,1936157038,1718562664,1634495583,1937337698,
     *1869378350,1752460652,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750304,1601403245,1835365490,2036298608,1633903967,
     *1735552885,1885302369,1835360072,1634495520,1701999215,1914708000,
     *        -3,1597059638, 538976288, 807411744, 825237536, 540094496,
     * 824197408, 538980384, 807415840, 824188960,        -3,1165128303,
     *1914726766, 544174624,1433299310,1952805488,1919251553,1651270944,
     *1214344300, 542341485,1651469344, 539897390, 774778414, 539246880,
     *1130915171,1797267488,        -3,        -2, 542402661, 544367984,
     *1869771877,1679837281,1819028851,2037211759,1814063475, 543584117,
     *1852055668,1864393317, 543780384,1701999215,1914728306, 544566889,
     *1853121906,1886545268,1633840229, 773857312,        -3,        -2,
     * 542270822,1701978228,1866080339, 777137736,1634495532, 542339169,
     *1667571783,1919907184, 542011252,1635019119,1847621481,1952981089,
     *1847608696,1886153059,1769218127,1919510377,1849368608,        -3,
     * 538976288, 538976288, 538976321,1668571424,1131575667,1949179944,
     * 825833521, 690757697, 859253792, 892417837, 892482862,        -3,
     * 538976288, 538976367,1916412008,1953787962, 791634787,1764650082,
     *1814980463,1982821223,1768842863, 795369836,1818194809,1835167596,
     *1932421236,1835802656,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750304,1601403245,1835365490,2036298608,1633903967,
     *1735552885,1885302369,1835360072,1634495520,1668247155,1769174117,
     *1852012832,        -3,1597059639, 538976288, 807411744, 825237536,
     * 540094496, 824197408, 538980384, 807415840, 824188960,        -3,
     *1231908972,1768122740, 541614444,1814057849,1835167596, 538986862,
     *1668247155,1769174117,1853104247,1769236512,1165521004,1768122740,
     * 539246880,1130915171,1797267488,        -3,        -2, 542402661,
     * 544367984,1869771877,1679837281,1819028851,2037211759,1814063475,
     * 544108404, 543777893,1853122915,1634476148,1864397928,1696624494,
     *1696622958,1952805486,1634495609, 544498018,1970037108,1701060640,
     *        -3, 543584114, 544499813, 544436321,1667571815,1919907184,
     * 543257376,1684370025,1986356256,1718775661, 544499813, 543520880,
     *1818846057,1953265952,1937076336,1818846564, 544438637,1835365490,
     *2032148512,        -3, 544174181,1918989417,1869509422, 541160224,
     *1634607205,2019650928,1818569760,1952998688,1214344300, 544438637,
     *1651469427, 539438416, 540178798, 656433518,1679828781,1344287353,
     *1633837863, 543321972,1746935840,        -3, 543387506,1919251312/
     * )
      ICK( 17101: 17400) = (/
     *1869505568,2003399784, 544436321,1667571815,1919907184, 539447346,
     * 825191975, 773865836,1952805486,1635019126,1701607724, 544108320,
     *1214344300, 762542445,1651469344,1668248940,1679843941,        -3,
     * 543450482,1769366884, 543324448,1347174740,1330520166,1869750388,
     *1751457893,2020633705,1667855392,1936028704,1868963955,2037214565,
     *1953659168,1869636978,1635019119,1853042208,1416128883, 544039289,
     * 543319328,        -3, 544499813, 543383923,1696626536,1701716065,
     *1847620974,1970500961,1814065010,1768384878, 543781664,1667788659,
     *1701719584,        -3,        -2, 542270822,1701978228,1866080339,
     * 777137736,1634495532, 542339169,1667571783,1919907184, 542011252,
     *1635019119,1847621481,1952981089,1847608696,1886153059,1769218127,
     *1919510377,1849368608,        -3, 538976288, 538976288, 538976321,
     *1668571424,1131575667,1949179944, 825833521, 690757697, 859253792,
     * 892417837, 892482862,        -3, 538976288, 538976367,1916412008,
     *1953787962, 791634787,1764650082,1814980463,1982821223,1768842863,
     * 795369836,1818194809,1835167596,1932421236,1835802656,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750382,1869491571,
     *1952542308,1634886688,1936744803,1700751218,1869967392,1936028788,
     *1768843123,        -3,1597059640, 538976288, 807411744, 825237536,
     * 540094496, 874529056, 538980384, 807415840, 824188960,        -3,
     *1097626725,1919836532,1696617317,1953786222,1730176623,1914718574,
     *1886745632,1399873891,1696614258,1869967396,1092624420,1109413487,
     *1952784416,        -3,        -2, 542126641, 795746401,1852055625,
     * 841965856,1702126382, 544433524,1953066599,1931501938,1696624486,
     *1952804384,1886545254,1701999205,1679847286,1701978192, 842084195,
     * 543256164, 541274671,1663072104,1701716000,        -3, 544499809,
     *1948281957,1633973024,1953439841, 543386735,1936028192,1953439801,
     * 807429221,1735550309,1931502181,1952522337,1852271717, 773857312,
     *        -3, 542340193,1852072306,1679844200,1869177701, 544171552,
     *1869769063,1768824937,1931506799, 543319328,1886545254,1701999205,
     *1680744513, 544108398, 762541153,1852072306,1679847282,1768384878,
     * 543385711,1768121632,        -3, 544041319,1752440930,1696626035,
     *1701213548, 543584114, 543584114, 544499813, 543387501,1885434473,
     *1936682528,1868963954,1701601652,1701060723,1953658211,1953854053,
     *1932402720,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750389,1853191029,1634476142,1869491571,1952542308,1634886688,
     *1399873891,1696622450,1869967392,1851878757,        -3,1597059641,
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1433302387,1969318944,1399873891,
     *1696614258,1869967392,1399874915,1768319333,1679830574, 774778414,
     * 774778414, 774778414, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 542402661, 544367984,1869771877,1679848304,
     *1633903917,1735552885,1881173601,1835343977,1931507054,1970500961,
     *1814962208,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750371,1969383779, 975200544,1025532448,1025532704,        -3,
     *1597059888, 538976288, 807411744, 540024864, 538980384, 824197408,
     * 538980384, 824193056, 807411744,        -3,1131766377,1663056416,
     *1630281826, 539369571, 541354349,1701737321,1869509408,1147758182,
     *1701978158, 774778414, 774778414, 774774816, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 542341485/
     * )
      ICK( 17401: 17700) = (/
     *1835365490,2032165743,1853060210,1634299508,1931505518, 543384940,
     *1814062185,1835363955,1768910451, 543257189, 543385701,1667982692,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750371,1969383779, 975200620,1885888800,1025532517,1952522301,
     * 543646061,1835081789, 540618784,        -3,1597059889, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 824193056,
     * 807411744,        -3,1131766377,1663056416,1634496616,1630281826,
     *1702125856,1634624544,1734438253,1629516648,1869966436, 543319328,
     * 959455300,1701257285,2019648372, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 542341485,1835365490,2032165743,
     *1853060210,1634299508,1931505518, 543384940,1814062185,1835363955,
     *1768910451, 543257189, 543385701,1667982692, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750388,1919510383,
     *1851878447,1751480417,1735356001,1814051360,1629502752,1646272544,
     *        -3,1597059890, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980384, 824193056, 807411744,        -3,1416784231,
     *1869504876, 793273720,1634168686,1634476129, 543256164, 543301700,
     *1768318565,1914711598, 774778414, 774778414, 774778414, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542341485,1835365490,2032165743,1853060210,1634299508,1931505518,
     * 543384940,1814062185,1835363955,1768910451, 543257189, 543385701,
     *1667982692, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750388,1919510383,1851878447,1751480417,1735356001,
     *1814051360,1634496616,1629502752,1650816097, 540876857, 807411744,
     *        -3,1597059891, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980384, 824193056, 807411744,        -3,1416784231,
     *1869504876, 793273720,1634168686,1634476129,1819306081, 543256164,
     * 543319412,1629508456,1869966436, 543319328, 959455300,1701257248,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542341485,1835365490,2032165743,1853060210,1634299508,1931505518,
     * 543384940,1814062185,1835363955,1768910451, 543257189, 543385701,
     *1667982692, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750388,1919510383,1851878447,1751480417,1735356001,
     *1814051360,1734438253,1629502752, 825372704,        -3,1597059892,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980384,
     * 824193056, 807411744,        -3,1416784231,1869504876, 793273720,
     *1634168686,1634476135,1634561377, 542337135,1970037792,1650794545,
     * 842014788,1701257285,2019648372, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542341485,1835365490,
     *2032165743,1853060210,1634299508,1931505518, 543384940,1814062185,
     *1835363955,1768910451, 543257189, 543385701,1667982692, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750388,
     *1702130273,1735356001,1815748705, 540876898,        -3,1597059893,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980384,
     * 824193056, 807411744,        -3,1415935090,1634168686,1634482720,
     *1629512046,1679843872,1399353205,1818501218,1696613745,1969318944,
     * 774778414, 774778414, 774778400, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542341485,1835365490,
     *2032165743,1853060210,1634299508,1931505518, 543384940,1814062185,
     *1835363955,1768910451, 543257189, 543385701,1667982692, 773857312/
     * )
      ICK( 17701: 18000) = (/
     *        -3,        -1, 589315646,1042306149,1936990310,1869750388,
     *1702130273,1735356001,1815748705,1819306081, 540876898,1702125856,
     *1025533793,1835884832,1025521968,        -3,1597059894, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 824193056,
     * 807411744,        -3,1415935090,1634168686,1634482720,1634496616,
     *1630281826,1702125856, 639657825,1835884832,1399353205,1818501218,
     *1696610608, 541353319, 538976288, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 542341485,1835365490,2032165743,
     *1853060210,1634299508,1931505518, 543384940,1814062185,1835363955,
     *1768910451, 543257189, 543385701,1667982692, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750383,1920231535,
     *1919446893,1651073850, 543255664,1751195709, 543319412,1629502752,
     *1734438253,1629502752, 959455264,        -3,1597059895, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 824193056,
     * 807411744,        -3,1332900968,1869768815,1835166051, 975200620,
     *1885888812, 543319412,1629496864,1734438253,1629508456,1869966436,
     * 543319328, 959455300,1701257248, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 542341485,1835365490,2032165743,
     *1853060210,1634299508,1931505518, 543384940,1814062185,1835363955,
     *1768910451, 543257189, 543385701,1667982692, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750381,1869508451,
     *1818848873,1663069551,1919230068,1751215648, 824205678,1735157024,
     *1868981792, 959455332,1701278309,1702043680,        -3,1597059896,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980384,
     * 824193056, 807411744,        -3,1299148399,1668049262,1768110624,
     *1299149413, 544499809,1847619438,1696612718,1735157024,1433298289,
     *1969318944, 959458864, 539897390, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542341485,1835365490,
     *2032165743,1853060210,1634299508,1931505518, 543384940,1814062185,
     *1835363955,1768910451, 543257189, 543385701,1667982692, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750386,
     *1752132962,1869112676,1918987296,1629502752,1646279968,1663049760,
     *        -3,1597059897, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980384, 824193056, 807411744,        -3,1382575981,
     *1651468389,1685217644, 975200556, 543301670, 543367265,1919230062,
     *1869881441,1819025477,2019648372,1819877445,1903518060, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542341485,1835365490,2032165743,1853060210,1634299508,1931505518,
     * 543384940,1814062185,1835363955,1768910451, 543257189, 543385701,
     *1667982692, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750386,1752132962,1869112676,1918987296,1634496616,
     *1629502752,1650816097, 540876903,1634561377,        -3,1597060144,
     * 538976288, 807411744, 540024864, 538980384, 824197408, 538980384,
     * 824193056, 807411744,        -3,1382575981,1651468389,1685217644,
     * 975200620,1885888812, 543319412,1629496864,1734438253,1629512050,
     *1696616047,1948270956,1814054257,1969318944, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542341485,1835365490,
     *2032165743,1853060210,1634299508,1931505518, 543384940,1814062185,
     *1835363955,1768910451, 543257189, 543385701,1667982692, 773857312,
     *        -3,        -1, 590429758,1042314030,1965957231,1847615776/
     * )
      ICK( 18001: 18300) = (/
     * 757096824,1769152627,1835101292, 544174624,1835627379,1768843040,
     *        -3,1597060145, 538976288, 807411744, 825237536, 540094496,
     * 874529056, 538980640, 807415840, 807411744,        -3,1932424494,
     * 544173600,1629498656,1098410355, 542338401,1819025519,1914719593,
     *1936943470,1730162222, 774778414, 774778414, 774778414, 539248160,
     *1097754414,        -3,        -2, 542402661, 544419445, 773877614,
     * 544499813, 543239521,2020176672,1769152627,1835101292, 544174624,
     *1835627379,1768843054, 542402661, 544240229,1936027235,1696624486,
     * 544419445, 774337312, 678914149,1919229984,        -3, 544367985,
     *1969844837,1680416865,1852055670,1634497893, 543257189, 543385701,
     *1667982692, 773870382,1965959027, 543257376,1734964837,1847616121,
     * 544499813, 543451494,1718772067,1953459557,1952805408,        -3,
     * 544436070,1953980786,1696620914,1696624486,1952804384,1836409704,
     * 544435553,1819043186, 544499809,1847620197,1634494835,1953063726,
     *        -3,        -1, 590429758,1042314030,1965957231,1847616032,
     * 757096824,1769152627,1835101292, 544174624,1835627379,1768843040,
     *        -3,1597060146, 538976288, 807411744, 825237536, 540094496,
     * 874529056, 538980640, 807415840, 807411744,        -3,1932424494,
     * 544173600,1646275872,1098410355, 542338401,1819025519,1914719593,
     *1936943470,1730162222, 774778414, 774778414, 774778414, 539248160,
     *1097754414,        -3,        -2, 542402661, 544419445, 773877614,
     * 544499813, 543305057,2020176672,1769152627,1835101292, 544174624,
     *1835627379,1768843054, 542402661, 544240229,1936027235,1696624486,
     * 544419445, 774337312, 678914149,1919229984,        -3, 544367985,
     *1969844837,1680416865,1852055670,1634497893, 543257189, 543385701,
     *1667982692, 773870453, 661856353,1931503465,1986358816,1652105332,
     *1751457892,1768318578,1633907823,1835365477,1914729327,1718908769,
     *1919229984, 543257189, 544171636,1701716077,1969448992,1936548204,
     *1818587680,1952997742, 544367969,1818850164,1768107552,        -3,
     *        -1, 590429758,1042314030,1965957231,1847616288, 757096824,
     *1769152627,1835101292, 544174624,1835627379,1768843040,        -3,
     *1597060147, 538976288, 807411744, 825237536, 540094496, 874529056,
     * 538980640, 807415840, 807411744,        -3,1932424494, 544173600,
     *1663053088,1098410355, 542338401,1819025519,1914719593,1936943470,
     *1730162222, 774778414, 774778414, 774778414, 539248160,1097754414,
     *        -3,        -2, 542402661, 544419445, 773877614, 544499813,
     * 543370593,2020176672,1769152627,1835101292, 544174624,1835627379,
     *1768843054, 542402661, 544240229,1936027235,1696624486, 544419445,
     * 774337312, 678914149,1919229984,        -3, 544367985,1969844837,
     *1680416865,1852055670,1634497893, 543257189, 543385701,1667982692,
     * 773870453, 661856353,1931503465,1986358816,1652105332,1751457892,
     *1768318578,1633907823,1835365477,1914729327,1718908769,1919229984,
     * 543257189, 544171636,1701716077,1969448992,1936548204,1818587680,
     *1952997742, 544367969,1818850164,1768107552,        -3,        -1,
     * 590429758,1042314030,1965957231,1847615852,1885888800,1936548204,
     *1814065010, 544041331,1936289383,        -3,1597060148, 538976288,
     * 807411744, 825237536, 540094496, 874529056, 538980640, 807415840,
     * 807411744,        -3,1932424494, 544173600,1634496616,1629495328,
     * 542338401,1819025519,1914719593,1936943470,1730162222, 774778414,
     * 774778414, 774778414, 539248160,1147496306,1701126176,        -3/
     * )
      ICK( 18301: 18600) = (/
     *        -2, 542402661, 544419445, 773877614, 543255664,1751195753,
     *1931506541,1634495520,1869750381,1769173865,1852255776,1416127776,
     *1886545267,1701733221, 544171552,1932424494, 661856288,        -3,
     * 539522920,1701995808,1919250805,1769104740, 689987950,1679849057,
     *1819632928,1634886944,1667786083,1801806894, 542340391,1931501939,
     * 543648118,1701716066,2032170088,1696621673,1717989985,1668575085,
     *1702126962,        -3, 544436070,1953980786,1696620914,1696624486,
     *1952804384,1836409704, 544435553,1819043186, 544499809,1847620197,
     *1634494835,1953063726,        -3,        -1, 590429758,1042314030,
     *1965957231,1847616101,1952522272,1936548204,1814065010, 544041331,
     *1936289383,        -3,1597060149, 538976288, 807411744, 825237536,
     * 540094496, 874529056, 538980640, 807415840, 807411744,        -3,
     *1932424494, 544173600,1650816097, 538976288, 542338401,1819025519,
     *1914719593,1936943470,1730162222, 774778414, 774778414, 774778414,
     * 539248160,1147496306,1701126176,        -3,        -2, 542402661,
     * 544419445, 773877614, 543319412,1629514099, 544435553,1819025519,
     *1914727785,1936943470,1731076180,1751457904,1919251301,1852007712,
     *1868963955, 779431463,1931487351,1751478885, 544367985,1969844837,
     *1680416800, 543256164, 544629100,1969561697,1919230051,1751475051,
     *1701064224,1400186739, 543257376,1734964837,1847616121, 544499813,
     * 543451494,1718772067,1953459557,1952805408,1936680564,2002874981,
     * 543257189, 544171636,1701716000, 544044387,1746957165,1634495589,
     *1914729576,1634607218,1700883561,1937008995, 773857312,        -3,
     *        -1, 590429758,1042314030,1965957231,1847617377,1835884832,
     *1936548204,1814065010, 544041331,1936289383,        -3,1597060150,
     * 538976288, 807411744, 825237536, 540094496, 874529056, 538980640,
     * 807415840, 807411744,        -3,1932424494, 544173600,1734438253,
     *1629495328, 542338401,1819025519,1914719593,1936943470,1730162222,
     * 774778414, 774778414, 774778414, 539248160,1147496306,1701126176,
     *        -3,        -2, 542402661, 544419445, 773877614, 543646061,
     *1835081833,1931506541,1634495520,1869750381,1769173865,1852255776,
     *1416127776,1886545267,1701733221, 544171552,1932424494, 661856288,
     *        -3, 539522920,1701995808,1919250805,1769104740, 689987950,
     *1679849057,1819632928,1634886944,1667786083,1801806894, 542340391,
     *1931501939, 543648118,1701716066,2032170088,1696621673,1717989985,
     *1668575085,1702126962,        -3, 544436070,1953980786,1696620914,
     *1696624486,1952804384,1836409704, 544435553,1819043186, 544499809,
     *1847620197,1634494835,1953063726,        -3,        -1, 590429758,
     *1042314030,1965957231,1847620473,1835885940,1920540786,1702065266,
     *1768125541,1679844197,1819025505,1852271717,        -3,1597060151,
     * 538976288, 807411744, 825237536, 540094496, 824197408, 538980384,
     * 824193056, 807411744,        -3,1932424494, 544173600,1400466797,
     *1702130297, 541290350,1937011297,1768842596, 541287788,1814053230,
     *1735157032,1932075054, 774778414, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542402661,1919230067,
     *1752135020,1679843941, 544108320,1932424494, 544173600,1937337709,
     *1702130297, 543387502,1937011297,1768842596, 543384940,1814061422,
     *1735157107, 773857312,        -3, 541423713,1836084325, 975195759,
     * 544419445, 773877614, 543255664,1751198752,1650816097, 543256164,
     * 543646061,1835081830,1869750383,1920231535,1919446893,1651073824/
     * )
      ICK( 18601: 18900) = (/
     *1937337709,1702130297, 773857312,        -3,        -1, 590429758,
     *1042314030,1965957231,1847615788,1647059055,1914725152, 757096824,
     *1769152628,1869553772,1634887525,        -3,1597060152, 538976288,
     * 807411744, 825237536, 540094496, 857751840, 538980384, 824193056,
     * 807411744,        -3,1932424494, 544173600,1952998688, 608247853,
     * 541161577,1931503987, 539513967,1864966220,1634887525, 539897390,
     * 773858374, 541159015, 773857312,        -3,        -2, 542402661,
     * 544419445, 773877614, 544499813, 544367984,1869771877,1679830369,
     *2020176672,1769152629,1852143728,1701016677,1684830496,1818325607,
     *1697521696,        -3,        -1, 590429758,1042314030,1965957231,
     *1847615852,1885888812, 543319412,1629515634, 543646061,1835081845,
     *1852404768,1667591276, 543256167,1818587936,1953460000,1818325607,
     *1696604192,        -3,1597060153, 540028465, 807415854, 842014752,
     * 540094496, 857751840, 538980384, 824193056, 807411744,        -3,
     *1932424494, 544173600,1952998688, 608247873,1852271717, 543781664,
     *1416589088,1281454695,1696607790, 774778414, 773858374, 541353319,
     *1919247648,        -3,        -2, 542402661, 544419445, 773877614,
     * 544499813, 544367984,1869771877,1679843694,1735157024,1769152628,
     *1869553772,1634887525, 773857312,        -3,        -1, 590429758,
     *1042301800,1701014304,1919250543,1920230756, 544566889,1948279653,
     *1819025494,1869378925,1696626273,1819632928,1634165097,1853060128,
     *1952998688,1667329123,1970037108,1701060726,1634497893,        -3,
     *1597060400, 540028469, 538976305, 774905888, 825110560, 824197408,
     * 538980640, 807415840, 807411744,        -3,1450142837,1835343969,
     *1931494241,1818457452,1635018084, 541354342,1717924467, 543584879,
     *1830843496,1635000391,1769366894, 539897390, 539248160,1097754462,
     * 857743392,        -3,        -2, 541158944,1095517522,1411410291,
     * 543781747,1969579040,2003330414, 544499813, 544367984,1869771877,
     *1679848814,1769218147,1701604384,1987013749,1835343972,1768318565,
     *1920147571,1768386153,1718182753,1853123705,        -3, 543584879,
     *1830843496,1696626287,1819635045, 543383916,1668639841,1952801824,
     *1869488244,1751457890,1634953587, 544171552,1952998688,1937076336,
     *1818846564, 543384940,1814062185,1835363955,1768910451, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1952998688,
     *1919250543,1920230756, 544419445, 773877614, 544499813, 544566889,
     *1948279653,1819025526,1869378925,1696604192,        -3,1597060401,
     * 538976288, 807411744, 825237536, 540094496, 824197408, 538980640,
     * 807415840, 807411744,        -3,1315905651, 779431456, 677737316,
     * 689981289,1986358816,1869488214,1869378925,1696607790, 774778414,
     * 774778414, 774778414, 774778414, 538976288, 542141541,1634952480,
     *1148133409,        -3,        -2, 541944179,1936289383, 544419445,
     * 773877614, 543384940,1814066799,1819635045, 773857312,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1668247155,
     *1769174117,1852012832,1868963955, 779431456,1869488246,1869378925,
     *1696620910,1679844197,1819025520,1634885997,1702126962,1931485216,
     *        -3,1597060402, 538976288, 824188960, 960045088, 540621088,
     * 824199456, 538980384, 807415840, 807411744,        -3,1416127776,
     *1400205424,1818846564, 543256164, 541286764,1663967318,1869378925,
     *1696625454,1965957188,1768318565,1914724985, 539897390, 539248928,
     *1433299316,1931485216,        -3,        -2, 542338925,1696625519/
     * )
      ICK( 18901: 19200) = (/
     *1718908769,1919230064,1633905505,1734701856,1667329123,1970037108,
     *1696618095,1819635045, 544419445, 774337312,1768842095,1920099683,
     *1953265966, 542402661, 543387506,1919247220,        -3, 543584114,
     *1836412001, 538994287,1914729586,1768123497,1852400428, 544042862,
     *1868786793,1852400416,1634624544,1869771880,1869768815,1835166051,
     * 544438643,1952804211,        -3, 539517537,1936024608,1869488244,
     *1751457904,1919905889,1734440041,1869488239,1713399154,1919906336,
     *1702391922,1702065001,1869490464,1835104544,1650794598,1869966948,
     * 543780410,        -3,        -2, 541928992,1315009124,1701604457,
     * 740311919,1836086644,1701978150, 541288549,1835627380,1920543776,
     * 674314552, 858336288, 925638713, 892156216, 773857312,        -3,
     * 544174624,        -3, 541273632,1198088547,1870029178,2054103141,
     *1680744553,1847600966,1970168929,1835363956,1634497312,1868963907,
     *1920562036,1634495599,1735549296,1752770348, 542336355,1869505568,
     *1164208500,1768910380,        -3, 542079078,1869767712,1433299318,
     *1701999465,1954095184,1919251315, 740307504, 808660000,1882272565,
     * 773857312,        -3,        -2, 541158515,1864396399,1952784500,
     *1751217184,1936029285,1918987296,1667591276, 544235890,1634559348,
     *1701999392,1718579744,1751738216,1701978227,2037214565,1953659168,
     *1667591276,1931501938,1696624239,        -3, 543977326,1734701600,
     *1768842341,1885695588,1701737518, 542322293, 773874529,1818457452,
     *1635019119,1853038702,1701143584,1936745827,1767992352,1953654113,
     *1953326446,1948281198, 544499823,1936007267,1634952563, 773857312,
     *        -1, 589315646,1042314341,1936990310,1869750373,1903518060,
     * 543258729,1634476147, 779431463,1931485216,        -3,1597060403,
     * 538976288, 807411744, 825237536, 540094496, 824199456, 538980384,
     * 807415840, 824188960,        -3,1416127776,1932424494, 661856367,
     *1847620712,1696613221,1819025473,2019914528, 538993010,1696613745,
     *1969318944, 774776910,1869899049, 539248160,1097754414,        -3,
     *        -2, 542402661, 544367984,1869771877,1679844197,1819025505,
     *2019914528,1932424494, 661856353,1919230066,1701867378,1952801824,
     *1701934433,1814962256,1818583411,1696621416,1701014304,2003330420,
     *1751478816,        -3, 544499817,1931503987, 543387506,1919247220,
     * 544174624,1629516655,1718908769,1919230052,1701208437,1819549814,
     *1634497893, 773857312,        -3,        -1, 589315646,1042314341,
     *1936990310,1869750373,1903518060, 543384940,1814061422,1735157024,
     *1932424494, 661856288,        -3,1597060404, 538976288, 807411744,
     * 825237536, 540094496, 824199456, 538980384, 807415840, 824188960,
     *        -3,1416127776,1932424494, 661856367,1847620712,1696613221,
     *1819025473,1852271717,1931501938,1696613745,1969318944, 774776910,
     *1869899049, 539248160,1147496306,1701126176,        -3,        -2,
     * 542402661, 544367984,1869771877,1679844197,1819025505,1852271717,
     * 544419445, 774337312,1634886944,1919250543,1920230756, 543519093,
     *1634479648,1349281121,1936007267,1751475051, 544696421,1952998770,
     *        -3, 544499817,1931503987, 543387506,1919247220, 544174624,
     *1629516655,1718908769,1919230052,1701208437,1819549814,1634497893,
     * 773857312,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1919247477,1667589152,1667591276, 543248416,        -3,
     *1597060405, 538976288, 807411744, 825237536, 540094496, 874529056,
     * 538980384, 807415840, 824188960,        -3,1416127776,1416784227/
     * )
      ICK( 19201: 19500) = (/
     *1818848873,1663063406,1769218115,1701604384,1769152590,1330913362,
     *1701082467,1701060654, 774778414, 774778414, 538976288, 542141541,
     *1634952480,1148133409,        -3,        -2, 542469740,1702064928,
     *1718579744,1936745827,1767992352,1919246707,1869509408,1919249505,
     *1952801824,1953439860,1751457907,1953658211,1953854053, 795045742,
     *1952804468, 740319520,1970170228, 543384940,1814061422,1679826976,
     * 544437362,1969452149,1919230057,1931502181,1936990322,1701867378,
     *1952801824,2003399784, 544367974,1701995886,1667571828,1864397928,
     *1696616041,1734831209, 542270820,1969448292, 541287788,1814962260,
     *1751741216,        -3, 541150277,1381245037,1635328111,1919510377,
     *1851880549, 543255667,1864394354,1869422689, 543580521,1819636325,
     * 544501536,1869767781,1914729576,1696620920,1702043750,1919905056,
     *1936548204,1814066287, 543973746,1734680608, 543451501,1701737321,
     *1869491744,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1852796461,1937006958,1684107876, 543258729,1634476143,
     *1919182194,        -3,1597060406, 538976288, 807411744, 825237536,
     * 540094496, 874529056, 538980384, 807415840, 824188960,        -3,
     *1098410337,1814057849,1937007981, 541683312,1970544707,1701604384,
     *1852797984,1400136046,1684107876, 539897390, 774778414, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542402661, 543258729,1634476143,1919182194, 544434287,1970037792,
     *1650794598,1919905056,1936548204,1814066287, 543973746,1734680681,
     *1847620712,1696625778,1768123497,1852400416,1667591276, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1852796461,1937006958,1684107876, 544042862,1868786793,1852400416,
     *1650816097, 543256167,1818566716, 540618784,1147496306,1701147438,
     *        -3,1597060407, 538980398, 807411761, 808329248, 825241120,
     * 874529056, 538980384, 807415840, 824188960,        -3,1315925549,
     *1937006958,1684107876, 541945710,1868786793,1852400416,1113945185,
     * 541159015,1818566764,1702064928, 959455300,1701257248, 539248160,
     *1147496306,1701126176,        -3,        -2, 541227296,1668247158,
     *1701737577,1869491232,1952998688,1299148399,1668049262,1768104034,
     *1702125856,1634625388,1696622963, 543255671,1635349280,1667788659,
     *1701716084,1864393317, 543973746,1734701600,1952997742,        -3,
     * 540618798, 807421029,1735550309,1932402753, 544502377,1986617708,
     * 544502369,1853056623,1919770996,1768910368, 674308144, 540028720,
     * 539832608, 808398880, 807415089, 689992552,1869966436, 543319328,
     *        -3, 543256688,1818846564, 544501536,1952998688,1684108385,
     * 773857312,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1937006958,1684107876, 544367972,1969448292, 543384940,
     *1814044704,        -3,1597060408, 538976288, 807411744, 825237536,
     * 540094496, 874529056, 538980384, 807415840, 824188960,        -3,
     *1416127776,1231974517,1948276078,1769218115,1701604384,1769152590,
     *1330913363,1952542308,1634886703,1382376565,1667589152, 774778414,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542469740,1702064928,1718579744,1936745827,1767992352,
     *1919246707,1869509408,1919249505,1952801824,1953439860,1751457907,
     *1953658211,1953854053, 795045742,1952804468, 740319520,1970170228,
     * 543384940,1814061422,1679826976, 544437362,1969452149,1919230057,
     *1931502181,1936990322,1701867378,1952801824,2003399784, 544367974/
     * )
      ICK( 19501: 19800) = (/
     *1701995886,1667571828,1864397928,1696616041,1734831209, 542270820,
     *1969448292, 541287788,1814962208,        -3,        -1, 589315646,
     *1042301800,1701014304,1650816097, 761359975,1818566774,1634497893,
     * 543584114, 544042862,1868786793,1852400416,1663049760,        -3,
     *1597060409, 538976288, 807411744, 540024864, 538980384, 824197408,
     * 538980384, 824193056, 807411744,        -3,1416127776,1113945185,
     * 541159015,1818566724,1702259041,1952805664,1718775661, 540618784,
     *1718579744,1299148399,1668049262,1768107363, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 542076524,
     *2032170088,1696614241,1835884832,1634625388,1696623969,2032167009,
     *1986338913, 544629100,1969561710,1869881445,1903518060, 544501536,
     * 959455332,1701278309,1702047264,        -3,        -1, 589315646,
     *1042304361,1936943470,1730181165,1668247410,1684631137,1952784499,
     * 779431456,        -3,1597060657, 538976288, 807411744, 825237536,
     * 540094496, 874529056, 538980384, 807415840, 824188960,        -3,
     *1298756467,1768843040,1869750362,1701998368,1932424494, 539518323,
     *1680416879,1847621677,1668247410,1684631137,1952784486,1869750318,
     * 538977345, 541288549,1667964960,        -3,        -2, 541944179,
     *1936289383, 544174624,1516597871, 544419445, 773859429,1935943968,
     *1869488248, 761491311,1919183214,1635018030,        -3,        -2,
     * 542142323,1769236847,1851878432,1885434465,1835365477,1920147558,
     *1869750369,1819025518,1869491560,2036626031,1734700576,1635020653,
     *1931503982, 543647086,1701994860, 544239475,1769236847,1853038689,
     *1919229984,        -3, 543385701,1667982692, 543584114, 544499813,
     * 544240229,1936027235,1696624486, 543236206,1869491578,1701998368,
     *1932424494, 544173600,1952998765, 773870696,1769152617,1852009589,
     *1684370208,        -3, 544235890,1634559348,1701999392,1718188133,
     *1679848559, 543582584, 544499813, 544174697,1734962720,1768824944,
     *1869373810, 544436321,1667575143,1919907184,1931507560,1768122400,
     *1769152622,1864395887,1852269938,        -3, 544105827,1702064993,
     *1920540791,1751477792,1919247977,1852140901,1853104233,1931502703,
     *1852121207,1769236512,1836016741,1919819888,1919903602,1634562848,
     * 677719655, 773870408,1162631244, 740317268,1095510318,        -3,
     *        -1, 589315646,1042304361,1936943470,1730181421,1668247410,
     *1684631137,1952784499, 779431456,        -3,1597060658, 538976288,
     * 807411744, 825237536, 540094496, 874529056, 538980384, 807415840,
     * 824188960,        -3,1298756467,1768843040,1869750362,1701998368,
     *1932424494, 539518323,1680416879,1847621933,1668247410,1684631137,
     *1952784486,1869750318, 538977345, 541288549,1667964960,        -3,
     *        -2, 541944179,1936289383, 544174624,1516597871, 544419445,
     * 773859429,1935943968,1869488249, 761491311,1919183214,1635018030,
     *        -3,        -2, 542142323,1769236847,1851878432,1885434465,
     *1835365477,1920147558,1869750369,1819025518,1869491560,2036626031,
     *1734700576,1635020653,1931503982, 543647086,1701994860, 544239475,
     *1769236847,1853038689,1919229984,        -3, 543385701,1667982692,
     * 543584114, 544499813, 544240229,1936027235,1696624486, 543236206,
     *1869491578,1701998368,1932424494, 544173600,1952998765, 773870696,
     *1769152617,1852009589,1684370208,        -3, 544235890,1634559348,
     *1701999392,1718188133,1679848559, 543582584, 544499813, 544174697,
     *1734962720,1768824944,1869373810, 544436321,1667575143,1919907184/
     * )
      ICK( 19801: 20100) = (/
     *1931487333, 778513952,1345466665, 544696425,1667768352,        -3,
     * 543781664,1852776556,1869506405,1914728037,1667593075,1634892064,
     *2003330414, 544367974,1768842605,1701737504,1769152612,1869505824,
     *2003399784, 544042852,1701998112,1886547815,1918987635,        -3,
     * 539518254,1731076179,1212501080,1277960280,1413565481, 773857312,
     *        -3,        -1, 589315646,1042304361,1936943470,1730181677,
     *1668247410,1684631137,1952784499, 779431456,        -3,1597060659,
     * 538976288, 807411744, 825237536, 540094496, 874529056, 538980384,
     * 807415840, 824188960,        -3,1298756467,1768843040,1869750362,
     *1701998368,1932424494, 539518323,1680416879,1847622189,1668247410,
     *1684631137,1952784486,1869750318, 538977345, 541288549,1667964960,
     *        -3,        -2, 541944179,1936289383, 544174624,1516597871,
     * 544419445, 773859429,1935943968,1869488250, 761491311,1919183214,
     *1635018030,        -3,        -2, 542142323,1769236847,1851878432,
     *1885434465,1835365477,1920147558,1869750369,1819025518,1869491560,
     *2036626031,1734700576,1635020653,1931503982, 543647086,1701994860,
     * 544239475,1769236847,1853038689,1919229984,        -3, 543385701,
     *1667982692, 543584114, 544499813, 544240229,1936027235,1696624486,
     * 543236206,1869491578,1701998368,1932424494, 544173600,1952998765,
     * 773870696,1769152617,1852009589,1684370208,        -3, 544235890,
     *1634559348,1701999392,1718188133,1679848559, 543582584, 544499813,
     * 544174697,1734962720,1768824944,1869373810, 544436321,1667575143,
     *1919907184,1931487333, 778513952,1345597737, 544696425,1667768352,
     *        -3, 543781664,1852776556,1869506405,1914728037,1667593075,
     *1634892064,2003330414, 544367974,1768842605,1701737504,1769152612,
     *1869505824,2003399784, 544042852,1701998112,1886547815,1918987635,
     *        -3, 539518254,1731076179,1212501080,1277960280,1413565481,
     * 773857312,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1919247977,1852138528,1127041056,1210933620,1869443872,
     *        -3,1597060660, 538976288, 807411744, 825237536, 540094496,
     * 874529056, 538980384, 807416096, 807411744,        -3,1316105760,
     *1868963922,1701210478,1701060675, 759701576, 759264367,1836261481,
     *1847609445,1635154221,1098149741, 542340210,1969452078, 539248928,
     *1315927141,        -3,        -2, 542597490,1852403303, 975196773,
     *1718185573,1679835949,1210075181,1635020653,1931503982, 543712609,
     *1987652961,1953459488,1937011317,1668576626,1696606313, 778382880,
     *1668247156,1634299497,1852252257,1847599136,        -3, 543517797,
     *1835363956, 543319417,1869505568,1701602669,1701737504, 590428201,
     * 773870453,1667768392, 761361519,1836261473,1919230057,1847617381,
     *1852142177,1814061669,1953785202, 544367974,1768842596,        -3,
     * 543257632,1667329123,1970037108,1701060720,1869834612,1768910451,
     * 544368996,1768843040,1869488244,1751457889,1953459571, 544499813,
     *2032165234,1696620916,1952539496,1701060724,1865293889,        -3,
     * 543319412,1952805408,1684108385, 544175717,1914728545,1918987621,
     *1952805408,1918989417,1864398697,1819025506,1696620899,1751737718,
     *1701064224,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1378707052,1634166629,1679847023,1848461357,1635020653,
     *1931485216,        -3,1597060661, 538976288, 807411744, 825237536,
     * 540094496, 857751840, 538980384, 807415840, 824188960,        -3,
     *1316105760,1868963923,1952543861,1931498029,1181507943,1734698016/
     * )
      ICK( 20101: 20400) = (/
     *1315925549,1215915122,1869047150, 541160559,1836261422, 774778414,
     * 539248928,1315927141,        -3,        -2, 542270832,1869771808,
     *1869488242,1702065266,1634299493,1679829106,1768188270,1730748494,
     *1869491528,2036626031,1734700576,1635020653,1932402766,1869899066,
     * 542402665,1931504993,2032168037,1633951860,1864376352,        -3,
     * 544108398, 544040289,1852403303,1718971424,1651469924, 543256164,
     * 543256167,1818566771, 779431463,1931487297,1279611476,1394630455,
     * 892415008,1597453618, 690888736,        -3, 542256486,1818322791,
     *1701060705,1953459571, 544039289, 543257193,1936007285,1852403316,
     *1701737577,1869504876, 543319401,1852252259,1635087205,1679843961,
     * 543256096, 574703177,1478504482, 543975790,1696604192,        -3,
     * 543319401,1852252269,1769173865,1852252265,1847615776,1936221548,
     *2020355689,1853038694,1768711456, 676546629,1280855085, 959914098,
     *1701210478,1701668206,1948855840,        -3, 541158516,1701998177,
     *1953068645,1819880480,1952998688,1853189474,1701978223,1713402469,
     *1718185573,1679847521,1918987621,1952805491, 544039289, 543711606,
     *1696621157,1701716076,1768778100,1701060640,        -3, 543450476,
     *1768056178,1635018092,2032150629, 778513952,1652105330,1701210478,
     *1701668206,1948282726, 541273414, 544696692,1746953833,2019910688,
     *1802399607,1847617381,1869440372,1920543776,        -3, 544434541,
     *1768710514, 544501536,1127041065, 543780384,1869767781,1914729583,
     * 543909221,1881175144,1696621665,1952526192,1634885997,1702126962,
     * 544366964,1768890465,1667458416,1952539244,1697521696,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1667329123,
     * 543583329,1734829412, 543257711,1836261495,1769236512,1932424494,
     * 661856367,1847616367,1869767785,1851880549,1931485216,        -3,
     *1597060662, 538976288, 807411744, 825237536, 540094496, 874529056,
     * 538980384, 807415840, 824188960,        -3,1395545383,1931495273,
     *1986358816,1869488195,1869574756,1768841588,1702043750,1869750339,
     *1634493229,1718378855,1734698016, 774778414, 538977345, 542011252,
     *1696604192,        -3,        -2, 541286764,1663919724,1634166629,
     *1679843700,1869443872,1634886944,1852797984,1937076336,1869833572,
     * 544501536,1667330674,2032169774,1965959027, 544173600,1952998761,
     *1914725231,1869767785,1851880549,1932402720,        -3,        -1,
     * 589315646,1042306149,1936990276,1095649056,1919251316,1918986606,
     *1948284513,1819632928,1768824899,1229335909,1835165028,1684366368,
     * 779249011, 543582572,1696604192,        -3,1597060663, 538976288,
     * 807411744, 540024864, 538980384, 857751840, 538980384, 807416096,
     * 807411744,        -3,1092636271,1848468581,1717663084,1948271681,
     *1313284178,1702065266,1634299508, 542531948,1969561704,1634934882,
     *1701146144,1970496868, 539248160,1382379631,1920213024,        -3,
     *        -2, 542328901,1280855072,1634758764,1768256288,1629512805,
     *1717663084,1948280166,1717920628,1769366816,1937006958,1684107876,
     * 543450486,1767994473,1869488246,1634497893, 544171552, 808333364,
     * 541159015, 543584114,        -3, 544499813, 541344078,1193308773,
     *1937011297,1768846451, 773870696,1696626035,1696624486, 543236205,
     *1969448992,1937011311,1852269938, 544367987,1953653097,1853107232,
     *2003399784, 543236204,1870095730,        -3, 544629100,1969561711,
     *1713402984,1869833504,1885434465,1835365477,1920150560,1835104544,
     *1751737445, 544433522,1768912243, 544240239,1651271021,1931507561/
     * )
      ICK( 20401: 20700) = (/
     *1952981089, 544437362,1969452149,1919233568,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1163417946, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597060664, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1163417946, 542270819,
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1163417946, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539914853,1931503209,
     *1818566771,1752135020,1679843941, 543453027,1970103662,1952801824,
     *1768824948,1751457824, 543520880,1701996909,1701737569,1814066021,
     *1668573551,1847619430, 544499813, 543257459,1868786017,1952801824,
     *1886741100,1768120692,1768910382,        -3,        -1, 589315646,
     *1042301800,1701014304,1718579744,1095125336, 540090482,1701015410,
     *1680372521, 543780384,1128875565,1701667429,1684301156, 539914853,
     *1931503209,1818566688,        -3,1597060665, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1095125336, 540090450,
     *1701012595, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552, 658589257,1478504743, 544367971,
     *1869767720,1932075113,1847620712,1696617288,1162631244, 539438706,
     *1702045472,1718185061, 544434287,1970037792,1650794596,1868789101,
     *1701737573,1679826976, 543780384,1952998688,1702391909,1919511909,
     *1853120876, 544433507,1953066862, 544171552,1952998688,1634956143,
     *1667850612,1701060720,1969384553,1667331177,1869491744,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1937073766,
     *1768122725,1853104228,1635016992,1768824948,1751457889,1953459488,
     *1684108385, 543977327,1881153568,        -3,1597060912, 538976288,
     * 807411744, 540024864, 538980384, 874529056, 538980384, 807415840,
     * 824188960,        -3,1231975285,1717987683,1768255092, 541352308,
     *1629514094, 541290351,1919183214,1635018016,1282371440, 539897390,
     * 774778414, 774778414, 538977345,        -3,        -2, 541683315,
     *1969645161,1667851630,1948279905,1952522341,1852010357,1853121906,
     *1701060713,1847620712,1696621423,1869767785,1851880549, 543977327,
     *1882071105, 544239475,1936286316,1696621409,1970496800,1835624296,
     *1948262432, 543319328,1952998688,1970496800,1868963937, 542328901,
     *1280843891,1954114661, 539442471, 543387502,1953066613,1635019119,
     *1847618665,1852124704,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1161905232, 544367971,1869767720,1932075113,
     *1847608137,1177380205,1650812004,1701060654,1919251232,1718185061,
     *        -3,1597060913, 538976288, 807411744, 540024864, 538980384,
     * 874529056, 538980384, 807415840, 824188960,        -3,1416127776,
     *1128875565,1164796517,1684301156, 539914853,1931495017,1818566723,
     *1869509729,1768846112,1161905232, 542270819,1869767795, 539248928,
     *1382379631,1920213024,        -3,        -2, 542402661, 544568165,
     * 544171552,1161905232, 544367971,1869767720,1932075113,1847620712,
     *1696617288,1162631244, 539438706,1702045472,1718185061, 544434287,
     *1970037792,1650794596,1868789101,1701737573,1679845742,        -3/
     * )
      ICK( 20701: 21000) = (/
     * 544499813, 543520880,1701996909,1701737569,1814066021,1668573551,
     *1847619430, 544499813, 543257459,1868786017,1952801824,1886741100,
     *1768120692,1768910382,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1145456984, 544367971,1869767720,1932075113,
     *1847608137,1177380205,1650812004,1701060654,1919251232,1718185061,
     *        -3,1597060914, 538976288, 807411744, 540024864, 538980384,
     * 874529056, 538980384, 807415840, 824188960,        -3,1416127776,
     *1128875565,1164796517,1684301156, 539914853,1931495017,1818566723,
     *1869509729,1768846112,1145456984, 542270819,1869767795, 539248928,
     *1382379631,1920213024,        -3,        -2, 542402661, 544568165,
     * 544171552,1145456984, 544367971,1869767720,1932075113,1847620712,
     *1696617288,1162631244, 539438706,1702045472,1718185061, 544434287,
     *1970037792,1650794596,1868789101,1701737573,1679845742,        -3,
     * 544499813, 543520880,1701996909,1701737569,1814066021,1668573551,
     *1847619430, 544499813, 543257459,1868786017,1952801824,1886741100,
     *1768120692,1768910382, 542402661, 543257459,1868786017,1952801824,
     *        -3, 543647087,1835365490,2032165989,1952541036,1931504993,
     *2032165477, 543974771,1931503982,1718579821,1635019126,1697521696,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1145130567, 544367971,1869767720,1932075113,1847608137,1177380205,
     *1650812004,1701060654,1919251232,1718185061,        -3,1597060915,
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1416127776,1128875565,1164796517,
     *1684301156, 539914853,1931495017,1818566723,1869509729,1768846112,
     *1145130567, 542270819,1869767795, 539248928,1382379631,1920213024,
     *        -3,        -2, 542402661, 544568165, 544171552,1145130567,
     * 544367971,1869767720,1932075113,1847620712,1696617288,1162631244,
     * 539438706,1702045472,1718185061, 544434287,1970037792,1650794596,
     *1868789101,1701737573,1679845742,        -3, 544499813, 543520880,
     *1701996909,1701737569,1814066021,1668573551,1847619430, 544499813,
     * 543257459,1868786017,1952801824,1886741100,1768120692,1768910382,
     * 542402661, 543257459,1868786017,1952801824,        -3, 543647087,
     *1835365490,2032165989,1952541036,1931504993,2032165477, 543974771,
     *1931503982,1718579821,1635019126,1697521696,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1179402580, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597060916, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1179402580, 542270819,
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1179402580, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539438706,1702045472,
     *1718185061, 544434287,1970037792,1650794596,1868789101,1701737573,
     *1679845742,        -3, 544499813, 543520880,1701996909,1701737569,
     *1814066021,1668573551,1847619430, 544499813, 543257459,1868786017,
     *1952801824,1886741100,1768120692,1768910382, 542402661, 543257459,
     *1868786017,1952801824,        -3, 543647087,1835365490,2032165989,
     *1952541036,1931504993,2032165477, 543974771,1931503982,1718579821,
     *1635019126,1697521696,        -3,        -1, 589315646,1042301800/
     * )
      ICK( 21001: 21300) = (/
     *1701014304,1718579744,1396788549, 544367971,1869767720,1932075113,
     *1847608137,1177380205,1650812004,1701060654,1919251232,1718185061,
     *        -3,1597060917, 538976288, 807411744, 540024864, 538980384,
     * 874529056, 538980384, 807415840, 824188960,        -3,1416127776,
     *1128875565,1164796517,1684301156, 539914853,1931495017,1818566723,
     *1869509729,1768846112,1396788549, 542270819,1869767795, 539248928,
     *1382379631,1920213024,        -3,        -2, 542402661, 544568165,
     * 544171552,1396788549, 544367971,1869767720,1932075113,1847620712,
     *1696617288,1162631244, 539438706,1702045472,1718185061, 544434287,
     *1970037792,1650794596,1868789101,1701737573,1679845742,        -3,
     * 544499813, 543520880,1701996909,1701737569,1814066021,1668573551,
     *1847619430, 544499813, 543257459,1868786017,1952801824,1886741100,
     *1768120692,1768910382, 542402661, 543257459,1868786017,1952801824,
     *        -3, 543647087,1835365490,2032165989,1952541036,1931504993,
     *2032165477, 543974771,1931503982,1718579821,1635019126,1697521696,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1396786249, 544367971,1869767720,1932075113,1847608137,1177380205,
     *1650812004,1701060654,1919251232,1718185061,        -3,1597060918,
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1416127776,1128875565,1164796517,
     *1684301156, 539914853,1931495017,1818566723,1869509729,1768846112,
     *1396786249, 542270819,1869767795, 539248928,1382379631,1920213024,
     *        -3,        -2, 542402661, 544568165, 544171552,1396786249,
     * 544367971,1869767720,1932075113,1847620712,1696617288,1162631244,
     * 539438706,1702045472,1718185061, 544434287,1970037792,1650794596,
     *1868789101,1701737573,1679845742,        -3, 544499813, 543520880,
     *1701996909,1701737569,1814066021,1668573551,1847619430, 544499813,
     * 543257459,1868786017,1952801824,1886741100,1768120692,1768910382,
     * 542402661, 543257459,1868786017,1952801824,        -3, 543647087,
     *1835365490,2032165989,1952541036,1931504993,2032165477, 543974771,
     *1931503982,1718579821,1635019126,1697521696,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1145392213, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597060919, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1145392213, 542270819,
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1145392213, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539438706,1702045472,
     *1718185061, 544434287,1970037792,1650794596,1868789101,1701737573,
     *1679845742,        -3, 544499813, 543520880,1701996909,1701737569,
     *1814066021,1668573551,1847619430, 544499813, 543257459,1868786017,
     *1952801824,1886741100,1768120692,1768910382,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1397312853, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597060920, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1397312853, 542270819/
     * )
      ICK( 21301: 21600) = (/
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1397312853, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539438706,1702045472,
     *1718185061, 544434287,1970037792,1650794596,1868789101,1701737573,
     *1679845742,        -3, 544499813, 543520880,1701996909,1701737569,
     *1814066021,1668573551,1847619430, 544499813, 543257459,1868786017,
     *1952801824,1886741100,1768120692,1768910382,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1128810838, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597060921, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1128810838, 542270819,
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1128810838, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539438706,1702045472,
     *1718185061, 544434287,1970037792,1650794596,1868789101,1701737573,
     *1679845742,        -3, 544499813, 543520880,1701996909,1701737569,
     *1814066021,1668573551,1847619430, 544499813, 543257459,1868786017,
     *1952801824,1886741100,1768120692,1768910382,        -3,        -1,
     * 589315646,1042301800,1701014304,1919907182,1684631143, 544171552,
     *1667591276, 543258725,1931501934,1679843694,1735157107,        -3,
     *1597061168, 538976288, 807411744, 540024864, 538980384, 874531104,
     * 538980384, 824193056, 807411744,        -3,1130915171,1797276517,
     *1819025490,1869966948,1768843066, 539172975,1713395297,1819633011,
     * 541421156,1768843040,2003399784, 540024893, 539248928,1315927141,
     *        -3,        -2, 541684768,1769152629,1853191029,1634476148,
     *1751217184,1836020325, 543384940,1814065249,1918987621,1952805491,
     * 543518308, 544696692,1746952480,2053468783, 543256164, 544499813,
     * 544419445, 773876083, 540094510,        -3, 542402665,1931505778,
     *1868721253,1830841705,1734898720,1650794595,1635087205,1679843961,
     * 544499813, 544436325,1667851881,1667331177,1869488239,1713400174,
     *1937073766,1768122725,1853104160,        -3, 539454821,1634625902,
     *1734767980, 656434281,1734964339, 543257376,1668246896,1634887012,
     * 544501536,1952998688,1919250543,1920230756, 544419445, 773857312,
     *        -3, 542336357, 543255667,1866080343, 776170597,1734814752,
     *1097036897, 541291129,1936993824, 674377776, 858333253, 892939296,
     *1697787237, 892215328,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1634495520,1634625388,1702043749,2019648372,
     *1819877433, 807429221,1735550309,1931503982, 544042862,1868786793,
     *1852400416,        -3,1597061169, 538976288, 807411744, 540024864,
     * 538980896, 824197408, 538980640, 807415840, 807411744,        -3,
     *1097624608,1097754476,1702043717,2019648372,1819877433, 807421029,
     *1735550309,1931503982, 541945710,1868786793,1852400416,1130720364,
     * 538976288, 542141541,1634952480,1130915171,1797267488,        -3,
     *        -2, 542076517, 544171552,1952998688,1634625388,1702043753,
     *1847615776,1836019311,1668049262,1768104035,1701604384,1769152613,
     *2020631907,1952801824,1953439842,1696624239,1948280184,1633907820,
     *2032154928,        -3, 543450471,1919247731, 773857312,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1635000428/
     * )
      ICK( 21601: 21900) = (/
     *1700885364, 544173669, 544419445, 773875570,1700885605,1914729576,
     *1634607226,1701998368,1768824941,1869508451,1818848873,1663049760,
     *        -3,1597061170, 538976288, 807411744, 540024864, 538980896,
     * 824197408, 538980640, 807415840, 807411744,        -3,1097624608,
     *1097754476,1702043767,1769236512,2053468783, 544419445, 773876078,
     * 541945710,1868786793,1852400416,1130720364, 539897390, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542076517, 543256167,1818566771,1752135020,1679845473,1986338913,
     *1847620398,1965957223,1919246708,1701978228,1751215648,2053468783,
     * 543780384,1629515119,1852793708,1768843619, 543384940,1814962208,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1600349548,1818193253,1634956658,1701668206,1952412261,1718382195,
     *1601532773,1679849057,1819632928,1919250543,1920230756,        -3,
     *1597061171, 538976288, 807411744, 540024864, 538980384, 824197408,
     * 538980640, 807415840, 807411744,        -3,1298756467,1768843040,
     *1600349548,1818193253,1634956658,1701668206,1952412261,1718382195,
     *1601532773,1679840865,1819632928, 774778414, 538976288, 542141541,
     *1634952480,1148133409,        -3,        -2, 542141541,1634952480,
     *1937076336,1819877492,1751457910,1634497893, 543584114, 539451235,
     *1701604447,1835360627,1970431341,1701737567,1919247980,1853054837,
     *1936024615, 773857312,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1600349548,1818193253,1634956658,1701668206,
     *1952412776,1702125919,1835626016,1986096245,1696625253,1886351988,
     *1701060640,        -3,1597061172, 538976288, 807411744, 540024864,
     * 538980384, 824197408, 538980640, 807415840, 807411744,        -3,
     *1298756467,1768843040,1600349548,1818193253,1634956658,1701668206,
     *1952412776,1702125919,1835626016, 538990177,1819632928, 774778414,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542141541,1634952480,1937076336,1819877492,1751457910,1634497893,
     * 543584114, 539451235,1701604447,1835360627,1970431341,1701737567,
     *1952998772,1633643881,1848061472,        -3,        -1, 589315646,
     *1042301800,1701014304,1718579744,1600349548,1818193253,1634956658,
     *1701668206,1952412776,1702125919,1835104288,1986096245,1696625253,
     *1886351988,1701060640,        -3,1597061173, 538976288, 807411744,
     * 540024864, 538980384, 824197408, 538980640, 807415840, 807411744,
     *        -3,1298756467,1768843040,1600349548,1818193253,1634956658,
     *1701668206,1952412776,1702125919,1835104288, 538990177,1819632928,
     * 774778414, 538976288, 542141541,1634952480,1148133409,        -3,
     *        -2, 542141541,1634952480,1937076336,1819877492,1751457910,
     *1634497893, 543584114, 543122277,1819041645,1700885365,1919249765,
     *1853120372,1751479393,1601003896, 773857312,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1230196562, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597061174, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1230196562, 542270819,
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1230196562, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539438706,1702045472/
     * )
      ICK( 21901: 22200) = (/
     *1718185061, 544434287,1970037792,1650794596,1868789101,1701737573,
     *1679845742,        -3, 544499813, 543520880,1701996909,1701737569,
     *1814066021,1668573551,1847619430, 544499813, 543257459,1868786017,
     *1952801824,1886741100,1768120692,1768910382,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1380534101, 544367971,
     *1869767720,1932075113,1847608137,1177380205,1650812004,1701060654,
     *1919251232,1718185061,        -3,1597061175, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875565,1164796517,1684301156, 539914853,
     *1931495017,1818566723,1869509729,1768846112,1380534101, 542270819,
     *1869767795, 539248928,1382379631,1920213024,        -3,        -2,
     * 542402661, 544568165, 544171552,1380534101, 544367971,1869767720,
     *1932075113,1847620712,1696617288,1162631244, 539438706,1702045472,
     *1718185061, 544434287,1970037792,1650794596,1868789101,1701737573,
     *1679845742,        -3, 544499813, 543520880,1701996909,1701737569,
     *1814066021,1668573551,1847619430, 544499813, 543257459,1868786017,
     *1952801824,1886741100,1768120692,1768910382,        -3,        -1,
     * 589315646,1042306149,1936990291,1229804832,1919251316,1918986606,
     *1948284513,1819632928,1768824899,1229335909,1835165028,1684366368,
     * 779249011, 543582572,1696604192,        -3,1597061176, 538976288,
     * 807411744, 540024864, 538980384, 857751840, 538980384, 807415840,
     * 824188960,        -3,1092636271,1848468581,1717663084,1948275529,
     *1297424466,1702065266,1634299508, 542531948,1969561704,1634934882,
     *1701146144,1970496868, 539248160,1382379631,1920213024,        -3,
     *        -2, 542328901,1280855072,1634758764,1768256288,1629512805,
     *1717663084,1948280166,1717920628,1769366816,1937006958,1684107876,
     * 543450486,1767994473,1869488246,1634497893, 544171552, 808333364,
     * 543584114, 544499813,        -3, 542329165,1428189797,1937011297,
     *1768846382, 542402661, 544568165, 544171552,1629515125,1667768435,
     *1953656686,1734701600,1919251316,1918986606,1948284777,1952981089,
     * 543977335,1701978230,1634497893, 544171552,        -3, 544499809,
     *1948282977,1918987621,1952805408,1835104544,1751737445, 544433522,
     *1768912243, 544240239,1651271021,1931507561,1952981089, 544437362,
     *1969452149,1919230067,1969448992,1634934903,1919905383, 543257711,
     *1830821920, 544504176,1696620915,1936287598,1835363956,1932402720,
     *        -3,        -1, 589315646,1042306149,1936990291,1095583008,
     *1919251316,1918986606,1948284513,1819632928,1768824899,1229335909,
     *1835165028,1684366368, 779249011, 543582572,1696604192,        -3,
     *1597061177, 538976288, 807411744, 540024864, 538980384, 857751840,
     * 538980384, 807416096, 807411744,        -3,1092636271,1848468581,
     *1717663084,1948275521,1296375890,1702065266,1634299508, 542531948,
     *1969561702,1869750308,1092625478, 542270832,1869771808,        -3,
     *        -2, 542328901,1280855072,1634758764,1768256288,1629512805,
     *1717663084,1948280166,1717920628,1769366816,1937006958,1684107876,
     * 543450486,1767994473,1869488246,1634497893, 544171552, 808333362,
     * 541159015, 543584114,        -3, 544499813, 542327117,1159737644,
     * 840986482, 540093491, 543321966,1679848037,1937011297,1768846451,
     * 773870696,1696626035,1696624486, 543236205,1969448992,1937011311,
     *1852269938, 544367987,1953653097,1853107232,        -3, 544696692,
     *1746952480,1819244389,1914730081,1819632928,1868963956,1752134501/
     * )
      ICK( 22201: 22500) = (/
     * 544235890,1634559348,1701999404, 544039289, 543713636,1696625509,
     *1919512437,1931505778,1868721253,1836261495,1769236512,1629495328,
     *        -3, 544437362,1969452149,1919233568,        -3,        -1,
     * 589315646,1042306149,1936990290,1229411616,1919251316,1918986606,
     *1948284513,1819632928,1768824899,1229335909,1835165028,1684366368,
     * 779249011, 543582572,1696604192,        -3,1597061424, 538976288,
     * 807411744, 540024864, 538980384, 857751840, 538980384, 807416096,
     * 807411744,        -3,1092636271,1848468581,1717663084,1948275273,
     *1196761170,1702065266,1634299508, 542531948,1969561702,1869750308,
     *1092625478, 542270832,1869771808,        -3,        -2, 542328901,
     *1280855072,1634758764,1768256288,1629512805,1717663084,1948280166,
     *1717920628,1769366816,1937006958,1684107876, 543450486,1767994473,
     *1869488246,1634497893, 544171552, 808333360, 874538607,1914729576,
     *1696604192, 542263623,1428189797,1937011297,1768846382, 542402661,
     * 544568165, 544171552,1629515125,1667768435,1953656686,1734701600,
     *1919251316,1918986606,1948284777,1952981089, 543977335,1701978230,
     *1634497893, 544171552,        -3, 544499809,1948282977,1918987621,
     *1952805408,1835104544,1751737445, 544433522,1768912243, 544240239,
     *1651271021,1931507561,1952981089, 544437362,1969452149,1919230067,
     *1969448992,1634934903,1919905383, 543257711,1830821920, 544504176,
     *1696620915,1936287598,1835363956,1932402720,        -3,        -1,
     * 589315646,1042306149,1936990291,1094994208,1919251316,1918986606,
     *1948284513,1819632928,1768824899,1229335909,1835165028,1684366368,
     * 779249011, 543582572,1696604192,        -3,1597061425, 538976288,
     * 807411744, 540024864, 538980384, 857751840, 538980384, 807416096,
     * 807411744,        -3,1092636271,1848468581,1717663084,1948275521,
     *1145643090,1702065266,1634299508, 542531948,1969561704,1634934882,
     *1701146144,1970496868, 539248160,1382379631,1920213024,        -3,
     *        -2, 542328901,1280855072,1634758764,1768256288,1629512805,
     *1717663084,1948280166,1717920628,1769366816,1937006958,1684107876,
     * 543450486,1767994473,1869488246,1634497893, 544171552, 808333362,
     * 541159015, 543584114,        -3, 544499813, 542327108,1226859119,
     *1852055666,1702065266,1634299508,1932402772,1751457909,1936007279,
     *1713398048,1836409704, 544437362,1869506405,1914729061,1937011297,
     *1768846380, 544696692,1746952480,1819244389,1914708000, 544629100,
     *1969561711,1713402984,1869833504,1885434465,1835365477,1920150560,
     *1835104544,1751737445, 544433522,1768912243, 544240239,1651271021,
     *1931507561,1952981089, 544437362,1969452149,1919233568,        -3,
     *        -1, 589315646,1042306149,1936990276,1162630432,1919251316,
     *1918986606,1948284513,1819632928,1768824899,1229335909,1835165028,
     *1684366368, 779249011, 543582572,1696604192,        -3,1597061426,
     * 538976288, 807411744, 540024864, 538980384, 857751840, 538980384,
     * 807416096, 807411744,        -3,1092636271,1848468581,1717663084,
     *1948271685,1280647250,1702065266,1634299508, 542531948,1969561702,
     *1869750308,1092625478, 542270832,1869771808,        -3,        -2,
     * 542328901,1280855072,1634758764,1768256288,1629512805,1717663084,
     *1948280166,1717920628,1769366816,1937006958,1684107876, 543450486,
     *1767994473,1869488246,1634497893, 544171552, 808333361, 541159015,
     * 543584114,        -3, 544499813, 541345100,1428189797,1937011297,
     *1768846451, 773870696,1696626035,1696624486, 543236205,1969448992/
     * )
      ICK( 22501: 22800) = (/
     *1937011311,1852269938, 544367987,1953653097,1853107232,2003399784,
     * 543236204,1870095730,        -3, 544629100,1969561711,1713402984,
     *1869833504,1885434465,1835365477,1920150560,1835104544,1751737445,
     * 544433522,1768912243, 544240239,1651271021,1931507561,1952981089,
     * 544437362,1969452149,1919233568,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1668882543,
     *1713398629,1819025446, 543451494,1718772067,1953066862, 544499053,
     *1885696609,1953854053,1931485216,        -3,1597061427, 538976288,
     * 807411744, 540352544, 540094496, 824199456, 538980384, 824193056,
     * 807411744,        -3,1130720364, 543256164, 541354342,1718772067,
     *1953066862, 542401901,1885696609,1953854053,1931494505,1717986674,
     * 543324448, 774778414, 539248928,1147496306,1701126176,        -3,
     *        -2, 542402661, 544367984,1869771877,1679828831,1667591276,
     *1601004897,1937076837,1835363956,1601463661,1885696609,1953854053,
     * 656434277,1986617716,1702043750,1919905056,1952998688,1919250543,
     *1920230756,        -3, 539451236,1768318578,1851744621,1651074414,
     *1952412773,1836082546,1635022194,1696626273,1819632935, 773870696,
     *1696625253,1818588769,1853104243,1702109295,1713398629,1819025520,
     *1634885997,1702126962,        -3, 544629100,1969582880,1634886944,
     *1953001331,1696620916, 544499813, 543449460,1633906540,1818583924,
     *1768910368,1952804208,1701994868,1970431264, 677981797, 773874029,
     *1651074414,1948284005,1836082546,1635022194,1696604192, 543257632,
     *1952998688,1668446579,1952541737, 543319395,1635087205, 544499813,
     * 543450482,1769366884, 543647087,1835365490,2032169057,1918987621,
     *1952805408,1986096245,1702043767,1768713248,1650794595,1869771365,
     *1668554784, 543256164, 544040289,1852403303,1718971424,1869507705,
     * 544696421,1847620712,1869833504,1667591276, 544235890,1634559348,
     *1701978230,1634497893,1931501938,1696626035,1701064224,1466459502,
     * 544367980,1702257006,1949048864, 543384940,1814065249,1918987621,
     *1952805408,1986096245,1702043745,1948284005,1836082546,1635022194,
     *1702043748,1768318565,1919512167, 543584879,1830843496,1696604192,
     *        -3, 539451236,1768318578,1851744621,1651074414,1952412773,
     *1836082546,1635022194,1697063009,1919230050,1702065184,1634886504,
     *1769366884, 543257376,1668246893,1701737504,1986096245,1696626030,
     *1684369952,        -3, 543122277,1819041651,1885692777,1634492260,
     *1702125929,1819487776,        -3,        -1, 589315646,1042305637,
     *1886351988, 544173600,1852796461,1684366945,1970041888,1145390675,
     * 544367987,1953653097,1853104246,1634497893,1931503982, 541280582,
     * 761621858,1701078117,1679830642,1702043750,1768711456,        -3,
     *1597061428, 538976288, 807411744, 540024864, 538980384, 857751840,
     * 538980384, 807416096, 807411744,        -3,1092636271,1848468581,
     *1717663084,1948271685,1179852882,1702065266,1634299508, 542531948,
     *1969561715,1702109220,1092625478, 542011252,1696669728,        -3,
     *        -2, 542011246, 761554278,1635085428, 541345094,1394634849,
     *1918987621,1952805408,1986096245,1702043753,1847608137,1177372013,
     *1650812004,1701060654,1919251232,1718185061, 773857312,        -3,
     * 542336357, 542328901,1280855072,1835101813,1634479648,        -3,
     *        -1, 589315646,1042306149,1936990276,1179211808,1919251316,
     *1918986606,1948284513,1819632928,1768824899,1229335909,1835165028,
     *1684366368, 779249011, 543582572,1696604192,        -3,1597061429/
     * )
      ICK( 22801: 23100) = (/
     * 538976288, 807411744, 540024864, 538980384, 857751840, 538980384,
     * 807416096, 807411744,        -3,1092636271,1848468581,1717663084,
     *1948271686,1230512210,1702065266,1634299508, 542531948,1969561704,
     *1634934882,1701146144,1970496868, 539248160,1382379631,1920213024,
     *        -3,        -2, 542328901,1280855072,1634758764,1768256288,
     *1629512805,1717663084,1948280166,1717920628,1769366816,1937006958,
     *1684107876, 543450486,1767994473,1869488246,1634497893, 544171552,
     * 808333362, 541159015, 543584114,        -3, 544499813, 541345353,
     *1478521445,1937011297,1768846451, 773870696,1696626035,1696624486,
     * 543236205,1969448992,1937011311,1852269938, 544367987,1953653097,
     *1853107232,2003399784, 543236204,1870095730,        -3, 544629100,
     *1969561711,1713402984,1869833504,1885434465,1835365477,1920150560,
     *1835104544,1751737445, 544433522,1768912243, 544240239,1651271021,
     *1931507561,1952981089, 544437362,1969452149,1919233568,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750367,1667591276,
     *1601004897,1937076837,1835363956,1601463661,1885696609,1953854053,
     * 544108404, 543519093,1634476082, 959662880,1634624544,1852776532,
     *1162694688,1919247215,1919164448,1597061430, 538976288, 807411744,
     * 540024864, 841887776, 824199456, 538980640, 807415840, 807411744,
     *        -3,1315905620,1162694688,1919247215,1919164513,1852055661,
     *1700885365,1919249765,1853104244,1701671013,1918989429,1919229998,
     *1313156640, 539248928,1147496306,1701126176,        -3,        -2,
     * 542328901,1280855072,1886151011,1702043720,2036626031,1734700576,
     *1635020653,1931501940, 543383916,1668639841,1952801824,1886352233,
     *1953066862,1931507561,1952981092,1701208437,1819549796,1769174113,
     *1852007712,        -3, 544629100,1969582880,1953439860,1751476594,
     * 544235890,1701737504,1635020653,1931502693,1885695588,1768843040,
     *1869488244,1751457908,1701671013,1918989429,1919230066,1701867378,
     *1952801824,1768824948,1751457824,        -3, 542393677,1344303717,
     *1668248164, 773871464,1701716084,1751457876,1162694688,1919247215,
     *1919164521,1931501922,1936027252, 543780384,1952998688,1701667429,
     *1684301156, 539438706,1702045472,1718185061, 543236128,        -3,
     * 543450470,1635085428, 544499053,1885696609,1953854053, 544171552,
     * 842609483, 543781664,1634956149,1835361326, 541158944,1095517522,
     *1411410291, 543781747,1969579040,2003330414, 544499813, 541280582,
     *        -3, 544367984,1869771877,1679828831,1667591276,1601004897,
     *1937076837,1835363956,1601463661,1885696609,1953854053, 656434281,
     *1717986674,1931503218,1869422642, 959662894,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750387,1885692777,1718182753,
     *1953066862, 544171552,1970170228, 543384940,1814060899,1701604447,
     *1835360627,1970431341,1701737567,1952804208,1701994868,1970431264,
     *        -3,1597061431, 538976288, 807411744, 540024864, 538980384,
     * 824199456, 538980640, 807415840, 807411744,        -3,1298756467,
     *1768843040,1600349548,1818193253,1634956658,1701668206,1952412773,
     *1836082546,1635022194,1696613473,1953852704, 774778414, 538976288,
     * 542141541,1634952480,1097098272,        -3,        -2, 542141541,
     *1634952480,1936745827,1768323360,1952998688,1952804208,1701994868,
     *1970431264, 678126956,1986620969, 543257632,2003331427,1746957416,
     *1696626030,1769218147,1701604384,1885434465,1835365477,1920147488,
     *        -3, 544695666,1696621669,1952805485,1768842596, 773870696/
     * )
      ICK( 23101: 23400) = (/
     *1635000436,1701671013,1918989429,1919230067,1752135020,1679843941,
     * 543647086,1701994860,1819877481,1684369012,1768120684, 544501536,
     *1952998688,        -3, 544499053,1885696609,1953854053, 544629100,
     *1969561715,1885692777,1718183268, 544696692,1746937695,1684629094,
     *1919836001,1835166053,1853120372,1701671013,1918989429,1919231776,
     * 678717541,        -3, 544499053,1885696609,1953854053, 544171552,
     *1952998688,1668446579,1952541728,1685418601,1852252260,1635017005,
     *1668246636,1701016681,1869490464,1768824943,1919182194, 544501536,
     *1835101029, 544433518,1936007200,        -3, 544696421,1847620979,
     *1701060713,1847620712,1696621409,1818457452,1635019119,1847619430,
     * 543450482,1769366884, 543647087,1835365490,2032169057,1918987621,
     *1952805408,1986096245,1702043688,1764648238, 543321966,1679826976,
     * 543451507,1952542307,1702046752,1651469924, 543256167,1818587936,
     *1702126382, 690888736,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1885692777,1718182753,1953066862, 544171552,
     *1684108385,1668246636,1701016681,1869488244,1701671013,1918989429,
     *1919229984,        -3,1597061432, 538976288, 807411744, 540024864,
     * 538980384, 824197408, 538980640, 807415840, 807411744,        -3,
     *1298756467,1768843040,1600416102,1718775391,1634558569,1701737567,
     *1952804208,1701994868,1970431264, 538985569,1953852704, 774778414,
     * 538976288, 542141541,1634952480,1097098272,        -3,        -2,
     * 542141541,1634952480,1936745827,1768323360,1952998688,1952804208,
     *1701994868,1970431264, 678126956,1986620969, 543257632,2003331427,
     *1746957416,1696622958,1952804467,1769240864,1684108385, 544695666,
     *1696604192,        -3, 543387500,1818583924,1701064224,1416127776,
     *1919250543,1920230756, 543384940,1814065249,1918987621,1952805408,
     *1986096245,1702043763,1752135020,1679843941, 544499823,1936007265,
     *1948284008,1769152544,        -3, 544499053,1885696609,1953854053,
     * 544501536,1835101029, 544433518,1936007279,1713402984,1696621669,
     *1919514213,1679845221,1869440372,1920540784,1634885997,1702126962,
     * 544629100,1969582894,        -3,        -1, 589315646,1042306149,
     *1936990291,1212501080,1277194863,1869444197,1836082546,1635022194,
     *1696621669,1717663084,1948284513,1819632928,1718579744,1970170228,
     * 543384940,1814062181,1952805485,1768841588,1768910368,        -3,
     *1597061433, 538976288, 807411761, 774905888, 841887776, 824199456,
     * 538980384, 807415840, 824188960,        -3,1382379631,1920230756,
     * 543122277,1819041645,1700885365,1919249765,1853120372,1701671013,
     *1918989429,1919229998, 774778414, 539511593, 539248928,1130915171,
     *1797267488,        -3,        -2, 542402661, 543384940,1814062181,
     *1952805485,1768841588,1768910368,1952804208,1701994868,1970431264,
     *1769152627,1702109289,1847620712,1696613193,1176527481, 543450470,
     *1635085428, 543324448,1397245260,1481390391,        -3, 544501536,
     * 842609440,1260418920,1701716084,1751457876,1162694688,1768846196,
     *1920295796,1768910368,1769152622,1869881461,1936024622, 542402661,
     * 543253364,1969318944,1952804208,1701994868,1970431264,1769152544,
     *        -3, 543975787,1701607712,1701409896,1701978227,1818847080,
     *1953265952,1869750387,1768386153,1718182753,1853123705, 539519342,
     * 543383923,1696624486, 543236204,1870078068,1701671013,1918989429,
     *1919230052,1635016992,        -3, 543387500,1818583924,1768910377,
     * 538993769,1717986674,1701737518, 541139052,1768645996,2032166258/
     * )
      ICK( 23401: 23700) = (/
     *1919905381,1869968160,1952804208,1701994868,1970431264,1868963890,
     * 926108448, 674251561, 543781664,        -3, 543255667,1864394348,
     *1634166629,1680744480,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750355,1212501080,1277194863,1869444197,1836082546,
     *1635022194,1696613477,1717663084,1948264548,1635017059,1869376613,
     *1668573551,1848188960,        -3,1597124656, 538976288, 807411761,
     * 774905888, 841887776, 824199456, 538980384, 807415840, 824188960,
     *        -3,1382379631,1920230756, 538976351,1684629094,1919836001,
     *1835166053,1853120372,1701671013,1918989429,1919229998, 774778414,
     * 539511593, 539248928,1130915171,1797267488,        -3,        -2,
     * 542402661, 543449460,1629512559,1819043171,1953066862, 544499053,
     *1885696609,1953854053, 543781664,1936028704,1768824948,1751457859,
     *1229332578,2032165989,1717663084,1948279417, 542328901,1280855097,
     * 924873839,        -3, 540162355, 541794409,1713402984,1696617541,
     *1297096809,1853060210,1969452137,1869488233,1931505263,1948284275,
     *1701064224,1092643945,1801809017, 543519346,1869505903,1970479220,
     *1701671013,1918989429,1919230063,1713381408, 540161843,1260398640,
     *1126768745,1931501932,1936662630,1818322791,1701064224,1416127776,
     *1633907829,1634476148,1701671013,1918989429,1919230057,1931504745,
     *1801809017, 543517044,1751478816,1936484711,1752460409,        -3,
     * 544174624,1936287598,1768319331,1634628716,2032150630,1869750369,
     * 543977335, 544499053,1885696609,1953854053, 543449460,1629512559,
     *1819043171,1953066862, 689988713,1717986674,1701737518,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750377,1936684146,
     *1869637987, 544108398, 759701601,1953459571, 543780384,1835100526,
     * 544367987,1768191333, 678635808,        -3,1597124657, 538976288,
     * 807411744, 540024864, 540094496, 840974624, 538980384, 807416096,
     * 807411744,        -3,1232301940,1919905897,1663069807,1848461344,
     *1098149741,1931503982, 541942121,1847612005,1936286837,1697149737,
     * 539897390, 774778414, 539248928,1382379631,1920213024,        -3,
     *        -2, 542402665,1931506789,1936990322,1701867378,1953701999,
     *1847619183,1848469625,1685221223,1701716065,1953459571, 544499809,
     *1948284773,1919230066,1701210478,1701060727,1769236512,1769172852,
     *1919905897,1663049760,        -3, 543451507,1886151011,1701668206,
     *1948282977,1918987621,1952805491, 544173676,2032167278, 544499813,
     * 544039273,1847620197,1936286837,1697521747,1969448992,1629515890,
     *1633907817,1667571817,1931507054,1970500961,1814044704, 543324448,
     *1836016741,1919819891,1952542308,1634886771, 543256164, 544173676,
     *2032168549,1701078372, 543584114, 544041326,1869750372,1769172850,
     *1684369952,1836016741,1819044206,1731076128,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750377,1936684146,1869637987,
     * 544108398, 759701601,1953459571, 543780384,1634625903,1847607072,
     *1869750387,1869379173,1853104191,        -3,1597124658, 538976288,
     * 807411744, 892346400, 540356640, 857751840, 538980384, 807416096,
     * 807411744,        -3,1232301940,1919905897,1663069807,1848461344,
     *1098149741,1931503982, 541159017,1869492051,1869379173,1853104174,
     * 774778414, 774778414, 539248928,1130915171,1797267488,        -3,
     *        -2, 542402665,1931506789,1936990322,1701867378,1953701999,
     *1847617907,1869902447,1885954913,1819048224,1919247977,1852138528,
     *1635020653,1931503982, 544435553,1819025517,1869178228,1768256288/
     * )
      ICK( 23701: 24000) = (/
     * 678785909,1634495609,        -3, 543256169,1869509408,1869750387,
     *1869379173,1853106478,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750382,1701273972,1769366816,1852796461,1752786034,
     *1869047150, 542451817,1936664864,        -3,1597124659, 538976288,
     * 807411744, 540024864, 538980384, 840974624, 538980384, 807416096,
     * 807411744,        -3,1315268449,1953068645, 541684591,1953656688,
     *1768104001,1146101862,1869750308,1092628014, 774778414, 774778414,
     * 773858374, 542270832,1869771808,        -3,        -2, 541684591,
     *1953656688,1768104021, 677999471, 689993313,1819633011, 543257189,
     * 543520880,1701016677,1679848559, 543711606,1696620832,1886352233,
     *1953068645, 544629100,1969565216,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750311,1634495533,1769172852,1919905897,
     *1663066468,1881699113,        -3,1597124912, 538976288, 807411744,
     * 540024864, 540094496, 857751840, 538980384, 807416096, 807411744,
     *        -3,1315905601,1852404591,1953656688,1768104001,1146103667,
     * 541486965,1852055657,1847608137,1176514094, 774778414, 774778414,
     * 774778414, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542011168,1634625907,1869902447,1885954913,
     *1819048224,1919247977,1852138528,1635020653,1931503982, 541280582,
     * 541007904,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750350,1346641985,1146103667, 538978353, 774908192,1768824941,
     *1634299424,1919251305,1685415208,1932075040,        -3,1597124913,
     * 538976288, 807411744, 540024864, 808334624, 840974624, 538980384,
     * 807416096, 807411744,        -3,1094996000,1868963905,1953459488,
     * 608247913,1931497006,1345209390, 544174624, 678323553,1919711529,
     * 540165152, 773857312, 538988652,1700885349, 541288549,1667964960,
     *        -3,        -2, 542402665,1931506789,1936990322,1701867378,
     *1953701999,1847619183,1848471663,1936290921,1986338916,1701210478,
     *1769235744, 677981797, 773874543,1836084325,2015388014,1679848814,
     *1919246700,1769174121,1663639584,        -3, 543256169,1936684146,
     *1869637987, 543451507,1886151011,1701668206,1948282977,1918987621,
     *1952805491, 543780384,1952998688,1835100526, 544367987,1768191333,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750350,1346641985,1146103667, 543780384,1634625903,1849630758,
     * 544436076,1986358900, 541007963, 808198193,1562386464,        -3,
     *1597124914, 538976288, 807411760, 775233568, 540621088, 840974624,
     * 538980384, 807416096, 807411744,        -3,1094996000,1868963905,
     *1953459488, 608247913,1931497006,1345209390, 544174624, 678323553,
     *1919711529, 540165152, 773857312, 538988652,1700885349, 541288549,
     *1667964960,        -3,        -2, 542402665,1931506789,1936990322,
     *1701867378,1953701999,1847619183,1848471663,1936290921,1986338916,
     *1701210478,1769235744, 677981797, 773874543,1836084325,2015388014,
     *1679826976,        -3, 544566898,1700883561,1937008995, 689987950,
     *1769172852,1919905897,1663067241,1936747617,1667591525,1853104240,
     *1634885997,1702126962,1931503982, 543256096,1634625903,1847619442,
     * 544436076,1986358900,        -3, 544367987,1768191333, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990322,1635019119,
     * 543253616, 544039288, 795699566, 543780384,1835100526, 544367987,
     *1768191333, 678635808,        -3,1597124915, 538981166, 807411764,
     * 774905888, 892219424, 840974624, 538980384, 807416096, 807411744/
     * )
      ICK( 24001: 24300) = (/
     *        -3,1098149741, 539246880, 538976288, 538994785,1931493700,
     *1344302433,2016374121,1847612001,1953066784, 774778414, 773858374,
     * 539247136,        -3,        -2, 542402661, 544039273,1847615864,
     *1702043766,1634497893,1931505510, 544499813, 541148240, 676538656,
     *1868963956,1751457901,1634299424,1919251305,1685415208,1932075105,
     *1919230052,1702126962,1835626085,1679843694,1679826976, 544174692,
     *1701995876, 975197489, 540811349, 840973344,1429417504,1416127776,
     *1986096245,1696624486, 542331218,1411929395, 794112297, 544039273,
     *1847615864,1769152577,1146101874,1635019119, 539509102,1735619698,
     *1869422624, 542469737,1953704224,1769152628,1702065253,1679844975,
     *1914729576,1696623969,1768824946,1702062436,1969563763, 690888780,
     *1634887525, 544629100,1969582880,1835104544,1768842345,1667331173,
     * 544566898,1702063980,1986356256, 543451507,1869767781,1915625551,
     *1651270004,1696621426,1769235826,1769303354, 542454560, 757093682,
     * 540811349, 840969504,1429286432,1349676908,1635018016,1869899877,
     *1920428403,1697521696,        -3,        -1, 589315646,1042306149,
     *1936990322,1635019119, 543253616, 544039288, 795699566, 543780384,
     *1634625903,1847607072,1869750387,1869379173,1853104191,        -3,
     *1597124916, 538981422, 807411765, 774905888, 908996640, 840974624,
     * 538980384, 807416096, 807411744,        -3,1098149741, 539246880,
     * 675376745,1869492051,1869379173,1853106464,1094996000,1835104303,
     *1835626016,1382118505,1864377414, 539247136,        -3,        -2,
     * 542402661, 544039273,1847615864,1702043766,1634497893,1931505510,
     * 544499813, 541148240, 676538656,1868963956,1751457901,1768845170,
     * 544367987,1768191333, 678635808,1634886944,1684370533,1919773038,
     *1701060705,1852055584, 544174692,1701995876, 975197489, 540811349,
     * 840973344,1429417504,1416127776,1986096245,1696624486, 542331218,
     *1411929395, 794112297, 544039273,1847615864,1769152577,1146101874,
     *1635019119, 539509102,1735619698,1869422624, 542469737,1953704224,
     *1769152628,1702065253,1679844975,1914729576,1696623969,1768824946,
     *1702062436,1969563763, 690888780,1634887525, 544629100,1969582880,
     *1835104544,1768842345,1667331173,        -3, 544566898,1702063980,
     *1986356256,1684632431,1919182194, 773869410,1818326117, 543388265,
     *1952805481,1970092576,1429413933, 542454304,1008751922, 539828309,
     * 825106512,1919904865,1952784495,1952998770,2003399525, 773857312,
     *        -1, 589315646,1042306149,1936990310,1869750389,1853191029,
     *1634476132,1769172850,1684370021,1679843700,1869422657,1146101865,
     *1847618913,1768824946,1702062436,1969561632,        -3,1597124917,
     * 538981166, 807411764, 774905888, 892219424, 857753888, 538980384,
     * 807416096, 807411744,        -3,1147761519,1919182194,1701060644,
     *1092642913,1931493700,1344302433,2016374121,1847612001,1953066784,
     * 774778414, 773858374, 542011252,1696604192,        -3,        -2,
     * 542402661, 544039288,1768781165, 543256164, 544041326,1768781165,
     * 544039273,1847615864,1769152577,1146101874,1635019119, 539509102,
     *1735619698,1869422677,1852404851, 689990003, 544499059,1952801824,
     *1718579744,        -3, 544499813, 544039273,1847620197,1936286837,
     *1697521740,1634887525, 544629100,1969582880,1835104544,1768842345,
     *1667331173, 544566898,1702063980,1986356256,1684632431,1919182194,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750389,1853191029,1634476132,1769172850,1684370021,1679843700/
     * )
      ICK( 24301: 24600) = (/
     *1869422657,1146101865,1847618921,1852797472,1919251305,1685415200,
     *        -3,1597124918, 538981678, 807411767, 774905888, 959328288,
     * 857753888, 538980384, 807416096, 807411744,        -3,1147761519,
     *1919182194,1701060644,1092626497,1848595311,1819683104,1094996000,
     *1835104303,1835626016,1382118505,1864377414, 542011252,1696604192,
     *        -3,        -2, 542402661, 544039288,1768781165, 543256164,
     * 544041326,1768781165, 544039273,1847615864,1769152577,1146101874,
     *1635019119, 539509102,1735619698,1869422677,1852404851, 689990003,
     * 544499059,1952801824,1718579744,        -3, 544499813, 544041326,
     *1869750386,1702062436,1969563763, 690888780,1634887525, 544629100,
     *1969582880,1835104544,1768842345,1667331173, 544566898,1702063980,
     *1986356256,1684632431,1919182194, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750377,1852010349,1886152052,
     *1696617768,1764518441, 543449460,1629495328,        -3,1597124919,
     * 538980398, 807411760, 774905888, 808333344, 824197408, 538980640,
     * 807415840, 807411744,        -3,1231971183,1836084325,1952784469,
     * 677473897,1936664864,1147237473, 543584114, 539897390, 774778414,
     * 774778414, 774778414, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 541288549,1667964966, 541290354,1919247220,
     * 542451809,1852404591, 689988705,1952522342,1869750371,1869443180,
     *1702126958,1702064928,1702126382,        -3, 541355808,1852797984,
     *1970496800,1397245260,1478521716,2037146912, 658319136,1668247156,
     *1768846689,1953066862, 543975790,1697521696,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509492,1918986606,
     *1701060693, 677981290, 690451232,        -3,1597124920, 538976288,
     * 807411744, 540155936, 538980896, 857751840, 538980640, 807415840,
     * 807411744,        -3,1131376243,1953653097,1852138528,1428711724,
     *1781080131,1869443183,1852141172,1932030761, 543584114, 539246880,
     * 538977353, 541288549,1667964960,        -3,        -2, 542451817,
     * 745154848,1668246896,1869505902,1953701992,1635149088,1650812270,
     * 543387502,1937011297,1768842596, 539519278,1697521783,1769236591,
     *1970544755, 779431465, 543780384,1952998688,1919247977,1852140901,
     *1853104160,        -1, 589315646,1042306149,1936990293,1701914733,
     *1635264815,1432711464,1298755113, 544366958,1734680678,1869750382,
     *1869491528, 543257711,1836261481,1847619183,1848472431,1819698542,
     *1948262432,        -3,1597125168, 538981166, 807411766, 774905905,
     * 808333344, 840976672, 538980384, 807416096, 807411744,        -3,
     *1315925587,1869379173,1853104160, 542270835,1680097637,1898474849,
     *2015965013,1701914733,1768827168,1382116967,1696605254, 542269812,
     *1768890400,        -3,        -2, 542402665,1931506789,1936990322,
     *1701867378,1953701999,1847615776,1818325607,1701978228,1751215648,
     *1970500961,1814058280,1701914912,1918987879,1696622191,1914729576,
     *1696625520,1701013862,1768252448,        -3, 543517797,1835363956,
     * 544504176,1696622958, 544499813, 544108398, 762539884,1986358900,
     * 794914409,1869488240,1634890784,1868963956,1751457907,1953658211,
     *1953854053, 773857312,        -3, 542404463, 543713639,1746956146,
     * 544501615, 543977335, 542467441, 661856365,1635328098,1696620910,
     * 543780452,1768120692,1768910368,1718579744,1768842095,1920099683,
     *1953265952,        -3, 543777893,1853122918,1768252448,1635020653,
     *1768104051,1885692777,1702043688,1764648238, 542056566,1701999477/
     * )
      ICK( 24601: 24900) = (/
     *1931497001, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990293,1701914733,1635264815,1432711464,1298755113, 544366958,
     *1734680678,1869750382,1869491528, 543257711,1836261481,1847620463,
     *1819698542,1948262432,        -3,1597125169, 538981422, 807411768,
     * 774905905, 841887776, 840974624, 538980384, 807416096, 807411744,
     *        -3,1399811190, 774848878,1768910368, 542270835,1680097637,
     *1898474849,2015965013,1701914733,1768827168,1382116967,1696605254,
     * 542269812,1768890400,        -3,        -2, 542402665,1931506789,
     *1936990322,1701867378,1953701999,1847615776,1818325607,1701978228,
     *1751215648,1970500961,1814058280,1701914912,1918987879,1696622191,
     *1914729576,1696624239,1848469625,1685221223,1701716000,        -3,
     * 543257711,1836261491,1869379173,1853108065,1852403566, 773870703,
     *1864394857,1734877295,1914729583,1864395887,1998607717,1898410784,
     *1835104544,1650794593,1847617902,1684628321,1953066862, 543584114,
     *        -3, 543780451,1869771365,1668574329, 543777893,1853122918,
     *1768252448,1635020653,1768104051,1885692777,1702043688,1764648238,
     * 541225504,1986359923,1970479169,1730752032,        -3,        -1,
     * 589315646,1042306149,1936990293,1769172776,1835104297, 794126707,
     *1864912233,1848189042,1634625381, 543584114, 541597793,1953459571,
     * 543780384,1852796461,1936682102,1701737504,        -3,1597125170,
     * 538981422, 807416112, 774905913, 959330592, 857751840, 538980384,
     * 807416096, 807411744,        -3,1315925587,1869379173,1853104210,
     *1702061092,1097429871, 678257016, 690967913,1936664685,1768827168,
     *1382116967,1696605254, 542269812,1768890400,        -3,        -2,
     * 542402665,1931506789,1936990322,1701867378,1953701999,1847615776,
     *1818325607,1701978228,1751215648,1970500961,1814065761,1852269856,
     *1868963925, 677736745, 544629100,1969582880,1718579744,1752786034,
     *1869047150,        -3, 543257711,1836261481,1847620712,1696624239,
     *1848472431,1819698542,1949262190,1768910368,1885434484, 544171552,
     *1952998688,1937011317,1668576626,1697521696,        -3,        -2,
     * 542142323,1936286316,1696621409,1970496883, 543257189, 975183904,
     *        -3,        -2, 540090413, 543451507,1869767781,1915494501,
     * 778513952,1768824948, 761427316,2037129325,1869178228,1768256302,
     *        -3, 540155949, 544239471,1914725473,1952525344,1852797984,
     *1633969521,1969321061, 543584114, 544499813, 544367974,1768842605,
     *1701737504,1868963945,1852074358,1768191329,1814062185,1936747617,
     *1667591525,1853104160,        -3, 538976288, 544235890,1634559348,
     *1701999406,        -3, 540221485, 541944179,1886151011,1701060712,
     *2036626031,1734700576,1635020653,1931487337, 778382880,1952998770,
     *1696622963, 544108320,1684369011,1769240864,1635000436,1751457904,
     *1869834612,1768910368,        -3, 538976288, 544696421,1919230063,
     *1852121199,1713402984,1696614445,1635020653,1931503987, 544239475,
     *1769236847,1852138537, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990293,1701914733,1635264815,1432711464,1298755113,
     * 544366958,1734680678,1869750344, 543257711,1836261481,1847620463,
     *1819698542,1948262432,        -3,1597125171, 538981422, 807416112,
     * 774905913, 959330592, 874529056, 538980384, 807416096, 807411744,
     *        -3,1399811190, 774848878,1768910368, 542270835,1680097637,
     *1898474849,2015965013,1701914733,1768827168,1382116967,1696605254,
     * 542269812,1768890400,        -3,        -2, 542402665,1931506789/
     * )
      ICK( 24901: 25200) = (/
     *1936990322,1701867378,1953701999,1847618657,1919378720,1918987879,
     *1702043753,1847616617,1936747617,1667591525,1853104240,1634885997,
     *1702126962,1931503215,1914726521,1685221223,1701716000,        -3,
     * 543257711,1836261481,1847620712,1696625519,1819698542,1949262190,
     *1768910368,1885434484, 544171552,1952998688,1937011317,1668576626,
     *1697521696,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750372,1768318565,1919250019,1696622958, 543780208,1818846057,
     *1948279150,1679844728,1886153059,1769218133, 677736745,        -3,
     *1597125172, 539897904, 840969776, 808656942, 808465696, 824197408,
     * 538980384, 807416096, 807411744,        -3,1432711464,1382379561,
     * 543256164, 542467441, 675504492,1663639620,1768318565,1914724985,
     * 608247873,1852254762, 840966180,1109410664,1701014304,        -3,
     *        -2, 542402665,1931506789,1936990322,1701867378,1953701999,
     *1847615776,1818325607,1696621673,1717986674,1701733221, 543319412,
     *2003133806, 542467441, 543780384,1952998688,1128875552,1634624544,
     *1952998688,1432711456,        -3, 543383916,1668639841,1952801824,
     *1718775661, 544499813, 540418162,1701867378,1952801824,1428711724,
     *1781080182,1634497893,1932402720, 538976288, 538976288, 538976288,
     * 538976288, 538976288, 538976288, 538979872,        -3,        -1,
     * 589315646,1042303081,1920165990,1701602336,1919510377,1680695919,
     *1852055668,1702065184,1531011956,1629504370,2037609518, 539504953,
     * 926296364, 541143858, 740307507, 959263284, 878518304,        -3,
     *1597125424, 538981678, 807411767, 774905913, 959328288, 840974624,
     * 538980384, 807416096, 807411744,        -3,1214870131,1751541100,
     *1679840357,1936990276,1768318496,1718579744, 538976292,1093479716,
     *1110319140,1176531758,1965957152,        -3,        -2, 542402661,
     * 543387501,1886350949,1853125408,1868963956,1751457889,1852404591,
     *1953656688,1768104036,1769173100,1633903981,1701737504,1885434465,
     *1835365477,1920147553,1819242087, 543385701,1835623265,1814044704,
     *        -3, 543321966,1685266529,1919230049,1936946541,1701060724,
     *1864393317, 543519093,1634476137,1847618913,1735289204,1969513774,
     * 541876594,1734680676,1768318565,1919250019,1702043757,1768384628,
     *        -3, 543780452,1768120692,1696621423,1853120877,1768841588,
     *1768910368,1868963956,1751479141, 544235890,1634559348,1701999392,
     *2003399784, 544175208,1701978152,1970172517,1936682102,1701062944,
     *1701209701,1668576032,        -3, 544437603,1746952563, 539521909,
     *1651733609,1953854569,1869504876, 689988713,1936683620,1701981216,
     *1836016741,1814065010, 543449460,1629513074,1919906419, 543256164,
     * 795832864,        -3, 544175717,1915581029,1718185573,1835363956,
     * 773865844,1869441379, 544434548,1702043745,1936943463,1852138528,
     *1952998688,2003988334,1730179939,1635021925,1919512167, 544504176,
     *1696606309, 778513952,1097277472,        -3, 544630130,1937077024,
     *1114777888,1936224117,1818501223,1701733746,1635018016, 661680751,
     *1651271021, 544434535,1851878515, 656439145,1952981108,1751741216,
     *1952805748, 773866593,1952522355,1702130464,        -3, 543387506,
     *1919247220,1701060710,1869750369,1651732338,1886677359,1847616870,
     *1717920628,1931507561,1952981060,1162629701,1176532069,1667788393,
     *1903519091, 539518254,1731076164,1229340994,1395400787,1212501080,
     *1093410848, 542654786,1395796256,1868985445,1847620456,1870078060,
     *1634887525, 541345100,1428190817,1819633011, 543584114, 543321966/
     * )
      ICK( 25201: 25500) = (/
     *1685266537,1853255532,1986621031, 544499813, 543712609,1986618739,
     *1948279156,1869426208,        -3,        -2, 542011252,1698308180,
     *1751457903,1919510377,1851878432, 659057010,1936221797,1818504564,
     *1702065191, 544694643, 543450470,1768842596, 543780384,1633842031,
     *1819636837, 544499058,1836261416,1936024864,        -3, 541470284,
     * 776497522,1936221797,1818504224,1097036897, 541291129,1936993824,
     * 674314551, 908668448,1093874220, 540160825, 758264884, 690888788,
     *1751457891,1970434661,1853104244,1702065184,1769152631,1769236512,
     *        -3, 544367974,1701995886,1667571828,1864397928,1696620915,
     *1936679785,1635018084, 544437345,1852072306,1679848814,1667592820,
     *1634299508,2033066016,        -3,        -1, 589315646,1042303081,
     *1920165990,1701602336,1919510377,1680695919,1852055668,1702065184,
     * 676556652,1986358900, 689986369,1668571424,1131575667,1949179944,
     * 825833270, 690766131, 841757235, 959263284, 878518304,        -3,
     *1597125425, 538981678, 807411769, 774905913, 959328288, 874529056,
     * 538980384, 807416096, 807411744,        -3,1214870131,1751541100,
     *1679840357,1936990248,1399811190,1701737513, 538976292,1093479716,
     *1110319140,1176531758,1965957152,        -3,        -2, 542402661,
     * 543387501,1886350949,1853125408,1868963956,1751457889,1852404591,
     *1953656688,1768104036,1769173100,1633903981,1701737504,1885434465,
     *1835365477,1920147553,1819242087, 543385701,1835623265,1814044704,
     *        -3, 543321966,1685266529,1919230049,1936946541,1701060724,
     *1864393317, 543519093,1634476137,1847618913,1735289204,1969513774,
     * 541876594,1734680676,1768318565,1919250019,1702043757,1768384628,
     *        -3, 543780452,1768120692,1696625768,1696621423,1853120877,
     *1768841588,1768910368,1868963956,1751479141, 544235890,1634559348,
     *1701999392,2003399784, 544175208,1701978152,1970172517,1936682102,
     *1701062944,        -3, 543516262,1701016691, 544437603,1746952563,
     * 539521909,1651733609,1953854569,1869504876, 689988713,1936683620,
     *1701981216,1836016741,1814065010, 543449460,1629513074,1919906419,
     * 543256164, 795832864,        -3, 544175717,1915581029,1718185573,
     *1835363956, 773865844,1869441379, 544434548,1702043745,1936943463,
     *1852138528,1952998688,2003988334,1730179939,1635021925,1919512167,
     * 544504176,1696606309, 778513952,1097277472,        -3, 544630130,
     *1937077024,1114777888,1936224117,1818501223,1701733746,1635018016,
     * 661680751,1651271021, 544434535,1851878515, 656439145,1952981108,
     *1751741216,1952805748, 773866593,1952522355,1702130464,        -3,
     * 543387506,1919247220,1701060710,1869750369,1651732338,1886677359,
     *1847616870,1717920628,1931507561,1952981060,1162629701,1176532069,
     *1667788393,1903519091, 539518254,1731076164,1229340994,1395400787,
     *1212501080,1093410848, 542654786,1395796256,1868985445,1847620456,
     *1870078060,1634887525, 541345100,1428190817,1819633011, 543584114,
     * 543321966,1685266537,1853255532,1986621031, 544499813, 543712609,
     *1986618739,1948279156,1869426208,        -3, 542011252,1698308180,
     *1751457903,1919510377,1851878432, 659057010,1936221797,1818504564,
     *1702065191, 544694643, 543450470,1768842596, 543780384,1633842031,
     *1819636837, 544499058,1836261416,1936024864,        -3, 541470284,
     * 776497522,1936221797,1818504224,1097036897, 541291129,1936993824,
     * 674314551, 908668448,1093874220, 540160825, 758264884, 690888788,
     *1751457891,1970434661,1853104244,1702065184,1769152631,1769236512/
     * )
      ICK( 25501: 25800) = (/
     *        -3, 544367974,1701995886,1667571828,1864397928,1696620915,
     *1936679785,1635018084, 544437345,1852072306,1679848814,1667592820,
     *1634299508,2033066016,        -3,        -1, 589315646,1042303081,
     *1920165990,1701602336,1919510377,1680695919,1852055668,1702065184,
     * 676146520, 689986369,1668571424,1131575667,1949179944, 825833270,
     * 690766131, 841757235, 959263284, 878518304,        -3,1597125426,
     * 538981678, 807416112, 774905913, 959328288, 840974624, 538980384,
     * 807416096, 807411744,        -3,1214870131,1751541100,1679840357,
     *1936990276,1768318496, 676146520, 689971236,1093479716,1110319140,
     *1176531758,1965957152,        -3,        -2, 542402661, 543387501,
     *1886350949,1853125408,1868963956,1751457889,1852404591,1953656688,
     *1768104036,1769173100,1633903981,1701737504,1885434465,1835365477,
     *1920147553,1819242087, 543385701,1835623265,1814044704,        -3,
     * 543321966,1685266529,1919230049,1936946541,1701060724,1864393317,
     * 543519093,1634476137,1847618913,1735289204,1969513774, 541876594,
     *1734680676,1768318565,1919250019,1702043757,1768384628,        -3,
     * 543780452,1768120692,1696621423,1853120877,1768841588,1768910368,
     *1868963956,1751479141, 544235890,1634559348,1701999392,2003399784,
     * 544175208,1701978152,1970172517,1936682102,1701062944,1701209701,
     *1668576032,        -3, 544437603,1746952563, 539521909,1651733609,
     *1953854569,1869504876, 689988713,1936683620,1701981216,1836016741,
     *1814065010, 543449460,1629513074,1919906419, 543256164, 795832864,
     *        -3, 544175717,1915581029,1718185573,1835363956, 773865844,
     *1869441379, 544434548,1702043745,1936943463,1852138528,1952998688,
     *2003988334,1730179939,1635021925,1919512167, 544504176,1696606309,
     * 778513952,1097277472,        -3, 544630130,1937077024,1114777888,
     *1936224117,1818501223,1701733746,1635018016, 661680751,1651271021,
     * 544434535,1851878515, 656439145,1952981108,1751741216,1952805748,
     * 773866593,1952522355,1702130464,        -3, 543387506,1919247220,
     *1701060710,1869750369,1651732338,1886677359,1847616870,1717920628,
     *1931507561,1952981060,1162629701,1176532069,1667788393,1903519091,
     * 539518254,1731076164,1229340994,1395400787,1212501080,1093410848,
     * 542654786,1395796256,1868985445,1847620456,1870078060,1634887525,
     * 541345100,1428190817,1819633011, 543584114, 543321966,1685266537,
     *1853255532,1986621031, 544499813, 543712609,1986618739,1948279156,
     *1869426208,        -3,        -2, 541139059,1885692777,1634476131,
     *1634952480,1634886944,1294811965,1327527033,1885675631,1713402745,
     *1937007981,1931506792,1635000423,1701733746,1634495609, 544434287,
     *1998615401,1735289190,1768120686,1948262432,        -3, 543451494,
     *1717924453,1852007795, 543584114, 544499813, 541928771, 543321966,
     *1680744531,1701126212, 776106593,1734418470, 542387782, 773868399,
     *1702132332,1696606257, 959985705, 740311395,1952522307,1920562036,
     * 773857312, 541209652, 740307253, 825045301, 891891232,        -3,
     *        -2, 542011252,1698308180,1751457903,1919510377,1851878432,
     * 659057010,1936221797,1818504564,1702065191, 544694643, 543450470,
     *1768842596, 543780384,1633842031,1819636837, 544499058,1836261416,
     *1936024864,        -3, 541470284, 776497522,1936221797,1818504224,
     *1097036897, 541291129,1936993824, 674314551, 908668448,1093874220,
     * 540160825, 758264884, 690888788,1751457891,1970434661,1853104244,
     *1702065184,1769152631,1769236512,        -3, 544367974,1701995886/
     * )
      ICK( 25801: 26100) = (/
     *1667571828,1864397928,1696620915,1936679785,1635018084, 544437345,
     *1852072306,1679848814,1667592820,1634299508,2033066016,        -3,
     *        -2, 542011252,1698308180,1751457831,1214870131,1751541100,
     *1680700517,1936992032,1095517522,1414733921,1919230067,1970303090,
     *1702064997,1679844975,1914728559,1819897189,1919509280,1869750372,
     *1769172850,1684370021,1679826976, 544437362,1969452149,1919251246,
     *        -3,        -1, 589315646,1042303081,1920165990,1701602336,
     *1919510377,1680695919,1852055668,1702065184, 676146520, 544436076,
     *1986358900, 689986369,1668571424,1131575667,1949179944, 825833270,
     * 690766131, 841757235, 959263284, 878518304,1597125427, 540094510,
     * 807416117, 774905913, 959328288, 874529056, 538980384, 807416096,
     * 807411744,        -3,1214870131,1751541100,1679829069, 760750163,
     *1869379173,1853106464, 538976292,1093479716,1110319140,1176531758,
     *1965957152,        -3,        -2, 542402661, 543387501,1886350949,
     *1853125408,1868963956,1751457889,1852404591,1953656688,1768104036,
     *1769173100,1633903981,1701737504,1885434465,1835365477,1920147553,
     *1819242087, 543385701,1835623265,1814044704,        -3, 543321966,
     *1685266529,1919230049,1936946541,1701060724,1864393317, 543519093,
     *1634476137,1847618913,1735289204,1969513774, 541876594,1734680676,
     *1768318565,1919250019,1702043757,1768384628,        -3, 543780452,
     *1768120692,1696621423,1853120877,1768841588,1768910368,1868963956,
     *1751479141, 544235890,1634559348,1701999392,2003399784, 544175208,
     *1701978152,1970172517,1936682102,1701062944,1701209701,1668576032,
     *        -3, 544437603,1746952563, 539521909,1651733609,1953854569,
     *1869504876, 689988713,1936683620,1701981216,1836016741,1814065010,
     * 543449460,1629513074,1919906419, 543256164, 795832864,        -3,
     * 544175717,1915581029,1718185573,1835363956, 773865844,1869441379,
     * 544434548,1702043745,1936943463,1852138528,1952998688,2003988334,
     *1730179939,1635021925,1919512167, 544504176,1696606309, 778513952,
     *1097277472,        -3, 544630130,1937077024,1114777888,1936224117,
     *1818501223,1701733746,1635018016, 661680751,1651271021, 544434535,
     *1851878515, 656439145,1952981108,1751741216,1952805748, 773866593,
     *1952522355,1702130464,        -3, 543387506,1919247220,1701060710,
     *1869750369,1651732338,1886677359,1847616870,1717920628,1931507561,
     *1952981060,1162629701,1176532069,1667788393,1903519091, 539518254,
     *1731076164,1229340994,1395400787,1212501080,1093410848, 542654786,
     *1395796256,1868985445,1847620456,1870078060,1634887525, 541345100,
     *1428190817,1819633011, 543584114, 543321966,1685266537,1853255532,
     *1986621031, 544499813, 543712609,1986618739,1948279156,1869426208,
     *        -3,        -2, 542011252,1698308180,1751457903,1919510377,
     *1851878432, 659057010,1936221797,1818504564,1702065191, 544694643,
     * 543450470,1768842596, 543780384,1633842031,1819636837, 544499058,
     *1836261416,1936024864,        -3, 541470284, 776497522,1936221797,
     *1818504224,1097036897, 541291129,1936993824, 674314551, 908668448,
     *1093874220, 540160825, 758264884, 690888788,1751457891,1970434661,
     *1853104244,1702065184,1769152631,1769236512,        -3, 544367974,
     *1701995886,1667571828,1864397928,1696620915,1936679785,1635018084,
     * 544437345,1852072306,1679848814,1667592820,1634299508,2033066016,
     *        -3,        -1, 589315646,1042303081,1920165990,1701602336,
     *1919510377,1680695919,1852055668,1702065184,1531011956,1629504370/
     * )
      ICK( 26101: 26400) = (/
     *2037609518, 539504953, 926296364,1093874220, 842217773, 842282077,
     *        -3,1597125428, 540028465, 891301934, 842342432, 808334112,
     * 874529056, 538980384, 807416096, 807411744,        -3,1281454695,
     *1696614505,1920165990,1701602336,1147758182,1701995886,1667571748,
     *1093479716,1110319140,1176519022,1731076128,        -3,        -2,
     * 542402661, 543387501,1886350949,1853125408,1868963956,1751457889,
     *1852404591,1953656688,1768104036,1769173100,1633903981,1701737504,
     *1885434465,1835365477,1920147553,1819242087, 543385701,1835623265,
     *1814044704,        -3, 543321966,1685266529,1919230049,1936946541,
     *1701060724,1864393317, 543519093,1634476137,1847618913,1735289204,
     *1969513774, 541876594,1734680676,1768318565,1919250019,1702043757,
     *1768384628,        -3, 543780452,1768120692,1696621423,1853120877,
     *1768841588,1768910368,1868963956,1751479141, 544235890,1634559348,
     *1701999392,2003399784, 544175208,1701978152,1970172517,1936682102,
     *1701062944,1701209701,1668576032,        -3, 544437603,1746952563,
     * 539521909,1651733609,1953854569,1869504876, 689988713,1936683620,
     *1701981216,1836016741,1814065010, 543449460,1629513074,1919906419,
     * 543256164, 795832864,        -3, 544175717,1915581029,1718185573,
     *1835363956, 773865844,1869441379, 544434548,1702043745,1936943463,
     *1852138528,1952998688,2003988334,1730179939,1635021925,1919512167,
     * 544504176,1696606309, 778513952,1097277472,        -3, 544630130,
     *1937077024,1114777888,1936224117,1818501223,1701733746,1635018016,
     * 661680751,1651271021, 544434535,1851878515, 656439145,1952981108,
     *1751741216,1952805748, 773866593,1952522355,1702130464,        -3,
     * 543387506,1919247220,1701060710,1869750369,1651732338,1886677359,
     *1847616870,1717920628,1931507561,1952981060,1162629701,1176532069,
     *1667788393,1903519091, 539518254,1731076164,1229340994,1395400787,
     *1212501080,1093410848, 542654786,1395796256,1868985445,1847620456,
     *1870078060,1634887525, 541345100,1428190817,1819633011, 543584114,
     * 543321966,1685266537,1853255532,1986621031, 544499813, 543712609,
     *1986618739,1948279156,1869426208,        -3,        -2, 542011252,
     *1698308180,1751457903,1919510377,1851878432, 659057010,1936221797,
     *1818504564,1702065191, 544694643, 543450470,1768842596, 543780384,
     *1633842031,1819636837, 544499058,1836261416,1936024864,        -3,
     * 541470284, 773867625,1920165990,1701602348, 541156212,1629504370,
     *2037609518, 539504953, 926296366, 541143858, 740307507, 959263284,
     * 875114016,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750389,1853191029,1634495609, 543713639,1746949416,1701914912,
     *1634934883,1869443169,1919247392,2003399784, 543321966,1684366368,
     *1852139879,1751281525,1920147488,        -3,1597125681, 539897905,
     * 891301934, 808788016, 774976800, 840974624, 538980384, 807416096,
     * 807411744,        -3,1214867304, 538976295,1298229614,1299147815,
     * 542467441, 543257376,1131375984,1634887012, 544501536,1315268967,
     *1751281522,1931505510, 538977345, 541288549,1667964960,        -3,
     *        -2, 542402661, 542451813,1898520694,1634497893, 544171552,
     *1634607201,1953459488,1769152611,1869443169,1919247392,2003399784,
     * 544499813, 543258213,1918986085, 542451813,1898520678,1869750388,
     *1864376352,        -3, 544108398, 761821540,1919903589,1847615860,
     *1869443872,1651469924,1701060724,1864395124, 773868641,1919378720,
     *1684629094,1701995886,1667592992,1835104544,1768842345,1667331173/
     * )
      ICK( 26401: 26700) = (/
     * 544499809,1948284008,1696604192,        -3, 544698991,1852252257,
     *1953459488,1954115685, 544694643, 543257459,1768386149,1679829093,
     * 778513952,1310746990,1937007969,1679847270, 542058798,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750357,1853191029,
     *1634495609, 541880183, 538989864,1701914912,1634934883,1869443169,
     *1919247392,2003399784, 543321966,1684366368,1852139879,1751281525,
     *1920147488,        -3,1597125682, 539897905, 891301934, 808788016,
     * 774976800, 840974624, 538980384, 807416096, 807411744,        -3,
     *1282373408, 538976295,1298229614,1299147815, 542467441, 543257376,
     *1131375984,1634887012, 544501536,1315268967,1751281522,1931505510,
     * 538977345, 541288549,1667964960,        -3,        -2, 542402661,
     * 542451813,1898520694,1634497893, 544171552,1634607201,1953459488,
     *1769152611,1869443169,1919247392,2003399784, 544499813, 543258213,
     *1918986085, 542451813,1898520678,1869750304,        -3, 544108398,
     * 761821540,1919903589,1847615860,1869443872,1651469924,1701060724,
     *1864395124, 773868641,1919378720,1684629094,1701995886,1667592992,
     *1835104544,1768842345,1667331173, 544499809,1948284008,1696604192,
     *        -3, 544698991,1852252257,1953459488,1954115685, 544694643,
     * 543257459,1768386149,1679829093, 778513952,1310746990,1937007969,
     *1679847270, 542058798, 541483372,1936007265,1818325613,1931504993,
     *2032148512,        -3, 544170851,1970413670,1869750388,1701997929,
     *1851878432,1735552885,1886593139,1969448992,1634934900,1751457908,
     * 761427316,2037129325,1869178228,2033066016,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750389,1853191029,1634495609,
     * 543713639,1746957167,1819698542,1948276008,1701914912,1634934883,
     *1869443169,1919247392,2003399784, 543321966,1684366368,1852139879,
     *1751281525,1920147488,1597125683, 539897905, 891302190, 808460337,
     * 774909984, 874529056, 538980384, 807416096, 807411744,        -3,
     *1214867304, 538976295,1399811190,1701737511, 542467441, 543257376,
     *1131375984,1634887012, 544501536,1315268967,1751281522,1931505510,
     * 538977345, 541288549,1667964960,        -3,        -2, 542402661,
     * 542451813,1898520694,1634497893, 544171552,1634607201,1953459488,
     *1768824948,1751457907,1869379173,1853104239,1914726767,1847617907,
     * 543387501,1885434469,1679849321,1952981108,1751457889,1986359905,
     *1734680608, 542451813,1898520678,1869750382,1869491560,2036626031,
     *1734700576,1635020653,1931502191,1852073316, 544501536,1769221664,
     *1281454695,1696621673,1717986674,1701733221,1931504993,2032167278,
     *1684628321,1952784416,        -3, 544499809,1948284008,1696626546,
     *1869506336,1635020653, 544504176,1696626529,1931501939,1936287598,
     *1701060648,1697539886, 541991017,1853060197,1633951855,1713393449,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750389,1853191029,1634495609, 543977335, 544436076,1986358900,
     * 538989864,1701914912,1634934883,1869443169,1919247392,2003399784,
     * 543321966,1684366368,1852139879,1751281525,1920147488,1597125684,
     * 539897905, 891302190, 808460337, 774909984, 874529056, 538980384,
     * 807416096, 807411744,        -3,1282373408, 538976295,1399811190,
     *1701737511, 542467441, 543257376,1131375984,1634887012, 544501536,
     *1315268967,1751281522,1931505510, 538977345, 541288549,1667964960,
     *        -3,        -2, 542402661, 542451813,1898520694,1634497893,
     * 544171552,1634607201,1953459488,1768824948,1751457907,1869379173/
     * )
      ICK( 26701: 27000) = (/
     *1853104239,1914726767,1847617907, 543387501,1885434469,1679849321,
     *1952981108,1751457889,1986359905,1734680608, 542451813,1898520678,
     *1869750382,1869491560,2036626031,1734700576,1635020653,1931502191,
     *1852073316, 544501536,1769221664,1281454695,1696621673,1717986674,
     *1701733221,1931504993,2032167278,1684628321,1952784416,        -3,
     * 544499809,1948284008,1696626546,1869506336,1635020653, 544504176,
     *1696626529,1931501939,1936287598,1701060648,1697539886, 541991017,
     *1853060197,1633951855,1713393449, 773867105,1819501856,1634492786,
     *1836261485,1635328032, 544170851,1970413670,1869750388,1701997929,
     *1851878432,1735552885,1886593139,1969448992,1634934900,1751457908,
     * 761427316,2037129325,1869178228,2033066016,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750389,1853191029,1634495609,
     * 543977335, 541601109, 677736745, 543257376,1668246896,1634887012,
     * 544696692,1746952815,1852073316, 543257711,1830821920,        -3,
     *1597125685, 540028464, 824193070, 808788016, 774975520, 840974624,
     * 538980384, 807416096, 807411744,        -3,1428711795,1864966180,
     *1092637549,1634495589,1914729576,1634607189, 677736745, 539247136,
     *1652105252,1176519022,1730816562,        -3,        -2, 542451817,
     *1936664864,1868963937, 543717732,1919903589,1847615860,1869422697,
     *1931503461,1852142177,1819048224,1702391909,1668572516, 544501536,
     *1650794599,1919246708,1701978228,1751215648,1952998688,        -3,
     * 542451813,1898520687,1713402984,1696624239,1848469625,1685221223,
     *1701716065,1953459488,1769218153,1931501940,1952539496,1701060724,
     *1865293856,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750389,1853191029,1634476129,1852404591,1953656688,1768104033,
     *1986359905,1734680661, 677981290, 689971232,        -3,1597125936,
     * 540159536, 807416878, 808460345, 774909984, 840974624, 538980384,
     * 807416096, 807411744,        -3,1281454695,1696617779, 794112288,
     *1382118505,1864394351,1914715221, 677981290, 691937364,1701737327,
     *1915233345, 689972294, 542011252,1696604192,        -3,        -2,
     * 541158944,1635149170,1634166048,1986096245,1696624486, 544499813,
     * 542451817, 745154848,1952804467,1869750383,1713402984,1696620915,
     *2037214565,1953655139, 544566889,1948282726, 543236210,1702062436,
     *1969561632,        -3, 543781664,1667329123,1970037108,1701064224,
     *1097736257,1279611476, 543781664,1734700645,1918989413,1679849320,
     *1701716084,1751457891,1869771365,1936748398,1684631143, 544039273,
     *1847615864,1769152597, 858740017,        -3, 544366964,1768890468,
     *1702259041,1952805664,1936287598,1768319331,1634628716,2032166514,
     *1869422641, 774909472,1281454695,1696626273,1819633011, 544171552,
     *1952999795, 544366964,1768890483,1752135020,1679843941,        -3,
     * 544498027,1701716065,1931501934, 543780452,1768120692,1768910368,
     *1868963952,1869837161,1651270944,1937339252,1701667188,1768104037,
     *1920102258,1931503982, 544499813, 543449460,1629515634, 543519346,
     *1869771552,        -3, 543780384,1952998688,1836016741,1814962262,
     *1769174369,1814063470,1936745827,1953066862, 544171552,1634607183,
     *1381254480, 544238703,1948284777,1819025523,1752135456,1952997748,
     * 544039278,2032148512,        -3, 543451507,1886151011,1701668206,
     *1948280172,1818849395,1869177971, 543711606,1696625768,1701409312,
     *1835100783,1914724728,1769152624,1869180532,1768843040,1768824948,
     *1751457907,1634559264,1684632165,1668573551,1848516640,        -1/
     * )
      ICK( 27001: 27300) = (/
     * 589315646,1042306149,1936990310,1869750376,1768384544,1635149170,
     *1634166048,1432711456,1718579744,1919251305,1685415200,        -3,
     *1597126192, 539898160, 807415854, 858791985, 774909984, 840974624,
     * 538980384, 807416608, 807411744,        -3,1281454695,1696612726,
     *1701994855,1696617829,1897951078, 542270835,1768191333, 541683299,
     *1819632745,1852252196,1092625478, 541288549,1667964960,        -3,
     *        -2, 541139052,1634887525, 543258213,1918986085, 542467441,
     * 544629100,1969561702,1869750369, 544367987,1768191333, 544039289,
     * 543780452,1768120692,1696625253,1718185573,1835363956, 544696692,
     *1746952480,1953460000,        -3, 543713639,1746937968,1869837161,
     *1651276064,1718188133,1680416880,1869641068,1635019119,1847619681,
     *1918987621,1952805408,1986096245,1697521696,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750374,1769497956, 544235890,
     *1953063276, 544170851,1970299246,1668882547,1769235827,        -3,
     *1597126969, 538976288, 807411744, 540024864, 538980384, 874529056,
     * 538980384, 807416096, 807411744,        -3,1098149741, 542337396,
     *1696616291,1668640865,1852012832,1131376243,1953653097,1852138528,
     *1635000366, 774778414, 774778414, 774778414, 539248160,1130915171,
     *1797267488,        -3,        -2, 542402665,1931506537,1952784489,
     *1931502968,1885692788,1701060724,1864393317, 543585644,1819877487,
     *1667462512,1768252448,1651864608,1751216928,1650812270, 543387502,
     *1937011297,1768842596, 539518254,1731076128,        -3, 544696692,
     *1746952480,1397245260,1481384006,1447121440,1986097769,1633840229,
     * 689991538, 543582584,1701060705,1948279072,1986096245,1696623717,
     *1936924788,1751215648, 825110574, 542141541,1634952480,1667786083,
     *1797267488, 543584114, 543780451,1869443180,1702126880, 678655330,
     *1937009012,1970563439,1851878441, 543451507,1869767781,1914726497,
     *1852075113,1852255776,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750374,1769497956, 544235890,1953063276, 544170851,
     *1970299246,1668882464,        -3,1597190192, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807416096, 807411744,
     *        -3,1098149741, 542337396,1696616291,1668640865,1852012832,
     *1868963876,1092624451,1869509492,1918986606,1701060705,1948263494,
     * 541288549,1667964960,        -3,        -2, 542402665,1931506537,
     *1952784489,1931502968,1885692788,1701060724,1864393317, 543585644,
     *1819877487,1667462512,1768252448,1651864608,1751216928,1650812270,
     * 543387502,1937011297,1768842596, 539518254,1731076128,        -3,
     * 544696692,1746952480,1397245260,1481384006,1447121440,1986097769,
     *1633840229, 689991538, 543582584,1701060705,1948279072,1986096245,
     *1696623717,1936924788,1751215648, 825110574, 542141541,1634952480,
     *1667786083,1797267488, 543584114, 543780451,1869443180,1702126880,
     * 678655330,1937009012,1970563439,1851878441, 543451507,1869767781,
     *1914726497,1852075113,1852255776,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750381,1634299424,1919251305,1685415208,
     *1932075108,1769172850,1684369952, 622862368,        -3,1597190193,
     * 538976288, 807411744, 540024864, 538980384, 857751840, 538980384,
     * 807416096, 807411744,        -3,1298229614, 542270835,1768191333,
     * 538985577,1936683620,1701978158, 774778414, 774778414, 774778414,
     * 774382657, 690243877, 542011252,1696604192,        -3,        -2,
     * 541160559,1830843241,1952805664,1952997748, 543257189, 544108404/
     * )
      ICK( 27301: 27600) = (/
     * 543585644,1819877487,1667462512,1768252448,1634886944,1668248942,
     *1952801838, 541139052,1634887525, 543584865,1668573551,1847619430,
     *        -3, 543451507,1869767781,1919247392,1635020653,1931504993,
     *2032165477, 543321972,1746952480,1936287598,1634476134,1869750387,
     *1701996911,1970479219,1953658211,1953854053, 543256161,1819898729,
     *1931485216,        -3, 544240239,1651271021,1931505522, 543974771,
     *1931506277,1818845538,1818570601,1853121906,1702065257,1852252274,
     *1702065516,1953705504,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750312,1634625903,1848603503,1819698542,1948852324,
     *1769172850,1684369952, 622862368,        -3,1597190194, 538976288,
     * 807411744, 540024864, 538980384, 874529056, 538980384, 807416096,
     * 807411744,        -3,1097754991,1848595311,1819698542,1949257065,
     *1852797485,1382380393,1685415200,1147761519,1919182194, 539501633,
     * 690243877, 542011252,1696604192,        -3,        -2, 541160559,
     *1830843241,1952805664,1952997748, 543257189, 544108404, 543585644,
     *1819877487,1667462512,1768252448,1634886944,1668248942,1952801838,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750381,
     *1869767968,1952997742, 540090467,1869508197,1668573551,1847620719,
     * 541601121,1953459571,        -3,1597190195, 538976288, 824188960,
     * 540155936, 538981152, 840974624, 538980384, 807416096, 807411744,
     *        -3,1182100588, 542073699,1970299246,1668882497,1953459488,
     * 608247927,1769236512, 589316975,1852728675,1953066862,1931486278,
     * 541288549,1667964960,        -3,        -2, 541620580,1919903589,
     *1847615860,1869443872,1634886944,1734700645,1918987372,2032165743,
     *1852728675,1952801824,1953439855,1852602656,1869505824,1869899877,
     *1914724724,1869426208,1092642937,1685221223,1701716000,        -3,
     * 543257711,1830838885,1953981797,1847620727,1864396664,2036819310,
     * 543257711,1836261481,1931501856,1936745827,1767992352,1667330917,
     * 773867886,1986360180,1768382836,1696626536,1702127717,1914729576,
     *1769152544,        -3, 543717732,1919903589,1847615860,1869422697,
     *1931502181,1953785202, 543450483,1668442466,1701060727,1769236512,
     *1629512809,1936683620,1701978221,1868850540, 544696692,1746957431,
     *1864396897,1920231777,1819048224,        -3, 544170851,1970301285,
     *1679848297,1952805678, 541139044,1768318565,1919250019,1696623969,
     *1881173353,1734898720,1936224119, 543236196,1869963884,1697478501,
     *1819025508,1701737321,1954098720,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750382,1869491561,1853121895,1701978222,
     *1970102885,1914728294, 543257711,1836261481,1847620197,1936286837,
     *1696604192,        -3,1597190196, 538976288, 807411744, 540155936,
     * 538980896, 874529056, 538980384, 807416096, 807411744,        -3,
     *1315925549,1231975525,1734701600,1316318562,1701978223,1713389940,
     *1869443872,1768824878, 774778414, 539501634, 689972294, 541288549,
     *1667964960,        -3,        -2, 541139054,1869491561,1853121895,
     *1701978222,1970102885,1914728294, 543257711,1836261480,1634934882,
     *1701146144,1718580590,1679845742, 543236210,1702062436,1969565216,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750377,
     *1936682081,1952801824,1210933620,1869443872,        -3,1597190197,
     * 538976288, 807411744, 540024864, 538980384, 840974624, 538980384,
     * 807416096, 807411744,        -3,1232301932,1635018084, 541620580,
     *1919903589,1847607668,1869422624, 539512693,1953720676,1696612975/
     * )
      ICK( 27601: 27900) = (/
     *1852055634,1634625381, 541015849, 538977345, 541288549,1667964960,
     *        -3,        -2, 542402665,1931506789,1936990322,1701867378,
     *1953701999,1847617657,1685221223,1701716065,1953459571, 544499809,
     *1948279154,1696624239,1948282734, 543321966,1684631143, 543451507,
     *1952542307,1696625775, 543256185,        -3, 543257711,1831739476,
     *1751741216,1095517522,1411411297,2032167278,1684628321,1952784500,
     *1751217184,1952998688,1752786034,1869047150, 543257711,1830842981,
     *1718185573,1679848559, 543236128,        -3, 544108398, 761425774,
     *1684631143, 544239475,1769236847,1847619442, 544105829,1685266529,
     * 544438637,1835365490,2032168816,1701994868,1768910368,1953439842,
     *1919512167, 543781920,1953439842,1869505641,1852252192,        -3,
     * 543451507,1952542307,1697521737,1948279148,1936662637,1635328105,
     *1852074339,1635018016,1629515890,1868721253,1830844265,1952981097,
     *1852010349,1885434985,1651270944,1886351477,1818326121,1869488160,
     *        -3, 544235890,1634559348,1701999392, 677719655, 773866272,
     * 757090336,2003399784, 544239472,1970037108,1768910368, 808335392,
     *1634624544, 808335648,1919251312,1701016681,1986358393, 690888736,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750377,
     *1936682081,1952801824,1870166375,1701716065,1953459571,        -3,
     *1597190198, 538976288, 807411744, 540024864, 538980896, 840974624,
     * 538980384, 807416096, 807411744,        -3,1232301932,1635018084,
     * 542079097,1734700576,1098149741, 539510829,1635020653,1931496809,
     *1936943470,1730166569, 539897390, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 542402665,1931506789,1936990322,
     *1701867378,1953701999,1847619448,2036819310, 543257711,1836261492,
     *1751217184,1634886944,1852797984,2003399784,1768824930,1869505641,
     *1852252260,1769174113,1852007712,1953439776,        -3, 543256185,
     * 544175208,1701978209,1953459488,1768824948,1751457907,1953658211,
     *1953854053, 773865760,1668246893,1869488242,1700885359,1847618913,
     *2032165477, 544499809,1948282479, 543717732,1919903589,1847599136,
     *        -3, 543257711,1836261473,1919230055,1769366894, 543584114,
     * 543236215,1635018098, 544042860,1701016940,1697521729,1953785197,
     *1886679840,1936224117,1818501218,1696623969,1684349044,1864395887,
     *1667331173,        -3, 544499823,1936007272,2036626031,1734700576,
     *1635020653,1931503218,1869422689, 543451494,1717924453,1852007712,
     *1835102254,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750377,1936682081,1952801824,1835365473,1814061428,1869443872,
     *        -3,1597190199, 538976288, 807411744, 540024864, 538980384,
     * 840974624, 538980384, 807416096, 807411744,        -3,1232301932,
     *1635018084, 541943156,1634476097,1953459488,1718580590,1679845742,
     * 542340210,1969452149,1919229992,1433302387,1969318953, 538977345,
     * 541288549,1667964960,        -3,        -2, 542402665,1931506789,
     *1936990322,1701867378,1953701999,1847618917,1952541728,1635020653,
     *1931506792,1635000417,1919230062,1869881442,1869505637,1679847282,
     * 543257632,1668247410,1684631137,1953066862,        -3, 543451507,
     *1952542307,1696624486, 544175208,1701978209,1953459571, 773867891,
     *1869373812,1701060713,1869509408,1634886944,1986359929, 544566901,
     *1937072492, 539520882, 544108398, 761624681,1937007982,1948270377,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1768843116,1696621167,1852073316, 544040308,1634476129,1953459571/
     * )
      ICK( 27901: 28200) = (/
     *        -3,1597190200, 538976288, 807411744, 540024864, 538980384,
     * 840974624, 538980384, 807416096, 807411744,        -3,1399418471,
     *1818566722,1869505637,1679838565,1952541728,1098149741, 543780384,
     *1400140405,1668576626,1696604200,1433302387,1969318953, 538977345,
     * 541288549,1667964960,        -3,        -2, 542402665,1931506789,
     *1936990322,1701867378,1953701999,1847620457,1852271717, 543321966,
     *1684366368, 677605231,1919183214,1635018084, 689991013,1952541728,
     *1635020653,1932487023,1853042208,1416128883,        -3, 544367984,
     *1919251301,1853125408,1629517413,1920540789,1853191029,1634476147,
     *1769239905,1953066862, 773870696,1701995808,1634886944,1818850405,
     *1918989429,1919230053,2019650928,1818587936,2003330418,1696625525,
     *1667768352, 543236135,1936289383,1818566754,1869505637,1679846757,
     *1952541735, 544694643, 544434287,2003705972,1864393317, 543236200,
     *1634496359,1701719584,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1768843116,1696621167,1852073316, 544176249,
     *1734700576,1635020653,1931485216,        -3,1597190201, 538976288,
     * 807411744, 960045088, 540621088, 840974624, 538980384, 807416096,
     * 807411744,        -3,1399418471,1818566722,1869505637,1679839096,
     *2036819310, 539509549,1327513120, 825111328,1097754409, 539897390,
     * 774778414, 774778414, 538977345, 541288549,1667964960,        -3,
     *        -2, 542337390,1735157024,1651469924,1701060687,2021222245,
     *1847621481,1952981059, 760160318, 540094003, 541159015,1937011311,
     *1831739469,1769173865,1852252232, 759264367,1830829856,1130915171,
     *1797267488,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750311,1953460000,1668050803,1697062952,1937337709,1702130297,
     * 544367980,1635018084, 689989237,1819025527,1701406568,1948279156,
     *1869443872,        -3,1597190448, 538976288, 807411744, 540024864,
     * 538980384, 840974624, 538980384, 807416096, 807411744,        -3,
     * 608247876,1701602676,1701060648,1131179891,1696625775, 539247145,
     * 538985577,1936990254, 774774820,1176519022,1731076128,        -3,
     *        -2, 542402665,1931506789,1936990313,1684369012,1768319333,
     *1931487350,1702000937, 544434287,1920213091,1869509729,1668576032,
     *1650816119,1701146144,1635020653,1931506792,1635000431,1852602656,
     *1650811759,1835365152,        -3, 543256688,1634887022,1948279142,
     *1952805408,1952998688,1634758764,1768120692,1768910368,1868963955,
     *2037214565,1953659168,1869488244,1751457904,1919511905,1920540771,
     *1869574756,1768841588,1696625509,1949179936,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750377,1936682081,1952801824,
     *1684632431,1919182194,1701060687,2021222245,1847607668,1869443872,
     *        -3,1597190449, 538976288, 807411744, 825237536, 540094496,
     * 840974624, 538980384, 807416096, 807411744,        -3,1232301932,
     *1635018084, 541354355,1869767781,1919247392,1333295463,1701716033,
     *1953459488, 676228896,1210544928,1059659822, 774778414, 538977345,
     * 541288549,1667964960,        -3,        -2, 542402665,1931506789,
     *1936990322,1701867378,1953701999,1847619448,2036819310, 543257711,
     *1836261416,1852797984,1718971500, 544695657,1734898729, 544499809,
     *1948279154,1696624239,1948284777,1952999790,        -3, 543321966,
     *1684631143, 543451507,1952542307,1696625775, 543256185, 544175208,
     *1701978209,1953459488,1768824948,1751457907,1953658211,1953854053,
     * 773857312,        -3, 541139043,1869442415,1847620197,1634955118/
     * )
      ICK( 28201: 28500) = (/
     * 544039289, 543319328,1952997748, 544108320,1752786034,1869047150,
     * 543257711,1836261473,1919230055,1769366894, 543584114, 543236215,
     *1635018098, 544042860,1701016940,1697521696,        -1, 589315646,
     *1042306149,1936990310,1869750339,1028599112, 543647087,1835365490,
     *2032148512,        -3,1597190450, 538976288, 807415854, 808591408,
     * 774911264, 840974624, 538980384, 807416096, 807411744,        -3,
     *1400140385,1852269856,1127042861,1210074981,1869440372,1920540712,
     *1127042848, 540811296, 540094002, 891306350,1730748462, 774778414,
     * 538977345, 541288549,1667964960,        -3,        -2, 542340210,
     *1634625381, 541273423, 759701607,1701801317,1953659168,2003399784,
     * 541273423, 538983456, 538980654, 842342465,1852273524,1919905056,
     *1684370533,1668572516, 773868905,1936747617,1667589152,        -3,
     * 541601089,1953459488,1059069984,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750351,2021222245,1847621481,1952981108,
     *1752327525, 543387510,1634493806,1948279407,1852076832,        -3,
     *1597190451, 538976288, 807411744, 540155936, 538980896, 840974624,
     * 538980384, 807416096, 807411744,        -3,1333295463,1701716087,
     *1769236512,1416131173,1696613231,1986096229,1853104194,1869505651,
     * 539521633,1919232288, 774778414, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 542079097,1734700576,1635020653,
     * 544696692,1746957416,1919247648,1668249185,1818586740, 543321966,
     *1685266532,1702126947,1952801838, 541288549,1667965030,1869750371,
     *1869771365,1668554849,1953459488,1954115685,        -3, 543257459,
     *1768386157,1701737504, 677719655, 773869088,1918989416,1701978228,
     *1751215648,1328095264,        -3,        -2, 542011252,1698308165,
     *2019779952,1953066862,1931501938,1696614451,1328226344,1333291373,
     *1769303328,1869750344,2036626031,2020568681,1970088224,1634624544,
     *        -3, 538976288, 538976288, 538976288, 538976288, 538976288,
     * 538986549,1328687904, 675838308,1919905385,1970085999,1914724721,
     *1969302888,2036626031,2020568681,1970088224,1936745827,1768256302,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750381,
     *1702125932, 760163656, 543256167,1818566767,1713391666,1327505440,
     *        -3,1597190452, 538976288, 807411744, 540155936, 538980896,
     * 840974624, 538980384, 807416096, 807411744,        -3,1399677292,
     *1814053230,1735157024,1718579744,1211256634, 541943156,1634479396,
     *1093477442, 539893796,1176519781,1735550309,        -3,        -2,
     * 541139063,1635018098, 544042860,1701016940,1696621423,1869767785,
     *1851880549,1679848559, 543236205,1702125932, 543781664,1684370533,
     *1668572516, 544696692,1746952558, 544566901,1937072492,1819877491,
     *1835101292,        -3, 544629100,1969561711,1713402984,1696615781,
     *1952541741,1333295463,1701719368,2036626031,1734700576,1097754476,
     *1697521696,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1768843116,1696621167,1852073316, 543383922,1651469856,
     *1635020653,        -3,1597190453, 538976288, 807411744, 540024864,
     * 538980896, 840974624, 538980384, 807416096, 807411744,        -3,
     *1399418471,1819877442,1869505637,1679836001,1919053678, 541353332,
     *1701016677,1679829064, 761361519,1836261453,1769173865,1852254510,
     * 538977345, 541288549,1667964960,        -3,        -2, 541288549,
     *1667965030,1869750381,1769173865,1852252232, 761361519,1836264992,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744/
     * )
      ICK( 28501: 28800) = (/
     *1953460000,1835101817, 541599603, 544173600,1126197614, 541277518,
     * 543321966,1679845742, 544039273,1847620197,1936286837,1697149737,
     *        -3,1597190454, 538976288, 807411744, 540024864, 538980384,
     * 840974624, 538980384, 807416096, 807411744,        -3,1416589088,
     *1835101817, 541597807,1847608096,1768824899,1028530253,1869178228,
     *2032167278, 541942121,1847612005,1936286837,1696607790, 538977345,
     * 541288549,1667964960,        -3,        -2, 541158944,1936732960,
     *1752785522,1768188282,1701060675, 544694643, 543450484,1701016677,
     *1679843699, 544235890,1948282726, 543236163,1028530285,1869178228,
     *2033066063,1852602656,1869505824,        -3, 543257716,1633904741,
     *1679837216,1635020653, 543780384,1936732704,1668247142,1768387954,
     *1635019119,1847617907, 543520880,1701016677,1679843694,1679847023,
     *1948284023,1865293856,        -3, 541683232,1397245260,1481384052,
     *1701997939, 544499817,1931502447,1920099699,1886350948,1931507561,
     *1952981089,1847616882,1919905381,1869968160,1095125336, 540160800,
     *1918989416,1701978228,1751215648,1634607136,        -3, 541148745,
     *1478505523, 544504176,1696624486, 541597793,1953459488,1886352233,
     *1953066862, 543647086,1701994868,1768910368,1634624544,1919247977,
     *1852140901,1853107744,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1953460000,1835101817, 541599603, 544173600,
     *1126197614, 541277518, 543321966,1679845742, 544436076,1986358900,
     * 795438958, 539521833,        -3,1597190455, 538976288, 807411744,
     * 825237536, 540094496, 840974624, 538980384, 807416096, 807411744,
     *        -3,1416589088,1835101817, 541597807,1847608096,1768824899,
     *1028530253,1869178228,2032167278, 542338924,1986358900, 793341806,
     * 539897390, 538977345, 541288549,1667964960,        -3,        -2,
     * 541158944,1936732960,1752785522,1768188282,1701060675, 544694643,
     * 543450484,1701016677,1679843699, 544235890,1948282726, 543236163,
     *1028530285,1869178228,2033066063,1852602656,1869505824,        -3,
     * 543257716,1633904741,1679837216,1635020653, 543780384,1936732704,
     *1668247142,1768387954,1635019119,1847617907, 543520880,1701016677,
     *1679843694,1679847023,1948284023,1865293856,        -3, 541683232,
     *1397245260,1481384052,1701997939, 544499817,1931502447,1920099699,
     *1886350948,1931507561,1952981089,1847616882,1919905381,1869968160,
     *1095125336, 540160800,1918989416,1701978228,1751215648,1634607136,
     *        -3, 541148745,1478505523, 544504176,1696624486, 541597793,
     *1953459488,1886352233,1953066862, 543647086,1701994868,1768910368,
     *1634624544,1919247977,1852140901,1853107744,        -3,        -1,
     * 589315646,1042303097,1651665252,1769169268,1768910368,1886547810,
     *1818586400,1869488206, 543780384,1835100526, 544367987,1768191333,
     * 678635808,        -3,1597190456, 538976288, 807411744, 960045088,
     * 540621088, 840974624, 538980384, 807416096, 807411744,        -3,
     *1215914610,1768188275,1635019119,1847619430, 539246880,1768824909,
     *1634299424,1382380393,1685415200, 774778414, 773857312, 538988652,
     *1700885349, 541288549,1667964960,        -3,        -2, 542402661,
     * 544499059,1948279156,1952804208,1953702004,1864393075,1936287598,
     * 544173669, 544171552,1953002085,1696622713,1651665252,1769169268,
     *1768910451, 544501536,1310744948,1869443872,1768824941,1634299424,
     *        -3, 544367987,1768191333, 975205232, 740324208, 840986482,
     * 544436275, 544173600,1952998688,1650553705,1931505510, 544499813/
     * )
      ICK( 28801: 29100) = (/
     * 543256167,1818587936,1634889589,1852055630, 773857312,        -3,
     * 542402665,1931493708,1163023392,1835104544,1768842345,1667331173,
     * 543236205,1769155937,1936943463,1852138528,1210081652,1869422704,
     *1869834612,1768910368, 677719655, 773874030, 543257711,1830821920,
     *        -3, 544238689,1667589152,1768824929, 544436274, 544239475,
     *1769236847,1847617902,1937007969,1679847270, 544436275, 690888736,
     *        -3,        -1, 589315646,1042303097,1651665252,1769169268,
     *1768910368,1886547810,1818586400,1869488206, 543780384,1936682102,
     *1701737519,1768910368,        -3,1597190457, 538976288, 807411744,
     * 960045088, 540621088, 840974624, 538980384, 807416096, 807411744,
     *        -3,1215914610,1768188275,1635019119,1847619430, 539246880,
     *1768824915,1869379173,1853108041,1869488174, 774778414, 773857312,
     * 538988652,1700885349, 541288549,1667964960,        -3,        -2,
     * 542402661, 544499059,1948279156,1952804208,1953702004,1864393075,
     *1936287598, 544173669, 544171552,1953002085,1696622713,1651665252,
     *1769169268,1768910451, 544501536,1310744948,1869443872,1768824941,
     *1634299424,        -3, 544367987,1768191333, 975205232, 740324208,
     * 840986482, 544436275, 544173600,1952998688,1650553705,1931505510,
     * 544499813, 543256167,1818587936,1634889589,1852055630, 773857312,
     *        -3, 542402665,1931493708,1163023392,1835104544,1768842345,
     *1667331173, 543236205,1769155937,1936943463,1852138528,1210081652,
     *1869422704,1869834612,1768910368, 677719655, 773874030, 543257711,
     *1830821920,        -3, 544238689,1667589152,1768824929, 544436274,
     * 544239475,1769236847,1847617902,1937007969,1679847270, 544436275,
     * 690888736,        -3,        -1, 589315646,1042303097,1651665252,
     *1769169268,1768910368,1886547810,1818586400,1869488195, 543780384,
     *1835100526, 544367987,1768191333, 678635808,        -3,1597190704,
     * 538976288, 807411744, 960045088, 540621088, 840974624, 538980384,
     * 807416096, 807411744,        -3,1215914610,1768188275,1635019119,
     *1847619430, 539246880,1768824909,1634299424,1382380393,1685415200,
     * 774778414, 773857312, 538988652,1700885349, 541288549,1667964960,
     *        -3,        -2, 542402661, 544499059,1948279156,1952804208,
     *1953702004,1864393075,1936287598, 544173669, 544171552,1953002085,
     *1696622713,1651665252,1769169268,1768910451, 544501536,1126195572,
     *1869443872,1768824941,1634299424,        -3, 544367987,1768191333,
     * 975205232, 740324208, 840986482, 544436275, 544173600,1952998688,
     *1650553705,1931505510, 544499813, 543256167,1818587936,1634889589,
     *1852055619, 773867886, 544499817,1931507553,2032934944,        -3,
     * 544041331,1936289383, 541597793,1953459571, 544174624,1953460000,
     *1835101817, 541601121,1953459571, 544173600,1629512545,1919053678,
     * 543257711,1830843240,1869966436, 543319328,1684370533,1668572516,
     * 773857312,        -3,        -1, 589315646,1042303097,1651665252,
     *1769169268,1768910368,1886547810,1818586400,1869488195, 543780384,
     *1936682102,1701737519,1768910368,        -3,1597190705, 538976288,
     * 807411744, 960045088, 540621088, 840974624, 538980384, 807416096,
     * 807411744,        -3,1215914610,1768188275,1635019119,1847619430,
     * 539246880,1768824915,1869379173,1853108041,1869488174, 774778414,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542402661, 544499059,1948279156,1952804208,1953702004,
     *1864393075,1936287598, 544173669, 544171552,1953002085,1696622713/
     * )
      ICK( 29101: 29400) = (/
     *1651665252,1769169268,1768910451, 544501536,1126195572,1869443872,
     *1768824864,        -3, 544436076,1986358831,1634625903,1849303155,
     *1881940083,1882333295,1914729328, 857763694, 544499813, 543318387,
     *1769152623,1713402984,1696620910,1735157107, 543257199,1970168864,
     *1127096393,1847620712,1769152544,        -3, 544694649, 544041331,
     *1936289383, 541597793,1953459571, 544174624,1953460000,1835101817,
     * 541601121,1953459571, 544173600,1629512545,1919053678, 543257711,
     *1830843240,1869966436, 543319328,1684370533,1668572516, 773857312,
     *        -1, 589315646,1042303097,1651665252,1769169268,1768910368,
     *1886547810,1818586400,1869488238,1869491523, 543780384,1835100526,
     * 544367987,1768191333, 678635808,        -3,1597190706, 538976288,
     * 807411744, 960045088, 540621088, 840974624, 538980384, 807416096,
     * 807411744,        -3,1215914610,1768188275,1635019119,1847619430,
     * 539246880,1768824909,1634299424,1382380393,1685415200, 774778414,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542402661, 544499059,1948279156,1952804208,1953702004,
     *1864393075,1936287598, 544173669, 544171552,1953002085,1696622713,
     *1651665252,1769169268,1768910451, 544501536,1629515375,1848460064,
     *1635020653, 543780384,        -3, 544499813, 544039273,1847620197,
     *1936286837,1698308211,1881940083,1882333295,1914729328, 857763694,
     * 544499813, 543318387,1769152623,1713402984,1696620910,1735157107,
     * 543257199,1970168864,1952998688,1852796461,1126178848, 543257711,
     *1831739465,1847620712,1769152631,1635331104,1835627379,1768843040,
     *1210081652,1869443872,1869750388,1869553773,1634629920,1210933620,
     *1869443872,1936224117,1818501218,1696621669,1952801652,1701064224,
     *        -3,        -1, 589315646,1042303097,1651665252,1769169268,
     *1768910368,1886547810,1818586400,1869488238,1869491523, 543780384,
     *1936682102,1701737519,1768910368,        -3,1597190707, 538976288,
     * 807411744, 960045088, 540621088, 840974624, 538980384, 807416096,
     * 807411744,        -3,1215914610,1768188275,1635019119,1847619430,
     * 539246880,1768824915,1869379173,1853108041,1869488174, 774778414,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542402661, 544499059,1948279156,1952804208,1953702004,
     *1864393075,1936287598, 544173669, 544171552,1953002085,1696622713,
     *1651665252,1769169268,1768910451, 544501536,1629515375,1848460064,
     *1635020653, 543780384,        -3, 544499813, 544436076,1986358900,
     * 794914409,1869494816,1936731168,1936732704,1869750387,1882398831,
     *1847620712,1696621153,1936290592,1868963956,1751457889,1852271717,
     *1931501938,1869966948, 544499813,        -3, 544108398, 759373921,
     *1953459502, 541683232,1952999795, 544694649, 740322665,1936943470,
     *1730168864,1635020653,1931505522, 544501615, 544039278,2032158765,
     *1635020653,1931506536,1869966436, 543319328,        -3, 543450484,
     *1701016677,1680744480,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1886352243,1768057977, 544041331,1936289383,
     * 541597807,1847616367,1869767785,1851880553,1852252248, 760098136,
     * 543780384,1835100526, 544367987,1768191333,        -3,1597190708,
     * 538976288, 807411744, 960045088, 540621088, 840974624, 538980384,
     * 807416096, 807411744,        -3,1130915171,1797285487,1914720367,
     *1936943458,1819877453,1769173865,1852252232, 544173600,1131376498,
     *1684631137,1953066599, 774778414, 538977345, 541288549,1667964960/
     * )
      ICK( 29401: 29700) = (/
     *        -3,        -2, 541288549,1667965030,1869750384,1869837161,
     *1651276064,1835627379,1768843040,1215915122,1869047150, 543257711,
     *1830842222, 542009716,1919903589,1847616367,1869767785,1851880553,
     *1852252276,1864392992,1835365473,1814044704, 543780384,1952998688,
     *1835100526, 544367987,1768191333, 773857312,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1886352243,1768057977,
     * 544041331,1936289383, 541597807,1847616367,1869767785,1851880553,
     *1852252248, 760098136, 543780384,1936682102,1701737519,1634625903,
     *1847599136,        -3,1597190709, 538976288, 807411744, 960045088,
     * 540621088, 840974624, 538980384, 807416096, 807411744,        -3,
     *1130915171,1797285487,1914720367,1936943458,1819877453,1769173865,
     *1852252232, 544173600,1131376498,1684631137,1953066599, 774778414,
     * 538977345, 541288549,1667964960,        -3,        -2, 541288549,
     *1667965030,1869750384,1869837161,1651276064,1835627379,1768843040,
     *1215915122,1869047150, 543257711,1830842222, 542009716,1919903589,
     *1847616367,1869767785,1851880553,1852252276,1864392992,1835365473,
     *1814044704, 543780384,1952998688,1936682102,1701737519,1634625903,
     *1848516640,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1886352243,1768057977, 544041331,1936289383, 541597807,
     *1847619695,1952804468,1767992428,2032169840, 857752417,1919053678,
     *        -3,1597190710, 538976288, 807411744, 540024864, 540621088,
     * 840974624, 538980384, 807416096, 807411744,        -3,1349481331,
     *1768057957, 541944179,1936289383, 541597807,1847620464, 859775043,
     *1634886255,1847602734, 774778414, 774778414, 774778414, 538977345,
     * 541288549,1667964960,        -3,        -2, 541288549,1667965030,
     *1869750384,1869837161,1651276064,1835627379,1768843040,1215915122,
     *1869047150, 543257711,1830842222, 541286770,1651469856,2003399784,
     * 544436275, 762079595,1696622437,1869440372,1920540704,        -3,
     * 543780384,1952998688,1835100526, 544367987,1768191333, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1886352243,1768057977, 544041331,1936289383, 541597807,1847619695,
     *1952804468,1767992428,2032169840, 857752417,1919053678,        -3,
     *1597190711, 538976288, 807411744, 540024864, 540621088, 840974624,
     * 538980384, 807416096, 807411744,        -3,1349481331,1768057957,
     * 541944179,1936289383, 541597807,1847620464, 859775043,1634886255,
     *1847602734, 774778414, 774778414, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 541288549,1667965030,1869750384,
     *1869837161,1651276064,1835627379,1768843040,1215915122,1869047150,
     * 543257711,1830842222, 541286770,1651469856,2003399784, 544436275,
     * 762079595,1696622437,1869440372,1920540704,        -3, 543780384,
     *1952998688,1936682102,1701737519,1634625903,1848516640,        -3,
     *        -1, 589315646,1042301800,1701014304,1718579744,1629515887,
     *1936943458,1819877485,1769173865,1852252232, 544173600,1886352485,
     *1853122913,1819048224,1936732960,1885892467,1885892466,1970479136,
     *        -3,1597190712, 538976288, 807411744, 960045088, 540621088,
     * 874529056, 538980384, 807416096, 807411744,        -3,1349481331,
     *1768057957, 541944179,1936289383, 541597807,1847620464, 859775056,
     *1752134512,1752134261,1931488814, 774778414, 774778414, 538977345,
     * 541288549,1667964960,        -3,        -2, 541288549,1667965030,
     *1869750369, 544239475,1936286316,2032168297,1936943470,1730168953/
     * )
      ICK( 29701: 30000) = (/
     *1685221223,1701716065,1953459488,1869488208,1752134512,1752134261,
     *1931507561,1952981107,1882402156,1768645920,        -3, 543647087,
     *1835365490,2033066016,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1970168684,1700885024,1667330658,1869488225,
     *1953459488,1752785522,1768188275,1635019119,1847599136,        -3,
     *1597190713, 538976288, 807411744, 960045088, 540621088, 874529056,
     * 538980384, 807416096, 807411744,        -3,1130459746,1869488193,
     *1953459488,1215914610,1768188275,1635019119,1847612782,1668048225,
     *1914725999,1914711598, 774778414, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 542402661, 543717730,1919509609,
     *1935766633,1869488239,1713402984,1769152611,1634493039,1847615860,
     *1869422691,1869966436, 544108404, 543319328,1702065249,1651272051,
     *1751475232,1718775661, 544499813,        -3, 544109933,1650815520,
     *1868963955,1969386356,1769239909,1853125408,1634624544,1952998761,
     *1914726245,1869440372,1920544288,1130915171,1797285487,1914727785,
     *1936943470,1730177145,1685221223,1701716065,1953459571,        -3,
     * 543256164, 795832864,1886351218, 543647087,1835365490,2033066016,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1818325607,1696620918,1701994855,1696624744,1701738860, 541273411,
     * 543321966,1679844457,1937006958,1667571830,1634497893,        -3,
     *1597190960, 540028464, 824193070, 808591408, 774910752, 840974624,
     * 538980384, 807416096, 807411744,        -3,1281454695,1696612726,
     *1701978192,1751477881,1814053677,1126188137,1936990244,1093479716,
     *1110319140,1176519022,1731076128,        -3,        -2, 542402661,
     * 544437345,1852072306,1679843702,1701994855,1696613165,1126195823,
     *1852055652,1769174113,1852007712,1768824929, 544237669,1853451296,
     *1919512167, 543781664, 825111353, 891306350,1735619698,1869426208,
     *        -3, 542402661, 543253364,1969318944,1635149170,1634166048,
     *1919512167, 543451507,1952542307,1696623969,2032165477, 543973746,
     *1734701600,1952997742, 543520880,1701016677,1679844469,1696625775,
     *        -3, 544438643,1952804193,1953063712,1701999215,1920147561,
     *1847620712,1696626030,1769218147,1701604384,1684630885,1853057391,
     *1853038632,1697539886, 544499813, 544568165, 544171552,1634607209,
     *1852010354,1919247220,        -3, 544694646,1701602670,1735682080,
     *1986096245,1696622191,1914729576,1696621669,1952805485,1768841588,
     *1768910368,1868963956,1751457909,1852404768,1667591276, 544235890,
     *1634559348,1701999401, 773857312,        -3,        -1, 589315646,
     *1042301800,1701014304,1718579744,1936548204,1814061430,1701994855,
     *1696624744,1701738860, 541273411, 543321966,1679844457,1937006958,
     *1667571830,1634497893,        -3,1597190961, 540028464, 840970286,
     * 808656944, 774911008, 840974624, 538980384, 807416096, 807411744,
     *        -3,1399677292,1814053238,1701978192,1751477881,1814053677,
     *1126188137,1936990244,1093479716,1110319140,1176519022,1731076128,
     *        -3,        -2, 542402661, 544437345,1852072306,1679843702,
     *1701994855,1696613165,1126195823,1852055652,1769174113,1852007712,
     *1768824929, 544237669,1853451296,1919512167, 543781664, 825111353,
     * 891306350,1735619698,1869426208,        -3, 542402661, 543258213,
     *1918986085, 544369006,1730176105,1937006958,1667571821,1635328098,
     *1696625517,1634495589,1914725493,1696625775, 543973746,1734680692,
     *1751478893,1634476141,1869900143,1847619442,        -3, 543780451/
     * )
      ICK( 30001: 30300) = (/
     *1869771365,1668554869,1852404768,1667591276, 543451501,1701737321,
     *1869509408, 677719655, 773878888,1696626035,1696624486, 543256096,
     *1768842095,1920099683,1948284769,1986358373,1852273768, 544629100,
     *1969561632, 543584114, 544499813, 543450484,1701997929,1851880553,
     *1869488239,1713402984,1696626030,1769218147,1701604384,1885434465,
     *1835365477,1920149806,        -3,        -1, 589315646,1042301800,
     *1701014304,1885889902,2037129283, 759373922,1869505568,1684632436,
     *1634624357, 544366958,1734680608,        -3,1597190962, 540028465,
     * 891301934, 842342448, 775107872, 840974624, 538980384, 807416096,
     * 807411744,        -3,1281454695,1696616552,1701738860, 541273411,
     * 542269806,1734680608, 538976292,1092627748,1110319140,1176519022,
     *1731076128,        -3,        -2, 542402661, 544437345,1852072306,
     *1679843702,1701994855,1696613165,1126197614, 543236208,1751477881,
     *1814065769,1852252265,1931489582, 859387168,1097754483,1953656685,
     * 773866095,1852055652,1769174113,1852007795,        -3, 543780384,
     *1952998688,1919512167, 543257189, 543520880,1701016677,1679848559,
     * 544629106,2032168814,1819877491,1818847080,1953265952,1685415200,
     *1953439860,1751478893,1634476141,1869900143,1847619442,        -3,
     * 544437602,1937009012,1969581684, 543516262,1701016691, 773868641,
     *1919378720,1684371049,1635019119,1853038689,1919230060,1768645996,
     *2032166005,1696625775, 543449460,1629515634, 544042852,1701584997,
     *1920102258,1932402720,        -1, 589315646,1042301800,1701014304,
     *1718579744,1818325607,1696611395, 759381536,1651469924, 543451507,
     *1952542307,1696622958, 544044396,1953067116,1696625525,1651733609,
     *1953854565,1679847528,1701738860, 544369006,1730158624,1597190963,
     * 540028464, 857747502, 808853552, 774912288, 840974624, 538980384,
     * 807416096, 807411744,        -3,1281454695,1696612726,1701978179,
     * 908939881,1852252227, 759373892,1769174048, 608251172,1110319140,
     *1176519022,1731076128,        -3,        -2, 542402661, 544437345,
     *1852072306,1679843702,1701994855,1696613165,1126195823,1852055652,
     *1769174113,1852007712,1768824929, 543583329,1948283753,2015388513,
     *1919053678, 543257711,1830839151,1853120873,1852403303,        -3,
     * 543257199,1835103337,1663070825,1852252265,1931489582, 859387168,
     *1097754483,1953656685, 773857312,        -3, 542402661, 543253364,
     *1969318944,1635149170,1634166048,1919512167, 543451507,1952542307,
     *1696623969,2032165477, 543973746,1734701600,1952997742, 543520880,
     *1701016677,1679844469,1696625775,        -3, 544437602,1937009012,
     *1969581684,1931506549,1667768417,1931487037,1327967264,1936289383,
     *1818566754,1869505651, 544174624,1937339252,1701667188,1768104037,
     *1920102258,1931503982, 544499813, 543384940,1814044704,        -3,
     * 543451501,1701737321,1869509408, 675622503, 773879656,1701716084,
     *1751457911,1919905383, 544694646,1701602670,1735682080,1769152629,
     *1936024608,1768824948,1751457892,1701996918,1635019119,1847619430,
     *        -3, 544499813, 543384940,1814065249,1918987621,1952805491,
     * 690888736,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1936548204,1814051907, 759381536,1651469924, 543451507,
     *1952542307,1696622958, 544044396,1953067116,1696625525,1651733609,
     *1953854565,1679847528,1701738860, 544369006,1730158624,1597190964,
     * 540028464, 857747502, 808853552, 774912288, 840974624, 538980384,
     * 807416096, 807411744,        -3,1399677292,1814051907, 759381536/
     * )
      ICK( 30301: 30600) = (/
     *1113943674,1701733664,1147761524, 773857312, 608251172,1110319140,
     *1176519022,1731076128,        -3,        -2, 542402661, 544437345,
     *1852072306,1679843702,1701994855,1696613165,1126195823,1852055652,
     *1769174113,1852007712,1768824929, 544237669,1853451296,1919512167,
     * 543781664, 825111353, 891306350,1735619698,1869426208,        -3,
     * 542402661, 543258213,1918986085, 544369006,1730176105,1937006958,
     *1667571821,1635328098,1696625517,1634495589,1914725493,1696625775,
     * 543973746,1734680692,1751478893,1634476141,1869900143,1848385568,
     *        -3, 544437602,1937009012,1969581684,1931506549,1667768417,
     *1931487037,1327964271,1914726766,1668248178,1701016608,1667591276,
     * 543451501,1701737321,1869509422,        -3,        -1, 589315646,
     *1042301800,1701014304,1836412020,1768975461, 544437602,1937009012,
     *1970562404, 544237669,1853451296,1954115685, 541273411, 543321966,
     *1679844457,1937006958,1667571826,1634625381,        -3,1597190965,
     * 540028465, 891301934, 842342448, 775107872, 840974624, 538980384,
     * 807416096, 807411744,        -3,1130915171,1797278817,1919378720,
     *1127620690,1768843040,1127039776,1382116967,1696605249, 757350948,
     *1176519022,1731076128,        -3,        -2, 542402661, 544437345,
     *1852072306,1679843702,1701994855,1696613165,1126195823,1852055652,
     *1769174113,1852007712,1768824929, 543319406,2053467749, 544369006,
     *1730177395, 540094003, 959782977,1852273524,1919905070,        -3,
     * 541224814,1679844457,1937006958,1667592992,1768824948,1751457906,
     *1768843040,1634886944,1702391909,1668572516, 544501536,1986097785,
     * 544173676,2032169836,1768384628,1819877495,1751477792,1685415200,
     *1953439776,        -3, 544437602,1937009012,1969581684, 543516262,
     *1701016691, 539518328,1667592308,1768910451, 543780451,1819632741,
     * 540888864,1937072755,1953068149,1701737587, 690888780,1634887525,
     * 543450486,1767994473,1869509408,        -3, 544039289, 543780452,
     *1768120692,1696621665,1952522351,1914727791,1684368416,1701999215,
     *1920151072,        -3,        -1, 589315646,1042301800,1701014304,
     *1718579744,1970173299,1969318944,1651469924, 543451507,1952542307,
     *1696604192,        -3,1597190966, 540028464, 538980910, 807411762,
     * 774905888, 840974624, 538980384, 807416096, 807411744,        -3,
     *1282371175, 541224814,1679836265,1937006958,1667571814,1869750318,
     * 774778414, 539246893, 608313380,1176519022,1731076128,        -3,
     *        -2, 541288549,1667965044,1751741216,1651469924, 543451507,
     *1952542307,1697521696,        -3,        -1, 589315646,1042301800,
     *1701014304,1635149170,1634166048,1953460851,1768910368,1634625388,
     *1696622958, 543390051,1819225448,1702388078,1696625257,1852252192,
     *        -3,1597190968, 540161326, 807416885, 774905910, 808333344,
     * 874529056, 538980384, 807416096, 807411744,        -3,1399677292,
     *1814053238,1701978196,1635065961,1847608185,1668050792,1702388078,
     *1696605249, 757350948,1176519781,1735550309,        -3,        -2,
     * 541292899,1819240549,2019651173, 544042857,1702127973,1931506536,
     *1869966436, 543711606,1696621157, 544434535,1852401257,1667329652,
     *1819877488,1969449829,1919247392,1634934893,1700885365,1919247392,
     *1652105248,        -3, 544499813, 543258213,1918986085, 544501618,
     *1936289646, 543256167,1818566772,1635069472,1433301605,1936682102,
     *1701060708,1769172850,1684369952,1734700645,1918987372,2032169573,
     *1937075316,1931503982,        -3, 543583329,1953785198,1701060722/
     * )
      ICK( 30601: 30900) = (/
     *1768843123, 543256164, 543517807,1852268916,1701060708,1769173100,
     *1633903981,1701737504,1701604457,1886613353,1685270048,1092641897,
     *1936683620,1701978221,1868850540,        -3, 544434287,1970037792,
     *1650794601,1852009589,1684366368,1768824948,1751457891,1634493301,
     *1818326121,1869509422,        -3,        -1, 589315646,1042301800,
     *1701014304,1651469924, 544240229,1667855209,1869488230,1869750339,
     * 759373929,1847618665,1734898720,1635020653, 544437362,1969452149,
     *1919251232, 676997229,1635264800,1008742960, 689971232,        -3,
     *1597191216, 539897904, 874524718, 808525872, 774911264, 857751840,
     * 538980384, 807416096, 807411744,        -3,1282373408,1114599012,
     * 542143077,1667855209,1869488239,1847599171, 759373890,1869505651,
     * 539897390, 774778414, 774778414, 774778414, 539248160,1097754414,
     *        -3,        -2, 542402661, 543258213,1918986085, 544419445,
     * 773875311,1914722349,1495294575,1852076832,1769152628,1702065253,
     *1679829102,1634559332, 543321966,1680699506,1701013875,1768910377,
     * 773871661,1495299945,1819025440,        -3, 543647086,1701994860,
     *1819877474,1696613165,1126195823,1852076844, 544566892,1702064928,
     *1952998770,1696620914,1696624239,1852124704,1231954036,1751457900,
     *1634956320,1667330917, 544499813, 544419445, 774337312,1868963872,
     * 544499813, 543977335,1702065184,1701602669,1701737504,1853189474,
     *1701999392,1634886944,1668247155,1768187250,1701060648,1702388588,
     *1969514862,1730177145,1685221223,1701718318, 542402661,1919230049,
     *1919229984,        -3, 544499826,1701126260,1702065184,1918987879,
     *1702050336,1869505824,1718579744,1937011317,1668576626,1702043767,
     *1769236512,1952998688,1818325607,1702065184,1701602669,1701737504,
     *1512061984, 842017824,1869505824,        -3, 543584114, 544499813,
     * 543973746,1734701940, 542777449,1847620712,1696625249,1852269856,
     * 842014836,1864381241, 543256164, 544173669, 543584114, 544437362,
     *1969452149,1919251232,2003399784, 542779501,1635264800, 875569184,
     * 544174624,1751738216,1701978152,1597191216, 740319027, 875634785,
     *1852055647, 859058720,1919251312,1701016681,1986358393, 690888736,
     *        -3,        -1, 589315646,1042301800,1701014304,1651469924,
     * 544240229,1667855209,1869488230,1869750339, 759373929,1847620468,
     *1920295796,1970431347, 539504953, 540811354, 678257016, 689978400,
     * 875571488,        -3,1597191217, 539897904, 908078640, 825565230,
     * 808924448, 857751840, 538980384, 807416096, 807411744,        -3,
     *1282373408,1114599012, 542143077,1667855209,1869488239,1847599171,
     * 759373890,1869505651, 539897390, 774778414, 774778414, 774778414,
     * 539248160,1097754414,        -3,        -2, 542402661, 543258213,
     *1918986085, 544419445, 773875311,1914722349,1495294575,1852076832,
     *1769152628,1702065253,1679829102,1634559332, 543321966,1680699506,
     *1701013875,1768910377, 773871661,1495299945,1819025440,        -3,
     * 543647086,1701994860,1819877474,1696613165,1126195823,1852076844,
     * 544566892,1702064928,1952998770,1696620914,1696624239,1852124704,
     *1231954036,1751457900,1634956320,1667330917, 544499813, 544419445,
     * 774337312,1868963872, 544499813, 543977335,1702065184,1701602669,
     *1701737504,1853189474,1701999392,1634886944,1668247155,1768187250,
     *1701060648,1702388588,1969514862,1730177145,1685221223,1701718318,
     * 542402661,1919230049,1919229984,        -3, 544499826,1701126260,
     *1702065184,1918987879,1702050336,1869505824,1718579744,1937011317/
     * )
      ICK( 30901: 31200) = (/
     *1668576626,1702043767,1769236512,1952998688,1818325607,1702065184,
     *1701602669,1701737504,1512061984, 842017824,1869505824,        -3,
     * 543584114, 544499813, 543973746,1734701940, 542777449,1847620712,
     *1696625249,1852269856, 842014836,1864381241, 543256164, 544173669,
     * 543584114, 544437362,1969452149,1919251232,2003399784, 542779501,
     *1635264800, 875569184, 544174624,1751738216,1701978152,1597191216,
     * 740319027, 875634785,1852055647, 859058720,1919251312,1701016681,
     *1986358393, 690888736,        -3,        -1, 589315646,1042301800,
     *1701014304,1651469924, 544240229,1667855209,1869488230,1869750339,
     * 759373929,1847620468,1920295796,1970431347, 539515432,1835104297,
     * 540942387, 958996512,        -3,1597191218, 539897904, 941633072,
     * 842014766, 825241632, 857751840, 538980384, 807416096, 807411744,
     *        -3,1282373408,1114599012, 542143077,1667855209,1869488239,
     *1847599171, 759373890,1869505651, 539897390, 774778414, 774778414,
     * 774778414, 539248160,1097754414,        -3,        -2, 542402661,
     * 543258213,1918986085, 544419445, 773875311,1914722349,1495294575,
     *1852076832,1769152628,1702065253,1679829102,1634559332, 543321966,
     *1680699506,1701013875,1768910377, 773871661,1495299945,1819025440,
     *        -3, 543647086,1701994860,1819877474,1696613165,1126195823,
     *1852076844, 544566892,1702064928,1952998770,1696620914,1696624239,
     *1852124704,1231954036,1751457900,1634956320,1667330917, 544499813,
     * 544419445, 774337312,1868963872, 544499813, 543977335,1702065184,
     *1701602669,1701737504,1853189474,1701999392,1634886944,1668247155,
     *1768187250,1701060648,1702388588,1969514862,1730177145,1685221223,
     *1701718318, 542402661,1919230049,1919229984,        -3, 544499826,
     *1701126260,1702065184,1918987879,1702050336,1869505824,1718579744,
     *1937011317,1668576626,1702043767,1769236512,1952998688,1818325607,
     *1702065184,1701602669,1701737504,1512061984, 842017824,1869505824,
     *        -3, 543584114, 544499813, 543973746,1734701940, 542777449,
     *1847620712,1696625249,1852269856, 842014836,1864381241, 543256164,
     * 544173669, 543584114, 544437362,1969452149,1919251232,2003399784,
     * 542779501,1635264800, 875569184, 544174624,1751738216,1701978152,
     *1597191216, 740319027, 875634785,1852055647, 859058720,1919251312,
     *1701016681,1986358393, 690888736,        -3,        -1, 589315646,
     *1042303097,1651665252,1769169268,1768910368,1886547810,1818586400,
     *1869488195, 543780384,1835100526, 544367987,1768191333, 678635808,
     *        -3,1597191219, 538976288, 807411744, 540024864, 538980384,
     * 840974624, 538980384, 807416096, 807411744,        -3,1433302387,
     *1969318944, 608256366,1735157024,1382116967,1696622958, 541942121,
     *1847612005,1936286837,1696622191,1914708004,1109410664,1701014304,
     *        -3,        -2, 542402661, 543256167,1818566770,1634625381,
     * 543781664,1818325607,1701978228,1751215648,1970500961,1814062703,
     *1914729576,1696625765,1853120884,1769366892,2032165235,1936287598,
     *1701060640,        -3, 543717730,1919509609,1935766633,1869488239,
     *1713402984,1696625253,1886351988,1701060705,1953459488,1768824948,
     *1751457901,1634299424,1919251305,1685415214,        -3,        -1,
     * 589315646,1042303097,1651665252,1769169268,1768910368,1886547810,
     *1818586400,1869488195, 543780384,1936682102,1701737519,1768910368,
     *        -3,1597191220, 538976288, 807411744, 540024864, 538980384,
     * 840974624, 538980384, 807416096, 807411744,        -3,1433302387/
     * )
      ICK( 31201: 31500) = (/
     *1969318944, 608247873,1852271717, 542269806,1734680681,1847612271,
     *1819698542,1949256047,1847617135,1914708004,1109410664,1701014304,
     *        -3,        -2, 542402661, 543256167,1818566770,1634625381,
     * 543781664,1818325607,1701978228,1751215648,1970500961,1814062703,
     *1914729576,1696625765,1853120884,1769366892,2032165235,1936287598,
     *1701060640,        -3, 543717730,1919509609,1935766633,1869488239,
     *1713402984,1696625253,1886351988,1701060705,1953459488,1768824948,
     *1751457907,1869379173,1848598894,1768910382,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750387,1752134260, 541270061,
     * 541597736,1097754483,1953656685, 543451494,1717924453,1852007721,
     * 542659137,1496981552, 775501344,1313166676, 540094000, 941629472,
     *        -3,1597191472, 540028465, 824188976, 775036960, 808334112,
     * 857751840, 538980384, 807416096, 807411744,        -3,1399353202,
     *1948262467, 759701544,1479552569, 908873265, 774912065, 689972289,
     * 539829314, 539893796,1176519022,1731076128,        -3,        -2,
     * 541876594,1734680676,1702259041,1953066862,1931503218,1869422695,
     *1701733746,1634495609, 543253347,1701868645,1679849057,1819633011,
     * 544039289, 543780452,1768120692,1696623983,1684368416,1886547810,
     *1818586483, 740302880, 544175717,1914729061,1718185573,1835363956,
     * 543519843, 773857348,1701208437,1819549763, 759701565, 540028473,
     * 908083566,1731076136,1479365217,2032738422,1634497893, 543584879,
     *1830835016,1162631244, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750380,1869506336, 541270061, 541597736,
     *1097754483,1953656685, 543451494,1717924453,1852007721, 542659137,
     *1496981552, 775501344,1313166676, 540094000, 941629472,        -3,
     *1597191473, 540028465, 874520624, 775036960, 808334112, 857751840,
     * 538980384, 807416096, 807411744,        -3,1282371175, 538976323,
     * 759701544,1479552569, 908873265, 774912065, 689972289, 539829314,
     * 539893796,1176519022,1731076128,        -3,        -2, 541876594,
     *1734680676,1702259041,1953066862,1931503218,1869422695,1701733746,
     *1634495609, 543253347,1701868645,1679849057,1819633011, 544039289,
     * 543780452,1768120692,1696623983,1684368416,1886547810,1818586483,
     * 740302880, 544175717,1914729061,1718185573,1835363956, 543519843,
     * 773857348,1701208437,1819549763, 759701565, 540028473, 908083566,
     *1731076136,1479365217,2032738422,1634497893, 543584879,1830835016,
     *1162631244, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1752134260, 541990957, 541597736,1097754483,
     *1953656685, 543451494,1717924453,1852007721, 542659137,1496981552,
     * 775436064,1313166676, 540094000, 809050144,        -3,1597191474,
     * 538980398, 824188976, 775036960, 808334112, 857751840, 538980384,
     * 807416096, 807411744,        -3,1399353202,1948262478, 759701544,
     *1479552568, 925650481, 774910273, 689972289, 539829314, 539893796,
     *1176519022,1731076128,        -3,        -2, 541876594,1734680676,
     *1702259041,1953066862,1931503218,1869422695,1701733746,1634495609,
     * 543253347,1701868645,1679849057,1819633011, 544039289, 543780452,
     *1768120692,1696623983,1684368416,1886547810,1818586483, 740302880,
     * 544175717,1914729061,1718185573,1835363956, 543519843, 773857348,
     *1701208437,1819549774, 759701565, 540028472, 924860782,1731076136,
     *1479365217,2032738422,1634497893, 543584879,1830835016,1162631244,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310/
     * )
      ICK( 31501: 31800) = (/
     *1869750380,1869506336, 541990957, 541597736,1097754483,1953656685,
     * 543451494,1717924453,1852007721, 542659137,1496981552, 775436064,
     *1313166676, 540094000, 809050144,        -3,1597191475, 540028465,
     * 857743408, 775036960, 808334112, 857751840, 538980384, 807416096,
     * 807411744,        -3,1282371175, 538976334, 759701544,1311780408,
     * 925650481, 774910273, 689972289, 539829314, 539893796,1176519022,
     *1731076128,        -3,        -2, 541876594,1734680676,1702259041,
     *1953066862,1931503218,1869422695,1701733746,1634495609, 543253347,
     *1701868645,1679849057,1819633011, 544039289, 543780452,1768120692,
     *1696623983,1684368416,1886547810,1818586483, 740302880, 544175717,
     *1914729061,1718185573,1835363956, 543519843, 773857348,1701208437,
     *1819549774, 759701565, 540028472, 924860782,1731076136,1479365217,
     *2032738422,1634497893, 543584879,1830835016,1162631244, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1752134260, 542056493, 541597736,1097754483,1953656685, 543451494,
     *1717924453,1852007721, 542659137,1496981552, 775434784,1313166676,
     * 540028473, 942874656,        -3,1597191476, 538980398, 824188976,
     * 775036960, 808334112, 857751840, 538980384, 807416096, 807411744,
     *        -3,1399353202,1948262479, 759701544,1479552568, 841764400,
     * 775501889, 689972289, 539829314, 539893796,1176519022,1731076128,
     *        -3,        -2, 541876594,1734680676,1702259041,1953066862,
     *1931503218,1869422695,1701733746,1634495609, 543253347,1701868645,
     *1679849057,1819633011, 544039289, 543780452,1768120692,1696623983,
     *1684368416,1886547810,1818586483, 740302880, 544175717,1914729061,
     *1718185573,1835363956, 543519843, 773857348,1701208437,1819549775,
     * 759701565, 540028472, 840974702,1731076136,1479365217,2032738422,
     *1634497893, 543584879,1830835016,1162631244, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750380,1869506336,
     * 542056493, 541597736,1097754483,1953656685, 543451494,1717924453,
     *1852007721, 542659137,1496981552, 775434784,1313166676, 540028473,
     * 942874656,        -3,1597191477, 540028465, 941633582, 842342432,
     * 808334112, 857751840, 538980384, 807416096, 807411744,        -3,
     *1282371175, 538976335, 759701544,1479552568, 841764400, 775501889,
     * 689972289, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773857348,1701208437,1819549775, 759701565,
     * 540028472, 840974702,1731076136,1479365217,2032738422,1634497893,
     * 543584879,1830835016,1162631244, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750387,1752134260, 541207880,
     * 543451507,1952542307,1696622958, 542649666,1211310189,1869178228,
     *2032148512,        -3,1597191478, 540028464, 891301934, 825630768,
     * 775042336, 857751840, 538980384, 807416096, 807411744,        -3,
     *1399353202,1948262432,1479361096, 857743392, 538976324,1769174113,
     *1852007712, 608247853, 608313380,1176519022,1731076128,        -3,
     *        -2, 541139059,1752134260, 541207880, 543451507,1952542307,
     *1696623969,2032165477, 543454565, 544501536,1718188137,1852252276,
     *1751217184,1684632436,1634624357, 544501536,1629517682,1869506336/
     * )
      ICK( 31801: 32100) = (/
     *1986096245,1697390624,        -3, 543501927, 773878895, 544499809,
     *1948282726, 544499813, 541273416, 543451507,1952542307,1696622958,
     * 543236163,1211310183,1919907184, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750380,1869506336,1110263840,
     *1684632436,1634624357, 543780384,1479361096, 857763183,1768256633,
     *        -3,1597191479, 540028465, 807415854, 842014768, 775106592,
     * 857751840, 538980384, 807416096, 807411744,        -3,1282371175,
     * 538976288,1479361096, 857743392, 538976324,1769174113,1852007712,
     * 608247853, 608313380,1176519022,1731076128,        -3,        -2,
     * 541288549,1667965044,1751457900,1869506336,1919250543,1920230756,
     * 541207880, 543321966,1679844457,1937006958,1667571752,1110263840,
     *1769152613,2020631907,1952801824,1953439848,1635149088,1629517409,
     *1819632928,        -3, 543257199,1970168864, 825110838, 541159015,
     * 543780384,1629509677,1112027936,1735552885,1881743392,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1752134260,
     * 541207880, 543451507,1952542307,1696622958, 539514924,1496078889,
     * 759311688, 544042857,1702132000,        -3,1597191480, 540028464,
     * 891301934, 825630768, 775042336, 857751840, 538980384, 807416096,
     * 807411744,        -3,1399353202,1948262440,1479301420,1512648002,
     * 759701572,1769174113,1852007712, 608247853, 608313380,1176519022,
     *1731076128,        -3,        -2, 541139059,1752134260, 541207880,
     * 543451507,1952542307,1696623969,2032165477, 543454565, 544501536,
     *1718188137,1852252276,1751217184,1684632436,1634624357, 544501536,
     *1629517682,1869506336,1986096245,1697524768,        -3, 543501927,
     * 773878895, 544499809,1948282726, 544499813, 541273416, 543451507,
     *1952542307,1697521696,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750380,1869506336,1110263840,1684632436,1634624357,
     * 543780384, 676867161, 744106285,1110263840,1836018021,1954095136,
     *        -3,1597191481, 540028465, 807415854, 842014768, 775106592,
     * 857751840, 538980384, 807416096, 807411744,        -3,1282371175,
     * 538976296,1479301420,1512648002, 759701572,1769174113,1852007712,
     * 608247853, 608313380,1176519022,1731076128,        -3,        -2,
     * 541288549,1667965044,1751457900,1869506336,1919250543,1920230756,
     * 541207880, 543321966,1679844457,1937006958,1667571752,1110263840,
     *1769152613,2020631907,1952801824,1953439848,1635149088,1629517409,
     *1819632928,        -3, 543257199,1970168864, 825110582, 541159015,
     * 543780384,1629497432, 744041562, 690831917,1210084719,1768256633,
     * 690888736,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 541275168, 757089076, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094005,
     * 874520608,        -3,1597191728, 538980398, 824188976, 775036960,
     * 808334112, 840974624, 538980384, 807416096, 807411744,        -3,
     *1399353202,1948262467, 678654003, 690832168,1936732969, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773866597,1717663084,1948271412, 759378976,
     *1025519918, 892608577,1852255776, 676867410,1635330336,1986096245/
     * )
      ICK( 32101: 32400) = (/
     *1696622194,1869422624,        -3, 541876580,1679828512,1348562029,
     *1701981216,1400140405,1668576626,1696613477,1952805485,1768841588,
     *1768910368,1652105304,1918990624,1131575667,1952541804,1869050465,
     *1885894944, 674314552, 891891232,        -3, 542011252,1698308128,
     *        -3, 538979616,1127492931, 874539374,1684628321,1952805664,
     *1629512303,1852055650,1702131557,1701716065,1953459571, 544696692,
     *1746940960,1651469924,1931502945,1667771936,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750380,1869506336, 541275168,
     * 757089076, 539509102,1735619698,1869422692,1768318565,1919250019,
     *1697194072,1380014394, 540094005, 874520608,        -3,1597191729,
     * 538980398, 824188976, 775036960, 808334112, 840974624, 538980384,
     * 807416096, 807411744,        -3,1282371175, 538976323, 678654003,
     * 690832168,1936732969, 541224814,1679828033, 539829314, 539893796,
     *1176519022,1731076128,        -3,        -2, 541876594,1734680676,
     *1702259041,1953066862,1931503218,1869422695,1701733746,1634495609,
     * 543253347,1701868645,1679849057,1819633011, 544039289, 543780452,
     *1768120692,1696623983,1684368416,1886547810,1818586483, 740302880,
     * 544175717,1914729061,1718185573,1835363956, 543519843, 773866597,
     *1717663084,1948271412, 759378976,1025519918, 892608577,1852255776,
     * 676867410,1635330336,1986096245,1696622194,1869422624,        -3,
     * 541876580,1679828512,1348562029,1701981216,1400140405,1668576626,
     *1696613477,1952805485,1768841588,1768910368,1652105304,1918990624,
     *1131575667,1952541804,1869050465,1885894944, 674314552, 891891232,
     *        -3, 542011252,1698308128,        -3, 538979616,1127492931,
     * 874539374,1684628321,1952805664,1629512303,1852055650,1702131557,
     *1701716065,1953459571, 544696692,1746940960,1651469924,1931502945,
     *1667771936,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 541275168, 757089075, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094005,
     * 840966176,        -3,1597191730, 538980398, 824188976, 775036960,
     * 808334112, 840974624, 538980384, 807416096, 807411744,        -3,
     *1399353202,1948262467, 678654003, 690832168,1936732713, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773866597,1717663084,1948271412, 759378720,
     *1025519918, 892477505,1852255776, 676867410,1635330336,1986096245,
     *1696622194,1869422624,        -3, 541876580,1679828512,1348562029,
     *1701981216,1400140405,1668576626,1696613477,1952805485,1768841588,
     *1768910368,1652105304,1918990624,1131575667,1952541804,1869050465,
     *1885894944, 674314552, 891891232,        -3, 542011252,1698308128,
     *        -3, 538979616,1127492931, 857762158,1684628321,1952805664,
     *1629512303,1852055650,1702131557,1701716065,1847615860,1869422711,
     *1769236512, 874537583,1852076832,1634624544,1869505824,2003399784,
     * 540221538,1869505651, 773857312, 538979616,1131376234,1969709428,
     *1701060723,2037609573,1836261485,1635328099,1635087205, 544436077,
     *1696606054,1634497381, 543255649,1919756064,1835365235,1634166131,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310/
     * )
      ICK( 32401: 32700) = (/
     *1869750380,1869506336, 541275168, 757089075, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094005,
     * 840966176,        -3,1597191731, 538980398, 824188976, 775036960,
     * 808334112, 840974624, 538980384, 807416096, 807411744,        -3,
     *1282371175, 538976323, 678654003, 690832168,1936732713, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773866597,1717663084,1948271412, 759378720,
     *1025519918, 892477505,1852255776, 676867410,1635330336,1986096245,
     *1696622194,1869422624,        -3, 541876580,1679828512,1348562029,
     *1701981216,1400140405,1668576626,1696613477,1952805485,1768841588,
     *1768910368,1652105304,1918990624,1131575667,1952541804,1869050465,
     *1885894944, 674314552, 891891232,        -3, 542011252,1698308128,
     *        -3, 538979616,1127492931, 857762158,1684628321,1952805664,
     *1629512303,1852055650,1702131557,1701716065,1847615860,1869422711,
     *1769236512, 874537583,1852076832,1634624544,1869505824,2003399784,
     * 540221538,1869505651, 773857312, 538979616,1131376234,1969709428,
     *1701060723,2037609573,1836261485,1635328099,1635087205, 544436077,
     *1696606054,1634497381, 543255649,1919756064,1835365235,1634166131,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 541275168, 757089074, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094004,
     * 908075040,        -3,1597191732, 538980398, 824188976, 775036960,
     * 808334112, 840974624, 538980384, 807416096, 807411744,        -3,
     *1399353202,1948262467, 678654003, 690832168,1936730400, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773866597,1717663084,1948271412, 759378464,
     *1025519918, 875962433,1852255776, 676867410,1635330336,1986096245,
     *1696622194,1869422624,        -3, 541876580,1679828512,1348562029,
     *1701981216,1400140405,1668576626,1696613477,1952805485,1768841588,
     *1768910368,1652105304,1918990624,1131575667,1952541804,1869050465,
     *1885894944, 674314552, 891891232,        -3, 542011252,1698308128,
     *        -3, 538979616,1127492931, 840984942,1684628321,1952805664,
     *1629512303,1852055650,1702131557,1701716065,1847615860,1869422711,
     *1769236512, 874537583,1852076832,1634624544,1869505824,2003399784,
     * 540156002,1869505651, 773857312, 538979616,1131376234,1969709428,
     *1701060723,2037609573,1836261485,1635328099,1635087205, 544436077,
     *1696606054,1634497381, 543255649,1919756064,1835365235,1634166131,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750380,1869506336, 541275168, 757089074, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094004,
     * 908075040,        -3,1597191733, 538980398, 824188976, 775036960,
     * 808334112, 840974624, 538980384, 807416096, 807411744,        -3/
     * )
      ICK( 32701: 33000) = (/
     *1282371175, 538976323, 678654003, 690832168,1936730400, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773866597,1717663084,1948271412, 759378464,
     *1025519918, 875962433,1852255776, 676867410,1635330336,1986096245,
     *1696622194,1869422624,        -3, 541876580,1679828512,1348562029,
     *1701981216,1400140405,1668576626,1696613477,1952805485,1768841588,
     *1768910368,1652105304,1918990624,1131575667,1952541804,1869050465,
     *1885894944, 674314552, 891891232,        -3, 542011252,1698308128,
     *        -3, 538979616,1127492931, 840984942,1684628321,1952805664,
     *1629512303,1852055650,1702131557,1701716065,1847615860,1869422711,
     *1769236512, 874537583,1852076832,1634624544,1869505824,2003399784,
     * 540156002,1869505651, 773857312, 538979616,1131376234,1969709428,
     *1701060723,2037609573,1836261485,1635328099,1635087205, 544436077,
     *1696606054,1634497381, 543255649,1919756064,1835365235,1634166131,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 541277984, 757089087, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094005,
     * 807411744,        -3,1597191734, 540028467, 891297840, 775233568,
     * 825110560, 840974624, 538980384, 807416096, 807411744,        -3,
     *1399353202,1950294083, 678654015, 690832168,1936736041, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 542402661, 543717730,1919509609,1935766633,1869488239,
     *1713398132, 543974753,1936990319,1852121187,1634886255,1847615860,
     *1869422697,1931505263,1948283493,1668245358,1769629028, 773857312,
     *        -3, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 543584114, 543236163, 759373922,1869505568,1835104544,
     *1768842345,1667331173,        -3, 544042852,1701585008,1919902316,
     *1701671724, 544566898,1702063980,1986356256,1684632431,1919182194,
     * 740323190,1701981554,1701210478,1701668206,1948280180,1663967316,
     *1751457859, 759373922,1869505568,1769152544,        -3, 544499059,
     *1952801824,1953439842,1696624239,1948283752,1869771877,1914729576,
     *1634607153, 774976800,1097754483,1953656685, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750380,1869506336,
     * 541277984, 757089087, 539509102,1735619698,1869422692,1768318565,
     *1919250019,1697194072,1380014394, 540094005, 807411744,        -3,
     *1597191735, 540028464, 891297840, 775036960, 808334112, 840974624,
     * 538980384, 807416096, 807411744,        -3,1282371175,1059070019,
     * 678654015, 690832168,1936736041, 541224814,1679828033, 539829314,
     * 539893796,1176519022,1731076128,        -3,        -2, 541876594,
     *1734680676,1702259041,1953066862,1931503218,1869422695,1701733746,
     *1634495609, 543253347,1701868645,1679849057,1819633011, 544039289,
     * 543780452,1768120692,1696623983,1684368416,1886547810,1818586483,
     * 740302880, 544175717,1914729061,1718185573,1835363956, 543519843,
     * 773866597,1717663084,1948271423, 759381792,1025519918, 892346433,
     *1852255776, 676867410,1635330336,1986096245,1696622194,1869422624/
     * )
      ICK( 33001: 33300) = (/
     *        -3, 541876580,1679828512,1348562029,1701981216,1400140405,
     *1668576626,1696613477,1952805485,1768841588,1768910368,1652105304,
     *1918990624,1131575667,1952541804,1869050465,1885894944, 674314552,
     * 891891232,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 541274912, 757089075, 539509102,1735619698,
     *1869422692,1768318565,1919250019,1697194072,1380014394, 540094003,
     * 874520608,        -3,1597191736, 538980398, 824188976, 775036960,
     * 808334112, 840974624, 538980384, 807416096, 807411744,        -3,
     *1399353202,1948262467, 678654002, 690832168,1936732713, 541224814,
     *1679828033, 539829314, 539893796,1176519022,1731076128,        -3,
     *        -2, 541876594,1734680676,1702259041,1953066862,1931503218,
     *1869422695,1701733746,1634495609, 543253347,1701868645,1679849057,
     *1819633011, 544039289, 543780452,1768120692,1696623983,1684368416,
     *1886547810,1818586483, 740302880, 544175717,1914729061,1718185573,
     *1835363956, 543519843, 773866597,1717663084,1948271411, 759378720,
     *1025519918, 859054145,1852255776, 676867410,1635330336,1986096245,
     *1696622194,1869422624,        -3, 541876580,1679828512,1348562029,
     *1701981216,1400140405,1668576626,1696613477,1952805485,1768841588,
     *1768910368,1652105304,1918990624,1131575667,1952541804,1869050465,
     *1885894944, 674314552, 891891232,        -3, 542011252,1698308128,
     *        -3, 538979616,1127427395, 857762158,1684628321,1952805664,
     *1629512303,1852055650,1702131557,1701716065,1953459571, 544696692,
     *1746940704,1651469924,1931502945,1667771936,        -3, 538979616,
     *1131376234,1969709428,1701060723,2037609573,1836261485,1635328099,
     *1635087205, 544436077,1696606054,1634497381, 543255649,1919756064,
     *1835365235,1634166131, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750380,1869506336, 541274912, 757089075,
     * 539509102,1735619698,1869422692,1768318565,1919250019,1697194072,
     *1380014394, 540094003, 874520608,        -3,1597191737, 540028465,
     * 941633582, 842145824, 808334112, 840974624, 538980384, 807416096,
     * 807411744,        -3,1282371175, 538976323, 678654002, 690832168,
     *1936732713, 541224814,1679828033, 539829314, 539893796,1176519022,
     *1731076128,        -3,        -2, 541876594,1734680676,1702259041,
     *1953066862,1931503218,1869422695,1701733746,1634495609, 543253347,
     *1701868645,1679849057,1819633011, 544039289, 543780452,1768120692,
     *1696623983,1684368416,1886547810,1818586483, 740302880, 544175717,
     *1914729061,1718185573,1835363956, 543519843, 773857348,1701208437,
     *1819549763, 858604339, 540876849, 775107616,1097754414, 539514925,
     *1382119721, 544629100,1969561702,1919905056,        -3, 541876580,
     *1679828512,1348562029,1701981216,1400140405,1668576626,1696613477,
     *1952805485,1768841588,1768910368,1652105304,1918990624,1131575667,
     *1952541804,1869050465,1885894944, 674314552, 891891232,        -3,
     * 542011252,1698308128,        -3, 538979616,1127427395, 857762158,
     *1684628321,1952805664,1629512303,1852055650,1702131557,1701716065,
     *1953459571, 544696692,1746940960,2003399784, 540221538,1869505651,
     * 543514979,1747853344,        -3, 538979616,1131376234,1969709428,
     *1701060723,2037609573,1836261485,1635328099,1635087205, 544436077,
     *1696606054,1634497381, 543255649,1919756064,1835365235,1634166131,
     * 773857312,        -3, 538979616,1092644463,1952539244,1696621944,
     *1667592308,1768910368,1769152628,1751457859, 759373922,1869505568/
     * )
      ICK( 33301: 33600) = (/
     *1768824877,1126710607, 690832168,1028598061, 544438643,1952804211,
     * 544696692,1746952558,        -3, 538976288,1868723045,1920361828,
     * 544040289,1847621217,1819632928,1868963889, 775238688,1097754483,
     *1953656685, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1752134260, 541274912, 757089074, 539509102,
     *1735619698,1869422692,1768318565,1919250019,1697194072,1380014394,
     * 540094003, 824188960,        -3,1597191984, 538980398, 824188976,
     * 775036960, 808334112, 840974624, 538980384, 807416096, 807411744,
     *        -3,1399353202,1948262467, 678654002, 690832168,1936732457,
     * 541224814,1679828033, 539829314, 539893796,1176519022,1731076128,
     *        -3,        -2, 541876594,1734680676,1702259041,1953066862,
     *1931503218,1869422695,1701733746,1634495609, 543253347,1701868645,
     *1679849057,1819633011, 544039289, 543780452,1768120692,1696623983,
     *1684368416,1886547810,1818586483, 740302880, 544175717,1914729061,
     *1718185573,1835363956, 543519843, 773866597,1717663084,1948271411,
     * 759378464,1025519918, 858857537,1852255776, 676867410,1635330336,
     *1986096245,1696622194,1869422624,        -3, 541876580,1679828512,
     *1348562029,1701981216,1400140405,1668576626,1696613477,1952805485,
     *1768841588,1768910368,1652105304,1918990624,1131575667,1952541804,
     *1869050465,1885894944, 674314552, 891891232,        -3, 542011252,
     *1698308128,        -3, 538979616,1127427395, 840984942,1684628321,
     *1952805664,1629512303,1852055650,1702131557,1701716065,1847615860,
     *1869422711,1769236512, 857760367,1852076832,1634624544,1869505824,
     *2003399784, 540156002,1869505651, 773857312, 538979616,1131376234,
     *1969709428,1701060723,2037609573,1836261485,1635328099,1635087205,
     * 544436077,1696606054,1634497381, 543255649,1919756064,1835365235,
     *1634166131, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750380,1869506336, 541274912, 757089074, 539509102,
     *1735619698,1869422692,1768318565,1919250019,1697194072,1380014394,
     * 540094003, 824188960,        -3,1597191985, 540028465, 538980398,
     * 840966176, 808334112, 840974624, 538980384, 807416096, 807411744,
     *        -3,1282371175, 538976323, 678654002, 690832168,1936732457,
     * 541224814,1679828033, 539829314, 539893796,1176519022,1731076128,
     *        -3,        -2, 541876594,1734680676,1702259041,1953066862,
     *1931503218,1869422695,1701733746,1634495609, 543253347,1701868645,
     *1679849057,1819633011, 544039289, 543780452,1768120692,1696623983,
     *1684368416,1886547810,1818586483, 740302880, 544175717,1914729061,
     *1718185573,1835363956, 543519843, 773866597,1717663084,1948271411,
     * 759378464,1025519918, 858857537,1852255776, 676867410,1635330336,
     *1986096245,1696622194,1869422624,        -3, 541876580,1679828512,
     *1348562029,1701981216,1400140405,1668576626,1696613477,1952805485,
     *1768841588,1768910368,1652105304,1918990624,1131575667,1952541804,
     *1869050465,1885894944, 674314552, 891891232,        -3, 542011252,
     *1698308128,        -3, 538979616,1127427395, 840984942,1684628321,
     *1952805664,1629512303,1852055650,1702131557,1701716065,1847615860,
     *1869422711,1769236512, 857760367,1852076832,1634624544,1869505824,
     *2003399784, 540156002,1869505651, 773857312, 538979616,1131376234,
     *1969709428,1701060723,2037609573,1836261485,1635328099,1635087205,
     * 544436077,1696606054,1634497381, 543255649,1919756064,1835365235,
     *1634166131, 773857312,        -3,        -1, 589315646,1042306149/
     * )
      ICK( 33601: 33900) = (/
     *1936990310,1869750387,1752134260, 541274656, 757089074, 539509102,
     *1735619698,1869422692,1768318565,1919250019,1697194072,1380014394,
     * 540094002, 891297824,        -3,1597191986, 538980398, 824188976,
     * 775036960, 808334112, 840974624, 538980384, 807416096, 807411744,
     *        -3,1399353202,1948262467, 678653993, 759375987,1881743392,
     * 541224814,1679828033, 539829314, 539893796,1176519022,1731076128,
     *        -3,        -2, 541876594,1734680676,1702259041,1953066862,
     *1931503218,1869422695,1701733746,1634495609, 543253347,1701868645,
     *1679849057,1819633011, 544039289, 543780452,1768120692,1696623983,
     *1684368416,1886547810,1818586483, 740302880, 544175717,1914729061,
     *1718185573,1835363956, 543519843, 773866597,1717663084,1948271410,
     * 759378464,1025519918, 842342465,1852255776, 676867410,1635330336,
     *1986096245,1696622194,1869422624,        -3, 541876580,1679828512,
     *1348562029,1701981216,1400140405,1668576626,1696613477,1952805485,
     *1768841588,1768910368,1652105304,1918990624,1131575667,1952541804,
     *1869050465,1885894944, 674314552, 891891232,        -3, 542011252,
     *1698308128,        -3, 538979616,1127361859, 840984942,1684628321,
     *1952805664,1629512303,1852055650,1702131557,1701716065,1953459571,
     * 544696692,1746940448,1651469924,1931502945,1667771936,        -3,
     * 538979616,1131376234,1969709428,1701060723,2037609573,1836261485,
     *1635328099,1635087205, 544436077,1696606054,1634497381, 543255649,
     *1919756064,1835365235,1634166131, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750380,1869506336, 541274656,
     * 757089074, 539509102,1735619698,1869422692,1768318565,1919250019,
     *1697194072,1380014394, 540094002, 891297824,        -3,1597191987,
     * 538980398, 824188976, 775036960, 808334112, 840974624, 538980384,
     * 807416096, 807411744,        -3,1282371175, 538976323, 678653993,
     * 759375987,1881743392, 541224814,1679828033, 539829314, 539893796,
     *1176519022,1731076128,        -3,        -2, 541876594,1734680676,
     *1702259041,1953066862,1931503218,1869422695,1701733746,1634495609,
     * 543253347,1701868645,1679849057,1819633011, 544039289, 543780452,
     *1768120692,1696623983,1684368416,1886547810,1818586483, 740302880,
     * 544175717,1914729061,1718185573,1835363956, 543519843, 773866597,
     *1717663084,1948271410, 759378464,1025519918, 842342465,1852255776,
     * 676867410,1635330336,1986096245,1696622194,1869422624,        -3,
     * 541876580,1679828512,1348562029,1701981216,1400140405,1668576626,
     *1696613477,1952805485,1768841588,1768910368,1652105304,1918990624,
     *1131575667,1952541804,1869050465,1885894944, 674314552, 891891232,
     *        -3, 542011252,1698308128,        -3, 538979616,1127361859,
     * 840984942,1684628321,1952805664,1629512303,1852055650,1702131557,
     *1701716065,1953459571, 544696692,1746940448,1651469924,1931502945,
     *1667771936,        -3, 538979616,1131376234,1969709428,1701060723,
     *2037609573,1836261485,1635328099,1635087205, 544436077,1696606054,
     *1634497381, 543255649,1919756064,1835365235,1634166131, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750380,
     *1869506336, 541990957, 541991010,1869505568, 539508256, 825111605,
     * 541159015,1937011311,1831411744,        -3,1597191988, 540028464,
     * 891301934, 825565232, 775042336, 840974624, 538980384, 807416096,
     * 807411744,        -3,1282371175, 538976334, 539828302, 538976288,
     * 538976288, 541224814,1679828033, 539829314, 539893796,1176519022/
     * )
      ICK( 33901: 34200) = (/
     *1731076128,        -3,        -2, 541876594,1734680676,1702259041,
     *1953066862,1931503218,1869422695,1701733746,1634495609, 544170611,
     *1702000229,1679843951,1852055652,1769174113,1852007795, 544039289,
     * 543780452,1768120692,1696623983,1684368416,        -3, 544240239,
     *1651271021,1932271727,1986359853,1919247977,1852140901,1853104229,
     *1952656928,1130915171,1797285487,1914730354,1869506336,1635020653,
     * 762607984,1696620915,1936287598,1835363956,1932402720,        -3,
     * 541486962, 543256096,1702388077,1886151968,1936024890, 541156212,
     *1629504370,2037609518, 539505200, 808659232,1161115948, 544028465,
     * 808283447, 825372192,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750339, 760163656, 544696692,1746955361,1919378720,
     *1127042848,1651469924, 543451507,1952542307,1696604192,        -3,
     *1597191989, 538976288, 807415854, 808591408, 774911264, 840974624,
     * 538980384, 807416096, 807411744,        -3,1400140385,1852269856,
     *1127042861,1210074981,1869440372,1920540712,1127042848, 540942368,
     * 540094004, 891306350,1730748462, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 542340210,1634625381, 541273423,
     * 759701607,1701801317,1953659168,2003399784, 541273423, 538983968,
     * 538980654, 875896897,1852273524,1919905056,1684370533,1668572516,
     * 773857312,        -3, 542601839,1852252225,1953459488,1417244773,
     * 541007904,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750377,1852010354,1919247220,1819877487,1919509870,1952801824,
     *1835365480,2037129325,1869178228,2032148512,        -3,1597192240,
     * 538980398, 807416112, 774905905, 808333344, 874529056, 538980384,
     * 807416096, 807411744,        -3,1231971183,1920099683,1953265983,
     * 542077545,1701737573,1679841320,1936732713, 760046964,1752788000,
     *1299147109,1954095150, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 542402665,1931506789,1936990305,1818587764,
     *1931503215,1914728559,1936943458,1818566761,1852010354,1919247220,
     *1819877487,1919509870,1952801824,1128805152,1836018021,1953064307,
     * 773857312,        -3, 539510062,1731076161,1179211808, 858988649,
     *1853060197,1633951855,1713389894,1230512177, 859250789,1952656928,
     *2003399784,1768824948,1751457875,1212501080,1277194853,1634495785,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990317,
     *1702127737,1814064495,1768256633, 542649667, 759701602,1869505568,
     *1634625388,1696604192,        -3,1597192496, 538981934, 891297849,
     * 775233589, 808333344, 857751840, 538980384, 807416096, 807411744,
     *        -3,1147500137,1635019118,1730170213,1953003884, 539246880,
     *1479361325,1210073711,1852055617,1852271717, 539897390, 773858377,
     * 541353319,1919247648,        -3,        -2, 542469749,1937072492,
     * 541943156,1752788000,1299147109,1954095192, 759377224, 541159015,
     *1818566696,1231316321,1819048224, 825243936,1147496306,1701147424,
     *1718579744, 875389551,1852073316, 541272366,        -3,        -1,
     * 589315646,1042306149,1936990317,1702127737,1814064495,1768256633,
     * 541601091, 759701602,1869505568,1634625388,1696604192,        -3,
     *1597192497, 538982190, 891297849, 775233589, 808333344, 857751840,
     * 538980384, 807416096, 807411744,        -3,1147500137,1635019118,
     *1730170213,1953003884, 539246880,1210925869,1210073711,1852055617,
     *1852271717, 539897390, 773858377, 541353319,1919247648,        -3,
     *        -2, 542469749,1937072492, 541943156,1752788000,1299147109/
     * )
      ICK( 34201: 34500) = (/
     *1954095176, 759377224, 541159015,1818566696,1768187233,1819048224,
     * 825243936,1147496306,1701147433, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990311,1701733746,1634476120, 760163673,
     * 543256167,1818566774,1634497893,        -3,1597192501, 540094510,
     * 807416120, 808329265, 942681632, 840974624, 538980384, 807415840,
     * 824188960,        -3,1147500137,1635019118,1730159682,1097754476,
     *1696614002,1869422641, 842014822,1869750308,1093541924,1176519781,
     *1735550309,        -3,        -2, 542402661, 542649679, 760815713,
     *1852271717, 544629100,1969561700,1768318565,1920147558,1919905056,
     *1952998688,1668246893,1869488254, 825372718, 807421029,1735550309,
     *1932402720,        -3,        -1, 589315646,1042306149,1936990291,
     *1764577069,1399398497,1852271717, 544629100,1969561632,        -3,
     *1597192502, 540094510, 807416120, 808329265, 942681632, 840974624,
     * 538980384, 807415840, 824188960,        -3,1147500137,1635019118,
     *1730159682,1097754476,1696614002,1869422641, 892346470,1869750308,
     *1093541924,1176519781,1735550309,        -3,        -2, 542402661,
     * 542337325,1328370537, 543256167,1818566774,1634497893, 543451494,
     *1717924467, 543584879,1830843496,1696621423,1835888494, 545141045,
     * 808333344,1147496306,1701147438,        -3,        -1, 589315646,
     *1042306149,1936990274, 760163650, 543256167,1818566774,1634497893,
     *        -3,1597192503, 540094510, 807416120, 808329265, 942681632,
     * 840974624, 538980384, 807415840, 824188960,        -3,1147500137,
     *1635019118,1730159682, 541159015,1818566726,1919905056, 825372704,
     *1718579744, 608247844,1176519781,1735550309,        -3,        -2,
     * 542402661, 541207887, 759308385,1852271717, 543451494,1717924467,
     * 544434535,1852401257,1667329652,1819877478,1919905056, 825372718,
     * 807429221,1735550309,1932402720,        -3, 542402665,1931503987,
     * 543847795,1948279072,1852798057,1667578400,1110265645,1109418350,
     *1735157107, 544629106,2032170857,1684368505, 543450480,1701733481,
     *1852252271,1847621480,1635000425,1931502191,1852073316,        -3,
     * 544501536,1952998688,1114600047,1847615860,1869443886,        -3,
     *        -1, 589315646,1042306149,1936990275, 760163651, 543256167,
     *1818566774,1634497893,        -3,1597192504, 540094510, 807416120,
     * 808329265, 942681632, 840974624, 538980384, 807415840, 824188960,
     *        -3,1147500137,1635019118,1730159682,1097754476,1696614002,
     *1869422641, 842014822,1869750308,1093541924,1176519781,1735550309,
     *        -3,        -2, 542402661, 541273423, 759373921,1852271717,
     * 544629100,1969561700,1768318565,1920147558,1919905056,1952998688,
     *1668246893,1869488254, 825372718, 807421029,1735550309,1932402720,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1752134260, 544108398, 761425774,1684631143, 543780468,1918967880,
     * 774785056,1668247156,1633907827,        -3,1597255984, 538980398,
     * 874520624, 775233568, 808334880, 840974624, 538980384, 807415840,
     * 824188960,        -3,1399353202,1948273006,1953653024,1210986030,
     *1210073967,1853120867,1948262436,1093545508,1110319140,1176519022,
     *1731076128,        -3,        -2, 542337135,1920213097,1853125217,
     *1836018789,1668639841,1914725231,1853120867,1953701997,1635328097,
     *1919513445, 544696421,1847609389,1635020653,1931501938,1696622958,
     * 539518561,1819501865,        -3, 543383916,1668639841,1952801824,
     *1886352233,1953066862,1932402771,1752134260, 543780468,1918987631/
     * )
      ICK( 34501: 34800) = (/
     *1818583925,1818325536,1668247156,1633907827, 544039289, 543255667,
     *1864393317, 543236211,1768386080,1718579744,1629495328, 543580524,
     *1936007283,1953658211,1953854053, 544696692,1746957416,1696623983,
     *1818583925,1818566771,1769239657,1852252271,1847615776,1936290917,
     * 544696692,1746954605,1886547824,1701978227,1769235744,        -3,
     * 544438637,1835365490,2032150629, 778513952, 657598240,1768846196,
     *1700881440,1868963879, 758196009, 544696425,1667768429,1635328104,
     *1634758757,1847621480,1701716065, 543973748,1953063781,        -3,
     * 544502369,1853058145,1953066862, 543781664,1835627379,1701064224,
     *1399353202,1948279663,1853120867,1953701985,1919230052,1701210478,
     *1701060725,1936289383, 543236214,1634607204,1701978199,1633774707,
     *        -3, 544366948,1769304864,1868963889, 775036993,1852273524,
     *1919905070, 541486962, 543780468,1918987631,1818583925,1818325536,
     *1668247156,1633907827, 543255653,1920234272,1634886944,1734700645,
     *1918989413,1679826976,        -3, 543584114, 543387502,1952539508,
     *1931504741,1936924788,1751215648, 841887776,1097754483,1953656685,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 544108398, 761425774,1684631143, 543780468,
     *1701978184, 774785056,1668247156,1633907827,        -3,1597255985,
     * 538976288, 807411760, 775168032, 808334880, 840974624, 538980384,
     * 807415840, 824188960,        -3,1399353202,1948273006,1952805408,
     *1210986030,1210073967,1853120867,1948262436,1093545508,1110319140,
     *1176519022,1731076128,        -3,        -2, 542337135,1920213097,
     *1853121906,1836018789,1668639841,1914718254, 776478819,1869509729,
     *1668576032,1835104544,1768842345,1667331173, 543780451,1869771365,
     *1668574329, 543450484,1701997929,1852138528,        -3, 544437362,
     *1969452149,1919251232, 677981797, 773879666,1869506336,1937337709,
     *1702130297, 740322665,1936942436, 544502369,1853058145,1953066862,
     * 544438637,1835365490,2032935031,1919905383, 544239475,1769236847,
     *1847599136, 544696692,1746956901,1717924453,1852007712,1953439860,
     *1751457907,2037214565,1953659168,1701602669,1701737587, 740321401,
     *1685221223,1701716065,1953459571, 544173600,1635020653,1931507560,
     *1701995808,1952998770,1696604192, 544434287,1970037792,1852797984,
     *1650794593,1853431840,1702126382, 774447136,        -3, 542337135,
     *1920213097,1853121906,1836018789,1668639841,1914725231,1853120867,
     *1953701997,1635328098,1696622958,1684628321,1953068645, 543584114,
     * 543780451,1869509481,1937007982,1948283769,1835885940,1920540704,
     *        -3, 543449460,1629497445, 778513952,1668247410,1684631137,
     *1952805664,1718579744,1936744803,1697474418,1869967392,1345598240,
     *1634624544,1937337709,1702130297, 544436325,1667851881,1701060705,
     *1931497524, 824209266,        -3, 542126641, 795746342, 542126641,
     * 795025507,1869506165,1936289646,1932078624,1399353202,1948279663,
     *1853120867,1953701985,1919230052,1701210478,1701060725,1936289383,
     * 543236214,1634607204,1701978199,1633774707,        -3, 544366948,
     *1769304864,1868963889, 775036993,1852273524,1919905070, 541486962,
     * 543780468,1701997935,1818583925,1818325536,1668247156,1633907827,
     * 740319598, 543255653,1920213097,1931503461,1852142177,1952801824,
     *        -3, 543584114, 543387502,1952539508,1931504741,1936924788,
     *1751215648, 841888800,1097754483,1953656685, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1752134260/
     * )
      ICK( 34801: 35100) = (/
     * 544108398, 761425774,1684631143, 543780468,1918967880, 774785056,
     *1668247156,1633907827, 539519342,1987013750,1768843040,1481126697,
     *        -3,1597255986, 538980398, 891297840, 775299104, 808335136,
     * 840974624, 538980384, 807415840, 824188960,        -3,1399353202,
     *1948273006,1953653024,1481126688, 774774872,1215176736, 538976292,
     *1093545508,1110319140,1176519022,1731076128,        -3,        -2,
     * 542337135,1920213097,1853125217,1836018789,1668639841,1914725231,
     *1853120867,1953701997,1635328097,1919513445, 544696421,1847609389,
     *1635020653,1931501938,1696622958, 539518561,1819501865,        -3,
     * 543383916,1668639841,1952801824,1886352233,1953066862,1932402771,
     *1752134260, 543780468,1918987631,1818583925,1818325536,1668247156,
     *1633907827, 544039289, 543255667,1864393317, 543236211,1768386080,
     *1718579744,1629495328, 543580524,1936007283,1953658211,1953854053,
     * 544696692,1746957416,1696623983,1818583925,1818566771,1769239657,
     *1852252271,1847615776,1936290917, 544696692,1746954605,1886547824,
     *1701978227,1769235744,        -3, 544438637,1835365490,2032150629,
     * 778513952, 657598240,1768846196,1700881440,1868963879, 758196009,
     * 544696425,1667768429,1635328104,1634758757,1847621480,1701716065,
     * 543973748,1953063781,        -3, 544502369,1853058145,1953066862,
     * 543781664,1835627379,1701064224,1399353202,1948279663,1853120867,
     *1953701985,1919230052,1701210478,1701060725,1936289383, 543236214,
     *1634607204,1701978199,1633774707,        -3, 544366948,1769304864,
     *1868963889, 775036993,1852273524,1919905070, 542337135,1920213064,
     * 539897376,1210082159,1853120867,1948281198,1987013750,1768843040,
     *1128805152,1210933620,1869443872,1634886944,1868985445,1847599136,
     * 543711597,1885696613,1679843961, 544499813, 543580515,1948284008,
     *1635000436,1751480608,1768846959,1819698464,1210081652,1869443872,
     *1635000430,1869881455,1886677357,1634476131,1634493301,1818326117,
     *1679826976,        -3, 544239475,1769236847,1853042208,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1752134260,
     * 544108398, 761425774,1684631143, 543780468,1701978184, 774785056,
     *1668247156,1633907827, 539519342,1987013750,1768843040,1481126697,
     *        -3,1597255987, 538980398, 807411760, 775168032, 808334624,
     * 840974624, 538980384, 807415840, 824188960,        -3,1399353202,
     *1948273006,1952805408,1481126688, 774774872,1215176736, 538976292,
     *1093545508,1110319140,1176519022,1731076128,        -3,        -2,
     * 542337135,1920213097,1853121906,1836018789,1668639841,1914718254,
     * 776478819,1869509729,1668576032,1835104544,1768842345,1667331173,
     * 543780451,1869771365,1668574329, 543450484,1701997929,1852138528,
     *        -3, 544437362,1969452149,1919251232, 677981797, 773879666,
     *1869506336,1937337709,1702130297, 740322665,1936942436, 544502369,
     *1853058145,1953066862, 544438637,1835365490,2032935031,1919905383,
     * 544239475,1769236847,1847599136, 544696692,1746956901,1717924453,
     *1852007712,1953439860,1751457907,2037214565,1953659168,1701602669,
     *1701737587, 740321401,1685221223,1701716065,1953459571, 544173600,
     *1635020653,1931507560,1701995808,1952998770,1696604192, 544434287,
     *1970037792,1852797984,1650794593,1853431840,1702126382, 774450720,
     *1399353202,1948281198,1952805485,1869374819,1970037106, 543387502,
     *1952539508,1931504993,2032165477, 543780452,1768120692,1769366816,
     *        -3, 543584114, 543780451,1869509481,1937007982,1948283769/
     * )
      ICK( 35101: 35400) = (/
     *1835885940,1920540772,1635016992, 677719655, 773874543,1869767785,
     *1851880549,1931503215,1914729328,1633903917,1735552885,1881165876,
     * 857760110,1679826976,        -3, 544438637,1835365490,2032169840,
     *1701013862,1768252448,1634934864, 875634799,1914720306, 825191968,
     * 639651890, 825189152,1668247142,1970497903,1853040942, 542337135,
     *1920213091,1869509729,1668576032,1634886944,        -3, 543450470,
     *1768842596, 544568169,1852252257, 544629102, 543450482, 542597473,
     *1819484274,1633970549,1931505510, 540094002, 541159015,1937011311,
     *1831739475,1752134260, 541597742, 773867552,1668247156,1633907744,
     *        -3, 543780470,1869379177,1852252227,1211310152, 761361519,
     *1836261473,1919230063,1718904174, 543711597,1885696613,1679843961,
     * 544499813, 543580515,1948284008,1635000436,1751480608,1768846959,
     *1819698464,        -3, 541597793,1953459571, 543257632,1852797984,
     *1869640809,1835101216,1667329123,1970037108,1701060720,1869834612,
     *1768910451, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1752134260, 544108398, 761425774,1684631143,
     * 543780468,1918967876, 759705134,1210931232,1668247156,1633907827,
     *        -3,1597255988, 538980398, 874520624, 775233568, 808334880,
     * 840974624, 538980384, 807415840, 824188960,        -3,1399353202,
     *1948273006,1953653024,1143818286, 776482136, 538976288, 538976292,
     *1093545508,1110319140,1176519022,1731076128,        -3,        -2,
     * 542337135,1920213097,1853125217, 541338952, 774785069,1478517615,
     *1853120867,1949179988,1751741216,1835624296,1948279397, 543236196,
     *1764583545,1685221223,1701716066,1869505568,1868963956,1751457908,
     *2037409056,        -3, 541207880, 774785069,1328422944,1399153952,
     *1131569506,1953654117, 543519776,1634479648,1097032494, 541288549,
     *1831739474,1702047264, 825833782, 740307513, 740307764, 942486325,
     * 875438112,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1752134260, 544108398, 761425774,1684631143, 543780468,
     *1701978180, 759705134,1210931232,1668247156,1633907827,        -3,
     *1597255989, 538980398, 824188976, 775168032, 808334624, 840974624,
     * 538980384, 807415840, 824188960,        -3,1399353202,1948273006,
     *1952805408,1143818286, 776482136, 538976288, 538976292,1093545508,
     *1110319140,1176519022,1731076128,        -3,        -2, 542337135,
     *1920213097,1853121906, 541338952, 774785069,1478517615,1853120867,
     *1949179988,1751741216,1835624296,1948279397, 543236196,1764583545,
     *1685221223,1701716066,1869505568,1868963956,1751457908,2037409056,
     *        -3, 541207880, 774785069,1328422995,1701132832,1131569506,
     *1953654117, 543519776,1634479648,1097032494, 541288549,1831739474,
     *1702047264, 825833782, 740307513, 740307764, 942486325, 875438112,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1752134260, 544108398, 761425774,1684631143, 543780468,1918967876,
     * 759705134,1210926112,1668247156,1633907827,        -3,1597255990,
     * 538980398, 874520624, 775233568, 841889056, 840974624, 538980384,
     * 807415840, 824188960,        -3,1399353202,1948273006,1953653024,
     *1143818286, 776482116, 538976288, 538976292,1093545508,1110319140,
     *1176519022,1731076128,        -3,        -2, 542337135,1920213102,
     *1869491554,1869505641,1852252265,1853125217, 541338952, 774785069,
     *1142973295,1853120867,1953701997,1635328098,1696625253,1818326117,
     *1679848559, 543451507,1869767781,1919247392,1869750304,        -3/
     * )
      ICK( 35401: 35700) = (/
     * 544041331,1886151011,1701060680, 761361519,1836264992,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1752134260,
     * 544108398, 761425774,1684631143, 543780468,1701978180, 759705134,
     *1210926112,1668247156,1633907827,        -3,1597255991, 538976288,
     * 807411760, 775102496, 808334880, 840974624, 538980384, 807415840,
     * 824188960,        -3,1399353202,1948273006,1952805408,1143818286,
     * 776482116, 538976288, 538976292,1093545508,1110319140,1176519022,
     *1731076128,        -3,        -2, 542337135,1920213102,1869491554,
     *1869505641,1852252265,1853121906, 541338952, 774785069,1142973295,
     *1853120867,1953701997,1635328098,1696625253,1818326117,1679848559,
     * 543451507,1869767781,1919247392,1869750304,        -3, 544041331,
     *1886151011,1701060680, 761361519,1836264992,1165520997,1919509870,
     *1667571816,1634934899,1752135534, 544499809,1948279150,2032167278,
     *1952805485,1869374819,1970037106, 541601326, 776478752,        -3,
     * 544433520,1634886004,1768910368,1868963948,1702064928,1952997742,
     * 540094008, 541159015,1937011311,1836261474,1702131557,1701716085,
     *1852404781,1868784501,1885433443,2032158752,1635020653,1931503987,
     * 543236128,        -3, 543386725,1634869353,1852074339,1635020658,
     * 544499809,1948282734,1696624498, 543321972,1746956134, 544499813,
     *1936007240, 543257711,1836261485,1635328098,1696626546,1869506412,
     *2032169068,1633903972, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750340, 759701602,1869505651, 544696692,
     *1752135028, 543253347,1701868655,1914708000,        -3,1597256240,
     * 538976288, 807411761, 775233568, 540621088, 840974624, 538980384,
     * 807415840, 824188960,        -3,1143818272,1114599012, 542599540,
     *1752135028, 541156195,1701868655,1914708004,1093479716,1110319136,
     * 538976336,1818583411,1696613224,1701014304,        -3,        -2,
     * 542142324,1701737577,1634476136,2036626031,1734700576,1651469924,
     * 543453038,1869771552,1634886944,1667786083,1801806880,1718579744,
     *1952998688,1886545267,1701733221, 544171552,1937074548,1633840229,
     *        -3, 543253347,1701868655,1920147573,1936289383, 543387501,
     *1836019308,2032170355,1701060648,1248159334,1919252777, 541601122,
     *1869505568,1668442484,1701996897, 773865843, 543236199,1701733746,
     *1634476146,1970038048,        -3, 544499813,1919230067,1752135020,
     *1679843941, 543256096,1633903461,1886678898, 543584114, 543514979,
     *1746953327,1852797486, 541423715,1701868649,1869509408,1634886944,
     *1986359929, 544366962,1696622191,1914720045,1210064928, 543256164,
     * 544042866,1696621423,1835888494, 543584114, 539840072, 543256164,
     * 539840072, 841883713, 543387501,1836019232,1701999215,1914726771,
     * 543256096, 760170528,2003399784, 541620580,1919903589,1847615860,
     *1869422624, 544173600,1629512545,1818457452,1635018084, 544239475,
     *1769236847,1847621481,1952981071, 759701616,1869180532,1768843040,
     *1768824948,1751457911,1919905383, 543451506,1701016681,1869491744,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1752134260, 544108398, 761425774,1684631143, 543780468,1701978180,
     * 774778433, 543387502,1952539508,1931485216,        -3,1597256496,
     * 538976288, 807415854, 825827376, 775237664, 840974624, 538980384,
     * 807415840, 824188960,        -3,1399353202,1948273006,1952805408,
     *1143877166,1092633455,1853120867,1948262436,1093545508,1110319140,
     *1176519022,1731076128,        -3,        -2, 542402665,1931506789/
     * )
      ICK( 35701: 36000) = (/
     *1936990305,1818587764,1931503215,1914728559,1936943458,1819877485,
     *1769173861,1679837305,1685221223,1701716066,1869505651, 543257376,
     *1768842345,1667331173,1679843961, 544434287,1920213024,        -3,
     * 539519278,1697521779,1752134260,1701978228,1751215648,1937075488,
     *1868963956,1751457910,1634607204,1701978199,1633774707, 544366948,
     *1768497197, 540028466, 541159015,1937011311,1831411744,        -3,
     * 541355886,1869750317, 541156195,1701868655,1914724724,1869422692,
     *1769174113,1852007795, 773857312,        -3,        -2, 542011252,
     *1698308179,1752134260, 541277519, 539897376,1329414944,1634886944,
     *1868723045,1920361828, 544436077,1702127981,1702043767,1751477792,
     *1885434484, 544171552,1953002085,1697473381,1853125221,        -3,
     * 542059848, 740314669,1210085234, 541273416, 542060078,1327522418,
     *1768187753,1852255776,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1752134260, 544108398, 761425774,1684631143,
     * 543780468,1701978184,1278094894,1092641647,1853120867,1953701920,
     *        -3,1597256497, 540028465, 807415854, 858791984, 775237664,
     * 840974624, 538980384, 807415840, 824188960,        -3,1399353202,
     *1948273006,1952805408,1212952110,1092633455,1853120867,1948262436,
     *1093545508,1110319140,1176519022,1731076128,        -3,        -2,
     * 542402665,1931506789,1936990322,1701867378,1953701999,1847620456,
     *1869771808,1768846437,1919774572,1701016940,1634869320,1634496359,
     *1701716014, 773866607,1852797487,1097032549,1886678898,        -3,
     * 543257711,1831695481,1885675620,1769174113,1852007795, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1752134260, 544108398, 761425774,1684631143, 543780468,1701978200,
     * 774778457, 543387502,1952539508,1931485216,        -3,1597256498,
     * 538980398, 840970286, 858791984, 775237664, 840974624, 538980384,
     * 807415840, 824188960,        -3,1399353202,1948273006,1952805408,
     *1479421486,1495286639,1853120867,1948262436,1093545508,1110319140,
     *1176519022,1731076128,        -3,        -2, 542402665,1931506789,
     *1936990322,1634300773,1679843694, 541150277,1381245030,1869750387,
     *1752134260, 543780468,1701997935,1818583925,1818325536,1668247156,
     *1633907827, 773857312,        -3, 541683232,1734700645,1918987308,
     * 543780468,1701997935,1818583925,1818325536,1668247156,1633907744,
     *1684632436,1634624357,1931506536,1869966436, 543319328,1852797984,
     *1836409704, 544435553,1819043186, 544499809,1847599136, 544499813,
     * 544437613, 544171552,1952998688,1634956143,1667850612,1701060726,
     *1634607204,1701978199,1633774707, 542269796,1768500768,1299149413,
     * 544171636,1701716084,1751215648,1852797996, 544437603,1746935840,
     *        -3, 544434287,1920213091,1869509729,1668576032,1667329568,
     *1650794593, 544694642,1852403303, 544434535,1847617135,1914725746,
     *1919906419, 773865836,1814066024,1869771808,1668247156,1633907827,
     * 544434287,1970037792,        -3, 544499813,1919247983,1919230050,
     *1696621944,1634560366,1701060713,1847620463,1835343972,1702125929,
     *1814962249,1853121906,1702065257,1852252261,2019779952,1953066862,
     *1931501938,1696621409,1919053678,2037132576,        -3, 543383922,
     *1651469945,1814063470,1952805473,1668573551,1853038708,1751217184,
     *1868985445,1847617125,1635022194,1696625512,1869771808,1328426542,
     *1126196079,1853120867,1953701928,1936024864,1097624677,1847599136,
     *        -3, 543519776,1634479648, 674314553, 942219330, 892611616/
     * )
      ICK( 36001: 36300) = (/
     * 858927149, 858929452, 544434287,1920213070,1328685135, 774778447,
     * 543780468,1701994851,1953066862,1931501934,1679835718, 875048233,
     * 544501536,        -3, 539517298,1869439348,1768106272,1667330658,
     *1869488227,1869509729,1668576046,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750387,1752134260, 544108398, 761425774,
     *1684631143, 544041326,1869753902,1835626095,1914726766,1952805408,
     *1479421486,1495294831,1853120867,1953701920,        -3,1597256499,
     * 538980398, 891301934, 943005745, 774909984, 874529056, 538980384,
     * 807415840, 824188960,        -3,1399353202,1948273006,1952805408,
     *1479421486,1495286639,1853120867,1948262436,1093545508,1110319140,
     *1176519022,1731076128,        -3,        -2, 542402665,1931506789,
     *1936990322,1634300773,1679843694, 541150277,1381245030,1869750387,
     *1752134260, 543780468,1701997935,1818583925,1818325536,1668247156,
     *1633907827, 543319412,2003133806, 544041326,1869750304,        -3,
     * 543451507,1869767781,1914725231,1836085102,1701737587, 773867886,
     * 543647086,1701994860, 740321646,1952805485,1869374819,1970037106,
     * 543387502,1952539508, 543451507,1952542307,1702043763,1752135020,
     *1679843941,        -3, 544108404, 544044387,1746957165,1634495589,
     *1914729576,1634607220,1751457907,1970085999,1713402984,1696620915,
     *1936679785,1635018084, 544629102, 543450482, 542597473,1819484242,
     *1633970537, 773868911,1919229984,        -3, 544171636,1701716084,
     *1751215648,1852797996, 544437603,1746957160,1869771808,1668247156,
     *1633907827, 543383918, 543319328,1629517665,1919838574,1730179945,
     *1735270502,1869750373,1920102258,1932402753,1819025440,        -3,
     * 544434287,1920213091,1869509729,1668576032,1936224117,1818501236,
     *1751478885,1718579813, 543319328,1702388077,1768842596, 543780384,
     *1936682341, 543450484,1634298926, 541683316,1701995891,1953066599,
     *        -3, 543520867,1701868649,1869509408,1634886944,1667330658,
     *1869511020, 761487730,1651469945,1814063470,1952805473,1668573551,
     *1853038708,1751217184,1868985445,1847617125,1635022194,1696625512,
     *1869771808,1328426542,1126178848, 543387502,1952539508,1931487347,
     *1701126209,1819043182, 543519776,1634479648, 674314553, 942219330,
     * 892611616, 858927149, 858929449, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750387,1752134260, 544108398,
     * 761425774,1684631143, 543780468,1701978184,1278094894,1212948579,
     *1869509729,1668576032,        -3,1597256500, 540028465, 807415854,
     * 875896880, 775368736, 840974624, 807415840, 807416096,        -3,
     *1399353202,1948273006,1952805408,1212952110,1212948547,1869509729,
     *1668554788,1093545508,1110319140,1176519022,1731076128,        -3,
     *        -2, 542402665,1931506789,1936990322,1701867378,1953701999,
     *1847620456,1869771808,1768846437,1919774572,1701016940,1634869320,
     *1634496359,1701716014, 773867617,1819240293,1847620729,1885675620,
     *1769174113,1852007795, 773857312, 542011252,1698308162,1919509607,
     *1768843040,1227694185,1869509408,1768824929, 542649673, 774778441,
     * 758001198,1227708704,1667785065,1847618913,2032167278,1987013477,
     * 543974774,1701584962, 541150277,1381266222,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750388,1869553772,1634887525,
     * 541601326, 776020000,        -3,1597257776, 539831857, 840970286,
     * 842342432, 808334624, 874529056, 538980384, 807415840, 824188960,
     *        -3,1282371175, 541601326, 776020040, 759328622,1679839845/
     * )
      ICK( 36301: 36600) = (/
     *1886351988,1701060644,1093545508,1110319140,1176519022,1731076128,
     *        -3,        -2, 541288549,1667965044,1751741216, 678784626,
     *1700883561,1937008995,1634495609, 689990767,1852252274,1701867378,
     *1952801824,1210986049, 543387502,1952539508, 773857312,        -3,
     * 541746534,1718773113, 543388265,1952805481,1970092576,1131376244,
     *1633907744, 540811296, 544629847,1378371625, 539697270,1683444264,
     *1093214253, 540028465, 840974702,1735619698,1869426208,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750388,1869553772,
     *1634887525, 541339182, 776020000,        -3,1597257777, 538980398,
     * 891297841, 774905888, 841887776, 874529056, 538980384, 807415840,
     * 824188960,        -3,1282371175, 541339182, 776020040, 759328622,
     *1679839845,1886351988,1701060644,1093545508,1110319140,1176519022,
     *1731076128,        -3,        -2, 541288549,1667965044,1751741216,
     * 678784626,1700883561,1937008995,1634495609, 689990767,1852252274,
     *1701867378,1952801824,1143877185, 543387502,1952539508, 773857312,
     *        -3, 541746534,1718773113, 543388265,1952805481,1970092576,
     *1131376244,1633907744, 540811296, 544629847,1378370601, 539697270,
     *1683444264,1093214251, 540028469, 807420270,1735619698,1869426208,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750388,
     *1869553779,1835101292, 541338952, 774778433, 543256167,1818566688,
     *        -3,1597257778, 538982448, 773863728, 774905905, 808463904,
     * 874529056, 538980384, 807415840, 824188960,        -3,1399677292,
     *1814053933,1210986049, 541159015,1818566738,1701847142,1869750308,
     *1093545508,1110319140,1176519781,1735550309,        -3,        -2,
     * 541288549,1667965044,1751741216,1970172517,1634494835,1953063777,
     *1819048224,1936548204,1814065765,1886351988,1701060676, 759705134,
     *1092632942,1735157038,        -3, 541746534,1718773113, 543388265,
     *1952805481,1970092576,1143818286, 776020033,1852271717, 540942385,
     * 808460388,1701278309,1702047264,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750382,1869881458,1869966948,1701060676,
     * 759705134, 776020065,1852271717,        -3,1597257780, 538976288,
     * 807411744, 540155936, 538980896, 874531104, 538980384, 807415840,
     * 824188960,        -3,1383036270,1679836205,1210986049, 541159015,
     *1818566738,1701847142,1869750308,1093545508,1110319140,1226851429,
     *1735550309,        -3,        -2, 541338952, 774783264,1634625388,
     *1702043767,1769236591,1970544755, 779431456,1936224117,1818501218,
     *1696625263,1970168933,1679848559, 543780468,1701274994, 544629100,
     *1969582880,1718579744,        -3, 544240994,1818846049,1953066862,
     * 544241010,1886352229,1931487314,1701934441,1919247392,1718579744,
     *1097036897, 541291129,1936993833, 773857312,        -3,        -1,
     * 589315646,1042305637,1886351988, 544499813, 543973746,1734701940,
     * 539522414,1919250543,1920230756, 689992559,1819698542,1948279139,
     *1667593075,1768057957, 544632681,1679848297,2053447712,        -3,
     *1597386801, 538976307, 807411761, 808460320, 842018848, 840974624,
     * 538980384, 807415840, 824188960,        -3,1433299316, 541287788,
     *1814053743,1853120873,1853038675,1869379173,1853104193,1667458419,
     *1936286316,1696618063,1229214496, 538983485, 539248928,1097754410,
     * 707993632,        -3,        -2, 541291129,1937006956, 544437362,
     *1969452149,1919251232,1768824935,1701733746,1634476132,1864396399,
     *1948279663,1853120873,1847618657,1919378720,1936682102,1701737504/
     * )
      ICK( 36601: 36900) = (/
     *1633903461,1936943458,1818566774,1869177971,        -3, 543780384,
     *1952998688,1818326132,1768121646, 541945715,1948283764,1920295796,
     *1970431347, 543977331,1696625768,1701409312,1819242087, 762470766,
     *1734680687,1919182194,1768843040,2003330414, 544436076,1986358900,
     *        -3, 544042860,1701016940,1702043756,1700886117, 544499813,
     * 543388281,1937006956, 773869422,1819877495,1751477792,1952998688,
     *1919249761,1768843630,1730178661,1953984370,1797286259, 544437362,
     *1869506412,2032148512,        -3, 543321966,1684366368, 677719655,
     * 773880421,1869375860,1702043745,1852055667,1869440288,1752786034,
     *1869047150, 543321966,1684366368,1852142711,1869769587, 689992808,
     *1696621426,2037609569,1814044704,        -3, 544437362,1969452149,
     *1919230061,1635328115,1970435689,1986342432,1382380393,1685414252,
     * 544632681,1685266537,1847615776,1937011317,1668576626,1696623969,
     *2032167278,1684628321,1952784500,1751457824,        -3, 544173417,
     *1936943471,1847619430, 539518057,1936683620,1701995876, 689988709,
     *1853057396,2032166514,1869422708,1751457901,1868850540, 773866601,
     *1936683620,1701995876, 543450478,1936290937, 544039289, 543649568,
     *        -3, 544566884,1702126947,1952801824,2003330414, 544435557,
     *1634887012, 544434542,1667571824,1700883232,1936023922,1667768432,
     *1919903602,1634562848,1634886944,1852797984,1684370281,1735288164,
     * 544501536,1819239265,1952784416, 544039288,1768775968,1869488228,
     *1701737321,1954095218,1768187749,1932402772,1751457904,1919251301,
     *1852007712,1869750369,1651729774,1667571823,1713402469,1936286837,
     *1634476132,1701737321,1954095209,1847620712,1696604192, 544632681,
     *1679846753,2032165477, 544630130,1768319333,1679847278, 543236208,
     *1919512180,1701064560,1819243636,1701060708,1768318565,1919250019,
     *1696613999,1970432357,1914727777,1881173874, 544696692,1746935840,
     *        -3, 542133313,1414483503,1397839173,1163543854, 542535529,
     *1685266543,1713386544, 541159015, 707408672,1835104544,1633903471,
     *1835888484,1635018016,1211256622, 542338401,1819025517,1869374819,
     *1970038131, 544437603,1746935840, 543257376,1415935090,1634236772,
     *1919903349,1918987808,1751217765, 544504176,1768120684, 544632684,
     *1970103667, 543780384,1952998688, 825241632,1953439794, 808460353,
     *1852254762, 857764449,1852269870, 542402665,1931485216, 544499059,
     *1948283493,1886351988,1931506792,1696626287,1819635045, 544171552,
     *1952998688,1818325607,1702065184,1936682102,1701737504,1633903461,
     *1936943458,1818566774,1869177888,1768824948,1751457824,        -3,
     * 544437362,1969452149,1919233568,1092644961,1885696544,1919250543,
     *1920231790,1730175264,1668446579,1952541728,1937011317,1668576626,
     *1696626537,1952981089, 544434535,1852401257,1667329652, 544436076,
     *1986358900,        -3, 543253347,1702065001,1651270944,1987012964,
     * 544434287,1970037792,1635000436,1751457900,1700885364, 543451507,
     *1668641651, 544499813, 543781747,1969565216,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750356,1330585676,1095911237,
     * 539522414,1919250543,1920230756, 689992559,1819698542,1948279139,
     *1667593075,1768057957, 544632681,1685266464,        -3,1597386802,
     * 538976288, 807411744, 540024864, 538980384, 840974624, 538980384,
     * 807415840, 824188960,        -3,1399811190,1701737504,1097032549,
     *1936943458,1818566742,1330201640,1395204201,1847620712,1696617838,
     *1769218115,1701604384, 774778414, 538976288, 538976288, 538976544/
     * )
      ICK( 36901: 37200) = (/
     *1130915171,1797267488,        -3,        -2, 542402665,1931506789,
     *1936990322,1701867378,1953701999,1847615776,1936682102,1701737504,
     *1633903461,1936943458,1818566774,1869177888,1768824948,1751457907,
     *1953658211,1953854053, 740324463,1864395873,1919378720,        -3,
     * 544174624,1953460000,1953066341, 543387502,1937075561,1852252262,
     *1869750388,1751457891,1970434661,1853104208,1279349839,1310750309,
     *1920166255,1847617135,1914724640,1836020325, 543450484,1634298981,
     *1679826976,        -3, 543256161,1819898729,1931501939, 544235890,
     *1948282726, 544499813, 544629100,1768186228,1768910368,1920298542,
     * 542471013, 544499813, 542330700,1444966256,1953066862, 543584114,
     * 544042866,1696621669,1952541036,1932402720, 542340451,1746952480,
     *2002874990,1768843040,1835624296,1948279148,1936662633,1852074339,
     *1635018016,1952997748, 544499813, 544438637,1835365490,2032167283,
     * 543780451,1869443180,1702126880,        -3, 543501927, 773878632,
     *1869966436, 543711606,1696621157,1701716083,1885692777,1718183268,
     * 543257376,1345138976,1634624544,1852797984,1345399840,1818583414,
     *1768843040,1869968416,1751215206, 544171552,        -3, 544499813,
     * 544566889,1948279653,1819025507,1869509733,1853107744,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750356,1330585676,
     *1095911237, 542469737,1948271461,1819025510,1869750358,1330201632,
     *1936023922,1667768352,        -3,1597386803, 538976288, 807411744,
     * 540024864, 538980384, 874520608,1092628512, 807415840, 824188960,
     *        -3,1433299316, 541287788,1814058063,1327524961,1919378720,
     *1718579744,1448036676, 542328129,1380141088,1768824915,1953658211,
     *1953854053, 538976288, 538976288, 538976544,1231971951,        -3,
     *        -2, 542011168,1936023922,1667768422,1869750387,1869379173,
     *1853104225,1667458419,1936286316,1696618063,1229214496,1685024357,
     * 543257376,1885434484, 544171552,1447119945,1145132105,1330520169,
     *1847599136,        -3, 544631141,1998614374, 543973746,1734680693,
     *1852404781,1667591276, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750356,1330585677,1634629920,1448036676,
     *1394614304,        -3,1597386804, 538976288, 807411744, 540024864,
     * 538980384, 874529056, 538980384, 807415840, 824188960,        -3,
     *1416589088,1298230905, 542527305,1146298436,1702126947,1952801824,
     *1768824915,1953658211,1953854053, 539897390, 774778414, 774778414,
     * 774774816, 538976288, 538976544,1231971951,        -3,        -2,
     * 542404463, 544039278,2032169839,1819698542,1948279139,1667593075,
     *1768057957, 542527305,1146301984,        -3, 589315389,1027423549,
     *1027423549,1027423549,1027423549,1027423549,1027423549,1027423549,
     *1027423549,1027423549,1027423549,1027423549,1027423549,1027423549,
     *1027423549,1027423549,1027423549,1027423549,1027423549,1027416096,
     * 589315646,1042306149,1936990310,1869750312,1919250543,1920230756,
     * 689992559,1819698542,1948279139,1667593075,1768057957, 544632681,
     *1685266464,        -3,1597386805, 538976288, 807411744, 540024864,
     * 538980384, 874529056, 538980384, 807415840, 824188960,        -3,
     *1281454695,1702065184,1399811190,1701737504,1097032549,1936943458,
     *1818566742,1330201632,1768824948,1751457875,1953658211,1953854053,
     * 539248928,1093282355,        -3,        -2, 541291129,1937006956,
     * 544437362,1969452149,1919251232,1768824935,1701733746,1634476132,
     *1864396399,1948279663,1853120873,1847618657,1919378720,1936682102/
     * )
      ICK( 37201: 37500) = (/
     *1701737504,1633903461,1936943458,1818566774,1869177971,        -3,
     * 543780384,1952998688,1818326132,1768121646, 541945715,1948283764,
     *1920295796,1970431347, 543977331,1696625768,1701409312,1819242087,
     * 762470766,1734680687,1919182194,1768843040,2003330414, 544436076,
     *1986358900,        -3, 544042860,1701016940,1702043756,1700886117,
     * 544499813, 543388281,1937006956, 773869422,1819877495,1751477792,
     *1952998688,1919249761,1768843630,1730178661,1953984370,1797286259,
     * 544437362,1869506412,2032148512,        -3, 543321966,1684366368,
     * 677719655, 773880421,1869375860,1702043745,1852055667,1869440288,
     *1752786034,1869047150, 543321966,1684366368,1852142711,1869769587,
     * 689992808,1696621426,2037609569,1814044704,        -3, 544437362,
     *1969452149,1919230061,1635328115,1970435689,1986342432,        -3,
     * 542270835,1768191329,1814066799,1768190752,1768824929, 544437362,
     *1969452149,1919230061,1635328105,1852074339,1635018016,1952998688,
     *1869441395,1936289646, 544171552, 677669235,1869767781,1919247401,
     *        -3, 543450478,1936290937, 543584879,1830843496,1696623983,
     *1684368430, 541354355,1869767781,1919247392,1684369011,1769240864,
     *1835104544,1735336053,1852073332,1701016677,1679849320,1701716083,
     *1835360626,1701060640,        -3, 544434542,1667571824,1700883232,
     *1936023922,1667768432,1919903602,1634562848,1634886944,1852797984,
     *1684370281,1735288164, 544501536,1819239265,1952784493,1635281261,
     *1629515630, 543450478,1936290937,        -3, 544368996,1734701870,
     * 542402661, 544240229,1936027235,1696624498, 543253107,1701733221,
     * 544171552,1919251305,1685414252, 543450478,1936290937, 543780384,
     *1952998688,1987012964, 544039289, 543319328,        -3, 544630130,
     *1768319333,1679847278, 543236208,1919512180,1701064560,1819243636,
     *1701060708,1768318565,1919250019,1696613999,1970432357,1914727777,
     *1881173874, 544696692,1746948172,1096044366, 793989461,1162172997,
     * 773857312, 542535529,1685266543,1713386544, 541159015, 707408672,
     *1835104544,1633903471,1835888484,1635018016,1211256622, 542338401,
     *1819025517,1869374819,1970038131, 544437603,1746952563,        -3,
     * 542401908,1918986361,1685221222,1970430318, 543711606,1696625785,
     *1885954913,1814066799,1819635045,1931503982, 544499813, 540094512,
     * 544501536, 842018848,1097754410, 707993714,1634625381, 773857312,
     *        -3, 542402665,1931506789,1936990322,1701867378,1953702004,
     *1751457910,1869378925,1696624486, 544499813, 543973746,1734701940,
     * 544436076,1986358900, 543253347,1702065001,1651270944,1987012964,
     * 543780384,1952998688,        -3, 544437362,1969452149,1919233568,
     *        -3, 541139056,1634755954, 544367984,1869771881,1852252257,
     * 543388281,1937006956, 544437362,1969452149,1919230071,1769236512,
     *1629516649,1735289190,1768120686,1948283759,1819698542,1948279139,
     *1667593075,1768057957,        -3, 544632681,1679848296,1869966436,
     * 543257632,1952998688,1818583411,1948279913,1935897971,1931506792,
     *1696622963,1937073454,        -3,        -2, 542011252,1698308180,
     *1751457909,1936007279,1713393740,1096044366, 793989461,1162172997,
     * 544694643, 544367984,1869771877,1679845742, 544499813, 541280582,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750356,1330585676,1095911237, 539521637,1886351988,1701062944,
     *1936682102,1701737504,1633903461,1936943458,1818566774,1869177971,
     *        -3,1597386806, 538976288, 807411744, 540024864, 538980384/
     * )
      ICK( 37501: 37800) = (/
     * 874529056, 538980384, 807415840, 824188960,        -3,1399811190,
     *1701737504,1097032549,1936943458,1818566742,1330201640,1395204201,
     *1847612276,1920295796,1970431264, 774778414, 774778414, 538976288,
     * 538976288, 538976544,1231971951,        -3,        -2, 542402665,
     *1931506789,1936990322,1701867378,1953701999,1847615776,1936682102,
     *1701737504,1633903461,1936943458,1818566774,1869177888,1768824948,
     *1751457907,1953658211,1953854053, 740324463,1864395873,1919378720,
     *        -3, 544174624,1953460000,1953066341, 543387502,1937075561,
     *1852252262,1869750388,1751457891,1970434661,1853104208,1279349839,
     *1310750309,1920166255,1847617135,1914724640,1836020325, 543450484,
     *1634298981,1679826976,        -3, 543256161,1819898729,1931501939,
     * 544235890,1948282726, 544499813, 544629100,1768186228,1768910368,
     *1920298542, 542471013, 544499813, 542330700,1444966256,1953066862,
     * 543584114, 544042866,1696621669,1952541036,1932402720, 542340451,
     *1746952480,2002874990,1768843040,1835624296,1948279148,1936662633,
     *1852074339,1635018016,1952997748, 544499813, 544438637,1835365490,
     *2032167283, 543780451,1869443180,1702126880,        -3, 543501927,
     * 773878632,1869966436, 543711606,1696621157,1701716083,1885692777,
     *1718183268, 543257376,1345138976,1634624544,1852797984,1345399840,
     *1818583414,1768843040,1869968416,1751215206, 544171552,        -3,
     * 544499813, 544566889,1948279653,1819025507,1869509733,1853107744,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1802072176,1701060694,1330201632,1415934836, 543780384,1667330917,
     * 544171552,1936029285,1919230052,1769172850,1684369952,        -3,
     *1597386807, 538976288, 807411744, 540024864, 538980384, 874529056,
     * 538980384, 807415840, 824188960,        -3,1448036676, 542401907,
     *1948275563,1768976485,1679836277,1696625775, 542336374,1701995808,
     *1147761519,1919182194, 539897390, 774778414, 538976288, 538976288,
     * 538976544,1231971951,        -3,        -2, 542535529,1679848549,
     *1936990291,1802072176,1701064224,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750388,1869553773,1634629920,1635020653,
     *1931503215,1914716484,1146313037, 544499059,1948279155, 544235890,
     *1948282726, 543385701,1667973961,1176510496,        -3,1597386808,
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1094992979,1498226772,1702065184,
     *1399548272,1885692960, 676622191, 542402925,1697473391,1853060461,
     *1768843049, 539897390, 774778414, 538976288, 538976288, 538976544,
     *1231971951,        -3,        -2, 542402661, 541148228,1398361376,
     *1952805748, 543781664,1936419184,1885692960,1634934896,1634890784,
     *1868963956,1751457891,1751475051,1128875552,1920298528,2003330414,
     * 544499813, 544438637,1835365490,2032148512,        -3, 543647086,
     *1701994868,1701060707,1701604384,1668247156,1701737504,1734702195,
     * 544501615, 543973746,1734680673,1852055668,1751457891,1634493301,
     *1818326121,1869488244,1869553780,1768776992,1668247155,1768778094,
     *1731076128, 542402661, 543383916,1668639841,1953066862, 543383918,
     * 544437353,1819025506,1696621679,1852121206,1767972980,1751457857,
     *1145328473,1293972591,1869357161,1847611468,1096044366, 773857312,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1835627379,1768843040,1397839173,1163543840,1869750349,1095977760,
     *1768842863,        -3,1597386809, 538976288, 807411744, 540024864/
     * )
      ICK( 37801: 38100) = (/
     * 538980384, 874529056, 538980384, 807415840, 824188960,        -3,
     *1397839173,1163543840,1869750349,1095977760,1231971951, 544041331,
     *1936289383, 740321129,1986358816,1094863182, 542270819,1869767712,
     * 538976288, 538976288, 538976544,1130915171,1797267488,        -3,
     *        -2, 542402661, 544240229,1936027235,1696624486, 543256096,
     *1094863182, 543780467,1953658211,1953066862, 543780384,1952998688,
     *1397245260,1481383982,1768846112,1718185061, 543780208,1818846579,
     * 544499813, 544568165,        -3, 544171552,1952998688,1347174740,
     *1330523987,1364542789,1514479727,1914720076,1163407919,1296126795,
     * 544501615,1814066287, 544498027,1696622958,1953439841,1667460981,
     *1853104244,1751457892,1769172850,1684370021,1679826976, 544436076,
     *1986358900, 543387502,1953655138,1970563439,1847620719, 544499813,
     * 543383916,1668639841,1952801824,1937011317,1668576626,1696622177,
     *1668575090,1932402772,1751457891,1869771365,1936748398,1684631143,
     *        -3, 544240239,1667589237,1919230052,1702125929,1819487264,
     *1734700645,1918989413,1679843961, 544499823,1936007280,1919903602,
     *1634562860, 543256688,1700885024,1953439842,1696620898,1936027252,
     * 543584879,1830842226,        -3, 543780451,1869771365,1668574329,
     * 544042852,1768319333,1679843699, 544235890,1948282726, 544499813,
     * 541280582, 543518050,1701078117,1679828782,1717658151, 543582572,
     *1697521696,        -3,        -1, 589315646,1042305637,1886351988,
     * 544499813, 544568165, 544171552,1952998688,1397245260,1481387859,
     *1463899168,1768846196,1920295796,1768910368,        -3,1597388080,
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1398227284, 541683315,1953658211,
     *1953066862, 542471013,1679848559, 541945700,1701584979,1869379173,
     *1853104196,1769172850,1684369952, 538976288, 538976288, 538976544,
     *1382379631,1920213024,        -3,        -2, 542402665,1931506789,
     *1936990322,1701867378,1953702004,1751457909,1936007279,1713402984,
     *1696617288,1162631244, 793990977,1411410286,1937011317,1668573551,
     *1847617135,1914729576,1696623983,1684368492,1768843040,        -3,
     * 544171552,1952998688,1684632431,1919182194,1701060723,1869379173,
     *1853104227,1869509746,1768060276,1768910368,1953439860,1751457891,
     *1634493301,1818326117,1679848308,1920295796,1970431264,1717658484,
     *1869771566,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1633970529,1953066862, 544504176,1696625520,1701013862,
     *1768120692,1768910368,        -3,1597388336, 538976288, 807411744,
     * 540024864, 538980384, 824197408, 538980640, 807415840, 807411744,
     *        -3,1315905622,1634494820, 543122537,1717989998,1601331556,
     *1767994473,1869504372,2037409056,1449225333,1696617061,1886351988,
     *1701060654, 538976288, 542141541,1634952480,1148133409,        -3,
     *        -2, 541423713,1836084325,1931505510, 543520880,1701016677,
     *1679849057,1819633011, 543257189, 539446639,1264658220, 539456377,
     *1852008562,1869902447,1848060960, 661546357,1953656686, 657203239,
     *1701602659,1953656686, 656416800,        -1, 589315646,1042301800,
     *1701014304,1718579744,1112293710,1260417637,1668248164,1931503982,
     * 543518050,1701078117,1679845483,1814062697,1818566688,        -3,
     *1597389111, 538976288, 807411744, 540024864, 538980384, 824197408,
     * 538980640, 807415840, 807411744,        -3,1316318562,1701978223,
     *1713390188,1634626336,1382376303,1919185696,1768824899,1229332581/
     * )
      ICK( 38101: 38400) = (/
     *1835165028,1684366368,1751870496,1181314149, 539248928,1130915171,
     *1797267488,        -3,        -2, 541139054,1970102885,1914728294,
     * 543321185,1852514418,1701015410,1685266537,1853121906,1936745842,
     *1936024608,1768824948,1751457859,1229332581,1835165028,1684366368,
     *1751870496,1718185061, 543711606,1696621157,1701716000, 544367981,
     *1870030180, 773857312,        -3,        -1, 589315646,1042301800,
     *1701014304,1718579744,1601398885,1819828073,1852009589,1684365158,
     *1768711519,1667786083,1802728813,        -3,1597389112, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980640, 807415840,
     * 807411744,        -3, 608264051,1751477368,1600745059,1819632741,
     *1600547180,1700750184,1701014387,1970085993,1847608137,1176514094,
     * 773857312, 538988652,1700885349, 541288549,1667964960,        -3,
     *        -2, 542402661, 544437616,1886153061,1679835977,1176527727,
     *1853120873,1853038689, 539451251,1751477368,1600745059,1819632741,
     *1600547180,1697063026,1701015410,1679843957,1948282479,1948279072,
     *1986096233,1679826976,        -3, 543257459,1868786017,1952801824,
     * 660566888,1701607519,1768842092,1969513823,1718185061,1600350309,
     *1667986293,1831280754,1701015410,1679847282, 544629100,1768169590,
     *1634497893, 774774816,        -3, 542402665,1931503982,1668052324,
     *1696622185,1818566761,1931502433,1819043172, 543584879,1830829171,
     *1751477368,1043229038,1931501934,1679845747, 544105829,1684366368,
     *1718579744,1952998688,1919247977,1852140901,1853104160, 543256164,
     * 544367917,1668441441,1953066862, 544171552,1952998688,1634956143,
     *1667850612,1701060654,1717790240,1718185061, 539522419,1701060710,
     *1869750369, 543450484,1634298981,1679843694,1634498931,1769152623,
     *1713381408, 544499813, 544367974,1768842605,1701737504,1919251317,
     *1819552046, 542402661, 543383916,1668639841,1952801824,1634624544,
     *1919250543,1920230756, 543385701,1667986293,1836261491,1752135020,
     *1679843941,        -3, 543777893,1853122915,1634479648,1332636793,
     * 543385697,1918985076,1701999392,2003399784, 543256096,1095975753,
     *1226864225,1819632928,1751738216,1701978228,1751215648, 858923107,
     *1869509746,1768060276,1696625775,        -3, 544499813, 543385701,
     *1667986293,1831739424,1097736293,1835165028,1684366368,1768842092,
     *1969513760,1718185061, 544041319,1752440930,1696621170,1869309294,
     * 740320617,1952998770, 543454565, 544501536,        -3, 544502369,
     *1853056613,1914725746,1919906419, 544174624,1953439844,1701603682,
     *1701994868,1696624498, 543253347,1768187246,1952541728,1886352244,
     * 762471782,1768842605,1701737504,1701079412,1768843040,1868963945,
     *1953701920, 543387502,1952804468, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750367,1702391924,1818190706,
     *2037609569,1818190949,1935897193,1886677359,1847621217,1819632928,
     *        -3,1597389113, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980640, 807415840, 807411744,        -3,1298756467,
     *1768843040,1600485488,1953259363,1920562036,1634492260,1702060914,
     *1768977513,1869488214,1634497893, 539897390, 774778414, 538976288,
     * 542141541,1634952480,1148133409,        -3,        -2, 541423713,
     *1836084325,1931505510, 543520880,1701016677,1679849057,1819633011,
     * 543257189, 539452012,1868786471, 740304750,1701143660,1697066016,
     * 661679201,1952786220, 539456368,1751478885, 657203232,        -3,
     * 539452281,1818848868,1701979950, 541683232,1667330917, 544171552/
     * )
      ICK( 38401: 38700) = (/
     * 660830572,1768842341,1915166831,1914709875,1885889906,1697063009,
     *1819504416,1886547830,1768187168,1629517409,1819632928,1718579744,
     *        -3, 539451237,2020635756,1600352889,1937006956,1601399162,
     *1700754017,1680289312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750371,1869509481,1937007982,1668882543,1713398383,
     *1852076832,1634624544,1668247410,1684631137,1952805664,1768824899,
     *1229332512,        -3,1597452337, 538980654, 807411762, 774905888,
     * 858664992, 824197408, 538980384, 807415840, 824188960,        -3,
     *1114599012, 538976288,1130458211, 609758240,1382379556,1496064068,
     *1702243886, 539248160,1399416685,1629495328,        -3,        -2,
     * 541224814,1679844457,1937006958,1667592992,1734964837,1847617902,
     * 544499813, 541280582, 543257189, 543388271,1936928099,1751475051,
     *1701060727,1769236512,1668248178,1702064239,1852074350,1730158624,
     *        -3, 544629100,1969582880,1667329123,1970037108,1701060710,
     *1919905056,1952998688,1668247410,1684631137,1952805678, 538984812,
     *1701999731, 543257189, 544433524, 543257632, 824980000,1634624544,
     * 857756521,1735221536,        -3, 543450486,1767994473,1869488236,
     *1702258028,1932402720,        -3, 542011252,1698308164,1701208437,
     *1819549811, 779431463,1931501938,1696626035,1701060727,1751478885,
     * 544108320,1932424494, 543648118,1701716008,1697539886, 543584114,
     * 541273416, 690888777,1847617381,1852142177,1814831136, 543255660,
     * 543451494,1717924453,1852007795, 544434287,1970037792,1650794615,
     *1769236585,1847620712,1696620915,1936679785,1635018084, 544419445,
     * 773870445,1634495520,1684629094,1701995886,1667592992,1835104544,
     *        -3, 543257193,1936007270,1919905056,1919907182,1684631143,
     * 773871205,1920540780,1634887525, 543450486,1767994473,1869488168,
     *1869750394,1701998368,1684632436,1634624357, 689991279,1919770988,
     *1819877408,        -3, 543780452,1768120692,1696622958,1668248178,
     *1701016684,2032169840,1701013862,1768252448,1937337709,1702130297,
     * 544174181,1918989417,1869509408,1869488244,1751457889,1936944995,
     *1767994469,1679843700,1869443884,        -3, 544174624, 660829556,
     * 761359972, 762339699,1953066599, 656437094, 543780451,1869443169,
     *1953063532,1696613193,1176990510,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1668882543,
     *1713398126,1735157107, 543256164, 543387503,1919183214,1635018099,
     * 543780384,1128875552,        -3,1597452338, 538980654, 807411762,
     * 774905888, 858664992, 824197408, 538980384, 807415840, 824188960,
     *        -3,1097754476,1696604192,1130458211, 609758240,1382379556,
     *1496064068,1702243886, 539248160,1399416685,1629495328,        -3,
     *        -2, 541224814,1679835502,1735157107, 543648118,1701716073,
     *1847620712,1696613193,1176527218,1696621426,1869837101,1667786083,
     *1801806880,2003399784, 543387506,1919251312,1869505641,1852252278,
     *1634497893,1931485216,        -3, 543383916,1668639841,1952801824,
     *1718775661, 544499813, 543387503,1919183214,1635018099, 773857345,
     *1818587764,1931501938,1696625509,1948279156, 540093490, 543256164,
     * 540221523,1768385889,        -3, 543450486,1767994473,1869488236,
     *1702258028,1932402720,        -3, 541683232,1734700645,1918987308,
     * 543255660, 543451494,1717924453,1852007795, 544434287,1970037792,
     *1650794615,1769236585,1847620712,1696620915,1936679785,1635018084,
     * 544419445, 773870445,1634495520,        -3, 543451494,1717924453/
     * )
      ICK( 38701: 39000) = (/
     *1852007795, 544039289, 543257193,1936007270,1919905056,1919907182,
     *1684631143, 773871205,1920540780,1634887525, 543450486,1767994473,
     *1869509408,1852797549,1634495609, 543780452,1768120692,1696604192,
     * 543780451,1869771365,1668574329, 544436325,1667851881,1701060723,
     *2037214565,1953659168,1869636978,1635019119,1853038703,1847620712,
     *1696620915,1936679785,1635018084, 543257711,1836264480,1869750304,
     *        -3, 539452277,1949131118,1680699489,1937009006,1730617455,
     *1713400174,1668246896,1635019106,1818566723,1229334387, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1869509481,1937007982,1668882543,1713402991,1920166255,1853038689,
     *1852055651,1869574756,1768841588,1702043753,1847608137,1176510496,
     *        -3,1597452339, 538980654, 807411762, 774905888, 858664992,
     * 824197408, 538980384, 807415840, 824188960,        -3,1416589939,
     *1768910368,1130458211, 609758240,1382379556,1496064068,1702243886,
     * 539248160,1399416685,1629495328,        -3,        -2, 542404466,
     *1936289646, 543256167,1818587936,1734964837,1847617902, 544499813,
     * 541280582, 543257189, 543388271,1936928099,1751475051,1701060727,
     *1769236512,1668248178,1702064239,1852074350,1730180705,1819633011,
     *        -3, 543383916,1668639841,1952801824,1718775661, 544499813,
     * 543387503,1919183214,1635018099, 773857345,1818587764,1931501938,
     *1696625509,1948279156, 540093490, 543256164, 540221523,1768385889,
     *        -3, 543450486,1767994473,1869488236,1702258028,1932402720,
     *        -3, 541683232,1734700645,1918987308, 543255660, 543451494,
     *1717924453,1852007795, 544434287,1970037792,1650794615,1769236585,
     *1847620712,1696620915,1936679785,1635018084, 544419445, 773870445,
     *1634495520,        -3, 543451494,1717924453,1852007795, 544039289,
     * 543257193,1936007270,1919905056,1919907182,1684631143, 773871205,
     *1920540780,1634887525, 543450486,1767994473,1869509408,1852797549,
     *1634495609, 543780452,1768120692,1696604192, 543780451,1869771365,
     *1668574329, 544436325,1667851881,1701060723,2037214565,1953659168,
     *1869636978,1635019119,1853038703,1847620712,1696620915,1936679785,
     *1635018084, 543257711,1836264480,1869750304,        -3, 539452277,
     *1949131118,1680699489,1937009006,1730617455,1713400174,1668246896,
     *1635019106,1818566723,1229334387, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713398639,1853120867,1948279913,1937006958,1667592992,
     *1634624544,1668247410,1684631137,1952805664,1768824899,1229332512,
     *        -3,1597452340, 538980654, 807411762, 774905888, 858664992,
     * 824197408, 538980384, 807415840, 824188960,        -3,1131376244,
     *1633907744,1130458211, 609758240,1382379556,1496064068,1702243886,
     * 539248160,1399416685,1629495328,        -3,        -2, 541683316,
     *1701997935,1818583925,1818325536,1668247156,1633907827, 543975795,
     *1952801824,1768824948,1751457859,1229332577,1919230051,1751475051,
     *1701060705,1734437230,1936990324,1751457891,1869574756,1768841588,
     *1702043680, 543780384,1952998688,1128875566, 538984812,1701999731,
     * 543257189, 544433524, 543257632, 824980000,1634624544, 857756521,
     *1735221536,1684371049,1635019119,1847618661,1986358387, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1869509481,1937007982,1668882543,1713391661,1651469924, 541338952,
     * 543451507,1952542307,1702043745,1852055651,1869574756,1768841588/
     * )
      ICK( 39001: 39300) = (/
     *1702043753,1847608137,1176510496,        -3,1597452341, 538980654,
     * 807411762, 774905888, 858664992, 824197408, 538980384, 807415840,
     * 824188960,        -3,1143818272, 538976288,1130458211, 609758240,
     *1382379556,1496064068,1702243886, 539248160,1399416685,1629495328,
     *        -3,        -2, 541620580,1919903589,1848459887,1852055620,
     * 759701612,1769174117,1679845742, 544499813, 541280582, 543781664,
     *1667786083,1801806894, 541158501,1920234272,1634886944,1936028704,
     *1635000352,        -3, 540093490, 543256164, 540221523,1768385889,
     * 543450486,1767994473,1869488236,1702258028,1932402720,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750371,1869509481,
     *1937007982,1668882543,1713391661,1651469924, 541601326,1092641897,
     *1937006958,1667592992,1634624544,1668247410,1684631137,1952805664,
     *1768824899,1229332512,        -3,1597452342, 538980654, 807411762,
     * 774905888, 858664992, 824197408, 538980384, 807415840, 824188960,
     *        -3,1210986030,1092624416,1130458211, 609758240,1382379556,
     *1496064068,1702243886, 539248160,1399416685,1629495328,        -3,
     *        -2, 541620580,1919903589,1848459887,1852055624, 774783264,
     *1818850164,1701060713,1847620712,1696613193,1176529267, 543385701,
     *1667982692, 773865836,1701999731, 543257189, 544433524, 543257632,
     * 824980000,1634624544,        -3, 540221523,1768385889, 543450486,
     *1767994473,1869488236,1702258028,1932402720,        -3,        -2,
     * 542402665,1931493708,1163023392,1769152615,1701733746,1634495609,
     * 544367980,1635018084, 544501536,1768842095,1920099683,1948283769,
     *1835885940,1920540771,1868850547, 773870696,1696625529,1835885940,
     *1920540704,        -3, 544109933,1650815520,1931503982, 544499813,
     * 544438637,1835365490,2032165743,1684349043,1601204594, 544434287,
     *1970037792,1668248178,1702064239,1852055668,1864397928,1696621944,
     *1886545267,1936289646,        -3, 543584114, 544415849,1847620712,
     *1696613193,1177428052,1752134501, 543520880,1919251315,1768910451,
     * 543383918, 543319328,1684629094,1701995886,1948280431,1914725481,
     *1717986674,1701737504,        -3, 544436070,1953980786,1696624737,
     *1667981671,1702047264,1160668974, 544235891,1953066599, 541601122,
     *1869505568,1952539244,1696621665,1952522343,1701733746,1635018084,
     * 544696692,1746948172,1096044366,        -3, 543780468,1864392992,
     *1128875552,1734700645,1918989413,1679849321,1952981075,1212501080,
     *1277193569,2032169569,1769170208,1952999795, 541150277,1381248544,
     *1298230901,1634476131,1869771365,1668573551,1847599136,        -3,
     * 544171552,1952998688,1937337709,1702130297, 543387492,1696625512,
     *1869966436, 543319328,1953655158,1767992366,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713391661,1651469924, 541339182,1092641897,1937006958,
     *1667592992,1634624544,1668247410,1684631137,1952805664,1768824899,
     *1229332512,        -3,1597452343, 538980654, 807411762, 774905888,
     * 858664992, 824197408, 538980384, 807415840, 824188960,        -3,
     *1143877166,1092624416,1130458211, 609758240,1382379556,1496064068,
     *1702243886, 539248160,1399416685,1629495328,        -3,        -2,
     * 541620580,1919903589,1848459887,1852055620, 774783264,1818850164,
     *1701060713,1847620712,1696613193,1176529267, 543385701,1667982692,
     * 773865836,1701999731, 543257189, 544433524, 543257632, 824980000,
     *1634624544,        -3, 540221523,1768385889, 543450486,1767994473/
     * )
      ICK( 39301: 39600) = (/
     *1869488236,1702258028,1932402720,        -3,        -2, 542402665,
     *1931493708,1163023392,1769152615,1701733746,1634495609, 544367980,
     *1635018084, 544501536,1768842095,1920099683,1948283769,1835885940,
     *1920540771,1868850547, 773870696,1696625529,1835885940,1920540704,
     *        -3, 544109933,1650815520,1931503982, 544499813, 544438637,
     *1835365490,2032165743,1684349043,1601204594, 544434287,1970037792,
     *1668248178,1702064239,1852055668,1864397928,1696621944,1886545267,
     *1936289646,        -3, 543584114, 544415849,1847620712,1696613193,
     *1177428052,1752134501, 543520880,1919251315,1768910451, 543383918,
     * 543319328,1684629094,1701995886,1948280431,1914725481,1717986674,
     *1701737504,        -3, 544436070,1953980786,1696624737,1667981671,
     *1702047264,1160668974, 544235891,1953066599, 541601122,1869505568,
     *1952539244,1696621665,1952522343,1701733746,1635018084, 544696692,
     *1746948172,1096044366,        -3, 543780468,1864392992,1128875552,
     *1734700645,1918989413,1679849321,1952981075,1212501080,1277193569,
     *2032169569,1769170208,1952999795, 541150277,1381248544,1298230901,
     *1634476131,1869771365,1668573551,1847599136,        -3, 544171552,
     *1952998688,1937337709,1702130297, 543387492,1696625512,1869966436,
     * 543319328,1953655158,1767992366,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1668882543,
     *1713391661,1651469924, 541338952, 774783264,1634625388,1702043745,
     *1852055651,1869574756,1768841588,1702043753,1847608137,1176510496,
     *        -3,1597452344, 538980654, 807411762, 774905888, 858664992,
     * 824197408, 538980384, 807415840, 824188960,        -3,1143818286,
     * 776020000,1130458211, 609758240,1382379556,1496064068,1702243886,
     * 539248160,1399416685,1629495328,        -3,        -2, 541620580,
     *1919903589,1848459887,1852055617,1852271717, 541338952, 774783264,
     *1818850164,1701060713,1847620712,1696613193,1176529267, 543385701,
     *1667982692, 773865836,1701999731, 543257189, 544433524, 543257632,
     *        -3, 540093490, 543256164, 540221523,1768385889, 543450486,
     *1767994473,1869488236,1702258028,1932402720,        -3,        -2,
     * 542402665,1931493708,1163023392,1769152615,1701733746,1634495609,
     * 544367980,1635018084, 544501536,1768842095,1920099683,1948283769,
     *1835885940,1920540771,1868850547, 773870696,1696625529,1835885940,
     *1920540704,        -3, 544109933,1650815520,1931503982, 544499813,
     * 544438637,1835365490,2032165743,1684349043,1601204594, 544434287,
     *1970037792,1668248178,1702064239,1852055668,1864397928,1696621944,
     *1886545267,1936289646,        -3, 543584114, 544415849,1847620712,
     *1696613193,1177428052,1752134501, 543520880,1919251315,1768910451,
     * 543383918, 543319328,1684629094,1701995886,1948280431,1914725481,
     *1717986674,1701737504,        -3, 544436070,1953980786,1696624737,
     *1667981671,1702047264,1160668974, 544235891,1953066599, 541601122,
     *1869505568,1952539244,1696621665,1952522343,1701733746,1635018084,
     * 544696692,1746948172,1096044366,        -3, 543780468,1864392992,
     *1128875552,1734700645,1918989413,1679849321,1952981075,1212501080,
     *1277193569,2032169569,1769170208,1952999795, 541150277,1381248544,
     *1298230901,1634476131,1869771365,1668573551,1847599136,        -3,
     * 544171552,1952998688,1937337709,1702130297, 543387492,1696625512,
     *1869966436, 543319328,1953655158,1767992366,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750381,1700884073,1852271717/
     * )
      ICK( 39601: 39900) = (/
     *1936924711,1818848869,1634871072,1953460851,1768910368,1634625388,
     *1702043753,1847620712,1696613193,1176510496,        -3,1597452592,
     * 538976288, 807411744, 540024864, 538980384, 874531104, 538980384,
     * 807415840, 824188960,        -3,1147497573,1952784433, 758263091,
     * 544174624, 841823021, 874531945,1852137842, 542404466,1936289646,
     * 541159015,1818566702, 774774819, 538977345, 541355808, 555753504,
     *        -3,        -2, 542404466,1936289646, 543256167,1818587936,
     *1936745827,1768319333,1679845742, 544499813, 541280582, 543257189,
     * 543385701,1667982692, 543584114, 544499813,        -3, 539454569,
     *1852137842, 544629106,1768256633, 656439144,1701995808,1869505824,
     *1869750370,1869899808,1868963956,1751457841, 758263091, 543256164,
     * 540159283, 758390882,1869505568,        -3, 543256167,1818587936,
     *1634886944,1668050803,1696625775, 540096560, 541353319, 773870408,
     *1162631244, 959914103,1768713248,1734700645,1918989413, 544499823,
     *1936007207,1953460851,1768910451, 656434799,1914708000,        -3,
     * 544042860,1701016940,1702043747,1869509729,1768843630,1730178153,
     *1852137842, 544042857,1702127973,1931487301, 778513952,1298494561,
     *1814905661,1328098848,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750380,1633838444, 544240239,1651271021,1931503215,
     *1914724975,1852076832,1768824948,1751457859,1229332512,        -3,
     *1597452593, 538976288, 807411744, 960045088, 540621088, 824197408,
     * 538980384, 807415840, 824188960,        -3,1112493636, 538976288,
     *1433299822,1870097952,1869750345,1852010350,1936290676,1701737504,
     *1281450597,1814048302, 774778414, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 542599269,1847618657,1650814067,
     * 543257189, 543584117,1852055663,1847617381,1869440372,1920540777,
     *1952804211, 539517551,1852076844, 543256167,1818587936,1702126382,
     * 689992808,1635000417,1919230062,1869881449,1847599136, 544499813,
     * 543387503,1919183214,1635018016,1818850164, 740319598,1679835468,
     *1163023392,1597452654, 543781664,1769173877,1701063712,1919249505,
     *1952801824,1953439809,1279611476, 543110960,1848516640,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750380,1633838444,
     * 544240239,1651271021, 543584114, 543256167,1818587936,1768824899,
     *1229332512,        -3,1597452594, 538976288, 807411744, 960045088,
     * 540621088, 824197408, 538980384, 807415840, 824188960,        -3,
     *1095649100,1159733280,1433299822,1870097952,1869750345,1852010350,
     *1936290676,1701737504,1281450597,1814048302, 774778414, 774778414,
     * 538977345, 541288549,1667964960,        -3,        -2, 542599269,
     *1847618657,1650814067, 543257189, 543584117,1852055663,1847617381,
     *1869440372,1920540777,1952804211, 539517551,1852076844, 543256167,
     *1818587936,1702126382, 689992808,1635000417,1919230062,1869881449,
     *1847599136, 544499813, 543387503,1919183214,1635018016,1818850164,
     * 740319598,1679835468,1163023392,1597452654, 543781664,1769173877,
     *1701063712,1919249505,1952801824,1953439809,1279611476, 543110960,
     *1848516640,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750380,1633838444, 544240239,1651271021, 543584114, 544501618,
     *1936289646,1931503982, 544499813, 541280582,        -3,1597452595,
     * 538976288, 807411744, 960045088, 540621088, 824197408, 538980384,
     * 807415840, 824188960,        -3,1414484563,1229934112,1433299822,
     *1870097952,1869750345,1852010350,1936290676,1701737504,1281450597/
     * )
      ICK( 39901: 40200) = (/
     *1814048302, 774778414, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 542599269,1847618657,1650814067, 543257189,
     * 543584117,1852055663,1847617381,1869440372,1920540777,1952804211,
     * 539517551,1852076844, 543256167,1818587936,1702126382, 689992808,
     *1635000417,1919230062,1869881449,1847599136, 544499813, 543387503,
     *1919183214,1635018016,1818850164, 740319598,1679835468,1163023392,
     *1597452654, 543781664,1769173877,1701063712,1919249505,1952801824,
     *1953439809,1279611476, 543110960,1848516640,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750380,1633838444, 544240239,
     *1651271021, 543584114, 543387502,1952539508, 543451507,1952542307,
     *1702043753,1847620712,1696613193,1176510496,        -3,1597452596,
     * 538976288, 807411744, 960045088, 540621088, 824197408, 538980384,
     * 807415840, 824188960,        -3,1129270868,1094931488,1433299822,
     *1870097952,1869750345,1852010350,1936290676,1701737504,1281450597,
     *1814048302, 774778414, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 542599269,1847618657,1650814067, 543257189,
     * 543584117,1852055663,1847617381,1869440372,1920540777,1952804211,
     * 539517551,1852076844, 543256167,1818587936,1702126382, 689992808,
     *1635000417,1919230062,1869881449,1847599136, 544499813, 543387503,
     *1919183214,1635018016,1818850164, 740319598,1679835468,1163023392,
     *1597452654, 543781664,1769173877,1701063712,1919249505,1952801824,
     *1953439809,1279611476, 543110960,1848516640,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750380,1633838444, 544240239,
     *1651271021, 543584114, 541601122,1869505568,1143818272,1684632436,
     *1634624357,1931503982, 544499813, 541280582,        -3,1597452597,
     * 538976288, 807411744, 960045088, 540621088, 824197408, 538980384,
     * 807415840, 824188960,        -3,1143818272, 538976288,1433299822,
     *1870097952,1869750345,1852010350,1936290676,1701737504,1281450597,
     *1814048302, 774778414, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 542599269,1847618657,1650814067, 543257189,
     * 543584117,1852055663,1847617381,1869440372,1920540777,1952804211,
     * 539517551,1852076844, 543256167,1818587936,1702126382, 689992808,
     *1635000417,1919230062,1869881449,1847599136, 544499813, 543387503,
     *1919183214,1635018016,1818850164, 740319598,1679835468,1163023392,
     *1597452654, 543781664,1769173877,1701063712,1919249505,1952801824,
     *1953439809,1279611476, 543110960,1848516640,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750380,1633838444, 544240239,
     *1651271021, 543584114, 541601122,1869505568,1210986049, 543451507,
     *1952542307,1702043753,1847620712,1696613193,1176510496,        -3,
     *1597452598, 538976288, 807411744, 960045088, 540621088, 824197408,
     * 538980384, 807415840, 824188960,        -3,1210986030,1092624416,
     *1433299822,1870097952,1869750345,1852010350,1936290676,1701737504,
     *1281450597,1814048302, 774778414, 774778414, 538977345, 541288549,
     *1667964960,        -3,        -2, 542599269,1847618657,1650814067,
     * 543257189, 543584117,1852055663,1847617381,1869440372,1920540777,
     *1952804211, 539517551,1852076844, 543256167,1818587936,1702126382,
     * 689992808,1635000417,1919230062,1869881449,1847599136, 544499813,
     * 543387503,1919183214,1635018016,1818850164, 740319598,1679835468,
     *1163023392,1597452654, 543781664,1769173877,1701063712,1919249505,
     *1952801824,1953439809,1279611476, 543110960,1848516640,        -3/
     * )
      ICK( 40201: 40500) = (/
     *        -1, 589315646,1042306149,1936990310,1869750380,1633838444,
     * 544240239,1651271021, 543584114, 538986541,1651469924, 541339182,
     *1092641897,1937006958,1667592992,1768824948,1751457859,1229332512,
     *        -3,1597452599, 538976288, 807411744, 960045088, 540621088,
     * 824197408, 538980384, 807415840, 824188960,        -3,1143877166,
     *1092624416,1433299822,1870097952,1869750345,1852010350,1936290676,
     *1701737504,1281450597,1814048302, 774778414, 774778414, 538977345,
     * 541288549,1667964960,        -3,        -2, 542599269,1847618657,
     *1650814067, 543257189, 543584117,1852055663,1847617381,1869440372,
     *1920540777,1952804211, 539517551,1852076844, 543256167,1818587936,
     *1702126382, 689992808,1635000417,1919230062,1869881449,1847599136,
     * 544499813, 543387503,1919183214,1635018016,1818850164, 740319598,
     *1679843692,1701999648,1597452654, 543781664,1769173877,1701063712,
     *1919249505,1952801824,1953439841,1818587764, 543110960,1848516640,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750380,
     *1633838444, 544240239,1651271021, 543584114, 541601122,1869505568,
     *1143818286, 776020065,1852271717,1931503982, 544499813, 541280582,
     *        -3,1597452600, 538976288, 807411744, 960045088, 540621088,
     * 824197408, 538980384, 807415840, 824188960,        -3,1143818286,
     * 776020000,1433299822,1870097952,1869750345,1852010350,1936290676,
     *1701737504,1281450597,1814048302, 774778414, 774778414, 538977345,
     * 541288549,1667964960,        -3,        -2, 542599269,1847618657,
     *1650814067, 543257189, 543584117,1852055663,1847617381,1869440372,
     *1920540777,1952804211, 539517551,1852076844, 543256167,1818587936,
     *1702126382, 689992808,1635000417,1919230062,1869881449,1847599136,
     * 544499813, 543387503,1919183214,1635018016,1818850164, 740319598,
     *1679835468,1163023392,1597452654, 543781664,1769173877,1701063712,
     *1919249505,1952801824,1953439809,1279611476, 543110960,1848516640,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750389,
     *1853191029,1634476129,1852055662,1869509492,1634624609,1919164524,
     *1633838444,1931485216,        -3,1597452848, 538976288, 807411744,
     * 540155936, 538980896, 874531104, 538980384, 807415840, 824188960,
     *        -3,1316318562,1701978223,1713395054,1970500961,1815039599,
     *1848464244,1634624609,1919164492,1633838444,1931488814, 774778414,
     * 774778414, 539248928,1315927141,        -3,        -2, 542470176,
     *1953439796, 541288545,1918985076,1701978188,1633838444,1931505510,
     * 544499813, 544504176,1696613169, 824975432, 825241900, 541995312,
     *1093410921, 778382880,1667786093,1768120684, 544438637,1651469344,
     * 723525664, 544109933,1650815520, 723545968,1953066862,1634476140,
     *1702130789,1914724722,1696625775, 543319328,1886545254,1701999205,
     *1680744480,        -3, 542011252,1698308179,1212501080,1277190753,
     *1936024608,1919247977,1852140901,1853125408,1835104544,1970496800,
     *1818321509,1819484277,1881175151, 540483683,1751216737,1668572530,
     *1931487305,1852009589,1684631143,        -3, 544367987,1768191333,
     * 543256164, 544174624,1684632431,1919182194, 543780454,1869770081,
     *1953066862, 690888736,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750371,1869509481,1937007982,1668882543,1713398383,
     *1852076832,1634624544,1668247410,1684631137,1952805664,1768824948,
     *1751457859,1229332512,        -3,1597452849, 538980654, 807411762,
     * 774905888, 858664992, 824197408, 538980384, 807415840, 824188960/
     * )
      ICK( 40501: 40800) = (/
     *        -3,1114599012, 538976288,1130458211, 609758240,1382379556,
     *1495286885,1982737966, 539248160,1097754414,        -3,        -2,
     * 542335341,1696620915, 540487729, 543323508, 543584114, 543451507,
     *1952542307,1696626537,1953001333,1948283694,1965957160,1702061097,
     * 773866601,1717986674,1701733221, 543781664,1952805748,1701060713,
     *1847599136,        -3, 544499058,1836261487,1713389934,1735619698,
     *1869443886,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750371,1869509481,1937007982,1668882543,1713398126,1735157107,
     * 543256164, 543387503,1919183214,1635018099, 543780384,1952998688,
     *1128875552,        -3,1597452850, 538980654, 807411762, 774905888,
     * 858664992, 824197408, 538980384, 807415840, 824188960,        -3,
     *1097754476,1696604192,1130458211, 609758240,1382379556,1495286885,
     *1982737966, 539248160,1147496306,1701126176,        -3,        -2,
     * 542335341,1696620915, 540487730, 543323508, 543584114, 543256167,
     *1818566775,1769236591,1970544755, 779431456, 677737316, 690888772,
     *1768318565,1919250019,1696622963, 544499059,1952801824,1768824948,
     *1701997939,        -3, 544171552,1147496306,1701147438,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750371,1869509481,
     *1937007982,1668882543,1713402991,1920166255,1853038689,1852055651,
     *1869574756,1768841588,1702043753,1847620712,1696613193,1176510496,
     *        -3,1597452851, 538980654, 807418169, 959324217, 960048672,
     * 824197408, 538980384, 807415840, 824188960,        -3,1416589939,
     *1768910368,1130458211, 609758240,1382379556,1495286885,1982737966,
     * 539248160,1399416685,1629495328,        -3,        -2, 542335341,
     *1696620915, 540487731, 543323508, 543584114, 544501618,1936289646,
     * 544696692,1752135028, 544419445, 773859429,1935943982, 541354342,
     *1717924453,1852007712,1769152628,1702065253,1679845742, 544499058,
     *1836261408, 544171552,1147496306,1701147438,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713398639,1853120867,1948279913,1937006958,1667592992,
     *1634624544,1668247410,1684631137,1952805664,1768824948,1751457859,
     *1229332512,        -3,1597452852, 538980654, 807411762, 774905888,
     * 858664992, 840974624, 538980384, 807415840, 824188960,        -3,
     *1131376244,1633907744,1130458211, 609758240,1382379556,1495286885,
     *1982737966, 539248160,1097754414,        -3,        -2, 542335341,
     *1696620915, 540487732, 740319861,1948280431,1914725481,1937006958,
     *1667571831,1769236591,1970544755, 779431456, 677737316, 690888772,
     *1768318565,1919250019,1696622963, 544499059,1952801824,1768824864,
     *        -3, 544499058,1836261487,1713389934,1735619698,1869443886,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1869509481,1937007982,1668882543,1713391661,1651469924, 541338952,
     * 543451507,1952542307,1702043745,1852055619,1869574756,1768841588,
     *1702043753,1847620712,1696613193,1176510496,1597452853, 538980654,
     * 807411762, 774905888, 858664992, 840974624, 538980384, 807415840,
     * 824188960,        -3,1143818272, 538976288,1130458211, 609758240,
     *1382379556,1495286885,1982737966, 539248160,1097754414,        -3,
     *        -2, 542335341,1696620915, 540487733, 543323508, 543584114,
     * 543451507,1952542307,1696626537,1953001333,1948283694,1965957160,
     *1702061097, 773866601,1717986674,1701733221,1931501938,1696625765,
     *1937007972, 543780384,        -3, 544499058,1836261487,1713389934/
     * )
      ICK( 40801: 41100) = (/
     *1735619698,1869426208,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750371,1869509481,1937007982,1668882543,1713391661,
     *1651469924, 541601326,1092641897,1937006958,1667592992,1634624544,
     *1668247410,1684631137,1952805664,1768824948,1751457859,1229332512,
     *1597452854, 538980654, 807411762, 774905888, 858664992, 840974624,
     * 538980384, 807415840, 824188960,        -3,1210986030,1092624416,
     *1130458211, 609758240,1382379556,1495286885,1982737966, 539248160,
     *1097754414,        -3,        -2, 542335341,1696620915, 540487734,
     * 543323508, 543584114, 543451507,1952542307,1696626537,1953001333,
     *1948283694,1965957160,1702061097, 773866601,1717986674,1701733221,
     *1931501938,1696625765,1937007972, 543780384,        -3, 544499058,
     *1836261487,1713389934,1735619698,1869426208,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713391661,1651469924, 541339182,1092641897,1937006958,
     *1667592992,1634624544,1668247410,1684631137,1952805664,1768824948,
     *1751457859,1229332512,1597452855, 538980654, 807411762, 774905888,
     * 858664992, 824197408, 538980384, 807415840, 824188960,        -3,
     *1143877166,1092624416,1130458211, 609758240,1382379556,1495286885,
     *1982737966, 539248160,1097754414,        -3,        -2, 542335341,
     *1696620915, 540487735, 543323508, 543584114, 543451507,1952542307,
     *1696626537,1953001333,1948283694,1965957160,1702061097, 773866601,
     *1717986674,1701733221,1931501938,1696625765,1937007972, 543780384,
     *        -3, 544499058,1836261487,1713389934,1735619698,1869426208,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1869509481,1937007982,1668882543,1713391661,1651469924, 541338952,
     * 774783264,1634625388,1702043745,1852055651,1869574756,1768841588,
     *1702043753,1847620712,1696613193,1176510496,1597452856, 538980654,
     * 807411762, 774905888, 858664992, 824197408, 538980384, 807415840,
     * 824188960,        -3,1143818286, 776020000,1130458211, 609758240,
     *1382379556,1495286885,1982737966, 539248160,1147496306,1701126176,
     *        -3,        -2, 542335341,1696620915, 541150277,1381244983,
     * 808984674,1970544742,1869750369,1852271717, 544696692,1752135028,
     * 544419445, 773859429,1935943982, 541354342,1717924453,1852007795,
     * 543257189, 544499059,1952801824,        -3, 543780384,1952805485,
     *1931505510, 541353319,1919247731, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713398383,1852055667, 779431463,1931501934,1679844207,
     *1869767785,1851880549, 544419445, 774337312,1768824948,1751457859,
     *1229332512,        -3,1597453105, 538981166, 807411766, 774905905,
     * 841887776, 824197408, 538980384, 807415840, 824188960,        -3,
     *1114599012, 538976288,1130458211, 609758240,1382379556,1495281198,
     * 774778414, 539248928,1937059154,1635000352,        -3,        -2,
     * 541139052,1634887525, 544366964,1768890479,1713402984,1696625253,
     *1886351988,1701060705,1852055651,1634493301,1818326117,1679843951,
     *1852055667, 779431463,1931503987, 543584117,1852059168,        -3,
     * 542402661, 544568165, 544171552,1629504582,1230512233,1853060210,
     *1969452137,1869488237,1768384628, 543383925,1936007283,1969448992,
     *1629517665,1919838574,1730179945,1852007712,        -3, 543383916,
     *1668639841,1952801824,1932424494, 661856353,1919230050,1634952548,
     * 544173600,1919250543,1920230756, 544629106,1767992931,1702043759/
     * )
      ICK( 41101: 41400) = (/
     *1852602670,        -3, 542011252,1700737338, 544419445, 774337312,
     *1869488244,1751457909,1852404781,1667591276, 543451501,1701737321,
     *1869509408,1634886944,1952541541,1847617902,1953439841,1667460981,
     *1853104233,1847620712,1696604192,        -3, 543383916,1668639841,
     *1953066862, 544171552,1702391909,1668572516, 544419445, 774337326,
     * 542402665,1931504993,2032169573,1937075316, 543780384,1818325607,
     *1696621673,1717986674,1701733221,1931485216,        -3, 543319412,
     *2003133806, 543520880,1701016677,1679843694,1679848037,1886351988,
     *1701060723, 779431463,1931507560,1701716084,1751741216,1668247156,
     *1919509109,1953066862, 543781664,1852797984,1768842092,1969513828,
     *        -3, 543780384,1952998688,1919250543,1920230756, 544419445,
     * 774337324, 543780384,1885434484,1768125804,1634869350,1869750377,
     *1851876195,1970430324,1696626030,1769221475,1701604467, 773857312,
     *        -3, 542011252,1700737594, 541159023,1952998770, 544436085,
     *1919116576,1718579744,1952998688,1684632419,1919250529,1852012832,
     *1650816119,1701146144,1667329123,1970037108,1701060705,1852055584,
     *        -3, 544367984,1869771877,1679848238,1965959027, 543383918,
     * 543319328,1952997748, 544499813, 544629100,1768186228,1768910368,
     *1936680564,2002874981, 543711603, 543253347,1702064928,1869507705,
     * 544501536,        -3, 544499813, 544629106,1767992931,1702043759,
     *1713402984,1696625253,1718185573,1679847521,1918987621,1952805491,
     * 543257376,1869639791,1936024608,1953439860,1751457894,1970039840,
     *1668230518,1634888033,1852007712,        -3, 544039284,1919514656,
     *1970496868, 543324448,1697539886, 542328901,1280855072,1718579744,
     *1952998688,1667329123,1970037108,1768910368,1868963940,1701996918,
     *1701060720,1634885997,1702126962,1931485216,        -3, 544696692,
     *1746952563,1936679785,1635018084, 544419445, 774337326, 541290350,
     *1937011297,1768842596, 796026227,1953653097,1852138528,1919247977,
     *1852140901,1853104237,1635328099,1635087205, 543973746,1734680608,
     *        -3, 543387437,1986097769,1634624357,1932402720,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750371,1869509481,
     *1937007982,1668882543,1713398126,1735157107, 543256164, 543387503,
     *1919183214,1635018099, 543780384,1128875552,1932424494, 661856288,
     *        -3,1597453106, 538980910, 807411764, 774905888, 942551072,
     * 824197408, 538980384, 807415840, 824188960,        -3,1097754476,
     *1696604192,1130458211, 609758240,1382379556,1495281198, 774778414,
     * 539248160,1932424494, 760373620,        -3,        -2, 541139052,
     *1634887525, 544366964,1768890479,1713402984,1696625253,1886351988,
     *1701060705,1852055651,1634493301,1818326117,1679843951,1852055649,
     *1852271717, 544419445, 774337312,1769152614,1869966948, 773857312,
     *        -3, 542402665,1931502440,1701014304,1936224117,1818501239,
     *1634889248,1718579744,1701999215,1852141429,1931506287,1970168937,
     *1852258848,1160668974, 540094517, 775235633, 958996596,1864380720,
     * 892220712, 841556079,1914708000, 540094517, 774907957, 689992815,
     * 540094517, 674572576,1702126382, 542011252,1698308172,1634887525,
     * 543451494,1717924453,1852007795, 543257189, 544239475,1936286316,
     *1696626536,1701716067,1701999713,1768824864,        -3, 543387502,
     *1937011297,1768846451, 796026227,1953653097,1853125408,2003137125,
     * 543256688,1818846564, 543780384,1952998688,1919247977,1852140901,
     *1853104168,1697539886, 544499813, 541477953,1411411824,1953066862/
     * )
      ICK( 41401: 41700) = (/
     *        -3, 543780384,1397245260,1481390391, 690888736,        -3,
     * 542011252,1700737338, 544419445, 774337312,1869488244,1751457909,
     *1852404781,1667591276, 543451501,1701737321,1869509408,1634886944,
     *1952541541,1847617902,1953439841,1667460981,1853104233,1847620712,
     *1696604192,        -3, 543383916,1668639841,1953066862, 544171552,
     *1702391909,1668572516, 544419445, 774337326, 542402665,1931504993,
     *2032169573,1937075316, 543780384,1818325607,1696621673,1717986674,
     *1701733221,1931485216,        -3, 543319412,2003133806, 543520880,
     *1701016677,1679843694,1679848037,1886351988,1701060723, 779431463,
     *1931507560,1701716084,1751741216,1668247156,1919509109,1953066862,
     * 543781664,1852797984,1768842092,1969513828,        -3, 543780384,
     *1952998688,1919250543,1920230756, 544419445, 774337324, 543780384,
     *1885434484,1768125804,1634869350,1869750377,1851876195,1970430324,
     *1696626030,1769221475,1701604467, 773857312,        -3, 542011252,
     *1700737594, 541159023,1952998770, 544436085,1919116576,1718579744,
     *1952998688,1684632419,1919250529,1852012832,1650816119,1701146144,
     *1667329123,1970037108,1701060705,1852055666,1701867378,1952801824,
     *        -3, 544419445, 774337312,1667329568,1650794612,1751217184,
     *1952998688,1986096233,1684108393,1869488243,1868985463,1634886944,
     *1751216928,1633903461,1936924783,1852602656,1953439860,1751457910,
     *1634888033,1852007795,        -3, 544171552,1952998688,1919247977,
     *1852138528,1885434465,1835365477,1920147553,1931505520,1886352229,
     *1679848559, 544499813, 543585644,1814061935, 762732914,1767992931,
     *1696623969,1953655160, 544568165,1679843961,        -3, 543501927,
     * 773870408,1162631244, 543584114, 544499813, 543383916,1668639841,
     *1953066862, 544171552,1684370025,1986356256,1885434465,1835365477,
     *1920147575,1769236512,1634956143,1667850612,1701060723, 779431463,
     *1932402720, 541290350,1937011297,1768842596, 796026227,1953653097,
     *1852138528,1919247977,1852140901,1853104237,1635328099,1635087205,
     * 543973746,1734680675,1865250401,1919508846,1667593006,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750371,1869509481,
     *1937007982,1668882543,1713402991,1920166255,1853038689,1852055651,
     *1869574756,1768841588,1702043753,1847608137,1176531758,1965519648,
     *        -3,1597453107, 538981422, 807411766, 774905888, 942551072,
     * 824197408, 538980384, 807415840, 824188960,        -3,1416589939,
     *1768910368,1130458211, 609758240,1382379556,1495281198, 774778414,
     * 539248160,1932424494, 760373620,        -3,        -2, 541139052,
     *1634887525, 544366964,1768890479,1713402984,1696625253,1886351988,
     *1701060705,1852055651,1634493301,1818326117,1679848559,1920166255,
     *1847615854,1735157024,1932424494, 661856361,1931503215,1970168878,
     *        -3, 542402665,1931502440,1701014304,1936224117,1818501239,
     *1634889248,1718579744,1701999215,1852141429,1931506287,1970168937,
     *1852258848,1160668974, 540094517, 775235633, 958996596,1864380720,
     * 892220712, 841556000,        -3, 544174624, 825242926, 807941417,
     * 544501536, 825242920, 891887717,1952656928,        -3, 542011252,
     *1700737338, 544419445, 774337312,1869488244,1751457909,1852404781,
     *1667591276, 543451501,1701737321,1869509408,1634886944,1952541541,
     *1847617902,1953439841,1667460981,1853104233,1847620712,1696604192,
     *        -3, 543383916,1668639841,1953066862, 544171552,1702391909,
     *1668572516, 544419445, 774337326, 542402665,1931504993,2032169573/
     * )
      ICK( 41701: 42000) = (/
     *1937075316, 543780384,1818325607,1696621673,1717986674,1701733221,
     *1931502181,1953981797,1847599136, 543520880,1701016677,1679843694,
     *1679848037,1886351988,1701060723, 779431463,1931507560,1701716084,
     *1751741216,1668247156,1919509109,1953066862, 543781664,1852797984,
     *1768842092,1969513828, 543780384,1952998688,        -3, 544367984,
     *1869771877,1679848238,1965959027, 740321646, 544235890,1953063797,
     *1818325536,1718579744,1768841571,1668641377,1952784501,1852404781,
     *1667591276,1932402720,        -3, 542011252,1700737594, 541159023,
     *1952998770, 544436085,1919116576,1718579744,1952998688,1684632419,
     *1919250529,1852012832,1650816119,1701146144,1667329123,1970037108,
     *1701060705,1852055666,1701867378,1952801824,        -3, 544419445,
     * 774337312,1667329568,1650794612,1751217184,1952998688,1986096233,
     *1684108393,1869488243,1868985463,1634886944,1751216928,1633903461,
     *1936924783,1852602656,1953439860,1751457910,1634888033,1852007795,
     *        -3, 544171552,1952998688,1919247977,1852138528,1885434465,
     *1835365477,1920147553,1931505520,1886352229,1679848559, 544499813,
     * 543585644,1814061935, 762732914,1767992931,1696623969,1953655160,
     * 544568165,1679843961,        -3, 543501927, 773870408,1162631244,
     * 543584114, 544499813, 543383916,1668639841,1953066862, 544171552,
     *1684370025,1986356256,1885434465,1835365477,1920147575,1769236512,
     *1634956143,1667850612,1701060723, 779431463,1932402720, 541290350,
     *1937011297,1768842596, 796026227,1953653097,1852138528,1919247977,
     *1852140901,1853104237,1635328099,1635087205, 543973746,1734680675,
     *1865250401,1919508846,1667593006,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1668882543,
     *1713398639,1853120867,1948279913,1937006958,1667571827, 779431456,
     *1634624544,1668247410,1684631137,1952784499, 779431456,1768824899,
     *1229332512,1597453108, 538980910, 807411764, 774905888, 942551072,
     * 824197408, 538980384, 807415840, 824188960,        -3,1131376244,
     *1633907744,1130458211, 609758240,1382379556,1495281198, 774778414,
     * 539248160,1932424494, 760373620,        -3,        -2, 541139052,
     *1634887525, 544366964,1768890479,1713402984,1696625253,1886351988,
     *1701060705,1852055651,1634493301,1818326117,1679844207,1853120867,
     *1948279913,1937006958,1667571827, 779431463,1931503987,        -3,
     * 543584117,1852059168,        -3, 542011252,1698308211, 779431463,
     *1931505518, 544499813, 544566889,1949131621,1819025508,1768777070,
     *1936289646,1931501938,1696625761,1801809440,1768846447, 543253347,
     *1869966964, 543780384,1952998688,        -3, 543383916,1668639841,
     *1953066862, 544171552,1702391909,1668572516, 544419445, 774337326,
     * 542402665,1931504993,2032169573,1937075316, 543780384,1818325607,
     *1696621673,1717986674,1701733221,1931485216,        -3, 543319412,
     *2003133806, 543520880,1701016677,1679843694,1679848037,1886351988,
     *1701060723, 779431463,1931507560,1701716084,1751741216,1668247156,
     *1919509109,1953066862, 543781664,1852797984,1768842092,1969513828,
     *        -3, 543780384,1952998688,1919250543,1920230756, 544419445,
     * 774337324, 543780384,1885434484,1768125804,1634869350,1869750377,
     *1851876195,1970430324,1696626030,1769221475,1701604467, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1869509481,1937007982,1668882543,1713391661,1651469924, 541338952,
     * 543451507,1949180019, 779431456,1634624544,1668247410,1684631137/
     * )
      ICK( 42001: 42300) = (/
     *1952784499, 779431456,1768824899,1229332512,1597453109, 538980910,
     * 807411764, 774905888, 942551072, 824197408, 538980384, 807415840,
     * 824188960,        -3,1143818272, 538976288,1130458211, 609758240,
     *1382379556,1495281198, 774778414, 539248928,1932424494, 760373620,
     *        -3,        -2, 541139052,1634887525, 544366964,1768890479,
     *1713402984,1696625253,1886351988,1701060705,1852055651,1634493301,
     *1818326117,1679837229,1651469924, 541338952, 543451507,1952542307,
     *1696625454,1965959027, 543781664,        -3, 543584117,1852059168,
     *1416127776,1970496800,1868963937, 541345353,1478519150,1937011317,
     *1668573551,1847618921,1734898720,1667331443,1696625525,1667768417,
     * 544694642,1852403303, 544434542,1667571744,        -3, 543383916,
     *1668639841,1952801824,1932424494, 661856353,1919230050,1634952548,
     * 544173600,1919250543,1920230756, 544629106,1767992931,1702043759,
     *1852602670,        -3, 542011252,1698308211, 779431463,1931505518,
     * 544499813, 544566889,1949131621,1819025508,1768777070,1936289646,
     *1931501938,1696625761,1801809440,1768846447, 543253347,1869966964,
     * 543780384,1952998688,        -3, 543383916,1668639841,1953066862,
     * 544171552,1702391909,1668572516, 544419445, 774337326, 542402665,
     *1931504993,2032169573,1937075316, 543780384,1818325607,1696621673,
     *1717986674,1701733221,1931485216,        -3, 543319412,2003133806,
     * 543520880,1701016677,1679843694,1679848037,1886351988,1701060723,
     * 779431463,1931507560,1701716084,1751741216,1668247156,1919509109,
     *1953066862, 543781664,1852797984,1768842092,1969513828,        -3,
     * 543780384,1952998688,1919250543,1920230756, 544419445, 774337324,
     * 543780384,1885434484,1768125804,1634869350,1869750377,1851876195,
     *1970430324,1696626030,1769221475,1701604467, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750371,1869509481,
     *1937007982,1668882543,1713391661,1651469924, 541601326,1092641897,
     *1937006958,1667571827, 779431456,1634624544,1668247410,1684631137,
     *1952805664,1768824899,1229332512,1597453110, 538980910, 807411764,
     * 774905888, 942551072, 824197408, 538980384, 807415840, 824188960,
     *        -3,1210986030,1092624416,1130458211, 609758240,1382379556,
     *1495281198, 774778414, 539248160,1932424494, 760373620,        -3,
     *        -2, 541139052,1634887525, 544366964,1768890479,1713402984,
     *1696625253,1886351988,1701060705,1852055651,1634493301,1818326117,
     *1679837229,1651469924, 541601326,1092641897,1937006958,1667571827,
     * 779431463,1931485216,        -3, 543781664,1718580590,1680744480,
     *        -3, 542011252,1698308211, 779431463,1931505518, 544499813,
     * 544566889,1949131621,1819025508,1768777070,1936289646,1931501938,
     *1696625761,1801809440,1768846447, 543253347,1869966964, 543780384,
     *1952998688,        -3, 543383916,1668639841,1953066862, 544171552,
     *1702391909,1668572516, 544419445, 774337326, 542402665,1931504993,
     *2032169573,1937075316, 543780384,1818325607,1696621673,1717986674,
     *1701733221,1931485216,        -3, 543319412,2003133806, 543520880,
     *1701016677,1679843694,1679848037,1886351988,1701060723, 779431463,
     *1931507560,1701716084,1751741216,1668247156,1919509109,1953066862,
     * 543781664,1852797984,1768842092,1969513828,        -3, 543780384,
     *1952998688,1919250543,1920230756, 544419445, 774337324, 543780384,
     *1885434484,1768125804,1634869350,1869750377,1851876195,1970430324,
     *1696626030,1769221475,1701604467, 773857312,        -3,        -1/
     * )
      ICK( 42301: 42600) = (/
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713391661,1651469924, 541339182,1092641897,1937006958,
     *1667571827, 779431456,1634624544,1668247410,1684631137,1952805664,
     *1768824899,1229332512,1597453111, 538980910, 807411764, 774905888,
     * 942551072, 824197408, 538980384, 807415840, 824188960,        -3,
     *1143877166,1092624416,1130458211, 609758240,1382379556,1495281198,
     * 774778414, 539248160,1932424494, 760373620,        -3,        -2,
     * 541139052,1634887525, 544366964,1768890479,1713402984,1696625253,
     *1886351988,1701060705,1852055651,1634493301,1818326117,1679837229,
     *1114599012, 541339182, 776020068,1769174113,1852007712,1932424494,
     * 661856361,1931485216, 543584117,1852059168,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1869509481,1937007982,
     *1668882543,1713391661,1651469924, 541338952, 774783264,1634625388,
     *1696620910,1679844207,1869767785,1851880549,1931503982, 541280582,
     * 544419445, 773857312,1597453112, 538980910, 807411764, 774905888,
     * 942551072, 824197408, 538980384, 807415840, 824188960,        -3,
     *1143818286, 776020000,1130458211, 609758240,1382379556,1495281198,
     * 774778414, 539248160,1932424494, 760373620,        -3,        -2,
     * 541139052,1634887525, 544366964,1768890479,1713402984,1696625253,
     *1886351988,1701060705,1852055651,1634493301,1818326117,1679837229,
     *1114599012, 541338952, 774783264,1634625388,1696625454,1965959027,
     *        -3, 543781664,1718580590,1680744480,        -3, 542011252,
     *1698308211, 779431463,1931505518, 544499813, 544566889,1949131621,
     *1819025508,1768777070,1936289646,1931501938,1696625761,1801809440,
     *1768846447, 543253347,1869966964, 543780384,1952998688,        -3,
     * 543383916,1668639841,1953066862, 544171552,1702391909,1668572516,
     * 544419445, 774337326, 542402665,1931504993,2032169573,1937075316,
     * 543780384,1818325607,1696621673,1717986674,1701733221,1931485216,
     *        -3, 543319412,2003133806, 543520880,1701016677,1679843694,
     *1679848037,1886351988,1701060723, 779431463,1931507560,1701716084,
     *1751741216,1668247156,1919509109,1953066862, 543781664,1852797984,
     *1768842092,1969513828,        -3, 543780384,1952998688,1919250543,
     *1920230756, 544419445, 774337324, 543780384,1885434484,1768125804,
     *1634869350,1869750377,1851876195,1970430324,1696626030,1769221475,
     *1701604467, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750381,1769173865,1852252258,1869505568,1932424494,
     * 543780384,1952998688,1128875552,        -3,1597453361, 538980398,
     * 807418169, 774905913, 959328288, 824197408, 538980384, 807415840,
     * 824188960,        -3,1114599012, 538976288,1130458211, 609758240,
     *1382379556,1495281198, 774778414, 538976288,1298756467,1768843040,
     *1932424494,        -3,        -2, 541878635,1701607712,1298756467,
     *1768843040,1932424494, 544173600,1114599012, 543780384,1128875566,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750381,
     *1769173865,1852252257,1852271717, 544419445, 773876078, 544499813,
     * 541280582,        -3,1597453362, 538980398, 807418169, 774905913,
     * 959328288, 824197408, 538980384, 807415840, 824188960,        -3,
     *1097754476,1696604192,1130458211, 609758240,1382379556,1495281198,
     * 774778414, 538976288,1298756467,1768843040,1932424494,        -3,
     *        -2, 541878635,1701607712,1298756467,1768843040,1932424494,
     * 544173600,1114599012, 543256167,1818566761,1847608137,1177428000/
     * )
      ICK( 42601: 42900) = (/
     *        -3,        -1, 589315646,1042306149,1936990310,1869750381,
     *1769173865,1852252276,1869771625,1869488243, 779431456,1768824948,
     *1751457859,1229332512,        -3,1597453363, 538980398, 807418169,
     * 774905913, 959328288, 824197408, 538980384, 807415840, 824188960,
     *        -3,1416589939,1768910368,1130458211, 609758240,1382379556,
     *1495281198, 774778414, 538976288,1298756467,1768843040,1932424494,
     *        -3,        -2, 541878635,1701607712,1298756467,1768843040,
     *1932424494, 544173600,1416589939,1768910368,1634625388,1696622958,
     * 541280582, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750381,1769173865,1852252259,1869509729,1668554852,
     *1769174113,1852007712,1932424494, 543780384,1952998688,1128875552,
     *        -3,1597453364, 538980398, 807418169, 774905913, 959328288,
     * 824197408, 538980384, 807415840, 824188960,        -3,1131376244,
     *1633907744,1130458211, 609758240,1382379556,1495281198, 774778414,
     * 538976288,1298756467,1768843040,1932424494,        -3,        -2,
     * 541878635,1701607712,1835627379,1768843040,1932424494, 544173600,
     *1668247156,1633907744,1147761524,1634624357, 543780384,1128875566,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750381,
     *1769173865,1852252232, 761425774,1679836205,1210082409,1937006958,
     *1667571827, 779431456,1768824948,1751457859,1229332512,        -3,
     *1597453365, 538980398, 807418169, 774905913, 959328288, 824197408,
     * 538980384, 807415840, 824188960,        -3,1143818272, 538976288,
     *1130458211, 609758240,1382379556,1495281198, 774778414, 538976288,
     *1298756467,1768843040,1932424494,        -3,        -2, 541878635,
     *1701607712,1835627379,1768843040,1932424494, 544173600,1210925679,
     *1852055620, 759701604,1769174113,1852007712,1768824899,1229336096,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750381,
     *1769173865,1852252232, 761425774,1679837230, 776020068,1769174113,
     *1852007712,1932424494, 543780384,1952998688,1128875552,        -3,
     *1597453366, 538980398, 807418169, 774905913, 959328288, 824197408,
     * 538980384, 807415840, 824188960,        -3,1210986030,1092624416,
     *1130458211, 609758240,1382379556,1495281198, 774778414, 538976288,
     *1298756467,1768843040,1932424494,        -3,        -2, 541878635,
     *1701607712,1835627379,1768843040,1932424494, 544173600,1210925679,
     *1852055624, 774778433, 543451507,1952542307,1696622958, 541280582,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750381,1769173865,1852252232, 761425774,1679836206, 776020068,
     *1769174113,1852007712,1932424494, 543780384,1952998688,1128875552,
     *        -3,1597453367, 538980398, 807418169, 774905913, 959328288,
     * 824197408, 538980384, 807415840, 824188960,        -3,1143877166,
     *1092624416,1130458211, 609758240,1382379556,1495281198, 774778414,
     * 538976288,1298756467,1768843040,1932424494,        -3,        -2,
     * 541878635,1701607712,1835627379,1768843040,1932424494, 544173600,
     *1210925679,1852055620, 774778433, 543451507,1952542307,1696622958,
     * 541280582, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750381,1769173865,1852252232, 761425774,1679836205,
     *1210986049, 543256167,1818566771, 779431456,1768824948,1751457859,
     *1229332512,        -3,1597453368, 538980398, 807418169, 774905913,
     * 959328288, 824197408, 538980384, 807415840, 824188960,        -3,
     *1143818286, 776020000,1130458211, 609758240,1382379556,1495281198/
     * )
      ICK( 42901: 43200) = (/
     * 774778414, 538976288,1298756467,1768843040,1932424494,        -3,
     *        -2, 541878635,1701607712,1835627379,1768843040,1932424494,
     * 544173600,1210925679,1852055620, 759705134,1092641134,1735157024,
     *1768824899,1229336096,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1701737317,1818588019, 543321966,1679848238,
     *1965957225,1847620712,1696613193,1176510496,        -3,1597453617,
     * 538980398, 807418169, 774905913, 959328288, 874529056, 538980384,
     * 807415840, 824188960,        -3,1114599012, 538976288,1130458211,
     * 609758240,1382379556,1495281198, 774778414, 538989413,1853056364,
     *1702064928,1932424494,        -3,        -2, 541158944,1932424494,
     * 544434287,1970037792,1852797984,1650794599,1769366894, 543780384,
     *1952998688,1128875552,1718579744,1668247155,1953653097,1852138528,
     *1684632436,1634624357,1932402720,        -3, 542141541,1634952480,
     *1667786083,1797285487,1914728562,1869636978, 544367974,1768842605,
     *1701737504,1937006964,1970479206,1818322803, 539518254,1731076178,
     * 689971232,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1701737317,1818588019, 543256167,1818566771, 779431456,
     *1768824948,1751457859,1229332512,        -3,1597453618, 538980398,
     * 807418169, 774905913, 959328288, 874529056, 538980384, 807415840,
     * 824188960,        -3,1097754476,1696604192,1130458211, 609758240,
     *1382379556,1495281198, 774778414, 538989413,1853056364,1702064928,
     *1932424494,        -3,        -2, 541158944,1932424494, 544434287,
     *1970037792,1852797984,1650794599,1769366894, 543780384,1952998688,
     *1128875552,1718579744,1668247155,1953653097,1852138528,1634625388,
     *1702047264,        -3, 542141541,1634952480,1667786083,1797285487,
     *1914728562,1869636978, 544367974,1768842605,1701737504,1937006964,
     *1970479206,1818322803, 539518254,1731076178, 689971232,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1701737317,
     *1818588019, 544501618,1936289646, 544419445, 773876078, 544499813,
     * 541280582,        -3,1597453619, 538980398, 807418169, 774905913,
     * 959328288, 874529056, 538980384, 807415840, 824188960,        -3,
     *1416589939,1768910368,1130458211, 609758240,1382379556,1495281198,
     * 774778414, 538989413,1853056364,1702064928,1932424494,        -3,
     *        -2, 541158944,1932424494, 544434287,1970037792,1852797984,
     *1650794599,1769366894, 543780384,1952998688,1128875552,1718579744,
     *1668247155,1953653097,1852138528,1953460851,1768910368,1634625388,
     *1702047264,        -3, 542141541,1634952480,1667786083,1797285487,
     *1914728562,1869636978, 544367974,1768842605,1701737504,1937006964,
     *1970479206,1818322803, 539518254,1731076178, 689971232,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1701737317,
     *1818588019, 543387502,1952539508, 543451507,1952542307,1696625454,
     *1965957225,1847620712,1696613193,1176510496,        -3,1597453620,
     * 538980398, 807418169, 774905913, 959328288, 874529056, 538980384,
     * 807415840, 824188960,        -3,1131376244,1633907744,1130458211,
     * 609758240,1382379556,1495281198, 774778414, 538989413,1853056364,
     *1702064928,1932424494,        -3,        -2, 541158944,1932424494,
     * 544434287,1970037792,1852797984,1650794599,1769366894, 543780384,
     *1952998688,1128875552,1718579744,1668247155,1953653097,1852138528,
     *1668247156,1633907744,1684632436,1634624357,1932402720,        -3,
     * 542141541,1634952480,1667786083,1797285487,1914728562,1869636978/
     * )
      ICK( 43201: 43500) = (/
     * 544367974,1768842605,1701737504,1937006964,1970479206,1818322803,
     * 539518254,1731076178, 689971232,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750387,1701737317,1818588019, 541601122,
     *1869505568,1143818272,1684632436,1634624357, 544419445, 773876078,
     * 544499813, 541280582,        -3,1597453621, 538980398, 807418169,
     * 774905913, 959328288, 874529056, 538980384, 807415840, 824188960,
     *        -3,1143818272, 538976288,1130458211, 609758240,1382379556,
     *1495281198, 774778414, 538989413,1853056364,1702064928,1932424494,
     *        -3,        -2, 541158944,1932424494, 544434287,1970037792,
     *1852797984,1650794599,1769366894, 543780384,1952998688,1128875552,
     *1718579744,1668247155,1953653097,1852138528,1684632436,1634624357,
     *1932402720,        -3, 542141541,1634952480,1667786083,1797285487,
     *1914728562,1869636978, 544367974,1768842605,1701737504,1937006964,
     *1970479206,1818322803, 539518254,1731076178, 690888736,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1701737317,
     *1818588019, 541601122,1869505568,1210986049, 543451507,1952542307,
     *1696625454,1965957225,1847620712,1696613193,1176510496,        -3,
     *1597453622, 538980398, 807418169, 774905913, 959328288, 874529056,
     * 538980384, 807415840, 824188960,        -3,1210986030,1092624416,
     *1130458211, 609758240,1382379556,1495281198, 774778414, 538989413,
     *1853056364,1702064928,1932424494,        -3,        -2, 541158944,
     *1932424494, 544434287,1970037792,1852797984,1650794599,1769366894,
     * 543780384,1952998688,1128875552,1718579744,1668247155,1953653097,
     *1852138528,1684632436,1634624357,1932402720,        -3, 542141541,
     *1634952480,1667786083,1797285487,1914728562,1869636978, 544367974,
     *1768842605,1701737504,1937006964,1970479206,1818322803, 539518254,
     *1731076178, 690888736,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1701737317,1818588019, 541601122,1869505568,
     *1143877185, 543451507,1952542307,1696625454,1965957225,1847620712,
     *1696613193,1176510496,        -3,1597453623, 538980398, 807418169,
     * 774905913, 959328288, 874529056, 538980384, 807415840, 824188960,
     *        -3,1143877166,1092624416,1130458211, 609758240,1382379556,
     *1495281198, 774778414, 538989413,1853056364,1702064928,1932424494,
     *        -3,        -2, 541158944,1932424494, 544434287,1970037792,
     *1852797984,1650794599,1769366894, 543780384,1952998688,1128875552,
     *1718579744,1668247155,1953653097,1852138528,1684632436,1634624357,
     *1932402720,        -3, 542141541,1634952480,1667786083,1797285487,
     *1914728562,1869636978, 544367974,1768842605,1701737504,1937006964,
     *1970479206,1818322803, 539518254,1731076178, 690888736,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750387,1701737317,
     *1818588019, 541601122,1869505568,1143818286, 776020065,1852271717,
     * 544419445, 773876078, 544499813, 541280582,        -3,1597453624,
     * 538980398, 807418169, 774905913, 959328288, 874529056, 538980384,
     * 807415840, 824188960,        -3,1143818286, 776020000,1130458211,
     * 609758240,1382379556,1495281198, 774778414, 538989413,1853056364,
     *1702064928,1932424494,        -3,        -2, 541158944,1932424494,
     * 544434287,1970037792,1852797984,1650794599,1769366894, 543780384,
     *1952998688,1128875552,1718579744,1668247155,1953653097,1852138528,
     *1634625388,1702047264,        -3, 542141541,1634952480,1667786083,
     *1797285487,1914728562,1869636978, 544367974,1768842605,1701737504/
     * )
      ICK( 43501: 43800) = (/
     *1937006964,1970479206,1818322803, 539518254,1731076178, 689971232,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750388,
     *1751457904,1919251301,1852007712,1868963937,1948281957,1634956320,
     *1869505824,1953460851,1768910368,1634625388,1696622958, 544499813,
     * 541280582,        -3,1597453872, 538976288, 807411744, 540155936,
     * 538980896, 824199456, 538980384, 807415840, 824188960,        -3,
     *1128875552,1131376244,1634299507, 544108320,1416589939,1768910368,
     *1097754476,1702043694, 774778414, 774778414, 774778414, 774778414,
     * 538976288, 538976288, 538984224,1231971951,        -3,        -2,
     * 542402661, 541280582, 543387502,1952541038,1931505263, 544501618,
     *1936289646, 543256167,1818566757,1853125225,1702047264,1416128883,
     * 544041319,1752440930,1696620899,1668246896,1818850152,1701060727,
     *1769236512,        -3, 544499813, 542328901,1280855072,1768846196,
     *1920295796,1768910368,1129270854, 773857312,        -3, 541683299,
     *1819636585,1869488233,1931502958,1668248946,1634166116, 543324448,
     *1097036897, 541291129,1936993824,1651864608,1852797984,1852138341,
     *1936941426,1768716576,1936662626,2032168820,1751478816,        -3,
     * 543846261,1919836524,1932402720,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750388,1751457904,1919251301,1852007712,
     *1868963937,1948281957,1634956320,1869505824,1479362592,1768824948,
     *1751457859,1229332512,        -3,1597453873, 538976288, 807411744,
     * 540155936, 538980896, 824199456, 538980384, 807415840, 824188960,
     *        -3,1128875552,1131376244,1634299507, 544108320,1479362592,
     *1114599012,1931488814, 774778414, 774778414, 774778414, 774778414,
     * 774778414, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542402661, 541280582, 543387502,1952541038,
     *1931505263, 542649672, 541224814,1685270048,1416128883, 544041319,
     *1752440930,1696621409,1970496868, 543324448,1852797984,1970497902,
     *1730180200,1696617288,1162631244,        -3, 543780467,1953658211,
     *1953066862, 541216590,1142957128, 773867886,1668052339,1768910368,
     *1769152626,1701934441,1919247392,1652105281,1668571424,1131575667,
     *1949180002,1970544750,1869881454,1701012851,1935766121,1819877408,
     * 544436000,1652105327,1952998770, 543846261,1919836524,1932402720,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750369,
     *1948281957,1634956320,1869505824,1479366957,1210085234, 541601113,
     * 759701605,1853125241, 543780384,1952998688,1128875552,        -3,
     *1597453874, 538976288, 807411744, 540155936, 538980896, 824199456,
     * 538980384, 807415840, 824188960,        -3,1128875552,1131376244,
     *1634299507, 544108320,1479366957,1210085234, 541601113, 759701569,
     *1852271717,1931488814, 774778414, 774778414, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 542402661,
     * 541280582, 543387502,1952541038,1931505263, 542649689, 759701615,
     *1914718253,1496139808,1651469924, 543256167,1818587950, 542402665,
     *1931505001,1734898720,1650794595,1635087205,1679843961, 544108404,
     *        -3, 544568169,1852252276,1751457875,1212501080,1277192558,
     *1937011317,1668573551,1847607887,1313087524,1210982484,1752134501,
     * 543449460,1629516648,1869966436, 543255667,1864393317, 544437616,
     *1886153061,1679826976,        -3, 544696421,1847609389,1635020653,
     *1931501938,1696622958,1953656676,1969448292, 544173600,1667329123,
     *1970037108,1701060720,1869834612,1768910451, 543256164, 795832864/
     * )
      ICK( 43801: 44100) = (/
     *1919247977,1852138528,1919509609,1852252271,1847599136, 544499813,
     *1769087075,1634890345,1701978209,1953459502, 541683299,1819636585,
     *1869488233,1931506277,1903520114,1701060706,2032157027,1952522307,
     *1920562036, 773874293,1948282479,1948282469,1667593075,1634888044,
     *2032148512, 544436000,1652105327,1952998770, 543846261,1919836524,
     *1932402720,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750381,1769173865,1852252258,1869505651, 543780384,1952998688,
     *1128875552,        -3,1597453875, 540028464, 824188976, 774971424,
     * 892219424, 824199456, 538980384, 807415840, 824188960,        -3,
     *1231971183,1836084325,1952784451,1229332546,1869505568,1818850164,
     * 541353332,1701016677,1679829074,1701850949,2020631593, 539897390,
     * 539248160,1382118505,1864376352,        -3,        -2, 541224814,
     *1679846505,1936990313,1847608137,1176530025,1801809017, 543780451,
     *1869443180,1702126894,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750383,1986359907,1869443180,1702126880,1651469924,
     *1931503982, 544499813, 541280582,        -3,1597453876, 538980398,
     * 807411765, 774905888, 892219424, 874531104, 538980384, 807415840,
     * 824188960,        -3,1333159282,1668246896,1818588261, 541280582,
     * 541224814,1679838313,1936990276,1702126947,1952801824, 676488560,
     * 793081968,1680416814, 539248160,1382118505,1864376352,        -3,
     *        -2, 542402661, 541280582, 543387502,1952541038,1931505007,
     *1919230050,1869505651, 544499809,1847620712,1696626030,1769043301,
     * 544433524, 740321646,1684628321,1953066599, 544367972,1970168929,
     *1852012846,        -3, 541158944,1702388077,1886151968,1769152626,
     *1701082478,1684106851,2032166005,1696625775, 544499813, 543780451,
     *1819636585,1869488239,1713402745,1835885940,1920540786,1701601652,
     *1701060706,1869505651, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750373,1920102254,1701803379, 539446345,
     *1398022200, 656435566,1937011317,1668573551,1847617902, 544499813,
     * 543518050,1701078117,1679830642,1702043750,1768711456,        -3,
     *        -2,1597453878, 538980398, 807411762, 774905888, 841887776,
     * 874531104, 538980384, 807415840, 824188960,        -3,1229869856,
     *1164796517,1684301156, 541870419,1411397664,1231975284,1920295796,
     *1768910368,1399353205,1818501218,1696615497,1398022196, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542402661, 543582574,1634476092,1851878757,1043228259,1713398131,
     *1936679785,1635018084, 544696692,1746957416,1696611438,1634559294,
     * 778266982, 544434287,1970037792,1751217765, 543319397,1847616370,
     *1700885605,1679826976, 544696692,1746957416,1696615497,1398022196,
     * 543780467,1953658211,1953066862, 539520882, 543847795,1948281957,
     *1718886511,1970544738,1701011829,1936007265,1819436385,1685659753,
     *1836084329,1667855392,2003399784,        -3, 544499813, 541147988,
     *1092643182,1937011317,1668573551,1848192544,1416127776,1279873876,
     * 540549225,1853060210,1969452137,1869488247,1768713248,1668441441,
     *1952784481,1847608899,1176528489,1818566775,1751478885,        -3,
     * 544499813, 544170611,1702000229,1679844449,1952522337,1919230052,
     *1702131561,1852728676, 544039275,1768843040,1952998688,1734700645,
     *1918989413,1679834222,1634559294, 778462054, 544566899,1969845345,
     *1651270944,        -3, 543584114, 543385701,1667983726,1730176623,
     *1914727785,1936942436, 539517284,1684632681,1869504876, 689992823/
     * )
      ICK( 44101: 44400) = (/
     *1768844905,1852252257,1852055670,1634494820,1635019119,1848516640,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750373,
     *1920102254,1701803379, 539446345,1398022198, 656435566,1937011317,
     *1668573551,1847617902, 544499813, 543518050,1701078117,1679830642,
     *1702043750,1768711456,        -3,1597453879, 538980398, 807411762,
     * 774905888, 841887776, 874531104, 538980384, 807415840, 824188960,
     *        -3,1229869856,1164796517,1684301156, 541870419,1411397152,
     *1231975284,1920295796,1768910368,1399353205,1818501218,1696615497,
     *1398022196, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542402661, 539438694,1667639072,1718185061,
     * 543257459,1868786017,1952801824,2003399784, 544499813, 539438691,
     *1768302368,1718185061, 544434287,1970037792,1751217765, 543319397,
     *1847616370,1700885605,1679849321,1952981024, 543236135,1279873876,
     * 540288800,1768846196,1920295796,1768910368, 678392352,1818584692,
     * 544175476, 543319395,1635087205, 543255666,1700881529, 543780208,
     *1818846057,1948284777,1952981108,1751457857,1129595168,        -3,
     * 543780467,1953658211,1953066862, 690888780,1230197792, 908097385,
     *1819025507,1919246708,1696620832, 657352291,1713840230,1768711456,
     *2003330418,1696625768,1696624482,1936028278,1701060708,1635016992,
     *1634886944,        -3, 543387506,1919247220,1701060710,1869750369,
     *1852796257,1819243891, 796026227,1869504878,1948283747,1635021925,
     *1919512167, 740322657,1802071655, 544499813, 543647086,1701994868,
     *1701060647, 778462054, 656434793,1818566688, 544566899,1969845345,
     *1651270944,1718579744,1886352244, 544367974,1768842605,1701737504,
     *1633842031,1819636837, 544437362,1969452149,1919230049,1851878521,
     *1936290592,1634624544,1986096233,1684108393,1869491744,        -3,
     *        -1, 589315646,1042306117,1398022246,1869750339,1229336402,
     *1163075685,1835165028,1684366368,1702391916,1768122740, 544432993,
     *1953785202,1768843040,1717658484,1869750390,1634497893,1931485216,
     *        -3,1597453880, 538980398, 807411760, 774905888, 808333344,
     * 874531104, 538980384, 807415840, 824188960,        -3,1380274976,
     *1164796517,1684301156, 541423728,1818846057,1953265952,1400205424,
     *1818846564, 542335841,1953785202,1768843040,1147237473, 538976288,
     * 542141541,1634952480,1315927141,        -3,        -2, 542402661,
     * 544437616,1886153061,1679828782,1667851815, 543582572,1696622958,
     *1668052324,1702043749,2020633705,1667855392,1635020653,1768104051,
     *1667331188,1701996910,1730176609,1668575090, 543449460,1696622958,
     *        -3, 544499813, 543518050,1701078117,1679828782,1919251239,
     * 543582572,1697521748,1752134501, 544629100,1969582880,1835104544,
     *1869750381,1635328110,1869881442,1696622948,1701737577,1667329056,
     *1953439860,1751457824,        -3, 544437345,1852072306,1679849057,
     *1819633011, 543257376,1768842092,1969513828, 543780384,1668641394,
     *1701737504,1986359923,1768910451, 544171552,1397245260,1481387552,
     *1232347251,1752135020,1679843941, 544108404,1701060640, 544499809,
     *1948284008,1869833504,1986096245,1702043767,1768713248,1852797984,
     * 677542176,1684366945,1970041897, 543319328,1886545267,1701737504,
     *1634934851,1229332580,1635016992,1769235821,1931503982, 541280582,
     * 661856288, 543388261,1635018084, 544696692,1746948936,1162631244,
     * 773869644,1096044366, 795043941,1667973961,1176532841,1819025525,
     *1936007273,1953701999,2003705954,1969843300, 761884192,1935892852/
     * )
      ICK( 44401: 44700) = (/
     *1952805481,1852252192,        -3, 543580515,1953460851, 740324456,
     *1635000417,1919230057,1684369012,1768120684, 544501536,1953001331,
     *1696626035,1701060706,2032165989,1717663084,1948279417, 542328901,
     *1280855072,1718579744,1668246893,1869488160,        -3, 544694646,
     *1701602670,1735682163, 740320879,1914726772,1931507297,1818846305,
     *1953066862, 543383916,1668639841,1953066862,1932402720,        -3,
     *        -1, 589315646,1042306117,1398022246,1869750339,1229332581,
     *1835165028,1684366368,1702391916,1768122740, 544432993,1953785202,
     *1768843040,1717658484,1869750390,1634497893,1931485216,        -3,
     *1597453881, 538980398, 807411760, 774905888, 808333344, 874531104,
     * 538980384, 807415840, 824188960,        -3,1128875552,1164796517,
     *1684301156, 541423728,1818846057,1953265952,1400205424,1818846564,
     * 542335841,1953785202,1768843040,1147237473, 538976288, 542141541,
     *1634952480,1315927141,        -3,        -2, 542402661, 544437616,
     *1886153061,1679828782,1667851815, 543582572,1696621423,1853120873,
     *1853038693,2020633705,1667855392,1935892852,1952805481,1852252262,
     *1633907823,1914725473,1952522337,1931507297,1819633011,        -3,
     * 544171552,1952998761,1914725231,1920099699,1886350948,1768843040,
     *1128875552,1684108385,1851878757,1932402772,1752134501, 544432993,
     *1953785202,1768843040,1717658484,1869750372,1635016992,1634886944,
     *1970496868, 543324448, 542133313,1414483503,1667786083,1799571782,
     * 543584114, 543782003, 544629100,1768186228,1768910368,1667329123,
     *1970037108,1768910451, 543257376,1869639791,1936024608,1953439861,
     *1936289383, 544499813,        -3, 544105845,1953653100, 544432993,
     *1953785202,1768843040,1717658484,1869750372,1635016992,1952997748,
     * 543257189, 544437359,1919247392,1768824912,1279349839,1310730359,
     *1751737192, 543257189, 543777893,1853122915,1634476064, 544501536,
     *1953001331,1696625524,1869768036, 543780468,1701998177,1819048224,
     *1768824915,1212501080,1277767200,1416130419,1696613193,1176531557,
     *1886351988,1701060726,1634497893,1931506536,1869966436, 543319328,
     *        -3, 543777893,1853122915,1634476148,1864397928,1869833504,
     *1886547830,1768187236, 543780384,1952998688,1701667429,1684301156,
     * 539438706,1702045472,1718185061, 773857312,        -3, 541291890,
     *1919250036, 542328901,1280855072,1986359923,1768910451, 543452960,
     *1852797984,1668247673, 544432993,1953785202,1768843040,1717658484,
     *1869750372,1635016992,1952997748, 543257189,        -3, 543520880,
     *1818846057,1953265952,1768842092,1969513828, 543780384,1952998688,
     * 657353070,1931944041,1853060210,1969452137,1869488230,1768711456,
     *1768846447, 543387506,1919251312,1869505641,1852252227,1229332512,
     *        -3, 543449460,1629514100,1701671726, 541139058,1700885359,
     *1847617135,1914729576,1696626035,1696624486, 544108398, 761554278,
     *1635085428, 544432993,1953785202,1768843040,1717658484,1869771552,
     *1667329568,1650794528,        -3, 544499813, 544042852,1701604457,
     *1852252271,1713398632,1634887525,1679843700,1869443872,1768824948,
     *1751457906,1701210478,1701668206,1949179969,1819504428, 544499813,
     * 542133313,1414483488,1651861868,1680697710,        -3, 542139758,
     *1730173773,1768125039,1847604016, 674314553, 958996534, 842345782,
     * 876109088,1701602659,1953656686, 544432993,1953785202,1768843040,
     *1717658484,1869771552,1835624296,1948280929,1986338914,1701146144,
     *        -3, 544437602,1937009012,1970562404, 543324448,1634607201/
     * )
      ICK( 44701: 45000) = (/
     *1819567474,1851880553,1986338931,1702112800,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750387,1970499685,1668554819,
     * 759701602,1869505651, 543780384,1128875552, 678326132, 543383925,
     *1734898720,1869899877,1920428403,1697194016,        -3,1597454128,
     * 538980398, 807411760, 774905888, 808333344, 840974624, 538980384,
     * 807415840, 824188960,        -3,1400206192,1701016608,1127041056,
     *1114599012, 543780384,1128875578, 538977345, 757933122, 539893796,
     *1176519022,1731076128,        -3,        -2, 542270832,1869771808,
     *1869488245,1853191029,1634476099, 759701602,1869505651, 544108404,
     * 543383925,1734898720,1768824943,1952998770, 544499059,1953705504,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750387,
     *1970499685,1668554830, 759701602,1869505651, 543780384,1128875552,
     * 678326132, 543383925,1734898720,1869899877,1920428403,1697194016,
     *        -3,1597454129, 538980398, 807411761, 775168032, 825111840,
     * 840974624, 538980384, 807415840, 824188960,        -3,1130915171,
     *1797267488,1311590432,1114599012, 543780384,1128875578, 539246893,
     * 757350944, 774774820,1176519022,1731076128,        -3,        -2,
     * 542270832,1869771808,1869488245,1853191029,1634476110, 759701602,
     *1869505651, 544108404, 543383925,1734898720,1768824943,1952998770,
     * 544499059,1953705504,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1970499685,1668554831, 759701602,1869505651,
     * 543780384,1128875552, 678326132, 543383925,1734898720,1869899877,
     *1920428403,1697194016,        -3,1597454130, 538980398, 807411761,
     * 775168032, 825111840, 840974624, 538980384, 807415840, 824188960,
     *        -3,1400206192,1701016608,1328367648,1114599012, 543780384,
     *1128875578, 539246893, 757350944, 774774820,1176519022,1731076128,
     *        -3,        -2, 542270832,1869771808,1869488245,1853191029,
     *1634476111, 759701602,1869505651, 544108404, 543383925,1734898720,
     *1768824943,1952998770, 544499059,1953705504,        -3,        -2,
     * 542011252,1698308165,2019779952,1953066862,1931502433,1847616101,
     * 541601121,1953459571, 543780384,1633904996, 542060078,1210986063,
     * 543322729,1684497779, 544174624,1768824904, 894382635,        -3,
     * 538976288, 538976296,1215915122,1869506933,1831411827,1885692777,
     *1702047264,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750387,1970499685,1668554819, 759373922,1869505651, 543780384,
     *1128875552, 678326132, 543383925,1734898720,1869899877,1920428403,
     *1697194016,        -3,1597454131, 538980398, 807411760, 774905888,
     * 808333344, 840974624, 538980384, 807415840, 824188960,        -3,
     *1130915171,1797287023,1852252227, 759373890,1869505568,1768824899,
     *1229339168, 608251181, 608313380,1176519022,1731076128,        -3,
     *        -2, 542270832,1869771808,1869488245,1853191029,1634476099,
     * 759373922,1869505651, 740323439,1936943458,1819877408,1852797984,
     *1667331431,1752440937,1847619444,1751478816,1952805748,1932402720,
     *        -3, 541423715,1701868649,1869509408,1768842092,1969513760,
     *1127039776,1684632436,1634624357,1931505510, 543257199,1970168864,
     * 825112373, 541159015, 773876078, 543501927, 773857312,        -3,
     * 540093490, 761555299,1634886241, 761490543,1936665956,1868850531,
     *1633841010,1634624814,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750388,1869553772,1634887525, 795177586,1869505903,
     *1970479202,1869505568,1684632436,1634624357,        -3,1597454132/
     * )
      ICK( 45001: 45300) = (/
     * 538981166, 891297844, 774905913, 959328288, 824197408, 538980384,
     * 807415840, 824188960,        -3,1130915171,1797267488,1479366944,
     *1114599012, 543780384,1128875578, 539246893, 757350944, 774774820,
     *1176519022,1731076128,        -3,        -2, 541878635,1701607712,
     *1165128303,1852141429,1931493999,1852055621,1853125241, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750388,
     *1869553772,1634887525, 795177586,1869505903,1970479203,1869509729,
     *1668554852,1769174113,1852007712,        -3,1597454133, 538981422,
     * 807411766, 774905913, 959328288, 824197408, 538980384, 807415840,
     * 824188960,        -3,1130915171,1797267488,1479366944,1131376244,
     *1633907744,1768824899,1229339168, 608251181, 608313380,1176519022,
     *1731076128,        -3,        -2, 541878635,1701607712,1165128303,
     *1852141429,1931494255,1853120867,1948271982,1953659182,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750388,1869553772,
     *1634887525, 795177586,1869505903,1970479176, 761425774,1679836205,
     *1210064996,1769174113,1852007712,        -3,1597454134, 538980654,
     * 857743409, 775233568, 841887776, 824197408, 538980384, 807415840,
     * 824188960,        -3,1130915171,1797267488,1143818272,1147761524,
     * 543780384,1128875578, 539246893, 757350944, 774774820,1176519022,
     *1731076128,        -3,        -2, 541878635,1701607712,1165128303,
     *1852141429,1931494445,1210074478,1953659182,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1311649352, 774789163,
     * 543321966,1685266537,1847620712,1696613193,1176510496,        -3,
     *1597454135, 538980398, 807411760, 774905888, 808333344, 840974624,
     * 538980384, 807415840, 824188960,        -3,1130915171,1797279278,
     * 776482350,1478509167,1852055657,1847608137,1178214436,1093479716,
     *1109401636,1176519022,1731076128,        -3,        -2, 542270832,
     *1869771808,1311590432,1684632436,1634624357, 543780384,1936745827,
     *1767992352,1311649352, 774789163, 543321966,1685270048,1416127776,
     *1310731822, 542646372,1769174113,1852007712,1769152544,        -3,
     * 543520880,1701016677,1679848559, 543319328,1936224114,1952805408,
     *1952997742, 543780384,1629516660,1634624609,1919164520,2036626031,
     *1734700576,1651469924, 773857312,        -3,        -1, 589315646,
     *1042301800,1701014304,1718579744,1328426568, 774789163, 543321966,
     *1685266537,1847620712,1696613193,1176510496,        -3,1597454136,
     * 538980398, 807411760, 774905888, 808333344, 840974624, 538980384,
     * 807415840, 824188960,        -3,1130915171,1797279534, 776482350,
     *1478509167,1852055657,1847608137,1178214436,1093479716,1109401636,
     *1176519022,1731076128,        -3,        -2, 542270832,1869771808,
     *1328367648,1684632436,1634624357, 543780384,1936745827,1767992352,
     *1328426568, 774789163, 543321966,1685270048,1416127776,1327509038,
     * 542646372,1769174113,1852007712,1769152544,        -3, 543520880,
     *1701016677,1679848559, 543319328,1936224114,1952805408,1952997742,
     * 543780384,1629516660,1634624609,1919164520,2036626031,1734700576,
     *1651469924, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750387,1970499685,1668554849,1852271717, 543780384,
     *1128875552, 678326132, 543383925,1734898720,1869899877,1920428403,
     *1697194016,        -3,1597454137, 538980398, 807411760, 774905888,
     * 808333344, 874531104, 538980384, 807415840, 824188960,        -3,
     *1400206192,1701016608,1869750345,1920099692,1702257006,1948264514/
     * )
      ICK( 45301: 45600) = (/
     *1869505577, 541159015,1818568819, 689989998, 541280582, 539897390,
     * 538977345, 541353319, 773857312,        -3,        -2, 542142323,
     *1936286316,2032166258,1919905381,1869968160, 675442542,1680433518,
     *1735157024,1818588019, 544499809,1847604277, 543450471,1919247662,
     * 542402661, 543256167,1818566765,1768384628, 543319328,        -3,
     * 543387502,1936286821,1919247392,1718579744,1701603693,1768841588,
     *1768910368,1718775661, 544499813, 541280582, 544696421,1847617906,
     *1919249509,1986096756, 773870696,1769152577,1279611476, 543383918,
     *        -3, 543255667,1864393317, 544502377,1734829426,1701060727,
     *1751477792,1952998688,1634956137,1735288164, 544170851,1970299246,
     *1668882534,1633907823,1920147553,1919230057,1852010354,1919247220,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990327,
     *1751479400,1701978228,1751457891,1869574756,1768841588,1702043750,
     *1869770016,1629512559,1852728675,1952801824,1936028704,        -3,
     *1597454384, 538976288, 807411744, 540024864, 825110560, 824197408,
     * 538980384, 824193056, 807411744,        -3,1131376498,1684631137,
     *1952805664,1685004398,1869881414,1869770016,1629507698,1869636978,
     *1819877443,1869508197,1668572516, 542336372, 538976288, 542141541,
     *1634952480,1148133409,        -3,        -2, 541160559,1836261479,
     *1769366894, 543780384,1629504329,1176531816,1869966436, 543584114,
     *1830838560, 660828014,1852138356,1701060723,1702111020, 543764069,
     * 773877359, 544438637,1835365490,2032148512,        -3, 544174181,
     *1918989417,1869509408,1634886944,1852138852,1701060724,1864394597,
     *1948279156,1869443872,1768824929, 543321966,1684631143, 544239475,
     *1769236847,1848516673, 543387502,1852138356,1701060723,1702109295,
     *1713381408, 543257711,1836261481,1931505263,1948282469,1701078372,
     * 543584114, 544499813, 543974753,1936990323,1903518066,1702043762,
     *1701210478,1701668206,1948264565,1852597619,1931503737,1685221223,
     *1701716065,1953459571,        -3, 543257189, 544501536,1650794593,
     *1684301156, 543257632,1667329123,1970037108,1701060720,1869834612,
     *1768910451, 690888775,1701801317,1953659168,1818850164,1768843123,
     * 539517551,1852076844, 543256167,1818587948,        -3, 544501618,
     *1936289646,1931486752,1210933871,1852076841, 543319395,1869440288,
     *1970173801,1701602425, 543584114, 544108398, 761491310,1852138356,
     *1701060705,1953459488,1936028787, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750342,1818321771, 544743542,
     *1634497893, 543584114, 543384942,1953656691,2037214565,1953655139,
     * 544436321,1667575143,1919907184,        -3,1597454385, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 807415840,
     * 824188960,        -3,1181507939,1797279841,1918987621,1952805408,
     *1769152583,1769366894, 543584114, 541287790,1953656608,1399873891,
     *1697466226,1869967406, 538976288, 538976288, 538984224,1165128303,
     *1914708000,        -3,        -2, 541139014,1818321771, 544235890,
     *1634559348,1701978230,1634497893, 543781664,1701999215,1852141429,
     *1936488736,1734964837,1847617135,1914724640,1937011317,1668576626,
     *1696625253,1886351988,1701060640,        -3, 543780384,1629512549,
     *1853125231,1937337709,1702130281,1663071088,1633903917,1735552885,
     *1882071072,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750389,1853191029,1634476099, 760106802, 543256096,1127039823,
     * 840985967,1768256633, 543321966,1679845221,1869440372,1920540704/
     * )
      ICK( 45601: 45900) = (/
     *        -3,1597454386, 538976288, 807411761, 774905888, 841887776,
     * 840974624, 538980384, 807416096, 807411744,        -3,1433302387,
     *1969318944,1114599012, 541549935,1835365490,2032166511,1914709057,
     * 541945705,1702132000,1098018677,1852055584, 538977346, 541288549,
     *1667964960,        -3,        -2, 542597490,1852403303, 543584114,
     * 543236208,1869837161,1651270944,1835627361,1936943463,1852663150,
     *1948282726, 541273422,1328685153,1852055619, 759385906, 544042857,
     *1702127973,1932402720,        -3, 542402661, 543647087,1835365490,
     *2032168806, 544499813, 544367984,1869771877,1679846767,1768256633,
     * 543256688,1700885107, 544501536,1650794613,1853191029,1634479977,
     *1852010350,1936290676,1701737518,        -3, 542402661, 541273423,
     * 543321966,1679844457,1937006958,1667592992,1768824899, 759385906,
     * 543257189, 543520880,1701016677,1679848559, 543253604, 544567328,
     *1953439841,1651471732, 540159541,        -3, 542401907,1948271474,
     *1769235826,1767979552,1095517522,1411409519,1914716973,1327522415,
     *1852055667,1970085948, 540159540, 941646190,1679835949,1126186016,
     * 825111608, 541159015,1937011311,1830821920,        -3, 542402661,
     * 541994319, 543321966,1679844457,1937006958,1667592992,1768824899,
     * 760106802, 543257189, 543520880,1701016677,1679848559, 543253604,
     * 544567328,1953439841,1651471732, 540159540,        -3, 542401907,
     *1948271474,1769235826,1767979552,1095517522,1411409519,1914719789,
     *1327522415,1852055667,1970085950, 540159540, 941646190,1679835949,
     *1126186528, 825111608, 541159015,1937011311,1830821920,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750341,1815158889,
     *1847612277,1833332594,1836412001,        -3,1597454391, 538976288,
     * 807418169, 774905913, 959328288, 874529056, 538980384, 807415840,
     * 824188960,        -3,1130914158,1734680612,1092643182,1953439780,
     *1109420398, 542340461,1181708909,1970037024, 774774816, 538976336,
     *1818583411,1696613487,        -3,        -2, 542402661, 544109933,
     *1701996899,1634476144,1634890784,1718579744,1634607205,1818586469,
     *1853104233,1847620712,1696617333,1833332594,1836412001, 544434287,
     *1970037792,1650794596,1919905904,1701060727,1751477792,        -3,
     * 539439399, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750341,1815158889,1847610735,1768256633,1181708909,
     *1970037024,1768846196,1700881440,1868963909,1814044704,        -3,
     *1597454392, 538976288, 807418169, 774905913, 959328288, 874529056,
     * 538980384, 807415840, 824188960,        -3,1130914158,1734680612,
     *1092643182,1953439780,1109420398, 541945705,1702132038,1869770101,
     *1818304544, 538976336,1818583411,1696613487,        -3,        -2,
     * 542402661, 544109933,1701996899,1634476144,1634890784,1718579744,
     *1634607205,1818586469,1853104233,1847620712,1696615791,1768256633,
     *1181708909,1970037024,1936224117,1818501218,1696621682,1869639781,
     *1679826976,        -3, 544696421,1847600945, 657334304,        -3,
     *        -1, 589315646,1042305637,1886351988, 544499813, 544109933,
     *1650815520,1868963937,1953459571, 544696692,1746955877,1734440041,
     *1986338911,1635020653,1601399156,1700750441,1936683620,1701994343,
     *1919907184, 539172896,        -3,1597454393, 538976288, 807411744,
     * 540024864, 538980384, 874531104, 538980384, 807415840, 824188960,
     *        -3,1098149741,1931507561,1952981070,1701273972,1769366816,
     *1600222319,1834972009,1952800612,1769172850,1684370015,1735552885/
     * )
      ICK( 45901: 46200) = (/
     *1881153571, 539248928,1130915171,1797267488,        -3,        -2,
     * 541139054,1701273972,1769366816,1986096245,1696624486, 544499813,
     * 539451233,1953459551,1936290917,1600416115,1869767781,1918855026,
     *1869967399, 544109933,1650815520,1868963937,1847615860,1869422624,
     *        -3, 543780452,1768120692,1702043767,1751479400,1701978228,
     *1751217184,1635020653, 543781664,1885434484, 544171552,1629513586,
     *1869967392,1684632431,1919182194,1701060719,1986359840,1629516665,
     *1835885940,1920540704,        -3, 543517797,1835363956, 773866344,
     *1701014304,2003330420,1751478816,1952999795, 544105831,1635019126,
     *1696625513,1735270497,1936943463,1852663150,1948279152,1886153061,
     *1932402720,        -3,        -1, 589315646,1042306149,1936990327,
     *1751479400,1701978211,1701737586,1697476454, 761754209,1986622585,
     * 544171552,1629516389,1936286837,1696622963, 544696692,1751739936,
     *1952998688,1970170228,1667591276, 543321976,        -3,1597454640,
     * 538976288, 807411744, 540155936, 538980896, 874531104, 538980384,
     * 807415840, 824188960,        -3,1130720884,1919230063,1713391474,
     *1635150196,2032168559,1948276585,1952999790, 542469737,1948271461,
     *1819032096,1382380388, 773857315, 539248928,1315927141,        -3,
     *        -2, 542469740,1702064928,1718579744,1629513583,1868832882,
     *1700885359,1848385645,1869374819,1970037106, 544436325,1667851635,
     * 544434287,1970037792,1650794612,1918987891,1718579821,1701060640,
     *        -3, 539517561, 544438637,1835365490,2032165230,1680830322,
     * 544502369,1853058145,1953066862, 689992559, 544499809,1948284008,
     *1701409312,1667591796,1919251232,1868963943,1918989929,1954095136,
     *        -3, 543257189, 543386735,1936007284,1864396658, 544696692,
     *1751739936,1952998688,1970170228, 761488748,1814061679,1970168947,
     * 773870696,1769152617,1931501856,1937011305,1668554866,1970038048,
     *1718579744,1952998688,        -3, 544039273,1847620464,1701013861,
     *1932402756,1702259041,1953066862,1931503218,1869422708,1751741216,
     *1734700645,1918987296,1920298085, 543257189, 543584114, 544435553,
     *1819043186, 543253604,1769236847,1851878432,        -3, 544436325,
     *1667851635, 544696421,1847620197,1818588769,1853104230,1869750377,
     *1853121906,1836018789,1668639841,1914726766,1952805473,1668573551,
     *1853038711,1769236512,1952998688,1835100526, 544436325,1667851635,
     * 773857312,        -1, 589315646,1042301800,1701014304,1952998688,
     *1633842031,1819636837, 543387502,1718183797,1918989417,1869488239,
     *1713398632,1769103724, 543257711,1830840686, 542338920,1852009317,
     * 544436321,1667575143,1919907184,        -3,1597454641, 538976288,
     * 807411744, 540024864, 538980384, 874531104, 538980384, 807415840,
     * 824188960,        -3,1299145829,1814063201,1931494248,1769103724,
     *1769240864,1635000356,1092624424,1399810158,1667982624,1399867250,
     * 689971236,1109415525,1919510137,        -3,        -2, 541139060,
     *1701737569,1953068645, 539513391,1395204193,1936943463,1852663150,
     *1948281203, 543453038,1696624494, 544499813, 543318387,1769152623,
     *1713402984,1696622437,1869440372,1919509345,1814061422,1679826976,
     *        -3, 543257711,1830843513,1885675620,1635016992,1768824948,
     *1751457859,1229336096,1092641647,1920099683,1948279155,1936287598,
     *1835363956, 543450480,1701733491, 544173600,1952998688,1634494319,
     *1919513704,1830821920,        -3, 544568165,1679848559, 543257972,
     *1869439348,1768120684,1819877476,1702126947,1948279919,1969384549/
     * )
      ICK( 46201: 46500) = (/
     * 543256164, 544502377,1886151968,1651469924,1932402758,1869750388,
     *1751217184,1919246707,1869488233,1948281203,        -3, 543780208,
     *1869771873,1853104244,1751217184,1952998688,1836018789,1668639845,
     * 543781664,1668246896,1818588261, 539519278,1697521761,1819025512,
     *2036626031,1734700576,1635020653,1931506536,1869966436, 543319328,
     *        -3, 543780451,1819632741,1680420384,1231954019,1634952480,
     *1868963937, 543385705,1918987296,1836018789,1668639845, 543780384,
     *1629512549,1853125231, 762542445,1835365490,1768104051,1885430629,
     *1735552885,1881940073,1948262432, 543781664,1702064997,1853122913,
     *1814066280,1635000436,1751457891,1869574756,1768841588,1696625509,
     *1948284275,1701060705,1852055668,1751457889,1936944995,1767994469,
     *1679846767,1818583925,1818325536,        -3, 539512658,1413828649,
     * 543779948,1970500722,1635019119,1847615858,1696621423,1853057395,
     *1952804468, 773870696,1769152611,1634607202,1696626277,1919510121,
     *1701060706,2032165736,1701014377,1852252276,1751457824,        -3,
     * 543777893,1853122915,1634476147,1768386163, 544171552,1919249509,
     *1986096756, 544501618,1936289646, 543256167,1818587950, 542402661,
     * 543253107,1869378932,1696625524,1920295796,1970431264,1634956137,
     *1735290213,1853104160, 544434287,1970037792,1634497391, 543319328,
     *1668247155,1769174117,1853104247,1769236512,1952998688,1819244389,
     *1936990326,1634497893, 544171552,1952998688,1181507939,1797288033,
     *1918987621,1952805408,1634624559,1869750304, 543911535,2003705953,
     *1651732332,1970562336,1668247142,1768387954,1635019119,1848516640,
     *        -3,        -1, 589315646,1042301800,1701014304,1952998688,
     *1633841966, 543387502,1718183726, 544171552,1667787122,1634476129,
     *1953459488,1768824929, 544239468,1634869326,1869491539,1869114979,
     *1801789555,1885430629, 761754223,1970282528,1597454642, 538976288,
     * 807411744, 540024864, 538980384, 824199456, 538980384, 807415840,
     * 824188960,        -3,1299145829,1814063201,1931494248,1769103724,
     *1769240864,1635000356,1092624416, 676360044,1634869280,1399867250,
     * 689971236,1109415525,1919510137,        -3,        -2, 542402665,
     *1931506789,1936990305,1684304485,1936942451, 544499813, 543387502,
     *1936290676,1701733241, 544171552,1952998688,1633842031,1819636837,
     * 544437362,1969452149,1919230049,1936943463,1852663150,1948262432,
     *        -3, 539519278,1697521776,1869373810,1769240864,1702126382,
     * 689989998, 544108398, 761488750,1953656691,2037214565,1953655139,
     * 544437362,1969452149,1919251232,1768824947,1885430629, 543650415,
     *1970303776,        -3, 544499809,1948281198,1668052324,1696622957,
     *1886547824,1701978227,2037214565,1953659168,1869636978,1635019119,
     *1853038632,1697539886, 544041330,1919906336,1886151022,1702045998,
     *        -3, 541288549,1667965044,1751457832,1378833193, 543253107,
     *1869378932,1696621423,1852205415,1970430324,1768910368,1634956137,
     *1735290213,1853104239,1713402984,1769152609,1953459488,1634624544,
     *        -3, 544499813, 543387502,1936290676,1701733241, 544171552,
     *1952998688,1633842031,1819636837, 543387502,1718183797,1918989417,
     *1869488233,1836084329,1667855392,1768824948,1751457859,1229335908,
     *1635016992,        -3, 544696692,1746957416,1635000425,1847620712,
     *1696606031,1381254480, 656435564,1819636596,1918989417,1869491744,
     *        -3,        -1, 589315646,1042301800,1701014304,1952998688,
     *1633841966, 543387502,1718183726, 544171552,1667787122,1634476129/
     * )
      ICK( 46501: 46800) = (/
     *1953459488,1768824929, 543384942,1953656691,2037214565,1953655139,
     * 544436321,1667575143,1919907184,        -3,1597454643, 538976288,
     * 807411744, 540024864, 538980384, 874529056, 538980384, 807415840,
     * 824188960,        -3,1299145829,1814063201,1931494248,1769103724,
     *1769240864,1635000356,1092624416, 675505518,1953656608,1399867250,
     * 689971236,1109415525,1919510137,        -3,        -2, 542402665,
     *1931506789,1936990305,1684304485,1936942451, 544499813, 543780468,
     *1701998177,1814061935,1853057395,1952804451,2032168806, 544499813,
     * 543253107,1869378932,1696621423,1852205415,1970430324,1768910368,
     *        -3, 543257459,1768386157,1701737504,1868963949,1869374819,
     *1970038131, 543780384,1952998688,1919250543,1920230756, 543257465,
     *1835885940,1919509280,1970170228, 544171552,1952998688,1668247410,
     *1684631137,1952805676,        -3, 544499813, 544042860,1701016940,
     *1634869360,1919251301,1853120884,1768910451, 539518254,1731076175,
     *1381254480, 689987950,1679848552,1696621416,1701669219,1634476132,
     *1767991154,1634562862, 541288549,1667965044,1751457824, 539513391,
     *1395204193,1651732332,1970562336,1668247142,1768387954,1635019119,
     *1847615859,1936287598,1835363956, 544171552,1952999795, 543257711,
     *1830838638,1679848552,1696621423,1853057395,1952804451,2032168806,
     *        -3, 544499813, 543253107,1869378932,1696621423,1852205415,
     *1970430324,1768910368,1768779884,1768122740, 543780384,1952998688,
     *1128875565,1684108385, 544696692,1746957416,1635000425,1847620712,
     *1696606031,1381254480, 656416800, 543779948,1970500722,1635019119,
     *1848516640,        -3,        -1, 589315646,1042305637,1886351988,
     * 544499813, 543383916,1668639841,1952801824, 659972460,1701733221,
     * 541224814,1680285814,1634493806,1668882534,1869750381,1702125932,
     *1931485216,        -3,1597454644, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 824188960,        -3,
     *1415933556,1635019126,1696612975,1852055638,1634493806,1668882534,
     *1869750308,1092625474, 539893796,1176521070,1718558752,        -3,
     *        -2, 542402665,1931506789,1936990322,1701867378,1953702004,
     *1751457910,1634493806,1668882543,1713398126, 543257711,1830838643,
     * 544240229,1684628340,1701060706,2032170088,1696618081,1818586723,
     *1696604192,        -3, 541224814,1679838575,1684368430, 542336357,
     * 975183904,        -3, 541994565, 773866098,1702061344, 639651118,
     * 542058315,1701144166,1696606257, 960049449, 541156212,1629504370,
     *2037609518, 541209655, 740307257, 841822521, 925769760,        -3,
     * 541666884, 773866098,1870097952, 674377776, 841559584,1416127776,
     *1130915181,1768120684, 541224814,1679845742, 541683311,1919377774,
     *1768104003,1751477609,1937011321, 975183904,        -3, 538976288,
     * 538989672,1696612975,1852055638,1634493806,1667571789,1868850540,
     * 773869432,1718579812, 542469737,1986359923,1769240864,1349674355,
     *1932402720,        -3,        -2, 541945714,1696621944,1886153059,
     *1769218153,1852206880,1869488244,1751457891,1634493301,1818326121,
     *1869509408,1667329568,1650794607,1651794281,1852138528,1652105330,
     *1970171497,1852252276,1751457824,        -3, 543383916,1668639841,
     *1953066862,1931502968,1886153059,1769237625, 544696692,1746957416,
     *1696616524,1096044366, 544174196,1768910368,1114599012,1449225317,
     *1852007726,        -3,        -2, 542011252,1698308180,1751457909,
     *1852073330,1819896174,1730180200,1701802617, 543781664,1701671017/
     * )
      ICK( 46801: 47100) = (/
     *1919509345,1814061422,1679846761,1734898720,1852797984,1634758764,
     *2032170095, 544499813,        -3, 538976288, 538976355,1634952480,
     *1635000424,1634624544, 677719655, 773874536,1634887525,1679848304,
     *1701013861,1932078624,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750339, 761361519,1830841441,1650814067, 544174692,
     *1701995876,        -3,1597454645, 538980398, 807411760, 774905888,
     * 808333344, 874531104, 538980384, 807415840, 824188960,        -3,
     *1127039348,1869422697,1847608137,1176519535,1869767785,1851880549,
     * 541878643,1948274549,1949134694, 760440177,1969581667,1696607790,
     * 538977345, 542011252,1696604192,        -3,        -2, 541160559,
     *1836261481,1847620712,1696613193,1176527218,1696624239,1948280681,
     *1986358816,1768824940,1869048163,1634476143,1919182194, 539519278,
     *1697521731, 824975427, 840983924,1663969568,        -3, 542402661,
     * 544367971,1869442405,1852073316, 544240239,1667589237,1919230057,
     *1931506799, 544436082,1948284008,1696620916,1869422700,1769174048,
     *1768824947,1869440288,1819240297,1667329056,        -3, 544174692,
     *1701978210,1701212018,1696625768,1696622185,1851878432,1919247977,
     *1852140901,1853104227,2036558949,1932402720,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750351, 761361519,1830841441,
     *1650814067, 544174692,1701995876,        -3,1597454646, 538980398,
     * 807411762, 774905888, 841887776, 874531104, 538980384, 807415840,
     * 824188960,        -3,1328365940,1869422697,1847608137,1176519535,
     *1869767785,1851880549, 541878643,1948274549,1949134694, 760440177,
     *1969581667,1696607790, 538977345, 542011252,1696604192,        -3,
     *        -2, 541160559,1836261481,1847620712,1696613193,1176527218,
     *1696624239,1948280681,1986358816,1768824940,1869048163,1634476143,
     *1919182194, 539519278,1697521743, 824975439, 840983924,1663969568,
     *1416127776,        -3, 544367971,1869442405,1852073316, 544240239,
     *1667589237,1919230057,1931506799, 544436082,1948284008,1696620916,
     *1869422700,1769174048,1768824947,1869440288,1819240297,1667329056,
     *1869767781,1914724965,1718579813,        -3, 544499813, 543582574,
     *1634476146,1701210478,1701668206,1948279673,1668048243, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750350,
     * 761361519,1830841441,1650814067, 544174692,1701995876,        -3,
     *1597454647, 538980398, 807411762, 774905888, 841887776, 874531104,
     * 538980384, 807415840, 824188960,        -3,1311588724,1869422697,
     *1847608137,1176519535,1869767785,1851880549, 541878643,1948274549,
     *1949134694, 760440177,1969581667,1696607790, 538977345, 542011252,
     *1696604192,        -3,        -2, 541160559,1836261481,1847620712,
     *1696613193,1176527218,1696624239,1948280681,1986358816,1768824940,
     *1869048163,1634476143,1919182194, 539519278,1697521742, 824975438,
     * 840983924,1663969568,1416127776,        -3, 544367971,1869442405,
     *1852073316, 544240239,1667589237,1919230057,1931506799, 544436082,
     *1948284008,1696620916,1869422700,1769174048,1768824947,1869440288,
     *1819240297,1667329056,1869767781,1914724965,1718579813,        -3,
     * 544499813, 543582574,1634476146,1701210478,1701668206,1948279673,
     *1668048243, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750369,1819306081,1853189477,1919509280,1635020653,
     * 543973730,1701585001,1847616367,1869767785,1851880549, 544367971,
     *1869767712,        -3,1597454648, 538980398, 807411762, 774905888/
     * )
      ICK( 47101: 47400) = (/
     * 841887776, 874529056, 538980384, 807415840, 824188960,        -3,
     *1316318565,1919509280,1098149741, 541876578,1701585007,1847608175,
     *1869767785,1851880549, 542138738, 773870181,1668248164, 539897390,
     * 538977345, 541288549,1667964960,        -3,        -2, 541160559,
     *1830841441,1650814067, 543257189, 543647086,1701994860,1819877486,
     *1869881441, 544109933,1650815520, 677981797, 773878644,1634890857,
     *1852252279,1769236512,1869505824,1869750388,2003771424,        -3,
     * 543385697,1918985076,1701999392,1768842345,1667331177,1852252276,
     *1751457889,1953459488,1954115685, 690888780,1633838444,1931502433,
     *1847616101, 543519346,1869505903,1970498681, 544109933,1701996899,
     * 543454565,        -3, 544501536,1954115689,1852252261,1920102258,
     *1931487333, 778513952, 659519609,1734700583, 544504176,1701060705,
     *1931487098,1701998375, 690888736,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750369,1819306081,1853189477,1919509280,
     *1818321509,1814063470, 543451507,1886151011,1701668206,1948282977,
     *1918988897,1835365477,1914729061,1668248164,        -3,1597454649,
     * 538980398, 807411762, 774905888, 841887776, 874529056, 538980384,
     * 807415840, 824188960,        -3,1316318565,1919509280,1281450597,
     *1814065006, 541354355,1886151011,1701668206,1948274785,1915625554,
     *1701015410,1679830574, 774778414, 538977345, 541288549,1667964960,
     *        -3,        -2, 541160559,1830841441,1650814067, 543257189,
     * 543647086,1701994860,1819877486,1869881441, 544109933,1650815520,
     * 677981797, 773878644,1634890857,1852252279,1769236512,1869505824,
     *1869750388,2003771424,        -3, 543385697,1918985076,1701999392,
     *1768842345,1667331177,1852252276,1751457889,1953459488,1954115685,
     * 690888780,1633838444,1931502433,1847616101, 543519346,1869505903,
     *1970498681, 544109933,1701996899, 543454565,        -3, 544501536,
     *1954115689,1852252261,1920102258,1931487333, 778513952, 659519609,
     *1734700583, 544504176,1701060705,1931487098,1701998375, 690888736,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750383,
     *1970548079,1714253682,1684369952,1937337709,1702130297, 543449460,
     *1629495328,        -3,1597517872, 538980398, 807411760, 774905888,
     * 808333344, 874529056, 538980640, 807415840, 807411744,        -3,
     *1400466797,1702130297, 542339173,1667851881,1667331177,1869488211,
     *1752135020,1679839346,1701012836,1696613221,1819025476,1635017006,
     * 538976288, 542141541,1634952480,1148133664,        -3,        -2,
     * 542341485,1835365490,2032165985,1952522280,1764648238, 544436321,
     *1667571815,1919907184, 740324217,1835885940,1920540783,1885696609,
     *1953066862,1931502964,1663969568,1634886944,1702391909,1668572516,
     * 544501536,1650794528, 543648118,1701716073,1847620712,1696613193,
     *1176531058,1768911392,1953439860,1751457891,1701604384,1684630885,
     *1853057391,1853038689,1852055651,1869574756,1768841588,1696621665,
     *1952525856,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750381,1769173865,1852255264,1768842095,1836084325,1952784495,
     *1914728309,1949134694, 762278500,1701978179,1701604384,1684108385,
     *        -3,1597517873, 538980398, 807411760, 774905888, 808333344,
     * 874529056, 538980640, 807415840, 807411744,        -3,1130720364,
     * 541352308,1629506921,1936943470,1730945097,1852010349,1886152052,
     *1696624498, 542078324, 762275373,1332896869,1914711598, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2/
     * )
      ICK( 47401: 47700) = (/
     * 542133313,1414483503,1130915171,1799571782, 543711603, 543236208,
     *1919902316,1701650551,1769236512,1952998688,1130720364, 543449460,
     *1630412865, 544239475,1936286316,1696625253,1634955118, 543383918,
     * 543319328,        -3, 544499809,1948284008,1696621413,1819025508,
     *1635016992,1634886944,1835627379,1768843052, 543780451,1869443180,
     *1702126880,1869750383,1970548079,1714254693,1903519086,1667575328,
     *        -3, 542133313,1414483503,1130915171,1799571782, 544696691,
     *1751479072,1953439845,1852010357,1853121906, 544499813, 543384940,
     *1814061422,1679848313,1835885940,1920540772,1635016992,1650812527,
     *1919230049,1853431840,        -3, 543387503,1919183214,1635018099,
     * 543257189, 543648118,1701719584,1347174740,1330520165,2020631907,
     *1953702004,1751457910,1634497893,1931505510, 543255660, 544434552,
     * 543384940,1814065249,1918987621,1952805491, 773857312,        -1,
     * 589315646,1042306149,1936990310,1869750377,1852863860, 543975790,
     *1702043756,1869506405,1914729576,1634607160, 807428968,1634885987,
     *1952805491,        -3,1597517874, 538976288, 807411744, 825237536,
     * 540094496, 874531104, 538980384, 807415840, 824188960,        -3,
     *1128875552,1231974517,1948275301,1668248164, 678635808,2003399784,
     * 544042866,1696625768,1634607160, 807420776,1634885987,1952805491,
     * 539248928,1231971951,        -3,        -2, 542402661, 541280582,
     * 543387502,1952541038,1931506277,1668248164,1931504751,1852269938,
     * 544499809,1847605296, 543385697,1918985076,1701999406, 542011252,
     * 543255660, 544436070,1953980786,1696626537,1819025440,        -3,
     * 544367969,1679843941,2037345892, 543387500,1970105888, 942681632,
     *1416127776,1128875565, 825110816,1684366953,1852404841,1869488243,
     *1885692777,1718183283, 543236205,1635281261,1970085999,1713386032,
     * 876093472,        -3, 543385697,1918985076,1701978224,1701978226,
     *1701015410,1680744480,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750380,1869574176,1886547810,1818586400,1768824899,
     *1229335922,1700881440,        -3,1597517875, 538980398, 807411760,
     * 774905888, 808333344, 824197408, 538980384, 807415840, 824188960,
     *        -3,1282371440, 542143087,1651271021, 543780384,1128875565,
     *1382375780,1768843040, 676622191, 541942126,2032168047,1869619273,
     *1952804211, 689971232, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541483380,1634476112,1919902316,1701657120,
     *1130915171,1797287023,1869619300,1635016992,1851878757,1931501934,
     *1679844449,1952522342,1869750373,1920102258,1932402772,1751478885,
     * 543257189, 543975787,1701607712,        -3, 544501615, 544039278,
     *2032168818, 544501536,1717925664,1684108385, 543780384,1952998688,
     *1819242352, 773857312,        -3,        -1, 589315646,1042305637,
     *1886351988, 544173600,1095914797,1348559723, 544240239,1651271021,
     * 678635808,1768824912,1279349839,1310728224,        -3,1597517876,
     * 538976288, 807411744, 540090400, 538980640, 891308320, 538980384,
     * 807415840, 824188960,        -3,1316318562,1701978223,1713389906,
     *1429029743,1684349008,1633905513,1852252240,1919902316,1701652595,
     * 689989998, 542133313,1414483488, 539248928,1231971951,        -3,
     *        -2, 542143087,1651271021, 975192402,1428189797,1886545267,
     *1701737569,1953066862,1931506805,1919819887,1970544756,1864393317,
     * 544105829,1684366368,1869968499,1768187168,1952998688,1330795589,
     *1344303988,2037146912,        -3, 539833658, 891319662,1769221475/
     * )
      ICK( 47701: 48000) = (/
     *1701604384,1953653102,1936482676,1768910368,1918987879,1697521748,
     *1751457857,1851878521,1936290592,1835624296,1948279397, 543780451,
     *1869443180,1702126894, 542402661,        -3, 544240239,1651271021,
     * 544171636,1701716079,1667462514,1931503215,1914729332,1920295796,
     *1970431347, 544696692,1746952556,1768974433,1953063712,1667785065,
     *1853038707,1953654132,1667787118,1730178934,1701978144,        -3,
     * 544039278,2032170350,1769235301,1819046688,1869750382,1702131567,
     *1919623283,1953658211,1953854053,1932402772,1918987891,1718579821,
     *1635019119,1847619430, 544499813, 544566889,1952671084,1814061935,
     *1853121902,1948262432, 544501536,1629516665,1835885940,1920540786,
     *1701601652,1701060720,1869834612,1768910368,1835624296,1948283759,
     *1819698464,1952998688,1886547810,1818586414,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750377,1853060454,1718182761,
     *1701737504,1668247410,1684631137,1952784484,1635016992,1768824899,
     *1229332588,1869574176,        -3,1597517877, 538976288, 807411744,
     * 540024864, 538980384, 824197408, 538980384, 807415840, 824188960,
     *        -3,1180791905,1814057074,1868721253,1832525897,1853060454,
     *1718182761,1701737504,1147237473, 543780384,1098149741, 541880175,
     *1881157166, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541288549,1667964995,1869574756,1768841588,
     *1696613473,1952522316,1869574176,1718579744,1835627379,1768843040,
     *1701737586,1768256302,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750377,1853060454,1718182761,1701737504,1428711724,
     *1781080164,1635016992,1768824899,1229332588,1869574176,        -3,
     *1597517878, 538976288, 807411744, 540155936, 538980896, 874529056,
     * 538980640, 807415840, 824188960,        -3,1180791905,1814057074,
     *1868721253,1832525897,1853060454,1718182761,1701737504,1147237473,
     * 543780384,1430866464,1282371440, 539897390, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 541288549,
     *1667965013,1229594692,1635016992,1282371440, 543584114, 544041331,
     *1936289383, 543518324,1919509875, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750381,1635281261,1970085998,
     *1970102885,1914728294, 543257711,1836261477,2019779941,1684366368,
     *1886547810,1818586400,        -3,1597517879, 538976288, 807411744,
     * 540024864, 825241632, 891306272, 538980384, 807415840, 824188960,
     *        -3,1180791905,1814057074,1868721253,1832525901,1635281261,
     *1970085966,1970102885,1914728294, 541160559,1836261445,2019779941,
     *1684366382, 538976288, 538976288, 538976544,1231971951,        -3,
     *        -2, 542133313,1414483488,1667329568,1751215716,1818566773,
     *1881175151, 539446864, 824647785,1847620712,1696606309,2020630894,
     *1684366377, 541152335,1293970537,1936993824,1416128883, 544041319,
     *1752440936,1634758757,1847599136, 544696692,1746953321,1936683620,
     *1701995876, 544174624,1852142711,1869769504,1937011317,1668576626,
     *1702043753,1847617641,1734877299,2037214565,1953659168,1936744803,
     *1696622450,1869967475, 773866597,1818588265,1869488160, 544171552,
     *1952998688,1937337709,1702130297, 543780454,1869770081,1953066862,
     * 544041319,1752440947,1869379173, 544235890,1948282726, 544499813,
     * 544240239,1651271021, 543256164, 544240239,1986618469, 543236128,
     *        -3, 544235890,1953063276, 544629100,1768186228,1768910382,
     * 541158516,1701998177,1953068645,1819880480,1668049251,1802071655/
     * )
      ICK( 48001: 48300) = (/
     * 544173600, 659443539,1498238247, 544173600,1952998688,1347174740,
     *1330520173,1701737760,        -3, 543319398,1869767968,1768846959,
     *1802071655, 544629100,1768186228,1768910368,1835624296,1948279140,
     *1685218675,1931506792,1696624754,1868721253,1831739424,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750384,1634890597,
     *1633840229, 542328901,1280855072,1937013100,1696626533,1768384628,
     *1768843040,1935894629,1835343904,        -3,1597517880, 538976288,
     * 807411744, 540024864, 538980384, 891306272, 538980384, 807415840,
     * 824188960,        -3,1315905616,1634890597,1633840229, 542328901,
     *1280855072,1400142188,1696618341,1768384628,1768843040,1399023717,
     *1835343942,1869966948, 538976288, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 542402661, 544629100,1768186228,
     *1768910368,1936680564,2002874981, 543451492, 544108404, 544437603,
     *1667589476, 543780384,1718185572,1768843055,1634623852,2038065518,
     *1730175264,1885434483,1633840229,        -3, 544695657,1734898793,
     *1852252275,1667786093,1697521696,1397245260,1481384051,1954114661,
     * 544695657,1734898720,1885434465,1835365477,1920147553,1919230053,
     *2020631907,1952801824,1953439842,1696622441,1986358816,1768824864,
     * 544499813, 543584114,1835103290,        -3,        -2, 543126117,
     *1718185573,1600942943,2003134823,1752459630,1734304869,1952541036,
     *1931485216,        -3, 539452257,1818435703,1026633563,1551064626,
     *1579697775,1580359209, 724054062, 825241648,1344888370,1579888686,
     * 808464432,1348280439,1751478885, 542129448,1181703730,1579889222,
     *1667117662, 690959143,        -3,        -2, 541737294,1092645748,
     *2037146912,2003134823,1752440937,1931502968,1885692788,1701060724,
     *1864393317, 543648118,1701716073,1847620712,1696622191,1919770996,
     * 975183904,        -3,        -2, 543126117,1718185573,1600942943,
     *2003134823,1752459630,1734304869,1952541036,1931487095,1026633512,
     *1551064626,1579698473, 724577840, 808531529,1580359209, 656416800,
     *        -3,        -2,        -2, 538985583, 544108404, 543515753,
     *1948284008,1769152627,1953655150,1730178930, 544039275,1696622964,
     * 543780468,1864392992,1952807028, 543321199,1667965026,1702131557,
     *1701716007, 992423456,        -3,        -1, 589315646,1042305637,
     *1886351988, 544173600,1885434483,1768843040,1886547810,1818586400,
     *1868963923,1212501080,1277195124,2037146912,2003134823,1752459630,
     *1730179939,1751477605,        -3,1597517881, 538976288, 807411744,
     * 540024864, 538980384, 824197408, 538980384, 807415840, 824188960,
     *        -3,1130458656,1852797984,1348563571,1696625768,1696617288,
     *1162631244, 542598505,1734898793,1852252243,1667786093,1696617332,
     *1919512167, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 542402661, 544436070,1953980786,1696621673,
     *1679847023,1948283765,1667458405,1679845742, 542138738,1936289383,
     * 544499813, 542328901,1280855072,1937013100,1696626533,1768384628,
     *1768843040,1935894629,1835347488,        -3, 542402661, 544437362,
     *1768843040,1835624296,1948280929,1986338914,1701146144,1701079412,
     *1701060719,1914728294, 544499813, 544042866,1696625768,1634607154,
     * 544235890,1634559348,1701978230,1634888037,1954095136,        -3,
     * 539521893,1696617288,1162631244, 544039278,1969318953, 773857312,
     *        -3,        -1, 589315646,1042305637,1886351988, 542078324,
     * 762275373,1298492783,1920540784,1919902316,1701650537,1847611468/
     * )
      ICK( 48301: 48600) = (/
     *1096044366,        -3,1597518128, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 824188960,        -3,
     *1333097517,1868967245,1701670770,2032160882,1868721253,1830840686,
     * 542133313,1414483503,1095981389, 539897390, 774778414, 774778414,
     * 538976288, 538976288, 538976544,1231971951,        -3,        -2,
     * 541159009,1819898729,1931503215,1914727785,1936943470,1730179685,
     *1718379875,1953066862,1931504993,2032165477, 543780451,1869443180,
     *1702126880,1685415200,1953439841,1847619445,1949134694, 762144109,
     *1869773088,        -3, 544240239,1651271021, 773857312,        -3,
     *        -1, 589315646,1042305637,1886351988, 544173600,1852776513,
     *1145328473,1293967726,1634498931,1769152613,2019910517,1952801824,
     *1718579744,1953460000,1835101817, 543451507,1869767781,1919247392,
     *1635020653,1931502433,1936007200,1597518129, 538976288, 807411744,
     * 540155936, 538980896, 891306272, 538980384, 807415840, 824188960,
     *        -3,1315905601,1145328473,1293959534,1634498931,1769159200,
     *1416589088,1298230905, 541423715,1819632741,1679835508,1869443872,
     * 774778414, 538976288, 538976288, 538976544,1231971951,        -3,
     *        -2, 542402661, 541148228,1398361376,1952805748, 543584114,
     * 544041331,1936024608,1937337709,1702130297, 543781664,1852797984,
     *1702389091,1970562404, 543584114, 544437362,1969452149,1919251232,
     *2003399784, 544501615,        -3, 544039278,2032165993,1936683620,
     *1701995876, 543257711,1836264992,        -3,        -1, 589315646,
     *1042305637,1886351988, 543584114, 543255657,1634952563, 544175717,
     *1919315055,1998614642,1868721253,1830840686, 542133313,1414483488,
     *        -3,1597518130, 538976288, 807411744, 540024864, 538980896,
     * 891306272, 538980384, 807415840, 824188960,        -3,1347174740,
     *1330520176,1919902316,1701650477, 542404463, 541942126,2032157036,
     *1767994213,1679835508,1869443886, 541942136, 540876832, 539248928,
     *        -3,        -2, 542011246, 762541153,1852072306,1679846497,
     *1650814067, 543257189, 543255657,1634952548, 543780468,1864393059,
     *1667592308,1633840229, 543973730,1701606190, 542402661, 544039288,
     *1768781165, 544109933,1650815520,        -3, 544171552,1634494817,
     *1936028448,1769152626,1700881256,1701064224,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750377,1853060454,1718182761,
     *1701737504,1684108385, 544173600,1212894278, 544367971,1869767712,
     *1768824948,1751457859,1229332512,        -3,1597518131, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 807415840,
     * 824188960,        -3,1315905614,1970103666,1768120684, 541352308,
     *1629514094, 541608780,1176512558,1919251241, 542270819,1869767712,
     *1768824899,1229332526, 538976288, 542141541,1634952480,1130915171,
     *1797267488,        -3,        -2, 541288549,1667965044,1751457864,
     *1263289888,1919247215,1919164521,1847620712,1696617288,1162631244,
     * 544437369,1818566702,1919251232,1769152613,1835165028,1684366368,
     *1768824948,1751457859,1229336096,        -3, 542402665,1931506277,
     *1668248164, 544434287,1970037792,1936224119, 543517044,1751478816,
     * 659049292,1176515623, 544174624, 659049292,1176515879, 773870696,
     *1696622958,1718579821,1635019119,1847617902, 544499817,1931485216,
     * 544367971,1869767712,1769152629,1936024608,1953439845,1937006946,
     *1818850152, 544499809,1948279072,1953982830,1852403303, 544042852,
     *1701585015,1634934898,1701210478,1701064224,        -3,        -1/
     * )
      ICK( 48601: 48900) = (/
     * 589315646,1042306149,1936990310,1869750312,1768827235,1869442405,
     *1853060466,1635018016,1937011317,1668576626,1696621153,1936024608,
     *1128875552,        -3,1597518132, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 824188960,        -3,
     *1315905622,1634494820,1635019119,1847619430, 539511150, 694382445,
     *1835363955,1970430324,1696617332,1920295796,1970431264,1128875635,
     * 538976288, 538976288, 538976288,1315927141,        -3,        -2,
     * 542133313,1414483503,1130915171,1799571782, 543383918, 544108404,
     * 544629100,1768186228,1696625768,1696613193,1181950049,1936944995,
     *1767994469,1679849321,1952981032,1768827235,1869442405,1853060466,
     *1635018016,        -3, 544437362,1969452149,1919230066,1701867378,
     *1953705504,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750382,1970102885,1914728294, 544239472,1970037108,1768910368,
     *1885434465,1835365477,1914728310,1701996140,1870078057,1847611468,
     *1096044366,        -3,1597518133, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 824188960,        -3,
     *1347174740,1330520137,1936946533, 975196271,1886743649,1953066862,
     * 542138738,1634559348,1701978191,1986359910,1819244320, 774778414,
     * 538976288, 538976288, 538976288,1180791905,1814044704,        -3,
     *        -2, 542133313,1414483503,1667786083,1799571782, 543781664,
     *1668641394,1701737580,2032165993,1835363955,1768910437,1679844975,
     *1914729840, 544501536, 842347808,1886351477,1818326121,1869488240,
     *1634885997,1702126962,1932402720, 542141541,1634952480,1668247156,
     *1633907744,1952998688,1635087464,1869750369,1948279086,1814983536,
     *1701527669,1965977196,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750374,1768841580, 544367974,1768842605,1701737504,
     *2003399784, 543450484,2003398254,1701060647,1212894278, 540288800,
     *1684108385,        -3,1597518134, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 824188960,        -3,
     *1281977189,1819877446,1768841580, 542270822,1768842605,1701737504,
     *2003399784, 541353332,2003398254,1701060676,1635016992, 774778414,
     * 538977345, 541288549,1667964960,        -3,        -2, 542402661,
     * 541280582, 543780451,1819632741,1931501856,1819242352, 544696692,
     *1746957431,1768824941,1635021417,1667593006, 542402661, 543518050,
     *1701078117,1679830642,1702043750,1768711456,1752135525,1986359840,
     *        -3, 544239465,1853125408,1953439841, 541608780,1176515616,
     *1718185061, 544696692,1746955369,1801809017, 543450484,2003398254,
     *1701060713,1853121902,1936290921,1702047264,        -3,        -1,
     * 589315646,1042305637,1886351988, 544367969,1679847538,1868721253,
     *1830840686, 542133313,1414483488,1667786083,1799571782, 544370549,
     *1953066597,        -3,1597518384, 538976288, 807411744, 540024864,
     * 538980384, 891306272, 538980384, 807415840, 824188960,        -3,
     *1231975525,1919836524, 542133313,1414483488,1382375780, 542143087,
     *1651271021, 544696692,1746944332,1163023392,1316318562,1701978158,
     * 538977345,        -3,        -2, 541683316,1701998177,1814057036,
     *1096044366, 542143087,1651271021, 773869676,1700885349, 544367974,
     *1701978224,1919902316,1701650548,1864393077,1953001330, 543257632,
     *1630432302,1936745835,1081439534,1852579872,        -3,        -1,
     * 589315646,1042301800,1701014304,1718579744,1852139361,1953068645,
     * 542130514,1411412581,1668248164, 678635808,1768824899,1229335909/
     * )
      ICK( 48901: 49200) = (/
     *1835165028,1684366368, 779249011, 543582572,1696604192,        -3,
     *1597518386, 538976288, 807411744, 540024864, 538980384, 874529056,
     * 538980384, 807415840, 824188960,        -3,1128875565,1701667429,
     *1684301156, 539914853,1931494255,1853120873,1853038670,1701273972,
     *1769366816,1346458196, 542012781,1650815603, 539248928,1130915171,
     *1797267488,        -3,        -2, 542141541,1634952480,1667786083,
     *1797289064,1696626273,1818846313,1954095215,1713402984,1696624229,
     *1734440041,1986338896,1095914528,1853189474,1701999392,1768824948,
     *1751457859,1229335909,1835165028,1684366368,        -3, 542328901,
     *1280855072, 779249011, 543582572,1697521748,1751476594, 544568165,
     * 544039289, 544170611,1668641381, 543451507,1869767781,1914727791,
     *1684368416,1701999215,1920151072,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750338,1095976495,1415006542, 544240239,
     *1651271021, 543780384,1397245260,1481383968,        -3,1597519152,
     * 538980398, 807411762, 774905888, 841887776, 874529056, 538980384,
     * 807415840, 824188960,        -3,1130915171,1797277292,1633905440,
     *1348563553,1835365477,1914717560,1633907744,1449225333,1696608302,
     * 808460407,1769236512,1932424494, 539248160,1130915171,1797267488,
     *        -3,        -2, 542402665,1931495263,1095517522,1411408737,
     *1847616101, 543778670,1869768036, 543780384,1952998688,1667330917,
     * 544499809,1948284008,1696625519, 761487724,1818584096, 661614125,
     *1952998701,1667786081,1881612320,        -3, 541486177,1667965040,
     *1634885997,1702126962, 543781664,1919250543,1920230756, 543257376,
     *1684370533,1919773038,1701060727,1769236512,1397245260,1481387552,
     *        -3,        -2, 541423713,1668574329, 544892274,1864398433,
     *1819633011, 543257189, 544239475,1936286316,1696621173,1948282209,
     *2032165228,1936662626,1696620832,1936680564,2002874981, 543257204,
     *1701208419,1949179936,        -3,        -2, 542402661, 543584108,
     *1819244393,1852252275,1752135020,1679843941, 543385701,1667982692,
     * 975183904,        -3,        -2, 542143087,1651271021, 539177274,
     * 542338925,1696617288,1162631244, 959914102,1701999465,1869509408,
     *1685004398,1869881441,1819045751, 544105831,1635019126,1696626273,
     *1819633011, 544171552,1952998688,        -3, 541486177,1667965040,
     *1634885997,1702126962, 544696421,1847616613,1952805485,1768842596,
     * 544568169,1852252276,1751457858,1095976495,1415006542, 543780467,
     *1953658211,1953066862,1932402720,        -3, 542008679,1635019126,
     *1696626273,1819633011, 543257189, 544433524, 544501536, 808333360,
     * 808464686, 542270822,1768842605,1701737504,1835104544,1852797984,
     *1668247158,1701996389, 543387501,1886152052,1701607726,        -3,
     * 542143087,1651271021, 539177530, 542338925,1696617288,1162631244,
     * 959914102,1701999465,1869509408,1886745632,1835360622,1768843116,
     *1702064928,1986096245,1702043753,1847620712,1696613193,1176528495,
     *1914729576,1696604192, 541486177,1667965040,1634885997,1702126962,
     * 544696421,1847600980,1464421920, 758194224, 540024880, 539832608,
     * 807415840, 807415089, 540155951, 541213011,1176969321,1853060210,
     *1969452137,1869509408, 677981797, 773857312, 543256096,1702391916,
     *1768122740, 544039284,1919514656,1769152627,1885692777,1718183268,
     * 544173600,1952998688,1415006542, 543780467,1953658211,1953066862,
     * 689987954,1696626035,1701064224,        -3, 542141541,1634952480,
     *1667786083,1797289064,1696626273,1819632928,1868963906,1095976480/
     * )
      ICK( 49201: 49500) = (/
     * 677998112,1952998688,1818850164, 544175476,1886745641, 538992999,
     *1634299507,1948284008,1696613996,1633905440,        -3, 544235890,
     *1634559348,1701978217,1847620712,1696613193,1177427977,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750386,1702065266,
     *1634299508,1931502181,1768843040,1970496868, 543780384,1919247977,
     *1852140901,1853104160,        -3,1597519408, 538976288, 807411744,
     * 540024864, 538980384, 857753888, 538980384, 807416096, 807411744,
     *        -3,1316318562,1701978223,1713392741,1634956333,1399944545,
     *1919251232,1382380404,1918986606,1953701934, 774778414, 774778414,
     * 774778414, 539248928,1315927141,        -3,        -2, 542402661,
     * 544568165, 544171552,1919251316,1918986606,1953702005,1936024608,
     *1768824948,1751457906,1701210478,1701668206,1948283752,1869966436,
     * 543319328,1702391916,1634299493,1679845742,        -3, 544499813,
     * 544698985,1952787829,1881173862, 543236211,1953658211,1953854053,
     * 543256161,1819898729,1932402720,        -3,        -2, 541684768,
     *1769152609,1819504416,1919247215,1835885934,1684366368,1953439849,
     *1852009589,1684349044,1751457906,1701210478,1701668206,1948281198,
     *1937011317,1668573551,1853038697,1847620712,1696604192,        -3,
     * 541280582, 539518254,1731076212,1751457894,1768841580, 539914853,
     *1931505510, 543236179,1212501080,1277194853,1718185573,1835363956,
     * 689987955, 543236195,1869442405,1853110816,        -3, 543123829,
     *1668439922,1701210478,1700751726,1937011317,1668573551,1853054820,
     *1702125929,1819484192,        -3, 540745760,        -3, 542394708,
     *1277173792,        -3, 539897376,        -3, 539518324,1663969568,
     *        -3, 540745760,        -3,        -2, 542011252,1698308161,
     *1847616888,1667592308,1768910368,1634886944,1919251316,1918986606,
     *1953701990,1869750374,1819238772,1768843040,1869769063,1768846112,
     * 677719655, 773876078, 542126641, 690888736,        -3,        -1,
     * 589315646,1042304623,1953064569, 544499813, 544437616,1886545267,
     *1936289646, 544171552,1332503928, 841965427,1836343928,1601003891,
     *1802707058,1701601652,1701060673,1279611476,1394614304,        -3,
     *1597519416, 538976288, 807411744, 540024864, 538980384, 874529056,
     * 538980384, 807415840, 824188960,        -3,1095517522,1414733892,
     *1969561716,1864397928,1696617843,1696624486, 543126381,1952610399,
     *1835103083,1931498357,1886417509,1936942436, 538976288, 538976288,
     * 538976544,1231971951,        -3,        -2, 541150277,1381258016,
     *1919249505,1952801824,1953439860,1751457909,1936007279,1713393516,
     *1702375983,1601400180,1652055917,1634954099, 544499809,1948279649,
     *1847619183,1948264569,1702111520,1650794528,        -3, 543253347,
     *1869966964,1701060710,1869750369,1931505761,1920213103,1713402984,
     *1696618049,1279870017,1414090574, 543255655,1869769076,1752003360,
     *1751217765, 543319397,1847620469,1886417509,1936942436, 773857312,
     *        -3,        -1, 589315646,1042304623,1953064569, 544499813,
     * 544437616,1886545267,1936289646, 544171552,1397839173,1163543840,
     *1919249505,1952801824,1095517522,1414733856,        -3,1597519417,
     * 538976288, 807411744, 540024864, 538980384, 874529056, 538980384,
     * 807415840, 824188960,        -3,1095517522,1414733906,1701601652,
     *1701060724,1864397928,1696617843,1696624486, 542331221,1162172997,
     * 538989429,1886417509,1936942436, 538976288, 538976288, 538976544,
     *1231971951,        -3,        -2, 541150277,1381258016,1919249505/
     * )
      ICK( 49501: 49800) = (/
     *1952801824,1953439860,1751457909,1936007279,1713393740,1096044366,
     * 793989461,1162172997, 544499809,1948279649,1847619183,1948264569,
     *1702111520,1650794593,1667460981,1853121892,        -3, 543584114,
     * 543257376,1885434484, 544171552,1952998688,1447119945,1145132105,
     *1330520161,1818718066,1769236589,1931503713,1986338914,1701146144,
     *1937076336,1919251315,1701064224,        -3,        -1, 589315646,
     *1042305637,1886351988, 544499813, 544437616,1886545267,1936289646,
     * 544171552,1936682341, 544503657,1852729710,1730179685,1818326117,
     *1679835468,1163023443,        -3,1597519664, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3,1095517522,1414733906,1701601652,1701060724,1864389751,
     *1768844905,1852252229,1717986659,1953701971,1970303090,1702064997,
     *1679830574, 538976288, 538976288, 538976544,1231971951,        -3,
     *        -2, 541150277,1381258016,1919249505,1952801824,1953439860,
     *2003398254,1768843040,1701209701,1668576032,1952997748, 543383918,
     * 544108404, 539523429,1948852322,1696620899,1668248942,1952801824,
     *        -3, 543584114, 543257376,1885434484, 544171552,1952998688,
     *1447119945,1145132105,1330520161,1818718066,1769236589,1931503713,
     *1986338914,1701146144,1937076336,1919251315,1701064224,        -3,
     *        -1, 589315646,1042305637,1886351988, 544499813, 544437616,
     *1886545267,1936289646, 544171552,1936682341, 541876597,1696625765,
     *1667788393,1903519008,1919249505,1952801824,1095517522,1414733856,
     *        -3,1597519665, 538976288, 807411744, 540024864, 538980384,
     * 874529056, 538980384, 807415840, 824188960,        -3,1281455461,
     * 542401891,1752066417,1969561682,1701601652,1701060673,1279611476,
     *1394631026,1696617333,1886417509,1936942436, 539897390, 538976288,
     * 538976288, 538976544,1231971951,        -3,        -2, 541150277,
     *1381258016,1919249505,1952801824,1953439860,1751457909,1936007279,
     *1713402984,1696615521,1969561716,1701013614,1769043301, 544696692,
     *1746952480,2002876005,1818586727,1952981106,1634625381, 543711606,
     *1696604192, 543319397,1847620469,1886417509,1936942436, 773857312,
     *        -3,        -1, 589315646,1042305637,1886351988, 544499813,
     * 544437616,1886545267,1936289646, 544171552,1634625633,1919774574,
     *1768104050,1701210478,1701668206,1948283493,1818326117,1679835468,
     *1163023443,        -3,1597519666, 538976288, 807411744, 540024864,
     * 538980384, 874529056, 538980384, 807415840, 824188960,        -3,
     *1095517522,1414733906,1701601652,1701060724,1864384878,1751216749,
     *1869506915, 542270822,1768842528, 538989429,1886417509,1936942436,
     * 538976288, 538976288, 538976544,1231971951,        -3,        -2,
     * 541150277,1381258016,1919249505,1952801824,1953439841,1852334450,
     *1836019305,1663070821,1718185573,1835363956, 543711606,1696621157,
     *1701716083,1970303090,1702064997,1680744532,1751741216,1734700645,
     *1918987372,2032148512, 543387502,1667592814,1931499588, 543256164,
     * 544436077,1696616268,1163407904,1919247977,1852140901,1853104226,
     *1634952548, 541280582, 661859872,1231975525,1919836524,1819877475,
     *1634493301,1818326117,1679826976,        -3, 544437362,1969452149,
     *1919230054,1633907823,1920147553,1919230050,1634952548, 544173600,
     *1952998688,1919250543,1920230756, 543711602,1836019305,1663067241,
     *1936747617,1667591525,1853104240,1634885997,1702126962,1931485216,
     * 544173676,2033066016,        -3,        -1, 589315646,1042305637/
     * )
      ICK( 49801: 50100) = (/
     *1886351988, 544041331,1936289383, 543449460,1970085990,1869750367,
     *1684629094,1919836018,1701211246,1935634037,1835165042,        -3,
     *1597519920, 538976288, 807411744, 540024864, 538980384, 824197408,
     * 538980640, 807415840, 807411744,        -3,1315905636,1635022189,
     * 543584114, 543122537,1717989998,1601332582,1819177823,1853189474,
     *1701978227,1970303084,1768252448, 774778414, 538976288, 542141541,
     *1634952480,1148133409,        -3,        -2, 542402661, 544501620,
     *1634476142,1970102885,1914728294, 544040289,1937076837,1679848037,
     *1718379875,1953066862,1931503987, 544108404, 544367984,1869771877,
     *1680744480,        -3,        -1, 589315646,1042305637,1886351988,
     * 544041331,1936289383, 543449460,1970085990,1869750367,1684629094,
     *1919836018,1701211246,1935630710,1599233893,1903520118,1634493806,
     *1953701920,        -3,1597519921, 538976288, 807411744, 540024864,
     * 538980384, 824197408, 538980640, 807415840, 807411744,        -3,
     *1315905604,1635022189, 543584114, 543122537,1717989998,1601332582,
     *1819177823,1635147602,1600483701,1769365868,1701737587, 539897390,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542402661, 544040306,1734962791, 542256486,1633907823,1914725999,
     *1914725745,1969845857,1818586740, 544367974,1818583924,1768910451,
     * 543781664,1835627379,1768843040,1768824948,1751457859,1229336096,
     *        -3, 541139062,1634497893, 544171552, 808333344,1970500961,
     *1819048224,1768842345,1667331173,1931506792,1635000429,1701996393,
     *1852252264,1634934882,1701146144,1685024357, 544175476,1936286821,
     * 544499813,        -3, 544240239,1735549293, 544499809,1948279666,
     *1700885605,1679848552,1696613193,1177428033, 544240239,1885696544,
     *1986096245,1696625512,1869966436, 543319328,1768842092,1969513828,
     * 543257376,1919250543,1920230756,        -3, 543324448,1952998688,
     *1702392933,1919836524, 544040306,1734962791, 544240239,1735549293,
     * 773869167,1952791072,1836016741,1919819880,1634886775,1634886944,
     *2003397740, 543647086,1701994860,1819877488,1919902837,1667571744,
     * 544367972,1970168929,1853104242,1701211237,1668573551,1847616609,
     *1952525856,        -3,        -1, 589315646,1042305637,1886351988,
     * 544041331,1936289383, 543449460,1970085990,1869750367,1684629094,
     *1919836018,1701211246,1935630710,1601531493,1950953326,1702119712,
     *        -3,1597519922, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980640, 807415840, 807411744,        -3,1315905604,
     *1635022189, 543584114, 543122537,1717989998,1601332582,1819177823,
     *1635147637,1852142665, 795764084,1226845742, 774778414, 538976288,
     * 542141541,1634952480,1148133409,        -3,        -2, 542011168,
     *1986096245,1696625253,1886351988,1701060710,1869750373,1769236581,
     *1914709855,1684629094,1919836018,1701211246,1935630710,1601531493,
     *1950953326,1702119719, 544174624,1952998688,        -3, 544173156,
     *1701982067,1970300274,1936024677,1679843172,1768318578,1851748965,
     *1718382195,1600222815,1936287597,1632186222,1702119712,1128875552,
     *1769235821, 773857312,        -3,        -1, 589315646,1042305637,
     *1886351988, 544041331,1936289383, 543449460,1970085990,1869750367,
     *1635020653,1601399156,1702059891,1869378932,1768910431,1886546285,
     *1634892064,        -3,1597519923, 538976288, 807411744, 540024864,
     * 538980384, 824199456, 538980640, 807415840, 807411744,        -3,
     *1096971109,1853104196,1635022189, 543584114, 543121780,1869438835/
     * )
      ICK( 50101: 50400) = (/
     *1769235827,1601400684,1970563439,1851748466,1768776050,2032152110,
     * 538976288, 542141541,1634952480,1148133409,        -3,        -2,
     * 542141541,1634952480,1937076336,1819877492,1751457904,1919905893,
     *1914726766,1718558822,1869750311,1600222319,1834972009,1952805727,
     *1936682101,1953066862,1601204841,1835102841, 657334358,1634497893,
     *1931505013,1936990240, 543319328,1869505824,1868963956,1751457894,
     *1869376623,2003398247, 975201385,1718444400, 740324965,1668112752,
     * 740321381,1635154220, 543451506,1701016620, 543647087,1831608420,
     *1769173093,1915494505,1936682351,1915494432, 544108404,1684370476,
     * 543454561,1814831209,1952805473,1953068645, 740323188,1751478830,
     *        -3,        -1, 589315646,1042301800,1701014304,1718579744,
     *1685418092,1768120692,1696614445,1293972336,1633903904,1735552885,
     *1881174905,1835167596,        -3,1597520184, 538980398, 807411760,
     * 774905888, 808333344, 874529056, 538980384, 807415840, 824188960,
     *        -3,1399153519,1852055634,1701867378,1952801824,1210928416,
     *1400466786,1869357161,1847608137,1176521063,1852797541,1679830574,
     * 774778414, 538976288, 538976288, 538976544,1130915171,1797267488,
     *        -3,        -2, 541139059,1701015406,1679848304,1701013862,
     *1768120692,1768910368,1868963956,1751457864, 760029299,2037211759,
     *1814063475, 543584117,1852055657,1847620712,1696613193,1177428047,
     *1852602656,1952998688,1718186611,1948262432, 544173669, 543518307,
     *1869966964,1701995876, 543781664,1919251553,1768842596, 773857312,
     *        -3,        -1, 589315646,1042305637,1886351988, 544499813,
     * 542471013, 544171552,1634607215,1818518898, 542328901,1280855072,
     *1986359923,1768910368,        -3,1597520185, 538976288, 807411744,
     * 540024864, 538980384, 874529056, 538980384, 807415840, 824188960,
     *        -3, 608313449,1931497333,1952735604,1701060640, 543256164,
     * 542340451,1667589476,1701060706,2032161608,1162631244, 538977345,
     * 542011252,1696604192,        -3,        -2, 541139053,1869767968,
     *1919247205,1853104211,1212501080,1277195877,1920166255,1847617907,
     * 544108407, 543258209,1768710498,1818570272,1181314657,1814065765,
     *1718185573,1835363956, 544696692,1746957416,1696604192,        -3,
     * 543973748,1702065184,1986359923,1768910368,1769152626,1701015405,
     *1835363940,1701060723,1768842085, 539511125,1131555104,1667786083,
     *1799571782, 543781664,1920298528,1634165097,1853060128,1952998688,
     *1818326117,1936990240, 542328901,1280855072,1986359923,1768910368,
     *1718579744,1952998688,1919233379,1919246708,1768910368,1868963956,
     *1751457862,1128669281,1852055657,1953702006,1634494820,1635019119,
     *1848516640,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750311,1315908973,1635017576,1768843040,1919247980,1701016681,
     *1869488230,1768711463,        -3,1597583408, 538976288, 807411744,
     * 540024864, 538980384, 824199456, 538980384, 807415840, 824188960,
     *        -3,1315905613,1635017576,1768843040,1181691718,1663062629,
     *1718379875,1953066862, 541485420,1696606278,1128671520,1181709678,
     *1679830574, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541878635,1701607712,1667331443,1698308164,
     *1635017075,1702109294,1634559347, 543780384,1952998688,1128875552,
     *1634624544,1178813984,1684629094,1701981728,        -3, 542011252,
     *1698308166,1128669270,1634494820,1635019119,1847617907, 542337897,
     *1886414180, 543584114, 544499817,1931494766,1953659182,        -3/
     * )
      ICK( 50401: 50700) = (/
     *        -1, 589315646,1042306149,1936990310,1869750339,1229332518,
     * 541475654, 541279564,1277194337,1918987621,1952805491, 544108404,
     * 544039284,1667787118,1730158624,        -3,1597583409, 538976288,
     * 807411744, 540024864, 538980384, 824199456, 538980384, 807415840,
     * 824188960,        -3,1130720364, 542138738,1634559348,1701999392,
     *1768824899,1229332577,1852055622,1128669284,1864396399,1948274017,
     *1952671776, 774778414, 538976288, 538976288, 538976544,1165128303,
     *1914708000,        -3,        -2, 542142323,1936286316,1696621409,
     *1970496883, 975206258,1869506336,1684108385,1936028716, 541280582,
     * 544174624,1178813984,1885434465,1835365477,1920147557,1684632677,
     *1679845742,1668247155,1769174117,1853123705,        -3, 544174624,
     *1667591276, 544235890,1634559348,1701999392,1718579744,1953653102,
     *1936093042,1835361312,1667591276, 539518254,1731076176, 842084206,
     * 540814654, 542126641, 795027758,        -3, 542011252,1698308166,
     *1128669270,1634494820,1635019119,1847617907, 542337897,1886414180,
     * 543584114, 544499817,1931494766,1953659182,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750382,1869491578,1701998368,
     *1853189474,1701978223,1713402469,1668245358,1769170276, 544367974,
     *1818583924,1768910451, 543780384,1178813984,        -3,1597583410,
     * 538976288, 807411744, 540024864, 538980384, 824199456, 538980384,
     * 807415840, 824188960,        -3,1315905576,1231975525,1919971941,
     *1952539244,1697194066,1701211237,1668573551,1853038662,1869966948,
     * 543780384,1178813984, 774778414, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 541419892,1751478816,
     *1852776562,1701211237,1668573551,1853038689,1919230054,1869966948,
     * 543780384,1952998688,1178813984,1869750388,1751457862,1128669289,
     *1931507054,1768846437,1919971941,1952539244,1696604192,        -3,
     * 543454565, 544501536,1970170734,1870097952,1718579821,1635000431,
     *1914725732,1769236846,1731076128,        -3, 542011252,1698308166,
     *1128669270,1634494820,1635019119,1847617907, 542337897,1886414180,
     * 543584114, 544499817,1931494766,1953659182,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750342,1868723005,1180918124,
     *1663068526, 541475654,        -3,1597583411, 538976288, 807411744,
     * 540024864, 538980384, 824199456, 538980384, 807415840, 824188960,
     *        -3,1177055074,1932075105,1852055622, 677601644,1663639638,
     *1634497893,1931501938,1696614756,1701737577,1667329056,1768824902,
     *1128669230, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541288549,1667965044,1751457862,1128669286,
     *1768711456,1718579744,1177055074,1932075109,1903518060, 541468771,
     *1634493225, 542863218, 541468783,1651714346, 707928165,1903518060,
     * 541468771,1634493225, 707408477, 773857312, 542402661, 541475654,
     * 543781664,1868723817,1869968236,2032168559,1948279666,1700885605,
     *1679843699, 544499813, 544367987,1970041888,1868963937, 544367974,
     *1768842605,1701737504,2003399784, 544367975,1970037106,        -3,
     * 544170611,1702000229,1679844449,1952525856,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750350,1919247904,1042304624,
     *1634869353,1847620712,1696613193,1176510496,        -3,1597583412,
     * 538976288, 807411744, 540024864, 538980384, 824199456, 538980384,
     * 807415840, 824188960,        -3,1316318562,1701978223,1713394277,
     *1718379875,1953066862,1931503987, 540811296,1316318562,1701978223/
     * )
      ICK( 50701: 51000) = (/
     *1713393761,1918987621,1952805491, 539248928,        -3,        -2,
     * 542402661, 544109933,1650815520,1868963954,1701211237,1668573551,
     *1853038694,1869966948, 543780384,1952998688,1919247980,1701016681,
     *1869488230,1768711456,1769152620,1702064928,1952997742, 544499813,
     *        -3, 544109933,1650815520,1868963952,1634885997,1702126962,
     *1931506277,1886351988,1701060713,1847620712,1696613193,1177428000,
     *        -3,        -1, 589315646,1042305637,1886351988, 544105831,
     *1635019126,1696615200,1986096245,1702043753,1847620712,1696612718,
     *1634498931,1769152623,1713395297,1919508846,1667571744,        -3,
     *1597583413, 538980398, 807411761, 774905888, 841887776, 857753888,
     * 538980384, 807416096, 807411744,        -3,1315268449,1953068645,
     * 541794422,1634497893, 543780384,1952998688,1097752940,2037606771,
     * 544171552,1449226857,1634624357, 539897390, 539248160,1382379631,
     *1920213024,        -3,        -2, 542335841,1818566726,1633907823,
     *1920147496,1764648238, 541794365, 541943137,1851475496,1868722985,
     * 707408477, 539959373,1700884000,1531324515,1634493225, 707408477,
     * 689989231,1914729317,1818583924,1701060640,        -3, 543650415,
     *1970303776,1868963954,1701211237,1668573551,1853041696,1634934892,
     *1769174117,1679845742, 544499813, 541159009,1819898729,1931505510,
     * 542531954,1767992931,1696617317,1668573551,1847599927, 544171552,
     *        -3, 544499813, 541475654, 544629100,1768186228,1768910368,
     *1919250543,1920216096,1634886944,1702391909,1668572516, 544501536,
     *1751217765, 543236214,1634497893, 544171552,1633841013,1948266798,
     * 808464430,        -3, 542340210,1869506336,1684371049,1635019119,
     *1853038707,1752135020,1679843941, 543780470,1702065257,1734440037,
     *1680613473,1668572516, 544567407,1847619442, 543520880,1818323310,
     *1701064224, 678651237, 543255667,1864376352, 542328901,1280855072,
     *1835101813,1634478382, 541139058,1700885359,1847616353,1847616101,
     * 544040289,1852403303,1818588019, 539522917,1634412832,1751738216,
     * 544174692,1701978212,1635016992,2003330418,1696620832,        -3,
     * 543389044, 761422179,1797287782, 544499813, 544367987,1869378932,
     *1768910368,1835624296,1948279397, 543780452,1768120692,1701064224,
     *1231971183,1920099683,1948279393,1667983218,1869966948, 544502373,
     *1635020133,1853104160, 543383918, 543974753,1679848559, 544109933,
     *1701998453,1931505253,1734440041,1986338927,1651729778,1986356256,
     *1768846437,1853057396,1768256288,1718579744,2003132779, 544367974,
     *1818583924,1768910451, 539519278,1697521696, 541468771,1634493225,
     * 543386735,1936007284,1864399461,1919888928,1181708832,1684370529,
     *1768715040,1936024864,1952998688,1097752940,2037606771, 762275373,
     *1449226857,1634624357, 542336355,1953066862, 540483689,1847599136,
     * 544499813, 544629100,1768186228,1768910368, 657351531,1713840230,
     *1768711470,        -3,        -1, 589315646,1042305637,1886351988,
     * 541876594,1734680651, 544629100,1969582880,1768824948,1751457857,
     *1851878521,1936290592,1868963926,1634888033,1852007712,        -3,
     *1597583414, 538980398, 807411761, 774905888, 841887776, 857753888,
     * 538980384, 807416096, 807411744,        -3,1281454695,1696615200,
     *1449225333,1696622958, 544499813, 541159009,1819898729,1931505510,
     * 542531954,1767992931,1696607790, 774778414, 539248160,1130915171,
     *1797267488,        -3,        -2, 542335841,1818566726,1633907823,
     *1920147496,1764648238, 541794365, 541943137,1851475496,1868722985/
     * )
      ICK( 51001: 51300) = (/
     * 707408477, 539959373,1700884000,1531324515,1634493225, 707408477,
     * 689989231,1914729317,1818583924,1701060640,        -3, 543650415,
     *1970303776,1868963954,1701211237,1668573551,1853041696,1634934892,
     *1769174117,1679845742, 544499813, 541159009,1819898729,1931505510,
     * 542531954,1767992931,1696617317,1668573551,1847599927, 544171552,
     *        -3, 544499813, 541475654, 544629100,1768186228,1768910368,
     *1919250543,1920216096,1634886944,1702391909,1668572516, 544501536,
     *1751217765, 543236214,1634497893, 544171552,1633841013,1948266798,
     * 808464430,        -3, 542340210,1869506336,1684371049,1635019119,
     *1853038707,1752135020,1679843941, 543780470,1702065257,1734440037,
     *1680613473,1668572516, 544567407,1847619442, 543520880,1818323310,
     *1701064224, 678651237, 543255667,1864376352, 542328901,1280855072,
     *1835101813,1634478382, 541486962, 543450484,1634298995, 544433509,
     * 544499813, 541159009,1819898729,1932357478, 760635762,1767992931,
     *1696617317,1668573551,1847605024,1768824948,1751457824,        -3,
     * 544629100,1768186228,1768910368, 657351531,1713840230,1768711470,
     *        -3,        -1, 589315646,1042301800,1701014304,2003330420,
     *1751478816,1952998688,1937011317,1668576626,1696624229,1701081888,
     *1953439842,1696622958,1986359924,1701060640,        -3,1597583415,
     * 538980398, 891302192, 774905905, 808333344, 840974624, 538980384,
     * 807416096, 807411744,        -3,1181507939,1797290016,1042296878,
     * 892084307,1953658211,1953854053, 542008677,1685266548,1864393317,
     * 541683318,1701999717,1681858606, 539248160,1130915171,1797267488,
     *        -3,        -2, 541139014,1818321771, 544743542,1634497893,
     * 543647086,1701994860,1819877481,1852074339,1635018099, 544499809,
     *1948284008,1696625524,1920295796,1970431264,1852138852,1931506799,
     * 543319328,1768846949,1920230756, 773857312, 541288549,1667965047,
     *1751479400,1701978228,1751457862,1818321771, 544743542,1634497893,
     * 543781664,1970172517,1818845538,1818566756,1969561716,1864392992,
     *2003132779, 543256175,1835101295,1970479136,        -3, 543451507,
     *1885696627,1768910368,1936287598,1634479136,1937339252,1701667188,
     *1768104037,1920102258,1931505522, 544695649,1797284961,1952522337,
     *1852055649,1734437230,1936990315,1852798752,1633842031,1819636837,
     *        -3, 544437362,1969452149,1919233568,        -3,        -1,
     * 589315646,1042305637,1886351988, 544173600,1298233376,1868723045,
     *1920361828, 543449460,1629514094, 543256185, 544367987,1869378932,
     *1768910368,1936221548,1814044704,        -3,1597583416, 538976288,
     * 807411744, 540024864, 538980384, 840974624, 538980384, 807415840,
     * 824188960,        -3,1298233390, 542139762,1663967300,1635016992,
     *2003399784, 541663294, 540158579, 675883296,1885696544,1382380334,
     *1399350636,1814048288, 608576800,1315927141,        -3,        -2,
     * 541139052,1870078061,1635281261,1970086000,1701995365,1853120871,
     *1696624486, 544367974,1818583924,1768910451, 544696692,1746946336,
     *1042297386,1932020009, 544039289, 543780452,1768120692,1698308128,
     *        -3, 540090413, 541944179,1936024608,1953653102,1936482676,
     *1768910368,1937337709,1702130297, 773866798,1731076193,1819025522,
     *1701211237,1668573551,1853038696,1802248311,1700883232,        -3,
     * 538976288, 543584114, 543957053, 540175904, 724639776,        -3,
     * 540155949, 542143333,1969516333,1835364975,1751475314,1634476148,
     *2003398254,1768843052, 543780452,1702371390, 540093984, 677719655/
     * )
      ICK( 51301: 51600) = (/
     * 773877359,1848472432,1633903975,1919907184,        -3, 538976288,
     * 543520884,1768842100,1768910451, 773857312,        -3, 540221485,
     * 542532978,2032170853,1634410607,1651729778,1986356256,1684108385,
     * 773857312,        -3,        -1, 589315646,1042305637,1886351988,
     * 543253103,1970544755,1768386153,1718182753,1853104239,1651729778,
     *1986356256,1684108385, 543319417,1869505568,1416127860,1630364533,
     *1953457766,        -3,1597583417, 538976288, 807411744, 540024864,
     * 538980384, 857751840, 538980384, 824193056, 807411744,        -3,
     *1348825699,1701737569,1734680687,1713391934, 846424423, 675883296,
     *1147237473, 543257632,1416127860,1630031201,2015961171,1953066092,
     * 608773408,1315927141,        -3,        -2, 542402665,1931493708,
     *1163023392,1382379631,1920234272,1869488247,1751479400,1701978228,
     *1751478885, 543781664,1937009004,1814061344,1936287598,1768319331,
     *1634628640,1818588773,1814064998, 544170611,1702000229,1679826976,
     * 543449460,1629512293,2037345892, 544499813, 542402661,1952522339,
     *1970564966,1713401702, 544499813, 541352308,1634952564, 773870696,
     *1701995808,1936224117,1818501218,1696620832,1735356260, 544367969,
     *1936682528,        -3, 543584114, 543236195,1970564966,1713398373,
     *1819244320,1936289320,1952998772,1630089068,1634558564,1629502752,
     * 808334880,1097754410, 707604782, 542270822,1818583924,1768910368,
     *1684108385, 543319417,1869505568,        -3, 544499809,1948284513,
     *1819632928,1936224117,1818501230,1869881442,1696625253,1836021349,
     *1679849320,1701716083,1768386153,1718182753,1853123705, 543253103,
     *1986338932,1751457902,1869181797, 543974774,1701588512,        -3,
     * 541404775, 773878888,1702436973,1635328098,1696626277,1920540786,
     *1701602678,1634628640,1768824931,1634952480,1868963952,1936029028,
     *1865228403,2037214565,1953659168,1634624544,        -3, 539520623,
     *1848206181,1853125231,1937337709,1702130297, 544367974,1768842605,
     *1701737518,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750382,1970102885,1914728294, 544041331,1936289383, 544367974,
     *1818583924,1768910451, 543319404,1870078036,1751479393, 676161902,
     * 689971232,        -3,1597583664, 538976288, 807411744, 825237536,
     * 540356640, 857751840, 538980384, 807415840, 824188960,        -3,
     *1298756467,1768843040, 589328230, 541475654, 542270822,1818583924,
     *1768910376,1932075074,1701605239, 542402661,1952524365,1768827182,
     * 539248928,1315927141,        -3,        -2, 542142323,1936286316,
     *1696621409,1970496883, 975193464,1885696617,1835363956,1634476130,
     *1700883827,1953460256,1416127860,1630039401,1848189036,1768778100,
     * 544433524, 544501615, 543713639,1748705345, 543973746,1734680608,
     * 544566889,1949131621,1819025507,1635087209,1852252274,1701211237,
     *1668573551,1853038693,1717986659,1952801824,1652105332,1751457890,
     *1700883827,1953460270, 541139056,1869837161,1651270944,1952801640,
     *1852400481,1814044704, 544436076,1970563439,1847619438, 541279044,
     * 543318387,1701060709,1903520112,1835363956, 543780470,1869379173,
     *1931506792,1696621423,1819043171,1953066862, 544171552,1633969257,
     *1953066862,1634476137,1835100005,1931485216, 544696692,1746957416,
     *1696621669,1952801652,1869750369,1948279072,1818325607,1701978212,
     *1769174113,1852007712,1718775661, 544499813, 543388281,1937006956,
     * 544696692,1746957416,1696621157,1634562932,1869619232,        -3,
     * 544433524,1953066599, 543385697,1852269924, 543253347,1869767785/
     * )
      ICK( 51601: 51900) = (/
     *1852271737, 773865836,1952805486,1635019126,1701607724, 543236204,
     *1634887525, 544109933,1650815520,1868963948,1870081391,1919182194,
     *        -3, 539455349,1953261925,1915166834,1701211237,1668573551,
     *1853038701,1768384628, 543711606,1696621157,1701716007,1332570484,
     *1952801831, 543450476,1768056178,1635018092,2032166514,1869422708,
     *1751457832,1718185569,1814634528, 543974753,1936993651,1903518066,
     *1702043762,1701210478,1701668206,1949179988,1751457908,1702065184,
     *1769152609,1734437230,1936990324,1751457889,1668576609,1814058088,
     *1702125864,1298755113, 544171552,1952998688,        -3, 544367974,
     *1818583924,1768910451, 543780384,1952998688, 657352291,1713840230,
     *1768711470, 542336357, 544499813, 539438691,1801856800,1718185061,
     * 543584114, 543450484,1634298995, 544171552,1952998688,1835627379,
     *1768843040, 544367974,1818583924,1768910451, 773867375,1868832881,
     *1969319017,1954095212,1870078063,1919182194, 544367974,1818583924,
     *1768910451, 544041319,1752440930,1696625253,1818588769,1853104230,
     *1869750355,1364542789,1514479648, 543256164, 544434541,1768710514,
     * 544436076,1986358900, 544042852,1701604457,1852252274,1701210478,
     *1701668206,1948284005,1667788393,1903519091, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750381,1769173865,
     *1852252274,1701211237,1668573551,1853038690,1702131557,1701716052,
     *1751479393, 676161902, 694251108, 542337390, 676620389,1952524591,
     *1281453410,1684094256, 775299104,1597583665, 538976301, 824188960,
     * 540352544, 960051488, 857751840, 538980384, 807415840, 824188960,
     *        -3,1298756467,1768843040,1178813984,1382377068, 541222260,
     *2003133806, 542402669,1768824870, 542332008, 793525540,1092625481,
     * 542270832,1869771808,        -3,        -2, 542142323,1936286316,
     *1696621409,1970496883, 975195497,1936943470,1730175861,1936728175,
     *1713398881,1952522280,1685415200,1953439858,1869898100,1768910368,
     *1633841013,1948282734,1696620920,1769154860,        -3, 543450476,
     *1702126948, 539520886,1701996140,1870080288,1919247980,1701016681,
     *1869509408,1869750377,1836085871,1885696544,1937011297,1952802681,
     * 539520882,1953001330,1752132962,1768104038,1869750304,        -3,
     * 544042862,1868786793,1852400416,1668446579,1952541728,1702126382,
     * 689984357,1696625768,1696605998,1667982887, 543582572,1696622191,
     *1914725477,1952541036,1932402720,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750381,1769173865,1852252274,1701211237,
     *1668573551,1853038689,1651471973, 542337390, 676620389,1952524591,
     *1281453410,1684086845, 540028470,        -3,1597583666, 538976301,
     * 824188977, 808460320, 960051488, 874529056, 538980384, 807415840,
     * 824188960,        -3,1298756467,1768843040, 589328230, 541475654,
     * 542270822,1818583924,1768910451, 541155951,1986338899,1416113996,
     *1025515568, 775303216, 539248928,1315927141,        -3,        -2,
     * 542142323,1936286316,1696621409,1970496883, 975195497,1936943470,
     *1730175861,1936728175,1713398881,1952522280,1685415200,1953439858,
     *1869898100,1768910368,1633841013,1948282734,1696620920,1769154860,
     *        -3, 543450476,1702126948, 539520886,1701996140,1870080288,
     *1919247980,1701016681,1869509408,1869750377,1836085871,1885696544,
     *1937011297,1952802681, 539520882,1953001330,1752132962,1768104038,
     *1869750304,        -3, 544042862,1868786793,1852400416,1668446579,
     *1952541728,1702126382, 689984357,1696625768,1696605998,1667982887/
     * )
      ICK( 51901: 52200) = (/
     * 543582572,1696622191,1914725477,1952541036,1932402720,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750381,1769173865,
     *1852252275,1953656686,1730179685,1718379875,1953066862,1931485216,
     *        -3,1597583667, 538976288, 807411761, 808460320, 960051488,
     * 857751840, 538980384, 807415840, 824188960,        -3,1298756467,
     *1768843040, 589328230, 542532978,2032161652,1919905383, 542270822,
     *1818583924,1768910451, 543780384,1178813984, 774778414, 539248928,
     *1315927141,        -3,        -2, 542402665,1931493708,1163023392,
     *1919250543,1920234272,1952998688,1853189474,1701978223,1713401193,
     *1936943470,1730179685,1718379875,1953066862,1931507561,1952981062,
     *1663707698, 544629100,1969582880,        -3, 543650405,1635018098,
     * 544499809,1847620712,1696623713,1919378803,1948272168,1667329123,
     * 690629170, 544629100,1969561705,1847620712,1696613955,1177428048,
     *1869837161,1651270944,1667331443,1702050336,        -3, 541944179,
     *1936289383, 543389043,1881173862, 543449460,1629497444,1969561716,
     *1864397423,1952543849,1869488225,1651471732, 544173669, 543258729,
     *1932078112,1684368485,1952801824, 678393445,1919315055,1999183904,
     *        -3, 544367974,1818583924,1768910451, 544174624,1768779890,
     *1869636978, 544437362,1635018087,2032150639,1920231535,1919446893,
     *1651073824,1718579744,1836019311,1668049262,1768104035,1920562036,
     *1634476133,1952656937,        -3, 544174624,1650813033,1852055668,
     *1751457890,1700883827,1953460270, 542336357, 544499813, 539438691,
     *1801856800,1718185061, 543584114, 543450484,1634298995, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750369,
     *1651729774,1667571823,1713390185,1786146661,1948274785,1769108256,
     *1768824942,1869491555,1701737586,1864397684,1920295796,1970431264,
     *        -3,1597583668, 538976288, 807411744, 540155936, 538980896,
     * 857751840, 538980384, 807415840, 824188960,        -3,1315905602,
     *1768584815,1702109264,1634300531, 543780384,1178813984,1718579744,
     *1315925549,1667591796,1919885395,1953658211,1953854053, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542402665,1931493708,1163023392,1919247980,1701016691, 544499813,
     * 544108404,1768910368,1952997748, 543236196,1635017075,1702109299,
     *1752135020,1679844207,1853120873,1847615776,1937073766,1768122725,
     *1853104160,        -3, 544109933,1650815520,1868963906,1768584815,
     *1702109224,1181903205,1684368425, 544235881,1920147558,1869750388,
     *1751457906,1701603681,1651270944,1684370533,1919773038,1635019119,
     *1847619430, 544499813,        -3, 543253107,1869378932,1696625524,
     *1920295796,1970431264,1868963937, 544108398, 761488750,1953656691,
     *2037214565,1953655139, 543388281,1937006956, 544437362,1969452149,
     *1919233568,        -3, 542402665,1931506789,1936990313,1931503982,
     *1987013477,1679849320,1701716065, 541486177,1667965040,1634885997,
     *1702126962, 544629100,1969561705,1931506544,1701013862,1768252462,
     *        -3, 542011252,1698308179,1212501080,1278818080,2003397740,
     * 543383916,1668639841,1952788338,1701867378,1948279072,1181507939,
     *1797288033,1918987621,1952805408,1986096245,1696621942,1701716070,
     *1869750304,        -3, 544367974,1768842605,1701737504,1634165097,
     *1853060128,1181903205,1684368416,1835364967,1701060708,1635017006,
     * 542270829,1870030112,1952998688,1181507939,1797285230,1953659168,
     *1718775661, 544499813, 541280582, 773857312,        -1, 589315646/
     * )
      ICK( 52201: 52500) = (/
     *1042306149,1936990310,1869750380,1870078022,1919509860,1701585008,
     *1634300448,1668249189,1918986085, 543780384,1852796461,1667591796,
     *1919885427,1953658211,1953854053,        -3,1597583669, 538980912,
     * 773857333, 808329248, 825241632, 857751840, 538980384, 807415840,
     * 824188960,        -3,1315905606,1818321771, 544743491,1751475051,
     * 541355886,1698308172,1870078022,1919509860,1701584976,1634300448,
     *1131378277,1918986085, 539248928, 622862368,        -3,        -2,
     * 542402665,1931493708,1163023392,1919247980,1701016691, 544499813,
     * 544108404,1768910368,1952997748, 543236196,1635017075,1702109299,
     *1752135020,1679844207,1853120873,1847615776,1937073766,1768122725,
     *1853104160,        -3, 544109933,1650815520,1868963906,1768584815,
     *1702109224,1181903205,1684368425, 544235881,1920147558,1869750388,
     *1751457906,1701603681,1651270944,1684370533,1919773038,1635019119,
     *1847619430, 544499813,        -3, 543253107,1869378932,1696625524,
     *1920295796,1970431264,1868963937, 544108398, 761488750,1953656691,
     *2037214565,1953655139, 543388281,1937006956, 544437362,1969452149,
     *1919233568,        -3,        -2, 541139014,1919509860,1701584995,
     *1870030194,1634166048,1952997748, 543450486,1767994469,1931506537,
     *1735289190,1768120686,1953265952,1718775661, 540094512, 544236914,
     *1667591796, 544039289,        -3, 543320417,1932487022,1986096233,
     *1684108389, 544499813, 544629100,1969561711,1713402984,1696613996,
     *1633905440,1885434465,1835365477,1915625504,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750372,1768318565,1919512167,
     * 541486177,1667965048, 543256164, 541618031,1718886521, 544235890,
     *1634559348,1701978230,1634497893,1931485216,        -3,1597583670,
     * 538980398, 824188976, 775036960, 808334112, 840974624, 538980384,
     * 807415840, 824188960,        -3,1215262566,1948285216,1634624544,
     *1181507939,1797290016,1348563553,1835365477,1914721889,1819633011,
     * 541354342,1717924384,1652105262, 539248160,1130915171,1797267488,
     *        -3,        -2, 542402661, 541618031,1718886521, 542138738,
     *1634559348,1701978217,1931502433,1818457452,1635018084, 543780452,
     *1701864814,1684369012,1819877478,1919905056,1952998688,1114204790,
     *1868919840,        -3, 543451494,1717924453,1852007795, 543256164,
     * 544434287,1970037792,1751217765, 543236214,1634497893, 544434541,
     *1768710514, 539520866,1936028278,1768843040,1952998688,1932424494,
     * 661858592,1953439860,1751217184,1868963872, 544499813, 541486177,
     *1667965048, 542138738,1634559348,1701981728,1399153978, 541618031,
     *1718889504,1378768686,1462509651,1953653110,1701981216,1278101550,
     * 539369555,1885694764,1093553198, 539505200, 808986926,        -3,
     * 541732384,1097887852, 740311922,2037609518, 540291372, 540620333,
     * 825242414, 542402671,1836086127,1848394030,1278091302, 542597492,
     *1802071596, 541339210, 773859378, 808466729, 773870693,1953653096,
     *1701081711,1849303072, 541160313,1835885940,1920543776,1685023034,
     * 825241137, 808531503,1781429349,1952543609, 775041072, 959328306,
     * 774910517, 773868641,1919378720,1684629094,1701995886,1667592992,
     *1835104544,1634888051,1696622958,        -3, 543383923,1702043767,
     *1751478885, 544499813, 541486177,1667965040,1634885997,1702126962,
     * 544694643, 544108404, 543450484,1701997929,1852138528,2003399784,
     * 543236162,1095976495,1415006542,        -3, 544367974,1768842605,
     *1701737504,1869750391,1769236512,1702064997,1853122913,1819048224/
     * )
      ICK( 52501: 52800) = (/
     *1667591796,1919906681,1835885940,1919509280,1684108385, 773870437,
     *1698308166,1818321771, 740313134,1143876640,        -3, 541222258,
     *1851880036,1768842604,1818831904,1194074179,1818586469,1853121836,
     * 541339201, 774643788,1768842341,1848385601, 773870448,1701522464,
     *1093553198, 539505200, 808855840,1097036897, 541291129,1936993824,
     *        -3, 541210162, 740308537, 892155696, 825106464,        -3,
     *        -1, 589315646,1042306149,1936994162,1701867378,1948284776,
     *1702127717,1914717763,1176529267, 543318387,1701060719,1847615776,
     *1111577414, 794056521,1310749285,1718185573,1835363956,        -3,
     *1597583671, 538980398, 807411760, 774905888, 808333344, 840974624,
     * 538980384, 807415840, 824188960,        -3,1416127776,1178813984,
     *1769152588,1768645996,2032160335,1411400289,1936024608,1869488225,
     * 541213011,1177506903,1229856838,1818321771, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 542402661,
     * 543387502,1953655138,1970563439,1847619430, 541468717,1747725675,
     * 741174313, 544501536,1177053228,1798073385, 543781664,1818848101,
     *1819877486,1869881449,1852009589,1684366368,1768824948,1751457824,
     *        -3, 539438694,1667639072,1718185061, 773870696,1769152629,
     *1937072492,1819877481,1852074339,1635018099, 544499809,1948284008,
     *1696613996,1633905440,1885434465,1835365477,1914730337,1931497039,
     *1411391520,        -3, 543450484,1701997929,1852138528,2003399784,
     * 543236162,1095976495,1415006542, 544504176,1696624486, 544367974,
     *1768842605,1701737518,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750386,1701211237,1668573551,1853038711,1769236512,
     *1227386722,1932075068,1008748840,1667329123, 689971232,        -3,
     *1597583672, 538976288, 807411769, 960045088, 960051488, 857751840,
     * 538980384, 807415840, 824188960,        -3,1382377068,1701016681,
     *1869490291, 689993577,1952981065, 678388339, 689991029,1667768403,
     *1835101292,1701978185, 677601644,1663639598, 539248928,1130915171,
     *1797267488,        -3,        -2, 542402665,1931493708,1163023392,
     *1919250543,1920234272,1869488244,1751457902,1970102885,1914728294,
     * 544367974,1818583924,1768910451, 544696692,1746935840,        -3,
     * 539510312,1868722985, 707408416, 757089832,1667329123, 690629170,
     * 689975072,1399416685,1630029352,1868722985, 707408425, 540811309,
     * 540094512, 774909472,1231954019,1634952480,1868963955,1953656686,
     *1730158624,        -3, 544367974,1818583924,1768910451, 544499817,
     *1931505001,1734898720,1650794596,1969561716,1864394104,1953066595,
     *1953066862, 539522159, 543319328,1633969266,1702064997,1679849321,
     *1952981108,1751457824,        -3, 544367974,1768842605,1701737504,
     *1868963937,1847616888,1953066595,1953066862, 544235890,1634559348,
     *1701981728,1333028965,1920428403,1696625768,1869833504,1919247980,
     *1701016681,1869509408,1634886944,1650816116,1701978144, 544367981,
     *1870030180, 543584879,1830843496,1696622185,1851878432,1919247977,
     *1852140901,1853104243,1768842085, 544499813,2032165234,1696622958,
     * 544438643,1952804193,1953063712,1701999215,1915625551,1713381408,
     *        -3, 543387509,1920165164, 543236214,1634494820, 544367969,
     *1936682528,1718579744,1952999795, 544240239,1651271021, 544434287,
     *1970037792,1650794598,1869966948, 773857312,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750386,1701211237,1668573551,
     *1853038689,1717986659,1952801824,1652105332,1751457890,1700883827/
     * )
      ICK( 52801: 53100) = (/
     *1953460256,        -3,1597583673, 538976288, 807411744, 540024864,
     * 960051488, 857751840, 538980384, 807415840, 824188960,        -3,
     *1382377068,1701016681,1869488163, 541878635,1701607712,1097229925,
     *1668572516, 543324448,1952998688,1113940333,1937010544, 539897390,
     * 539248928,1130915171,1797267488,        -3,        -2, 542402665,
     *1931493708,1163023392,1919250543,1920234272,1952998688,1853189474,
     *1701978223,1713402469,1718379875,1953066862,1931507561,1952981097,
     *1853121902,1936290921,1702043763,1701996911,1970498681,        -3,
     * 543516262,1701016677,1679843961, 544499813, 543319393,1836282991,
     *1882071122,1701211237,1668573551,1853038689,1919230051,1869966964,
     *1701060710,1869750391,1751737192, 544499813,1952522300, 540221472,
     *        -3, 541353319,1919247731, 543256164, 539510312,1868722985,
     * 707408416, 757089832,1667329123, 690629170, 689975072,1936814708,
     * 678913385,1734898729, 540811309, 540094510, 808329300,1752134501,
     *        -3, 544367974,1818583924,1768910451, 543257189, 543319412,
     *1952805408,1919249775,1986356256,1718775661, 544499813, 543582574,
     *1634476146,1701210478,1701668206,1948283753,1852007712,1952998777,
     * 543257189,        -3, 543780384,1937339252,1701667188,1768104037,
     *1920102258, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750356,1751479393, 676159864, 689988463,1853057395,
     *1952804451,2032165477,1953981797,1847608137,1176512032,1178813984,
     *        -3,1597583920, 538979889, 807411758, 892346425, 959328288,
     * 824197408, 538980384, 807415840, 824188960,        -3,1416127860,
     *1630031201,2015961120,1768824899,1229332577,1852055622,1128669252,
     *1768318565,1914724985, 539897390, 774778414, 774778414, 539248160,
     *1147496306,1701126176,        -3,        -2, 541288549,1667965042,
     *1701211237,1668573551,1847620468,1635019123,1953063795, 544171552,
     *1952998688,1684108385, 543780384,1952998688, 657352291,1713840230,
     *1768711456,1718579744,1668247155,1769174117,1852012832,        -3,
     * 544696692,1746957416,1696621665,1952522354,1701867378,1952801824,
     *1768824948,1751457831, 778266982, 656434793,1818570272,1092641897,
     *1717986674,1701733221, 544568181,1634495609, 543780452,1768120692,
     *1702043745,1847599136, 543515753,1952801824, 657220457,1713840230,
     *1768711456,1869750369,1847600942,1717790247, 543582572,1696625768,
     *1635000439,1634934894,1869881443,1919246708,1701060713,1847620712,
     *1696625505,1835343955,1212501080,1277173792, 544372078, 544696421,
     *1919230068,1751457831, 778266982, 656434793,1818566775,1634934883,
     *1919246708,1701064224,1231954034,1634886944,1667330917,1931506792,
     *1769152577,1279611476, 544039289, 544239465,1853104244,1864376352,
     * 544568169,1852252257, 542328901,1280855072,1415006542, 543780467,
     *1953658211,1953066862, 543584114, 543711598,1684826478,1730175264,
     *1852796461,1835364975,1751475314,1634476148,2003398190,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750354, 824197999,
     *1853057395,1952804451,2032165477,1953981797,1847608137,1176512032,
     *1178813984, 676294772,1768910433,1819048224,1919233379,1634493301,
     *1818326117,1680416800,        -3,1597583921, 539897904, 824192560,
     * 808788014, 808792096, 824197408, 538980384, 807415840, 824188960,
     *        -3,1378951273,1847608137,1176527214,1679839793, 541286764,
     *1667506278,1919905056,1178813984,1147237473, 541354342,1717924384,
     *1652105262, 539248160,1130915171,1797267488,        -3,        -2/
     * )
      ICK( 53101: 53400) = (/
     * 542141541,1634952480,1667786083,1797289832,1702127717,1914729576,
     *1696625525,1886415977,1701060647, 778462054, 656434793,1818566755,
     *1869771365,1936748398,1685266551,1769236512,1952998688, 657351529,
     *1713840160,        -3, 541477196,1159753842,1868854627,1701060713,
     *1847620712,1696625505,1835343980,1700885364, 544436597,1634887027,
     * 544367974,1768842605,1701737504,1785684526, 542336357, 543257632,
     *1952998688,1701733408,1868963872,        -3, 542336355,1953066862,
     * 539177264, 543780384,1952998688, 657351531,1713840242,1701867378,
     *1948280425,1818566758,1869750372,1702125929,1819487776,1416127776,
     *1952805748, 543781664,1650553701,1679847278, 544499813,        -3,
     * 544170611,1702000229,1679843694,1679844193,1818457452,1635018084,
     * 541469226, 840984942, 544499813, 539438694,1667639072,1718185061,
     * 544696692,1746958181,1768384628, 544235890,1634559348,1701999392,
     *1952541541,1847599136, 543584879,1830843496,1696605998,1667851815,
     * 543582572,1697521696,        -3, 542011252,1698308166, 678388339,
     * 694039072,1986096245,1702043753,1847615776,1397245260,1481384039,
     *1701733746,1635018084, 541475654, 543257189, 543387506,1919247220,
     *1701060710,1869750373,2020895086,1668573551,1848516640,        -1,
     * 589315646,1042306149,1936990310,1869750391,1379016803,1869509481,
     *1937007982,1668882530,1702131557,1701716035,1229332518, 541475654,
     * 676488560,1869771877,1680416800,        -3,1597583922, 539897904,
     * 824192560, 808788014, 808792096, 824197408, 538980384, 807415840,
     * 824188960,        -3,2001875488,1768824948,1751457859,1229332577,
     *1852055622,1128669252,1768318565,1914724985, 539897390, 774778414,
     * 774778414, 774778414, 539248160,1130915171,1797267488,        -3,
     *        -2, 542141541,1634952480,1667786083,1797289832,1702127717,
     *1914729576,1696625525,1886415977,1701060647, 778462054, 656434793,
     *1818566755,1869771365,1936748398,1685266551,1769236512,1952998688,
     * 657351529,1713840160,        -3, 543582572,1696624754,1868854627,
     *1701060713,1847620712,1696625505,1835343980,1700885364, 762540405,
     *1634887027, 544367974,1768842605,1701737504,1785684526, 542336357,
     * 543257632,1952998688,1701733408,1868963872,        -3, 542336355,
     *1953066862, 539177264, 543780384,1952998688, 657351531,1713840242,
     *1701867378,1948280425,1818566758,1869750372,1702125929,1819487776,
     *1416127776,1952805748, 543781664,1650553701,1679847278, 544499813,
     *        -3, 544170611,1702000229,1679843694,1679844193,1818457452,
     *1635018084, 541469226, 840984942, 544499813, 539438694,1667639072,
     *1718185061, 543256164, 543450400,2003134823,1752440944,1634885997,
     *1702126962,1931485216,        -3, 544498027,1701716070,1919905056,
     *1952998688, 657351529,1713840230,1768711470,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750355, 543387502,1936290676,
     *1701733241, 543319412,2003133806, 541280582, 539369542,1128671314,
     *1701867378,1952801833,        -3,1597583923, 538979888, 824188974,
     * 892346400, 825110560, 824197408, 538980384, 807415840, 824188960,
     *        -3,1394614304, 542531948,1969582880,1768824948,1751457859,
     *1229332577,1852055622,1128669252,1768318565,1914724985, 539897390,
     * 774778414, 539248160,1130915171,1797267488,        -3,        -2,
     * 542141541,1634952480,1667786083,1797289832,1702127717,1914729576,
     *1696625525,1886415977,1701060647, 778462054, 656434793,1818566755,
     *1869771365,1936748398,1685266551,1769236512,1952998688, 657351529/
     * )
      ICK( 53401: 53700) = (/
     *1713840160,        -3, 543582572,1696624754,1868854627,1701060713,
     *1847620712,1696625505,1835343980,1700885364, 762540405,1634887027,
     * 544367974,1768842605,1701737504,1785684526, 542336357, 543257632,
     *1952998688,1701733408,1868963872,        -3, 542336355,1953066862,
     * 539177264, 543780384,1952998688, 657351531,1713840242,1701867378,
     *1948280425,1818566758,1869750372,1702125929,1819487776,1416127776,
     *1952805748, 543781664,1650553701,1679847278, 544499813,        -3,
     * 544170611,1702000229,1679843694,1679844193,1818457452,1635018084,
     * 541469226, 840984942, 544499813, 539438694,1667639072,1718185061,
     * 543256164, 543450400,2003134823,1752440944,1634885997,1702126962,
     *1931485216,        -3, 544498027,1701716070,1919905056,1952998688,
     * 657351529,1713840230,1768711470,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1668882543,
     *1713402984,1696625253,1886351988,1701060646, 543383916,1668639841,
     *1952801824, 542271599, 678259054, 689971232,        -3,1597583924,
     * 538980654, 807411762, 774905888, 858664992, 824197408, 538980384,
     * 807415840, 824188960,        -3,1416127776,1382379631,1920230756,
     * 543256164, 541286764,1668639841,1952801824,1382575912,1835626025,
     * 541354342,1717924384,1652105262, 539248160,1698770227,        -3,
     *        -2, 541288549,1667965025,1852055621,2020633697,1768824951,
     *1752768628,1751457906,1701867378,1952801824,1382575912,1835626025,
     * 543451494,1717924467, 544434535,1852401257,1667329652,1819877478,
     *1919905056,1952998688,        -3, 544629100,1969561699,1634493301,
     *1818326117,1679847278, 544499813, 543318387,1769152623,1713402984,
     *1696625253,1886351988,1701060723,1953658211,1953854053, 539522419,
     *1768843040,1952998688,1095322912,1836016741,1814634528, 542011252,
     *1698308180,1751457874,1701867378,1952801824,1634624544,1130458211,
     *1970037108,1701060726,1634497893,1931504993,2032165993,1717986674,
     * 544435305,1734898796,2032166005,1696625775, 543236128,        -3,
     * 543451494,1717924457,1852252272,1700883232,1768846437,1919971180,
     *1635019119,1847615852,1735357033,1953000748, 544174624,1936287598,
     *1768319331,1634628716,2032170856,1701716084,1751457906,1701210478,
     *1701668206,1948262432, 543781664,1650553701,1679847278, 543236206,
     *1869491571,1885889906,1768120684, 543257711,1830841711,1684368430,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1869509481,1937007982,1668882543,1713402984,1696625253,1886351988,
     *1701060646, 543383916,1668639841,1952801824,1382575912,1835104297,
     *        -3,1597583925, 538980654, 807411762, 774905888, 858664992,
     * 824197408, 538980384, 807415840, 824188960,        -3,1416127776,
     *1382379631,1920230756, 543256164, 541286764,1668639841,1952801824,
     *1382575912,1835104297, 541354342,1717924384,1652105262, 539248160,
     *1698770227,        -3,        -2, 541288549,1667965025,1852055621,
     *2020633697,1768824951,1752768628,1751457906,1701867378,1952801824,
     *1382575912,1835104297, 543451494,1717924467, 544434535,1852401257,
     *1667329652,1819877478,1919905056,1952998688,        -3, 544629100,
     *1969561699,1634493301,1818326117,1679847278, 544499813, 543318387,
     *1769152623,1713402984,1696625253,1886351988,1701060723,1953658211,
     *1953854053, 539522419,1768843040,1952998688,1095322912,1836016741,
     *1814634528, 542011252,1698308180,1751457874,1701867378,1952801824,
     *1634624544,1130458211,1970037108,1701060726,1634497893,1931504993/
     * )
      ICK( 53701: 54000) = (/
     *2032165993,1717986674, 544435305,1734898796,2032166005,1696625775,
     * 543236128,        -3, 543451494,1717924457,1852252272,1700883232,
     *1768846437,1919971180,1635019119,1847615852,1735357033,1953000748,
     * 544174624,1936287598,1768319331,1634628716,2032170856,1701716084,
     *1751457906,1701210478,1701668206,1948262432, 543781664,1650553701,
     *1679847278, 543236206,1869491571,1885889906,1768120684, 543257711,
     *1830841711,1684368430,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750354, 824206191,1853057395,1952804451,2032165477,
     *1953981797,1847608137,1176512032,1178813992,1130458211,1970037108,
     *1701062944,        -3,1597583926, 539897904, 824192560, 808788014,
     * 808792096, 824197408, 538980384, 807415840, 824188960,        -3,
     *1382379631,1920230756, 543256164, 541286764,1668639841,1952801824,
     * 538989105, 541354342,1717924384,1652105262, 774778414, 774778414,
     * 539248160,1130915171,1797267488,        -3,        -2, 542141541,
     *1634952480,1667786083,1797289832,1702127717,1914729576,1696617009,
     * 544629100,1969561716,1751217184,1769152626,1701867378,1952801824,
     *1768824948,1751457859,1229332579,1869771365,1936748398,1685266464,
     *        -3, 544696692,1746957416,1696617009, 544629100,1969561699,
     *1634493301,1818326117,1679844978,1869422708,1751457904,1634885997,
     *1702126962,1931506549,1886415977,1701060713,1847620712,1696613193,
     *1177428051,1701126241,1948262432, 544499813, 543518308, 544171552,
     *1399153524,1768910368, 590426144,1768824948,1751457831, 778267494,
     * 656437861,1886351988, 543582572,1696622191,1914725477,1952541036,
     *1932402720,1416128883, 544499059,1948281203,        -3, 543318387,
     *1701060719,1847620712,1696624482,1936028278,1701060722,1701211237,
     *1668573551,1847616609,1952522345,1847620712,1696613955,1176527214,
     *1679848037,1718379875,1953066862, 543449460,1629516904,1635000417,
     *1919229984, 543383916,1668639841,1952801824,2003399784, 544499813,
     * 544235890,1634559348,1701999392, 677981797, 773874543,1869767785,
     *1851880549,1932271716,1769173100,1633903981,1701737504,1634624544,
     *2003134823,1752440864,        -3, 544235890,1634559348,1701999401,
     * 544498027,1701716070,1919905056,1952998688,1128875566,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750391,1379016803,
     *1869509481,1937007982,1668882530,1702131557,1701716035,1229332518,
     * 541475654, 675504492,1668639841,1952801833,        -3,1597583927,
     * 539897904, 824192560, 808788014, 808792096, 824197408, 538980384,
     * 807415840, 824188960,        -3,1382379631,1920230756, 543256164,
     * 541286764,1668639841,1952801824, 544690738, 541354342,1717924384,
     *1652105262, 774778414, 774778414, 539248160,1130915171,1797267488,
     *        -3,        -2, 542141541,1634952480,1667786083,1797289832,
     *1702127717,1914729576,1696626514, 840988257,1819632928,1952997748,
     * 543781664,1919250543,1920230756, 543780384,1952998688,1128875552,
     *1668248178,1702064239,1852076832,        -3, 544696692,1746957416,
     *1696626514, 840988257,1819632928,1667329123,1970037108,1701060710,
     *1919905056,1952998688,1885434465,1835365477,1920147571,1970303084,
     *1768252448,1768824948,1751457859,1229336096,1399153952,1635000352,
     * 544499813, 543518308, 544171552,1399153524,1768910368, 590426144,
     *1768824948,1751457831, 778267494, 656437861,1886351988, 543582572,
     *1696622191,1914725477,1952541036,1932402720,1416128883, 544499059,
     *1948281203,        -3, 543318387,1701060719,1847620712,1696624482/
     * )
      ICK( 54001: 54300) = (/
     *1936028278,1701060722,1701211237,1668573551,1847616609,1952522345,
     *1847620712,1696613955,1176527214,1679848037,1718379875,1953066862,
     * 543449460,1629516904,1635000417,1919229984, 543383916,1668639841,
     *1952801824,2003399784, 544499813, 544235890,1634559348,1701999392,
     * 677981797, 773874543,1869767785,1851880549,1932271716,1769173100,
     *1633903981,1701737504,1634624544,2003134823,1752440864,        -3,
     * 544235890,1634559348,1701999401, 544498027,1701716070,1919905056,
     *1952998688,1128875566,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750355, 543387502,1936290676,1701733241, 543319412,
     *2003133806, 541280582, 539369542,1128671299,1634493301,1818326117,
     *1680416800,        -3,1597583928, 538979889, 807411758, 842014770,
     * 774909984, 824197408, 538980384, 807415840, 824188960,        -3,
     *1382379631,1920230756, 543256164, 541286764,1668639841,1952801824,
     * 538976339, 544629100,1969561632, 541354342,1717924384,1652105262,
     * 539248160,1130915171,1797267488,        -3,        -2, 542141541,
     *1634952480,1667786083,1797289832,1702127717,1914729576,1696617248,
     *1986096245,1696625768,1635000425,1931506277,1886351988,1701060713,
     *1847620712,1696613193,1176527727,1920099699,1886350948,1931485216,
     *        -3, 544696692,1746957416,1696617248,1986096245,1696621409,
     *1818457452,1635018084, 543584879,1830843496,1696624737,1918987621,
     *1952805491, 544437616,1886153061,1679845742, 544499813, 541280582,
     * 773857312,        -3, 542336357, 543257632,1952998688,1701733408,
     *1868963923,1701016681,1869488163, 825237609,1847620712,1696605998,
     *1667982887, 544367984,1869771808,1718185061, 543584114, 543450484,
     *1634298995, 773857312,        -3, 542402665,1931506789,1936990313,
     *1931502177,1936024608,1869488244,1751457903,1651729778,1986356256,
     *1919247980,1701016681,1869488228,1635016992,1768824948,1751457862,
     *1128669281,1852055584,        -3, 544367974,1818583924,1768910368,
     *1684108385, 544499809,1948279154,1696621409,1818457452,1635018084,
     * 544696692,1746957416,1696624737,1918987621,1952805491, 539519278,
     *1697521763,1869574756,1768841588,1702046752,        -3, 543451507,
     *1886151011,1701668206,1948279150,1679849317,1768384628, 544235890,
     *1634559348,1701999401, 544498027,1701716070,1919905056,1952998688,
     *1128875566,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750377,1853121906,1886545268,1633840229, 544695657,1734898720,
     *1885434465,1835365477,1920147558,1869750354, 824975479,1379016742,
     * 542318691,1869443169,1919513455,1847599136,        -3,1597583929,
     * 538976288, 807411744, 825237536, 540094496, 891306272, 538980384,
     * 807415840, 824188960,        -3,1315905623,1701406568,1948274785,
     *1920150607,1651712097,1852055619,1634493216,1378954359,1379019859,
     * 544108404, 541288549,1667982692, 538976288, 538976288, 538976544,
     *1231971951,        -3,        -2, 542328901,1280855072,2003134823,
     *1752440944,1634885997,1702126962,1931501938,1696621944,1885692788,
     *1701060724,1864393317, 543648118,1701716073,1847620712,1696622191,
     *1919770996, 543319404,1870084640,        -3,        -2, 543126117,
     *1718185573,1600942943,2003134823,1752459630,1734304869,1952541036,
     *1931485216,        -3, 539452257,1818435703,1026633563,1551064626,
     *1579697775,1580359209, 724054062, 825241648,1344888370,1579888686,
     * 808464432,1348280439,1751478885, 542129448,1181703730,1579889222,
     *1667117662, 690959143,        -3,        -2, 541737294,1092645748/
     * )
      ICK( 54301: 54600) = (/
     *2037146912,2003134823,1752459630,1730177395, 543520880,1701016677,
     *1679848559, 543319328,1734964837,1847617902, 544499813, 543584114,
     *1835103290,        -3,        -2, 543126117,1718185573,1600942943,
     *2003134823,1752459630,1734304869,1952541036,1931487095,1026633512,
     *1551064626,1579698473, 724577840, 808531529,1580359209, 656416800,
     *        -3,        -2, 538985583, 544108404, 543515753,1948284008,
     *1769152627,1953655150,1730178930, 544039275,1696622964, 543780468,
     *1864392992,1952807028, 543321199,1667965026,1702131557,1701716007,
     * 992423456,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750381,1769173861,1679848567,1768844905,1852252258,1634952548,
     * 544173600,1952998688,1634623852,2037606771, 544171552,1952998688,
     *1178813984,1684108385,        -3,1597584176, 538979888, 807411758,
     * 808460320, 775434272, 840974624, 538980384, 807416096, 807411744,
     *        -3,1178813997,1650553701,1679826976,1417111918, 541876599,
     * 608248898,1165194286,1679835713,1397104676,1176519528,1701014304,
     *        -3,        -2, 541288549,1667965044,1751457904,1919905903,
     *1936024608,1417111918, 541876599, 773870696,1696621934,1953659168,
     *1768824872, 689992293,1886545267,1701737587, 544499813, 544240239,
     *1886352229,1679848047,1952543849,1869488160, 543258729,1931503982,
     * 544367971,1768977007,1667329056,1936744803,1696620910,1679848552,
     *1696624494,1696622958, 542858528,1952998688,1668248178,1702064239,
     *1852074350,1730179695,1952543849,1869488233,1931485216,        -3,
     * 543451506,1701016608,1936744803,1697521748,1751457906,1701602678,
     *1634628640,1417111918, 541942132,1919514656,1667329568,1650794598,
     *1869966948, 543780384,1952998688,1718185061, 539438691,1801856814,
     *        -3, 542011252,1698308180,1751741216,1634623852,2037606771,
     * 543781664,1650553701,1679847278, 541468783,1651714346, 707931974,
     * 677601644,1663642154, 840983657,1717986674,1701733221,1931507561,
     *1952981024,        -3, 541468771,1634493225, 707408416,1684108385,
     * 544498027,1701716070,1919905056,1952998688, 657352291,1713840230,
     *1768711456, 677981797, 773867048,1868722985, 740312616,1667329123,
     * 689990761,1937009006,1730752032,        -3, 541150277,1381261113,
     * 858792041,1931502968,1885692788,1701060724,1864394597,1852142177,
     *1952784481,1847620197,1818326117,1679835468,1163023405, 959656224,
     *1634934903,1701604398,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750381,1769173861,1679848567,1768844905,1852252262,
     *1919905056,1178813999,1128875552,1684108385,        -3,1597584177,
     * 538979888, 807411758, 808460320, 775434272, 891306272, 538980384,
     * 807416096, 807411744,        -3,1128875619,1634493254,1128669216,
     *1417111918, 541876599, 608248898,1165194286,1679835713,1397104676,
     *1176519528,1701014304,        -3,        -2, 541288549,1667965044,
     *1751457904,1919905903,1936024608,1417111918, 541876599, 773870696,
     *1696621934,1953659168,1768824872, 689992293,1886545267,1701737587,
     * 544499813, 544240239,1886352229,1679848047,1952543849,1869488160,
     * 543258729,1931503982, 544367971,1768977007,1667329056,1936744803,
     *1696620910,1679848552,1696624494,1696622958, 542858528,1952998688,
     *1668248178,1702064239,1852074350,1730179695,1952543849,1869488233,
     *1847599136,        -3, 543451506,1701016608,1936744803,1697521748,
     *1751457906,1701602678,1634628640,1417111918, 541942132,1919514656,
     *1667329568,1650794598,1869966948, 543780384,1952998688, 657351531/
     * )
      ICK( 54601: 54900) = (/
     *1713840230,1768711470,        -3, 542011252,1698308180,1751741216,
     *1952805748, 543781664,1650553701,1679847278, 541468771,1634493225,
     * 707408416,1986096245,1702043747,1634493301,1818326117,1679849321,
     *1952981108,1751457892,1635016992,1768824948,1751457824, 541280582,
     * 773870696,1769152577,1279611476, 543383918, 543319328,1768386159,
     *1919247392,2003330414, 544503657,1852729710,1730177121,1931502181,
     *1701716065,1684304485,1936942436, 543780384,1952998688,        -3,
     * 544367974,1768842605,1701737504, 675377952,1768842345,1667331173,
     *1679843961, 544499813, 541155955,1701733221, 544171552,1095517522,
     *1415526707, 808005152,1349281121,1936007277,1634428192,1937076837,
     * 544499809,1948262432, 544503657,1852729710,1730177395, 544040302,
     *1953066862,1701060713,1847620712,1696626546,1769235757,1970282607,
     *1713402984,1696625524,1920295796,1970431264,1919250543,1920213103,
     *1914728545,1885696558,        -3,        -1, 589315646,1042305637,
     *1886351988, 544109933,1650815520,1868963919,1296651296,1919247215,
     *1919185696,1768824933,1835165028,1684366368, 779249011, 543582572,
     *1696604192,        -3,1597584179, 538976288, 807411744, 540024864,
     * 538980384, 840974624, 538980384, 807416096, 807411744,        -3,
     *1316318562,1701978223,1713391691,1278037837,1230250066,1701015410,
     *1685266537,1847608685,1650812004,1701060654,1919251232,1181314149,
     * 539248928,1315927141,        -3,        -2, 542402665,1931493708,
     *1163023392,1919250543,1920234272,1869488244,1751457902,1970102885,
     *1914728294, 539447117,1230250088, 543891564, 656437861,1668248164,
     *1931487314,1701211237,1668573551,1853038624,        -3, 544173417,
     *1953785188, 543584879,1830843496,1696623717,1634956333,1936815457,
     *1919251232,1919247977,1852140901,1853106464,1768824948,1751457859,
     *1229332581,1835165028,1684366368, 657355365,1931944038,1768711470,
     *        -3, 541549934,1701994860,1819880480,1952998770,1696625512,
     *1869966436, 543319328,1629513583,1868832882,1700885359,1847617385,
     *1986358816,1718579744,1702388588,1969514862,1730180200,1869833504,
     *1868723045,1920361828,        -3, 543520880,1701996909,1701737569,
     *1814062177,1952522352,1869180532, 544437603,1746952563, 539521121,
     *1920231777,1814634607,1651729269,1918989417,1869488226,2032170088,
     *1696621157,1634541683,1953460270,        -3,        -1, 589315646,
     *1042305637,1886351988, 544109933,1650815520,1868963951,1970564201,
     *1701999392,1768824948,1751457862,1128669286,1768711456,        -3,
     *1597584180, 538976288, 807411744, 540090400, 540094496, 857751840,
     * 538980384, 807416096, 807411744,        -3,1316318562,1701978223,
     *1713383497,1868722989,1231249772,1663643475,1768385889, 676800800,
     *1042297136, 542078324,1818846578,1931488814, 539248928,1130915171,
     *1797267488,        -3,        -2, 542402665,1931493708,1163023392,
     *1919250543,1920234272,1869488244,1751457902,1970102885,1914728294,
     * 544367974,1818583924,1768910451, 543584114, 544696425,1667768393,
     * 678388339, 689987950,1679837480,1667329123, 689971232, 543451494,
     *1717924384,1836020325, 544499809,1948266800, 544500077,1702043731,
     *1768385889,1462640680,1416127776,1818326132,1701978210,1701408359,
     * 544499813, 544436597,1634886944,1919905652, 544171552,        -3,
     * 540094000, 796353897,1734898720,1718579744,1952997748, 544367974,
     *1818583924,1768910368,1768824948,1751457868, 777203232,1919247977,
     *1852140901,1853106478, 542402661, 544367969,1936682528,1718579744/
     * )
      ICK( 54901: 55200) = (/
     *1953001331,1696604192, 543450486,1767994473,1869509408,1936224117,
     *1818501218,1696622958,1986360180,1768382836,1701064224,1466459502,
     * 544434287,2003705972,1864393317, 544438643,1952804193,1953063712,
     *1701999215,1920150560,1953001331,1696604192, 544367974,1818583924,
     *1768910451, 543257189, 543319411,1948283493,1836021349,1679844978,
     *1869422708,1751457906,1701210478,1701668206,1948279150,1679848552,
     *1701409312,1869441395,1936289646, 543584879,1830843496,1696604192,
     * 544367974,1768842605,1701737504,1919250543,1920230756, 543780384,
     *1952998688,1702391909,1919511909,1853120876, 544433507,1953066862,
     * 544171552,1634607201,1936944995,1767994469,1679847521,1885696558,
     *        -3,        -1, 589315646,1042305139,1702192239, 543520884,
     *1768842100,1768910368,1885434465,1835365477,1914729573,1936990240,
     *        -3,1597584181, 538979888, 891302190, 808460338, 774909984,
     * 840974624, 538980384, 807415840, 807411744,        -3,1281454695,
     *1696618081,1819632928,1868963907,1634493230, 542143333,1969516320,
     *1165522025,1852011625,1869488208,1634885997,1702126962, 539248160,
     *        -3,        -2, 541224820,1746957161,1735289190,1768120686,
     *1953265952,1886352233,1953068645, 543256164, 544434535,1852401257,
     *1667329652,1819877486,1701273972,1769366816,1986096245,1702043763,
     *1752135020,1679826976,        -3, 543780470,1869309216,1629516645,
     *1634886504, 543584114, 543236204,1768645996,2032165729,1970496800,
     *1634624544,1629512559,1920099683,1953068645, 543253364,1768910382,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750340,
     *1095585824,1768846196,1920295796,1768910368,1768824933,1835165028,
     *1684366368, 779249011, 543582572,1696604192,        -3,1597584182,
     * 538976288, 807411760, 775233568, 538980640, 840974624, 538980384,
     * 807416096, 807411744,        -3,1416127776,1164796517,1684301156,
     * 539914853,1931495017,1818566729,1852009589,1684370208,1629504577,
     *1297096771,1869442401,1852055598, 539248160,1382379631,1920213024,
     *        -3,        -2, 542402661, 544367969,1936682528,1718579744,
     *1952998688,1970496800,1868963937, 541344077,1344301422,1937011317,
     *1668573551,1847617902, 544499813, 543582574,1634476146,1701210478,
     *1701668206,1948281455,1646272544,        -3, 544434287,1970037792,
     *1650794596,1769169781,1936942436, 796026224,1869771877,1680744487,
     *1145130320, 540028464, 656438120,1869966436, 544108404, 543319328,
     *1970496868, 543584114, 544435553,1819025440,        -3, 544042860,
     *1701016940,1696625253,1718185573,1835363956, 544434542,1667571817,
     *1948282209,1936421664,1852796461,1668247158,1701996389,1852007726,
     *        -3,        -1, 589315646,1042305637,1886351988, 543520880,
     *1869505902,1953063276, 544499058,1830840686, 542328901,1280855072,
     *2003134823,1752440933,2020635237,1936943471,1847599136,        -3,
     *1597584183, 538976288, 807416112, 774905906, 808333344, 874529056,
     * 538980384, 807416096, 807411744,        -3,1466263911,1752440901,
     *2020635237,1936943471,1847608175,1853120873,1853038661,2020634478,
     *1701737577,1634476116,1701997856, 774778414, 539248160,1382379631,
     *1920213024,        -3,        -2, 542402661, 544568165, 544171552,
     *1634607205,2020634478,1701737577,1634476148,1701997856,1768824948,
     *1751457875,1212501080,1277196133,1768384628, 543520880,1919251315,
     *1768910368,1769152622,1869881376,        -3, 544367971,1869442405,
     *1852073316, 543780384,1952998688,1718185569,1814065765,1718185573/
     * )
      ICK( 55201: 55500) = (/
     *1835363956, 544437345,1734680616,1764648238, 544499813, 544499817,
     *1919164528,1634885997,1702126962, 543780384,1952998688,        -3,
     * 542328901,1280855072,1464289364, 544367971,1869767721, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750376,
     *1768384544,1852797984,2003134823,1752440943,1886677357,1769629028,
     * 542318710,1634497893,        -3,1597584185, 540094510, 807416112,
     * 808329269, 808463904, 857751840, 538980384, 807415840, 824188960,
     *        -3,1281454695,1696618081,1819632928,1868963918,1869881384,
     *1397245260,1481386272,1466263911,1752440911,1886677357,1769629028,
     * 542318638, 539248160,1130915171,1797267488,        -3,        -2,
     * 542328901,1280855072,1937074023,1702065267, 795832436,1768778106,
     *1702043764,2003771511,1701406568,1948282977,1918987621,1952805491,
     * 543254893,1768843040,1635000418,1919512167,1768843040,1952998688,
     *1394614304,        -3, 544629100,1969561640,1198485348,1852142451,
     * 762275373,1181316137, 543386735,1936007284,1864380718, 808329300,
     *1751741216, 959658335,1095517522,1411412581,1886351988,1931506792,
     *1696617248,1986096245,1696626536,1701716000, 543318387,1701060719,
     *1847620712,1696625525,1886415977,1701060691,1768385889, 675883296,
     *1986096245,1702043759,1852602670, 541139052,1634887525, 544629100,
     *1969561711,1713402984,1769152622,1869881463,1701406568,1948262432,
     * 544174196,1768778106,1701060691, 543647086,1701994860,1819877481,
     *1852074339,1635018099, 544499813, 544240229,1936027235,1696624486,
     * 543973746,1734680687,1970564201,1701999392,1768824948,1751457892,
     *1635016992,        -3, 544433524, 773866872,1634562156,1702043745,
     *1919230066,1701211237,1668573551,1853038632,1885434484,1767992428,
     *2032738343,1835360627,1970431332, 656433765,1751740004, 544499813,
     * 543319393,1830843252,1869622816,        -3, 539513701,1696620908,
     *1936662593,1279611476,1597583673, 690888788,1751457900,1635021925,
     *1914727535,1998614386,1684369952,1919247980,1701016681,1869509408,
     *1634886944,1650815860, 543974758,1948282741,1948280434,1869422624,
     * 544499813, 543582574,1634476146,1701210478,1701668206,1948284777,
     *1952981089,1847611213,1230250088,1802248297,1853060210,1969452137,
     *1869491744,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750391,1379016818,1701210478,1701668206,1948284777,1952981089,
     *1819025508,1635016992,        -3,1597584432, 538976288, 807411744,
     * 540024864, 538980896, 857751840, 538980384, 807415840, 824188960,
     *        -3,1181970788, 542270822,1768842605,1701737504,1466528872,
     * 541663294, 544088106, 542337383,1835083849, 689983342,1819877422,
     * 774778414, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541159536,1634887022,1953265964, 544170611,
     *1702000229,1679844449,1952522359,1769236512,1226849824,1847601696,
     *1399416685,1630030121, 544695666,1696626035,1701060713,1847620712,
     *1696613930, 707928096,        -3, 543974753,1936990323,1903518066,
     *1702043762,1701210478,1701668206,1949048946,1635018853,1914729576,
     *1634607201,1819025519,1651729778,1986356256,1684108385, 773869676,
     *1700885349, 543778670,1869767968,        -3, 544696421,1847620712,
     *1696621665,1952543589,1948281203, 543519603,1701737577,1634495609,
     * 543387501,1886152052,1696606305,1852055649,1819025522,1701211237,
     *1668573551,1853038709,1936024608,1768824948,1751457824,        -3,
     * 544367974,1768842605,1701737504, 661611123,1702000229,1680289312/
     * )
      ICK( 55501: 55800) = (/
     *        -3,        -1, 589315646,1042306149,1936990310,1869750380,
     *1870078061,1700885365,1919247392,1751870496,1836412020,1768975465,
     *1667855481,        -3,1597584433, 538980398, 807411765, 774905888,
     * 892219424, 857751840, 538980384, 824193056, 807411744,        -3,
     *1098278258,1634166048,1212894240,1298489715,1970431341,1701737504,
     *1299541108,1768975465,1667855481, 539897390, 774778414, 774778414,
     * 539248160,1282373408,        -3,        -2, 541947244,1953067116,
     *1696622699,1814064485,1634956658,1701668206,1953701985,1919230049,
     *1685481843,1701063712,1701409896,1701978223,1713402745,1835885940,
     *1920540786,1701601652,1701060722,1701211237,1668573551,1853038624,
     * 543256164, 795832864,1635000420,1768318565,1919250036, 544240489,
     * 543256167,1818566774,1634497893,1931501938,1869966948, 544499813,
     * 543451494,1718772067,1953066862, 544630115,1953460768,1852797549,
     *1634476148,1864376352, 544499813, 543451494,1718772067,1953066599,
     * 544238689,1852124704,1092642671,1868832877,1970041961,1886153059,
     *1769240864,1769152622,1701143653,1679844975,1914724640,1835360622,
     *1768843110,1970020384,        -3, 544044396,1953049971,1667329568,
     *1650553701,1679844207,1920099683,1953066862, 543584114, 543253107,
     *1869770868,1768910382, 541353332,1634298995, 543383918, 543319328,
     *1718580590,1679845742, 544499813,        -3, 539438691,1801856800,
     *1718185061, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750352,1869181811,1869488244,2037409056,1768846437,
     *1853057396,2032169833,1735221536,1684632436,1919509109,1953066862,
     *        -3,1597584441, 538976288, 807411744, 540024864, 538980384,
     * 891306272, 538980384, 824193056, 807411744,        -3,1433302387,
     *1969318944,1165520997,1919511909,1853120876, 542270822,1818583924,
     *1768910368,1399416685,1630030121, 661856302, 774778414, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 541288549,1667965044,1751457910,1634494820,1769240864,1868963956,
     *1751457903,1651729778,1986356256,1919247980,1701016681,1869488228,
     *1635017006,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1701867378,1952801824,1634624544,1667329123,1970037108,
     *1701060680,1835104288,1684629094,1701995886,1667571752,1718775661,
     * 541280582, 543449460,1630085152,        -3,1597584688, 538976288,
     * 807411761, 808460320, 842018848, 891308320, 538980384, 807415840,
     * 824188960,        -3,1130458211,1970037108,1701060648,1416121697,
     *2015961185,1852055619,1229335890,1701867378,1952801824,1215127928,
     * 541354342,1717924384, 539248928,1433299316,1931485216,        -3,
     *        -2, 542270832,1869771877,1679829097,1847620712,1696613193,
     *1177100385,1852055619,1634493301,1818326117,1679829094,1919905056,
     *1416127860,1630367073,2015390062, 541280582, 689982817,2015905901,
     *1635265581,1215129966, 689971232, 544629100,1969582880,1684629094,
     *1701978210,2032165236, 543974753,1936990319,1852121205,1852404782,
     * 541288549,1667965044,1751457891,1869509481,1937007982,1668882543,
     *1713403745,1986358373,1852273768, 543256164,        -3, 544367984,
     *1869771877,1679848037,1936682101,1953066862, 543449460,1629514100,
     *1701671726,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1701867378,1952801824,1634624544,1667329123,1970037108,
     *1701060683,1835104288,1684629094,1701995886,1667571752,1718775661,
     * 541280582, 543449460,1630085152,        -3,1597584689, 538976288/
     * )
      ICK( 55801: 56100) = (/
     * 807411761, 808460320, 842018848, 891308320, 538980384, 807415840,
     * 824188960,        -3,1130458211,1970037108,1701060648,1416121697,
     *2015961185,1852055619,1229335890,1701867378,1952801824,1265459576,
     * 541354342,1717924384, 539248928,1433299316,1931485216,        -3,
     *        -2, 542270832,1869771877,1679829097,1847620712,1696613193,
     *1177100385,1852055619,1634493301,1818326117,1679829094,1919905056,
     *1416127860,1630367073,2015390062, 541280582, 689982817,2015906669,
     *1635265581,1265461614, 689971232, 544629100,1969582880,1684629094,
     *1701978210,2032165236, 543974753,1936990319,1852121205,1852404782,
     * 541288549,1667965044,1751457891,1869509481,1937007982,1668882543,
     *1713403745,1986358373,1852273768, 543256164,        -3, 544367984,
     *1869771877,1679848037,1936682101,1953066862, 543449460,1629514100,
     *1701671726,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1701867378,1952801824,1634624544,1667329123,1970037108,
     *1701060684,1835104288,1684629094,1701995886,1667571752,1718775661,
     * 541280582, 541352308,1630085152,        -3,1597584690, 538976288,
     * 807411761, 808460320, 842018848, 891308320, 538980384, 807415840,
     * 824188960,        -3,1130458211,1970037108,1701060648,1416121697,
     *2015961185,1852055619,1229335890,1701867378,1952801824,1282236792,
     * 541354342,1717924398, 539248928,1433299316,1931485216,        -3,
     *        -2, 542270832,1869771877,1679829097,1847620712,1696613193,
     *1177100385,1852055619,1634493301,1818326117,1679829094,1919905056,
     *1416127860,1630367073,2015390062, 541280582, 689971277,1635264588,
     *1835104300, 759983465,1848188960, 544629100,1969582880,1684629094,
     *1701978210,2032165236, 543974753,1936990319,1852121205,1852404782,
     * 541288549,1667965044,1751457891,1869509481,1937007982,1668882543,
     *1713403745,1986358373,1852273768, 543256164,        -3, 544367984,
     *1869771877,1679848037,1936682101,1953066862, 543449460,1629514100,
     *1701671726,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750386,1701867378,1952801824, 677998112,1128875561, 543256164,
     * 543253364,1969318944,1215127928, 543451494,1717924453,1852007712,
     *1768824948,1751457862,1128669254,1768711456,        -3,1597584691,
     * 538976288, 824188985, 960045088, 960051488, 824199456, 538980384,
     * 807415840, 824188960,        -3,1382379631,1920230756, 539509577,
     *1177100385,1852055617,1668576609,1814046790,1128671520,1215127928,
     * 541354342,1717924384,1652105262, 539248928,1433299316,1931485216,
     *        -3,        -2, 542270832,1869771877,1679829097,1847620712,
     *1696613193,1177100385,1852055617,1668576609,1814046825,1847620712,
     *1696613955,1177100320,1298233384,1215127928, 741165165,1768827168,
     *1986096245,1702043748,1768318565,1914708000, 543324448,1836020325,
     * 544499809,1847619438,1696626030,1769221664,1130915171,1797285487,
     *1914725473,1952522355,1702109300,1920298595,1635019119,1848516640,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750386,
     *1701867378,1952801824, 677998112,1128875561, 543256164, 543253364,
     *1969318944,1265459576, 543451494,1717924453,1852007712,1768824948,
     *1751457862,1128669254,1768711456,        -3,1597584692, 538976288,
     * 824188985, 960045088, 960051488, 824199456, 538980384, 807415840,
     * 824188960,        -3,1382379631,1920230756, 539509577,1177100385,
     *1852055617,1668576609,1814046790,1128671520,1265459576, 541354342,
     *1717924384,1652105262, 539248928,1433299316,1931485216,        -3/
     * )
      ICK( 56101: 56400) = (/
     *        -2, 542270832,1869771877,1679829097,1847620712,1696613193,
     *1177100385,1852055617,1668576609,1814046825,1847620712,1696613955,
     *1177100365,1635264587,1835104300, 759917929,1848189046,1634497893,
     *1931485216,        -3, 543451494,1717924384,1652105325,1869767968,
     *1952997742, 544173669, 544566889,1949179971,1751475051, 543584114,
     * 543449460,1629516645,1948284018,1970168673,1953066862, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750386,
     *1701867378,1952801824, 677998112,1128875561, 543256164, 543253364,
     *1969318944,1282236792, 543451494,1717924453,1852007712,1768824948,
     *1751457862,1128669286,1768711456,        -3,1597584693, 538976288,
     * 824188985, 960045088, 960051488, 824199456, 538980384, 807415840,
     * 824188960,        -3,1382379631,1920230756, 539509577,1177100385,
     *1852055617,1668576609,1814046790,1128671520,1282236792, 541354342,
     *1717924384,1652105262, 539248928,1433299316,1931485216,        -3,
     *        -2, 542270832,1869771877,1679829097,1847620712,1696613193,
     *1177100385,1852055617,1668576609,1814046825,1847620712,1696613955,
     *1177100365,1635264588,1835104300, 759983465,1848189046,1634497893,
     *1931485216,        -3, 543451494,1717924384,1652105325,1869767968,
     *1952997742, 544173669, 544566889,1949179971,1751475051, 543584114,
     * 543449460,1629516645,1948284018,1970168673,1953066862, 773857312,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750371,
     *1634493301,1818326117,1679829076,1751479393, 762143096, 689987950,
     *1679843683,1953849708, 541617505,2015388777,1717986674,1701733221,
     * 543780384,1952998688,1178813984,        -3,1597584694, 538976288,
     * 824188985, 960045088, 960051488, 824199456, 538980384, 807415840,
     * 824188960,        -3,1130458211,1970037108,1701060648,1416121697,
     *2015961185,1852055617,1668576609,1814046790,1128671520,1215127928,
     * 541354342,1717924384, 539248928,1433299316,1931485216,        -3,
     *        -2, 541286764,1668639841,1952801824, 675705455,1830835304,
     *1702125869,1298233376,1768824948,1751457859,1229334816,1634624544,
     *1097036917,1634476072,1768824948,1751457862,1128671520,1298233384,
     *1215127928, 741165165,1768827168, 544629100,1969582880,1684629094,
     *1701978210,2032168303,1919230068,1751215648,1869505824,1970170228,
     * 773866344,1701014304,1718579744,1684108385, 544433524, 544502389,
     *1852006772,1768910382,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750371,1634493301,1818326117,1679829076,1751479393,
     * 762143096, 689987950,1679843683,1953849708, 541814113,2015388777,
     *1717986674,1701733221, 543780384,1952998688,1178813984,        -3,
     *1597584695, 538976288, 824188985, 960045088, 960051488, 824199456,
     * 538980384, 807415840, 824188960,        -3,1130458211,1970037108,
     *1701060648,1416121697,2015961185,1852055617,1668576609,1814046790,
     *1128671520,1265459576, 541354342,1717924384, 539248928,1433299316,
     *1931485216,        -3,        -2, 541286764,1668639841,1952801824,
     * 675705455,1830835304,1702125869,1298233376,1768824948,1751457859,
     *1229334816,1634624544,1097036917,1634476072,1768824948,1751457862,
     *1128671520,1298233384,1265459576, 741165933,1768827168, 544629100,
     *1969582880,1684629094,1701978210,2032168303,1919230068,1751215648,
     *1869505824,1970170228, 773866344,1701014304,1718579744,1684108385,
     * 544433524, 544502389,1852006772,1768910382,        -3,        -1,
     * 589315646,1042306149,1936990310,1869750371,1634493301,1818326117/
     * )
      ICK( 56401: 56700) = (/
     *1679829076,1751479393, 762143096, 689987950,1679843683,1953849708,
     * 541879649,2015388777,1717986674,1701733221, 543780384,1952998688,
     *1178813984,        -3,1597584696, 538976288, 824188985, 960045088,
     * 960051488, 824199456, 538980384, 807415840, 824188960,        -3,
     *1130458211,1970037108,1701060648,1416121697,2015961185,1852055617,
     *1668576609,1814046790,1128671520,1282236792, 541354342,1717924398,
     * 539248928,1433299316,1931485216,        -3,        -2, 541286764,
     *1668639841,1952801824, 675705455,1830835304,1702125869,1835104288,
     *1768824948,1751457859,1229334816,1634624544,1097036917,1634476072,
     *1768824948,1751457862,1128671520,        -3, 541942136, 676097377,
     *2016161100,1835626025, 544629100,1969582880,1684629094,1701978210,
     *2032168303,1919230068,1751215648,1869505824,1970170228, 773866344,
     *1701014304,1718579744,1684108385, 544433524,        -3, 544502389,
     *1852006772,1768910382,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750386,1701211237,1668573551,1853038711,1769236512,
     *1226849312, 758262387,1768385889, 675883296,        -3,1597584944,
     * 538976288, 807411744, 540024864, 960051488, 857751840, 538980384,
     * 807415840, 824188960,        -3,1316318562,1701978223,1713391982,
     *1952804467,1769236837,1931507561,1952981065, 540811309, 540158547,
     *1768385889, 675883296, 774778414, 539248928,1130915171,1797267488,
     *        -3,        -2, 541947244,1953067116,1696625524,1919905383,
     *1819877486,1701273972,1769366816,1768846437,1853057396,1768256288,
     *1835104544,1650794601,1852074339,1635019126,1696622191,1914728559,
     *1869750377,1853121895,1918989417,1869488160, 544171552,1952998688,
     * 543451494,1718772067,1953066862, 543780193,1734701870, 542404463,
     * 544039278,2032168549,1734440041,1986338921,1853121902,1936290921,
     *1702043757,1635328114,1702065516,1948281198,        -3, 543713639,
     *1751478816,1952997742, 544568181,1634476151,1379016822,1634497893,
     *1932402720,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750369,1651729774,1667571823,1713401445,1734440041,1986338927,
     *1651729778,1986356256,1768846437,1853057396,1768256288,        -3,
     *1597584945, 538976288, 807411744, 540024864, 538980384, 891306272,
     * 538980384, 807415840, 824188960,        -3,1147237473,1936028704,
     *1131376244,1634299507, 544108320,1315268449,1953068645, 541683316,
     *1701737321,1953064307, 539897390, 774778414, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 541549934,
     *1701994860,1819880480,1651471464, 544239475,1769236854,1696620910,
     *1679848300,1768384628,1819877486,1701273972,1769366816,1768846437,
     *1853057396,1768256288,1634886944,1702391909,1668572516, 543780384,
     *1629495328, 543449460,1629516645,1949179986,1702061428,1953066599,
     * 544105831,1635019126,1696622958,1952804467,1769236837,1931506799,
     * 544892274,1864396129,2032165481,1634934900,1751457906,1701210478,
     *1701668206,1948262432,        -3, 544367987,1970041971, 543256164,
     * 544499813, 539451758,1634498931,1769155951,1714255457,1919508846,
     *1667573536,1634934898,1701867378,1952801824,1697539886, 543780384,
     *1952998688, 542328901,1280855072,1869968496,1970544672, 543975795,
     *1953066599, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750377,1852863860, 544367974,1818583924,1768910451,
     * 544696692,1746948969,1735221544,1227431997, 540028464,        -3,
     *1597584946, 538976288, 807411744, 540024864, 538980640, 891306272/
     * )
      ICK( 56701: 57000) = (/
     * 538980384, 807415840, 824188960,        -3,1316318562,1701978148,
     *1092624466,1701602659,1953066862,1931507561,1952981075,1768385889,
     * 675883296,1025519662, 807412809, 542011252,1696604192,        -3,
     *        -2, 542270822,1818583924,1768910451, 544696692,1746948969,
     *1730693417, 540876848, 774905953,1919230067,1970499685,1668554849,
     *1852055650,1702065184,1818584692, 544175476, 544171552,1952998688,
     *        -3, 544367974,1768842605,1701737518, 542402665,1931506809,
     *1885675631,1713402469,1718379875,1953066862,1931507561,1819025522,
     *1702065516,1948281198, 544044396,1953067116,1696616992, 639652653,
     *1986096245,1696604192,        -3, 543451494,1717924453,1852007712,
     *1095517522,1414737440,1315927141, 975197039,1835365481,1835365152,
     *1937073000, 543236144, 774909984,1986096245,1696623969,2032165477,
     * 544367980,1635018084, 544501536,1952998688,        -3, 543975789,
     *1769235812, 544109933,1650815520,1868963954,1701867378,1952801824,
     *1684366185,1835101299, 543780384,1952998688,1178813984,1718185061,
     * 543257376,1869639791,1936024608,1953439860,1752134501, 543780384,
     *        -3, 544499813, 544566899,1667329125,1679848814,1835364967,
     *1701060680,1263280230,1768711470,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750370,1869899808,2003134823,1752459630,
     *1730179169,1918987621,1952805408,1986096245,1702043770,1701998368,
     * 676546629,1280855081,        -3,1597584947, 538980398, 807411760,
     * 774905888, 808333344, 840974624, 538980384, 807415840, 824188960,
     *        -3,1114600552, 542328901,1280855072,1464158535,1213472848,
     *1634885997,1702126962, 542531948,1969582880,1516597871, 539897390,
     * 774778414, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541288549,1667965045,1853191029,1634476146,
     *1701867378,1952801839,1919247977,1852138528,2053468783, 542328901,
     *1280855072,2003134823,1752440944,1634885997,1702126962, 544629100,
     *1969582894,        -3, 542011252,1698308179,1212501080,1277196137,
     *1819025518,1869881458,1701210478,1696625775, 544105831,1635019126,
     *1696626273,1819633011, 773857312,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750371,1869509481,1937007982,1668882543,
     *1713394504,1162631244, 544695657,1734898720,1885434465,1835365477,
     *1920147561,1847608137,1176512032,1701667429,1684301156, 539914853,
     *1931485216,1597584948, 538980398, 807411760, 774905888, 825110560,
     * 840974624, 538980384, 807415840, 824188960,        -3,1397245260,
     *1481384023,1162430280,1411403873,1915625558,1634497893,1931503982,
     * 541280582, 539369554,1163075652,1768318565,1914711598, 538976288,
     * 542141541,1634952480,1130915171,1797267488,        -3,        -2,
     * 542406511, 544695657,1734898720,1885434465,1835365477,1914730081,
     *1819633011, 544367984,1869771877,1679845742, 544499813, 541280582,
     * 544695657,1734898720,1702391922,1702065001,1869488243,1953655150,
     *1730158624,        -3, 539451250,1701210478,1700752499,1601660265,
     *1734898793,1852268388,1702125929,1819485984,1634886944,1718580590,
     *1679848559, 543451494,1717924384,1718775661, 544499823,1936007265,
     *1919117417,1986356256,1768824948,1751457824, 542590792,1411412065,
     *1918987621,1952805408,1986096245,1696623721,1936990313,1847620712,
     *1696621933,1650812004,1701060647, 745694579, 656434793,1818570272,
     *1416127776,1818326132,1701978230,1634497893,1931501938,1696604192,
     * 543257459,1970103652, 544501536,1650794612,1751457891,1869771365/
     * )
      ICK( 57001: 57300) = (/
     *1668554863,1852142368,1634934896,1634890784,1868963956,1751457894,
     *1768841580, 544367974,1768842605,1701737518,        -3, 542270819,
     *1919246708,1768910368,1868963956,1751457862,1128669286,1919905056,
     *1952998688,1701667429,1684301156, 539438697,1853040416, 639641390,
     *1751870503, 543582572,1702043767,1768713248,1919251317,1819549801,
     *1847599136, 543780451,1869509481,1937007982,1948284754, 840982894,
     *1679840032,1986096245,1702043745,1852055649,1936944995,1767994469,
     *1679835468,1163023443, 543780384,1952998688,1667786083,1799571782,
     * 544367984,1869771808,        -3, 544696421,1847620712,1869833504,
     *2003134823,1752440944,1634885997,1702126962, 544629100,1969582880,
     *1684629094,1701981728,1349281121,1936007265,1819504416,1667786083,
     *1797289064,1696624754,1869636978,        -3, 543584114,1835103264,
     *1868963956,1751457875,1212501080,1277196133,1768384628, 543520880,
     *1919251315,1768910368,1937011305,1852255776,        -3,        -1,
     * 589315646,1042306149,1936990327,1751479400,1701978228,1751457875,
     *1212501080,1277196133,1768384628, 544174196,1768778099,1635019119,
     *1847617633,1931502447,1853252978,1734698016,        -3,1597584949,
     * 538980398, 807411760, 774905888, 808333344, 840974624, 538980384,
     * 807415840, 824188960,        -3,1416127776,1397245260,1481384023,
     *1162430280,1411403632,1953066345,1935766633,1869488232,1634934894,
     *1869881411,1869510245,1919378788, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 542402665,1931493708,
     *1163023392,1769152626,1634300773,1679849320,1701716084,1751457911,
     *1701406568,1953066599, 544235890,1634559348,1701978230,1634497893,
     *1931506277,1886351988,1701060713,1847620712,1696604192,        -3,
     * 541280582, 543518050,1701078117,1679828782,1919251239, 543582572,
     *1696622191,1914716448,1869750338, 543257376,1970496868, 543780384,
     *1952998688,1397245260,1481384050,1701210478,1701668206,1948279913,
     *1717986674,        -3, 544434535,1852401257,1667329652,1819877478,
     *1919905056,1953001331,1696625525,1734829427,1952801824,1635000436,
     *1751457893,1852055663,1713402984,1696605998,1919251239, 543582572,
     *1697525280,        -3, 541156452,1769236847,1851878432,1919247977,
     *1852140901,1853104227,2036558949,1931501938,1696620900,1986622309,
     *1679848819,1768843040,1952998688, 676546629,1280855081, 544437607,
     *1734701940,1701060718,1702305824,        -3, 542590792,1411412065,
     *1918987621,1952805408,1986096245,1702047264,        -3,        -1,
     * 589315646,1042306149,1936994162,1701867378,1948274509,1230250100,
     *1752327539,1752132708, 543388265,1952805481,1970086006,1634497893,
     *        -3,1597584950, 538976288, 807411744, 540024864, 538980384,
     * 891306272, 538980384, 807415840, 824188960,        -3,1315927141,
     * 975195759,1848464244,1634624609,1919164456,1764648238, 540159536,
     * 689983309,1230250068,1752327539,1752132708, 538996582, 539248160,
     *1399416616,1227431968,        -3,        -2, 542402661, 543387502,
     *1986358900,1768910433,1814056781,1230250100,1752327539,1752132708,
     * 543781664,1228812892,1932020009, 773870696,1769152577,1279611476,
     * 544367984,1869771891, 544499813, 544568165, 544171552,        -3,
     * 543236196,1702259041,1953066599, 544629100,1969561701,1717986659,
     *1953066599, 543501927, 773878888,1696625253,1886351988,1701060690,
     * 824211041,1819632942,        -3,        -1, 589315646,1042305637,
     *1886351988, 544499813,1952522339,1970564966,1713383503,1296651305/
     * )
      ICK( 57301: 57600) = (/
     * 544367971,1869767712,1768824933,1835165028,1684366368, 779249011,
     *        -3,1597584951, 538976288, 807411744, 540024864, 538980384,
     * 891306272, 538980384, 807415840, 824188960,        -3,1315927141,
     * 975197303,1865241704,1702125856,1131770991,1717968982,1634497893,
     * 543780384,1164796517,1684301156, 539914853,1931488814, 539248160,
     *1147496306,1701126176,        -3,        -2, 541683232,1734700645,
     *1918987308, 544367974,1768842605,1701737504,2003399784, 543255660,
     * 543520880,1701996909,1701737569,1814065765,1718379875,1953066862,
     * 543449460,1629514099, 543253622,1769170276, 773865760,        -3,
     * 544499813,1952538467,1970564966,1713403489,1819632928,1835104544,
     *1650794595,1869509481,1684370021,1679848559, 543258223,1768169586,
     *1701210478,1701668206,1948282734, 544108393,1936007270,1869750304,
     *        -3, 544367987,1869378932,1768910368,1936221548,1819484279,
     *1769236512,1011429203,1768385889,1042299936, 841634665,1735221550,
     *        -3,        -1, 589315646,1042305637,1886351988, 539445349,
     *1852711013,1948279148, 774316144,1919247465,1668572516, 543256164,
     * 542256486,1633907823,1915578209,1881175649,1819633011,        -3,
     *1597584953, 538976288, 807411744, 540024864, 538980384, 891306272,
     * 538980384, 807415840, 824188960,        -3,1416127776, 659055982,
     *1847616884, 543255598, 656429613,1180787572,1869753703,1634738294,
     *1634497893, 539897390, 774778414, 774778414, 539248160,1315927141,
     *        -3,        -2, 542270832,1869771808,1869488240,1919247465,
     *1668572516, 544690738, 740319841,1936024608,1869488227,1869966964,
     *1768843040,1937006964,1769174121,1668492320,1869750355,1212501080,
     *1277195124,2037146912,        -3, 544695657,1734898793,1852252257,
     *1931502447,1836081522,1701060724,1864397928,1696620899,1953849708,
     * 544367974,1768842596, 544690738, 773857312,        -3, 542336357,
     * 975194670,1214606958, 539369537, 777216872,1869507685,1650815532,
     * 541156212,1629504370,2037609518, 539505200, 825436448,1094072620,
     * 540357689, 758461752, 773857312,        -3,        -1, 589315646,
     *1042306149,1936994162,1701867378,1948280172,1701016690,1869488228,
     *1768318578,1633907817,1869488228,1635016992,        -3,1597585200,
     * 538976288, 807411744, 540024864, 538980384, 891306272, 538980384,
     * 807415840, 824188960,        -3,1382377065,1852140901,1853104210,
     *1701934441,1919251232,1164731747,1953656686, 542335841,1953785202,
     *1768843040,1180787572,1869771552, 538976288, 542141541,1634952480,
     *1130915171,1797267488,        -3,        -2, 541139059,1953658211,
     *1953854053, 543318387,1701060719,1847616876,1701016690,1869488228,
     *1768318578,1633907817,1869488233,1931506277,1886351988,1701064224,
     *        -3, 542141541,1634952480,1667786083,1797285487,1914729576,
     *1696626035,1696624486, 544240239,1885696544,1701602659,1953656686,
     * 544432993,1953785202,1768843040,1717658484,1869771552,1768824948,
     *1751457824,        -3, 544367974,1768842605,1701737518, 542649714,
     *1635328115,1667331188,1701996910,1730176609,1668575090,1931501938,
     *1696624239,1948279152,1886547824,1919508852,1696622191,1914724640,
     *1397245260,1481384034,1634952548,        -3, 544367974,1768842605,
     *1701737518,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750380,1634887525, 544239475,1769236854,1696621409,1818453024,
     *1919251305,1685414252, 543450478,1936290937, 544105825,1914724640,
     *1751474550,2032165236,1869422707,1769235744,        -3,1597585201/
     * )
      ICK( 57601: 57900) = (/
     * 540094005, 807416366, 892346419, 775237664, 840974624, 538980384,
     * 807416096, 807411744,        -3,1130915171,1797276513,1818453024,
     *1382380393,1680744516,1701737262, 608313414,1919905056, 608247844,
     *1176528193, 758325280,        -3,        -2, 541139020,1634887525,
     *1914729576,1634607205,2020631907,1952801824,1919251305,1685414252,
     * 543450478,1936290937, 544039288,1768781165, 544175476,1936286821,
     * 543236200,1700886137, 543257711,1830824045,1702125932, 689971232,
     * 543977315,1635019119,1847617907, 543450484,1701016677,1679845742,
     * 543256096,1768842341,1885695588,1701737580,2032165729,1818457452,
     *1635018084, 543451494,1717924453,1852007712,1684369011,1769240864,
     *1835102240,        -3, 539522419,1768843040,1952998688,1095322912,
     *1836016741,1814638112,1232368416,1684632436,1634624357, 544501536,
     *1952998688,1751474550,2032165236,1869422697,1931506809,1885954913,
     *1819048224,1635000417,1919907182,1679826976, 540028473, 541159015,
     * 773867892, 543781664,1954115689,1667329132,2032169573,1818326117,
     *1679848559, 543780449,1684369781,1635018016,1668248178,1701016681,
     *1869488230,1869750369,1651732338,1886677359,1848516640,        -3,
     * 541483363,1696622958,1684371561,1852252258,1634952548, 543387506,
     *1919247220,1768910368,1835624296,1948279397, 544105829,1684366368,
     *1718579744,1751738216, 544044320, 706769440,1935764848,1818587950,
     * 541684768,        -3, 544041319,1752440929,1819504416,1650794595,
     *1635087205,1679843961, 544566881,1667460981,1853121892, 543584114,
     * 544503657,1852729710,1730945124,1769172850,1684369964, 544698991,
     *1852271737, 543257459,1768386149,1679826976, 543257711,1830843513,
     *1885696812, 544698991,1852252275,2037214565,1953659180, 544566881,
     *1667460981,1853121892, 543584114, 544436076,1986358900, 543256164,
     * 544175208,1701978221,1868850540, 543519346,1869771566,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750380,1634887525,
     * 544105831,1635019126,1696621409,1818457452,1635018084, 544367987,
     *1768191329,1814062181,1853057396,2032168821,1953720676,1696623973,
     *1952541728,1819239214,        -3,1597585202, 540094005, 807416366,
     * 892346419, 775237664, 840974624, 538980384, 807416096, 807411744,
     *        -3,1130915171,1797276513,1818453024,1382380393,1680744516,
     *1701737262, 608313414,1919905056, 608247844,1176528193, 758325280,
     *        -3,        -2, 541876594,1734701600,1952997742, 543520880,
     *1701016677,1679848037,1936286837,1634476132,1701737321,1954095213,
     *1768843629,1970085999,1970565993,1684349037,1702125932, 543257711,
     *1830841455,1667331177,1869509422,        -3, 542402665,1931505001,
     *1734898720,1650794595,1635087205,1679843961, 544566881,1667460981,
     *1853121892, 543584114, 544503657,1852729710,1730945143,1919905383,
     *1819877473,1936943463,1852138528,1635020653,        -3, 544504176,
     *1702043745,1852055663,1952998770, 544042852,1701584997,1920102258,
     *1932402720,        -3, 542011252,1698308180,1751741216,1986096245,
     *1696622963, 543318387,1701060719,1847615854, 541160559,1831692654,
     * 760049516,1701016940,1696606273,1229793568,1684629094,1701995886,
     *1667571812,1701737321,1954095213,1634738208, 543383916,1668639841,
     *1953066862, 543256164, 544039289, 543451494,1717924384,1936287598,
     *1768319331,1634628716,2032166511,1914724640,1919247977,1852140901,
     *1853104245,1936289383, 543236128,        -3, 544108398, 762540136,
     *1701996899,1634476129,1953459488,1836016741,1814962208,        -3/
     * )
      ICK( 57901: 58200) = (/
     *        -1, 589315646,1042306149,1936990310,1869750380,1634887525,
     * 544239475,1769236854,1696621669,1853057396,2032168814, 544040308,
     *1634476129,1953459488,        -3,1597585203, 540094000, 807411761,
     * 775233568, 841887776, 840974624, 538980384, 807416096, 807411744,
     *        -3,1130915171,1797276513,1818453024,1349481321,1953068645,
     * 542270835,1768173088,1147498099,1769240864,1869488164,1092625478,
     * 543506733, 857743392,        -3,        -2, 541876594,1734701600,
     *1952997742, 543520880,1701016677,1679848037,1936286837,1634476132,
     *1701737321,1954095213,1635281261,1970085999,1847618917,1952541728,
     *1635020653, 543977315,1635019119,1848516640,        -3, 542402665,
     *1931505001,1734898720,1650794595,1635087205,1679843961, 544566881,
     *1667460981,1853121892, 543584114, 544503657,1852729710,1730945143,
     *1919905383,1819877473,1936943463,1852138528,        -3, 543257711,
     *1830843513,1885696800,1634624544,1869899877,1914727791,1684368416,
     *1701999215,1920151072,1097756532,1751478816,1667331443,1696623969,
     *2032165477, 543236179,1212501080,1277175620,1095585824, 807415847,
     *        -3, 543780467,1953658211,1953066862, 543584114, 543236206,
     *1869491555,1869510245,1919378788, 544367974,1768842605,1701737518,
     *        -3,        -1, 589315646,1042306149,1936990310,1869750380,
     *1634887525, 544105831,1635019126,1696621669,1853057396,2032165740,
     *1869833504,1953439853,1702125932, 543257711,1830821920,        -3,
     *1597585204, 540094000, 807411761, 775233568, 841887776, 840974624,
     * 538980384, 807416096, 807411744,        -3,1130915171,1797276513,
     *1818453024,1315268449,1953068645, 542270835,1768173088,1147498099,
     *1769240864,1869488164,1092625478, 543506733, 857743392,        -3,
     *        -2, 541876594,1734701600,1952997742, 543520880,1701016677,
     *1679848037,1936286837,1634476132,1701737321,1954095213,1768843629,
     *1970085999,1847618917,1952541728,1635020653, 543977315,1635019119,
     *1848516692,1751741216,        -3, 544041319,1752440930,1696621409,
     *1970496868, 543324448,1970168163,1668248942,1952801824,1718579744,
     *1953982830,1852403303, 740325234,1869506412,2032165235,1936287598,
     *1701060705,1953459488,1954115685,1931485216,        -3, 543256164,
     * 544175208,1701978221,1868850540, 543519346,1869771566, 541159023,
     *1952998770, 543383925,1936007277,1635328098,1696620832,1397245260,
     *1481383975,1145130320, 540024880, 656435566,1937011317,1668573551,
     *1847599136, 543584114, 543236206,1869491555,1869510245,1919378788,
     * 544367974,1768842605,1701737518,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750384,1869834612,1769366816,1684369011,
     *1769240864,1852137842, 541991023,1914720032,        -3,1597585205,
     * 540028467, 807411761, 775233568, 841887776, 840974624, 538980384,
     * 807416096, 807411744,        -3,1130915171,1797276513,1818453024,
     *1382380393,1680744516,1701737262, 608313414,1919905056, 608247844,
     *1176528193, 758325280,        -3,        -2, 542142323,1769236854,
     *1696621669,1853057396,2032166511,1970168864,1768824929, 543451494,
     *1717924453,1852007712,1684369011,1769240864,1835102240,1635000417,
     * 544239475,1769236847,1847621481,1952999790,        -3, 543321966,
     *1684631143, 543451507,1952542307,1696622191,1914724640,1210933620,
     *1869422694,1919905056,1629515369,1953656679,1701716079,1914728312,
     *2036819310, 543257711,1831739457,        -3, 544239475,1936286316,
     *1696625253,1634955118, 543383918, 543319328,1629515113,1936943470/
     * )
      ICK( 58201: 58500) = (/
     *1730177145,1685221223,1701716065,1953459502, 541158515,1864393576,
     *1701014304,1718579744,1952544116,1869440370,1769172270,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750382,1701273972,
     *1769366816,1684369011,1769240864,1852137842, 541991023,1914720032,
     *        -3,1597585206, 540028467, 807411761, 775233568, 841887776,
     * 840974624, 538980384, 807416096, 807411744,        -3,1130915171,
     *1797276513,1818453024,1382380393,1680744516,1701737262, 608313414,
     *1919905056, 608247844,1176528193, 758325280,        -3,        -2,
     * 542008679,1635019126,1696621669,1853057396,2032166511,1970168864,
     *1768824929, 543451494,1717924453,1852007712,1684369011,1769240864,
     *1835102240,1635000417, 543977315,1635019119,1847621481,1952999790,
     *        -3, 543321966,1684631143, 543451507,1952542307,1696622191,
     *1914724640,1210933620,1869422694,1919905056,1629515369,1953656679,
     *1701716079,1914728312,2036819310, 543257711,1831739457, 544239475,
     *1936286316,1696604192,        -3, 544367969,1936682528,1667329568,
     *1650794593, 544041331,1634956137,1735288164, 541601121,1953459502,
     * 541158515,1864393576,1701014304,1718579744,1952544116,1869440370,
     *1769172270,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750382,1701273972,1769366816,1684369011,1769240864,1869488200,
     * 761361519,1830842479,1936290921,1869509408,        -3,1597585207,
     * 540028467, 807411761, 775233568, 841887776, 840974624, 538980384,
     * 807416096, 807411744,        -3,1130915171,1797279333,1734440041,
     *1986338884,1768318565,1919250019,1696613477,1853057396,2032168814,
     * 539246880, 773858374, 543506733, 857743392,        -3,        -2,
     * 542008679,1635019126,1696621669,1853057396,2032166511,1970168864,
     *1768824929, 543451494,1717924453,1852007712,1684369011,1769240864,
     *1835102240,1635000417, 541601121,1953459488,1819239265,1953066862,
     * 773857312,        -3, 541139058,1700885359,1847618921,1734898720,
     *1650794593,1847617902,1668248178,1701016608,1095125336, 543780467,
     *1953658211,1953066862, 773857312,        -3,        -1, 589315646,
     *1042305637,1886351988, 544109933,1650815520,1868963939,1634952563,
     * 544696692,1746956399,1936290921,1986338916,1701737321,1954095215,
     *1847608109,1126195823,1852076832,        -3,1597585208, 538976288,
     * 807411744, 540155936, 538980896, 840974624, 538980384, 807416096,
     * 807411744,        -3,1316318562,1701978179, 759373890,1869505651,
     * 544696692,1746948207,1936290921,1986338898,1702062436,1969318944,
     *1147498099,1769240878, 539248928,1231971951,        -3,        -2,
     * 541354342,1717924453,1852007712,1684369011,1769240864,1835102323,
     * 543647086,1701994860,1819877491,1752135456,1919251305,1685414252,
     * 543450478,1936290921,1702043759,1847608109,1126195823,1852076832,
     *2003330414,        -3, 543236211,1953658211,1953854053, 543781664,
     *1919247977,1852138528,2003399784, 544499813, 541149517, 544042852,
     *1701588512,1092645737,1735289190,1768120686,1948282485,1835165042,
     * 544171552,1953001331,1696623969,2032148512, 543780452,1768120692,
     *1696622447,1868832868,1635017006, 541286771,1702043767,1751478885,
     * 544499817,1931505269,1835165042, 543781664,2053468783, 544434287,
     *1970037792,1650794601,1853252979,1953064801,1952801824,        -3,
     * 543584114, 544499813, 544367969,1936682542, 542402661, 544568165,
     * 544171552,1634955368,1701996899,1634476147,1667331188,1701996910,
     *1730176609,1668575090,1931503982, 544499813, 544367974,1768842605/
     * )
      ICK( 58501: 58800) = (/
     *1701737504,        -3, 544042852,1701585005,1635328098,1696624494,
     *1697521696,        -3,        -1, 589315646,1042305637,1886351988,
     * 544499813, 544568165, 544171552,1315918704,1751478849, 840987491,
     *1635021925,1919512167, 543580515,1953460851,        -3,1597585209,
     * 538976288, 807411744, 540024864, 960051488, 824197408, 538980384,
     * 807415840, 824188960,        -3,1315918704,1751478849, 840979299,
     *1635021925,1919512167, 541483363,1953460851, 542471013,1679830574,
     * 774778414, 774778414, 774778414, 538976288, 542141541,1634952480,
     *1315927141,        -3,        -2, 542011246, 762540136,1701996899,
     *1634476147,1667331188,1701996910,1730176609,1668575090,1931507557,
     *1919230069,1936024608,1768824948,1751457906,1701210478,1701668206,
     *1949179987,1869440288,1095517522,1414733856,        -3, 544499809,
     *1948279155,1937075557, 544436328,1701996899,1634476147,1667331188,
     *1701996910,1730176609,1668575090,1931501938,1696625525,1886417509,
     *1936942436, 773857312,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750382,1869491578,1701998368,1853189474,1701978223,
     *1713398126,1869439340,1869968160,1935892852,1952805481,1852252262,
     *1633907823,1920147488,        -3,1597585456, 538976288, 807411744,
     * 540024864, 960051488, 824197408, 538980384, 807415840, 824188960,
     *        -3,1315905601,1852796257,1819243891, 542335841,1953785202,
     *1768843040,1180787572,1869771552,1181709678,1679845742, 541280582,
     * 539897390, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541288549,1667965030,1869750381,1769173865,
     *1852252257,1852796257,1819243891, 544432993,1953785202,1768843040,
     *1717658484,1869771566,        -3,        -1, 589315646,1042306149,
     *1936990310,1869750382,1869491578,1701998368,1713512545,1852796257,
     *1819243891, 544432993,1953785202,1768843040,1717658484,1869750390,
     *1634497893,1931485216,        -3,1597585457, 538976288, 807411744,
     * 540024864, 960051488, 824197408, 538980384, 807415840, 824188960,
     *        -3,1315905646,1869491578,1701998368,1713512513,1852796257,
     *1819243891, 542335841,1953785202,1768843040,1449225333,1702043718,
     *1869966948, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541288549,1667965030,1869750382,1869491578,
     *1701998368,1713512545,1852796257,1819243891, 544432993,1953785202,
     *1768843040,1717658484,1869750390,1634497893,1931503982, 544499813,
     * 541280582, 773857312,        -3, 542011252,1698308186,1701998368,
     *1986096245,1702043745,1919230051,1869771365,1668554854,1869750355,
     *1212501080,1277185349,1380393012, 544367974,1768842605,1701737587,
     * 773857312,        -3,        -1, 589315646,1042306149,1936990324,
     *1751457889,1852796257,1819243891, 544432993,1953785202,1768843040,
     *1717658484,1869750374, 656438881,1819633011, 543254369,1768846196,
     * 541683316, 773870689,1651271027,        -3,1597585458, 538976288,
     * 807411744, 540024864, 960051488, 824197408, 538980384, 807415840,
     * 824188960,        -3,1416127780,1092896288,1147500137,1635018099,
     * 543584879,1830821961,1412257377,1819632928,1025515552, 539247136,
     *1130915171,1797267488,        -3,        -2, 541288549,1667965044,
     *1751457907,1970303084,1768252448,1634627437,1634496373,1931506531,
     *1635021925,1919512167, 543580515,1953460768,1713840246,1634497893,
     * 543254369,1768846196, 544499813,        -3, 541683316,1701998177,
     *1953066862,1634476116,1633840229,1931506785,1651862625,1952801824/
     * )
      ICK( 58801: 59100) = (/
     *1986096245,1697521729,1819504416,1667786083,1797289832,1702127717,
     *1914729576,1696613193,1176527214,1679826976,        -3, 543518050,
     *1701078117,1679839813,1394635365,1886351988,1701060727,1635149164,
     *1701734260,1752375393,1919230051,1869771365,1668558691,1869509481,
     *1937007982,1949179936,        -3,        -1, 589315646,1042306149,
     *1936990324,1751457889,1852796257,1819243891, 544432993,1953785202,
     *1768843040,1717658484,1869750374, 572552801,1819633011, 543254369,
     *1768846196, 541683316, 773870689,1651271027,        -3,1597585459,
     * 538976288, 807411744, 540024864, 960051488, 824197408, 538980384,
     * 807415840, 824188960,        -3,1416127780,1092896288,1147500137,
     *1635018099, 543584879,1830821961,1412257377,1819632928,1025515552,
     * 539247136,1130915171,1797267488,        -3,        -2, 541288549,
     *1667965044,1751457907,1970303084,1768252448,1634627437,1634496373,
     *1931506531,1635021925,1919512167, 543580515,1953460768,1713841952,
     *1986096245,1696620903,1634299507,1948284008,1696604192,        -3,
     * 541683316,1701998177,1953066862,1634476116,1633840229,1931506785,
     *1651862625,1952801824,1986096245,1697521729,1819504416,1667786083,
     *1797289832,1702127717,1914729576,1696613193,1176527214,1679826976,
     *        -3, 543518050,1701078117,1679839813,1394635365,1886351988,
     *1701060727,1635149164,1701734260,1752375393,1919230051,1869771365,
     *1668558691,1869509481,1937007982,1949179936,        -3,        -1,
     * 589315646,1042306149,1936990324,1751457889,1852796257,1819243891,
     * 544432993,1953785202,1768843040,1717658484,1869750374, 656438881,
     *1819632928,1634165097,1853060128,1114793326,1851878944, 639648623,
     *2002873888,        -3,1597585460, 538976288, 807411744, 540024864,
     * 960051488, 824197408, 538980384, 807415840, 824188960,        -3,
     *1416127780,1092896288,1147500137,1635018099, 543584879,1830843496,
     *1696612902,1127044705,1819632928, 539247136,1130915171,1797267488,
     *        -3,        -2, 541288549,1667965044,1751457907,1970303084,
     *1768252448,1634627437,1634496373,1931506531,1635021925,1919512167,
     * 543580515,1953460768,1713840246,1634497893, 543584114, 544499813,
     * 544108398,        -3, 541291851,1630281799,1632330028, 541945675,
     *1630281793,1732993324, 541683275,1629517665,1986358373,1852273768,
     * 543254369,1768846196, 544499823,1936007279,1713394478, 541225573,
     *1852727662, 539369504,        -3, 542125644, 773866351,2002873888,
     * 674314553, 841559584,1382381102, 542335849, 773867886,1937011246,
     * 740308531, 740309045, 808269877, 858660896,        -3,        -1,
     * 589315646,1042306149,1936990324,1751457889,1852796257,1819243891,
     * 544432993,1953785202,1768843040,1717658484,1869750374, 572552801,
     *1819632928,1634165097,1853060128,1114793326,1851878944, 639648623,
     *2002873888,        -3,1597585461, 538976288, 807411744, 540024864,
     * 960051488, 824197408, 538980384, 807415840, 824188960,        -3,
     *1416127780,1092896288,1147500137,1635018099, 543584879,1830843496,
     *1696612902,1127044705,1819632928, 539247136,1130915171,1797267488,
     *        -3,        -2, 541288549,1667965044,1751457907,1970303084,
     *1768252448,1634627437,1634496373,1931506531,1635021925,1919512167,
     * 543580515,1953460768,1713841952,1986096245,1696622191,1914729576,
     *1696624239,1847599136,        -3, 541291851,1630281799,1632330028,
     * 541945675,1630281793,1732993324, 541683275,1629517665,1986358373,
     *1852273768, 543254369,1768846196, 544499823,1936007279,1713394478/
     * )
      ICK( 59101: 59400) = (/
     * 541225573,1852727662, 539369552, 776744480,        -3, 541290359,
     *1634607144, 825833778, 690888786,1702243872,1399023918, 541683315,
     *1953639980, 540422956, 540554544, 758658355, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750382,1869491578,
     *1701998368,1713840225,1852796257,1819243891, 544432993,1953785202,
     *1768843040,1717658484,1869750390,1634497893,1931485216,        -3,
     *1597585462, 538976288, 807411744, 540024864, 960051488, 824197408,
     * 538980384, 807415840, 824188960,        -3,1315905646,1869491578,
     *1701998368,1713840193,1852796257,1819243891, 542335841,1953785202,
     *1768843040,1449225333,1702043718,1869966948, 538976288, 542141541,
     *1634952480,1130915171,1797267488,        -3,        -2, 541288549,
     *1667965030,1869750382,1869491578,1701998368,1713840225,1852796257,
     *1819243891, 544432993,1953785202,1768843040,1717658484,1869750390,
     *1634497893,1931503982, 544499813, 541280582, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750388,1751457902,
     *1701143584,1868963937, 542398281,1311720001,1397104754,1701210478,
     *1701668206,1948262432,        -3,1597585463, 538976288, 807411761,
     * 774905888, 960051488, 824197408, 538980384, 807415840, 824188960,
     *        -3,1416127776,1181507939,1797290016,1769152574,1042296864,
     * 757080132,1864392992,1111577414, 794056521,1310741093,1718185573,
     *1835363956, 538976288, 542141541,1634952480,1130915171,1797267488,
     *        -3,        -2, 541139010,1095976495,1415006542, 544367974,
     *1768842605,1701737504,1868963956,1751457862,1818321771, 544743536,
     *1634885997,1702126962, 543781664,1768842345,1667331173,1679849320,
     *1701716073,1953702006,1634497893,        -3, 543450486,1767994469,
     *1931506537,1735289190,1768120686,1953265952,1718775661, 544892274,
     *1864393075, 544040289,1937076837,1679843687,1634299507,1948281204,
     *1931501939,1936679785,1635018084, 544419445, 773857312,        -3,
     * 544629100,1969565216,1416128883, 543256688,1818846579, 543780384,
     *1885434484,1768125804,1634869350,1869750387,1953658211,1953854053,
     *1931502447,1853120873,1852403303, 544434535,1852401257,1667329652,
     *        -3, 543256175,1835101295,1970479219,1667331188,1701995890,
     *1932402775,1769236512,1629512805,1717663084,1948275528,1162631244,
     * 544367974,1768842605,1701737516, 544499813, 541486177,1667965048,
     * 544235890,1634559348,1701978144, 544629100,1969561705,1931505263,
     *1948284001,1801809440,1768846447, 543253347,1869966964, 543780384,
     *1952998688,1919247977,1852140901,1853104237,1868850540, 543257376,
     *1885434484, 544171552,1952998688,        -3, 543383916,1668639841,
     *1953066862, 544171552,1177052001,1818437920,1634624544,1952998688,
     *1668441441,1953066862, 544171552,1952998688,1178813984,1718185061,
     * 773867886,1668052339,1768910368,1868963937, 541486177,1667964960,
     * 544743529,1847620712,1696625253,1718185573,1835363956, 544042852,
     *1701585012,1751217184,1684371049,1635018099, 544434535,1852401257,
     *1667329652,1819877478,1919905056,2053468783, 544696684,1814064229,
     *1633951860,1864376352, 543977335,1701978194, 762732908,1969582880,
     *1634624544,1629512293,1953785202, 544042852,1701588512,        -3,
     *        -1, 589315646,1042305637,1886351988, 544499813, 544568165,
     * 544171552,1937076336,1818846564, 543565600,1718579744,1835627379,
     *1768843040,1768846437,1919836524,2032165729,1818457452,1635018084,
     * 544629100,1969561632,        -3,1597585464, 538976288, 807411744/
     * )
      ICK( 59401: 59700) = (/
     * 540024864, 960051488, 824197408, 538980384, 807415840, 824188960,
     *        -3,1416127776,1128875552,1400205424,1818846564, 539246966,
     *1634497893, 542471013,1679845742, 542531948,1768186228,1768910368,
     * 608575566,1869899040,        -3,        -2, 541288549,1667965044,
     *1751457907,1970303084,1768252448,1634627437,1634496373,1931506531,
     *1635021925,1919512167, 543580515,1953460768,1713840246,1634497893,
     * 543584114, 544499813, 544367984,1869771877,1679826976,        -3,
     * 544694646,1701602670,1735682094, 539512431, 543780468,1701998177,
     *1819048224,1667329123,1970037108,1701060710, 656438881,1819632928,
     *1635148137,1818321516,1697197600,        -3,        -1, 589315646,
     *1042305637,1886351988, 544499813, 544568165, 544171552,1937076336,
     *1818846564, 543565607, 543584114, 544041331,1936289383, 543780468,
     *1701998177,1819877475,1634493301,1818326117,1679849057,1819632928,
     *        -3,1597585465, 538976288, 807411744, 540024864, 960051488,
     * 824197408, 538980384, 807415840, 824188960,        -3,1416127776,
     *1128875552,1400205424,1818846564, 539246966,1634497893, 542471013,
     *1679845742, 542531948,1768186228,1768910368, 608575566,1869899040,
     *        -3,        -2, 541288549,1667965044,1751457907,1970303084,
     *1768252448,1634627437,1634496373,1931506531,1635021925,1919512167,
     * 543580515,1953460768,1713841952,1986096245,1696622191,1914729576,
     *1696625253,1886351988,1701060640,        -3, 544694646,1701602670,
     *1735682094, 539512431, 543780468,1701998177,1819048224,1667329123,
     *1970037108,1701060710, 656875638,1634497893, 543258209,1768710498,
     *1818569006,        -3,        -1, 589315646,1042305637,1886351988,
     * 543450480,1919247201,1952801824, 779249011, 543582572,1696621153,
     *1936024608,1397839173,1163543840,1785684512,        -3,1597585712,
     * 538976288, 807411744, 540024864, 960051488, 824197408, 540024880,
     * 540024881,        -3,1147498610,1701011828,1701060654,1919251247,
     * 778595180, 541683312,1970544723,1954114661, 542331221,1162172997,
     * 541749090, 539897390, 538976288, 538976288, 538976544,1315927141,
     *        -3,        -2, 542331221,1162172997, 543846242,1931506536,
     *1869966436, 543257376,1868963956,1751457889,1986095468,1633839468,
     *1769240864,1868963923,1212501080,1278357624,2032165477, 543318387,
     *1701060719,1847620712,1696604192,        -3, 544568165, 544171552,
     *1629504329,1177241155,1176527730,1700885605,1679845742, 543236179,
     *1212501080,1278357624,2032169573,1718185573,1835363956, 773857312,
     *        -3, 542336357, 541142604, 777220197,1797269554, 808531241,
     * 541156212,1629504370,2037609518, 541275953, 740309293, 825765408,
     *        -3,        -1, 589315646,1042305637,1886351988, 544173600,
     *1734700645,1918989413,1679845483,1814062177,1952522355,1970303084,
     *1768252448,1634934895,1651729778,1986356256,1751870496,1684108385,
     *        -3,1597585713, 538976288, 807411744, 540024864, 538980384,
     * 891306272, 540024880, 540024881,        -3,1212894240,1684108385,
     * 543388261,1635018084, 544696692,1746948172,1096044366, 795305326,
     *1701994868,1696607790, 774778414, 774778414, 538976288, 538976288,
     * 538976544,1315927141,        -3,        -2, 542597490,1852403303,
     * 544499809,1948284008,1696625253,1718379875,1953066862, 543449460,
     *1629512050,1696624239,1948280184,1885696617,1835363956,1634476130,
     *1970544739,1634493301,1818326117,1680744532,1752134501,        -3,
     * 543449460,1629512050,1696623221,1936990317,1700884084, 544501536/
     * )
      ICK( 59701: 60000) = (/
     *1650794613,1936024608,1634934900,1702065184,1684108385, 773857312,
     *        -3,        -1, 589315646,1042305637,1886351988, 543451494,
     *1717924453,1852007712,1650816119,1701146144,1919250543,1920230756,
     * 543256164, 543253364,1969318944,1601332582,1819177823,1853189474,
     *1701994343,1948284513,1819633011,        -3,1597585714, 538976305,
     * 807411744, 892346400, 825241632, 891306272, 540024880, 540024881,
     *        -3,1382379620, 539369537,1668576609,1814060914,1701211246,
     *1935634037,1835165042,1600615456,1449225333,1702043716,1768318565,
     *1914724985, 539248928,1130915171,1797267488,        -3,        -2,
     * 542402661, 541280582, 542270832,1869771877,1679843694,1679843683,
     *1953849708, 539519342, 544499813, 541475654, 689973087,1919247980,
     *1853054830,1970102885,1918855028, 656438881,1819633011, 543257189,
     * 543584117,1852055584, 544501536,1684629094,1701981728,1378951286,
     *1634497893,1931501938,1696621409,1818457452,1635018084, 543324448,
     *1667786083,1799571782, 544501536,1668444019,1932354408,1701014377,
     *1852252279,1769236512,1952998688,1378951200, 544629100,1969561697,
     *1931506277,1886351988,1701060713,1847620712,1696613193,1177428052,
     *1751457902,1970102885,1914728294, 539455330,1936028278,1701062432,
     *1919247980,1701016681,1869509408,1952997748, 543649637,1931485216,
     * 543780468,1864397928,1635000419,1634493301,1818326121,1869488233,
     *1931502177,1936024608,1869488244,1751457891,1919513701,1919513965,
     * 541663294, 540159536, 539631699,1768385889, 675883310, 541138976,
     *        -3, 544367974,1768842605,1701737504,1886547815,1918987552,
     *1818848101, 542328901,1280855072,1970496883, 541468783,1651714336,
     *1042297902, 807414304,1399416685,1630029352,1868722985, 689987955,
     *        -3, 539455330,1936028278,1701062432,1668442484,1701996917,
     *1830840686, 543782003, 543383916,1668639841,1953066862, 544171552,
     *1378954784,1114600552, 544109933,1650815603, 544039289, 543451494,
     *1717924384,        -3, 544435305,1734898796,2032166511,1914728053,
     *1835364969,1667329056,1919246707,1869509422, 541876594,1734680676,
     *1768318565,1919250019,1702043757,1635328112,1869180532, 544501536,
     *        -3, 543780451,1869509481,1937007982,1667851635, 543319412,
     *2003133806, 544499813, 541280582, 543256164, 541475654, 544499809,
     *1948282469,1701060724,1864393317, 543780470,1702065257,1734440037,
     *1680744480,        -3,        -1, 589315646,1042305637,1886351988,
     * 544041331,1936289383, 539910767,1684283497,1852009589,1684349030,
     *1768711456,1718579744,1229210945,1277194853,1718185573,1835363956,
     *        -3,1597585715, 538976288, 807411744, 540024864, 960051488,
     * 824197408, 540024880, 540024881,        -3,1315905582,1651467364,
     * 541683299,1819632741, 541485420,1696626537,1952981058,1162102048,
     * 639650895,1313153138,1701015410,1685266478, 538976288, 538976288,
     * 538976544,1315927141,        -3,        -2, 542402661, 541280582,
     * 761621858,1701078117,1679830642,1702043750,1768711456,1768842092,
     *1969513843, 543236195,1634495520,1718579744,1629498978,1868850208,
     *1768842092,1969513760,1718185061, 773870453,1667768417,        -3,
     * 543582572,1696622963, 544108404, 543584117,1852055653,2020894066,
     *1851878508,2032168818, 541280582, 761621858,1701078117,1680744535,
     *1769236591,1970544756,1751741216,1718185061, 740324456,1696604192,
     *        -3, 543450484,1634298995, 544171552,1952998688,1919247977,
     *1852140901,1853104225,1919230062,1869881443,1869443180,1702126880/
     * )
      ICK( 60001: 60300) = (/
     *1634624544,1852776494,1717790240,1667329568,1650794595,1919246708,
     *1701064224,        -3,        -1, 589315646,1042305637,1886351988,
     * 544041331,1936289383, 542328901,1280855087,1296388679, 543780467,
     *1953658211,1953066862,        -3,1597585716, 538976288, 807411744,
     * 540024864, 960051488, 824197408, 540024880, 540024881,        -3,
     *1397245260,1481383982,1768846112,1131376244,1634299507, 544108320,
     *1296388679, 541683315,1953658211,1953066862, 539897390, 774778414,
     * 538976288, 538976288, 538976544,1315927141,        -3,        -2,
     * 541139027,1212501080,1277192815,1646290789,1852142177,1819048224,
     *1768842092,1969513843, 543236173,1163020064,1768846196,1920295796,
     *1768910382, 541681184,1852797996, 544499813, 544367974,1768842605,
     *1701737504,        -3, 543256164, 539446345,1398022196, 656426563,
     *1176532841,1819025513,1852009589,1684349042,1701082478,1684106868,
     * 544367974,1818583924,1768910451, 539519278,1697521778,1701210478,
     *1701668206,1948282734, 544042866,1696604192, 544499809,1847620712,
     *1696626030,1769043301, 544433524, 544171552,1919247980,1701016681,
     *1869509422, 689971232,        -3,        -1, 589315646,1042305637,
     *1886351988, 544240239,1651271021, 544696692,1746956901,1668441441,
     *1953066599, 541475654, 544696692,1746948936,1162631244,        -3,
     *1597585717, 538976288, 807411744, 540024864, 538980896, 824197408,
     * 540024880, 540024881,        -3,1130458656,1852797984,1382376306,
     *1700885605, 539911779,1713399410,1869422661,1835165028,1684366368,
     * 539914853,1931486752, 778595180, 538976288, 538976288, 538976544,
     *1130915171,1797267488,        -3,        -2, 542402661,1919230057,
     *1931501856,1886547810,1818586400,2003399784, 544499813, 544367971,
     *1919246708,1768910368,1868963937, 539911779,1713399401,1818566758,
     *1919905056,1952998688,1128875552,1701667429,1684301156,        -3,
     * 539914853,1931501934,1679830632,1802248292,1635016992,2003399784,
     * 542328901,1280855090, 813201454, 542011252,1698308179,1212501080,
     *1277175919,1914730604, 689991029,1936990306,1696622958, 544499813,
     * 542130516,1210064928, 544174624,1936028704,2003399784, 544499813,
     * 543518326,1769107310,1835363956, 544629106,1767989868,1696617288,
     *1279612997, 539518254,1731076212,1864385338,1549954652,1398297676,
     *1551395886,1702389033,        -3, 542141541,1634952480,1768846192,
     *1701016608,1952998688,1397245260,1481384052,1701997929,1851878432,
     *1819240294,1768711456,1718579744,1701999215,1914727781,1936941415,
     *1702047264,        -3,        -1, 589315646,1042306149,1936990326,
     *1634494820,1769240864,1868963923,1212501080,1277186932,2037146912,
     * 659310931,1411396647, 541486895,1180901446,1128669254,1768711456,
     *        -3,1597585718, 538976288, 807411744, 540024864, 538980384,
     * 824197408, 538980384, 807415840, 824188960,        -3,1315925549,
     *1400136046,1684107876, 542328901,1280855072,1279873876, 540287059,
     *1954114661, 541475654, 542340464,1886153061,1679830574, 538976288,
     * 538976288, 538976544,1130915171,1797267488,        -3,        -2,
     * 541139027,1212501080,1277175628,1230197792, 874979411,1954114661,
     * 541475654, 541485420,1696625512,1869966436, 543387501,1886157088,
     *2003399784, 544499813, 542328901,1280855072,1181708909,1635003936,
     *        -3, 542402665,1931503981,1886153061,1931506792,1635000417,
     *1847608899,1176531816,1869966436, 543780451,1819632741, 544173676,
     *2032165152,1970170225,1969561715,1702109295,1713402469,1718379875/
     * )
      ICK( 60301: 60600) = (/
     *1953066862,1932402720,        -3, 541486962, 544108398, 761488750,
     *1953656691,2037214565,1953655139, 544437362,1969452149,1919251244,
     * 541487721,1701078380, 544235881,1920147571,1752135020,1679843941,
     * 543780451,1819632741,1680744480,        -3,        -1, 589315646,
     *1042306149,1936990310,1869750369,1667458416,1952539244,1696613193,
     *1177503299,1176528489,1818566755,1869439593,1851880553,1869488230,
     *1869750355,1212501080,1277173792,        -3,1597585719, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 807415840,
     * 824188960,        -3,1433301877,1769234786,1818566723,1229336390,
     *1128669254,1768711456,1131375970,1768841588,1768910368,2003399784,
     * 542328901,1280855072,1128875552, 538976288, 538976544,1165128303,
     *1914708000,        -3,        -2, 542402661, 541280582, 543582572,
     *1696625253,1886351988,1931506277,1718185573,1835363956, 544696692,
     *1746948936,1162631244, 544696421,1919246707, 544499813, 544437616,
     *1886153061,1679848037,1718379875,1953066862,        -3, 543582572,
     *1696622963, 544108404, 544171552,1952998688,1397245260,1481383975,
     *1279873876, 540288800,1869750311,1279873876, 540550944,1954115685,
     * 773869682,1869636978, 541475654, 544629100,1768186228,1768910368,
     *1769152544, 544108404, 544239475,1936286316,1696626537,1952981108,
     *1751457889,1819567474,1851880553,1986338892,1230197792,1869640809,
     *1869509422,        -3,        -1, 589315646,1042306149,1936990310,
     *1869750311,1279873876, 540223264,1937013100,1696625253,1718379875,
     *1953066862, 543582572,1696604192,        -3,1597585720, 538976288,
     * 807411744, 540024864, 538980384, 824197408, 538980384, 807415840,
     * 824188960,        -3,1397245260,1481384012,1230197792, 857753199,
     * 793142048,1433301877,1769234786,1818566758,1869750342,1128672598,
     *1634494820,1635019119,1847599136, 538976288, 538976544,1165128303,
     *1914708000,        -3,        -2, 541676867,1914717032,1701014339,
     *1229332598,1634494820,1635019119,1847620197,1903520114,1702043731,
     *1212501080,1277175628,1230197792, 874982432, 659310931,1411397671,
     * 544174624,1165063529,1986096229,1853104160,        -3, 541486890,
     * 707931206,1663707698, 740316009,1735221544,1181690410, 841556000,
     *1919247980,1701016681,1869488230,1768711539, 773857312,        -3,
     *        -1, 589315646,1042306149,1936990310,1869750311,1279873876,
     * 540419872,1937013100,1696625253,1718379875,1953066862, 543582572,
     *1696604192,        -3,1597585721, 538976288, 807411744, 540024864,
     * 538980384, 824197408, 538980384, 807415840, 824188960,        -3,
     *1397245260,1481384012,1230197792, 908084847, 793142048,1433301877,
     *1769234786,1818566758,1869750342,1128672598,1634494820,1635019119,
     *1847599136, 538976288, 538976544,1165128303,1914708000,        -3,
     *        -2, 541676867,1914717032,1701014339,1229332598,1634494820,
     *1635019119,1847620197,1903520114,1702043731,1212501080,1277175628,
     *1230197792, 874982432, 659310931,1411397671, 544174624,1701934441,
     *1986096229,1853104160,        -3, 541486890, 707931206,1663707698,
     * 740316009,1735221544,1181690410, 841556082,1701211237,1668573551,
     *1847617129,1818587950, 542402661, 539446345,1398022198, 656438132,
     *2037146912,1718185061, 543711603, 544499813,        -3, 543451507,
     *1885696627,1768910368,1668247156,1919509109,1953066862, 544367981,
     *1870030180, 544039275,1768843040,1952999795, 543582572,1696626030,
     *1937074548,1633840229, 543584114, 543520884,1701998177,1814044704/
     * )
      ICK( 60601: 60630) = (/
     *        -3, 541159009,1819898729,1932357478, 760635762,1767992931,
     *1696625785,1885675631,1713398126,1634498931,1769152609,1852055670,
     *1634494820,1635019119,1847619430, 544499813, 543582574,1634476146,
     *1701210478,1701668206,1949179936,        -1, 606094670,1143820102,
     * 760431939,1414090574,        -3,         0, 606094670,1143820102/
     * )
      IF (MODE == 0) THEN
C * GET VERSION NUMBER yymmdd
        IVERS = - ICK(1)
      ELSE
C * RE-CREATE check.def FILE
        CALL PLA277 (ICK)
      END IF
      RETURN
      END SUBROUTINE CHECK
      MODULE cspgr
      SAVE
      LOGICAL                   :: SGTLOADED = .FALSE.
      INTEGER, PARAMETER        :: NNH    = 174
      INTEGER, PARAMETER        :: NTRL   = 205
      INTEGER, PARAMETER        :: NSTD   = 300
      INTEGER, PARAMETER        :: LU80   =  80
      INTEGER, PARAMETER        :: NOPR   =  18
      INTEGER, PARAMETER        :: NANO   =  16
      INTEGER, PARAMETER        :: NMON   = 128
      INTEGER, PARAMETER        :: NORT   =  80
      INTEGER, PARAMETER        :: NSITE  =  70
      INTEGER, PARAMETER        :: NTETL  =  19
      INTEGER, PARAMETER        :: NTETH  =  65
      INTEGER, PARAMETER        :: NTRIL  =   8
      INTEGER, PARAMETER        :: NTRIH  =  24
      INTEGER, PARAMETER        :: NHEXL  =   9
      INTEGER, PARAMETER        :: NHEXH  =  18
      INTEGER, PARAMETER        :: NCUBL  =  15
      INTEGER, PARAMETER        :: NCUBH  =  28
      INTEGER, PARAMETER        :: NMONA  = NANO   + 1
      INTEGER, PARAMETER        :: NMONB  = NANO   + NMON
      INTEGER, PARAMETER        :: NORTA  = NMONB  + 1
      INTEGER, PARAMETER        :: NORTB  = NMONB  + NORT
      INTEGER, PARAMETER        :: NTETLA = NORTB  + 1
      INTEGER, PARAMETER        :: NTETLB = NORTB  + NTETL
      INTEGER, PARAMETER        :: NTETHA = NTETLB + 1
      INTEGER, PARAMETER        :: NTETHB = NTETLB + NTETH
      INTEGER, PARAMETER        :: NTRILA = NTETHB + 1
      INTEGER, PARAMETER        :: NTRILB = NTETHB + NTRIL
      INTEGER, PARAMETER        :: NTRIHA = NTRILB + 1
      INTEGER, PARAMETER        :: NTRIHB = NTRILB + NTRIH
      INTEGER, PARAMETER        :: NHEXLA = NTRIHB + 1
      INTEGER, PARAMETER        :: NHEXLB = NTRIHB + NHEXL
      INTEGER, PARAMETER        :: NHEXHA = NHEXLB + 1
      INTEGER, PARAMETER        :: NHEXHB = NHEXLB + NHEXH
      INTEGER, PARAMETER        :: NCUBLA = NHEXHB + 1
      INTEGER, PARAMETER        :: NCUBLB = NHEXHB + NCUBL
      INTEGER, PARAMETER        :: NCUBHA = NCUBLB + 1
      INTEGER, PARAMETER        :: NRSPGR = NANO   + NMON  + NORT +
     1                             NTETL  + NTETH  + NTRIL + NTRIH +
     2                             NHEXL  + NHEXH  + NCUBL + NCUBH
      INTEGER                   :: IBV
      INTEGER                   :: ISW
      INTEGER                   :: NST
      INTEGER                   :: IER = 0
      INTEGER                   :: NIC
      INTEGER                   :: JBG
      INTEGER                   :: JEG
      INTEGER                   :: JSG = 0
      INTEGER                   :: IKLS
      INTEGER                   :: LAUE
      INTEGER                   :: IINV
      INTEGER                   :: IAXM
      INTEGER                   :: JSMI
      INTEGER                   :: JSMX
      INTEGER                   :: ISWD
      INTEGER                   :: JSWD
      INTEGER                   :: NSTT
      INTEGER                   :: IUIT
      INTEGER                   :: LRET
      INTEGER                   :: ISTO
      INTEGER                   :: ITRL
      INTEGER                   :: NUMS
      INTEGER                   :: NSLP
      INTEGER                   :: IOST = 0
      INTEGER                   :: ILAUE
      INTEGER                   :: ISGNR
      INTEGER                   :: NSYMP
      INTEGER                   :: NSLPM
      INTEGER                   :: ICNTR
      INTEGER                   :: ITRNS
      INTEGER                   :: NSGET
      INTEGER                   :: NTRNS
      INTEGER                   :: JLAUE
      INTEGER                   :: ISHEL
      INTEGER                   :: ICNTRX
      INTEGER                   :: IMPROP
      INTEGER                   :: IFLACK  = 0
      INTEGER                   :: IABSENT = 0
      INTEGER, DIMENSION(NSITE) :: KSITE = (/
     1      0,       1,       2,       4,       7,       8,      16,
     2     25,      32,      42,      52,      64,      76,      82,
     3     97,     127,     128,     256,     385,     512,     642,
     4    772,    1024,    1156,    1282,    1537,    1927,    2050,
     5   2730,    3410,    4098,    4818,    5418,    6151,    8191,
     6   8192,    8193,    8274,    8319,    8320,    8448,    8577,
     7  11602,   13010,   16383,   16384,   16385,   16386,   16388,
     8  16391,   16512,   16640,   16769,   16896,   17026,   17156,
     9  17408,   17540,   17666,   17921,   18311,   32768,   33024,
     *  32769,   65536,   65792,   65537,  131072,  131328,  131073/)
C *               1BAR   112   11M   1M1   121   M11   211    M-    2-
C *                 M+    2+   114  114B  3+++   113  3+--  3-+-  3--+
C *
C * THE SITE SITUATED ON THE 2-FOLD AXIS ALONG <110> IS DESCRIBED AS 2+.
C * THE SITE SITUATED ON THE MIRROR NORMAL TO <110> IS DESCRIBED AS M+.
C * THE SITE WITH MM2 SYMMETRY COMPOSED OF **2, M+, AND M- IS MM2+-.
C * THE SITE COMPOSED OF 2+, **M, AND M- IS M2M+.
C * THE SITE COMPOSED OF 2-, **M, AND M+ IS M2M-.
      CHARACTER(len=5), DIMENSION(70) :: SITE = (/
     1 '    1', '   -1', '  ..2', '  ..m', '..2/m', '  .m.', '  .2.',
     2 '.2/m.', '  m..', '  mm2', '  m2m', '  2..', '  2mm', '  222',
     3 '2/m..', '  mmm', '   m-', '   2-', ' 2/m-', '   m+', 'mm2+-',
     4 ' m2m-', '   2+', ' m2m+', '222+-', ' 2/m+', 'mmm+-', '  4..',
     5 '  4mm', '  422', ' -4..', ' -42m', ' -4m2', '4/m..', '4/mmm',
     6 '  .3.', ' .-3.', '   23', '   m3', '   3m', '  .32', '  -3m',
     7 '  432', ' -43m', '  m3m', '  3..', ' -3..', '  6..', ' -6..',
     8 '  6/m', '  3.m', '  3.2', ' -3.m', '  3m.', '  6mm', ' -6m2',
     9 '  32.', ' -62m', '  622', ' -3m.', '6/mmm', '  .3.', '  .32',
     * ' .-3.', '  .3.', '  .32', ' .-3.', '  .3.', '  .32', ' .-3.'/)
      INTEGER, DIMENSION(NOPR)      :: IOPR = (/
     1  -162,  132, -132,  134, -134,   160, -160, 156, -156, 138, -138,
     2  152, -142,   72, -4650,  -68, -30,   26/)
      INTEGER, DIMENSION(3, 3, 195) :: IR
      INTEGER, DIMENSION(3, 3, 48)  :: IS
      INTEGER, DIMENSION(3)         :: ISV
      INTEGER, DIMENSION(3, 3)      :: IORG
      INTEGER, DIMENSION(4, 3)      :: ISBRV
      INTEGER, DIMENSION(9, 4)      :: IHALL
      INTEGER, DIMENSION(6)         :: IABC
      INTEGER, DIMENSION(6)         :: JABC
      INTEGER, DIMENSION(7)         :: IBV0 = (/
     1 1, 2, 2, 2, 4, 2, 3/)
      INTEGER, DIMENSION(7)         :: IBV1 = (/
     1 0, 1, 4, 7, 1, 10, 13/)
      INTEGER, DIMENSION(18)        :: IBV2 = (/
     1 0, 6, 6, 6, 0, 6, 6, 6, 0, 6, 6, 6, 4, 8, 8, 8, 4, 4/)
      INTEGER, DIMENSION(28)        :: NSG = (/
     1 1, NANO, NMONA, NMONB, NORTA, NORTB, NTETLA, NTETLB, NTETHA,
     2 NTETHB, NTRILA, NTRILB, NTRIHA, NTRIHB, NTRIHA, NTRIHB, NHEXLA,
     3 NHEXLB, NHEXHA, NHEXHB, NCUBLA, NCUBLB, NCUBHA, NRSPGR, 1,
     4 NRSPGR, NTRIHA, NTRIHB/)
      INTEGER, DIMENSION(198)       :: NHRM = (/
     1  1, 0,  0,  0,  1, 0, 0,  0,  1,  1, 0,  0,  0, -1, 0, 0,  0, -1,
     2  1, 0,  0,  0,  0, 1, 0, -1, -1,  1, 0,  0,  0,  0, 1, 0, -1,  0,
     3  1, 0,  0,  0,  1, 1, 0, -1,  0,  1, 0,  0,  0,  1, 0, 0,  0,  1,
     4 -1, 0,  0,  0,  1, 0, 0,  0, -1, -1, 0, -1,  0,  1, 0, 1,  0,  0,
     5  0, 0, -1,  0,  1, 0, 1,  0,  0,  0, 0, -1,  0,  1, 0, 1,  0,  1,
     6  1, 0,  0,  0,  1, 0, 0,  0,  1, -1, 0,  0,  0, -1, 0, 0,  0,  1,
     7  0, 1,  0, -1, -1, 0, 0,  0,  1,  0, 1,  0, -1,  0, 0, 0,  0,  1,
     8  1, 1,  0, -1,  0, 0, 0,  0,  1, -1, 0,  0,  0,  0,-1, 0, -1,  0,
     9 -1, 0,  0,  0,  0, 1, 0,  1,  0,  0, 0, -1,  0, -1, 0,-1,  0,  0,
     *  0, 0,  1,  0, -1, 0, 1,  0,  0,  0,-1,  0, -1,  0, 0, 0,  0, -1,
     1  0, 1,  0,  1,  0, 0, 0,  0, -1,  0, 1,  0,  0,  0, 1, 1,  0,  0
     2  /)
      INTEGER, DIMENSION(59)        :: NSLOC = (/
     1  0,  1,  2,  0,  3,  4,  0,  0,  0,  5,  6,  7,  8,  9, 10,
     2 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25,
     3 26,  0,  0, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38,
     4 39, 40, 41, 42, 43, 44, 45, 46,  0, 47,  0, 48, 49, 50/)
      INTEGER, DIMENSION(230)       :: NSGF = (/
     1   799, 15327,    20,  5116,   763,     3,   325,    53,   844,
     2    15,   596,   471,   434, 30824,  5965,     6,     6,   426,
     3  8608,   185,     7,     3,    18,     3,     1,    31,     5,
     4     1,   636,    13,    76,    25,  1404,    31,     2,   140,
     5    10,     4,     8,    22,    80,    14,   293,    11,    79,
     6    12,     1,     5,     1,     5,     8,    73,    13,    33,
     7    29,   309,   135,    79,    50,   811,  3481,  1465,   127,
     8   160,     6,    11,     4,    30,     9,    68,     9,    57,
     9    22,    11,     7,   187,     8,  -187,    22,    22,    23,
     *   136,     4,    13,    88,   128,    58,   279,     2,     8,
     1    11,   378,     2,    20,   -11,  -378,     3,     3,     0,
     2     0,     2,     5,     0,    12,     1,     7,     7,     6,
     3    10,    36,     3,     0,    42,   139,     2,     3,     7,
     4    24,     8,     4,    31,    42,     4,    15,     1,    16,
     5     6,     5,    18,    34,     3,     1,     4,     6,     6,
     6    24,    16,     6,    18,     6,    15,    40,    27,   144,
     7  -106,   115,    84,   365,     0,     8,     4,   133,    -4,
     8  -133,    35,     1,     2,     8,    15,    37,   101,     2,
     9    31,    11,    41,    32,   102,     2,   106,  -106,     6,
     *    -6,    59,     3,     1,   164,     0,    16,     5,     7,
     1    -7,     4,     2,     0,     4,    24,     0,     0,     4,
     2    13,     3,     7,     1,    20,     0,     2,     6,    58,
     3     1,     3,     3,     4,     3,     9,    88,     8,     2,
     4     0,     2,     1,     0,     5,    -5,     0,     8,     7,
     5    25,    15,     8,    15,    10,     9,     5,     4,    24,
     6     2,    16,     7,    20,     1/)
      REAL,              DIMENSION(576)     :: A
      REAL,              DIMENSION(12)      :: B
      REAL,              DIMENSION(3, 3)    :: R0
      REAL,              DIMENSION(3, 3)    :: R1
      REAL,              DIMENSION(3, 3)    :: R3
      REAL,              DIMENSION(3, 3)    :: R4
      REAL,              DIMENSION(3, 4)    :: R2
      REAL,              DIMENSION(3)       :: T0
      REAL,              DIMENSION(3)       :: T3
      REAL,              DIMENSION(3)       :: OSFT
      REAL,              DIMENSION(3)       :: OCNT
      CHARACTER(len=9)                      :: YSPG
      CHARACTER(len=13)                     :: ZSPG
      CHARACTER(len=100)                    :: LINE
      CHARACTER(len=60)                     :: SGSMC
      CHARACTER(len=12)                     :: XSYSTX
      CHARACTER(len=33), DIMENSION(NRSPGR)  :: SGT
C * Hall symbols for non-standard orthorhombic settings
      CHARACTER(len=15), DIMENSION(3, NNH)  :: NHL = reshape ((/
     1 'P2221:2        ', 'P 2 2 21:2     ', ' P 2c 2c       ',
     2 'P2122          ', 'P 21 2 2       ', ' P 2a 2a       ',
     3 'P2122:2        ', 'P 21 2 2:2     ', ' P 2 2a        ',
     4 'P2212          ', 'P 2 21 2       ', ' P 2 2b        ',
     5 'P2212:2        ', 'P 2 21 2:2     ', ' P 2b 2        ',
     6 'P22121         ', 'P 2 21 21      ', ' P 2bc 2       ',
     7 'P21221         ', 'P 21 2 21      ', ' P 2ac 2ac     ',
     8 'A2122          ', 'A 21 2 2       ', ' A 2a 2a       ',
     9 'A2122:2        ', 'A 21 2 2:2     ', ' A 2 2a        ',
     * 'B2212          ', 'B 2 21 2       ', ' B 2 2b        ',
     1 'B2212:2        ', 'B 2 21 2:2     ', ' B 2b 2        ',
     2 'C2221:2        ', 'C 2 2 21:2     ', ' C 2c 2c       ',
     3 'A222           ', 'A 2 2 2        ', ' A 2 2         ',
     4 'B222           ', 'B 2 2 2        ', ' B 2 2         ',
     5 'P2mm           ', 'P 2 m m        ', ' P -2 2        ',
     6 'Pm2m           ', 'P m 2 m        ', ' P -2 -2       ',
     7 'Pcm21          ', 'P c m 21       ', ' P 2c -2c      ',
     8 'P21ma          ', 'P 21 m a       ', ' P -2a 2a      ',
     9 'P21am          ', 'P 21 a m       ', ' P -2 2a       ',
     * 'Pb21m          ', 'P b 21 m       ', ' P -2 -2b      ',
     1 'Pm21b          ', 'P m 21 b       ', ' P -2b -2      ',
     2 'P2aa           ', 'P 2 a a        ', ' P -2a 2       ',
     3 'Pb2b           ', 'P b 2 b        ', ' P -2b -2b     ',
     4 'Pbm2           ', 'P b m 2        ', ' P 2 -2b       ',
     5 'P2mb           ', 'P 2 m b        ', ' P -2b 2       ',
     6 'P2cm           ', 'P 2 c m        ', ' P -2c 2       ',
     7 'Pc2m           ', 'P c 2 m        ', ' P -2c -2c     ',
     8 'Pm2a           ', 'P m 2 a        ', ' P -2a -2a     ',
     9 'Pbc21          ', 'P b c 21       ', ' P 2c -2b      ',
     * 'P21ab          ', 'P 21 a b       ', ' P -2b 2a      ',
     1 'P21ca          ', 'P 21 c a       ', ' P -2ac 2a     ',
     2 'Pc21b          ', 'P c 21 b       ', ' P -2bc -2c    ',
     3 'Pb21a          ', 'P b 21 a       ', ' P -2a -2ab    ',
     4 'Pcn2           ', 'P c n 2        ', ' P 2 -2ac      ',
     5 'P2na           ', 'P 2 n a        ', ' P -2ac 2      ',
     6 'P2an           ', 'P 2 a n        ', ' P -2ab 2      ',
     7 'Pb2n           ', 'P b 2 n        ', ' P -2ab -2ab   ',
     8 'Pn2b           ', 'P n 2 b        ', ' P -2bc -2bc   ',
     9 'Pnm21          ', 'P n m 21       ', ' P 2bc -2bc    ',
     * 'P21mn          ', 'P 21 m n       ', ' P -2ab 2ab    ',
     1 'P21nm          ', 'P 21 n m       ', ' P -2 2ac      ',
     2 'Pn21m          ', 'P n 21 m       ', ' P -2 -2bc     ',
     3 'Pm21n          ', 'P m 21 n       ', ' P -2ab -2     ',
     4 'P2cb           ', 'P 2 c b        ', ' P -2bc 2      ',
     5 'Pc2a           ', 'P c 2 a        ', ' P -2ac -2ac   ',
     6 'Pbn21          ', 'P b n 21       ', ' P 2c -2ab     ',
     7 'P21nb          ', 'P 21 n b       ', ' P -2bc 2a     ',
     8 'P21cn          ', 'P 21 c n       ', ' P -2n 2a      ',
     9 'Pc21n          ', 'P c 21 n       ', ' P -2n -2ac    ',
     * 'Pn21a          ', 'P n 21 a       ', ' P -2ac -2n    ',
     1 'P2nn           ', 'P 2 n n        ', ' P -2n 2       ',
     2 'Pn2n           ', 'P n 2 n        ', ' P -2n -2n     ',
     3 'A2mm           ', 'A 2 m m        ', ' A -2 2        ',
     4 'Bm2m           ', 'B m 2 m        ', ' B -2 -2       ',
     5 'Ccm21          ', 'C c m 21       ', ' C 2c -2c      ',
     6 'A21ma          ', 'A 21 m a       ', ' A -2a 2a      ',
     7 'A21am          ', 'A 21 a m       ', ' A -2 2a       ',
     8 'Bb21m          ', 'B b 21 m       ', ' B -2 -2b      ',
     9 'Bm21b          ', 'B m 21 b       ', ' B -2b -2      ',
     * 'A2aa           ', 'A 2 a a        ', ' A -2a 2       ',
     1 'Bb2b           ', 'B b 2 b        ', ' B -2b -2b     ',
     2 'Bmm2           ', 'B m m 2        ', ' B 2 -2        ',
     3 'B2mm           ', 'B 2 m m        ', ' B -2 2        ',
     4 'C2mm           ', 'C 2 m m        ', ' C -2 2        ',
     5 'Cm2m           ', 'C m 2 m        ', ' C -2 -2       ',
     6 'Am2m           ', 'A m 2 m        ', ' A -2 -2       ',
     7 'Bma2           ', 'B m a 2        ', ' B 2 -2c       ',
     8 'B2cm           ', 'B 2 c m        ', ' B -2c 2       ',
     9 'C2mb           ', 'C 2 m b        ', ' C -2b 2       ',
     * 'Cm2a           ', 'C m 2 a        ', ' C -2b -2b     ',
     1 'Ac2m           ', 'A c 2 m        ', ' A -2c -2c     ',
     2 'Bbm2           ', 'B b m 2        ', ' B 2 -2b       ',
     3 'B2mb           ', 'B 2 m b        ', ' B -2b 2       ',
     4 'C2cm           ', 'C 2 c m        ', ' C -2c 2       ',
     5 'Cc2m           ', 'C c 2 m        ', ' C -2c -2c     ',
     6 'Am2a           ', 'A m 2 a        ', ' A -2a -2a     ',
     7 'Bba2           ', 'B b a 2        ', ' B 2 -2bc      ',
     8 'B2cb           ', 'B 2 c b        ', ' B -2bc 2      ',
     9 'C2cb           ', 'C 2 c b        ', ' C -2bc 2      ',
     * 'Cc2a           ', 'C c 2 a        ', ' C -2bc -2bc   ',
     1 'Ac2a           ', 'A c 2 a        ', ' A -2ac -2ac   ',
     2 'F2mm           ', 'F 2 m m        ', ' F -2 2        ',
     3 'Fm2m           ', 'F m 2 m        ', ' F -2 -2       ',
     4 'F2dd           ', 'F 2 d d        ', ' F -2d 2       ',
     5 'Fd2d           ', 'F d 2 d        ', ' F -2d -2d     ',
     6 'I2mm           ', 'I 2 m m        ', ' I -2 2        ',
     7 'Im2m           ', 'I m 2 m        ', ' I -2 -2       ',
     8 'I2cb           ', 'I 2 c b        ', ' I -2a 2       ',
     9 'Ic2a           ', 'I c 2 a        ', ' I -2b -2b     ',
     * 'Ibm2           ', 'I b m 2        ', ' I 2 -2b       ',
     1 'I2mb           ', 'I 2 m b        ', ' I -2b 2       ',
     2 'I2cm           ', 'I 2 c m        ', ' I -2c 2       ',
     3 'Ic2m           ', 'I c 2 m        ', ' I -2c -2c     ',
     4 'Im2a           ', 'I m 2 a        ', ' I -2a -2a     ',
     5 'Pmaa           ', 'P m a a        ', '-P 2a 2        ',
     6 'Pbmb           ', 'P b m b        ', '-P 2b 2b       ',
     7 'Pncb           ', 'P n c b        ', '-P 2b 2bc      ',
     8 'Pcna           ', 'P c n a        ', '-P 2a 2c       ',
     9 'Pmmb           ', 'P m m b        ', '-P 2b 2        ',
     * 'Pbmm           ', 'P b m m        ', '-P 2 2b        ',
     1 'Pcmm           ', 'P c m m        ', '-P 2c 2c       ',
     2 'Pmcm           ', 'P m c m        ', '-P 2c 2        ',
     3 'Pmam           ', 'P m a m        ', '-P 2 2a        ',
     4 'Pnnb           ', 'P n n b        ', '-P 2b 2n       ',
     5 'Pbnn           ', 'P b n n        ', '-P 2n 2b       ',
     6 'Pcnn           ', 'P c n n        ', '-P 2ab 2c      ',
     7 'Pncn           ', 'P n c n        ', '-P 2ab 2n      ',
     8 'Pnan           ', 'P n a n        ', '-P 2n 2bc      ',
     9 'Pnmb           ', 'P n m b        ', '-P 2bc 2bc     ',
     * 'Pbmn           ', 'P b m n        ', '-P 2ab 2ab     ',
     1 'Pcnm           ', 'P c n m        ', '-P 2 2ac       ',
     2 'Pncm           ', 'P n c m        ', '-P 2 2bc       ',
     3 'Pman           ', 'P m a n        ', '-P 2ab 2       ',
     4 'Pccb           ', 'P c c b        ', '-P 2b 2c       ',
     5 'Pbaa           ', 'P b a a        ', '-P 2a 2b       ',
     6 'Pcaa           ', 'P c a a        ', '-P 2ac 2c      ',
     7 'Pbcb           ', 'P b c b        ', '-P 2bc 2b      ',
     8 'Pbab           ', 'P b a b        ', '-P 2b 2ab      ',
     9 'Pmcb           ', 'P m c b        ', '-P 2bc 2       ',
     * 'Pcma           ', 'P c m a        ', '-P 2ac 2ac     ',
     1 'Pnaa           ', 'P n a a        ', '-P 2ac 2bc     ',
     2 'Pbnb           ', 'P b n b        ', '-P 2bc 2ab     ',
     3 'Pcam           ', 'P c a m        ', '-P 2c 2ac      ',
     4 'Pmca           ', 'P m c a        ', '-P 2ac 2a      ',
     5 'Pmab           ', 'P m a b        ', '-P 2b 2a       ',
     5 'Pbma           ', 'P b m a        ', '-P 2a 2ab      ',
     7 'Pcmb           ', 'P c m b        ', '-P 2bc 2c      ',
     8 'Pmnn           ', 'P m n n        ', '-P 2n 2        ',
     9 'Pnmn           ', 'P n m n        ', '-P 2n 2n       ',
     * 'Pnmm           ', 'P n m m        ', '-P 2c 2bc      ',
     1 'Pmnm           ', 'P m n m        ', '-P 2c 2a       ',
     2 'Pcan           ', 'P c a n        ', '-P 2n 2c       ',
     3 'Pnca           ', 'P n c a        ', '-P 2a 2n       ',
     4 'Pnab           ', 'P n a b        ', '-P 2bc 2n      ',
     5 'Pbna           ', 'P b n a        ', '-P 2ac 2b      ',
     6 'Pcnb           ', 'P c n b        ', '-P 2b 2ac      ',
     7 'Pcab           ', 'P c a b        ', '-P 2bc 2ac     ',
     8 'Pmnb           ', 'P m n b        ', '-P 2bc 2a      ',
     9 'Pbnm           ', 'P b n m        ', '-P 2c 2ab      ',
     * 'Pcmn           ', 'P c m n        ', '-P 2n 2ac      ',
     1 'Pmcn           ', 'P m c n        ', '-P 2n 2a       ',
     2 'Pnam           ', 'P n a m        ', '-P 2c 2n       ',
     3 'Ccmm           ', 'C c m m        ', '-C 2c 2c       ',
     4 'Amma           ', 'A m m a        ', '-A 2a 2a       ',
     5 'Amam           ', 'A m a m        ', '-A 2 2a        ',
     6 'Bbmm           ', 'B b m m        ', '-B 2 2b        ',
     7 'Bmmb           ', 'B m m b        ', '-B 2b 2        ',
     8 'Ccmb           ', 'C c m b        ', '-C 2bc 2bc     ',
     9 'Abma           ', 'A b m a        ', '-A 2ac 2ac     ',
     * 'Acam           ', 'A c a m        ', '-A 2 2ac       ',
     1 'Bbcm           ', 'B b c m        ', '-B 2 2bc       ',
     2 'Bmab           ', 'B m a b        ', '-B 2bc 2       ',
     3 'Ammm           ', 'A m m m        ', '-A 2 2         ',
     4 'Bmmm           ', 'B m m m        ', '-B 2 2         ',
     5 'Amaa           ', 'A m a a        ', '-A 2a 2        ',
     6 'Bbmb           ', 'B b m b        ', '-B 2b 2b       ',
     7 'Cmmb           ', 'C m m b        ', '-C 2b 2b       ',
     8 'Abmm           ', 'A b m m        ', '-A 2c 2c       ',
     9 'Acmm           ', 'A c m m        ', '-A 2 2c        ',
     * 'Bmcm           ', 'B m c m        ', '-B 2 2c        ',
     1 'Bmam           ', 'B m a m        ', '-B 2c 2        ',
     2 'Cccb           ', 'C c c b        ', '-C 2b 2c       ',
     3 'Abaa           ', 'A b a a        ', '-A 2a 2c       ',
     4 'Acaa           ', 'A c a a        ', '-A 2ac 2c      ',
     5 'Bbcb           ', 'B b c b        ', '-B 2bc 2b      ',
     6 'Bbab           ', 'B b a b        ', '-B 2b 2bc      ',
     7 'Imcb           ', 'I m c b        ', '-I 2a 2        ',
     8 'Icma           ', 'I c m a        ', '-I 2b 2b       ',
     9 'Icab           ', 'I c a b        ', '-I 2a 2b       ',
     * 'Immb           ', 'I m m b        ', '-I 2a 2a       ',
     1 'Ibmm           ', 'I b m m        ', '-I 2c 2c       ',
     2 'Icmm           ', 'I c m m        ', '-I 2 2b        ',
     3 'Imcm           ', 'I m c m        ', '-I 2 2a        ',
     4 'Imam           ', 'I m a m        ', '-I 2c 2        '
     6 /), (/3, NNH/))
C * EQUIVALENT SPACE-GROUP NAME SUBSTITUTIONS
      CHARACTER(len=13), DIMENSION(2, NTRL) :: TRLT = RESHAPE ((/
     1 'P121         ','P2           ', 'P1211        ','P21          ',
     2 'C121         ','C2           ', 'P1M1         ','PM           ',
     3 'P1C1         ','PC           ', 'C1M1         ','CM           ',
     4 'C1C1         ','CC           ', 'P12/M1       ','P2/M         ',
     5 'P121/M1      ','P21/M        ', 'C12/M1       ','C2/M         ',
     6 'P12/C1       ','P2/C         ', 'P121/C1      ','P21/C        ',
     7 'C12/C1       ','C2/C         ', 'PM3          ','PM-3         ',
     8 'PN3          ','PN-3         ', 'FM3          ','FM-3         ',
     9 'FD3          ','FD-3         ', 'IM3          ','IM-3         ',
     * 'PA3          ','PA-3         ', 'IA3          ','IA-3         ',
     1 'PM3M         ','PM-3M        ', 'PN3N         ','PN-3N        ',
     2 'PM3N         ','PM-3N        ', 'PN3M         ','PN-3M        ',
     3 'FM3M         ','FM-3M        ', 'FM3C         ','FM-3C        ',
     4 'FD3M         ','FD-3M        ', 'FD3C         ','FD-3C        ',
     5 'IM3M         ','IM-3M        ', 'IA3D         ','IA-3D        ',
     6 'FM3-M        ','FM-3M        ', 'F4-3C        ','F-43C        ',
     7 'IA3-         ','IA-3         ', 'FD3-         ','FD-3         ',
     8 'FM3-         ','FM-3         ', 'F4-3M        ','F-43M        ',
     9 'IM3-M        ','IM-3M        ', 'FM3-C        ','FM-3C        ',
     1 'IA3-D        ','IA-3D        ', 'IM3-         ','IM-3         ',
     2 'I4-C2        ','I-4C2        ', 'I4-2M        ','I-42M        ',
     3 'PM3-N        ','PM-3N        ', 'PN3-M        ','PN-3M        ',
     4 'PN3-N        ','PN-3N        ', 'P3-M1        ','P-3M1        ',
     5 'P4-C2        ','P-4C2        ', 'I4-M2        ','I-4M2        ',
     6 'I4-3D        ','I-43D        ', 'PA3-         ','PA-3         ',
     7 'PM3-         ','PM-3         ', 'P1-          ','P-1          ',
     8 'P3-          ','P-3          ', 'P3-1C        ','P-31C        ',
     9 'P4-          ','P-4          ', 'P4-M2        ','P-4M2        ',
     * 'I4-          ','I-4          ', 'I4-2D        ','I-42D        ',
     1 'I4-3M        ','I-43M        ', 'PM3-M        ','PM-3M        ',
     2 'PN3-         ','PN-3         ', 'P3-C1        ','P-3C1        ',
     3 'P3-1M        ','P-31M        ', 'P4-B2        ','P-4B2        ',
     4 'P4-N2        ','P-4N2        ', 'P4-2C        ','P-42C        ',
     5 'P4-21M       ','P-421M       ', 'P6-M2        ','P-6M2        ',
     6 'R3-R         ','R-3R         ', 'P4-2M        ','P-42M        ',
     7 'P4-3M        ','P-43M        ', 'P6-          ','P-6          ',
     8 'P6-2C        ','P-62C        ', 'R3-          ','R-3          ',
     9 'R3-C         ','R-3C         ', 'R3-MR        ','R-3MR        ',
     1 'P4-21C       ','P-421C       ', 'P4-3N        ','P-43N        ',
     2 'P6-C2        ','P-6C2        ', 'P6-2M        ','P-62M        ',
     3 'P1N1         ','PN           ', 'P12/N1       ','P2/N         ',
     5 'P121/N1      ','P21/N        ', 'P1A1         ','PA           ',
     6 'P12/A1       ','P2/A         ', 'P121/A1      ','P21/A        ',
     7 'PB3          ','PB-3         ', 'BBAM         ','BBCM         ',
     8 'C2CA         ','C2CB         ', 'CC2B         ','CC2A         ',
     9 'P4/N:2       ','P4/N         ', 'P42/N:2      ','P42/N        ',
     * 'I41/A:2      ','I41/A        ', 'FD-3C:2      ','FD-3C        ',
     1 'FD-3M:2      ','FD-3M        ', 'PN-3M:2      ','PN-3M        ',
     2 'PN-3N:2      ','PN-3N        ', 'FD-3:2       ','FD-3         ',
     3 'PN-3:2       ','PN-3         ', 'I41/ACD:2    ','I41/ACD      ',
     4 'I41/AMD:2    ','I41/AMD      ', 'P42/NCM:2    ','P42/NCM      ',
     5 'P42/NMC:2    ','P42/NMC      ', 'P42/NNM:2    ','P42/NNM      ',
     6 'P42/NBC:2    ','P42/NBC      ', 'P4/NCC:2     ','P4/NCC       ',
     7 'P4/NMM:2     ','P4/NMM       ', 'P4/NNC:2     ','P4/NNC       ',
     8 'P4/NBM:2     ','P4/NBM       ', 'R3:H         ','R3           ',
     9 'R3:R         ','R3R          ', 'R-3:H        ','R-3          ',
     1 'R-3:R        ','R-3R         ', 'R32:H        ','R32          ',
     2 'R32:R        ','R32R         ', 'R-3M:H       ','R-3M         ',
     3 'R-3M:R       ','R-3MR        ', 'R3M:H        ','R3M          ',
     4 'R3M:R        ','R3MR         ', 'R3C:H        ','R3C          ',
     5 'R3C:R        ','R3CR         ', 'R-3C:H       ','R-3C         ',
     6 'R-3C:R       ','R-3CR        ', 'CNNB         ','CCCA:1       ',
     7 'IBMA         ','ICMA         ', 'I12/M1       ','I2/M         ',
     8 'A12/M1       ','A2/M         ', 'P2/M2/M2/M   ','PMMM         ',
     9 'P2/N2/N2/N   ','PNNN         ', 'P2/C2/C2/M   ','PCCM         ',
     * 'P2/B2/A2/N   ','PBAN         ', 'P21/M2/M2/A  ','PMMA         ',
     1 'P2/N21/N2/A  ','PNNA         ', 'P2/M2/N21/A  ','PMNA         ',
     2 'P21/C2/C2/A  ','PCCA         ', 'P21/B21/A2/M ','PBAM         ',
     3 'P21/C21/2/N  ','PCCN         ', 'P2/B21/C21/M ','PBCM         ',
     4 'P21/N21/N2/M ','PNNM         ', 'P21/M21/M2/N ','PMMN         ',
     5 'PMMN:2       ','PMMN         ', 'P21/B2/C21/N ','PBCN         ',
     6 'P21/B21/C21/A','PBCA         ', 'P21/N21/M21/A','PNMA         ',
     7 'C2/M2/C21/M  ','CMCM         ', 'C2/M2/C21/A  ','CMCA         ',
     8 'C2/M2/M2/M   ','CMMM         ', 'C2/C2/C2/M   ','CCCM         ',
     9 'C2/M2/M2/A   ','CMMA         ', 'C2/C2/C2/A   ','CCCA         ',
     1 'F2/M2/M2/M   ','FMMM         ', 'F2/D2/D2/D   ','FDDD         ',
     2 'I2/M2/M/2/M  ','IMMM         ', 'I2/B2/A2/M   ','IBAM         ',
     3 'I21/B21/C21/A','IBCA         ', 'I21/M21/M21/A','IMMA         ',
     4 'H3           ','R3           ', 'H-3          ','R-3          ',
     5 'H3M          ','R3M          ', 'H-3M         ','R-3M         ',
     6 'H3C          ','R3C          ', 'H-3C         ','R-3C         ',
     7 'R3H          ','R3           ', 'R-3H         ','R-3          ',
     8 'R3MH         ','R3M          ', 'R-3MH        ','R-3M         ',
     9 'R3CH         ','R3C          ', 'R-3CH        ','R-3C         ',
     * 'H3-          ','R-3          ', 'R3-H         ','R-3          ',
     1 'H3-M         ','R-3M         ', 'R3-MH        ','R-3M         ',
     2 'H3-C         ','R-3          ', 'R3-CH        ','R-3C         ',
     3 'I121         ','I2           ', 'AEM2         ','ABM2         ',
     4 'BME2         ','BMA2         ', 'B2EM         ','B2CM         ',
     5 'C2ME         ','C2MB         ', 'CM2E         ','CM2A         ',
     6 'AE2M         ','AC2M         ', 'BBE2         ','BBA2         ',
     7 'B2EB         ','B2CB         ', 'C2CE         ','C2CB         ',
     8 'CC2E         ','CC2A         ', 'AE2A         ','AC2A         ',
     9 'CCME         ','CCMB         ', 'AEMA         ','ABMA         ',
     1 'AEAM         ','ACAM         ', 'BBEM         ','BBCM         ',
     2 'BMEB         ','BMAB         ', 'AEMM         ','ABMM         ',
     3 'BMEM         ','BMCM         ', 'AEAA         ','ABAA         ',
     4 'BBEB         ','BBCB         ', 'AEA2         ','ABA2         ',
     5 'CMCE         ','CMCA         ', 'CMME         ','CMMA         ',
     6 'CCCE         ','CCCA         ', 'I12/A1       ','I2/A         ',
     7 'I12/C1       ','I2/C         ', 'ABAM         ','ACAM         ',
     8 'P21/B        ','P1121/B      ', 'I1A1         ','IA           ',
     9 'Fddd:2       ','Fddd         '/), (/2, NTRL/))
      CHARACTER(len=6),  DIMENSION(230)     :: SHFL = (/
     1 'C1^1  ', 'Ci^1  ', 'C2^1  ', 'C2^2  ', 'C2^3  ', 'Cs^1  ',
     2 'Cs^2  ', 'Cs^3  ', 'Cs^4  ', 'C2h^1 ', 'C2h^2 ', 'C2h^3 ',
     3 'C2h^4 ', 'C2h^5 ', 'C2h^6 ', 'D2^1  ', 'D2^2  ', 'D2^3  ',
     4 'D2^4  ', 'D2^5  ', 'D2^6  ', 'D2^7  ', 'D2^8  ', 'D2^9  ',
     5 'C2v^1 ', 'C2v^2 ', 'C2v^3 ', 'C2v^4 ', 'C2v^5 ', 'C2v^6 ',
     6 'C2v^7 ', 'C2v^8 ', 'C2v^9 ', 'C2v^10', 'C2v^11', 'C2v^12',
     7 'C2v^13', 'C2v^14', 'C2v^15', 'C2v^16', 'C2v^17', 'C2v^18',
     8 'C2v^19', 'C2v^20', 'C2v^21', 'C2v^22', 'D2h^1 ', 'D2h^2 ',
     9 'D2h^3 ', 'D2h^4 ', 'D2h^5 ', 'D2h^6 ', 'D2h^7 ', 'D2h^8 ',
     * 'D2h^9 ', 'D2h^10', 'D2h^11', 'D2h^12', 'D2h^13', 'D2h^14',
     1 'D2h^15', 'D2h^16', 'D2h^17', 'D2h^18', 'D2h^19', 'D2h^20',
     2 'D2h^21', 'D2h^22', 'D2h^23', 'D2h^24', 'D2h^25', 'D2h^26',
     3 'D2h^27', 'D2h^28', 'C4^1  ', 'C4^2  ', 'C4^3  ', 'C4^4  ',
     4 'C4^5  ', 'C4^6  ', 'S4^1  ', 'S4^2  ', 'C4h^1 ', 'C4h^2 ',
     5 'C4h^3 ', 'C4h^4 ', 'C4h^5 ', 'C4h^6 ', 'D4^1  ', 'D4^2  ',
     6 'D4^3  ', 'D4^4  ', 'D4^5  ', 'D4^6  ', 'D4^7  ', 'D4^8  ',
     7 'D4^9  ', 'D4^10 ', 'C4v^1 ', 'C4v^2 ', 'C4v^3 ', 'C4v^4 ',
     8 'C4v^5 ', 'C4v^6 ', 'C4v^7 ', 'C4v^8 ', 'C4v^9 ', 'C4v^10',
     9 'C4v^11', 'C4v^12', 'D2d^1 ', 'D2d^2 ', 'D2d^3 ', 'D2d^4 ',
     * 'D2d^5 ', 'D2d^6 ', 'D2d^7 ', 'D2d^8 ', 'D2d^9 ', 'D2d^10',
     1 'D2d^11', 'D2d^12', 'D4h^1 ', 'D4h^2 ', 'D4h^3 ', 'D4h^4 ',
     2 'D4h^5 ', 'D4h^6 ', 'D4h^7 ', 'D4h^8 ', 'D4h^9 ', 'D4h^10',
     3 'D4h^11', 'D4h^12', 'D4h^13', 'D4h^14', 'D4h^15', 'D4h^16',
     4 'D4h^17', 'D4h^18', 'D4h^19', 'D4h^20', 'C3^1  ', 'C3^2  ',
     5 'C3^3  ', 'C3^4  ', 'C3i^1 ', 'C3i^2 ', 'D3^1  ', 'D3^2  ',
     6 'D3^3  ', 'D3^4  ', 'D3^5  ', 'D3^6  ', 'D3^7  ', 'C3v^1 ',
     7 'C3v^2 ', 'C3v^3 ', 'C3v^4 ', 'C3v^5 ', 'C3v^6 ', 'D3d^1 ',
     8 'D3d^2 ', 'D3d^3 ', 'D3d^4 ', 'D3d^5 ', 'D3d^6 ', 'C6^1  ',
     9 'C6^2  ', 'C6^3  ', 'C6^4  ', 'C6^5  ', 'C6^6  ', 'C3h^1 ',
     * 'C6h^1 ', 'C6h^2 ', 'D6^1  ', 'D6^2  ', 'D6^3  ', 'D6^4  ',
     1 'D6^5  ', 'D6^6  ', 'C6v^1 ', 'C6v^2 ', 'C6v^3 ', 'C6v^4 ',
     2 'D3h^1 ', 'D3h^2 ', 'D3h^3 ', 'D3h^4 ', 'D6h^1 ', 'D6h^2 ',
     3 'D6h^3 ', 'D6h^4 ', 'T^1   ', 'T^2   ', 'T^3   ', 'T^4   ',
     4 'T^5   ', 'Th^1  ', 'Th^2  ', 'Th^3  ', 'Th^4  ', 'Th^5  ',
     5 'Th^6  ', 'Th^7  ', 'O^1   ', 'O^2   ', 'O^3   ', 'O^4   ',
     6 'O^5   ', 'O^6   ', 'O^7   ', 'O^8   ', 'Td^1  ', 'Td^2  ',
     7 'Td^3  ', 'Td^4  ', 'Td^5  ', 'Td^6  ', 'Oh^1  ', 'Oh^2  ',
     8 'Oh^3  ', 'Oh^4  ', 'Oh^5  ', 'Oh^6  ', 'Oh^7  ', 'Oh^8  ',
     9 'Oh^9  ', 'Oh^10 '/)
      CHARACTER(len=1), DIMENSION(43)   :: ICHR = (/
     1 '1','2','3','4','5','6','7','8','9','0','.','X','Y','Z', ' ',',',
     2 '+','-','/','[',']','A',' ','B','C','I','H','K','L','P', 'A','B',
     3 'C','F','I','R','P','I','R','F','A','B','C'/)
      CHARACTER(len=4), DIMENSION(6)    :: NOSTP = (/
     1 'ABC ', 'BA-C', 'CAB ', '-CBA', 'BCA ', 'A-CB'/)
      CHARACTER(len=3), DIMENSION(11)   :: CHLIST = (/
     1 ':1 ', ':2 ', ':3 ', ':A ', ':B ', ':C ', ':D ',
     2 ':E ', ':F ', ':N ', ':W '/)
C * NON-Standard Orthorhombic Settings
      CHARACTER(len=9), DIMENSION(NSTD) :: NONST = (/
     1 'P 2 2 21 ', 'P 2221:2 ', 'P 21 2 2 ', 'P 2122:2 ',
     2 'P 2 21 2 ', 'P 2212:2 ',
     3 'P 21 21 2', 'P 21 21 2', 'P 2 21 21', 'P 2 21 21',
     4 'P 21 2 21', 'P 21 2 21',
     5 'C 2 2 21 ', 'C 2221:2 ', 'A 21 2 2 ', 'A 2122:2 ',
     6 'B 2 21 2 ', 'B 2212:2 ',
     7 'C 2 2 2  ', 'C 2 2 2  ', 'A 2 2 2  ', 'A 2 2 2  ',
     8 'B 2 2 2  ', 'B 2 2 2  ',
     9 'P M M 2  ', 'P M M 2  ', 'P 2 M M  ', 'P 2 M M  ',
     * 'P M 2 M  ', 'P M 2 M  ',
     1 'P M C 21 ', 'P C M 21 ', 'P 21 M A ', 'P 21 A M ',
     2 'P B 21 M ', 'P M 21 B ',
     3 'P C C 2  ', 'P C C 2  ', 'P 2 A A  ', 'P 2 A A  ',
     4 'P B 2 B  ', 'P B 2 B  ',
     5 'P M A 2  ', 'P B M 2  ', 'P 2 M B  ', 'P 2 C M  ',
     6 'P C 2 M  ', 'P M 2 A  ',
     7 'P C A 21 ', 'P B C 21 ', 'P 21 A B ', 'P 21 C A ',
     8 'P C 21 B ', 'P B 21 A ',
     9 'P N C 2  ', 'P C N 2  ', 'P 2 N A  ', 'P 2 A N  ',
     * 'P B 2 N  ', 'P N 2 B  ',
     1 'P M N 21 ', 'P N M 21 ', 'P 21 M N ', 'P 21 N M ',
     2 'P N 21 M ', 'P M 21 N ',
     3 'P B A 2  ', 'P B A 2  ', 'P 2 C B  ', 'P 2 C B  ',
     4 'P C 2 A  ', 'P C 2 A  ',
     5 'P N A 21 ', 'P B N 21 ', 'P 21 N B ', 'P 21 C N ',
     6 'P C 21 N ', 'P N 21 A ',
     7 'P N N 2  ', 'P N N 2  ', 'P 2 N N  ', 'P 2 N N  ',
     8 'P N 2 N  ', 'P N 2 N  ',
     9 'C M M 2  ', 'C M M 2  ', 'A 2 M M  ', 'A 2 M M  ',
     * 'B M 2 M  ', 'B M 2 M  ',
     1 'C M C 21 ', 'C C M 21 ', 'A 21 M A ', 'A 21 A M ',
     2 'B B 21 M ', 'B M 21 B ',
     3 'C C C 2  ', 'C C C 2  ', 'A 2 A A  ', 'A 2 A A  ',
     4 'B B 2 B  ', 'B B 2 B  ',
     5 'A M M 2  ', 'B M M 2  ', 'B 2 M M  ', 'C 2 M M  ',
     6 'C M 2 M  ', 'A M 2 M  ',
     7 'A B M 2  ', 'B M A 2  ', 'B 2 C M  ', 'C 2 M B  ',
     8 'C M 2 A  ', 'A C 2 M  ',
     9 'A M A 2  ', 'B B M 2  ', 'B 2 M B  ', 'C 2 C M  ',
     * 'C C 2 M  ', 'A M 2 A  ',
     1 'A B A 2  ', 'B B A 2  ', 'B 2 C B  ', 'C 2 C B  ',
     2 'C C 2 A  ', 'A C 2 A  ',
     3 'F M M 2  ', 'F M M 2  ', 'F 2 M M  ', 'F 2 M M  ',
     4 'F M 2 M  ', 'F M 2 M  ',
     5 'F D D 2  ', 'F D D 2  ', 'F 2 D D  ', 'F 2 D D  ',
     6 'F D 2 D  ', 'F D 2 D  ',
     7 'I M M 2  ', 'I M M 2  ', 'I 2 M M  ', 'I 2 M M  ',
     8 'I M 2 M  ', 'I M 2 M  ',
     9 'I B A 2  ', 'I B A 2  ', 'I 2 C B  ', 'I 2 C B  ',
     * 'I C 2 A  ', 'I C 2 A  ',
     1 'I M A 2  ', 'I B M 2  ', 'I 2 M B  ', 'I 2 C M  ',
     2 'I C 2 M  ', 'I M 2 A  ',
     3 'P C C M  ', 'P C C M  ', 'P M A A  ', 'P M A A  ',
     4 'P B M B  ', 'P B M B  ',
     5 'P B A N  ', 'P B A N  ', 'P N C B  ', 'P N C B  ',
     6 'P C N A  ', 'P C N A  ',
     7 'P M M A  ', 'P M M B  ', 'P B M M  ', 'P C M M  ',
     8 'P M C M  ', 'P M A M  ',
     9 'P N N A  ', 'P N N B  ', 'P B N N  ', 'P C N N  ',
     * 'P N C N  ', 'P N A N  ',
     1 'P M N A  ', 'P N M B  ', 'P B M N  ', 'P C N M  ',
     2 'P N C M  ', 'P M A N  ',
     3 'P C C A  ', 'P C C B  ', 'P B A A  ', 'P C A A  ',
     4 'P B C B  ', 'P B A B  ',
     5 'P B A M  ', 'P B A M  ', 'P M C B  ', 'P M C B  ',
     6 'P C M A  ', 'P C M A  ',
     7 'P C C N  ', 'P C C N  ', 'P N A A  ', 'P N A A  ',
     8 'P B N B  ', 'P B N B  ',
     9 'P B C M  ', 'P C A M  ', 'P M C A  ', 'P M A B  ',
     * 'P B M A  ', 'P C M B  ',
     1 'P N N M  ', 'P N N M  ', 'P M N N  ', 'P M N N  ',
     2 'P N M N  ', 'P N M N  ',
     3 'P M M N  ', 'P M M N  ', 'P N M M  ', 'P N M M  ',
     4 'P M N M  ', 'P M N M  ',
     5 'P B C N  ', 'P C A N  ', 'P N C A  ', 'P N A B  ',
     6 'P B N A  ', 'P C N B  ',
     7 'P B C A  ', 'P C A B  ', 'P B C A  ', 'P C A B  ',
     8 'P B C A  ', 'P C A B  ',
     9 'P N M A  ', 'P M N B  ', 'P B N M  ', 'P C M N  ',
     * 'P M C N  ', 'P N A M  ',
     1 'C M C M  ', 'C C M M  ', 'A M M A  ', 'A M A M  ',
     2 'B B M M  ', 'B M M B  ',
     3 'C M C A  ', 'C C M B  ', 'A B M A  ', 'A C A M  ',
     4 'B B C M  ', 'B M A B  ',
     5 'C M M M  ', 'C M M M  ', 'A M M M  ', 'A M M M  ',
     6 'B M M M  ', 'B M M M  ',
     7 'C C C M  ', 'C C C M  ', 'A M A A  ', 'A M A A  ',
     8 'B B M B  ', 'B B M B  ',
     9 'C M M A  ', 'C M M B  ', 'A B M M  ', 'A C M M  ',
     * 'B M C M  ', 'B M A M  ',
     1 'C C C A  ', 'C C C B  ', 'A B A A  ', 'A C A A  ',
     2 'B B C B  ', 'B B A B  ',
     3 'F D D D  ', 'F D D D:2', 'F D D D  ', 'F D D D:2',
     4 'F D D D  ', 'F D D D:2',
     5 'I B A M  ', 'I B A M  ', 'I M C B  ', 'I M C B  ',
     6 'I C M A  ', 'I C M A  ',
     7 'I B C A  ', 'I C A B  ', 'I B C A  ', 'I C A B  ',
     8 'I B C A  ', 'I C A B  ',
     9 'I M M A  ', 'I M M B  ', 'I B M M  ', 'I C M M  ',
     * 'I M C M  ', 'I M A M  '/)
      END MODULE cspgr
 
      MODULE csgsx
      SAVE
      REAL :: TRDET
      END MODULE csgsx
 
      SUBROUTINE SGSM (ISWITS, LIN, X, NRSYM, IOUT, IERROR)
C **********************************************************************
C *                   (C) 1980 - 2024, A.L.Spek                        *
C **********************************************************************
C *                            A.L.SPEK,                               *
C *             BIJVOET CENTRE FOR BIOMOLECULAR RESEARCH,              *
C *         LABORATORIUM VOOR KRISTAL- EN  STRUCTUURCHEMIE,            *
C *                      UNIVERSITEIT UTRECHT,                         *
C *                        THE NETHERLANDS.                            *
C **********************************************************************
C *       SUBROUTINE FOR THE HANDLING OF SPACE GROUP SYMMETRY.         *
C **********************************************************************
C *                CURRENT VERSION  01-11-2024                         *
C **********************************************************************
C *           ------- FORMAL PARAMETER DEFINITION -----------          *
C **********************************************************************
C * LIN   : CONTAINS INFORMATION (A) FOR SPGR, LATT OR SYMM    (INPUT) *
C *         SYMMETRY OPERATION CODE (A)                        (OUTPUT)*
C * NRSYM : REQUESTED NUMBER OF SYMM OPERATION                 (INPUT) *
C *         NRSYM < 0 MEANS ONLY ABS VALUES                            *
C *         (IN LIST MODE: NRSYM = 0    - NO NEWPAGE HANDLING,         *
C *                        NRSYM < 0 - LINE COUNT/NEWPAGE HANDLING)    *
C * X(12) : X, Y, Z, TX, TY, TZ, XN, YN, ZN              (INPUT/OUTPUT)*
C * IOUT  : IOUT = 0 >> NO OUTPUT                                      *
C * ISWITS: SWITCH FOR OPTION SELECTION  (+/-)                 (INPUT) *
C * IERROR: REPORT ERROR                                       (OUTPUT)*
C **********************************************************************
C * ISW = 0  - ACTUAL SWITCH IS DERIVED FROM KEYWORD IN STRING 'LIN'   *
C * ISW = 1  - BRAVAIS LATTICE INIT WITH INSTRUCTION 'LATT P A'        *
C * ISW = 2  - LOAD SYMM_CODE IN STRING 'LIN' FOR PRINTING OF SYMM_OP  *
C * ISW = 3  - TRANSFORM X,Y,Z WITH SPECIFIED SYMMETRY OPERATION       *
C * ISW = 4  - RECIPROCAL SPACE SYMMETRY LISTING                       *
C * ISW = 5  - TRANSFORM SPECIFIED H,K,L AND PHI FOLLOWING SYMM_NUMBER *
C *            INPUT:  X(1),X(2),X(3),X(4)                             *
C *            OUTPUT: X(7),X(8),X(9),X(10)                            *
C * ISW = 6  - OUTPUT SYMMETRY OPERATION IN (R/T) FORMAT IN ARRAY X    *
C * ISW = 7  - GET SYMMETRY NUMBER + TRANSLATION FOR THAT SPECIFIED IN *
C *            X(1),X(2),X(3) TO X(9)-RESULT IN X(9),X(10),X(11),X(12) *
C *            e.g. 1 -X, X + Y, 1/2 - z =>> -1 1 3 0 2 0 12 0 6       *
C * ISW = 8  - MULTIPLY SYMM (R'/T') IN X(1),X(2),X(3),X(4)            *
C *            WITH (R/T) IN  X(5),X(6),X(7),X(8)                      *
C *            RESULT IN X(9),X(10),X(11),X(12)                        *
C * ISW = 9  - INVERT SYMM (R/T) IN X(1),X(2),X(3),X(4)                *
C *            RESULT  IN X(9),X(10),X(11),X(12)                       *
C * ISW = 10 - LATT CARD HANDLING                                      *
C * ISW = 11 - SYMM CARD HANDLING                                      *
C * ISW = 12 - SPGR CARD HANDLING                                      *
C * ISW = 13 - GET INFO ABOUT ACENT = 1, CENTRIC = 2 IN FN(1)          *
C *            NON-SOHNCKE/SOHNCKE (0/1) IN FN(2)                      *
C * ISW = 14 - HELP + LIST INTERNALLY KNOWN SPACE GROUPS ON UNIT IOUT  *
C * ISW = 15 - INPUT R/T MATRIX TROUGH X (R(1,2) = X(2), T(2) = X(11) )*
C * ISW = 16 - SPGR/LATT/SYMM WITH VALID TRANSFORMATION IN X           *
C * ISW = 17 - SAME AS ISW = 2 APART FROM SHELX-TYPE                   *
C * ISW = 18 - SPACE-GROUP INFO IN X (SG-NUMBER,CRYST-SYST, ..)        *
C *            CHARACTER DATA IN LINE                                  *
C * ISW = 19 - ANALYSE FOR SPECIAL POSITION X(1),X(2),X(3)             *
C *            TOL (DEFAULT = 0.0) IN X(10))                           *
C *            OUTPUT IN X(7)...X(12)                                  *
C * ISW = 20 - ISW(2) + TRANSLATION IN X(4), X(5), X(6)                *
C * ISW = 21 - HALL SYMBOL PARSING                                     *
C * ISW = 22 - SAME AS ISW = 7 BUT WITH SYMM LINE                      *
C * ISW = 23 : GET INFO ABOUT EQUIV NONST ORTHORHOMBIC SPACEGROUP      *
C * ISW = 24 - SAME AS ISW = 18 BUT STANDARD SETTINGS ONLY             *
C * ISW = 25 - SAVE SYMMETRY      ON FILE 'SAVESYMM'                   *
C * ISW = 26 - RESTORE SYMMETRY FROM FILE 'SAVESYMM'                   *
C * ISW = 27 - CHECK H,K,L IN X(1)..X(3) FOR ABSENCE;RES:.(0/1/2) X(12)*
C *            INP:X(12) -1 = lattice abs, +1 = non-lat abs, 0 = both  *
C * ISW =      NEGATIVE: LAUE/PATT SYMMETRY                            *
C **********************************************************************
C * SG01 - PARSE HALL SYMBOL IN 'LINE'                                 *
C * SG02 - CONVERT (R|T) INTO SYMM LINE                                *
C * SG03 - (GENERAL) LATTICE INIT ETC. GET TRANSFORMATION MATRIX       *
C * SG04 - FIND OUT ABOUT POSSIBLE INVERSION CENTRE (OUTSIDE (0 0 0)   *
C * SG05 - FILL IR(I, J, N) WITH IS(K, L, NSL) (TRANSPOSED FOR HKL)-   *
C * SG06 - CALCULATE (R'|T')(R|T) = (R'R|R'T + T')                     *
C * SG07 - MAKE SURE THAT THE TRANSLATION PART IS ALWAYS POSITIVE      *
C * SG08 - CHECK WHETHER THIS IS A NEW SYMMETRY OPERATION-             *
C * SG09 -                                                             *
C * SG10 - GET SYMMOP NR + UNITCELL TRANSLATIONS FOR GIVEN OPERATOR    *
C * SG11 - ISW = 8 : MULTIPLY EXTERNALLY SUPPLIED SYMM OP AND RETURN   *
C *          SYMM NR AND UNIT TRL                                      *
C *        ISW = 9 : CALCULATE INVERSE OPERATION FOR GIVEN OPERATION   *
C *          IN (X(1), ... X(4))                                       *
C * SG12 - FIND SPACE GROUP NAME WHEN VOID                             *
C * SG13 - FIND NAME OF NON-STANDARD SPACEGROUP WHEN SGSMC(8:11)       *
C *        NON-BLANK                                                   *
C * SG14 - GET SYMMETRY OPERATORS FOR SPGR                             *
C * SG15 - SYMM_NR TO SYMMETRY (R/T) IN X(1)..X(9) AND X(10)..X(12)    *
C * SG16 -                                                             *
C * SG17 - (GENERAL) LATTICE INIT - GET & HANDLE TRANSFORMATION MATRI  *
C * SG18 - HANDLE SAVESYMM FILE                                        *
C * SG19 - TEST FOR SYMMETRY RECORD                                    *
C * SG20 - INTERPRETE SYMMETRY INFORMATION (SYMM TO R|T)               *
C * SG21 - ENTRY POINT FOR SPGR & HALL - TRANSFORM LATTICE TYPE        *
C * SG22 - INITIALIZE                                                  *
C * SG23 - CHECK WHETHER REFLECTION H K L IS ABSENT                    *
C * SG24 - LIST SPACEGROUP HEADER                                      *
C * SG25 - LOAD SPACEGROUP DATA                                        *
      USE cspgr
      USE csgsx
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: NSM
      INTEGER            :: LINM
      INTEGER            :: IOUT
      INTEGER            :: NRSYM
      INTEGER            :: ISWITS
      INTEGER            :: IERROR
      REAL, DIMENSION(*) :: X
      CHARACTER(len=*)   :: LIN
      CHARACTER(len=4)   :: NONSTA
C * TEST/LOAD SPGR DATA
      IF (.NOT. SGTLOADED) CALL SG25
C * COPY FROM ARGUMENT LIST
      LINM  = MIN (80, LEN(LIN))
      LINE  = LIN(1:LINM)
      NSM   = NRSYM
      IUIT  = IOUT
      ILAUE = ISIGN (1, ISWITS)
      ISW   = IABS(ISWITS)
C * INIT DEFAULTS
      IER   = 0
      NIC   = 3
      ISWD  = 1
      LRET  = 3
      NSLP  = 0
      ISTO  = 0
      ITRL  = 0
      ISHEL = 0
      NSGET = 0
      NSLPM = 1
C * GLOBAL TRANSFORMATION MATRIX FLAG
      ITRNS = 0
      NTRNS = 0
      TRDET = 0.0
C * SWITCH SELECTION (SPECIAL SWITCHES FIRST)
      DO
        SELECT CASE (ISW)
C * ISW = 0 : HANDLE AND ACT UPON THE EXPLICIT SGSM KEYWORDS
C *           (LATT/SYMM/SPGR/HALL) IN THE INPUT 'LINE' RECORD
          CASE (0)
C * CONVERT LETTERS IN LINE TO UPPER CASE
            CALL GEN020 (1, LINE, 1, 80)
            SELECT CASE (LINE(1:4))
C * LATT RECORD
              CASE ('LATT')
                ISW = 10
C * SYMM RECORD
              CASE ('SYMM')
C * ELIMINATE BLANKS IN SYMM RECORD
                CALL GEN047 (LINE,   4, 80)
C * BLANK
                CALL GEN038 (SGSMC,  1, 11)
                CALL GEN038 (SGSMC, 15, 60)
                ISW = 11
C * SPGR RECORD
              CASE ('SPGR')
                ISW = 12
C * HALL RECORD
              CASE ('HALL')
                ISW = 21
C * UNKNOWN KEYWORD INSTRUCTION ERROR
              CASE DEFAULT
                IF (IUIT /= 0) THEN
                  WRITE (IUIT, 99997, IOSTAT = IOST) LINE(1:40)
                  IER = 13
                END IF
                IERROR = IER
                RETURN
            END SELECT
            CYCLE
C * ISW = 1 :  (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
          CASE (1)
            CALL SG03 (X, TRDET)
C * SET ISBRV, NST, ICNTR
            IF (IER == 0) CALL SG04
            IERROR = IER
            RETURN
C * ISW = 2 : PRINT SYMM (X,Y,Z) LINES
          CASE (2)
            EXIT
C * ISW = 3 : COORDINATE TRANSFORMATION
          CASE (3)
            ISWD = 1
            CALL SG09 (X, NSM)
            IERROR = IER
            RETURN
C * ISW = 4 : PRINT (H,K,L) LINES
          CASE (4)
            EXIT
C * ISW = 5 : HKL TRANSFORMATION
          CASE (5)
            ISWD = -1
            CALL SG09 (X, NSM)
            IERROR = IER
            RETURN
C * ISW = 6 : LOAD ROTATION MATRIX IN X(1:9) AND TRANSLATION VECTOR
C *           IN X(10:12)
          CASE (6)
C * LOAD ROTATION MATRIX FOR NSM IN X(1:9) AND TRANSLATION VECTOR IN X(10:12)
            CALL SG15 (X, NSM)
            IERROR = IER
            RETURN
C * ISW = 7 : GET SYMMOP NR + UNITCELL TRANSLATIONS FOR GIVEN OPERATOR
          CASE (7)
            CALL SG10 (X)
            IERROR = IER
            RETURN
C * ISW = 8 : MULTIPLY EXTERNALLY SUPPLIED SYMM OP AND RETURN SYMM NR
C *           AND UNIT TRL
          CASE (8)
            CALL SG11 (X)
            IERROR = IER
            RETURN
C * ISW = 9 : CALCULATE INVERSE OPERATION FOR GIVEN OPERATION
C *           IN (X(1), ... X(4))
          CASE (9)
            CALL SG11 (X)
            IERROR = IER
            RETURN
C * ISW = 10 : LATTICE CARD (E.G. LATT -4 or LATT I A)
          CASE (10)
            IABSENT = 0
            CALL SG17 (X, TRDET)
            IERROR = IER
            RETURN
C * ISW = 11 : READ SYMM LINE
          CASE (11)
C * INTERPRETE INPUT SYMMETRY INFO
            IABSENT = 0
            CALL SG20 (-1, X, NSM, LIN)
            IERROR = IER
            RETURN
C * ISW = 12 : SEARCH FOR GENERATORS FOR SPECIFIED SPACE GROUP
          CASE (12)
            IABSENT = 0
            CALL SG14 (X, TRDET)
            IF (IER == 0) THEN
              IF (LRET == 2) THEN
                JBG = -19
C * INTERPRETE INPUT SYMMETRY INFO
                CALL SG20 (-1, X, NSM, LIN)
              END IF
            END IF
            IERROR = IER
            RETURN
C * ISW = 13 : (A)CENTRIC, (NON)SOHNCKE
          CASE (13)
            X(1) = FLOAT (ICNTRX)
            X(2) = FLOAT (IMPROP)
            RETURN
C * ISW = 14 : HELP OPTION
          CASE (14)
            IF (IUIT /= 0) WRITE (IUIT, 99993, IOSTAT = IOST)
            IF (NRSYM > 0) THEN
              IF (IUIT /= 0) WRITE (IUIT, 99995, IOSTAT = IOST)
              READ  (NRSYM, 99990) LINE
            END IF
            IF (IUIT /= 0) THEN
              WRITE (IUIT, 99992, IOSTAT = IOST)
              WRITE (IUIT, 99991, IOSTAT = IOST)
            END IF
            IF (NRSYM > 0) THEN
              IF (IUIT /= 0) WRITE (IUIT, 99995, IOSTAT = IOST)
              READ  (NRSYM, 99990) LINE
            END IF
            IF (IUIT /= 0) THEN
              WRITE (IUIT, 99996, IOSTAT = IOST)
              WRITE (IUIT, 99994, IOSTAT = IOST)
     1          (SGT(I)(1:12), I = 1, NRSPGR)
            END IF
            IF (NRSYM > 0) THEN
              IF (IUIT /= 0) WRITE (IUIT, 99995, IOSTAT = IOST)
              READ  (NRSYM, 99990) LINE
            END IF
            IF (IUIT /= 0) THEN
              WRITE (IUIT, 99999, IOSTAT = IOST) (NOSTP(I), I = 1, 6)
              WRITE (IUIT, 99998, IOSTAT = IOST) (NONST(I), I = 1, NSTD)
            END IF
            RETURN
C * ISW = 15 : HANDLE R/T - MATRIX INPUT THROUGH X
          CASE (15)
C * INTERPRETE INPUT SYMMETRY INFO
            CALL SG20 (-1, X, NSM, LIN)
            IERROR = IER
            RETURN
C * ISW = 16 : APPLY TRANSFORMATION IN X ON SYMMETRY IN LINE
          CASE (16)
            ISW   = 0
            ITRNS = 1
            JBG   = 5
            JEG   = 80
            CYCLE
C * ISW = 17 : SHELX-STYLE SYMM CARDS
          CASE (17)
            ISW   = 2
            ISHEL = 1
            EXIT
C * ISW = 18 : INFO OPTION: SPACE GROUP NUMBER, CRYSTAL SYSTEM,
C *             LAUE GROUP NUMBER, NSYMP, ICNTR, IBV
C *             SPACEGROUP NAME (1:11)
          CASE (18)
            EXIT
C * ISW = 19 : FIND OUT ABOUT SPECIAL POSITION
          CASE (19)
            CALL SG16 (LIN, X)
            IERROR = IER
            RETURN
C * ISW = 20 : PRINT SYMM INCLUDING TRANSLATION
          CASE (20)
            ISW  = 2
            ITRL = 12
            EXIT
C * ISW = 21 : PARSE HALL-SYMBOL
          CASE (21)
            IABSENT = 0
C * (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
            CALL SG03 (X, TRDET)
C * SET ISBRV, NST, ICNTR
            IF (IER == 0) CALL SG04
            IF (IER == 0) THEN
C * BLANK SPGR NAME
              CALL GEN038 (ZSPG, 1, 13)
              DO I = 5, 80
                IF (LINE(I:I) /= ' ') EXIT
              END DO
              IF (LINE(I:I) == '-') THEN
                K = 35
              ELSE
                K = 34
              END IF
              SGSMC(33:) = LINE(I : I + 16)
C * MAKE NON-LATT PART LOWER CASE
              CALL GEN020 (-1, SGSMC, K, 49)
C * PARSE HALL-SYMBOL IN 'LINE'
              CALL SG01 (1)
              IF (IER == 0) THEN
                LRET = 2
                JBG  = -19
C * INTERPRETE INPUT SYMMETRY INFO
                CALL SG20 (-1, X, NSM, LIN)
              END IF
            END IF
            IERROR = IER
            RETURN
C * ISW = 22 : GET SYMM NR FOR SYMM
          CASE (22)
            ISW   = 0
            NSGET = 1
            CYCLE
C * ISW = 23 : GET INFO ABOUT EQUIV NONST ORTHORHOMBIC SPACEGROUP
          CASE (23)
            CALL GEN074 (X, 1, 8, 0.0)
            K = NSLOC(ISGNR - 15)
            IF (K == 0) THEN
              CALL GEN074 (X, 1, 6, 1.0)
            ELSE
              NONSTA = SGSMC(8:11)
              CALL GEN020 (1, NONSTA, 1, 4)
              IF (NONSTA == '    ') NONSTA = 'ABC '
              DO J = 1, 6
                IF (NOSTP(J) == NONSTA) EXIT
              END DO
              DO I = 1, 6
                IF (NONST((K - 1) * 6 + I) .EQ.
     1              NONST((K - 1) * 6 + J)) X(I) = 1
              END DO
            END IF
            IERROR = IER
            RETURN
C * ISW = 24 - SAME AS ISW = 18, STANDARD SETTING ONLY
          CASE (24)
            ISTO = 1
            ISW  = 18
            EXIT
C * ISW = 25
          CASE (25)
            CALL SG18 (1)
            IERROR = IER
            RETURN
C * ISW = 26
          CASE (26)
            CALL SG18 (-1)
            IERROR = IER
            RETURN
C * ISW = 27
          CASE (27)
            CALL SG23 (X)
            IERROR = IER
            RETURN
C * DEFAULT
          CASE DEFAULT
            IERROR = IER
            RETURN
        END SELECT
      END DO
C * SPACE GROUP NAME RECOVERY WHEN NAME-FIELD VOID
      IF (SGSMC(1:1) /= ' ') THEN
        CALL SG13 (LIN, X, NRSYM)
C * FIND NAME OF NON-STANDARD SPACEGROUP WHEN SGSMC(8:11) NON-BLANK
      ELSE
        CALL SG20 (0, X, NSM, LIN)
      END IF
      IF (ISW == 18 .AND. IUIT /= 0)
     1  WRITE (IUIT, 99989) LIN(1:LINM), (X(I), I = 1, 14)
      IERROR = IER
      RETURN
99999 FORMAT (/, 'Nonstandard Settings with Cell Transformations',
     1 ' (see Internat. Tables, Vol A)', /,
     1 46('='), /, 6(A4, 7X), /, 66('-'))
99998 FORMAT (6(1X, A, 1X))
99997 FORMAT (/, 'Line Ignored :', A, /)
99996 FORMAT (/, 4X, 'Space Group Names Known to the Program', //)
99995 FORMAT ('====>> Continue with <CR> <<====')
99994 FORMAT (6(1X, A))
99993 FORMAT (/, 'General Space Group Symmetry Handler - Version:',
     1 ' 16-Feb-2021', //, 'Note: only a subset may be accessible',
     2 //, 'There are Five  Groups of Instructions:', /,
     3 'A - Symmetry Specification with <SPGR>,<LATT>,<SYMM>', /,
     4 'B - Symmetry List Options  with <LIST> and <RLST>', /,
     5 'C - Actual Transformations with <ATOM> and <HKL>', /,
     6 'D - Output of R and T Matrices with <DMAT>', /,
     7 'E - Miscellaneous <TRNS>', //,
     8 '<SPGR> - Symmetry may be Specified as <P21/c>, P21.CAB, etc.',/,
     9 '<LATT> - Contains <P/A/B/C/I/F/R> and <C/A>', /
     * '<SYMM> - e.g. < 1/2-X,1/2+Y,1/2-Z>', /,
     1 '<LIST> - Gives a Listing of the Symmetry in X,Y,Z', /
     2 '<RLST> - Gives a Listing of the Symmetry in H,K,L', /,
     3 '<ATOM> - Specify Three Fractional Coordinates; The', /, 9X,
     4 'Program Generates Symm. Related Positions', /,
     5 '<VECT> - as <ATOM> but with Patterson Symmetry', /,
     6 '<HKL > - Specify H,K,L ; The Program Generates the', /, 9X,
     7 'Symm. Related Set. Specification of a Phase', /, 9X,
     6 'as a Fourth Item Gives Phase Values as Well')
99992 FORMAT ('<DMAT> - Specify Symmetry Number ; The Matrices R '/
     1 '         and T are Returned in Array X(1:12)'/,
     2 '<GSNR> - Specify Coded Symmetry Operation in X(1:9),',/
     3 '         Result: Symmetry Number + Unit Translations',/,
     4 '<MULT> - S1,TX1,TY1,TZ1,S2,TX2,TY2,TZ2',/,
     5 '         RESULT: S3,TX3,TY3,TZ3',/,
     6 '<INVT> - S1,TX1,TY1,TZ1 ; RESULT: S2,TX2,TY2,TZ2',/,
     7 '<TRNS> - T11,T12,..,T33,(S1,S2,S3) : Cell Transform+Shift',/,
     8 '<SITE> - X, Y, Z (Fract. TOL);Output Site Symm Nr in X(12)',/,
     9 '<END> or <STOP> Terminates the Program',/)
99991 FORMAT (/'Remarks:'/'1 - A <LATT> Card Initialises the Number',
     1 ' of Known'/4X,'Symmetry Operations to 1: X,Y,Z'/'2 - A <S',
     2 'YMM> Card is Interpreted as a Generator, so-'/4X,'that at ',
     3 'most 4 <SYMM> Cards are Needed'/'3 - The Program Contains ' ,
     4 'data for all Standard Space'/4X, 'Group Symbols (Including',
     5 ' Some Non-Standard Settings)',/,
     6 '4 - The Sub-word <PATT> Together with <LIST>,<ATOM>',
     7 /14X,'or <LAUE> Together with <RLST>,<HKL>',
     8 /4X,'Generates/Applies the Corresponding Symmetries'/)
99990 FORMAT (A)
99989 FORMAT (A, /, 14F5.0)
      END SUBROUTINE SGSM
 
      SUBROUTINE SG01 (MODE)
C * PARSE HALL-SYMBOL IN 'LINE'
      USE cspgr
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: LH
      INTEGER          :: JB
      INTEGER          :: JE
      INTEGER          :: IHX
      INTEGER          :: NLEV
      INTEGER          :: LPAR
      INTEGER          :: MODE
      INTEGER          :: ISGN
      INTEGER          :: ISTAT
      CHARACTER(len=1) :: LNI
      CHARACTER(len=1) :: LN0
C * IHALL (1, NLEV) = ROTATION AXIS OFFSET
C * IHALL (2, NLEV) = SIGN
C * IHALL (3, NLEV) = ROTATION AXIS
C * IHALL (4, NLEV) = GLY-X
C * IHALL (5, NLEV) = GLY-Y
C * IHALL (6, NLEV) = GLY-Z
C * IHALL (7, NLEV) = SHIFT-X
C * IHALL (8, NLEV) = SHIFT-Y
C * IHALL (9, NLEV) = SHIFT-Z
C * NLEV = -1 - START
C * NLEV =  0 - LATTICE TYPE FOUND
C * UPPER CASE
      CALL GEN020 (1, LINE, 1, 80)
      IF (MODE == 1) SGSMC(14:14) = 'A'
      JB    = -19
      JE    = 0
      NLEV  = -1
      ISGN  = 1
      LPAR  = -1
      JLAUE = 8
      ISTAT = 0
      DO L = 1, 4
        DO K = 1, 9
          IHALL(K, L) = 0
        END DO
        IHALL(2, L) = 1
      END DO
C * LOOP OVER CHARACTERS IN 'LINE'
      DO 10 I = 5, 80
        LN0 = LINE(I - 1: I - 1)
        LNI = LINE(I : I)
C * FIRST IDENTIFY LATTICE TYPE & (NON)CENTROSYMMETRY
        IF (NLEV == -1) THEN
          IF (LNI == '-') THEN
            IF (MODE == 1) SGSMC(14:14) = 'C'
          ELSE IF (LNI /= ' ') THEN
C * LOOP OVER LATTICE TYPES P, ...,R
            DO J = 1, 7
              IF (LNI == ICHR(36 + J)) THEN
                IF (ZSPG(1:1) == ' ' .AND. MODE == 1)
     1              SGSMC(13:13) = LNI
                NLEV        = 0
                ISTAT       = 1
                IHALL(1, 1) = 10
                GO TO 10
              END IF
            END DO
          END IF
C * IDENTIFY ROTATIONS
        ELSE
          SELECT CASE (LNI)
            CASE ( '-')
              IF (LPAR < 0) THEN
                NLEV  = NLEV + ISTAT
                IF (NLEV > 4) GO TO 20
                ISTAT          = 0
                IHALL(2, NLEV) = -1
              ELSE
                ISGN = -1
              END IF
            CASE ('(')
              IF (NLEV < 2) GO TO 20
              LPAR = 0
            CASE (')')
            CASE ('0')
              IF (LPAR >= 0) LPAR = LPAR + 1
            CASE ('1')
              IF (LPAR >= 0) THEN
                LPAR = LPAR + 1
                IF (NLEV > 4) GO TO 20
                IHALL(6 + LPAR, NLEV) = ISGN
                ISGN = 1
C * 31
              ELSE IF (LN0 == '3') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 4
C * 41
              ELSE IF (LN0 == '4') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 3
C * 61
              ELSE IF (LN0 == '6') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 2
              ELSE
                NLEV  = NLEV + ISTAT
                IF (NLEV > 4) GO TO 20
                ISTAT = 1
                IHALL(3, NLEV) = 0
              END IF
            CASE ('2')
C * 32
              IF (LN0 == '3') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 8
C * 62
              ELSE IF (LN0 == '6') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 4
              ELSE
                NLEV  = NLEV + ISTAT
                IF (NLEV > 4) GO TO 20
                ISTAT = 1
                IF (NLEV > 1) THEN
                  IHX = IHALL(1, NLEV - 1) + IHALL(3, NLEV - 1)
                ELSE
                  IHX = 0
                END IF
                IF (IHX == 2 .OR. IHX == 4) THEN
                  IHALL(1, NLEV) = 15
                  IHALL(3, NLEV) = 0
                ELSE IF (IHX == 7 .OR. IHX == 9) THEN
                  IHALL(1, NLEV) = 15
                  IHALL(3, NLEV) = 2
                ELSE IF (IHX == 12 .OR. IHX == 14 .OR.
     1                   IHX == 21) THEN
                  IHALL(1, NLEV) = 15
                  IHALL(3, NLEV) = 4
                ELSE
                  IHALL(3, NLEV) = 1
                END IF
              END IF
            CASE ('3')
C * 43
              IF (LN0 == '4') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 9
              ELSE
                NLEV  = NLEV + ISTAT
                IF (NLEV > 4) GO TO 20
                ISTAT = 1
                IHALL(3, NLEV) = 2
                IF (NLEV == 3) THEN
                  IHALL(1, NLEV) = 21
                  IHALL(3, NLEV) = 0
                END IF
              END IF
            CASE ('4')
C * 64
              IF (LN0 == '6') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) + 8
              ELSE
                NLEV  = NLEV + ISTAT
                IF (NLEV > 4) GO TO 20
                ISTAT = 1
                IHALL(3, NLEV) = 3
              END IF
            CASE ('5')
              IF (LN0 == '6') THEN
                IF (NLEV > 4) GO TO 20
                IHALL(6, NLEV) = IHALL(6, NLEV) +  10
              END IF
            CASE ('6')
              NLEV  = NLEV + ISTAT
              IF (NLEV > 4) GO TO 20
              ISTAT = 1
              IHALL(3, NLEV) = 4
            CASE ('X')
              IHALL(1, NLEV) = 0
            CASE ('Y')
              IHALL(1, NLEV) = 5
            CASE ('Z')
              IHALL(1, NLEV) = 10
            CASE ('*')
              IHALL(1, NLEV) = 21
              IHALL(3, NLEV) = 0
            CASE ('''')
              IHALL(1, NLEV) = 15
              IHX = IHALL(1, NLEV - 1)
              IF (IHX == 0) THEN
                IHALL(3, NLEV) = 0
              ELSE IF (IHX == 5) THEN
                IHALL(3, NLEV) = 2
              ELSE
                IHALL(3, NLEV) = 4
              END IF
            CASE ('"')
              JLAUE = 7
              IHALL(1, NLEV) = 15
              IF (NLEV == 1) GO TO 20
              IHX = IHALL(1, NLEV - 1)
              IF (IHX == 0) THEN
                IHALL(3, NLEV) = 1
              ELSE IF (IHX == 5) THEN
                IHALL(3, NLEV) = 3
              ELSE
                IHALL(3, NLEV) = 5
              END IF
            CASE ('A')
              IF (NLEV > 4) GO TO 20
              IHALL(4, NLEV) = IHALL(4, NLEV) + 6
            CASE ('B')
              IF (NLEV > 4) GO TO 20
              IHALL(5, NLEV) = IHALL(5, NLEV) + 6
            CASE ('C')
              IF (NLEV > 4) GO TO 20
              IHALL(6, NLEV) = IHALL(6, NLEV) + 6
            CASE ('N')
              IF (NLEV > 4) GO TO 20
              DO J = 4, 6
                IHALL(J, NLEV) = IHALL(J, NLEV) + 6
              END DO
            CASE ('U')
              IHALL(4, NLEV) = IHALL(4, NLEV) + 3
            CASE ('V')
              IHALL(5, NLEV) = IHALL(5, NLEV) + 3
            CASE ('W')
              IHALL(6, NLEV) = IHALL(6, NLEV) + 3
            CASE ('D')
              DO J = 4, 6
                IHALL(J, NLEV) = IHALL(J, NLEV) + 3
              END DO
          END SELECT
        END IF
   10 CONTINUE
      IF (NLEV > 0) THEN
        IF (MODE == 1) CALL SG04
        IF (IER == 0) THEN
          CALL GEN038 (LINE, 1, 80)
          DO LH = 1, NLEV
            JB = JB + 20
            JE = JE + 20
            M  = (IHALL(1, LH) + IHALL(3, LH)) * 9
            DO J = 1, 3
              DO I = 1, 3
                K = (J - 1) * 3 + I
                R0(I, J) = NHRM(M + K) * IHALL(2, LH)
              END DO
            END DO
            DO K = 1, 3
              T0(K) = (IHALL(3 + K, LH) + IHALL(6 + K, LH)) / 12.0
            END DO
            DO I = 1, 3
              DO J = 1, 3
                T0(I) = T0(I) - R0(I, J) * IHALL(6 + J, LH) / 12.0
              END DO
            END DO
            NTRNS = ITRNS
C * CONVERT (R0|T0) INTO SYMM LINE
            CALL SG02 (JB)
            IF (IER /= 0) GO TO 20
          END DO
        END IF
        IF (IER == 0) RETURN
      END IF
   20 IER = 7
      RETURN
      END SUBROUTINE SG01
 
      SUBROUTINE SG02 (JB)
      USE cspgr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: JB
      INTEGER :: NR0
      INTEGER :: NTRV
      INTEGER :: NTRVN
      REAL    :: TRV
C * CONVERT (R|T) INTO SYMM LINE
C * BLANK
      CALL GEN038 (LINE, JB, JB + 19)
      K = JB
      DO I = 1, 3
        TRV  = AMOD (T0(I) * 12.0, 12.0)
        NTRV = NINT (TRV)
        IF (ABS (TRV - NTRV) > 0.1) THEN
          IF (IUIT /= 0)
     1      WRITE (IUIT, 99999, IOSTAT = IOST) (T0(K), K = 1, 3)
          IER = 8
          RETURN
        END IF
        NTRVN = 12
        IF (NTRV /= 0) THEN
          IF (NTRV < 0) NTRV = NTRV + 12
          IF (NTRV > 0) THEN
            DO WHILE (.TRUE.)
              IF (MOD (NTRV, 2) == 0 .AND. MOD (NTRVN, 2) == 0) THEN
                NTRV  = NTRV  / 2
                NTRVN = NTRVN / 2
                CYCLE
              ELSE IF (MOD (NTRV, 3) == 0 .AND. MOD (NTRVN, 3) == 0)
     1          THEN
                NTRV  = NTRV  / 3
                NTRVN = NTRVN / 3
                CYCLE
              ELSE
                LINE(K:K+2) = ICHR(NTRV)//'/'//ICHR(NTRVN)
                K = K + 3
                EXIT
              END IF
            END DO
          END IF
        END IF
        DO J = 1, 3
          IF (ABS (R0(I, J)) > 0.9) THEN
            NR0 = NINT (R0(I, J))
            IF (NR0 > 0) THEN
              LINE(K:K) = '+'
            ELSE
              LINE(K:K) = '-'
            END IF
            LINE(K + 1:K + 1) = ICHR(11 + J)
            K = K + 2
          END IF
        END DO
        IF (I < 3) THEN
          LINE(K:K) = ','
          K = K + 1
        END IF
      END DO
      RETURN
99999 FORMAT (/, 'E: SYMM TRANSLATION n/a:', 3F8.3)
      END SUBROUTINE SG02
 
      SUBROUTINE SG03 (X, DET)
C * (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      REAL               :: DET
      REAL, DIMENSION(*) :: X
      IF (ITRNS == 0) THEN
C * INIT TO UNIT TRANSFORMATION
        CALL GEN021 (R1, 1.0)
        CALL GEN074 (OSFT, 1, 3, 0.0)
        DET = 1
C * LOAD ORIENTATION AND ORIGIN SHIFT DATA
      ELSE
        K = 0
        DO I = 1, 3
          OSFT(I) = - X(I + 9)
          DO J = 1, 3
            K        = K   + 1
            R1(J, I) = X(K)
          END DO
        END DO
C * R1 CONTAINS TRNS TRANSPOSE; R2 RECEIVES TTRNS-1 TRANSPOSE
        CALL GEN003 (R1, R4, DET, 0)
        DO I = 1, 3
          DO J = 1, 4
            IF (J == 4) THEN
              R2(I, J) = 0.0
            ELSE
              R2(I, J) = R4(I, J)
            END IF
          END DO
        END DO
C * CHECK FOR REVERSE HEXAGONAL SETTING
        IF (NINT (DET) == 3) THEN
          IF (R1(1, 1) == -1.0 .AND. R1(1, 2) ==  0.0 .AND.
     1        R1(1, 3) ==  1.0 .AND. R1(2, 1) ==  1.0 .AND.
     2        R1(2, 2) == -1.0 .AND. R1(2, 3) ==  1.0 .AND.
     3        R1(3, 1) ==  0.0 .AND. R1(3, 2) ==  1.0 .AND.
     4        R1(3, 3) ==  1) THEN
            IER = 14
            IF (IUIT /= 0) WRITE (IUIT, 99998, IOSTAT = IOST)
            RETURN
          END IF
C * CHECK FOR TRANSFORMATION WITH DETERMINANT = ZERO
        ELSE IF (ABS(DET) < 0.1) THEN
          IF (IUIT /= 0)
     1      WRITE (IUIT, 99999, IOSTAT = IOST)
     2        DET, ((R1(I, J), I = 1, 3), J = 1, 3)
          IER = 11
          RETURN
        END IF
      END IF
C * NOT SYMM LINE TEST
      IF (ISW /= 11) CALL SG22
      RETURN
99999 FORMAT (':: Transformation Matrix with Determinant =', F6.3, //,
     1 3(3F10.3, /))
99998 FORMAT (':: Transformation to Reverse Setting not Allowed', /,
     1        '   Use (1 -1 0 0 1 -1 1 1 1) for rR to hR.', /)
      END SUBROUTINE SG03
 
      SUBROUTINE SG04
      USE cspgr
      USE spgrdata
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: IBVP
      INTEGER :: NSYMX
      IF (SGSMC(14:14) == 'C') THEN
        ICNTR  = 2
        IFLACK = 0
      ELSE
        ICNTR = 1
      END IF
C * FIND OUT ABOUT POSSIBLE INVERSION CENTRE (OUTSIDE 0,0,0)
      ICNTRX = ICNTR
      NSYMX  = NSYMP
      OCNT(1) = 0.0
      OCNT(2) = 0.0
      OCNT(3) = 0.0
      IF (ICNTR == 1 .AND. NSYMP > 1) THEN
        DO 10 I = 2, NSYMP
          DO K = 1, 3
            IF (IS(2, K, I) /=   0) GO TO 10
            IF (IS(1, K, I) /= - K) GO TO 10
          END DO
          DO K = 1, 3
            OCNT(K) = FLOAT (IS(3, K, I)) / 24
          END DO
          ICNTRX = 2
          IFLACK = 0
          NSYMX  = NSYMP / 2
          EXIT
   10   CONTINUE
      END IF
      DO K = 1, 7
        IF (SGSMC(13:13) == ICHR(K + 29)) THEN
          IBV  = IBV0(K)
          IBVP = IBV1(K)
          DO J = 1, IBV
            DO I = 1, 3
              IF (J == 1) THEN
                ISBRV(J, I) = 0
              ELSE
                ISBRV(J, I) = IBV2(IBVP)
                IBVP        = IBVP + 1
              END IF
            END DO
          END DO
          IF (ILAUE < 0) THEN
            IINV = 2
          ELSE
            IINV = ICNTR
          END IF
          NST  = NSYMP * IBV * IINV
C * GET CRYSTAL SYSTEM
          IKLS  =  8
          LAUE  = 13
          IF (NSYMX == 1) THEN
C * TRICLINIC
            IKLS = 1
C * -1
            LAUE = 1
          ELSE IF (NSYMX == 2) THEN
C * MONOCLINIC
            IKLS = 2
C * 2/m
            LAUE = 2
      ELSE IF (IAXM == 6) THEN
C * HEXAGONAL
            IKLS = 6
            IF (NSYMX == 6) THEN
C * 6/m
              LAUE = 9
            ELSE
C * 6/mmm
              LAUE = 10
            END IF
          ELSE IF (NSYMX >= 12) THEN
C * CUBIC
            IKLS = 7
            IF (NSYMX == 12) THEN
C * m-3
              LAUE = 11
            ELSE
C * m-3m
              LAUE = 12
            END IF
          ELSE IF (IAXM == 4) THEN
C * TETRAGONAL
            IKLS = 4
            IF (NSYMX == 4) THEN
C * 4/m
              LAUE = 4
            ELSE
C * 4/mmm
              LAUE = 5
            END IF
          ELSE IF (IAXM == 3) THEN
C * TRIGONAL/RHOMBOHEDRAL
            IKLS = 5
            IF (NSYMX == 3) THEN
C * -3
              LAUE = 6
            ELSE
C * -3m1 or -31m
              LAUE = 14
            END IF
          ELSE IF (NSYMX == 4) THEN
C * ORTHORHOMBIC
            IKLS  = 3
C * mmm
            LAUE  = 3
          END IF
          JSMI = NSG(2 * LAUE - 1)
          JSMX = NSG(2 * LAUE)
C * DETERMINE RHOMBOHEDRAL OR HEXAGONAL SETTING FOR TRIGONAL
          IF(IKLS == 5 .AND. IABS (IS(1, 3, 2)) == 3) THEN
            SGSMC(12:12) = IBVL(6)
          ELSE
            SGSMC(12:12) = IBVL(IKLS)
          END IF
          RETURN
        ENDIF
      END DO
      IF (IUIT /= 0) WRITE (IUIT, 99999, IOSTAT = IOST) SGSMC(13:13)
      IER = 10
      RETURN
99999 FORMAT (':: Unknown LATTICE Type:', A)
      END SUBROUTINE SG04
 
      SUBROUTINE SG05 (N, NSL, INVOKED)
C * FILL IR(I, J, N) WITH IS(K, L, NSL) (TRANSPOSED FOR HKL)
      USE cspgr
      IMPLICIT NONE
      INTEGER :: INVOKED
      INTEGER :: I
      INTEGER :: K
      INTEGER :: N
      INTEGER :: NS
      INTEGER :: NS0
      INTEGER :: NS1
      INTEGER :: NS2
      INTEGER :: INH
      INTEGER :: NSL
      INTEGER :: INHD
C * N     - TARGET POSITION IN ARRAY IR()
C * NS    - NUMBER SYMMETRY OPERATION OUT OF NSYMP
C * NS0   - 0/1 INVERSION
C * NSL   - NUMBER SYMMETRY OPERATION
C * NSYMP - NUMBER SYMMETRY OPERATIONS EXCLUDING BRAVAIS AND INVERSION
      IF (NSL == 0) THEN
        IF (IUIT /= 0) WRITE (IUIT, 99996, IOSTAT = IOST) INVOKED
        IER = 9
        RETURN
      END IF
      NS0 = (IABS (NSL) - 1) / NSYMP
      NS  =  IABS (NSL) - NS0 * NSYMP
      IF (NS < 1) THEN
        IF (IUIT /= 0)
     1    WRITE (IUIT, 99998, IOSTAT = IOST) NSL, NSYMP, NS0, NS,ISW
        IER = 5
        RETURN
      END IF
      IF (ILAUE < 0) THEN
        IINV = 2
      ELSE
        IINV = ICNTR
      END IF
      NS2 = NS0 / IINV
      NS1 = NS0 + 1 - NS2 * IINV
      NS2 = NS2 + 1
      IF (NS2 < 1 .OR. NS2 > 4) THEN
        IF (IUIT /= 0)
     1    WRITE (IUIT, 99999, IOSTAT = IOST) NS0, NS1, NS2, IINV
        IER = 4
        RETURN
      END IF
      IF (N < 1 .OR. N > 195) THEN
        IF (IUIT /= 0)
     1    WRITE (IUIT, 99997, IOSTAT = IOST) NS, NS0, NS1, NS2, IINV, N
        IER = 3
        RETURN
      END IF
      DO I = 1, 3
        IR(1, I, N) = 0
        IR(2, I, N) = 0
      END DO
      DO I = 1, 3
        DO K = 1, 3
          INH = IS(K, I, NS)
          IF (NS1 == 2) INH = - INH
          IF (K == 3) THEN
            IF (ILAUE > 0) THEN
              INH = MOD (INH + ISBRV(NS2, I), 12)
            ELSE
              INH = MOD (ISBRV(NS2, I), 12)
            END IF
            IF (INH < 0) INH = INH + 12
            IR(K, I, N) = INH
          ELSE IF (ISWD > 0) THEN
            IR(K, I, N) = INH
          ELSE IF (INH /= 0) THEN
            IF (INH < 0) THEN
              INHD = - I
              INH  = - INH
            ELSE
              INHD =  I
            END IF
            IF (IR(1, INH, N) == 0) THEN
              IR(1, INH, N) = INHD
            ELSE
              IR(2, INH, N) = INHD
            END IF
          END IF
        END DO
      END DO
      RETURN
99999 FORMAT ('SGSM Problem:NS0,NS1,NS2,IINV = ', 4I10,
     1        'NS2 < 1 OR NS2 > 4')
99998 FORMAT ('NS < 1 ERROR IN (SGSM)', /,
     1        'NSL, NSYMP, NS0, NS, ISW =', 5I10, /)
99997 FORMAT ('E: SPGR-Problem', 6I5, /)
99996 FORMAT ('nsl = 0 in SG05 From', I4)
      END SUBROUTINE SG05
 
      SUBROUTINE SG06
C * CALCULATE (R'|T')(R|T) = (R'R|R'T+T')
      USE cspgr
      IMPLICIT NONE
      INTEGER :: K
      INTEGER :: L
      INTEGER :: M
      INTEGER :: N
      INTEGER :: ISJ
      INTEGER :: ISS
      INTEGER :: ISX
      INTEGER :: ISY
      INTEGER :: ITS
      DO K = 1, 3
        DO M = 1, 3
          ISV(M) = 0
        END DO
        ITS = IR(3, K, 193)
        DO L = 1, 2
          ISJ = IR(L, K, 193)
          IF (ISJ /= 0) THEN
            ISS = IR(3, IABS (ISJ), 194)
            IF (ISJ < 0) ISS = - ISS
            ITS = ITS + ISS
            DO M = 1, 2
              ISX = IR(M, IABS (ISJ), 194)
              IF (ISJ < 0) ISX = - ISX
              IF (ISX /= 0) THEN
                ISY = IABS (ISX)
                ISV(ISY) = ISV(ISY) + ISX
              END IF
            END DO
          END IF
        END DO
        IR(2, K, 195) = 0
        N = 0
        DO M = 1, 3
          IF (ISV(M) /= 0) THEN
            N             = N + 1
            IR(N, K, 195) = ISV(M)
          END IF
        END DO
        IR(3, K, 195) = ITS
      END DO
      RETURN
      END SUBROUTINE SG06
 
      SUBROUTINE SG07
      USE cspgr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: NSM
      INTEGER :: NSP
      INTEGER :: IAX
      INTEGER :: ISN
      INTEGER :: ITS
      INTEGER :: ISLK
      INTEGER :: ISLKA
      INTEGER :: ISCOD
C * MAKE SURE THAT THE TRANSLATION PART IS ALWAYS POSITIVE (IT-STANDARD)
      DO K = 1, 3
        ITS = MOD (IR(3, K, 195), 12)
        IF (ITS < 0) ITS = ITS + 12
        IR(3, K, 195) = ITS
      END DO
      NSP  = -1
      CALL SG08 (NSP)
      IF (IER == 0) THEN
        IF (NSP < 0) THEN
          IF (NSYMP < 48) THEN
            NSYMP = NSYMP + 1
            DO L = 1, 3
              DO K = 1, 3
                ISLK            = IR(L, K, 195)
                IS(L, K, NSYMP) = ISLK
                ISLKA           = IABS (ISLK)
                IF (L < 3 .AND. ISLK /= 0) THEN
                  IF (ISLKA < 4)  THEN
                    IORG(ISLKA, K) = IORG(ISLKA, K) + ISLK
                  ELSE
                    IF (IUIT /= 0) WRITE (IUIT, 99998, IOSTAT = IOST)
                    IER = 12
                    RETURN
                  END IF
                END IF
              END DO
            END DO
            IF (IS(1, 3, NSYMP) > 0) THEN
              ISN =  100000
            ELSE
              ISN = -100000
            END IF
            ISCOD = 555555
            DO K = 1, 3
              DO L = 1, 2
                ISCOD = ISCOD + ISN * IS(L, K, NSYMP)
                ISN = ISN / 10
              END DO
            END DO
            IF (ISCOD == 356385 .OR. ISCOD == 856575) THEN
              IAX = 3
            ELSE IF (ISCOD == 356585) THEN
              IAX = 4
            ELSE IF (ISCOD == 636585) THEN
              IAX = 6
            ELSE
              IAX = 0
            END IF
            IAXM = MAX (IAXM, IAX)
          ELSE
            IF (IUIT /= 0) WRITE (IUIT, 99999, IOSTAT = IOST)
            IER = 6
            RETURN
          END IF
C * NSP > 0
        ELSE IF (NSP > 0) THEN
          NSM = 1
          DO
            NSM = NSM + 1
            IF (NSM > 1 .AND. NSM <= NSYMP) THEN
              NSP = -1
              DO I = 1, 3
                DO J = 1, 3
                  IR(I, J, 195) = IS(I, J, NSM)
                END DO
              END DO
              NSP = -1
              CALL SG08 (NSP)
              IF (NSP > 0) THEN
                IF (NSM < NSYMP) THEN
                  DO I = 1, 3
                    DO J = I, 3
                      IS(I, J, NSM) = IS(I, J, NSYMP)
                    END DO
                  END DO
                END IF
                NSYMP = NSYMP - 1
              END IF
            ELSE
              EXIT
            END IF
          END DO
        END IF
      ENDIF
      RETURN
99999 FORMAT (':: Attempt to generate more than 48 ''non-LATT'' ',
     1        'operations', /, '   ** Please check symmetry operations'
     2        , /, '   ** No additional operations accepted!')
99998 FORMAT (':: Problem in SG07 - ERR = 12')
      END SUBROUTINE SG07
 
      SUBROUTINE SG08 (NSP)
      USE cspgr
      IMPLICIT NONE
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: NSM
      INTEGER          :: NSP
      INTEGER          :: IDV
      INTEGER          :: IDT
      INTEGER          :: ISN
      INTEGER          :: IDT0
      INTEGER          :: IDIF
      CHARACTER(len=1) :: JBRV
      CHARACTER(len=1) :: JCNT
C * CHECK WHETHER THIS IS A NEW SYMMETRY OPERATION
 
      JBRV = SGSMC(13:13)
      JCNT = SGSMC(14:14)
      CALL GEN038 (SGSMC, 1, 11)
      DO NSM = 1, NSYMP
        L = NSM
        DO M = 1, 3, 2
          ISN  = 2 - M
          IDIF = 0
          IDT  = 0
          IDT0 = 0
          DO K = 1, 3
            IDIF = IDIF + IABS (IS(1, K, L) - ISN * IR(1, K, 195))
     1                  + IABS (IS(2, K, L) - ISN * IR(2, K, 195))
            IDV  = MOD (IS(3, K, L) - ISN * IR(3, K, 195), 12)
            IF (IDV < 0) IDV = IDV + 12
C * NOTE R-LATTICE CENTERING (4 = 1/3, 8 = 2/3)
            IF (IDV == 4 .OR. IDV == 8) THEN
              IDT = IDT + IDV * 10**(3 - K)
C * NOTE A, B, C, F, I LATTICE (6 = 1/2)
            ELSE IF (IDV == 6) THEN
              IDT = IDT + 2**(3 - K)
            END IF
            IDT0 = IDT0 + IDV
          END DO
          IF (IDIF == 0) THEN
            IF (IDT0 == 0) THEN
              NSP = 0
              IF (ISN < 0) THEN
                IF (JCNT == 'A') THEN
                  SGSMC(14:14) = 'C'
                  NSP = 8
                END IF
              END IF
              RETURN
            ELSE IF (IDT == 3) THEN
              IF (JBRV == 'A' .OR. JBRV == 'F') THEN
                NSP = 0
                IF (ISN < 0) THEN
                  SGSMC(14:14) = 'C'
                  NSP = 8
                END IF
                RETURN
              ELSE IF (ISN > 0) THEN
                NSP = 0
                IF (JBRV == 'P') THEN
                  SGSMC(13:13) = 'A'
                  NSP = 2
                ELSE IF (JBRV /= 'F') THEN
                  SGSMC(13:13) = 'F'
                  NSP = 5
                END IF
                RETURN
              END IF
            ELSE  IF (IDT == 5) THEN
              IF (JBRV == 'B' .OR. JBRV == 'F') THEN
                NSP = 0
                IF (ISN < 0) THEN
                  SGSMC(14:14) = 'C'
                  NSP = 8
                END IF
                RETURN
              ELSE IF (ISN > 0) THEN
                NSP = 0
                IF (JBRV == 'P') THEN
                  SGSMC(13:13) = 'B'
                  NSP = 3
                ELSE IF (JBRV /= 'F') THEN
                  SGSMC(13:13) = 'F'
                  NSP = 5
                END IF
                RETURN
              END IF
            ELSE IF (IDT == 6) THEN
              IF (JBRV == 'C' .OR. JBRV == 'F') THEN
                NSP = 0
                IF (ISN < 0) THEN
                  SGSMC(14:14) = 'C'
                  NSP = 8
                END IF
                RETURN
              ELSE IF (ISN > 0) THEN
                NSP = 0
                IF (JBRV == 'P') THEN
                  SGSMC(13:13) = 'C'
                  NSP = 4
                ELSE IF (JBRV /= 'F') THEN
                  SGSMC(13:13) = 'F'
                  NSP = 5
                END IF
                RETURN
              ELSE IF (ISN < 0) THEN
                IF (JBRV == 'P' .AND. JCNT == 'C') THEN
                  SGSMC(13:13) = 'C'
                  NSP  = 4
                  RETURN
                ENDIF
              END IF
            ELSE IF (IDT == 7) THEN
              IF (JBRV == 'I') THEN
                NSP = 0
                IF (ISN < 1) THEN
                  SGSMC(14:14) = 'C'
                  NSP = 8
                END IF
                RETURN
              ELSE IF (ISN > 0) THEN
                NSP = 0
                IF (JBRV /= 'I') THEN
                  SGSMC(13:13) = 'I'
                  NSP = 6
                END IF
                RETURN
              END IF
C * TEST FOR R-Obverse
            ELSE IF (IDT == 488 .OR. IDT == 844) THEN
              IF (JBRV == 'R') THEN
                NSP = 0
                IF (ISN < 0) THEN
                  SGSMC(14:14) = 'C'
                  NSP = 8
                END IF
                RETURN
              ELSE IF (ISN > 0) THEN
                NSP  = 0
                IF (JBRV /= 'R') THEN
                  SGSMC(13:13) = 'R'
                  NSP = 7
                END IF
                RETURN
              END IF
C * TEST FOR R-Reverse
            ELSE IF (IDT == 848 .OR. IDT == 484) THEN
              IF (IUIT /= 0) WRITE (IUIT, 99999, IOSTAT = IOST)
              IER = 14
              RETURN
            END IF
          END IF
        END DO
      END DO
      RETURN
99999 FORMAT (':: (Transformation to) Obverse Setting Not Allowed.')
      END SUBROUTINE SG08
 
      SUBROUTINE SG09 (X, NSM)
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: N
      INTEGER            :: NSL
      INTEGER            :: ISJ
      INTEGER            :: NSM
      INTEGER            :: ISKP
      INTEGER            :: NSTOT
      REAL               :: X10
      REAL               :: XISJ
      REAL, DIMENSION(*) :: X
      IF (ILAUE < 0 .AND. ICNTR == 1) THEN
        NSTOT = NST * 2
        JSWD  = 0
        ISKP  = 0
      ELSE
        NSTOT = NST
        ISKP  = 1
      END IF
      IF (ISWD /= JSWD) THEN
C * LOAD APPROPRIATE MATRICES IN IR
        DO N = 1, NSTOT
          NSL = N
C * FILL IR(I, J, N) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
          CALL SG05 (NSL, NSL, 91)
          IF (IER /= 0) RETURN
        END DO
        JSWD = ISWD * ISKP
      END IF
      N = IABS(NSM)
      DO J = 1, 3
        IF (NSM > 0) THEN
C * TEST FOR HKL TRANSFORMATION
          IF (ISWD < 0) THEN
            X(J + 6) = 0.0
C * CALCULATE PHASE OF TRANSFORMED REFLECTION
            IF (J == 1) X(10) = X(4) / 360.0
            X(10) = X(10) - IR(3, J, N) * X(J) / 12.0
C * COORDINATE TRANSFORMATION
          ELSE
            X(J + 6) = IR(3, J, N) / 12.0 + X(J + 3)
          END IF
        ELSE
          X(J + 6) = 0.0
        END IF
        DO I = 1, 2
          IF (N > 0 .AND. N < 196) THEN
            ISJ = IR(I, J, N)
          ELSE
            ISJ = 0
          END IF
          IF (ISJ /= 0) THEN
            XISJ = X(IABS (ISJ))
            IF (ISJ < 0 .AND. NSM >= 0) XISJ = - XISJ
            X(J + 6) = X(J + 6) + XISJ
          END IF
        END DO
      END DO
C * TEST FOR HKL TRANSFORMATION
      IF (ISWD < 0) THEN
        X10 = MOD(X(10), 1.0)
        IF (X10 > 0.5) THEN
          X10 = X10 - 1.0
        ELSE IF (X10 <= -0.5) THEN
          X10 = X10 + 1.0
        END IF
        X(10) = X10 * 360.0
      END IF
      RETURN
      END SUBROUTINE SG09
 
      SUBROUTINE SG10 (X)
C * GET SYMMOP NR + UNITCELL TRANSLATIONS FOR GIVEN OPERATOR
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: NSL
      INTEGER            :: IDIF
      REAL, DIMENSION(*) :: X
      NSL = NST
C * FILL IR(I, J, 195) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
   10 CALL SG05 (195, NSL, 101)
      IF (IER == 0) THEN
        K = 0
        DO I = 1, 3
          DO J = 1, 3
            K = K + 1
            IDIF = IFIX (X(K)) - IR(I, J, 195)
            IF (I == 3) THEN
              X(9 + J) = FLOAT (IDIF / 12)
              IDIF     = MOD (IDIF, 12)
            END IF
            IF (IDIF /= 0) THEN
              NSL = NSL - 1
              IF (NSL > 0) THEN
                GO TO 10
              ELSE
                X(9) = NSL
                RETURN
              END IF
            END IF
          END DO
        END DO
        X(9) = NSL
      END IF
      RETURN
      END SUBROUTINE SG10
 
      SUBROUTINE SG11 (X)
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: N
      INTEGER            :: NSL
      INTEGER            :: ISJ
      INTEGER            :: ISS
      INTEGER            :: ITS
      REAL, DIMENSION(*) :: X
      IF (ISW == 9) X(5) = NST
      N   = 193
      NSL = NINT(X(1))
C * FILL IR(I, J, N) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
      CALL SG05 (N, NSL, 111)
      IF (IER == 0) THEN
        DO K = 1, 3
          IR(3, K, 193) = IR(3, K, 193) + NINT(X(K + 1)) * 12
        END DO
C * LOAD SECOND SYMMETRY OPERATION FROM (X(5) .... X(8))
        N   = 194
   10   NSL = NINT(X(5))
        IF (NSL == 0) THEN
          IF (IUIT /= 0)
     1      WRITE (IUIT, 99998, IOSTAT = IOST)
          IER = 1
          RETURN
        END IF
C * FILL IR(I, J, N) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
        CALL SG05 (N, NSL, 112)
        IF (IER == 0) THEN
          IF (ISW /= 9) THEN
            DO K = 1, 3
              IR(3, K, 194) = IR(3, K, 194) + NINT (X(5 + K)) * 12
            END DO
          END IF
C * CALCULATE (R'/T')(R/T) = (R'R/R'T+T')
          CALL SG06
          IF (ISW == 9) THEN
            DO K = 1, 3
              IF (IR(1, K, 195) /= K) GO TO 20
              IF (IR(2, K, 195) /= 0) GO TO 20
              IF (MOD (IABS (IR(3, K, 195)), 12) /= 0) GO TO 20
              ITS = - IR(3, K, 194)
              DO I = 1, 2
                ISJ = IR(I, K, 194)
                IF (ISJ /= 0) THEN
                  ISS = IR(3, IABS (ISJ), 193)
                  IF (ISJ < 0) ISS = - ISS
                  ITS = ITS - ISS
                END IF
              END DO
              X(9 + K) = FLOAT (ITS / 12)
            END DO
            X(9) = X(5)
            RETURN
   20       X(5) = X(5) - 1
            IF (X(5) > 0) THEN
              GO TO 10
            ELSE
              IF (IUIT /= 0) WRITE (IUIT, 99999, IOSTAT = IOST)
              IER = 1
              RETURN
            END IF
          END IF
          K = 0
          DO I = 1, 3
            DO J = 1, 3
              K = K + 1
              X(K) = IR(I, J, 195)
            END DO
          END DO
C * GET SYMMOP NR + UNITCELL TRANSLATIONS FOR GIVEN OPERATOR
          CALL SG10 (X)
        END IF
      END IF
      RETURN
99999 FORMAT ('Error at Label 20 in routine SGSM/SG11')
99998 FORMAT ('Supplied Symmetry number = 0 (ERROR in SG11')
      END SUBROUTINE SG11
 
      SUBROUTINE SG12 (X, NSM)
C * FIND SPACE GROUP NAME WHEN VOID
      USE cspgr
      USE spgrdata
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: K
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: NSL
      INTEGER            :: IND
      INTEGER            :: NSM
      INTEGER            :: NSLB
      INTEGER            :: NSLX
      INTEGER            :: ICHS
      INTEGER            :: NRSM
      REAL               :: TRV
      REAL, DIMENSION(*) :: X
      K    = 0
      NSL  = 1
      NRSM = NSM
      ISWD = 3 - ISW
      IF (ICNTR == 1 .AND. ILAUE < 0) THEN
        NSTT = NST * 2
      ELSE
        NSTT = NST
      END IF
      IF (ISWD < 0) NSTT = NSTT / IBV
      IF (NRSM > NSTT) NRSM = MOD (NRSM, NSTT)
      IF (NRSM /= 0) THEN
        NSL  = NRSM
        NSTT = NRSM
      ELSE
        CALL SG24
      END IF
C * SELECT X,Y,Z (ISW = 2) or H,K,L (ISW = 4)  OUTPUT FORMAT
      IF (ISW == 4) THEN
        ICHS = 26
      ELSE
        ICHS = 11
      END IF
      NSLB = NSL
      DO NSLX = NSLB, NSTT
        NSL = NSLX
        N   = 195
C * FILL IR(I, J, N) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
        CALL SG05 (N, NSL, 121)
        IF (IER /= 0) RETURN
        CALL GEN038 (LINE, 1, 80)
C * BUILD SYMMETRY OPERATION RECORD
        DO I = 1, 3
          IND = 17 * I - 4 + ISHEL * 4
          IF (I < 3) LINE(IND + 2:IND + 2) = ','
          M = IR(2, I, N)
          IF (M /= 0) THEN
            LINE(IND:IND) = ICHR(IABS (M) + ICHS)
            IF (M < 0) THEN
              LINE(IND - 2:IND - 2) = '-'
            ELSE
              LINE(IND - 2:IND - 2) = '+'
            END IF
            IND = IND - 4
          END IF
          LINE(IND:IND) = ICHR(IABS (IR(1, I, N)) + ICHS)
          IF (IR(1, I, N) < 0) LINE(IND - 2:IND - 2) = '-'
          M = IR(3, I, N)
          IF (ITRL /= 0) M = M + ITRL * NINT (X(I + 3))
          IF (M /= 0) THEN
            IF (IR(1, I, N) > 0) LINE(IND - 2:IND - 2) = '+'
            IF (ISHEL == 0) THEN
              IF (M < 0) THEN
                M = - M
                IF (IND > 8) LINE(IND - 8 : IND - 6) = '- -'
              END IF
              IF (MOD (M, 12) == 0) THEN
                K = 12
              ELSE IF (MOD (M, 6) == 0) THEN
                K = 6
              ELSE IF (MOD (M, 4) == 0) THEN
                K = 4
              ELSE IF (MOD (M, 3) == 0) THEN
                K = 3
              ELSE IF (MOD (M, 2) == 0) THEN
                K = 2
              END IF
              IF (K /= 12) THEN
                LINE(IND - 6:IND - 4) = ICHR(M / K)//'/'//ICHR(12 / K)
              ELSE
                LINE(IND - 4:IND - 4) = ICHR(M / K)
                IF (IND > 8) LINE(IND - 8:IND - 8) = ' '
              END IF
            ELSE
              TRV = FLOAT (IR(3, I, N)) / 12.0
              WRITE (LINE(IND - 10:IND - 4), 99998, IOSTAT = IOST) TRV
            END IF
          END IF
        END DO
C * ELIMINATE BLANKS
        IF (ITRL /= 0) CALL GEN047 (LINE, 1, 50)
        IF (IUIT > 0) THEN
          IF (IUIT == 7) CALL PLA262 (1)
          IF (IUIT /= 0)
     1      WRITE (IUIT, 99999, IOSTAT = IOST) NSL, LINE(1:60)
        END IF
      END DO
      RETURN
99999 FORMAT (I4, 3X, A)
99998 FORMAT (F7.5)
      END SUBROUTINE SG12
 
      SUBROUTINE SG13 (LIN, X, NSM)
C * FIND NAME OF NON-STANDARD SPACEGROUP WHEN SGSMC(8:11) NON-BLANK
      USE cspgr
      USE spgrdata
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: NSM
      REAL, DIMENSION(*) :: X
      CHARACTER(len=*)   :: LIN
      CHARACTER(len=2)   :: XIMP
      CHARACTER(len=7)   :: LZSPG
      IF (SGSMC(8:8) /= ' ') THEN
        DO I = 2, 6
          IF (SGSMC(8:11) == NOSTP(I)) THEN
            ZSPG = NONST((NSLOC(ISGNR - 15) - 1) * 6 + I)
            CALL GEN047 (ZSPG, 1, 9)
            YSPG(1:9)    = '['//ZSPG(1:7)//']'
            SGSMC(13:13) = ZSPG(1:1)
            GO TO 10
          END IF
        END DO
      END IF
C * GET SPACE GROUP NAME IN PROPER UPPER/LOWER CASE FORMAT
   10 CALL GEN020 (-1, SGSMC, 2, 11)
      CALL GEN020 (-1, YSPG,  3, 8)
      IF (ISW /= 18) THEN
C * FIND SPACE GROUP NAME WHEN VOID
        CALL SG12 (X, NSM)
        LIN = LINE
      ELSE
        IF (LAUE == 14 .AND. SGSMC(1:1) /= 'R') LAUE = JLAUE
        X(1)  = FLOAT (ISGNR)
        X(2)  = FLOAT (IKLS)
        X(3)  = FLOAT (LAUE)
        X(4)  = FLOAT (NSYMP)
        X(5)  = FLOAT (ICNTR)
        X(6)  = FLOAT (IBV)
        X(9)  = FLOAT (NST)
        X(13) = FLOAT (IFLACK)
        X(14) = 0.0
        IF (IKLS == 2) THEN
          IF (SGSMC(60:60) == '1') THEN
            X(14) = 1.0
          ELSE IF (SGSMC(60:60) == '3') THEN
            X(14) = 3.0
          END IF
        END IF
C * BRAVAIS-LATTICE TYPE NUMBERS (7 = SPGR/8 = SHELX ORDER)
        DO I = 1, 7
          IF (SGSMC(13:13) == ICHR(29 + I)) X(7) = I
          IF (SGSMC(13:13) == ICHR(36 + I)) X(8) = I
        END DO
        IF (SGSMC(14:14) == 'A') X(8) = - X(8)
C * 1:7 SG-NAME, 8:11 NOST-TRANS, 12 SYSTEM, 13 LATTICE 14 A/C
C * 15:24 SG-NAME(WITH  EMBEDDED SPACES)
        IF (IMPROP > 0 .AND. ICNTR == 1) THEN
          XIMP = ' C'
        ELSE
          XIMP = '  '
        END IF
        LZSPG = ZSPG(1:7)
        CALL GEN020 (-1, LZSPG, 2, 7)
        IF (SGSMC(9:9) == ' ') THEN
          ZSPG = SGSMC(1:7)
        ELSE
          DO J = 1, NNH
            IF (LZSPG == NHL(1, J)(1:7)) THEN
              SGSMC(15:26) = NHL(2, J)(1:12)
              SGSMC(33:54) = NHL(3, J)
            END IF
          END DO
        END IF
        LIN =
     1 SGSMC(1:26)//XSYST(IKLS)//NLAUE(LAUE)//SGSMC(33:59)//XIMP//LZSPG
C * ORIGIN FIXATION  (X(10), X(11), X(12))
        DO J = 1, 3
          X(J + 9) = 0.0
          IF (ICNTR == 1) THEN
            DO I = 1, 3
              IF (IORG(I, J) /= 0) X(J + 9) = X(J + 9) + 2 ** (I - 1)
            END DO
          END IF
        END DO
      END IF
      RETURN
      END SUBROUTINE SG13
 
      SUBROUTINE SG14 (X, TRDET)
C * GET SYMMETRY OPERATORS FOR SUPPLIED SPACEGROUP NAME
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: JA
      INTEGER            :: KB
      INTEGER            :: KE
      INTEGER            :: IMD
      INTEGER            :: ISGN
      INTEGER            :: LOOP
      REAL               :: TRDET
      REAL, DIMENSION(*) :: X
      CHARACTER(len=1)   :: CH
      CHARACTER(len=3)   :: CH3
      CHARACTER(len=12)  :: XSPG
      CHARACTER(len=9)   :: NONSTJ
C * FIRST STANDARDIZE SPACE GROUP NAME (HANDLE SPECIAL CHARACTERS AND BLANCS)
      KB   = 1
      KE   = NRSPGR
      ISGN = 0
      LOOP = 0
      CH3  = '   '
C * BLANK SGSMC RECORD
      CALL GEN038 (SGSMC, 1, 59)
      DO WHILE (LOOP == 0)
        LOOP = 1
        DO I = 5, 80
          CH = LINE(I:I)
C * REMOVE () FROM P2(1)
C * REMOVE ~  FROM P2~1~  ETC.
C * REMOVE _  FROM P_21_21_21
          IF (CH == '(' .OR. CH == ')' .OR.
     1        CH == '_' .OR. CH == '~') THEN
            LINE(I:I) = ' '
C * LOOK FOR PROTECTING [] (ELIMINATE & NO-TRANS)
          ELSE IF (CH == '[' .OR. CH == ']') THEN
            LINE(I:I) = ' '
            ITRNS = 0
            NTRNS = 0
          END IF
        END DO
C * REMOVE BLANKS
        CALL GEN047 (LINE, 5, 80)
C * CHECK FOR AND STANDARDIZE ALTERNATIVE SPELLING AND FORMATS
        DO I = 1, NTRL
          J = INDEX (LINE, TRLT(1, I))
          IF (J /= 0) THEN
            LINE(J:) = TRLT(2, I)(1:7)
            EXIT
          END IF
        END DO
C * (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
        CALL SG03 (X, TRDET)
        IF (IER /= 0) THEN
          LRET = 3
          RETURN
        ELSE
C * SET ISBRV, NST, ICNTR
          CALL SG04
          IF (IER /= 0) THEN
            LRET = 3
            RETURN
          END IF
C * INTERPRET SPACE GROUP NAME LINE
          J   = 0
          K   = 0
          M   = 0
          IMD = 0
          CALL GEN038 (SGSMC, 1, 11)
C * DISTINGUISH SETTING TYPES
          I = INDEX (LINE, ':')
          IF (I /= 0) THEN
            CH3 = LINE(I:I+2)
            DO J = 1, 11
              IF (CH3 == CHLIST(J)) EXIT
              IF (J == 11) LINE(I:I) = '.'
            END DO
          END IF
          DO I = 5, 80
C * SKIP BLANKS AND CHANGE INTERPRET MODE ON . FROM
C * SPACE-GROUP NAME (IMD=0) TO AXIAL EXCHANGE (IMD > 0)
            IF (LINE(I:I) == '.') THEN
              IMD  = 1
              ISGN = 1
            ELSE
              IF (IMD == 0) THEN
                K = K + 1
                IF (K > 9) EXIT
                SGSMC(K:K) = LINE(I:I)
                IF (K == 1) THEN
                  SGSMC(13:13) = SGSMC(1:1)
                ELSE
                  IF (SGSMC(K:K) == 'R') SGSMC(13:13) = 'P'
                END IF
              ELSE
                M = M + 1
                IF (M > 4) EXIT
                SGSMC(M + 7:M + 7) = LINE(I:I)
                IF (LINE(I:I) == '-') ISGN = -1
                DO L = 1, 3
                  IF (LINE(I:I) == CHAR (ICHAR ('A') - 1 + L)) THEN
                    IABC(L + 3) = ISGN
                    JABC(L + 3) = IMD
                    IMD         = IMD + 1
                    ISGN        = 1
                  END IF
                END DO
                IF (IMD == 4) EXIT
              END IF
            END IF
          END DO
        END IF
C * SAVE INPUT SPACEGROUP NAME
        IF (IMD == 0) THEN
          ZSPG = SGSMC(1:9)
        ELSE
          ZSPG = SGSMC(1:7)
        END IF
        IF (ITRNS == 1) THEN
          CALL GEN038 (SGSMC,  1, 11)
          CALL GEN038 (SGSMC, 15, 32)
C * CHECK FOR REVERSE SETTING
          IF (NINT (TRDET) == 3) THEN
            IF (R1(1, 1) == -1.0 .AND. R1(1, 2) ==  1.0 .AND.
     1          R1(1, 3) ==  0.0 .AND. R1(2, 1) ==  0.0 .AND.
     2          R1(2, 2) == -1.0 .AND. R1(2, 3) ==  1.0 .AND.
     3          R1(3, 1) ==  1.0 .AND. R1(3, 2) ==  1.0 .AND.
     4          R1(3, 3) ==  1) THEN
              IER = 14
              WRITE (IUIT, 99998, IOSTAT = IOST)
              WRITE (6,    99998, IOSTAT = IOST)
              RETURN
            END IF
          END IF
C * APPLY TRANSFORMATION ON LATTICE TYPE
          CALL SG21 (TRDET)
        ELSE
          IF (SGSMC(1:1) == 'A') THEN
            SGSMC(13:13) = CHAR (ICHAR ('A') + JABC(4) - 1)
          ELSE IF (SGSMC(1:1) == 'B') THEN
            SGSMC(13:13) = CHAR (ICHAR ('A') + JABC(5) - 1)
          ELSE IF (SGSMC(1:1) == 'C') THEN
            SGSMC(13:13) = CHAR (ICHAR ('A') + JABC(6) - 1)
          END IF
        END IF
C * LOOP OVER SPACE GROUP RANGE IN ARRAY SGT TO FIND SPACE GROUP GENERATORS
        DO K = KB, KE
C * COPY SPACEGROUP NAME FROM SPACE GROUP TABLE (SGT)
            XSPG = SGT(K)(1:12)
C * ELIMINATE BLANKS
            CALL GEN047 (XSPG, 1, 12)
            IF (ZSPG(1:9) == XSPG(1:9)) THEN
              SGSMC(60:60) = SGT(K)(33:33)
              READ (SGT(K)(13:15), 99997) ISGNR
              IF (SGSMC(15:15) == ' ') THEN
                SGSMC(15:54) = SGT(K)(1:12)//SHFL(ISGNR)//SGT(K)(16:32)
              ELSE
                SGSMC(38:54) = SGT(K)(16:32)
              END IF
              IF (ISGNR > 0 .AND. ISGNR <= 230)
     1          WRITE (SGSMC(55:59), 99996, IOSTAT = IOST) NSGF(ISGNR)
C * GET ASSOCIATED HALL SYMBOL
              LINE = '    '//SGT(K)(16:32)
              IF (ITRNS == 1) THEN
                IKLS  = 8
                ISGNR = 0
              END IF
C * PARSE HALL-SYMBOL IN 'LINE'
              CALL SG01 (1)
              IF (IER /= 0) THEN
                LRET = 3
              ELSE
                  LRET = 2
              ENDIF
              RETURN
            END IF
        END DO
C * SPGR NOT FOUND: NOW LOOK IN NON-STANDARD ORTHORHOMBIC SETTING LIST
        YSPG(1:9) = '['//ZSPG(1:7)//']'
        DO J = 1, NSTD
          NONSTJ = NONST(J)
          CALL GEN047 (NONSTJ, 1, 9)
          IF (ZSPG(1:9) == NONSTJ) THEN
            SGSMC(15:24) = NONST(J)
C * GENERATE NEW INPUT LINE AND RECYCLE
            JA = ((J - 1) / 6) * 6
            WRITE (LINE, 99998, IOSTAT = IOST)
     1        NONST(JA + 1), NOSTP(J - JA)
            KB  = NANO + NMON + 1
            KE  = KB + NORT
            LOOP = 0
            EXIT
          END IF
        END DO
      END DO
C * NO SYMMETRY GENERATORS AVAILABLE
      IF (IUIT /= 0) WRITE (IUIT, 99999, IOSTAT = IOST) SGSMC(1:11)
C * (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
      CALL SG03 (X, TRDET)
C * SET ISBRV, NST, ICNTR
      CALL SG04
      IER  = 5
      NST  = 0
      LRET = 3
      RETURN
99999 FORMAT (//, ':: Space Group Symbol not Known ', //,
     1 ':: No GENERATORS for this non-standard Space Group ', A,
     2 ' available ...', //,
     3 ':: Please supply generators explicitly with LATT/SYMM',
     4 ' instructions.', /)
99998 FORMAT ('SPGR ', A, '.', A, 61X)
99997 FORMAT (I3)
99996 FORMAT (I5)
      END SUBROUTINE SG14
 
      SUBROUTINE SG15 (X, NSM)
C * LOAD ROTATION MATRIX FOR NSM IN X(1:9) AND TRANSLATION VECTOR IN X(10:12)
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: K
      INTEGER            :: NSL
      INTEGER            :: NSM
      INTEGER            :: IRIK
      INTEGER            :: ISIK
      REAL, DIMENSION(*) :: X
      NSL = NSM
C * FILL IR(I, J, 195) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
      CALL SG05 (195, NSL, 151)
      IF (IER == 0) THEN
        DO I = 1, 12
          IF (I > 9) THEN
            X(I) = IR(3, I - 9, 195) / 12.0
          ELSE
            X(I) = 0.0
          END IF
        END DO
        DO I = 1, 2
          DO K = 1, 3
            IRIK = IR(I, K, 195)
            IF (IRIK /= 0) THEN
              ISIK = 1
              IF (IRIK < 0) ISIK = -1
              X((K - 1) * 3 + IABS (IRIK)) = ISIK
            END IF
          END DO
        END DO
      END IF
      RETURN
      END SUBROUTINE SG15
 
      SUBROUTINE SG16 (LIN, X)
C * THIS FUNCTION DETERMINES THE SITE SYMMETRY FOR ANY ATOM INPUT.
C * SITES LOCATED ON MIRRORS OR AXES WITH EQUIVALENT POINTS ON <110> OR
C * <1-10> WILL BE PLACED ON <110> OR ON <1-10>.
C * (NOT IMPLEMENTED IN FULL YET)
      USE cspgr
      USE spgrdata
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: IRT
      INTEGER            :: NSM
      INTEGER            :: NSP
      INTEGER            :: NDIF
      INTEGER            :: ISYM
      REAL               :: TOL
      REAL               :: YUNK
      REAL               :: DIFF
      REAL, DIMENSION(*) :: X
      REAL, DIMENSION(3) :: YAV
      CHARACTER(len=*)   :: LIN
      ISWD = 1
      ISYM = 0
      IF (X(10) > 0.0) THEN
        TOL = X(10)
      ELSE
        TOL = 0.005
      END IF
      DO L = 1, 3
        X(L + 3) = 0.0
        X(L + 6) = 0.0
        YAV(L)   = X(L)
      END DO
      NSP  = 1
C * LOOP OVER ALL SYMMETRY OPERATIONS
      IF (NST > 1) THEN
        DO 10 L = 2, NST
          NSM = L
          CALL SG09 (X, NSM)
          IF (IER /= 0) GO TO 30
C * TEST FOR SPECIAL POSITION
          DO I = 1, 3
            NDIF = INT (100.0 + X(6 + I) - X(I)) - 100
            X(6 + I) = X(6 + I) - NDIF
            DIFF = X(6 + I) - X(I)
            IF (DIFF > 0.5) THEN
              DIFF = 1.0 - DIFF
              X(6 + I) = X(6 + I) - 1.0
            END IF
            IF (DIFF > TOL) GO TO 10
          END DO
          NSP = NSP + 1
          DO I = 1, 3
            YAV(I) = YAV(I) + X(6 + I)
          END DO
C * ENCODE ROTATION PART OF SYMMETRY OPERATION FOR COMPARISON WITH IOPR
          K   = 0
          IRT = 0
          DO I = 1, 2
            DO J = 1, 3
              IRT = IRT + IR(I, J, NSM) * 7**K
              K   = K + 1
            END DO
          END DO
          DO J = 1, NOPR
            IF (IRT == IOPR(J)) THEN
              ISYM = ISYM + 2**(J - 1)
              GO TO 10
            END IF
          END DO
   10   CONTINUE
      END IF
      DO I = 1, 3
        YUNK = MOD (100.0 + (YAV(I) / NSP), 1.0)
        X(6 + I) = YUNK - NINT (YUNK - X(I))
      END DO
      DO I = 1, NSITE
        IF (ISYM == KSITE(I)) GO TO 20
      END DO
      I     = 1
   20 X(12) = I
      X(11) = ISYM
      X(10) = 1.0 / NSP
C * EDIT
      IF (IKLS == 4) THEN
        IF (I == 3) THEN
          I = 12
        ELSE IF (I == 4) THEN
          I = 9
        ELSE IF (I == 5) THEN
          I = 15
        ELSE IF (I == 12) THEN
          I = 7
        END IF
      END IF
      LIN(1:5) = SITE(I)
   30 RETURN
      END SUBROUTINE SG16
 
      SUBROUTINE SG17 (X, TRDET)
C * (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
      USE cspgr
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: L
      REAL               :: TRDET
      REAL, DIMENSION(*) :: X
      CALL GEN038 (SGSMC, 1, 59)
      CALL SG03 (X, TRDET)
      IF (IER == 0) THEN
C * SET ISBRV, NST, ICNTR
        CALL SG04
        J = 0
        DO I = 5, 80
          IF (LINE(I:I) /= ' ' .AND. LINE(I:I) /= '-') THEN
C * SHELX STYLE LATT CARD
            DO L = 1, 7
              IF (LINE(I:I) == CHAR (ICHAR ('0') + L)) THEN
                SGSMC(13:13) = ICHR(36 + L)
                IF (LINE(I - 1:I - 1) /= '-') SGSMC(14:14) = 'C'
                GO TO 10
              END IF
            END DO
C * NON-SHELX STYLE LATT LINE
            J = J + 1
            SGSMC(J + 12:J + 12) = LINE(I:I)
          END IF
        END DO
C * TRANSFORM LATTICE TYPE
   10   IF (ITRNS /= 0) CALL SG21 (TRDET)
        CALL SG04
      END IF
      RETURN
      END SUBROUTINE SG17
 
      SUBROUTINE SG18 (MODE)
C * HANDLE SAVESYMM FILE
      USE cspgr
      IMPLICIT NONE
      INTEGER             :: I
      INTEGER             :: J
      INTEGER             :: NSM
      INTEGER             :: NRET
      INTEGER             :: MODE
      REAL                :: TRDETX
      REAL, DIMENSION(12) :: X
      CHARACTER(len=80)   :: LIN
      OPEN (LU80, FILE = 'SAVESYMM', STATUS = 'UNKNOWN')
      IF (MODE == 1) THEN
        DO I = 1, NST
          NSM = I
C * LOAD ROTATION MATRIX FOR NSM IN X(1:9) AND TRANSLATION VECTOR IN X(10:12)
          CALL SG15 (X, NSM)
          WRITE (LU80, 99999, IOSTAT = IOST) (X(J), J = 1, 12)
        END DO
        CLOSE (LU80)
      ELSE IF (MODE == -1) THEN
        NRET = 0
        CALL SG03 (X, TRDETX)
C * SET ISBRV, NST, ICNTR
        CALL SG04
        DO
          READ (LU80, 99999, IOSTAT = IOST) (X(J), J = 1, 12)
          IF (IOST /= 0) EXIT
          CALL SG19 (LIN, X, NSM, NRET)
        END DO
        CLOSE (LU80, STATUS = 'DELETE')
      END IF
      RETURN
99999 FORMAT (9F5.2, 3F10.5)
      END SUBROUTINE SG18
 
      SUBROUTINE SG19 (LIN, X, NSM, NRET)
C * INTERPRETE INPUT SYMMETRY INFO
      USE cspgr
      USE csgsx
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: JL
      INTEGER            :: JM
      INTEGER            :: IC
      INTEGER            :: INX
      INTEGER            :: ISN
      INTEGER            :: INM
      INTEGER            :: NSM
      INTEGER            :: NCOM
      INTEGER            :: NFLT
      INTEGER            :: KTRV
      INTEGER            :: KM11
      INTEGER            :: KABC
      INTEGER            :: ISNN
      INTEGER            :: ITRV
      INTEGER            :: IFLT
      INTEGER            :: IFRC
      INTEGER            :: NRET
      INTEGER            :: NSYMO
      INTEGER            :: ISKIP
      REAL               :: FLT
      REAL               :: FFLT
      REAL               :: XLNG
      REAL               :: FFLT0
      REAL               :: GEN130
      REAL, DIMENSION(*) :: X
      REAL, DIMENSION(3) :: XSAV
      CHARACTER(len=*)   :: LIN
      CHARACTER(len=2)   :: OLAT
      INX  = 0
      NRET = 0
      FLT  = 0.0
      ISNN = 0
      KTRV = 0
      DO
C * TEST FOR SYMM LINE
        IF (ISW == 11) THEN
          DO I = 4, 6
            IABC(I) = 1
            JABC(I) = I - 3
          END DO
          IF (NST == 1) THEN
C * (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
            CALL SG03 (X, TRDET)
            IF (IER /= 0) RETURN
          END IF
          JBG  = 5
          JEG  = 80
          JSWD = 0
C * R/T INFO
        ELSE IF (ISW == 15 .OR. ISW == 26) THEN
          DO I = 1, 3
            DO J = 1, 3
              R0(J, I) = X(I + (J - 1) * 3)
            END DO
            T0(I) = X(I + 9)
          END DO
          JBG = 1
          JEG = 20
C * CONVERT R/T TO SYMM-LINE
          CALL SG02 (JBG)
          IF (IER /= 0) RETURN
          DO I = 4, 6
            IABC(I) = 1
            JABC(I) = I - 3
          END DO
          JSWD = 0
        ELSE
C * GET AND ANALYSE GENERATORS FROM HALL SYMBOLS
          JBG = JBG + 20
          JEG = JBG + 19
          NIC = 3
          IF (JBG > 100 .OR. LINE(JBG:JBG) == ' ') THEN
            IF (LRET == 1) THEN
              ISGNR = NUMS
              SGSMC(15:54) = SGT(JSG)(1:12)//SHFL(NUMS)//SGT(JSG)(16:32)
              SGSMC(60:60) = SGT(JSG)(33:33)
              IF (NSLP > 1) SGSMC(8:11) = NOSTP(NSLP)
              JLAUE = 8
              M     = 0
              DO L = 1, 12
                IF (SGT(JSG)(L + 15:L + 15) == '"') JLAUE = 7
                IF (SGT(JSG)(L:L) /= ' ') THEN
                  M          = M + 1
                  SGSMC(M:M) = SGT(JSG)(L:L)
                END IF
              END DO
C * FIND NAME OF NON-STANDARD SPACEGROUP WHEN SGSMC(8:11) NON-BLANK
              CALL SG13 (LIN, X, NSM)
            ELSE IF (LRET == 2) THEN
              CALL SG04
            END IF
            RETURN
          END IF
        END IF
        NTRNS = ITRNS
   10   IC    = 0
        JL    = JBG - 1
        NCOM  = 0
C * IC INDICATES CURRENT SUBFIELD OF SYMM-LINE
   20   IF (IC > 0) THEN
C * HANDLE ROTATION PART
          KABC = JABC(IC + NIC)
          IF (INX == 2) THEN
            IR(2, KABC, 195) = 0
          ELSE IF (INX > 2) THEN
C * STANDARDIZE
            IF (IABS (IR(1, KABC, 195)) > IABS (IR(2, KABC, 195)))
     1        CALL GEN014 (IR(1, KABC, 195), IR(2, KABC, 195))
          END IF
C * HANDLE TRANSLATION PART
          FFLT0 = ISNN * FLT * 12.0
          FFLT  = MOD (FFLT0, 12.0)
          IF (FFLT < 0.0) FFLT = FFLT + 12.0
          IF (NSGET == 1) XSAV(IC) = FFLT0 - FFLT
          NFLT = NINT(FFLT)
C * CHECK WHETHER THIS IS AN ALLOWED RATIO
          IF (NFLT == 1  .OR. NFLT == 5 .OR. NFLT == 7 .OR.
     1        NFLT == 11 .OR. ABS (FFLT - NFLT) > 0.01) THEN
            IF (IUIT /= 0)
     1        WRITE (IUIT, 99999, IOSTAT = IOST) LINE(1:40)
            IER = 2
            RETURN
          END IF
          IR(3, JABC(IC + NIC), 195) = MOD (IABC(IC + NIC)
     1        * NFLT + 12, 12)
        END IF
        IC   =  IC + 1
        INX  =  1
        FLT  =  0.0
        ITRV = -1
        IFLT =  0
        IFRC =  0
        ISNN =  1
        ISN  =  1
C * LOOP OVER THE RANGE (JBG, JEG) TO INTERPRETE SYMMETRY INSTRUCTION
   30   IF (JL < JEG) THEN
          JL = JL + 1
C * LOOP OVER ALLOWED CHARACTERS (OTHERS ARE IGNORED)
C * 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, ., X, Y, Z,  , ,, +, -, /, [, ]
          DO K = 1, 21
            IF (LINE(JL:JL) == ICHR(K)) THEN
C * PROTECT FOR TRANSFORMATION WHEN IN [] - AND BLANK
              CALL GEN038 (LINE, JL, JL)
              IF (K == 20 .OR. K == 21) THEN
                ITRNS = 0
                NTRNS = 0
C * NUMERICAL
              ELSE IF (K < 10) THEN
                IF (IFLT == 0) THEN
                  IF (ITRV /= 0) THEN
                    IF (ITRV < 0) THEN
                      ITRV = K
                      KTRV = K
                      INM  = 1
                    ELSE
                      INM  = K
                    END IF
                    ISNN = ISN
                    IF (KTRV > K .AND. NSGET == 0)
     1                  ITRV = MOD (KTRV, K)
                    FLT  = FLOAT (ITRV) / FLOAT (INM)
                    IFRC = IFRC + 1
                    IF (IFRC > 2) THEN
                      IF (IUIT /= 0)
     1                  WRITE (IUIT, 99999, IOSTAT = IOST) LINE(1:40)
                      IER = 2
                    END IF
                  END IF
                ELSE
                  FLT  = FLT  + K * 10.0**IFLT
                  IFLT = IFLT - 1
                  ISNN = ISN
                END IF
C * DECIMAL POINT
              ELSE IF (K == 11) THEN
                IFLT = IFLT - 1
                ISNN = ISN
C * X,Y,Z
              ELSE IF (K > 11 .AND. K < 15) THEN
                KM11 = K - 11
                IR(INX, JABC(IC + NIC), 195) =
     1            IABC(IC + NIC) * ISN * JABC(KM11 + NIC)
     2            * IABC(KM11 + NIC)
                INX   = INX + 1
                ISN  = 1
C * COMMA, START OF NEW SUBFIELD
              ELSE IF (K == 16) THEN
                NCOM = NCOM + 1
                IF (NCOM < 3) GO TO 20
C * PLUS
              ELSE IF (K == 17) THEN
                ISN = 1
C * MINUS
              ELSE IF (K == 18) THEN
                ISN = - 1
              END IF
              GO TO 30
            END IF
          END DO
          IF (IUIT /= 0)
     1      WRITE (IUIT, 99999, IOSTAT = IOST) LINE(1:40)
          IER = 2
          RETURN
        ELSE IF (JL == JEG) THEN
          JL = JL + 1
          GO TO 20
        ELSE
C * CHECK FOR CORRECT SYNTAX
          IF (IC < 3 .OR. (IC == 3 .AND. INX < 2) .OR.
     1        NCOM /= 2) THEN
            IF (IUIT /= 0)
     1        WRITE (IUIT, 99999, IOSTAT = IOST) LINE(1:40)
            IER = 2
            RETURN
          END IF
C * HANDLE 'GET SYMMETRY NUMBER CASE (ISW = 22)
          IF (NSGET == 1) THEN
            DO J = 1, 3
              X(J)     = IR(1, J, 195)
              X(J + 3) = IR(2, J, 195)
              X(J + 6) = IR(3, J, 195) + XSAV(J)
            END DO
            ISW = 7
C * GET SYMMOP NR + UNITCELL TRANSLATIONS FOR GIVEN OPERATOR
            CALL SG10 (X)
            RETURN
          END IF
C * REDUCE FOR LATTICE CENTERING (IN SYMM OR R|T OPERATION)
          IF (ISW == 11 .OR. ISW == 15 .OR. ISW == 26) THEN
            N = IR(3, 1, 195) * 100 + IR(3, 2, 195) * 10 + IR(3, 3, 195)
            ISKIP = 0
            SELECT CASE (SGSMC(13:13))
              CASE ('P')
                ISKIP = 1
              CASE ('A')
                IF (N /= 66)  ISKIP = 1
              CASE ('B')
                IF (N /= 606) ISKIP = 1
              CASE ('C')
                IF (N /= 660) ISKIP = 1
              CASE ('I')
                IF (N /= 666) ISKIP = 1
              CASE ('F')
                IF (N /= 660 .AND. N /= 606 .AND. N /= 66)
     1            ISKIP = 1
              CASE ('R')
                IF (N /= 844 .AND. N /= 488) ISKIP = 1
            END SELECT
C * REDUCE
            IF (ISKIP == 0) THEN
              DO J = 1, 3
                IR(3, J, 195) = 0
              END DO
            END IF
          END IF
C * CONVERT SYMMETRY OPERATION INTO (R|t) MATRICES
          CALL GEN021 (R3, 0.0)
          DO I = 1, 3
            DO J = 1, 2
              N = IR(J, I, 195)
              IF (N /= 0) R3(I, IABS (N)) = SIGN (1.0, FLOAT (N))
            END DO
            T3(I) = FLOAT (IR(3, I, 195)) / 12.0
          END DO
C * TEST FOR SYMM, SPGR, SYMM-R/T, HALL
          IF (ISW == 11 .OR. ISW == 12 .OR. ISW == 15 .OR.
     1        ISW == 21 .OR. ISW == 26) THEN
            IMPROP = MIN (IMPROP, NINT (GEN130 (R3)))
            IF (IMPROP == -1) THEN
              IF (IFLACK /= 0) IFLACK = -1
            END IF
          END IF
          IF (NTRNS > 0) THEN
            NTRNS = 0
C * APPLY T(TRANSPOSE,INVERSE) R T(TRANSPOSE) TO OBTAIN R'
            DO I = 1, 3
              DO J = 1, 3
                R4(I, J) = R2(I, J)
              END DO
            END DO
            CALL GEN132 (R4, R3, R1, R0)
C * APPLY T(TRANSPOSE,INVERSE) t              TO OBTAIN t'
            CALL GEN002 (1, R4, T3, T0, XLNG)
C * APPLY ORIGIN SHIFT
            DO I = 1, 3
              T0(I) = T0(I) + OSFT(I)
              DO J = 1, 3
                T0(I) = T0(I) - R0(I, J) * OSFT(J)
              END DO
            END DO
            NIC = 0
            CALL GEN038 (SGSMC, 1, 1)
            CALL GEN038 (YSPG, 1, 9)
C * CONVERT (R0|T0) INTO SYMM LINE
            CALL SG02 (JBG)
            IF (IER /= 0) RETURN
            JSWD = 0
            GO TO 10
          END IF
C * CHECK FOR PRE-OCCURRENCE OF THIS OPERATOR
          IF (ISW /= 2 .AND. ISW /= 4 .AND. ISW /= 18) THEN
C * SAVE CURRENT SYMMETRY PARAMETERS
            NSYMO = NSYMP
            OLAT  = SGSMC(13:14)
C * CHECK WHETHER THIS IS A NEW SYMMETRY OPERATION
            CALL SG07
            IF (IER /= 0) RETURN
            IF (SGSMC(13:14) /= OLAT) THEN
              GO TO 60
            END IF
C * OVERFLOW (SHOULD BE A REAL ERROR)
            IF (NSYMP >= 48) THEN
              CALL SG04
              RETURN
            END IF
C * EXPAND GENERATOR SET TO FULL SYMMETRY SET
            IF (NSYMP > 1) THEN
              K = 1
              DO WHILE (K < NSYMP)
                K  = K + 1
                I  = K
                JM = 2 * K - 2
C * FILL IR(I, J, 194) WITH IS(K, L, I) (TRANSPOSED FOR HKL)
                CALL SG05 (194, I, 191)
                IF (IER /= 0) RETURN
                DO L = 2, JM
                  J = L
                  IF (L > K) THEN
                    J = K
                    I = 2 * K - L
C * FILL IR(I, J, 194) WITH IS(K, L, I) (TRANSPOSED FOR HKL)
                    CALL SG05 (194, I, 192)
                    IF (IER /= 0) RETURN
                  END IF
C * FILL IR(I, J, 193) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
                  CALL SG05 (193, J, 193)
                  IF (IER /= 0) RETURN
C * MULTIPLY SYMMETRY OPERATIONS
                  CALL SG06
C * CHECK WHETHER THIS IS A NEW SYMMETRY OPERATION
                  CALL SG07
                  IF (IER /= 0) RETURN
                  IF (SGSMC(13:14) /= OLAT) THEN
                    NSYMP = NSYMO
                    GO TO 60
                  END IF
                  IF (NSYMP >= 48) THEN
                    CALL SG04
                    RETURN
                  END IF
                END DO
              END DO
            END IF
          ELSE
            DO 50 I = 1, NST
              DO J = 1, 3
                DO K = 1, 3
                  IF (IR(J, K, I) /= IR(J, K, 195)) GO TO 50
                END DO
              END DO
C * NEW SYMMETRY OPERATION FOUND
              GO TO 60
   50       CONTINUE
            NRET = 1
            RETURN
          END IF
        END IF
   60   IF (ISW == 11 .OR. ISW == 15 .OR. ISW == 26) THEN
          CALL SG04
          RETURN
        END IF
      END DO
      RETURN
99999 FORMAT (/, ':: Error in SYMM line syntax !!, ',
     1        /, ':: Line ignored: ', A, /)
      END SUBROUTINE SG19
 
      SUBROUTINE SG20 (NGO, X, NSM, LIN)
C * TEST FOR SYMM RECORD
      USE cspgr
      USE csgsx
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: N
      INTEGER            :: NSM
      INTEGER            :: NGO
      INTEGER            :: IMD
      INTEGER            :: NSL
      INTEGER            :: NRET
      INTEGER            :: ISGC
      INTEGER            :: ISGN
      REAL, DIMENSION(*) :: X
      CHARACTER(len=*)   :: LIN
      CHARACTER(len=1)   :: BLAT
      CHARACTER(len=1)   :: IBRAV
      CHARACTER(len=1)   :: XCHAR
      IF (ABS(NGO) == 1) THEN
        IF (NGO == -1) THEN
          CALL SG19 (LIN, X, NSM, NRET)
          IF (NRET == 0) RETURN
        END IF
        GO TO 20
      ELSE
        ISWD  = 1
        JSWD  = 1
        NTRNS = 0
C * LOAD APPROPRIATE MATRICES IN IR
        DO I = 1, NST
          NSL = I
C * FILL IR(I, J, NSL) WITH IS(K, L, J) (TRANSPOSED FOR HKL)
          CALL SG05 (NSL, NSL, 201)
          IF (IER /= 0) RETURN
        END DO
      END IF
C * LOOP OVER CANDIDATE SPACE GROUPS (BETWEEN JSMI AND JSMX)
      JSG = JSMX + 1
   10 JSG = JSG  - 1
      IF (JSG < JSMI) THEN
C * FIND NAME OF NON-STANDARD SPACEGROUP WHEN SGSMC(8:11) NON-BLANK
        CALL SG13 (LIN, X, NSM)
        RETURN
      END IF
C * AVOID NON-STANDARD SETTING MARKED X
      IF (SGT(JSG)(33:33) == 'X') GOTO 10
      IF (ISTO == 1 .AND. SGT(JSG)(33:33) == ' ') GO TO 10
      NSLP = 0
      NIC  = 3
      BLAT = SGT(JSG)(1:1)
C * TEST FOR CENTRO/NONCENTRO SIMILARITY (E.G. FOR PNNN:1)
      N = INDEX (SGT(JSG)(16:32), '-1')
      IF (N > 0) THEN
        IF (SGT(JSG)(15 + N:N + 17) == '-1)') N = 0
      END IF
      IF (SGT(JSG)(16:16) == '-' .OR. N /= 0) THEN
        ISGC = 2
      ELSE
        ISGC = 1
      END IF
      IF (ISGC /= ICNTRX) GO TO 10
      IBRAV = SGSMC(13:13)
C * NONSTANDARD SUB-LOOP (ORTHORHOMBIC: NSLPM = 6)
   20 NSLP = NSLP + 1
      IF (NSLP == 1) THEN
        NSLPM = 1
        N     = 0
        READ (SGT(JSG)(13:15), 99999) NUMS
C * CHECK FOR ORTHORHOMBIC CASES
        IF (NUMS > 15 .AND. NUMS < 75) THEN
          N = INDEX (SGT(JSG)(1:12), ':1')
          IF (N == 0) THEN
            IF (NSLOC(NUMS - 15) > 0) NSLPM = 6
          END IF
        END IF
C * TEST FOR BRAVAIS LATTICE SIMILARITY
C * SPECIAL RHOMBOHEDRAL SETTING CASE HANDLING
        IF (BLAT == 'R') THEN
          IF (INDEX (SGT(JSG)(2:12), 'R') /= 0) BLAT = 'P'
        END IF
      ELSE
        IF (NSLP > NSLPM) GO TO 10
        BLAT = NONST((NSLOC(NUMS - 15) - 1) * 6 + NSLP)(1:1)
      END IF
      SGSMC(13:13) = IBRAV
      IF (BLAT /= IBRAV) GO TO 20
      IMD  = 1
      ISGN = 1
      DO K = 1, 4
        XCHAR = NOSTP(NSLP)(K:K)
        IF (XCHAR == '-') THEN
          ISGN = -1
        ELSE
          DO L = 1, 3
            IF (XCHAR == CHAR (ICHAR ('A') - 1 + L)) THEN
              IABC(L + 3) = ISGN
              JABC(L + 3) = IMD
              IMD         = IMD + 1
              ISGN        = 1
            END IF
          END DO
        END IF
      END DO
      LINE = '    '//SGT(JSG)(16:32)
C * PARSE HALL-SYMBOL IN 'LINE'
      CALL SG01 (0)
      IF (IER == 0) THEN
        LRET = 1
        JBG  = -19
C * INTERPRETE INPUT SYMMETRY INFO
        CALL SG19 (LIN, X, NSM, NRET)
        IF (NRET == 1) GO TO 20
      END IF
      RETURN
99999 FORMAT (I3)
      END SUBROUTINE SG20
 
      SUBROUTINE SG21 (DET)
C * ENTRY POINT FOR SPGR & HALL - TRANSFORM LATTICE TYPE
      USE cspgr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: IDET
      INTEGER :: IBVP
      INTEGER :: IBVX
      REAL    :: DET
      K = 0
      DO N = 1, 7
        IF (SGSMC(13:13) == ICHR(N + 29)) THEN
          IDET = NINT (IBV0(N) * DET)
          IF (IDET == 4) THEN
            SGSMC(13:13) = 'F'
          ELSE IF (IDET == 3) THEN
            SGSMC(13:13) = 'R'
          ELSE IF (IDET == 2) THEN
            IBVX = 3
            IF (N > 1) THEN
              IBVP = IBV1(N) - 1
              DO J = 1, 3
                R2(J, 4) = 0.0
                DO K = 1, 3
                  R2(J, 4) = R2(J, 4) + R2(J, K) * IBV2(IBVP + K) / 12.0
                END DO
              END DO
              IBVX = 4
            END IF
            DO J = 1, IBVX
              K = 0
              DO I = 1, 3
                IF (ABS (0.5 - ABS (AMOD (R2(I, J), 1.0))) < 0.1)
     1            K = K + 2**(I - 1)
              END DO
              IF (K > 2 .AND. K /= 4) EXIT
            END DO
            IF (K == 6) THEN
              SGSMC(13:13) = 'A'
            ELSE IF (K == 5) THEN
              SGSMC(13:13) = 'B'
            ELSE IF (K == 3) THEN
              SGSMC(13:13) = 'C'
            ELSE IF (K == 7) THEN
              SGSMC(13:13) = 'I'
            END IF
          ELSE
            SGSMC(13:13) = 'P'
          END IF
          IF (SGSMC(14:14) == 'C') THEN
            DO I = 1, 3
              L = NINT (AMOD (ABS (2.0 * OSFT(I)), 1.0) * 12.0)
              IF (L /= 0 .AND. L /= 6) THEN
                IF (IUIT /= 0) WRITE (IUIT, 99998, IOSTAT = IOST)
                SGSMC(14:14) = 'A'
              END IF
            END DO
          END IF
          RETURN
        END IF
      END DO
      IF (IUIT /= 0) WRITE (IUIT, 99999, IOSTAT = IOST) SGSMC(13:13)
      RETURN
99999 FORMAT (':: Cannot Transform Lattice: ', A)
99998 FORMAT (':: Origin shift not compatible with inversion on 0,0,0')
      END SUBROUTINE SG21
 
 
      SUBROUTINE SG22
C * INITIALIZE
      USE cspgr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: L
      DO I = 1, 3
        IABC(I)     = 1
        IABC(I + 3) = 1
        JABC(I)     = I
        JABC(I + 3) = I
        DO J = 1, 3
          IF (I == 1) THEN
            L = J
          ELSE
            L = 0
          END IF
          IS (I, J, 1) = L
          IF (I == J) THEN
            L = I
          ELSE
            L = 0
          END IF
          IORG(I, J) = L
        END DO
      END DO
C * BLANK
      CALL GEN038 (YSPG,  1, 9)
      CALL GEN038 (ZSPG,  1, 13)
      CALL GEN038 (SGSMC, 1, 47)
      SGSMC(13:14) = 'PA'
      JSWD         = 0
      IKLS         = 8
      IAXM         = 0
      NSYMP        = 1
      ISGNR        = 0
      IMPROP       = 1
      IFLACK       = 1
      RETURN
      END SUBROUTINE SG22
 
      SUBROUTINE SG23 (XX)
C * CHECK WHETHER H K L IS ABSENT
      USE cspgr
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      INTEGER :: L
      INTEGER :: N
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IZ
      INTEGER :: NH
      INTEGER :: NK
      INTEGER :: NL
      INTEGER :: MC
      INTEGER :: MODE
      REAL    :: X
      REAL    :: Y
      REAL    :: Z
      REAL, DIMENSION(12) :: XX
C * MODE = -1 - Check for Lattice Absences
C *      =  1 - Check for Non-Lattice Absences
C *      =  0 - Check both
      MODE   = NINT (XX(12))
      XX(12) = 0.0
      N      = NSYMP * ICNTR / ICNTRX
C * CHECK FOR/LOAD SYMMETRY DATA
      IF (IABSENT == 0) THEN
        IABSENT = 1
C * LOAD NON-LATTICE OR INVERSION SYMMETRY OPERATIONS
        K = -11
        DO I = 1, N
          K = K + 12
          CALL SG15 (A(K), I)
          IF (I > 1) THEN
            DO J = 1, 3
              A(K + J + 8)  = A(K + J + 8) - 2.0 * OCNT(J)
            END DO
          END IF
        END DO
C * LOAD BRAVAIS LATTICE VECTORS FOR A,B,C,F,I,R
        IF (IBV > 1) THEN
          DO I = 2, 7
            IF (SGSMC(13:13) == ICHR(I + 29)) THEN
              K = IBV1(I) - 1
              L = (IBV0(I) - 1) * 3
              DO J = 1, L
                B(3 + J) = REAL (IBV2(K + J)) / 12.0
              END DO
            END IF
          END DO
        END IF
      END IF
C * check h, k, l
      X  = XX(1)
      Y  = XX(2)
      Z  = XX(3)
      NH = NINT (X)
      NK = NINT (Y)
      NL = NINT (Z)
C * Reject lattice absences
      IF (MODE <= 0) THEN
        I = 0
        DO J = 2, IBV
          I = I + 3
          IF (ABS (AMOD (X * B(I + 1) + Y * B(I + 2) +
     1      Z * B(I + 3) + 999.5, 1.0) -0.5) > 0.01) THEN
            XX(12) = 2.0
            RETURN
          END IF
        END DO
      END IF
C * Reject Non-Lattice systematic absences
      IF (MODE >= 0) THEN
C * Maximize indices
        IF (ICNTRX == 2) THEN
          I = NL
          IF (I == 0) I = NK
          IF (I == 0) I = NH
          IF (I <= 0) THEN
            NH = - NH
            NK = - NK
            NL = - NL
          END IF
        END IF
        K = -12
        DO J = 1, N
          K = K + 12
          IX = NINT (X * A(K + 1) + Y * A(K + 4) + Z * A(K + 7))
          IY = NINT (X * A(K + 2) + Y * A(K + 5) + Z * A(K + 8))
          IZ = NINT (X * A(K + 3) + Y * A(K + 6) + Z * A(K + 9))
          IF (ICNTRX == 2) THEN
            I = IZ
            IF (I == 0) I = IY
            IF (I == 0) I = IX
            IF (I <= 0) THEN
              IX = -IX
              IY = -IY
              IZ = -IZ
            END IF
          END IF
          IF (NL >  IZ) CYCLE
          IF (NL >= IZ) THEN
            IF (NK >  IY) CYCLE
            IF (NK >= IY) THEN
              IF (NH >= IX) CYCLE
            END IF
          END IF
          NH = IX
          NK = IY
          NL = IZ
        END DO
        X = REAL (NH)
        Y = REAL (NK)
        Z = REAL (NL)
C * find systematic absences
        MC = NL
        IF (MC == 0) MC = NK
        IF (MC == 0) MC = NH
        K = -12
        DO J = 1, N
          K = K + 12
          IX = NINT (X * A(K + 1) + Y * A(K + 4) + Z * A(K + 7))
          IY = NINT (X * A(K + 2) + Y * A(K + 5) + Z * A(K + 8))
          IZ = NINT (X * A(K + 3) + Y * A(K + 6) + Z * A(K + 9))
          IF (ICNTRX == 2) THEN
            I = IZ
            IF (I == 0) I = IY
            IF (I == 0) I = IX
            IF (I * MC <= 0) THEN
              IX = - IX
              IY = - IY
              IZ = - IZ
            END IF
          END IF
          IF (IABS (IX - NH) + IABS (IY - NK) + IABS (IZ - NL) == 0)
     1      THEN
            IF (ABS (AMOD (10.5 + ABS (X * A(K + 10) + Y * A(K + 11)
     1        + Z * A(K + 12)), 1.0) -0.5) >= 0.1) THEN
              XX(12) = 1.0
              RETURN
            END IF
          END IF
        END DO
      END IF
      RETURN
      END SUBROUTINE SG23
 
      SUBROUTINE SG24
C * LIST SPACEGROUP HEADER
      USE cspgr
      USE spgrdata
      IMPLICIT NONE
      INTEGER           :: J
      INTEGER           :: N
      INTEGER           :: JUNK
      CHARACTER(len=13) :: TXT
      CHARACTER(len=2)  :: ACENT
      CHARACTER(len=7)  :: LZSPG
      IF (ICNTRX == 2 .OR. ILAUE < 0) THEN
        ACENT = ' C'
      ELSE
        ACENT = 'Ac'
      END IF
      IF (LAUE == 14 .AND. SGSMC(1:1) /= 'R') LAUE = JLAUE
      IF (IUIT /= 0) THEN
        N = INDEX (SGSMC(1:11), ':')
        IF (N /= 0) THEN
          TXT = SGSMC(1:11)
        ELSE IF (SGSMC(8:8) /= ' ') THEN
          TXT = SGSMC(1:7)//':'//SGSMC(8:11)
          LZSPG = ZSPG(1:7)
          CALL GEN020 (-1, LZSPG, 2, 7)
          DO J = 1, NNH
            IF (LZSPG == NHL(1, J)(1:7)) THEN
              SGSMC(15:26) = NHL(2, J)(1:12)
              SGSMC(33:49) = NHL(3, J)
            END IF
          END DO
        ELSE
          IF (SGSMC(1:1) == 'R') THEN
            N = INDEX (SGSMC(2:7), 'r')
            IF (N > 0) THEN
              SGSMC(N + 1:N + 2) = ':R'
            ELSE
              N = INDEX (SGSMC(1:7), ' ')
              SGSMC(N:N+1) = ':H'
              N = INDEX (SGSMC(15:26), '  ')
              IF (N /= 0) SGSMC(15 + N:15 + N) = 'H'
            END IF
          END IF
          TXT = SGSMC(1:7)
        END IF
        JUNK = LAUE
        IF (LAUE == 14 .AND. JLAUE == 7) JUNK = 7
        WRITE (IUIT, 99999, IOSTAT = IOST) TXT, YSPG, NLAUE(JUNK),
     1    SGSMC(33:49), SGSMC(27:32), SGSMC(12:13), ACENT,
     2    XSYST(IKLS), NSTT, NSYMP, ISGNR
      END IF
      IF (IUIT == 7) CALL PLA262 (6)
      IF (ICNTR /= ICNTRX) THEN
        IF (IUIT /= 0)
     1    WRITE (IUIT, 99994, IOSTAT = IOST) OCNT(1), OCNT(2), OCNT(3)
        IF (IUIT == 7) CALL PLA262 (2)
      END IF
      IF (ILAUE > 0) THEN
        IF (ICNTRX == 1) THEN
          IF (IMPROP > 0) THEN
            IF (IUIT /= 0) WRITE (IUIT, 99995, IOSTAT = IOST)
     1        'Sohncke SpGr (Absolute Configuration)'
          ELSE IF (IMPROP == -1) THEN
            IF (IUIT /= 0) WRITE (IUIT, 99995, IOSTAT = IOST)
     1        'Non-Sohncke SpGr (Absolute Structure)'
          END IF
        ELSE
          IF (IUIT /= 0) WRITE (IUIT, 99996)
        END IF
        IF (IUIT == 7) CALL PLA262 (2)
        IF (IUIT /= 0) WRITE (IUIT, 99998, IOSTAT = IOST)
      ELSE
        IF (IUIT /= 0) WRITE (IUIT, 99997, IOSTAT = IOST)
      END IF
      RETURN
99999 FORMAT ('Space Group  H-M:  ', 2A, 21X, 'Laue:', A, /,
     1 'Space Group Hall: ', A, 16X, '[Schoenflies: ', A, ']', /,
     2 'Lattice Type: ', A, ', ', A, 'entric, ', A, ', Multiplicity: ',
     3 I3, '(', I2, '), No:', I4, /)
99998 FORMAT (2X, 'Nr', 12X, '***** Symmetry Operation(s) *****', /)
99997 FORMAT (2X, 'Nr', 7X, 'Patterson/Laue Symmetry Operation', /)
99996 FORMAT ('Non-Sohncke - No Absolute Structure', /)
99995 FORMAT (A, ' - P.G.Jones, Acta Cryst. (1986),A42,57.', /)
99994 FORMAT ('Shifted Inversion Centre at (', F6.3, ',', F6.3, ',',
     1        F6.3, ')', /)
      END SUBROUTINE SG24
 
      SUBROUTINE SG25
      USE cspgr
      IMPLICIT NONE
      SGTLOADED = .TRUE.
C * S = STANDARD SETTING; A = ALTERNATE SETTING, X = AVOID ALTERNATE FOR ADDSYM
C * TRICLINIC SPACE GROUPS
      SGT(1:NANO) = (/
     1 'P 1           1 P 1             S',
     2 'A 1           1 A 1              ',
     3 'B 1           1 B 1              ',
     4 'C 1           1 C 1              ',
     5 'I 1           1 I 1              ',
     6 'F 1           1 F 1              ',
     7 'R 1           1 R 1              ',
     8 'P -1:C        2 P -1c            ',
     9 'P -1          2-P 1             S',
     * 'A -1          2-A 1              ',
     1 'B -1          2-B 1              ',
     2 'C -1          2-C 1              ',
     3 'C -1:C        2 C -1c            ',
     4 'I -1          2-I 1              ',
     5 'F -1          2-F 1              ',
     6 'R -1          2-R 1              '/)
C * MONOCLINIC SPACE GROUPS
      SGT(NMONA:NMONB) = (/
     1 'P 2           3 P 2y            S',
     2 'B 2           3 B 2y             ',
     2 'P 1 1 2       3 P 2             3',
     3 'P 2 1 1       3 P 2x            1',
     4 'P 21          4 P 2yb           S',
     5 'B 21          4 B 2yb            ',
     5 'P 21:A        4 P 2yab           ',
     6 'P 21:C        4 P 2ybc           ',
     7 'P 21:N        4 P 2yn            ',
     8 'P 21:W        4 P 2ybw           ',
     8 'P 1 1 21      4 P 2c            3',
     9 'P 21 1 1      4 P 2xa           1',
     * 'P 1 1 21:A    4 P 2ac           3',
     1 'P 21 1 1:B    4 P 2xab          1',
     2 'C 2           5 C 2y            S',
     3 'C 2 1 1       5 C 2x            1',
     4 'I 2 1 1       5 I 2x            1',
     5 'C 21          5 C 2yb            ',
     6 'A 2           5 A 2y             ',
     7 'I 2           5 I 2y             ',
     8 'I 21          5 I 2yb            ',
     9 'F 2           5 F 2y             ',
     * 'A 1 1 2       5 A 2             3',
     1 'B 1 1 2       5 B 2             3',
     2 'I 1 1 2       5 I 2             3',
     3 'B 2 1 1       5 B 2x            1',
     4 'C 2 1 1       5 C 2x            1',
     5 'I 2 1 1       5 I 2x            1',
     6 'P M           6 P -2y           S',
     7 'P 1 1 M       6 P -2            3',
     8 'P M 1 1       6 P -2x           1',
     9 'P C           7 P -2yc          S',
     * 'P C S         7 P -2ybc          ',
     1 'P A           7 P -2ya          A',
     2 'P N           7 P -2yac         A',
     3 'P N S         7 P -2yabc         ',
     4 'P 1 1 A       7 P -2a           3',
     5 'P 1 1 B       7 P -2b           3',
     6 'P 1 1 N       7 P -2ab          3',
     7 'P B 1 1       7 P -2xb          1',
     8 'P N 1 1       7 P -2xbc         1',
     9 'P C 1 1       7 P -2xc          1',
     1 'C M           8 C -2y           S',
     2 'A M           8 A -2y            ',
     3 'I M           8 I -2y            ',
     4 'A 1 1 M       8 A -2            3',
     5 'B 1 1 M       8 B -2            3',
     6 'I 1 1 M       8 I -2            3',
     7 'B M 1 1       8 B -2x           1',
     8 'C M 1 1       8 C -2x           1',
     9 'I M 1 1       8 I -2x           1',
     * 'C C           9 C -2yc          S',
     1 'A N           9 A -2yac          ',
     2 'I A           9 I -2ya           ',
     3 'I C           9 I -2yc           ',
     4 'A A           9 A -2ya           ',
     5 'A 1 1 A       9 A -2a           3',
     6 'B 1 1 N       9 B -2bc          3',
     7 'I 1 1 B       9 I -2b           3',
     8 'B 1 1 B       9 B -2b           3',
     9 'A 1 1 N       9 A -2ac          3',
     * 'I 1 1 A       9 I -2a           3',
     1 'B B 1 1       9 B -2xb          1',
     2 'C N 1 1       9 C -2xbc         1',
     3 'I C 1 1       9 I -2xc          1',
     4 'C C 1 1       9 C -2xc          1',
     5 'B N 1 1       9 B -2xbc         1',
     6 'I B 1 1       9 I -2xb          1',
     7 'P 2/M        10-P 2y            S',
     8 'P 1 1 2/M    10-P 2             3',
     9 'P 2/M 1 1    10-P 2x            1',
     * 'P 21/M       11-P 2yb           S',
     1 'P 1 1 21/M   11-P 2c            3',
     2 'P 21/M 1 1   11-P 2xa           1',
     3 'C 2/M        12-C 2y            S',
     4 'A 2/M        12-A 2y             ',
     5 'I 2/M        12-I 2y             ',
     3 'I 2/N        12-I 2yac          X',
     6 'A 1 1 2/M    12-A 2             3',
     7 'B 1 1 2/M    12-B 2             3',
     8 'I 1 1 2/M    12-I 2             3',
     9 'I 1 1 2/B    12-I 2b            3',
     * 'I 1 1 2/A    12-I 2a            3',
     1 'B 2/M 1 1    12-B 2x            1',
     2 'C 2/M 1 1    12-C 2x            1',
     3 'I 2/M 1 1    12-I 2x            1',
     4 'P 2/C        13-P 2yc           S',
     5 'P 2/A        13-P 2ya           A',
     6 'P 2/N        13-P 2yac          A',
     7 'P 1 1 2/A    13-P 2a            3',
     8 'P 1 1 2/N    13-P 2ab           3',
     9 'P 1 1 2/B    13-P 2b            3',
     * 'P 2/B 1 1    13-P 2xb           1',
     1 'P 2/N 1 1    13-P 2xbc          1',
     2 'P 2/C 1 1    13-P 2xc           1',
     3 'P 21/C       14-P 2ybc          S',
     4 'P 21/C:C     14 P 2yb -1c        ',
     5 'P 21/A       14-P 2yab          A',
     6 'P 21/A:A     14 P 2yb -1a        ',
     7 'P 21/N       14-P 2yn           A',
     8 'P 21/N:N     14 P 2yb -1n        ',
     9 'P 1 1 21/A   14-P 2ac           3',
     * 'P 1 1 21/B   14-P 2bc           3',
     1 'P 1 1 21/N   14-P 2n            3',
     2 'P 21/N 1 1   14-P 2xn           1',
     3 'P 21/B 1 1   14-P 2xab          1',
     4 'P 21/C 1 1   14-P 2xac          1',
     5 'B 21/C       14-B 2ybc           ',
     6 'B 21/D       14-B 2ydav          ',
     7 'C 2/c:c      15 C 2y -1c         ',
     7 'C 2/C        15-C 2yc           S',
     8 'A 2/N        15-A 2yac           ',
     9 'I 2/A        15-I 2ya            ',
     * 'A 2/A        15-A 2ya            ',
     1 'C 2/N        15-C 2ybc          A',
     2 'I 2/C        15-I 2yc            ',
     4 'F 2/D:A      15-F 2yacuw         ',
     5 'F 2/D        15-F 2yauw          ',
     6 'A 1 1 2/A    15-A 2a            3',
     7 'B 1 1 2/N    15-B 2bc           3',
     8 'I 1 1 2/B    15-I 2b            3',
     9 'B 1 1 2/B    15-B 2b            3',
     * 'A 1 1 2/N    15-A 2ac           3',
     1 'I 1 1 2/A    15-I 2a            3',
     2 'B 2/B 1 1    15-B 2xb           1',
     3 'C 2/N 1 1    15-C 2xbc          1',
     4 'C 2/C 1 1    15-C 2xc           1',
     5 'I 2/C 1 1    15-I 2xc           1'/)
C * ORTHORHOMBIC SPACEGROUPS
      SGT(NORTA:NORTB) = (/
     1 'P 2 2 2      16 P 2 2           S',
     2 'P 2 2 21     17 P 2c 2          S',
     3 'P 21 21 2    18 P 2 2ab         S',
     4 'P 21 21 21:F 19 P 2c  2n         ',
     4 'P 21 21 21:E 19 P 2n  2a         ',
     4 'P 21 21 21:D 19 P 2n  2ac        ',
     4 'P 21 21 21:C 19 P 2c  2ab        ',
     4 'P 21 21 21:B 19 P 2bc 2a         ',
     4 'P 21 21 21:A 19 P 2ac 2n         ',
     5 'P 21 21 21   19 P 2ac 2ab       S',
     5 'C 2 2 21     20 C 2c 2          S',
     6 'C 2 2 2      21 C 2 2           S',
     7 'F 2 2 2      22 F 2 2           S',
     8 'I 2 2 2      23 I 2 2           S',
     9 'I 21 21 21   24 I 2b 2c         S',
     * 'P M M 2      25 P 2 -2          S',
     1 'P M C 21     26 P 2c -2         S',
     2 'P C C 2      27 P 2 -2c         S',
     3 'P M A 2      28 P 2 -2a         S',
     4 'P C A 21     29 P 2c -2ac       S',
     5 'P N C 2      30 P 2 -2bc        S',
     6 'P M N 21     31 P 2ac -2        S',
     7 'P B A 2      32 P 2 -2ab        S',
     8 'P N A 21     33 P 2c -2n        S',
     9 'P 21 C N:B   33 P -2n 2ab        ',
     9 'P N N 2      34 P 2 -2n         S',
     * 'C M M 2      35 C 2 -2          S',
     1 'C M C 21     36 C 2c -2         S',
     2 'C C C 2      37 C 2 -2c         S',
     3 'A M M 2      38 A 2 -2          S',
     4 'A B M 2      39 A 2 -2c         S',
     5 'A M A 2      40 A 2 -2a         S',
     6 'A B A 2      41 A 2 -2ac        S',
     7 'F M M 2      42 F 2 -2          S',
     8 'F D D 2      43 F 2 -2d         S',
     9 'I M M 2      44 I 2 -2          S',
     * 'I B A 2      45 I 2 -2c         S',
     1 'I M A 2      46 I 2 -2a         S',
     2 'P M M M      47-P 2 2           S',
     3 'P N N N:1    48 P 2 2 -1n        ',
     4 'P N N N      48-P 2ab 2bc       S',
     5 'P C C M      49-P 2 2c          S',
     6 'P B A N:1    50 P 2 2 -1ab       ',
     7 'P N C B:1    50 P 2 2 -1bc       ',
     8 'P C N A:1    50 P 2 2 -1ac       ',
     9 'P B A N      50-P 2ab 2b        S',
     * 'P M M A      51-P 2a 2a         S',
     1 'P N N A      52-P 2a 2bc        S',
     2 'P M N A      53-P 2ac 2         S',
     3 'P C C A      54-P 2a 2ac        S',
     4 'P B A M      55-P 2 2ab         S',
     5 'P C C N      56-P 2ab 2ac       S',
     6 'P B C M      57-P 2c 2b         S',
     7 'P N N M      58-P 2 2n          S',
     8 'P M M N:1    59 P 2 2ab -1ab     ',
     9 'P N M M:1    59 P 2bc 2 -1bc     ',
     * 'P M N M:1    59 P 2ac 2ac -1ac   ',
     1 'P M M N      59-P 2ab 2a        S',
     2 'P B C N      60-P 2n 2ab        S',
     3 'P B C A      61-P 2ac 2ab       S',
     4 'P N M A      62-P 2ac 2n        S',
     5 'C M C M      63-C 2c 2          S',
     6 'C M C A      64-C 2bc 2         S',
     7 'C M M M      65-C 2 2           S',
     8 'C C C M      66-C 2 2c          S',
     9 'C M M A      67-C 2b 2          S',
     * 'C C C A:1    68 C 2 2 -1bc       ',
     1 'C C C B:1    68 C 2 2 -1bc       ',
     2 'A B A A:1    68 A 2 2 -1ac       ',
     3 'A C A A:1    68 A 2 2 -1ac       ',
     4 'B B C B:1    68 B 2 2 -1bc       ',
     5 'B B A B:1    68 B 2 2 -1bc       ',
     6 'C C C A      68-C 2b 2bc        S',
     7 'F M M M      69-F 2 2           S',
     8 'F D D D:1    70 F 2 2 -1d        ',
     9 'F D D D      70-F 2uv 2vw       S',
     * 'I M M M      71-I 2 2           S',
     1 'I B A M      72-I 2 2c          S',
     2 'I B C A      73-I 2b 2c         S',
     3 'I M M A      74-I 2b 2          S'/)
C * LOW TETRAGONAL SPACEGROUPS
      SGT(NTETLA:NTETLB) = (/
     1 'P 4          75 P 4             S',
     2 'P 41         76 P 4w            S',
     3 'P 42         77 P 4c            S',
     4 'P 43         78 P 4cw           S',
     5 'I 4          79 I 4             S',
     6 'I 41         80 I 4bw           S',
     7 'P -4         81 P -4            S',
     8 'I -4         82 I -4            S',
     9 'P 4/M        83-P 4             S',
     * 'P 42/M       84-P 4c            S',
     1 'P 4/N:1      85 P 4ab -1ab       ',
     2 'P 4/N        85-P 4a            S',
     3 'P 42/N:3     86-P 4ac            ',
     4 'P 42/N:1     86 P 4n -1n         ',
     5 'P 42/N       86-P 4bc           S',
     6 'I 4/M        87-I 4             S',
     7 'I 41/A:3     88-I 4d             ',
     8 'I 41/A:1     88 I 4bw -1bw       ',
     9 'I 41/A       88-I 4ad           S'/)
C * HIGH TETRAGONAL SPACEGROUPS
      SGT(NTETHA:NTETHB) = (/
     1 'P 4 2 2      89 P 4 2           S',
     2 'P 4 21 2     90 P 4ab 2ab       S',
     3 'P 41 2 2     91 P 4w 2c         S',
     4 'P 41 21 2    92 P 4abw 2nw      S',
     5 'P 42 2 2     93 P 4c 2          S',
     6 'P 42 21 2    94 P 4n 2n         S',
     7 'P 43 2 2     95 P 4cw 2c        S',
     8 'P 43 21 2    96 P 4nw 2abw      S',
     9 'I 4 2 2      97 I 4 2           S',
     * 'I 41 2 2     98 I 4bw 2bw       S',
     1 'P 4 M M      99 P 4 -2          S',
     2 'P 4 B M     100 P 4 -2ab        S',
     3 'P 42 C M    101 P 4c -2c        S',
     4 'P 42 N M    102 P 4n -2n        S',
     5 'P 4 C C     103 P 4 -2c         S',
     6 'P 4 N C     104 P 4 -2n         S',
     7 'P 42 M C    105 P 4c -2         S',
     8 'P 42 B C    106 P 4c -2ab       S',
     9 'I 4 M M     107 I 4 -2          S',
     * 'I 4 C M     108 I 4 -2c         S',
     1 'I 41 M D    109 I 4bw -2        S',
     2 'I 41 C D    110 I 4bw -2c       S',
     3 'P -4 2 M    111 P -4 2          S',
     4 'P -4 2 C    112 P -4 2c         S',
     5 'P -4 21 M   113 P -4 2ab        S',
     6 'P -4 21 C   114 P -4 2n         S',
     7 'P -4 M 2    115 P -4 -2         S',
     8 'P -4 C 2    116 P -4 -2c        S',
     9 'P -4 B 2    117 P -4 -2ab       S',
     * 'P -4 N 2    118 P -4 -2n        S',
     1 'I -4 M 2    119 I -4 -2         S',
     2 'I -4 C 2    120 I -4 -2c        S',
     3 'I -4 2 M    121 I -4 2          S',
     4 'I -4 2 D    122 I -4 2bw        S',
     5 'P 4/M M M   123-P 4 2           S',
     6 'P 4/M C C   124-P 4 2c          S',
     7 'P 4/N B M:1 125 P 4 2 -1ab       ',
     8 'P 4/N B M   125-P 4a 2b         S',
     9 'P 4/N N C:1 126 P 4 2 -1n        ',
     * 'P 4/N N C   126-P 4a 2bc        S',
     1 'P 4/M B M   127-P 4 2ab         S',
     2 'P 4/M N C   128-P 4 2n          S',
     3 'P 4/N M M:1 129 P 4ab 2ab -1ab   ',
     4 'P 4/N M M   129-P 4a 2a         S',
     5 'P 4/N C C:1 130 P 4ab 2n -1ab    ',
     6 'P 4/N C C   130-P 4a 2ac        S',
     7 'P 42/M M C  131-P 4c 2          S',
     8 'P 42/M C M  132-P 4c 2c         S',
     9 'P 42/N B C:1133 P 4n 2c -1n      ',
     * 'P 42/N B C  133-P 4ac 2b        S',
     1 'P 42/N N M:1134 P 4n 2 -1n       ',
     2 'P 42/N N M  134-P 4ac 2bc       S',
     3 'P 42/M B C  135-P 4c 2ab        S',
     4 'P 42/M N M  136-P 4n 2n         S',
     5 'P 42/N M C:1137 P 4n 2n -1n      ',
     6 'P 42/N M C  137-P 4ac 2a        S',
     7 'P 42/N C M:1138 P 4n 2ab -1n     ',
     8 'P 42/N C M  138-P 4ac 2ac       S',
     9 'I 4/M M M   139-I 4 2           S',
     * 'I 4/M C M   140-I 4 2c          S',
     1 'I 41/A M D  141-I 4bd 2         S',
     2 'I 41/A M D:1141 I 4bw 2bw -1bw   ',
     3 'I 41/A C D  142-I 4bd 2c        S',
     4 'I 41/A C D:1142 I 4bw 2aw -1bw   ',
     5 'I 41/A C D:3142-I 4ad 2c         '/)
C * LOW TRIGONAL SPACE GROUPS
      SGT(NTRILA:NTRILB) = (/
     2 'P 3         143 P 3             S',
     3 'P 31        144 P 31            S',
     4 'P 32        145 P 32            S',
     5 'R 3         146 R 3             S',
     6 'R 3 R       146 P 3*             ',
     7 'P -3        147-P 3             S',
     8 'R -3        148-R 3             S',
     9 'R -3 R      148-P 3*             '/)
C * HIGH TRIGONAL SPACEGROUPS
      SGT(NTRIHA:NTRIHB) = (/
     1 'P 3 1 2     149 P 3 2           S',
     2 'P 3 2 1     150 P 3 2"          S',
     3 'P 31 1 2    151 P 31 2c (0 0 1) S',
     4 'P 31 2 1    152 P 31 2"         S',
     5 'P 32 1 2    153 P 32 2c (0 0 -1)S',
     6 'P 32 2 1    154 P 32 2"         S',
     7 'R 3 2       155 R 3 2"          S',
     8 'R 3 2 R     155 P 3* 2           ',
     9 'P 3 M 1     156 P 3 -2"         S',
     * 'P 3 1 M     157 P 3 -2          S',
     1 'P 3 C 1     158 P 3 -2"c        S',
     2 'P 3 1 C     159 P 3 -2c         S',
     3 'R 3 M       160 R 3 -2"         S',
     4 'R 3 M R     160 P 3* -2          ',
     5 'R 3 C       161 R 3 -2"c        S',
     6 'R 3 C R     161 P 3* -2n         ',
     7 'P -3 1 M    162-P 3 2           S',
     8 'P -3 1 C    163-P 3 2c          S',
     9 'P -3 M 1    164-P 3 2"          S',
     * 'P -3 C 1    165-P 3 2"c         S',
     1 'R -3 M      166-R 3 2"          S',
     2 'R -3 M R    166-P 3* 2           ',
     3 'R -3 C      167-R 3 2"c         S',
     4 'R -3 C R    167-P 3* 2n          '/)
C * LOW HEXAGONAL SPACEGROUPS
      SGT(NHEXLA:NHEXLB) = (/
     5 'P 6         168 P 6             S',
     6 'P 61        169 P 61            S',
     7 'P 65        170 P 65            S',
     8 'P 62        171 P 62            S',
     9 'P 64        172 P 64            S',
     1 'P 63        173 P 6c            S',
     2 'P -6        174 P -6            S',
     3 'P 6/M       175-P 6             S',
     4 'P 63/M      176-P 6c            S'/)
C * HIGH HEXAGONAL SPACE GROUPS
      SGT(NHEXHA:NHEXHB) = (/
     5 'P 6 2 2     177 P 6 2           S',
     6 'P 61 2 2    178 P 61 2 (0 0 -1) S',
     7 'P 65 2 2    179 P 65 2 ( 0 0 1) S',
     8 'P 62 2 2    180 P 62 2c (0 0 1) S',
     9 'P 64 2 2    181 P 64 2c (0 0 -1)S',
     * 'P 63 2 2    182 P 6c 2c         S',
     1 'P 6 M M     183 P 6 -2          S',
     2 'P 6 C C     184 P 6 -2c         S',
     3 'P 63 C M    185 P 6c -2         S',
     4 'P 63 M C    186 P 6c -2c        S',
     5 'P -6 M 2    187 P -6 2          S',
     6 'P -6 C 2    188 P -6c 2         S',
     7 'P -6 2 M    189 P -6 -2         S',
     8 'P -6 2 C    190 P -6c -2c       S',
     9 'P 6/M M M   191-P 6 2           S',
     1 'P 6/M C C   192-P 6 2c          S',
     2 'P 63/M C M  193-P 6c 2          S',
     3 'P 63/M M C  194-P 6c 2c         S'/)
C * LOW CUBIC SPACEGROUPS
      SGT(NCUBLA:NCUBLB) = (/
     1 'P 2 3       195 P 2 2 3         S',
     2 'F 2 3       196 F 2 2 3         S',
     3 'I 2 3       197 I 2 2 3         S',
     4 'P 21 3      198 P 2ac 2ab 3     S',
     5 'I 21 3      199 I 2b 2c 3       S',
     6 'P M -3      200-P 2 2 3         S',
     7 'P N -3:1    201 P 2 2 3 -1n      ',
     8 'P N -3      201-P 2ab 2bc 3     S',
     9 'F M -3      202-F 2 2 3         S',
     * 'F D -3:1    203 F 2 2 3 -1d     S',
     1 'F D -3      203-F 2uv 2vw 3     S',
     2 'I M -3      204-I 2 2 3         S',
     3 'P A -3      205-P 2ac 2ab 3     S',
     4 'P B -3      205-P 2bc 2ac 3     A',
     5 'I A -3      206-I 2b 2c 3       S'/)
C * HIGH CUBIC SPACEGROUPS
      SGT(NCUBHA:NRSPGR) = (/
     1 'P 4 3 2     207 P 4 2 3         S',
     2 'P 42 3 2    208 P 4n 2 3        S',
     3 'F 4 3 2     209 F 4 2 3         S',
     4 'F 41 3 2    210 F 4d 2 3        S',
     5 'I 4 3 2     211 I 4 2 3         S',
     6 'P 43 3 2    212 P 4acd 2ab 3    S',
     7 'P 41 3 2    213 P 4bd 2ab 3     S',
     8 'I 41 3 2    214 I 4bd 2c 3      S',
     9 'P -4 3 M    215 P -4 2 3        S',
     * 'F -4 3 M    216 F -4 2 3        S',
     1 'I -4 3 M    217 I -4 2 3        S',
     2 'P -4 3 N    218 P -4n 2 3       S',
     3 'F -4 3 C    219 F -4c 2 3       S',
     4 'I -4 3 D    220 I -4bd 2c 3     S',
     5 'P M -3 M    221-P 4 2 3         S',
     6 'P N -3 N:1  222 P 4 2 3 -1n      ',
     7 'P N -3 N    222-P 4a 2bc 3      S',
     8 'P M -3 N    223-P 4n 2 3        S',
     9 'P N -3 M:1  224 P 4n 2 3 -1n     ',
     * 'P N -3 M    224-P 4bc 2bc 3     S',
     1 'F M -3 M    225-F 4 2 3         S',
     2 'F M -3 C    226-F 4c 2 3        S',
     3 'F D -3 M:1  227 F 4d 2 3 -1d     ',
     4 'F D -3 M    227-F 4vw 2vw 3     S',
     5 'F D -3 C:1  228 F 4d 2 3 -1cd    ',
     6 'F D -3 C    228-F 4cvw 2vw 3    S',
     7 'I M -3 M    229-I 4 2 3         S',
     8 'I A -3 D    230-I 4bd 2c 3      S'/)
      RETURN
      END SUBROUTINE SG25
 
C * GENERAL ROUTINES (14-Jul-2024)
C * GEN001 - W = Z  * T * Z~  OR  W = Z~ * T * Z
C * GEN002 - MATVEC & NORM OR VECMAT
C * GEN003 - MINV
C * GEN004 - MPRD
C * GEN005 - TRANSPOSE MATRIX
C * GEN006 - VECTOR1 * MATRIX * VECTOR2
C * GEN007 - UNIP
C * GEN008 - VECTOR PRODUCT
C * GEN009 - VV
C * GEN010 - DETERMINANT
C * GEN011 - NORM
C * GEN012 - MATRIX INVERSION
C * GEN013 - RANDOM GEN
C * GEN014 - SWAP INTEGERS
C * GEN015 - Add/Subtract 3-vector B to/from 3-vector A
C * GEN016 - ANGLE BETWEEN TWO VECTORS
C * GEN017 - NORMALIZE VECTOR
C * GEN018 - SWAP REALS
C * GEN019 - AXES
C * GEN020 - UP/LO-CASE
C * GEN021 - ZINIT (INIT MATRIX ON REAL VALUE)
C * GEN022 - SORT(N1:N2)
C * GEN023 - EIGEN
C * GEN024 - EWEV
C * GEN025 - M(3, 3) <--> V(6)
C * GEN026 - METRIC TO CELL AND VISA VERSA
C * GEN027 - ANGLE BETWEEN VECTORS
C * GEN028 - FFT
C * GEN029 - EWEV1
C * GEN030 - EWEV2
C * GEN031 - EWEV3
C * GEN032 - EWEV4
C * GEN033 - SORT (INT,INT) ASCENDING
C * GEN034 - SORT REAL LARGE --> SMALL
C * GEN035 - SORT READ SMALL --> LARGE
C * GEN036 - SORT (REAL, INT)
C * GEN037 - SORT TABLE
C * GEN038 - BLANK LINE
C * GEN039 - STRIP HEADER/TRAILER BLANKS
C * GEN040 - NUMBER TO STRING
C * GEN041 - ROUND ROUTINE
C * GEN042 - GET NUMERICAL VALUE(S) FROM CHARACTER STRING
C * GEN043 - X,Y,Z ANGLE TO MATRIX
C * GEN044 - ORTHOGONALISATION
C * GEN045 - CALCULATE CELL-VOLUME FROM CELL-PARAMETERS
C * GEN046 - UNPACK HKL
C * GEN047 - ELIMINATE BLANKS
C * GEN048 - BIT MANIPULATION
C * GEN050 - TRANSFORM & ELIMINATE REFLECTIONS WITH NON-INTEGER INDICES
C * GEN051 - GENERATE RMAT FROM ROTX, ROTY, ROTZ
C * GEN052 - COPY MATRIX
C * GEN053 - SORT (HEAP)
C * GEN054 - JACOBI (DOUBLE PRECISION)
C * GEN055 - YLM - Spherical Harmonics
C * GEN056 - SINTHETA/LAMBDA
C * GEN057 - GAUSS-ELIMINATION METHOD FOR MATRIX INVERSION   A*X=D
C * GEN058 - NR-TO-ATOM LABEL
C * GEN059 - TMUL4
C * GEN060 - TRNSP4
C * GEN061 - TINV4
C * GEN062 - LUDCMP
C * GEN063 - LUBKSB
C * GEN064 - JACOBI (SINGLE PRECISION)
C * GEN065 - MODIFY AND PRINT PRINT-BUFFER
C * GEN066 - APPLY SYMMETRY CONSTRAINTS ON CELL DIMENSIONS
C * GEN067 - TRANSFORM CELL ESD'S
C * GEN068 - CALCULATE VOLUME SU
C * GEN069 - TRFORD
C * GEN070 - POLFIW
C * GEN071 - EVAPOL
C * GEN072 - FREEREAD
C * GEN073 - MOLSYM ROUTINE
C * GEN074 - SET ARRAY TO REAL VALUE
C * GEN075 - MOLSYM ROUTINE
C * GEN076 - MOLSYM ROUTINE
C * GEN077 - MOLSYM ROUTINE
C * GEN078 - MOLSYM ROUTINE
C * GEN079 - COPY MATRIX (INDEX 3)
C * GEN080 - COPY VECTOR
C * GEN081 - MOLSYM ROUTINE
C * GEN082 - MOLSYM ROUTINE
C * GEN083 - PLANE THROUGH THREE POINTS
C * GEN084 - DETERMINANT (,,)
C * GEN085 - COMPACT STRING
C * GEN086 - MOLSYM FUNCTION
C * GEN087 - MOLSYM SUBROUTINE
C * GEN088 - GROUP ORDER
C * GEN089 - ADOBE PS/
C * GEN090 - BITWISE LOGICAL AND
C * GEN091 - SORT IN ORDER OF X(*,ITEM)
C * GEN092 - TEST LATTICE TYPE
C * GEN093 - HYPOTHESES TEST
C * GEN094 - TEST LATTICE TYPE
C * GEN095 - CALCULATE (SIN(THETA) / LAMBDA)**2
C * GEN096 - MAP THE NINE ELEMENTS OF T INTO ROTX, ROTY, ROTZ, IDET
C * GEN097 - SET INTEGER ARRAY ON VALUE
C * GEN098 - SPLIT-UP ARU CODE IN COMPONENTS
C * GEN099 - FORM QUADRATIC FORM
C * GEN100 - TLS MATRIX
C * GEN101 - GENERATE INDEX COMBINATIONS IN +/- N RANGE
C * GEN102 - TRANSFORM KEYWORD TO ENTRYPOINT NUMBER IN ARRAY
C * GEN103 - COMPACT LINE TO ONE BLANK SEPARATOR
C * GEN104 - CHECK FOR TRIVIAL TRANSFORMATIONS
C * GEN105 - SEARCH FOR CHARACTER/NUMERAL
C * GEN106 - CONVERT PSI(H.FLACK) TO DIRECTION COSINES (SHELDRICK)
C * GEN107 - REDUCE VECTOR
C * GEN108 - REWIND/ENDFILE
C * GEN109 - SPHERICAL HARMONICS
C * GEN110 - CHOLESKI
C * GEN111 - MANIPULATE THE CHEMICAL FORMULA
C * GEN112 - CONVERT 3*3 MATRIX to 9 VECTOR AND REVERSE
C * GEN113 - COPY VECTOR WITH N ELEMENTS
C * GEN114 - GET MAIN AXES AND VALUES OF UIJ TENSOR
C * GEN115 - GAUSSIAN INTEGRATION COEFFICIENTS
C * GEN116 - (H)NP ROUTINE-1 - MAIN
C * GEN117 - (H)NP ROUTINE-2
C * GEN118 - (H)NP ROUTINE-3
C * GEN119 - CALCULATE CORRELATION COEFF ETC.
C * GEN120 - (H)NP ROUTINE-4 - PLOT
C * GEN121 - ELIMINATE () FROM STRING
C * GEN122 - BUBBLE SORT
C * GEN123 - SORT ELEMENTS IN FORMULA
C * GEN124 - SHELL-SORT SMALL TO LARGE
C * GEN125 - WRITE SPECIAL STRING
C * GEN126 - BLANK STRING
C * GEN127 - EXIT/STOP
C * GEN129 - DELETE FILE (CHECK FOR EXISTANCE)
C * GEN130 - DETERMINANT OF 3*3 MATRIX
C * GEN131 - DETERMINANT OF 3*3 MATRIX FROM EXTENDED ARRAY
C * GEN132 - Z = T1 * X * T2
C * GEN133 - C COPY VECTOR WITH N ELEMENTS
C * GEN134 - COPY FORMULA STRINGS
C * GEN135 - UNIT 3*3 MATRIX ?
C * GEN136 - GAMMA FUNCTION
C * GEN137 - PSI FUNCTION
C * GEN138 - HYPERGEOM FUNCTION
C * GEN139 - CALCULATE CUMULATIVE DISTRIBUTION FUNCTION FOR STUDENT-T PDF
C * GEN140 - INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
C * GEN141 - INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
C * GEN142 - PREPARE FOR Probability Plot (SORT)
C * GEN143 - INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
C * GEN144 - INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
C * GEN145 - STANDARDIZE H,K,L (FRIEDEL SYMMETRY APPLIED)
C * GEN146 - Pack Flack,Parsons or Hooft parameter values for listing
C * GEN147 - 3 ITEM SORT
C * GEN148 - REPORT REWIND ISSUE
C * GEN149 - Aitken repeated interpolation
C * GEN150
C * GEN151 -
C * GEN152 - ESTABLISH NUMBER OF RELEVANT DECIMALS
C * GEN153 - FIT CURVE TO Y = A(1) * RHO**3 + A(2) * RHO**2 + A(3) * RHO + A(4)
C * GEN154 - SORT
C * GEN155 - CHECKSUM
C * GEN156 - MOVE LABEL RIGHT
C * GEN157 - SOLVE EQUATION (DP)
C * GEN158 - CALCULATE CELL ERROR CONTRIBUTION TO BOND ANGLE ERROR
C * GEN159 - CALCULATE BOND ANGLE FOR BOND ANGL ERROR CALC
C * GEN160 - RANDOM GENERATOR
C * GEN161 - DP-EIGEN
C * GEN162 - AMOEBA
C * GEN163 - CALCULATE VOLUME FROM CELL DATA (SUPPORT FOR GEN068)
C * GEN164 - CONVERT A(3, 3) TO B(9)
C * GEN165 - MULTIPLY TWO '3X3' MATRICES (stored as rows)
      MODULE genrl
      SAVE
      CHARACTER(len=8), DIMENSION(56) :: STR1 = (/
     1       '-3.00000', '-2.00000', '-1.87500', '-1.83333', '-1.75000',
     2       '-1.66667', '-1.33333', '-1.00000', '-0.87500', '-0.83333',
     3       '-0.75000', '-0.66667', '-0.66666', '-0.62500', '-0.50000',
     4       '-0.37500', '-0.33333', '-0.25000', '-0.16667', '-0.16666',
     5       '-0.12500', '-0.00000', ' 0.00000', ' 0.08333', ' 0.12500',
     6       ' 0.16666', ' 0.16667', ' 0.25000', ' 0.33333', ' 0.37500',
     7       ' 0.50000', ' 0.62500', ' 0.66666', ' 0.66667', ' 0.75000',
     8       ' 0.83333', ' 0.87500', ' 1.00000', ' 1.12500', ' 1.16666',
     9       ' 1.16667', ' 1.25000', ' 1.33333', ' 1.37500', ' 1.50000',
     *       ' 1.62500', ' 1.66666', ' 1.66667', ' 1.75000', ' 1.83333',
     1       ' 1.87500', ' 2.00000', '  0.0000', ' 90.0000', '120.0000',
     2       '180.0000'/)
      CHARACTER(len=8), DIMENSION(56) :: STR2 = (/
     1       '      -3', '      -2', '   -15/8', '   -11/6', '    -7/4',
     2       '    -5/3', '    -4/3', '      -1', '    -7/8', '    -5/6',
     3       '    -3/4', '    -2/3', '    -2/3', '    -5/8', '    -1/2',
     4       '    -3/8', '    -1/3', '    -1/4', '    -1/6', '    -1/6',
     5       '    -1/8', '       0', '       0', '    1/12', '     1/8',
     6       '     1/6', '     1/6', '     1/4', '     1/3', '     3/8',
     7       '     1/2', '     5/8', '     2/3', '     2/3', '     3/4',
     8       '     5/6', '     7/8', '       1', '     9/8', '     7/6',
     9       '     7/6', '     5/4', '     4/3', '    11/8', '     3/2',
     *       '    13/8', '     5/3', '     5/3', '     7/4', '    11/6',
     1       '    15/8', '       2', '       0', '      90', '     120',
     2      '     180'/)
      CHARACTER(len=6), DIMENSION(48) :: STR3 = (/
     1 ' 2.000', ' 1.875', ' 1.833', ' 1.750', ' 1.667', ' 1.625',
     2 ' 1.500', ' 1.375', ' 1.333', ' 1.250', ' 1.167', ' 1.125',
     3 ' 1.000', ' 0.875', ' 0.833', ' 0.750', ' 0.667', ' 0.625',
     4 ' 0.500', ' 0.375', ' 0.333', ' 0.250', ' 0.167', ' 0.125',
     5 ' 0.000', '-0.000', '-0.250', '-0.333', '-0.375', '-0.500',
     6 '-0.625', '-0.667', '-0.750', '-0.833', '-0.875', '-1.000',
     7 '-1.125', '-1.167', '-1.250', '-1.333', '-1.375', '-1.500',
     8 '-1.625', '-1.667', '-1.750', '-1.833', '-1.875', '-2.000'/)
      CHARACTER(len=6), DIMENSION(48) :: STR4 = (/
     1 '     2', '  15/8', '  11/6', '   7/4', '   5/3', '  13/8',
     2 '   3/2', '  11/8', '   4/3', '   5/4', '   7/6', '   9/8',
     3 '     1', '   7/8', '   5/6', '   3/4', '   2/3', '   5/8',
     4 '   1/2', '   3/8', '   1/3', '   1/4', '   1/6', '   1/8',
     5 '     0', '     0', '  -1/4', '  -1/3', '  -3/8', '  -1/2',
     6 '  -5/8', '  -2/3', '  -3/4', '  -5/6', '  -7/8', '    -1',
     7 '  -9/8', '  -7/6', '  -5/4', '  -4/3', ' -11/8', '  -3/2',
     8 ' -13/8', '  -5/3', '  -7/4', ' -11/6', ' -15/8', '    -2'/)
      CHARACTER(len=6), DIMENSION(16) :: STR5 = (/
     1 ' 0.00 ', '-0.00 ', ' 0.25 ', '-0.25 ', ' 0.50 ', '-0.50 ',
     2 ' 0.75 ', '-0.75 ', ' 1.00 ', '-1.00 ', ' 1.50 ', '-1.50 ',
     3 ' 2.00 ', '-2.00 ', ' 3.00 ', '-3.00 '/)
      CHARACTER(len=6), DIMENSION(16) :: STR6 = (/
     1 '    0 ', '   -0 ', '  1/4 ', ' -1/4 ', '  1/2 ', ' -1/2 ',
     2 '  3/4 ', ' -3/4 ', '    1 ', '   -1 ', '  3/2 ', ' -3/2 ',
     3 '    2 ', '   -2 ', '    3 ', '   -3 '/)
      INTEGER, DIMENSION(9, 30) :: IT = RESHAPE ( (/
C * 2x, 2y, 2z, 2xy, 2xz, 2yz, 2x-y, 2-xz, 2y-z, 22xy, 2x2y
     1  211, 101, 110, 0, 1, 1, 0, 0, 0,
     2   11, 121, 110, 1, 1, 1, 0, 0, 0,
     3   11, 101, 112, 0, 1, 1, 0, 0, 0,
     4  121, 211, 110, 0, 0, 1, 0, 0, 0,
     5  112, 101, 211, 0, 0, 0, 0, 0, 0,
     6   11, 112, 121, 0, 0, 0, 0, 0, 0,
     7  101,  11, 110, 0, 0, 1, 0, 0, 0,
     8  110, 101,  11, 0, 0, 0, 0, 0, 0,
     9   11, 110, 101, 0, 0, 0, 0, 0, 0,
     *  221, 101, 110, 0, 0, 0, 0, 1, 0,
     1   11, 221, 110, 0, 0, 0, 0, 1, 0,
C * 3z1, 3z2, 3xyz1, 3xyz2, 3-xyz1, 3-xyz2, 3x-yz1, 3x-yz2, 3xy-z1, 3xy-z2
     1  121,   1, 112, 0, 0, 0, 1, 1, 0,
     2    1, 211, 112, 0, 0, 0, 1, 1, 0,
     3  121, 112, 211, 0, 0, 0, 0, 0, 1,
     4  112, 211, 121, 0, 0, 0, 0, 0, 1,
     5  110,  11, 121, 0, 0, 0, 0, 0, 1,
     6  101, 112,  11, 0, 0, 0, 0, 0, 1,
     7  112,  11, 101, 0, 0, 0, 0, 0, 1,
     8  101, 110, 211, 0, 0, 0, 0, 0, 1,
     9  110, 211, 101, 0, 0, 0, 0, 0, 1,
     *  121, 110,  11, 0, 0, 0, 0, 0, 1,
C * 4x1, 4x3, 4y1, 4y3, 4z1, 4z3
     1  211, 110, 121, 0, 0, 0, 0, 0, 1,
     2  211, 112, 101, 0, 0, 0, 0, 0, 1,
     3  112, 121,  11, 0, 0, 0, 0, 0, 1,
     4  110, 121, 211, 0, 0, 0, 0, 0, 1,
     5  121,  11, 112, 0, 0, 1, 0, 0, 1,
     6  101, 211, 112, 0, 0, 1, 0, 0, 1,
C * 6z1, 6z3, 6z5
     1  221,  11, 112, 0, 0, 0, 0, 1, 0,
     2  011, 101, 112, 0, 0, 0, 1, 1, 0,
     3  101, 221, 112, 0, 0, 0, 0, 1, 0/), (/9, 30/))
      END MODULE genrl
 
      SUBROUTINE GEN001 (MODE, Z, T, W)
C * W = Z  * T * Z~  OR  W = Z~ * T * Z
      IMPLICIT NONE
      INTEGER               :: MODE
      REAL, DIMENSION(3, 3) :: Z
      REAL, DIMENSION(3, 3) :: T
      REAL, DIMENSION(3, 3) :: V
      REAL, DIMENSION(3, 3) :: W
      REAL, DIMENSION(3, 3) :: ZTR
C * MODE =  1 : W = Z  * T * Z~  - W AND T MAY BE THE SAME MATRIX
C * MODE = -1 : W = Z~ * T * Z   - W AND T MAY BE THE SAME MATRIX
      CALL GEN005 (Z, ZTR)
      IF (MODE == 1) THEN
        CALL GEN004 (Z, T, V)
        CALL GEN004 (V, ZTR, W)
      ELSE
        CALL GEN004 (ZTR, T, V)
        CALL GEN004 (V, Z, W)
      END IF
      RETURN
      END SUBROUTINE GEN001
 
      SUBROUTINE GEN002 (MODE, A, B, C, XLNG)
C * MATVEC & NORM OR VECMAT
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: MODE
      REAL                  :: XLNG
      REAL                  :: GEN009
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3)    :: B
      REAL, DIMENSION(3)    :: C
      REAL, DIMENSION(3)    :: V
C * MODE =    1 : MATRIX * VECTOR : C(3) = A(3, 3) * B(3)
C * MODE =   -1 : VECTOR * MATRIX : C(3) = B(3)    * A(3, 3)
C * MODE = +/-2 : +/-1 + NORMALISE C AND CALCULATE LENGTH C (XLNG)
      XLNG = 0.0
      DO I = 1, 3
        V(I) = 0.0
        IF (MODE > 0) THEN
          DO J = 1, 3
            V(I) = V(I) + A(I, J) * B(J)
          END DO
        ELSE
          DO J = 1, 3
            V(I) = V(I) + B(J) * A(J, I)
          END DO
        END IF
      END DO
      DO I = 1, 3
        C(I) = V(I)
      END DO
      IF (IABS (MODE) == 2) THEN
        XLNG = SQRT (GEN009 (C, C))
        IF (XLNG > 1.E-5) THEN
          DO I = 1, 3
            C(I) = C(I) / XLNG
          END DO
        ELSE
          XLNG = 0.0
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN002
 
      SUBROUTINE GEN003 (A, B, DET, MODE)
C * MINV
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: MODE
      REAL                  :: DET
      REAL                  :: DEEL
      REAL                  :: GEN009
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3, 3) :: B
      REAL, DIMENSION(3, 3) :: C
C * MODE = 0 : INVERT 3*3 MATRIX
C * MODE = 1 : GET 'NORMALISED' COFACTOR MATRIX
      CALL GEN008 (A(1, 2), A(1, 3), B(1, 1), 0)
      CALL GEN008 (A(1, 3), A(1, 1), B(1, 2), 0)
      CALL GEN008 (A(1, 1), A(1, 2), B(1, 3), 0)
      DET = GEN009 (A(1, 1), B(1, 1))
      IF (MODE == 0) THEN
C * TRANSPOSE B
        CALL GEN005 (B, C)
C * COPY MATRIX BACK
        CALL GEN052 (C, B)
        DEEL = DET
      ELSE IF (MODE == 1) THEN
        DEEL = B(3, 3)
      ELSE IF (MODE == -2) THEN
        DEEL = DET
      ELSE
        DEEL = 0
      END IF
      IF (DEEL /= 0.0) THEN
        DO I = 1, 3
          DO J = 1, 3
            B(I, J) = B(I, J) / DEEL
          END DO
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN003
 
      SUBROUTINE GEN004 (A, B, C)
C * MATRIX PRODUCT C = A * B (THE RECEIVING ARRAY C MIGHT BE B IN THE CALL)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3, 3) :: B
      REAL, DIMENSION(3, 3) :: C
      REAL, DIMENSION(3, 3) :: V
      DO I = 1, 3
        DO J = 1, 3
          V(I, J) = 0.0
          DO K = 1, 3
            V(I, J) = V(I, J) + A(I, K) * B(K, J)
          END DO
        END DO
      END DO
      CALL GEN052 (V, C)
      RETURN
      END SUBROUTINE GEN004
 
      SUBROUTINE GEN005 (T, TR)
C * TRANSPOSE MATRIX
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL, DIMENSION(3, 3) :: T
      REAL, DIMENSION(3, 3) :: X
      REAL, DIMENSION(3, 3) :: TR
C * TRANSPOSE MATRIX T IN TR (MAYBE T ALSO)
      DO I = 1, 3
        DO J = 1, 3
          X(J, I) = T(I, J)
        END DO
      END DO
      DO I = 1, 3
        DO J = 1, 3
          TR(I, J) = X(I, J)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN005
 
      REAL FUNCTION GEN006 (X1, QM, X2)
C * VECTOR1 * MATRIX * VECTOR2
      IMPLICIT NONE
      INTEGER               :: I
      REAL                  :: T1
      REAL, DIMENSION(3, 3) :: QM
      REAL, DIMENSION(3)    :: X1
      REAL, DIMENSION(3)    :: X2
C * TRANSPOSED VECTOR * MATRIX * VECTOR
C * VMV=X1(3)*QM(3,3)*X2(3) TO EVALUATE QUADRATIC OR BILINEAR FORM
      T1 = 0.0
      DO I = 1, 3
        T1 = T1 + X1(I) * (X2(1) * QM(I, 1) + X2(2) * QM(I, 2)
     1     + X2(3) * QM(I, 3))
      END DO
      GEN006 = T1
      RETURN
      END FUNCTION GEN006
 
      SUBROUTINE GEN007 (AA, X, Z, ITYPE)
C * UNIP
      IMPLICIT NONE
      INTEGER               :: ITYPE
      REAL                  :: TN
      REAL                  :: GEN006
      REAL                  :: GEN009
      REAL, DIMENSION(3)    :: X
      REAL, DIMENSION(3)    :: Z
      REAL, DIMENSION(3, 3) :: AA
      IF (ITYPE > 0) THEN
        TN = SQRT(GEN009(X, X))
      ELSE
C * TRANSPOSED VECTOR * MATRIX * VECTOR
        TN = SQRT(GEN006(X, AA, X))
      END IF
C * NORMALIZE
      IF (TN == 0.0) TN = 1.0
      Z(1) = X(1) / TN
      Z(2) = X(2) / TN
      Z(3) = X(3) / TN
      RETURN
      END SUBROUTINE GEN007
 
      SUBROUTINE GEN008 (A, B, C, MODE)
C * VECTOR PRODUCT
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: MODE
      REAL               :: D
      REAL               :: DSQ
      REAL, DIMENSION(3) :: A
      REAL, DIMENSION(3) :: B
      REAL, DIMENSION(3) :: C
C * MODE =  1 : C = A X B (NORMALISED TO UNIT LENGTH)
C * MODE =  0 : C = A X B
C * MODE = -1 : D = A X B, C(1) = D1**2 + D2**2 + D3**2
      C(1) = A(2) * B(3) - A(3) * B(2)
      C(2) = A(3) * B(1) - A(1) * B(3)
      C(3) = A(1) * B(2) - A(2) * B(1)
      IF (MODE /= 0) THEN
        DSQ = 0.0
        DO I = 1, 3
          IF (ABS (C(I)) < 1.0E-18) C(I) = 0.0
          DSQ = DSQ + C(I)**2
        END DO
        IF (MODE > 0) THEN
          IF (DSQ > 0.0) THEN
            D = SQRT (DSQ)
            C(1) = C(1) / D
            C(2) = C(2) / D
            C(3) = C(3) / D
          END IF
        ELSE
          C(1) = SQRT (DSQ)
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN008
 
      REAL FUNCTION GEN009 (X, Y)
C * TRANSPOSED VECTOR * VECTOR : VV = X(3) * Y(3)
      IMPLICIT NONE
      REAL, DIMENSION(3) :: X
      REAL, DIMENSION(3) :: Y
      GEN009 = X(1) * Y(1) + X(2) * Y(2) + X(3) * Y(3)
      RETURN
      END FUNCTION GEN009
 
      SUBROUTINE GEN010 (R, IDET, MODE)
C * DETERMINANT
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: IDET
      INTEGER               :: MODE
      REAL                  :: DET
      REAL                  :: GEN009
      REAL, DIMENSION(3, 3) :: R
      REAL, DIMENSION(3)    :: V
C * SUBROUTINE CALCULATES DETERMINANT AND RETURNS 0 OR +/-1 IN IDET
C * IDET = -1
C * IDET =  0
C * IDET =  1
      IF (MODE >= 0) THEN
        CALL GEN008 (R(1, 1), R(1, 2), V, 0)
        DET = GEN009 (R(1, 3), V)
        IF (DET > 0.999) THEN
          IDET = 1
        ELSE IF (DET < -0.999) THEN
          IDET = -1
        ELSE
          IDET = 0
        END IF
      END IF
      IF (MODE /= 0) THEN
        DO I = 1, 3
          DO J = 1, 3
            R(I, J) = IDET * R(I, J)
          END DO
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN010
 
      SUBROUTINE GEN011 (BB, X, Y, Z, ITYPE)
C * NORM
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: I1
      INTEGER               :: I2
      INTEGER               :: ITYPE
      REAL                  :: T1
      REAL                  :: XLNG
      REAL, DIMENSION(3)    :: X
      REAL, DIMENSION(3)    :: Y
      REAL, DIMENSION(3)    :: Z
      REAL, DIMENSION(3)    :: Z1
      REAL, DIMENSION(3, 3) :: BB
C * ITYPE > 0 FOR CARTESIAN
C * ITYPE < 0 FOR TRICLINIC
      DO I = 1, 3
        I1 = MOD (I + 3, 3) + 1
        I2 = MOD (I + 1, 3) + 1
        T1 = X(I1) * Y(I2) - X(I2) * Y(I1)
        IF (ABS (T1) < 1.E-6) T1 = 0.0
        IF (ITYPE > 0) THEN
          Z(I) = T1
        ELSE
          Z1(I) = T1
        END IF
      END DO
      IF (ITYPE <= 0) CALL GEN002 (1, BB, Z1, Z, XLNG)
      RETURN
      END SUBROUTINE GEN011
 
      SUBROUTINE GEN012 (B, A, NN, DAMP, DA, R)
C * MATRIX INVERSION
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: NI
      INTEGER            :: NK
      INTEGER            :: NN
      REAL               :: R
      REAL               :: T
      REAL               :: DA
      REAL               :: DAMP
      REAL, DIMENSION(*) :: A
      REAL, DIMENSION(*) :: B
C * DA & DAMP MAY BE SET TO 0.0, R TO 1.0
      K = 0
      L = 0
      J = NN + 1
      DO NI = 1, NN
        K = K + 2
        I = J - 1
        M = J + 1
        B(J) = 1.0 / AMAX1 (B(J) + DA * DAMP, 0.1 * DA, 1.E-10)
        IF (NI < NN) THEN
   10     B(K) = - B(J) * B(M)
          M    = M + 1
          K    = K + 1
          IF (K >= J) THEN
            L = J + NI - NN
            J = J + 1
            IF (I >= L) THEN
   20         B(M) = B(J) * B(L) + B(M)
              M    = M + 1
              L    = L + 1
              IF (I < L) THEN
                L = J + NI - NN
                J = J + 1
                IF (I < L) CYCLE
              ENDIF
              GO TO 20
            ELSE
              CYCLE
            ENDIF
          ENDIF
          GO TO 10
        END IF
      END DO
      NI   = NN - 1
   30 NI   = NI - 1
      J    = K
      M    = K + NI - NN
      L    = M - 1
      I    = M + 1
      K    = I + NI - NN
   40 B(I) = 0.0
      I    = I + 1
      IF (I < J) GO TO 40
   50 M    = M + 1
      B(M) = B(K) * B(J) + B(M)
      I    = M
      NK   = K + 1
   60 IF (L >= NK) THEN
        J    = J + 1
        I    = I + 1
        B(I) = B(K)  * B(J) + B(I)
        B(M) = B(NK) * B(J) + B(M)
        NK   = NK + 1
        GO TO 60
      END IF
      B(NK) = B(K) * B(M) + B(NK)
      J     = J + 1
      K     = K + 1
      IF (L  >= K) GO TO 50
      IF (NI > 0) GO TO 30
      CALL GEN074 (B, 1, NN, 0.0)
      L = NN + 1
      DO I = 1, NN
        B(I) = B(I) - B(L) * A(I)
        T = B(L) * R
        DO K = I, NN
          B(I) = B(L) * A(K) + B(I)
          B(K) = B(L) * A(I) + B(K)
          L    = L + 1
        END DO
        A(I) = SQRT (ABS (T))
      END DO
      RETURN
      END SUBROUTINE GEN012
 
      REAL FUNCTION GEN013 (IDUM)
C * RANDOM NUMBER GENERATOR
      IMPLICIT NONE
      INTEGER, PARAMETER     :: M  = 714025
      INTEGER, PARAMETER     :: IA = 1366
      INTEGER, PARAMETER     :: IC = 150889
      INTEGER                :: J
      INTEGER                :: IY
      INTEGER                :: IDUM
      INTEGER, DIMENSION(97) :: IR
      REAL                   :: RM
      COMMON /DGEN13/ IR, RM, IY
      IF (IDUM < 0) THEN
        RM = 1.0 / M
        IDUM = MOD (IC - IDUM, M)
        DO J = 1, 97
          IDUM  = MOD (IA * IDUM + IC, M)
          IR(J) = IDUM
        END DO
        IDUM = MOD (IA * IDUM + IC, M)
        IY   = IDUM
      END IF
      J = 1 + (97 * IY) / M
      IF (J > 97 .OR. J < 1) STOP 'IN RANDOM'
      IY       = IR(J)
      GEN013   = IY * RM
      IDUM     = MOD (IA * IDUM + IC, M)
      IR(J)    = IDUM
      RETURN
      END FUNCTION GEN013
 
      SUBROUTINE GEN014 (I, J)
C * SWAP INTEGERS
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: K
      K = I
      I = J
      J = K
      RETURN
      END SUBROUTINE GEN014
 
      SUBROUTINE GEN015 (A, B, C, XMUL)
C * Add/Subtract 3-vector B to/from 3-vector A
      IMPLICIT NONE
      INTEGER            :: I
      REAL               :: XMUL
      REAL, DIMENSION(3) :: A
      REAL, DIMENSION(3) :: B
      REAL, DIMENSION(3) :: C
      DO I = 1, 3
        C(I) = A(I) + XMUL * B(I)
      END DO
      RETURN
      END SUBROUTINE GEN015
 
      REAL FUNCTION GEN016 (X1, QM, X2)
C * ANGLE BETWEEN TWO VECTORS
      IMPLICIT NONE
      REAL                  :: A
      REAL                  :: B
      REAL                  :: C
      REAL                  :: RAD
      REAL                  :: GEN006
      REAL, DIMENSION(3)    :: X1
      REAL, DIMENSION(3)    :: X2
      REAL, DIMENSION(3, 3) :: QM
      RAD    = ATAN2 (1.0, 1.0) / 45.0
      A      = GEN006 (X1, QM, X2)
      B      = GEN006 (X1, QM, X1)
      C      = GEN006 (X2, QM, X2)
      GEN016 = ACOS (A / SQRT (B * C)) / RAD
      RETURN
      END FUNCTION GEN016
 
      REAL FUNCTION GEN017 (V)
C * NORMALIZE VECTOR
      IMPLICIT NONE
      INTEGER            :: I
      REAL               :: D
      REAL, DIMENSION(3) :: V
      D = SQRT (V(1) ** 2 + V(2) ** 2 + V(3) ** 2)
      IF (D < 0.00001) THEN
        GEN017 = 0.0
      ELSE
        GEN017 = D
        DO I = 1, 3
          V(I) = V(I) / D
        END DO
      END IF
      RETURN
      END FUNCTION GEN017
 
      SUBROUTINE GEN018 (A, B)
C * SWAP REALS
      IMPLICIT NONE
      REAL :: A
      REAL :: B
      REAL :: C
      C = A
      A = B
      B = C
      RETURN
      END SUBROUTINE GEN018
 
      SUBROUTINE GEN019 (AA, BB, U, V, X, ITYPE)
C * STORE THREE ORTHOGONAL VECTORS EACH 1 ANGSTROM LONG
C * ITYPE .GT.0 FOR CARTESIAN,.LT.0 FOR TRICLINIC
C * IABS(ITYPE)=1 W(1)=U,W(2)=(UXV),W(3)=UX(UXV)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: IT
      INTEGER               :: ITYPE
      REAL, DIMENSION(3)    :: U
      REAL, DIMENSION(3)    :: V
      REAL, DIMENSION(3, 3) :: W
      REAL, DIMENSION(3, 3) :: X
      REAL, DIMENSION(3, 3) :: AA
      REAL, DIMENSION(3, 3) :: BB
      IT = ITYPE
      DO I = 1, 3
         W(I, 1) = U(I)
      END DO
      CALL GEN011 (BB, U, V, W(1, 2), IT)
      CALL GEN011 (BB, U, W(1, 2), W(1, 3), IT)
      DO I = 1, 3
        CALL GEN007 (AA, W(1, I), X(1, I), IT)
      END DO
      RETURN
      END SUBROUTINE GEN019
 
      SUBROUTINE GEN020 (MODE, ICL, IMIN, IMAX)
C * UPPER/LOWER CASE CONVERSION
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: N
      INTEGER          :: MODE
      INTEGER          :: IMIN
      INTEGER          :: IMAX
      CHARACTER(len=*) :: ICL
      IF (IMAX >= IMIN) THEN
C * MODE =  1 - CONVERT TO UPPER CASE
C * MODE = -1 - CONVERT TO LOWER CASE
        IF (MODE > 0) THEN
          DO I = IMIN, IMAX
            IF (ICL(I:I) == CHAR (9)) ICL(I:I) = ' '
            CALL GEN105 (2, ICL(I:I), N)
            IF (N > 0) ICL(I:I) = CHAR (N + ICHAR ('A') - ICHAR ('a'))
          END DO
        ELSE
          DO I = IMIN, IMAX
            CALL GEN105 (1, ICL(I:I), N)
            IF (N > 0) ICL(I:I) = CHAR (N - ICHAR ('A') + ICHAR ('a'))
          END DO
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN020
 
      SUBROUTINE GEN021 (X, VAL)
C * INIT MATRIX ON SUPPLIED REAL VALUE ON THE DIAGONAL, 0.0 OTHERWISE
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL                  :: VAL
      REAL, DIMENSION(3, 3) :: X
      DO I = 1, 3
        DO J = 1, 3
          IF (I == J) THEN
            X(I, I) = VAL
          ELSE
            X(I, J) = 0.0
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN021
 
      SUBROUTINE GEN022 (NA, N0, N, M)
C * SHELL-SORT NA FROM N0 TO N (M=1:SMALL TO LARGE;M=-1:LARGE TO SMALL)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: M
      INTEGER               :: N0
      INTEGER               :: ND
      INTEGER               :: NY
      INTEGER               :: NEL
      INTEGER, DIMENSION(*) :: NA
      NEL = N - N0 + 1
      IF (NEL > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (NEL)) / ALOG (2.0)) + 1.0E-5)) - 1
        DO WHILE (ND > 0)
          I = N0
          DO
            J = I
            NY = NA(I + ND)
            DO
              IF (M == 1) THEN
                IF (NY >= NA(J)) EXIT
              ELSE
                IF (NY <= NA(J)) EXIT
              END IF
              NA(J + ND) = NA(J)
              J = J - ND
              IF (J < N0) EXIT
            END DO
            NA(J + ND) = NY
            I = I + 1
            IF (I + ND >  N) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN022
 
      SUBROUTINE GEN023 (A, R, N)
C * EW, EV FOR SYMMETRICAL MATRIX
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: IA
      INTEGER            :: IQ
      INTEGER            :: JQ
      INTEGER            :: IL
      INTEGER            :: IM
      INTEGER            :: IJ
      INTEGER            :: LQ
      INTEGER            :: MQ
      INTEGER            :: LL
      INTEGER            :: LM
      INTEGER            :: MM
      INTEGER            :: IND
      INTEGER            :: ILQ
      INTEGER            :: IMQ
      INTEGER            :: ILR
      INTEGER            :: IMR
      REAL               :: X
      REAL               :: Y
      REAL               :: Y2
      REAL               :: SINX
      REAL               :: COSX
      REAL               :: SINX2
      REAL               :: COSX2
      REAL               :: SINCS
      REAL               :: ANORM
      REAL               :: ANRMX
      REAL               :: RANGEX
      REAL               :: THR
      REAL, DIMENSION(*) :: A
      REAL, DIMENSION(*) :: R
      RANGEX = 1.0E-6
C * GENERATE IDENTITY MATRIX
      IQ = - N
      DO J = 1, N
        IQ = IQ + N
        DO I = 1, N
          IJ = IQ + I
          IF (I == J) THEN
            R(IJ) = 1.0
          ELSE
            R(IJ) = 0.0
          END IF
        END DO
      END DO
C * COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX)
      ANORM = 0.0
      DO I = 1, N
        DO J = I, N
          IF (I /= J) THEN
            IA    = I + (J * J - J) / 2
C * AVOID UNDERFLOW
            IF (ABS (A(IA)) > 0.1E-17) THEN
              ANORM = ANORM + A(IA)**2
            END IF
          END IF
        END DO
      END DO
      IF (ANORM > 0.0) THEN
        ANORM = 1.414 * SQRT (ANORM)
        ANRMX = ANORM * RANGEX / FLOAT(N)
C * INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR
        IND = 0
        THR = ANORM
        DO
          THR = THR / FLOAT (N)
   10     L   = 1
   20     M   = L + 1
C * COMPUTE SIN AND COS
   30     MQ = (M * M - M) / 2
          LQ = (L * L - L) / 2
          LM = L + MQ
          IF (ABS (A(LM)) >= THR) THEN
            IND = 1
            LL  = L + LQ
            MM  = M + MQ
            X   = 0.5 * (A(LL) - A(MM))
            Y   = -A(LM) / SQRT (A(LM) * A(LM) + X**2)
            IF (X < 0.0) Y  = - Y
            Y2 = Y**2
            IF (Y2 < 1.0) THEN
              SINX = Y / SQRT (2.0 * (1.0 + (SQRT (1.0 - Y2))))
            ELSE
              SINX = Y / SQRT (2.0)
            END IF
            SINX2 = SINX * SINX
            COSX  = SQRT (1.0 - SINX2)
            COSX2 = COSX**2
            SINCS = SINX * COSX
C * ROTATE L AND M COLUMNS
            ILQ = N * (L - 1)
            IMQ = N * (M - 1)
            DO I = 1, N
              IQ = (I * I - I) / 2
              IF (I /= L) THEN
                IF (I > M) THEN
                  IM = M + IQ
                ELSE IF (I == M) THEN
                  GO TO 40
                ELSE
                  IM = I + MQ
                END IF
                IF (I < L) THEN
                  IL = I + LQ
                ELSE
                  IL = L + IQ
                END IF
                X     = A(IL) * COSX - A(IM) * SINX
                A(IM) = A(IL) * SINX + A(IM) * COSX
                A(IL) = X
              END IF
   40         ILR    = ILQ + I
              IMR    = IMQ + I
              X      = R(ILR) * COSX - R(IMR) * SINX
              R(IMR) = R(ILR) * SINX + R(IMR) * COSX
              R(ILR) = X
            END DO
            X     = 2.0 * A(LM) * SINCS
            Y     = A(LL) * COSX2 + A(MM) * SINX2 - X
            X     = A(LL) * SINX2 + A(MM) * COSX2 + X
            A(LM) = (A(LL) - A(MM)) * SINCS + A(LM) * (COSX2 - SINX2)
            A(LL) = Y
            A(MM) = X
          END IF
C * TESTS FOR COMPLETION
C * TEST FOR M = LAST COLUMN
          IF (M /= N) THEN
            M = M + 1
            GO TO 30
          END IF
C * TEST FOR L = SECOND FROM LAST COLUMN
          IF (L /= (N - 1)) THEN
            L = L + 1
            GO TO 20
          END IF
          IF (IND == 1) THEN
            IND = 0
            GO TO 10
          END IF
C * COMPARE THRESHOLD WITH FINAL NORM
          IF (THR <= ANRMX) EXIT
        END DO
      END IF
C * SORT EIGENVALUES AND EIGENVECTORS
      IQ = - N
      DO I = 1, N
        IQ = IQ + N
        LL = I + (I * I - I) / 2
        JQ = N * (I - 2)
        DO J = I, N
          JQ = JQ + N
          MM = J + (J * J - J) / 2
          IF (A(LL) < A(MM)) THEN
            X     = A(LL)
            A(LL) = A(MM)
            A(MM) = X
            DO K = 1, N
              ILR    = IQ + K
              IMR    = JQ + K
              X      = R(ILR)
              R(ILR) = R(IMR)
              R(IMR) = X
            END DO
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN023
 
      SUBROUTINE GEN024 (W, EV, EW, DUMV)
C * CALCULATE EIGENVECTORS AND EIGENVALUES FOR SYMM. 3X3 MATRIX W
C * EIGENVECTORS AS COLUMN VECTORS IN DUMV AND ROW VECTORS IN EV
      IMPLICIT NONE
      REAL, DIMENSION(3, 3) :: W
      REAL, DIMENSION(3, 3) :: EV
      REAL, DIMENSION(3)    :: EW
      REAL, DIMENSION(6)    :: DUMA
      REAL, DIMENSION(3, 3) :: DUMV
      DUMA(1) = W(1, 1)
      DUMA(2) = W(1, 2)
      DUMA(3) = W(2, 2)
      DUMA(4) = W(1, 3)
      DUMA(5) = W(2, 3)
      DUMA(6) = W(3, 3)
      CALL GEN023 (DUMA, DUMV, 3)
C * ENSURE THAT THE EIGENVECTORS DETERMINE A RIGHT-HANDED AXIS SYSTEM
      CALL GEN008 (DUMV(1, 1), DUMV(1, 2), DUMV(1, 3), 1)
      CALL GEN005 (DUMV, EV)
      EW(1) = DUMA(1)
      EW(2) = DUMA(3)
      EW(3) = DUMA(6)
      RETURN
      END SUBROUTINE GEN024
 
      SUBROUTINE GEN025 (A, V, MODE)
C * MODE =  1 : SYMMETRIC MATRIX TO VECTOR
C * MODE = -1 : VECTOR TO SYMMETRIC MATRIX
      IMPLICIT NONE
      INTEGER               :: MODE
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(6)    :: V
      IF (MODE > 0) THEN
        V(1) = A(1, 1)
        V(2) = A(2, 2)
        V(3) = A(3, 3)
        V(4) = A(2, 3)
        V(5) = A(1, 3)
        V(6) = A(1, 2)
      ELSE
        A(1, 1) = V(1)
        A(2, 2) = V(2)
        A(3, 3) = V(3)
        A(2, 3) = V(4)
        A(3, 2) = V(4)
        A(1, 3) = V(5)
        A(3, 1) = V(5)
        A(1, 2) = V(6)
        A(2, 1) = V(6)
      END IF
      RETURN
      END SUBROUTINE GEN025
 
      SUBROUTINE GEN026 (MODE, A, V)
C * METRIC TO CELL AND VISA VERSA
      IMPLICIT NONE
      INTEGER               :: MODE
      REAL                  :: RAD
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(6)    :: V
      RAD = ATAN2 (1.0, 1.0) / 45.0
      IF (MODE == 1) THEN
C * SET UP METRICAL MATRIX FROM CELL PARAMETERS
        A(1, 2) = 0.0
        A(1, 3) = 0.0
        A(2, 3) = 0.0
        A(1, 1) = V(1) * V(1)
        A(2, 2) = V(2) * V(2)
        A(3, 3) = V(3) * V(3)
        IF (ABS (V(6) - 90.0) > 0.00001)
     1    A(1, 2) = V(1) * V(2) * COS (V(6) * RAD)
        A(2, 1) = A(1, 2)
        IF (ABS (V(5) - 90.0) > 0.00001)
     1    A(1, 3) = V(1) * V(3) * COS (V(5) * RAD)
        A(3, 1) = A(1, 3)
        IF (ABS (V(4) - 90.0) > 0.00001)
     1    A(2, 3) = V(2) * V(3) * COS (V(4) * RAD)
        A(3, 2) = A(2, 3)
      ELSE IF (MODE == -1) THEN
C * RECOVER CELL PARAMETERS FROM METRIC
        V(1)   = SQRT (A(1, 1))
        V(2)   = SQRT (A(2, 2))
        V(3)   = SQRT (A(3, 3))
        V(4)   = ACOS (A(2, 3) / (V(2) * V(3))) / RAD
        V(5)   = ACOS (A(1, 3) / (V(1) * V(3))) / RAD
        V(6)   = ACOS (A(1, 2) / (V(1) * V(2))) / RAD
      END IF
      RETURN
      END SUBROUTINE GEN026
 
      REAL FUNCTION GEN027 (V1, V2, P5)
C * CALCULATE ANGLE BETWEEN VECTORS
      IMPLICIT NONE
      REAL               :: P5
      REAL               :: ANG
      REAL               :: GEN009
      REAL, DIMENSION(*) :: V1
      REAL, DIMENSION(*) :: V2
      ANG = GEN009 (V1, V2)
      IF (ANG >  1.0) ANG =  1.0
      IF (ANG < -1.0) ANG = -1.0
      GEN027 = ACOS (ANG) * P5
      RETURN
      END FUNCTION GEN027
 
      SUBROUTINE GEN028 (XAR, NN, NDM, ITEKEN)
C * FFT
      IMPLICIT NONE
      INTEGER                 :: N
      INTEGER                 :: IA
      INTEGER                 :: IB
      INTEGER                 :: IC
      INTEGER                 :: KA
      INTEGER                 :: KB
      INTEGER                 :: IDM
      INTEGER                 :: NDM
      INTEGER                 :: IPA
      INTEGER                 :: IPB
      INTEGER                 :: IPC
      INTEGER                 :: IBIT
      INTEGER                 :: NPRV
      INTEGER                 :: NTOT
      INTEGER                 :: NREM
      INTEGER                 :: IBRV
      INTEGER                 :: IFPA
      INTEGER                 :: IFPB
      INTEGER                 :: ICRV
      INTEGER                 :: ITEKEN
      INTEGER, DIMENSION(NDM) :: NN
      REAL                    :: SWI
      REAL                    :: SWR
      REAL                    :: YKI
      REAL                    :: YKR
      REAL                    :: XARKB
      REAL                    :: XARKB1
      REAL,    DIMENSION(*)   :: XAR
      DOUBLE PRECISION        :: WR
      DOUBLE PRECISION        :: WI
      DOUBLE PRECISION        :: TH
      DOUBLE PRECISION        :: WPR
      DOUBLE PRECISION        :: WPI
      DOUBLE PRECISION        :: WYK
C * REPLACES XAR BY ITS NDM-DIMENSIONAL DISCRETE FOURIER TRANSFORM,
C * IF ISIGN IS INPUT AS 1. NN IS AN INTEGER ARRAY OF LENGTH NDM,
C * CONTAINING THE LENGTHS OF EACH DIMENSION (NUMBER OF COMPLEX VALUES),
C * WHICH MUST ALL BE POWERS OF 2. XAR IS A REAL ARRAY OF LENGTH TWICE
C * THE PRODUCT OF THESE LENGTHS, IN WHICH THE DATA ARE STORED AS IN A
C * MULTIDIMENSIONAL COMPLEX FORTRAN ARRAY. IF ISIGN IS INPUT AS -1,
C * XAR IS REPLACED BY ITS INVERSE TRANSFORM TIMES THE PRODUCT OF THE
C * LENGTHS OF ALL DIMENSIONS.
      NPRV = 1
      NTOT = 1
      DO IDM = 1, NDM
        NTOT = NTOT * NN(IDM)
      END DO
      DO IDM = 1, NDM
        N    = NN(IDM)
        NREM = NTOT / (N * NPRV)
        IPA  = 2 * NPRV
        IPB  = IPA * N
        IPC  = IPB * NREM
        IBRV = 1
        DO IB = 1, IPB, IPA
          IF (IB < IBRV) THEN
            DO IA = IB, IB + IPA - 2, 2
              DO IC = IA, IPC, IPB
                ICRV          = IBRV + IC - IB
                YKR           = XAR(IC)
                YKI           = XAR(IC + 1)
                XAR(IC)       = XAR(ICRV)
                XAR(IC + 1)   = XAR(ICRV + 1)
                XAR(ICRV)     = YKR
                XAR(ICRV + 1) = YKI
              END DO
            END DO
          END IF
          IBIT = IPB / 2
   10     IF ((IBIT >= IPA) .AND. (IBRV > IBIT)) THEN
            IBRV = IBRV - IBIT
            IBIT = IBIT / 2
            GO TO 10
          END IF
          IBRV = IBRV + IBIT
        END DO
        IFPA = IPA
   20   IF (IFPA < IPB) THEN
          IFPB = 2 * IFPA
          TH   = ITEKEN * 6.28318530717959D0 / (IFPB / IPA)
          WPR  = -2.D0 * DSIN (0.5D0 * TH)**2
          WPI  = DSIN (TH)
          WR   = 1.D0
          WI   = 0.D0
          DO IC = 1, IFPA, IPA
            DO IA = IC, IC + IPA - 2, 2
              DO IB = IA, IPC, IFPB
                KA     = IB
                KB     = KA + IFPA
                SWR    = SNGL (WR)
                SWI    = SNGL (WI)
                XARKB  = XAR(KB)
                IF (ABS (XARKB) < 1.0E-15) XARKB = 0.0
                XARKB1 = XAR(KB + 1)
                IF (ABS (XARKB1) < 1.0E-15) XARKB1 = 0.0
                YKR    = SWR * XARKB  - SWI * XARKB1
                YKI    = SWR * XARKB1 + SWI * XARKB
                XAR(KB)     = XAR(KA)     - YKR
                XAR(KB + 1) = XAR(KA + 1) - YKI
                XAR(KA)     = XAR(KA)     + YKR
                XAR(KA + 1) = XAR(KA + 1) + YKI
              END DO
            END DO
            WYK = WR
            WR  = WR * WPR - WI  * WPI + WR
            WI  = WI * WPR + WYK * WPI + WI
          END DO
          IFPA = IFPB
          GO TO 20
        END IF
        NPRV = N * NPRV
      END DO
      RETURN
      END SUBROUTINE GEN028
 
      SUBROUTINE GEN029 (A, VAL, VECTOR, M, IA, IV, W)
C * EWEV1
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: K
      INTEGER                :: L
      INTEGER                :: M
      INTEGER                :: I1
      INTEGER                :: M1
      INTEGER                :: II
      INTEGER                :: IA
      INTEGER                :: IV
      REAL                   :: PP
      REAL, DIMENSION(IA, M) :: A
      REAL, DIMENSION(*)     :: W
      REAL, DIMENSION(M)     :: VAL
      REAL, DIMENSION(IV, M) :: VECTOR
C * THE FOLLOWING ROUTINES ARE FROM THE HARWELL SUBROUTINE LIBRARY
C * Given a real mXm symmetric matrix A = {aij} this routine finds all its
C * eigenvalues (lambda)i i=1,2,.....,m and eigenvectors xj i=1,2,...,m.
C * i.e. finds the non-trivial solutions of Ax=(lambda)x
C * Argument list: SUBROUTINE GEN029(A, VAL, X, M, IA, IX, W)
C * Arguments set by the user -
C * A  is a REAL 2-dimensional array with first dimension IA. The user must
C *    store the lower triangle of matrix A into the lower triangle of the
C *    array A. i.e. put a(ij) into A(I,J) for i>=j and I>=J.
C * M  is an INTEGER and should be set to the order m of the matrix
C * IA is an INTEGER set to the first dimension of the array A, i.e. if the
C *    allocation for the array A was specified by
C *           DIMENSION A(100,50)
C *    then IA would be set to 100
C * IX is an INTEGER set to the first dimension of the 2-dimensional array X
C * Arguments set by the routine -
C * A  the space above the diagonal of the array A is used by the routine as
C *    work space, the lower triangle set by the user will remain unchanged
C *    on return.
C * VALUE is a REAL array in which the routine puts the eigenvalues  (lambda)
C *    i=1,2,...,m. These are not necessarily in any order.
C * X  is a REAL 2-dimensional array, with first dimension IX, containing the
C *   eigenvectors. The components of the eigenvector x(i) corresponding to the
C *   eigenvalue (lambda)i (in VALUE(I)) are placed in X(J,I) J=1,2,...,M.
C *    The eigenvectors are normalized so that xT(i)x(i)=1 i=1,2,...,m.
C * W  is a REAL array used by the routine for work space. It must have
C *   dimension at least 5*M.
      M1   = M + 1
      W(1) = A(1, 1)
      IF (M == 2) THEN
        W(2) = A(2, 2)
        W(4) = A(2, 1)
      ELSE IF (M > 2) THEN
        CALL GEN030 (A, W, W(M1), M, IA, W(M + M1))
      END IF
      CALL GEN031 (W, W(M1), VAL, VECTOR, M, IV, W(M + M1))
      IF (M > 2) THEN
        DO L = 1, M
          DO II = 3, M
            I = M - II + 1
            IF (W(M1 + I) /= 0.0) THEN
              PP = 0.0
              I1 = I + 1
              DO K = I1, M
                PP = PP + A(I, K) * VECTOR(K, L)
              END DO
              PP = PP / (A(I, I + 1) * W(M1 + I))
              DO K = I1, M
                VECTOR(K, L) = VECTOR(K, L) + PP * A(I, K)
              END DO
            END IF
          END DO
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN029
 
      SUBROUTINE GEN030 (A, ALPHA, BETA, M, IA, Q)
C * EWEV2
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: J
      INTEGER                :: M
      INTEGER                :: I1
      INTEGER                :: I2
      INTEGER                :: J1
      INTEGER                :: M2
      INTEGER                :: IA
      INTEGER                :: KI
      INTEGER                :: KJ
      REAL                   :: H
      REAL                   :: PP
      REAL                   :: QJ
      REAL                   :: PP1
      REAL                   :: BIGK
      REAL, DIMENSION(IA, *) :: A
      REAL, DIMENSION(*)     :: ALPHA
      REAL, DIMENSION(*)     :: BETA
      REAL, DIMENSION(*)     :: Q
      ALPHA(1) = A(1, 1)
      DO J = 2, M
        J1 = J - 1
        DO I = 1, J1
          A(I, J) = A(J, I)
        END DO
        ALPHA(J) = A(J, J)
      END DO
      M2 = M - 2
      DO I = 1, M2
        PP = 0.0
        I1 = I + 1
        DO J = I1, M
          PP = PP + A(I, J)**2
        END DO
        PP1 = SQRT (PP)
        IF (A(I, I + 1) >= 0.0) THEN
          BETA(I + 1) = -PP1
        ELSE
          BETA(I + 1) = PP1
        END IF
        IF (PP > 0.0) THEN
          H = PP - BETA(I + 1) * A(I, I + 1)
          A(I, I + 1) = A(I, I + 1) - BETA(I + 1)
          DO KI = I1, M
            QJ = 0.0
            DO KJ = I1, KI
              QJ = QJ + A(KJ, KI) * A(I, KJ)
            END DO
            IF(KI < M) THEN
              I2 = KI + 1
              DO KJ = I2, M
                QJ = QJ + A(KI, KJ) * A(I, KJ)
              END DO
            END IF
            Q(KI) = QJ / H
          END DO
          BIGK = 0.0
          DO KJ = I1, M
            BIGK = BIGK + A(I, KJ) * Q(KJ)
          END DO
          BIGK = BIGK / (2.0 * H)
          DO KJ = I1, M
            Q(KJ) = Q(KJ) - BIGK * A(I, KJ)
          END DO
          DO KI = I1, M
            DO KJ = KI, M
              A(KI, KJ) = A(KI, KJ) - Q(KI) * A(I, KJ)
     1                  - Q(KJ) * A(I, KI)
            END DO
          END DO
        END IF
      END DO
      DO I = 2, M
        H = ALPHA(I)
        ALPHA(I) = A(I, I)
        A(I, I)  = H
      END DO
      BETA(M) = A(M - 1, M)
      RETURN
      END SUBROUTINE GEN030
 
      SUBROUTINE GEN031 (A, B, VAL, VEC, M, IV, W)
C * EWEV3
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: J1
      INTEGER            :: J2
      INTEGER            :: N1
      INTEGER            :: N2
      INTEGER            :: II
      INTEGER            :: IV
      INTEGER            :: JI
      INTEGER            :: JK
      INTEGER            :: ITER
      INTEGER            :: N2M1
      REAL               :: S
      REAL               :: SI
      REAL               :: CO
      REAL               :: XX
      REAL               :: V1
      REAL               :: V2
      REAL               :: A11
      REAL               :: A12
      REAL               :: A13
      REAL               :: A21
      REAL               :: A22
      REAL               :: A23
      REAL               :: A33
      REAL               :: A34 = 0.0
      REAL               :: EPS = 1E-5
      REAL               :: XAX
      REAL               :: ROOT
      REAL, DIMENSION(M) :: A
      REAL, DIMENSION(M) :: B
      REAL, DIMENSION(M) :: VAL
      REAL, DIMENSION(*) :: VEC
      REAL, DIMENSION(*) :: W
C * THIS USES QR ITERATION TO FIND THE EIGENVALUES AND EIGENVECTORS
C * OF THE SYMMETRIC TRIDIAGONAL MATRIX WHOSE DIAGONAL ELEMENTS ARE
C * A(I),I=1,M AND OFF-DIAGONAL ELEMENTS ARE B(I),I=2,M.  THE ARRAY
C * W IS USED FOR WORKSPACE AND MUST HAVE DIMENSION AT LEAST 2*M.
C * WE TREAT VEC AS IF IT HAD DIMENSIONS (IV,M).
      CALL GEN032 (A, B, W(M + 1), M, W)
C * SET VEC TO THE IDENTITY MATRIX.
      DO I = 1, M
        VAL(I) = A(I)
        W(I) = B(I)
        K = (I - 1) * IV + 1
        L = K + M - 1
        DO J = K, L
          VEC(J) = 0.0
        END DO
        VEC(K + I - 1) = 1.0
      END DO
      ITER = 0
      IF (M /= 1) THEN
        N2 = M
C * EACH QR ITERATION IS PERFORMED OF ROWS AND COLUMNS N1 TO N2
   10   DO II = 2, N2
          N1 = 2 + N2 - II
          IF (ABS (W(N1)) <= (ABS (VAL(N1 - 1))
     1              + ABS (VAL(N1))) * EPS) GO TO 20
        END DO
        N1 = 1
   20   IF (N2 == N1) THEN
          N2 = N2 - 1
          IF (N2 <= 1) THEN
            GO TO 30
          ELSE
            GO TO 10
          END IF
        END IF
        ROOT = W(M + N2)
        ITER = ITER + 1
        N2M1 = N2 - 1
        A22  = VAL(N1)
        A12  = A22 - ROOT
        A23  = W(N1 + 1)
        A13  = A23
        DO I = N1, N2M1
          A33 = VAL(I + 1)
          IF (I /= N2M1) A34 = W(I + 2)
          S = SIGN (SQRT (A12 * A12 + A13 * A13), A12)
          SI = A13 / S
          CO = A12 / S
          JK = I * IV + 1
          J1 = JK - IV
          J2 = J1 + MIN0 (M, I + ITER) - 1
          DO JI = J1, J2
            V1 = VEC(JI)
            V2 = VEC(JK)
            VEC(JI) = V1 * CO + V2 * SI
            VEC(JK) = V2 * CO - V1 * SI
            JK = JK + 1
          END DO
          IF (I /= N1) W(I) = S
          A11 = CO * A22 + SI * A23
          A12 = CO * A23 + SI * A33
          A13 = SI * A34
          A21 = CO * A23 - SI * A22
          A22 = CO * A33 - SI * A23
          A23 = CO * A34
          VAL(I) = A11 * CO + A12 * SI
          A12 = - A11 * SI + A12 * CO
          W(I + 1) = A12
          A22 = A22 * CO - A21 * SI
        END DO
        VAL(N2) = A22
        GO TO 10
C * RAYLEIGH QUOTIENT
   30   DO J = 1, M
          K = (J - 1) * IV
          XX = VEC(K + 1)**2
          XAX = XX * A(1)
          DO I = 2, M
            XX = XX + VEC(K + I)**2
            XAX = XAX + VEC(K + I) * (2.0 * B(I) * VEC(K + I - 1)
     1          + A(I) * VEC(K + I))
          END DO
          VAL(J) = XAX / XX
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN031
 
      SUBROUTINE GEN032 (A, B, VAL, M, OFF)
C * EWEV4
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: M
      INTEGER            :: II
      INTEGER            :: N1
      INTEGER            :: N2
      INTEGER            :: N2M1
      REAL               :: S
      REAL               :: A11
      REAL               :: A12
      REAL               :: A13
      REAL               :: A21
      REAL               :: A22
      REAL               :: A23
      REAL               :: A33
      REAL               :: A34 = 0.0
      REAL               :: SI
      REAL               :: CO
      REAL               :: BB
      REAL               :: CC
      REAL               :: EPS = 0.6E-7
      REAL               :: SBB
      REAL               :: ROOT
      REAL, DIMENSION(M) :: A
      REAL, DIMENSION(M) :: B
      REAL, DIMENSION(M) :: VAL
      REAL, DIMENSION(M) :: OFF
      VAL(1) = A(1)
      IF (M == 1) RETURN
      DO I = 2, M
        VAL(I) = A(I)
        OFF(I) = B(I)
      END DO
C * EACH QR ITERATION IS PERFORMED OF ROWS AND COLUMNS N1 TO N2
      N2 = M
   10 IF (N2 > 1) THEN
        DO II = 2, N2
          N1 = 2 + N2 - II
          IF (ABS (OFF(N1)) <= (ABS (VAL(N1 - 1))
     1      + ABS (VAL(N1))) * EPS) GO TO 20
        END DO
        N1 = 1
   20   IF (N2 == N1) THEN
          N2 = N2 - 1
          GO TO 10
        END IF
C * ROOT IS THE EIGENVALUE OF THE BOTTOM 2*2 MATRIX THAT IS NEAREST
C * TO THE LAST MATRIX ELEMENT AND IS USED TO ACCELERATE THE CONVERGENCE
        BB  = (VAL(N2) - VAL(N2 - 1)) * 0.5
        CC  = OFF(N2) * OFF(N2)
        SBB = 1.0
        IF (BB < 0.0) SBB = -1.0
        ROOT = VAL(N2) + CC / (BB + SBB * SQRT (BB * BB + CC))
        N2M1 = N2 - 1
        A22  = VAL(N1)
        A12  = A22 - ROOT
        A23  = OFF(N1 + 1)
        A13  = A23
        DO I = N1, N2M1
          A33 = VAL(I + 1)
          IF (I /= N2M1) A34 = OFF(I + 2)
          S = SQRT (A12 * A12 + A13 * A13)
          SI = A13 / S
          CO = A12 / S
          IF (I /= N1) OFF(I) = S
          A11 = CO * A22 + SI * A23
          A12 = CO * A23 + SI * A33
          A13 = SI * A34
          A21 = CO * A23 - SI * A22
          A22 = CO * A33 - SI * A23
          A23 = CO * A34
          VAL(I) = A11 * CO + A12 * SI
          A12 = - A11 * SI + A12 * CO
          OFF(I + 1) = A12
          A22 = A22 * CO - A21 * SI
        END DO
        VAL(N2) = A22
        GO TO 10
      END IF
      RETURN
      END SUBROUTINE GEN032
 
      SUBROUTINE GEN033 (IA, IB, NB, NE)
C * REARRANGE VALUES IN ARRAY IB BASED ON ORDERING ARRAY IA (ASCENDING)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: NB
      INTEGER               :: NE
      INTEGER               :: ND
      INTEGER               :: NY
      INTEGER               :: NZ
      INTEGER, DIMENSION(*) :: IA
      INTEGER, DIMENSION(*) :: IB
      N = NE - NB + 1
      IF (N > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (N)) / ALOG (2.0)) + 1.0e-5)) -1
        DO WHILE (ND > 0)
          I  = NB
          DO
            J  = I
            NY = IA(I + ND)
            NZ = IB(I + ND)
            DO WHILE (NY < IA(J))
              IA(J + ND) = IA(J)
              IB(J + ND) = IB(J)
              J          = J - ND
              IF (J < NB) EXIT
            END DO
            IA(J + ND) = NY
            IB(J + ND) = NZ
            I          = I + 1
            IF (I + ND > NE) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN033
 
      SUBROUTINE GEN034 (RA, NB, NE)
C * SORT REAL ARRAY RA ELEMENTS FROM NB TO NE (LARGE TO RMALL)
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: N
      INTEGER            :: NB
      INTEGER            :: NE
      REAL               :: Y
      REAL, DIMENSION(*) :: RA
      N = NE - NB + 1
      IF (N > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (N)) / ALOG (2.0)) + 1.0E-5)) - 1
        DO WHILE (ND > 0)
          I = NB
          DO
            J = I
            Y = RA(I + ND)
            DO WHILE (Y > RA(J))
              RA(J + ND) = RA(J)
              J          = J - ND
              IF (J < NB) EXIT
            END DO
            RA(J + ND) = Y
            I          = I + 1
            IF (I + ND > NE) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN034
 
      SUBROUTINE GEN035 (RA, NB, NE)
C * SORT REAL ARRAY RA ELEMENTS FROM NB TO NE (SMALL TO LARGE)
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: N
      INTEGER            :: NB
      INTEGER            :: NE
      INTEGER            :: ND
      REAL               :: Y
      REAL, DIMENSION(*) :: RA
      N = NE - NB + 1
      IF (N > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (N)) / ALOG (2.0)) + 1.0E-5)) - 1
        DO WHILE (ND > 0)
          I = NB
          DO
            J = I
            Y = RA(I + ND)
            DO WHILE (Y < RA(J))
              RA(J + ND) = RA(J)
              J          = J - ND
              IF (J < NB) EXIT
            END DO
            RA(J + ND) = Y
            I          = I + 1
            IF (I + ND > NE) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN035
 
      SUBROUTINE GEN036 (RA, IA, NB, NE)
C * SORT (REAL, INT)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: NB
      INTEGER               :: NE
      INTEGER               :: ND
      INTEGER               :: NZ
      REAL                  :: NY
      REAL,    DIMENSION(*) :: RA
      INTEGER, DIMENSION(*) :: IA
      N = NE - NB + 1
      IF (N > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (N)) / ALOG (2.0)) + 1.0e-5)) - 1
        DO WHILE (ND > 0)
          I = NB
          DO
            J  = I
            NY = RA(I + ND)
            NZ = IA(I + ND)
            DO WHILE (NY < RA(J))
              RA(J + ND) = RA(J)
              IA(J + ND) = IA(J)
              J          = J - ND
              IF (J < NB) EXIT
            END DO
            RA(J + ND) = NY
            IA(J + ND) = NZ
            I            = I + 1
            IF (I + ND > N) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN036
 
      SUBROUTINE GEN037 (IA, JL, JU)
C * SHEL-SORT ROUTINE: ON FIRST ELEMENT FROM JL TO JU (SMALL TO LARGE)
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: JL
      INTEGER                  :: JU
      INTEGER                  :: JV
      INTEGER                  :: ND
      INTEGER                  :: NX
      INTEGER                  :: NY
      INTEGER, DIMENSION(2, *) :: IA
      JV = JU - JL + 1
      IF (JV > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (JV)) / ALOG (2.0)) + 1.0E-5)) - 1
        DO
          IF (ND <= 0) EXIT
          I  = JL
          DO
            J  = I
            NX = IA(1, I + ND)
            NY = IA(2, I + ND)
   10       IF (NX < IA(1, J)) THEN
              IA(1, J + ND) = IA(1, J)
              IA(2, J + ND) = IA(2, J)
              J             = J - ND
              IF (J >= JL) GO TO 10
            END IF
            IA(1, J + ND) = NX
            IA(2, J + ND) = NY
            I             = I + 1
            IF (I + ND > JU) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN037
 
      SUBROUTINE GEN038 (LINE, LO, LU)
C * BLANK LINE
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: LO
      INTEGER          :: LU
      CHARACTER(len=*) :: LINE
      IF (LO > 0 .AND. LU >= LO) THEN
        DO I = LO, LU
          LINE(I:I) = ' '
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN038
 
      SUBROUTINE GEN039 (MODE, LINE, LB, LE, NB, NE)
C * STRIP HEADER/TRAILER BLANKS
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: K
      INTEGER          :: N
      INTEGER          :: LB
      INTEGER          :: LE
      INTEGER          :: NB
      INTEGER          :: NE
      INTEGER          :: MODE
      CHARACTER(len=*) :: LINE
C * MODE = -1 STRIP HEADER BLANKS,
C * MODE =  1 STRIP TRAILING BLANKS
C * MODE =  0 STRIP HEADER & TRAILING BLANKS
      NB = LB
      NE = LE
      IF (MODE >= 0) THEN
        N = LE - LB + 1
        K = LE + 1
        DO I = 1, N
          K = K - 1
          IF (K > 0) THEN
            IF (LINE(K:K) /= ' ') EXIT
          ELSE
            EXIT
          END IF
        END DO
        NE = K
      END IF
      IF (MODE <= 0) THEN
        N = NE - LB + 1
        K = LB - 1
        DO I = 1, N
          K = K + 1
          IF (LINE(K:K) /= ' ') GO TO 10
        END DO
        K  = K + 1
   10   NB = K
      END IF
      RETURN
      END SUBROUTINE GEN039
 
      SUBROUTINE GEN040 (NR, NQ, IP)
C * CONVERT NUMBER TO STRING
      IMPLICIT NONE
      INTEGER      :: I
      INTEGER      :: J
      INTEGER      :: N
      INTEGER      :: IP
      INTEGER      :: NR
      INTEGER      :: NR1
      INTEGER      :: ISN
      INTEGER      :: ISCR
      CHARACTER(*) :: NQ
      NQ  = '-       '
      NR1 = IABS (NR)
      ISN = 6
      IF (NR < 0) ISN = 5
      N = 1
      DO I = 1, ISN
        N = N * 10
        IF (N > NR1) GO TO 10
      END DO
      I = ISN
   10 IP = I - ISN + 6
      DO J = 1, I
        ISCR = MOD (NR1, 10)
        NQ(IP + 1 - J:IP + 1 - J) = CHAR (ICHAR ('0') + ISCR)
        NR1 = NR1 / 10
      END DO
      RETURN
      END SUBROUTINE GEN040
 
      SUBROUTINE GEN041 (X, SX, ISX, NDCD, NDEC, IRND)
C * ROUND ROUTINE
      IMPLICIT NONE
      INTEGER :: N
      INTEGER :: ISX
      INTEGER :: IXX
      INTEGER :: NDCD
      INTEGER :: NDEC
      INTEGER :: IRND
      INTEGER :: NEXIT
      REAL    :: X
      REAL    :: SX
      REAL    :: SXX
      REAL    :: XM
C * FORMAL PARAMETERS
C * X    = VARIABLE                       (INPUT/OUTPUT)
C * SX   = ESD                            (INPUT/OUTPUT)
C * ISX  = MULTIPLIED ESD                 (OUTPUT)
C * NDCD = DEFAULT NUMBER OF DECIMALS     (INPUT)
C * NDEC = NUMBER OF RELEVANT DECIMALS    (OUTPUT)
C * IRND = (NO)ROUND PARAMETER            (INPUT)
C * IRND = 0 : NO ROUND
C * IRND = 1 : ROUND (1:9)
C * IRND = 2 : ROUND (1:19)
C *        etc
      NDEC  = IABS (NDCD)
      NEXIT = 0
      N     = 0
      IF (SX > 0.0) THEN
        IF (IRND /= 0) THEN
          SXX = SX
          XM  = 1.0
          DO
            IF (N < IABS (NDCD)) THEN
              ISX = INT (SXX * XM + 0.051)
              IF (ISX < IRND) THEN
                XM = XM * 10
                N  = N + 1
                CYCLE
              END IF
            END IF
            IF (NEXIT == 0) EXIT
          END DO
          IXX  = NINT (X * XM + SIGN (0.051, X))
          ISX  = MAX (1, NINT (SXX * XM))
          X    = IXX / XM
          SX   = ISX / XM
          NDEC = N
        ELSE
          ISX = NINT (SX * 10**NDEC)
        END IF
      ELSE
        ISX = 0
        IF (NDCD < 0) THEN
          DO
            IF (ABS (FLOAT (INT (X * 10**N + 0.01)) - X * 10**N)
     1        > 0.1E-6 .AND. N < IABS (NDCD)) THEN
              N = N + 1
              CYCLE
            END IF
            IF (NEXIT == 0) EXIT
          END DO
          NDEC = N
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN041
 
      SUBROUTINE GEN042 (NWRD, A, NUM)
C * GET NUMERICAL VALUE(S) FROM CHARACTER STRING
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: L
      INTEGER            :: M
      INTEGER            :: N
      INTEGER            :: IP
      INTEGER            :: NP
      INTEGER            :: MB = 0
      INTEGER            :: ME = 0
      INTEGER            :: KE
      INTEGER            :: IA2
      INTEGER            :: NUM
      INTEGER            :: IER
      INTEGER            :: IFIN
      INTEGER            :: IFRC
      INTEGER            :: NLET = 0
      INTEGER            :: JPAR = 0
      INTEGER            :: NEXP
      REAL               :: S
      REAL, DIMENSION(2) :: A
      CHARACTER(len=*)   :: NWRD
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=1)   :: JCH
      CHARACTER(len=1)   :: KCH
C * NUM =  1 - Number
C * NUM =  0 - Non-Number
C * NUM = -1 - Default  (? or .)
C * NUM = -2 - Error (overflow)
C * NUM = -3 - Error (Improper Number)
      A(1) = 0.0
      A(2) = 0.0
      IP   = 0
      NP   = 0
      NUM  = 0
      K    = 1
      IFIN = 0
      IFRC = 0
      S    = 1.0
      M    = 0
      IA2  = 0
      NUM  = 0
C * GET NUMBER OF CHARACTERS IN STRING NWRD
      N    = INDEX (NWRD, '''')
      DO I = 2, N - 1
        ICH = NWRD(I:I)
C * CHECK FOR UC ALPHA-CHARACTER
        CALL GEN105 (1, ICH, L)
        IF (L > 0) THEN
C * CHECK FOR FLOATING NUMBER WITH SCIENTIFIC NOTATION
          IF (ICH == 'E') THEN
C * CHECK FOR SINGLE 'E' STRING
            IF (N < 4) THEN
              NUM = 0
              RETURN
            END IF
            NLET = 0
            JPAR = 0
            MB   = 0
            ME   = 0
            DO J = 2, N - 1
              JCH = NWRD(J:J)
C * CHECK FOR 0,1,...,9
              CALL GEN105 (3, JCH, K)
              IF (K < 0) THEN
C * CHECK FOR A,B,...,Z
                CALL GEN105 (1, JCH, K)
                IF (K > 0) THEN
                  NLET = NLET + 1
                  IF (NLET > 1) THEN
                    RETURN
                  ELSE
                    CYCLE
                  END IF
                ELSE IF (JCH == '.') THEN
                  IF (J .EQ. 2) THEN
C * SAVE DECIMAL POINT LOCATION
                    M = J
                    CYCLE
                  ELSE
                    KCH = NWRD(J-1:J-1)
                    IF (KCH == '+' .OR. KCH == '-') THEN
C * GET DECIMAL POINT LOCATION
                      M = J
                      CYCLE
                    END IF
                    CALL GEN105(3, KCH, K)
                    IF (K > 0) THEN
C * GET DECIMAL POINT LOCATION
                      M = J
                      CYCLE
                    ELSE
                      RETURN
                    END IF
                  END IF
                ELSE IF (JCH == '(') THEN
                  IF (J == 2) THEN
                    RETURN
                  ELSE
                    JPAR = 1
C * SAVE BEGIN SU STRING
                    MB   = J
                    CYCLE
                  END IF
                ELSE IF (JCH == ')') THEN
                  IF (JPAR > 0) THEN
C * SAVE END   SU STRING
                    ME = J
                    CYCLE
                  ELSE
                    RETURN
                  END IF
                ELSE IF (JCH == '+') THEN
                  IF (J /= 2) THEN
                    IF (NWRD(J-1:J) /= 'E+') THEN
                      RETURN
                    ELSE
                      CYCLE
                    END IF
                  END IF
                ELSE IF (JCH == '-') THEN
                  IF (J /= 2) THEN
                    IF (NWRD(J-1:J) /= 'E-') THEN
                      RETURN
                    ELSE
                      CYCLE
                    END IF
                  END IF
                ELSE
                  RETURN
                END IF
              END IF
            END DO
C * CHECK FOR SU ()
            K  = 0
C * CHECK BEGIN SU STRING
            IF (MB > 0) THEN
C * CHECK END   SU STRING
              IF (ME > 0) THEN
                IF (ME - MB > 1) THEN
                  READ (NWRD(MB+1:ME-1), *, IOSTAT = IER) IA2
                  IF (IER == 0) THEN
                    K = MB
                    IF (ME < I) THEN
                      DO J = I, N -1
                        NWRD(K:K) = NWRD(J:J)
                        K = K + 1
                      END DO
                      READ (NWRD(MB+1:K-1), *, IOSTAT = IER) NEXP
                      KE = MB - M - 1
                    ELSE
                      READ (NWRD(I+1:MB-1), *, IOSTAT = IER) NEXP
                      KE = I  - M - 1
                    END IF
                    J = N + MB - ME - 2
                    READ (NWRD(1:J), *, IOSTAT = IER) A(1)
                  ELSE
                    NUM = 0
                    RETURN
                  END IF
                END IF
              ELSE
                NUM = 0
                RETURN
              END IF
              A(2) = FLOAT (IA2) * 10.0**(NEXP-KE)
C * NO SU CASE
            ELSE
              READ (NWRD(1:N-1), *, IOSTAT = IER) A(1)
              A(2) = 0.0
            END IF
            IF (IER == 0) THEN
              NUM = 1
              RETURN
            END IF
C * CHARACTER STRING
          ELSE
            NUM = 0
            RETURN
          END IF
        END IF
      END DO
C * NON-SCIENTIFIC NUMBER FORMAT
      DO I = 2, N
        ICH = NWRD(I:I)
        IF (ICH == '''') THEN
          IFIN = 1
        ELSE IF (ICH == '+') THEN
          IF (I == 2) THEN
            S   = 1.0
            NUM = 1
            CYCLE
          ELSE
            NUM  = -3
            RETURN
          END IF
        ELSE IF (ICH == '-') THEN
          IF (I == 2) THEN
            S   = -1.0
            NUM = 1
            CYCLE
          ELSE
            NUM = -3
            RETURN
          END IF
        ELSE IF (ICH == '_') THEN
          IF (NUM == 1) IP = 1
          CYCLE
        ELSE IF (ICH == '.') THEN
          IP  = 1
          IF (NUM == 0) NUM = -1
          CYCLE
        ELSE IF (I == 2 .AND. ICH == '?') THEN
          NUM = -1
          RETURN
        ELSE IF (ICH == '(') THEN
        ELSE IF (ICH == '/') THEN
          IFRC = 1
        ELSE IF (ICH == ')') THEN
          IFIN = 1
        ELSE
          CALL GEN105 (3, ICH, M)
          IF (M >= 0) THEN
            NUM  = 1
            NP   = NP + IP
            IF (K > 0) THEN
              IF (A(K) >= 1.0E37) THEN
                A(1) = 0.0
                A(2) = 0.0
                NUM  = -2
                RETURN
              END IF
            ELSE IF (K == 0) THEN
              A(1) = 0.0
              A(2) = 0.0
              RETURN
            END IF
            A(K) = 10.0 * A(K) + M - 1
          END IF
          CYCLE
        END IF
        A(K) = S * A(K) / 10.0**NP
        IF (IFIN == 1) EXIT
        IP = 0
        S  = 1.0
        K  = 2
      END DO
C * HANDLE FRACTION N/M CASE
      IF (NUM * IFRC /= 0) THEN
        IF (A(1) /= 0.0 .AND. A(2) /=  0.0) THEN
          A(1) = A(1) / A(2)
          A(2) = 0.0
        ELSE
          NUM = 0
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN042
 
      SUBROUTINE GEN043 (MODE, A, ANG)
C * CONVERT X,Y,Z ANGLES TO MATRIX
      IMPLICIT NONE
      INTEGER               :: MODE
      REAL                  :: CA
      REAL                  :: SA
      REAL                  :: ANG
      REAL, DIMENSION(3, 3) :: A
      CA = COS (ANG)
      SA = SIN (ANG)
      CALL GEN074 (A, 1, 9, 0.0)
      IF (MODE == 3) THEN
C * Z ROTN
        A(1, 1) =  CA
        A(1, 2) =  SA
        A(2, 1) = -SA
        A(2, 2) =  CA
        A(3, 3) = 1.0
      ELSE IF (MODE == 2) THEN
C * Y ROTN
        A(1, 1) = CA
        A(1, 3) = -SA
        A(2, 2) = 1.0
        A(3, 1) = SA
        A(3, 3) = CA
C * X ROTN
      ELSE IF (MODE == 1) THEN
        A(1, 1) = 1.0
        A(2, 2) = CA
        A(2, 3) = SA
        A(3, 2) = -SA
        A(3, 3) = CA
      END IF
      RETURN
      END SUBROUTINE GEN043
 
      SUBROUTINE GEN044 (P, R, MODE)
C * GET ORTHOGONALISATION MATRIX R FROM CELL PARAMETERS IN P
      IMPLICIT NONE
      INTEGER               :: MODE
      REAL                  :: RAD
      REAL                  :: CP4RAD
      REAL                  :: CP5RAD
      REAL                  :: CP6RAD
      REAL                  :: SP4RAD
      REAL                  :: SP6RAD
      REAL                  :: UNITVOL
      REAL, DIMENSION(6)    :: P
      REAL, DIMENSION(3, 3) :: R
      IF (MODE > 0) THEN
        RAD     = ATAN2 (1.0, 1.0) / 45.0
        CP4RAD  = COS (P(4) * RAD)
        CP5RAD  = COS (P(5) * RAD)
        CP6RAD  = COS (P(6) * RAD)
      ELSE
        CP4RAD = P(4)
        CP5RAD = P(5)
        CP6RAD = P(6)
      END IF
      SP4RAD  = SQRT (1.0 - CP4RAD**2)
      SP6RAD  = SQRT (1.0 - CP6RAD**2)
      UNITVOL = SQRT (1.0 - CP4RAD**2 - CP5RAD**2 - CP6RAD**2
     1        + 2.0  * CP4RAD * CP5RAD * CP6RAD)
C * x||a, z ||c*, z||y ^ x  (SEE DUNITZ p237)
      IF (IABS (MODE) == 1) THEN
        R(1, 1) = P(1)
        R(1, 2) = P(2) * CP6RAD
        R(1, 3) = P(3) * CP5RAD
        R(2, 1) = 0.0
        R(2, 2) = P(2) * SP6RAD
        R(2, 3) = P(3) * (CP4RAD - CP5RAD * CP6RAD) / SP6RAD
        R(3, 1) = 0.0
        R(3, 2) = 0.0
        R(3, 3) = P(3) * UNITVOL / SP6RAD
C * z||c, x||a*, y||z ^ x  (Hazen & Finger, Comparative Crystal Chemistry)
      ELSE IF (IABS (MODE) == 2) THEN
        R(1, 1) = P(1) * UNITVOL / SP4RAD
        R(1, 2) = 0.0
        R(1, 3) = 0.0
        R(2, 1) = P(1) * (CP6RAD - CP4RAD * CP5RAD) / SP4RAD
        R(2, 2) = P(2) * SP4RAD
        R(2, 3) = 0.0
        R(3, 1) = P(1) * CP5RAD
        R(3, 2) = P(2) * CP4RAD
        R(3, 3) = P(3)
      END IF
      RETURN
      END SUBROUTINE GEN044
 
      REAL FUNCTION GEN045 (C)
C * CALCULATE CELL-VOLUME FROM CELL-PARAMETERS
C * A, B, C, ALF, BET, GAM IN [C(1)--C(6)]
      IMPLICIT NONE
      REAL               :: CA
      REAL               :: CB
      REAL               :: CG
      REAL               :: DTR
      REAL               :: VOL
      REAL, DIMENSION(6) :: C
      DTR = ATAN (1.0) / 45.0
      CA  = COS (C(4) * DTR)
      CB  = COS (C(5) * DTR)
      CG  = COS (C(6) * DTR)
      VOL = (1.0 - CA**2 - CB**2 - CG**2 + 2 * CA * CB * CG)
      IF (VOL < 0.0) STOP 'CELL VOLUME COMPLEX!!'
      GEN045 = C(1) * C(2) * C(3) * SQRT (VOL)
      RETURN
      END FUNCTION GEN045
 
      SUBROUTINE GEN046 (HKLP, X, Y, Z)
C * HKLP  =  (L x 200  +  K) * 200  +  H
      IMPLICIT NONE
      REAL :: X
      REAL :: Y
      REAL :: Z
      REAL :: HKLP
      Z = NINT (HKLP / 40000.0)
      X = (NINT (HKLP) - 40000.0 * Z) / 200.0
      Y = NINT (X)
      X = AINT (201.0 * (X - Y))
      RETURN
      END SUBROUTINE GEN046
 
      SUBROUTINE GEN047 (LINE, N, M)
C * ELIMINATE BLANKS BETWEEN NON-SPACE CHARACTERS FROM STRING LINE
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: N
      INTEGER          :: M
      CHARACTER(len=*) :: LINE
      J = N
      DO I = N, M
        IF (LINE(I:I) /= ' ') THEN
          LINE(J:J) = LINE(I:I)
          J         = J + 1
        END IF
      END DO
      CALL GEN038 (LINE, J, M)
      RETURN
      END SUBROUTINE GEN047
 
      SUBROUTINE GEN048 (IKEY, IFLI, IBIT, IVAL)
C * 'BIT' -MANIPULATION ROUTINE
      IMPLICIT NONE
      INTEGER                :: I
      INTEGER                :: KEY
      INTEGER                :: INH
      INTEGER                :: IFLI
      INTEGER                :: IVAL
      INTEGER                :: IBIT
      INTEGER                :: IKEY
      INTEGER                :: JKEY
      INTEGER                :: JBIT
      INTEGER, DIMENSION(32) :: IBT
      COMMON /NBIT/ IBT
      JKEY = IABS (IKEY)
      IF (JKEY == 1) THEN
        KEY = 2
      ELSE IF (JKEY == 10) THEN
        KEY = 1024
      ELSE IF (JKEY /= 0) THEN
        KEY = 2**JKEY
      ELSE
        DO I = 1, 31
          IBT(I) = 2**(I - 1)
        END DO
        RETURN
      END IF
      JBIT = IBT(IBIT)
      INH  = MOD (IFLI / JBIT, KEY)
      IF (IKEY < 0) THEN
        IVAL  = INH
      ELSE
        IFLI = IFLI + (IVAL - INH) * JBIT
      END IF
      RETURN
      END SUBROUTINE GEN048
 
      REAL FUNCTION GEN049 (LATC, JH, JK, JL)
C * CHECK FOR LATTICE ABSENCE
      IMPLICIT NONE
      INTEGER          :: JH
      INTEGER          :: JK
      INTEGER          :: JL
      REAL             :: S
      CHARACTER(len=1) :: LATC
      S = 1.0
      IF (LATC /= 'P') THEN
        IF (LATC == 'A') THEN
          IF (MOD (JK + JL, 2) /= 0) S = - 1.0
        ELSE IF (LATC == 'B') THEN
          IF (MOD (JH + JL, 2) /= 0) S = - 1.0
        ELSE IF (LATC == 'C') THEN
          IF (MOD (JH + JK, 2) /= 0) S = - 1.0
        ELSE IF (LATC == 'F') THEN
          IF (MOD (JH + JK, 2) /= 0 .OR. MOD (JH + JL, 2) .NE. 0)
     1        S = - 1.0
        ELSE IF (LATC == 'I') THEN
          IF (MOD (JH + JK + JL, 2) /= 0) S = - 1.0
        ELSE IF (LATC == 'R') THEN
          IF (MOD (-JH + JK + JL, 3) /= 0) S = -1.0
        END IF
      END IF
      GEN049 = S
      RETURN
      END FUNCTION GEN049
 
      REAL FUNCTION GEN050 (TM, IH, IK, IL, JH, JK, JL)
C * TRANSFORM & ELIMINATE REFLECTIONS WITH NON-INTEGER INDICES
      IMPLICIT NONE
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      INTEGER               :: JH
      INTEGER               :: JK
      INTEGER               :: JL
      REAL                  :: XH
      REAL                  :: XK
      REAL                  :: XL
      REAL, DIMENSION(3, 3) :: TM
      XH = TM(1, 1) * IH + TM(1, 2) * IK + TM(1, 3) * IL
      XK = TM(2, 1) * IH + TM(2, 2) * IK + TM(2, 3) * IL
      XL = TM(3, 1) * IH + TM(3, 2) * IK + TM(3, 3) * IL
      JH = NINT (XH)
      JK = NINT (XK)
      JL = NINT (XL)
      GEN050 = -1.0
      IF (ABS (XH - JH) < 0.01) THEN
        IF (ABS (XK - JK) < 0.01) THEN
          IF (ABS (XL - JL) < 0.01) THEN
            GEN050 = 1.0
          END IF
        END IF
      END IF
      RETURN
      END FUNCTION GEN050
 
      SUBROUTINE GEN051 (MODE, RV, X, L)
C * CONSTRUCT RMAT FROM ROTX, ROTY, ROTZ
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: MODE
      REAL                  :: X
      REAL, DIMENSION(3, 3) :: RM
      REAL, DIMENSION(3, 3) :: TM
      REAL, DIMENSION(3, 3) :: RV
C * MODE = 0 :GENERATE RMAT FROM ROTX, ROTY, ROTZ
C * MODE = 1  PREMULTIPLY WITH RM
      K        = MOD (L + 2, 3) + 1
      I        = MOD (K, 3) + 1
      J        = MOD (I, 3) + 1
      RM(I, I) = COS (X)
      RM(I, J) = SIN (X)
      RM(I, K) = 0.0
      RM(J, I) = -SIN (X)
      RM(J, J) = COS (X)
      RM(J, K) = 0.0
      RM(K, I) = 0.0
      RM(K, J) = 0.0
      RM(K, K) = 1.0
      IF (MODE == 0) THEN
        CALL GEN004 (RV, RM, TM)
      ELSE IF (MODE == 1) THEN
        CALL GEN004 (RM, RV, TM)
      END IF
C * COPY
      CALL GEN052 (TM, RV)
      RETURN
      END SUBROUTINE GEN051
 
      SUBROUTINE GEN052 (A, B)
C * COPY 3x3 MATRIX
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3, 3) :: B
      DO I = 1, 3
        DO J = 1, 3
          B(I, J) = A(I, J)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN052
 
      SUBROUTINE GEN053 (N, DATAX, INDY)
C * HEAP SORT
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: N
      INTEGER               :: INEXT
      INTEGER, DIMENSION(N) :: INDY
      REAL                  :: T
      REAL,    DIMENSION(N) :: DATAX
C * INDEXES THE ARRAY DATA(N) AND RETURNS THE ARRAY INDY(N) SORTED SUCH
C * THAT THE VALUES DATA(INDY(I)) ARE IN ASCENDING ORDER FOR I = 1, 2,
C * ..., N.  THE INPUT VARIABLES N AND DATA(N) ARE NOT CHANGED.
C * EMPLOYS THE "HEAPSORT" ALGORITHM.
      DO I = 1, N
        INDY(I) = I
      END DO
      IF (N > 1) THEN
        I = N / 2 + 1
        J = N
        DO
          IF (I > 1) THEN
            I     = I - 1
            INEXT = INDY(I)
            T     = DATAX(INEXT)
          ELSE
            INEXT   = INDY(J)
            T       = DATAX(INEXT)
            INDY(J) = INDY(1)
            J       = J - 1
            IF (J == 1) THEN
              INDY(1) = INEXT
              RETURN
            END IF
          END IF
          K = I
          L = 2 * I
   10     IF (L <= J) THEN
            IF (L < J) THEN
              IF (DATAX(INDY(L)) < DATAX(INDY(L + 1))) L = L + 1
            END IF
            IF (T < DATAX(INDY(L))) THEN
              INDY(K) = INDY(L)
              K = L
              L = 2 * L
            ELSE
              L = J + 1
            END IF
            GO TO 10
          END IF
          INDY(K) = INEXT
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN053
 
      SUBROUTINE GEN054 (N, M, A, U, V)
C * JOCOBI - DOUBLE PRECISION
C * EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC MATRIX A OF LOGICAL
C * SIZE A(N,N) STORED IN AN ARRAY OF PHYSICAL SIZE A(M,M), WHERE M >= N.
C * ON OUTPUT:
C * (1) ELEMENTS OF A ABOVE THE DIAGONAL ARE DESTROYED.
C * (2) THE ARRAY U(M) RETURNS THE EIGENVALUES OF A(N,N) IN ITS FIRST N
C *     ELEMENTS.
C * (3) THE COLUMNS OF THE MATRIX V(N,N), STORED IN THE ARRAY V(M,M),
C *    CONTAIN THE EIGENVECTORS OF A.
      IMPLICIT NONE
      INTEGER, PARAMETER                :: NMAX = 999
      INTEGER                           :: I
      INTEGER                           :: J
      INTEGER                           :: K
      INTEGER                           :: N
      INTEGER                           :: M
      INTEGER                           :: NCYCLE
      DOUBLE PRECISION                  :: T
      DOUBLE PRECISION                  :: E
      DOUBLE PRECISION                  :: C
      DOUBLE PRECISION                  :: S
      DOUBLE PRECISION                  :: P
      DOUBLE PRECISION                  :: Q
      DOUBLE PRECISION                  :: AII
      DOUBLE PRECISION                  :: AJJ
      DOUBLE PRECISION                  :: TAU
      DOUBLE PRECISION                  :: THETA
      DOUBLE PRECISION                  :: THRESH
      DOUBLE PRECISION, DIMENSION(M, M) :: A
      DOUBLE PRECISION, DIMENSION(M, M) :: V
      DOUBLE PRECISION, DIMENSION(M)    :: U
      DOUBLE PRECISION, DIMENSION(NMAX) :: B
      DOUBLE PRECISION, DIMENSION(NMAX) :: Z
C * INITIALIZE EIGENVECTORS MATRIX TO AN IDENTITY MATRIX.
      DO I = 1, N
        DO J = 1, N
          V(I, J) = 0
        END DO
        V(I, I) = 1
      END DO
C * INITIALIZE EIGENVALUES U AND WORK VECTOR B TO A(I,I) AND ZERO WORK
C * VECTOR Z.
      DO I = 1, N
        T    = A(I, I)
        U(I) = T
        B(I) = T
        Z(I) = 0
      END DO
C * PERFORM UP TO 50 ITERATIONS OF UP TO N*(N - 1)/2 JACOBI ROTATIONS.
      DO NCYCLE = 1, 50
C * TEST FOR NORMAL RETURN WHEN MAXIMUM MAGNITUDE OF AN OFF-DIAGONAL
C * ELEMENT EQUALS ZERO TO MACHINE PRECISION.  THE TEST PRESUMES THAT
C * ARITHMETIC UNDERFLOW VALUES ARE SET TO ZERO.
        T = 0
        DO I = 1, N - 1
          DO J = I + 1, N
            T = T + ABS (A(I, J))
          END DO
        END DO
        IF (T == 0.0) RETURN
C * SET OFF-DIAGONAL THRESHOLD.
        IF (NCYCLE < 4) THEN
          THRESH = T / (5 * N**2)
        ELSE
          THRESH = 0
        END IF
C * ROTATE TO ANNIHILATE OFF-DIAGONAL ELEMENTS.
        DO I = 1, N - 1
          DO J = I + 1, N
            T   = ABS (A(I, J))
            E   = 100 * T
            AII = ABS (U(I))
            AJJ = ABS (U(J))
            IF (NCYCLE > 4 .AND. AII + E == AII .AND.
     1                              AJJ + E == AJJ) THEN
C * AFTER FOUR CYCLES, SKIP THE ROTATION IF ABS(A(I,J)) IS SMALL COMPARED
C * TO BOTH ABS(A(I,I)) AND ABS(A(J,J)).
              A(I, J) = 0
            ELSE IF (T > THRESH) THEN
              T = ABS (AJJ - AII)
              IF (T + E == T) THEN
C * EFFECTIVELY, SET T = 1/(2*THETA)
                T = A(I, J) / (AJJ - AII)
              ELSE
                THETA = (AJJ - AII) / (2 * A(I, J))
                T     = 1 / (ABS (THETA) + SQRT (1 + THETA**2))
                IF (THETA < 0) T = -T
              END IF
              C   = 1 / SQRT (1 + T**2)
              S   = T * C
              TAU = S / (1 + C)
C * ADJUST EIGENVALUES U AND WORK VECTOR Z.
              E       = T * A(I, J)
              Z(I)    = Z(I) - E
              Z(J)    = Z(J) + E
              U(I)    = U(I) - E
              U(J)    = U(J) + E
              A(I, J) = 0
C * ROTATIONS  1 <= K < I.
              DO K = 1, I - 1
                P       = A(K, I)
                Q       = A(K, J)
                A(K, I) = P - S * (Q + P * TAU)
                A(K, J) = Q + S * (P - Q * TAU)
              END DO
C * ROTATIONS  I < K < J.
              DO K = I + 1, J - 1
                P       = A(I, K)
                Q       = A(K, J)
                A(I, K) = P - S * (Q + P * TAU)
                A(K, J) = Q + S * (P - Q * TAU)
              END DO
C * ROTATIONS  J < K <= N.
              DO K = J + 1, N
                P       = A(I, K)
                Q       = A(J, K)
                A(I, K) = P - S * (Q + P * TAU)
                A(J, K) = Q + S * (P - Q * TAU)
              END DO
C * COMPUTE AND STORE EIGENVECTORS.
              DO K = 1, N
                P       = V(K, I)
                Q       = V(K, J)
                V(K, I) = P - S * (Q + P * TAU)
                V(K, J) = Q + S * (P - Q * TAU)
              END DO
            END IF
          END DO
        END DO
C * ADJUST EIGENVALUES AND WORK VECTORS.
        DO I = 1, N
          B(I) = B(I) + Z(I)
          U(I) = B(I)
          Z(I) = 0
        END DO
      END DO
      STOP '50 CYCLES OF JACOBI ROTATIONS SHOULD NEVER BE NECESSARY.'
      END SUBROUTINE GEN054
 
      SUBROUTINE GEN055 (YLM, XYZ, L0MAX, L1MAX)
C * YLM : UN-NORMALIZED REAL SPHERICAL HARMONIC FUNCTIONS
C *  A. PATURLE AND P. COPPENS (1988).  ACTA CRYST. A44, 6-7.
C *  SCALE AND NORMALIZATION FACTORS FOR REAL SPHERICAL HARMONIC FUNCTIONS
C *  C(L,ABS(M)), N(L,ABS(M)); L=0,1,2,...,LMAX; ABS(M)=0,1,2,...,L.
C *  THE C(L,ABS(M)) SCALE THE CARTESIAN YLM(X,Y,Z) TO GIVE THE ASSOCIATED
C *  LEGENDRE FUNCTIONS P(L,M)(COS(THETA))*COS,SIN(M*PHI).
C *  THE N(L,ABS(M)) NORMALIZE TO 2 - DELTA(0,L).
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: L
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: IP
      INTEGER               :: LMAX
      INTEGER               :: L0MAX
      INTEGER               :: L1MAX
      REAL                  :: X
      REAL                  :: Y
      REAL                  :: Z
      REAL                  :: F
      REAL                  :: Q
      REAL                  :: XK
      REAL                  :: YK
      REAL                  :: ZK
      REAL                  :: XQ
      REAL                  :: YQ
      REAL                  :: ZQ
      REAL                  :: XV
      REAL                  :: YV
      REAL                  :: ZV
      REAL                  :: XP
      REAL                  :: YP
      REAL                  :: ZP
      REAL                  :: XS
      REAL                  :: YS
      REAL                  :: ZS
      REAL, DIMENSION(3)    :: XYZ
      REAL, DIMENSION(80)   :: YLM
      REAL, DIMENSION(0:44) :: FCLM = (/
     1 1.0, 1.0, 1.0, 0.5, 3.0, 3.0, 0.5, 1.5, 15.0, 15.0, 0.125, 2.5,
     2 7.5, 105.0, 105.0, 0.125, 1.875, 52.5, 52.5, 945.0, 945.0,
     3 0.0625, 2.625, 13.125, 157.5, 472.5, 10395.0, 10395.0, 0.0625,
     4 0.4375, 7.875, 39.375, 1732.5, 5197.5, 135135.0, 135135.0,
     5 0.0078125, 0.5625, 19.6875, 433.125, 1299.375, 67567.5, 67567.5,
     6 2027025.0, 2027025.0/)
      REAL, DIMENSION(0:44) :: FNLM = (/
     1 0.0795774, 0.3183099, 0.3183099, 0.2067483, 0.7500000, 0.3750000,
     2 0.2448538, 0.3203331, 1.0000000, 0.4244132, 0.0694175, 0.4740025,
     3 0.3305913, 1.2500000, 0.4687500, 0.0767395, 0.3229812, 1.6875000,
     4 0.3451455, 1.5000000, 0.5092958, 0.0417084, 0.4172129, 0.3261107,
     5 0.6513219, 0.3610405, 1.7500000, 0.5468750, 0.0447979, 0.0648780,
     6 0.1573192, 0.1109240, 0.7404370, 0.3772319, 2.0000000, 0.5820523,
     7 0.0059609, 0.0784858, 0.3253786, 0.8780415, 0.3411683, 2.4892756,
     8 0.3933012, 2.2500000, 0.6152344/)
      CALL GEN074 (YLM, 1, 80, 0.0)
C * MONOPOLE:  L = M = 0.
      IF (L0MAX == 0 .AND. L1MAX == 0) RETURN
      X  = XYZ(1)
      Y  = XYZ(2)
      Z  = XYZ(3)
      XK = X ** 2
      YK = Y ** 2
      ZK = Z ** 2
      XQ = X ** 3
      YQ = Y ** 3
      ZQ = Z ** 3
      XV = X ** 4
      YV = Y ** 4
      ZV = Z ** 4
      XP = X ** 5
      YP = Y ** 5
      ZP = Z ** 5
      XS = X ** 6
      YS = Y ** 6
      ZS = Z ** 6
 
C * DIPOLES:  L = 1; M = 0, +1, -1.
      IF (L1MAX >= 1) THEN
        YLM(1) = Z
        YLM(2) = X
        YLM(3) = Y
      END IF
C * QUADRUPOLES:  L = 2; M = 0, +1, -1, +2, -2.
      IF (L0MAX >= 2) THEN
        YLM(4) = 3 * ZK - 1
        YLM(5) = Z * X
        YLM(6) = Z * Y
        YLM(7) = XK - YK
        YLM(8) = 2 * X * Y
      END IF
C * OCTUPOLES:  L = 3; M = 0, +1, -1, +2, -2, +3, -3.
      IF (L1MAX >= 3) THEN
        YLM(9)  = 5 * ZQ - 3 * Z
        Q       = 5 * ZK - 1
        YLM(10) = Q * X
        YLM(11) = Q * Y
        YLM(12) = Z * (XK - YK)
        YLM(13) = 2 * X * Y * Z
        YLM(14) = XQ - 3 * X * YK
        YLM(15) = 3 * XK * Y - YQ
      END IF
C * HEXADECAPOLES:  L = 4; M = 0, +1, -1, +2, -2, +3, -3, +4, -4.
      IF (L0MAX >= 4) THEN
        YLM(16) = 35 * ZV - 30 * ZK + 3
        Q       = 7 * ZQ - 3 * Z
        YLM(17) = Q * X
        YLM(18) = Q * Y
        YLM(19) = (7 * ZK - 1) * (XK - YK)
        YLM(20) = 2 * X * Y * (7 * ZK - 1)
        YLM(21) = Z * (XQ - 3 * X * YK)
        YLM(22) = Z * (3 * XK * Y - YQ)
        YLM(23) = XV - 6 * XK * YK + YV
        YLM(24) = 4 * XQ * Y - 4 * X * YQ
      END IF
C * 2**5 = 32-POLES:  L = 5; M = 0, +1, -1, +2, -2,..., +5, -5.
      IF (L1MAX >= 5) THEN
        YLM(25) = 63 * ZP - 70 * ZQ + 15 * Z
        Q       = 21 * ZV - 14 * ZK + 1
        YLM(26) = Q * X
        YLM(27) = Q * Y
        YLM(28) = (3 * ZQ - Z) * (XK - YK)
        YLM(29) = 2 * X * Y * (3 * ZQ - Z)
        YLM(30) = (9 * ZK - 1) * (XQ - 3 * X * YK)
        YLM(31) = (9 * ZK - 1) * (3 * XK * Y - YQ)
        YLM(32) = Z * (XV - 6 * XK * YK + YV)
        YLM(33) = Z * (4 * XQ * Y - 4 * X * YQ)
        YLM(34) = XP - 10 * XQ * YK + 5 * X * YV
        YLM(35) = 5 * XV * Y - 10 * XK * YQ + YP
      END IF
C * 2**6 = 64-POLES:  L = 6; M = 0, +1, -1, +2, -2,..., +6, -6.
      IF (L0MAX >= 6) THEN
        YLM(36) = 231 * ZS - 315 * ZV + 105 * ZK - 5
        Q       = 33 * ZP - 30 * ZQ + 5 * Z
        YLM(37) = Q * X
        YLM(38) = Q * Y
        YLM(39) = (33 * ZV - 18 * ZK + 1) * (XK - YK)
        YLM(40) = 2 * X * Y * (33 * ZV - 18 * ZK + 1)
        Q       = 11 * ZQ - 3 * Z
        YLM(41) = Q * (XQ - 3 * X * YK)
        YLM(42) = Q * (3 * XK * Y - YQ)
        YLM(43) = (11 * ZK - 1) * (XV - 6 * XK * YK + YV)
        YLM(44) = (11 * ZK - 1) * (4 * XQ * Y - 4 * X * YQ)
        YLM(45) = Z * (XP - 10 * XQ * YK + 5 * X * YV)
        YLM(46) = Z * (5 * XV * Y - 10 * XK * YQ + YP)
        YLM(47) = XS - 15 * XV * YK + 15 * XK * YV - YS
        YLM(48) = 6 * XP * Y - 20 * XQ * YQ + 6 * X * YP
      END IF
C * 2**7 = 128-POLES:  L = 7; M = 0, +1, -1, +2, -2,..., +7, -7.
      IF (L1MAX >= 7) THEN
        YLM(49) = 429 * Z**7 - 639 * ZP + 315 * ZQ - 35 * Z
        Q       = 429 * ZS - 495 * ZV + 135 * ZK - 5
        YLM(50) = Q * X
        YLM(51) = Q * Y
        YLM(52) = (143 * ZP - 110 * ZQ + 15 * Z) * (XK - YK)
        YLM(53) = 2 * X * Y * (143 * ZP - 110 * ZQ + 15 * Z)
        Q       = 143 * ZV - 66 * ZK + 3
        YLM(54) = Q * (XQ - 3 * X * YK)
        YLM(55) = Q * (3 * XK * Y - YQ)
        Q       = 13 * ZQ - 3 * Z
        YLM(56) = Q * (XV - 6 * XK * YK + YV)
        YLM(57) = Q * (4 * XQ * Y - 4 * X * YQ)
        YLM(58) = (13 * ZK - 1) * (XP - 10 * XQ * YK + 5 * X * YV)
        YLM(59) = (13 * ZK - 1) * (5 * XV * Y - 10 * XK * YQ + YP)
        YLM(60) = Z * (XS - 15 * XV * YK + 15 * XK * YV - YS)
        YLM(61) = Z * (6 * XP * Y - 20 * XQ * YQ + 6 * X * YP)
        YLM(62) = X**7 - 21 * XP * YK + 35 * XQ * YV - 7 * X * YS
        YLM(63) = 7 * XS * Y - 35 * XV * YQ + 21 * XK * YP - Y**7
      END IF
C * 2**8 = 256-POLES:  L = 8; M = 0, +1, -1, +2, -2,..., +8, -8.
      IF (L0MAX >= 8) THEN
        YLM(64) = 6435 * Z**8 - 12012 * ZS + 6930 * ZV - 1260 * ZK
     1          + 35
        Q       = 715 * Z**7 - 1001 * ZP + 385 * ZQ - 35 * Z
        YLM(65) = Q * X
        YLM(66) = Q * Y
        Q       = 143 * ZS - 143 * ZV + 33 * ZK - 1
        YLM(67) = Q * (XK - YK)
        YLM(68) = Q * 2 * X * Y
        Q       = 39 * ZP - 26 * ZQ + 3 * Z
        YLM(69) = Q * (XQ - 3 * X * YK)
        YLM(70) = Q * (3 * XK * Y - YQ)
        Q       = 65 * ZV - 26 * ZK + 1
        YLM(71) = Q * (XV - 6 * XK * YK + YV)
        YLM(72) = Q * (4 * XQ * Y - 4 * X * YQ)
        Q       = 5 * ZQ - Z
        YLM(73) = Q * (XP - 10 * XQ * YK + 5 * X * YV)
        YLM(74) = Q * (5 * XV * Y - 10 * XK * YQ + YP)
        Q       = 15 * ZK - 1
        YLM(75) = Q * (XS - 15 * XV * YK + 15 * XK * YV - YS)
        YLM(76) = Q * (6 * XP * Y - 20 * XQ * YQ + 6 * X * YP)
        YLM(77) = Z * (X**7 - 21 * XP * YK + 35 * XQ * YV
     1          - 7 * X * YS)
        YLM(78) = Z * (7 * XS * Y - 35 * XV * YQ + 21 * XK * YP - Y**7)
        YLM(79) = X**8 - 28 * XS * YK + 70 * XV * YV
     1          - 28 * XK * YS + Y**8
        YLM(80) = 8 * X**7 * Y - 56 * XP * YQ + 56 * XQ * YP
     1          - 8 * X * Y**7
      END IF
      I = 0
      J = 0
      LMAX = MAX (L0MAX, L1MAX)
      DO L = 1, LMAX
        DO M = 0, L
          I = I + 1
          F = FCLM(I) * FNLM(I)
          DO IP = 0, MIN (M, 1)
            J = J + 1
            YLM(J) = F * YLM(J)
          END DO
        END DO
      END DO
      I = 0
      N = 0
      DO L = 1, LMAX
        DO M = -L, L
          I = I + 1
          IF ((MOD (L, 2) == 0 .AND. L <= L0MAX) .OR.
     1        (MOD (L, 2) == 1 .AND. L <= L1MAX)) THEN
            N = N + 1
            YLM(N) = YLM(I)
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN055
 
      REAL FUNCTION GEN056 (IH, IK, IL, GINV)
C * CALCULATE SIN(THETA)/LAMBDA
      IMPLICIT NONE
      INTEGER               :: IH
      INTEGER               :: IK
      INTEGER               :: IL
      REAL                  :: GEN006
      REAL, DIMENSION(3)    :: H
      REAL, DIMENSION(3, 3) :: GINV
      H(1) = IH
      H(2) = IK
      H(3) = IL
      GEN056 = 0.5 * SQRT (GEN006 (H, GINV, H))
      RETURN
      END FUNCTION GEN056
 
      SUBROUTINE GEN057 (A, X, D, N)
C * GAUSS-ELIMINATION METHOD FOR MATRIX INVERSION   A*X=D
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: N
      REAL                  :: Y
      REAL                  :: E
      REAL                  :: RL
      REAL                  :: RM
      REAL, DIMENSION(N, N) :: A
      REAL, DIMENSION(N)    :: X
      REAL, DIMENSION(N)    :: D
      K  = 0
      I  = 1
   10 J  = I
      RL = 0
   20 IF (ABS (A(J, I)) > RL) THEN
        RL = ABS (A(J, I))
        K  = J
      END IF
      J = J + 1
      IF (J <= N) GO TO 20
      J = I
      IF (K /= I) THEN
   30   Y = A(I, J)
        A(I, J) = A(K, J)
        A(K, J) = Y
        J = J + 1
        IF (J <= N) GO TO 30
        Y    = D(I)
        D(I) = D(K)
        D(K) = Y
      END IF
      J = I + 1
      IF (I /= N) THEN
   40   RM = A(J, I) / A(I, I)
        K  = I
   50   A(J, K) = A(J, K) - RM * A(I, K)
        K = K + 1
        IF (K <= N) GO TO 50
        D(J) = D(J) - RM * D(I)
        J = J + 1
        IF (J <= N) GO TO 40
        I = I + 1
        IF (I <= N) GO TO 10
      END IF
      I = N
   60 E = D(I)
      IF (I /= N) THEN
        J = I + 1
   70   E = - A(I, J) * X(J) + E
        J = J + 1
        IF (J <= N) GO TO 70
      END IF
      X(I) = E / A(I, I)
      I    = I - 1
      IF (I /= 0) GO TO 60
      RETURN
      END SUBROUTINE GEN057
 
      SUBROUTINE GEN058 (LABI, NR)
C * CONVERT NUMBER TO ATOM LABEL
      IMPLICIT NONE
      INTEGER          :: NR
      INTEGER          :: NO
      INTEGER          :: L0
      INTEGER          :: IOST
      CHARACTER(len=4) :: LABI
      IOST = 0
      IF (LABI(2:2) /= ' ') THEN
        L0 = 1
        NO = 10 + NR
      ELSE
        L0 = 0
        NO = 500 + NR
      END IF
      IF (NO < 100) THEN
        WRITE (LABI(2+L0:3+L0), 99999, IOSTAT = IOST) NO
      ELSE
        WRITE (LABI(2:4), 99998, IOSTAT = IOST) NO
      END IF
      RETURN
99999 FORMAT (I2)
99998 FORMAT (I3)
      END SUBROUTINE GEN058
 
      SUBROUTINE GEN059 (A, B, C)
C * MATRIX MANIPULATION ROUTINES FOR 4X4 HOMOGENEOUS TRANSFORMATIONS
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL, DIMENSION(4, 4) :: C
      REAL, DIMENSION(4, 4) :: A
      REAL, DIMENSION(4, 4) :: B
      DO I = 1, 4
        DO J = 1, 4
          C(I, J) = A(I, 1) * B(1, J) + A(I, 2) * B(2, J)
     1            + A(I, 3) * B(3, J) + A(I, 4) * B(4, J)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN059
 
      SUBROUTINE GEN060 (A, B)
C * TRANSPOSE 4X4 MATRIX
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL, DIMENSION(4, 4) :: B
      REAL, DIMENSION(4, 4) :: A
      DO I = 1, 4
        DO J = 1, 4
          B(I, J) = A(J, I)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN060
 
      REAL FUNCTION GEN061 (A, AI)
C * MATRIX INVERSION FOR A 4X4 MATRIX A
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER, DIMENSION(4) :: INDZ
      REAL                  :: D
      REAL, DIMENSION(4, 4) :: AI
      REAL, DIMENSION(4, 4) :: A
      REAL, DIMENSION(4, 4) :: TMP
      DO I = 1, 4
        DO J = 1, 4
          TMP(I, J) = A(I, J)
          AI(I, J) = 0.0
        END DO
        AI(I, I) = 1.0
      END DO
      CALL GEN062 (TMP, 4, INDZ, D)
      GEN061 = D * TMP(1, 1) * TMP(2, 2) * TMP(3, 3) * TMP(4, 4)
      DO J = 1, 4
        CALL GEN063 (TMP, 4, INDZ, AI(1, J))
      END DO
      RETURN
      END FUNCTION GEN061
 
      SUBROUTINE GEN062 (A, N, INDZ, D)
C ***********************************************************************
C *            MATRIX INVERSION VIA LU DECOMPOSITION                   *
C *     ADAPTED FROM NUMERICAL RECIPES IN FORTRAN (1986)               *
C ***********************************************************************
      IMPLICIT NONE
      INTEGER, PARAMETER       :: NMAX = 10
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: N
      INTEGER                  :: IMAX
      INTEGER, DIMENSION(N)    :: INDZ
      REAL                     :: D
      REAL                     :: SUMX
      REAL                     :: DUM
      REAL                     :: AAMAX
      REAL,    DIMENSION(N, N) :: A
      REAL,    DIMENSION(NMAX) :: VV
C ***********************************************************************
C * INPUT  NXN MATRIX A IS REPLACED BY ITS LU DECOMPOSITION
C * OUTPUT INDZ(N) RECORDS ROW PERMUTATION DUE TO PIVOTING
C * OUTPUT D IS PARITY OF ROW PERMUTATIONS
      IMAX = 0
      D    = 1.0
      DO I = 1, N
        AAMAX = 0.0
        DO J = 1, N
          IF (ABS (A(I, J)) > AAMAX) AAMAX = ABS (A(I, J))
        END DO
        VV(I) = 1.0 / AAMAX
      END DO
      DO J = 1, N
        IF (J > 1) THEN
          DO I = 1, J - 1
            SUMX = A(I, J)
            IF (I > 1) THEN
              DO K = 1, I - 1
                SUMX = SUMX - A(I, K) * A(K, J)
              END DO
              A(I, J) = SUMX
            END IF
          END DO
        END IF
        AAMAX = 0.0
        DO I = J, N
          SUMX = A(I, J)
          IF (J > 1) THEN
            DO K = 1, J - 1
              SUMX = SUMX - A(I, K) * A(K, J)
            END DO
            A(I, J) = SUMX
          END IF
          DUM = VV(I) * ABS (SUMX)
          IF (DUM >= AAMAX) THEN
            IMAX = I
            AAMAX = DUM
          END IF
        END DO
        IF (J /= IMAX) THEN
          DO K = 1, N
            DUM = A(IMAX, K)
            A(IMAX, K) = A(J, K)
            A(J, K) = DUM
          END DO
          D = - D
          VV(IMAX) = VV(J)
        END IF
        INDZ(J) = IMAX
        IF (J /= N) THEN
          DUM = 1.0 / A(J, J)
          DO I = J + 1, N
            A(I, J) = A(I, J) * DUM
          END DO
        END IF
      END DO
      RETURN
      END SUBROUTINE GEN062
 
      SUBROUTINE GEN063 (A, N, INDZ, B)
C * CORRESPONDING BACK-SUBSTITUTION ROUTINE (REF - GEN061)
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: N
      INTEGER                  :: II
      INTEGER                  :: LL
      REAL                     :: SUMX
      INTEGER, DIMENSION(N)    :: INDZ
      REAL,    DIMENSION(N)    :: B
      REAL,    DIMENSION(N, N) :: A
      II = 0
      DO I = 1, N
        LL = INDZ(I)
        SUMX  = B(LL)
        B(LL) = B(I)
        IF (II /= 0) THEN
          DO J = II, I - 1
            SUMX = SUMX - A(I, J) * B(J)
          END DO
        ELSE IF (SUMX /= 0.0) THEN
        II = I
        END IF
        B(I) = SUMX
      END DO
      DO I = N, 1, -1
        SUMX = B(I)
        IF (I < N) THEN
          DO J = I + 1, N
            SUMX = SUMX - A(I, J) * B(J)
          END DO
        END IF
        B(I) = SUMX / A(I, I)
      END DO
      RETURN
      END SUBROUTINE GEN063
 
      SUBROUTINE GEN064 (A, N, NP, D, V)
C **********************************************************************
C * FIND EIGENVALUES AND EIGENVECTORS OF NXN SYMMETRIC MATRIX USING    *
C * CYCLIC JACOBI METHOD. NP IS (FORTRAN) PHYSICAL STORAGE DIMENSION.  *
C * ON RETURN A IS DESTROYED, D CONTAINS EIGENVALUES,AND EACH COLUMN OF*
C * V IS A NORMALIZED EIGENVECTOR                                      *
C **********************************************************************
      IMPLICIT NONE
      INTEGER,      PARAMETER :: NMAX=100
C * MACHINE DEPENDENT! (CONVERGE WHEN OFF-DIAGONAL SUM IS LESS THAN THIS)
      REAL,         PARAMETER :: TINY = 1.E-37
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: N
      INTEGER                 :: IP
      INTEGER                 :: IQ
      INTEGER                 :: NP
      REAL                    :: G
      REAL                    :: H
      REAL                    :: T
      REAL                    :: S
      REAL                    :: C
      REAL                    :: SM
      REAL                    :: TAU
      REAL                    :: THETA
      REAL                    :: THRESH
      REAL, DIMENSION(NP, NP) :: A
      REAL, DIMENSION(NP, NP) :: V
      REAL, DIMENSION(NP)     :: D
      REAL, DIMENSION(NMAX)   :: B
      REAL, DIMENSION(NMAX)   :: Z
C * INITIALIZE V TO IDENTITY MATRIX, B AND D TO DIAGONAL OF A
      DO IP = 1, N
        DO IQ = 1, N
          V(IP, IQ) = 0.0
        END DO
        V(IP, IP) = 1.0
        B(IP)     = A(IP, IP)
        D(IP)     = B(IP)
        Z(IP)     = 0.0
      END DO
C * 50 SWEEPS IS NEVER EXPECTED TO HAPPEN; PRESS ET AL (1986) CLAIM
C * 6 TO 10 ARE TYPICAL FOR MODERATE MATRIX SIZES
      DO I = 1, 50
        SM = 0.0
        DO IP = 1, N - 1
          DO IQ = IP + 1, N
            SM = SM + ABS (A(IP, IQ))
          END DO
        END DO
        IF (SM < TINY) RETURN
C * AFTER 4 SWEEPS SKIP ROTATION IF THE OFF-DIAGONAL IS SMALL
        IF (I < 4) THEN
          THRESH = 0.2 * SM / (N * N)
        ELSE
          THRESH = 0.0
        END IF
        DO IP = 1, N - 1
          DO IQ = IP + 1, N
            G = 100.0 * ABS (A(IP, IQ))
            IF ((I > 4) .AND.
     1         (ABS (D(IP)) + G == ABS (D(IP))) .AND.
     2         (ABS (D(IQ)) + G == ABS (D(IQ)))) THEN
              A(IP,IQ) = 0.0
            ELSE IF (ABS(A(IP, IQ)) > THRESH) THEN
              H = D(IQ) - D(IP)
              IF (ABS (H) + G == ABS (H)) THEN
                T = A(IP, IQ) / H
              ELSE
                THETA = 0.5 * H / A(IP, IQ)
                T = 1.0 / (ABS (THETA) + SQRT (1.0 + THETA * THETA))
                IF (THETA < 0.0) T = -T
              END IF
              C = 1.0 / SQRT (1.0 + T * T)
              S = T * C
              TAU = S / (1.0 + C)
              H = T * A(IP, IQ)
              Z(IP) = Z(IP) - H
              Z(IQ) = Z(IQ) + H
              D(IP) = D(IP) - H
              D(IQ) = D(IQ) + H
              A(IP, IQ) = 0.0
              DO J = 1, IP - 1
                G = A(J, IP)
                H = A(J, IQ)
                A(J, IP) = G - S * (H + G * TAU)
                A(J, IQ) = H + S * (G - H * TAU)
              END DO
              DO J = IP + 1, IQ - 1
                G = A(IP, J)
                H = A(J, IQ)
                A(IP, J) = G - S * (H + G * TAU)
                A(J, IQ) = H + S * (G - H * TAU)
              END DO
              DO J = IQ + 1, N
                G = A(IP, J)
                H = A(IQ, J)
                A(IP, J) = G - S * (H + G * TAU)
                A(IQ, J) = H + S * (G - H * TAU)
              END DO
              DO J = 1, N
                G = V(J, IP)
                H = V(J, IQ)
                V(J, IP) = G - S * (H + G * TAU)
                V(J, IQ) = H + S * (G - H * TAU)
              END DO
            END IF
          END DO
        END DO
C * UPDATE D WITH SUM AND REINITIALIZE Z
        DO IP = 1, N
          B(IP) = B(IP) + Z(IP)
          D(IP) = B(IP)
          Z(IP) = 0.0
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN064
 
      SUBROUTINE GEN065 (LU, PRBUF, JBEG, JBUFL, JSUBST)
C * MODIFY AND PRINT PRINT-BUFFER
      USE genrl
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: I0
      INTEGER            :: J0
      INTEGER            :: K0
      INTEGER            :: JL
      INTEGER            :: JB
      INTEGER            :: LU
      INTEGER            :: IOST
      INTEGER            :: JFRM
      INTEGER            :: ITAR
      INTEGER            :: IPAR
      INTEGER            :: IDOT
      INTEGER            :: KMAX
      INTEGER            :: JBEG
      INTEGER            :: IBUFL
      INTEGER            :: JBUFL
      INTEGER            :: ISUBST
      INTEGER            :: JSUBST
      INTEGER            :: JSUBST0
      INTEGER            :: JSUBST1
      INTEGER            :: JSUBST2
      INTEGER            :: JSUBST3
      INTEGER            :: JSUBST4
      CHARACTER(len=*)   :: PRBUF
      CHARACTER(len=133) :: PRB
      CHARACTER(len=1)   :: PCH
      CHARACTER(len=1)   :: PCH0
      CHARACTER(len=1)   :: PCH1
C * JSUBST0 : NO SUBSTITUTIONS, WITH ELIMINATION BLANKS i.e. (  3)->(3)
C * JSUBST1 : STRING SUBSTITUTION of 0.33333( 0) with 1/3 etc
C * JSUBST2 : STRING SUBST 0.333 WITH 1/3 etc.
C * JSUBST3 : STRING SUBST 0.0000 WITH 0 ETC.
C * JSUBST4 :
      IOST = 0
      J0   = 0
      J    = 0
      JL   = 0
      JB   = JBEG - 1
      PRB  = PRBUF(1:JBUFL)//' '
      IF (JB > 0) CALL GEN038 (PRB, 1, JB)
      IBUFL = JBUFL + 1
C * ALIGN NUMBERS
      IPAR   = 0
      K0     = 0
C * BIT # 1
      JSUBST0 = MOD (JSUBST, 2)
      IF (JSUBST0 == 1) THEN
        DO I = 2, IBUFL
          PCH = PRB(I : I)
          IF (PCH == '(') THEN
C * 1ST HANDLE THE SPECIAL '.(' CASE BY MOVING NUMBER 1 POSN TO THE RIGHT
            I0   = I - 1
            J0   = I0
            PCH0 = PRB(I0 : I0)
            IF (PCH0 == '.') THEN
              IDOT = 1
            ELSE
              IDOT = 0
            END IF
   10       J0   = J0 - 1
C * AVOID FALLOUT ON LEFT OF STRING (WITH DUMMY QUOTE)
            IF (J0 == 0) THEN
              PCH0 = ''''
            ELSE
              PCH0 = PRB(J0 : J0)
            END IF
            IF (IDOT == 1) PRB(J0 + 1 : J0 + 1) = PCH0
            IF (PCH0 /= ' ' .AND. PCH0 .NE. ')' .AND.
     1          PCH0 /= '''' .AND. PCH0 .NE. '"' .AND.
     2          PCH0 /= '-' .AND. J0 > K0) GO TO 10
            IF (IDOT == 1) PRB(J0 : J0) = ' '
            J0 = J0 - 1 + IDOT
            IF (PCH0 == '''' .OR. PCH0 == '"') J0 = J0 + 1
 
            IPAR = 1
            J    = I
            JL   = I
          ELSE IF (IPAR > 0) THEN
            IF (PCH == ')') THEN
              K0 = I + 1
              IF (J > JL) THEN
                J            = J + 1
                PRB(J : J) = PCH
              ELSE
                J      = J - 1
              END IF
C * SHIFT CHARACTER STRING TO THE RIGHT
              IF (J < I) THEN
                KMAX = J - J0
                ITAR = I + 1
                JFRM = J + 1
                DO K = 1, KMAX
                  PCH1 = PRB(JFRM - K : JFRM - K)
                  PRB(ITAR - K : ITAR - K) = PCH1
                END DO
                DO K = J0 + 1, I - KMAX
                  PRB(K : K) = ' '
                END DO
              END IF
              IPAR = 0
            ELSE IF (PCH /= ' ') THEN
C * SKIP BLANK AND ZERO LEADING CHARACTERS WITHIN PARENTHESES
              IF (PCH == '0') THEN
                IF (J > JL) THEN
                  J            = J + 1
                  PRB(J : J) = PCH
                END IF
              ELSE
                J            = J + 1
                PRB(J : J) = PCH
              END IF
            END IF
          END IF
        END DO
      END IF
      ISUBST  = JSUBST / 2
C * BIT # 2
      JSUBST1 = MOD (ISUBST, 2)
C * TYPE 1 - SUBSTITUTIONS
      IF (JSUBST1 == 1) THEN
        DO 20 I = 9, IBUFL
          DO K = 1, 56
            IF (PRB(I - 8 : I) == STR1(K)//' ') THEN
                PRB(I - 8 : I) = STR2(K)//' '
              GO TO 20
            END IF
          END DO
   20   CONTINUE
      END IF
      ISUBST  = ISUBST / 2
C * BIT # 3
      JSUBST2 = MOD (ISUBST, 2)
C * TYPE 2 - SUBSTITUTIONS
      IF (JSUBST2 == 1) THEN
        DO 30 I = 7, IBUFL
          DO K = 1, 48
            IF (PRB(I - 6 : I) == STR3(K)//' ' .OR.
     1          PRB(I - 6 : I) == STR3(K)//'-') THEN
                PRB(I - 6 : I - 1) = STR4(K)
              GO TO 30
            END IF
          END DO
   30   CONTINUE
      END IF
      ISUBST  = ISUBST / 2
C * BIT # 4
      JSUBST3 = MOD (ISUBST, 2)
C * TYPE 3 - SUBSTITUTIONS
      IF (JSUBST3 == 1) THEN
        DO I = 8, IBUFL
          IF (PRB(I - 7: I) == ' 0.0000 ' .OR.
     1        PRB(I - 7: I) == ' 0.0000-') THEN
              PRB(I - 7: I - 1)  =  '      0'
          ELSE IF (PRB(I - 7: I) == ' 1.0000 ' .OR.
     1             PRB(I - 7: I) == ' 1.0000-') THEN
              PRB(I - 7: I - 1)  =  '      1'
          ELSE IF (PRB(I - 7: I) == '-1.0000 ' .OR.
     1             PRB(I - 7: I) == '-1.0000-') THEN
              PRB(I - 7: I - 1)  =  '     -1'
          END IF
        END DO
      END IF
      ISUBST  = ISUBST / 2
C * BIT # 5
      JSUBST4 = MOD (ISUBST, 2)
C * TYPE 4 - SUBSTITUTIONS
      IF (JSUBST4 == 1) THEN
        DO I = 6, IBUFL
          DO J = 1, 16
            IF (PRB(I - 5: I) == STR5(J)) THEN
              PRB(I - 5: I) = STR6(J)
            END IF
          END DO
        END DO
      END IF
      IF (JB > 0) PRB(1:JB) = PRBUF(1:JB)
      PRBUF = PRB(1:JBUFL)
      IF (LU /= 0) THEN
        IF (LU == 6) THEN
          CALL TRAILER (PRBUF(1:JBUFL))
        ELSE
          WRITE (LU, 99999, IOSTAT = IOST) PRBUF(1 : JBUFL)
        END IF
      END IF
      RETURN
99999 FORMAT (A)
      END SUBROUTINE GEN065
 
      SUBROUTINE GEN066 (MODE, PARA, PARS, KS, MSETTING)
C * APPLY SYMMETRY CONSTRAINTS ON CELL DIMENSIONS
      IMPLICIT NONE
      INTEGER            :: MODE
      INTEGER            :: MSETTING
      REAL               :: TOL
      REAL               :: AVER
      REAL, DIMENSION(6) :: PARA
      REAL, DIMENSION(6) :: PARS
      CHARACTER(len=1)   :: KS
C * MODE = 0 : CELL PAR ONLY
C * MODE = 1 : + ESD'S TOL = 0.1
C * MODE = 2 : + ESD'S TOL = 0.5
C * MONOCLINIC
      IF (MODE == 2) THEN
        TOL = 0.5
      ELSE
        TOL = 0.1
      END IF
      IF (KS == 'm') THEN
 
        IF (MSETTING == 0) THEN
          IF (ABS(PARA(4) - 90.0) + ABS (PARA(6) - 90.0) < TOL) THEN
            PARA(4) = 90.0
            PARA(6) = 90.0
            IF (MODE > 0) THEN
              PARS(4) = 0.0
              PARS(6) = 0.0
            END IF
          END IF
        ELSE IF (MSETTING == 1) THEN
          IF (ABS(PARA(5) - 90.0) + ABS (PARA(6) - 90.0) < TOL) THEN
            PARA(4) = 90.0
            PARA(5) = 90.0
            IF (MODE > 0) THEN
              PARS(4) = 0.0
              PARS(5) = 0.0
            END IF
          END IF
 
        ELSE IF (MSETTING == 3) THEN
          IF (ABS(PARA(4) - 90.0) + ABS (PARA(5) - 90.0) < TOL) THEN
            PARA(4) = 90.0
            PARA(5) = 90.0
            IF (MODE > 0) THEN
              PARS(4) = 0.0
              PARS(5) = 0.0
            END IF
          END IF
        END IF
C * ORTHORHOMBIC
      ELSE IF (KS == 'o') THEN
        PARA(4) = 90.0
        PARA(5) = 90.0
        PARA(6) = 90.0
        IF (MODE > 0) THEN
          PARS(4) = 0.0
          PARS(5) = 0.0
          PARS(6) = 0.0
        END IF
C * TETRAGONAL
      ELSE IF (KS == 't') THEN
        AVER    = (PARA(1) + PARA(2)) / 2.0
        PARA(1) = AVER
        PARA(2) = AVER
        PARA(4) = 90.0
        PARA(5) = 90.0
        PARA(6) = 90.0
        IF (MODE > 0) THEN
          AVER    = (PARS(1) + PARS(2)) / 2.0
          PARS(1) = AVER
          PARS(2) = AVER
          PARS(4) = 0.0
          PARS(5) = 0.0
          PARS(6) = 0.0
        END IF
C * TRIGONAL (RHOMBOHEDRAL)
      ELSE IF (KS == 'r') THEN
        AVER    = (PARA(1) + PARA(2) + PARA(3)) / 3.0
        PARA(1) = AVER
        PARA(2) = AVER
        PARA(3) = AVER
        AVER    = (PARA(4) + PARA(5) + PARA(6)) / 3.0
        PARA(4) = AVER
        PARA(5) = AVER
        PARA(6) = AVER
        IF (MODE > 0) THEN
          AVER    = (PARS(1) + PARS(2) + PARS(3)) / 3.0
          PARS(1) = AVER
          PARS(2) = AVER
          PARS(3) = AVER
          AVER    = (PARS(4) + PARS(5) + PARS(6)) / 3.0
          PARS(4) = AVER
          PARS(5) = AVER
          PARS(6) = AVER
        END IF
C * HEXAGONAL
      ELSE IF (KS == 'h') THEN
        AVER    = (PARA(1) + PARA(2)) / 2.0
        PARA(1) = AVER
        PARA(2) = AVER
        PARA(4) = 90.0
        PARA(5) = 90.0
        PARA(6) = 120.0
        IF (MODE > 0) THEN
          AVER    = (PARS(1) + PARS(2)) / 2.0
          PARS(1) = AVER
          PARS(2) = AVER
          PARS(4) = 0.0
          PARS(5) = 0.0
          PARS(6) = 0.0
        END IF
C * CUBIC
      ELSE IF (KS == 'c') THEN
        AVER     = (PARA(1) + PARA(2) + PARA(3)) / 3.0
        PARA(1) = AVER
        PARA(2) = AVER
        PARA(3) = AVER
        PARA(4) = 90.0
        PARA(5) = 90.0
        PARA(6) = 90.0
        IF (MODE > 0) THEN
          AVER     = (PARS(1) + PARS(2) + PARS(3)) / 3.0
          PARS(1) = AVER
          PARS(2) = AVER
          PARS(3) = AVER
          PARS(4) = 0.0
          PARS(5) = 0.0
          PARS(6) = 0.0
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN066
 
      SUBROUTINE GEN067 (TM, CELO, CELN, CSDO, CSDN)
C * TRANSFORM CELL-ESD'S
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL                  :: DEL
      REAL, DIMENSION(3, 3) :: AA
      REAL, DIMENSION(3, 3) :: BB
      REAL, DIMENSION(3, 3) :: TM
      REAL, DIMENSION(6)    :: A
      REAL, DIMENSION(6)    :: B
      REAL, DIMENSION(6)    :: C
      REAL, DIMENSION(6)    :: D
      REAL, DIMENSION(6)    :: CELO
      REAL, DIMENSION(6)    :: CELN
      REAL, DIMENSION(6)    :: CSDO
      REAL, DIMENSION(6)    :: CSDN
C * COPY OLD CELL PARAMETERS
      CALL GEN113 (CELO, A, 6)
C * COPY NEW CELL PARAMETERS
      CALL GEN113 (CELN, B, 6)
C * LOOP OVER CELL PARAMETERS
      DO J = 1, 6
        D(J) = 0.0
C * LOOP OVER S.U. CONTRIBUTERS
        DO I = 1, 6
          DEL = CSDO(I)
          IF (DEL > 0.0) THEN
            DEL  = DEL / 2.0
            A(I) = A(I) + DEL
C * CALCULATE METRIC
            CALL GEN026 (1, AA, A)
            A(I) = A(I) - DEL
C * TRANSFORM METRIC
            CALL GEN001 (1, TM, AA, BB)
C * GET REVISED CELL PARAMETERS
            CALL GEN026 (-1, BB, C(1))
            D(J) = D(J) + ((B(J) - C(J)) * 2.0) ** 2
          END IF
        END DO
      END DO
      DO J = 1, 6
        CSDN(J) = SQRT (D(J))
      END DO
      RETURN
      END SUBROUTINE GEN067
 
      REAL FUNCTION GEN068 (C, D, K)
C * CALCULATE VOLUME S.U.
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: K
      REAL               :: SV
      REAL               :: GEN163
      REAL               :: VOLUME
      REAL, DIMENSION(6) :: C
      REAL, DIMENSION(6) :: D
      IF (K == 2) THEN
C * MONOCLINIC-C
        IF (C(4) == 90.0 .AND. C(5) == 90.0) THEN
          K = 9
C * MONOCLINIC-A
        ELSE IF (C(5) == 90.0 .AND. C(6) == 90.0) THEN
          K = 10
        END IF
      END IF
      VOLUME = GEN163(C, D, K, 0)
      SV = 0.0
C * TRICLINIC
      IF (K == 1) THEN
        DO I = 1, 6
          IF (D(I) > 0.0) THEN
            SV = SV + (VOLUME - GEN163(C, D, 1, I))**2
          END IF
        END DO
C * MONOCLINIC
      ELSE IF (K == 2) THEN
        DO I = 1, 3
          SV = SV + (VOLUME - GEN163(C, D, 2, I))**2
        END DO
        SV = SV + (VOLUME - GEN163(C, D, 2, 5))**2
C * ORTHORHOMBIC
      ELSE IF (K == 3) THEN
        DO I = 1, 3
          SV = SV + (VOLUME - GEN163(C, D, 3, I))**2
        END DO
C * TRIGONAL
      ELSE IF (K == 4 .OR. K == 6) THEN
        SV = SV + (VOLUME - GEN163(C, D, K, 1))**2
        SV = SV + (VOLUME - GEN163(C, D, K, 3))**2
C * TETRAGONAL
      ELSE IF (K == 5) THEN
        SV = SV + (VOLUME - GEN163(C, D, 5, 1))**2
        SV = SV + (VOLUME - GEN163(C, D, 5, 3))**2
C * CUBIC
      ELSE IF (K == 7) THEN
        SV = SV + (VOLUME - GEN163(C, D, 7, 1))**2
C * RHOMBOHEDRAL
      ELSE IF (K == 8) THEN
        SV = SV + (VOLUME - GEN163(C, D, 8, 1))**2
        SV = SV + (VOLUME - GEN163(C, D, 8, 4))**2
C * MONOCLINIC-C
      ELSE IF (K == 9) THEN
        DO I = 1, 3
          SV = SV + (VOLUME - GEN163(C, D, 9, I))**2
        END DO
        SV = SV + (VOLUME - GEN163(C, D, 9, 6))**2
C * MONOCLINIC-A
      ELSE IF (K == 10) THEN
        DO I = 1, 3
          SV = SV + (VOLUME - GEN163(C, D, 10, I))**2
        END DO
        SV = SV + (VOLUME - GEN163(C, D, 10, 4))**2
      ENDIF
      GEN068 = SQRT (SV)
      RETURN
      END FUNCTION  GEN068
 
      SUBROUTINE GEN069 (K, A, B, C, P, SIGMA, D, G)
C * TRFORD
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: I1
      INTEGER               :: J1
      INTEGER               :: K1
      REAL                  :: H
      REAL                  :: SIGMA
      REAL, DIMENSION(*)    :: A
      REAL, DIMENSION(*)    :: B
      REAL, DIMENSION(*)    :: C
      REAL, DIMENSION(*)    :: P
      REAL, DIMENSION(*)    :: D
      REAL, DIMENSION(*)    :: G
      REAL, DIMENSION(1000) :: S0
      REAL, DIMENSION(1000) :: S1
      IF (K == 0) THEN
        D(1) = 1.0
        P(1) = C(1)
      ELSE
        S0(1) = 1.0
        S1(2) = 1.0
        S1(1) = -A(1)
        P(1)  = -C(2) * A(1) + C(1)
        P(2)  = C(2)
        D(1)  = A(1)**2 / G(2) + 1.0 / G(1)
        D(2)  = 1.0 / G(2)
        IF (K > 1) THEN
          DO I = 2, K
            D(I + 1) = 0.0
            P(I + 1) = 0.0
          END DO
          K1 = K - 1
          DO J = 1, K1
            S0(J + 2) = 1.0
            S0(J + 1) = S1(J) - A(J + 1)
            IF (J > 1) S0(J) = S1(J - 1) - A(J + 1) * S1(J) - B(J)
            IF (J > 2) THEN
              J1 = J - 2
              DO I1 = 1, J1
                I = J1 - I1 + 1
                S0(I + 1) =
     1            S1(I) - A(J + 1) * S1(I + 1) - B(J) * S0(I + 1)
              END DO
            END IF
            S0(1) = -A(J + 1) * S1(1) - B(J) * S0(1)
            J1 = J + 2
            DO I = 1, J1
              IF (I /= J1) THEN
                H     = S1(I)
                S1(I) = S0(I)
                S0(I) = H
              ELSE
                S1(I) = S0(I)
              END IF
              P(I)  = P(I) + C(J + 2) * S1(I)
              D(I)  = D(I) + S1(I)**2 / G(J + 2)
            END DO
          END DO
        END IF
      END IF
      K1 = K + 1
      DO I = 1, K1
        D(I) = SIGMA * SQRT (D(I))
      END DO
      RETURN
      END SUBROUTINE GEN069
 
      SUBROUTINE GEN070 (N, X, F, W, K, A, B, C, G, V)
C * POLFIW
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: K
      INTEGER            :: N
      INTEGER            :: I1
      INTEGER            :: I3
      INTEGER            :: K3
      REAL               :: S
      REAL               :: S0
      REAL               :: S1
      REAL               :: G0
      REAL               :: G1
      REAL               :: XS
      REAL               :: FS
      REAL               :: DELTA
      REAL, DIMENSION(*) :: X
      REAL, DIMENSION(*) :: F
      REAL, DIMENSION(*) :: W
      REAL, DIMENSION(*) :: A
      REAL, DIMENSION(*) :: B
      REAL, DIMENSION(*) :: C
      REAL, DIMENSION(*) :: G
      REAL, DIMENSION(*) :: V
      DELTA = 0.0
      DO J = 1, N
        DELTA = DELTA + W(J) * F(J)**2
      END DO
      K3 = K + 1
      DO I3 = 1, K3, 1
        I = I3 - 1
        XS = 0.0
        FS = 0.0
        S1 = 0.0
        S0 = 0.0
        DO J = 1, N
          G1 = 1.0
          G0 = 0.0
          IF (I > 0) THEN
            DO I1 = 1, I, 1
              S = 0.0
              IF (I1 /= 1) S = B(I1 - 1) * G0
              G0 = (X(J) - A(I1)) * G1 - S
              S  = G0
              G0 = G1
              G1 = S
            END DO
          END IF
          S1 = S1 + G1**2 * W(J)
          FS = FS + G1 * F(J) * W(J)
          IF (I /= K) THEN
            S0 = S0 + G0**2 * W(J)
            XS = XS + G1**2 * X(J) * W(J)
          END IF
        END DO
        IF (I /= K) THEN
          A(I + 1) = XS / S1
          IF (I /= 0) B(I) = S1 / S0
        END IF
        C(I + 1) = FS / S1
        G(I + 1) = S1
        IF (I /= 0) V(I + 1) = ABS (V(I)  - C(I + 1)**2 * S1)
        IF (I == 0) V(I + 1) = ABS (DELTA - C(I + 1)**2 * S1)
      END DO
      RETURN
      END SUBROUTINE GEN070
 
      REAL FUNCTION GEN071 (K, A, B, C, T, DER)
C * EVAPOL
      IMPLICIT NONE
      INTEGER, PARAMETER   :: IP5=2
      INTEGER              :: I
      INTEGER              :: K
      REAL                 :: S
      REAL                 :: T
      REAL                 :: D0
      REAL                 :: D1
      REAL                 :: G0
      REAL                 :: G1
      REAL                 :: S1
      REAL                 :: DER
      REAL, DIMENSION(IP5) :: A
      REAL, DIMENSION(IP5) :: B
      REAL, DIMENSION(IP5) :: C
      D0  = 0.0
      G0  = 0.0
      S1  = C(1)
      G1  = 1.0
      DER = 0.0
      D1  = 0.0
      IF (K /= 0) THEN
        DO I = 1, K
          S = 0.0
          IF (I /= 1) S = B(I - 1) * D0
          D0  = (T - A(I)) * D1 - S + G1
          S   = D0
          D0  = D1
          D1  = S
          DER = DER + C(I + 1) * D1
          S   = 0.0
          IF (I /= 1) S = B(I - 1) * G0
          G0 = (T - A(I)) * G1 - S
          S  = G0
          G0 = G1
          G1 = S
          S1 = S1 + C(I + 1) * G1
        END DO
      END IF
      GEN071 = S1
      RETURN
      END FUNCTION GEN071
 
      SUBROUTINE GEN072 (LINE, IFL, FN, KL, KN, LU5, LU6, IUP,
     1 JMIN, JMAX, NCHAR, NP17)
C * FREE FORMAT READ ROUTINE
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: L
      INTEGER                        :: N
      INTEGER                        :: KL
      INTEGER                        :: KN
      INTEGER                        :: IP
      INTEGER                        :: NP
      INTEGER                        :: LU5
      INTEGER                        :: LU6
      INTEGER                        :: IUP
      INTEGER                        :: INUM
      INTEGER                        :: IMIN
      INTEGER                        :: IMAX
      INTEGER                        :: JMIN
      INTEGER                        :: JMAX
      INTEGER                        :: IOST
      INTEGER                        :: NCHAR
      INTEGER                        :: ICONT
      INTEGER                        :: NP17
      REAL                           :: A
      REAL                           :: S
      REAL,             DIMENSION(*) :: FN
      CHARACTER(len=*), DIMENSION(*) :: IFL
      CHARACTER(len=80)              :: ICL
      CHARACTER(len=1)               :: ICH
      CHARACTER(len=80)              :: LINE
      GO TO 20
   10 IF (LU6 /= 0) THEN
        CALL TRAILER (' ')
        CALL TRAILER ('** ^C Ignored - s[default]')
      END IF
   20 KN    = 0
      KL    = 0
      ICONT = 0
C * INITIALIZE LITERAL AND NUMBER ARRAYS (IFL & FN)
      CALL GEN074 (FN, 1, NP17, 0.0)
      DO I = 1, NP17
        CALL GEN038 (IFL(I), 1, NCHAR)
      END DO
C * READ OR USE CARD-IMAGE IN CHARACTER BUFFER
   30 IF (LU5 /= 0) THEN
        READ (LU5, 99998, IOSTAT = IOST) LINE
        IF (IOST /= 0) THEN
          IF (IOST == -1) THEN
            IFL(1) = 'EOF       '
            KL     = 1
            RETURN
          ELSE
            GO TO 10
          END IF
        END IF
      END IF
      IMIN = JMIN
      IMAX = JMAX
C * AVOID READING SPECIAL CARDS
      IF (LINE(1:4) == 'EXTI') IMAX = 4
      IF (LINE(1:4) == 'TITL') THEN
        N = INDEX (LINE, '=')
        IF (N /= 0) IMAX = N - 1
      END IF
C * ADD BLANKS BETWEEN NUMBER AND CHARACTER (IN THAT ORDER)
      IF (IMAX == 0) THEN
        IMIN = 1
        INUM = 0
        DO I = JMIN, 80
          ICH  = LINE(I:I)
          CALL GEN105 (3, ICH, J)
          IF (J >= 0) THEN
            INUM = 1
            GO TO 40
          END IF
          IF (ICH == '.') THEN
            INUM = 1
            GO TO 40
          END IF
          IF (INUM == 1) THEN
            INUM = 0
            IF (ICH /= ' ') THEN
              IF (IMAX < 80) THEN
                IMAX = IMAX + 1
                ICL(IMAX:IMAX) = ' '
              END IF
            END IF
          END IF
   40     IF (IMAX < 80) THEN
            IMAX = IMAX + 1
            ICL(IMAX:IMAX) = LINE(I:I)
          END IF
        END DO
      ELSE
        ICL = LINE
      END IF
C * REMOVE CTRL-M
      DO I = 1, 80
        IF (ICL(I:I) == CHAR (13)) ICL(I:I) = ' '
      END DO
      IF (IMAX == 0) GO TO 130
C * CONVERT TO UPPER-CASE LETTERS
C * SEARCH FOR CONTINUATION MARK = (ALL REMAINDER CHARACTERS SKIPPED)
      IF (IUP == 1) CALL GEN020 (1, ICL, IMIN, IMAX)
      DO I = IMIN, IMAX
        ICH = ICL(I:I)
        IF (ICH == '=') THEN
          IMAX  = I - 1
          ICONT = 1
          GO TO 50
        END IF
      END DO
C * ANALYSE FORMULA FROM COLUMN IMIN THROUGH IMAX
      ICONT = 0
C * MAXIMUM SIZE LITERAL FIELD : NCHAR
   50 I     = IMIN - 1
C * START OF A NEW FIELD
   60 A     = 0.0
      IP    = 0
      NP    = 0
      L     = 0
      S     = 1.0
C * LOOK FOR A NON-BLANK COLUMN
   70 I     = I + 1
      IF (I <= IMAX) THEN
        ICH = ICL(I:I)
        IF (L == 0 .AND. ICH == ' ') GO TO 70
C * START OF A FIELD
        L     = L + 1
        CALL GEN105 (3, ICH, J)
        IF (J >= 0) THEN
C * START OF A LITERAL FIELD BY A CHARACTER WHICH IS OTHER THAN 0-9+-.
C * NUMERIC FIELD FOUND
          NP = NP + IP
          A  = 10.0 * A + J - 1
          GO TO 70
        END IF
        IF (ICH == '.') THEN
          IP = 1
        ELSE IF (ICH == '+') THEN
          IF (L > 1) GO TO 80
          S = 1.0
        ELSE IF (ICH == '-') THEN
          IF (L > 1) GO TO 80
          S = -1.0
        ELSE IF (ICH == ')') THEN
          GO TO 80
        ELSE
          IF (L > 1) GO TO 80
          GO TO 90
        END IF
        GO TO 70
      END IF
      IF (L <= 0) GO TO 130
C * END OF NUMERIC FIELD
   80 A = S * A / 10.0**NP
      IF (KN < NP17) THEN
        KN     = KN + 1
        FN(KN) = A
      END IF
      IF (ICH == '+' .OR. ICH == '-') I = I - 1
      GO TO 60
C * START NEW LITERAL FIELD
   90 KL = KL + 1
  100 IFL(KL)(L:L) = ICH
      L = L + 1
  110 I = I + 1
      IF (I <= IMAX) THEN
        ICH = ICL(I:I)
C * BREAK LITERAL MODE ON SPACE, COMMA (OR CONDITIONAL LEFT PARENTHESIS)
        IF (ICH /= ' ' .AND. ICH .NE. ',') THEN
C * CATCH SPAR( ) CASE
          IF (ICH /= '(' .OR. L <= 3) THEN
C * PLUS, MINUS OR DOT START NUMERICAL FIELD
            IF (ICH == '+' .OR. ICH == '-' .OR. ICH == '.')
     1        GO TO 120
            IF (L > NCHAR) THEN
              GO TO 110
            ELSE
              GO TO 100
            END IF
C * END OF LITERAL FIELD
  120       I = I - 1
          END IF
        END IF
      END IF
      GO TO 60
C * TEST FOR CONTINUATION OR FINISHED
  130 IF (ICONT == 1) GO TO 30
      RETURN
99998 FORMAT (A)
      END SUBROUTINE GEN072
 
      SUBROUTINE GEN073 (A, B, C, D, E, I, J, K)
C * D*A+B*E=C
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      REAL                  :: D
      REAL                  :: E
      REAL, DIMENSION(3, *) :: A
      REAL, DIMENSION(3, *) :: B
      REAL, DIMENSION(3, *) :: C
      C(1, K) = A(1, I) * D + B(1, J) * E
      C(2, K) = A(2, I) * D + B(2, J) * E
      C(3, K) = A(3, I) * D + B(3, J) * E
      RETURN
      END SUBROUTINE GEN073
 
      SUBROUTINE GEN074 (A, NB, NE, VAL)
C * SET REAL ARRAY ON VALUE
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: NB
      INTEGER            :: NE
      REAL               :: VAL
      REAL, DIMENSION(*) :: A
      DO I = NB, NE
        A(I) = VAL
      END DO
      RETURN
      END SUBROUTINE GEN074
 
      SUBROUTINE GEN075 (A, B, C, I, J, K)
C * K = 1 - SCALAR PRODUCT A*B=C [MOLSYM]
C * K = 2 - SQRT (A)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      REAL                  :: C
      REAL                  :: X
      REAL                  :: Y
      REAL                  :: Z
      REAL, DIMENSION(3, *) :: A
      REAL, DIMENSION(3, *) :: B
      X = 0.0
      DO L = 1, 3
        Y = A(L, I)
        Z = B(L, J)
        X = X + Y * Z
      END DO
      IF (K == 1) THEN
        C = X
      ELSE
        C = SQRT(X)
      END IF
      RETURN
      END SUBROUTINE GEN075
 
      SUBROUTINE GEN076 (A, B, C, I, J, K)
C * VECTOR PRODUCT A*B=C [MOLSYM]
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      REAL                  :: X1
      REAL                  :: X2
      REAL                  :: X3
      REAL                  :: Y1
      REAL                  :: Y2
      REAL                  :: Y3
      REAL, DIMENSION(3, *) :: A
      REAL, DIMENSION(3, *) :: B
      REAL, DIMENSION(3, *) :: C
      X1      = A(1, I)
      X2      = A(2, I)
      X3      = A(3, I)
      Y1      = B(1, J)
      Y2      = B(2, J)
      Y3      = B(3, J)
      C(1, K) =  X2 * Y3 - X3 * Y2
      C(2, K) = -X1 * Y3 + X3 * Y1
      C(3, K) =  X1 * Y2 - X2 * Y1
      RETURN
      END SUBROUTINE GEN076
 
      SUBROUTINE GEN077 (A, B, C, I, J, N)
C * MOLSYM ROUTINE
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: M
      INTEGER                  :: N
      REAL                     :: Y
      REAL                     :: Z
      REAL, DIMENSION(3, 3, *) :: A
      REAL, DIMENSION(3, 3, *) :: B
      REAL, DIMENSION(3, 3, *) :: C
      REAL, DIMENSION(3, 3)    :: X
      DO K = 1, 3
        DO L = 1, 3
          X(K, L) = 0.0
          DO M = 1, 3
            Y = A(K, M, I)
            Z = B(M, L, J)
            X(K, L) = X(K, L) + Y * Z
          END DO
        END DO
      END DO
      DO K = 1, 3
        DO L = 1, 3
          C(K, L, N) = X(K, L)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN077
 
      SUBROUTINE GEN078 (A, B, C, I, J, K)
C * MOLSYM ROUTINE
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: M
      REAL                     :: Y
      REAL                     :: Z
      REAL, DIMENSION(3, 3, *) :: A
      REAL, DIMENSION(3, *)    :: B
      REAL, DIMENSION(3, *)    :: C
      REAL, DIMENSION(3)       :: X
      DO L = 1, 3
        X(L) = 0.0
        DO M = 1, 3
          Y    = A(L, M, I)
          Z    = B(M, J)
          X(L) = X(L) + Y * Z
        END DO
      END DO
      DO L = 1, 3
        C(L, K) = X(L)
      END DO
      RETURN
      END SUBROUTINE GEN078
 
      SUBROUTINE GEN079 (A, B, I, J)
C * COPY MATRIX
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      REAL, DIMENSION(3, 3, *) :: A
      REAL, DIMENSION(3, 3, *) :: B
      DO K = 1, 3
        DO L = 1, 3
          B(K, L, J) = A(K, L, I)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN079
 
      SUBROUTINE GEN080 (A, B, I, J)
C * COPY VECTOR
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL, DIMENSION(3, *) :: A
      REAL, DIMENSION(3, *) :: B
      B(1, J) = A(1, I)
      B(2, J) = A(2, I)
      B(3, J) = A(3, I)
      RETURN
      END SUBROUTINE GEN080
 
      SUBROUTINE GEN081 (A, B, M, N)
C * MOLSYM ROUTINE
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: M
      INTEGER                  :: N
      REAL, DIMENSION(3, 3, *) :: A
      REAL, DIMENSION(3, 3, *) :: B
      REAL, DIMENSION(3, 3)    :: C
      DO I = 1, 3
        DO J = 1, 3
          C(I, J) = A(J, I, M)
        END DO
      END DO
      CALL GEN079 (C, B, 1, N)
      RETURN
      END SUBROUTINE GEN081
 
      SUBROUTINE GEN082 (A, I)
C * MOLSYM ROUTINE
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL                  :: B
      REAL, DIMENSION(3, *) :: A
      CALL GEN075 (A, A, B, I, I, 2)
      IF (B /= 0.0) THEN
        DO J = 1, 3
          A(J, I) = A(J, I) / B
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN082
 
      SUBROUTINE GEN083 (T, U, V, A)
C * PLANE TROUGH POINTS T, U, V
      IMPLICIT NONE
      INTEGER               :: I
      REAL                  :: DIST
      REAL                  :: GEN084
      REAL, DIMENSION(3)    :: T
      REAL, DIMENSION(3)    :: U
      REAL, DIMENSION(3)    :: V
      REAL, DIMENSION(4)    :: A
      REAL, DIMENSION(3, 3) :: AA
      REAL, DIMENSION(3, 3) :: DD
C * A(1) x X +A(2) x Y + A(3) x Z + A(4) = 0
C * DIR.COS: A(1), A(2), A(3), A(4) = - DISTANCE TO ORIGIN
C * INTERNATIONAL TABLES FOR CRYSTALLOGRAPHY II, P. 43, EQU. 2,3,4, 6
      DD(1, 1) = T(1)
      DD(1, 2) = T(2)
      DD(1, 3) = T(3)
      DD(2, 1) = U(1)
      DD(2, 2) = U(2)
      DD(2, 3) = U(3)
      DD(3, 1) = V(1)
      DD(3, 2) = V(2)
      DD(3, 3) = V(3)
      DO I = 1, 3
        CALL GEN079 (DD, AA, 1, 1)
        CALL GEN074 (AA(1, I), 1, 3, 1.0)
        A(I) = GEN084 (AA, 1)
      END DO
      CALL GEN075 (A, A, DIST, 1, 1, 2)
      A(1) =  A(1) / DIST
      A(2) =  A(2) / DIST
      A(3) =  A(3) / DIST
      A(4) = -GEN084 (DD, 1) / DIST
      RETURN
      END SUBROUTINE GEN083
 
      REAL FUNCTION GEN084 (X, N)
C * DETERMINANT FOR MATRIX X
      IMPLICIT NONE
      INTEGER                  :: N
      REAL, DIMENSION(3, 3, *) :: X
      GEN084 = X(1, 1, N) * X(2, 2, N) * X(3, 3, N)
     1       - X(1, 1, N) * X(2, 3, N) * X(3, 2, N)
     2       + X(1, 2, N) * X(2, 3, N) * X(3, 1, N)
     3       - X(1, 2, N) * X(2, 1, N) * X(3, 3, N)
     4       + X(1, 3, N) * X(2, 1, N) * X(3, 2, N)
     5       - X(1, 3, N) * X(2, 2, N) * X(3, 1, N)
      RETURN
      END FUNCTION GEN084
 
      SUBROUTINE GEN085 (WORD, L, K)
C * COMPACT (ELIMINATE BLANKS ETC)
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: N
      CHARACTER(len=*) :: WORD
      K = 0
      DO I = 1, L
        IF (WORD(I:I) > ' ' .AND. WORD(I:I) <= '~') THEN
          K = K + 1
          WORD(K:K) = WORD(I:I)
        END IF
      END DO
      N = K + 1
      CALL GEN038 (WORD, N, L)
      RETURN
      END SUBROUTINE GEN085
 
      REAL FUNCTION GEN086 (A, B, C, M, N)
C * CHECK  SE A=B A MENO DI C
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: N
      INTEGER                  :: M
      REAL                     :: C
      REAL, DIMENSION(3, 3, *) :: A
      REAL, DIMENSION(3, 3, *) :: B
C * IUM = 1 - TRUE
C * IUM = 0 - FALSE
      GEN086 = 0.0
      DO I = 1, 3
        DO J = 1, 3
          IF (ABS(A (I, J, M) - B(I, J, N)) > C) RETURN
        END DO
      END DO
      GEN086 = 1.0
      RETURN
      END FUNCTION GEN086
 
      SUBROUTINE GEN087 (LINE, B, C, IA, NB)
C * INTERPRETA IL VETTORE  A COME POSIZIONE EQUIVALENTE O
C *  PREPARA LO STESSO PER LA STAMPA A PARTIRE DA B E C
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: L
      INTEGER                  :: K1
      INTEGER                  :: IA
      INTEGER                  :: NB
      INTEGER                  :: LR
      INTEGER                  :: KM
      INTEGER                  :: MS
      INTEGER                  :: MA
      INTEGER                  :: KM1
      INTEGER                  :: MCM
      REAL                     :: CA
      REAL                     :: COST
      REAL, DIMENSION(3, 3, *) :: B
      REAL, DIMENSION(3, *)    :: C
      CHARACTER(len=23)        :: CAR
      CHARACTER(len=*)         :: LINE
      CHARACTER(len=23)        :: CARA
      CAR  = '1234567890 /,+-xyz[]XYZ'
      IF (NB == 1) THEN
C * INTERPRETE THE CONTENT OF LINE
        MCM = 1
        LR  = LEN (LINE)
        CALL GEN085 (LINE, LR, KM)
        K    = 1
        COST = 1.0
        DO I = 1, 3
          C(I, IA) = 0.0
          DO J = 1, 3
            B(I, J, IA) = 0.0
          END DO
        END DO
        DO I = 1, KM
C * IDENTIFY CHARACTER
          CARA = LINE(I:I)
          DO J = 1, 23
            IF (CAR(J:J) == CARA) GO TO 10
          END DO
          RETURN
   10     IF (J == 11) THEN
            CYCLE
          ELSE IF (J > 11) THEN
C * ALPHABETICAL CHARACTERS
            IF (J > 20) J = J - 5
            J = J - 11
C * BARRA
            IF (J == 1) THEN
              MCM = 2
C * CAMBIO LINE MATRICE (VIRGOLA)
            ELSE IF (J == 2) THEN
              K = K + 1
C * PLUS TEKEN
            ELSE IF (J == 3) THEN
              COST = 1.0
C * MIN TEKEN
            ELSE IF (J == 4) THEN
              COST = -1.0
            ELSE IF (J == 5) THEN
              B(K, 1, IA) = COST
              COST = 1.0
            ELSE IF (J == 6) THEN
              B(K, 2, IA) = COST
              COST = 1.0
            ELSE IF (J == 7) THEN
              B(K, 3, IA) = COST
              COST = 1.0
            ELSE IF (J == 8) THEN
            ELSE IF (J == 9) THEN
              RETURN
            END IF
            CYCLE
          ELSE
C * NUMERICAL CHARACTER
            IF (J == 10) J = 0
            IF (MCM == 1) THEN
C * NUMERATORE
              IF (C(K, IA) /= 0.0) C(K, IA) = C(K, IA) * 10
              C(K, IA) = C(K, IA) + COST * J
              COST = 1.0
            ELSE IF (MCM == 2) THEN
C * DENOMINATOR
              C(K, IA) = C(K, IA) / J
              MCM = 1
            END IF
          END IF
        END DO
      ELSE IF (NB == 2) THEN
C * SCRITTURA  DEL VETTORE POSIZIONE EQUIVALENTE ALFANUMERICA
        KM = LEN (LINE)
        DO I = 1, KM
          LINE(I:I) = CAR(11:11)
        END DO
        LINE(12:12) = ','
        LINE(23:23) = ','
        DO I = 1, 3
          MCM = 11 * I
          DO J = 1, 3
            L = 4 - J
            IF (NINT (B(I, L, IA)) /= 0) THEN
              MA = L + 15
              LINE(MCM:MCM) = CAR(MA:MA)
              K = 14
              IF (B(I, L, IA) < -0.1) K = 15
              MCM = MCM - 1
              LINE(MCM:MCM) = CAR(K:K)
              MCM = MCM - 1
            END IF
          END DO
          MS = 11
          IF (ABS (C(I, IA)) >= 0.1) THEN
            IF (C(I, IA) < 0.0) MS = 15
            DO J = 1, 6
              CA = C(I, IA) * J
              K = NINT(CA)
              IF (ABS (FLOAT (K) - CA) < 0.1) EXIT
            END DO
            IF (J /= 1) THEN
              LINE(MCM:MCM) = CAR(J:J)
              MCM = MCM - 1
              LINE(MCM:MCM) = CAR(12:12)
              MCM = MCM - 1
            END IF
   20       J = IABS (MOD (K, 10))
            LINE(MCM:MCM) = CAR(J:J)
            K = K / 10
            MCM = MCM - 1
            IF (K > 0) GO TO 20
            LINE(MCM:MCM) = CAR(MS:MS)
          END IF
        END DO
        KM1 = KM - 1
        CALL GEN085 (LINE(2:KM), KM1, K)
        IF (LINE(2:2) == '+') LINE(2:2) = ' '
        DO I = 1, 2
          K = INDEX (LINE, ',+')
          K1 = K + 1
          IF (K /= 0) LINE(K1:K1) = ' '
        END DO
        CALL GEN085 (LINE(2:KM), KM1, K)
      END IF
      RETURN
      END SUBROUTINE GEN087
 
      SUBROUTINE GEN088 (A, I, M, MSIGN, INVERS)
C * GROUP ORDER
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: M
      INTEGER                  :: M1
      INTEGER                  :: MSIGN
      INTEGER                  :: INVERS
      REAL                     :: GEN084
      REAL                     :: GEN086
      REAL, DIMENSION(3, 3, *) :: A
      REAL, DIMENSION(3, 3)    :: B
      REAL, DIMENSION(3, 3, 2) :: C
C * M     = GROUP ORDER FOR THE MATRIX SIM(I)
C * MSIGN =  1 -   PROPER ROTATION AXIS
C * MSIGN = -1 - IMPROPER ROTATION AXIS
      CALL GEN074 (C, 1, 18, 0.0)
      C(1, 1, 1) =  1.0
      C(2, 2, 1) =  1.0
      C(3, 3, 1) =  1.0
      C(1, 1, 2) = -1.0
      C(2, 2, 2) = -1.0
      C(3, 3, 2) = -1.0
      INVERS     = 2
      MSIGN      = NINT (GEN084 (A, I))
      CALL GEN077  (A, C, B, I, 1, 1)
      DO M = 1, 16
        IF (GEN086 (C, B, 1.E-2, 2, 1) /= 0.0) INVERS = 1
        IF (GEN086 (C, B, 1.E-2, 1, 1) /= 0.0) GO TO 10
        CALL GEN077  (A, B, B, I, 1, 1)
      END DO
   10 IF (M >= 6 .AND. MSIGN /= 1) THEN
        M1 = (M / 4) * 4
        IF (M1 /= M) M = M / INVERS
      END IF
      RETURN
      END SUBROUTINE GEN088
 
      SUBROUTINE GEN089 (LUA, LUB, NPAG, NLM)
C * ADOBE POSTSCRIPT
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: N
      INTEGER            :: NB
      INTEGER            :: NE
      INTEGER            :: NP
      INTEGER            :: NL
      INTEGER            :: LUA
      INTEGER            :: LUB
      INTEGER            :: NLM
      INTEGER            :: NPAG
      INTEGER            :: IOST = 0
      CHARACTER(len=1)   :: ICH
      CHARACTER(len=132) :: PRBUF
      CHARACTER(len=250) :: PSBUF
      WRITE (LUB, 99999, IOSTAT = IOST) NPAG
      WRITE (LUB, 99998, IOSTAT = IOST)
      NB = 1
      NE = 132
      NP = 0
      NL = NLM
      DO
        READ (LUA, 99995, IOSTAT = IOST) PRBUF
        IF (IOST == -1) EXIT
        IF (PRBUF(1:1) == CHAR (12)) THEN
          BACKSPACE LUA
          READ (LUA, 99994, IOSTAT = IOST) PRBUF
          IF (IOST == -1) CYCLE
          NP = NP + 1
          IF (NP > 1) WRITE (LUB, 99996, IOSTAT = IOST)
          WRITE (LUB, 99997, IOSTAT = IOST) NP, NP
          NL = 0
        END IF
        NL = NL + 1
        IF (NL >= NLM) THEN
          NP = NP + 1
          IF (NP > 1) WRITE (LUB, 99996, IOSTAT = IOST)
          WRITE (LUB, 99997, IOSTAT = IOST) NP, NP
          NL = 1
        END IF
        N = 0
        CALL GEN039 (1, PRBUF, 1, 132, NB, NE)
        DO I = 1, NE
          ICH = PRBUF(I:I)
          IF (ICH /= CHAR (0)) THEN
            IF (ICH == '(' .OR. ICH == ')') THEN
              N = N + 1
              PSBUF(N:N) = CHAR (92)
            END IF
            N = N + 1
            PSBUF(N:N) = ICH
          END IF
        END DO
        WRITE (LUB, 99993, IOSTAT = IOST) PSBUF(1:N)
      END DO
      WRITE (LUB, 99992, IOSTAT = IOST)
      RETURN
99999 FORMAT ('%!PS-Adobe-2.0', /,'%%Creator: PLATON - A.L.Spek', /,
     1  '%%BoundingBox: 0 0 612 792', /, '%%Pages:', I6, /,
     2  '%%PageOrder: Ascend', /, '%%EndComments', /,
     3  '%%BeginSetup', /,
     3  ' /FONT (Courier) cvn def', /,
     4  ' /FONT_SIZE 9.000000 def', /,
     5  ' /XLMARGIN 25 def', /,
     6  ' /XRMARGIN 10 def', /,
     7  ' /YPAGE 612 def', /,
     8  ' /XPAGE 792 def', /,
     9  ' /YTMARGIN 30 def', /,
     *  ' /YBMARGIN 10 def', /,
     1  ' /PAGENUM 1 def', /,
     2  ' /bd {bind def} bind def', /,
     3  ' /m {moveto} bd ', /,
     4  ' /gs {gsave} bd', /,
     5  ' /gr {grestore} bd',
     6  ' /tr {translate} bd', /,
     7  ' /rt {rotate} bd', /,
     8  ' /PAGES_PER_SHEET 1 def')
99998 FORMAT (
     1  ' /sp {/SAVEOBJ save def gs 0 XPAGE tr -90 rt } bd', /,
     2  ' /np { gr showpage SAVEOBJ restore sp bp} bd', /,
     3  ' FONT findfont FONT_SIZE scalefont setfont', /,
     4  ' /FONT_UPPER currentfont', /,
     5  ' /FontBBox get 3 get 0 exch currentfont', /,
     6  ' /FontMatrix get transform exch pop def', /,
     7  ' /FONT_LOWER currentfont', /,
     8  ' /FontBBox get 1 get 0 exch currentfont', /,
     9  ' /FontMatrix get transform exch pop def', /,
     *  ' /FONT_HT  FONT_UPPER FONT_LOWER sub def', /,
     1  ' FONT_HT 0 eq {/FONT_HT FONT_SIZE def } if', /,
     2  ' /FONT_MOVE FONT_SIZE FONT_HT gt {FONT_SIZE def}',
     3  ' {FONT_HT def} ifelse', /,
     4  ' /FONT_TOL FONT_HT YBMARGIN add def', /,
     4  ' /bp { XLMARGIN YPAGE YTMARGIN sub FONT_UPPER sub m } bd', /,
     5  ' /s { show  currentpoint exch pop dup FONT_TOL',
     6  ' gt {FONT_MOVE sub XLMARGIN  exch m} {np} ifelse}  bd', /,
     7  '%%EndSetup', /, 'sp', /, 'bp')
99997 FORMAT ('%%Page:', 2I7)
99996 FORMAT ('np')
99995 FORMAT (A)
99994 FORMAT (1X, A)
99993 FORMAT ('(', A, ')s')
99992 FORMAT ('np', /, '%%EOF')
      END SUBROUTINE GEN089
 
      INTEGER FUNCTION GEN090 (I, J)
C * BITWISE LOGICAL AND
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: J
      INTEGER :: N
      INTEGER :: I0
      INTEGER :: I1
      INTEGER :: I2
      INTEGER :: I3
      I0 = 0
      I1 = I
      I2 = J
      I3 = 1
      N  = 1
   10 IF (MOD (I1, 2) == 1 .AND. MOD (I2, 2) == 1) I0 = I0 + I3
      IF (N < 15) THEN
        N  = N  + 1
        I1 = I1 / 2
        I2 = I2 / 2
        I3 = I3 * 2
        GO TO 10
      END IF
      GEN090 = I0
      RETURN
      END FUNCTION GEN090
 
      SUBROUTINE GEN091 (X, T, KUSER, KUSR, NATO, NAT, ITEM)
C * SORT ARRAY X(*, *) IN ORDER FOR ITEM
      IMPLICIT NONE
      INTEGER                      :: I
      INTEGER                      :: J
      INTEGER                      :: K
      INTEGER                      :: L
      INTEGER                      :: M
      INTEGER                      :: NAT
      INTEGER                      :: KUSR
      INTEGER                      :: NATO
      INTEGER                      :: ITEM
      INTEGER                      :: IFIN
      INTEGER                      :: KUSER
      REAL, DIMENSION(KUSER, KUSR) :: X
      REAL, DIMENSION(KUSR)        :: T
      IF (NAT > 1) THEN
        M = 2
   10   M = 2 * M
        IF (M < NAT) GO TO 10
        M  = MIN0 (NAT, (3 * M) / 4 - 1)
        DO
          M  = M / 2
          IFIN = NAT - M
          DO L = 1, IFIN
            I = L
            J = I + M
            IF (X(NATO + I, ITEM) < X(NATO + J, ITEM)) THEN
              DO K = 1, KUSR
                T(K) = X(NATO + J, K)
              END DO
   20         DO K = 1, KUSR
                X(NATO + J, K) = X(NATO + I, K)
              END DO
              J = I
              I = I - M
              IF (I > 0) THEN
                IF (X(NATO + I, ITEM) < T(ITEM)) GO TO 20
              END IF
              DO K = 1, KUSR
                X(NATO + J, K) = T(K)
              END DO
            END IF
          END DO
          IF (M == 1) EXIT
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN091
 
      SUBROUTINE GEN092 (MODL, H, TM, NUM)
C * TEST LATTICE TYPE
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: NUM
      INTEGER               :: MODL
      REAL                  :: DM
      REAL, DIMENSION(3)    :: H
      REAL, DIMENSION(3, 3) :: TM
      NUM = 0
      DO J = 1, 3
        DM = 0.0
        DO I = 1, 3
          DM = DM + H(I) * TM(I, J)
        END DO
        NUM = NUM + MOD (NINT (ABS (DM)), MODL)
      END DO
      RETURN
      END SUBROUTINE GEN092
 
      SUBROUTINE GEN093 (IDOF, CSQ, IP)
C * SUBROUTINE RETURNS IP='P>95' FOR CONF HYPOT. WITH P > 0.95
C *                    IP='P<5 ' FOR                  P < 0.5
C *                    IP='    ' FOR      UNDEFINED
      IMPLICIT NONE
      INTEGER             :: IDOF
      REAL                :: CSQ
      REAL, DIMENSION(20) :: P95 = (/
     1 0.0, 0.1, 0.22, 0.71, 1.15, 1.70, 2.20, 2.70, 3.30, 3.94, 4.50,
     2 5.2, 6.0, 6.6, 7.26, 8.0, 8.65, 9.4, 10.1, 10.85/)
      REAL, DIMENSION(20) :: P5  = (/
     1 3.84, 5.99, 7.81, 9.49, 11.07, 12.5, 14.0, 15.5, 17.0, 18.31,
     2 19.8, 21.0, 22.2, 23.75, 25.0, 26.2, 27.5, 29.0, 30.2, 31.41/)
      CHARACTER(len=4)    :: IP
      IP = '    '
      IF (IDOF <= 20 .AND. IDOF > 0) THEN
        IF (CSQ <= P95(IDOF)) IP = 'P>95'
        IF (CSQ > P5(IDOF))  IP = 'P<5 '
      END IF
      RETURN
      END SUBROUTINE GEN093
 
      SUBROUTINE GEN094 (X, V, IDEV, IDUM)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: IDEV
      INTEGER               :: IDUM
      REAL                  :: DM
      REAL, DIMENSION(3, 3) :: X
      REAL, DIMENSION(3)    :: V
C * TEST LATTICE TYPE
      IDUM = 0
      DO J = 1, 3
        DM = 0.0
        DO I = 1, 3
          DM = DM + X(I, J) * V(I)
        END DO
        IDUM = IDUM + MOD (NINT (ABS (DM)), IDEV)
      END DO
      RETURN
      END SUBROUTINE GEN094
 
      REAL FUNCTION GEN095 (P, IH, IK, IL)
C * CALCULATE (SIN(THETA) / LAMBDA)**2
      IMPLICIT NONE
      INTEGER            :: IH
      INTEGER            :: IK
      INTEGER            :: IL
      REAL, DIMENSION(6) :: P
      GEN095 = 0.25 * (IH**2 * P(1) + IK**2 * P(2)
     1       + IL**2 * P(3) + 2.0 * (IK * IL * P(4)
     2       + IH * IL * P(5) + IH * IK * P(6)))
      RETURN
      END FUNCTION GEN095
 
      SUBROUTINE GEN096 (T, IROTX, IROTY, IROTZ, IDET, U, PHI, ROM)
C * MAP THE NINE ELEMENTS OF T INTO ROTX, ROTY, ROTZ, IDET
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: IROTX
      INTEGER               :: IROTY
      INTEGER               :: IROTZ
      INTEGER               :: IDET
      REAL                  :: AL
      REAL                  :: BE
      REAL                  :: GA
      REAL                  :: RTD
      REAL                  :: PHI
      REAL                  :: T11A
      REAL                  :: T12A
      REAL                  :: T22A
      REAL                  :: T32A
      REAL                  :: XLNG
      REAL                  :: XNORM
      REAL                  :: COSPH
      REAL                  :: TEKEN
      REAL, DIMENSION(3, 3) :: T
      REAL, DIMENSION(3, 3) :: ROM
      REAL, DIMENSION(3)    :: U
      REAL, DIMENSION(3)    :: V
      REAL, DIMENSION(15)   :: Z
      CALL GEN010 (T, IDET, 0)
      RTD = 0.0
      AL  = 0.0
      BE  = 0.0
      GA  = 0.0
      IF (IDET /= 0) THEN
        CALL GEN010 (T, IDET, -1)
        RTD = 45.0 / ATAN (1.0)
        IF (ABS (T(1, 1)) + ABS (T(2, 1)) > 0.00001)
     1    GA = ATAN2(T(2, 1), T(1, 1))
        T11A =   T(1, 1)  * COS (GA) + T(2, 1) * SIN (GA)
        T12A =   T(1, 2)  * COS (GA) + T(2, 2) * SIN (GA)
        T22A =  -T(1, 2)  * SIN (GA) + T(2, 2) * COS (GA)
        IF (ABS (T(3, 1)) + ABS (T11A) > 0.00001)
     1    BE = ATAN2 (-T(3, 1), T11A)
        T32A = SIN (BE) * T12A + COS (BE) * T(3, 2)
        IF (ABS (T32A) + ABS (T22A) > 0.00001)
     1    AL = ATAN2 (T32A, T22A)
C * DETERMINE EQUIVALENT VIEW DIRECTION AND SUBSEQUENT Z-ROTATION
        DO I = 1, 3
          V(I)      = T(3, I)
          Z(6 + I)  = T(3, I)
          Z(I + 9)  = T(2, I)
          Z(I + 12) = 0.0
        END DO
        IF (ABS (Z(8)) > 0.9999) THEN
          Z(13) = 1.0
        ELSE
          Z(14) = 1.0
        END IF
        CALL GEN008 (Z(13), Z(7), Z(1), 1)
        CALL GEN008 (Z(7), Z(1), Z(4), 1)
        COSPH = MAX (MIN (1.0, Z(4) * Z(10) + Z(5) * Z(11)
     1      + Z(6) * Z(12)), -1.0)
        CALL GEN008 (Z(4), Z(10), Z(13), 1)
        TEKEN = Z(7) * Z(13) + Z(8) * Z(14) + Z(9) * Z(15)
        PHI = SIGN (ACOS (COSPH) * RTD, TEKEN)
        CALL GEN002 (1, ROM, V, U, XLNG)
C * SCALE ABSOLUTE VALUE OF LARGEST COMPONENT OF DIRECTION VECTOR TO 1.0
        XNORM = MAX (ABS (U(1)), ABS (U(2)), ABS (U(3)))
        IF (XNORM /= 0.0) THEN
          DO I = 1, 3
            U(I) = U(I) / XNORM
          END DO
        END IF
C * RESTORE T - MATRIX
        CALL GEN010 (T, IDET, -1)
      END IF
      IROTX = - NINT (AL * RTD)
      IROTY = - NINT (BE * RTD)
      IROTZ = - NINT (GA * RTD)
      RETURN
      END SUBROUTINE GEN096
 
      SUBROUTINE GEN097 (IA, N1, N2, IVALUE)
C * SET INTEGER ARRAY ON VALUE
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: N1
      INTEGER               :: N2
      INTEGER               :: IVALUE
      INTEGER, DIMENSION(*) :: IA
      DO I = N1, N2
        IA(I) = IVALUE
      END DO
      RETURN
      END SUBROUTINE GEN097
 
      SUBROUTINE GEN098 (M, X, N, ITX, ITY, ITZ, IRES)
C * SPLIT-UP ARU CODE IN COMPONENTS
      IMPLICIT NONE
      INTEGER :: M
      INTEGER :: N
      INTEGER :: ITX
      INTEGER :: ITY
      INTEGER :: ITZ
      INTEGER :: IRES
      INTEGER :: IARU
      INTEGER :: MABS
      REAL    :: X
      IARU = NINT (X)
      MABS = IABS (M)
      ITX  = MOD (MABS / (100 * IARU), 10) - 5
      ITY  = MOD (MABS / (10  * IARU), 10) - 5
      ITZ  = MOD (MABS / IARU,         10) - 5
      IRES = MOD (MABS,  IARU)
      N    = MABS / (1000 * IARU)
      RETURN
      END SUBROUTINE GEN098
 
      SUBROUTINE GEN099 (A, B, C)
C * FORM QUADRATIC FORM
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3, 3) :: C
      REAL, DIMENSION(3)    :: B
      DO I = 1, 3
        DO J = 1, 3
          C(I, J) = 0.0
          DO K = 1, 3
            C(I, J) = C(I, J) + A(I, K) * A(J, K) * B(K)
          END DO
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN099
 
      SUBROUTINE GEN100 (AO, J, X, Y, Z)
C * TLS MATRIX
      IMPLICIT NONE
      INTEGER             :: J
      REAL                :: X
      REAL                :: Y
      REAL                :: Z
      REAL, DIMENSION(20) :: AO
      CALL GEN074 (AO, 1, 20, 0.0)
      IF (J == 1) THEN
        AO(4)  =   Z * Z
        AO(6)  =   Y * Y
        AO(5)  = - 2 * Y * Z
        AO(19) = - 2 * Y
        AO(16) =   2 * Z
        AO(7)  =   1.0
      ELSE IF (J == 2) THEN
        AO(6)  = - X * Y
        AO(5)  =   X * Z
        AO(3)  =   Y * Z
        AO(2)  = - Z * Z
        AO(13) = - Z
        AO(17) =   Z
        AO(19) =   X
        AO(20) = - Y
        AO(8)  =   1.0
      ELSE IF (J == 3) THEN
        AO(4)  = - X * Z
        AO(5)  =   X * Y
        AO(3)  = - Y * Y
        AO(2)  =   Y * Z
        AO(13) =   2 * Y
        AO(17) =   Y
        AO(18) =   Z
        AO(16) = - X
        AO(9)  =   1.0
      ELSE IF (J == 4) THEN
        AO(1)  =   Z * Z
        AO(6)  =   X * X
        AO(3)  = - 2 * X * Z
        AO(14) = - 2 * Z
        AO(20) =   2 * X
        AO(10) =   1.0
      ELSE IF (J == 5) THEN
        AO(1)  = - Y * Z
        AO(5)  = - X * X
        AO(3)  =   X * Y
        AO(2)  =   X * Z
        AO(13) = - X
        AO(17) = - 2 * X
        AO(14) =   Y
        AO(15) = - Z
        AO(11) =   1.0
      ELSE IF (J == 6) THEN
        AO(1)  =   Y * Y
        AO(4)  =   X * X
        AO(2)  = - 2 * X * Y
        AO(18) = - 2 * X
        AO(15) =   2 * Y
        AO(12) =   1.0
      END IF
      RETURN
      END SUBROUTINE GEN100
 
      SUBROUTINE GEN101 (M, N, DHX)
C * GENERATE INDEX COMBINATIONS
      IMPLICIT NONE
      INTEGER               :: M
      INTEGER               :: N
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: I1
      INTEGER               :: I3
      INTEGER               :: I4
      INTEGER               :: I5
      INTEGER               :: J1
      INTEGER               :: J3
      INTEGER               :: J4
      INTEGER               :: J5
      INTEGER               :: K1
      INTEGER               :: K3
      INTEGER               :: K4
      INTEGER               :: K5
      INTEGER               :: NN
      INTEGER               :: IJK
      REAL, DIMENSION(3, *) :: DHX
      N  = 3
      DO I = 0, M
        I1 = MOD (I, 2)
        I3 = MOD (I, 3)
        I4 = MOD (I, 5)
        I5 = MOD (I, 7)
        J  = - M -1
        DO
          J  = J + 1
          IF (J > M) EXIT
          J1 = MOD (J, 2)
          J3 = MOD (J, 3)
          J4 = MOD (J, 5)
          J5 = MOD (J, 7)
          K  = -M -1
          DO
            K  = K + 1
            IF (K > M) EXIT
            K1 = MOD (K, 2)
            K3 = MOD (K, 3)
            K4 = MOD (K, 5)
            K5 = MOD (K, 7)
            IF (I * J * K == 0) THEN
              IF (ABS (I1) + ABS (J1) + ABS (K1) == 0) CYCLE
              IF (ABS (I3) + ABS (J3) + ABS (K3) == 0) CYCLE
              IF (ABS (I4) + ABS (J4) + ABS (K4) == 0) CYCLE
              IF (ABS (I5) + ABS (J5) + ABS (K5) == 0) CYCLE
              IF (I < 0) THEN
                CYCLE
              ELSE IF (I == 0) THEN
                IF (J < 0) THEN
                  CYCLE
                ELSE IF (J == 0) THEN
                  IF (K < 0) CYCLE
                END IF
              END IF
            ELSE
              IF (ABS (I1) + ABS (J1) == 0) CYCLE
              IF (ABS (I1) + ABS (K1) == 0) CYCLE
              IF (ABS (J1) + ABS (K1) == 0) CYCLE
              IF (ABS (I3) + ABS (J3) == 0) CYCLE
              IF (ABS (I3) + ABS (K3) == 0) CYCLE
              IF (ABS (J3) + ABS (K3) == 0) CYCLE
              IF (ABS (I4) + ABS (J4) == 0) CYCLE
              IF (ABS (I4) + ABS (K4) == 0) CYCLE
              IF (ABS (J4) + ABS (K4) == 0) CYCLE
              IF (ABS (I5) + ABS (J5) == 0) CYCLE
              IF (ABS (I5) + ABS (K5) == 0) CYCLE
              IF (ABS (J5) + ABS (K5) == 0) CYCLE
            END IF
C * PUT 1,0,0 0,1,0 and 0,0,1 up-front
            IJK = I * 10000 + J * 100 + K
            IF (IJK == 10000) THEN
              NN = 1
            ELSE IF (IJK == 100) THEN
              NN = 2
            ELSE IF (IJK == 1) THEN
              NN = 3
            ELSE
              N  = N + 1
              NN = N
            END IF
            DHX(1, NN) = I
            DHX(2, NN) = J
            DHX(3, NN) = K
          END DO
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN101
 
      SUBROUTINE GEN102 (IS, KEY, SWS, NM)
C * TRANSFORM KEYWORD TO ENTRYPOINT NUMBER IN ARRAY
      IMPLICIT NONE
      INTEGER                        :: N
      INTEGER                        :: IS
      INTEGER                        :: NM
      CHARACTER(len=4), DIMENSION(*) :: SWS
      CHARACTER(len=4)               :: KEY
      IS = 1
      DO N = 1, NM
        IF (KEY == SWS(N)) THEN
          IS = N + 1
          EXIT
        END IF
      END DO
      RETURN
      END SUBROUTINE GEN102
 
      SUBROUTINE GEN103 (LINE, N)
C * COMPACT LINE TO ONE BLANK SEPARATOR
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: NBL
      CHARACTER(len=*) :: LINE
      CHARACTER(len=1) :: ICH
      M   = 0
      NBL = 1
      DO I = 1, N
        ICH = LINE(I:I)
        IF (ICH == ' ') THEN
          NBL = NBL + 1
          IF (NBL == 1) THEN
            M = M + 1
            LINE(M:M) = ICH
          ELSE
            CYCLE
          END IF
        ELSE
          M   = M + 1
          NBL = 0
          LINE(M:M) = ICH
        END IF
      END DO
      M = M + 1
      IF (M <= N) CALL GEN038 (LINE, M, N)
      RETURN
      END SUBROUTINE GEN103
 
 
      SUBROUTINE GEN104 (LAT, C, A)
C * CHECK FOR TRIVIAL TRANSFORMATIONS
      USE genrl
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: N1
      INTEGER               :: N2
      INTEGER               :: N3
      INTEGER               :: LAT
      REAL                  :: DET
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(3, 3) :: B
      REAL, DIMENSION(3, 3) :: C
C * LAT = 1 TRICLINIC
C * LAT = 2 MONOCLINIC
C * LAT = 3 ORTHORHOMBIC
C * LAT = 4 TETRAGONAL
C * LAT = 5 TRIGONAL/RHOMBOHEDRAL
C * LAT = 6 HEXAGONAL
C * LAT = 7 CUBIC
C * UNIT MATRIX
      CALL GEN021 (A, 1.0)
C * INVERT
      CALL GEN003 (C, B, DET, 0)
      IF (ABS (DET - 1.0) < 0.001 .AND. LAT > 1) THEN
        N1 = NINT (C(1, 1)) * 100 + NINT (C(1, 2)) * 10 + NINT (C(1, 3))
     1     + 111
        N2 = NINT (C(2, 1)) * 100 + NINT (C(2, 2)) * 10 + NINT (C(2, 3))
     1     + 111
        N3 = NINT (C(3, 1)) * 100 + NINT (C(3, 2)) * 10 + NINT (C(3, 3))
     1     + 111
        DO I = 1, 30
          IF (IT (LAT + 2, I) /= 0) THEN
            IF (N1 == IT(1, I) .AND. N2 == IT(2, I) .AND.
     1          N3 == IT(3, I)) THEN
C * COPY
              CALL GEN052 (B, A)
C * UNIT MATRIX
              CALL GEN021 (C, 1.0)
              RETURN
            END IF
          END IF
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN104
 
      SUBROUTINE GEN105 (MODE, ICH, N)
C * MODE = 1 - SEARCH FOR UPPER CASE CHAR
C * MODE = 2 - SEARCH FOR LOWER CASE CHAR
C * MODE = 3 - SEARCH FOR NUMERAL
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: N
      INTEGER          :: MODE
      CHARACTER(len=1) :: ICH
      N = - 1
C * CHECK FOR UPPER CASE
      IF (MODE == 1) THEN
        DO I = ICHAR ('A'), ICHAR ('Z')
          IF (ICH == CHAR (I)) THEN
            N = I
            EXIT
          END IF
        END DO
C * CHECK FOR LOWER CASE
      ELSE IF (MODE == 2) THEN
        DO I = ICHAR ('a'), ICHAR ('z')
          IF (ICH == CHAR (I)) THEN
            N = I
            EXIT
          END IF
        END DO
C * CHECK FOR NUMERAL
      ELSE IF (MODE == 3) THEN
        DO I = 1, 10
          IF (ICH == CHAR (ICHAR ('0') - 1 + I)) THEN
            N = I
            EXIT
          END IF
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN105
 
      SUBROUTINE GEN106 (V, STH, PSI, AA, BB, V6, V8, PAR)
C * SUBROUTINE CONVERTS PSI(H.FLACK) TO DIRECTION COSINES (SHELDRICK)
      IMPLICIT NONE
      INTEGER               :: K
      REAL                  :: STH
      REAL                  :: CTH
      REAL                  :: PSI
      REAL                  :: XLNG
      REAL, DIMENSION(3)    :: V
      REAL, DIMENSION(3)    :: V1
      REAL, DIMENSION(3)    :: V2
      REAL, DIMENSION(3)    :: V3
      REAL, DIMENSION(3)    :: V4
      REAL, DIMENSION(3)    :: V6
      REAL, DIMENSION(3)    :: V8
      REAL, DIMENSION(3, 3) :: AA
      REAL, DIMENSION(3, 3) :: BB
      REAL, DIMENSION(6)    :: PAR
      CTH = SQRT(1.0 - STH**2)
C * GET NORMALIZED CONTRAVARIANT COMPONENTS OF HKL
      CALL GEN002 (-1, BB, V, V6, XLNG)
      CALL GEN007 (AA, V6, V1, -1)
C * FIND VECTOR PERPENDICULAR TO HKL
      IF (V(1) == V(2) .AND. V(2) == V(3)) THEN
        V6(1) =   V(1)
        V6(2) = - V(1)
        V6(3) =   0.0
      ELSE
        V6(1) = V(2) - V(3)
        V6(2) = V(3) - V(1)
        V6(3) = V(1) - V(2)
      END IF
C * NORMALIZE V6
      CALL GEN007 (AA, V6, V2, -1)
C * MAKE NORMALISED VECTOR V1 X V2
      CALL GEN008 (V1, V2, V6, 0)
      CALL GEN002 (-1, BB, V6, V8, XLNG)
      CALL GEN007 (AA, V8, V3, -1)
C * GET VECTOR PERPENDICULAR TO HKL IN DIFFRACTION PLANE
      DO K = 1, 3
        V4(K) =  V3(K) * COS (PSI) + V2(K) * SIN (PSI)
        V6(K) = (V1(K) * STH + V4(K) * CTH) / PAR(K)
        V8(K) = (V1(K) * STH - V4(K) * CTH) / PAR(K)
      END DO
      RETURN
      END SUBROUTINE GEN106
 
      SUBROUTINE GEN107 (IA, N, M)
C * REDUCE VECTOR
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: N
      INTEGER               :: M
      INTEGER               :: MN
      INTEGER, DIMENSION(*) :: IA
      M  = 1
      MN = 99999
      DO I = 1, N
        IF (IA(I) > 0) MN = MIN (MN, IA(I))
      END DO
      DO 10 I = 1, MN
        M = MN + 1 - I
        DO J = 1, N
          IF (MOD (IA(J), M) /= 0) GOTO 10
        END DO
        DO J = 1, N
          IA(J) = IA(J) / M
        END DO
        EXIT
   10 CONTINUE
      RETURN
      END SUBROUTINE GEN107
 
      SUBROUTINE GEN108 (LU, MODE)
C * REWIND/ENDFILE
      IMPLICIT NONE
      INTEGER           :: LU
      INTEGER           :: MODE
      INTEGER           :: IOST
      CHARACTER(len=80) :: LINE
      IF (MODE /= 0) THEN
        ENDFILE (LU, IOSTAT = IOST)
        IF (IOST /= 0) THEN
          WRITE (LINE, 99998) LU
          CALL TRAILER (LINE)
          RETURN
        END IF
      END IF
      REWIND (LU, IOSTAT = IOST)
      IF (IOST /= 0) THEN
        WRITE (LINE, 99999) LU
        CALL TRAILER (LINE)
      END IF
      RETURN
99999 FORMAT ('W: REWIND  PROBLEM FOR UNIT ', I5)
99998 FORMAT ('W: ENDFILE PROBLEM FOR UNIT ', I5)
      END SUBROUTINE GEN108
 
      SUBROUTINE GEN109 (M, N, X, Y, Z, F, NP)
C * Generates spherical harmonic functions in terms of orthogonal
C * direction cosines up to odd order M and even order N.  X,Y,Z are
C * the direction cosines and the functions are returned in F(1..NP).
C * The functions have not been normalized
      IMPLICIT NONE
      INTEGER                         :: M
      INTEGER                         :: N
      INTEGER                         :: NP
      REAL                            :: X
      REAL                            :: Y
      REAL                            :: Z
      REAL                            :: U
      REAL                            :: V
      REAL                            :: W
      REAL                            :: Q
      REAL                            :: T
      REAL                            :: XX
      REAL                            :: YY
      REAL                            :: ZZ
      REAL                            :: XY
      REAL                            :: XZ
      REAL                            :: YZ
      DOUBLE PRECISION, DIMENSION(81) :: F
      XX = X**2
      YY = Y**2
      ZZ = Z**2
      XY = X * Y
      XZ = X * Z
      YZ = Y * Z
      U  = XX - YY
      V  = 3.0 * XX - YY
      W  = XX - 3.0 * YY
      T  = XX * (XX - 6.0 * YY) + YY**2
      NP = 0
C * EVEN TERMS
      IF (N >= 2) THEN
        NP   = 5
        F(1) = 1.5 * ZZ - 0.5
        F(2) = 3.0 * XZ
        F(3) = 3.0 * YZ
        F(4) = 3.0 * U
        F(5) = 6.0 * XY
        IF (N >= 4) THEN
          NP    = 14
          F(6)  = ZZ     * (4.375 * ZZ -3.75) + 0.375
          F(7)  = XZ     * (17.5 * ZZ -7.5)
          F(8)  = YZ     * (17.5 * ZZ -7.5)
          F(9)  = (52.5  * ZZ - 7.5) * U
          F(10) = (105.0 * ZZ - 15.0) * XY
          F(11) = 105.0  * XZ * W
          F(12) = 105.0  * YZ * V
          F(13) = 105.0  * T
          F(14) = 420.0  * XY * U
          IF (N >= 6) THEN
            NP    = 27
            F(15) = ZZ * (ZZ * (14.4375 * ZZ - 19.6875) + 6.5625)
     1            - 0.3125
            F(16) = XZ * (ZZ * (86.625 * ZZ - 78.75) + 13.125)
            F(17) = YZ * (ZZ * (86.625 * ZZ - 78.75) + 13.125)
            F(18) = (ZZ * (433.125 * ZZ - 236.25) + 13.125) * U
            F(19) = (ZZ * (866.25 * ZZ - 472.5) + 26.25) * XY
            F(20) = XZ * (1732.5 * ZZ - 472.5) * W
            F(21) = YZ * (1732.5 * ZZ - 472.5) * V
            F(22) = (5197.5 * ZZ - 472.5) * T
            F(23) = XY * (20790.0 * ZZ - 1890.0) * U
            F(24) = 10395.0 * XZ * (XX * (XX - 10.0 * YY)
     1            + 5.0 * YY**2)
            F(25) = 10395.0 * YZ * (XX * (5.0 * XX - 10.0 * YY)
     1            + YY**2)
            F(26) = 10395.0 * (XX * (XX * (XX - 15.0) * YY
     1            + 15.0 * YY**2) - YY**3)
            F(27) = 62370.0 * XY * (XX * (XX - 3.333333 * YY) + YY**2)
            IF (N >= 8) THEN
              NP    = 44
              F(28) = (((50.2734375 * ZZ - 93.84375) * ZZ
     1              + 54.140625) * ZZ - 9.84375) * ZZ + 0.2734375
              Q     = ((402.1875 * ZZ - 563.0625) * ZZ
     1              + 216.5625) * ZZ - 19.6875
              F(29) = XZ * Q
              F(30) = YZ * Q
              Q     = ((2815.3125 * ZZ - 2815.3125) * ZZ
     1              + 649.6875) * ZZ - 19.6875
              F(31) = U * Q
              F(32) = 2.0 * XY * Q
              Q     = (16891.875 * ZZ - 11261.25) * ZZ + 1299.375
              F(33) = XZ * Q * W
              F(34) = YZ * Q * V
              Q     = (84459.375 * ZZ - 33783.75) * ZZ + 1299.375
              F(35) = Q * T
              F(36) = 4.0 * XY * Q * U
              Q     = 337837.5 * ZZ - 67567.5
              F(37) = XZ * Q * (XX * (XX - 10.0 * YY) + 5.0 * YY**2)
              F(38) = YZ * Q * (XX * (5.0 * XX - 10.0 * YY) + YY**2)
              Q     = 1013512.5 * ZZ - 67567.5
              F(39) = Q * (XX * (XX * (XX - 15.0 * YY)
     1              + 15.0 * YY**2) - YY**3)
              F(40) = Q * XY * (XX * (6.0 * XX - 20.0 * YY)
     1              + 6.0 * YY**2)
              F(41) = 2027025.0 * XZ * (XX * (XX * (XX - 21.0 *YY)
     1              + 35.0 * YY**2) - 7.0 * YY**3)
              F(42) = 2027025.0 * YZ * (XX * (XX * (7.0 * XX
     1              - 35.0 * YY) + 21.0 * YY**2) - YY**3)
              F(43) = 2027025.0 * (XX * (XX * (XX * (XX - 28.0 * YY)
     1              + 70.0 * YY**2) - 28.0 * YY**3) + YY**4)
              F(44) = 16216200.0 * XY * (XX * (XX * (XX - 7.0 * YY)
     1              + 7.0 * YY**2) - YY**3)
            END IF
          END IF
        END IF
      END IF
C * ODD TERMS
      IF (M >= 1) THEN
        NP        = NP + 3
        F(NP - 2) = Z
        F(NP - 1) = X
        F(NP)     = Y
        IF (M >= 3) THEN
          NP        = NP + 7
          F(NP - 6) = Z * (2.5 * ZZ - 1.5)
          Q         = 7.5 * ZZ - 1.5
          F(NP - 5) = X * Q
          F(NP - 4) = Y * Q
          F(NP - 3) = 15.0 * Z * U
          F(NP - 2) = 30.0 * X * YZ
          F(NP - 1) = 15.0 * X * W
          F(NP)     = 15.0 * Y * V
          IF (M >= 5) THEN
            NP         = NP + 11
            F(NP - 10) = Z * (ZZ * (ZZ * 7.875 - 8.75) + 1.875)
            Q          = ZZ * (39.375 * ZZ - 26.25) + 1.875
            F(NP -  9) = X * Q
            F(NP -  8) = Y * Q
            Q          = Z * (157.5 * ZZ - 52.5)
            F(NP -  7) = Q * U
            F(NP -  6) = 2.0 * Q * XY
            Q          = 472.5 * ZZ - 52.5
            F(NP -  5) = Q * X * W
            F(NP -  4) = Q * Y * V
            F(NP -  3) = 945.0 * Z * T
            F(NP -  2) = 3780.0 * Z * XY * U
            F(NP -  1) = 945.0 * X * (XX * (XX - 10.0 * YY)
     1                 + 5.0 * YY**2)
            F(NP)      = 945.0 * Y * (XX * (5.0 * XX - 10.0 * YY)
     1                 + YY**2)
            IF (M >= 7) THEN
              NP         = NP + 15
              F(NP - 14) = Z * (ZZ * (ZZ * (ZZ * 26.8125 - 43.3125)
     1                   + 19.6875) - 2.1875)
              Q          = ZZ * (ZZ * (ZZ * 187.6875 - 216.5625)
     1                   + 59.0625) - 2.1875
              F(NP - 13) = X * Q
              F(NP - 12) = Y * Q
              Q          = Z * (ZZ * (ZZ * 1126.125 - 866.25)
     1                   + 118.125)
              F(NP - 11) = Q * U
              F(NP - 10) = 2.0 * XY * Q
              Q          = ZZ * (ZZ * 5630.625 - 2598.75) + 118.125
              F(NP -  9) = Q * X * W
              F(NP -  8) = Q * Y * V
              Q          = Z * (22522.5 * ZZ - 5197.5)
              F(NP -  7) = Q * T
              F(NP -  6) = 4.0 * Q * XY * U
              Q          = 67567.5 * ZZ - 5197.5
              F(NP -  5) = Q * X * (XX * (XX - 10.0 *YY) + 5.0 * YY**2)
              F(NP -  4) = Q * Y * (XX * (5.0 * XX -10.0 * YY) + YY**2)
              F(NP -  3) = 135135.0 * Z * (XX * (XX * (XX - 15.0 * YY)
     1                   + 15.0 * YY**2) - YY**3)
              F(NP -  2) = 810810.0 * Z * XY * (XX * (XX
     1                   - 3.333333 * YY)
     1               + YY**2)
              F(NP -  1) = 135135.0 * X * (XX * (XX * (XX - 21.0 * YY)
     1                   + 35.0 * YY**2) - 7.0 * YY**3)
              F(NP)      = 135135.0 * Y * (XX * (XX * (7.0 * XX
     1                   - 35.0 * YY) + 21.0 * YY**2) - YY**3)
            END IF
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN109
 
      SUBROUTINE GEN110 (NP, NN, C, B)
C * Cholesky factorization
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: K
      INTEGER                         :: L
      INTEGER                         :: M
      INTEGER                         :: N
      INTEGER                         :: NP
      INTEGER                         :: NN
      INTEGER                         :: NI
      DOUBLE PRECISION, DIMENSION(NP) :: C
      DOUBLE PRECISION, DIMENSION(NN) :: B
      DOUBLE PRECISION                :: DT
C * Invert lower triangular matrix B and multiply by vector C.
C * NN should be NP*(NP+1) where NP is the number of l.s. parameters.
      M = 0
      I = 0
      DO N = 1, NP
        I = I + 1
        L = I
        M = 1
        J = 1
  10    IF (J /= I) THEN
          B(I) = B(I) * B(J)
          C(N) = C(N) - B(I) * C(M)
          M    = M + 1
          NI   = I
          I    = I + 1
          J    = J + 1
          DT   = B(I)
          DO K = L, NI
            DT = DT - B(J) * B(K)
            J  = J  + 1
          END DO
          B(I) = DT
          GO TO 10
        END IF
        B(I) = 1.0 / DSQRT (B(I))
        C(N) = C(N) * B(I)
      END DO
C * Calculate and add shifts
      DT   = C(M)
  20  C(M) = DT * B(I)
      I    = I - M
      M    = M - 1
      IF (M < 1) RETURN
      DT   = C(M)
      K    = I + M
      DO N = M + 1, NP
        DT = DT - C(N) * B(K)
        K  = K  + N
      END DO
      GO TO 20
      RETURN
      END SUBROUTINE GEN110
 
      SUBROUTINE GEN111 (A, B, N, M)
C * MANIPULATE CHEMICAL FORMULA
      IMPLICIT NONE
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: KMOVE
      CHARACTER(len=*) :: A
      CHARACTER(len=2) :: B
      B = ' '
      M = 0
      L = 0
      DO 10 J = 1, N
        DO K = 48, 122
          IF (A(J:J) == CHAR(K)) THEN
            IF (K < 58) THEN
              M = M * 10 + K - 48
              GO TO 10
            ELSE IF (K > 64) THEN
              IF (L < 2) THEN
                IF (K > 96) THEN
                  KMOVE = 32
                ELSE
                  KMOVE = 0
                END IF
                L = L + 1
                B(L:L) = CHAR(K - KMOVE)
              END IF
            END IF
          END IF
        END DO
  10  CONTINUE
      RETURN
      END SUBROUTINE GEN111
 
      SUBROUTINE GEN112 (A, B, MODE)
C * CONVERT 3*3 MATRIX to 9 VECTOR AND REVERSE
      IMPLICIT NONE
      INTEGER               :: MODE
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(*)    :: B
      IF (MODE > 0) THEN
        A(1, 1) = B(1)
        A(1, 2) = B(2)
        A(1, 3) = B(3)
        A(2, 1) = B(4)
        A(2, 2) = B(5)
        A(2, 3) = B(6)
        A(3, 1) = B(7)
        A(3, 2) = B(8)
        A(3, 3) = B(9)
      ELSE
        B(1) = A(1, 1)
        B(2) = A(1, 2)
        B(3) = A(1, 3)
        B(4) = A(2, 1)
        B(5) = A(2, 2)
        B(6) = A(2, 3)
        B(7) = A(3, 1)
        B(8) = A(3, 2)
        B(9) = A(3, 3)
      END IF
      RETURN
      END SUBROUTINE GEN112
 
      SUBROUTINE GEN113 (A, B, N)
C * COPY VECTOR WITH N ELEMENTS
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: N
      REAL, DIMENSION(*) :: A
      REAL, DIMENSION(*) :: B
      DO I = 1, N
        B(I) = A(I)
      END DO
      RETURN
      END SUBROUTINE GEN113
 
      SUBROUTINE GEN114 (PAR, OR, UIJ, UIL, DUMA, RIK, UEQ)
C * GET MAIN AXES AND VALUES OF UIJ TENSOR
      IMPLICIT NONE
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      REAL                  :: UEQ
      REAL                  :: DET
      REAL                  :: SUMX
      REAL, DIMENSION(*)    :: PAR
      REAL, DIMENSION(6)    :: DUMA
      REAL, DIMENSION(3, 3) :: OR
      REAL, DIMENSION(3, 3) :: ROR
      REAL, DIMENSION(3, 3) :: UIJ
      REAL, DIMENSION(3, 3) :: RIK
      REAL, DIMENSION(3, 3) :: RLJ
      REAL, DIMENSION(3, 3) :: UKL
      REAL, DIMENSION(3, 3) :: UIL
      CALL GEN003 (OR, ROR, DET, 0)
      DO K = 1, 3
        DO L = 1, 3
          RLJ(K, L) = 0.0
          IF (K == L) RLJ(K, K) = PAR(112 + K)
        END DO
      END DO
      CALL GEN004 (OR, RLJ, UKL)
      CALL GEN001 (1, UKL, UIJ, UIL)
C * GET EIGENVECTOR AND VALUES
      CALL GEN024 (UIL, RIK, DUMA, RLJ)
C * SWAP 1 & 3
      CALL GEN018 (DUMA(1), DUMA(3))
      CALL GEN018 (RLJ(1, 1), RLJ(1, 3))
      CALL GEN018 (RLJ(2, 1), RLJ(2, 3))
      CALL GEN018 (RLJ(3, 1), RLJ(3, 3))
      CALL GEN004 (ROR, RLJ, RIK)
      DO J = 1, 3
        SUMX = SQRT (RIK(1, J)**2 + RIK(2, J)**2 + RIK(3, J)**2)
        RIK(1, J) = RIK(1, J) / SUMX
        RIK(2, J) = RIK(2, J) / SUMX
        RIK(3, J) = RIK(3, J) / SUMX
      END DO
      UEQ = (DUMA(1) + DUMA(2) + DUMA(3)) / 3.0
      RETURN
      END SUBROUTINE GEN114
 
      SUBROUTINE GEN115 (X, W, N)
C * GAUSSIAN INTEGRATION COEFFICIENTS
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: J
      INTEGER            :: N
      INTEGER            :: M
      REAL, DIMENSION(*) :: X
      REAL, DIMENSION(*) :: W
      DOUBLE PRECISION   :: Z
      DOUBLE PRECISION   :: Z1
      DOUBLE PRECISION   :: P1
      DOUBLE PRECISION   :: P2
      DOUBLE PRECISION   :: P3
      DOUBLE PRECISION   :: PP
      DOUBLE PRECISION   :: XM
      DOUBLE PRECISION   :: XL
      M  = (N + 1) / 2
      XM = 0.5D0
      XL = 0.5D0
      DO I = 1, M
        Z = COS (3.141592654D0 * (I - 0.25D0) / (N + 0.5D0))
   10   CONTINUE
        P1 = 1.D0
        P2 = 0.D0
        DO J = 1, N
          P3 = P2
          P2 = P1
          P1 = ((2.0D0 * J - 1.0D0) * Z * P2 - (J - 1.0D0) * P3) / J
        END DO
        PP = N * (Z * P1 - P2) / (Z * Z - 1.0D0)
        Z1 = Z
        Z  = Z1 - P1 / PP
        IF (ABS (Z - Z1) > 3.0D-14) GO TO 10
        X(I)         = REAL (XM - XL * Z)
        X(N + 1 - I) = REAL (XM + XL * Z)
        W(I)         = REAL (2.D0 * XL / ((1.0D0 - Z * Z) * PP * PP))
        W(N + 1 - I) = W(I)
      END DO
      RETURN
      END SUBROUTINE GEN115
 
      SUBROUTINE GEN116 (MODE, Y, W, N, GRAPH, LU)
C * MODE = 1: SUBROUTINE GENERATES A HALFNORMAL PROBABILITY PLOT.
C * MODE = 2: SUBROUTINE GENERATES A NORMAL (GAUSSIAN) PROBABILITY PLOT
C * THE PROTOTYPE HALFNORMAL DISTRIBUTION USED HEREIN
C * HAS MEAN = SQRT(2/PI) = 0.79788456 AND STANDARD DEVIATION = 1.
C * THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X AND HAS THE
C * PROBABILITY DENSITY FUNCTION F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C * THE PROTOTYPE HALFNORMAL DISTRIBUTION USED HEREIN IS THE DISTRIBUTION
C * OF THE VARIATE X = ABS(Z) WHERE THE VARIATE Z IS NORMALLY DISTRIBUTED
C * WITH MEAN = 0 AND STANDARD DEVIATION = 1. AS USED HEREIN, A PROBABILITY
C * PLOT FOR A DISTRIBUTION IS A PLOT OF THE ORDERED OBSERVATIONS VERSUS
C * THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION. THE HALFNORMAL
C * PROBABILITY PLOT IS USEFUL IN GRAPHICALLY TESTING THE COMPOSITE (THAT IS,
C * LOCATION AND SCALE PARAMETERS NEED NOT BE SPECIFIED) HYPOTHESIS THAT THE
C * UNDERLYING DISTRIBUTION FROM WHICH THE DATA HAVE BEEN RANDOMLY DRAWN
C * IS THE HALFNORMAL DISTRIBUTION. IF THE HYPOTHESIS IS TRUE, THE PROBABILITY
C * PLOT SHOULD BE NEAR-LINEAR. A MEASURE OF SUCH LINEARITY IS GIVEN BY THE
C * CALCULATED PROBABILITY PLOT CORRELATION COEFFICIENT.
C * THE PROTOTYPE NORMAL DISTRIBUTION USED HEREIN HAS MEAN = 0 AND STANDARD
C * DEVIATION = 1. THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS THE
C * PROBABILITY DENSITY FUNCTION  F(X) = (1/SQRT(2*PI)) * EXP(-X*X/2).
C * AS USED HEREIN, A PROBABILITY PLOT FOR A DISTRIBUTION IS A PLOT OF THE
C * ORDERED OBSERVATIONS VERSUS THE ORDER STATISTIC MEDIANS FOR THAT
C * DISTRIBUTION. THE NORMAL PROBABILITY PLOT IS USEFUL IN GRAPHICALLY TESTING
C * THE COMPOSITE (THAT IS, LOCATION AND SCALE PARAMETERS NEED NOT BE SPECIFIED)
C * HYPOTHESIS THAT THE UNDERLYING DISTRIBUTION FROM WHICH THE DATA HAVE BEEN
C * RANDOMLY DRAWN IS THE NORMAL DISTRIBUTION. IF THE HYPOTHESIS IS TRUE,
C * THE PROBABILITY PLOT SHOULD BE NEAR-LINEAR. A MEASURE OF SUCH LINEARITY
C * IS GIVEN BY THE CALCULATED PROBABILITY PLOT CORRELATION COEFFICIENT.
 
C * INPUT ARGUMENTS - Y = THE SINGLE PRECISION VECTOR OF (UNSORTED)
C * OBSERVATIONS.
C *                 - N = THE INTEGER NUMBER OF OBSERVATIONS IN THE VECTOR Y.
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: N
      INTEGER                        :: LU
      INTEGER                        :: MODE
      REAL                           :: Q
      REAL, DIMENSION(*)             :: Y
      REAL, DIMENSION(*)             :: W
      CHARACTER(len=*), DIMENSION(*) :: GRAPH
C * SORT THE DATA
      CALL GEN035 (Y, 1, N)
C * GENERATE UNIFORM ORDER STATISTIC MEDIANS
      CALL GEN117 (N, W)
C * COMPUTE (HALF)NORMAL ORDER STATISTIC MEDIANS
      DO I = 1, N
        Q = W(I)
        IF (MODE == 1) Q = (Q + 1.0) / 2.0
        CALL GEN118 (Q, W(I))
      END DO
 
C * CALCULATE CORRELATION COEFFICIENT, DIRECTION COEFF ETC.
      CALL GEN119 (MODE, Y, W, N)
C * PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. WRITE OUT
C * THE TAIL LENGTH MEASURE OF THE DISTRIBUTION AND THE SAMPLE SIZE.
      CALL GEN120 (MODE, Y, W, N, GRAPH, LU)
      RETURN
      END SUBROUTINE GEN116
 
      SUBROUTINE GEN117 (N, X)
C * THIS SUBROUTINE GENERATES THE N ORDER STATISTIC MEDIANS FROM THE
C * UNIFORM (RECTANGULAR) DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C * THIS DISTRIBUTION HAS MEAN = 0.5 AND STANDARD DEVIATION = SQRT(1/12) =
C * 0.28867513. THIS DISTRIBUTION HAS THE PROBABILITY DENSITY FUNCTION F(X) = 1.
C * A PROBABILITY PLOT FOR A GENERAL DISTRIBUTION IS A PLOT OF THE ORDERED
C * OBSERVATIONS VERSUS THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION.
C * THE I-TH ORDER STATISTIC MEDIAN FOR A GENERAL DISTRIBUTION IS OBTAINED BY
C * TRANSFORMING THE I-TH UNIFORM ORDER STATISTIC MEDIAN BY THE PERCENT POINT
C * FUNCTION OF THE DESIRED DISTRIBUTION--HENCE THE IMPORTANCE OF BEING ABLE TO
C * GENERATE UNIFORM ORDER STATISTIC MEDIANS. IT IS OF THEORETICAL INTEREST
C * TO NOTE THAT THE I-TH UNIFORM ORDER STATISTIC MEDIAN IN A SAMPLE OF SIZE
C * N IS IDENTICALLY THE MEDIAN OF THE BETA DISTRIBUTION WITH PARAMETERS I
C * AND N-I+1.
C * INPUT  - N = THE DESIRED INTEGER NUMBER OF UNIFORM ORDER
C *              STATISTIC MEDIANS TO BE GENERATED.
C * OUTPUT - X = A SINGLE PRECISION VECTOR (OF DIMENSION AT LEAST N)
C *              INTO WHICH THE GENERATED UNIFORM ORDER STATISTIC
C *                     MEDIANS WILL BE PLACED.
C * OUTPUT - THE N ORDER STATISTIC MEDIANS FROM THE RECTANGULAR DISTRIBUTION
C *         ON (0,1).
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: N
      REAL, DIMENSION(*) :: X
C * COMPUTE THE MEDIANS FOR THE FIRST AND LAST ORDER STATISTICS
      X(N) = 0.5 ** (1.0 / FLOAT (N))
      X(1) = 1.0 - X(N)
      IF (N > 2) THEN
C * COMPUTE THE MEDIANS FOR THE OTHER ORDER STATISTICS
C * NOTE: 0.365 = 1.0 - 2 * 0.3175
        DO I = 2, N - 1
          X(I) = (FLOAT (I) - 0.3175) / (FLOAT (N) + 0.365)
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN117
 
      SUBROUTINE GEN118 (P, PPF)
C * THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION VALUE FOR THE
C * NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C * THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY
C * FUNCTION F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). NOTE THAT THE PERCENT POINT
C * FUNCTION OF A DISTRIBUTION IS IDENTICALLY THE SAME AS THE INVERSE
C * CUMULATIVE DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C * INPUT  - P   = THE SINGLE PRECISION VALUE (BETWEEN 0.0 AND 1.0)
C *                AT WHICH THE PERCENT POINT FUNCTION IS TO BE EVALUATED.
C * OUTPUT - PPF = THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE.
      IMPLICIT NONE
      REAL :: P
      REAL :: R
      REAL :: T
      REAL :: P0
      REAL :: P1
      REAL :: P2
      REAL :: P3
      REAL :: P4
      REAL :: Q0
      REAL :: Q1
      REAL :: Q2
      REAL :: Q3
      REAL :: Q4
      REAL :: PPF
      REAL :: ANUM
      REAL :: ADEN
      DATA P0, P1, P2, P3, P4, Q0, Q1, Q2, Q3, Q4/
     1 -0.322232431088, -1.0, -0.342242088547, -0.204231210245E-1,
     2 -0.453642210148E-4,  0.993484626060E-1, 0.588581570495,
     C  0.531103462366, 0.103537752850, 0.38560700634E-2/
      IF (P == 0.5) THEN
        PPF = 0.0
      ELSE
        R = P
        IF (P > 0.5) R = 1.0 - R
        T = SQRT (-2.0 * ALOG (R))
        ANUM = ((((T * P4 + P3) * T + P2) * T + P1) * T + P0)
        ADEN = ((((T * Q4 + Q3) * T + Q2) * T + Q1) * T + Q0)
        PPF  = T + (ANUM / ADEN)
        IF (P < 0.5) PPF = - PPF
      END IF
      RETURN
      END SUBROUTINE GEN118
 
      SUBROUTINE GEN119 (MODE, Y, X, N)
C * COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. COMPUTE LOCATION
C * AND SCALE ESTIMATES FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT.
C * MODE = 1: SUBROUTINE GENERATES A HALFNORMAL PROBABILITY PLOT.
C * MODE = 2: SUBROUTINE GENERATES A NORMAL (GAUSSIAN) PROBABILITY PLOT
      USE npplot
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: N
      INTEGER            :: MODE
      REAL               :: SUM1
      REAL               :: SUM2
      REAL               :: SUM3
      REAL               :: YBAR
      REAL               :: WBAR
      REAL, DIMENSION(*) :: X
      REAL, DIMENSION(*) :: Y
      SUM1 = 0.0
      SUM2 = 0.0
      WBAR = 0.0
      DO I = 1, N
        SUM1 = SUM1 + Y(I)
        IF (MODE == 1) SUM2 = SUM2 + X(I)
      END DO
      YBAR = SUM1 / FLOAT (N)
      IF (MODE == 1) WBAR = SUM2 / FLOAT (N)
      SUM1 = 0.0
      SUM2 = 0.0
      SUM3 = 0.0
      DO I = 1, N
        IF (MODE == 1) THEN
          SUM1 = SUM1 + (Y(I) - YBAR) * (Y(I) - YBAR)
          SUM2 = SUM2 + (Y(I) - YBAR) * (X(I) - WBAR)
          SUM3 = SUM3 + (X(I) - WBAR) * (X(I) - WBAR)
        ELSE IF (MODE == 2) THEN
          SUM1 = SUM1 + (Y(I) - YBAR) * (Y(I) - YBAR)
          SUM2 = SUM2 + X(I) * Y(I)
          SUM3 = SUM3 + X(I) * X(I)
        END IF
      END DO
      IF (SUM1 /= 0.0) THEN
        YCC = SUM2 / SQRT (SUM3 * SUM1)
      ELSE
        YCC = 1.0
      END IF
      YSLOPE = SUM2 / SUM3
      YINT   = YBAR - YSLOPE * WBAR
      RETURN
      END SUBROUTINE GEN119
 
      SUBROUTINE GEN120 (MODE, Y, X, N, GRAPH, LU)
C * THIS SUBROUTINE YIELDS A ONE-PAGE PRINTER PLOT OF Y(I) VERSUS X(I).
C * INPUT  - Y  = THE SINGLE PRECISION VECTOR OF (UNSORTED OR SORTED)
C *               OBSERVATIONS TO BE PLOTTED VERTICALLY.
C *        - X  = THE SINGLE PRECISION VECTOR OF (UNSORTED OR SORTED)
C *               OBSERVATIONS TO BE PLOTTED HORIZONTALLY.
C *        - N  = THE INTEGER NUMBER OF OBSERVATIONS IN THE VECTOR Y.
C * OUTPUT - A ONE-PAGE PRINTER PLOT OF Y(I) VERSUS X(I).
C * VALUES IN THE VERTICAL AXIS VECTOR (Y) OR THE HORIZONTAL AXIS
C * VECTOR (X) WHICH ARE EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE PLOTTED.
C * THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM OF PLOTTING WHEN SOME
C * ELEMENTS IN THE VECTOR Y (OR X) ARE 'MISSING DATA', OR WHEN WE PURPOSELY
C * WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y (OR X) FOR PLOTTING
C * PURPOSES (THAT IS, WE DO NOT WANT CERTAIN ELEMENTS IN Y (OR X) TO BE
C * PLOTTED).
C * MODE = 1: SUBROUTINE GENERATES A HALFNORMAL PROBABILITY PLOT.
C * MODE = 2: SUBROUTINE GENERATES A NORMAL (GAUSSIAN) PROBABILITY PLOT
      USE npplot
      IMPLICIT NONE
      INTEGER                           :: I
      INTEGER                           :: J
      INTEGER                           :: K
      INTEGER                           :: N
      INTEGER                           :: LU
      INTEGER                           :: MX
      INTEGER                           :: MY
      INTEGER                           :: IM2
      INTEGER                           :: MODE
      INTEGER                           :: IOST
      INTEGER                           :: IFLAG
      REAL                              :: X25
      REAL                              :: X75
      REAL                              :: AIM1
      REAL                              :: XMIN
      REAL                              :: XMAX
      REAL                              :: XMID
      REAL                              :: YMIN
      REAL                              :: YMAX
      REAL                              :: RATIOX
      REAL                              :: RATIOY
      REAL, DIMENSION(*)                :: X
      REAL, DIMENSION(*)                :: Y
      REAL, DIMENSION(11)               :: YLABLE
      CHARACTER(len=125), DIMENSION(44) :: GRAPH
      IOST = 0
C * DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS
      YMIN = Y(1)
      YMAX = Y(N)
      YMAX = MAX ( 3.5, YMAX)
      YMIN = MIN (-3.5, YMIN)
      IF (MODE == 1) YMIN = 0.0
      DO I = 1, 9
        AIM1 = I - 1
        YLABLE(I) = YMAX - (AIM1 / 8.0) * (YMAX - YMIN)
      END DO
C * DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS
C * DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND X75 (=THE 75% POINT)
      XMIN = X(1)
      XMAX = X(N)
      XMID = (XMIN + XMAX) / 2.0
      X25  = 0.75 * XMIN + 0.25 * XMAX
      X75  = 0.25 * XMIN + 0.75 * XMAX
C * BLANK OUT THE GRAPH
      DO I = 1, 44
        GRAPH(I) = ' '
      END DO
C * PRODUCE THE VERTICAL AXES
      DO I = 2, 42
        GRAPH(I)(20:20)   = 'I'
        GRAPH(I)(124:124) = 'I'
      END DO
      DO I = 2, 42, 5
        GRAPH(I)(20:20)   = '-'
        GRAPH(I)(124:124) = '-'
      END DO
      GRAPH(2)(16:19)   = '=Max'
      GRAPH(22)(16:19)  = '=Mid'
      GRAPH(42)(16:19)  = '=Min'
      GRAPH(42)(64:120) =
     1 'Vertical: Experimental Data, Horizontal: Theoretical Data'
      IF (MODE == 1) THEN
        GRAPH(3)(22:49) = 'Half-Normal Probability Plot'
      ELSE IF (MODE == 2) THEN
        GRAPH(3)(22:44) = 'Normal Probability Plot'
      ELSE IF (MODE == 3) THEN
        GRAPH(3)(22:47) = 'Student-t Probability Plot'
      END IF
      GRAPH(3)(51:111) =
     1 '(S.C.Abrahams and E.T.Keve (1971). Acta Cryst. A27, 157-165.)'
      WRITE (GRAPH(5)(22:47), 99996, IOSTAT = IOST) N
      WRITE (GRAPH(6)(22:47), 99995, IOSTAT = IOST) YCC
      WRITE (GRAPH(7)(22:47), 99994, IOSTAT = IOST) YINT
      WRITE (GRAPH(8)(22:47), 99993, IOSTAT = IOST) YSLOPE
C * PRODUCE THE HORIZONTAL AXES
      DO J = 22, 122
        GRAPH(1)(J:J)  = '-'
        GRAPH(43)(J:J) = '-'
      END DO
      DO J = 22, 122, 25
        GRAPH(1)(J:J)  = 'I'
        GRAPH(43)(J:J) = 'I'
      END DO
      DO J = 35, 122, 25
        GRAPH(1)(J:J)  = 'I'
        GRAPH(43)(J:J) = 'I'
      END DO
C * DETERMINE THE (X,Y) PLOT POSITIONS
      RATIOY =  40.0 / (YMAX - YMIN)
      RATIOX = 100.0 / (XMAX - XMIN)
      DO I = 1, N
        MX = NINT (RATIOX * (X(I) - XMIN))
        MX = MX + 22
        MY = NINT (RATIOY * (Y(I) - YMIN))
        MY = 42 - MY
        GRAPH(MY)(MX:MX) = 'x'
      END DO
C * WRITE OUT THE GRAPH
      DO I = 1, 44
        IF (I == 44) THEN
          WRITE (GRAPH(44), 99997, IOSTAT = IOST)
     1      XMIN, X25, XMID, X75, XMAX
        ELSE
          IM2   = I - 2
          IFLAG = IM2 - (IM2 / 5) * 5
          K     = IM2 / 5 + 1
          IF (IFLAG == 0)
     1      WRITE (GRAPH(I)(1:15), 99998, IOSTAT = IOST) YLABLE(K)
        END IF
        IF (LU /= 0) WRITE (LU, 99999, IOSTAT = IOST) GRAPH(I)
      END DO
      RETURN
99999 FORMAT (A)
99998 FORMAT (F15.3)
99997 FORMAT (5(9X, F16.3))
99996 FORMAT ('Sample Size    =', I10)
99995 FORMAT ('CC             =', F10.4)
99994 FORMAT ('Est. Intercept =', F10.4)
99993 FORMAT ('Est. Slope     =', F10.4)
      END SUBROUTINE GEN120
 
      SUBROUTINE GEN121 (NQ, N)
C * ELIMINATE () FROM STRING
      IMPLICIT NONE
      INTEGER           :: N
      INTEGER           :: N1
      INTEGER           :: N2
      CHARACTER(len=*)  :: NQ
      CHARACTER(len=12) :: NQ1
      NQ1 = NQ
      N1  = INDEX (NQ1(1:N), '(')
      N2  = INDEX (NQ1(1:N), ')')
      IF (N1 /= 0 .AND. N2 .NE. 0) THEN
        NQ = NQ1(1:N1 -1)//NQ1(N1+1:N2-1)//NQ1(N2+1:N+2)
      END IF
      RETURN
      END SUBROUTINE GEN121
 
      SUBROUTINE GEN122 (AXES, NS, ITEL)
C * BUBBLE SORT AXES ON VALUE OF COLUMN NS
      IMPLICIT NONE
      INTEGER                 :: I
      INTEGER                 :: J
      INTEGER                 :: NS
      INTEGER                 :: ITEL
      INTEGER                 :: ICHANGE
      REAL, DIMENSION(15, 23) :: AXES
      DO
        ICHANGE = 0
        DO J = 1, (ITEL - 1)
          IF (AXES(J, NS) > AXES(J + 1, NS)) THEN
            DO I = 1, 13
              CALL GEN018 (AXES(J, I), AXES(J + 1, I))
            END DO
            CALL GEN018 (AXES(J, 23), AXES(J + 1, 23))
            ICHANGE = 1
          END IF
        END DO
        IF (ICHANGE == 0) EXIT
      END DO
      RETURN
      END SUBROUTINE GEN122
 
      SUBROUTINE GEN123 (MODE, IEN, IENS, IEL, IAN)
C * SORT FORMULA INTO C H D .. ALPHABETIC ORDER
C * OR ALPHABETIC WHEN C ABSENT
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: IAN
      INTEGER               :: IVAL
      INTEGER               :: IENI
      INTEGER               :: MODE
      INTEGER, DIMENSION(*) :: IEN
      INTEGER, DIMENSION(*) :: IEL
      INTEGER, DIMENSION(*) :: IENS
      DO I = 1, IAN
        IENI = IEN(I)
        IF (MODE == 1) THEN
          IF (IENI == 2) THEN
            IVAL = 0
          ELSE IF (IENI == 1) THEN
            IVAL = 1
          ELSE IF (IENI == 33) THEN
            IVAL = 2
          ELSE
            IVAL = IEL(IENI)
          END IF
        ELSE
          IVAL = IEL(IENI)
        END IF
        IENS(I) = IVAL * 100 + I
      END DO
      CALL GEN022 (IENS, 1, IAN, 1)
      DO I = 1, IAN
        IENS(I) = MOD (IENS(I), 100)
      END DO
      RETURN
      END SUBROUTINE GEN123
 
      SUBROUTINE GEN124 (NA, NB, NE)
C * SHELL-SORT FROM NB TO NE, STEP 2 (SMALL TO LARGE)
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: NY
      INTEGER               :: NZ
      INTEGER               :: ND
      INTEGER               :: NB
      INTEGER               :: NE
      INTEGER               :: NEL
      INTEGER               :: NDS
      INTEGER, DIMENSION(*) :: NA
      NEL = (NE - NB + 1) / 2
      IF (NEL >= 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (NEL)) / ALOG (2.0)) + 1.0E-5)) - 1
        DO
          IF (ND <= 0) EXIT
          NDS = ND + ND
          I   = NB
          DO
            J   = I
            NY = NA(I + NDS)
            NZ = NA(I + NDS + 1)
   10       IF (NY < NA(J)) THEN
              NA(J + NDS)     = NA(J)
              NA(J + NDS + 1) = NA(J + 1)
              J = J - NDS
              IF (J >= NB) GO TO 10
            END IF
            NA(J + NDS)     = NY
            NA(J + NDS + 1) = NZ
            I = I + 2
            IF (I + NDS > NE) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN124
 
      SUBROUTINE GEN125 (MODE, LO, STR)
C * WRITE SPECIAL STRING
      IMPLICIT NONE
      INTEGER          :: IOST = 0
      INTEGER          :: MODE
      INTEGER          :: LO
      CHARACTER(LEN=*) :: STR
      IF (MODE == 0) THEN
        WRITE (LO, 99999, ADVANCE = 'NO', IOSTAT = IOST) STR
      ELSE
        WRITE (LO, 99998, ADVANCE = 'NO', IOSTAT = IOST) STR
      END IF
      RETURN
99999 FORMAT (A)
99998 FORMAT (/, A)
      END SUBROUTINE GEN125
 
      SUBROUTINE GEN126 (C, N, M)
C * BLANK STRING ARRAY
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: N
      INTEGER                         :: M
      CHARACTER(len=*), DIMENSION(*)  :: C
      DO I = N, M
        C(I) = ' '
      END DO
      RETURN
      END  SUBROUTINE GEN126
 
      SUBROUTINE GEN127 (C)
C * EXIT/STOP
      IMPLICIT NONE
      INTEGER           :: IOST = 0
      CHARACTER(len=*)  :: C
      CHARACTER(len=70) :: LINE
      CHARACTER(len=70) :: LINF
      IF (C(1:1) /= ' ') THEN
        WRITE (LINE, 99999, IOSTAT = IOST) C
        WRITE (LINF, 99998)
        CALL TRAILER (' ')
        CALL TRAILER (LINF)
        CALL TRAILER (LINE)
        CALL TRAILER (LINF)
        STOP
      ELSE
        CALL EXIT
      END IF
99999 FORMAT ('>>> STOP: ', A, ' <<< (Job ABORTED)')
99998 FORMAT (67('*'))
      END SUBROUTINE GEN127
 
      SUBROUTINE GEN129 (LU, STRING)
C * DELETE FILE
      IMPLICIT NONE
      LOGICAL          :: EXST
      INTEGER          :: LU
      INTEGER          :: LENGTH
      CHARACTER(len=*) :: STRING
      LENGTH = LEN (STRING)
      INQUIRE (FILE = STRING(1:LENGTH), EXIST = EXST)
      IF (EXST) THEN
        OPEN  (LU, FILE = STRING(1:LENGTH), STATUS = 'UNKNOWN')
        CLOSE (LU, STATUS = 'DELETE')
      END IF
      RETURN
      END SUBROUTINE GEN129
 
      REAL FUNCTION GEN130 (A)
C * DETERMINANT OF 3*3 MATRIX
      IMPLICIT NONE
      REAL, DIMENSION(3, 3) :: A
      GEN130 =
     1        A(1, 1) * (A(2, 2) * A(3, 3) - A(2, 3) * A(3, 2))
     2      - A(1, 2) * (A(2, 1) * A(3, 3) - A(2, 3) * A(3, 1))
     3      + A(1, 3) * (A(2, 1) * A(3, 2) - A(2, 2) * A(3, 1))
      RETURN
      END FUNCTION GEN130
 
      SUBROUTINE GEN131 (LHNT, I, J, K, L, IDET)
C * DETERMINANT OF 3*3 MATRIX FROM  EXTENDED ARRAY
      IMPLICIT NONE
      INTEGER                     :: I
      INTEGER                     :: J
      INTEGER                     :: K
      INTEGER                     :: L
      INTEGER                     :: IDET
      INTEGER, DIMENSION(4, 3, 5) :: LHNT
      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 GEN131
 
      SUBROUTINE GEN132 (T1, Y, T2, Z)
C * Z = T1 * Y * T2
      IMPLICIT NONE
      REAL, DIMENSION(3, 3) :: X
      REAL, DIMENSION(3, 3) :: Y
      REAL, DIMENSION(3, 3) :: Z
      REAL, DIMENSION(3, 3) :: T1
      REAL, DIMENSION(3, 3) :: T2
      CALL GEN004 (Y, T2, X)
      CALL GEN004 (T1, X, Z)
      RETURN
      END SUBROUTINE GEN132
 
      SUBROUTINE GEN133 (IA, IB, N)
C * COPY VECTOR WITH N ELEMENTS
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: N
      INTEGER, DIMENSION(*) :: IA
      INTEGER, DIMENSION(*) :: IB
      DO I = 1, N
        IB(I) = IA(I)
      END DO
      RETURN
      END SUBROUTINE GEN133
 
      SUBROUTINE GEN134 (STR1, STR2, NB, NE)
C * COPY FORMULA STRINGS
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: M
      INTEGER          :: N
      INTEGER          :: LB
      INTEGER          :: LE
      INTEGER          :: NB
      INTEGER          :: NE
      CHARACTER(len=1) :: ICH
      CHARACTER(len=*) :: STR1
      CHARACTER(len=*) :: STR2
      LB = NB
      LE = NE
C * STRIP FRONT AND BACK BLANCS
      CALL GEN039 (0, STR1, NB, NE, LB, LE)
      N = 0
      DO I = LB, LE
        ICH = STR1(I:I)
        IF (ICH == '[') EXIT
C * CHECK FOR UPPER CASE CHARACTER
        CALL GEN105 (1, ICH, M)
        IF (M > 0) THEN
          N = N + 1
        ELSE
          N = 0
        END IF
        IF (N == 2) THEN
          N = 0
          CALL GEN020 (-1, ICH, 1, 1)
          STR1(I:I) = ICH
        END IF
      END DO
      STR2 = STR1(LB:LE)
      RETURN
      END SUBROUTINE GEN134
 
      INTEGER FUNCTION GEN135 (A)
C * UNIT 3*3 MATRIX ?
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL                  :: DIAG
      REAL, DIMENSION(3, 3) :: A
      GEN135 = 0
      DIAG   = 0.0
      DO I = 1, 3
        DO J = 1, 3
          IF (I == J) THEN
            DIAG = DIAG + ABS (A(I, J) - 1.0)
          ELSE
            DIAG = DIAG + ABS (A(I, J))
          END IF
        END DO
      END DO
      IF (NINT(DIAG) == 0) GEN135 = 1
      RETURN
      END FUNCTION GEN135
 
      SUBROUTINE GEN136 (X, GA)
C * Purpose: Compute the gamma function a(x)
C * Input :  x  --- Argument of a(x)
C *        ( x is not equal to 0,-1,-2,uuu )
C * Output:  GA --- a(x)
      IMPLICIT NONE
      INTEGER                         :: K
      INTEGER                         :: M
      INTEGER                         :: M1
      DOUBLE PRECISION                :: X
      DOUBLE PRECISION                :: Z
      DOUBLE PRECISION                :: R
      DOUBLE PRECISION                :: GA
      DOUBLE PRECISION                :: GR
      DOUBLE PRECISION                :: PI
      DOUBLE PRECISION, DIMENSION(26) :: G
      G = (/
     1  1.0D0,
     2  0.5772156649015329D0,
     3 -0.6558780715202538D0,
     4 -0.420026350340952D-1,
     5  0.1665386113822915D0,
     6 -0.421977345555443D-1,
     7 -0.96219715278770D-2,
     8  0.72189432466630D-2,
     9 -0.11651675918591D-2,
     * -0.2152416741149D-3,
     1  0.1280502823882D-3,
     2 -0.201348547807D-4,
     3 -0.12504934821D-5,
     4  0.11330272320D-5,
     5 -0.2056338417D-6,
     6  0.61160950D-8,
     7  0.50020075D-8,
     8 -0.11812746D-8,
     9  0.1043427D-9,
     *  0.77823D-11,
     1 -0.36968D-11,
     2  0.51D-12,
     3 -0.206D-13,
     4 -0.54D-14,
     5  0.14D-14,
     6  0.1D-15
     7  /)
      PI = 3.141592653589793D0
      IF (X == INT (X)) THEN
        IF (X > 0.0D0) THEN
          GA = 1.0D0
          M1 = INT (X) - 1
          DO K = 2, M1
            GA = GA * K
          END DO
        ELSE
          GA = 1.0D + 300
        ENDIF
      ELSE
        IF (DABS (X) > 1.0D0) THEN
          Z = DABS (X)
          M = INT (Z)
          R = 1.0D0
          DO K = 1, M
            R = R * (Z - K)
          END DO
          Z = Z - M
        ELSE
          Z = X
        ENDIF
        GR = G(26)
        DO K = 25, 1, -1
          GR = GR * Z + G(K)
        END DO
        GA = 1.0D0 / (GR * Z)
        IF (DABS (X) > 1.0D0) THEN
          GA = GA * R
          IF (X < 0.0D0) GA = - PI / (X * GA * DSIN (PI * X))
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE GEN136
 
      SUBROUTINE GEN137 (X, PS)
C * Purpose: Compute Psi function
C * Input :  x  --- Argument of psi(x)
C * Output:  PS --- psi(x)
      IMPLICIT NONE
      INTEGER          :: K
      INTEGER          :: N
      DOUBLE PRECISION :: X
      DOUBLE PRECISION :: S
      DOUBLE PRECISION :: PS
      DOUBLE PRECISION :: XA
      DOUBLE PRECISION :: PI
      DOUBLE PRECISION :: EL
      DOUBLE PRECISION :: X2
      DOUBLE PRECISION :: A1
      DOUBLE PRECISION :: A2
      DOUBLE PRECISION :: A3
      DOUBLE PRECISION :: A4
      DOUBLE PRECISION :: A5
      DOUBLE PRECISION :: A6
      DOUBLE PRECISION :: A7
      DOUBLE PRECISION :: A8
      XA = DABS (X)
      PI = 3.141592653589793D0
      EL = 0.5772156649015329D0
      S = 0.0D0
      IF (X == INT (X) .AND. X <= 0.0D+0) THEN
        PS = 1.0D + 300
        RETURN
      ELSE IF (XA == INT (XA)) THEN
        N = INT (XA)
        DO K = 1, N - 1
          S = S + 1.0D0 / K
        END DO
        PS = - EL + S
      ELSE IF (XA + 0.5D+0 == INT (XA + 0.5D+0)) THEN
        N = INT (XA - 0.5D+0)
        DO  K = 1, N
          S = S + 1.0D+0 / (2.0D0 * K - 1.0D0)
        END DO
        PS = - EL + 2.0D0 * S - 1.386294361119891D0
      ELSE
        IF (XA < 10.0D+0) THEN
          N = 10 - INT (XA)
          DO K = 0, N - 1
            S = S + 1.0D0 / (XA + K)
          END DO
          XA = XA + N
        END IF
        X2 = 1.0D0 / (XA * XA)
        A1 = -0.8333333333333D-01
        A2 = 0.83333333333333333D-02
        A3 = -0.39682539682539683D-02
        A4 = 0.41666666666666667D-02
        A5 = -0.75757575757575758D-02
        A6 = 0.21092796092796093D-01
        A7 = -0.83333333333333333D-01
        A8 = 0.4432598039215686D0
        PS = DLOG (XA) - 0.5D0 / XA + X2 * (((((((A8 * X2 + A7) * X2 +
     1        A6) * X2 + A5) * X2 + A4) * X2 + A3) * X2 + A2) * X2 + A1)
        PS = PS - S
      END IF
      IF (X < 0.0D+0)
     1    PS = PS - PI * DCOS (PI * X) / DSIN (PI * X) - 1.0D0 / X
      RETURN
      END SUBROUTINE GEN137
 
      SUBROUTINE GEN138 (A, B, C, X, HF)
C * Purpose: Compute hypergeometric function F(a,b,c,x)
C * Input :  a --- Parameter
C *          b --- Parameter
C *          c --- Parameter, c <> 0,-1,-2,...
C *          x --- Argument   ( x < 1 )
C * Output:  HF --- F(a,b,c,x)
C * Routines called:
C *         (1) GEN136 for computing gamma function
C *         (2) GEN137 for computing psi function
      IMPLICIT NONE
      INTEGER           :: J
      INTEGER           :: K
      INTEGER           :: M
      INTEGER           :: NM
      INTEGER           :: IOST = 0
      DOUBLE PRECISION  :: A
      DOUBLE PRECISION  :: B
      DOUBLE PRECISION  :: C
      DOUBLE PRECISION  :: X
      DOUBLE PRECISION  :: R
      DOUBLE PRECISION  :: AA
      DOUBLE PRECISION  :: BB
      DOUBLE PRECISION  :: F0
      DOUBLE PRECISION  :: F1
      DOUBLE PRECISION  :: X1
      DOUBLE PRECISION  :: R0
      DOUBLE PRECISION  :: R1
      DOUBLE PRECISION  :: A0
      DOUBLE PRECISION  :: C0
      DOUBLE PRECISION  :: C1
      DOUBLE PRECISION  :: G0
      DOUBLE PRECISION  :: G1
      DOUBLE PRECISION  :: G2
      DOUBLE PRECISION  :: G3
      DOUBLE PRECISION  :: GM
      DOUBLE PRECISION  :: HW
      DOUBLE PRECISION  :: RM
      DOUBLE PRECISION  :: RP
      DOUBLE PRECISION  :: SM
      DOUBLE PRECISION  :: SP
      DOUBLE PRECISION  :: PI
      DOUBLE PRECISION  :: EL
      DOUBLE PRECISION  :: HF
      DOUBLE PRECISION  :: GA
      DOUBLE PRECISION  :: GB
      DOUBLE PRECISION  :: GC
      DOUBLE PRECISION  :: PA
      DOUBLE PRECISION  :: PB
      DOUBLE PRECISION  :: EPS
      DOUBLE PRECISION  :: SP0
      DOUBLE PRECISION  :: GCA
      DOUBLE PRECISION  :: GCB
      DOUBLE PRECISION  :: GAM
      DOUBLE PRECISION  :: GBM
      DOUBLE PRECISION  :: GCAB
      DOUBLE PRECISION  :: GABC
      CHARACTER(len=80) :: LINE
      LOGICAL           :: L0
      LOGICAL           :: L1
      LOGICAL           :: L2
      LOGICAL           :: L3
      LOGICAL           :: L4
      LOGICAL           :: L5
      HW = 0.0D+0
      PI = 3.141592653589793D0
      EL = 0.5772156649015329D0
      L0 = C == INT (C) .AND. C < 0.0D+0
      L1 = 1.0D0 - X < 1.0D-15 .AND. C - A - B <= 0.0D+0
      L2 = A == INT (A) .AND. A < 0.0D+0
      L3 = B == INT (B) .AND. B < 0.0D+0
      L4 = C - A == INT (C - A) .AND. C - A .LE .0.0D+0
      L5 = C - B == INT (C - B) .AND. C - B <= 0.0D+0
      IF (L0 .OR. L1) THEN
        WRITE (LINE, 99999, IOSTAT = IOST)
        CALL TRAILER (LINE)
        RETURN
      END IF
      EPS = 1.0D-15
      IF (X > 0.95D+0) EPS = 1.0D-8
      IF (X == 0.0D+0 .OR. A == 0.0D+0 .OR. B == 0.0D+0) THEN
        HF = 1.0D0
        RETURN
      ELSE IF (1.0D0 - X == EPS .AND. C - A - B > 0.0D+0) THEN
        CALL GEN136 (C, GC)
        CALL GEN136 (C - A -B, GCAB)
        CALL GEN136 (C - A, GCA)
        CALL GEN136 (C - B, GCB)
        HF= GC * GCAB / (GCA * GCB)
        RETURN
      ELSE IF (1.0D0 + X <= EPS .AND.
     1         DABS (C - A + B - 1.0D+0) <= EPS) THEN
        G0 = DSQRT (PI) * 2.0D0 ** (-A)
        CALL GEN136 (C, G1)
        CALL GEN136 (1.0D0 + A / 2.0D+0 - B, G2)
        CALL GEN136 (0.5D0 + 0.5D+0 * A, G3)
        HF = G0 * G1 / (G2 * G3)
        RETURN
      ELSE IF (L2 .OR. L3) THEN
        IF (L2) NM = INT (ABS (A))
        IF (L3) NM = INT (ABS (B))
        HF = 1.0D0
        R  = 1.0D0
        DO K = 1, NM
          R = R * (A + K - 1.0D0) * (B + K - 1.0D0) /
     1        (K * (C + K -1.0D0)) * X
          HF = HF + R
        END DO
        RETURN
      ELSE IF (L4 .OR. L5) THEN
        IF (L4) NM = INT (ABS (C - A))
        IF (L5) NM = INT (ABS (C - B))
        HF = 1.0D0
        R  = 1.0D0
        DO K = 1, NM
          R = R * (C - A + K - 1.0D0) * (C - B + K - 1.0D0) /
     1       (K * (C + K - 1.0D0)) * X
          HF = HF + R
        END DO
        HF = (1.0D0 - X) ** (C - A - B ) * HF
        RETURN
      END IF
      AA = A
      BB = B
      X1 = X
      IF (X < 0.0D0) THEN
        X = X / (X - 1.0D0)
        IF (C > A .AND. B < A .AND. B > 0.0) THEN
          A = BB
          B = AA
        END IF
        B = C - B
      END IF
      IF (X >= 0.75D0) THEN
        GM = 0.0D0
        IF (DABS (C - A - B - INT (C - A - B)) < 1.0D-15) THEN
          M = INT (C - A - B)
          CALL GEN136 (A, GA)
          CALL GEN136 (B, GB)
          CALL GEN136 (C, GC)
          CALL GEN136 (A + M, GAM)
          CALL GEN136 (B + M, GBM)
          CALL GEN137 (A, PA)
          CALL GEN137 (B, PB)
          IF (M /= 0) GM = 1.0D0
          DO J = 1, ABS (M) - 1
            GM = GM * J
          END DO
          RM = 1.0D0
          DO J = 1, ABS (M)
            RM = RM * J
          END DO
          F0  = 1.0D0
          R0  = 1.0D0
          R1  = 1.0D0
          SP0 = 0.D0
          SP  = 0.0D0
          IF (M >= 0) THEN
            C0 = GM * GC / (GAM * GBM)
            C1 = - GC * (X - 1.0D0) ** M / (GA * GB * RM)
            DO K = 1, M - 1
              R0 = R0 * (A + K - 1.0D0) * (B + K - 1.0) /
     1             (K * (K - M)) * (1.0 - X)
              F0 = F0 + R0
            END DO
            DO K = 1, M
              SP0 = SP0 + 1.0D0 / (A + K - 1.0) + 1.0 /
     1             (B + K - 1.0) - 1.0 / K
            END DO
            F1 = PA + PB + SP0 + 2.0D0 * EL + DLOG (1.0D0 - X)
            DO K = 1, 250
              SP = SP + (1.0D0 - A) / (K * (A + K - 1.0)) +
     1            (1.0 - B) / (K * (B + K - 1.0))
              SM = 0.0D0
              DO J = 1, M
                SM = SM + (1.0D0 - A) / ((J + K) * (A + J + K - 1.0)) +
     1               1.0 / (B + J + K - 1.0)
              END DO
              RP = PA + PB + 2.0D0 * EL + SP + SM + DLOG (1.0D0 - X)
              R1 = R1 * (A + M + K - 1.0D0) * (B + M + K - 1.0) /
     1             (K * (M + K)) * (1.0 - X)
              F1 = F1 + R1 * RP
              IF (DABS (F1 - HW) < DABS (F1) * EPS) EXIT
              HW = F1
            END DO
            HF = F0 * C0 + F1 * C1
          ELSE IF (M < 0) THEN
            M = - M
            C0 = GM * GC / (GA * GB * (1.0D0 - X)**M)
            C1 = - (-1) ** M * GC / (GAM * GBM * RM)
            DO K = 1, M - 1
              R0 = R0 * (A - M + K - 1.0D0) * (B - M + K - 1.0) /
     1             (K * (K - M)) * (1.0 - X)
              F0 = F0 + R0
            END DO
            DO K = 1, M
              SP0 = SP0 + 1.0D0 / K
            END DO
            F1 = PA + PB - SP0 + 2.0D0 * EL + DLOG (1.0D0 - X)
            DO K = 1, 250
              SP = SP + (1.0D0 - A) / (K * (A + K - 1.0)) +
     1             (1.0 - B) / (K * (B + K - 1.0))
              SM = 0.0D0
              DO J = 1, M
                SM = SM + 1.0D0 / (J + K)
              END DO
              RP = PA + PB + 2.0D0 * EL + SP - SM + DLOG (1.0D0 - X)
              R1 = R1 * (A + K - 1.0D0) * (B + K - 1.0) /
     1            (K * (M + K)) * (1.0 - X)
              F1 = F1 + R1 * RP
              IF (DABS (F1 - HW) < DABS (F1) * EPS) EXIT
              HW = F1
            END DO
            HF = F0 * C0 + F1 * C1
          END IF
        ELSE
          CALL GEN136 (A, GA)
          CALL GEN136 (B, GB)
          CALL GEN136 (C, GC)
          CALL GEN136 (C - A, GCA)
          CALL GEN136 (C - B, GCB)
          CALL GEN136 (C - A - B, GCAB)
          CALL GEN136 (A + B - C, GABC)
          C0 = GC * GCAB / (GCA * GCB)
          C1 = GC * GABC / (GA * GB) * (1.0D0 - X) ** (C - A - B)
          HF = 0.0D0
          R0 = C0
          R1 = C1
          DO K = 1, 250
            R0 = R0 * (A + K - 1.0D0) * (B + K - 1.0) /
     1           (K * (A + B - C + K)) * (1.0 - X)
            R1 = R1 * (C - A + K - 1.0D0) * (C - B + K - 1.0) /
     1          (K * (C - A - B + K)) * (1.0 - X)
            HF = HF + R0 + R1
            IF (DABS (HF - HW) < DABS (HF) * EPS) EXIT
            HW = HF
          END DO
          HF = HF + C0 + C1
        END IF
      ELSE
        A0 = 1.0D0
        IF (C > A .AND. C < 2.0D0 * A .AND.
     1    C > B .AND. C < 2.0D0 * B) THEN
          A0 = (1.0D0 - X) ** (C - A - B)
          A = C - A
          B = C - B
        END IF
        HF = 1.0D0
        R  = 1.0D0
        DO K = 1, 250
          R = R * (A + K - 1.0D0) * (B + K - 1.0D0) /
     1       (K * (C + K - 1.0D0)) * X
          HF = HF + R
          IF (DABS (HF - HW) <= DABS (HF) * EPS) EXIT
          HW = HF
        END DO
        HF = A0 * HF
      END IF
      IF (X1 < 0.0D0) THEN
        X  = X1
        C0 = 1.0D0 / (1.0D0 - X) ** AA
        HF = C0 * HF
      END IF
      A = AA
      B = BB
      IF (K > 120) THEN
        WRITE (LINE, 99998, IOSTAT = IOST)
        CALL TRAILER (LINE)
      END IF
      RETURN
99999 FORMAT ('The hypergeometric series is divergent')
99998 FORMAT ('Warning! check the accuracy')
      END SUBROUTINE GEN138
 
      SUBROUTINE GEN139 (X, XNU, CDFT)
C * CALCULATE CUMULATIVE DISTRIBUTION FUNCTION FOR STUDENT-T PDF
      IMPLICIT NONE
      DOUBLE PRECISION :: X
      DOUBLE PRECISION :: A
      DOUBLE PRECISION :: B
      DOUBLE PRECISION :: C
      DOUBLE PRECISION :: D
      DOUBLE PRECISION :: E
      DOUBLE PRECISION :: F
      DOUBLE PRECISION :: G
      DOUBLE PRECISION :: PI
      DOUBLE PRECISION :: XNU
      DOUBLE PRECISION :: CDFT
      PI = 3.141592653589793D0
      A  = 0.5D+0
      B  = (XNU + 1) / 2
      C  = 1.5D+0
      D  = - X**2 / XNU
      E  = 0.0D+0
      CALL GEN138 (A, B, C, D, E)
      A  = (XNU + 1) / 2
      F  = 0.0D+0
      CALL GEN136 (A, F)
      A  = XNU / 2
      G  = 0.0D+0
      CALL GEN136 (A, G)
      CDFT = 0.5D+0 + X * F * E / (SQRT (PI * XNU) * G)
      RETURN
      END SUBROUTINE GEN139
 
      SUBROUTINE GEN140 (X, XNU, CDFTINV)
C * INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
      IMPLICiT NONE
      INTEGER           :: IOST = 0
      DOUBLE PRECISION  :: A
      DOUBLE PRECISION  :: X
      DOUBLE PRECISION  :: XNU
      DOUBLE PRECISION  :: XMID
      DOUBLE PRECISION  :: XLOW
      DOUBLE PRECISION  :: XHIGH
      DOUBLE PRECISION  :: CDFTINV
      CHARACTER(len=80) :: LINE
      IF (X < 0.0D+0 .OR. X >= 1.0D+0) THEN
        WRITE (LINE, 99999, IOSTAT = IOST)
        CALL TRAILER (LINE)
        RETURN
      END IF
      IF (X < 0.5D+0) THEN
        XHIGH =  0.0D+0
        XLOW  = -1.0D+0
        DO WHILE (.TRUE.)
C * CALCULATE CUMULATIVE DISTRIBUTION FUNCTION FOR STUDENT-T PDF
          CALL GEN139 (XLOW, XNU, A)
          IF (A <= X) EXIT
          XHIGH = XLOW
          XLOW  = XLOW * 2.0D+0
        END DO
      ELSE
        XLOW  = 0.0D+0
        XHIGH = 1.0D+0
        DO WHILE (.TRUE.)
C * CALCULATE CUMULATIVE DISTRIBUTION FUNCTION FOR STUDENT-T PDF
          CALL GEN139 (XHIGH, XNU, A)
          IF (A >= X) EXIT
          XLOW  = XHIGH
          XHIGH = XHIGH * 2.0D+0
        END DO
      END IF
      DO WHILE (XHIGH - XLOW > 1D-6)
        XMID = (XHIGH + XLOW) / 2.0D+0
C * CALCULATE CUMULATIVE DISTRIBUTION FUNCTION FOR STUDENT-T PDF
        CALL GEN139 (XMID, XNU, A)
        IF (A < X) THEN
          XLOW = XMID
        ELSE
          XHIGH = XMID
        END IF
        CDFTINV = (XHIGH + XLOW) / 2.0D+0
      END DO
      RETURN
99999 FORMAT ('Argument outside 0 to 1 range')
      END SUBROUTINE GEN140
 
      SUBROUTINE GEN141 (W, RNU, N)
C * INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
      IMPLICIT NONE
      INTEGER            :: I
      INTEGER            :: N
      REAL               :: RNU
      DOUBLE PRECISION   :: X
      DOUBLE PRECISION   :: Y
      DOUBLE PRECISION   :: XNU
      REAL, DIMENSION(*) :: W
      XNU = RNU
      DO I = 1, N
        X  = (FLOAT (I) - 0.5) / FLOAT(N)
C * INVERSE CUMULATIVE DISTRIBUTION FOR STUDENT-T DISTRIBUTION
        CALL GEN140 (X, XNU, Y)
        W(I) =  SNGL(Y)
      END DO
      END
 
      SUBROUTINE GEN142 (Y, W, RNU, N, GRAPH, LU)
      IMPLICIT NONE
      INTEGER                           :: I
      INTEGER                           :: J
      INTEGER                           :: N
      INTEGER                           :: M
      INTEGER                           :: LU
      REAL                              :: RNU
      REAL, DIMENSION(*)                :: Y
      REAL, DIMENSION(*)                :: W
      CHARACTER(len=125), DIMENSION(44) :: GRAPH
C * SORT DATA
C * NR OF DATA POINTS ......... N
C * LEAVE OUT LOW OUTLIERS .... M
C * LEAVE OUT HIGH OUTLIERS ... M
      M = 5
C * SORT SMALL TO LARGE
      CALL GEN035 (Y, 1, N)
      J = 0
      DO I = M + 1, N - M
        J = J + 1
        Y(J) = Y(I)
      END DO
      N = N - 2 * M
      CALL GEN143 (Y, W, N, RNU)
      CALL GEN141 (W, RNU, N)
      CALL GEN119 (2, Y, W, N)
      CALL GEN120 (3, Y, W, N, GRAPH, LU)
      RETURN
      END SUBROUTINE GEN142
 
      SUBROUTINE GEN143 (Y, W, N, RNU)
      USE npplot
      IMPLICIT NONE
      REAL, PARAMETER    :: R = 0.61803399
      REAL, PARAMETER    :: C = 1.0 - R
      INTEGER            :: N
      REAL               :: AX
      REAL               :: BX
      REAL               :: CX
      REAL               :: F1
      REAL               :: F2
      REAL               :: X0
      REAL               :: X1
      REAL               :: X2
      REAL               :: X3
      REAL               :: TOL
      REAL               :: RNU
      REAL, DIMENSION(*) :: Y
      REAL, DIMENSION(*) :: W
      IF (RNU == 0.0) THEN
        TOL = 0.0005
        AX  = 2.0
        BX  = 99.0
        CX  = 100.0
        X0  = AX
        X3  = CX
        IF (ABS(CX - BX) > ABS (BX - AX)) THEN
          X1 = BX
          X2 = BX + C * (CX - BX)
        ELSE
          X2 = BX
          X1 = BX - C * (BX - AX)
        END IF
        CALL GEN141 (W, X1, N)
        CALL GEN119 (2, Y, W, N)
        F1 = 1.0 - YCC
        CALL GEN141 (W, X2, N)
        CALL GEN119 (2, Y, W, N)
        F2 = 1.0 - YCC
        DO WHILE (ABS (X3 - X0) > TOL * (ABS (X1) + ABS (X2)))
          IF (F2 < F1) THEN
            X0 = X1
            X1 = X2
            X2 = R * X1 + C * X3
            F1 = F2
            CALL GEN141 (W, X2, N)
            CALL GEN119 (2, Y, W, N)
            F2 = 1.0 - YCC
          ELSE
            X3 = X2
            X2 = X1
            X1 = R * X2 + C * X0
            F2 = F1
            CALL GEN141 (W, X1, N)
            CALL GEN119 (2, Y, W, N)
            F1 = 1.0 - YCC
          END IF
        END DO
        IF  (F1 < F2) THEN
          RNU = X1
        ELSE
          RNU = X2
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN143
 
      SUBROUTINE GEN144 (MODE, A, B)
      IMPLICIT NONE
      INTEGER            :: MODE
      REAL, DIMENSION(6) :: A
      REAL, DIMENSION(3) :: B
      IF (MODE == 1) THEN
        A(1) = A(1) * B(1)**2
        A(2) = A(2) * B(2)**2
        A(3) = A(3) * B(3)**2
        A(4) = A(4) * B(2) * B(3)
        A(5) = A(5) * B(1) * B(3)
        A(6) = A(6) * B(1) * B(2)
      ELSE
        A(1) = A(1) / B(1)**2
        A(2) = A(2) / B(2)**2
        A(3) = A(3) / B(3)**2
        A(4) = A(4) / (B(2) * B(3))
        A(5) = A(5) / (B(1) * B(3))
        A(6) = A(6) / (B(1) * B(2))
      ENDIF
      RETURN
      END SUBROUTINE GEN144
 
      SUBROUTINE GEN145 (IH, IK, IL)
C * APPLY FRIEDEL SYMMETRY TO MAKE IL >= 0
      IMPLICIT NONE
      INTEGER :: IH
      INTEGER :: IK
      INTEGER :: IL
      IF (IL < 0) THEN
        IH = - IH
        IK = - IK
        IL = - IL
      ELSE IF (IL == 0) THEN
        IF (IK < 0) THEN
          IK = - IK
          IH = - IH
        ELSE IF (IK == 0) THEN
          IH = IABS(IH)
        END IF
      END IF
      RETURN
      END SUBROUTINE GEN145
 
      SUBROUTINE GEN146 (FORMX, X, IX, N)
C * Pack Flack,Parsons or Hooft parameter values for listing
 
      IMPLICIT NONE
      INTEGER           :: N
      INTEGER           :: IX
      INTEGER           :: IOST = 0
      REAL              :: X
      CHARACTER(len=10) :: FORMX
      CHARACTER(len=17) :: FORMA
      FORMA = '(F7.0,''('',I1,'')'')'
      IF (IX >= 10) THEN
        FORMA(3:3)   = CHAR (54)
        FORMA(12:12) = CHAR (50)
      END IF
      FORMA(5:5) = CHAR (N + 48)
      WRITE (FORMX, FORMA, IOSTAT = IOST) X, IX
      RETURN
      END SUBROUTINE GEN146
 
      SUBROUTINE GEN147 (IA, N, JL, JU)
C * SHEL-SORT ROUTINE: ON FIRST ELEMENT FROM JL TO JU (SMALL TO LARGE)
      IMPLICIT NONE
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: K
      INTEGER                  :: N
      INTEGER                  :: ND
      INTEGER                  :: JV
      INTEGER                  :: JL
      INTEGER                  :: JU
      INTEGER, DIMENSION(N, *) :: IA
      INTEGER, DIMENSION(N)    :: IB
      JV = JU - JL + 1
      IF (JV > 1) THEN
        ND = 2**(INT ((ALOG (FLOAT (JV)) / ALOG (2.0)) + 1.0E-5)) - 1
        DO
          IF (ND <= 0) EXIT
          I  = JL
          DO
            J  = I
            DO K = 1, N
              IB(K) = IA(K, I + ND)
            END DO
   10       IF (IB(1) < IA(1, J)) THEN
              DO K = 1, N
                IA(K, J + ND) = IA(K, J)
              END DO
              J = J - ND
              IF (J >= JL) GO TO 10
            END IF
            DO K = 1, N
              IA(K, J + ND) = IB(K)
            END DO
            I = I + 1
            IF (I + ND > JU) EXIT
          END DO
          ND = (ND - 1) / 2
        END DO
      END IF
      RETURN
      END SUBROUTINE GEN147
 
      SUBROUTINE GEN148 (LU, IOPER)
C * REPORT REWIND ISSUE
      CHARACTER(len=80) :: LINE
      IF (IOPER == 1) THEN
        WRITE (LINE, 99999) LU
        CALL TRAILER (LINE)
      END IF
      RETURN
99999 FORMAT ('** Problem with REWIND on UNIT', I4)
      END SUBROUTINE GEN148
 
      DOUBLE PRECISION FUNCTION GEN149 (XP, N, X, Y)
C * Aitken repeated interpolation
C * XP = abscissa at which interpolation is desired
C * X  = vector of n values of abscissa
C * Y  = vector of n values of ordinate
C * T  = temporary storage vector of 4*(m+1) locations)
      IMPLICIT NONE
      INTEGER                         :: I
      INTEGER                         :: J
      INTEGER                         :: K
      INTEGER                         :: N
      INTEGER                         :: INDX
      INTEGER                         :: MEND
      DOUBLE PRECISION                :: XP
      DOUBLE PRECISION                :: SGN
      DOUBLE PRECISION                :: TEL
      DOUBLE PRECISION                :: NOEM
      DOUBLE PRECISION, DIMENSION(*)  :: X
      DOUBLE PRECISION, DIMENSION(*)  :: Y
      DOUBLE PRECISION, DIMENSION(20) :: T
      INDX = 0
      IF (N <= 2) THEN
        CALL TRAILER (' Too few points, funct=y(1)')
        GEN149 = Y(1)
      ELSE
        SGN = SIGN (1.0D0, X(1) - X(2))
        I   = 1
        DO WHILE (SGN * X(I) > SGN * XP .AND. I <= N)
          INDX = I
          I    = I + 1
        END DO
        INDX = INDX - 1
        INDX = MAX0 (INDX, 1)
        INDX = MIN0 (INDX, N - 2)
        MEND  = INDX + 2
        DO I  = INDX, MEND
          K        = I - INDX + 1
          T(K)     = Y(I)
          T(K + 3) = X(I) - XP
        END DO
        DO I = 1, 2
          K = I + 1
          DO J = K, 3
            TEL  = T(I) * T(J + 3) - T(J) * T(I + 3)
            NOEM = X(J + INDX - 1) - X(I + INDX - 1)
            T(J) = TEL / NOEM
          END DO
        END DO
        GEN149 = T(3)
      END IF
      RETURN
      END FUNCTION GEN149
 
      SUBROUTINE GEN150 (N, A, B)
C * bubble sort.  largest becomes last
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: N
      DOUBLE PRECISION               :: X
      DOUBLE PRECISION               :: Y
      DOUBLE PRECISION, DIMENSION(*) :: A
      DOUBLE PRECISION, DIMENSION(*) :: B
      DO I = 1, N - 1
        DO J = I + 1, N
          IF (A(J) < A(I)) THEN
            X    = A(J)
            Y    = A(I)
            A(I) = X
            A(J) = Y
            X    = B(J)
            Y    = B(I)
            B(I) = X
            B(J) = Y
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN150
 
      SUBROUTINE GEN151 (A, N)
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: J
      INTEGER          :: L
      INTEGER          :: N
      CHARACTER(len=*) :: A
      L = LEN (A)
      DO I = N, L
C * SUBSTITUTE FORWARD SLASH FOR A BACKWARD SLASH
        IF (A(I:I) == CHAR (92)) A(I:I) = CHAR (47)
C * CHECK FOR HASH CHARACTER AND BLANK COMMENT
        IF (A(I:I) == CHAR (35)) THEN
          DO J = I, L
            A(J:J) = CHAR (32)
          END DO
          RETURN
        END IF
C * SUBSTITUTE BLANK FOR CARRIAGE RETURN CHARACTER
        IF (A(I:I) == CHAR(13)) A(I:I) = CHAR(32)
      END DO
      RETURN
      END SUBROUTINE GEN151
 
      INTEGER FUNCTION GEN152 (X)
C * ESTABLISH RELEVANT NUMBER OF DECIMALS
      IMPLICIT NONE
      INTEGER           :: I
      INTEGER           :: J
      REAL              :: X
      CHARACTER(len=10) :: LINE
      WRITE (LINE, 99999) X
      DO I = 1, 5
        J = 11 - I
        IF (LINE(J:J) /= '0') THEN
          GEN152  = J - 5
          EXIT
        END IF
      END DO
      RETURN
99999 FORMAT (F10.5)
      END FUNCTION GEN152
 
      SUBROUTINE GEN153 (R, Y1, Y2, Y3, Y4, A)
C * FIT CURVE TO Y = A(1) * RHO**3 + A(2) * RHO**2 + A(3) * RHO + A(4)
      IMPLICIT NONE
      REAL               :: B1
      REAL               :: B2
      REAL               :: Y1
      REAL               :: Y2
      REAL               :: Y3
      REAL               :: Y4
      REAL               :: C11
      REAL               :: C12
      REAL               :: C21
      REAL               :: C22
      REAL               :: C31
      REAL               :: C32
      REAL, DIMENSION(4) :: R
      REAL, DIMENSION(4) :: A
      B2   = R(4) * (R(4) + R(1))
      B1   = (Y4 - Y1) / (R(4) - R(1))
      C31  = (Y2 - Y1) / (R(2) - R(1)) - B1
      C32  = (Y3 - Y1) / (R(3) - R(1)) - B1
      C11  = R(2) * (R(2) + R(1)) - B2
      C12  = R(3) * (R(3) + R(1)) - B2
      C21  = R(2) - R(4)
      C22  = R(3) - R(4)
      A(1) = (C31 * C22 - C32 * C21) / (C22 * C11 - C12 * C21)
      A(2) = (C31 - C11 * A(1)) / C21
      A(3) = B1 - (R(4) * R(4) + R(1) * R(1) + R(4) * R(1)) * A(1)
     1     - (R(4) + R(1)) * A(2)
      A(4) = Y1 - R(1) * (A(3) + R(1) * (A(2) + R(1) * A(1)))
      RETURN
      END SUBROUTINE GEN153
 
      SUBROUTINE GEN154 (A, B, IX, N)
C * SORT ON A
      IMPLICIT NONE
      INTEGER               :: N
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      INTEGER               :: L
      INTEGER               :: IFIN
      INTEGER               :: INTX
      INTEGER, DIMENSION(N) :: IX
      REAL                  :: X
      REAL                  :: T
      REAL,    DIMENSION(N) :: A
      REAL,    DIMENSION(N) :: B
      INTX = 2
   10 INTX = 2 * INTX
      IF (INTX < N) GO TO 10
      INTX  = MIN0 (N, (3 * INTX) / 4 - 1)
   20 INTX  = INTX / 2
      IFIN  = N - INTX
      DO  K = 1, IFIN
        I = K
        J = I + INTX
        IF (A(I) < A(J)) THEN
          T     = A(J)
          X     = B(J)
          L     = IX(J)
   30     A(J)  = A(I)
          B(J)  = B(I)
          IX(J) = IX(I)
          J     = I
          I     = I - INTX
          IF (I > 0) THEN
            IF (A(I) < T) GO TO 30
          END IF
          A(J)  = T
          B(J)  = X
          IX(J) = L
        END IF
      END DO
      IF (INTX > 1) GO TO 20
      RETURN
      END SUBROUTINE GEN154
 
      SUBROUTINE GEN155 (MODE, A, ICKS)
C * CALCULATE CHECKSUM
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER, SAVE    :: M
      INTEGER          :: ICH
      INTEGER          :: MODE
      INTEGER          :: ICKS
      CHARACTER(len=*) :: A
C * M =  0 - INIT
C * M =  1 - ADD TO SUM
C * M = -1 - REPORT CHECKSUM
      IF (MODE == 1) THEN
        DO I = 1, LEN_TRIM (A)
          ICH = ICHAR (A(I:I))
          IF (ICH > 32) M = M + ICH
        END DO
      ELSE IF (MODE == 0) THEN
        M = 0
      ELSE IF (MODE == -1) THEN
        ICKS = MOD (MOD (MOD (M, 714025) * 1366 + 150889, 714025),
     1         100000)
      END IF
      RETURN
      END SUBROUTINE GEN155
 
      SUBROUTINE GEN156 (LABA)
C * MOVE LABEL CONTENT RIGHT
      IMPLICIT NONE
      INTEGER          :: J
      INTEGER          :: K
      INTEGER          :: L
      CHARACTER(len=9) :: LABA
      CHARACTER(len=9) :: LABB
      K = 10
      DO L = 1, 9
        IF (LABA(10 - L:10 - L) /= ' ') THEN
          K         = K - 1
          LABB(K:K) = LABA(10 - L:10 - l)
        END IF
      END DO
      IF (K > 1) THEN
        DO J = 1, K - 1
          LABB(J:J) = ' '
        END DO
      END IF
      LABA = LABB
      RETURN
      END SUBROUTINE GEN156
 
      SUBROUTINE GEN157 (D, IZ)
C * SOLVE EQUATION
      IMPLICIT NONE
      INTEGER                         :: IZ
      DOUBLE PRECISION                :: A
      DOUBLE PRECISION                :: B
      DOUBLE PRECISION                :: C
      DOUBLE PRECISION                :: G
      DOUBLE PRECISION                :: E
      DOUBLE PRECISION                :: F
      DOUBLE PRECISION, DIMENSION (*) :: D
      IF (IZ == 2) THEN
        A    =  D(1) * D(6)  - D(5)  * D(2)
        B    = -D(3) * D(6)  + D(5)  * D(4)
        D(3) =  D(1) * D(4)  - D(3)  * D(2)
        D(1) =  B
        D(2) =  A
      ELSE
        A    =  D(8) * D(12) - D(9)  * D(11)
        B    =  D(7) * D(12) - D(9)  * D(10)
        C    =  D(7) * D(11) - D(8)  * D(10)
        G    =  D(4) * A     - D(5)  * B     + D(6) * C
        E    = -D(1) * A     + D(2)  * B     - D(3) * C
        F    =  D(1) * (D(5) * D(9)  - D(6) * D(8))
     1       -  D(2) * (D(4) * D(9)  - D(6) * D(7))
     2       +  D(3) * (D(4) * D(8)  - D(5) * D(7))
        D(3) =  D(1) * (D(5) * D(12) - D(6) * D(11))
     1       -  D(2) * (D(4) * D(12) - D(6) * D(10))
     2       +  D(3) * (D(4) * D(11) - D(5) * D(10))
        D(1) =  G
        D(2) =  E
        D(4) =  F
      END IF
      RETURN
      END SUBROUTINE GEN157
 
      REAL FUNCTION GEN158 (CELA, CELSD, X1, X2, X3)
C * CALCULATE CELL ERROR CONTRIBUTION TO BOND ANGLE ERROR
      IMPLICIT NONE
      INTEGER               :: I
      INTEGER               :: J
      REAL                  :: S
      REAL                  :: A
      REAL                  :: B
      REAL                  :: SK
      REAL                  :: GEN159
      REAL, DIMENSION(*)    :: CELA
      REAL, DIMENSION(*)    :: CELSD
      REAL, DIMENSION(3)    :: X1
      REAL, DIMENSION(3)    :: X2
      REAL, DIMENSION(3)    :: X3
      REAL, DIMENSION(3, 3) :: RA
      REAL, DIMENSION(3, 3) :: RB
      REAL, DIMENSION(6)    :: CELB
      S = 45.0 / ATAN2 (1.0, 1.0)
      CALL GEN026 (1, RA, CELA)
      A = GEN159 (X1, X2, X3, RA) * S
      SK = 0.0
      DO I = 1, 6
        DO J = 1, 6
          CELB(J) = CELA(J)
        END DO
        IF (CELSD(I) > 0.0) THEN
          CELB(I) = CELB(I) + CELSD(I)
          CALL GEN026 (1, RB, CELB)
          B = GEN159 (X1, X2, X3, RB) * S
          SK = SK + (A - B)**2
        END IF
      END DO
      GEN158 = SK
      RETURN
      END
 
      REAL FUNCTION GEN159 (X1, X2, X3, R)
C * CALCULATE BOND ANGLE FOR BOND ANGL ERROR CALC
      IMPLICIT NONE
      REAL                  :: D1
      REAL                  :: D2
      REAL                  :: D3
      REAL                  :: GEN006
      REAL                  :: COSA
      REAL, DIMENSION(3, 3) :: R
      REAL, DIMENSION(3)    :: X1
      REAL, DIMENSION(3)    :: X2
      REAL, DIMENSION(3)    :: X3
      REAL, DIMENSION(3)    :: V
      v(1) = X1(1) - X2(1)
      v(2) = X1(2) - X2(2)
      v(3) = X1(3) - X2(3)
      D1 = GEN006 (V, R, V)
      v(1) = X2(1) - X3(1)
      v(2) = X2(2) - X3(2)
      v(3) = X2(3) - X3(3)
      D2 = GEN006 (V, R, V)
      v(1) = X1(1) - X3(1)
      v(2) = X1(2) - X3(2)
      v(3) = X1(3) - X3(3)
      D3 = GEN006 (V, R, V)
      IF (D1 > 0.0 .AND. D2 > 0.0) THEN
        COSA = (D1 + D2 - D3) / (2.0 * SQRT (D1)*SQRT (D2))
        IF (COSA < -1.0) COSA = -1.0
        IF (COSA >  1.0) COSA =  1.0
        GEN159 = ACOS (COSA)
      ELSE
        GEN159 = 0.0
      END IF
      RETURN
      END
 
      DOUBLE PRECISION FUNCTION GEN160 (IS)
C * RANDOM GENERATOR
      IMPLICIT NONE
      INTEGER,          PARAMETER    :: IA   = 16807
      INTEGER,          PARAMETER    :: IM   = 2147483647
      INTEGER,          PARAMETER    :: IQ   = 127773
      INTEGER,          PARAMETER    :: IR   = 2836
      INTEGER,          PARAMETER    :: NTAB = 32
      INTEGER,          PARAMETER    :: NDIV = 67108864
      DOUBLE PRECISION, PARAMETER    :: AM   = 1.0D0 / IM
      DOUBLE PRECISION, PARAMETER    :: EPS  = 1.2D-7
      DOUBLE PRECISION, PARAMETER    :: RNMX = 1.0D0 - EPS
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER, SAVE                  :: IY
      INTEGER                        :: IS
      INTEGER, SAVE, DIMENSION(NTAB) :: IV
      DATA IV /NTAB*0/, IY /0/
      IF (IS <= 0 .OR. IY == 0) THEN
        IS = MAX (-IS, 1)
        DO J = NTAB + 8, 1, -1
          K = IS / IQ
          IS = IA * (IS - K * IQ) - IR * K
          IF (IS < 0) IS = IS + IM
          IF (J <= NTAB) IV(J) = IS
        END DO
        IY = IV(1)
      END IF
      K  = IS / IQ
      IS = IA * (IS - K * IQ) - IR * K
      IF (IS < 0) IS = IS + IM
      J      = 1 + IY / NDIV
      IY     = IV(J)
      IV(J)  = IS
      GEN160 = MIN (AM * IY, RNMX)
      RETURN
      END FUNCTION GEN160
 
      SUBROUTINE GEN161 (A, R)
C * DP-EIGEN
      IMPLICIT NONE
      INTEGER                        :: I
      INTEGER                        :: J
      INTEGER                        :: K
      INTEGER                        :: L
      INTEGER                        :: M
      INTEGER                        :: IA
      INTEGER                        :: IJ
      INTEGER                        :: IQ
      INTEGER                        :: IL
      INTEGER                        :: IM
      INTEGER                        :: MQ
      INTEGER                        :: LQ
      INTEGER                        :: LM
      INTEGER                        :: LL
      INTEGER                        :: JQ
      INTEGER                        :: MM
      INTEGER                        :: IND
      INTEGER                        :: ILQ
      INTEGER                        :: IMQ
      INTEGER                        :: ILR
      INTEGER                        :: IMR
      DOUBLE PRECISION               :: X
      DOUBLE PRECISION               :: Y
      DOUBLE PRECISION               :: THR
      DOUBLE PRECISION               :: SINX
      DOUBLE PRECISION               :: COSX
      DOUBLE PRECISION               :: SINX2
      DOUBLE PRECISION               :: COSX2
      DOUBLE PRECISION               :: SINCS
      DOUBLE PRECISION               :: ANORM
      DOUBLE PRECISION               :: BEREIK
      DOUBLE PRECISION               :: ANRMX
      DOUBLE PRECISION, DIMENSION(9) :: A
      DOUBLE PRECISION, DIMENSION(9) :: R
      BEREIK = 1.0D-6
      IQ    = -3
      DO J = 1, 3
        IQ = IQ + 3
        DO I = 1, 3
          IJ = IQ + I
          R(IJ) = 0.0D0
          IF (I == J) R(IJ) = 1.0D0
        END DO
      END DO
      ANORM = 0.0D0
      DO I = 1, 3
        DO J = I, 3
          IF (I /= J) THEN
            IA = I + (J * J - J) / 2
            ANORM = ANORM + A(IA) * A(IA)
          END IF
        END DO
      END DO
      IF (ANORM > 0) THEN
        ANORM = 1.414D0 * SQRT (ANORM)
        ANRMX = ANORM * BEREIK / 3.0D0
        IND = 0
        THR = ANORM
        THR = THR / 3.0D0
        L = 1
        M = L + 1
   10   MQ = (M * M - M) / 2
        LQ = (L * L - L) / 2
        LM = L + MQ
        IF (ABS (A(LM)) >= THR) THEN
          IND = 1
          LL = L + LQ
          MM = M + MQ
          X = 0.5D0 * (A(LL) - A(MM))
          Y = -A(LM) / SQRT (A(LM) * A(LM) + X * X)
          IF (X < 0.0D0) Y = -Y
          SINX = Y / SQRT (2.0D0 * (1.0D0 + (SQRT (1.0D0 - Y * Y))))
          SINX2 = SINX * SINX
          COSX = SQRT (1.0D0 - SINX2)
          COSX2 = COSX * COSX
          SINCS = SINX * COSX
          ILQ   = 3 * (L - 1)
          IMQ   = 3 * (M - 1)
          DO I = 1, 3
            IQ = (I * I - I) / 2
            IF (I /= L) THEN
              IF (I /= M) THEN
                IF (I < M) THEN
                  IM = I + MQ
                ELSE IF (I > M) THEN
                  IM = M + IQ
                END IF
                IF (I < L) THEN
                  IL = I + LQ
                ELSE
                  IL = L + IQ
                END IF
                X  = A(IL) * COSX - A(IM) * SINX
                A(IM) = A(IL) * SINX + A(IM) * COSX
                A(IL) = X
              END IF
            END IF
            ILR = ILQ + I
            IMR = IMQ + I
            X = R(ILR) * COSX - R(IMR) * SINX
            R(IMR) = R(ILR) * SINX + R(IMR) * COSX
            R(ILR) = X
          END DO
          X     = 2.0D0 * A(LM) * SINCS
          Y     = A(LL) * COSX2 + A(MM) * SINX2 - X
          X     = A(LL) * SINX2 + A(MM) * COSX2 + X
          A(LM) = (A(LL) - A(MM)) * SINCS + A(LM) * (COSX2 - SINX2)
          A(LL) = Y
          A(MM) = X
        END IF
        IF(M /= 3) THEN
          M = M + 1
          GO TO 10
        END IF
        IF (L /= 2) THEN
          L = L + 1
          M = L + 1
          GOTO 10
        END IF
        IF (IND == 1) THEN
          IND = 0
          L   = 1
          M   = L + 1
          GOTO 10
        END IF
        IF (THR > ANRMX) THEN
          THR = THR / 3.0D0
          L   = 1
          M   = L + 1
          GOTO 10
        END IF
      END IF
      IQ = -3
      DO I = 1, 3
        IQ = IQ + 3
        LL = I + (I * I - I) / 2
        JQ = 3 * (I - 2)
        DO J = I, 3
          JQ = JQ + 3
          MM = J + (J * J - J) / 2
          IF (A(LL) < A(MM)) THEN
            X = A(LL)
            A(LL) = A(MM)
            A(MM) = X
            DO K = 1, 3
              ILR = IQ + K
              IMR = JQ + K
              X   = R(ILR)
              R(ILR) = R(IMR)
              R(IMR) = X
            END DO
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN161
 
      SUBROUTINE GEN162 (P, Y, MP0, NP, NDIM, FTOL, FUNK, ITER)
C * AMOEBA
      IMPLICIT NONE
      INTEGER, PARAMETER       :: NMAX  = 20
      INTEGER, PARAMETER       :: ITMAX = 500
      REAL,    PARAMETER       :: ALPHA = 1.0
      REAL,    PARAMETER       :: BETA  = 0.5
      REAL,    PARAMETER       :: GAM   = 2.0
      INTEGER                  :: I
      INTEGER                  :: J
      INTEGER                  :: NP
      INTEGER                  :: MP0
      INTEGER                  :: ILO
      INTEGER                  :: IHI
      INTEGER                  :: INHI
      INTEGER                  :: NDIM
      INTEGER                  :: ITER
      INTEGER                  :: MPTS
      REAL                     :: YPR
      REAL                     :: FUNK
      REAL                     :: YPRR
      REAL                     :: FTOL
      REAL                     :: RTOL
      REAL, DIMENSION(MP0, NP) :: P
      REAL, DIMENSION(MP0)     :: Y
      REAL, DIMENSION(NMAX)    :: PR
      REAL, DIMENSION(NMAX)    :: PRR
      REAL, DIMENSION(NMAX)    :: PBAR
      EXTERNAL FUNK
      MPTS = NDIM + 1
      ITER = 0
      DO WHILE (.TRUE.)
        ILO = 1
        IF (Y(1) > Y(2)) THEN
          IHI  = 1
          INHI = 2
        ELSE
          IHI  = 2
          INHI = 1
        END IF
        DO I = 1, MPTS
          IF (Y(I) < Y(ILO)) ILO = I
          IF (Y(I) > Y(IHI)) THEN
            INHI = IHI
            IHI  = I
          ELSE IF (Y(I) > Y(INHI)) THEN
            IF (I /= IHI) INHI = I
          END IF
        END DO
        RTOL = 2.0 * ABS (Y(IHI) - Y(ILO)) / (ABS (Y(IHI))
     1       + ABS (Y(ILO)))
        IF (RTOL < FTOL) RETURN
        IF (ITER == ITMAX)
     1    CALL TRAILER ('GEN033 exceeding maximum iterations.')
        ITER = ITER + 1
        CALL GEN074 (PBAR, 1, NDIM, 0.0)
        DO I = 1, MPTS
          IF (I /= IHI) THEN
            DO J = 1, NDIM
              PBAR(J) = PBAR(J) + P(I, J)
            END DO
          END IF
        END DO
        DO J = 1, NDIM
          PBAR(J) = PBAR(J) / NDIM
          PR(J)   = (1.0 + ALPHA) * PBAR(J) - ALPHA * P(IHI, J)
        END DO
        YPR = FUNK(PR)
        IF (YPR <= Y(ILO)) THEN
          DO J = 1, NDIM
            PRR(J) = GAM * PR(J) + (1.0 - GAM) * PBAR(J)
          END DO
          YPRR = FUNK(PRR)
          IF (YPRR < Y(ILO)) THEN
            DO J = 1, NDIM
              P(IHI, J) = PRR(J)
            END DO
            Y(IHI) = YPRR
          ELSE
            DO J = 1, NDIM
              P(IHI, J) = PR(J)
            END DO
            Y(IHI) = YPR
          END IF
        ELSE IF (YPR >= Y(INHI)) THEN
          IF (YPR < Y(IHI)) THEN
            DO J = 1, NDIM
              P(IHI, J) = PR(J)
            END DO
            Y(IHI) = YPR
          END IF
          DO J = 1, NDIM
            PRR(J) = BETA * P(IHI, J) + (1.0 - BETA) * PBAR(J)
          END DO
          YPRR = FUNK(PRR)
          IF (YPRR < Y(IHI)) THEN
            DO J = 1, NDIM
              P(IHI, J) = PRR(J)
            END DO
            Y(IHI) = YPRR
          ELSE
            DO I = 1, MPTS
              IF(I /= ILO) THEN
                DO J = 1, NDIM
                  PR(J) = 0.5 * (P(I, J) + P(ILO, J))
                  P(I, J) = PR(J)
                END DO
                Y(I) = FUNK(PR)
              END IF
            END DO
          END IF
        ELSE
          DO J = 1, NDIM
            P(IHI, J) = PR(J)
          END DO
          Y(IHI) = YPR
        END IF
      END DO
      RETURN
      END SUBROUTINE GEN162
 
 
      REAL FUNCTION GEN163 (C, D, K, N)
C * CALCULATE VOLUME FROM CELL DATA (SUPPORT FOR GEN068)
      IMPLICIT NONE
      INTEGER            :: K
      INTEGER            :: N
      REAL               :: V
      REAL               :: SA
      REAL               :: SB
      REAL               :: SG
      REAL               :: CA
      REAL               :: CB
      REAL               :: CG
      REAL               :: DTR
      REAL, DIMENSION(6) :: C
      REAL, DIMENSION(6) :: D
      V   = 0.0
      DTR = 45.0 / ATAN2 (1.0, 1.0)
C * add S.U. for parameter N
      IF (N > 0) C(N) = C(N) + D(N)
      SA  = SIN (C(4) / DTR)
      SB  = SIN (C(5) / DTR)
      SG  = SIN (C(6) / DTR)
      CA  = COS (C(4) / DTR)
      CB  = COS (C(5) / DTR)
      CG  = COS (C(6) / DTR)
C * TRICLINIC
      IF (K == 1) THEN
        V = C(1) * C(2) * C(3) * SQRT (1.0 - CA**2 - CB**2 - CG**2 +
     1       2.0 * CA * CB * CG)
C * MONOCLINIC-b
      ELSE IF (K == 2) THEN
        V = C(1) * C(2) * C(3) * SB
C * ORTHORHOMBIC
      ELSE IF (K == 3) THEN
        V = C(1) * C(2) * C(3)
C * TRIGONAL & HEXAGONAL
      ELSE IF (K == 4 .OR. K == 6) THEN
        V = C(3) * (C(1)**2) * SG
C * TETRAGONAL
      ELSE IF (K == 5) THEN
        V = C(3) * C(1)**2
C * CUBIC
      ELSE IF (K == 7) THEN
        V = C(1)**3
C * RHOMBOHEDRAL
      ELSE IF (K == 8) THEN
        V = (C(1)**3) * SQRT (1.0 - 3.0 * CA**2 + 2.0 * CA**3)
C * MONOCLINIC-c
      ELSE IF (K == 9) THEN
        V = C(1) * C(2) * C(3) * SG
C * MONOCLINIC-a
      ELSE IF (K == 10) THEN
        V = C(1) * C(2) * C(3) * SA
      END IF
      IF (N > 0) C(N) = C(N) - D(N)
      GEN163 = V
      RETURN
      END FUNCTION GEN163
 
      SUBROUTINE GEN164 (A, B)
C * CONVERT A(3, 3) TO B(9)
      INTEGER               :: I
      INTEGER               :: J
      INTEGER               :: K
      REAL, DIMENSION(3, 3) :: A
      REAL, DIMENSION(9)    :: B
      K = 0
      DO J = 1, 3
        DO I = 1, 3
          K = K + 1
          B(K) = A(I, J)
        END DO
      END DO
      RETURN
      END SUBROUTINE GEN164
 
      SUBROUTINE GEN165 (U, T, P)
 
C * MULTIPLY TWO '3X3' MATRICES (stored as rows)
      REAL, DIMENSION(9) :: U
      REAL, DIMENSION(9) :: T
      REAL, DIMENSION(9) :: P
      P(1) = T(1) * U(1) + T(4) * U(2) + T(7) * U(3)
      P(2) = T(2) * U(1) + T(5) * U(2) + T(8) * U(3)
      P(3) = T(3) * U(1) + T(6) * U(2) + T(9) * U(3)
      P(4) = T(1) * U(4) + T(4) * U(5) + T(7) * U(6)
      P(5) = T(2) * U(4) + T(5) * U(5) + T(8) * U(6)
      P(6) = T(3) * U(4) + T(6) * U(5) + T(9) * U(6)
      P(7) = T(1) * U(7) + T(4) * U(8) + T(7) * U(9)
      P(8) = T(2) * U(7) + T(5) * U(8) + T(8) * U(9)
      P(9) = T(3) * U(7) + T(6) * U(8) + T(9) * U(9)
      RETURN
      END SUBROUTINE GEN165
 
      INTEGER FUNCTION GEN166 (ICH)
C * GET CHARACTER TYPE
      IMPLICIT NONE
      INTEGER          :: I
      CHARACTER(len=1) :: ICH
      GEN166 = -3
C * CHECK FOR SPACE
      IF (ICH == CHAR(32)) THEN
        GEN166 = -2
        RETURN
      END IF
C * CHECK FOR UPPER CASE CHARACTER
      DO I = ICHAR ('A'), ICHAR ('Z')
        IF (ICH == CHAR (I)) THEN
          GEN166 = 1
          RETURN
        END IF
      END DO
C * CHECK FOR LOWER CASE CHARACTER
      DO I = ICHAR ('a'), ICHAR ('z')
        IF (ICH == CHAR (I)) THEN
          GEN166 = -1
          RETURN
        END IF
      END DO
C * CHECK FOR NUMERAL
      DO I = 1, 10
        IF (ICH == CHAR (ICHAR ('0') - 1 + I)) THEN
          GEN166 = 0
          RETURN
        END IF
      END DO
      RETURN
      END FUNCTION GEN166
C * GRAPHICS FUNCTION INTERFACE ROUTINE GGIP
      MODULE cggip                   ! GGIP SECTION
      SAVE
      INTEGER, PARAMETER :: IPDS = 2
      INTEGER, PARAMETER :: IPME = 2
      INTEGER :: IXVERS     = 251223 ! VERSION ddmmyy OF xdrvr.c  ROUTINE
      INTEGER :: TERMINAL   = 1      ! DEFAULT GRAPHICS OUTPUT TO TERMINAL
      INTEGER :: IHPDP      = 1      ! DEFAULT TERMINAL SWITCH ON TERMINAL
      INTEGER :: METAFILE   = -1     ! DEFAULT GRAPHICS META-FILE OUTPUT
      INTEGER :: TERM       = 1      ! TERMINAL DEFAULT SET TO X11
      INTEGER :: META       = 1      ! METAFILE DEFAULT SET TO PostScript
      INTEGER :: IXM
      INTEGER :: IYM
      INTEGER :: JXO
      INTEGER :: JYO
      INTEGER :: KNM
      INTEGER :: ISW        = 930
      INTEGER :: ISWD       = 930
      INTEGER :: NPUD
      INTEGER :: IPCL
      INTEGER :: JTEL
      INTEGER :: KTEL
      INTEGER :: IDMX       = 800
      INTEGER :: IDMY       = 600
      INTEGER :: IDMZ       = 8
      INTEGER :: NAMP       = -1
      INTEGER :: IPSD       = 2
      INTEGER :: NVEC       = -1
      INTEGER :: IBAW       = 0
      INTEGER :: NRPS       = 0
      INTEGER :: IPSR       = 0
      INTEGER :: IPSH       = 0
      INTEGER :: IPSV       = 0
      INTEGER :: IPSW       = 0
      INTEGER :: IPSM       = 9
      INTEGER :: IPSX       = 1
      INTEGER :: IGST       = -1
      INTEGER :: IWDO       = 0
      INTEGER :: INOP
      INTEGER :: IPSN
      INTEGER :: NOYES
      INTEGER :: IPCLD      = 1
      INTEGER :: ISTAT      = 1
      INTEGER :: IPCLN
      INTEGER :: IXOHI
      INTEGER :: IXOLO
      INTEGER :: IYOHI
      INTEGER :: IYOLO
      INTEGER :: ISVPLT     = 0
      INTEGER :: METAPL     = 0
      INTEGER :: IOTERM     = -1
      INTEGER :: IOMETA     = -1
      INTEGER :: IOTERMINAL = -9
      INTEGER :: IOMETAFILE = -9
      INTEGER, DIMENSION(7)  :: KXE
      INTEGER, DIMENSION(7)  :: KYE
C * ASCII CHARACTER 32 TO 122 PLOT ENCODING AS A SET OF STROKES
      INTEGER, DIMENSION(91) :: ADR = (/
     1     0,  9405,  9209,  8411,  7712, 19714,  9512,  9804,  7504,
     2  7604,  7111,  6905,  8106,  7002,  8305,  7402,  4709,  4905,
     3  5009,  5213,  5504,  5609,  5812,  6105,  6216,  6612,  8911,
     4 10812, 10203,  8005, 10303,  9911, 10415,   109,   312,   608,
     5   807,  1007,  1206,  1410,  1606,  1806,  2006,  2206,  2403,
     6  2505,  2604,  2710,  2907,  3112,  3410,  3612,  3904,  4006,
     7  4203,  4305,  4405,  4505,  4604,  8704, 10702,  8804, 20003,
     8 19603,     0, 14211, 14511, 14808, 15011, 15310, 15508, 15714,
     9 16007, 16208, 16406, 16606, 16805, 16910, 17107, 17309, 17511,
     * 17811, 18106, 18310, 18508, 18707, 18903, 19005, 19105, 19211,
     1 19504/)
      INTEGER, DIMENSION(200) :: TAB = (/
     1    929990,259942400,  1964453,470927585,402653184,645722497,
     2 140644352,  1964449,402653184,656164612,  8388608,  1163527,
     3 654311424,645722497,140646611,  1853735,536870912,140576207,
     4 520093696, 33850913,654311424,  1849804,536870912,117571584,
     5   1919456,  1968576,496628678, 18974822,  1964453,470810624,
     6 563737542, 18974840,310378496,  1964453,470927584, 18974819,
     7 472928655,530055168,274495936,117736993,654311424,121794560,
     8 119617063, 10453472,122750247,127666176,563737542, 18974784,
     9 240976408, 85522406,621021184,104724901,473024737,404754432,
     * 410790016, 18974819,470841792, 53594337,404754831,530055168,
     1 102659152,202117656,562938629,104724901,469762048, 18974822,
     2 524050699,462422016,290795747, 59506688,290795747,319182021,
     3 553648128, 10223616,407201728,138765248, 23472348,202697144,
     4 390070272,605257890,138748553,285212672,138482248, 76777602,
     5 941940253,419430400,660408320,123535360,153691209,942753101,
     6 201326592,358413688,631109952,273122455,574652482,494498758,
     7  92274688,494761792, 85522406,625815057,268435456,554586112,
     8  25972736,443368138,292170013,219157016,125829120,138748553,
     9 299971852,189530112,307249184,609296384,307282113,140646620,
     * 340262912,307238996,301989888,307299458,575143936,302138500,
     1 541589504,307242018,340262912,306266274,340262912,302137632,
     2 301989888,311445760,536944640,303113234,608698368,311538372,
     3 186909273,543536256,302138516,273172498, 42541056,311445504,
     4 301989888,307299456,302654592,559972419,208813604,536870912,
     5 117670092,479073800, 16777216,559972419,208809984,559972419,
     6 208813607,536870912, 40515340, 50628129,137983974,940687360,
     7 990152225,664400838, 70105344,117453596,595591168, 67404825,
     8 940863488,990152225,654311424,117451027,536870912,117736473,
     9  67121939,273533152, 67121948,595591168, 17614627,559972416,
     * 989884815,530204363, 67108864,998406559,253248219,603979776,
     1   1061660,587202560, 18974810,168609571,560005711,940654592,
     2 203752993,612368384, 71450624, 69281316, 75726884,993838299,
     3 614340104, 16777216, 76548096,990519296, 12550998,253287968,
     4 696883200,106848256/)
      REAL                              :: SCF
      REAL                              :: XOLD
      REAL                              :: YOLD
      REAL                              :: XMAX
      REAL                              :: YMAX
      REAL                              :: SCFJ
      REAL                              :: ZFRC
      REAL                              :: XREF  = 0.0
      REAL                              :: YREF  = 0.0
      REAL                              :: FACTR
      CHARACTER(len=4)                  :: DCODE = 'none'
      CHARACTER(len=4)                  :: MCODE = 'none'
      CHARACTER(len=80)                 :: METAF
      CHARACTER(len=132)                :: BUF
      CHARACTER(len=1), DIMENSION(7)    :: KME
      CHARACTER(len=4), DIMENSION(IPDS) :: DSCOD = (/' X11', 'NONE'/)
      CHARACTER(len=4), DIMENSION(IPME) :: MECOD = (/'  PS', 'HPGL'/)
      CHARACTER(len=3), DIMENSION(IPME) :: PLEXT = (/'ps ',   'hpl'/)
C * WHITE, BLACK, RED, GREEN, BLUE, YELLOW, ORANGE, MAGENTA
      CHARACTER(len=16), DIMENSION(17)  :: KLEUR = (/
     1 ' 1.0  1.0  1.0 c', ' 0.0  0.0  0.0 c', ' 1.0  0.0  0.0 c',
     2 ' 0.0  1.0  0.0 c', ' 0.0  0.0  1.0 c', ' 1.0  1.0  0.0 c',
     3 ' 1.0  0.25 0.2 c', ' 1.0  0.0  1.0 c', '0.65 0.16 0.16 c',
     4 ' 0.0  0.0  0.0 c', ' 0.0  0.0  0.0 c', ' 0.0  0.0  0.0 c',
     5 ' 0.0  0.0  0.0 c', ' 0.0  0.0  0.0 c', ' 0.0  0.0  0.0 c',
     6 ' 0.0  0.0  0.0 c', ' 0.0  0.0  0.0 c'/)
      END MODULE cggip
 
      SUBROUTINE GGIP (X, Y, Z, IFUNCTION)
C *====================================================================C
C *                 ****    G   G   I   P   ****                       C
C *====================================================================C
C *                    (C) 1980 - 2023  A.L. Spek                      C
C *                                                                    C
C *             GENERAL GRAPHICS INTERFACE PACKAGE FOR                 C
C *              HARD-COPY AND DISPLAY SURFACE OUTPUT                  C
C *                                                                    C
C *                          A.L. SPEK,                                C
C *                      UTRECHT UNIVERSITY                            C
C *                       THE NETHERLANDS.                             C
C *                                                                    C
C *                       VERSION 06-Jul-2023                          C
C *                                                                    C
C * GRAPHICS DISPLAYS CURRENTLY SUPPORTED (DISPLAY-MODE) SHORT NAME    C
C *                                                                    C
C *          X-WINDOW                                    - X11         C
C *                                                                    C
C * GRAPHICS METAFILE CODE          (METAFILE-MODE)                    C
C *                                                                    C
C *          POSTSCRIPT (DEFAULT)                        - PS          C
C *          HPGL - LANGUAGE                             - HPGL        C
C *                                                                    C
C * ALL USER CALLS TO A GRAPHICS MEDIUM SHOULD BE DIRECTED THROUGH     C
C * THIS ROUTINE. ESSENTIALLY ONLY THE OLD CALCOMP TYPE VECTOR GRAPHICSC
C * 'CALL PLOT(X, Y, IPEN)' INSTRUCTIONS HAVE BEEN IMPLEMENTED, WHERE  C
C * X, Y   C ARE IN CM AND IPEN = +,-2 OR +,-3. ALL OTHER CALLS TO     C
C * GGIP SET PARAMETERS WITHIN THIS PACKAGE.  METAFILE ON UNIT LU98    C
C * (WHEN 'META ON') FOR OFF-LINE DISPLAY/HARDCOPY.                    C
C * ------------------------------------------------------------------ C
C * GENERAL CALL TO ROUTINE GGIP:  GGIP (X, Y, Z, FUNCTION), WHERE FOR C
C *                                                                    C
C * X = -999.0 =====(SET PACKAGE PARAMETERS, HANDLE REQUESTS)==========C
C *   I   FUNCTION                                                     C
C *   I ---  1 --> GET XWINDOW OPEN STATUS IN 'Z' = (0/1)              C
C *   I ---  2 --> DISPLAY   ON                                        C
C *   I --- -2 --> DISPLAY  OFF (IMPLICITLY METAFILE ON)               C
C *   I ---  3 --> METAFILE  ON (PERMANENT FOR Z = -1.0)               C
C *   I --- -3 --> METAFILE OFF (IMPLICITLY DISPLAY  ON)               C
C *   I ---  4 --> LANDSCAPE POSTSCRIPT                                C
C *   I --- -4 --> PORTRAIT  POSTSCRIPT                                C
C *   I ---  5 --> BEGIN OF PROGRAM INIT  Y >  0: METAFILE  (EXT)      C
C *   I                                   Y =  0: 'PLOT.EXT' (INT)     C
C *   I                                   Y = -L: METAF IN IGGT        C
C *   I                                           L = LENGTH NAME      C
C *   I                                   Z >  0: DISPLAY-FILE (E)     C
C *   I                                   Z =  0: INTERNAL             C
C *   I --- -5 --> END OF PROGRAM CLOSING PROCEDURES                   C
C *   I ---  6 --> Y =  1 :X-WINDOW       Z =  0                       C
C *   I                                                                C
C *   I                                                                C
C *   I                Y =  0 : META FILE-->  Z =  1 :POSTSCRIPT       C
C *   I                                       Z =  2 :HPGL             C
C *   I ---  6     Y =  0, Z =  0 --> INFORMATION IN IGGT              C
C *   I                                   MEDIUM, IGGT(16:22)          C
C *   I ---  7 --> GRAPHICS HELP OPTION                                C
C *   I ---  8 --> INFO GRAPHICS STATUS     Y =  0                     C
C *   I --- -8 --> REPORT DISPLAY PARAMETERS                           C
C *   I            X = X-PIXEL, Y = YPIXEL, Z = DEPTH                  C
C *   I                                     Y =  1 : X11               C
C *   I ---  9 --> Y =  0, IZ =  FRACTION OF DISPLAY SIZE (/1000)      C
C *   I            Y =  1, IZ =  FRACTION OF DISPLAY SIZE (/1000)      C
C *   I --- 10 --> Submenu title                                       C
C *   I --- 11-25 --> Option texts    (+ color & nr of sunboxes)       C
C *   I --- 111-112 Message Boxes                                      C
C *                                                                    C
C *   X > -999 AND IABS(I) < 7 ===== (GRAPHICS) =======================C
C *       FUNCTION                                                     C
C *          1 --> BEG PLOT X > 0;Y = 0: X = XMAX,YMAX PLOT IN CM.     C
C *                         X > 0;Y > 0: X = XMAX, Y = YMAX            C
C *                                      Z = FRACTION XMAX-SIZE        C
C *         -1 --> END PLOT X = 0;Y = 0: Z = 0: READ AT E-O-PLOT       C
C *                                      Z = 1: GO   AT E-O-PLOT       C
C *          0 --> NEWPEN(Y)      Y =  0: BLACK (WHITE)                C
C *                               Y =  1: WHITE (BLACK)                C
C *                               Y =  2: RED                          C
C *                               Y =  3: GREEN                        C
C *                               Y =  4: BLUE                         C
C *                               Y =  5: YELLOW                       C
C *                               Y =  6: ORANGE                       C
C *                               Y =  7: VIOLET                       C
C *                               Y =  8: BROWN                        C
C *                               Y =  9: PINK                         C
C *                               Y = 10: MAGENTA                      C
C *                               Y = 11: CYAN                         C
C *                               Y = 12: GOLDN                        C
C *                               Y = 13: NAVYBLUE                     C
C *                               Y = 14: GRAY                         C
C *                               Y = 15: LIME GREEN                   C
C *                                                                    C
C *                               Y = < 0: LINEWIDTH                   C
C *                                                                    C
C *                (Set Default)  Y = -100 : X-Win MinWidth = 1        C
C *                (Set Default)  Y = -200 : X-Win MinWidth = 2        C
C *                                                                    C
C *          2 --> DRAW(X, Y, Z)                                       C
C *          3 --> MOVE(X, Y, Z)                                       C
C *         -3 --> MOVE TO NEW ORIGIN                                  C
C *          4 --> CHARACTER PLOT                                      C
C *          5 --> MOUSE EVENTLOOP                                     C
C *          6 --> Flush Buffer   Z = Seconds Sleep                    C
C *          7 --> FACTOR         Y = Multiplication fact X,Y,Z        C
C *          9 --> Interruptloop                                       C
C *                                                                    C
C *********************************************************************C
C *                                                                    C
C *               * * * BITMAP PIXEL NUMBERING * * *                   C
C *                                                                    C
C * PIXELS ARE NUMBERED FROM 0 TO IXM  (= IXM + 1 HORIZONTAL PIXELS)   C
C * PIXELS ARE NUMBERED FROM 0 TO IYM  (= IYM + 1 VERTICAL   PIXELS)   C
C *                                                                    C
C * ORIGIN (0, 0) IN LOWER LEFT CORNER, X HORIZONTAL, Y VERTICAL       C
C *                                                                    C
C * ============================ =======================================
C * THE IGGT HOLDS THE COMMAND LINE ENTERED IN ENDPLT                  C
C * ===================================================================C
C *                  GRAPHICS CALLING FRAMEWORK                        C
C *                  ==========================                        C
C *                                                                    C
C *  GENERAL INITIALISATION:          CALL GGIP(-999.0, UNIT, 0.0,  5) C
C *    WITH META-FILE UNIT_NUMBER                                      C
C *  SELECT DISPLAY TYPE (DTYP)       CALL GGIP(-999.0, DTYP, 0.0,  6) C
C *    XWINDOW(=1)                                                     C
C *  SELECT META TYPE  (TYPM)         CALL GGIP(-999.0, 0.0,  TYPM, 6) C
C *      HPGL(=1)                                                      C
C *  SELECT GRAPHICS MEDIUM  (ISEL)   CALL GGIP(-999.0, 0.0, 0.0, ISEL)C
C *   DISPLAY(=1), METAFILE(=2):                                       C
C *                                           .........                C
C *  START A NEW PLOT:                CALL GGIP(XMAX,   YMAX, 0.0,  1) C
C *                                           .........                C
C *  PLOT INSTRUCTIONS                CALL GGIP(X, Y, Z, IPEN)         C
C *                                           .........                C
C *  SELECT PEN:                      CALL GGIP(0.0, XPEN, 0.0, 0)     C
C *                                           .........                C
C *  END OF A PLOT:                   CALL GGIP(0.0, 0.0, 0.0, -1)     C
C *                                           .........                C
C *  GENERAL GRAPHICS CLOSING:        CALL GGIP(-999.0, 0.0, 0.0, -5)  C
C *                                                                    C
C *********************************************************************C
      USE files
      USE cggip
      USE cggt
      IMPLICIT NONE
      INTEGER          :: I
      INTEGER          :: IX
      INTEGER          :: IY
      INTEGER          :: IZ
      INTEGER          :: IBUT
      INTEGER          :: IFUNC
      INTEGER          :: IDUM1
      INTEGER          :: IDUM2
      INTEGER          :: IDUM3
      INTEGER          :: IDUM4
      INTEGER          :: IVENT
      INTEGER          :: CHANGE
      INTEGER          :: IFUNCTION
      REAL             :: X
      REAL             :: Y
      REAL             :: Z
      REAL             :: XVAL
      REAL             :: YVAL
      REAL             :: ZVAL
      CHARACTER(len=3) :: DISPLAY_STATUS
      CHARACTER(len=3) :: METAFILE_STATUS
C * XMAX - PLOT WIDTH  (CM)
C * YMAX - PLOT HEIGHT (CM)
C * COPY X, Y, Z, IFUNCTION INTO XVAL, YVAL, ZVAL, IFUNC
      XVAL   = X
      YVAL   = Y
      ZVAL   = Z
      IFUNC  = IFUNCTION
      CHANGE = 0
C * TEST FOR SPECIAL FUNCTIONS: GRAPHICS MEDIUM, GENERAL INIT AND CLOSE
   10 IF (XVAL < -998.9) THEN
C * SPECIAL FUNCTIONS
        IF (IABS(IFUNC) < 10) THEN
          IF (IFUNC /= -5) THEN
            IY = NINT (YVAL)
            IZ = NINT (ZVAL)
          END IF
          ISTAT = 1
C * IFUNCTION 9: FRACTION WINDOW:DISPLAY SIZE
          IF (IFUNC == 9) THEN
            IBAW = IY
            IF (IZ >= 10) ISW = MIN (IZ, ISWD)
            IF (IWDO /= 0) THEN
              IDUM1 = 0
              IDUM2 = 0
              IDUM3 = 0
              IDUM4 = 0
              CALL GGIP08 (IDUM1, IDUM2, IDUM3, IDUM4)
              IWDO  = 0
            END IF
            WRITE (LU6, 99995) ISW / 1000.0
C * IFUNCTION 8: GRAPHICS STATUS INFO
          ELSE IF (IFUNC == 8) THEN
            IF (IGST == -1) THEN
              IDUM1 = 0
              IDUM2 = 0
              IDUM3 = 0
              IDUM4 = -1
              CALL GGIP08 (IDUM1, IDUM2, IGST, IDUM4)
            END IF
            Y = IGST
            Z = META
C * REPORT DISPLAY PARAMETERS
          ELSE IF (IFUNC == -8) THEN
            X = IDMX
            Y = IDMY
            Z = IDMZ
C * IFUNCTION 7: HELP GRAPHICS
          ELSE IF (IFUNC == 7) THEN
            ISTAT = -1
            WRITE (LU6, 99997)
            WRITE (LU6, 99992) (DSCOD(I), I = 1, IPDS)
            WRITE (LU6, 99993) (MECOD(I), I = 1, IPME)
            WRITE (LU6, 99994)
C * IFUNCTION 6: SET TERMINAL, ON-LINE HARDCOPY OR META-FILE TYPE
          ELSE IF (IFUNC == 6) THEN
            IF (IY == 0 .AND. IZ == 0) THEN
              IF (INDEX (IGGT, ' ON ') /= 0) THEN
                IFUNC =  1
              ELSE IF (INDEX (IGGT, ' OFF ') /= 0) THEN
                CALL GGIP05
                IFUNC = -1
              ELSE
                IFUNC =  6
              END IF
C * SET BEEP ON/OFF
              IF (MEDIUM == 0) THEN
C * SET MEDIUM DISPLAY
              ELSE IF (MEDIUM == 1) THEN
                IF (IFUNC /= 6) IFUNC = 2 * IFUNC
C * SET MEDIUM META
              ELSE IF (MEDIUM == 2) THEN
                IF (IFUNC /= 6) THEN
                  IFUNC = 3 * IFUNC
C * META:  1 = PS(POSTSCRIPT), 2 = HPGL
                ELSE
                  DO IZ = 1, IPME
                    IF (INDEX (IGGT, MECOD(IZ)) /= 0) THEN
                      GO TO 30
                    END IF
                  END DO
                  IZ = META
                END IF
              ELSE
C * CHAR(7) = ASCII BELL = CTRL-G
                WRITE (LU6, 99991) MEDIUM, CHAR (7)
              END IF
   30         CALL GEN038 (IGGT, 1, 80)
              IF (IFUNC /= 6) GO TO 10
            END IF
            IF (IY > 0 .AND. IY <= IPDS) THEN
C * SET TERMINAL TYPE (TEK 4010)
              TERM = IY
            ELSE
C * SET META-FILE TYPE
              IF (NPLOT == 0) THEN
                META = IZ
              ELSE
                IF (META /= IZ) THEN
                  INQUIRE (LU98, EXIST = EXST)
                  IF (NVEC <= 0) THEN
                    IF (EXST) CLOSE (UNIT = LU98, STATUS = 'DELETE')
                  ELSE
                    IF (EXST) CLOSE (UNIT = LU98)
                    WRITE (LU6, 99996) METAF(1:KNM), PLEXT(META),
     1                                  NVEC, NPLOT
                    META  = IZ
                    NVEC  = -1
                    NPLOT = 0
                  END IF
                END IF
              END IF
              CALL GEN038 (IGGT, 1, 80)
            END IF
            IF (TERM < 99) DCODE = DSCOD(TERM)
            MCODE = MECOD(META)
            IF (IOMETA /= META) THEN
              CHANGE = 1
              IOMETA = META
            END IF
            IF (IOTERM /= TERM) THEN
              CHANGE = 1
              IOTERM = TERM
            END IF
C * IFUNCTION 5: HANDLING OF PROGRAM START/FINISH
          ELSE IF (IABS(IFUNC) == 5) THEN
C * LOAD CHARACTER DRAW DATA
            CALL GGIP06 (IFUNC, IY, IZ)
C * IFUNCTION  4: LANDSCAPE/PORTRAIT HANDLING (POSTSCRIPT)
          ELSE IF (IABS(IFUNC) == 4) THEN
            IF (IFUNC > 0) THEN
              IPSH = 0
              IPSV = 0
              IPSR = 0
            ELSE
              IPSH = 0
              IPSV = 6120
              IPSR = -90
            END IF
C * IFUNCTION 3: IS IT A META(ON/OFF) REQUEST
          ELSE IF (IABS (IFUNC) == 3) THEN
            METAFILE = SIGN (1, IFUNC)
            IF (METAFILE < 0) TERMINAL = 1
            IF (ZVAL < 0) THEN
              METAPL = -1
            ELSE
              METAPL =  1
            END IF
C * IFUNCTION 2: IS IT A DISPLAY(ON/OFF) REQUEST
          ELSE IF (IABS (IFUNC) == 2) THEN
            IHPDP    = 1
            TERMINAL = SIGN (1, IFUNC)
C * IFUNCTION 1: CHECK FOR AN OPEN DISPLAY WINDOW
          ELSE IF (IABS (IFUNC) == 1) THEN
            CALL GGIP08 (0, 0, NOYES, 13)
C * RETURN NO/YES (0/1) VALUE TO
            Z = NOYES
          END IF
C * MAKE SHURE THAT AT LEAST ONE FUNCTION IS OPEN
          IF (TERMINAL < 0) METAFILE = 1
C * OUTPUT DISPLAY (ON/OFF) AND  METAFILE (ON/OFF) STATUS
          IF (ISTAT > 0) THEN
C * TERMINAL STATUS (-/+)
            IF (TERMINAL < 0) THEN
              DISPLAY_STATUS = 'off'
            ELSE
              DISPLAY_STATUS = 'on '
            END IF
            IF (IOTERMINAL /= TERMINAL) THEN
              CHANGE = 1
              IOTERMINAL = TERMINAL
            END IF
C * METAFILE STATUS (-/+)0
 
            IF (METAFILE > 0) THEN
              METAFILE_STATUS = 'on '
            ELSE
              METAFILE_STATUS = 'off'
            END IF
            IF (IOMETAFILE /= METAFILE) THEN
              CHANGE = 1
              IOMETAFILE = METAFILE
            END IF
            IF (CHANGE /= 0) THEN
              WRITE (LU6, 99999) DISPLAY_STATUS,  DCODE
              WRITE (LU6, 99998) METAFILE_STATUS, MCODE
              CHANGE = 0
            END IF
            ISTAT = -1
          END IF
C * BUILD MENU FUNCTIONS  (10, 11), AND MESSAGES 111, 112
        ELSE IF (IFUNC > 9) THEN
            IDUM1 = INDEX (BCD, CHAR (0))
            IDUM2 = NINT (YVAL)
            IDUM3 = NINT (ZVAL)
            IDUM4 = IABS (IFUNC) + 90
            BUF   = BCD
            CALL GGIP08 (IDUM1, IDUM2, IDUM3, IDUM4)
        END IF
C * PLOT INSTRUCTIONS
      ELSE
        IF (IABS (IFUNC) <= 9) THEN
C * PLOT FUNCTIONS 1, -1, 0: HANDLING OF NAMPLT/ENDPLT/NEWPEN
          IF (IABS (IFUNC) <= 1) THEN
C * NAMPLOT
            IF (IFUNC == 1) THEN
C * GET X-MAX, Y-MAX AND FRACTION
              CALL GGIP01 (XVAL, YVAL, ZVAL)
              FACTR = 1.0
C * ENDPLOT
            ELSE IF (IFUNC == -1) THEN
              CALL GGIP02 (Z)
C * NEWPEN (COLOUR AND/OR LINEWIDTH)
C * SET COLOUR
            ELSE IF (IFUNC == 0) THEN
              XVAL = 0.0
              IF (YVAL >= 0.0) THEN
                IF (TERMINAL > 0 .OR. METAFILE > 0)
     1            IPCLN = NINT (YVAL)
C * SET LINEWIDTH
              ELSE
                IF (TERMINAL > 0 .OR. METAFILE > 0) THEN
                  IPSN = NINT (ABS (YVAL))
                  IF (IPSN >= 100) THEN
                    IPSX = IPSN / 100
                    IPSN = IPSN - IPSX * 100
                  END IF
                END IF
              END IF
            END IF
C * CHARACTER STRING PLOT FUNCTION
          ELSE IF (IFUNC == 4) THEN
            CALL GGIP07 (XVAL, YVAL)
C * MOUSE EVENTLOOP (RETURN COORDINATES X, Y OF EVENT)
          ELSE IF (IFUNC == 5) THEN
            IF (NAMP >= 0) THEN
              IF (IHPDP == 1 .AND. IWDO == 1) THEN
                IPCLN = IPCLD
                IPSN  = IPSD
C * CHECK COLOUR/LINEWIDTH CHANGE
                CALL GGIP03
                IBUT  = 0
                IX    = 0
                IY    = 0
                CALL GGIP08 (IX, IY, IBUT, IFUNC)
                ZVAL  = IBUT
                IVENT = IFUNC
C * SCALE BACKWARDS
                IF (IFUNC == 1) THEN
                  XVAL = IX / (SCF * FACTR)
                  YVAL = IY / (SCF * FACTR)
                ELSE IF (IFUNC == 5) THEN
                  BCD(1:1) = BUF(1:1)
                ELSE
                  XVAL    = IX
                  YVAL    = IY
                END IF
              ELSE
                IVENT = -1
              END IF
            ELSE
              IVENT = 0
            END IF
            X         = XVAL
            Y         = YVAL
            Z         = ZVAL
            IFUNCTION = IVENT
C * FLUSH AND SLEEP
          ELSE IF (IFUNC == 6) THEN
            IF (IHPDP == 1 .AND. IWDO == 1) THEN
              IDUM1 = 0
              IDUM2 = 0
              IDUM3 = 0
              IDUM4 = 7
              BUF(1:1) = CHAR (0)
              CALL GGIP08 (IDUM1, IDUM2, IDUM3, IDUM4)
            END IF
C * CALL FACTOR
          ELSE IF (IFUNC == 7) THEN
            FACTR = YVAL
C * INTERRUPT
          ELSE IF (IFUNC == 9) THEN
            IF (NAMP >= 0) THEN
              IF (IHPDP == 1 .AND. IWDO == 1) THEN
                IDUM3 = 0
                CALL GGIP08 (IX, IY, IDUM3, IFUNC)
                IVENT = IFUNC
              ELSE
                IVENT = -1
              END IF
            ELSE
              IVENT = 0
            END IF
            IFUNCTION = IVENT
          ELSE
C * PLOT FUNCTION 2,3: INSTRUCTION A LA CALCOMP : CALL PLOT(X, Y, I)
            IF (IFUNC == -3) THEN
              IDUM3 = 3
              CALL GGIP04 (XVAL, YVAL, IDUM3)
            END IF
            CALL GGIP04 (XVAL, YVAL, IFUNC)
          END IF
        END IF
      END IF
      RETURN
99999 FORMAT (/, 'Current Graphics Settings: DISPLAY  = ',
     1        A, '; DISPLAY  TYPE = ', A)
99998 FORMAT ('===(See HELP GRAPHICS)===: METAFILE = ',
     1        A, '; METAFILE TYPE = ', A, /)
99997 FORMAT (/,
     1 'The graphics drivers provide for 2 types of graphics output:'/
     2 '  DISPLAY  - Interactive graphics output on the Display'/
     3 '  METAFILE - A disk-file with graphics instructions.'//
     4 'The (ON/OFF) status of a graphics medium is managed with',
     5 ' instructions of the', /, 'type: SET DISPLAY ON ',
     6 'and SET META ON  etc.', //, 'The kind of code',
     7 ' that is generated for the various media may be:')
99996 FORMAT (/, ':: Meta-Plotfile  on File ', A, '.', A, /,
     1           26X, I6, ' Vector(s),', I6, ' Plot(s)')
99995 FORMAT (/, ':: Window Size (Re)Set to : ', F4.2, /)
99994 FORMAT (/, 'Type to change the current Display code :',
     1 ' e.g. SET DISPLAY X11,', /,
     2 'Similarly the current Metafile code may be set.', /)
99993 FORMAT ('  METAFILE : ',  7(A, ', '), /, 12X, 7(A, ', '))
99992 FORMAT ('  DISPLAY  : ',  7(A, ', '), /, 12X, 7(A, ', '))
99991 FORMAT (':: UNKNOWN MEDIUM REQUEST (IGNORED)! :', I3, A)
      END SUBROUTINE GGIP
      SUBROUTINE GGIP01 (X, Y, Z)
C * 'BEGPLT' FUNCTION
      USE files
      USE cggip
      USE cggt
      IMPLICIT NONE
      INTEGER           :: IDUM1
      INTEGER           :: IDUM2
      INTEGER           :: IDUM3
      INTEGER           :: IDUM4
      INTEGER           :: IMENU
      REAL              :: X
      REAL              :: Y
      REAL              :: Z
      CHARACTER(len=1)  :: CMETA
      CHARACTER(len=80) :: FNLUMETA
      BUF = BCD
C * INTERRUPT SETUP
      CC = .FALSE.
      CALL SETUPCC
C * ESTABLISH WHETHER META-FILE SHOULD BE (STILL) ON
      IF (TERMINAL > 0 .AND. METAFILE > 0) THEN
        IF (METAPL == 0 .AND. IHPDP == 2) THEN
          WRITE (LU6, 99997, ADVANCE = 'NO')
          READ  (LU5, 99996) CMETA
          IF (CMETA == 'N' .OR. CMETA == 'n') METAFILE = -1
          IF (CMETA == 'A' .OR. CMETA == 'a') METAPL   = -1
        END IF
      END IF
      IF (METAPL == 1) METAPL = 0
      XMAX = ABS (X)
      YMAX = ABS (Y)
      ZFRC = ABS (Z)
      IF (YMAX < 0.01) YMAX = XMAX
      IF (ZFRC < 0.01) ZFRC = 1.0
      NAMP = 1
      CALL GEN038 (IGGT, 1, 80)
      IPCL = 0
      IPSW = 0
C * DISPLAY FUNCTIONS
      IF (TERMINAL > 0) THEN
C * MAKE SHURE THAT THE CORRECT GRAPHICS CODE IS GENERATED
   10   IHPDP = TERM
C * INITIALISE TERMINAL OUTPUT BUFFER
        IPCLN = IPCLD
        IPSN  = IPSD
C * X11 - XLIB GRAPHICS
        IF (IHPDP == 1) THEN
          IF (IWDO == 0) THEN
C * HANDLE REVERSE B&W
            IDUM1 = 0
            IDUM2 = 0
            CALL GGIP08 (IDUM1, IDUM2, IBAW, 12)
C * SET WINDOW SCALE
            IXM = ISW
            IYM = 1000
            IMENU = IXVERS
C * IXM, IYM, IMENU RETURNED FROM XWIN
            CALL GGIP08 (IXM, IYM, IMENU, 1)
C * RESET TO ALTERNATIVE GRAPHICS DEFAULT WHEN NOT ON XWINDOW TERMINAL
            IF (IXM < 0 .AND. IPDS > 1) THEN
              TERM = 2
              DCODE = DSCOD(TERM)
              GO TO 10
            ELSE
              IWDO = 1
            END IF
C * GET DISPLAY CHARACTERISTICS
            CALL GGIP08 (IDMX, IDMY, IDMZ, 11)
          END IF
          IDUM1 = 0
          IDUM2 = 0
          IDUM3 = 0
          IDUM4 = 6
          CALL GGIP08 (IDUM1, IDUM2, IDUM3, IDUM4)
        END IF
        SCF = (IYM + 1) * ZFRC / YMAX
      END IF
C * META-FILE HPGL-CODE/ POSTSCRIPT ETC
      IF (METAFILE > 0) THEN
        IF (NVEC < 0) THEN
          FNLUMETA = METAF(1:KNM)//'.'//PLEXT(META)
          OPEN (UNIT = LU98, FILE = FNLUMETA, STATUS = 'UNKNOWN')
          NVEC = 0
        END IF
        NPLOT = NPLOT + 1
C * POSTSCRIPT
        IF (META == 1) THEN
          NRPS = NRPS + 1
          IF (NRPS == 1) THEN
            WRITE (LU98, 99999) DATIJD
          ELSE
            WRITE (LU98, 99995) NRPS, NRPS
          END IF
          WRITE (LU98, 99994) IPSH, IPSV, IPSR
          JXO    = 7333
          JYO    = 5500
          JTEL   = 0
          KTEL   = -1
          KXE(7) = 0
          KYE(7) = 0
          KME(7) = 'm'
C * HPGL
        ELSE IF (META == 2) THEN
          IF (ISVPLT == 0) THEN
            ISVPLT = 1
          ELSE
            WRITE (LU98, 99993)
          END IF
          WRITE (LU98, 99998) IPCL
          JXO = 10000
          JYO = 7200
        END IF
      END IF
      IF (METAFILE > 0) THEN
C * SCF FOR META FILE
        SCFJ = MIN (JYO * ZFRC /YMAX, JXO * ZFRC /XMAX)
      END IF
C * SET RELATIVE ORIGIN TO ZERO
      XREF = 0.0
      YREF = 0.0
      RETURN
99999 FORMAT ('%!PS-Adobe-1.0', /,
     1        '%%Creator GGIP - A.L.Spek - ', A, /,
     2        '%%BoundingBox: 0 0 612 792', /,
     3        '%%EndComments', /,
     5        '/m {moveto} def /l {lineto} def /c {setrgbcolor} def ',
     6        '/p {showpage} def', /,
     7        '/w {setlinewidth} def /s {stroke} def /n {newpath} def',
     8        ' /r {rlineto} def', /,
     4        '%%Page: 1 1')
99998 FORMAT ('IN;SP', I5,';')
99997 FORMAT ('Should META-file remain opened for this plot?',
     1 '(A/Y/N[Y])')
99996 FORMAT (A)
99995 FORMAT ('%%Page:', 2I5)
99994 FORMAT (' 0.1 0.1 scale n 1 setlinecap',
     1         2I5, ' translate ', I4, ' rotate')
99993 FORMAT ('AF;')
      END SUBROUTINE GGIP01
 
      SUBROUTINE GGIP02 (Z)
C * ENDPLT FUNCTION
      USE files
      USE cggip
      USE cggt
      IMPLICIT NONE
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IZ
      INTEGER :: IWIN
      REAL    :: Z
      IF (NAMP > 0) THEN
        CALL GGIP05
        IF (TERMINAL > 0) THEN
C * ROUTINE TO SIMULATE CALL ENDPLT
C * LIFT PEN AND MOVE TO ORIGIN
C * X11
          IF (IHPDP == 1) THEN
C * FLUSH X-BUFFER
            IX   = 0
            IY   = 0
            IZ   = 0
            IWIN = 8
            CALL GGIP08 (IX, IY, IZ, IWIN)
            IWIN = 7
            CALL GGIP08 (IX, IY, IZ, IWIN)
          END IF
C * PREEMPT ASCII CHARACTER BUFFER
          IPCL = 0
        END IF
      END IF
      IF (TERMINAL > 0 .AND. NAMP >= 0) THEN
        IF (NAMP == 1 .AND. NINT (Z) == 0) THEN
          IF (IHPDP /= 1) THEN
            READ (LU5, 99999, IOSTAT = IOST) IGGT
          END IF
        ELSE IF (NAMP == 1 .AND. NINT (Z) > 0) THEN
          WRITE (LU6, 99998)
        END IF
      END IF
      IF (NAMP == 1) NAMP = 0
      RETURN
99999 FORMAT (A)
99998 FORMAT (/, ':: PLOTTING INTERRUPTED!!', /)
      END SUBROUTINE GGIP02
 
      SUBROUTINE GGIP03
C * ROUTINE TO SIMULATE CALL NEWPEN(I)
      USE files
      USE cggip
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IPSY
      INTEGER :: IDUM2
      INTEGER :: IDUM3
      INTEGER :: IDUM4
      INTEGER :: IPCLX
      IF (IPCLN /= IPCL) THEN
        IPCL = IPCLN
C * DISPLAY
        IF (TERMINAL > 0) THEN
C * X-WINDOWS
          IF (IHPDP == 1) THEN
            IDUM2 = 0
            IDUM3 = 0
            IDUM4 = 99
            CALL GGIP08 (IPCL, IDUM2, IDUM3, IDUM4)
          END IF
        END IF
C * META - FILE
        IF (METAFILE > 0) THEN
C * POSTSCRIPT (META = 1)
          IF (META == 1) THEN
            IF (KTEL > 0) THEN
C * CLEAR BUFFER
              WRITE (LU98, 99997)
     1            (KXE(I), KYE(I), KME(I), I = 1, KTEL)
C * SAVE LAST POSITION
              KXE(7) = KXE(KTEL)
              KYE(7) = KYE(KTEL)
              KME(7) = 'm'
            ENDIF
            IF (KTEL > -1) THEN
              KXE(1) = KXE(7)
              KYE(1) = KYE(7)
              KME(1) = KME(7)
              KTEL   = 1
            ENDIF
            JTEL = KTEL
            WRITE (LU98, 99996) IPSM
C * PEN COLOUR
            IF (IPCL < 17) THEN
              WRITE (LU98, 99999) KLEUR(IPCL + 1)
            ELSE
              WRITE (LU98, 99999) KLEUR(2)
            END IF
C * HPGL (META = 2)
          ELSE IF (META == 2) THEN
            IPCLX = IPCL
            WRITE (LU98, 99998) IPCLX
          END IF
        END IF
      END IF
      IF (IPSN /= IPSW) THEN
C * DISPLAY
        IF (TERMINAL > 0) THEN
C * X-WINDOWS
          IF (IHPDP == 1) THEN
            IPSY = MAX (IPSN, IPSX)
            IDUM2 = 0
            IDUM3 = 0
            IDUM4 = 10
            CALL GGIP08 (IPSY, IDUM2, IDUM3, IDUM4)
          END IF
        END IF
C * META - FILE
        IF (METAFILE > 0) THEN
C * POSTSCRIPT (META = 1)
          IF (META == 1) THEN
            IF (KTEL > 0)  THEN
              WRITE (LU98, 99997)
     1          (KXE(I), KYE(I), KME(I), I = 1, KTEL)
              KXE(7) = KXE(KTEL)
              KYE(7) = KYE(KTEL)
              KME(7) = 'm'
            END IF
            IF (KTEL > -1) THEN
              KXE(1) = KXE(7)
              KYE(1) = KYE(7)
              KME(1) = KME(7)
              KTEL   = 1
            END IF
            JTEL   = KTEL
            WRITE (LU98, 99996) IPSM
          END IF
        END IF
        IPSW = IPSN
      END IF
99999 FORMAT (A)
99998 FORMAT ('PU;SP',I5,';')
99997 FORMAT (6(2I5, 1X, A1))
99996 FORMAT (I3, ' w s n ')
      RETURN
      END SUBROUTINE GGIP03
 
      SUBROUTINE GGIP04 (XP, YP, IPUD)
C * ROUTINE IMPLEMENTS 'CALL PLOT' FOR X11, POSTSCRIPT AND HP-GL
      USE files
      USE cggip
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IP
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: JXE
      INTEGER :: JYE
      INTEGER :: IPUD
      INTEGER :: IPEN
      INTEGER :: IDUM3
      REAL    :: X
      REAL    :: Y
      REAL    :: XN
      REAL    :: YN
      REAL    :: XP
      REAL    :: YP
      IP = IPUD
      XN = XREF + XP * FACTR
      YN = YREF + YP * FACTR
      IF (IP < 0) THEN
C * REQUEST FOR NEW REFERENCE POINT
        IP   = -IP
        XREF =  XN
        YREF =  YN
      ELSE IF (IP == 3) THEN
C * KEEP TRACK OF LAST PEN-UP
        NPUD = 0
      ELSE IF (IP == 2) THEN
C * PHYSICAL PLOTTING
   10   IF (NPUD == 0) THEN
          X    = XOLD
          Y    = YOLD
          IPEN = 3
        ELSE
          X    = XN
          Y    = YN
          IPEN = 2
        END IF
C * NEWPEN: CHECK COLOUR/LINEWIDTH CHANGE
        CALL GGIP03
C * TEST FOR DISPLAY/PLOTTER ON
        IF (TERMINAL > 0) THEN
          IX = NINT (X * SCF)
          IY = NINT (Y * SCF)
          IF (IX < 0) IX = 0
          IF (IY < 0) IY = 0
          IF (IX > IXM) IX = IXM
          IF (IY > IYM) IY = IYM
C * X11 TERMINAL
          IF (IHPDP == 1) THEN
            IDUM3 = 0
            CALL GGIP08 (IX, IY, IDUM3, IPEN)
          END IF
        END IF
C * TEST FOR META-FILE ON
        IF (METAFILE > 0) THEN
          IF (NVEC == -1) THEN
            WRITE (6, 99999)
            METAFILE = 0
          END IF
          NVEC = NVEC + 1
          JXE  = NINT (X * SCFJ)
          JYE  = NINT (Y * SCFJ)
          IF (JXE < 0) JXE = 0
          IF (JYE < 0) JYE = 0
          IF (JXE > JXO) JXE = JXO
          IF (JYE > JYO) JYE = JYO
C * POSTSCRIPT ENCODING
          IF (META == 1) THEN
            IF (KTEL == -1) KTEL = 0
            KTEL = KTEL + 1
            JTEL = JTEL + 1
C * ADD ORIGIN OFFSETS
            KXE(KTEL) = (JYO - JYE) + 200
            KYE(KTEL) = JXE         + 200
            KME(KTEL) = CHAR (106 + IPEN)
            IF (KTEL == 6) THEN
              WRITE (LU98, 99995) (KXE(I), KYE(I), KME(I), I = 1, 6)
              KXE(7) = KXE(6)
              KYE(7) = KYE(6)
              KME(7) = 'm'
              KTEL   = 0
              IF (JTEL >= 150) THEN
                WRITE (LU98, 99998) IPSM
                KXE(1) = KXE(7)
                KYE(1) = KYE(7)
                KME(1) = KME(7)
                JTEL   = 1
                KTEL   = 1
              END IF
            END IF
C * HPGL ENCODING
          ELSE IF (META == 2) THEN
            IF (IPEN == 3) THEN
              WRITE (LU98, 99997) JXE, JYE
            ELSE IF (IPEN == 2) THEN
              WRITE (LU98, 99996) JXE, JYE
            END IF
          END IF
        END IF
        IF (NPUD == 0) THEN
          NPUD = 1
          GO TO 10
        END IF
      END IF
C * KEEP TRACK OF LAST COORDINATES
      XOLD = XN
      YOLD = YN
      RETURN
99999 FORMAT ('>> LU98-NOT OPEN YET !!')
99998 FORMAT (I3, ' w s n')
99997 FORMAT ('PU;PA',I5,',',I5,';')
99996 FORMAT ('PD;PA',I5,',',I5,';')
99995 FORMAT (6(2I5, 1X, A1))
      END SUBROUTINE GGIP04
      SUBROUTINE GGIP05
C * PostScript CODE
      USE files
      USE cggip
      IMPLICIT NONE
      LOGICAL :: LOPEN
      INTEGER :: I
      IF (NAMP > 0) THEN
        IF (METAFILE > 0) THEN
C * CLEAR BUFFER
          INQUIRE (UNIT = LU98, OPENED = LOPEN)
          IF (LOPEN) THEN
            CALL GGIP04 (0.0, 0.0, 3)
            IF (META == 1) THEN
C * CLEAR BUFFER
              IF (KTEL >= 0) THEN
                IF (KTEL > 0) WRITE (LU98, 99992)
     1            (KXE(I), KYE(I), KME(I), I = 1, KTEL)
C * SHOW PAGE
                WRITE (LU98, 99993) IPSM
                KTEL = -1
              END IF
C * HPGL
            ELSE IF (META == 2) THEN
              WRITE (LU98, 99996)
            END IF
          END IF
        END IF
      END IF
      RETURN
99996 FORMAT ('PU;SP    0;'/'AF;')
99993 FORMAT (I3,' w s p')
99992 FORMAT (6(2I5,1X,A1))
      END SUBROUTINE GGIP05
 
      SUBROUTINE GGIP06 (IMODE, IY, IZ)
C * SUBROUTINE PERFORMES GENERAL OPEN/CLOSE PROCEDURES ON PROGRAM BEGIN/END
      USE files
      USE cggip
      USE cggt
      IMPLICIT NONE
      INTEGER :: IY
      INTEGER :: IZ
      INTEGER :: IDUM1 = 0
      INTEGER :: IDUM2 = 0
      INTEGER :: IDUM3 = 0
      INTEGER :: IDUM4 = 0
      INTEGER :: IMODE
      ISTAT = IMODE
C * GENERAL WINDOW OPEN PREAMBLE
      IF (ISTAT > 0) THEN
        TERM = 1
        IF (IY > 0) THEN
          NVEC = 0
          LU98 = IY
C * STORE META FILE NAME
        ELSE IF (IY < 0) THEN
          KNM = - IY
          METAF = IGGT(2:KNM + 1)//' '
C * DEFAULT META FILE NAME
        ELSE
          METAF = 'PLOT'
          KNM   = 4
        END IF
        IF (IZ > 0) THEN
        END IF
        IF (TERM < 99)  DCODE = DSCOD(TERM)
        MCODE = MECOD(META)
C * GENERAL WINDOW CLOSE AND REPORT
      ELSE
        IF (IHPDP * IWDO == 1) CALL GGIP08 (IDUM1, IDUM2, IDUM3, IDUM4)
        INQUIRE (LU98, EXIST = EXST)
        IF (NVEC <= 0) THEN
          IF (EXST) CLOSE (UNIT = LU98, STATUS = 'DELETE')
        ELSE
          IF (META == 1) WRITE (LU98, 99999) NRPS
C * REPORT GRAPHICS STATUS ON CLOSING
          WRITE (LU6, 99998) METAF(1:KNM), PLEXT(META), NPLOT, NVEC
          IF (EXST) CLOSE (UNIT = LU98)
        END IF
      END IF
      RETURN
99999 FORMAT ('%%Pages:', I5, /, '%%EOF')
99998 FORMAT (/, ':: Meta-plotfile on File ', A, '.', A, /,
     1        ':: # Plot(s) =', I5, ', # Vector(s) =', I8, /)
      END SUBROUTINE GGIP06
 
      SUBROUTINE GGIP07 (X, Y)
C * STRING PLOT
      USE cggip
      USE cggt
      IMPLICIT NONE
      INTEGER :: I
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IC
      INTEGER :: IS
      INTEGER :: IW
      INTEGER :: NR
      INTEGER :: IYS
      INTEGER :: IWR
      INTEGER :: ICH
      INTEGER :: JCH
      INTEGER :: IWRD
      INTEGER :: IDEEL
      REAL    :: X
      REAL    :: Y
      REAL    :: H
      REAL    :: XA
      REAL    :: YA
      REAL    :: X0
      REAL    :: Y0
      REAL    :: W1
      REAL    :: W2
      REAL    :: SINT
      REAL    :: COST
      REAL    :: GRID
      REAL    :: THETA
C * NEW STARTPOINT CHARACTER S
      X0    = X
      Y0    = Y
      THETA = THET * 0.017453294
      COST  = COS (THETA)
      SINT  = SIN (THETA)
C * INITIALISE
      IC   = 3
      IW   = 1
      GRID = 7
      H    = CHT / GRID
C * UNIT IN GRID
      XA  = COST * H
      YA  = SINT * H
   10 IYS = 0
C * FROM CHARACTERS SPACE TO z (32 to 122)
      ICH = 0
      I   = ICHAR (BCD(IW:IW)) - 31
      IF (I > 0 .AND. I < 92) THEN
        JCH = ADR(I)
        ICH = JCH / 100
        NR  = MOD (JCH, 100)
      END IF
      DO
        IF (ICH == 0) THEN
C * NEXT CHARACTER
          IC = 3
          X0 = X0 + XA * 6.0
          Y0 = Y0 + YA * 6.0
          IW = IW + 1
          IF (IW > NCHE) RETURN
          GO TO 10
        ELSE
   20     IWR   = TAB(ICH)
          ICH   = ICH + 1
C * 16777216 = 2^24
          IDEEL = 16777216
          IS    = 6
          DO
            IS    = IS - 1
            IF (IS == 0) GO TO 20
            IWRD  = IWR / IDEEL
            IWR   = MOD (IWR, IDEEL)
            IDEEL = IDEEL / 64
            IX    = IWRD / 8
            IY    = MOD (IWRD, 8)
            IF (IX == 7) THEN
              IYS = IY
C * NEXT MOVE WITH PEN UP
              IC = 3
            ELSE
              W1 = X0 + IX * XA - (IY - IYS) * YA
              W2 = Y0 + IX * YA + (IY - IYS) * XA
              CALL GGIP04 (W1, W2, IC)
              IC = 2
            END IF
            NR = NR - 1
            IF (NR == 0) EXIT
          END DO
        END IF
        ICH = 0
      END DO
      RETURN
      END SUBROUTINE GGIP07
 
      SUBROUTINE GGIP08 (IX, IY, IZ, IP)
C * FORTRAN/C - INTERFACE
      USE cggip
      IMPLICIT NONE
      INTEGER :: IX
      INTEGER :: IY
      INTEGER :: IZ
      INTEGER :: IP
C STRIP_END
      RETURN
      END SUBROUTINE GGIP08
 
 
      SUBROUTINE CTRLCT
      USE cggt
      IMPLICIT NONE
      CC = .TRUE.
      RETURN
      END
 
      SUBROUTINE SETUPCC
      EXTERNAL CTRLCT
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
C STRIP_END
